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/pg_proc.h"
19 #include "catalog/pg_type.h"
20 #include "commands/event_trigger.h"
21 #include "commands/trigger.h"
22 #include "executor/spi.h"
23 #include "fmgr.h"
24 #include "mb/pg_wchar.h"
25 #include "miscadmin.h"
26 #include "nodes/makefuncs.h"
27 #include "parser/parse_type.h"
28 #include "tcop/tcopprot.h"
29 #include "utils/builtins.h"
30 #include "utils/lsyscache.h"
31 #include "utils/memutils.h"
32 #include "utils/rel.h"
33 #include "utils/syscache.h"
34 #include "utils/typcache.h"
35
36
37 PG_MODULE_MAGIC;
38
39 #define HAVE_TCL_VERSION(maj,min) \
40 ((TCL_MAJOR_VERSION > maj) || \
41 (TCL_MAJOR_VERSION == maj && TCL_MINOR_VERSION >= min))
42
43 /* Insist on Tcl >= 8.4 */
44 #if !HAVE_TCL_VERSION(8,4)
45 #error PostgreSQL only supports Tcl 8.4 or later.
46 #endif
47
48 /* Hack to deal with Tcl 8.6 const-ification without losing compatibility */
49 #ifndef CONST86
50 #define CONST86
51 #endif
52
53 /* define our text domain for translations */
54 #undef TEXTDOMAIN
55 #define TEXTDOMAIN PG_TEXTDOMAIN("pltcl")
56
57
58 /*
59 * Support for converting between UTF8 (which is what all strings going into
60 * or out of Tcl should be) and the database encoding.
61 *
62 * If you just use utf_u2e() or utf_e2u() directly, they will leak some
63 * palloc'd space when doing a conversion. This is not worth worrying about
64 * if it only happens, say, once per PL/Tcl function call. If it does seem
65 * worth worrying about, use the wrapper macros.
66 */
67
68 static inline char *
utf_u2e(const char * src)69 utf_u2e(const char *src)
70 {
71 return pg_any_to_server(src, strlen(src), PG_UTF8);
72 }
73
74 static inline char *
utf_e2u(const char * src)75 utf_e2u(const char *src)
76 {
77 return pg_server_to_any(src, strlen(src), PG_UTF8);
78 }
79
80 #define UTF_BEGIN \
81 do { \
82 const char *_pltcl_utf_src = NULL; \
83 char *_pltcl_utf_dst = NULL
84
85 #define UTF_END \
86 if (_pltcl_utf_src != (const char *) _pltcl_utf_dst) \
87 pfree(_pltcl_utf_dst); \
88 } while (0)
89
90 #define UTF_U2E(x) \
91 (_pltcl_utf_dst = utf_u2e(_pltcl_utf_src = (x)))
92
93 #define UTF_E2U(x) \
94 (_pltcl_utf_dst = utf_e2u(_pltcl_utf_src = (x)))
95
96
97 /**********************************************************************
98 * Information associated with a Tcl interpreter. We have one interpreter
99 * that is used for all pltclu (untrusted) functions. For pltcl (trusted)
100 * functions, there is a separate interpreter for each effective SQL userid.
101 * (This is needed to ensure that an unprivileged user can't inject Tcl code
102 * that'll be executed with the privileges of some other SQL user.)
103 *
104 * The pltcl_interp_desc structs are kept in a Postgres hash table indexed
105 * by userid OID, with OID 0 used for the single untrusted interpreter.
106 **********************************************************************/
107 typedef struct pltcl_interp_desc
108 {
109 Oid user_id; /* Hash key (must be first!) */
110 Tcl_Interp *interp; /* The interpreter */
111 Tcl_HashTable query_hash; /* pltcl_query_desc structs */
112 } pltcl_interp_desc;
113
114
115 /**********************************************************************
116 * The information we cache about loaded procedures
117 **********************************************************************/
118 typedef struct pltcl_proc_desc
119 {
120 char *user_proname;
121 char *internal_proname;
122 TransactionId fn_xmin;
123 ItemPointerData fn_tid;
124 bool fn_readonly;
125 bool lanpltrusted;
126 pltcl_interp_desc *interp_desc;
127 FmgrInfo result_in_func;
128 Oid result_typioparam;
129 int nargs;
130 FmgrInfo arg_out_func[FUNC_MAX_ARGS];
131 bool arg_is_rowtype[FUNC_MAX_ARGS];
132 } pltcl_proc_desc;
133
134
135 /**********************************************************************
136 * The information we cache about prepared and saved plans
137 **********************************************************************/
138 typedef struct pltcl_query_desc
139 {
140 char qname[20];
141 SPIPlanPtr plan;
142 int nargs;
143 Oid *argtypes;
144 FmgrInfo *arginfuncs;
145 Oid *argtypioparams;
146 } pltcl_query_desc;
147
148
149 /**********************************************************************
150 * For speedy lookup, we maintain a hash table mapping from
151 * function OID + trigger flag + user OID to pltcl_proc_desc pointers.
152 * The reason the pltcl_proc_desc struct isn't directly part of the hash
153 * entry is to simplify recovery from errors during compile_pltcl_function.
154 *
155 * Note: if the same function is called by multiple userIDs within a session,
156 * there will be a separate pltcl_proc_desc entry for each userID in the case
157 * of pltcl functions, but only one entry for pltclu functions, because we
158 * set user_id = 0 for that case.
159 **********************************************************************/
160 typedef struct pltcl_proc_key
161 {
162 Oid proc_id; /* Function OID */
163
164 /*
165 * is_trigger is really a bool, but declare as Oid to ensure this struct
166 * contains no padding
167 */
168 Oid is_trigger; /* is it a trigger function? */
169 Oid user_id; /* User calling the function, or 0 */
170 } pltcl_proc_key;
171
172 typedef struct pltcl_proc_ptr
173 {
174 pltcl_proc_key proc_key; /* Hash key (must be first!) */
175 pltcl_proc_desc *proc_ptr;
176 } pltcl_proc_ptr;
177
178
179 /**********************************************************************
180 * Global data
181 **********************************************************************/
182 static bool pltcl_pm_init_done = false;
183 static Tcl_Interp *pltcl_hold_interp = NULL;
184 static HTAB *pltcl_interp_htab = NULL;
185 static HTAB *pltcl_proc_htab = NULL;
186
187 /* these are saved and restored by pltcl_handler */
188 static FunctionCallInfo pltcl_current_fcinfo = NULL;
189 static pltcl_proc_desc *pltcl_current_prodesc = NULL;
190
191 /**********************************************************************
192 * Lookup table for SQLSTATE condition names
193 **********************************************************************/
194 typedef struct
195 {
196 const char *label;
197 int sqlerrstate;
198 } TclExceptionNameMap;
199
200 static const TclExceptionNameMap exception_name_map[] = {
201 #include "pltclerrcodes.h" /* pgrminclude ignore */
202 {NULL, 0}
203 };
204
205 /**********************************************************************
206 * Forward declarations
207 **********************************************************************/
208 void _PG_init(void);
209
210 static void pltcl_init_interp(pltcl_interp_desc *interp_desc, bool pltrusted);
211 static pltcl_interp_desc *pltcl_fetch_interp(bool pltrusted);
212 static void pltcl_init_load_unknown(Tcl_Interp *interp);
213
214 static Datum pltcl_handler(PG_FUNCTION_ARGS, bool pltrusted);
215
216 static Datum pltcl_func_handler(PG_FUNCTION_ARGS, bool pltrusted);
217
218 static HeapTuple pltcl_trigger_handler(PG_FUNCTION_ARGS, bool pltrusted);
219 static void pltcl_event_trigger_handler(PG_FUNCTION_ARGS, bool pltrusted);
220
221 static void throw_tcl_error(Tcl_Interp *interp, const char *proname);
222
223 static pltcl_proc_desc *compile_pltcl_function(Oid fn_oid, Oid tgreloid,
224 bool is_event_trigger,
225 bool pltrusted);
226
227 static int pltcl_elog(ClientData cdata, Tcl_Interp *interp,
228 int objc, Tcl_Obj *const objv[]);
229 static void pltcl_construct_errorCode(Tcl_Interp *interp, ErrorData *edata);
230 static const char *pltcl_get_condition_name(int sqlstate);
231 static int pltcl_quote(ClientData cdata, Tcl_Interp *interp,
232 int objc, Tcl_Obj *const objv[]);
233 static int pltcl_argisnull(ClientData cdata, Tcl_Interp *interp,
234 int objc, Tcl_Obj *const objv[]);
235 static int pltcl_returnnull(ClientData cdata, Tcl_Interp *interp,
236 int objc, Tcl_Obj *const objv[]);
237
238 static int pltcl_SPI_execute(ClientData cdata, Tcl_Interp *interp,
239 int objc, Tcl_Obj *const objv[]);
240 static int pltcl_process_SPI_result(Tcl_Interp *interp,
241 const char *arrayname,
242 Tcl_Obj *loop_body,
243 int spi_rc,
244 SPITupleTable *tuptable,
245 uint64 ntuples);
246 static int pltcl_SPI_prepare(ClientData cdata, Tcl_Interp *interp,
247 int objc, Tcl_Obj *const objv[]);
248 static int pltcl_SPI_execute_plan(ClientData cdata, Tcl_Interp *interp,
249 int objc, Tcl_Obj *const objv[]);
250 static int pltcl_SPI_lastoid(ClientData cdata, Tcl_Interp *interp,
251 int objc, Tcl_Obj *const objv[]);
252
253 static void pltcl_set_tuple_values(Tcl_Interp *interp, const char *arrayname,
254 uint64 tupno, HeapTuple tuple, TupleDesc tupdesc);
255 static Tcl_Obj *pltcl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc);
256
257
258 /*
259 * Hack to override Tcl's builtin Notifier subsystem. This prevents the
260 * backend from becoming multithreaded, which breaks all sorts of things.
261 * That happens in the default version of Tcl_InitNotifier if the TCL library
262 * has been compiled with multithreading support (i.e. when TCL_THREADS is
263 * defined under Unix, and in all cases under Windows).
264 * It's okay to disable the notifier because we never enter the Tcl event loop
265 * from Postgres, so the notifier capabilities are initialized, but never
266 * used. Only InitNotifier and DeleteFileHandler ever seem to get called
267 * within Postgres, but we implement all the functions for completeness.
268 */
269 static ClientData
pltcl_InitNotifier(void)270 pltcl_InitNotifier(void)
271 {
272 static int fakeThreadKey; /* To give valid address for ClientData */
273
274 return (ClientData) &(fakeThreadKey);
275 }
276
277 static void
pltcl_FinalizeNotifier(ClientData clientData)278 pltcl_FinalizeNotifier(ClientData clientData)
279 {
280 }
281
282 static void
pltcl_SetTimer(CONST86 Tcl_Time * timePtr)283 pltcl_SetTimer(CONST86 Tcl_Time *timePtr)
284 {
285 }
286
287 static void
pltcl_AlertNotifier(ClientData clientData)288 pltcl_AlertNotifier(ClientData clientData)
289 {
290 }
291
292 static void
pltcl_CreateFileHandler(int fd,int mask,Tcl_FileProc * proc,ClientData clientData)293 pltcl_CreateFileHandler(int fd, int mask,
294 Tcl_FileProc *proc, ClientData clientData)
295 {
296 }
297
298 static void
pltcl_DeleteFileHandler(int fd)299 pltcl_DeleteFileHandler(int fd)
300 {
301 }
302
303 static void
pltcl_ServiceModeHook(int mode)304 pltcl_ServiceModeHook(int mode)
305 {
306 }
307
308 static int
pltcl_WaitForEvent(CONST86 Tcl_Time * timePtr)309 pltcl_WaitForEvent(CONST86 Tcl_Time *timePtr)
310 {
311 return 0;
312 }
313
314
315 /*
316 * This routine is a crock, and so is everyplace that calls it. The problem
317 * is that the cached form of pltcl functions/queries is allocated permanently
318 * (mostly via malloc()) and never released until backend exit. Subsidiary
319 * data structures such as fmgr info records therefore must live forever
320 * as well. A better implementation would store all this stuff in a per-
321 * function memory context that could be reclaimed at need. In the meantime,
322 * fmgr_info_cxt must be called specifying TopMemoryContext so that whatever
323 * it might allocate, and whatever the eventual function might allocate using
324 * fn_mcxt, will live forever too.
325 */
326 static void
perm_fmgr_info(Oid functionId,FmgrInfo * finfo)327 perm_fmgr_info(Oid functionId, FmgrInfo *finfo)
328 {
329 fmgr_info_cxt(functionId, finfo, TopMemoryContext);
330 }
331
332 /*
333 * _PG_init() - library load-time initialization
334 *
335 * DO NOT make this static nor change its name!
336 *
337 * The work done here must be safe to do in the postmaster process,
338 * in case the pltcl library is preloaded in the postmaster.
339 */
340 void
_PG_init(void)341 _PG_init(void)
342 {
343 Tcl_NotifierProcs notifier;
344 HASHCTL hash_ctl;
345
346 /* Be sure we do initialization only once (should be redundant now) */
347 if (pltcl_pm_init_done)
348 return;
349
350 pg_bindtextdomain(TEXTDOMAIN);
351
352 #ifdef WIN32
353 /* Required on win32 to prevent error loading init.tcl */
354 Tcl_FindExecutable("");
355 #endif
356
357 /*
358 * Override the functions in the Notifier subsystem. See comments above.
359 */
360 notifier.setTimerProc = pltcl_SetTimer;
361 notifier.waitForEventProc = pltcl_WaitForEvent;
362 notifier.createFileHandlerProc = pltcl_CreateFileHandler;
363 notifier.deleteFileHandlerProc = pltcl_DeleteFileHandler;
364 notifier.initNotifierProc = pltcl_InitNotifier;
365 notifier.finalizeNotifierProc = pltcl_FinalizeNotifier;
366 notifier.alertNotifierProc = pltcl_AlertNotifier;
367 notifier.serviceModeHookProc = pltcl_ServiceModeHook;
368 Tcl_SetNotifier(¬ifier);
369
370 /************************************************************
371 * Create the dummy hold interpreter to prevent close of
372 * stdout and stderr on DeleteInterp
373 ************************************************************/
374 if ((pltcl_hold_interp = Tcl_CreateInterp()) == NULL)
375 elog(ERROR, "could not create master Tcl interpreter");
376 if (Tcl_Init(pltcl_hold_interp) == TCL_ERROR)
377 elog(ERROR, "could not initialize master Tcl interpreter");
378
379 /************************************************************
380 * Create the hash table for working interpreters
381 ************************************************************/
382 memset(&hash_ctl, 0, sizeof(hash_ctl));
383 hash_ctl.keysize = sizeof(Oid);
384 hash_ctl.entrysize = sizeof(pltcl_interp_desc);
385 pltcl_interp_htab = hash_create("PL/Tcl interpreters",
386 8,
387 &hash_ctl,
388 HASH_ELEM | HASH_BLOBS);
389
390 /************************************************************
391 * Create the hash table for function lookup
392 ************************************************************/
393 memset(&hash_ctl, 0, sizeof(hash_ctl));
394 hash_ctl.keysize = sizeof(pltcl_proc_key);
395 hash_ctl.entrysize = sizeof(pltcl_proc_ptr);
396 pltcl_proc_htab = hash_create("PL/Tcl functions",
397 100,
398 &hash_ctl,
399 HASH_ELEM | HASH_BLOBS);
400
401 pltcl_pm_init_done = true;
402 }
403
404 /**********************************************************************
405 * pltcl_init_interp() - initialize a new Tcl interpreter
406 **********************************************************************/
407 static void
pltcl_init_interp(pltcl_interp_desc * interp_desc,bool pltrusted)408 pltcl_init_interp(pltcl_interp_desc *interp_desc, bool pltrusted)
409 {
410 Tcl_Interp *interp;
411 char interpname[32];
412
413 /************************************************************
414 * Create the Tcl interpreter as a slave of pltcl_hold_interp.
415 * Note: Tcl automatically does Tcl_Init in the untrusted case,
416 * and it's not wanted in the trusted case.
417 ************************************************************/
418 snprintf(interpname, sizeof(interpname), "slave_%u", interp_desc->user_id);
419 if ((interp = Tcl_CreateSlave(pltcl_hold_interp, interpname,
420 pltrusted ? 1 : 0)) == NULL)
421 elog(ERROR, "could not create slave Tcl interpreter");
422 interp_desc->interp = interp;
423
424 /************************************************************
425 * Initialize the query hash table associated with interpreter
426 ************************************************************/
427 Tcl_InitHashTable(&interp_desc->query_hash, TCL_STRING_KEYS);
428
429 /************************************************************
430 * Install the commands for SPI support in the interpreter
431 ************************************************************/
432 Tcl_CreateObjCommand(interp, "elog",
433 pltcl_elog, NULL, NULL);
434 Tcl_CreateObjCommand(interp, "quote",
435 pltcl_quote, NULL, NULL);
436 Tcl_CreateObjCommand(interp, "argisnull",
437 pltcl_argisnull, NULL, NULL);
438 Tcl_CreateObjCommand(interp, "return_null",
439 pltcl_returnnull, NULL, NULL);
440
441 Tcl_CreateObjCommand(interp, "spi_exec",
442 pltcl_SPI_execute, NULL, NULL);
443 Tcl_CreateObjCommand(interp, "spi_prepare",
444 pltcl_SPI_prepare, NULL, NULL);
445 Tcl_CreateObjCommand(interp, "spi_execp",
446 pltcl_SPI_execute_plan, NULL, NULL);
447 Tcl_CreateObjCommand(interp, "spi_lastoid",
448 pltcl_SPI_lastoid, NULL, NULL);
449
450 /************************************************************
451 * Try to load the unknown procedure from pltcl_modules
452 ************************************************************/
453 pltcl_init_load_unknown(interp);
454 }
455
456 /**********************************************************************
457 * pltcl_fetch_interp() - fetch the Tcl interpreter to use for a function
458 *
459 * This also takes care of any on-first-use initialization required.
460 * Note: we assume caller has already connected to SPI.
461 **********************************************************************/
462 static pltcl_interp_desc *
pltcl_fetch_interp(bool pltrusted)463 pltcl_fetch_interp(bool pltrusted)
464 {
465 Oid user_id;
466 pltcl_interp_desc *interp_desc;
467 bool found;
468
469 /* Find or create the interpreter hashtable entry for this userid */
470 if (pltrusted)
471 user_id = GetUserId();
472 else
473 user_id = InvalidOid;
474
475 interp_desc = hash_search(pltcl_interp_htab, &user_id,
476 HASH_ENTER,
477 &found);
478 if (!found)
479 pltcl_init_interp(interp_desc, pltrusted);
480
481 return interp_desc;
482 }
483
484 /**********************************************************************
485 * pltcl_init_load_unknown() - Load the unknown procedure from
486 * table pltcl_modules (if it exists)
487 **********************************************************************/
488 static void
pltcl_init_load_unknown(Tcl_Interp * interp)489 pltcl_init_load_unknown(Tcl_Interp *interp)
490 {
491 Relation pmrel;
492 char *pmrelname,
493 *nspname;
494 char *buf;
495 int buflen;
496 int spi_rc;
497 int tcl_rc;
498 Tcl_DString unknown_src;
499 char *part;
500 uint64 i;
501 int fno;
502
503 /************************************************************
504 * Check if table pltcl_modules exists
505 *
506 * We allow the table to be found anywhere in the search_path.
507 * This is for backwards compatibility. To ensure that the table
508 * is trustworthy, we require it to be owned by a superuser.
509 ************************************************************/
510 pmrel = relation_openrv_extended(makeRangeVar(NULL, "pltcl_modules", -1),
511 AccessShareLock, true);
512 if (pmrel == NULL)
513 return;
514 /* sanity-check the relation kind */
515 if (!(pmrel->rd_rel->relkind == RELKIND_RELATION ||
516 pmrel->rd_rel->relkind == RELKIND_MATVIEW ||
517 pmrel->rd_rel->relkind == RELKIND_VIEW))
518 {
519 relation_close(pmrel, AccessShareLock);
520 return;
521 }
522 /* must be owned by superuser, else ignore */
523 if (!superuser_arg(pmrel->rd_rel->relowner))
524 {
525 relation_close(pmrel, AccessShareLock);
526 return;
527 }
528 /* get fully qualified table name for use in select command */
529 nspname = get_namespace_name(RelationGetNamespace(pmrel));
530 if (!nspname)
531 elog(ERROR, "cache lookup failed for namespace %u",
532 RelationGetNamespace(pmrel));
533 pmrelname = quote_qualified_identifier(nspname,
534 RelationGetRelationName(pmrel));
535
536 /************************************************************
537 * Read all the rows from it where modname = 'unknown',
538 * in the order of modseq
539 ************************************************************/
540 buflen = strlen(pmrelname) + 100;
541 buf = (char *) palloc(buflen);
542 snprintf(buf, buflen,
543 "select modsrc from %s where modname = 'unknown' order by modseq",
544 pmrelname);
545
546 spi_rc = SPI_execute(buf, false, 0);
547 if (spi_rc != SPI_OK_SELECT)
548 elog(ERROR, "select from pltcl_modules failed");
549
550 pfree(buf);
551
552 /************************************************************
553 * If there's nothing, module unknown doesn't exist
554 ************************************************************/
555 if (SPI_processed == 0)
556 {
557 SPI_freetuptable(SPI_tuptable);
558 ereport(WARNING,
559 (errmsg("module \"unknown\" not found in pltcl_modules")));
560 relation_close(pmrel, AccessShareLock);
561 return;
562 }
563
564 /************************************************************
565 * There is a module named unknown. Reassemble the
566 * source from the modsrc attributes and evaluate
567 * it in the Tcl interpreter
568 *
569 * leave this code as DString - it's only executed once per session
570 ************************************************************/
571 fno = SPI_fnumber(SPI_tuptable->tupdesc, "modsrc");
572
573 Tcl_DStringInit(&unknown_src);
574
575 for (i = 0; i < SPI_processed; i++)
576 {
577 part = SPI_getvalue(SPI_tuptable->vals[i],
578 SPI_tuptable->tupdesc, fno);
579 if (part != NULL)
580 {
581 UTF_BEGIN;
582 Tcl_DStringAppend(&unknown_src, UTF_E2U(part), -1);
583 UTF_END;
584 pfree(part);
585 }
586 }
587 tcl_rc = Tcl_EvalEx(interp, Tcl_DStringValue(&unknown_src),
588 Tcl_DStringLength(&unknown_src),
589 TCL_EVAL_GLOBAL);
590
591 Tcl_DStringFree(&unknown_src);
592 SPI_freetuptable(SPI_tuptable);
593
594 if (tcl_rc != TCL_OK)
595 ereport(ERROR,
596 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
597 errmsg("could not load module \"unknown\": %s",
598 utf_u2e(Tcl_GetStringResult(interp)))));
599
600 relation_close(pmrel, AccessShareLock);
601 }
602
603
604 /**********************************************************************
605 * pltcl_call_handler - This is the only visible function
606 * of the PL interpreter. The PostgreSQL
607 * function manager and trigger manager
608 * call this function for execution of
609 * PL/Tcl procedures.
610 **********************************************************************/
611 PG_FUNCTION_INFO_V1(pltcl_call_handler);
612
613 /* keep non-static */
614 Datum
pltcl_call_handler(PG_FUNCTION_ARGS)615 pltcl_call_handler(PG_FUNCTION_ARGS)
616 {
617 return pltcl_handler(fcinfo, true);
618 }
619
620 /*
621 * Alternative handler for unsafe functions
622 */
623 PG_FUNCTION_INFO_V1(pltclu_call_handler);
624
625 /* keep non-static */
626 Datum
pltclu_call_handler(PG_FUNCTION_ARGS)627 pltclu_call_handler(PG_FUNCTION_ARGS)
628 {
629 return pltcl_handler(fcinfo, false);
630 }
631
632
633 static Datum
pltcl_handler(PG_FUNCTION_ARGS,bool pltrusted)634 pltcl_handler(PG_FUNCTION_ARGS, bool pltrusted)
635 {
636 Datum retval;
637 FunctionCallInfo save_fcinfo;
638 pltcl_proc_desc *save_prodesc;
639
640 /*
641 * Ensure that static pointers are saved/restored properly
642 */
643 save_fcinfo = pltcl_current_fcinfo;
644 save_prodesc = pltcl_current_prodesc;
645
646 PG_TRY();
647 {
648 /*
649 * Determine if called as function or trigger and call appropriate
650 * subhandler
651 */
652 if (CALLED_AS_TRIGGER(fcinfo))
653 {
654 pltcl_current_fcinfo = NULL;
655 retval = PointerGetDatum(pltcl_trigger_handler(fcinfo, pltrusted));
656 }
657 else if (CALLED_AS_EVENT_TRIGGER(fcinfo))
658 {
659 pltcl_current_fcinfo = NULL;
660 pltcl_event_trigger_handler(fcinfo, pltrusted);
661 retval = (Datum) 0;
662 }
663 else
664 {
665 pltcl_current_fcinfo = fcinfo;
666 retval = pltcl_func_handler(fcinfo, pltrusted);
667 }
668 }
669 PG_CATCH();
670 {
671 pltcl_current_fcinfo = save_fcinfo;
672 pltcl_current_prodesc = save_prodesc;
673 PG_RE_THROW();
674 }
675 PG_END_TRY();
676
677 pltcl_current_fcinfo = save_fcinfo;
678 pltcl_current_prodesc = save_prodesc;
679
680 return retval;
681 }
682
683
684 /**********************************************************************
685 * pltcl_func_handler() - Handler for regular function calls
686 **********************************************************************/
687 static Datum
pltcl_func_handler(PG_FUNCTION_ARGS,bool pltrusted)688 pltcl_func_handler(PG_FUNCTION_ARGS, bool pltrusted)
689 {
690 pltcl_proc_desc *prodesc;
691 Tcl_Interp *volatile interp;
692 Tcl_Obj *tcl_cmd;
693 int i;
694 int tcl_rc;
695 Datum retval;
696
697 /* Connect to SPI manager */
698 if (SPI_connect() != SPI_OK_CONNECT)
699 elog(ERROR, "could not connect to SPI manager");
700
701 /* Find or compile the function */
702 prodesc = compile_pltcl_function(fcinfo->flinfo->fn_oid, InvalidOid,
703 false, pltrusted);
704
705 pltcl_current_prodesc = prodesc;
706
707 interp = prodesc->interp_desc->interp;
708
709 /************************************************************
710 * Create the tcl command to call the internal
711 * proc in the Tcl interpreter
712 ************************************************************/
713 tcl_cmd = Tcl_NewObj();
714 Tcl_ListObjAppendElement(NULL, tcl_cmd,
715 Tcl_NewStringObj(prodesc->internal_proname, -1));
716
717 /* We hold a refcount on tcl_cmd just to be sure it stays around */
718 Tcl_IncrRefCount(tcl_cmd);
719
720 /************************************************************
721 * Add all call arguments to the command
722 ************************************************************/
723 PG_TRY();
724 {
725 for (i = 0; i < prodesc->nargs; i++)
726 {
727 if (prodesc->arg_is_rowtype[i])
728 {
729 /**************************************************
730 * For tuple values, add a list for 'array set ...'
731 **************************************************/
732 if (fcinfo->argnull[i])
733 Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj());
734 else
735 {
736 HeapTupleHeader td;
737 Oid tupType;
738 int32 tupTypmod;
739 TupleDesc tupdesc;
740 HeapTupleData tmptup;
741 Tcl_Obj *list_tmp;
742
743 td = DatumGetHeapTupleHeader(fcinfo->arg[i]);
744 /* Extract rowtype info and find a tupdesc */
745 tupType = HeapTupleHeaderGetTypeId(td);
746 tupTypmod = HeapTupleHeaderGetTypMod(td);
747 tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod);
748 /* Build a temporary HeapTuple control structure */
749 tmptup.t_len = HeapTupleHeaderGetDatumLength(td);
750 tmptup.t_data = td;
751
752 list_tmp = pltcl_build_tuple_argument(&tmptup, tupdesc);
753 Tcl_ListObjAppendElement(NULL, tcl_cmd, list_tmp);
754
755 ReleaseTupleDesc(tupdesc);
756 }
757 }
758 else
759 {
760 /**************************************************
761 * Single values are added as string element
762 * of their external representation
763 **************************************************/
764 if (fcinfo->argnull[i])
765 Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj());
766 else
767 {
768 char *tmp;
769
770 tmp = OutputFunctionCall(&prodesc->arg_out_func[i],
771 fcinfo->arg[i]);
772 UTF_BEGIN;
773 Tcl_ListObjAppendElement(NULL, tcl_cmd,
774 Tcl_NewStringObj(UTF_E2U(tmp), -1));
775 UTF_END;
776 pfree(tmp);
777 }
778 }
779 }
780 }
781 PG_CATCH();
782 {
783 /* Release refcount to free tcl_cmd */
784 Tcl_DecrRefCount(tcl_cmd);
785 PG_RE_THROW();
786 }
787 PG_END_TRY();
788
789 /************************************************************
790 * Call the Tcl function
791 *
792 * We assume no PG error can be thrown directly from this call.
793 ************************************************************/
794 tcl_rc = Tcl_EvalObjEx(interp, tcl_cmd, (TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL));
795
796 /* Release refcount to free tcl_cmd (and all subsidiary objects) */
797 Tcl_DecrRefCount(tcl_cmd);
798
799 /************************************************************
800 * Check for errors reported by Tcl.
801 ************************************************************/
802 if (tcl_rc != TCL_OK)
803 throw_tcl_error(interp, prodesc->user_proname);
804
805 /************************************************************
806 * Disconnect from SPI manager and then create the return
807 * value datum (if the input function does a palloc for it
808 * this must not be allocated in the SPI memory context
809 * because SPI_finish would free it). But don't try to call
810 * the result_in_func if we've been told to return a NULL;
811 * the Tcl result may not be a valid value of the result type
812 * in that case.
813 ************************************************************/
814 if (SPI_finish() != SPI_OK_FINISH)
815 elog(ERROR, "SPI_finish() failed");
816
817 if (fcinfo->isnull)
818 retval = InputFunctionCall(&prodesc->result_in_func,
819 NULL,
820 prodesc->result_typioparam,
821 -1);
822 else
823 retval = InputFunctionCall(&prodesc->result_in_func,
824 utf_u2e(Tcl_GetStringResult(interp)),
825 prodesc->result_typioparam,
826 -1);
827
828 return retval;
829 }
830
831
832 /**********************************************************************
833 * pltcl_trigger_handler() - Handler for trigger calls
834 **********************************************************************/
835 static HeapTuple
pltcl_trigger_handler(PG_FUNCTION_ARGS,bool pltrusted)836 pltcl_trigger_handler(PG_FUNCTION_ARGS, bool pltrusted)
837 {
838 pltcl_proc_desc *prodesc;
839 Tcl_Interp *volatile interp;
840 TriggerData *trigdata = (TriggerData *) fcinfo->context;
841 char *stroid;
842 TupleDesc tupdesc;
843 volatile HeapTuple rettup;
844 Tcl_Obj *tcl_cmd;
845 Tcl_Obj *tcl_trigtup;
846 Tcl_Obj *tcl_newtup;
847 int tcl_rc;
848 int i;
849 int *modattrs;
850 Datum *modvalues;
851 char *modnulls;
852 int ret_numvals;
853 const char *result;
854 const char **ret_values;
855
856 /* Connect to SPI manager */
857 if (SPI_connect() != SPI_OK_CONNECT)
858 elog(ERROR, "could not connect to SPI manager");
859
860 /* Find or compile the function */
861 prodesc = compile_pltcl_function(fcinfo->flinfo->fn_oid,
862 RelationGetRelid(trigdata->tg_relation),
863 false, /* not an event trigger */
864 pltrusted);
865
866 pltcl_current_prodesc = prodesc;
867
868 interp = prodesc->interp_desc->interp;
869
870 tupdesc = trigdata->tg_relation->rd_att;
871
872 /************************************************************
873 * Create the tcl command to call the internal
874 * proc in the interpreter
875 ************************************************************/
876 tcl_cmd = Tcl_NewObj();
877 Tcl_IncrRefCount(tcl_cmd);
878
879 PG_TRY();
880 {
881 /* The procedure name (note this is all ASCII, so no utf_e2u) */
882 Tcl_ListObjAppendElement(NULL, tcl_cmd,
883 Tcl_NewStringObj(prodesc->internal_proname, -1));
884
885 /* The trigger name for argument TG_name */
886 Tcl_ListObjAppendElement(NULL, tcl_cmd,
887 Tcl_NewStringObj(utf_e2u(trigdata->tg_trigger->tgname), -1));
888
889 /* The oid of the trigger relation for argument TG_relid */
890 /* Consider not converting to a string for more performance? */
891 stroid = DatumGetCString(DirectFunctionCall1(oidout,
892 ObjectIdGetDatum(trigdata->tg_relation->rd_id)));
893 Tcl_ListObjAppendElement(NULL, tcl_cmd,
894 Tcl_NewStringObj(stroid, -1));
895 pfree(stroid);
896
897 /* The name of the table the trigger is acting on: TG_table_name */
898 stroid = SPI_getrelname(trigdata->tg_relation);
899 Tcl_ListObjAppendElement(NULL, tcl_cmd,
900 Tcl_NewStringObj(utf_e2u(stroid), -1));
901 pfree(stroid);
902
903 /* The schema of the table the trigger is acting on: TG_table_schema */
904 stroid = SPI_getnspname(trigdata->tg_relation);
905 Tcl_ListObjAppendElement(NULL, tcl_cmd,
906 Tcl_NewStringObj(utf_e2u(stroid), -1));
907 pfree(stroid);
908
909 /* A list of attribute names for argument TG_relatts */
910 tcl_trigtup = Tcl_NewObj();
911 Tcl_ListObjAppendElement(NULL, tcl_trigtup, Tcl_NewObj());
912 for (i = 0; i < tupdesc->natts; i++)
913 {
914 if (tupdesc->attrs[i]->attisdropped)
915 Tcl_ListObjAppendElement(NULL, tcl_trigtup, Tcl_NewObj());
916 else
917 Tcl_ListObjAppendElement(NULL, tcl_trigtup,
918 Tcl_NewStringObj(utf_e2u(NameStr(tupdesc->attrs[i]->attname)), -1));
919 }
920 Tcl_ListObjAppendElement(NULL, tcl_cmd, tcl_trigtup);
921
922 /* The when part of the event for TG_when */
923 if (TRIGGER_FIRED_BEFORE(trigdata->tg_event))
924 Tcl_ListObjAppendElement(NULL, tcl_cmd,
925 Tcl_NewStringObj("BEFORE", -1));
926 else if (TRIGGER_FIRED_AFTER(trigdata->tg_event))
927 Tcl_ListObjAppendElement(NULL, tcl_cmd,
928 Tcl_NewStringObj("AFTER", -1));
929 else if (TRIGGER_FIRED_INSTEAD(trigdata->tg_event))
930 Tcl_ListObjAppendElement(NULL, tcl_cmd,
931 Tcl_NewStringObj("INSTEAD OF", -1));
932 else
933 elog(ERROR, "unrecognized WHEN tg_event: %u", trigdata->tg_event);
934
935 /* The level part of the event for TG_level */
936 if (TRIGGER_FIRED_FOR_ROW(trigdata->tg_event))
937 {
938 Tcl_ListObjAppendElement(NULL, tcl_cmd,
939 Tcl_NewStringObj("ROW", -1));
940
941 /* Build the data list for the trigtuple */
942 tcl_trigtup = pltcl_build_tuple_argument(trigdata->tg_trigtuple,
943 tupdesc);
944
945 /*
946 * Now the command part of the event for TG_op and data for NEW
947 * and OLD
948 */
949 if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
950 {
951 Tcl_ListObjAppendElement(NULL, tcl_cmd,
952 Tcl_NewStringObj("INSERT", -1));
953
954 Tcl_ListObjAppendElement(NULL, tcl_cmd, tcl_trigtup);
955 Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj());
956
957 rettup = trigdata->tg_trigtuple;
958 }
959 else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
960 {
961 Tcl_ListObjAppendElement(NULL, tcl_cmd,
962 Tcl_NewStringObj("DELETE", -1));
963
964 Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj());
965 Tcl_ListObjAppendElement(NULL, tcl_cmd, tcl_trigtup);
966
967 rettup = trigdata->tg_trigtuple;
968 }
969 else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
970 {
971 Tcl_ListObjAppendElement(NULL, tcl_cmd,
972 Tcl_NewStringObj("UPDATE", -1));
973
974 tcl_newtup = pltcl_build_tuple_argument(trigdata->tg_newtuple,
975 tupdesc);
976
977 Tcl_ListObjAppendElement(NULL, tcl_cmd, tcl_newtup);
978 Tcl_ListObjAppendElement(NULL, tcl_cmd, tcl_trigtup);
979
980 rettup = trigdata->tg_newtuple;
981 }
982 else
983 elog(ERROR, "unrecognized OP tg_event: %u", trigdata->tg_event);
984 }
985 else if (TRIGGER_FIRED_FOR_STATEMENT(trigdata->tg_event))
986 {
987 Tcl_ListObjAppendElement(NULL, tcl_cmd,
988 Tcl_NewStringObj("STATEMENT", -1));
989
990 if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
991 Tcl_ListObjAppendElement(NULL, tcl_cmd,
992 Tcl_NewStringObj("INSERT", -1));
993 else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
994 Tcl_ListObjAppendElement(NULL, tcl_cmd,
995 Tcl_NewStringObj("DELETE", -1));
996 else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
997 Tcl_ListObjAppendElement(NULL, tcl_cmd,
998 Tcl_NewStringObj("UPDATE", -1));
999 else if (TRIGGER_FIRED_BY_TRUNCATE(trigdata->tg_event))
1000 Tcl_ListObjAppendElement(NULL, tcl_cmd,
1001 Tcl_NewStringObj("TRUNCATE", -1));
1002 else
1003 elog(ERROR, "unrecognized OP tg_event: %u", trigdata->tg_event);
1004
1005 Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj());
1006 Tcl_ListObjAppendElement(NULL, tcl_cmd, Tcl_NewObj());
1007
1008 rettup = (HeapTuple) NULL;
1009 }
1010 else
1011 elog(ERROR, "unrecognized LEVEL tg_event: %u", trigdata->tg_event);
1012
1013 /* Finally append the arguments from CREATE TRIGGER */
1014 for (i = 0; i < trigdata->tg_trigger->tgnargs; i++)
1015 Tcl_ListObjAppendElement(NULL, tcl_cmd,
1016 Tcl_NewStringObj(utf_e2u(trigdata->tg_trigger->tgargs[i]), -1));
1017
1018 }
1019 PG_CATCH();
1020 {
1021 Tcl_DecrRefCount(tcl_cmd);
1022 PG_RE_THROW();
1023 }
1024 PG_END_TRY();
1025
1026 /************************************************************
1027 * Call the Tcl function
1028 *
1029 * We assume no PG error can be thrown directly from this call.
1030 ************************************************************/
1031 tcl_rc = Tcl_EvalObjEx(interp, tcl_cmd, (TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL));
1032
1033 /* Release refcount to free tcl_cmd (and all subsidiary objects) */
1034 Tcl_DecrRefCount(tcl_cmd);
1035
1036 /************************************************************
1037 * Check for errors reported by Tcl.
1038 ************************************************************/
1039 if (tcl_rc != TCL_OK)
1040 throw_tcl_error(interp, prodesc->user_proname);
1041
1042 /************************************************************
1043 * The return value from the procedure might be one of
1044 * the magic strings OK or SKIP or a list from array get.
1045 * We can check for OK or SKIP without worrying about encoding.
1046 ************************************************************/
1047 if (SPI_finish() != SPI_OK_FINISH)
1048 elog(ERROR, "SPI_finish() failed");
1049
1050 result = Tcl_GetStringResult(interp);
1051
1052 if (strcmp(result, "OK") == 0)
1053 return rettup;
1054 if (strcmp(result, "SKIP") == 0)
1055 return (HeapTuple) NULL;
1056
1057 /************************************************************
1058 * Convert the result value from the Tcl interpreter
1059 * and setup structures for SPI_modifytuple();
1060 ************************************************************/
1061 if (Tcl_SplitList(interp, result,
1062 &ret_numvals, &ret_values) != TCL_OK)
1063 ereport(ERROR,
1064 (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
1065 errmsg("could not split return value from trigger: %s",
1066 utf_u2e(Tcl_GetStringResult(interp)))));
1067
1068 /* Use a TRY to ensure ret_values will get freed */
1069 PG_TRY();
1070 {
1071 if (ret_numvals % 2 != 0)
1072 ereport(ERROR,
1073 (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
1074 errmsg("trigger's return list must have even number of elements")));
1075
1076 modattrs = (int *) palloc(tupdesc->natts * sizeof(int));
1077 modvalues = (Datum *) palloc(tupdesc->natts * sizeof(Datum));
1078 for (i = 0; i < tupdesc->natts; i++)
1079 {
1080 modattrs[i] = i + 1;
1081 modvalues[i] = (Datum) NULL;
1082 }
1083
1084 modnulls = palloc(tupdesc->natts);
1085 memset(modnulls, 'n', tupdesc->natts);
1086
1087 for (i = 0; i < ret_numvals; i += 2)
1088 {
1089 char *ret_name = utf_u2e(ret_values[i]);
1090 char *ret_value = utf_u2e(ret_values[i + 1]);
1091 int attnum;
1092 Oid typinput;
1093 Oid typioparam;
1094 FmgrInfo finfo;
1095
1096 /************************************************************
1097 * Get the attribute number
1098 *
1099 * We silently ignore ".tupno", if it's present but doesn't match
1100 * any actual output column. This allows direct use of a row
1101 * returned by pltcl_set_tuple_values().
1102 ************************************************************/
1103 attnum = SPI_fnumber(tupdesc, ret_name);
1104 if (attnum == SPI_ERROR_NOATTRIBUTE)
1105 {
1106 if (strcmp(ret_name, ".tupno") == 0)
1107 continue;
1108 ereport(ERROR,
1109 (errcode(ERRCODE_UNDEFINED_COLUMN),
1110 errmsg("unrecognized attribute \"%s\"",
1111 ret_name)));
1112 }
1113 if (attnum <= 0)
1114 ereport(ERROR,
1115 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1116 errmsg("cannot set system attribute \"%s\"",
1117 ret_name)));
1118
1119 /************************************************************
1120 * Ignore dropped columns
1121 ************************************************************/
1122 if (tupdesc->attrs[attnum - 1]->attisdropped)
1123 continue;
1124
1125 /************************************************************
1126 * Lookup the attribute type in the syscache
1127 * for the input function
1128 ************************************************************/
1129 getTypeInputInfo(tupdesc->attrs[attnum - 1]->atttypid,
1130 &typinput, &typioparam);
1131 fmgr_info(typinput, &finfo);
1132
1133 /************************************************************
1134 * Set the attribute to NOT NULL and convert the contents
1135 ************************************************************/
1136 modvalues[attnum - 1] = InputFunctionCall(&finfo,
1137 ret_value,
1138 typioparam,
1139 tupdesc->attrs[attnum - 1]->atttypmod);
1140 modnulls[attnum - 1] = ' ';
1141 }
1142
1143 rettup = SPI_modifytuple(trigdata->tg_relation, rettup, tupdesc->natts,
1144 modattrs, modvalues, modnulls);
1145
1146 pfree(modattrs);
1147 pfree(modvalues);
1148 pfree(modnulls);
1149
1150 if (rettup == NULL)
1151 elog(ERROR, "SPI_modifytuple() failed - RC = %d", SPI_result);
1152 }
1153 PG_CATCH();
1154 {
1155 ckfree((char *) ret_values);
1156 PG_RE_THROW();
1157 }
1158 PG_END_TRY();
1159 ckfree((char *) ret_values);
1160
1161 return rettup;
1162 }
1163
1164 /**********************************************************************
1165 * pltcl_event_trigger_handler() - Handler for event trigger calls
1166 **********************************************************************/
1167 static void
pltcl_event_trigger_handler(PG_FUNCTION_ARGS,bool pltrusted)1168 pltcl_event_trigger_handler(PG_FUNCTION_ARGS, bool pltrusted)
1169 {
1170 pltcl_proc_desc *prodesc;
1171 Tcl_Interp *volatile interp;
1172 EventTriggerData *tdata = (EventTriggerData *) fcinfo->context;
1173 Tcl_Obj *tcl_cmd;
1174 int tcl_rc;
1175
1176 /* Connect to SPI manager */
1177 if (SPI_connect() != SPI_OK_CONNECT)
1178 elog(ERROR, "could not connect to SPI manager");
1179
1180 /* Find or compile the function */
1181 prodesc = compile_pltcl_function(fcinfo->flinfo->fn_oid,
1182 InvalidOid, true, pltrusted);
1183
1184 pltcl_current_prodesc = prodesc;
1185
1186 interp = prodesc->interp_desc->interp;
1187
1188 /* Create the tcl command and call the internal proc */
1189 tcl_cmd = Tcl_NewObj();
1190 Tcl_IncrRefCount(tcl_cmd);
1191 Tcl_ListObjAppendElement(NULL, tcl_cmd,
1192 Tcl_NewStringObj(prodesc->internal_proname, -1));
1193 Tcl_ListObjAppendElement(NULL, tcl_cmd,
1194 Tcl_NewStringObj(utf_e2u(tdata->event), -1));
1195 Tcl_ListObjAppendElement(NULL, tcl_cmd,
1196 Tcl_NewStringObj(utf_e2u(tdata->tag), -1));
1197
1198 tcl_rc = Tcl_EvalObjEx(interp, tcl_cmd, (TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL));
1199
1200 /* Release refcount to free tcl_cmd (and all subsidiary objects) */
1201 Tcl_DecrRefCount(tcl_cmd);
1202
1203 /* Check for errors reported by Tcl. */
1204 if (tcl_rc != TCL_OK)
1205 throw_tcl_error(interp, prodesc->user_proname);
1206
1207 if (SPI_finish() != SPI_OK_FINISH)
1208 elog(ERROR, "SPI_finish() failed");
1209 }
1210
1211
1212 /**********************************************************************
1213 * throw_tcl_error - ereport an error returned from the Tcl interpreter
1214 **********************************************************************/
1215 static void
throw_tcl_error(Tcl_Interp * interp,const char * proname)1216 throw_tcl_error(Tcl_Interp *interp, const char *proname)
1217 {
1218 /*
1219 * Caution is needed here because Tcl_GetVar could overwrite the
1220 * interpreter result (even though it's not really supposed to), and we
1221 * can't control the order of evaluation of ereport arguments. Hence, make
1222 * real sure we have our own copy of the result string before invoking
1223 * Tcl_GetVar.
1224 */
1225 char *emsg;
1226 char *econtext;
1227
1228 emsg = pstrdup(utf_u2e(Tcl_GetStringResult(interp)));
1229 econtext = utf_u2e(Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY));
1230 ereport(ERROR,
1231 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
1232 errmsg("%s", emsg),
1233 errcontext("%s\nin PL/Tcl function \"%s\"",
1234 econtext, proname)));
1235 }
1236
1237
1238 /**********************************************************************
1239 * compile_pltcl_function - compile (or hopefully just look up) function
1240 *
1241 * tgreloid is the OID of the relation when compiling a trigger, or zero
1242 * (InvalidOid) when compiling a plain function.
1243 **********************************************************************/
1244 static pltcl_proc_desc *
compile_pltcl_function(Oid fn_oid,Oid tgreloid,bool is_event_trigger,bool pltrusted)1245 compile_pltcl_function(Oid fn_oid, Oid tgreloid,
1246 bool is_event_trigger, bool pltrusted)
1247 {
1248 HeapTuple procTup;
1249 Form_pg_proc procStruct;
1250 pltcl_proc_key proc_key;
1251 pltcl_proc_ptr *proc_ptr;
1252 bool found;
1253 pltcl_proc_desc *prodesc;
1254
1255 /* We'll need the pg_proc tuple in any case... */
1256 procTup = SearchSysCache1(PROCOID, ObjectIdGetDatum(fn_oid));
1257 if (!HeapTupleIsValid(procTup))
1258 elog(ERROR, "cache lookup failed for function %u", fn_oid);
1259 procStruct = (Form_pg_proc) GETSTRUCT(procTup);
1260
1261 /* Try to find function in pltcl_proc_htab */
1262 proc_key.proc_id = fn_oid;
1263 proc_key.is_trigger = OidIsValid(tgreloid);
1264 proc_key.user_id = pltrusted ? GetUserId() : InvalidOid;
1265
1266 proc_ptr = hash_search(pltcl_proc_htab, &proc_key,
1267 HASH_ENTER,
1268 &found);
1269 if (!found)
1270 proc_ptr->proc_ptr = NULL;
1271
1272 prodesc = proc_ptr->proc_ptr;
1273
1274 /************************************************************
1275 * If it's present, must check whether it's still up to date.
1276 * This is needed because CREATE OR REPLACE FUNCTION can modify the
1277 * function's pg_proc entry without changing its OID.
1278 ************************************************************/
1279 if (prodesc != NULL)
1280 {
1281 bool uptodate;
1282
1283 uptodate = (prodesc->fn_xmin == HeapTupleHeaderGetRawXmin(procTup->t_data) &&
1284 ItemPointerEquals(&prodesc->fn_tid, &procTup->t_self));
1285
1286 if (!uptodate)
1287 {
1288 proc_ptr->proc_ptr = NULL;
1289 prodesc = NULL;
1290 }
1291 }
1292
1293 /************************************************************
1294 * If we haven't found it in the hashtable, we analyze
1295 * the functions arguments and returntype and store
1296 * the in-/out-functions in the prodesc block and create
1297 * a new hashtable entry for it.
1298 *
1299 * Then we load the procedure into the Tcl interpreter.
1300 ************************************************************/
1301 if (prodesc == NULL)
1302 {
1303 bool is_trigger = OidIsValid(tgreloid);
1304 char internal_proname[128];
1305 HeapTuple typeTup;
1306 Form_pg_type typeStruct;
1307 Tcl_DString proc_internal_def;
1308 Tcl_DString proc_internal_body;
1309 char proc_internal_args[33 * FUNC_MAX_ARGS];
1310 Datum prosrcdatum;
1311 bool isnull;
1312 char *proc_source;
1313 char buf[32];
1314 Tcl_Interp *interp;
1315 int i;
1316 int tcl_rc;
1317
1318 /************************************************************
1319 * Build our internal proc name from the function's Oid. Append
1320 * "_trigger" when appropriate to ensure the normal and trigger
1321 * cases are kept separate. Note name must be all-ASCII.
1322 ************************************************************/
1323 if (!is_trigger && !is_event_trigger)
1324 snprintf(internal_proname, sizeof(internal_proname),
1325 "__PLTcl_proc_%u", fn_oid);
1326 else if (is_event_trigger)
1327 snprintf(internal_proname, sizeof(internal_proname),
1328 "__PLTcl_proc_%u_evttrigger", fn_oid);
1329 else if (is_trigger)
1330 snprintf(internal_proname, sizeof(internal_proname),
1331 "__PLTcl_proc_%u_trigger", fn_oid);
1332
1333 /************************************************************
1334 * Allocate a new procedure description block
1335 ************************************************************/
1336 prodesc = (pltcl_proc_desc *) malloc(sizeof(pltcl_proc_desc));
1337 if (prodesc == NULL)
1338 ereport(ERROR,
1339 (errcode(ERRCODE_OUT_OF_MEMORY),
1340 errmsg("out of memory")));
1341 MemSet(prodesc, 0, sizeof(pltcl_proc_desc));
1342 prodesc->user_proname = strdup(NameStr(procStruct->proname));
1343 prodesc->internal_proname = strdup(internal_proname);
1344 if (prodesc->user_proname == NULL || prodesc->internal_proname == NULL)
1345 ereport(ERROR,
1346 (errcode(ERRCODE_OUT_OF_MEMORY),
1347 errmsg("out of memory")));
1348 prodesc->fn_xmin = HeapTupleHeaderGetRawXmin(procTup->t_data);
1349 prodesc->fn_tid = procTup->t_self;
1350
1351 /* Remember if function is STABLE/IMMUTABLE */
1352 prodesc->fn_readonly =
1353 (procStruct->provolatile != PROVOLATILE_VOLATILE);
1354 /* And whether it is trusted */
1355 prodesc->lanpltrusted = pltrusted;
1356
1357 /************************************************************
1358 * Identify the interpreter to use for the function
1359 ************************************************************/
1360 prodesc->interp_desc = pltcl_fetch_interp(prodesc->lanpltrusted);
1361 interp = prodesc->interp_desc->interp;
1362
1363 /************************************************************
1364 * Get the required information for input conversion of the
1365 * return value.
1366 ************************************************************/
1367 if (!is_trigger && !is_event_trigger)
1368 {
1369 typeTup =
1370 SearchSysCache1(TYPEOID,
1371 ObjectIdGetDatum(procStruct->prorettype));
1372 if (!HeapTupleIsValid(typeTup))
1373 {
1374 free(prodesc->user_proname);
1375 free(prodesc->internal_proname);
1376 free(prodesc);
1377 elog(ERROR, "cache lookup failed for type %u",
1378 procStruct->prorettype);
1379 }
1380 typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
1381
1382 /* Disallow pseudotype result, except VOID */
1383 if (typeStruct->typtype == TYPTYPE_PSEUDO)
1384 {
1385 if (procStruct->prorettype == VOIDOID)
1386 /* okay */ ;
1387 else if (procStruct->prorettype == TRIGGEROID ||
1388 procStruct->prorettype == EVTTRIGGEROID)
1389 {
1390 free(prodesc->user_proname);
1391 free(prodesc->internal_proname);
1392 free(prodesc);
1393 ereport(ERROR,
1394 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1395 errmsg("trigger functions can only be called as triggers")));
1396 }
1397 else
1398 {
1399 free(prodesc->user_proname);
1400 free(prodesc->internal_proname);
1401 free(prodesc);
1402 ereport(ERROR,
1403 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1404 errmsg("PL/Tcl functions cannot return type %s",
1405 format_type_be(procStruct->prorettype))));
1406 }
1407 }
1408
1409 if (typeStruct->typtype == TYPTYPE_COMPOSITE)
1410 {
1411 free(prodesc->user_proname);
1412 free(prodesc->internal_proname);
1413 free(prodesc);
1414 ereport(ERROR,
1415 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1416 errmsg("PL/Tcl functions cannot return composite types")));
1417 }
1418
1419 perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
1420 prodesc->result_typioparam = getTypeIOParam(typeTup);
1421
1422 ReleaseSysCache(typeTup);
1423 }
1424
1425 /************************************************************
1426 * Get the required information for output conversion
1427 * of all procedure arguments
1428 ************************************************************/
1429 if (!is_trigger && !is_event_trigger)
1430 {
1431 prodesc->nargs = procStruct->pronargs;
1432 proc_internal_args[0] = '\0';
1433 for (i = 0; i < prodesc->nargs; i++)
1434 {
1435 typeTup = SearchSysCache1(TYPEOID,
1436 ObjectIdGetDatum(procStruct->proargtypes.values[i]));
1437 if (!HeapTupleIsValid(typeTup))
1438 {
1439 free(prodesc->user_proname);
1440 free(prodesc->internal_proname);
1441 free(prodesc);
1442 elog(ERROR, "cache lookup failed for type %u",
1443 procStruct->proargtypes.values[i]);
1444 }
1445 typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
1446
1447 /* Disallow pseudotype argument */
1448 if (typeStruct->typtype == TYPTYPE_PSEUDO)
1449 {
1450 free(prodesc->user_proname);
1451 free(prodesc->internal_proname);
1452 free(prodesc);
1453 ereport(ERROR,
1454 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1455 errmsg("PL/Tcl functions cannot accept type %s",
1456 format_type_be(procStruct->proargtypes.values[i]))));
1457 }
1458
1459 if (typeStruct->typtype == TYPTYPE_COMPOSITE)
1460 {
1461 prodesc->arg_is_rowtype[i] = true;
1462 snprintf(buf, sizeof(buf), "__PLTcl_Tup_%d", i + 1);
1463 }
1464 else
1465 {
1466 prodesc->arg_is_rowtype[i] = false;
1467 perm_fmgr_info(typeStruct->typoutput,
1468 &(prodesc->arg_out_func[i]));
1469 snprintf(buf, sizeof(buf), "%d", i + 1);
1470 }
1471
1472 if (i > 0)
1473 strcat(proc_internal_args, " ");
1474 strcat(proc_internal_args, buf);
1475
1476 ReleaseSysCache(typeTup);
1477 }
1478 }
1479 else if (is_trigger)
1480 {
1481 /* trigger procedure has fixed args */
1482 strcpy(proc_internal_args,
1483 "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");
1484 }
1485 else if (is_event_trigger)
1486 {
1487 /* event trigger procedure has fixed args */
1488 strcpy(proc_internal_args, "TG_event TG_tag");
1489 }
1490
1491 /************************************************************
1492 * Create the tcl command to define the internal
1493 * procedure
1494 *
1495 * leave this code as DString - it's a text processing function
1496 * that only gets invoked when the tcl function is invoked
1497 * for the first time
1498 ************************************************************/
1499 Tcl_DStringInit(&proc_internal_def);
1500 Tcl_DStringInit(&proc_internal_body);
1501 Tcl_DStringAppendElement(&proc_internal_def, "proc");
1502 Tcl_DStringAppendElement(&proc_internal_def, internal_proname);
1503 Tcl_DStringAppendElement(&proc_internal_def, proc_internal_args);
1504
1505 /************************************************************
1506 * prefix procedure body with
1507 * upvar #0 <internal_procname> GD
1508 * and with appropriate setting of arguments
1509 ************************************************************/
1510 Tcl_DStringAppend(&proc_internal_body, "upvar #0 ", -1);
1511 Tcl_DStringAppend(&proc_internal_body, internal_proname, -1);
1512 Tcl_DStringAppend(&proc_internal_body, " GD\n", -1);
1513 if (is_trigger)
1514 {
1515 Tcl_DStringAppend(&proc_internal_body,
1516 "array set NEW $__PLTcl_Tup_NEW\n", -1);
1517 Tcl_DStringAppend(&proc_internal_body,
1518 "array set OLD $__PLTcl_Tup_OLD\n", -1);
1519
1520 Tcl_DStringAppend(&proc_internal_body,
1521 "set i 0\n"
1522 "set v 0\n"
1523 "foreach v $args {\n"
1524 " incr i\n"
1525 " set $i $v\n"
1526 "}\n"
1527 "unset i v\n\n", -1);
1528 }
1529 else if (is_event_trigger)
1530 {
1531 /* no argument support for event triggers */
1532 }
1533 else
1534 {
1535 for (i = 0; i < prodesc->nargs; i++)
1536 {
1537 if (prodesc->arg_is_rowtype[i])
1538 {
1539 snprintf(buf, sizeof(buf),
1540 "array set %d $__PLTcl_Tup_%d\n",
1541 i + 1, i + 1);
1542 Tcl_DStringAppend(&proc_internal_body, buf, -1);
1543 }
1544 }
1545 }
1546
1547 /************************************************************
1548 * Add user's function definition to proc body
1549 ************************************************************/
1550 prosrcdatum = SysCacheGetAttr(PROCOID, procTup,
1551 Anum_pg_proc_prosrc, &isnull);
1552 if (isnull)
1553 elog(ERROR, "null prosrc");
1554 proc_source = TextDatumGetCString(prosrcdatum);
1555 UTF_BEGIN;
1556 Tcl_DStringAppend(&proc_internal_body, UTF_E2U(proc_source), -1);
1557 UTF_END;
1558 pfree(proc_source);
1559 Tcl_DStringAppendElement(&proc_internal_def,
1560 Tcl_DStringValue(&proc_internal_body));
1561 Tcl_DStringFree(&proc_internal_body);
1562
1563 /************************************************************
1564 * Create the procedure in the interpreter
1565 ************************************************************/
1566 tcl_rc = Tcl_EvalEx(interp,
1567 Tcl_DStringValue(&proc_internal_def),
1568 Tcl_DStringLength(&proc_internal_def),
1569 TCL_EVAL_GLOBAL);
1570 Tcl_DStringFree(&proc_internal_def);
1571 if (tcl_rc != TCL_OK)
1572 {
1573 free(prodesc->user_proname);
1574 free(prodesc->internal_proname);
1575 free(prodesc);
1576 ereport(ERROR,
1577 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
1578 errmsg("could not create internal procedure \"%s\": %s",
1579 internal_proname,
1580 utf_u2e(Tcl_GetStringResult(interp)))));
1581 }
1582
1583 /************************************************************
1584 * Add the proc description block to the hashtable. Note we do not
1585 * attempt to free any previously existing prodesc block. This is
1586 * annoying, but necessary since there could be active calls using
1587 * the old prodesc.
1588 ************************************************************/
1589 proc_ptr->proc_ptr = prodesc;
1590 }
1591
1592 ReleaseSysCache(procTup);
1593
1594 return prodesc;
1595 }
1596
1597
1598 /**********************************************************************
1599 * pltcl_elog() - elog() support for PLTcl
1600 **********************************************************************/
1601 static int
pltcl_elog(ClientData cdata,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1602 pltcl_elog(ClientData cdata, Tcl_Interp *interp,
1603 int objc, Tcl_Obj *const objv[])
1604 {
1605 volatile int level;
1606 MemoryContext oldcontext;
1607 int priIndex;
1608
1609 static const char *logpriorities[] = {
1610 "DEBUG", "LOG", "INFO", "NOTICE",
1611 "WARNING", "ERROR", "FATAL", (const char *) NULL
1612 };
1613
1614 static const int loglevels[] = {
1615 DEBUG2, LOG, INFO, NOTICE,
1616 WARNING, ERROR, FATAL
1617 };
1618
1619 if (objc != 3)
1620 {
1621 Tcl_WrongNumArgs(interp, 1, objv, "level msg");
1622 return TCL_ERROR;
1623 }
1624
1625 if (Tcl_GetIndexFromObj(interp, objv[1], logpriorities, "priority",
1626 TCL_EXACT, &priIndex) != TCL_OK)
1627 return TCL_ERROR;
1628
1629 level = loglevels[priIndex];
1630
1631 if (level == ERROR)
1632 {
1633 /*
1634 * We just pass the error back to Tcl. If it's not caught, it'll
1635 * eventually get converted to a PG error when we reach the call
1636 * handler.
1637 */
1638 Tcl_SetObjResult(interp, objv[2]);
1639 return TCL_ERROR;
1640 }
1641
1642 /*
1643 * For non-error messages, just pass 'em to ereport(). We do not expect
1644 * that this will fail, but just on the off chance it does, report the
1645 * error back to Tcl. Note we are assuming that ereport() can't have any
1646 * internal failures that are so bad as to require a transaction abort.
1647 *
1648 * This path is also used for FATAL errors, which aren't going to come
1649 * back to us at all.
1650 */
1651 oldcontext = CurrentMemoryContext;
1652 PG_TRY();
1653 {
1654 UTF_BEGIN;
1655 ereport(level,
1656 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
1657 errmsg("%s", UTF_U2E(Tcl_GetString(objv[2])))));
1658 UTF_END;
1659 }
1660 PG_CATCH();
1661 {
1662 ErrorData *edata;
1663
1664 /* Must reset elog.c's state */
1665 MemoryContextSwitchTo(oldcontext);
1666 edata = CopyErrorData();
1667 FlushErrorState();
1668
1669 /* Pass the error data to Tcl */
1670 pltcl_construct_errorCode(interp, edata);
1671 UTF_BEGIN;
1672 Tcl_SetObjResult(interp, Tcl_NewStringObj(UTF_E2U(edata->message), -1));
1673 UTF_END;
1674 FreeErrorData(edata);
1675
1676 return TCL_ERROR;
1677 }
1678 PG_END_TRY();
1679
1680 return TCL_OK;
1681 }
1682
1683
1684 /**********************************************************************
1685 * pltcl_construct_errorCode() - construct a Tcl errorCode
1686 * list with detailed information from the PostgreSQL server
1687 **********************************************************************/
1688 static void
pltcl_construct_errorCode(Tcl_Interp * interp,ErrorData * edata)1689 pltcl_construct_errorCode(Tcl_Interp *interp, ErrorData *edata)
1690 {
1691 Tcl_Obj *obj = Tcl_NewObj();
1692
1693 Tcl_ListObjAppendElement(interp, obj,
1694 Tcl_NewStringObj("POSTGRES", -1));
1695 Tcl_ListObjAppendElement(interp, obj,
1696 Tcl_NewStringObj(PG_VERSION, -1));
1697 Tcl_ListObjAppendElement(interp, obj,
1698 Tcl_NewStringObj("SQLSTATE", -1));
1699 Tcl_ListObjAppendElement(interp, obj,
1700 Tcl_NewStringObj(unpack_sql_state(edata->sqlerrcode), -1));
1701 Tcl_ListObjAppendElement(interp, obj,
1702 Tcl_NewStringObj("condition", -1));
1703 Tcl_ListObjAppendElement(interp, obj,
1704 Tcl_NewStringObj(pltcl_get_condition_name(edata->sqlerrcode), -1));
1705 Tcl_ListObjAppendElement(interp, obj,
1706 Tcl_NewStringObj("message", -1));
1707 UTF_BEGIN;
1708 Tcl_ListObjAppendElement(interp, obj,
1709 Tcl_NewStringObj(UTF_E2U(edata->message), -1));
1710 UTF_END;
1711 if (edata->detail)
1712 {
1713 Tcl_ListObjAppendElement(interp, obj,
1714 Tcl_NewStringObj("detail", -1));
1715 UTF_BEGIN;
1716 Tcl_ListObjAppendElement(interp, obj,
1717 Tcl_NewStringObj(UTF_E2U(edata->detail), -1));
1718 UTF_END;
1719 }
1720 if (edata->hint)
1721 {
1722 Tcl_ListObjAppendElement(interp, obj,
1723 Tcl_NewStringObj("hint", -1));
1724 UTF_BEGIN;
1725 Tcl_ListObjAppendElement(interp, obj,
1726 Tcl_NewStringObj(UTF_E2U(edata->hint), -1));
1727 UTF_END;
1728 }
1729 if (edata->context)
1730 {
1731 Tcl_ListObjAppendElement(interp, obj,
1732 Tcl_NewStringObj("context", -1));
1733 UTF_BEGIN;
1734 Tcl_ListObjAppendElement(interp, obj,
1735 Tcl_NewStringObj(UTF_E2U(edata->context), -1));
1736 UTF_END;
1737 }
1738 if (edata->schema_name)
1739 {
1740 Tcl_ListObjAppendElement(interp, obj,
1741 Tcl_NewStringObj("schema", -1));
1742 UTF_BEGIN;
1743 Tcl_ListObjAppendElement(interp, obj,
1744 Tcl_NewStringObj(UTF_E2U(edata->schema_name), -1));
1745 UTF_END;
1746 }
1747 if (edata->table_name)
1748 {
1749 Tcl_ListObjAppendElement(interp, obj,
1750 Tcl_NewStringObj("table", -1));
1751 UTF_BEGIN;
1752 Tcl_ListObjAppendElement(interp, obj,
1753 Tcl_NewStringObj(UTF_E2U(edata->table_name), -1));
1754 UTF_END;
1755 }
1756 if (edata->column_name)
1757 {
1758 Tcl_ListObjAppendElement(interp, obj,
1759 Tcl_NewStringObj("column", -1));
1760 UTF_BEGIN;
1761 Tcl_ListObjAppendElement(interp, obj,
1762 Tcl_NewStringObj(UTF_E2U(edata->column_name), -1));
1763 UTF_END;
1764 }
1765 if (edata->datatype_name)
1766 {
1767 Tcl_ListObjAppendElement(interp, obj,
1768 Tcl_NewStringObj("datatype", -1));
1769 UTF_BEGIN;
1770 Tcl_ListObjAppendElement(interp, obj,
1771 Tcl_NewStringObj(UTF_E2U(edata->datatype_name), -1));
1772 UTF_END;
1773 }
1774 if (edata->constraint_name)
1775 {
1776 Tcl_ListObjAppendElement(interp, obj,
1777 Tcl_NewStringObj("constraint", -1));
1778 UTF_BEGIN;
1779 Tcl_ListObjAppendElement(interp, obj,
1780 Tcl_NewStringObj(UTF_E2U(edata->constraint_name), -1));
1781 UTF_END;
1782 }
1783 /* cursorpos is never interesting here; report internal query/pos */
1784 if (edata->internalquery)
1785 {
1786 Tcl_ListObjAppendElement(interp, obj,
1787 Tcl_NewStringObj("statement", -1));
1788 UTF_BEGIN;
1789 Tcl_ListObjAppendElement(interp, obj,
1790 Tcl_NewStringObj(UTF_E2U(edata->internalquery), -1));
1791 UTF_END;
1792 }
1793 if (edata->internalpos > 0)
1794 {
1795 Tcl_ListObjAppendElement(interp, obj,
1796 Tcl_NewStringObj("cursor_position", -1));
1797 Tcl_ListObjAppendElement(interp, obj,
1798 Tcl_NewIntObj(edata->internalpos));
1799 }
1800 if (edata->filename)
1801 {
1802 Tcl_ListObjAppendElement(interp, obj,
1803 Tcl_NewStringObj("filename", -1));
1804 UTF_BEGIN;
1805 Tcl_ListObjAppendElement(interp, obj,
1806 Tcl_NewStringObj(UTF_E2U(edata->filename), -1));
1807 UTF_END;
1808 }
1809 if (edata->lineno > 0)
1810 {
1811 Tcl_ListObjAppendElement(interp, obj,
1812 Tcl_NewStringObj("lineno", -1));
1813 Tcl_ListObjAppendElement(interp, obj,
1814 Tcl_NewIntObj(edata->lineno));
1815 }
1816 if (edata->funcname)
1817 {
1818 Tcl_ListObjAppendElement(interp, obj,
1819 Tcl_NewStringObj("funcname", -1));
1820 UTF_BEGIN;
1821 Tcl_ListObjAppendElement(interp, obj,
1822 Tcl_NewStringObj(UTF_E2U(edata->funcname), -1));
1823 UTF_END;
1824 }
1825
1826 Tcl_SetObjErrorCode(interp, obj);
1827 }
1828
1829
1830 /**********************************************************************
1831 * pltcl_get_condition_name() - find name for SQLSTATE
1832 **********************************************************************/
1833 static const char *
pltcl_get_condition_name(int sqlstate)1834 pltcl_get_condition_name(int sqlstate)
1835 {
1836 int i;
1837
1838 for (i = 0; exception_name_map[i].label != NULL; i++)
1839 {
1840 if (exception_name_map[i].sqlerrstate == sqlstate)
1841 return exception_name_map[i].label;
1842 }
1843 return "unrecognized_sqlstate";
1844 }
1845
1846
1847 /**********************************************************************
1848 * pltcl_quote() - quote literal strings that are to
1849 * be used in SPI_execute query strings
1850 **********************************************************************/
1851 static int
pltcl_quote(ClientData cdata,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1852 pltcl_quote(ClientData cdata, Tcl_Interp *interp,
1853 int objc, Tcl_Obj *const objv[])
1854 {
1855 char *tmp;
1856 const char *cp1;
1857 char *cp2;
1858 int length;
1859
1860 /************************************************************
1861 * Check call syntax
1862 ************************************************************/
1863 if (objc != 2)
1864 {
1865 Tcl_WrongNumArgs(interp, 1, objv, "string");
1866 return TCL_ERROR;
1867 }
1868
1869 /************************************************************
1870 * Allocate space for the maximum the string can
1871 * grow to and initialize pointers
1872 ************************************************************/
1873 cp1 = Tcl_GetStringFromObj(objv[1], &length);
1874 tmp = palloc(length * 2 + 1);
1875 cp2 = tmp;
1876
1877 /************************************************************
1878 * Walk through string and double every quote and backslash
1879 ************************************************************/
1880 while (*cp1)
1881 {
1882 if (*cp1 == '\'')
1883 *cp2++ = '\'';
1884 else
1885 {
1886 if (*cp1 == '\\')
1887 *cp2++ = '\\';
1888 }
1889 *cp2++ = *cp1++;
1890 }
1891
1892 /************************************************************
1893 * Terminate the string and set it as result
1894 ************************************************************/
1895 *cp2 = '\0';
1896 Tcl_SetObjResult(interp, Tcl_NewStringObj(tmp, -1));
1897 pfree(tmp);
1898 return TCL_OK;
1899 }
1900
1901
1902 /**********************************************************************
1903 * pltcl_argisnull() - determine if a specific argument is NULL
1904 **********************************************************************/
1905 static int
pltcl_argisnull(ClientData cdata,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1906 pltcl_argisnull(ClientData cdata, Tcl_Interp *interp,
1907 int objc, Tcl_Obj *const objv[])
1908 {
1909 int argno;
1910 FunctionCallInfo fcinfo = pltcl_current_fcinfo;
1911
1912 /************************************************************
1913 * Check call syntax
1914 ************************************************************/
1915 if (objc != 2)
1916 {
1917 Tcl_WrongNumArgs(interp, 1, objv, "argno");
1918 return TCL_ERROR;
1919 }
1920
1921 /************************************************************
1922 * Check that we're called as a normal function
1923 ************************************************************/
1924 if (fcinfo == NULL)
1925 {
1926 Tcl_SetObjResult(interp,
1927 Tcl_NewStringObj("argisnull cannot be used in triggers", -1));
1928 return TCL_ERROR;
1929 }
1930
1931 /************************************************************
1932 * Get the argument number
1933 ************************************************************/
1934 if (Tcl_GetIntFromObj(interp, objv[1], &argno) != TCL_OK)
1935 return TCL_ERROR;
1936
1937 /************************************************************
1938 * Check that the argno is valid
1939 ************************************************************/
1940 argno--;
1941 if (argno < 0 || argno >= fcinfo->nargs)
1942 {
1943 Tcl_SetObjResult(interp,
1944 Tcl_NewStringObj("argno out of range", -1));
1945 return TCL_ERROR;
1946 }
1947
1948 /************************************************************
1949 * Get the requested NULL state
1950 ************************************************************/
1951 Tcl_SetObjResult(interp, Tcl_NewBooleanObj(PG_ARGISNULL(argno)));
1952 return TCL_OK;
1953 }
1954
1955
1956 /**********************************************************************
1957 * pltcl_returnnull() - Cause a NULL return from the current function
1958 **********************************************************************/
1959 static int
pltcl_returnnull(ClientData cdata,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1960 pltcl_returnnull(ClientData cdata, Tcl_Interp *interp,
1961 int objc, Tcl_Obj *const objv[])
1962 {
1963 FunctionCallInfo fcinfo = pltcl_current_fcinfo;
1964
1965 /************************************************************
1966 * Check call syntax
1967 ************************************************************/
1968 if (objc != 1)
1969 {
1970 Tcl_WrongNumArgs(interp, 1, objv, "");
1971 return TCL_ERROR;
1972 }
1973
1974 /************************************************************
1975 * Check that we're called as a normal function
1976 ************************************************************/
1977 if (fcinfo == NULL)
1978 {
1979 Tcl_SetObjResult(interp,
1980 Tcl_NewStringObj("return_null cannot be used in triggers", -1));
1981 return TCL_ERROR;
1982 }
1983
1984 /************************************************************
1985 * Set the NULL return flag and cause Tcl to return from the
1986 * procedure.
1987 ************************************************************/
1988 fcinfo->isnull = true;
1989
1990 return TCL_RETURN;
1991 }
1992
1993
1994 /*----------
1995 * Support for running SPI operations inside subtransactions
1996 *
1997 * Intended usage pattern is:
1998 *
1999 * MemoryContext oldcontext = CurrentMemoryContext;
2000 * ResourceOwner oldowner = CurrentResourceOwner;
2001 *
2002 * ...
2003 * pltcl_subtrans_begin(oldcontext, oldowner);
2004 * PG_TRY();
2005 * {
2006 * do something risky;
2007 * pltcl_subtrans_commit(oldcontext, oldowner);
2008 * }
2009 * PG_CATCH();
2010 * {
2011 * pltcl_subtrans_abort(interp, oldcontext, oldowner);
2012 * return TCL_ERROR;
2013 * }
2014 * PG_END_TRY();
2015 * return TCL_OK;
2016 *----------
2017 */
2018 static void
pltcl_subtrans_begin(MemoryContext oldcontext,ResourceOwner oldowner)2019 pltcl_subtrans_begin(MemoryContext oldcontext, ResourceOwner oldowner)
2020 {
2021 BeginInternalSubTransaction(NULL);
2022
2023 /* Want to run inside function's memory context */
2024 MemoryContextSwitchTo(oldcontext);
2025 }
2026
2027 static void
pltcl_subtrans_commit(MemoryContext oldcontext,ResourceOwner oldowner)2028 pltcl_subtrans_commit(MemoryContext oldcontext, ResourceOwner oldowner)
2029 {
2030 /* Commit the inner transaction, return to outer xact context */
2031 ReleaseCurrentSubTransaction();
2032 MemoryContextSwitchTo(oldcontext);
2033 CurrentResourceOwner = oldowner;
2034
2035 /*
2036 * AtEOSubXact_SPI() should not have popped any SPI context, but just in
2037 * case it did, make sure we remain connected.
2038 */
2039 SPI_restore_connection();
2040 }
2041
2042 static void
pltcl_subtrans_abort(Tcl_Interp * interp,MemoryContext oldcontext,ResourceOwner oldowner)2043 pltcl_subtrans_abort(Tcl_Interp *interp,
2044 MemoryContext oldcontext, ResourceOwner oldowner)
2045 {
2046 ErrorData *edata;
2047
2048 /* Save error info */
2049 MemoryContextSwitchTo(oldcontext);
2050 edata = CopyErrorData();
2051 FlushErrorState();
2052
2053 /* Abort the inner transaction */
2054 RollbackAndReleaseCurrentSubTransaction();
2055 MemoryContextSwitchTo(oldcontext);
2056 CurrentResourceOwner = oldowner;
2057
2058 /*
2059 * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
2060 * have left us in a disconnected state. We need this hack to return to
2061 * connected state.
2062 */
2063 SPI_restore_connection();
2064
2065 /* Pass the error data to Tcl */
2066 pltcl_construct_errorCode(interp, edata);
2067 UTF_BEGIN;
2068 Tcl_SetObjResult(interp, Tcl_NewStringObj(UTF_E2U(edata->message), -1));
2069 UTF_END;
2070 FreeErrorData(edata);
2071 }
2072
2073
2074 /**********************************************************************
2075 * pltcl_SPI_execute() - The builtin SPI_execute command
2076 * for the Tcl interpreter
2077 **********************************************************************/
2078 static int
pltcl_SPI_execute(ClientData cdata,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])2079 pltcl_SPI_execute(ClientData cdata, Tcl_Interp *interp,
2080 int objc, Tcl_Obj *const objv[])
2081 {
2082 int my_rc;
2083 int spi_rc;
2084 int query_idx;
2085 int i;
2086 int optIndex;
2087 int count = 0;
2088 const char *volatile arrayname = NULL;
2089 Tcl_Obj *volatile loop_body = NULL;
2090 MemoryContext oldcontext = CurrentMemoryContext;
2091 ResourceOwner oldowner = CurrentResourceOwner;
2092
2093 enum options
2094 {
2095 OPT_ARRAY, OPT_COUNT
2096 };
2097
2098 static const char *options[] = {
2099 "-array", "-count", (const char *) NULL
2100 };
2101
2102 /************************************************************
2103 * Check the call syntax and get the options
2104 ************************************************************/
2105 if (objc < 2)
2106 {
2107 Tcl_WrongNumArgs(interp, 1, objv,
2108 "?-count n? ?-array name? query ?loop body?");
2109 return TCL_ERROR;
2110 }
2111
2112 i = 1;
2113 while (i < objc)
2114 {
2115 if (Tcl_GetIndexFromObj(interp, objv[i], options, "option",
2116 TCL_EXACT, &optIndex) != TCL_OK)
2117 break;
2118
2119 if (++i >= objc)
2120 {
2121 Tcl_SetObjResult(interp,
2122 Tcl_NewStringObj("missing argument to -count or -array", -1));
2123 return TCL_ERROR;
2124 }
2125
2126 switch ((enum options) optIndex)
2127 {
2128 case OPT_ARRAY:
2129 arrayname = Tcl_GetString(objv[i++]);
2130 break;
2131
2132 case OPT_COUNT:
2133 if (Tcl_GetIntFromObj(interp, objv[i++], &count) != TCL_OK)
2134 return TCL_ERROR;
2135 break;
2136 }
2137 }
2138
2139 query_idx = i;
2140 if (query_idx >= objc || query_idx + 2 < objc)
2141 {
2142 Tcl_WrongNumArgs(interp, query_idx - 1, objv, "query ?loop body?");
2143 return TCL_ERROR;
2144 }
2145
2146 if (query_idx + 1 < objc)
2147 loop_body = objv[query_idx + 1];
2148
2149 /************************************************************
2150 * Execute the query inside a sub-transaction, so we can cope with
2151 * errors sanely
2152 ************************************************************/
2153
2154 pltcl_subtrans_begin(oldcontext, oldowner);
2155
2156 PG_TRY();
2157 {
2158 UTF_BEGIN;
2159 spi_rc = SPI_execute(UTF_U2E(Tcl_GetString(objv[query_idx])),
2160 pltcl_current_prodesc->fn_readonly, count);
2161 UTF_END;
2162
2163 my_rc = pltcl_process_SPI_result(interp,
2164 arrayname,
2165 loop_body,
2166 spi_rc,
2167 SPI_tuptable,
2168 SPI_processed);
2169
2170 pltcl_subtrans_commit(oldcontext, oldowner);
2171 }
2172 PG_CATCH();
2173 {
2174 pltcl_subtrans_abort(interp, oldcontext, oldowner);
2175 return TCL_ERROR;
2176 }
2177 PG_END_TRY();
2178
2179 return my_rc;
2180 }
2181
2182 /*
2183 * Process the result from SPI_execute or SPI_execute_plan
2184 *
2185 * Shared code between pltcl_SPI_execute and pltcl_SPI_execute_plan
2186 */
2187 static int
pltcl_process_SPI_result(Tcl_Interp * interp,const char * arrayname,Tcl_Obj * loop_body,int spi_rc,SPITupleTable * tuptable,uint64 ntuples)2188 pltcl_process_SPI_result(Tcl_Interp *interp,
2189 const char *arrayname,
2190 Tcl_Obj *loop_body,
2191 int spi_rc,
2192 SPITupleTable *tuptable,
2193 uint64 ntuples)
2194 {
2195 int my_rc = TCL_OK;
2196 int loop_rc;
2197 HeapTuple *tuples;
2198 TupleDesc tupdesc;
2199
2200 switch (spi_rc)
2201 {
2202 case SPI_OK_SELINTO:
2203 case SPI_OK_INSERT:
2204 case SPI_OK_DELETE:
2205 case SPI_OK_UPDATE:
2206 Tcl_SetObjResult(interp, Tcl_NewWideIntObj(ntuples));
2207 break;
2208
2209 case SPI_OK_UTILITY:
2210 case SPI_OK_REWRITTEN:
2211 if (tuptable == NULL)
2212 {
2213 Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
2214 break;
2215 }
2216 /* FALL THRU for utility returning tuples */
2217
2218 case SPI_OK_SELECT:
2219 case SPI_OK_INSERT_RETURNING:
2220 case SPI_OK_DELETE_RETURNING:
2221 case SPI_OK_UPDATE_RETURNING:
2222
2223 /*
2224 * Process the tuples we got
2225 */
2226 tuples = tuptable->vals;
2227 tupdesc = tuptable->tupdesc;
2228
2229 if (loop_body == NULL)
2230 {
2231 /*
2232 * If there is no loop body given, just set the variables from
2233 * the first tuple (if any)
2234 */
2235 if (ntuples > 0)
2236 pltcl_set_tuple_values(interp, arrayname, 0,
2237 tuples[0], tupdesc);
2238 }
2239 else
2240 {
2241 /*
2242 * There is a loop body - process all tuples and evaluate the
2243 * body on each
2244 */
2245 uint64 i;
2246
2247 for (i = 0; i < ntuples; i++)
2248 {
2249 pltcl_set_tuple_values(interp, arrayname, i,
2250 tuples[i], tupdesc);
2251
2252 loop_rc = Tcl_EvalObjEx(interp, loop_body, 0);
2253
2254 if (loop_rc == TCL_OK)
2255 continue;
2256 if (loop_rc == TCL_CONTINUE)
2257 continue;
2258 if (loop_rc == TCL_RETURN)
2259 {
2260 my_rc = TCL_RETURN;
2261 break;
2262 }
2263 if (loop_rc == TCL_BREAK)
2264 break;
2265 my_rc = TCL_ERROR;
2266 break;
2267 }
2268 }
2269
2270 if (my_rc == TCL_OK)
2271 {
2272 Tcl_SetObjResult(interp, Tcl_NewWideIntObj(ntuples));
2273 }
2274 break;
2275
2276 default:
2277 Tcl_AppendResult(interp, "pltcl: SPI_execute failed: ",
2278 SPI_result_code_string(spi_rc), NULL);
2279 my_rc = TCL_ERROR;
2280 break;
2281 }
2282
2283 SPI_freetuptable(tuptable);
2284
2285 return my_rc;
2286 }
2287
2288
2289 /**********************************************************************
2290 * pltcl_SPI_prepare() - Builtin support for prepared plans
2291 * The Tcl command SPI_prepare
2292 * always saves the plan using
2293 * SPI_keepplan and returns a key for
2294 * access. There is no chance to prepare
2295 * and not save the plan currently.
2296 **********************************************************************/
2297 static int
pltcl_SPI_prepare(ClientData cdata,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])2298 pltcl_SPI_prepare(ClientData cdata, Tcl_Interp *interp,
2299 int objc, Tcl_Obj *const objv[])
2300 {
2301 volatile MemoryContext plan_cxt = NULL;
2302 int nargs;
2303 Tcl_Obj **argsObj;
2304 pltcl_query_desc *qdesc;
2305 int i;
2306 Tcl_HashEntry *hashent;
2307 int hashnew;
2308 Tcl_HashTable *query_hash;
2309 MemoryContext oldcontext = CurrentMemoryContext;
2310 ResourceOwner oldowner = CurrentResourceOwner;
2311
2312 /************************************************************
2313 * Check the call syntax
2314 ************************************************************/
2315 if (objc != 3)
2316 {
2317 Tcl_WrongNumArgs(interp, 1, objv, "query argtypes");
2318 return TCL_ERROR;
2319 }
2320
2321 /************************************************************
2322 * Split the argument type list
2323 ************************************************************/
2324 if (Tcl_ListObjGetElements(interp, objv[2], &nargs, &argsObj) != TCL_OK)
2325 return TCL_ERROR;
2326
2327 /************************************************************
2328 * Allocate the new querydesc structure
2329 *
2330 * struct qdesc and subsidiary data all live in plan_cxt. Note that if the
2331 * function is recompiled for whatever reason, permanent memory leaks
2332 * occur. FIXME someday.
2333 ************************************************************/
2334 plan_cxt = AllocSetContextCreate(TopMemoryContext,
2335 "PL/TCL spi_prepare query",
2336 ALLOCSET_SMALL_SIZES);
2337 MemoryContextSwitchTo(plan_cxt);
2338 qdesc = (pltcl_query_desc *) palloc0(sizeof(pltcl_query_desc));
2339 snprintf(qdesc->qname, sizeof(qdesc->qname), "%p", qdesc);
2340 qdesc->nargs = nargs;
2341 qdesc->argtypes = (Oid *) palloc(nargs * sizeof(Oid));
2342 qdesc->arginfuncs = (FmgrInfo *) palloc(nargs * sizeof(FmgrInfo));
2343 qdesc->argtypioparams = (Oid *) palloc(nargs * sizeof(Oid));
2344 MemoryContextSwitchTo(oldcontext);
2345
2346 /************************************************************
2347 * Execute the prepare inside a sub-transaction, so we can cope with
2348 * errors sanely
2349 ************************************************************/
2350
2351 pltcl_subtrans_begin(oldcontext, oldowner);
2352
2353 PG_TRY();
2354 {
2355 /************************************************************
2356 * Resolve argument type names and then look them up by oid
2357 * in the system cache, and remember the required information
2358 * for input conversion.
2359 ************************************************************/
2360 for (i = 0; i < nargs; i++)
2361 {
2362 Oid typId,
2363 typInput,
2364 typIOParam;
2365 int32 typmod;
2366
2367 parseTypeString(Tcl_GetString(argsObj[i]), &typId, &typmod, false);
2368
2369 getTypeInputInfo(typId, &typInput, &typIOParam);
2370
2371 qdesc->argtypes[i] = typId;
2372 fmgr_info_cxt(typInput, &(qdesc->arginfuncs[i]), plan_cxt);
2373 qdesc->argtypioparams[i] = typIOParam;
2374 }
2375
2376 /************************************************************
2377 * Prepare the plan and check for errors
2378 ************************************************************/
2379 UTF_BEGIN;
2380 qdesc->plan = SPI_prepare(UTF_U2E(Tcl_GetString(objv[1])),
2381 nargs, qdesc->argtypes);
2382 UTF_END;
2383
2384 if (qdesc->plan == NULL)
2385 elog(ERROR, "SPI_prepare() failed");
2386
2387 /************************************************************
2388 * Save the plan into permanent memory (right now it's in the
2389 * SPI procCxt, which will go away at function end).
2390 ************************************************************/
2391 if (SPI_keepplan(qdesc->plan))
2392 elog(ERROR, "SPI_keepplan() failed");
2393
2394 pltcl_subtrans_commit(oldcontext, oldowner);
2395 }
2396 PG_CATCH();
2397 {
2398 pltcl_subtrans_abort(interp, oldcontext, oldowner);
2399
2400 MemoryContextDelete(plan_cxt);
2401
2402 return TCL_ERROR;
2403 }
2404 PG_END_TRY();
2405
2406 /************************************************************
2407 * Insert a hashtable entry for the plan and return
2408 * the key to the caller
2409 ************************************************************/
2410 query_hash = &pltcl_current_prodesc->interp_desc->query_hash;
2411
2412 hashent = Tcl_CreateHashEntry(query_hash, qdesc->qname, &hashnew);
2413 Tcl_SetHashValue(hashent, (ClientData) qdesc);
2414
2415 /* qname is ASCII, so no need for encoding conversion */
2416 Tcl_SetObjResult(interp, Tcl_NewStringObj(qdesc->qname, -1));
2417 return TCL_OK;
2418 }
2419
2420
2421 /**********************************************************************
2422 * pltcl_SPI_execute_plan() - Execute a prepared plan
2423 **********************************************************************/
2424 static int
pltcl_SPI_execute_plan(ClientData cdata,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])2425 pltcl_SPI_execute_plan(ClientData cdata, Tcl_Interp *interp,
2426 int objc, Tcl_Obj *const objv[])
2427 {
2428 int my_rc;
2429 int spi_rc;
2430 int i;
2431 int j;
2432 int optIndex;
2433 Tcl_HashEntry *hashent;
2434 pltcl_query_desc *qdesc;
2435 const char *nulls = NULL;
2436 const char *arrayname = NULL;
2437 Tcl_Obj *loop_body = NULL;
2438 int count = 0;
2439 int callObjc;
2440 Tcl_Obj **callObjv = NULL;
2441 Datum *argvalues;
2442 MemoryContext oldcontext = CurrentMemoryContext;
2443 ResourceOwner oldowner = CurrentResourceOwner;
2444 Tcl_HashTable *query_hash;
2445
2446 enum options
2447 {
2448 OPT_ARRAY, OPT_COUNT, OPT_NULLS
2449 };
2450
2451 static const char *options[] = {
2452 "-array", "-count", "-nulls", (const char *) NULL
2453 };
2454
2455 /************************************************************
2456 * Get the options and check syntax
2457 ************************************************************/
2458 i = 1;
2459 while (i < objc)
2460 {
2461 if (Tcl_GetIndexFromObj(interp, objv[i], options, "option",
2462 TCL_EXACT, &optIndex) != TCL_OK)
2463 break;
2464
2465 if (++i >= objc)
2466 {
2467 Tcl_SetObjResult(interp,
2468 Tcl_NewStringObj("missing argument to -array, -count or -nulls", -1));
2469 return TCL_ERROR;
2470 }
2471
2472 switch ((enum options) optIndex)
2473 {
2474 case OPT_ARRAY:
2475 arrayname = Tcl_GetString(objv[i++]);
2476 break;
2477
2478 case OPT_COUNT:
2479 if (Tcl_GetIntFromObj(interp, objv[i++], &count) != TCL_OK)
2480 return TCL_ERROR;
2481 break;
2482
2483 case OPT_NULLS:
2484 nulls = Tcl_GetString(objv[i++]);
2485 break;
2486 }
2487 }
2488
2489 /************************************************************
2490 * Get the prepared plan descriptor by its key
2491 ************************************************************/
2492 if (i >= objc)
2493 {
2494 Tcl_SetObjResult(interp,
2495 Tcl_NewStringObj("missing argument to -count or -array", -1));
2496 return TCL_ERROR;
2497 }
2498
2499 query_hash = &pltcl_current_prodesc->interp_desc->query_hash;
2500
2501 hashent = Tcl_FindHashEntry(query_hash, Tcl_GetString(objv[i]));
2502 if (hashent == NULL)
2503 {
2504 Tcl_AppendResult(interp, "invalid queryid '", Tcl_GetString(objv[i]), "'", NULL);
2505 return TCL_ERROR;
2506 }
2507 qdesc = (pltcl_query_desc *) Tcl_GetHashValue(hashent);
2508 i++;
2509
2510 /************************************************************
2511 * If a nulls string is given, check for correct length
2512 ************************************************************/
2513 if (nulls != NULL)
2514 {
2515 if (strlen(nulls) != qdesc->nargs)
2516 {
2517 Tcl_SetObjResult(interp,
2518 Tcl_NewStringObj(
2519 "length of nulls string doesn't match number of arguments",
2520 -1));
2521 return TCL_ERROR;
2522 }
2523 }
2524
2525 /************************************************************
2526 * If there was an argtype list on preparation, we need
2527 * an argument value list now
2528 ************************************************************/
2529 if (qdesc->nargs > 0)
2530 {
2531 if (i >= objc)
2532 {
2533 Tcl_SetObjResult(interp,
2534 Tcl_NewStringObj(
2535 "argument list length doesn't match number of arguments for query"
2536 ,-1));
2537 return TCL_ERROR;
2538 }
2539
2540 /************************************************************
2541 * Split the argument values
2542 ************************************************************/
2543 if (Tcl_ListObjGetElements(interp, objv[i++], &callObjc, &callObjv) != TCL_OK)
2544 return TCL_ERROR;
2545
2546 /************************************************************
2547 * Check that the number of arguments matches
2548 ************************************************************/
2549 if (callObjc != qdesc->nargs)
2550 {
2551 Tcl_SetObjResult(interp,
2552 Tcl_NewStringObj(
2553 "argument list length doesn't match number of arguments for query"
2554 ,-1));
2555 return TCL_ERROR;
2556 }
2557 }
2558 else
2559 callObjc = 0;
2560
2561 /************************************************************
2562 * Get loop body if present
2563 ************************************************************/
2564 if (i < objc)
2565 loop_body = objv[i++];
2566
2567 if (i != objc)
2568 {
2569 Tcl_WrongNumArgs(interp, 1, objv,
2570 "?-count n? ?-array name? ?-nulls string? "
2571 "query ?args? ?loop body?");
2572 return TCL_ERROR;
2573 }
2574
2575 /************************************************************
2576 * Execute the plan inside a sub-transaction, so we can cope with
2577 * errors sanely
2578 ************************************************************/
2579
2580 pltcl_subtrans_begin(oldcontext, oldowner);
2581
2582 PG_TRY();
2583 {
2584 /************************************************************
2585 * Setup the value array for SPI_execute_plan() using
2586 * the type specific input functions
2587 ************************************************************/
2588 argvalues = (Datum *) palloc(callObjc * sizeof(Datum));
2589
2590 for (j = 0; j < callObjc; j++)
2591 {
2592 if (nulls && nulls[j] == 'n')
2593 {
2594 argvalues[j] = InputFunctionCall(&qdesc->arginfuncs[j],
2595 NULL,
2596 qdesc->argtypioparams[j],
2597 -1);
2598 }
2599 else
2600 {
2601 UTF_BEGIN;
2602 argvalues[j] = InputFunctionCall(&qdesc->arginfuncs[j],
2603 UTF_U2E(Tcl_GetString(callObjv[j])),
2604 qdesc->argtypioparams[j],
2605 -1);
2606 UTF_END;
2607 }
2608 }
2609
2610 /************************************************************
2611 * Execute the plan
2612 ************************************************************/
2613 spi_rc = SPI_execute_plan(qdesc->plan, argvalues, nulls,
2614 pltcl_current_prodesc->fn_readonly, count);
2615
2616 my_rc = pltcl_process_SPI_result(interp,
2617 arrayname,
2618 loop_body,
2619 spi_rc,
2620 SPI_tuptable,
2621 SPI_processed);
2622
2623 pltcl_subtrans_commit(oldcontext, oldowner);
2624 }
2625 PG_CATCH();
2626 {
2627 pltcl_subtrans_abort(interp, oldcontext, oldowner);
2628 return TCL_ERROR;
2629 }
2630 PG_END_TRY();
2631
2632 return my_rc;
2633 }
2634
2635
2636 /**********************************************************************
2637 * pltcl_SPI_lastoid() - return the last oid. To
2638 * be used after insert queries
2639 **********************************************************************/
2640 static int
pltcl_SPI_lastoid(ClientData cdata,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])2641 pltcl_SPI_lastoid(ClientData cdata, Tcl_Interp *interp,
2642 int objc, Tcl_Obj *const objv[])
2643 {
2644 Tcl_SetObjResult(interp, Tcl_NewWideIntObj(SPI_lastoid));
2645 return TCL_OK;
2646 }
2647
2648
2649 /**********************************************************************
2650 * pltcl_set_tuple_values() - Set variables for all attributes
2651 * of a given tuple
2652 *
2653 * Note: arrayname is presumed to be UTF8; it usually came from Tcl
2654 **********************************************************************/
2655 static void
pltcl_set_tuple_values(Tcl_Interp * interp,const char * arrayname,uint64 tupno,HeapTuple tuple,TupleDesc tupdesc)2656 pltcl_set_tuple_values(Tcl_Interp *interp, const char *arrayname,
2657 uint64 tupno, HeapTuple tuple, TupleDesc tupdesc)
2658 {
2659 int i;
2660 char *outputstr;
2661 Datum attr;
2662 bool isnull;
2663 const char *attname;
2664 Oid typoutput;
2665 bool typisvarlena;
2666 const char **arrptr;
2667 const char **nameptr;
2668 const char *nullname = NULL;
2669
2670 /************************************************************
2671 * Prepare pointers for Tcl_SetVar2() below
2672 ************************************************************/
2673 if (arrayname == NULL)
2674 {
2675 arrptr = &attname;
2676 nameptr = &nullname;
2677 }
2678 else
2679 {
2680 arrptr = &arrayname;
2681 nameptr = &attname;
2682
2683 /*
2684 * When outputting to an array, fill the ".tupno" element with the
2685 * current tuple number. This will be overridden below if ".tupno" is
2686 * in use as an actual field name in the rowtype.
2687 */
2688 Tcl_SetVar2Ex(interp, arrayname, ".tupno", Tcl_NewWideIntObj(tupno), 0);
2689 }
2690
2691 for (i = 0; i < tupdesc->natts; i++)
2692 {
2693 /* ignore dropped attributes */
2694 if (tupdesc->attrs[i]->attisdropped)
2695 continue;
2696
2697 /************************************************************
2698 * Get the attribute name
2699 ************************************************************/
2700 UTF_BEGIN;
2701 attname = pstrdup(UTF_E2U(NameStr(tupdesc->attrs[i]->attname)));
2702 UTF_END;
2703
2704 /************************************************************
2705 * Get the attributes value
2706 ************************************************************/
2707 attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
2708
2709 /************************************************************
2710 * If there is a value, set the variable
2711 * If not, unset it
2712 *
2713 * Hmmm - Null attributes will cause functions to
2714 * crash if they don't expect them - need something
2715 * smarter here.
2716 ************************************************************/
2717 if (!isnull)
2718 {
2719 getTypeOutputInfo(tupdesc->attrs[i]->atttypid,
2720 &typoutput, &typisvarlena);
2721 outputstr = OidOutputFunctionCall(typoutput, attr);
2722 UTF_BEGIN;
2723 Tcl_SetVar2Ex(interp, *arrptr, *nameptr,
2724 Tcl_NewStringObj(UTF_E2U(outputstr), -1), 0);
2725 UTF_END;
2726 pfree(outputstr);
2727 }
2728 else
2729 Tcl_UnsetVar2(interp, *arrptr, *nameptr, 0);
2730
2731 pfree((char *) attname);
2732 }
2733 }
2734
2735
2736 /**********************************************************************
2737 * pltcl_build_tuple_argument() - Build a list object usable for 'array set'
2738 * from all attributes of a given tuple
2739 **********************************************************************/
2740 static Tcl_Obj *
pltcl_build_tuple_argument(HeapTuple tuple,TupleDesc tupdesc)2741 pltcl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc)
2742 {
2743 Tcl_Obj *retobj = Tcl_NewObj();
2744 int i;
2745 char *outputstr;
2746 Datum attr;
2747 bool isnull;
2748 char *attname;
2749 Oid typoutput;
2750 bool typisvarlena;
2751
2752 for (i = 0; i < tupdesc->natts; i++)
2753 {
2754 /* ignore dropped attributes */
2755 if (tupdesc->attrs[i]->attisdropped)
2756 continue;
2757
2758 /************************************************************
2759 * Get the attribute name
2760 ************************************************************/
2761 attname = NameStr(tupdesc->attrs[i]->attname);
2762
2763 /************************************************************
2764 * Get the attributes value
2765 ************************************************************/
2766 attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
2767
2768 /************************************************************
2769 * If there is a value, append the attribute name and the
2770 * value to the list
2771 *
2772 * Hmmm - Null attributes will cause functions to
2773 * crash if they don't expect them - need something
2774 * smarter here.
2775 ************************************************************/
2776 if (!isnull)
2777 {
2778 getTypeOutputInfo(tupdesc->attrs[i]->atttypid,
2779 &typoutput, &typisvarlena);
2780 outputstr = OidOutputFunctionCall(typoutput, attr);
2781 UTF_BEGIN;
2782 Tcl_ListObjAppendElement(NULL, retobj,
2783 Tcl_NewStringObj(UTF_E2U(attname), -1));
2784 UTF_END;
2785 UTF_BEGIN;
2786 Tcl_ListObjAppendElement(NULL, retobj,
2787 Tcl_NewStringObj(UTF_E2U(outputstr), -1));
2788 UTF_END;
2789 pfree(outputstr);
2790 }
2791 }
2792
2793 return retobj;
2794 }
2795