granicus.if.org Git - postgresql/blob - src/pl/tcl/pltcl.c

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