diff --git a/doc/src/sgml/pltcl.sgml b/doc/src/sgml/pltcl.sgml
new file mode 100644
index d2175d5..1ac7804
*** a/doc/src/sgml/pltcl.sgml
--- b/doc/src/sgml/pltcl.sgml
*************** CREATE EVENT TRIGGER tcl_a_snitch ON ddl
*** 775,780 ****
--- 775,903 ----
+
+ Error Handling in PL/Tcl
+
+
+ error handling
+ in PL/Tcl
+
+
+
+ All Tcl errors that are allowed to propagate back to the top level of the
+ interpreter, that is, errors not caught within the stored procedure
+ using the Tcl catch command will raise a database
+ error.
+
+
+ Tcl code within or called from the stored procedure can choose to
+ raise a database error by invoking the elog
+ command provided by PL/Tcl or by generating an error using the Tcl
+ error command and not catching it with Tcl's
+ catch command.
+
+
+ Database errors that occur from the PL/Tcl stored procedure's
+ use of spi_exec, spi_prepare,
+ and spi_execp are also catchable by Tcl's
+ catch command.
+
+
+ Tcl provides an errorCode variable that can
+ represent additional information about the error in a form that
+ is easy for programs to interpret. The contents are in Tcl list
+ format and the first word identifies the subsystem or
+ library responsible for the error and beyond that the contents are left
+ to the individual code or library. For example if Tcl's
+ open command is asked to open a file that doesn't
+ exist, errorCode
+ might contain POSIX ENOENT {no such file or directory}
+ where the third element may vary by locale but the first and second
+ will not.
+
+
+ When spi_exec, spi_prepare
+ or spi_execp cause a database error to be raised,
+ that database eror propagates back to Tcl as a Tcl error.
+ In this case errorCode is set to a list
+ where the first element is POSTGRES followed by a
+ copious decoding of the Postgres error structure. Since fields in the
+ structure may or may not be present depending on the nature of the
+ error, how the function was invoked, etc, PL/Tcl has adopted the
+ convention that subsequent elements of the errorCode
+ list are key-value pairs where the first value is the name of the
+ field and the second is its value.
+
+
+ Fields that may be present include SQLSTATE,
+ message, detail,
+ detail_log, hint,
+ domain, context_domain,
+ context, schema,
+ table, column,
+ datatype, constraint,
+ cursor_position, internalquery,
+ internal_position, filename,
+ lineno and funcname.
+
+
+ You might find it useful to load the results into an array. Code
+ for doing that might look like
+
+ if {[lindex $errorCode 0] == "POSTGRES"} {
+ array set errorRow [lrange $errorCode 1 end]
+ }
+
+
+
+ In the example below we cause an error by attempting to
+ SELECT> from a table that doesn't exist.
+
+ select tcl_eval('spi_exec "select * from foo;"');
+
+
+
+ ERROR: relation "foo" does not exist
+
+
+
+
+ Now we examine the error code. (The double-colons explicitly
+ reference errorCode as a global variable.)
+
+ select tcl_eval('join $::errorCode "\n"');
+
+
+
+ tcl_eval
+ -------------------------------
+ POSTGRES +
+ SQLSTATE +
+ 42P01 +
+ message +
+ relation "foo" does not exist+
+ domain +
+ postgres-9.6 +
+ context_domain +
+ postgres-9.6 +
+ cursorpos +
+ 0 +
+ internalquery +
+ select * from foo; +
+ internalpos +
+ 15 +
+ filename +
+ parse_relation.c +
+ lineno +
+ 1159 +
+ funcname +
+ parserOpenTable
+ (1 row)
+
+
+
+
+
Modules and the unknown> Command
diff --git a/src/pl/tcl/expected/pltcl_setup.out b/src/pl/tcl/expected/pltcl_setup.out
new file mode 100644
index e11718c..0592c48
*** a/src/pl/tcl/expected/pltcl_setup.out
--- b/src/pl/tcl/expected/pltcl_setup.out
*************** NOTICE: tclsnitch: ddl_command_start DR
*** 555,557 ****
--- 555,605 ----
NOTICE: tclsnitch: ddl_command_end DROP TABLE
drop event trigger tcl_a_snitch;
drop event trigger tcl_b_snitch;
+ -- test error handling
+ /*
+ * The ugly hack of messsing with the verbosity is because the error context is
+ * set to the TCL variable errorInfo, which contains some unstable data (namely
+ * the full name of the TCL function created by the handler, which includes the
+ * Postgres backend PID).
+ */
+ \set VERBOSITY terse
+ CREATE OR REPLACE FUNCTION pg_temp.tcl_eval (varchar) RETURNS varchar AS $$
+ eval $1
+ $$ LANGUAGE pltcl;
+ select pg_temp.tcl_eval('spi_exec "select * from foo;"');
+ ERROR: relation "foo" does not exist
+ select pg_temp.tcl_eval($$
+ set list [lindex $::errorCode 0];
+ foreach "key value" [lrange $::errorCode 1 end] {
+ if {$key == "domain" || $key == "context_domain" || $key == "lineno"} {
+ regsub -all {[0-9]} $value "" value
+ }
+ lappend list $key $value
+ };
+ return [join $list "\n"]
+ $$);
+ tcl_eval
+ -------------------------------
+ POSTGRES +
+ SQLSTATE +
+ 42P01 +
+ message +
+ relation "foo" does not exist+
+ domain +
+ postgres-. +
+ context_domain +
+ postgres-. +
+ cursor_position +
+ 0 +
+ internalquery +
+ select * from foo; +
+ internal_position +
+ 15 +
+ filename +
+ parse_relation.c +
+ lineno +
+ +
+ funcname +
+ parserOpenTable
+ (1 row)
+
diff --git a/src/pl/tcl/pltcl.c b/src/pl/tcl/pltcl.c
new file mode 100644
index 5b27c73..d8a8a89
*** a/src/pl/tcl/pltcl.c
--- b/src/pl/tcl/pltcl.c
*************** compile_pltcl_function(Oid fn_oid, Oid t
*** 1576,1581 ****
--- 1576,1673 ----
return prodesc;
}
+ /**********************************************************************
+ * 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("SQLSTATE", -1));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(unpack_sql_state(edata->sqlerrcode), -1));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("message", -1));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(edata->message, -1));
+
+ if (edata->detail)
+ {
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("detail", -1));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(edata->detail, -1));
+ }
+ if (edata->detail_log)
+ {
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("detail_log", -1));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(edata->detail_log, -1));
+ }
+ if (edata->hint)
+ {
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("hint", -1));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(edata->hint, -1));
+ }
+ if (edata->domain)
+ {
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("domain", -1));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(edata->domain, -1));
+ }
+ if (edata->context_domain)
+ {
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("context_domain", -1));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(edata->context_domain, -1));
+ }
+ if (edata->context)
+ {
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("context", -1));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(edata->context, -1));
+ }
+ if (edata->schema_name)
+ {
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("schema", -1));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(edata->schema_name, -1));
+ }
+ if (edata->table_name)
+ {
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("table", -1));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(edata->table_name, -1));
+ }
+ if (edata->column_name)
+ {
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("column", -1));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(edata->column_name, -1));
+ }
+ if (edata->datatype_name)
+ {
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("datatype", -1));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(edata->datatype_name, -1));
+ }
+ if (edata->constraint_name)
+ {
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("constraint", -1));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(edata->constraint_name, -1));
+ }
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("cursor_position", -1));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewIntObj(edata->cursorpos));
+ if (edata->internalquery)
+ {
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("internalquery", -1));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(edata->internalquery, -1));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("internal_position", -1));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewIntObj(edata->internalpos));
+ }
+ if (edata->filename)
+ {
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("filename", -1));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(edata->filename, -1));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("lineno", -1));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewIntObj(edata->lineno));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("funcname", -1));
+ Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(edata->funcname, -1));
+ }
+
+ Tcl_SetObjErrorCode(interp, obj);
+ }
+
/**********************************************************************
* pltcl_elog() - elog() support for PLTcl
*************** pltcl_elog(ClientData cdata, Tcl_Interp
*** 1610,1615 ****
--- 1702,1709 ----
level = loglevels[priIndex];
+ level = loglevels[priIndex];
+
if (level == ERROR)
{
/*
*************** pltcl_elog(ClientData cdata, Tcl_Interp
*** 1652,1657 ****
--- 1746,1752 ----
UTF_BEGIN;
Tcl_SetObjResult(interp, Tcl_NewStringObj(UTF_E2U(edata->message), -1));
UTF_END;
+ pltcl_construct_errorCode(interp, edata);
FreeErrorData(edata);
return TCL_ERROR;
*************** pltcl_subtrans_abort(Tcl_Interp *interp,
*** 1884,1889 ****
--- 1979,1985 ----
UTF_BEGIN;
Tcl_SetResult(interp, UTF_E2U(edata->message), TCL_VOLATILE);
UTF_END;
+ pltcl_construct_errorCode(interp, edata);
FreeErrorData(edata);
}
diff --git a/src/pl/tcl/sql/pltcl_setup.sql b/src/pl/tcl/sql/pltcl_setup.sql
new file mode 100644
index 53358ea..3ee8583
*** a/src/pl/tcl/sql/pltcl_setup.sql
--- b/src/pl/tcl/sql/pltcl_setup.sql
*************** drop table foo;
*** 595,597 ****
--- 595,623 ----
drop event trigger tcl_a_snitch;
drop event trigger tcl_b_snitch;
+
+
+ -- test error handling
+
+ /*
+ * The ugly hack of messsing with the verbosity is because the error context is
+ * set to the TCL variable errorInfo, which contains some unstable data (namely
+ * the full name of the TCL function created by the handler, which includes the
+ * Postgres backend PID).
+ */
+ \set VERBOSITY terse
+ CREATE OR REPLACE FUNCTION pg_temp.tcl_eval (varchar) RETURNS varchar AS $$
+ eval $1
+ $$ LANGUAGE pltcl;
+
+ select pg_temp.tcl_eval('spi_exec "select * from foo;"');
+ select pg_temp.tcl_eval($$
+ set list [lindex $::errorCode 0];
+ foreach "key value" [lrange $::errorCode 1 end] {
+ if {$key == "domain" || $key == "context_domain" || $key == "lineno"} {
+ regsub -all {[0-9]} $value "" value
+ }
+ lappend list $key $value
+ };
+ return [join $list "\n"]
+ $$);