Clean up a number of bogosities around pltcl's handling of the Tcl "result":

1. Directly reading interp->result is deprecated in Tcl 8.0 and later;
you're supposed to use Tcl_GetStringResult.  This code finally broke with
Tcl 8.5, because Tcl_GetVar can now have side-effects on interp->result even
though it preserves the logical state of the result.  (There's arguably a
Tcl issue here, because Tcl_GetVar could invalidate the pointer result of a
just-preceding Tcl_GetStringResult, but I doubt the Tcl guys will see it as
a bug.)

2. We were being sloppy about the encoding of the result: some places would
push database-encoding data into the Tcl result, which should not happen,
and we were assuming that any error result coming back from Tcl was in the
database encoding, which is not a good assumption.

3. There were a lot of calls of Tcl_SetResult that uselessly specified
TCL_VOLATILE for constant strings.  This is only a minor performance issue,
but I fixed it in passing since I had to look at all the calls anyway.

#2 is a live bug regardless of which Tcl version you are interested in,
so back-patch even to branches that are unlikely to be used with Tcl 8.5.
I went back as far as 8.0, which is as far as the patch applied easily;
7.4 was using a different error processing scheme that has got its own
problems :-(

diff --git a/src/pl/tcl/pltcl.c b/src/pl/tcl/pltcl.c
index 4b72b860bbc7e4d1e792462bc1d08b573954a0af..1929c79eaf1993b901d4ce343d1a167a2256bd03 100644 (file)
--- a/src/pl/tcl/pltcl.c
+++ b/src/pl/tcl/pltcl.c
@@ -2,7 +2,7 @@
  * pltcl.c     - PostgreSQL support for Tcl as
  *               procedural language (PL)
  *
- *   $PostgreSQL: pgsql/src/pl/tcl/pltcl.c,v 1.117 2007/11/15 21:14:46 momjian Exp $
+ *   $PostgreSQL: pgsql/src/pl/tcl/pltcl.c,v 1.117.2.1 2008/06/17 00:52:49 tgl Exp $
  *
  **********************************************************************/
 
@@ -37,6 +37,11 @@
    ((TCL_MAJOR_VERSION > maj) || \
     (TCL_MAJOR_VERSION == maj && TCL_MINOR_VERSION >= min))
 
+/* In Tcl >= 8.0, really not supposed to touch interp->result directly */
+#if !HAVE_TCL_VERSION(8,0)
+#define Tcl_GetStringResult(interp)  ((interp)->result)
+#endif
+
 #if defined(UNICODE_CONVERSION) && HAVE_TCL_VERSION(8,1)
 
 #include "mb/pg_wchar.h"
@@ -135,6 +140,8 @@ static Datum pltcl_func_handler(PG_FUNCTION_ARGS);
 
 static HeapTuple pltcl_trigger_handler(PG_FUNCTION_ARGS);
 
+static void throw_tcl_error(Tcl_Interp *interp, const char *proname);
+
 static pltcl_proc_desc *compile_pltcl_function(Oid fn_oid, Oid tgreloid);
 
 static int pltcl_elog(ClientData cdata, Tcl_Interp *interp,
@@ -633,16 +640,7 @@ pltcl_func_handler(PG_FUNCTION_ARGS)
     * Check for errors reported by Tcl.
     ************************************************************/
    if (tcl_rc != TCL_OK)
-   {
-       UTF_BEGIN;
-       ereport(ERROR,
-               (errmsg("%s", interp->result),
-                errcontext("%s\nin PL/Tcl function \"%s\"",
-                           UTF_U2E(Tcl_GetVar(interp, "errorInfo",
-                                              TCL_GLOBAL_ONLY)),
-                           prodesc->user_proname)));
-       UTF_END;
-   }
+       throw_tcl_error(interp, prodesc->user_proname);
 
    /************************************************************
     * Disconnect from SPI manager and then create the return
@@ -650,8 +648,8 @@ pltcl_func_handler(PG_FUNCTION_ARGS)
     * this must not be allocated in the SPI memory context
     * because SPI_finish would free it).  But don't try to call
     * the result_in_func if we've been told to return a NULL;
-    * the contents of interp->result may not be a valid value of
-    * the result type in that case.
+    * the Tcl result may not be a valid value of the result type
+    * in that case.
     ************************************************************/
    if (SPI_finish() != SPI_OK_FINISH)
        elog(ERROR, "SPI_finish() failed");
@@ -665,7 +663,7 @@ pltcl_func_handler(PG_FUNCTION_ARGS)
    {
        UTF_BEGIN;
        retval = InputFunctionCall(&prodesc->result_in_func,
-                                  UTF_U2E(interp->result),
+                                  UTF_U2E((char *) Tcl_GetStringResult(interp)),
                                   prodesc->result_typioparam,
                                   -1);
        UTF_END;
@@ -696,6 +694,7 @@ pltcl_trigger_handler(PG_FUNCTION_ARGS)
    Datum      *modvalues;
    char       *modnulls;
    int         ret_numvals;
+   CONST84 char *result;
    CONST84 char **ret_values;
 
    /* Connect to SPI manager */
@@ -863,37 +862,35 @@ pltcl_trigger_handler(PG_FUNCTION_ARGS)
     * Check for errors reported by Tcl.
     ************************************************************/
    if (tcl_rc != TCL_OK)
-   {
-       UTF_BEGIN;
-       ereport(ERROR,
-               (errmsg("%s", interp->result),
-                errcontext("%s\nin PL/Tcl function \"%s\"",
-                           UTF_U2E(Tcl_GetVar(interp, "errorInfo",
-                                              TCL_GLOBAL_ONLY)),
-                           prodesc->user_proname)));
-       UTF_END;
-   }
+       throw_tcl_error(interp, prodesc->user_proname);
 
    /************************************************************
     * The return value from the procedure might be one of
-    * the magic strings OK or SKIP or a list from array get
+    * the magic strings OK or SKIP or a list from array get.
+    * We can check for OK or SKIP without worrying about encoding.
     ************************************************************/
    if (SPI_finish() != SPI_OK_FINISH)
        elog(ERROR, "SPI_finish() failed");
 
-   if (strcmp(interp->result, "OK") == 0)
+   result = Tcl_GetStringResult(interp);
+
+   if (strcmp(result, "OK") == 0)
        return rettup;
-   if (strcmp(interp->result, "SKIP") == 0)
+   if (strcmp(result, "SKIP") == 0)
        return (HeapTuple) NULL;
 
    /************************************************************
     * Convert the result value from the Tcl interpreter
     * and setup structures for SPI_modifytuple();
     ************************************************************/
-   if (Tcl_SplitList(interp, interp->result,
+   if (Tcl_SplitList(interp, result,
                      &ret_numvals, &ret_values) != TCL_OK)
+   {
+       UTF_BEGIN;
        elog(ERROR, "could not split return value from trigger: %s",
-            interp->result);
+            UTF_U2E(Tcl_GetStringResult(interp)));
+       UTF_END;
+   }
 
    /* Use a TRY to ensure ret_values will get freed */
    PG_TRY();
@@ -993,6 +990,36 @@ pltcl_trigger_handler(PG_FUNCTION_ARGS)
 }
 
 
+/**********************************************************************
+ * throw_tcl_error - ereport an error returned from the Tcl interpreter
+ **********************************************************************/
+static void
+throw_tcl_error(Tcl_Interp *interp, const char *proname)
+{
+   /*
+    * Caution is needed here because Tcl_GetVar could overwrite the
+    * interpreter result (even though it's not really supposed to),
+    * and we can't control the order of evaluation of ereport arguments.
+    * Hence, make real sure we have our own copy of the result string
+    * before invoking Tcl_GetVar.
+    */
+   char       *emsg;
+   char       *econtext;
+
+   UTF_BEGIN;
+   emsg = pstrdup(UTF_U2E(Tcl_GetStringResult(interp)));
+   UTF_END;
+   UTF_BEGIN;
+   econtext = UTF_U2E((char *) Tcl_GetVar(interp, "errorInfo",
+                                          TCL_GLOBAL_ONLY));
+   ereport(ERROR,
+           (errmsg("%s", emsg),
+            errcontext("%s\nin PL/Tcl function \"%s\"",
+                       econtext, proname)));
+   UTF_END;
+}
+
+
 /**********************************************************************
  * compile_pltcl_function  - compile (or hopefully just look up) function
  *
@@ -1319,8 +1346,10 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid)
            free(prodesc->user_proname);
            free(prodesc->internal_proname);
            free(prodesc);
+           UTF_BEGIN;
            elog(ERROR, "could not create internal procedure \"%s\": %s",
-                internal_proname, interp->result);
+                internal_proname, UTF_U2E(Tcl_GetStringResult(interp)));
+           UTF_END;
        }
 
        /************************************************************
@@ -1349,8 +1378,7 @@ pltcl_elog(ClientData cdata, Tcl_Interp *interp,
 
    if (argc != 3)
    {
-       Tcl_SetResult(interp, "syntax error - 'elog level msg'",
-                     TCL_VOLATILE);
+       Tcl_SetResult(interp, "syntax error - 'elog level msg'", TCL_STATIC);
        return TCL_ERROR;
    }
 
@@ -1375,11 +1403,26 @@ pltcl_elog(ClientData cdata, Tcl_Interp *interp,
        return TCL_ERROR;
    }
 
-   /************************************************************
-    * If elog() throws an error, catch it and return the error to the
-    * Tcl interpreter.  Note we are assuming that elog() can't have any
+   if (level == ERROR)
+   {
+       /*
+        * We just pass the error back to Tcl.  If it's not caught,
+        * it'll eventually get converted to a PG error when we reach
+        * the call handler.
+        */
+       Tcl_SetResult(interp, (char *) argv[2], TCL_VOLATILE);
+       return TCL_ERROR;
+   }
+
+   /*
+    * For non-error messages, just pass 'em to elog().  We do not expect
+    * that this will fail, but just on the off chance it does, report the
+    * error back to Tcl.  Note we are assuming that elog() can't have any
     * internal failures that are so bad as to require a transaction abort.
-    ************************************************************/
+    *
+    * This path is also used for FATAL errors, which aren't going to come
+    * back to us at all.
+    */
    oldcontext = CurrentMemoryContext;
    PG_TRY();
    {
@@ -1397,7 +1440,9 @@ pltcl_elog(ClientData cdata, Tcl_Interp *interp,
        FlushErrorState();
 
        /* Pass the error message to Tcl */
-       Tcl_SetResult(interp, edata->message, TCL_VOLATILE);
+       UTF_BEGIN;
+       Tcl_SetResult(interp, UTF_E2U(edata->message), TCL_VOLATILE);
+       UTF_END;
        FreeErrorData(edata);
 
        return TCL_ERROR;
@@ -1425,7 +1470,7 @@ pltcl_quote(ClientData cdata, Tcl_Interp *interp,
     ************************************************************/
    if (argc != 2)
    {
-       Tcl_SetResult(interp, "syntax error - 'quote string'", TCL_VOLATILE);
+       Tcl_SetResult(interp, "syntax error - 'quote string'", TCL_STATIC);
        return TCL_ERROR;
    }
 
@@ -1477,7 +1522,8 @@ pltcl_argisnull(ClientData cdata, Tcl_Interp *interp,
     ************************************************************/
    if (argc != 2)
    {
-       Tcl_SetResult(interp, "syntax error - 'argisnull argno'", TCL_VOLATILE);
+       Tcl_SetResult(interp, "syntax error - 'argisnull argno'",
+                     TCL_STATIC);
        return TCL_ERROR;
    }
 
@@ -1487,7 +1533,7 @@ pltcl_argisnull(ClientData cdata, Tcl_Interp *interp,
    if (fcinfo == NULL)
    {
        Tcl_SetResult(interp, "argisnull cannot be used in triggers",
-                     TCL_VOLATILE);
+                     TCL_STATIC);
        return TCL_ERROR;
    }
 
@@ -1503,7 +1549,7 @@ pltcl_argisnull(ClientData cdata, Tcl_Interp *interp,
    argno--;
    if (argno < 0 || argno >= fcinfo->nargs)
    {
-       Tcl_SetResult(interp, "argno out of range", TCL_VOLATILE);
+       Tcl_SetResult(interp, "argno out of range", TCL_STATIC);
        return TCL_ERROR;
    }
 
@@ -1511,9 +1557,9 @@ pltcl_argisnull(ClientData cdata, Tcl_Interp *interp,
     * Get the requested NULL state
     ************************************************************/
    if (PG_ARGISNULL(argno))
-       Tcl_SetResult(interp, "1", TCL_VOLATILE);
+       Tcl_SetResult(interp, "1", TCL_STATIC);
    else
-       Tcl_SetResult(interp, "0", TCL_VOLATILE);
+       Tcl_SetResult(interp, "0", TCL_STATIC);
 
    return TCL_OK;
 }
@@ -1533,7 +1579,7 @@ pltcl_returnnull(ClientData cdata, Tcl_Interp *interp,
     ************************************************************/
    if (argc != 1)
    {
-       Tcl_SetResult(interp, "syntax error - 'return_null'", TCL_VOLATILE);
+       Tcl_SetResult(interp, "syntax error - 'return_null'", TCL_STATIC);
        return TCL_ERROR;
    }
 
@@ -1543,7 +1589,7 @@ pltcl_returnnull(ClientData cdata, Tcl_Interp *interp,
    if (fcinfo == NULL)
    {
        Tcl_SetResult(interp, "return_null cannot be used in triggers",
-                     TCL_VOLATILE);
+                     TCL_STATIC);
        return TCL_ERROR;
    }
 
@@ -1629,7 +1675,9 @@ pltcl_subtrans_abort(Tcl_Interp *interp,
    SPI_restore_connection();
 
    /* Pass the error message to Tcl */
-   Tcl_SetResult(interp, edata->message, TCL_VOLATILE);
+   UTF_BEGIN;
+   Tcl_SetResult(interp, UTF_E2U(edata->message), TCL_VOLATILE);
+   UTF_END;
    FreeErrorData(edata);
 }
 
@@ -1661,7 +1709,7 @@ pltcl_SPI_execute(ClientData cdata, Tcl_Interp *interp,
     ************************************************************/
    if (argc < 2)
    {
-       Tcl_SetResult(interp, usage, TCL_VOLATILE);
+       Tcl_SetResult(interp, usage, TCL_STATIC);
        return TCL_ERROR;
    }
 
@@ -1672,7 +1720,7 @@ pltcl_SPI_execute(ClientData cdata, Tcl_Interp *interp,
        {
            if (++i >= argc)
            {
-               Tcl_SetResult(interp, usage, TCL_VOLATILE);
+               Tcl_SetResult(interp, usage, TCL_STATIC);
                return TCL_ERROR;
            }
            arrayname = argv[i++];
@@ -1683,7 +1731,7 @@ pltcl_SPI_execute(ClientData cdata, Tcl_Interp *interp,
        {
            if (++i >= argc)
            {
-               Tcl_SetResult(interp, usage, TCL_VOLATILE);
+               Tcl_SetResult(interp, usage, TCL_STATIC);
                return TCL_ERROR;
            }
            if (Tcl_GetInt(interp, argv[i++], &count) != TCL_OK)
@@ -1697,7 +1745,7 @@ pltcl_SPI_execute(ClientData cdata, Tcl_Interp *interp,
    query_idx = i;
    if (query_idx >= argc || query_idx + 2 < argc)
    {
-       Tcl_SetResult(interp, usage, TCL_VOLATILE);
+       Tcl_SetResult(interp, usage, TCL_STATIC);
        return TCL_ERROR;
    }
    if (query_idx + 1 < argc)
@@ -1769,7 +1817,7 @@ pltcl_process_SPI_result(Tcl_Interp *interp,
        case SPI_OK_UTILITY:
            if (tuptable == NULL)
            {
-               Tcl_SetResult(interp, "0", TCL_VOLATILE);
+               Tcl_SetResult(interp, "0", TCL_STATIC);
                break;
            }
            /* FALL THRU for utility returning tuples */
@@ -1873,7 +1921,7 @@ pltcl_SPI_prepare(ClientData cdata, Tcl_Interp *interp,
    if (argc != 3)
    {
        Tcl_SetResult(interp, "syntax error - 'SPI_prepare query argtypes'",
-                     TCL_VOLATILE);
+                     TCL_STATIC);
        return TCL_ERROR;
    }
 
@@ -1974,6 +2022,7 @@ pltcl_SPI_prepare(ClientData cdata, Tcl_Interp *interp,
 
    ckfree((char *) args);
 
+   /* qname is ASCII, so no need for encoding conversion */
    Tcl_SetResult(interp, qdesc->qname, TCL_VOLATILE);
    return TCL_OK;
 }
@@ -2017,7 +2066,7 @@ pltcl_SPI_execute_plan(ClientData cdata, Tcl_Interp *interp,
        {
            if (++i >= argc)
            {
-               Tcl_SetResult(interp, usage, TCL_VOLATILE);
+               Tcl_SetResult(interp, usage, TCL_STATIC);
                return TCL_ERROR;
            }
            arrayname = argv[i++];
@@ -2027,7 +2076,7 @@ pltcl_SPI_execute_plan(ClientData cdata, Tcl_Interp *interp,
        {
            if (++i >= argc)
            {
-               Tcl_SetResult(interp, usage, TCL_VOLATILE);
+               Tcl_SetResult(interp, usage, TCL_STATIC);
                return TCL_ERROR;
            }
            nulls = argv[i++];
@@ -2037,7 +2086,7 @@ pltcl_SPI_execute_plan(ClientData cdata, Tcl_Interp *interp,
        {
            if (++i >= argc)
            {
-               Tcl_SetResult(interp, usage, TCL_VOLATILE);
+               Tcl_SetResult(interp, usage, TCL_STATIC);
                return TCL_ERROR;
            }
            if (Tcl_GetInt(interp, argv[i++], &count) != TCL_OK)
@@ -2053,7 +2102,7 @@ pltcl_SPI_execute_plan(ClientData cdata, Tcl_Interp *interp,
     ************************************************************/
    if (i >= argc)
    {
-       Tcl_SetResult(interp, usage, TCL_VOLATILE);
+       Tcl_SetResult(interp, usage, TCL_STATIC);
        return TCL_ERROR;
    }
 
@@ -2080,7 +2129,7 @@ pltcl_SPI_execute_plan(ClientData cdata, Tcl_Interp *interp,
        {
            Tcl_SetResult(interp,
                       "length of nulls string doesn't match # of arguments",
-                         TCL_VOLATILE);
+                         TCL_STATIC);
            return TCL_ERROR;
        }
    }
@@ -2093,7 +2142,7 @@ pltcl_SPI_execute_plan(ClientData cdata, Tcl_Interp *interp,
    {
        if (i >= argc)
        {
-           Tcl_SetResult(interp, "missing argument list", TCL_VOLATILE);
+           Tcl_SetResult(interp, "missing argument list", TCL_STATIC);
            return TCL_ERROR;
        }
 
@@ -2110,7 +2159,7 @@ pltcl_SPI_execute_plan(ClientData cdata, Tcl_Interp *interp,
        {
            Tcl_SetResult(interp,
               "argument list length doesn't match # of arguments for query",
-                         TCL_VOLATILE);
+                         TCL_STATIC);
            ckfree((char *) callargs);
            return TCL_ERROR;
        }
@@ -2126,7 +2175,7 @@ pltcl_SPI_execute_plan(ClientData cdata, Tcl_Interp *interp,
 
    if (i != argc)
    {
-       Tcl_SetResult(interp, usage, TCL_VOLATILE);
+       Tcl_SetResult(interp, usage, TCL_STATIC);
        return TCL_ERROR;
    }