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