In PL/Tcl, make database errors return additional info in the errorCode.

Tcl has a convention for returning additional info about an error in a
global variable named errorCode.  Up to now PL/Tcl has ignored that,
but this patch causes database errors caught by PL/Tcl to fill in
errorCode with useful information from the ErrorData struct.

Jim Nasby, reviewed by Pavel Stehule and myself

4 files changed, 272 insertions, 5 deletions

diff --git a/doc/src/sgml/pltcl.sgml b/doc/src/sgml/pltcl.sgml
index d2175d552eb..1ff9b96fa52 100644
--- a/doc/src/sgml/pltcl.sgml
+++ b/doc/src/sgml/pltcl.sgml
@@ -507,8 +507,9 @@ SELECT 'doesn''t' AS ret
         written to the server log, or both is controlled by the
         <xref linkend="guc-log-min-messages"> and
         <xref linkend="guc-client-min-messages"> configuration
-        variables. See <xref linkend="runtime-config"> for more
-        information.
+        variables. See <xref linkend="runtime-config">
+        and <xref linkend="pltcl-error-handling">
+        for more information.
        </para>
       </listitem>
      </varlistentry>
@@ -775,6 +776,75 @@ CREATE EVENT TRIGGER tcl_a_snitch ON ddl_command_start EXECUTE PROCEDURE tclsnit
     </para>
    </sect1>
 
+   <sect1 id="pltcl-error-handling">
+    <title>Error Handling in PL/Tcl</title>
+
+    <indexterm>
+     <primary>exceptions</primary>
+     <secondary>in PL/Tcl</secondary>
+    </indexterm>
+
+    <para>
+     Tcl code within or called from a PL/Tcl function can raise an error,
+     either by executing some invalid operation or by generating an error
+     using the Tcl <function>error</function> command or
+     PL/Tcl's <function>elog</function> command.  Such errors can be caught
+     within Tcl using the Tcl <function>catch</function> command.  If they
+     are not caught but are allowed to propagate out to the top level of
+     execution of the PL/Tcl function, they turn into database errors.
+    </para>
+
+    <para>
+     Conversely, database errors that occur within PL/Tcl's
+     <function>spi_exec</function>, <function>spi_prepare</function>,
+     and <function>spi_execp</function> commands are reported as Tcl errors,
+     so they are catchable by Tcl's <function>catch</function> command.
+     Again, if they propagate out to the top level without being caught,
+     they turn back into database errors.
+    </para>
+
+    <para>
+     Tcl provides an <varname>errorCode</varname> variable that can represent
+     additional information about an error in a form that is easy for Tcl
+     programs to interpret.  The contents are in Tcl list format, and the
+     first word identifies the subsystem or library reporting the error;
+     beyond that the contents are left to the individual subsystem or
+     library.  For database errors reported by PL/Tcl commands, the first
+     word is <literal>POSTGRES</literal>, the second word is the Postgres
+     version number, and additional words are field name/value pairs
+     providing detailed information about the error.
+     Fields <varname>message</> and <varname>SQLSTATE</> (the error code
+     shown in <xref linkend="errcodes-appendix">) are always supplied.
+     Fields that may be present include
+     <varname>detail</>, <varname>hint</>, <varname>context</>,
+     <varname>schema</>, <varname>table</>, <varname>column</>,
+     <varname>datatype</>, <varname>constraint</>,
+     <varname>statement</>, <varname>cursor_position</>,
+     <varname>filename</>, <varname>lineno</> and
+     <varname>funcname</>.
+    </para>
+
+    <para>
+     A convenient way to work with PL/Tcl's <varname>errorCode</varname>
+     information is to load it into an array, so that the field names become
+     array subscripts.  Code for doing that might look like
+<programlisting>
+if {[catch { spi_exec $sql_command }]} {
+    if {[lindex $::errorCode 0] == "POSTGRES"} {
+        array set errorArray $::errorCode
+        if {$errorArray(SQLSTATE) == "42P01"} {  # UNDEFINED_TABLE
+            # deal with missing table
+        } else {
+            # deal with some other type of SQL error
+        }
+    }
+}
+</programlisting>
+     (The double colons explicitly specify that <varname>errorCode</varname>
+     is a global variable.)
+    </para>
+   </sect1>
+
    <sect1 id="pltcl-unknown">
        <title>Modules and the <function>unknown</> Command</title>
        <para>
diff --git a/src/pl/tcl/expected/pltcl_setup.out b/src/pl/tcl/expected/pltcl_setup.out
index e11718c64b3..807a6a3a94f 100644
--- a/src/pl/tcl/expected/pltcl_setup.out
+++ b/src/pl/tcl/expected/pltcl_setup.out
@@ -555,3 +555,31 @@ NOTICE:  tclsnitch: ddl_command_start DROP TABLE
 NOTICE:  tclsnitch: ddl_command_end DROP TABLE
 drop event trigger tcl_a_snitch;
 drop event trigger tcl_b_snitch;
