/********************************************************************** * pltcl.c - PostgreSQL support for Tcl as * procedural language (PL) * * src/pl/tcl/pltcl.c * **********************************************************************/ #include "postgres.h" #include #include #include #include "access/htup_details.h" #include "access/xact.h" #include "catalog/objectaccess.h" #include "catalog/pg_proc.h" #include "catalog/pg_type.h" #include "commands/event_trigger.h" #include "commands/trigger.h" #include "executor/spi.h" #include "fmgr.h" #include "funcapi.h" #include "mb/pg_wchar.h" #include "miscadmin.h" #include "nodes/makefuncs.h" #include "parser/parse_func.h" #include "parser/parse_type.h" #include "pgstat.h" #include "tcop/tcopprot.h" #include "utils/acl.h" #include "utils/builtins.h" #include "utils/lsyscache.h" #include "utils/memutils.h" #include "utils/regproc.h" #include "utils/rel.h" #include "utils/syscache.h" #include "utils/typcache.h" PG_MODULE_MAGIC; #define HAVE_TCL_VERSION(maj,min) \ ((TCL_MAJOR_VERSION > maj) || \ (TCL_MAJOR_VERSION == maj && TCL_MINOR_VERSION >= min)) /* Insist on Tcl >= 8.4 */ #if !HAVE_TCL_VERSION(8,4) #error PostgreSQL only supports Tcl 8.4 or later. #endif /* Hack to deal with Tcl 8.6 const-ification without losing compatibility */ #ifndef CONST86 #define CONST86 #endif /* define our text domain for translations */ #undef TEXTDOMAIN #define TEXTDOMAIN PG_TEXTDOMAIN("pltcl") /* * Support for converting between UTF8 (which is what all strings going into * or out of Tcl should be) and the database encoding. * * If you just use utf_u2e() or utf_e2u() directly, they will leak some * palloc'd space when doing a conversion. This is not worth worrying about * if it only happens, say, once per PL/Tcl function call. If it does seem * worth worrying about, use the wrapper macros. */ static inline char * utf_u2e(const char *src) { return pg_any_to_server(src, strlen(src), PG_UTF8); } static inline char * utf_e2u(const char *src) { return pg_server_to_any(src, strlen(src), PG_UTF8); } #define UTF_BEGIN \ do { \ const char *_pltcl_utf_src = NULL; \ char *_pltcl_utf_dst = NULL #define UTF_END \ if (_pltcl_utf_src != (const char *) _pltcl_utf_dst) \ pfree(_pltcl_utf_dst); \ } while (0) #define UTF_U2E(x) \ (_pltcl_utf_dst = utf_u2e(_pltcl_utf_src = (x))) #define UTF_E2U(x) \ (_pltcl_utf_dst = utf_e2u(_pltcl_utf_src = (x))) /********************************************************************** * Information associated with a Tcl interpreter. We have one interpreter * that is used for all pltclu (untrusted) functions. For pltcl (trusted) * functions, there is a separate interpreter for each effective SQL userid. * (This is needed to ensure that an unprivileged user can't inject Tcl code * that'll be executed with the privileges of some other SQL user.) * * The pltcl_interp_desc structs are kept in a Postgres hash table indexed * by userid OID, with OID 0 used for the single untrusted interpreter. **********************************************************************/ typedef struct pltcl_interp_desc { Oid user_id; /* Hash key (must be first!) */ Tcl_Interp *interp; /* The interpreter */ Tcl_HashTable query_hash; /* pltcl_query_desc structs */ } pltcl_interp_desc; /********************************************************************** * The information we cache about loaded procedures * * The pltcl_proc_desc struct itself, as well as all subsidiary data, * is stored in the memory context identified by the fn_cxt field. * We can reclaim all the data by deleting that context, and should do so * when the fn_refcount goes to zero. (But note that we do not bother * trying to clean up Tcl's copy of the procedure definition: it's Tcl's * problem to manage its memory when we replace a proc definition. We do * not clean up pltcl_proc_descs when a pg_proc row is deleted, only when * it is updated, and the same policy applies to Tcl's copy as well.) * * Note that the data in this struct is shared across all active calls; * nothing except the fn_refcount should be changed by a call instance. **********************************************************************/ typedef struct pltcl_proc_desc { char *user_proname; /* user's name (from pg_proc.proname) */ char *internal_proname; /* Tcl name (based on function OID) */ MemoryContext fn_cxt; /* memory context for this procedure */ unsigned long fn_refcount; /* number of active references */ TransactionId fn_xmin; /* xmin of pg_proc row */ ItemPointerData fn_tid; /* TID of pg_proc row */ bool fn_readonly; /* is function readonly? */ bool lanpltrusted; /* is it pltcl (vs. pltclu)? */ pltcl_interp_desc *interp_desc; /* interpreter to use */ Oid result_typid; /* OID of fn's result type */ FmgrInfo result_in_func; /* input function for fn's result type */ Oid result_typioparam; /* param to pass to same */ bool fn_retisset; /* true if function returns a set */ bool fn_retistuple; /* true if function returns composite */ bool fn_retisdomain; /* true if function returns domain */ void *domain_info; /* opaque cache for domain checks */ int nargs; /* number of arguments */ /* these arrays have nargs entries: */ FmgrInfo *arg_out_func; /* output fns for arg types */ bool *arg_is_rowtype; /* is each arg composite? */ } pltcl_proc_desc; /********************************************************************** * The information we cache about prepared and saved plans **********************************************************************/ typedef struct pltcl_query_desc { char qname[20]; SPIPlanPtr plan; int nargs; Oid *argtypes; FmgrInfo *arginfuncs; Oid *argtypioparams; } pltcl_query_desc; /********************************************************************** * For speedy lookup, we maintain a hash table mapping from * function OID + trigger flag + user OID to pltcl_proc_desc pointers. * The reason the pltcl_proc_desc struct isn't directly part of the hash * entry is to simplify recovery from errors during compile_pltcl_function. * * Note: if the same function is called by multiple userIDs within a session, * there will be a separate pltcl_proc_desc entry for each userID in the case * of pltcl functions, but only one entry for pltclu functions, because we * set user_id = 0 for that case. **********************************************************************/ typedef struct pltcl_proc_key { Oid proc_id; /* Function OID */ /* * is_trigger is really a bool, but declare as Oid to ensure this struct * contains no padding */ Oid is_trigger; /* is it a trigger function? */ Oid user_id; /* User calling the function, or 0 */ } pltcl_proc_key; typedef struct pltcl_proc_ptr { pltcl_proc_key proc_key; /* Hash key (must be first!) */ pltcl_proc_desc *proc_ptr; } pltcl_proc_ptr; /********************************************************************** * Per-call state **********************************************************************/ typedef struct pltcl_call_state { /* Call info struct, or NULL in a trigger */ FunctionCallInfo fcinfo; /* Trigger data, if we're in a normal (not event) trigger; else NULL */ TriggerData *trigdata; /* Function we're executing (NULL if not yet identified) */ pltcl_proc_desc *prodesc; /* * Information for SRFs and functions returning composite types. * ret_tupdesc and attinmeta are set up if either fn_retistuple or * fn_retisset, since even a scalar-returning SRF needs a tuplestore. */ TupleDesc ret_tupdesc; /* return rowtype, if retistuple or retisset */ AttInMetadata *attinmeta; /* metadata for building tuples of that type */ ReturnSetInfo *rsi; /* passed-in ReturnSetInfo, if any */ Tuplestorestate *tuple_store; /* SRFs accumulate result here */ MemoryContext tuple_store_cxt; /* context and resowner for tuplestore */ ResourceOwner tuple_store_owner; } pltcl_call_state; /********************************************************************** * Global data **********************************************************************/ static char *pltcl_start_proc = NULL; static char *pltclu_start_proc = NULL; static bool pltcl_pm_init_done = false; static Tcl_Interp *pltcl_hold_interp = NULL; static HTAB *pltcl_interp_htab = NULL; static HTAB *pltcl_proc_htab = NULL; /* this is saved and restored by pltcl_handler */ static pltcl_call_state *pltcl_current_call_state = NULL; /********************************************************************** * Lookup table for SQLSTATE condition names **********************************************************************/ typedef struct { const char *label; int sqlerrstate; } TclExceptionNameMap; static const TclExceptionNameMap exception_name_map[] = { #include "pltclerrcodes.h" /* pgrminclude ignore */ {NULL, 0} }; /********************************************************************** * Forward declarations **********************************************************************/ void _PG_init(void); static void pltcl_init_interp(pltcl_interp_desc *interp_desc, Oid prolang, bool pltrusted); static pltcl_interp_desc *pltcl_fetch_interp(Oid prolang, bool pltrusted); static void call_pltcl_start_proc(Oid prolang, bool pltrusted); static void start_proc_error_callback(void *arg); static Datum pltcl_handler(PG_FUNCTION_ARGS, bool pltrusted); static Datum pltcl_func_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state, bool pltrusted); static HeapTuple pltcl_trigger_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state, bool pltrusted); static void pltcl_event_trigger_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state, bool pltrusted); static void throw_tcl_error(Tcl_Interp *interp, const char *proname); static pltcl_proc_desc *compile_pltcl_function(Oid fn_oid, Oid tgreloid, bool is_event_trigger, bool pltrusted); static int pltcl_elog(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void pltcl_construct_errorCode(Tcl_Interp *interp, ErrorData *edata); static const char *pltcl_get_condition_name(int sqlstate); static int pltcl_quote(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int pltcl_argisnull(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int pltcl_returnnull(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int pltcl_returnnext(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int pltcl_SPI_execute(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int pltcl_process_SPI_result(Tcl_Interp *interp, const char *arrayname, Tcl_Obj *loop_body, int spi_rc, SPITupleTable *tuptable, uint64 ntuples); static int pltcl_SPI_prepare(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int pltcl_SPI_execute_plan(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int pltcl_subtransaction(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int pltcl_commit(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int pltcl_rollback(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void pltcl_subtrans_begin(MemoryContext oldcontext, ResourceOwner oldowner); static void pltcl_subtrans_commit(MemoryContext oldcontext, ResourceOwner oldowner); static void pltcl_subtrans_abort(Tcl_Interp *interp, MemoryContext oldcontext, ResourceOwner oldowner); static void pltcl_set_tuple_values(Tcl_Interp *interp, const char *arrayname, uint64 tupno, HeapTuple tuple, TupleDesc tupdesc); static Tcl_Obj *pltcl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc, bool include_generated); static HeapTuple pltcl_build_tuple_result(Tcl_Interp *interp, Tcl_Obj **kvObjv, int kvObjc, pltcl_call_state *call_state); static void pltcl_init_tuple_store(pltcl_call_state *call_state); /* * Hack to override Tcl's builtin Notifier subsystem. This prevents the * backend from becoming multithreaded, which breaks all sorts of things. * That happens in the default version of Tcl_InitNotifier if the TCL library * has been compiled with multithreading support (i.e. when TCL_THREADS is * defined under Unix, and in all cases under Windows). * It's okay to disable the notifier because we never enter the Tcl event loop * from Postgres, so the notifier capabilities are initialized, but never * used. Only InitNotifier and DeleteFileHandler ever seem to get called * within Postgres, but we implement all the functions for completeness. */ static ClientData pltcl_InitNotifier(void) { static int fakeThreadKey; /* To give valid address for ClientData */ return (ClientData) &(fakeThreadKey); } static void pltcl_FinalizeNotifier(ClientData clientData) { } static void pltcl_SetTimer(CONST86 Tcl_Time *timePtr) { } static void pltcl_AlertNotifier(ClientData clientData) { } static void pltcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, ClientData clientData) { } static void pltcl_DeleteFileHandler(int fd) { } static void pltcl_ServiceModeHook(int mode) { } static int pltcl_WaitForEvent(CONST86 Tcl_Time *timePtr) { return 0; } /* * _PG_init() - library load-time initialization * * DO NOT make this static nor change its name! * * The work done here must be safe to do in the postmaster process, * in case the pltcl library is preloaded in the postmaster. */ void _PG_init(void) { Tcl_NotifierProcs notifier; HASHCTL hash_ctl; /* Be sure we do initialization only once (should be redundant now) */ if (pltcl_pm_init_done) return; pg_bindtextdomain(TEXTDOMAIN); #ifdef WIN32 /* Required on win32 to prevent error loading init.tcl */ Tcl_FindExecutable(""); #endif /* * Override the functions in the Notifier subsystem. See comments above. */ notifier.setTimerProc = pltcl_SetTimer; notifier.waitForEventProc = pltcl_WaitForEvent; notifier.createFileHandlerProc = pltcl_CreateFileHandler; notifier.deleteFileHandlerProc = pltcl_DeleteFileHandler; notifier.initNotifierProc = pltcl_InitNotifier; notifier.finalizeNotifierProc = pltcl_FinalizeNotifier; notifier.alertNotifierProc = pltcl_AlertNotifier; notifier.serviceModeHookProc = pltcl_ServiceModeHook; Tcl_SetNotifier(¬ifier); /************************************************************ * Create the dummy hold interpreter to prevent close of * stdout and stderr on DeleteInterp ************************************************************/ if ((pltcl_hold_interp = Tcl_CreateInterp()) == NULL) elog(ERROR, "could not create dummy Tcl interpreter"); if (Tcl_Init(pltcl_hold_interp) == TCL_ERROR) elog(ERROR, "could not initialize dummy Tcl interpreter"); /************************************************************ * Create the hash table for working interpreters ************************************************************/ hash_ctl.keysize = sizeof(Oid); hash_ctl.entrysize = sizeof(pltcl_interp_desc); pltcl_interp_htab = hash_create("PL/Tcl interpreters", 8, &hash_ctl, HASH_ELEM | HASH_BLOBS); /************************************************************ * Create the hash table for function lookup ************************************************************/ hash_ctl.keysize = sizeof(pltcl_proc_key); hash_ctl.entrysize = sizeof(pltcl_proc_ptr); pltcl_proc_htab = hash_create("PL/Tcl functions", 100, &hash_ctl, HASH_ELEM | HASH_BLOBS); /************************************************************ * Define PL/Tcl's custom GUCs ************************************************************/ DefineCustomStringVariable("pltcl.start_proc", gettext_noop("PL/Tcl function to call once when pltcl is first used."), NULL, &pltcl_start_proc, NULL, PGC_SUSET, 0, NULL, NULL, NULL); DefineCustomStringVariable("pltclu.start_proc", gettext_noop("PL/TclU function to call once when pltclu is first used."), NULL, &pltclu_start_proc, NULL, PGC_SUSET, 0, NULL, NULL, NULL); pltcl_pm_init_done = true; } /********************************************************************** * pltcl_init_interp() - initialize a new Tcl interpreter **********************************************************************/ static void pltcl_init_interp(pltcl_interp_desc *interp_desc, Oid prolang, bool pltrusted) { Tcl_Interp *interp; char interpname[32]; /************************************************************ * Create the Tcl interpreter subsidiary to pltcl_hold_interp. * Note: Tcl automatically does Tcl_Init in the untrusted case, * and it's not wanted in the trusted case. ************************************************************/ snprintf(interpname, sizeof(interpname), "subsidiary_%u", interp_desc->user_id); if ((interp = Tcl_CreateSlave(pltcl_hold_interp, interpname, pltrusted ? 1 : 0)) == NULL) elog(ERROR, "could not create subsidiary Tcl interpreter"); /************************************************************ * Initialize the query hash table associated with interpreter ************************************************************/ Tcl_InitHashTable(&interp_desc->query_hash, TCL_STRING_KEYS); /************************************************************ * Install the commands for SPI support in the interpreter ************************************************************/ Tcl_CreateObjCommand(interp, "elog", pltcl_elog, NULL, NULL); Tcl_CreateObjCommand(interp, "quote", pltcl_quote, NULL, NULL); Tcl_CreateObjCommand(interp, "argisnull", pltcl_argisnull, NULL, NULL); Tcl_CreateObjCommand(interp, "return_null", pltcl_returnnull, NULL, NULL); Tcl_CreateObjCommand(interp, "return_next", pltcl_returnnext, NULL, NULL); Tcl_CreateObjCommand(interp, "spi_exec", pltcl_SPI_execute, NULL, NULL); Tcl_CreateObjCommand(interp, "spi_prepare", pltcl_SPI_prepare, NULL, NULL); Tcl_CreateObjCommand(interp, "spi_execp", pltcl_SPI_execute_plan, NULL, NULL); Tcl_CreateObjCommand(interp, "subtransaction", pltcl_subtransaction, NULL, NULL); Tcl_CreateObjCommand(interp, "commit", pltcl_commit, NULL, NULL); Tcl_CreateObjCommand(interp, "rollback", pltcl_rollback, NULL, NULL); /************************************************************ * Call the appropriate start_proc, if there is one. * * We must set interp_desc->interp before the call, else the start_proc * won't find the interpreter it's supposed to use. But, if the * start_proc fails, we want to abandon use of the interpreter. ************************************************************/ PG_TRY(); { interp_desc->interp = interp; call_pltcl_start_proc(prolang, pltrusted); } PG_CATCH(); { interp_desc->interp = NULL; Tcl_DeleteInterp(interp); PG_RE_THROW(); } PG_END_TRY(); } /********************************************************************** * pltcl_fetch_interp() - fetch the Tcl interpreter to use for a function * * This also takes care of any on-first-use initialization required. **********************************************************************/ static pltcl_interp_desc * pltcl_fetch_interp(Oid prolang, bool pltrusted) { Oid user_id; pltcl_interp_desc *interp_desc; bool found; /* Find or create the interpreter hashtable entry for this userid */ if (pltrusted) user_id = GetUserId(); else user_id = InvalidOid; interp_desc = hash_search(pltcl_interp_htab, &user_id, HASH_ENTER, &found); if (!found) interp_desc->interp = NULL; /* If we haven't yet successfully made an interpreter, try to do that */ if (!interp_desc->interp) pltcl_init_interp(interp_desc, prolang, pltrusted); return interp_desc; } /********************************************************************** * call_pltcl_start_proc() - Call user-defined initialization proc, if any **********************************************************************/ static void call_pltcl_start_proc(Oid prolang, bool pltrusted) { LOCAL_FCINFO(fcinfo, 0); char *start_proc; const char *gucname; ErrorContextCallback errcallback; List *namelist; Oid procOid; HeapTuple procTup; Form_pg_proc procStruct; AclResult aclresult; FmgrInfo finfo; PgStat_FunctionCallUsage fcusage; /* select appropriate GUC */ start_proc = pltrusted ? pltcl_start_proc : pltclu_start_proc; gucname = pltrusted ? "pltcl.start_proc" : "pltclu.start_proc"; /* Nothing to do if it's empty or unset */ if (start_proc == NULL || start_proc[0] == '\0') return; /* Set up errcontext callback to make errors more helpful */ errcallback.callback = start_proc_error_callback; errcallback.arg = unconstify(char *, gucname); errcallback.previous = error_context_stack; error_context_stack = &errcallback; /* Parse possibly-qualified identifier and look up the function */ namelist = stringToQualifiedNameList(start_proc); procOid = LookupFuncName(namelist, 0, NULL, false); /* Current user must have permission to call function */ aclresult = pg_proc_aclcheck(procOid, GetUserId(), ACL_EXECUTE); if (aclresult != ACLCHECK_OK) aclcheck_error(aclresult, OBJECT_FUNCTION, start_proc); /* Get the function's pg_proc entry */ procTup = SearchSysCache1(PROCOID, ObjectIdGetDatum(procOid)); if (!HeapTupleIsValid(procTup)) elog(ERROR, "cache lookup failed for function %u", procOid); procStruct = (Form_pg_proc) GETSTRUCT(procTup); /* It must be same language as the function we're currently calling */ if (procStruct->prolang != prolang) ereport(ERROR, (errcode(ERRCODE_OBJECT_NOT_IN_PREREQUISITE_STATE), errmsg("function \"%s\" is in the wrong language", start_proc))); /* * It must not be SECURITY DEFINER, either. This together with the * language match check ensures that the function will execute in the same * Tcl interpreter we just finished initializing. */ if (procStruct->prosecdef) ereport(ERROR, (errcode(ERRCODE_OBJECT_NOT_IN_PREREQUISITE_STATE), errmsg("function \"%s\" must not be SECURITY DEFINER", start_proc))); /* A-OK */ ReleaseSysCache(procTup); /* * Call the function using the normal SQL function call mechanism. We * could perhaps cheat and jump directly to pltcl_handler(), but it seems * better to do it this way so that the call is exposed to, eg, call * statistics collection. */ InvokeFunctionExecuteHook(procOid); fmgr_info(procOid, &finfo); InitFunctionCallInfoData(*fcinfo, &finfo, 0, InvalidOid, NULL, NULL); pgstat_init_function_usage(fcinfo, &fcusage); (void) FunctionCallInvoke(fcinfo); pgstat_end_function_usage(&fcusage, true); /* Pop the error context stack */ error_context_stack = errcallback.previous; } /* * Error context callback for errors occurring during start_proc processing. */ static void start_proc_error_callback(void *arg) { const char *gucname = (const char *) arg; /* translator: %s is "pltcl.start_proc" or "pltclu.start_proc" */ errcontext("processing %s parameter", gucname); } /********************************************************************** * pltcl_call_handler - This is the only visible function * of the PL interpreter. The PostgreSQL * function manager and trigger manager * call this function for execution of * PL/Tcl procedures. **********************************************************************/ PG_FUNCTION_INFO_V1(pltcl_call_handler); /* keep non-static */ Datum pltcl_call_handler(PG_FUNCTION_ARGS) { return pltcl_handler(fcinfo, true); } /* * Alternative handler for unsafe functions */ PG_FUNCTION_INFO_V1(pltclu_call_handler); /* keep non-static */ Datum pltclu_call_handler(PG_FUNCTION_ARGS) { return pltcl_handler(fcinfo, false); } /********************************************************************** * pltcl_handler() - Handler for function and trigger calls, for * both trusted and untrusted interpreters. **********************************************************************/ static Datum pltcl_handler(PG_FUNCTION_ARGS, bool pltrusted) { Datum retval = (Datum) 0; pltcl_call_state current_call_state; pltcl_call_state *save_call_state; /* * Initialize current_call_state to nulls/zeroes; in particular, set its * prodesc pointer to null. Anything that sets it non-null should * increase the prodesc's fn_refcount at the same time. We'll decrease * the refcount, and then delete the prodesc if it's no longer referenced, * on the way out of this function. This ensures that prodescs live as * long as needed even if somebody replaces the originating pg_proc row * while they're executing. */ memset(¤t_call_state, 0, sizeof(current_call_state)); /* * Ensure that static pointer is saved/restored properly */ save_call_state = pltcl_current_call_state; pltcl_current_call_state = ¤t_call_state; PG_TRY(); { /* * Determine if called as function or trigger and call appropriate * subhandler */ if (CALLED_AS_TRIGGER(fcinfo)) { /* invoke the trigger handler */ retval = PointerGetDatum(pltcl_trigger_handler(fcinfo, ¤t_call_state, pltrusted)); } else if (CALLED_AS_EVENT_TRIGGER(fcinfo)) { /* invoke the event trigger handler */ pltcl_event_trigger_handler(fcinfo, ¤t_call_state, pltrusted); retval = (Datum) 0; } else { /* invoke the regular function handler */ current_call_state.fcinfo = fcinfo; retval = pltcl_func_handler(fcinfo, ¤t_call_state, pltrusted); } } PG_FINALLY(); { /* Restore static pointer, then clean up the prodesc refcount if any */ /* * (We're being paranoid in case an error is thrown in context * deletion) */ pltcl_current_call_state = save_call_state; if (current_call_state.prodesc != NULL) { Assert(current_call_state.prodesc->fn_refcount > 0); if (--current_call_state.prodesc->fn_refcount == 0) MemoryContextDelete(current_call_state.prodesc->fn_cxt); } } PG_END_TRY(); return retval; } /********************************************************************** * pltcl_func_handler() - Handler for regular function calls **********************************************************************/ static Datum pltcl_func_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state, bool pltrusted) { bool nonatomic; pltcl_proc_desc *prodesc; Tcl_Interp *volatile interp; Tcl_Obj *tcl_cmd; int i; int tcl_rc; Datum retval; nonatomic = fcinfo->context && IsA(fcinfo->context, CallContext) && !castNode(CallContext, fcinfo->context)->atomic; /* Connect to SPI manager */ if (SPI_connect_ext(nonatomic ? SPI_OPT_NONATOMIC : 0) != SPI_OK_CONNECT) elog(ERROR, "could not connect to SPI manager"); /* Find or compile the function */ prodesc = compile_pltcl_function(fcinfo->flinfo->fn_oid, InvalidOid, false, pltrusted); call_state->prodesc = prodesc; prodesc->fn_refcount++; interp = prodesc->interp_desc->interp; /* * If we're a SRF, check caller can handle materialize mode, and save * relevant info into call_state. We must ensure that the returned * tuplestore is owned by the caller's context, even if we first create it * inside a subtransaction. */ if (prodesc->fn_retisset) { ReturnSetInfo *rsi = (ReturnSetInfo *) fcinfo->resultinfo; if (!rsi || !IsA(rsi, ReturnSetInfo) || (rsi->allowedModes & SFRM_Materialize) == 0) ereport(ERROR, (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), errmsg("set-valued function called in context that cannot accept a set"))); call_state->rsi = rsi; call_state->tuple_store_cxt = rsi->econtext->ecxt_per_query_memory; call_state->tuple_store_owner = CurrentResourceOwner; } /************************************************************ * Create the tcl command to call the internal * proc in the Tcl interpreter ************************************************************/ tcl_cmd = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj(prodesc->internal_proname, -1)); /* We hold a refcount on tcl_cmd just to be sure it stays around */ Tcl_IncrRefCount(tcl_cmd); /************************************************************ * Add all call arguments to the command ************************************************************/ PG_TRY(); { for (i = 0; i < prodesc->nargs; i++) { if (prodesc->arg_is_rowtype[i]) { /************************************************** * For tuple values, add a list for 'array set ...' **************************************************/ if (fcinfo->args[i].isnull) Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj()); else { HeapTupleHeader td; Oid tupType; int32 tupTypmod; TupleDesc tupdesc; HeapTupleData tmptup; Tcl_Obj *list_tmp; td = DatumGetHeapTupleHeader(fcinfo->args[i].value); /* Extract rowtype info and find a tupdesc */ tupType = HeapTupleHeaderGetTypeId(td); tupTypmod = HeapTupleHeaderGetTypMod(td); tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod); /* Build a temporary HeapTuple control structure */ tmptup.t_len = HeapTupleHeaderGetDatumLength(td); tmptup.t_data = td; list_tmp = pltcl_build_tuple_argument(&tmptup, tupdesc, true); Tcl_ListObjAppendElement(NULL, tcl_cmd, list_tmp); ReleaseTupleDesc(tupdesc); } } else { /************************************************** * Single values are added as string element * of their external representation **************************************************/ if (fcinfo->args[i].isnull) Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj()); else { char *tmp; tmp = OutputFunctionCall(&prodesc->arg_out_func[i], fcinfo->args[i].value); UTF_BEGIN; Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj(UTF_E2U(tmp), -1)); UTF_END; pfree(tmp); } } } } PG_CATCH(); { /* Release refcount to free tcl_cmd */ Tcl_DecrRefCount(tcl_cmd); PG_RE_THROW(); } PG_END_TRY(); /************************************************************ * Call the Tcl function * * We assume no PG error can be thrown directly from this call. ************************************************************/ tcl_rc = Tcl_EvalObjEx(interp, tcl_cmd, (TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL)); /* Release refcount to free tcl_cmd (and all subsidiary objects) */ Tcl_DecrRefCount(tcl_cmd); /************************************************************ * Check for errors reported by Tcl. ************************************************************/ if (tcl_rc != TCL_OK) throw_tcl_error(interp, prodesc->user_proname); /************************************************************ * Disconnect from SPI manager and then create the return * value datum (if the input function does a palloc for it * this must not be allocated in the SPI memory context * because SPI_finish would free it). But don't try to call * the result_in_func if we've been told to return a NULL; * the Tcl result may not be a valid value of the result type * in that case. ************************************************************/ if (SPI_finish() != SPI_OK_FINISH) elog(ERROR, "SPI_finish() failed"); if (prodesc->fn_retisset) { ReturnSetInfo *rsi = call_state->rsi; /* We already checked this is OK */ rsi->returnMode = SFRM_Materialize; /* If we produced any tuples, send back the result */ if (call_state->tuple_store) { rsi->setResult = call_state->tuple_store; if (call_state->ret_tupdesc) { MemoryContext oldcxt; oldcxt = MemoryContextSwitchTo(call_state->tuple_store_cxt); rsi->setDesc = CreateTupleDescCopy(call_state->ret_tupdesc); MemoryContextSwitchTo(oldcxt); } } retval = (Datum) 0; fcinfo->isnull = true; } else if (fcinfo->isnull) { retval = InputFunctionCall(&prodesc->result_in_func, NULL, prodesc->result_typioparam, -1); } else if (prodesc->fn_retistuple) { TupleDesc td; HeapTuple tup; Tcl_Obj *resultObj; Tcl_Obj **resultObjv; int resultObjc; /* * Set up data about result type. XXX it's tempting to consider * caching this in the prodesc, in the common case where the rowtype * is determined by the function not the calling query. But we'd have * to be able to deal with ADD/DROP/ALTER COLUMN events when the * result type is a named composite type, so it's not exactly trivial. * Maybe worth improving someday. */ switch (get_call_result_type(fcinfo, NULL, &td)) { case TYPEFUNC_COMPOSITE: /* success */ break; case TYPEFUNC_COMPOSITE_DOMAIN: Assert(prodesc->fn_retisdomain); break; case TYPEFUNC_RECORD: /* failed to determine actual type of RECORD */ ereport(ERROR, (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), errmsg("function returning record called in context " "that cannot accept type record"))); break; default: /* result type isn't composite? */ elog(ERROR, "return type must be a row type"); break; } Assert(!call_state->ret_tupdesc); Assert(!call_state->attinmeta); call_state->ret_tupdesc = td; call_state->attinmeta = TupleDescGetAttInMetadata(td); /* Convert function result to tuple */ resultObj = Tcl_GetObjResult(interp); if (Tcl_ListObjGetElements(interp, resultObj, &resultObjc, &resultObjv) == TCL_ERROR) throw_tcl_error(interp, prodesc->user_proname); tup = pltcl_build_tuple_result(interp, resultObjv, resultObjc, call_state); retval = HeapTupleGetDatum(tup); } else retval = InputFunctionCall(&prodesc->result_in_func, utf_u2e(Tcl_GetStringResult(interp)), prodesc->result_typioparam, -1); return retval; } /********************************************************************** * pltcl_trigger_handler() - Handler for trigger calls **********************************************************************/ static HeapTuple pltcl_trigger_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state, bool pltrusted) { pltcl_proc_desc *prodesc; Tcl_Interp *volatile interp; TriggerData *trigdata = (TriggerData *) fcinfo->context; char *stroid; TupleDesc tupdesc; volatile HeapTuple rettup; Tcl_Obj *tcl_cmd; Tcl_Obj *tcl_trigtup; int tcl_rc; int i; const char *result; int result_Objc; Tcl_Obj **result_Objv; int rc PG_USED_FOR_ASSERTS_ONLY; call_state->trigdata = trigdata; /* Connect to SPI manager */ if (SPI_connect() != SPI_OK_CONNECT) elog(ERROR, "could not connect to SPI manager"); /* Make transition tables visible to this SPI connection */ rc = SPI_register_trigger_data(trigdata); Assert(rc >= 0); /* Find or compile the function */ prodesc = compile_pltcl_function(fcinfo->flinfo->fn_oid, RelationGetRelid(trigdata->tg_relation), false, /* not an event trigger */ pltrusted); call_state->prodesc = prodesc; prodesc->fn_refcount++; interp = prodesc->interp_desc->interp; tupdesc = RelationGetDescr(trigdata->tg_relation); /************************************************************ * Create the tcl command to call the internal * proc in the interpreter ************************************************************/ tcl_cmd = Tcl_NewObj(); Tcl_IncrRefCount(tcl_cmd); PG_TRY(); { /* The procedure name (note this is all ASCII, so no utf_e2u) */ Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj(prodesc->internal_proname, -1)); /* The trigger name for argument TG_name */ Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj(utf_e2u(trigdata->tg_trigger->tgname), -1)); /* The oid of the trigger relation for argument TG_relid */ /* Consider not converting to a string for more performance? */ stroid = DatumGetCString(DirectFunctionCall1(oidout, ObjectIdGetDatum(trigdata->tg_relation->rd_id))); Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj(stroid, -1)); pfree(stroid); /* The name of the table the trigger is acting on: TG_table_name */ stroid = SPI_getrelname(trigdata->tg_relation); Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj(utf_e2u(stroid), -1)); pfree(stroid); /* The schema of the table the trigger is acting on: TG_table_schema */ stroid = SPI_getnspname(trigdata->tg_relation); Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj(utf_e2u(stroid), -1)); pfree(stroid); /* A list of attribute names for argument TG_relatts */ tcl_trigtup = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, tcl_trigtup, Tcl_NewObj()); for (i = 0; i < tupdesc->natts; i++) { Form_pg_attribute att = TupleDescAttr(tupdesc, i); if (att->attisdropped) Tcl_ListObjAppendElement(NULL, tcl_trigtup, Tcl_NewObj()); else Tcl_ListObjAppendElement(NULL, tcl_trigtup, Tcl_NewStringObj(utf_e2u(NameStr(att->attname)), -1)); } Tcl_ListObjAppendElement(NULL, tcl_cmd, tcl_trigtup); /* The when part of the event for TG_when */ if (TRIGGER_FIRED_BEFORE(trigdata->tg_event)) Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj("BEFORE", -1)); else if (TRIGGER_FIRED_AFTER(trigdata->tg_event)) Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj("AFTER", -1)); else if (TRIGGER_FIRED_INSTEAD(trigdata->tg_event)) Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj("INSTEAD OF", -1)); else elog(ERROR, "unrecognized WHEN tg_event: %u", trigdata->tg_event); /* The level part of the event for TG_level */ if (TRIGGER_FIRED_FOR_ROW(trigdata->tg_event)) { Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj("ROW", -1)); /* * Now the command part of the event for TG_op and data for NEW * and OLD * * Note: In BEFORE trigger, stored generated columns are not * computed yet, so don't make them accessible in NEW row. */ if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event)) { Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj("INSERT", -1)); Tcl_ListObjAppendElement(NULL, tcl_cmd, pltcl_build_tuple_argument(trigdata->tg_trigtuple, tupdesc, !TRIGGER_FIRED_BEFORE(trigdata->tg_event))); Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj()); rettup = trigdata->tg_trigtuple; } else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event)) { Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj("DELETE", -1)); Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj()); Tcl_ListObjAppendElement(NULL, tcl_cmd, pltcl_build_tuple_argument(trigdata->tg_trigtuple, tupdesc, true)); rettup = trigdata->tg_trigtuple; } else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event)) { Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj("UPDATE", -1)); Tcl_ListObjAppendElement(NULL, tcl_cmd, pltcl_build_tuple_argument(trigdata->tg_newtuple, tupdesc, !TRIGGER_FIRED_BEFORE(trigdata->tg_event))); Tcl_ListObjAppendElement(NULL, tcl_cmd, pltcl_build_tuple_argument(trigdata->tg_trigtuple, tupdesc, true)); rettup = trigdata->tg_newtuple; } else elog(ERROR, "unrecognized OP tg_event: %u", trigdata->tg_event); } else if (TRIGGER_FIRED_FOR_STATEMENT(trigdata->tg_event)) { Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj("STATEMENT", -1)); if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event)) Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj("INSERT", -1)); else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event)) Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj("DELETE", -1)); else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event)) Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj("UPDATE", -1)); else if (TRIGGER_FIRED_BY_TRUNCATE(trigdata->tg_event)) Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj("TRUNCATE", -1)); else elog(ERROR, "unrecognized OP tg_event: %u", trigdata->tg_event); Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj()); Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj()); rettup = (HeapTuple) NULL; } else elog(ERROR, "unrecognized LEVEL tg_event: %u", trigdata->tg_event); /* Finally append the arguments from CREATE TRIGGER */ for (i = 0; i < trigdata->tg_trigger->tgnargs; i++) Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj(utf_e2u(trigdata->tg_trigger->tgargs[i]), -1)); } PG_CATCH(); { Tcl_DecrRefCount(tcl_cmd); PG_RE_THROW(); } PG_END_TRY(); /************************************************************ * Call the Tcl function * * We assume no PG error can be thrown directly from this call. ************************************************************/ tcl_rc = Tcl_EvalObjEx(interp, tcl_cmd, (TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL)); /* Release refcount to free tcl_cmd (and all subsidiary objects) */ Tcl_DecrRefCount(tcl_cmd); /************************************************************ * Check for errors reported by Tcl. ************************************************************/ if (tcl_rc != TCL_OK) throw_tcl_error(interp, prodesc->user_proname); /************************************************************ * Exit SPI environment. ************************************************************/ if (SPI_finish() != SPI_OK_FINISH) elog(ERROR, "SPI_finish() failed"); /************************************************************ * The return value from the procedure might be one of * the magic strings OK or SKIP, or a list from array get. * We can check for OK or SKIP without worrying about encoding. ************************************************************/ result = Tcl_GetStringResult(interp); if (strcmp(result, "OK") == 0) return rettup; if (strcmp(result, "SKIP") == 0) return (HeapTuple) NULL; /************************************************************ * Otherwise, the return value should be a column name/value list * specifying the modified tuple to return. ************************************************************/ if (Tcl_ListObjGetElements(interp, Tcl_GetObjResult(interp), &result_Objc, &result_Objv) != TCL_OK) ereport(ERROR, (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED), errmsg("could not split return value from trigger: %s", utf_u2e(Tcl_GetStringResult(interp))))); /* Convert function result to tuple */ rettup = pltcl_build_tuple_result(interp, result_Objv, result_Objc, call_state); return rettup; } /********************************************************************** * pltcl_event_trigger_handler() - Handler for event trigger calls **********************************************************************/ static void pltcl_event_trigger_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state, bool pltrusted) { pltcl_proc_desc *prodesc; Tcl_Interp *volatile interp; EventTriggerData *tdata = (EventTriggerData *) fcinfo->context; Tcl_Obj *tcl_cmd; int tcl_rc; /* Connect to SPI manager */ if (SPI_connect() != SPI_OK_CONNECT) elog(ERROR, "could not connect to SPI manager"); /* Find or compile the function */ prodesc = compile_pltcl_function(fcinfo->flinfo->fn_oid, InvalidOid, true, pltrusted); call_state->prodesc = prodesc; prodesc->fn_refcount++; interp = prodesc->interp_desc->interp; /* Create the tcl command and call the internal proc */ tcl_cmd = Tcl_NewObj(); Tcl_IncrRefCount(tcl_cmd); Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj(prodesc->internal_proname, -1)); Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj(utf_e2u(tdata->event), -1)); Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewStringObj(utf_e2u(GetCommandTagName(tdata->tag)), -1)); tcl_rc = Tcl_EvalObjEx(interp, tcl_cmd, (TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL)); /* Release refcount to free tcl_cmd (and all subsidiary objects) */ Tcl_DecrRefCount(tcl_cmd); /* Check for errors reported by Tcl. */ if (tcl_rc != TCL_OK) throw_tcl_error(interp, prodesc->user_proname); if (SPI_finish() != SPI_OK_FINISH) elog(ERROR, "SPI_finish() failed"); } /********************************************************************** * throw_tcl_error - ereport an error returned from the Tcl interpreter **********************************************************************/ static void throw_tcl_error(Tcl_Interp *interp, const char *proname) { /* * Caution is needed here because Tcl_GetVar could overwrite the * interpreter result (even though it's not really supposed to), and we * can't control the order of evaluation of ereport arguments. Hence, make * real sure we have our own copy of the result string before invoking * Tcl_GetVar. */ char *emsg; char *econtext; emsg = pstrdup(utf_u2e(Tcl_GetStringResult(interp))); econtext = utf_u2e(Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY)); ereport(ERROR, (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), errmsg("%s", emsg), errcontext("%s\nin PL/Tcl function \"%s\"", econtext, proname))); } /********************************************************************** * compile_pltcl_function - compile (or hopefully just look up) function * * tgreloid is the OID of the relation when compiling a trigger, or zero * (InvalidOid) when compiling a plain function. **********************************************************************/ static pltcl_proc_desc * compile_pltcl_function(Oid fn_oid, Oid tgreloid, bool is_event_trigger, bool pltrusted) { HeapTuple procTup; Form_pg_proc procStruct; pltcl_proc_key proc_key; pltcl_proc_ptr *proc_ptr; bool found; pltcl_proc_desc *prodesc; pltcl_proc_desc *old_prodesc; volatile MemoryContext proc_cxt = NULL; Tcl_DString proc_internal_def; Tcl_DString proc_internal_body; /* We'll need the pg_proc tuple in any case... */ procTup = SearchSysCache1(PROCOID, ObjectIdGetDatum(fn_oid)); if (!HeapTupleIsValid(procTup)) elog(ERROR, "cache lookup failed for function %u", fn_oid); procStruct = (Form_pg_proc) GETSTRUCT(procTup); /* * Look up function in pltcl_proc_htab; if it's not there, create an entry * and set the entry's proc_ptr to NULL. */ proc_key.proc_id = fn_oid; proc_key.is_trigger = OidIsValid(tgreloid); proc_key.user_id = pltrusted ? GetUserId() : InvalidOid; proc_ptr = hash_search(pltcl_proc_htab, &proc_key, HASH_ENTER, &found); if (!found) proc_ptr->proc_ptr = NULL; prodesc = proc_ptr->proc_ptr; /************************************************************ * If it's present, must check whether it's still up to date. * This is needed because CREATE OR REPLACE FUNCTION can modify the * function's pg_proc entry without changing its OID. ************************************************************/ if (prodesc != NULL && prodesc->fn_xmin == HeapTupleHeaderGetRawXmin(procTup->t_data) && ItemPointerEquals(&prodesc->fn_tid, &procTup->t_self)) { /* It's still up-to-date, so we can use it */ ReleaseSysCache(procTup); return prodesc; } /************************************************************ * If we haven't found it in the hashtable, we analyze * the functions arguments and returntype and store * the in-/out-functions in the prodesc block and create * a new hashtable entry for it. * * Then we load the procedure into the Tcl interpreter. ************************************************************/ Tcl_DStringInit(&proc_internal_def); Tcl_DStringInit(&proc_internal_body); PG_TRY(); { bool is_trigger = OidIsValid(tgreloid); char internal_proname[128]; HeapTuple typeTup; Form_pg_type typeStruct; char proc_internal_args[33 * FUNC_MAX_ARGS]; Datum prosrcdatum; bool isnull; char *proc_source; char buf[48]; Tcl_Interp *interp; int i; int tcl_rc; MemoryContext oldcontext; /************************************************************ * Build our internal proc name from the function's Oid. Append * "_trigger" when appropriate to ensure the normal and trigger * cases are kept separate. Note name must be all-ASCII. ************************************************************/ if (is_event_trigger) snprintf(internal_proname, sizeof(internal_proname), "__PLTcl_proc_%u_evttrigger", fn_oid); else if (is_trigger) snprintf(internal_proname, sizeof(internal_proname), "__PLTcl_proc_%u_trigger", fn_oid); else snprintf(internal_proname, sizeof(internal_proname), "__PLTcl_proc_%u", fn_oid); /************************************************************ * Allocate a context that will hold all PG data for the procedure. ************************************************************/ proc_cxt = AllocSetContextCreate(TopMemoryContext, "PL/Tcl function", ALLOCSET_SMALL_SIZES); /************************************************************ * Allocate and fill a new procedure description block. * struct prodesc and subsidiary data must all live in proc_cxt. ************************************************************/ oldcontext = MemoryContextSwitchTo(proc_cxt); prodesc = (pltcl_proc_desc *) palloc0(sizeof(pltcl_proc_desc)); prodesc->user_proname = pstrdup(NameStr(procStruct->proname)); MemoryContextSetIdentifier(proc_cxt, prodesc->user_proname); prodesc->internal_proname = pstrdup(internal_proname); prodesc->fn_cxt = proc_cxt; prodesc->fn_refcount = 0; prodesc->fn_xmin = HeapTupleHeaderGetRawXmin(procTup->t_data); prodesc->fn_tid = procTup->t_self; prodesc->nargs = procStruct->pronargs; prodesc->arg_out_func = (FmgrInfo *) palloc0(prodesc->nargs * sizeof(FmgrInfo)); prodesc->arg_is_rowtype = (bool *) palloc0(prodesc->nargs * sizeof(bool)); MemoryContextSwitchTo(oldcontext); /* Remember if function is STABLE/IMMUTABLE */ prodesc->fn_readonly = (procStruct->provolatile != PROVOLATILE_VOLATILE); /* And whether it is trusted */ prodesc->lanpltrusted = pltrusted; /************************************************************ * Identify the interpreter to use for the function ************************************************************/ prodesc->interp_desc = pltcl_fetch_interp(procStruct->prolang, prodesc->lanpltrusted); interp = prodesc->interp_desc->interp; /************************************************************ * Get the required information for input conversion of the * return value. ************************************************************/ if (!is_trigger && !is_event_trigger) { Oid rettype = procStruct->prorettype; typeTup = SearchSysCache1(TYPEOID, ObjectIdGetDatum(rettype)); if (!HeapTupleIsValid(typeTup)) elog(ERROR, "cache lookup failed for type %u", rettype); typeStruct = (Form_pg_type) GETSTRUCT(typeTup); /* Disallow pseudotype result, except VOID and RECORD */ if (typeStruct->typtype == TYPTYPE_PSEUDO) { if (rettype == VOIDOID || rettype == RECORDOID) /* okay */ ; else if (rettype == TRIGGEROID || rettype == EVENT_TRIGGEROID) ereport(ERROR, (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), errmsg("trigger functions can only be called as triggers"))); else ereport(ERROR, (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), errmsg("PL/Tcl functions cannot return type %s", format_type_be(rettype)))); } prodesc->result_typid = rettype; fmgr_info_cxt(typeStruct->typinput, &(prodesc->result_in_func), proc_cxt); prodesc->result_typioparam = getTypeIOParam(typeTup); prodesc->fn_retisset = procStruct->proretset; prodesc->fn_retistuple = type_is_rowtype(rettype); prodesc->fn_retisdomain = (typeStruct->typtype == TYPTYPE_DOMAIN); prodesc->domain_info = NULL; ReleaseSysCache(typeTup); } /************************************************************ * Get the required information for output conversion * of all procedure arguments, and set up argument naming info. ************************************************************/ if (!is_trigger && !is_event_trigger) { proc_internal_args[0] = '\0'; for (i = 0; i < prodesc->nargs; i++) { Oid argtype = procStruct->proargtypes.values[i]; typeTup = SearchSysCache1(TYPEOID, ObjectIdGetDatum(argtype)); if (!HeapTupleIsValid(typeTup)) elog(ERROR, "cache lookup failed for type %u", argtype); typeStruct = (Form_pg_type) GETSTRUCT(typeTup); /* Disallow pseudotype argument, except RECORD */ if (typeStruct->typtype == TYPTYPE_PSEUDO && argtype != RECORDOID) ereport(ERROR, (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), errmsg("PL/Tcl functions cannot accept type %s", format_type_be(argtype)))); if (type_is_rowtype(argtype)) { prodesc->arg_is_rowtype[i] = true; snprintf(buf, sizeof(buf), "__PLTcl_Tup_%d", i + 1); } else { prodesc->arg_is_rowtype[i] = false; fmgr_info_cxt(typeStruct->typoutput, &(prodesc->arg_out_func[i]), proc_cxt); snprintf(buf, sizeof(buf), "%d", i + 1); } if (i > 0) strcat(proc_internal_args, " "); strcat(proc_internal_args, buf); ReleaseSysCache(typeTup); } } else if (is_trigger) { /* trigger procedure has fixed args */ strcpy(proc_internal_args, "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"); } else if (is_event_trigger) { /* event trigger procedure has fixed args */ strcpy(proc_internal_args, "TG_event TG_tag"); } /************************************************************ * Create the tcl command to define the internal * procedure * * Leave this code as DString - performance is not critical here, * and we don't want to duplicate the knowledge of the Tcl quoting * rules that's embedded in Tcl_DStringAppendElement. ************************************************************/ Tcl_DStringAppendElement(&proc_internal_def, "proc"); Tcl_DStringAppendElement(&proc_internal_def, internal_proname); Tcl_DStringAppendElement(&proc_internal_def, proc_internal_args); /************************************************************ * prefix procedure body with * upvar #0 GD * and with appropriate setting of arguments ************************************************************/ Tcl_DStringAppend(&proc_internal_body, "upvar #0 ", -1); Tcl_DStringAppend(&proc_internal_body, internal_proname, -1); Tcl_DStringAppend(&proc_internal_body, " GD\n", -1); if (is_trigger) { Tcl_DStringAppend(&proc_internal_body, "array set NEW $__PLTcl_Tup_NEW\n", -1); Tcl_DStringAppend(&proc_internal_body, "array set OLD $__PLTcl_Tup_OLD\n", -1); Tcl_DStringAppend(&proc_internal_body, "set i 0\n" "set v 0\n" "foreach v $args {\n" " incr i\n" " set $i $v\n" "}\n" "unset i v\n\n", -1); } else if (is_event_trigger) { /* no argument support for event triggers */ } else { for (i = 0; i < prodesc->nargs; i++) { if (prodesc->arg_is_rowtype[i]) { snprintf(buf, sizeof(buf), "array set %d $__PLTcl_Tup_%d\n", i + 1, i + 1); Tcl_DStringAppend(&proc_internal_body, buf, -1); } } } /************************************************************ * Add user's function definition to proc body ************************************************************/ prosrcdatum = SysCacheGetAttr(PROCOID, procTup, Anum_pg_proc_prosrc, &isnull); if (isnull) elog(ERROR, "null prosrc"); proc_source = TextDatumGetCString(prosrcdatum); UTF_BEGIN; Tcl_DStringAppend(&proc_internal_body, UTF_E2U(proc_source), -1); UTF_END; pfree(proc_source); Tcl_DStringAppendElement(&proc_internal_def, Tcl_DStringValue(&proc_internal_body)); /************************************************************ * Create the procedure in the interpreter ************************************************************/ tcl_rc = Tcl_EvalEx(interp, Tcl_DStringValue(&proc_internal_def), Tcl_DStringLength(&proc_internal_def), TCL_EVAL_GLOBAL); if (tcl_rc != TCL_OK) ereport(ERROR, (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), errmsg("could not create internal procedure \"%s\": %s", internal_proname, utf_u2e(Tcl_GetStringResult(interp))))); } PG_CATCH(); { /* * If we failed anywhere above, clean up whatever got allocated. It * should all be in the proc_cxt, except for the DStrings. */ if (proc_cxt) MemoryContextDelete(proc_cxt); Tcl_DStringFree(&proc_internal_def); Tcl_DStringFree(&proc_internal_body); PG_RE_THROW(); } PG_END_TRY(); /* * Install the new proc description block in the hashtable, incrementing * its refcount (the hashtable link counts as a reference). Then, if * there was a previous definition of the function, decrement that one's * refcount, and delete it if no longer referenced. The order of * operations here is important: if something goes wrong during the * MemoryContextDelete, leaking some memory for the old definition is OK, * but we don't want to corrupt the live hashtable entry. (Likewise, * freeing the DStrings is pretty low priority if that happens.) */ old_prodesc = proc_ptr->proc_ptr; proc_ptr->proc_ptr = prodesc; prodesc->fn_refcount++; if (old_prodesc != NULL) { Assert(old_prodesc->fn_refcount > 0); if (--old_prodesc->fn_refcount == 0) MemoryContextDelete(old_prodesc->fn_cxt); } Tcl_DStringFree(&proc_internal_def); Tcl_DStringFree(&proc_internal_body); ReleaseSysCache(procTup); return prodesc; } /********************************************************************** * pltcl_elog() - elog() support for PLTcl **********************************************************************/ static int pltcl_elog(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { volatile int level; MemoryContext oldcontext; int priIndex; static const char *logpriorities[] = { "DEBUG", "LOG", "INFO", "NOTICE", "WARNING", "ERROR", "FATAL", (const char *) NULL }; static const int loglevels[] = { DEBUG2, LOG, INFO, NOTICE, WARNING, ERROR, FATAL }; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "level msg"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], logpriorities, "priority", TCL_EXACT, &priIndex) != TCL_OK) return TCL_ERROR; level = loglevels[priIndex]; if (level == ERROR) { /* * We just pass the error back to Tcl. If it's not caught, it'll * eventually get converted to a PG error when we reach the call * handler. */ Tcl_SetObjResult(interp, objv[2]); return TCL_ERROR; } /* * For non-error messages, just pass 'em to ereport(). We do not expect * that this will fail, but just on the off chance it does, report the * error back to Tcl. Note we are assuming that ereport() can't have any * internal failures that are so bad as to require a transaction abort. * * This path is also used for FATAL errors, which aren't going to come * back to us at all. */ oldcontext = CurrentMemoryContext; PG_TRY(); { UTF_BEGIN; ereport(level, (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), errmsg("%s", UTF_U2E(Tcl_GetString(objv[2]))))); UTF_END; } PG_CATCH(); { ErrorData *edata; /* Must reset elog.c's state */ MemoryContextSwitchTo(oldcontext); edata = CopyErrorData(); FlushErrorState(); /* Pass the error data to Tcl */ pltcl_construct_errorCode(interp, edata); UTF_BEGIN; Tcl_SetObjResult(interp, Tcl_NewStringObj(UTF_E2U(edata->message), -1)); UTF_END; FreeErrorData(edata); return TCL_ERROR; } PG_END_TRY(); return TCL_OK; } /********************************************************************** * pltcl_construct_errorCode() - construct a Tcl errorCode * list with detailed information from the PostgreSQL server **********************************************************************/ static void pltcl_construct_errorCode(Tcl_Interp *interp, ErrorData *edata) { Tcl_Obj *obj = Tcl_NewObj(); Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("POSTGRES", -1)); Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(PG_VERSION, -1)); Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("SQLSTATE", -1)); Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(unpack_sql_state(edata->sqlerrcode), -1)); Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("condition", -1)); Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(pltcl_get_condition_name(edata->sqlerrcode), -1)); Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("message", -1)); UTF_BEGIN; Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(UTF_E2U(edata->message), -1)); UTF_END; if (edata->detail) { Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("detail", -1)); UTF_BEGIN; Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(UTF_E2U(edata->detail), -1)); UTF_END; } if (edata->hint) { Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("hint", -1)); UTF_BEGIN; Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(UTF_E2U(edata->hint), -1)); UTF_END; } if (edata->context) { Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("context", -1)); UTF_BEGIN; Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(UTF_E2U(edata->context), -1)); UTF_END; } if (edata->schema_name) { Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("schema", -1)); UTF_BEGIN; Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(UTF_E2U(edata->schema_name), -1)); UTF_END; } if (edata->table_name) { Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("table", -1)); UTF_BEGIN; Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(UTF_E2U(edata->table_name), -1)); UTF_END; } if (edata->column_name) { Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("column", -1)); UTF_BEGIN; Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(UTF_E2U(edata->column_name), -1)); UTF_END; } if (edata->datatype_name) { Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("datatype", -1)); UTF_BEGIN; Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(UTF_E2U(edata->datatype_name), -1)); UTF_END; } if (edata->constraint_name) { Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("constraint", -1)); UTF_BEGIN; Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(UTF_E2U(edata->constraint_name), -1)); UTF_END; } /* cursorpos is never interesting here; report internal query/pos */ if (edata->internalquery) { Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("statement", -1)); UTF_BEGIN; Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(UTF_E2U(edata->internalquery), -1)); UTF_END; } if (edata->internalpos > 0) { Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("cursor_position", -1)); Tcl_ListObjAppendElement(interp, obj, Tcl_NewIntObj(edata->internalpos)); } if (edata->filename) { Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("filename", -1)); UTF_BEGIN; Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(UTF_E2U(edata->filename), -1)); UTF_END; } if (edata->lineno > 0) { Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("lineno", -1)); Tcl_ListObjAppendElement(interp, obj, Tcl_NewIntObj(edata->lineno)); } if (edata->funcname) { Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj("funcname", -1)); UTF_BEGIN; Tcl_ListObjAppendElement(interp, obj, Tcl_NewStringObj(UTF_E2U(edata->funcname), -1)); UTF_END; } Tcl_SetObjErrorCode(interp, obj); } /********************************************************************** * pltcl_get_condition_name() - find name for SQLSTATE **********************************************************************/ static const char * pltcl_get_condition_name(int sqlstate) { int i; for (i = 0; exception_name_map[i].label != NULL; i++) { if (exception_name_map[i].sqlerrstate == sqlstate) return exception_name_map[i].label; } return "unrecognized_sqlstate"; } /********************************************************************** * pltcl_quote() - quote literal strings that are to * be used in SPI_execute query strings **********************************************************************/ static int pltcl_quote(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { char *tmp; const char *cp1; char *cp2; int length; /************************************************************ * Check call syntax ************************************************************/ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); return TCL_ERROR; } /************************************************************ * Allocate space for the maximum the string can * grow to and initialize pointers ************************************************************/ cp1 = Tcl_GetStringFromObj(objv[1], &length); tmp = palloc(length * 2 + 1); cp2 = tmp; /************************************************************ * Walk through string and double every quote and backslash ************************************************************/ while (*cp1) { if (*cp1 == '\'') *cp2++ = '\''; else { if (*cp1 == '\\') *cp2++ = '\\'; } *cp2++ = *cp1++; } /************************************************************ * Terminate the string and set it as result ************************************************************/ *cp2 = '\0'; Tcl_SetObjResult(interp, Tcl_NewStringObj(tmp, -1)); pfree(tmp); return TCL_OK; } /********************************************************************** * pltcl_argisnull() - determine if a specific argument is NULL **********************************************************************/ static int pltcl_argisnull(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { int argno; FunctionCallInfo fcinfo = pltcl_current_call_state->fcinfo; /************************************************************ * Check call syntax ************************************************************/ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "argno"); return TCL_ERROR; } /************************************************************ * Check that we're called as a normal function ************************************************************/ if (fcinfo == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("argisnull cannot be used in triggers", -1)); return TCL_ERROR; } /************************************************************ * Get the argument number ************************************************************/ if (Tcl_GetIntFromObj(interp, objv[1], &argno) != TCL_OK) return TCL_ERROR; /************************************************************ * Check that the argno is valid ************************************************************/ argno--; if (argno < 0 || argno >= fcinfo->nargs) { Tcl_SetObjResult(interp, Tcl_NewStringObj("argno out of range", -1)); return TCL_ERROR; } /************************************************************ * Get the requested NULL state ************************************************************/ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(PG_ARGISNULL(argno))); return TCL_OK; } /********************************************************************** * pltcl_returnnull() - Cause a NULL return from the current function **********************************************************************/ static int pltcl_returnnull(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { FunctionCallInfo fcinfo = pltcl_current_call_state->fcinfo; /************************************************************ * Check call syntax ************************************************************/ if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, ""); return TCL_ERROR; } /************************************************************ * Check that we're called as a normal function ************************************************************/ if (fcinfo == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("return_null cannot be used in triggers", -1)); return TCL_ERROR; } /************************************************************ * Set the NULL return flag and cause Tcl to return from the * procedure. ************************************************************/ fcinfo->isnull = true; return TCL_RETURN; } /********************************************************************** * pltcl_returnnext() - Add a row to the result tuplestore in a SRF. **********************************************************************/ static int pltcl_returnnext(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { pltcl_call_state *call_state = pltcl_current_call_state; FunctionCallInfo fcinfo = call_state->fcinfo; pltcl_proc_desc *prodesc = call_state->prodesc; MemoryContext oldcontext = CurrentMemoryContext; ResourceOwner oldowner = CurrentResourceOwner; volatile int result = TCL_OK; /* * Check that we're called as a set-returning function */ if (fcinfo == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("return_next cannot be used in triggers", -1)); return TCL_ERROR; } if (!prodesc->fn_retisset) { Tcl_SetObjResult(interp, Tcl_NewStringObj("return_next cannot be used in non-set-returning functions", -1)); return TCL_ERROR; } /* * Check call syntax */ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "result"); return TCL_ERROR; } /* * The rest might throw elog(ERROR), so must run in a subtransaction. * * A small advantage of using a subtransaction is that it provides a * short-lived memory context for free, so we needn't worry about leaking * memory here. To use that context, call BeginInternalSubTransaction * directly instead of going through pltcl_subtrans_begin. */ BeginInternalSubTransaction(NULL); PG_TRY(); { /* Set up tuple store if first output row */ if (call_state->tuple_store == NULL) pltcl_init_tuple_store(call_state); if (prodesc->fn_retistuple) { Tcl_Obj **rowObjv; int rowObjc; /* result should be a list, so break it down */ if (Tcl_ListObjGetElements(interp, objv[1], &rowObjc, &rowObjv) == TCL_ERROR) result = TCL_ERROR; else { HeapTuple tuple; tuple = pltcl_build_tuple_result(interp, rowObjv, rowObjc, call_state); tuplestore_puttuple(call_state->tuple_store, tuple); } } else { Datum retval; bool isNull = false; /* for paranoia's sake, check that tupdesc has exactly one column */ if (call_state->ret_tupdesc->natts != 1) elog(ERROR, "wrong result type supplied in return_next"); retval = InputFunctionCall(&prodesc->result_in_func, utf_u2e((char *) Tcl_GetString(objv[1])), prodesc->result_typioparam, -1); tuplestore_putvalues(call_state->tuple_store, call_state->ret_tupdesc, &retval, &isNull); } pltcl_subtrans_commit(oldcontext, oldowner); } PG_CATCH(); { pltcl_subtrans_abort(interp, oldcontext, oldowner); return TCL_ERROR; } PG_END_TRY(); return result; } /*---------- * Support for running SPI operations inside subtransactions * * Intended usage pattern is: * * MemoryContext oldcontext = CurrentMemoryContext; * ResourceOwner oldowner = CurrentResourceOwner; * * ... * pltcl_subtrans_begin(oldcontext, oldowner); * PG_TRY(); * { * do something risky; * pltcl_subtrans_commit(oldcontext, oldowner); * } * PG_CATCH(); * { * pltcl_subtrans_abort(interp, oldcontext, oldowner); * return TCL_ERROR; * } * PG_END_TRY(); * return TCL_OK; *---------- */ static void pltcl_subtrans_begin(MemoryContext oldcontext, ResourceOwner oldowner) { BeginInternalSubTransaction(NULL); /* Want to run inside function's memory context */ MemoryContextSwitchTo(oldcontext); } static void pltcl_subtrans_commit(MemoryContext oldcontext, ResourceOwner oldowner) { /* Commit the inner transaction, return to outer xact context */ ReleaseCurrentSubTransaction(); MemoryContextSwitchTo(oldcontext); CurrentResourceOwner = oldowner; } static void pltcl_subtrans_abort(Tcl_Interp *interp, MemoryContext oldcontext, ResourceOwner oldowner) { ErrorData *edata; /* Save error info */ MemoryContextSwitchTo(oldcontext); edata = CopyErrorData(); FlushErrorState(); /* Abort the inner transaction */ RollbackAndReleaseCurrentSubTransaction(); MemoryContextSwitchTo(oldcontext); CurrentResourceOwner = oldowner; /* Pass the error data to Tcl */ pltcl_construct_errorCode(interp, edata); UTF_BEGIN; Tcl_SetObjResult(interp, Tcl_NewStringObj(UTF_E2U(edata->message), -1)); UTF_END; FreeErrorData(edata); } /********************************************************************** * pltcl_SPI_execute() - The builtin SPI_execute command * for the Tcl interpreter **********************************************************************/ static int pltcl_SPI_execute(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { int my_rc; int spi_rc; int query_idx; int i; int optIndex; int count = 0; const char *volatile arrayname = NULL; Tcl_Obj *volatile loop_body = NULL; MemoryContext oldcontext = CurrentMemoryContext; ResourceOwner oldowner = CurrentResourceOwner; enum options { OPT_ARRAY, OPT_COUNT }; static const char *options[] = { "-array", "-count", (const char *) NULL }; /************************************************************ * Check the call syntax and get the options ************************************************************/ if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "?-count n? ?-array name? query ?loop body?"); return TCL_ERROR; } i = 1; while (i < objc) { if (Tcl_GetIndexFromObj(NULL, objv[i], options, NULL, TCL_EXACT, &optIndex) != TCL_OK) break; if (++i >= objc) { Tcl_SetObjResult(interp, Tcl_NewStringObj("missing argument to -count or -array", -1)); return TCL_ERROR; } switch ((enum options) optIndex) { case OPT_ARRAY: arrayname = Tcl_GetString(objv[i++]); break; case OPT_COUNT: if (Tcl_GetIntFromObj(interp, objv[i++], &count) != TCL_OK) return TCL_ERROR; break; } } query_idx = i; if (query_idx >= objc || query_idx + 2 < objc) { Tcl_WrongNumArgs(interp, query_idx - 1, objv, "query ?loop body?"); return TCL_ERROR; } if (query_idx + 1 < objc) loop_body = objv[query_idx + 1]; /************************************************************ * Execute the query inside a sub-transaction, so we can cope with * errors sanely ************************************************************/ pltcl_subtrans_begin(oldcontext, oldowner); PG_TRY(); { UTF_BEGIN; spi_rc = SPI_execute(UTF_U2E(Tcl_GetString(objv[query_idx])), pltcl_current_call_state->prodesc->fn_readonly, count); UTF_END; my_rc = pltcl_process_SPI_result(interp, arrayname, loop_body, spi_rc, SPI_tuptable, SPI_processed); pltcl_subtrans_commit(oldcontext, oldowner); } PG_CATCH(); { pltcl_subtrans_abort(interp, oldcontext, oldowner); return TCL_ERROR; } PG_END_TRY(); return my_rc; } /* * Process the result from SPI_execute or SPI_execute_plan * * Shared code between pltcl_SPI_execute and pltcl_SPI_execute_plan */ static int pltcl_process_SPI_result(Tcl_Interp *interp, const char *arrayname, Tcl_Obj *loop_body, int spi_rc, SPITupleTable *tuptable, uint64 ntuples) { int my_rc = TCL_OK; int loop_rc; HeapTuple *tuples; TupleDesc tupdesc; switch (spi_rc) { case SPI_OK_SELINTO: case SPI_OK_INSERT: case SPI_OK_DELETE: case SPI_OK_UPDATE: Tcl_SetObjResult(interp, Tcl_NewWideIntObj(ntuples)); break; case SPI_OK_UTILITY: case SPI_OK_REWRITTEN: if (tuptable == NULL) { Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); break; } /* fall through for utility returning tuples */ /* FALLTHROUGH */ case SPI_OK_SELECT: case SPI_OK_INSERT_RETURNING: case SPI_OK_DELETE_RETURNING: case SPI_OK_UPDATE_RETURNING: /* * Process the tuples we got */ tuples = tuptable->vals; tupdesc = tuptable->tupdesc; if (loop_body == NULL) { /* * If there is no loop body given, just set the variables from * the first tuple (if any) */ if (ntuples > 0) pltcl_set_tuple_values(interp, arrayname, 0, tuples[0], tupdesc); } else { /* * There is a loop body - process all tuples and evaluate the * body on each */ uint64 i; for (i = 0; i < ntuples; i++) { pltcl_set_tuple_values(interp, arrayname, i, tuples[i], tupdesc); loop_rc = Tcl_EvalObjEx(interp, loop_body, 0); if (loop_rc == TCL_OK) continue; if (loop_rc == TCL_CONTINUE) continue; if (loop_rc == TCL_RETURN) { my_rc = TCL_RETURN; break; } if (loop_rc == TCL_BREAK) break; my_rc = TCL_ERROR; break; } } if (my_rc == TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewWideIntObj(ntuples)); } break; default: Tcl_AppendResult(interp, "pltcl: SPI_execute failed: ", SPI_result_code_string(spi_rc), NULL); my_rc = TCL_ERROR; break; } SPI_freetuptable(tuptable); return my_rc; } /********************************************************************** * pltcl_SPI_prepare() - Builtin support for prepared plans * The Tcl command SPI_prepare * always saves the plan using * SPI_keepplan and returns a key for * access. There is no chance to prepare * and not save the plan currently. **********************************************************************/ static int pltcl_SPI_prepare(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { volatile MemoryContext plan_cxt = NULL; int nargs; Tcl_Obj **argsObj; pltcl_query_desc *qdesc; int i; Tcl_HashEntry *hashent; int hashnew; Tcl_HashTable *query_hash; MemoryContext oldcontext = CurrentMemoryContext; ResourceOwner oldowner = CurrentResourceOwner; /************************************************************ * Check the call syntax ************************************************************/ if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "query argtypes"); return TCL_ERROR; } /************************************************************ * Split the argument type list ************************************************************/ if (Tcl_ListObjGetElements(interp, objv[2], &nargs, &argsObj) != TCL_OK) return TCL_ERROR; /************************************************************ * Allocate the new querydesc structure * * struct qdesc and subsidiary data all live in plan_cxt. Note that if the * function is recompiled for whatever reason, permanent memory leaks * occur. FIXME someday. ************************************************************/ plan_cxt = AllocSetContextCreate(TopMemoryContext, "PL/Tcl spi_prepare query", ALLOCSET_SMALL_SIZES); MemoryContextSwitchTo(plan_cxt); qdesc = (pltcl_query_desc *) palloc0(sizeof(pltcl_query_desc)); snprintf(qdesc->qname, sizeof(qdesc->qname), "%p", qdesc); qdesc->nargs = nargs; qdesc->argtypes = (Oid *) palloc(nargs * sizeof(Oid)); qdesc->arginfuncs = (FmgrInfo *) palloc(nargs * sizeof(FmgrInfo)); qdesc->argtypioparams = (Oid *) palloc(nargs * sizeof(Oid)); MemoryContextSwitchTo(oldcontext); /************************************************************ * Execute the prepare inside a sub-transaction, so we can cope with * errors sanely ************************************************************/ pltcl_subtrans_begin(oldcontext, oldowner); PG_TRY(); { /************************************************************ * Resolve argument type names and then look them up by oid * in the system cache, and remember the required information * for input conversion. ************************************************************/ for (i = 0; i < nargs; i++) { Oid typId, typInput, typIOParam; int32 typmod; parseTypeString(Tcl_GetString(argsObj[i]), &typId, &typmod, false); getTypeInputInfo(typId, &typInput, &typIOParam); qdesc->argtypes[i] = typId; fmgr_info_cxt(typInput, &(qdesc->arginfuncs[i]), plan_cxt); qdesc->argtypioparams[i] = typIOParam; } /************************************************************ * Prepare the plan and check for errors ************************************************************/ UTF_BEGIN; qdesc->plan = SPI_prepare(UTF_U2E(Tcl_GetString(objv[1])), nargs, qdesc->argtypes); UTF_END; if (qdesc->plan == NULL) elog(ERROR, "SPI_prepare() failed"); /************************************************************ * Save the plan into permanent memory (right now it's in the * SPI procCxt, which will go away at function end). ************************************************************/ if (SPI_keepplan(qdesc->plan)) elog(ERROR, "SPI_keepplan() failed"); pltcl_subtrans_commit(oldcontext, oldowner); } PG_CATCH(); { pltcl_subtrans_abort(interp, oldcontext, oldowner); MemoryContextDelete(plan_cxt); return TCL_ERROR; } PG_END_TRY(); /************************************************************ * Insert a hashtable entry for the plan and return * the key to the caller ************************************************************/ query_hash = &pltcl_current_call_state->prodesc->interp_desc->query_hash; hashent = Tcl_CreateHashEntry(query_hash, qdesc->qname, &hashnew); Tcl_SetHashValue(hashent, (ClientData) qdesc); /* qname is ASCII, so no need for encoding conversion */ Tcl_SetObjResult(interp, Tcl_NewStringObj(qdesc->qname, -1)); return TCL_OK; } /********************************************************************** * pltcl_SPI_execute_plan() - Execute a prepared plan **********************************************************************/ static int pltcl_SPI_execute_plan(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { int my_rc; int spi_rc; int i; int j; int optIndex; Tcl_HashEntry *hashent; pltcl_query_desc *qdesc; const char *nulls = NULL; const char *arrayname = NULL; Tcl_Obj *loop_body = NULL; int count = 0; int callObjc; Tcl_Obj **callObjv = NULL; Datum *argvalues; MemoryContext oldcontext = CurrentMemoryContext; ResourceOwner oldowner = CurrentResourceOwner; Tcl_HashTable *query_hash; enum options { OPT_ARRAY, OPT_COUNT, OPT_NULLS }; static const char *options[] = { "-array", "-count", "-nulls", (const char *) NULL }; /************************************************************ * Get the options and check syntax ************************************************************/ i = 1; while (i < objc) { if (Tcl_GetIndexFromObj(NULL, objv[i], options, NULL, TCL_EXACT, &optIndex) != TCL_OK) break; if (++i >= objc) { Tcl_SetObjResult(interp, Tcl_NewStringObj("missing argument to -array, -count or -nulls", -1)); return TCL_ERROR; } switch ((enum options) optIndex) { case OPT_ARRAY: arrayname = Tcl_GetString(objv[i++]); break; case OPT_COUNT: if (Tcl_GetIntFromObj(interp, objv[i++], &count) != TCL_OK) return TCL_ERROR; break; case OPT_NULLS: nulls = Tcl_GetString(objv[i++]); break; } } /************************************************************ * Get the prepared plan descriptor by its key ************************************************************/ if (i >= objc) { Tcl_SetObjResult(interp, Tcl_NewStringObj("missing argument to -count or -array", -1)); return TCL_ERROR; } query_hash = &pltcl_current_call_state->prodesc->interp_desc->query_hash; hashent = Tcl_FindHashEntry(query_hash, Tcl_GetString(objv[i])); if (hashent == NULL) { Tcl_AppendResult(interp, "invalid queryid '", Tcl_GetString(objv[i]), "'", NULL); return TCL_ERROR; } qdesc = (pltcl_query_desc *) Tcl_GetHashValue(hashent); i++; /************************************************************ * If a nulls string is given, check for correct length ************************************************************/ if (nulls != NULL) { if (strlen(nulls) != qdesc->nargs) { Tcl_SetObjResult(interp, Tcl_NewStringObj("length of nulls string doesn't match number of arguments", -1)); return TCL_ERROR; } } /************************************************************ * If there was an argtype list on preparation, we need * an argument value list now ************************************************************/ if (qdesc->nargs > 0) { if (i >= objc) { Tcl_SetObjResult(interp, Tcl_NewStringObj("argument list length doesn't match number of arguments for query", -1)); return TCL_ERROR; } /************************************************************ * Split the argument values ************************************************************/ if (Tcl_ListObjGetElements(interp, objv[i++], &callObjc, &callObjv) != TCL_OK) return TCL_ERROR; /************************************************************ * Check that the number of arguments matches ************************************************************/ if (callObjc != qdesc->nargs) { Tcl_SetObjResult(interp, Tcl_NewStringObj("argument list length doesn't match number of arguments for query", -1)); return TCL_ERROR; } } else callObjc = 0; /************************************************************ * Get loop body if present ************************************************************/ if (i < objc) loop_body = objv[i++]; if (i != objc) { Tcl_WrongNumArgs(interp, 1, objv, "?-count n? ?-array name? ?-nulls string? " "query ?args? ?loop body?"); return TCL_ERROR; } /************************************************************ * Execute the plan inside a sub-transaction, so we can cope with * errors sanely ************************************************************/ pltcl_subtrans_begin(oldcontext, oldowner); PG_TRY(); { /************************************************************ * Setup the value array for SPI_execute_plan() using * the type specific input functions ************************************************************/ argvalues = (Datum *) palloc(callObjc * sizeof(Datum)); for (j = 0; j < callObjc; j++) { if (nulls && nulls[j] == 'n') { argvalues[j] = InputFunctionCall(&qdesc->arginfuncs[j], NULL, qdesc->argtypioparams[j], -1); } else { UTF_BEGIN; argvalues[j] = InputFunctionCall(&qdesc->arginfuncs[j], UTF_U2E(Tcl_GetString(callObjv[j])), qdesc->argtypioparams[j], -1); UTF_END; } } /************************************************************ * Execute the plan ************************************************************/ spi_rc = SPI_execute_plan(qdesc->plan, argvalues, nulls, pltcl_current_call_state->prodesc->fn_readonly, count); my_rc = pltcl_process_SPI_result(interp, arrayname, loop_body, spi_rc, SPI_tuptable, SPI_processed); pltcl_subtrans_commit(oldcontext, oldowner); } PG_CATCH(); { pltcl_subtrans_abort(interp, oldcontext, oldowner); return TCL_ERROR; } PG_END_TRY(); return my_rc; } /********************************************************************** * pltcl_subtransaction() - Execute some Tcl code in a subtransaction * * The subtransaction is aborted if the Tcl code fragment returns TCL_ERROR, * otherwise it's subcommitted. **********************************************************************/ static int pltcl_subtransaction(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { MemoryContext oldcontext = CurrentMemoryContext; ResourceOwner oldowner = CurrentResourceOwner; int retcode; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "command"); return TCL_ERROR; } /* * Note: we don't use pltcl_subtrans_begin and friends here because we * don't want the error handling in pltcl_subtrans_abort. But otherwise * the processing should be about the same as in those functions. */ BeginInternalSubTransaction(NULL); MemoryContextSwitchTo(oldcontext); retcode = Tcl_EvalObjEx(interp, objv[1], 0); if (retcode == TCL_ERROR) { /* Rollback the subtransaction */ RollbackAndReleaseCurrentSubTransaction(); } else { /* Commit the subtransaction */ ReleaseCurrentSubTransaction(); } /* In either case, restore previous memory context and resource owner */ MemoryContextSwitchTo(oldcontext); CurrentResourceOwner = oldowner; return retcode; } /********************************************************************** * pltcl_commit() * * Commit the transaction and start a new one. **********************************************************************/ static int pltcl_commit(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { MemoryContext oldcontext = CurrentMemoryContext; PG_TRY(); { SPI_commit(); } PG_CATCH(); { ErrorData *edata; /* Save error info */ MemoryContextSwitchTo(oldcontext); edata = CopyErrorData(); FlushErrorState(); /* Pass the error data to Tcl */ pltcl_construct_errorCode(interp, edata); UTF_BEGIN; Tcl_SetObjResult(interp, Tcl_NewStringObj(UTF_E2U(edata->message), -1)); UTF_END; FreeErrorData(edata); return TCL_ERROR; } PG_END_TRY(); return TCL_OK; } /********************************************************************** * pltcl_rollback() * * Abort the transaction and start a new one. **********************************************************************/ static int pltcl_rollback(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { MemoryContext oldcontext = CurrentMemoryContext; PG_TRY(); { SPI_rollback(); } PG_CATCH(); { ErrorData *edata; /* Save error info */ MemoryContextSwitchTo(oldcontext); edata = CopyErrorData(); FlushErrorState(); /* Pass the error data to Tcl */ pltcl_construct_errorCode(interp, edata); UTF_BEGIN; Tcl_SetObjResult(interp, Tcl_NewStringObj(UTF_E2U(edata->message), -1)); UTF_END; FreeErrorData(edata); return TCL_ERROR; } PG_END_TRY(); return TCL_OK; } /********************************************************************** * pltcl_set_tuple_values() - Set variables for all attributes * of a given tuple * * Note: arrayname is presumed to be UTF8; it usually came from Tcl **********************************************************************/ static void pltcl_set_tuple_values(Tcl_Interp *interp, const char *arrayname, uint64 tupno, HeapTuple tuple, TupleDesc tupdesc) { int i; char *outputstr; Datum attr; bool isnull; const char *attname; Oid typoutput; bool typisvarlena; const char **arrptr; const char **nameptr; const char *nullname = NULL; /************************************************************ * Prepare pointers for Tcl_SetVar2Ex() below ************************************************************/ if (arrayname == NULL) { arrptr = &attname; nameptr = &nullname; } else { arrptr = &arrayname; nameptr = &attname; /* * When outputting to an array, fill the ".tupno" element with the * current tuple number. This will be overridden below if ".tupno" is * in use as an actual field name in the rowtype. */ Tcl_SetVar2Ex(interp, arrayname, ".tupno", Tcl_NewWideIntObj(tupno), 0); } for (i = 0; i < tupdesc->natts; i++) { Form_pg_attribute att = TupleDescAttr(tupdesc, i); /* ignore dropped attributes */ if (att->attisdropped) continue; /************************************************************ * Get the attribute name ************************************************************/ UTF_BEGIN; attname = pstrdup(UTF_E2U(NameStr(att->attname))); UTF_END; /************************************************************ * Get the attributes value ************************************************************/ attr = heap_getattr(tuple, i + 1, tupdesc, &isnull); /************************************************************ * If there is a value, set the variable * If not, unset it * * Hmmm - Null attributes will cause functions to * crash if they don't expect them - need something * smarter here. ************************************************************/ if (!isnull) { getTypeOutputInfo(att->atttypid, &typoutput, &typisvarlena); outputstr = OidOutputFunctionCall(typoutput, attr); UTF_BEGIN; Tcl_SetVar2Ex(interp, *arrptr, *nameptr, Tcl_NewStringObj(UTF_E2U(outputstr), -1), 0); UTF_END; pfree(outputstr); } else Tcl_UnsetVar2(interp, *arrptr, *nameptr, 0); pfree(unconstify(char *, attname)); } } /********************************************************************** * pltcl_build_tuple_argument() - Build a list object usable for 'array set' * from all attributes of a given tuple **********************************************************************/ static Tcl_Obj * pltcl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc, bool include_generated) { Tcl_Obj *retobj = Tcl_NewObj(); int i; char *outputstr; Datum attr; bool isnull; char *attname; Oid typoutput; bool typisvarlena; for (i = 0; i < tupdesc->natts; i++) { Form_pg_attribute att = TupleDescAttr(tupdesc, i); /* ignore dropped attributes */ if (att->attisdropped) continue; if (att->attgenerated) { /* don't include unless requested */ if (!include_generated) continue; } /************************************************************ * Get the attribute name ************************************************************/ attname = NameStr(att->attname); /************************************************************ * Get the attributes value ************************************************************/ attr = heap_getattr(tuple, i + 1, tupdesc, &isnull); /************************************************************ * If there is a value, append the attribute name and the * value to the list * * Hmmm - Null attributes will cause functions to * crash if they don't expect them - need something * smarter here. ************************************************************/ if (!isnull) { getTypeOutputInfo(att->atttypid, &typoutput, &typisvarlena); outputstr = OidOutputFunctionCall(typoutput, attr); UTF_BEGIN; Tcl_ListObjAppendElement(NULL, retobj, Tcl_NewStringObj(UTF_E2U(attname), -1)); UTF_END; UTF_BEGIN; Tcl_ListObjAppendElement(NULL, retobj, Tcl_NewStringObj(UTF_E2U(outputstr), -1)); UTF_END; pfree(outputstr); } } return retobj; } /********************************************************************** * pltcl_build_tuple_result() - Build a tuple of function's result rowtype * from a Tcl list of column names and values * * In a trigger function, we build a tuple of the trigger table's rowtype. * * Note: this function leaks memory. Even if we made it clean up its own * mess, there's no way to prevent the datatype input functions it calls * from leaking. Run it in a short-lived context, unless we're about to * exit the procedure anyway. **********************************************************************/ static HeapTuple pltcl_build_tuple_result(Tcl_Interp *interp, Tcl_Obj **kvObjv, int kvObjc, pltcl_call_state *call_state) { HeapTuple tuple; TupleDesc tupdesc; AttInMetadata *attinmeta; char **values; int i; if (call_state->ret_tupdesc) { tupdesc = call_state->ret_tupdesc; attinmeta = call_state->attinmeta; } else if (call_state->trigdata) { tupdesc = RelationGetDescr(call_state->trigdata->tg_relation); attinmeta = TupleDescGetAttInMetadata(tupdesc); } else { elog(ERROR, "PL/Tcl function does not return a tuple"); tupdesc = NULL; /* keep compiler quiet */ attinmeta = NULL; } values = (char **) palloc0(tupdesc->natts * sizeof(char *)); if (kvObjc % 2 != 0) ereport(ERROR, (errcode(ERRCODE_INVALID_PARAMETER_VALUE), errmsg("column name/value list must have even number of elements"))); for (i = 0; i < kvObjc; i += 2) { char *fieldName = utf_u2e(Tcl_GetString(kvObjv[i])); int attn = SPI_fnumber(tupdesc, fieldName); /* * We silently ignore ".tupno", if it's present but doesn't match any * actual output column. This allows direct use of a row returned by * pltcl_set_tuple_values(). */ if (attn == SPI_ERROR_NOATTRIBUTE) { if (strcmp(fieldName, ".tupno") == 0) continue; ereport(ERROR, (errcode(ERRCODE_UNDEFINED_COLUMN), errmsg("column name/value list contains nonexistent column name \"%s\"", fieldName))); } if (attn <= 0) ereport(ERROR, (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), errmsg("cannot set system attribute \"%s\"", fieldName))); if (TupleDescAttr(tupdesc, attn - 1)->attgenerated) ereport(ERROR, (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED), errmsg("cannot set generated column \"%s\"", fieldName))); values[attn - 1] = utf_u2e(Tcl_GetString(kvObjv[i + 1])); } tuple = BuildTupleFromCStrings(attinmeta, values); /* if result type is domain-over-composite, check domain constraints */ if (call_state->prodesc->fn_retisdomain) domain_check(HeapTupleGetDatum(tuple), false, call_state->prodesc->result_typid, &call_state->prodesc->domain_info, call_state->prodesc->fn_cxt); return tuple; } /********************************************************************** * pltcl_init_tuple_store() - Initialize the result tuplestore for a SRF **********************************************************************/ static void pltcl_init_tuple_store(pltcl_call_state *call_state) { ReturnSetInfo *rsi = call_state->rsi; MemoryContext oldcxt; ResourceOwner oldowner; /* Should be in a SRF */ Assert(rsi); /* Should be first time through */ Assert(!call_state->tuple_store); Assert(!call_state->attinmeta); /* We expect caller to provide an appropriate result tupdesc */ Assert(rsi->expectedDesc); call_state->ret_tupdesc = rsi->expectedDesc; /* * Switch to the right memory context and resource owner for storing the * tuplestore. If we're within a subtransaction opened for an exception * block, for example, we must still create the tuplestore in the resource * owner that was active when this function was entered, and not in the * subtransaction's resource owner. */ oldcxt = MemoryContextSwitchTo(call_state->tuple_store_cxt); oldowner = CurrentResourceOwner; CurrentResourceOwner = call_state->tuple_store_owner; call_state->tuple_store = tuplestore_begin_heap(rsi->allowedModes & SFRM_Materialize_Random, false, work_mem); /* Build attinmeta in this context, too */ call_state->attinmeta = TupleDescGetAttInMetadata(call_state->ret_tupdesc); CurrentResourceOwner = oldowner; MemoryContextSwitchTo(oldcxt); }