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

Generated by: LCOV version 1.13