+-- test use of errorCode in error handling
+create function tcl_error_handling_test() returns text as $$
+    global errorCode
+    if {[catch { spi_exec "select no_such_column from foo;" }]} {
+        array set errArray $errorCode
+        if {$errArray(SQLSTATE) == "42P01"} {
+            return "expected error: $errArray(message)"
+        } else {
+            return "unexpected error: $errArray(SQLSTATE) $errArray(message)"
+        }
+    } else {
+        return "no error"
+    }
+$$ language pltcl;
+select tcl_error_handling_test();
+            tcl_error_handling_test            
+-----------------------------------------------
+ expected error: relation "foo" does not exist
+(1 row)
+
+create temp table foo(f1 int);
+select tcl_error_handling_test();
+                    tcl_error_handling_test                     
+----------------------------------------------------------------
+ unexpected error: 42703 column "no_such_column" does not exist
+(1 row)
+
+drop table foo;
diff --git a/src/pl/tcl/pltcl.c b/src/pl/tcl/pltcl.c
index 5b27c731b6e..b1d66e31a6e 100644
--- a/src/pl/tcl/pltcl.c
+++ b/src/pl/tcl/pltcl.c
@@ -212,6 +212,7 @@ static pltcl_proc_desc *compile_pltcl_function(Oid fn_oid, Oid tgreloid,
 
 static int pltcl_elog(ClientData cdata, Tcl_Interp *interp,
 		   int objc, Tcl_Obj *const objv[]);
+static void pltcl_construct_errorCode(Tcl_Interp *interp, ErrorData *edata);
 static int pltcl_quote(ClientData cdata, Tcl_Interp *interp,
 			int objc, Tcl_Obj *const objv[]);
 static int pltcl_argisnull(ClientData cdata, Tcl_Interp *interp,
@@ -1648,7 +1649,8 @@ pltcl_elog(ClientData cdata, Tcl_Interp *interp,
 		edata = CopyErrorData();
 		FlushErrorState();
 
-		/* Pass the error message to Tcl */
+		/* Pass the error data to Tcl */
+		pltcl_construct_errorCode(interp, edata);
 		UTF_BEGIN;
 		Tcl_SetObjResult(interp, Tcl_NewStringObj(UTF_E2U(edata->message), -1));
 		UTF_END;
@@ -1663,6 +1665,148 @@ pltcl_elog(ClientData cdata, Tcl_Interp *interp,
 
 
 /**********************************************************************
+ * pltcl_construct_errorCode()		- construct a Tcl errorCode
+ *		list with detailed information from the PostgreSQL server
+ **********************************************************************/
+static void
+pltcl_construct_errorCode(Tcl_Interp *interp, ErrorData *edata)
+{
+	Tcl_Obj    *obj = Tcl_NewObj();
+
+	Tcl_ListObjAppendElement(interp, obj,
+							 Tcl_NewStringObj("POSTGRES", -1));
+	Tcl_ListObjAppendElement(interp, obj,
+							 Tcl_NewStringObj(PG_VERSION, -1));
+	Tcl_ListObjAppendElement(interp, obj,
+							 Tcl_NewStringObj("SQLSTATE", -1));
+	Tcl_ListObjAppendElement(interp, obj,
+				  Tcl_NewStringObj(unpack_sql_state(edata->sqlerrcode), -1));
+	Tcl_ListObjAppendElement(interp, obj,
+							 Tcl_NewStringObj("message", -1));
+	UTF_BEGIN;
+	Tcl_ListObjAppendElement(interp, obj,
+							 Tcl_NewStringObj(UTF_E2U(edata->message), -1));
+	UTF_END;
+	if (edata->detail)
+	{
+		Tcl_ListObjAppendElement(interp, obj,
+								 Tcl_NewStringObj("detail", -1));
+		UTF_BEGIN;
+		Tcl_ListObjAppendElement(interp, obj,
+							   Tcl_NewStringObj(UTF_E2U(edata->detail), -1));
+		UTF_END;
+	}
+	if (edata->hint)
+	{
+		Tcl_ListObjAppendElement(interp, obj,
+								 Tcl_NewStringObj("hint", -1));
+		UTF_BEGIN;
+		Tcl_ListObjAppendElement(interp, obj,
+								 Tcl_NewStringObj(UTF_E2U(edata->hint), -1));
+		UTF_END;
+	}
+	if (edata->context)
+	{
+		Tcl_ListObjAppendElement(interp, obj,
+								 Tcl_NewStringObj("context", -1));
+		UTF_BEGIN;
+		Tcl_ListObjAppendElement(interp, obj,
+							  Tcl_NewStringObj(UTF_E2U(edata->context), -1));
+		UTF_END;
+	}
+	if (edata->schema_name)
+	{
+		Tcl_ListObjAppendElement(interp, obj,
+								 Tcl_NewStringObj("schema", -1));
+		UTF_BEGIN;
+		Tcl_ListObjAppendElement(interp, obj,
+						  Tcl_NewStringObj(UTF_E2U(edata->schema_name), -1));
+		UTF_END;
+	}
+	if (edata->table_name)
+	{
+		Tcl_ListObjAppendElement(interp, obj,
+								 Tcl_NewStringObj("table", -1));
+		UTF_BEGIN;
+		Tcl_ListObjAppendElement(interp, obj,
+						   Tcl_NewStringObj(UTF_E2U(edata->table_name), -1));
+		UTF_END;
+	}
+	if (edata->column_name)
+	{
+		Tcl_ListObjAppendElement(interp, obj,
+								 Tcl_NewStringObj("column", -1));
+		UTF_BEGIN;
+		Tcl_ListObjAppendElement(interp, obj,
+						  Tcl_NewStringObj(UTF_E2U(edata->column_name), -1));
+		UTF_END;
+	}
+	if (edata->datatype_name)
+	{
+		Tcl_ListObjAppendElement(interp, obj,
+								 Tcl_NewStringObj("datatype", -1));
+		UTF_BEGIN;
+		Tcl_ListObjAppendElement(interp, obj,
+						Tcl_NewStringObj(UTF_E2U(edata->datatype_name), -1));
+		UTF_END;
+	}
+	if (edata->constraint_name)
+	{
+		Tcl_ListObjAppendElement(interp, obj,
+								 Tcl_NewStringObj("constraint", -1));
+		UTF_BEGIN;
+		Tcl_ListObjAppendElement(interp, obj,
+					  Tcl_NewStringObj(UTF_E2U(edata->constraint_name), -1));
+		UTF_END;
+	}
+	/* cursorpos is never interesting here; report internal query/pos */
+	if (edata->internalquery)
+	{
+		Tcl_ListObjAppendElement(interp, obj,
+								 Tcl_NewStringObj("statement", -1));
+		UTF_BEGIN;
+		Tcl_ListObjAppendElement(interp, obj,
+						Tcl_NewStringObj(UTF_E2U(edata->internalquery), -1));
+		UTF_END;
+	}
+	if (edata->internalpos > 0)
+	{
+		Tcl_ListObjAppendElement(interp, obj,
+								 Tcl_NewStringObj("cursor_position", -1));
+		Tcl_ListObjAppendElement(interp, obj,
+								 Tcl_NewIntObj(edata->internalpos));
+	}
+	if (edata->filename)
+	{
+		Tcl_ListObjAppendElement(interp, obj,
+								 Tcl_NewStringObj("filename", -1));
+		UTF_BEGIN;
+		Tcl_ListObjAppendElement(interp, obj,
+							 Tcl_NewStringObj(UTF_E2U(edata->filename), -1));
+		UTF_END;
+	}
+	if (edata->lineno > 0)
+	{
+		Tcl_ListObjAppendElement(interp, obj,
+								 Tcl_NewStringObj("lineno", -1));
+		Tcl_ListObjAppendElement(interp, obj,
+								 Tcl_NewIntObj(edata->lineno));
+	}
+	if (edata->funcname)
+	{
+		Tcl_ListObjAppendElement(interp, obj,
+								 Tcl_NewStringObj("funcname", -1));
+		UTF_BEGIN;
+		Tcl_ListObjAppendElement(interp, obj,
+							 Tcl_NewStringObj(UTF_E2U(edata->funcname), -1));
+		UTF_END;
+	}
+
+	Tcl_SetObjErrorCode(interp, obj);
+}
+
+
+/**********************************************************************
  * pltcl_quote()	- quote literal strings that are to
  *			  be used in SPI_execute query strings
  **********************************************************************/
@@ -1880,9 +2024,10 @@ pltcl_subtrans_abort(Tcl_Interp *interp,
 	 */
 	SPI_restore_connection();
 
-	/* Pass the error message to Tcl */
+	/* Pass the error data to Tcl */
+	pltcl_construct_errorCode(interp, edata);
 	UTF_BEGIN;
-	Tcl_SetResult(interp, UTF_E2U(edata->message), TCL_VOLATILE);
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(UTF_E2U(edata->message), -1));
 	UTF_END;
 	FreeErrorData(edata);
 }
diff --git a/src/pl/tcl/sql/pltcl_setup.sql b/src/pl/tcl/sql/pltcl_setup.sql
index 53358ea361f..36d9ef8539e 100644
--- a/src/pl/tcl/sql/pltcl_setup.sql
+++ b/src/pl/tcl/sql/pltcl_setup.sql
@@ -595,3 +595,27 @@ drop table foo;
 
 drop event trigger tcl_a_snitch;
 drop event trigger tcl_b_snitch;
+
+-- test use of errorCode in error handling
+
+create function tcl_error_handling_test() returns text as $$
+    global errorCode
+    if {[catch { spi_exec "select no_such_column from foo;" }]} {
+        array set errArray $errorCode
+        if {$errArray(SQLSTATE) == "42P01"} {
+            return "expected error: $errArray(message)"
+        } else {
+            return "unexpected error: $errArray(SQLSTATE) $errArray(message)"
+        }
+    } else {
+        return "no error"
+    }
+$$ language pltcl;
+
+select tcl_error_handling_test();
+
+create temp table foo(f1 int);
+
+select tcl_error_handling_test();
+
+drop table foo;