aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/pl/tcl/expected/pltcl_setup.out28
-rw-r--r--src/pl/tcl/pltcl.c151
-rw-r--r--src/pl/tcl/sql/pltcl_setup.sql24
3 files changed, 200 insertions, 3 deletions
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;
generated by cgit v1.2.3 (git 2.25.1) at 2025-06-20 22:51:00 +0000