LCOV - code coverage report
Current view: top level - src/pl/tcl - pltcl.c (source / functions) Hit Total Coverage
Test: PostgreSQL 18devel Lines: 999 1092 91.5 %
Date: 2025-04-01 18:16:35 Functions: 41 47 87.2 %
Legend: Lines: hit not hit

          Line data    Source code
       1             : /**********************************************************************
       2             :  * pltcl.c      - PostgreSQL support for Tcl as
       3             :  *                procedural language (PL)
       4             :  *
       5             :  *    src/pl/tcl/pltcl.c
       6             :  *
       7             :  **********************************************************************/
       8             : 
       9             : #include "postgres.h"
      10             : 
      11             : #include <tcl.h>
      12             : 
      13             : #include <unistd.h>
      14             : #include <fcntl.h>
      15             : 
      16             : #include "access/htup_details.h"
      17             : #include "access/xact.h"
      18             : #include "catalog/objectaccess.h"
      19             : #include "catalog/pg_proc.h"
      20             : #include "catalog/pg_type.h"
      21             : #include "commands/event_trigger.h"
      22             : #include "commands/trigger.h"
      23             : #include "executor/spi.h"
      24             : #include "fmgr.h"
      25             : #include "funcapi.h"
      26             : #include "mb/pg_wchar.h"
      27             : #include "miscadmin.h"
      28             : #include "parser/parse_func.h"
      29             : #include "parser/parse_type.h"
      30             : #include "pgstat.h"
      31             : #include "utils/acl.h"
      32             : #include "utils/builtins.h"
      33             : #include "utils/guc.h"
      34             : #include "utils/lsyscache.h"
      35             : #include "utils/memutils.h"
      36             : #include "utils/regproc.h"
      37             : #include "utils/rel.h"
      38             : #include "utils/syscache.h"
      39             : #include "utils/typcache.h"
      40             : 
      41             : 
      42          18 : PG_MODULE_MAGIC_EXT(
      43             :                     .name = "pltcl",
      44             :                     .version = PG_VERSION
      45             : );
      46             : 
      47             : #define HAVE_TCL_VERSION(maj,min) \
      48             :     ((TCL_MAJOR_VERSION > maj) || \
      49             :      (TCL_MAJOR_VERSION == maj && TCL_MINOR_VERSION >= min))
      50             : 
      51             : /* Insist on Tcl >= 8.4 */
      52             : #if !HAVE_TCL_VERSION(8,4)
      53             : #error PostgreSQL only supports Tcl 8.4 or later.
      54             : #endif
      55             : 
      56             : /* Hack to deal with Tcl 8.6 const-ification without losing compatibility */
      57             : #ifndef CONST86
      58             : #define CONST86
      59             : #endif
      60             : 
      61             : #if !HAVE_TCL_VERSION(8,7)
      62             : typedef int Tcl_Size;
      63             : #endif
      64             : 
      65             : /* define our text domain for translations */
      66             : #undef TEXTDOMAIN
      67             : #define TEXTDOMAIN PG_TEXTDOMAIN("pltcl")
      68             : 
      69             : 
      70             : /*
      71             :  * Support for converting between UTF8 (which is what all strings going into
      72             :  * or out of Tcl should be) and the database encoding.
      73             :  *
      74             :  * If you just use utf_u2e() or utf_e2u() directly, they will leak some
      75             :  * palloc'd space when doing a conversion.  This is not worth worrying about
      76             :  * if it only happens, say, once per PL/Tcl function call.  If it does seem
      77             :  * worth worrying about, use the wrapper macros.
      78             :  */
      79             : 
      80             : static inline char *
      81        1524 : utf_u2e(const char *src)
      82             : {
      83        1524 :     return pg_any_to_server(src, strlen(src), PG_UTF8);
      84             : }
      85             : 
      86             : static inline char *
      87        2716 : utf_e2u(const char *src)
      88             : {
      89        2716 :     return pg_server_to_any(src, strlen(src), PG_UTF8);
      90             : }
      91             : 
      92             : #define UTF_BEGIN \
      93             :     do { \
      94             :         const char *_pltcl_utf_src = NULL; \
      95             :         char *_pltcl_utf_dst = NULL
      96             : 
      97             : #define UTF_END \
      98             :     if (_pltcl_utf_src != (const char *) _pltcl_utf_dst) \
      99             :             pfree(_pltcl_utf_dst); \
     100             :     } while (0)
     101             : 
     102             : #define UTF_U2E(x) \
     103             :     (_pltcl_utf_dst = utf_u2e(_pltcl_utf_src = (x)))
     104             : 
     105             : #define UTF_E2U(x) \
     106             :     (_pltcl_utf_dst = utf_e2u(_pltcl_utf_src = (x)))
     107             : 
     108             : 
     109             : /**********************************************************************
     110             :  * Information associated with a Tcl interpreter.  We have one interpreter
     111             :  * that is used for all pltclu (untrusted) functions.  For pltcl (trusted)
     112             :  * functions, there is a separate interpreter for each effective SQL userid.
     113             :  * (This is needed to ensure that an unprivileged user can't inject Tcl code
     114             :  * that'll be executed with the privileges of some other SQL user.)
     115             :  *
     116             :  * The pltcl_interp_desc structs are kept in a Postgres hash table indexed
     117             :  * by userid OID, with OID 0 used for the single untrusted interpreter.
     118             :  **********************************************************************/
     119             : typedef struct pltcl_interp_desc
     120             : {
     121             :     Oid         user_id;        /* Hash key (must be first!) */
     122             :     Tcl_Interp *interp;         /* The interpreter */
     123             :     Tcl_HashTable query_hash;   /* pltcl_query_desc structs */
     124             : } pltcl_interp_desc;
     125             : 
     126             : 
     127             : /**********************************************************************
     128             :  * The information we cache about loaded procedures
     129             :  *
     130             :  * The pltcl_proc_desc struct itself, as well as all subsidiary data,
     131             :  * is stored in the memory context identified by the fn_cxt field.
     132             :  * We can reclaim all the data by deleting that context, and should do so
     133             :  * when the fn_refcount goes to zero.  That will happen if we build a new
     134             :  * pltcl_proc_desc following an update of the pg_proc row.  If that happens
     135             :  * while the old proc is being executed, we mustn't remove the struct until
     136             :  * execution finishes.  When building a new pltcl_proc_desc, we unlink
     137             :  * Tcl's copy of the old procedure definition, similarly relying on Tcl's
     138             :  * internal reference counting to prevent that structure from disappearing
     139             :  * while it's in use.
     140             :  *
     141             :  * Note that the data in this struct is shared across all active calls;
     142             :  * nothing except the fn_refcount should be changed by a call instance.
     143             :  **********************************************************************/
     144             : typedef struct pltcl_proc_desc
     145             : {
     146             :     char       *user_proname;   /* user's name (from format_procedure) */
     147             :     char       *internal_proname;   /* Tcl proc name (NULL if deleted) */
     148             :     MemoryContext fn_cxt;       /* memory context for this procedure */
     149             :     unsigned long fn_refcount;  /* number of active references */
     150             :     TransactionId fn_xmin;      /* xmin of pg_proc row */
     151             :     ItemPointerData fn_tid;     /* TID of pg_proc row */
     152             :     bool        fn_readonly;    /* is function readonly? */
     153             :     bool        lanpltrusted;   /* is it pltcl (vs. pltclu)? */
     154             :     pltcl_interp_desc *interp_desc; /* interpreter to use */
     155             :     Oid         result_typid;   /* OID of fn's result type */
     156             :     FmgrInfo    result_in_func; /* input function for fn's result type */
     157             :     Oid         result_typioparam;  /* param to pass to same */
     158             :     bool        fn_retisset;    /* true if function returns a set */
     159             :     bool        fn_retistuple;  /* true if function returns composite */
     160             :     bool        fn_retisdomain; /* true if function returns domain */
     161             :     void       *domain_info;    /* opaque cache for domain checks */
     162             :     int         nargs;          /* number of arguments */
     163             :     /* these arrays have nargs entries: */
     164             :     FmgrInfo   *arg_out_func;   /* output fns for arg types */
     165             :     bool       *arg_is_rowtype; /* is each arg composite? */
     166             : } pltcl_proc_desc;
     167             : 
     168             : 
     169             : /**********************************************************************
     170             :  * The information we cache about prepared and saved plans
     171             :  **********************************************************************/
     172             : typedef struct pltcl_query_desc
     173             : {
     174             :     char        qname[20];
     175             :     SPIPlanPtr  plan;
     176             :     int         nargs;
     177             :     Oid        *argtypes;
     178             :     FmgrInfo   *arginfuncs;
     179             :     Oid        *argtypioparams;
     180             : } pltcl_query_desc;
     181             : 
     182             : 
     183             : /**********************************************************************
     184             :  * For speedy lookup, we maintain a hash table mapping from
     185             :  * function OID + trigger flag + user OID to pltcl_proc_desc pointers.
     186             :  * The reason the pltcl_proc_desc struct isn't directly part of the hash
     187             :  * entry is to simplify recovery from errors during compile_pltcl_function.
     188             :  *
     189             :  * Note: if the same function is called by multiple userIDs within a session,
     190             :  * there will be a separate pltcl_proc_desc entry for each userID in the case
     191             :  * of pltcl functions, but only one entry for pltclu functions, because we
     192             :  * set user_id = 0 for that case.
     193             :  **********************************************************************/
     194             : typedef struct pltcl_proc_key
     195             : {
     196             :     Oid         proc_id;        /* Function OID */
     197             : 
     198             :     /*
     199             :      * is_trigger is really a bool, but declare as Oid to ensure this struct
     200             :      * contains no padding
     201             :      */
     202             :     Oid         is_trigger;     /* is it a trigger function? */
     203             :     Oid         user_id;        /* User calling the function, or 0 */
     204             : } pltcl_proc_key;
     205             : 
     206             : typedef struct pltcl_proc_ptr
     207             : {
     208             :     pltcl_proc_key proc_key;    /* Hash key (must be first!) */
     209             :     pltcl_proc_desc *proc_ptr;
     210             : } pltcl_proc_ptr;
     211             : 
     212             : 
     213             : /**********************************************************************
     214             :  * Per-call state
     215             :  **********************************************************************/
     216             : typedef struct pltcl_call_state
     217             : {
     218             :     /* Call info struct, or NULL in a trigger */
     219             :     FunctionCallInfo fcinfo;
     220             : 
     221             :     /* Trigger data, if we're in a normal (not event) trigger; else NULL */
     222             :     TriggerData *trigdata;
     223             : 
     224             :     /* Function we're executing (NULL if not yet identified) */
     225             :     pltcl_proc_desc *prodesc;
     226             : 
     227             :     /*
     228             :      * Information for SRFs and functions returning composite types.
     229             :      * ret_tupdesc and attinmeta are set up if either fn_retistuple or
     230             :      * fn_retisset, since even a scalar-returning SRF needs a tuplestore.
     231             :      */
     232             :     TupleDesc   ret_tupdesc;    /* return rowtype, if retistuple or retisset */
     233             :     AttInMetadata *attinmeta;   /* metadata for building tuples of that type */
     234             : 
     235             :     ReturnSetInfo *rsi;         /* passed-in ReturnSetInfo, if any */
     236             :     Tuplestorestate *tuple_store;   /* SRFs accumulate result here */
     237             :     MemoryContext tuple_store_cxt;  /* context and resowner for tuplestore */
     238             :     ResourceOwner tuple_store_owner;
     239             : } pltcl_call_state;
     240             : 
     241             : 
     242             : /**********************************************************************
     243             :  * Global data
     244             :  **********************************************************************/
     245             : static char *pltcl_start_proc = NULL;
     246             : static char *pltclu_start_proc = NULL;
     247             : static bool pltcl_pm_init_done = false;
     248             : static Tcl_Interp *pltcl_hold_interp = NULL;
     249             : static HTAB *pltcl_interp_htab = NULL;
     250             : static HTAB *pltcl_proc_htab = NULL;
     251             : 
     252             : /* this is saved and restored by pltcl_handler */
     253             : static pltcl_call_state *pltcl_current_call_state = NULL;
     254             : 
     255             : /**********************************************************************
     256             :  * Lookup table for SQLSTATE condition names
     257             :  **********************************************************************/
     258             : typedef struct
     259             : {
     260             :     const char *label;
     261             :     int         sqlerrstate;
     262             : } TclExceptionNameMap;
     263             : 
     264             : static const TclExceptionNameMap exception_name_map[] = {
     265             : #include "pltclerrcodes.h"
     266             :     {NULL, 0}
     267             : };
     268             : 
     269             : /**********************************************************************
     270             :  * Forward declarations
     271             :  **********************************************************************/
     272             : 
     273             : static void pltcl_init_interp(pltcl_interp_desc *interp_desc,
     274             :                               Oid prolang, bool pltrusted);
     275             : static pltcl_interp_desc *pltcl_fetch_interp(Oid prolang, bool pltrusted);
     276             : static void call_pltcl_start_proc(Oid prolang, bool pltrusted);
     277             : static void start_proc_error_callback(void *arg);
     278             : 
     279             : static Datum pltcl_handler(PG_FUNCTION_ARGS, bool pltrusted);
     280             : 
     281             : static Datum pltcl_func_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state,
     282             :                                 bool pltrusted);
     283             : static HeapTuple pltcl_trigger_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state,
     284             :                                        bool pltrusted);
     285             : static void pltcl_event_trigger_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state,
     286             :                                         bool pltrusted);
     287             : 
     288             : static void throw_tcl_error(Tcl_Interp *interp, const char *proname);
     289             : 
     290             : static pltcl_proc_desc *compile_pltcl_function(Oid fn_oid, Oid tgreloid,
     291             :                                                bool is_event_trigger,
     292             :                                                bool pltrusted);
     293             : 
     294             : static int  pltcl_elog(ClientData cdata, Tcl_Interp *interp,
     295             :                        int objc, Tcl_Obj *const objv[]);
     296             : static void pltcl_construct_errorCode(Tcl_Interp *interp, ErrorData *edata);
     297             : static const char *pltcl_get_condition_name(int sqlstate);
     298             : static int  pltcl_quote(ClientData cdata, Tcl_Interp *interp,
     299             :                         int objc, Tcl_Obj *const objv[]);
     300             : static int  pltcl_argisnull(ClientData cdata, Tcl_Interp *interp,
     301             :                             int objc, Tcl_Obj *const objv[]);
     302             : static int  pltcl_returnnull(ClientData cdata, Tcl_Interp *interp,
     303             :                              int objc, Tcl_Obj *const objv[]);
     304             : static int  pltcl_returnnext(ClientData cdata, Tcl_Interp *interp,
     305             :                              int objc, Tcl_Obj *const objv[]);
     306             : static int  pltcl_SPI_execute(ClientData cdata, Tcl_Interp *interp,
     307             :                               int objc, Tcl_Obj *const objv[]);
     308             : static int  pltcl_process_SPI_result(Tcl_Interp *interp,
     309             :                                      const char *arrayname,
     310             :                                      Tcl_Obj *loop_body,
     311             :                                      int spi_rc,
     312             :                                      SPITupleTable *tuptable,
     313             :                                      uint64 ntuples);
     314             : static int  pltcl_SPI_prepare(ClientData cdata, Tcl_Interp *interp,
     315             :                               int objc, Tcl_Obj *const objv[]);
     316             : static int  pltcl_SPI_execute_plan(ClientData cdata, Tcl_Interp *interp,
     317             :                                    int objc, Tcl_Obj *const objv[]);
     318             : static int  pltcl_subtransaction(ClientData cdata, Tcl_Interp *interp,
     319             :                                  int objc, Tcl_Obj *const objv[]);
     320             : static int  pltcl_commit(ClientData cdata, Tcl_Interp *interp,
     321             :                          int objc, Tcl_Obj *const objv[]);
     322             : static int  pltcl_rollback(ClientData cdata, Tcl_Interp *interp,
     323             :                            int objc, Tcl_Obj *const objv[]);
     324             : 
     325             : static void pltcl_subtrans_begin(MemoryContext oldcontext,
     326             :                                  ResourceOwner oldowner);
     327             : static void pltcl_subtrans_commit(MemoryContext oldcontext,
     328             :                                   ResourceOwner oldowner);
     329             : static void pltcl_subtrans_abort(Tcl_Interp *interp,
     330             :                                  MemoryContext oldcontext,
     331             :                                  ResourceOwner oldowner);
     332             : 
     333             : static void pltcl_set_tuple_values(Tcl_Interp *interp, const char *arrayname,
     334             :                                    uint64 tupno, HeapTuple tuple, TupleDesc tupdesc);
     335             : static Tcl_Obj *pltcl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc, bool include_generated);
     336             : static HeapTuple pltcl_build_tuple_result(Tcl_Interp *interp,
     337             :                                           Tcl_Obj **kvObjv, int kvObjc,
     338             :                                           pltcl_call_state *call_state);
     339             : static void pltcl_init_tuple_store(pltcl_call_state *call_state);
     340             : 
     341             : 
     342             : /*
     343             :  * Hack to override Tcl's builtin Notifier subsystem.  This prevents the
     344             :  * backend from becoming multithreaded, which breaks all sorts of things.
     345             :  * That happens in the default version of Tcl_InitNotifier if the Tcl library
     346             :  * has been compiled with multithreading support (i.e. when TCL_THREADS is
     347             :  * defined under Unix, and in all cases under Windows).
     348             :  * It's okay to disable the notifier because we never enter the Tcl event loop
     349             :  * from Postgres, so the notifier capabilities are initialized, but never
     350             :  * used.  Only InitNotifier and DeleteFileHandler ever seem to get called
     351             :  * within Postgres, but we implement all the functions for completeness.
     352             :  */
     353             : static ClientData
     354          18 : pltcl_InitNotifier(void)
     355             : {
     356             :     static int  fakeThreadKey;  /* To give valid address for ClientData */
     357             : 
     358          18 :     return (ClientData) &(fakeThreadKey);
     359             : }
     360             : 
     361             : static void
     362           0 : pltcl_FinalizeNotifier(ClientData clientData)
     363             : {
     364           0 : }
     365             : 
     366             : static void
     367           2 : pltcl_SetTimer(CONST86 Tcl_Time *timePtr)
     368             : {
     369           2 : }
     370             : 
     371             : static void
     372           0 : pltcl_AlertNotifier(ClientData clientData)
     373             : {
     374           0 : }
     375             : 
     376             : static void
     377           0 : pltcl_CreateFileHandler(int fd, int mask,
     378             :                         Tcl_FileProc *proc, ClientData clientData)
     379             : {
     380           0 : }
     381             : 
     382             : static void
     383          88 : pltcl_DeleteFileHandler(int fd)
     384             : {
     385          88 : }
     386             : 
     387             : static void
     388           0 : pltcl_ServiceModeHook(int mode)
     389             : {
     390           0 : }
     391             : 
     392             : static int
     393      702218 : pltcl_WaitForEvent(CONST86 Tcl_Time *timePtr)
     394             : {
     395      702218 :     return 0;
     396             : }
     397             : 
     398             : 
     399             : /*
     400             :  * _PG_init()           - library load-time initialization
     401             :  *
     402             :  * DO NOT make this static nor change its name!
     403             :  *
     404             :  * The work done here must be safe to do in the postmaster process,
     405             :  * in case the pltcl library is preloaded in the postmaster.
     406             :  */
     407             : void
     408          18 : _PG_init(void)
     409             : {
     410             :     Tcl_NotifierProcs notifier;
     411             :     HASHCTL     hash_ctl;
     412             : 
     413             :     /* Be sure we do initialization only once (should be redundant now) */
     414          18 :     if (pltcl_pm_init_done)
     415           0 :         return;
     416             : 
     417          18 :     pg_bindtextdomain(TEXTDOMAIN);
     418             : 
     419             : #ifdef WIN32
     420             :     /* Required on win32 to prevent error loading init.tcl */
     421             :     Tcl_FindExecutable("");
     422             : #endif
     423             : 
     424             :     /*
     425             :      * Override the functions in the Notifier subsystem.  See comments above.
     426             :      */
     427          18 :     notifier.setTimerProc = pltcl_SetTimer;
     428          18 :     notifier.waitForEventProc = pltcl_WaitForEvent;
     429          18 :     notifier.createFileHandlerProc = pltcl_CreateFileHandler;
     430          18 :     notifier.deleteFileHandlerProc = pltcl_DeleteFileHandler;
     431          18 :     notifier.initNotifierProc = pltcl_InitNotifier;
     432          18 :     notifier.finalizeNotifierProc = pltcl_FinalizeNotifier;
     433          18 :     notifier.alertNotifierProc = pltcl_AlertNotifier;
     434          18 :     notifier.serviceModeHookProc = pltcl_ServiceModeHook;
     435          18 :     Tcl_SetNotifier(&notifier);
     436             : 
     437             :     /************************************************************
     438             :      * Create the dummy hold interpreter to prevent close of
     439             :      * stdout and stderr on DeleteInterp
     440             :      ************************************************************/
     441          18 :     if ((pltcl_hold_interp = Tcl_CreateInterp()) == NULL)
     442           0 :         elog(ERROR, "could not create dummy Tcl interpreter");
     443          18 :     if (Tcl_Init(pltcl_hold_interp) == TCL_ERROR)
     444           0 :         elog(ERROR, "could not initialize dummy Tcl interpreter");
     445             : 
     446             :     /************************************************************
     447             :      * Create the hash table for working interpreters
     448             :      ************************************************************/
     449          18 :     hash_ctl.keysize = sizeof(Oid);
     450          18 :     hash_ctl.entrysize = sizeof(pltcl_interp_desc);
     451          18 :     pltcl_interp_htab = hash_create("PL/Tcl interpreters",
     452             :                                     8,
     453             :                                     &hash_ctl,
     454             :                                     HASH_ELEM | HASH_BLOBS);
     455             : 
     456             :     /************************************************************
     457             :      * Create the hash table for function lookup
     458             :      ************************************************************/
     459          18 :     hash_ctl.keysize = sizeof(pltcl_proc_key);
     460          18 :     hash_ctl.entrysize = sizeof(pltcl_proc_ptr);
     461          18 :     pltcl_proc_htab = hash_create("PL/Tcl functions",
     462             :                                   100,
     463             :                                   &hash_ctl,
     464             :                                   HASH_ELEM | HASH_BLOBS);
     465             : 
     466             :     /************************************************************
     467             :      * Define PL/Tcl's custom GUCs
     468             :      ************************************************************/
     469          18 :     DefineCustomStringVariable("pltcl.start_proc",
     470             :                                gettext_noop("PL/Tcl function to call once when pltcl is first used."),
     471             :                                NULL,
     472             :                                &pltcl_start_proc,
     473             :                                NULL,
     474             :                                PGC_SUSET, 0,
     475             :                                NULL, NULL, NULL);
     476          18 :     DefineCustomStringVariable("pltclu.start_proc",
     477             :                                gettext_noop("PL/TclU function to call once when pltclu is first used."),
     478             :                                NULL,
     479             :                                &pltclu_start_proc,
     480             :                                NULL,
     481             :                                PGC_SUSET, 0,
     482             :                                NULL, NULL, NULL);
     483             : 
     484          18 :     MarkGUCPrefixReserved("pltcl");
     485          18 :     MarkGUCPrefixReserved("pltclu");
     486             : 
     487          18 :     pltcl_pm_init_done = true;
     488             : }
     489             : 
     490             : /**********************************************************************
     491             :  * pltcl_init_interp() - initialize a new Tcl interpreter
     492             :  **********************************************************************/
     493             : static void
     494          22 : pltcl_init_interp(pltcl_interp_desc *interp_desc, Oid prolang, bool pltrusted)
     495             : {
     496             :     Tcl_Interp *interp;
     497             :     char        interpname[32];
     498             : 
     499             :     /************************************************************
     500             :      * Create the Tcl interpreter subsidiary to pltcl_hold_interp.
     501             :      * Note: Tcl automatically does Tcl_Init in the untrusted case,
     502             :      * and it's not wanted in the trusted case.
     503             :      ************************************************************/
     504          22 :     snprintf(interpname, sizeof(interpname), "subsidiary_%u", interp_desc->user_id);
     505          22 :     if ((interp = Tcl_CreateSlave(pltcl_hold_interp, interpname,
     506             :                                   pltrusted ? 1 : 0)) == NULL)
     507           0 :         elog(ERROR, "could not create subsidiary Tcl interpreter");
     508             : 
     509             :     /************************************************************
     510             :      * Initialize the query hash table associated with interpreter
     511             :      ************************************************************/
     512          22 :     Tcl_InitHashTable(&interp_desc->query_hash, TCL_STRING_KEYS);
     513             : 
     514             :     /************************************************************
     515             :      * Install the commands for SPI support in the interpreter
     516             :      ************************************************************/
     517          22 :     Tcl_CreateObjCommand(interp, "elog",
     518             :                          pltcl_elog, NULL, NULL);
     519          22 :     Tcl_CreateObjCommand(interp, "quote",
     520             :                          pltcl_quote, NULL, NULL);
     521          22 :     Tcl_CreateObjCommand(interp, "argisnull",
     522             :                          pltcl_argisnull, NULL, NULL);
     523          22 :     Tcl_CreateObjCommand(interp, "return_null",
     524             :                          pltcl_returnnull, NULL, NULL);
     525          22 :     Tcl_CreateObjCommand(interp, "return_next",
     526             :                          pltcl_returnnext, NULL, NULL);
     527          22 :     Tcl_CreateObjCommand(interp, "spi_exec",
     528             :                          pltcl_SPI_execute, NULL, NULL);
     529          22 :     Tcl_CreateObjCommand(interp, "spi_prepare",
     530             :                          pltcl_SPI_prepare, NULL, NULL);
     531          22 :     Tcl_CreateObjCommand(interp, "spi_execp",
     532             :                          pltcl_SPI_execute_plan, NULL, NULL);
     533          22 :     Tcl_CreateObjCommand(interp, "subtransaction",
     534             :                          pltcl_subtransaction, NULL, NULL);
     535          22 :     Tcl_CreateObjCommand(interp, "commit",
     536             :                          pltcl_commit, NULL, NULL);
     537          22 :     Tcl_CreateObjCommand(interp, "rollback",
     538             :                          pltcl_rollback, NULL, NULL);
     539             : 
     540             :     /************************************************************
     541             :      * Call the appropriate start_proc, if there is one.
     542             :      *
     543             :      * We must set interp_desc->interp before the call, else the start_proc
     544             :      * won't find the interpreter it's supposed to use.  But, if the
     545             :      * start_proc fails, we want to abandon use of the interpreter.
     546             :      ************************************************************/
     547          22 :     PG_TRY();
     548             :     {
     549          22 :         interp_desc->interp = interp;
     550          22 :         call_pltcl_start_proc(prolang, pltrusted);
     551             :     }
     552           6 :     PG_CATCH();
     553             :     {
     554           6 :         interp_desc->interp = NULL;
     555           6 :         Tcl_DeleteInterp(interp);
     556           6 :         PG_RE_THROW();
     557             :     }
     558          16 :     PG_END_TRY();
     559          16 : }
     560             : 
     561             : /**********************************************************************
     562             :  * pltcl_fetch_interp() - fetch the Tcl interpreter to use for a function
     563             :  *
     564             :  * This also takes care of any on-first-use initialization required.
     565             :  **********************************************************************/
     566             : static pltcl_interp_desc *
     567         130 : pltcl_fetch_interp(Oid prolang, bool pltrusted)
     568             : {
     569             :     Oid         user_id;
     570             :     pltcl_interp_desc *interp_desc;
     571             :     bool        found;
     572             : 
     573             :     /* Find or create the interpreter hashtable entry for this userid */
     574         130 :     if (pltrusted)
     575         130 :         user_id = GetUserId();
     576             :     else
     577           0 :         user_id = InvalidOid;
     578             : 
     579         130 :     interp_desc = hash_search(pltcl_interp_htab, &user_id,
     580             :                               HASH_ENTER,
     581             :                               &found);
     582         130 :     if (!found)
     583          16 :         interp_desc->interp = NULL;
     584             : 
     585             :     /* If we haven't yet successfully made an interpreter, try to do that */
     586         130 :     if (!interp_desc->interp)
     587          22 :         pltcl_init_interp(interp_desc, prolang, pltrusted);
     588             : 
     589         124 :     return interp_desc;
     590             : }
     591             : 
     592             : 
     593             : /**********************************************************************
     594             :  * call_pltcl_start_proc()   - Call user-defined initialization proc, if any
     595             :  **********************************************************************/
     596             : static void
     597          22 : call_pltcl_start_proc(Oid prolang, bool pltrusted)
     598             : {
     599          22 :     LOCAL_FCINFO(fcinfo, 0);
     600             :     char       *start_proc;
     601             :     const char *gucname;
     602             :     ErrorContextCallback errcallback;
     603             :     List       *namelist;
     604             :     Oid         procOid;
     605             :     HeapTuple   procTup;
     606             :     Form_pg_proc procStruct;
     607             :     AclResult   aclresult;
     608             :     FmgrInfo    finfo;
     609             :     PgStat_FunctionCallUsage fcusage;
     610             : 
     611             :     /* select appropriate GUC */
     612          22 :     start_proc = pltrusted ? pltcl_start_proc : pltclu_start_proc;
     613          22 :     gucname = pltrusted ? "pltcl.start_proc" : "pltclu.start_proc";
     614             : 
     615             :     /* Nothing to do if it's empty or unset */
     616          22 :     if (start_proc == NULL || start_proc[0] == '\0')
     617          14 :         return;
     618             : 
     619             :     /* Set up errcontext callback to make errors more helpful */
     620           8 :     errcallback.callback = start_proc_error_callback;
     621           8 :     errcallback.arg = unconstify(char *, gucname);
     622           8 :     errcallback.previous = error_context_stack;
     623           8 :     error_context_stack = &errcallback;
     624             : 
     625             :     /* Parse possibly-qualified identifier and look up the function */
     626           8 :     namelist = stringToQualifiedNameList(start_proc, NULL);
     627           8 :     procOid = LookupFuncName(namelist, 0, NULL, false);
     628             : 
     629             :     /* Current user must have permission to call function */
     630           4 :     aclresult = object_aclcheck(ProcedureRelationId, procOid, GetUserId(), ACL_EXECUTE);
     631           4 :     if (aclresult != ACLCHECK_OK)
     632           0 :         aclcheck_error(aclresult, OBJECT_FUNCTION, start_proc);
     633             : 
     634             :     /* Get the function's pg_proc entry */
     635           4 :     procTup = SearchSysCache1(PROCOID, ObjectIdGetDatum(procOid));
     636           4 :     if (!HeapTupleIsValid(procTup))
     637           0 :         elog(ERROR, "cache lookup failed for function %u", procOid);
     638           4 :     procStruct = (Form_pg_proc) GETSTRUCT(procTup);
     639             : 
     640             :     /* It must be same language as the function we're currently calling */
     641           4 :     if (procStruct->prolang != prolang)
     642           0 :         ereport(ERROR,
     643             :                 (errcode(ERRCODE_OBJECT_NOT_IN_PREREQUISITE_STATE),
     644             :                  errmsg("function \"%s\" is in the wrong language",
     645             :                         start_proc)));
     646             : 
     647             :     /*
     648             :      * It must not be SECURITY DEFINER, either.  This together with the
     649             :      * language match check ensures that the function will execute in the same
     650             :      * Tcl interpreter we just finished initializing.
     651             :      */
     652           4 :     if (procStruct->prosecdef)
     653           2 :         ereport(ERROR,
     654             :                 (errcode(ERRCODE_OBJECT_NOT_IN_PREREQUISITE_STATE),
     655             :                  errmsg("function \"%s\" must not be SECURITY DEFINER",
     656             :                         start_proc)));
     657             : 
     658             :     /* A-OK */
     659           2 :     ReleaseSysCache(procTup);
     660             : 
     661             :     /*
     662             :      * Call the function using the normal SQL function call mechanism.  We
     663             :      * could perhaps cheat and jump directly to pltcl_handler(), but it seems
     664             :      * better to do it this way so that the call is exposed to, eg, call
     665             :      * statistics collection.
     666             :      */
     667           2 :     InvokeFunctionExecuteHook(procOid);
     668           2 :     fmgr_info(procOid, &finfo);
     669           2 :     InitFunctionCallInfoData(*fcinfo, &finfo,
     670             :                              0,
     671             :                              InvalidOid, NULL, NULL);
     672           2 :     pgstat_init_function_usage(fcinfo, &fcusage);
     673           2 :     (void) FunctionCallInvoke(fcinfo);
     674           2 :     pgstat_end_function_usage(&fcusage, true);
     675             : 
     676             :     /* Pop the error context stack */
     677           2 :     error_context_stack = errcallback.previous;
     678             : }
     679             : 
     680             : /*
     681             :  * Error context callback for errors occurring during start_proc processing.
     682             :  */
     683             : static void
     684           8 : start_proc_error_callback(void *arg)
     685             : {
     686           8 :     const char *gucname = (const char *) arg;
     687             : 
     688             :     /* translator: %s is "pltcl.start_proc" or "pltclu.start_proc" */
     689           8 :     errcontext("processing %s parameter", gucname);
     690           8 : }
     691             : 
     692             : 
     693             : /**********************************************************************
     694             :  * pltcl_call_handler       - This is the only visible function
     695             :  *                of the PL interpreter. The PostgreSQL
     696             :  *                function manager and trigger manager
     697             :  *                call this function for execution of
     698             :  *                PL/Tcl procedures.
     699             :  **********************************************************************/
     700          18 : PG_FUNCTION_INFO_V1(pltcl_call_handler);
     701             : 
     702             : /* keep non-static */
     703             : Datum
     704         446 : pltcl_call_handler(PG_FUNCTION_ARGS)
     705             : {
     706         446 :     return pltcl_handler(fcinfo, true);
     707             : }
     708             : 
     709             : /*
     710             :  * Alternative handler for unsafe functions
     711             :  */
     712           0 : PG_FUNCTION_INFO_V1(pltclu_call_handler);
     713             : 
     714             : /* keep non-static */
     715             : Datum
     716           0 : pltclu_call_handler(PG_FUNCTION_ARGS)
     717             : {
     718           0 :     return pltcl_handler(fcinfo, false);
     719             : }
     720             : 
     721             : 
     722             : /**********************************************************************
     723             :  * pltcl_handler()      - Handler for function and trigger calls, for
     724             :  *                        both trusted and untrusted interpreters.
     725             :  **********************************************************************/
     726             : static Datum
     727         446 : pltcl_handler(PG_FUNCTION_ARGS, bool pltrusted)
     728             : {
     729         446 :     Datum       retval = (Datum) 0;
     730             :     pltcl_call_state current_call_state;
     731             :     pltcl_call_state *save_call_state;
     732             : 
     733             :     /*
     734             :      * Initialize current_call_state to nulls/zeroes; in particular, set its
     735             :      * prodesc pointer to null.  Anything that sets it non-null should
     736             :      * increase the prodesc's fn_refcount at the same time.  We'll decrease
     737             :      * the refcount, and then delete the prodesc if it's no longer referenced,
     738             :      * on the way out of this function.  This ensures that prodescs live as
     739             :      * long as needed even if somebody replaces the originating pg_proc row
     740             :      * while they're executing.
     741             :      */
     742         446 :     memset(&current_call_state, 0, sizeof(current_call_state));
     743             : 
     744             :     /*
     745             :      * Ensure that static pointer is saved/restored properly
     746             :      */
     747         446 :     save_call_state = pltcl_current_call_state;
     748         446 :     pltcl_current_call_state = &current_call_state;
     749             : 
     750         446 :     PG_TRY();
     751             :     {
     752             :         /*
     753             :          * Determine if called as function or trigger and call appropriate
     754             :          * subhandler
     755             :          */
     756         446 :         if (CALLED_AS_TRIGGER(fcinfo))
     757             :         {
     758             :             /* invoke the trigger handler */
     759         116 :             retval = PointerGetDatum(pltcl_trigger_handler(fcinfo,
     760             :                                                            &current_call_state,
     761             :                                                            pltrusted));
     762             :         }
     763         330 :         else if (CALLED_AS_EVENT_TRIGGER(fcinfo))
     764             :         {
     765             :             /* invoke the event trigger handler */
     766          20 :             pltcl_event_trigger_handler(fcinfo, &current_call_state, pltrusted);
     767          20 :             retval = (Datum) 0;
     768             :         }
     769             :         else
     770             :         {
     771             :             /* invoke the regular function handler */
     772         310 :             current_call_state.fcinfo = fcinfo;
     773         310 :             retval = pltcl_func_handler(fcinfo, &current_call_state, pltrusted);
     774             :         }
     775             :     }
     776         110 :     PG_FINALLY();
     777             :     {
     778             :         /* Restore static pointer, then clean up the prodesc refcount if any */
     779             :         /*
     780             :          * (We're being paranoid in case an error is thrown in context
     781             :          * deletion)
     782             :          */
     783         446 :         pltcl_current_call_state = save_call_state;
     784         446 :         if (current_call_state.prodesc != NULL)
     785             :         {
     786             :             Assert(current_call_state.prodesc->fn_refcount > 0);
     787         440 :             if (--current_call_state.prodesc->fn_refcount == 0)
     788           2 :                 MemoryContextDelete(current_call_state.prodesc->fn_cxt);
     789             :         }
     790             :     }
     791         446 :     PG_END_TRY();
     792             : 
     793         336 :     return retval;
     794             : }
     795             : 
     796             : 
     797             : /**********************************************************************
     798             :  * pltcl_func_handler()     - Handler for regular function calls
     799             :  **********************************************************************/
     800             : static Datum
     801         310 : pltcl_func_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state,
     802             :                    bool pltrusted)
     803             : {
     804             :     bool        nonatomic;
     805             :     pltcl_proc_desc *prodesc;
     806             :     Tcl_Interp *volatile interp;
     807             :     Tcl_Obj    *tcl_cmd;
     808             :     int         i;
     809             :     int         tcl_rc;
     810             :     Datum       retval;
     811             : 
     812         692 :     nonatomic = fcinfo->context &&
     813         336 :         IsA(fcinfo->context, CallContext) &&
     814          26 :         !castNode(CallContext, fcinfo->context)->atomic;
     815             : 
     816             :     /* Connect to SPI manager */
     817         310 :     SPI_connect_ext(nonatomic ? SPI_OPT_NONATOMIC : 0);
     818             : 
     819             :     /* Find or compile the function */
     820         310 :     prodesc = compile_pltcl_function(fcinfo->flinfo->fn_oid, InvalidOid,
     821             :                                      false, pltrusted);
     822             : 
     823         304 :     call_state->prodesc = prodesc;
     824         304 :     prodesc->fn_refcount++;
     825             : 
     826         304 :     interp = prodesc->interp_desc->interp;
     827             : 
     828             :     /*
     829             :      * If we're a SRF, check caller can handle materialize mode, and save
     830             :      * relevant info into call_state.  We must ensure that the returned
     831             :      * tuplestore is owned by the caller's context, even if we first create it
     832             :      * inside a subtransaction.
     833             :      */
     834         304 :     if (prodesc->fn_retisset)
     835             :     {
     836          10 :         ReturnSetInfo *rsi = (ReturnSetInfo *) fcinfo->resultinfo;
     837             : 
     838          10 :         if (!rsi || !IsA(rsi, ReturnSetInfo))
     839           0 :             ereport(ERROR,
     840             :                     (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
     841             :                      errmsg("set-valued function called in context that cannot accept a set")));
     842             : 
     843          10 :         if (!(rsi->allowedModes & SFRM_Materialize))
     844           0 :             ereport(ERROR,
     845             :                     (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
     846             :                      errmsg("materialize mode required, but it is not allowed in this context")));
     847             : 
     848          10 :         call_state->rsi = rsi;
     849          10 :         call_state->tuple_store_cxt = rsi->econtext->ecxt_per_query_memory;
     850          10 :         call_state->tuple_store_owner = CurrentResourceOwner;
     851             :     }
     852             : 
     853             :     /************************************************************
     854             :      * Create the tcl command to call the internal
     855             :      * proc in the Tcl interpreter
     856             :      ************************************************************/
     857         304 :     tcl_cmd = Tcl_NewObj();
     858         304 :     Tcl_ListObjAppendElement(NULL, tcl_cmd,
     859         304 :                              Tcl_NewStringObj(prodesc->internal_proname, -1));
     860             : 
     861             :     /* We hold a refcount on tcl_cmd just to be sure it stays around */
     862         304 :     Tcl_IncrRefCount(tcl_cmd);
     863             : 
     864             :     /************************************************************
     865             :      * Add all call arguments to the command
     866             :      ************************************************************/
     867         304 :     PG_TRY();
     868             :     {
     869         700 :         for (i = 0; i < prodesc->nargs; i++)
     870             :         {
     871         396 :             if (prodesc->arg_is_rowtype[i])
     872             :             {
     873             :                 /**************************************************
     874             :                  * For tuple values, add a list for 'array set ...'
     875             :                  **************************************************/
     876          14 :                 if (fcinfo->args[i].isnull)
     877           0 :                     Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj());
     878             :                 else
     879             :                 {
     880             :                     HeapTupleHeader td;
     881             :                     Oid         tupType;
     882             :                     int32       tupTypmod;
     883             :                     TupleDesc   tupdesc;
     884             :                     HeapTupleData tmptup;
     885             :                     Tcl_Obj    *list_tmp;
     886             : 
     887          14 :                     td = DatumGetHeapTupleHeader(fcinfo->args[i].value);
     888             :                     /* Extract rowtype info and find a tupdesc */
     889          14 :                     tupType = HeapTupleHeaderGetTypeId(td);
     890          14 :                     tupTypmod = HeapTupleHeaderGetTypMod(td);
     891          14 :                     tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod);
     892             :                     /* Build a temporary HeapTuple control structure */
     893          14 :                     tmptup.t_len = HeapTupleHeaderGetDatumLength(td);
     894          14 :                     tmptup.t_data = td;
     895             : 
     896          14 :                     list_tmp = pltcl_build_tuple_argument(&tmptup, tupdesc, true);
     897          14 :                     Tcl_ListObjAppendElement(NULL, tcl_cmd, list_tmp);
     898             : 
     899          14 :                     ReleaseTupleDesc(tupdesc);
     900             :                 }
     901             :             }
     902             :             else
     903             :             {
     904             :                 /**************************************************
     905             :                  * Single values are added as string element
     906             :                  * of their external representation
     907             :                  **************************************************/
     908         382 :                 if (fcinfo->args[i].isnull)
     909           4 :                     Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj());
     910             :                 else
     911             :                 {
     912             :                     char       *tmp;
     913             : 
     914         378 :                     tmp = OutputFunctionCall(&prodesc->arg_out_func[i],
     915             :                                              fcinfo->args[i].value);
     916         378 :                     UTF_BEGIN;
     917         378 :                     Tcl_ListObjAppendElement(NULL, tcl_cmd,
     918         378 :                                              Tcl_NewStringObj(UTF_E2U(tmp), -1));
     919         378 :                     UTF_END;
     920         378 :                     pfree(tmp);
     921             :                 }
     922             :             }
     923             :         }
     924             :     }
     925           0 :     PG_CATCH();
     926             :     {
     927             :         /* Release refcount to free tcl_cmd */
     928           0 :         Tcl_DecrRefCount(tcl_cmd);
     929           0 :         PG_RE_THROW();
     930             :     }
     931         304 :     PG_END_TRY();
     932             : 
     933             :     /************************************************************
     934             :      * Call the Tcl function
     935             :      *
     936             :      * We assume no PG error can be thrown directly from this call.
     937             :      ************************************************************/
     938         304 :     tcl_rc = Tcl_EvalObjEx(interp, tcl_cmd, (TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL));
     939             : 
     940             :     /* Release refcount to free tcl_cmd (and all subsidiary objects) */
     941         304 :     Tcl_DecrRefCount(tcl_cmd);
     942             : 
     943             :     /************************************************************
     944             :      * Check for errors reported by Tcl.
     945             :      ************************************************************/
     946         304 :     if (tcl_rc != TCL_OK)
     947          76 :         throw_tcl_error(interp, prodesc->user_proname);
     948             : 
     949             :     /************************************************************
     950             :      * Disconnect from SPI manager and then create the return
     951             :      * value datum (if the input function does a palloc for it
     952             :      * this must not be allocated in the SPI memory context
     953             :      * because SPI_finish would free it).  But don't try to call
     954             :      * the result_in_func if we've been told to return a NULL;
     955             :      * the Tcl result may not be a valid value of the result type
     956             :      * in that case.
     957             :      ************************************************************/
     958         228 :     if (SPI_finish() != SPI_OK_FINISH)
     959           0 :         elog(ERROR, "SPI_finish() failed");
     960             : 
     961         228 :     if (prodesc->fn_retisset)
     962             :     {
     963           6 :         ReturnSetInfo *rsi = call_state->rsi;
     964             : 
     965             :         /* We already checked this is OK */
     966           6 :         rsi->returnMode = SFRM_Materialize;
     967             : 
     968             :         /* If we produced any tuples, send back the result */
     969           6 :         if (call_state->tuple_store)
     970             :         {
     971           6 :             rsi->setResult = call_state->tuple_store;
     972           6 :             if (call_state->ret_tupdesc)
     973             :             {
     974             :                 MemoryContext oldcxt;
     975             : 
     976           6 :                 oldcxt = MemoryContextSwitchTo(call_state->tuple_store_cxt);
     977           6 :                 rsi->setDesc = CreateTupleDescCopy(call_state->ret_tupdesc);
     978           6 :                 MemoryContextSwitchTo(oldcxt);
     979             :             }
     980             :         }
     981           6 :         retval = (Datum) 0;
     982           6 :         fcinfo->isnull = true;
     983             :     }
     984         222 :     else if (fcinfo->isnull)
     985             :     {
     986           2 :         retval = InputFunctionCall(&prodesc->result_in_func,
     987             :                                    NULL,
     988             :                                    prodesc->result_typioparam,
     989             :                                    -1);
     990             :     }
     991         220 :     else if (prodesc->fn_retistuple)
     992             :     {
     993             :         TupleDesc   td;
     994             :         HeapTuple   tup;
     995             :         Tcl_Obj    *resultObj;
     996             :         Tcl_Obj   **resultObjv;
     997             :         Tcl_Size    resultObjc;
     998             : 
     999             :         /*
    1000             :          * Set up data about result type.  XXX it's tempting to consider
    1001             :          * caching this in the prodesc, in the common case where the rowtype
    1002             :          * is determined by the function not the calling query.  But we'd have
    1003             :          * to be able to deal with ADD/DROP/ALTER COLUMN events when the
    1004             :          * result type is a named composite type, so it's not exactly trivial.
    1005             :          * Maybe worth improving someday.
    1006             :          */
    1007          32 :         switch (get_call_result_type(fcinfo, NULL, &td))
    1008             :         {
    1009          24 :             case TYPEFUNC_COMPOSITE:
    1010             :                 /* success */
    1011          24 :                 break;
    1012           6 :             case TYPEFUNC_COMPOSITE_DOMAIN:
    1013             :                 Assert(prodesc->fn_retisdomain);
    1014           6 :                 break;
    1015           2 :             case TYPEFUNC_RECORD:
    1016             :                 /* failed to determine actual type of RECORD */
    1017           2 :                 ereport(ERROR,
    1018             :                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    1019             :                          errmsg("function returning record called in context "
    1020             :                                 "that cannot accept type record")));
    1021             :                 break;
    1022           0 :             default:
    1023             :                 /* result type isn't composite? */
    1024           0 :                 elog(ERROR, "return type must be a row type");
    1025             :                 break;
    1026             :         }
    1027             : 
    1028             :         Assert(!call_state->ret_tupdesc);
    1029             :         Assert(!call_state->attinmeta);
    1030          30 :         call_state->ret_tupdesc = td;
    1031          30 :         call_state->attinmeta = TupleDescGetAttInMetadata(td);
    1032             : 
    1033             :         /* Convert function result to tuple */
    1034          30 :         resultObj = Tcl_GetObjResult(interp);
    1035          30 :         if (Tcl_ListObjGetElements(interp, resultObj, &resultObjc, &resultObjv) == TCL_ERROR)
    1036           2 :             ereport(ERROR,
    1037             :                     (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
    1038             :                      errmsg("could not parse function return value: %s",
    1039             :                             utf_u2e(Tcl_GetStringResult(interp)))));
    1040             : 
    1041          28 :         tup = pltcl_build_tuple_result(interp, resultObjv, resultObjc,
    1042             :                                        call_state);
    1043          20 :         retval = HeapTupleGetDatum(tup);
    1044             :     }
    1045             :     else
    1046         188 :         retval = InputFunctionCall(&prodesc->result_in_func,
    1047             :                                    utf_u2e(Tcl_GetStringResult(interp)),
    1048             :                                    prodesc->result_typioparam,
    1049             :                                    -1);
    1050             : 
    1051         216 :     return retval;
    1052             : }
    1053             : 
    1054             : 
    1055             : /**********************************************************************
    1056             :  * pltcl_trigger_handler()  - Handler for trigger calls
    1057             :  **********************************************************************/
    1058             : static HeapTuple
    1059         116 : pltcl_trigger_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state,
    1060             :                       bool pltrusted)
    1061             : {
    1062             :     pltcl_proc_desc *prodesc;
    1063             :     Tcl_Interp *volatile interp;
    1064         116 :     TriggerData *trigdata = (TriggerData *) fcinfo->context;
    1065             :     char       *stroid;
    1066             :     TupleDesc   tupdesc;
    1067             :     volatile HeapTuple rettup;
    1068             :     Tcl_Obj    *tcl_cmd;
    1069             :     Tcl_Obj    *tcl_trigtup;
    1070             :     int         tcl_rc;
    1071             :     int         i;
    1072             :     const char *result;
    1073             :     Tcl_Size    result_Objc;
    1074             :     Tcl_Obj   **result_Objv;
    1075             :     int         rc PG_USED_FOR_ASSERTS_ONLY;
    1076             : 
    1077         116 :     call_state->trigdata = trigdata;
    1078             : 
    1079             :     /* Connect to SPI manager */
    1080         116 :     SPI_connect();
    1081             : 
    1082             :     /* Make transition tables visible to this SPI connection */
    1083         116 :     rc = SPI_register_trigger_data(trigdata);
    1084             :     Assert(rc >= 0);
    1085             : 
    1086             :     /* Find or compile the function */
    1087         232 :     prodesc = compile_pltcl_function(fcinfo->flinfo->fn_oid,
    1088         116 :                                      RelationGetRelid(trigdata->tg_relation),
    1089             :                                      false, /* not an event trigger */
    1090             :                                      pltrusted);
    1091             : 
    1092         116 :     call_state->prodesc = prodesc;
    1093         116 :     prodesc->fn_refcount++;
    1094             : 
    1095         116 :     interp = prodesc->interp_desc->interp;
    1096             : 
    1097         116 :     tupdesc = RelationGetDescr(trigdata->tg_relation);
    1098             : 
    1099             :     /************************************************************
    1100             :      * Create the tcl command to call the internal
    1101             :      * proc in the interpreter
    1102             :      ************************************************************/
    1103         116 :     tcl_cmd = Tcl_NewObj();
    1104         116 :     Tcl_IncrRefCount(tcl_cmd);
    1105             : 
    1106         116 :     PG_TRY();
    1107             :     {
    1108             :         /* The procedure name (note this is all ASCII, so no utf_e2u) */
    1109         116 :         Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1110         116 :                                  Tcl_NewStringObj(prodesc->internal_proname, -1));
    1111             : 
    1112             :         /* The trigger name for argument TG_name */
    1113         116 :         Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1114         116 :                                  Tcl_NewStringObj(utf_e2u(trigdata->tg_trigger->tgname), -1));
    1115             : 
    1116             :         /* The oid of the trigger relation for argument TG_relid */
    1117             :         /* Consider not converting to a string for more performance? */
    1118         116 :         stroid = DatumGetCString(DirectFunctionCall1(oidout,
    1119             :                                                      ObjectIdGetDatum(trigdata->tg_relation->rd_id)));
    1120         116 :         Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1121             :                                  Tcl_NewStringObj(stroid, -1));
    1122         116 :         pfree(stroid);
    1123             : 
    1124             :         /* The name of the table the trigger is acting on: TG_table_name */
    1125         116 :         stroid = SPI_getrelname(trigdata->tg_relation);
    1126         116 :         Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1127         116 :                                  Tcl_NewStringObj(utf_e2u(stroid), -1));
    1128         116 :         pfree(stroid);
    1129             : 
    1130             :         /* The schema of the table the trigger is acting on: TG_table_schema */
    1131         116 :         stroid = SPI_getnspname(trigdata->tg_relation);
    1132         116 :         Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1133         116 :                                  Tcl_NewStringObj(utf_e2u(stroid), -1));
    1134         116 :         pfree(stroid);
    1135             : 
    1136             :         /* A list of attribute names for argument TG_relatts */
    1137         116 :         tcl_trigtup = Tcl_NewObj();
    1138         116 :         Tcl_ListObjAppendElement(NULL, tcl_trigtup, Tcl_NewObj());
    1139         530 :         for (i = 0; i < tupdesc->natts; i++)
    1140             :         {
    1141         414 :             Form_pg_attribute att = TupleDescAttr(tupdesc, i);
    1142             : 
    1143         414 :             if (att->attisdropped)
    1144          26 :                 Tcl_ListObjAppendElement(NULL, tcl_trigtup, Tcl_NewObj());
    1145             :             else
    1146         388 :                 Tcl_ListObjAppendElement(NULL, tcl_trigtup,
    1147         388 :                                          Tcl_NewStringObj(utf_e2u(NameStr(att->attname)), -1));
    1148             :         }
    1149         116 :         Tcl_ListObjAppendElement(NULL, tcl_cmd, tcl_trigtup);
    1150             : 
    1151             :         /* The when part of the event for TG_when */
    1152         116 :         if (TRIGGER_FIRED_BEFORE(trigdata->tg_event))
    1153          94 :             Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1154             :                                      Tcl_NewStringObj("BEFORE", -1));
    1155          22 :         else if (TRIGGER_FIRED_AFTER(trigdata->tg_event))
    1156          16 :             Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1157             :                                      Tcl_NewStringObj("AFTER", -1));
    1158           6 :         else if (TRIGGER_FIRED_INSTEAD(trigdata->tg_event))
    1159           6 :             Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1160             :                                      Tcl_NewStringObj("INSTEAD OF", -1));
    1161             :         else
    1162           0 :             elog(ERROR, "unrecognized WHEN tg_event: %u", trigdata->tg_event);
    1163             : 
    1164             :         /* The level part of the event for TG_level */
    1165         116 :         if (TRIGGER_FIRED_FOR_ROW(trigdata->tg_event))
    1166             :         {
    1167         100 :             Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1168             :                                      Tcl_NewStringObj("ROW", -1));
    1169             : 
    1170             :             /*
    1171             :              * Now the command part of the event for TG_op and data for NEW
    1172             :              * and OLD
    1173             :              *
    1174             :              * Note: In BEFORE trigger, stored generated columns are not
    1175             :              * computed yet, so don't make them accessible in NEW row.
    1176             :              */
    1177         100 :             if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
    1178             :             {
    1179          60 :                 Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1180             :                                          Tcl_NewStringObj("INSERT", -1));
    1181             : 
    1182          60 :                 Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1183             :                                          pltcl_build_tuple_argument(trigdata->tg_trigtuple,
    1184             :                                                                     tupdesc,
    1185          60 :                                                                     !TRIGGER_FIRED_BEFORE(trigdata->tg_event)));
    1186          60 :                 Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj());
    1187             : 
    1188          60 :                 rettup = trigdata->tg_trigtuple;
    1189             :             }
    1190          40 :             else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
    1191             :             {
    1192          16 :                 Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1193             :                                          Tcl_NewStringObj("DELETE", -1));
    1194             : 
    1195          16 :                 Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj());
    1196          16 :                 Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1197             :                                          pltcl_build_tuple_argument(trigdata->tg_trigtuple,
    1198             :                                                                     tupdesc,
    1199             :                                                                     true));
    1200             : 
    1201          16 :                 rettup = trigdata->tg_trigtuple;
    1202             :             }
    1203          24 :             else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
    1204             :             {
    1205          24 :                 Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1206             :                                          Tcl_NewStringObj("UPDATE", -1));
    1207             : 
    1208          24 :                 Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1209             :                                          pltcl_build_tuple_argument(trigdata->tg_newtuple,
    1210             :                                                                     tupdesc,
    1211          24 :                                                                     !TRIGGER_FIRED_BEFORE(trigdata->tg_event)));
    1212          24 :                 Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1213             :                                          pltcl_build_tuple_argument(trigdata->tg_trigtuple,
    1214             :                                                                     tupdesc,
    1215             :                                                                     true));
    1216             : 
    1217          24 :                 rettup = trigdata->tg_newtuple;
    1218             :             }
    1219             :             else
    1220           0 :                 elog(ERROR, "unrecognized OP tg_event: %u", trigdata->tg_event);
    1221             :         }
    1222          16 :         else if (TRIGGER_FIRED_FOR_STATEMENT(trigdata->tg_event))
    1223             :         {
    1224          16 :             Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1225             :                                      Tcl_NewStringObj("STATEMENT", -1));
    1226             : 
    1227          16 :             if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
    1228           6 :                 Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1229             :                                          Tcl_NewStringObj("INSERT", -1));
    1230          10 :             else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
    1231           2 :                 Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1232             :                                          Tcl_NewStringObj("DELETE", -1));
    1233           8 :             else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
    1234           6 :                 Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1235             :                                          Tcl_NewStringObj("UPDATE", -1));
    1236           2 :             else if (TRIGGER_FIRED_BY_TRUNCATE(trigdata->tg_event))
    1237           2 :                 Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1238             :                                          Tcl_NewStringObj("TRUNCATE", -1));
    1239             :             else
    1240           0 :                 elog(ERROR, "unrecognized OP tg_event: %u", trigdata->tg_event);
    1241             : 
    1242          16 :             Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj());
    1243          16 :             Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj());
    1244             : 
    1245          16 :             rettup = (HeapTuple) NULL;
    1246             :         }
    1247             :         else
    1248           0 :             elog(ERROR, "unrecognized LEVEL tg_event: %u", trigdata->tg_event);
    1249             : 
    1250             :         /* Finally append the arguments from CREATE TRIGGER */
    1251         270 :         for (i = 0; i < trigdata->tg_trigger->tgnargs; i++)
    1252         154 :             Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1253         154 :                                      Tcl_NewStringObj(utf_e2u(trigdata->tg_trigger->tgargs[i]), -1));
    1254             :     }
    1255           0 :     PG_CATCH();
    1256             :     {
    1257           0 :         Tcl_DecrRefCount(tcl_cmd);
    1258           0 :         PG_RE_THROW();
    1259             :     }
    1260         116 :     PG_END_TRY();
    1261             : 
    1262             :     /************************************************************
    1263             :      * Call the Tcl function
    1264             :      *
    1265             :      * We assume no PG error can be thrown directly from this call.
    1266             :      ************************************************************/
    1267         116 :     tcl_rc = Tcl_EvalObjEx(interp, tcl_cmd, (TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL));
    1268             : 
    1269             :     /* Release refcount to free tcl_cmd (and all subsidiary objects) */
    1270         116 :     Tcl_DecrRefCount(tcl_cmd);
    1271             : 
    1272             :     /************************************************************
    1273             :      * Check for errors reported by Tcl.
    1274             :      ************************************************************/
    1275         116 :     if (tcl_rc != TCL_OK)
    1276          14 :         throw_tcl_error(interp, prodesc->user_proname);
    1277             : 
    1278             :     /************************************************************
    1279             :      * Exit SPI environment.
    1280             :      ************************************************************/
    1281         102 :     if (SPI_finish() != SPI_OK_FINISH)
    1282           0 :         elog(ERROR, "SPI_finish() failed");
    1283             : 
    1284             :     /************************************************************
    1285             :      * The return value from the procedure might be one of
    1286             :      * the magic strings OK or SKIP, or a list from array get.
    1287             :      * We can check for OK or SKIP without worrying about encoding.
    1288             :      ************************************************************/
    1289         102 :     result = Tcl_GetStringResult(interp);
    1290             : 
    1291         102 :     if (strcmp(result, "OK") == 0)
    1292          80 :         return rettup;
    1293          22 :     if (strcmp(result, "SKIP") == 0)
    1294           2 :         return (HeapTuple) NULL;
    1295             : 
    1296             :     /************************************************************
    1297             :      * Otherwise, the return value should be a column name/value list
    1298             :      * specifying the modified tuple to return.
    1299             :      ************************************************************/
    1300          20 :     if (Tcl_ListObjGetElements(interp, Tcl_GetObjResult(interp),
    1301             :                                &result_Objc, &result_Objv) != TCL_OK)
    1302           0 :         ereport(ERROR,
    1303             :                 (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
    1304             :                  errmsg("could not parse trigger return value: %s",
    1305             :                         utf_u2e(Tcl_GetStringResult(interp)))));
    1306             : 
    1307             :     /* Convert function result to tuple */
    1308          20 :     rettup = pltcl_build_tuple_result(interp, result_Objv, result_Objc,
    1309             :                                       call_state);
    1310             : 
    1311          18 :     return rettup;
    1312             : }
    1313             : 
    1314             : /**********************************************************************
    1315             :  * pltcl_event_trigger_handler()    - Handler for event trigger calls
    1316             :  **********************************************************************/
    1317             : static void
    1318          20 : pltcl_event_trigger_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state,
    1319             :                             bool pltrusted)
    1320             : {
    1321             :     pltcl_proc_desc *prodesc;
    1322             :     Tcl_Interp *volatile interp;
    1323          20 :     EventTriggerData *tdata = (EventTriggerData *) fcinfo->context;
    1324             :     Tcl_Obj    *tcl_cmd;
    1325             :     int         tcl_rc;
    1326             : 
    1327             :     /* Connect to SPI manager */
    1328          20 :     SPI_connect();
    1329             : 
    1330             :     /* Find or compile the function */
    1331          20 :     prodesc = compile_pltcl_function(fcinfo->flinfo->fn_oid,
    1332             :                                      InvalidOid, true, pltrusted);
    1333             : 
    1334          20 :     call_state->prodesc = prodesc;
    1335          20 :     prodesc->fn_refcount++;
    1336             : 
    1337          20 :     interp = prodesc->interp_desc->interp;
    1338             : 
    1339             :     /* Create the tcl command and call the internal proc */
    1340          20 :     tcl_cmd = Tcl_NewObj();
    1341          20 :     Tcl_IncrRefCount(tcl_cmd);
    1342          20 :     Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1343          20 :                              Tcl_NewStringObj(prodesc->internal_proname, -1));
    1344          20 :     Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1345          20 :                              Tcl_NewStringObj(utf_e2u(tdata->event), -1));
    1346          20 :     Tcl_ListObjAppendElement(NULL, tcl_cmd,
    1347          20 :                              Tcl_NewStringObj(utf_e2u(GetCommandTagName(tdata->tag)),
    1348             :                                               -1));
    1349             : 
    1350          20 :     tcl_rc = Tcl_EvalObjEx(interp, tcl_cmd, (TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL));
    1351             : 
    1352             :     /* Release refcount to free tcl_cmd (and all subsidiary objects) */
    1353          20 :     Tcl_DecrRefCount(tcl_cmd);
    1354             : 
    1355             :     /* Check for errors reported by Tcl. */
    1356          20 :     if (tcl_rc != TCL_OK)
    1357           0 :         throw_tcl_error(interp, prodesc->user_proname);
    1358             : 
    1359          20 :     if (SPI_finish() != SPI_OK_FINISH)
    1360           0 :         elog(ERROR, "SPI_finish() failed");
    1361          20 : }
    1362             : 
    1363             : 
    1364             : /**********************************************************************
    1365             :  * throw_tcl_error  - ereport an error returned from the Tcl interpreter
    1366             :  *
    1367             :  * Caution: use this only to report errors returned by Tcl_EvalObjEx() or
    1368             :  * other variants of Tcl_Eval().  Other functions may not fill "errorInfo",
    1369             :  * so it could be unset or even contain details from some previous error.
    1370             :  **********************************************************************/
    1371             : static void
    1372          90 : throw_tcl_error(Tcl_Interp *interp, const char *proname)
    1373             : {
    1374             :     /*
    1375             :      * Caution is needed here because Tcl_GetVar could overwrite the
    1376             :      * interpreter result (even though it's not really supposed to), and we
    1377             :      * can't control the order of evaluation of ereport arguments. Hence, make
    1378             :      * real sure we have our own copy of the result string before invoking
    1379             :      * Tcl_GetVar.
    1380             :      */
    1381             :     char       *emsg;
    1382             :     char       *econtext;
    1383             :     int         emsglen;
    1384             : 
    1385          90 :     emsg = pstrdup(utf_u2e(Tcl_GetStringResult(interp)));
    1386          90 :     econtext = utf_u2e(Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY));
    1387             : 
    1388             :     /*
    1389             :      * Typically, the first line of errorInfo matches the primary error
    1390             :      * message (the interpreter result); don't print that twice if so.
    1391             :      */
    1392          90 :     emsglen = strlen(emsg);
    1393          90 :     if (strncmp(emsg, econtext, emsglen) == 0 &&
    1394          90 :         econtext[emsglen] == '\n')
    1395          90 :         econtext += emsglen + 1;
    1396             : 
    1397             :     /* Tcl likes to prefix the next line with some spaces, too */
    1398         450 :     while (*econtext == ' ')
    1399         360 :         econtext++;
    1400             : 
    1401             :     /* Note: proname will already contain quoting if any is needed */
    1402          90 :     ereport(ERROR,
    1403             :             (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
    1404             :              errmsg("%s", emsg),
    1405             :              errcontext("%s\nin PL/Tcl function %s",
    1406             :                         econtext, proname)));
    1407             : }
    1408             : 
    1409             : 
    1410             : /**********************************************************************
    1411             :  * compile_pltcl_function   - compile (or hopefully just look up) function
    1412             :  *
    1413             :  * tgreloid is the OID of the relation when compiling a trigger, or zero
    1414             :  * (InvalidOid) when compiling a plain function.
    1415             :  **********************************************************************/
    1416             : static pltcl_proc_desc *
    1417         446 : compile_pltcl_function(Oid fn_oid, Oid tgreloid,
    1418             :                        bool is_event_trigger, bool pltrusted)
    1419             : {
    1420             :     HeapTuple   procTup;
    1421             :     Form_pg_proc procStruct;
    1422             :     pltcl_proc_key proc_key;
    1423             :     pltcl_proc_ptr *proc_ptr;
    1424             :     bool        found;
    1425             :     pltcl_proc_desc *prodesc;
    1426             :     pltcl_proc_desc *old_prodesc;
    1427         446 :     volatile MemoryContext proc_cxt = NULL;
    1428             :     Tcl_DString proc_internal_def;
    1429             :     Tcl_DString proc_internal_name;
    1430             :     Tcl_DString proc_internal_body;
    1431             : 
    1432             :     /* We'll need the pg_proc tuple in any case... */
    1433         446 :     procTup = SearchSysCache1(PROCOID, ObjectIdGetDatum(fn_oid));
    1434         446 :     if (!HeapTupleIsValid(procTup))
    1435           0 :         elog(ERROR, "cache lookup failed for function %u", fn_oid);
    1436         446 :     procStruct = (Form_pg_proc) GETSTRUCT(procTup);
    1437             : 
    1438             :     /*
    1439             :      * Look up function in pltcl_proc_htab; if it's not there, create an entry
    1440             :      * and set the entry's proc_ptr to NULL.
    1441             :      */
    1442         446 :     proc_key.proc_id = fn_oid;
    1443         446 :     proc_key.is_trigger = OidIsValid(tgreloid);
    1444         446 :     proc_key.user_id = pltrusted ? GetUserId() : InvalidOid;
    1445             : 
    1446         446 :     proc_ptr = hash_search(pltcl_proc_htab, &proc_key,
    1447             :                            HASH_ENTER,
    1448             :                            &found);
    1449         446 :     if (!found)
    1450         120 :         proc_ptr->proc_ptr = NULL;
    1451             : 
    1452         446 :     prodesc = proc_ptr->proc_ptr;
    1453             : 
    1454             :     /************************************************************
    1455             :      * If it's present, must check whether it's still up to date.
    1456             :      * This is needed because CREATE OR REPLACE FUNCTION can modify the
    1457             :      * function's pg_proc entry without changing its OID.
    1458             :      ************************************************************/
    1459         446 :     if (prodesc != NULL &&
    1460         320 :         prodesc->internal_proname != NULL &&
    1461         320 :         prodesc->fn_xmin == HeapTupleHeaderGetRawXmin(procTup->t_data) &&
    1462         316 :         ItemPointerEquals(&prodesc->fn_tid, &procTup->t_self))
    1463             :     {
    1464             :         /* It's still up-to-date, so we can use it */
    1465         316 :         ReleaseSysCache(procTup);
    1466         316 :         return prodesc;
    1467             :     }
    1468             : 
    1469             :     /************************************************************
    1470             :      * If we haven't found it in the hashtable, we analyze
    1471             :      * the functions arguments and returntype and store
    1472             :      * the in-/out-functions in the prodesc block and create
    1473             :      * a new hashtable entry for it.
    1474             :      *
    1475             :      * Then we load the procedure into the Tcl interpreter.
    1476             :      ************************************************************/
    1477         130 :     Tcl_DStringInit(&proc_internal_def);
    1478         130 :     Tcl_DStringInit(&proc_internal_name);
    1479         130 :     Tcl_DStringInit(&proc_internal_body);
    1480         130 :     PG_TRY();
    1481             :     {
    1482         130 :         bool        is_trigger = OidIsValid(tgreloid);
    1483             :         Tcl_CmdInfo cmdinfo;
    1484             :         const char *user_proname;
    1485             :         const char *internal_proname;
    1486             :         bool        need_underscore;
    1487             :         HeapTuple   typeTup;
    1488             :         Form_pg_type typeStruct;
    1489             :         char        proc_internal_args[33 * FUNC_MAX_ARGS];
    1490             :         Datum       prosrcdatum;
    1491             :         char       *proc_source;
    1492             :         char        buf[48];
    1493             :         pltcl_interp_desc *interp_desc;
    1494             :         Tcl_Interp *interp;
    1495             :         int         i;
    1496             :         int         tcl_rc;
    1497             :         MemoryContext oldcontext;
    1498             : 
    1499             :         /************************************************************
    1500             :          * Identify the interpreter to use for the function
    1501             :          ************************************************************/
    1502         130 :         interp_desc = pltcl_fetch_interp(procStruct->prolang, pltrusted);
    1503         124 :         interp = interp_desc->interp;
    1504             : 
    1505             :         /************************************************************
    1506             :          * If redefining the function, try to remove the old internal
    1507             :          * procedure from Tcl's namespace.  The point of this is partly to
    1508             :          * allow re-use of the same internal proc name, and partly to avoid
    1509             :          * leaking the Tcl procedure object if we end up not choosing the same
    1510             :          * name.  We assume that Tcl is smart enough to not physically delete
    1511             :          * the procedure object if it's currently being executed.
    1512             :          ************************************************************/
    1513         124 :         if (prodesc != NULL &&
    1514           4 :             prodesc->internal_proname != NULL)
    1515             :         {
    1516             :             /* We simply ignore any error */
    1517           4 :             (void) Tcl_DeleteCommand(interp, prodesc->internal_proname);
    1518             :             /* Don't do this more than once */
    1519           4 :             prodesc->internal_proname = NULL;
    1520             :         }
    1521             : 
    1522             :         /************************************************************
    1523             :          * Build the proc name we'll use in error messages.
    1524             :          ************************************************************/
    1525         124 :         user_proname = format_procedure(fn_oid);
    1526             : 
    1527             :         /************************************************************
    1528             :          * Build the internal proc name from the user_proname and/or OID.
    1529             :          * The internal name must be all-ASCII since we don't want to deal
    1530             :          * with encoding conversions.  We don't want to worry about Tcl
    1531             :          * quoting rules either, so use only the characters of the function
    1532             :          * name that are ASCII alphanumerics, plus underscores to separate
    1533             :          * function name and arguments.  If what we end up with isn't
    1534             :          * unique (that is, it matches some existing Tcl command name),
    1535             :          * append the function OID (perhaps repeatedly) so that it is unique.
    1536             :          ************************************************************/
    1537             : 
    1538             :         /* For historical reasons, use a function-type-specific prefix */
    1539         124 :         if (is_event_trigger)
    1540           2 :             Tcl_DStringAppend(&proc_internal_name,
    1541             :                               "__PLTcl_evttrigger_", -1);
    1542         122 :         else if (is_trigger)
    1543          16 :             Tcl_DStringAppend(&proc_internal_name,
    1544             :                               "__PLTcl_trigger_", -1);
    1545             :         else
    1546         106 :             Tcl_DStringAppend(&proc_internal_name,
    1547             :                               "__PLTcl_proc_", -1);
    1548             :         /* Now add what we can from the user_proname */
    1549         124 :         need_underscore = false;
    1550        2830 :         for (const char *ptr = user_proname; *ptr; ptr++)
    1551             :         {
    1552        2706 :             if (strchr("ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    1553             :                        "abcdefghijklmnopqrstuvwxyz"
    1554        2706 :                        "0123456789_", *ptr) != NULL)
    1555             :             {
    1556             :                 /* Done this way to avoid adding a trailing underscore */
    1557        2422 :                 if (need_underscore)
    1558             :                 {
    1559          96 :                     Tcl_DStringAppend(&proc_internal_name, "_", 1);
    1560          96 :                     need_underscore = false;
    1561             :                 }
    1562        2422 :                 Tcl_DStringAppend(&proc_internal_name, ptr, 1);
    1563             :             }
    1564         284 :             else if (strchr("(, ", *ptr) != NULL)
    1565         152 :                 need_underscore = true;
    1566             :         }
    1567             :         /* If this name already exists, append fn_oid; repeat as needed */
    1568         250 :         while (Tcl_GetCommandInfo(interp,
    1569         126 :                                   Tcl_DStringValue(&proc_internal_name),
    1570             :                                   &cmdinfo))
    1571             :         {
    1572           2 :             snprintf(buf, sizeof(buf), "_%u", fn_oid);
    1573           2 :             Tcl_DStringAppend(&proc_internal_name, buf, -1);
    1574             :         }
    1575         124 :         internal_proname = Tcl_DStringValue(&proc_internal_name);
    1576             : 
    1577             :         /************************************************************
    1578             :          * Allocate a context that will hold all PG data for the procedure.
    1579             :          ************************************************************/
    1580         124 :         proc_cxt = AllocSetContextCreate(TopMemoryContext,
    1581             :                                          "PL/Tcl function",
    1582             :                                          ALLOCSET_SMALL_SIZES);
    1583             : 
    1584             :         /************************************************************
    1585             :          * Allocate and fill a new procedure description block.
    1586             :          * struct prodesc and subsidiary data must all live in proc_cxt.
    1587             :          ************************************************************/
    1588         124 :         oldcontext = MemoryContextSwitchTo(proc_cxt);
    1589         124 :         prodesc = (pltcl_proc_desc *) palloc0(sizeof(pltcl_proc_desc));
    1590         124 :         prodesc->user_proname = pstrdup(user_proname);
    1591         124 :         MemoryContextSetIdentifier(proc_cxt, prodesc->user_proname);
    1592         124 :         prodesc->internal_proname = pstrdup(internal_proname);
    1593         124 :         prodesc->fn_cxt = proc_cxt;
    1594         124 :         prodesc->fn_refcount = 0;
    1595         124 :         prodesc->fn_xmin = HeapTupleHeaderGetRawXmin(procTup->t_data);
    1596         124 :         prodesc->fn_tid = procTup->t_self;
    1597         124 :         prodesc->nargs = procStruct->pronargs;
    1598         124 :         prodesc->arg_out_func = (FmgrInfo *) palloc0(prodesc->nargs * sizeof(FmgrInfo));
    1599         124 :         prodesc->arg_is_rowtype = (bool *) palloc0(prodesc->nargs * sizeof(bool));
    1600         124 :         MemoryContextSwitchTo(oldcontext);
    1601             : 
    1602             :         /* Remember if function is STABLE/IMMUTABLE */
    1603         124 :         prodesc->fn_readonly =
    1604         124 :             (procStruct->provolatile != PROVOLATILE_VOLATILE);
    1605             :         /* And whether it is trusted */
    1606         124 :         prodesc->lanpltrusted = pltrusted;
    1607             :         /* Save the associated interpreter, too */
    1608         124 :         prodesc->interp_desc = interp_desc;
    1609             : 
    1610             :         /************************************************************
    1611             :          * Get the required information for input conversion of the
    1612             :          * return value.
    1613             :          ************************************************************/
    1614         124 :         if (!is_trigger && !is_event_trigger)
    1615             :         {
    1616         106 :             Oid         rettype = procStruct->prorettype;
    1617             : 
    1618         106 :             typeTup = SearchSysCache1(TYPEOID, ObjectIdGetDatum(rettype));
    1619         106 :             if (!HeapTupleIsValid(typeTup))
    1620           0 :                 elog(ERROR, "cache lookup failed for type %u", rettype);
    1621         106 :             typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
    1622             : 
    1623             :             /* Disallow pseudotype result, except VOID and RECORD */
    1624         106 :             if (typeStruct->typtype == TYPTYPE_PSEUDO)
    1625             :             {
    1626          48 :                 if (rettype == VOIDOID ||
    1627             :                     rettype == RECORDOID)
    1628             :                      /* okay */ ;
    1629           0 :                 else if (rettype == TRIGGEROID ||
    1630             :                          rettype == EVENT_TRIGGEROID)
    1631           0 :                     ereport(ERROR,
    1632             :                             (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    1633             :                              errmsg("trigger functions can only be called as triggers")));
    1634             :                 else
    1635           0 :                     ereport(ERROR,
    1636             :                             (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    1637             :                              errmsg("PL/Tcl functions cannot return type %s",
    1638             :                                     format_type_be(rettype))));
    1639             :             }
    1640             : 
    1641         106 :             prodesc->result_typid = rettype;
    1642         106 :             fmgr_info_cxt(typeStruct->typinput,
    1643             :                           &(prodesc->result_in_func),
    1644             :                           proc_cxt);
    1645         106 :             prodesc->result_typioparam = getTypeIOParam(typeTup);
    1646             : 
    1647         106 :             prodesc->fn_retisset = procStruct->proretset;
    1648         106 :             prodesc->fn_retistuple = type_is_rowtype(rettype);
    1649         106 :             prodesc->fn_retisdomain = (typeStruct->typtype == TYPTYPE_DOMAIN);
    1650         106 :             prodesc->domain_info = NULL;
    1651             : 
    1652         106 :             ReleaseSysCache(typeTup);
    1653             :         }
    1654             : 
    1655             :         /************************************************************
    1656             :          * Get the required information for output conversion
    1657             :          * of all procedure arguments, and set up argument naming info.
    1658             :          ************************************************************/
    1659         124 :         if (!is_trigger && !is_event_trigger)
    1660             :         {
    1661         106 :             proc_internal_args[0] = '\0';
    1662         202 :             for (i = 0; i < prodesc->nargs; i++)
    1663             :             {
    1664          96 :                 Oid         argtype = procStruct->proargtypes.values[i];
    1665             : 
    1666          96 :                 typeTup = SearchSysCache1(TYPEOID, ObjectIdGetDatum(argtype));
    1667          96 :                 if (!HeapTupleIsValid(typeTup))
    1668           0 :                     elog(ERROR, "cache lookup failed for type %u", argtype);
    1669          96 :                 typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
    1670             : 
    1671             :                 /* Disallow pseudotype argument, except RECORD */
    1672          96 :                 if (typeStruct->typtype == TYPTYPE_PSEUDO &&
    1673             :                     argtype != RECORDOID)
    1674           0 :                     ereport(ERROR,
    1675             :                             (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    1676             :                              errmsg("PL/Tcl functions cannot accept type %s",
    1677             :                                     format_type_be(argtype))));
    1678             : 
    1679          96 :                 if (type_is_rowtype(argtype))
    1680             :                 {
    1681           8 :                     prodesc->arg_is_rowtype[i] = true;
    1682           8 :                     snprintf(buf, sizeof(buf), "__PLTcl_Tup_%d", i + 1);
    1683             :                 }
    1684             :                 else
    1685             :                 {
    1686          88 :                     prodesc->arg_is_rowtype[i] = false;
    1687          88 :                     fmgr_info_cxt(typeStruct->typoutput,
    1688          88 :                                   &(prodesc->arg_out_func[i]),
    1689             :                                   proc_cxt);
    1690          88 :                     snprintf(buf, sizeof(buf), "%d", i + 1);
    1691             :                 }
    1692             : 
    1693          96 :                 if (i > 0)
    1694          28 :                     strcat(proc_internal_args, " ");
    1695          96 :                 strcat(proc_internal_args, buf);
    1696             : 
    1697          96 :                 ReleaseSysCache(typeTup);
    1698             :             }
    1699             :         }
    1700          18 :         else if (is_trigger)
    1701             :         {
    1702             :             /* trigger procedure has fixed args */
    1703          16 :             strcpy(proc_internal_args,
    1704             :                    "TG_name TG_relid TG_table_name TG_table_schema TG_relatts TG_when TG_level TG_op __PLTcl_Tup_NEW __PLTcl_Tup_OLD args");
    1705             :         }
    1706           2 :         else if (is_event_trigger)
    1707             :         {
    1708             :             /* event trigger procedure has fixed args */
    1709           2 :             strcpy(proc_internal_args, "TG_event TG_tag");
    1710             :         }
    1711             : 
    1712             :         /************************************************************
    1713             :          * Create the tcl command to define the internal
    1714             :          * procedure
    1715             :          *
    1716             :          * Leave this code as DString - performance is not critical here,
    1717             :          * and we don't want to duplicate the knowledge of the Tcl quoting
    1718             :          * rules that's embedded in Tcl_DStringAppendElement.
    1719             :          ************************************************************/
    1720         124 :         Tcl_DStringAppendElement(&proc_internal_def, "proc");
    1721         124 :         Tcl_DStringAppendElement(&proc_internal_def, internal_proname);
    1722         124 :         Tcl_DStringAppendElement(&proc_internal_def, proc_internal_args);
    1723             : 
    1724             :         /************************************************************
    1725             :          * prefix procedure body with
    1726             :          * upvar #0 <internal_proname> GD
    1727             :          * and with appropriate setting of arguments
    1728             :          ************************************************************/
    1729         124 :         Tcl_DStringAppend(&proc_internal_body, "upvar #0 ", -1);
    1730         124 :         Tcl_DStringAppend(&proc_internal_body, internal_proname, -1);
    1731         124 :         Tcl_DStringAppend(&proc_internal_body, " GD\n", -1);
    1732         124 :         if (is_trigger)
    1733             :         {
    1734          16 :             Tcl_DStringAppend(&proc_internal_body,
    1735             :                               "array set NEW $__PLTcl_Tup_NEW\n", -1);
    1736          16 :             Tcl_DStringAppend(&proc_internal_body,
    1737             :                               "array set OLD $__PLTcl_Tup_OLD\n", -1);
    1738          16 :             Tcl_DStringAppend(&proc_internal_body,
    1739             :                               "set i 0\n"
    1740             :                               "set v 0\n"
    1741             :                               "foreach v $args {\n"
    1742             :                               "  incr i\n"
    1743             :                               "  set $i $v\n"
    1744             :                               "}\n"
    1745             :                               "unset i v\n\n", -1);
    1746             :         }
    1747         108 :         else if (is_event_trigger)
    1748             :         {
    1749             :             /* no argument support for event triggers */
    1750             :         }
    1751             :         else
    1752             :         {
    1753         202 :             for (i = 0; i < prodesc->nargs; i++)
    1754             :             {
    1755          96 :                 if (prodesc->arg_is_rowtype[i])
    1756             :                 {
    1757           8 :                     snprintf(buf, sizeof(buf),
    1758             :                              "array set %d $__PLTcl_Tup_%d\n",
    1759             :                              i + 1, i + 1);
    1760           8 :                     Tcl_DStringAppend(&proc_internal_body, buf, -1);
    1761             :                 }
    1762             :             }
    1763             :         }
    1764             : 
    1765             :         /************************************************************
    1766             :          * Add user's function definition to proc body
    1767             :          ************************************************************/
    1768         124 :         prosrcdatum = SysCacheGetAttrNotNull(PROCOID, procTup,
    1769             :                                              Anum_pg_proc_prosrc);
    1770         124 :         proc_source = TextDatumGetCString(prosrcdatum);
    1771         124 :         UTF_BEGIN;
    1772         124 :         Tcl_DStringAppend(&proc_internal_body, UTF_E2U(proc_source), -1);
    1773         124 :         UTF_END;
    1774         124 :         pfree(proc_source);
    1775         124 :         Tcl_DStringAppendElement(&proc_internal_def,
    1776         124 :                                  Tcl_DStringValue(&proc_internal_body));
    1777             : 
    1778             :         /************************************************************
    1779             :          * Create the procedure in the interpreter
    1780             :          ************************************************************/
    1781         248 :         tcl_rc = Tcl_EvalEx(interp,
    1782         124 :                             Tcl_DStringValue(&proc_internal_def),
    1783             :                             Tcl_DStringLength(&proc_internal_def),
    1784             :                             TCL_EVAL_GLOBAL);
    1785         124 :         if (tcl_rc != TCL_OK)
    1786           0 :             ereport(ERROR,
    1787             :                     (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
    1788             :                      errmsg("could not create internal procedure \"%s\": %s",
    1789             :                             internal_proname,
    1790             :                             utf_u2e(Tcl_GetStringResult(interp)))));
    1791             :     }
    1792           6 :     PG_CATCH();
    1793             :     {
    1794             :         /*
    1795             :          * If we failed anywhere above, clean up whatever got allocated.  It
    1796             :          * should all be in the proc_cxt, except for the DStrings.
    1797             :          */
    1798           6 :         if (proc_cxt)
    1799           0 :             MemoryContextDelete(proc_cxt);
    1800           6 :         Tcl_DStringFree(&proc_internal_def);
    1801           6 :         Tcl_DStringFree(&proc_internal_name);
    1802           6 :         Tcl_DStringFree(&proc_internal_body);
    1803           6 :         PG_RE_THROW();
    1804             :     }
    1805         124 :     PG_END_TRY();
    1806             : 
    1807             :     /*
    1808             :      * Install the new proc description block in the hashtable, incrementing
    1809             :      * its refcount (the hashtable link counts as a reference).  Then, if
    1810             :      * there was a previous definition of the function, decrement that one's
    1811             :      * refcount, and delete it if no longer referenced.  The order of
    1812             :      * operations here is important: if something goes wrong during the
    1813             :      * MemoryContextDelete, leaking some memory for the old definition is OK,
    1814             :      * but we don't want to corrupt the live hashtable entry.  (Likewise,
    1815             :      * freeing the DStrings is pretty low priority if that happens.)
    1816             :      */
    1817         124 :     old_prodesc = proc_ptr->proc_ptr;
    1818             : 
    1819         124 :     proc_ptr->proc_ptr = prodesc;
    1820         124 :     prodesc->fn_refcount++;
    1821             : 
    1822         124 :     if (old_prodesc != NULL)
    1823             :     {
    1824             :         Assert(old_prodesc->fn_refcount > 0);
    1825           4 :         if (--old_prodesc->fn_refcount == 0)
    1826           2 :             MemoryContextDelete(old_prodesc->fn_cxt);
    1827             :     }
    1828             : 
    1829         124 :     Tcl_DStringFree(&proc_internal_def);
    1830         124 :     Tcl_DStringFree(&proc_internal_name);
    1831         124 :     Tcl_DStringFree(&proc_internal_body);
    1832             : 
    1833         124 :     ReleaseSysCache(procTup);
    1834             : 
    1835         124 :     return prodesc;
    1836             : }
    1837             : 
    1838             : 
    1839             : /**********************************************************************
    1840             :  * pltcl_elog()     - elog() support for PLTcl
    1841             :  **********************************************************************/
    1842             : static int
    1843         532 : pltcl_elog(ClientData cdata, Tcl_Interp *interp,
    1844             :            int objc, Tcl_Obj *const objv[])
    1845             : {
    1846             :     volatile int level;
    1847             :     MemoryContext oldcontext;
    1848             :     int         priIndex;
    1849             : 
    1850             :     static const char *logpriorities[] = {
    1851             :         "DEBUG", "LOG", "INFO", "NOTICE",
    1852             :         "WARNING", "ERROR", "FATAL", (const char *) NULL
    1853             :     };
    1854             : 
    1855             :     static const int loglevels[] = {
    1856             :         DEBUG2, LOG, INFO, NOTICE,
    1857             :         WARNING, ERROR, FATAL
    1858             :     };
    1859             : 
    1860         532 :     if (objc != 3)
    1861             :     {
    1862           2 :         Tcl_WrongNumArgs(interp, 1, objv, "level msg");
    1863           2 :         return TCL_ERROR;
    1864             :     }
    1865             : 
    1866         530 :     if (Tcl_GetIndexFromObj(interp, objv[1], logpriorities, "priority",
    1867             :                             TCL_EXACT, &priIndex) != TCL_OK)
    1868           2 :         return TCL_ERROR;
    1869             : 
    1870         528 :     level = loglevels[priIndex];
    1871             : 
    1872         528 :     if (level == ERROR)
    1873             :     {
    1874             :         /*
    1875             :          * We just pass the error back to Tcl.  If it's not caught, it'll
    1876             :          * eventually get converted to a PG error when we reach the call
    1877             :          * handler.
    1878             :          */
    1879          12 :         Tcl_SetObjResult(interp, objv[2]);
    1880          12 :         return TCL_ERROR;
    1881             :     }
    1882             : 
    1883             :     /*
    1884             :      * For non-error messages, just pass 'em to ereport().  We do not expect
    1885             :      * that this will fail, but just on the off chance it does, report the
    1886             :      * error back to Tcl.  Note we are assuming that ereport() can't have any
    1887             :      * internal failures that are so bad as to require a transaction abort.
    1888             :      *
    1889             :      * This path is also used for FATAL errors, which aren't going to come
    1890             :      * back to us at all.
    1891             :      */
    1892         516 :     oldcontext = CurrentMemoryContext;
    1893         516 :     PG_TRY();
    1894             :     {
    1895         516 :         UTF_BEGIN;
    1896         516 :         ereport(level,
    1897             :                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
    1898             :                  errmsg("%s", UTF_U2E(Tcl_GetString(objv[2])))));
    1899         516 :         UTF_END;
    1900             :     }
    1901           0 :     PG_CATCH();
    1902             :     {
    1903             :         ErrorData  *edata;
    1904             : 
    1905             :         /* Must reset elog.c's state */
    1906           0 :         MemoryContextSwitchTo(oldcontext);
    1907           0 :         edata = CopyErrorData();
    1908           0 :         FlushErrorState();
    1909             : 
    1910             :         /* Pass the error data to Tcl */
    1911           0 :         pltcl_construct_errorCode(interp, edata);
    1912           0 :         UTF_BEGIN;
    1913           0 :         Tcl_SetObjResult(interp, Tcl_NewStringObj(UTF_E2U(edata->message), -1));
    1914           0 :         UTF_END;
    1915           0 :         FreeErrorData(edata);
    1916             : 
    1917           0 :         return TCL_ERROR;
    1918             :     }
    1919         516 :     PG_END_TRY();
    1920             : 
    1921         516 :     return TCL_OK;
    1922             : }
    1923             : 
    1924             : 
    1925             : /**********************************************************************
    1926             :  * pltcl_construct_errorCode()      - construct a Tcl errorCode
    1927             :  *      list with detailed information from the PostgreSQL server
    1928             :  **********************************************************************/
    1929             : static void
    1930          36 : pltcl_construct_errorCode(Tcl_Interp *interp, ErrorData *edata)
    1931             : {
    1932          36 :     Tcl_Obj    *obj = Tcl_NewObj();
    1933             : 
    1934          36 :     Tcl_ListObjAppendElement(interp, obj,
    1935             :                              Tcl_NewStringObj("POSTGRES", -1));
    1936          36 :     Tcl_ListObjAppendElement(interp, obj,
    1937             :                              Tcl_NewStringObj(PG_VERSION, -1));
    1938          36 :     Tcl_ListObjAppendElement(interp, obj,
    1939             :                              Tcl_NewStringObj("SQLSTATE", -1));
    1940          36 :     Tcl_ListObjAppendElement(interp, obj,
    1941          36 :                              Tcl_NewStringObj(unpack_sql_state(edata->sqlerrcode), -1));
    1942          36 :     Tcl_ListObjAppendElement(interp, obj,
    1943             :                              Tcl_NewStringObj("condition", -1));
    1944          36 :     Tcl_ListObjAppendElement(interp, obj,
    1945             :                              Tcl_NewStringObj(pltcl_get_condition_name(edata->sqlerrcode), -1));
    1946          36 :     Tcl_ListObjAppendElement(interp, obj,
    1947             :                              Tcl_NewStringObj("message", -1));
    1948          36 :     UTF_BEGIN;
    1949          36 :     Tcl_ListObjAppendElement(interp, obj,
    1950          36 :                              Tcl_NewStringObj(UTF_E2U(edata->message), -1));
    1951          36 :     UTF_END;
    1952          36 :     if (edata->detail)
    1953             :     {
    1954           6 :         Tcl_ListObjAppendElement(interp, obj,
    1955             :                                  Tcl_NewStringObj("detail", -1));
    1956           6 :         UTF_BEGIN;
    1957           6 :         Tcl_ListObjAppendElement(interp, obj,
    1958           6 :                                  Tcl_NewStringObj(UTF_E2U(edata->detail), -1));
    1959           6 :         UTF_END;
    1960             :     }
    1961          36 :     if (edata->hint)
    1962             :     {
    1963           2 :         Tcl_ListObjAppendElement(interp, obj,
    1964             :                                  Tcl_NewStringObj("hint", -1));
    1965           2 :         UTF_BEGIN;
    1966           2 :         Tcl_ListObjAppendElement(interp, obj,
    1967           2 :                                  Tcl_NewStringObj(UTF_E2U(edata->hint), -1));
    1968           2 :         UTF_END;
    1969             :     }
    1970          36 :     if (edata->context)
    1971             :     {
    1972          18 :         Tcl_ListObjAppendElement(interp, obj,
    1973             :                                  Tcl_NewStringObj("context", -1));
    1974          18 :         UTF_BEGIN;
    1975          18 :         Tcl_ListObjAppendElement(interp, obj,
    1976          18 :                                  Tcl_NewStringObj(UTF_E2U(edata->context), -1));
    1977          18 :         UTF_END;
    1978             :     }
    1979          36 :     if (edata->schema_name)
    1980             :     {
    1981           6 :         Tcl_ListObjAppendElement(interp, obj,
    1982             :                                  Tcl_NewStringObj("schema", -1));
    1983           6 :         UTF_BEGIN;
    1984           6 :         Tcl_ListObjAppendElement(interp, obj,
    1985           6 :                                  Tcl_NewStringObj(UTF_E2U(edata->schema_name), -1));
    1986           6 :         UTF_END;
    1987             :     }
    1988          36 :     if (edata->table_name)
    1989             :     {
    1990           6 :         Tcl_ListObjAppendElement(interp, obj,
    1991             :                                  Tcl_NewStringObj("table", -1));
    1992           6 :         UTF_BEGIN;
    1993           6 :         Tcl_ListObjAppendElement(interp, obj,
    1994           6 :                                  Tcl_NewStringObj(UTF_E2U(edata->table_name), -1));
    1995           6 :         UTF_END;
    1996             :     }
    1997          36 :     if (edata->column_name)
    1998             :     {
    1999           2 :         Tcl_ListObjAppendElement(interp, obj,
    2000             :                                  Tcl_NewStringObj("column", -1));
    2001           2 :         UTF_BEGIN;
    2002           2 :         Tcl_ListObjAppendElement(interp, obj,
    2003           2 :                                  Tcl_NewStringObj(UTF_E2U(edata->column_name), -1));
    2004           2 :         UTF_END;
    2005             :     }
    2006          36 :     if (edata->datatype_name)
    2007             :     {
    2008           2 :         Tcl_ListObjAppendElement(interp, obj,
    2009             :                                  Tcl_NewStringObj("datatype", -1));
    2010           2 :         UTF_BEGIN;
    2011           2 :         Tcl_ListObjAppendElement(interp, obj,
    2012           2 :                                  Tcl_NewStringObj(UTF_E2U(edata->datatype_name), -1));
    2013           2 :         UTF_END;
    2014             :     }
    2015          36 :     if (edata->constraint_name)
    2016             :     {
    2017           6 :         Tcl_ListObjAppendElement(interp, obj,
    2018             :                                  Tcl_NewStringObj("constraint", -1));
    2019           6 :         UTF_BEGIN;
    2020           6 :         Tcl_ListObjAppendElement(interp, obj,
    2021           6 :                                  Tcl_NewStringObj(UTF_E2U(edata->constraint_name), -1));
    2022           6 :         UTF_END;
    2023             :     }
    2024             :     /* cursorpos is never interesting here; report internal query/pos */
    2025          36 :     if (edata->internalquery)
    2026             :     {
    2027           8 :         Tcl_ListObjAppendElement(interp, obj,
    2028             :                                  Tcl_NewStringObj("statement", -1));
    2029           8 :         UTF_BEGIN;
    2030           8 :         Tcl_ListObjAppendElement(interp, obj,
    2031           8 :                                  Tcl_NewStringObj(UTF_E2U(edata->internalquery), -1));
    2032           8 :         UTF_END;
    2033             :     }
    2034          36 :     if (edata->internalpos > 0)
    2035             :     {
    2036           8 :         Tcl_ListObjAppendElement(interp, obj,
    2037             :                                  Tcl_NewStringObj("cursor_position", -1));
    2038           8 :         Tcl_ListObjAppendElement(interp, obj,
    2039             :                                  Tcl_NewIntObj(edata->internalpos));
    2040             :     }
    2041          36 :     if (edata->filename)
    2042             :     {
    2043          36 :         Tcl_ListObjAppendElement(interp, obj,
    2044             :                                  Tcl_NewStringObj("filename", -1));
    2045          36 :         UTF_BEGIN;
    2046          36 :         Tcl_ListObjAppendElement(interp, obj,
    2047          36 :                                  Tcl_NewStringObj(UTF_E2U(edata->filename), -1));
    2048          36 :         UTF_END;
    2049             :     }
    2050          36 :     if (edata->lineno > 0)
    2051             :     {
    2052          36 :         Tcl_ListObjAppendElement(interp, obj,
    2053             :                                  Tcl_NewStringObj("lineno", -1));
    2054          36 :         Tcl_ListObjAppendElement(interp, obj,
    2055             :                                  Tcl_NewIntObj(edata->lineno));
    2056             :     }
    2057          36 :     if (edata->funcname)
    2058             :     {
    2059          36 :         Tcl_ListObjAppendElement(interp, obj,
    2060             :                                  Tcl_NewStringObj("funcname", -1));
    2061          36 :         UTF_BEGIN;
    2062          36 :         Tcl_ListObjAppendElement(interp, obj,
    2063          36 :                                  Tcl_NewStringObj(UTF_E2U(edata->funcname), -1));
    2064          36 :         UTF_END;
    2065             :     }
    2066             : 
    2067          36 :     Tcl_SetObjErrorCode(interp, obj);
    2068          36 : }
    2069             : 
    2070             : 
    2071             : /**********************************************************************
    2072             :  * pltcl_get_condition_name()   - find name for SQLSTATE
    2073             :  **********************************************************************/
    2074             : static const char *
    2075          36 : pltcl_get_condition_name(int sqlstate)
    2076             : {
    2077             :     int         i;
    2078             : 
    2079        4558 :     for (i = 0; exception_name_map[i].label != NULL; i++)
    2080             :     {
    2081        4558 :         if (exception_name_map[i].sqlerrstate == sqlstate)
    2082          36 :             return exception_name_map[i].label;
    2083             :     }
    2084           0 :     return "unrecognized_sqlstate";
    2085             : }
    2086             : 
    2087             : 
    2088             : /**********************************************************************
    2089             :  * pltcl_quote()    - quote literal strings that are to
    2090             :  *            be used in SPI_execute query strings
    2091             :  **********************************************************************/
    2092             : static int
    2093          22 : pltcl_quote(ClientData cdata, Tcl_Interp *interp,
    2094             :             int objc, Tcl_Obj *const objv[])
    2095             : {
    2096             :     char       *tmp;
    2097             :     const char *cp1;
    2098             :     char       *cp2;
    2099             :     Tcl_Size    length;
    2100             : 
    2101             :     /************************************************************
    2102             :      * Check call syntax
    2103             :      ************************************************************/
    2104          22 :     if (objc != 2)
    2105             :     {
    2106           2 :         Tcl_WrongNumArgs(interp, 1, objv, "string");
    2107           2 :         return TCL_ERROR;
    2108             :     }
    2109             : 
    2110             :     /************************************************************
    2111             :      * Allocate space for the maximum the string can
    2112             :      * grow to and initialize pointers
    2113             :      ************************************************************/
    2114          20 :     cp1 = Tcl_GetStringFromObj(objv[1], &length);
    2115          20 :     tmp = palloc(length * 2 + 1);
    2116          20 :     cp2 = tmp;
    2117             : 
    2118             :     /************************************************************
    2119             :      * Walk through string and double every quote and backslash
    2120             :      ************************************************************/
    2121         112 :     while (*cp1)
    2122             :     {
    2123          92 :         if (*cp1 == '\'')
    2124           2 :             *cp2++ = '\'';
    2125             :         else
    2126             :         {
    2127          90 :             if (*cp1 == '\\')
    2128           2 :                 *cp2++ = '\\';
    2129             :         }
    2130          92 :         *cp2++ = *cp1++;
    2131             :     }
    2132             : 
    2133             :     /************************************************************
    2134             :      * Terminate the string and set it as result
    2135             :      ************************************************************/
    2136          20 :     *cp2 = '\0';
    2137          20 :     Tcl_SetObjResult(interp, Tcl_NewStringObj(tmp, -1));
    2138          20 :     pfree(tmp);
    2139          20 :     return TCL_OK;
    2140             : }
    2141             : 
    2142             : 
    2143             : /**********************************************************************
    2144             :  * pltcl_argisnull()    - determine if a specific argument is NULL
    2145             :  **********************************************************************/
    2146             : static int
    2147          14 : pltcl_argisnull(ClientData cdata, Tcl_Interp *interp,
    2148             :                 int objc, Tcl_Obj *const objv[])
    2149             : {
    2150             :     int         argno;
    2151          14 :     FunctionCallInfo fcinfo = pltcl_current_call_state->fcinfo;
    2152             : 
    2153             :     /************************************************************
    2154             :      * Check call syntax
    2155             :      ************************************************************/
    2156          14 :     if (objc != 2)
    2157             :     {
    2158           2 :         Tcl_WrongNumArgs(interp, 1, objv, "argno");
    2159           2 :         return TCL_ERROR;
    2160             :     }
    2161             : 
    2162             :     /************************************************************
    2163             :      * Check that we're called as a normal function
    2164             :      ************************************************************/
    2165          12 :     if (fcinfo == NULL)
    2166             :     {
    2167           2 :         Tcl_SetObjResult(interp,
    2168             :                          Tcl_NewStringObj("argisnull cannot be used in triggers", -1));
    2169           2 :         return TCL_ERROR;
    2170             :     }
    2171             : 
    2172             :     /************************************************************
    2173             :      * Get the argument number
    2174             :      ************************************************************/
    2175          10 :     if (Tcl_GetIntFromObj(interp, objv[1], &argno) != TCL_OK)
    2176           2 :         return TCL_ERROR;
    2177             : 
    2178             :     /************************************************************
    2179             :      * Check that the argno is valid
    2180             :      ************************************************************/
    2181           8 :     argno--;
    2182           8 :     if (argno < 0 || argno >= fcinfo->nargs)
    2183             :     {
    2184           2 :         Tcl_SetObjResult(interp,
    2185             :                          Tcl_NewStringObj("argno out of range", -1));
    2186           2 :         return TCL_ERROR;
    2187             :     }
    2188             : 
    2189             :     /************************************************************
    2190             :      * Get the requested NULL state
    2191             :      ************************************************************/
    2192           6 :     Tcl_SetObjResult(interp, Tcl_NewBooleanObj(PG_ARGISNULL(argno)));
    2193           6 :     return TCL_OK;
    2194             : }
    2195             : 
    2196             : 
    2197             : /**********************************************************************
    2198             :  * pltcl_returnnull()   - Cause a NULL return from the current function
    2199             :  **********************************************************************/
    2200             : static int
    2201           6 : pltcl_returnnull(ClientData cdata, Tcl_Interp *interp,
    2202             :                  int objc, Tcl_Obj *const objv[])
    2203             : {
    2204           6 :     FunctionCallInfo fcinfo = pltcl_current_call_state->fcinfo;
    2205             : 
    2206             :     /************************************************************
    2207             :      * Check call syntax
    2208             :      ************************************************************/
    2209           6 :     if (objc != 1)
    2210             :     {
    2211           2 :         Tcl_WrongNumArgs(interp, 1, objv, "");
    2212           2 :         return TCL_ERROR;
    2213             :     }
    2214             : 
    2215             :     /************************************************************
    2216             :      * Check that we're called as a normal function
    2217             :      ************************************************************/
    2218           4 :     if (fcinfo == NULL)
    2219             :     {
    2220           2 :         Tcl_SetObjResult(interp,
    2221             :                          Tcl_NewStringObj("return_null cannot be used in triggers", -1));
    2222           2 :         return TCL_ERROR;
    2223             :     }
    2224             : 
    2225             :     /************************************************************
    2226             :      * Set the NULL return flag and cause Tcl to return from the
    2227             :      * procedure.
    2228             :      ************************************************************/
    2229           2 :     fcinfo->isnull = true;
    2230             : 
    2231           2 :     return TCL_RETURN;
    2232             : }
    2233             : 
    2234             : 
    2235             : /**********************************************************************
    2236             :  * pltcl_returnnext()   - Add a row to the result tuplestore in a SRF.
    2237             :  **********************************************************************/
    2238             : static int
    2239          36 : pltcl_returnnext(ClientData cdata, Tcl_Interp *interp,
    2240             :                  int objc, Tcl_Obj *const objv[])
    2241             : {
    2242          36 :     pltcl_call_state *call_state = pltcl_current_call_state;
    2243          36 :     FunctionCallInfo fcinfo = call_state->fcinfo;
    2244          36 :     pltcl_proc_desc *prodesc = call_state->prodesc;
    2245          36 :     MemoryContext oldcontext = CurrentMemoryContext;
    2246          36 :     ResourceOwner oldowner = CurrentResourceOwner;
    2247          36 :     volatile int result = TCL_OK;
    2248             : 
    2249             :     /*
    2250             :      * Check that we're called as a set-returning function
    2251             :      */
    2252          36 :     if (fcinfo == NULL)
    2253             :     {
    2254           0 :         Tcl_SetObjResult(interp,
    2255             :                          Tcl_NewStringObj("return_next cannot be used in triggers", -1));
    2256           0 :         return TCL_ERROR;
    2257             :     }
    2258             : 
    2259          36 :     if (!prodesc->fn_retisset)
    2260             :     {
    2261           2 :         Tcl_SetObjResult(interp,
    2262             :                          Tcl_NewStringObj("return_next cannot be used in non-set-returning functions", -1));
    2263           2 :         return TCL_ERROR;
    2264             :     }
    2265             : 
    2266             :     /*
    2267             :      * Check call syntax
    2268             :      */
    2269          34 :     if (objc != 2)
    2270             :     {
    2271           0 :         Tcl_WrongNumArgs(interp, 1, objv, "result");
    2272           0 :         return TCL_ERROR;
    2273             :     }
    2274             : 
    2275             :     /*
    2276             :      * The rest might throw elog(ERROR), so must run in a subtransaction.
    2277             :      *
    2278             :      * A small advantage of using a subtransaction is that it provides a
    2279             :      * short-lived memory context for free, so we needn't worry about leaking
    2280             :      * memory here.  To use that context, call BeginInternalSubTransaction
    2281             :      * directly instead of going through pltcl_subtrans_begin.
    2282             :      */
    2283          34 :     BeginInternalSubTransaction(NULL);
    2284          34 :     PG_TRY();
    2285             :     {
    2286             :         /* Set up tuple store if first output row */
    2287          34 :         if (call_state->tuple_store == NULL)
    2288          10 :             pltcl_init_tuple_store(call_state);
    2289             : 
    2290          34 :         if (prodesc->fn_retistuple)
    2291             :         {
    2292             :             Tcl_Obj   **rowObjv;
    2293             :             Tcl_Size    rowObjc;
    2294             : 
    2295             :             /* result should be a list, so break it down */
    2296          14 :             if (Tcl_ListObjGetElements(interp, objv[1], &rowObjc, &rowObjv) == TCL_ERROR)
    2297           0 :                 result = TCL_ERROR;
    2298             :             else
    2299             :             {
    2300             :                 HeapTuple   tuple;
    2301             : 
    2302          14 :                 tuple = pltcl_build_tuple_result(interp, rowObjv, rowObjc,
    2303             :                                                  call_state);
    2304          10 :                 tuplestore_puttuple(call_state->tuple_store, tuple);
    2305             :             }
    2306             :         }
    2307             :         else
    2308             :         {
    2309             :             Datum       retval;
    2310          20 :             bool        isNull = false;
    2311             : 
    2312             :             /* for paranoia's sake, check that tupdesc has exactly one column */
    2313          20 :             if (call_state->ret_tupdesc->natts != 1)
    2314           0 :                 elog(ERROR, "wrong result type supplied in return_next");
    2315             : 
    2316          20 :             retval = InputFunctionCall(&prodesc->result_in_func,
    2317          20 :                                        utf_u2e((char *) Tcl_GetString(objv[1])),
    2318             :                                        prodesc->result_typioparam,
    2319             :                                        -1);
    2320          20 :             tuplestore_putvalues(call_state->tuple_store, call_state->ret_tupdesc,
    2321             :                                  &retval, &isNull);
    2322             :         }
    2323             : 
    2324          30 :         pltcl_subtrans_commit(oldcontext, oldowner);
    2325             :     }
    2326           4 :     PG_CATCH();
    2327             :     {
    2328           4 :         pltcl_subtrans_abort(interp, oldcontext, oldowner);
    2329           4 :         return TCL_ERROR;
    2330             :     }
    2331          30 :     PG_END_TRY();
    2332             : 
    2333          30 :     return result;
    2334             : }
    2335             : 
    2336             : 
    2337             : /*----------
    2338             :  * Support for running SPI operations inside subtransactions
    2339             :  *
    2340             :  * Intended usage pattern is:
    2341             :  *
    2342             :  *  MemoryContext oldcontext = CurrentMemoryContext;
    2343             :  *  ResourceOwner oldowner = CurrentResourceOwner;
    2344             :  *
    2345             :  *  ...
    2346             :  *  pltcl_subtrans_begin(oldcontext, oldowner);
    2347             :  *  PG_TRY();
    2348             :  *  {
    2349             :  *      do something risky;
    2350             :  *      pltcl_subtrans_commit(oldcontext, oldowner);
    2351             :  *  }
    2352             :  *  PG_CATCH();
    2353             :  *  {
    2354             :  *      pltcl_subtrans_abort(interp, oldcontext, oldowner);
    2355             :  *      return TCL_ERROR;
    2356             :  *  }
    2357             :  *  PG_END_TRY();
    2358             :  *  return TCL_OK;
    2359             :  *----------
    2360             :  */
    2361             : static void
    2362         248 : pltcl_subtrans_begin(MemoryContext oldcontext, ResourceOwner oldowner)
    2363             : {
    2364         248 :     BeginInternalSubTransaction(NULL);
    2365             : 
    2366             :     /* Want to run inside function's memory context */
    2367         248 :     MemoryContextSwitchTo(oldcontext);
    2368         248 : }
    2369             : 
    2370             : static void
    2371         258 : pltcl_subtrans_commit(MemoryContext oldcontext, ResourceOwner oldowner)
    2372             : {
    2373             :     /* Commit the inner transaction, return to outer xact context */
    2374         258 :     ReleaseCurrentSubTransaction();
    2375         258 :     MemoryContextSwitchTo(oldcontext);
    2376         258 :     CurrentResourceOwner = oldowner;
    2377         258 : }
    2378             : 
    2379             : static void
    2380          24 : pltcl_subtrans_abort(Tcl_Interp *interp,
    2381             :                      MemoryContext oldcontext, ResourceOwner oldowner)
    2382             : {
    2383             :     ErrorData  *edata;
    2384             : 
    2385             :     /* Save error info */
    2386          24 :     MemoryContextSwitchTo(oldcontext);
    2387          24 :     edata = CopyErrorData();
    2388          24 :     FlushErrorState();
    2389             : 
    2390             :     /* Abort the inner transaction */
    2391          24 :     RollbackAndReleaseCurrentSubTransaction();
    2392          24 :     MemoryContextSwitchTo(oldcontext);
    2393          24 :     CurrentResourceOwner = oldowner;
    2394             : 
    2395             :     /* Pass the error data to Tcl */
    2396          24 :     pltcl_construct_errorCode(interp, edata);
    2397          24 :     UTF_BEGIN;
    2398          24 :     Tcl_SetObjResult(interp, Tcl_NewStringObj(UTF_E2U(edata->message), -1));
    2399          24 :     UTF_END;
    2400          24 :     FreeErrorData(edata);
    2401          24 : }
    2402             : 
    2403             : 
    2404             : /**********************************************************************
    2405             :  * pltcl_SPI_execute()      - The builtin SPI_execute command
    2406             :  *                for the Tcl interpreter
    2407             :  **********************************************************************/
    2408             : static int
    2409         130 : pltcl_SPI_execute(ClientData cdata, Tcl_Interp *interp,
    2410             :                   int objc, Tcl_Obj *const objv[])
    2411             : {
    2412             :     int         my_rc;
    2413             :     int         spi_rc;
    2414             :     int         query_idx;
    2415             :     int         i;
    2416             :     int         optIndex;
    2417         130 :     int         count = 0;
    2418         130 :     const char *volatile arrayname = NULL;
    2419         130 :     Tcl_Obj    *volatile loop_body = NULL;
    2420         130 :     MemoryContext oldcontext = CurrentMemoryContext;
    2421         130 :     ResourceOwner oldowner = CurrentResourceOwner;
    2422             : 
    2423             :     enum options
    2424             :     {
    2425             :         OPT_ARRAY, OPT_COUNT
    2426             :     };
    2427             : 
    2428             :     static const char *options[] = {
    2429             :         "-array", "-count", (const char *) NULL
    2430             :     };
    2431             : 
    2432             :     /************************************************************
    2433             :      * Check the call syntax and get the options
    2434             :      ************************************************************/
    2435         130 :     if (objc < 2)
    2436             :     {
    2437           2 :         Tcl_WrongNumArgs(interp, 1, objv,
    2438             :                          "?-count n? ?-array name? query ?loop body?");
    2439           2 :         return TCL_ERROR;
    2440             :     }
    2441             : 
    2442         128 :     i = 1;
    2443         128 :     while (i < objc)
    2444             :     {
    2445         144 :         if (Tcl_GetIndexFromObj(NULL, objv[i], options, NULL,
    2446             :                                 TCL_EXACT, &optIndex) != TCL_OK)
    2447         122 :             break;
    2448             : 
    2449          22 :         if (++i >= objc)
    2450             :         {
    2451           4 :             Tcl_SetObjResult(interp,
    2452             :                              Tcl_NewStringObj("missing argument to -count or -array", -1));
    2453           4 :             return TCL_ERROR;
    2454             :         }
    2455             : 
    2456          18 :         switch ((enum options) optIndex)
    2457             :         {
    2458          16 :             case OPT_ARRAY:
    2459          16 :                 arrayname = Tcl_GetString(objv[i++]);
    2460          16 :                 break;
    2461             : 
    2462           2 :             case OPT_COUNT:
    2463           2 :                 if (Tcl_GetIntFromObj(interp, objv[i++], &count) != TCL_OK)
    2464           2 :                     return TCL_ERROR;
    2465           0 :                 break;
    2466             :         }
    2467         144 :     }
    2468             : 
    2469         122 :     query_idx = i;
    2470         122 :     if (query_idx >= objc || query_idx + 2 < objc)
    2471             :     {
    2472           2 :         Tcl_WrongNumArgs(interp, query_idx - 1, objv, "query ?loop body?");
    2473           2 :         return TCL_ERROR;
    2474             :     }
    2475             : 
    2476         120 :     if (query_idx + 1 < objc)
    2477          16 :         loop_body = objv[query_idx + 1];
    2478             : 
    2479             :     /************************************************************
    2480             :      * Execute the query inside a sub-transaction, so we can cope with
    2481             :      * errors sanely
    2482             :      ************************************************************/
    2483             : 
    2484         120 :     pltcl_subtrans_begin(oldcontext, oldowner);
    2485             : 
    2486         120 :     PG_TRY();
    2487             :     {
    2488         120 :         UTF_BEGIN;
    2489         120 :         spi_rc = SPI_execute(UTF_U2E(Tcl_GetString(objv[query_idx])),
    2490         120 :                              pltcl_current_call_state->prodesc->fn_readonly, count);
    2491         104 :         UTF_END;
    2492             : 
    2493         104 :         my_rc = pltcl_process_SPI_result(interp,
    2494             :                                          arrayname,
    2495             :                                          loop_body,
    2496             :                                          spi_rc,
    2497             :                                          SPI_tuptable,
    2498             :                                          SPI_processed);
    2499             : 
    2500         104 :         pltcl_subtrans_commit(oldcontext, oldowner);
    2501             :     }
    2502          16 :     PG_CATCH();
    2503             :     {
    2504          16 :         pltcl_subtrans_abort(interp, oldcontext, oldowner);
    2505          16 :         return TCL_ERROR;
    2506             :     }
    2507         104 :     PG_END_TRY();
    2508             : 
    2509         104 :     return my_rc;
    2510             : }
    2511             : 
    2512             : /*
    2513             :  * Process the result from SPI_execute or SPI_execute_plan
    2514             :  *
    2515             :  * Shared code between pltcl_SPI_execute and pltcl_SPI_execute_plan
    2516             :  */
    2517             : static int
    2518         202 : pltcl_process_SPI_result(Tcl_Interp *interp,
    2519             :                          const char *arrayname,
    2520             :                          Tcl_Obj *loop_body,
    2521             :                          int spi_rc,
    2522             :                          SPITupleTable *tuptable,
    2523             :                          uint64 ntuples)
    2524             : {
    2525         202 :     int         my_rc = TCL_OK;
    2526             :     int         loop_rc;
    2527             :     HeapTuple  *tuples;
    2528             :     TupleDesc   tupdesc;
    2529             : 
    2530         202 :     switch (spi_rc)
    2531             :     {
    2532          74 :         case SPI_OK_SELINTO:
    2533             :         case SPI_OK_INSERT:
    2534             :         case SPI_OK_DELETE:
    2535             :         case SPI_OK_UPDATE:
    2536             :         case SPI_OK_MERGE:
    2537          74 :             Tcl_SetObjResult(interp, Tcl_NewWideIntObj(ntuples));
    2538          74 :             break;
    2539             : 
    2540           2 :         case SPI_OK_UTILITY:
    2541             :         case SPI_OK_REWRITTEN:
    2542           2 :             if (tuptable == NULL)
    2543             :             {
    2544           2 :                 Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
    2545           2 :                 break;
    2546             :             }
    2547             :             /* fall through for utility returning tuples */
    2548             :             /* FALLTHROUGH */
    2549             : 
    2550             :         case SPI_OK_SELECT:
    2551             :         case SPI_OK_INSERT_RETURNING:
    2552             :         case SPI_OK_DELETE_RETURNING:
    2553             :         case SPI_OK_UPDATE_RETURNING:
    2554             :         case SPI_OK_MERGE_RETURNING:
    2555             : 
    2556             :             /*
    2557             :              * Process the tuples we got
    2558             :              */
    2559         124 :             tuples = tuptable->vals;
    2560         124 :             tupdesc = tuptable->tupdesc;
    2561             : 
    2562         124 :             if (loop_body == NULL)
    2563             :             {
    2564             :                 /*
    2565             :                  * If there is no loop body given, just set the variables from
    2566             :                  * the first tuple (if any)
    2567             :                  */
    2568         100 :                 if (ntuples > 0)
    2569          58 :                     pltcl_set_tuple_values(interp, arrayname, 0,
    2570             :                                            tuples[0], tupdesc);
    2571             :             }
    2572             :             else
    2573             :             {
    2574             :                 /*
    2575             :                  * There is a loop body - process all tuples and evaluate the
    2576             :                  * body on each
    2577             :                  */
    2578             :                 uint64      i;
    2579             : 
    2580          52 :                 for (i = 0; i < ntuples; i++)
    2581             :                 {
    2582          44 :                     pltcl_set_tuple_values(interp, arrayname, i,
    2583          44 :                                            tuples[i], tupdesc);
    2584             : 
    2585          44 :                     loop_rc = Tcl_EvalObjEx(interp, loop_body, 0);
    2586             : 
    2587          44 :                     if (loop_rc == TCL_OK)
    2588          24 :                         continue;
    2589          20 :                     if (loop_rc == TCL_CONTINUE)
    2590           4 :                         continue;
    2591          16 :                     if (loop_rc == TCL_RETURN)
    2592             :                     {
    2593           4 :                         my_rc = TCL_RETURN;
    2594           4 :                         break;
    2595             :                     }
    2596          12 :                     if (loop_rc == TCL_BREAK)
    2597           4 :                         break;
    2598           8 :                     my_rc = TCL_ERROR;
    2599           8 :                     break;
    2600             :                 }
    2601             :             }
    2602             : 
    2603         124 :             if (my_rc == TCL_OK)
    2604             :             {
    2605         112 :                 Tcl_SetObjResult(interp, Tcl_NewWideIntObj(ntuples));
    2606             :             }
    2607         124 :             break;
    2608             : 
    2609           2 :         default:
    2610           2 :             Tcl_AppendResult(interp, "pltcl: SPI_execute failed: ",
    2611             :                              SPI_result_code_string(spi_rc), NULL);
    2612           2 :             my_rc = TCL_ERROR;
    2613           2 :             break;
    2614             :     }
    2615             : 
    2616         202 :     SPI_freetuptable(tuptable);
    2617             : 
    2618         202 :     return my_rc;
    2619             : }
    2620             : 
    2621             : 
    2622             : /**********************************************************************
    2623             :  * pltcl_SPI_prepare()      - Builtin support for prepared plans
    2624             :  *                The Tcl command SPI_prepare
    2625             :  *                always saves the plan using
    2626             :  *                SPI_keepplan and returns a key for
    2627             :  *                access. There is no chance to prepare
    2628             :  *                and not save the plan currently.
    2629             :  **********************************************************************/
    2630             : static int
    2631          34 : pltcl_SPI_prepare(ClientData cdata, Tcl_Interp *interp,
    2632             :                   int objc, Tcl_Obj *const objv[])
    2633             : {
    2634          34 :     volatile MemoryContext plan_cxt = NULL;
    2635             :     Tcl_Size    nargs;
    2636             :     Tcl_Obj   **argsObj;
    2637             :     pltcl_query_desc *qdesc;
    2638             :     int         i;
    2639             :     Tcl_HashEntry *hashent;
    2640             :     int         hashnew;
    2641             :     Tcl_HashTable *query_hash;
    2642          34 :     MemoryContext oldcontext = CurrentMemoryContext;
    2643          34 :     ResourceOwner oldowner = CurrentResourceOwner;
    2644             : 
    2645             :     /************************************************************
    2646             :      * Check the call syntax
    2647             :      ************************************************************/
    2648          34 :     if (objc != 3)
    2649             :     {
    2650           2 :         Tcl_WrongNumArgs(interp, 1, objv, "query argtypes");
    2651           2 :         return TCL_ERROR;
    2652             :     }
    2653             : 
    2654             :     /************************************************************
    2655             :      * Split the argument type list
    2656             :      ************************************************************/
    2657          32 :     if (Tcl_ListObjGetElements(interp, objv[2], &nargs, &argsObj) != TCL_OK)
    2658           2 :         return TCL_ERROR;
    2659             : 
    2660             :     /************************************************************
    2661             :      * Allocate the new querydesc structure
    2662             :      *
    2663             :      * struct qdesc and subsidiary data all live in plan_cxt.  Note that if the
    2664             :      * function is recompiled for whatever reason, permanent memory leaks
    2665             :      * occur.  FIXME someday.
    2666             :      ************************************************************/
    2667          30 :     plan_cxt = AllocSetContextCreate(TopMemoryContext,
    2668             :                                      "PL/Tcl spi_prepare query",
    2669             :                                      ALLOCSET_SMALL_SIZES);
    2670          30 :     MemoryContextSwitchTo(plan_cxt);
    2671          30 :     qdesc = (pltcl_query_desc *) palloc0(sizeof(pltcl_query_desc));
    2672          30 :     snprintf(qdesc->qname, sizeof(qdesc->qname), "%p", qdesc);
    2673          30 :     qdesc->nargs = nargs;
    2674          30 :     qdesc->argtypes = (Oid *) palloc(nargs * sizeof(Oid));
    2675          30 :     qdesc->arginfuncs = (FmgrInfo *) palloc(nargs * sizeof(FmgrInfo));
    2676          30 :     qdesc->argtypioparams = (Oid *) palloc(nargs * sizeof(Oid));
    2677          30 :     MemoryContextSwitchTo(oldcontext);
    2678             : 
    2679             :     /************************************************************
    2680             :      * Execute the prepare inside a sub-transaction, so we can cope with
    2681             :      * errors sanely
    2682             :      ************************************************************/
    2683             : 
    2684          30 :     pltcl_subtrans_begin(oldcontext, oldowner);
    2685             : 
    2686          30 :     PG_TRY();
    2687             :     {
    2688             :         /************************************************************
    2689             :          * Resolve argument type names and then look them up by oid
    2690             :          * in the system cache, and remember the required information
    2691             :          * for input conversion.
    2692             :          ************************************************************/
    2693          68 :         for (i = 0; i < nargs; i++)
    2694             :         {
    2695             :             Oid         typId,
    2696             :                         typInput,
    2697             :                         typIOParam;
    2698             :             int32       typmod;
    2699             : 
    2700          40 :             (void) parseTypeString(Tcl_GetString(argsObj[i]),
    2701             :                                    &typId, &typmod, NULL);
    2702             : 
    2703          38 :             getTypeInputInfo(typId, &typInput, &typIOParam);
    2704             : 
    2705          38 :             qdesc->argtypes[i] = typId;
    2706          38 :             fmgr_info_cxt(typInput, &(qdesc->arginfuncs[i]), plan_cxt);
    2707          38 :             qdesc->argtypioparams[i] = typIOParam;
    2708             :         }
    2709             : 
    2710             :         /************************************************************
    2711             :          * Prepare the plan and check for errors
    2712             :          ************************************************************/
    2713          28 :         UTF_BEGIN;
    2714          28 :         qdesc->plan = SPI_prepare(UTF_U2E(Tcl_GetString(objv[1])),
    2715             :                                   nargs, qdesc->argtypes);
    2716          26 :         UTF_END;
    2717             : 
    2718          26 :         if (qdesc->plan == NULL)
    2719           0 :             elog(ERROR, "SPI_prepare() failed");
    2720             : 
    2721             :         /************************************************************
    2722             :          * Save the plan into permanent memory (right now it's in the
    2723             :          * SPI procCxt, which will go away at function end).
    2724             :          ************************************************************/
    2725          26 :         if (SPI_keepplan(qdesc->plan))
    2726           0 :             elog(ERROR, "SPI_keepplan() failed");
    2727             : 
    2728          26 :         pltcl_subtrans_commit(oldcontext, oldowner);
    2729             :     }
    2730           4 :     PG_CATCH();
    2731             :     {
    2732           4 :         pltcl_subtrans_abort(interp, oldcontext, oldowner);
    2733             : 
    2734           4 :         MemoryContextDelete(plan_cxt);
    2735             : 
    2736           4 :         return TCL_ERROR;
    2737             :     }
    2738          26 :     PG_END_TRY();
    2739             : 
    2740             :     /************************************************************
    2741             :      * Insert a hashtable entry for the plan and return
    2742             :      * the key to the caller
    2743             :      ************************************************************/
    2744          26 :     query_hash = &pltcl_current_call_state->prodesc->interp_desc->query_hash;
    2745             : 
    2746          26 :     hashent = Tcl_CreateHashEntry(query_hash, qdesc->qname, &hashnew);
    2747          26 :     Tcl_SetHashValue(hashent, (ClientData) qdesc);
    2748             : 
    2749             :     /* qname is ASCII, so no need for encoding conversion */
    2750          26 :     Tcl_SetObjResult(interp, Tcl_NewStringObj(qdesc->qname, -1));
    2751          26 :     return TCL_OK;
    2752             : }
    2753             : 
    2754             : 
    2755             : /**********************************************************************
    2756             :  * pltcl_SPI_execute_plan()     - Execute a prepared plan
    2757             :  **********************************************************************/
    2758             : static int
    2759         110 : pltcl_SPI_execute_plan(ClientData cdata, Tcl_Interp *interp,
    2760             :                        int objc, Tcl_Obj *const objv[])
    2761             : {
    2762             :     int         my_rc;
    2763             :     int         spi_rc;
    2764             :     int         i;
    2765             :     int         j;
    2766             :     int         optIndex;
    2767             :     Tcl_HashEntry *hashent;
    2768             :     pltcl_query_desc *qdesc;
    2769         110 :     const char *nulls = NULL;
    2770         110 :     const char *arrayname = NULL;
    2771         110 :     Tcl_Obj    *loop_body = NULL;
    2772         110 :     int         count = 0;
    2773             :     Tcl_Size    callObjc;
    2774         110 :     Tcl_Obj   **callObjv = NULL;
    2775             :     Datum      *argvalues;
    2776         110 :     MemoryContext oldcontext = CurrentMemoryContext;
    2777         110 :     ResourceOwner oldowner = CurrentResourceOwner;
    2778             :     Tcl_HashTable *query_hash;
    2779             : 
    2780             :     enum options
    2781             :     {
    2782             :         OPT_ARRAY, OPT_COUNT, OPT_NULLS
    2783             :     };
    2784             : 
    2785             :     static const char *options[] = {
    2786             :         "-array", "-count", "-nulls", (const char *) NULL
    2787             :     };
    2788             : 
    2789             :     /************************************************************
    2790             :      * Get the options and check syntax
    2791             :      ************************************************************/
    2792         110 :     i = 1;
    2793         110 :     while (i < objc)
    2794             :     {
    2795         196 :         if (Tcl_GetIndexFromObj(NULL, objv[i], options, NULL,
    2796             :                                 TCL_EXACT, &optIndex) != TCL_OK)
    2797         100 :             break;
    2798             : 
    2799          96 :         if (++i >= objc)
    2800             :         {
    2801           6 :             Tcl_SetObjResult(interp,
    2802             :                              Tcl_NewStringObj("missing argument to -array, -count or -nulls", -1));
    2803           6 :             return TCL_ERROR;
    2804             :         }
    2805             : 
    2806          90 :         switch ((enum options) optIndex)
    2807             :         {
    2808           8 :             case OPT_ARRAY:
    2809           8 :                 arrayname = Tcl_GetString(objv[i++]);
    2810           8 :                 break;
    2811             : 
    2812          82 :             case OPT_COUNT:
    2813          82 :                 if (Tcl_GetIntFromObj(interp, objv[i++], &count) != TCL_OK)
    2814           2 :                     return TCL_ERROR;
    2815          80 :                 break;
    2816             : 
    2817           0 :             case OPT_NULLS:
    2818           0 :                 nulls = Tcl_GetString(objv[i++]);
    2819           0 :                 break;
    2820             :         }
    2821         198 :     }
    2822             : 
    2823             :     /************************************************************
    2824             :      * Get the prepared plan descriptor by its key
    2825             :      ************************************************************/
    2826         102 :     if (i >= objc)
    2827             :     {
    2828           2 :         Tcl_SetObjResult(interp,
    2829             :                          Tcl_NewStringObj("missing argument to -count or -array", -1));
    2830           2 :         return TCL_ERROR;
    2831             :     }
    2832             : 
    2833         100 :     query_hash = &pltcl_current_call_state->prodesc->interp_desc->query_hash;
    2834             : 
    2835         100 :     hashent = Tcl_FindHashEntry(query_hash, Tcl_GetString(objv[i]));
    2836         100 :     if (hashent == NULL)
    2837             :     {
    2838           2 :         Tcl_AppendResult(interp, "invalid queryid '", Tcl_GetString(objv[i]), "'", NULL);
    2839           2 :         return TCL_ERROR;
    2840             :     }
    2841          98 :     qdesc = (pltcl_query_desc *) Tcl_GetHashValue(hashent);
    2842          98 :     i++;
    2843             : 
    2844             :     /************************************************************
    2845             :      * If a nulls string is given, check for correct length
    2846             :      ************************************************************/
    2847          98 :     if (nulls != NULL)
    2848             :     {
    2849           0 :         if (strlen(nulls) != qdesc->nargs)
    2850             :         {
    2851           0 :             Tcl_SetObjResult(interp,
    2852             :                              Tcl_NewStringObj("length of nulls string doesn't match number of arguments",
    2853             :                                               -1));
    2854           0 :             return TCL_ERROR;
    2855             :         }
    2856             :     }
    2857             : 
    2858             :     /************************************************************
    2859             :      * If there was an argtype list on preparation, we need
    2860             :      * an argument value list now
    2861             :      ************************************************************/
    2862          98 :     if (qdesc->nargs > 0)
    2863             :     {
    2864          90 :         if (i >= objc)
    2865             :         {
    2866           0 :             Tcl_SetObjResult(interp,
    2867             :                              Tcl_NewStringObj("argument list length doesn't match number of arguments for query",
    2868             :                                               -1));
    2869           0 :             return TCL_ERROR;
    2870             :         }
    2871             : 
    2872             :         /************************************************************
    2873             :          * Split the argument values
    2874             :          ************************************************************/
    2875          90 :         if (Tcl_ListObjGetElements(interp, objv[i++], &callObjc, &callObjv) != TCL_OK)
    2876           0 :             return TCL_ERROR;
    2877             : 
    2878             :         /************************************************************
    2879             :          * Check that the number of arguments matches
    2880             :          ************************************************************/
    2881          90 :         if (callObjc != qdesc->nargs)
    2882             :         {
    2883           0 :             Tcl_SetObjResult(interp,
    2884             :                              Tcl_NewStringObj("argument list length doesn't match number of arguments for query",
    2885             :                                               -1));
    2886           0 :             return TCL_ERROR;
    2887             :         }
    2888             :     }
    2889             :     else
    2890           8 :         callObjc = 0;
    2891             : 
    2892             :     /************************************************************
    2893             :      * Get loop body if present
    2894             :      ************************************************************/
    2895          98 :     if (i < objc)
    2896           8 :         loop_body = objv[i++];
    2897             : 
    2898          98 :     if (i != objc)
    2899             :     {
    2900           0 :         Tcl_WrongNumArgs(interp, 1, objv,
    2901             :                          "?-count n? ?-array name? ?-nulls string? "
    2902             :                          "query ?args? ?loop body?");
    2903           0 :         return TCL_ERROR;
    2904             :     }
    2905             : 
    2906             :     /************************************************************
    2907             :      * Execute the plan inside a sub-transaction, so we can cope with
    2908             :      * errors sanely
    2909             :      ************************************************************/
    2910             : 
    2911          98 :     pltcl_subtrans_begin(oldcontext, oldowner);
    2912             : 
    2913          98 :     PG_TRY();
    2914             :     {
    2915             :         /************************************************************
    2916             :          * Setup the value array for SPI_execute_plan() using
    2917             :          * the type specific input functions
    2918             :          ************************************************************/
    2919          98 :         argvalues = (Datum *) palloc(callObjc * sizeof(Datum));
    2920             : 
    2921         284 :         for (j = 0; j < callObjc; j++)
    2922             :         {
    2923         186 :             if (nulls && nulls[j] == 'n')
    2924             :             {
    2925           0 :                 argvalues[j] = InputFunctionCall(&qdesc->arginfuncs[j],
    2926             :                                                  NULL,
    2927           0 :                                                  qdesc->argtypioparams[j],
    2928             :                                                  -1);
    2929             :             }
    2930             :             else
    2931             :             {
    2932         186 :                 UTF_BEGIN;
    2933         558 :                 argvalues[j] = InputFunctionCall(&qdesc->arginfuncs[j],
    2934         186 :                                                  UTF_U2E(Tcl_GetString(callObjv[j])),
    2935         186 :                                                  qdesc->argtypioparams[j],
    2936             :                                                  -1);
    2937         186 :                 UTF_END;
    2938             :             }
    2939             :         }
    2940             : 
    2941             :         /************************************************************
    2942             :          * Execute the plan
    2943             :          ************************************************************/
    2944         196 :         spi_rc = SPI_execute_plan(qdesc->plan, argvalues, nulls,
    2945          98 :                                   pltcl_current_call_state->prodesc->fn_readonly,
    2946             :                                   count);
    2947             : 
    2948          98 :         my_rc = pltcl_process_SPI_result(interp,
    2949             :                                          arrayname,
    2950             :                                          loop_body,
    2951             :                                          spi_rc,
    2952             :                                          SPI_tuptable,
    2953             :                                          SPI_processed);
    2954             : 
    2955          98 :         pltcl_subtrans_commit(oldcontext, oldowner);
    2956             :     }
    2957           0 :     PG_CATCH();
    2958             :     {
    2959           0 :         pltcl_subtrans_abort(interp, oldcontext, oldowner);
    2960           0 :         return TCL_ERROR;
    2961             :     }
    2962          98 :     PG_END_TRY();
    2963             : 
    2964          98 :     return my_rc;
    2965             : }
    2966             : 
    2967             : 
    2968             : /**********************************************************************
    2969             :  * pltcl_subtransaction()   - Execute some Tcl code in a subtransaction
    2970             :  *
    2971             :  * The subtransaction is aborted if the Tcl code fragment returns TCL_ERROR,
    2972             :  * otherwise it's subcommitted.
    2973             :  **********************************************************************/
    2974             : static int
    2975          16 : pltcl_subtransaction(ClientData cdata, Tcl_Interp *interp,
    2976             :                      int objc, Tcl_Obj *const objv[])
    2977             : {
    2978          16 :     MemoryContext oldcontext = CurrentMemoryContext;
    2979          16 :     ResourceOwner oldowner = CurrentResourceOwner;
    2980             :     int         retcode;
    2981             : 
    2982          16 :     if (objc != 2)
    2983             :     {
    2984           0 :         Tcl_WrongNumArgs(interp, 1, objv, "command");
    2985           0 :         return TCL_ERROR;
    2986             :     }
    2987             : 
    2988             :     /*
    2989             :      * Note: we don't use pltcl_subtrans_begin and friends here because we
    2990             :      * don't want the error handling in pltcl_subtrans_abort.  But otherwise
    2991             :      * the processing should be about the same as in those functions.
    2992             :      */
    2993          16 :     BeginInternalSubTransaction(NULL);
    2994          16 :     MemoryContextSwitchTo(oldcontext);
    2995             : 
    2996          16 :     retcode = Tcl_EvalObjEx(interp, objv[1], 0);
    2997             : 
    2998          16 :     if (retcode == TCL_ERROR)
    2999             :     {
    3000             :         /* Rollback the subtransaction */
    3001          10 :         RollbackAndReleaseCurrentSubTransaction();
    3002             :     }
    3003             :     else
    3004             :     {
    3005             :         /* Commit the subtransaction */
    3006           6 :         ReleaseCurrentSubTransaction();
    3007             :     }
    3008             : 
    3009             :     /* In either case, restore previous memory context and resource owner */
    3010          16 :     MemoryContextSwitchTo(oldcontext);
    3011          16 :     CurrentResourceOwner = oldowner;
    3012             : 
    3013          16 :     return retcode;
    3014             : }
    3015             : 
    3016             : 
    3017             : /**********************************************************************
    3018             :  * pltcl_commit()
    3019             :  *
    3020             :  * Commit the transaction and start a new one.
    3021             :  **********************************************************************/
    3022             : static int
    3023          20 : pltcl_commit(ClientData cdata, Tcl_Interp *interp,
    3024             :              int objc, Tcl_Obj *const objv[])
    3025             : {
    3026          20 :     MemoryContext oldcontext = CurrentMemoryContext;
    3027             : 
    3028          20 :     PG_TRY();
    3029             :     {
    3030          20 :         SPI_commit();
    3031             :     }
    3032          10 :     PG_CATCH();
    3033             :     {
    3034             :         ErrorData  *edata;
    3035             : 
    3036             :         /* Save error info */
    3037          10 :         MemoryContextSwitchTo(oldcontext);
    3038          10 :         edata = CopyErrorData();
    3039          10 :         FlushErrorState();
    3040             : 
    3041             :         /* Pass the error data to Tcl */
    3042          10 :         pltcl_construct_errorCode(interp, edata);
    3043          10 :         UTF_BEGIN;
    3044          10 :         Tcl_SetObjResult(interp, Tcl_NewStringObj(UTF_E2U(edata->message), -1));
    3045          10 :         UTF_END;
    3046          10 :         FreeErrorData(edata);
    3047             : 
    3048          10 :         return TCL_ERROR;
    3049             :     }
    3050          10 :     PG_END_TRY();
    3051             : 
    3052          10 :     return TCL_OK;
    3053             : }
    3054             : 
    3055             : 
    3056             : /**********************************************************************
    3057             :  * pltcl_rollback()
    3058             :  *
    3059             :  * Abort the transaction and start a new one.
    3060             :  **********************************************************************/
    3061             : static int
    3062          12 : pltcl_rollback(ClientData cdata, Tcl_Interp *interp,
    3063             :                int objc, Tcl_Obj *const objv[])
    3064             : {
    3065          12 :     MemoryContext oldcontext = CurrentMemoryContext;
    3066             : 
    3067          12 :     PG_TRY();
    3068             :     {
    3069          12 :         SPI_rollback();
    3070             :     }
    3071           2 :     PG_CATCH();
    3072             :     {
    3073             :         ErrorData  *edata;
    3074             : 
    3075             :         /* Save error info */
    3076           2 :         MemoryContextSwitchTo(oldcontext);
    3077           2 :         edata = CopyErrorData();
    3078           2 :         FlushErrorState();
    3079             : 
    3080             :         /* Pass the error data to Tcl */
    3081           2 :         pltcl_construct_errorCode(interp, edata);
    3082           2 :         UTF_BEGIN;
    3083           2 :         Tcl_SetObjResult(interp, Tcl_NewStringObj(UTF_E2U(edata->message), -1));
    3084           2 :         UTF_END;
    3085           2 :         FreeErrorData(edata);
    3086             : 
    3087           2 :         return TCL_ERROR;
    3088             :     }
    3089          10 :     PG_END_TRY();
    3090             : 
    3091          10 :     return TCL_OK;
    3092             : }
    3093             : 
    3094             : 
    3095             : /**********************************************************************
    3096             :  * pltcl_set_tuple_values() - Set variables for all attributes
    3097             :  *                of a given tuple
    3098             :  *
    3099             :  * Note: arrayname is presumed to be UTF8; it usually came from Tcl
    3100             :  **********************************************************************/
    3101             : static void
    3102         102 : pltcl_set_tuple_values(Tcl_Interp *interp, const char *arrayname,
    3103             :                        uint64 tupno, HeapTuple tuple, TupleDesc tupdesc)
    3104             : {
    3105             :     int         i;
    3106             :     char       *outputstr;
    3107             :     Datum       attr;
    3108             :     bool        isnull;
    3109             :     const char *attname;
    3110             :     Oid         typoutput;
    3111             :     bool        typisvarlena;
    3112             :     const char **arrptr;
    3113             :     const char **nameptr;
    3114         102 :     const char *nullname = NULL;
    3115             : 
    3116             :     /************************************************************
    3117             :      * Prepare pointers for Tcl_SetVar2Ex() below
    3118             :      ************************************************************/
    3119         102 :     if (arrayname == NULL)
    3120             :     {
    3121          58 :         arrptr = &attname;
    3122          58 :         nameptr = &nullname;
    3123             :     }
    3124             :     else
    3125             :     {
    3126          44 :         arrptr = &arrayname;
    3127          44 :         nameptr = &attname;
    3128             : 
    3129             :         /*
    3130             :          * When outputting to an array, fill the ".tupno" element with the
    3131             :          * current tuple number.  This will be overridden below if ".tupno" is
    3132             :          * in use as an actual field name in the rowtype.
    3133             :          */
    3134          44 :         Tcl_SetVar2Ex(interp, arrayname, ".tupno", Tcl_NewWideIntObj(tupno), 0);
    3135             :     }
    3136             : 
    3137         244 :     for (i = 0; i < tupdesc->natts; i++)
    3138             :     {
    3139         142 :         Form_pg_attribute att = TupleDescAttr(tupdesc, i);
    3140             : 
    3141             :         /* ignore dropped attributes */
    3142         142 :         if (att->attisdropped)
    3143           0 :             continue;
    3144             : 
    3145             :         /************************************************************
    3146             :          * Get the attribute name
    3147             :          ************************************************************/
    3148         142 :         UTF_BEGIN;
    3149         142 :         attname = pstrdup(UTF_E2U(NameStr(att->attname)));
    3150         142 :         UTF_END;
    3151             : 
    3152             :         /************************************************************
    3153             :          * Get the attributes value
    3154             :          ************************************************************/
    3155         142 :         attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
    3156             : 
    3157             :         /************************************************************
    3158             :          * If there is a value, set the variable
    3159             :          * If not, unset it
    3160             :          *
    3161             :          * Hmmm - Null attributes will cause functions to
    3162             :          *        crash if they don't expect them - need something
    3163             :          *        smarter here.
    3164             :          ************************************************************/
    3165         142 :         if (!isnull)
    3166             :         {
    3167         142 :             getTypeOutputInfo(att->atttypid, &typoutput, &typisvarlena);
    3168         142 :             outputstr = OidOutputFunctionCall(typoutput, attr);
    3169         142 :             UTF_BEGIN;
    3170         142 :             Tcl_SetVar2Ex(interp, *arrptr, *nameptr,
    3171         142 :                           Tcl_NewStringObj(UTF_E2U(outputstr), -1), 0);
    3172         142 :             UTF_END;
    3173         142 :             pfree(outputstr);
    3174             :         }
    3175             :         else
    3176           0 :             Tcl_UnsetVar2(interp, *arrptr, *nameptr, 0);
    3177             : 
    3178         142 :         pfree(unconstify(char *, attname));
    3179             :     }
    3180         102 : }
    3181             : 
    3182             : 
    3183             : /**********************************************************************
    3184             :  * pltcl_build_tuple_argument() - Build a list object usable for 'array set'
    3185             :  *                from all attributes of a given tuple
    3186             :  **********************************************************************/
    3187             : static Tcl_Obj *
    3188         138 : pltcl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc, bool include_generated)
    3189             : {
    3190         138 :     Tcl_Obj    *retobj = Tcl_NewObj();
    3191             :     int         i;
    3192             :     char       *outputstr;
    3193             :     Datum       attr;
    3194             :     bool        isnull;
    3195             :     char       *attname;
    3196             :     Oid         typoutput;
    3197             :     bool        typisvarlena;
    3198             : 
    3199         586 :     for (i = 0; i < tupdesc->natts; i++)
    3200             :     {
    3201         448 :         Form_pg_attribute att = TupleDescAttr(tupdesc, i);
    3202             : 
    3203             :         /* ignore dropped attributes */
    3204         448 :         if (att->attisdropped)
    3205          16 :             continue;
    3206             : 
    3207         432 :         if (att->attgenerated)
    3208             :         {
    3209             :             /* don't include unless requested */
    3210          36 :             if (!include_generated)
    3211          12 :                 continue;
    3212             :             /* never include virtual columns */
    3213          24 :             if (att->attgenerated == ATTRIBUTE_GENERATED_VIRTUAL)
    3214          12 :                 continue;
    3215             :         }
    3216             : 
    3217             :         /************************************************************
    3218             :          * Get the attribute name
    3219             :          ************************************************************/
    3220         408 :         attname = NameStr(att->attname);
    3221             : 
    3222             :         /************************************************************
    3223             :          * Get the attributes value
    3224             :          ************************************************************/
    3225         408 :         attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
    3226             : 
    3227             :         /************************************************************
    3228             :          * If there is a value, append the attribute name and the
    3229             :          * value to the list
    3230             :          *
    3231             :          * Hmmm - Null attributes will cause functions to
    3232             :          *        crash if they don't expect them - need something
    3233             :          *        smarter here.
    3234             :          ************************************************************/
    3235         408 :         if (!isnull)
    3236             :         {
    3237         400 :             getTypeOutputInfo(att->atttypid,
    3238             :                               &typoutput, &typisvarlena);
    3239         400 :             outputstr = OidOutputFunctionCall(typoutput, attr);
    3240         400 :             UTF_BEGIN;
    3241         400 :             Tcl_ListObjAppendElement(NULL, retobj,
    3242         400 :                                      Tcl_NewStringObj(UTF_E2U(attname), -1));
    3243         400 :             UTF_END;
    3244         400 :             UTF_BEGIN;
    3245         400 :             Tcl_ListObjAppendElement(NULL, retobj,
    3246         400 :                                      Tcl_NewStringObj(UTF_E2U(outputstr), -1));
    3247         400 :             UTF_END;
    3248         400 :             pfree(outputstr);
    3249             :         }
    3250             :     }
    3251             : 
    3252         138 :     return retobj;
    3253             : }
    3254             : 
    3255             : /**********************************************************************
    3256             :  * pltcl_build_tuple_result() - Build a tuple of function's result rowtype
    3257             :  *                from a Tcl list of column names and values
    3258             :  *
    3259             :  * In a trigger function, we build a tuple of the trigger table's rowtype.
    3260             :  *
    3261             :  * Note: this function leaks memory.  Even if we made it clean up its own
    3262             :  * mess, there's no way to prevent the datatype input functions it calls
    3263             :  * from leaking.  Run it in a short-lived context, unless we're about to
    3264             :  * exit the procedure anyway.
    3265             :  **********************************************************************/
    3266             : static HeapTuple
    3267          62 : pltcl_build_tuple_result(Tcl_Interp *interp, Tcl_Obj **kvObjv, int kvObjc,
    3268             :                          pltcl_call_state *call_state)
    3269             : {
    3270             :     HeapTuple   tuple;
    3271             :     TupleDesc   tupdesc;
    3272             :     AttInMetadata *attinmeta;
    3273             :     char      **values;
    3274             :     int         i;
    3275             : 
    3276          62 :     if (call_state->ret_tupdesc)
    3277             :     {
    3278          42 :         tupdesc = call_state->ret_tupdesc;
    3279          42 :         attinmeta = call_state->attinmeta;
    3280             :     }
    3281          20 :     else if (call_state->trigdata)
    3282             :     {
    3283          20 :         tupdesc = RelationGetDescr(call_state->trigdata->tg_relation);
    3284          20 :         attinmeta = TupleDescGetAttInMetadata(tupdesc);
    3285             :     }
    3286             :     else
    3287             :     {
    3288           0 :         elog(ERROR, "PL/Tcl function does not return a tuple");
    3289             :         tupdesc = NULL;         /* keep compiler quiet */
    3290             :         attinmeta = NULL;
    3291             :     }
    3292             : 
    3293          62 :     values = (char **) palloc0(tupdesc->natts * sizeof(char *));
    3294             : 
    3295          62 :     if (kvObjc % 2 != 0)
    3296           4 :         ereport(ERROR,
    3297             :                 (errcode(ERRCODE_INVALID_PARAMETER_VALUE),
    3298             :                  errmsg("column name/value list must have even number of elements")));
    3299             : 
    3300         196 :     for (i = 0; i < kvObjc; i += 2)
    3301             :     {
    3302         146 :         char       *fieldName = utf_u2e(Tcl_GetString(kvObjv[i]));
    3303         146 :         int         attn = SPI_fnumber(tupdesc, fieldName);
    3304             : 
    3305             :         /*
    3306             :          * We silently ignore ".tupno", if it's present but doesn't match any
    3307             :          * actual output column.  This allows direct use of a row returned by
    3308             :          * pltcl_set_tuple_values().
    3309             :          */
    3310         146 :         if (attn == SPI_ERROR_NOATTRIBUTE)
    3311             :         {
    3312           6 :             if (strcmp(fieldName, ".tupno") == 0)
    3313           0 :                 continue;
    3314           6 :             ereport(ERROR,
    3315             :                     (errcode(ERRCODE_UNDEFINED_COLUMN),
    3316             :                      errmsg("column name/value list contains nonexistent column name \"%s\"",
    3317             :                             fieldName)));
    3318             :         }
    3319             : 
    3320         140 :         if (attn <= 0)
    3321           0 :             ereport(ERROR,
    3322             :                     (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    3323             :                      errmsg("cannot set system attribute \"%s\"",
    3324             :                             fieldName)));
    3325             : 
    3326         140 :         if (TupleDescAttr(tupdesc, attn - 1)->attgenerated)
    3327           2 :             ereport(ERROR,
    3328             :                     (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
    3329             :                      errmsg("cannot set generated column \"%s\"",
    3330             :                             fieldName)));
    3331             : 
    3332         138 :         values[attn - 1] = utf_u2e(Tcl_GetString(kvObjv[i + 1]));
    3333             :     }
    3334             : 
    3335          50 :     tuple = BuildTupleFromCStrings(attinmeta, values);
    3336             : 
    3337             :     /* if result type is domain-over-composite, check domain constraints */
    3338          50 :     if (call_state->prodesc->fn_retisdomain)
    3339           6 :         domain_check(HeapTupleGetDatum(tuple), false,
    3340           6 :                      call_state->prodesc->result_typid,
    3341           6 :                      &call_state->prodesc->domain_info,
    3342           6 :                      call_state->prodesc->fn_cxt);
    3343             : 
    3344          48 :     return tuple;
    3345             : }
    3346             : 
    3347             : /**********************************************************************
    3348             :  * pltcl_init_tuple_store() - Initialize the result tuplestore for a SRF
    3349             :  **********************************************************************/
    3350             : static void
    3351          10 : pltcl_init_tuple_store(pltcl_call_state *call_state)
    3352             : {
    3353          10 :     ReturnSetInfo *rsi = call_state->rsi;
    3354             :     MemoryContext oldcxt;
    3355             :     ResourceOwner oldowner;
    3356             : 
    3357             :     /* Should be in a SRF */
    3358             :     Assert(rsi);
    3359             :     /* Should be first time through */
    3360             :     Assert(!call_state->tuple_store);
    3361             :     Assert(!call_state->attinmeta);
    3362             : 
    3363             :     /* We expect caller to provide an appropriate result tupdesc */
    3364             :     Assert(rsi->expectedDesc);
    3365          10 :     call_state->ret_tupdesc = rsi->expectedDesc;
    3366             : 
    3367             :     /*
    3368             :      * Switch to the right memory context and resource owner for storing the
    3369             :      * tuplestore. If we're within a subtransaction opened for an exception
    3370             :      * block, for example, we must still create the tuplestore in the resource
    3371             :      * owner that was active when this function was entered, and not in the
    3372             :      * subtransaction's resource owner.
    3373             :      */
    3374          10 :     oldcxt = MemoryContextSwitchTo(call_state->tuple_store_cxt);
    3375          10 :     oldowner = CurrentResourceOwner;
    3376          10 :     CurrentResourceOwner = call_state->tuple_store_owner;
    3377             : 
    3378          10 :     call_state->tuple_store =
    3379          10 :         tuplestore_begin_heap(rsi->allowedModes & SFRM_Materialize_Random,
    3380             :                               false, work_mem);
    3381             : 
    3382             :     /* Build attinmeta in this context, too */
    3383          10 :     call_state->attinmeta = TupleDescGetAttInMetadata(call_state->ret_tupdesc);
    3384             : 
    3385          10 :     CurrentResourceOwner = oldowner;
    3386          10 :     MemoryContextSwitchTo(oldcxt);
    3387          10 : }

Generated by: LCOV version 1.14