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

Generated by: LCOV version 1.13