?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
another small message tweak
[PostgreSQL.git] / src / pl / plperl / plperl.c
blob2127a2369fb716f84803b39f5464223335d06217
1 /**********************************************************************
2 * plperl.c - perl as a procedural language for PostgreSQL
3 *
4 * $PostgreSQL$
5 *
6 **********************************************************************/
7
8 #include "postgres.h"
9 /* Defined by Perl */
10 #undef _
11
12 /* system stuff */
13 #include <ctype.h>
14 #include <fcntl.h>
15 #include <unistd.h>
16 #include <locale.h>
17
18 /* postgreSQL stuff */
19 #include "access/xact.h"
20 #include "catalog/pg_language.h"
21 #include "catalog/pg_proc.h"
22 #include "catalog/pg_type.h"
23 #include "commands/trigger.h"
24 #include "executor/spi.h"
25 #include "funcapi.h"
26 #include "mb/pg_wchar.h"
27 #include "miscadmin.h"
28 #include "nodes/makefuncs.h"
29 #include "parser/parse_type.h"
30 #include "utils/builtins.h"
31 #include "utils/fmgroids.h"
32 #include "utils/guc.h"
33 #include "utils/hsearch.h"
34 #include "utils/lsyscache.h"
35 #include "utils/memutils.h"
36 #include "utils/syscache.h"
37 #include "utils/typcache.h"
38
39 /* define our text domain for translations */
40 #undef TEXTDOMAIN
41 #define TEXTDOMAIN PG_TEXTDOMAIN("plperl")
42
43 /* perl stuff */
44 #include "plperl.h"
45
46 PG_MODULE_MAGIC;
47
48 /**********************************************************************
49 * The information we cache about loaded procedures
50 **********************************************************************/
51 typedef struct plperl_proc_desc
52 {
53 char *proname; /* user name of procedure */
54 TransactionId fn_xmin;
55 ItemPointerData fn_tid;
56 bool fn_readonly;
57 bool lanpltrusted;
58 bool fn_retistuple; /* true, if function returns tuple */
59 bool fn_retisset; /* true, if function returns set */
60 bool fn_retisarray; /* true if function returns array */
61 Oid result_oid; /* Oid of result type */
62 FmgrInfo result_in_func; /* I/O function and arg for result type */
63 Oid result_typioparam;
64 int nargs;
65 FmgrInfo arg_out_func[FUNC_MAX_ARGS];
66 bool arg_is_rowtype[FUNC_MAX_ARGS];
67 SV *reference;
68 } plperl_proc_desc;
69
70 /* hash table entry for proc desc */
71
72 typedef struct plperl_proc_entry
73 {
74 char proc_name[NAMEDATALEN]; /* internal name, eg
75 * __PLPerl_proc_39987 */
76 plperl_proc_desc *proc_data;
77 } plperl_proc_entry;
78
79 /*
80 * The information we cache for the duration of a single call to a
81 * function.
82 */
83 typedef struct plperl_call_data
84 {
85 plperl_proc_desc *prodesc;
86 FunctionCallInfo fcinfo;
87 Tuplestorestate *tuple_store;
88 TupleDesc ret_tdesc;
89 AttInMetadata *attinmeta;
90 MemoryContext tmp_cxt;
91 } plperl_call_data;
92
93 /**********************************************************************
94 * The information we cache about prepared and saved plans
95 **********************************************************************/
96 typedef struct plperl_query_desc
97 {
98 char qname[sizeof(long) * 2 + 1];
99 void *plan;
100 int nargs;
101 Oid *argtypes;
102 FmgrInfo *arginfuncs;
103 Oid *argtypioparams;
104 } plperl_query_desc;
105
106 /* hash table entry for query desc */
107
108 typedef struct plperl_query_entry
109 {
110 char query_name[NAMEDATALEN];
111 plperl_query_desc *query_data;
112 } plperl_query_entry;
113
114 /**********************************************************************
115 * Global data
116 **********************************************************************/
117
118 typedef enum
119 {
120 INTERP_NONE,
121 INTERP_HELD,
122 INTERP_TRUSTED,
123 INTERP_UNTRUSTED,
124 INTERP_BOTH
125 } InterpState;
126
127 static InterpState interp_state = INTERP_NONE;
128 static bool can_run_two = false;
129
130 static bool plperl_safe_init_done = false;
131 static PerlInterpreter *plperl_trusted_interp = NULL;
132 static PerlInterpreter *plperl_untrusted_interp = NULL;
133 static PerlInterpreter *plperl_held_interp = NULL;
134 static bool trusted_context;
135 static HTAB *plperl_proc_hash = NULL;
136 static HTAB *plperl_query_hash = NULL;
137
138 static bool plperl_use_strict = false;
139
140 /* this is saved and restored by plperl_call_handler */
141 static plperl_call_data *current_call_data = NULL;
142
143 /**********************************************************************
144 * Forward declarations
145 **********************************************************************/
146 Datum plperl_call_handler(PG_FUNCTION_ARGS);
147 Datum plperl_validator(PG_FUNCTION_ARGS);
148 void _PG_init(void);
149
150 static void plperl_init_interp(void);
151
152 static Datum plperl_func_handler(PG_FUNCTION_ARGS);
153
154 static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
155 static plperl_proc_desc *compile_plperl_function(Oid fn_oid, bool is_trigger);
156
157 static SV *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc);
158 static void plperl_init_shared_libs(pTHX);
159 static HV *plperl_spi_execute_fetch_result(SPITupleTable *, int, int);
160 static SV *newSVstring(const char *str);
161 static SV **hv_store_string(HV *hv, const char *key, SV *val);
162 static SV **hv_fetch_string(HV *hv, const char *key);
163 static SV *plperl_create_sub(char *proname, char *s, bool trusted);
164 static SV *plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo);
165
166 /*
167 * This routine is a crock, and so is everyplace that calls it. The problem
168 * is that the cached form of plperl functions/queries is allocated permanently
169 * (mostly via malloc()) and never released until backend exit. Subsidiary
170 * data structures such as fmgr info records therefore must live forever
171 * as well. A better implementation would store all this stuff in a per-
172 * function memory context that could be reclaimed at need. In the meantime,
173 * fmgr_info_cxt must be called specifying TopMemoryContext so that whatever
174 * it might allocate, and whatever the eventual function might allocate using
175 * fn_mcxt, will live forever too.
176 */
177 static void
178 perm_fmgr_info(Oid functionId, FmgrInfo *finfo)
179 {
180 fmgr_info_cxt(functionId, finfo, TopMemoryContext);
181 }
182
183
184 /*
185 * _PG_init() - library load-time initialization
186 *
187 * DO NOT make this static nor change its name!
188 */
189 void
190 _PG_init(void)
191 {
192 /* Be sure we do initialization only once (should be redundant now) */
193 static bool inited = false;
194 HASHCTL hash_ctl;
195
196 if (inited)
197 return;
198
199 pg_bindtextdomain(TEXTDOMAIN);
200
201 DefineCustomBoolVariable("plperl.use_strict",
202 gettext_noop("If true, trusted and untrusted Perl code will be compiled in strict mode."),
203 NULL,
204 &plperl_use_strict,
205 false,
206 PGC_USERSET, 0,
207 NULL, NULL);
208
209 EmitWarningsOnPlaceholders("plperl");
210
211 MemSet(&hash_ctl, 0, sizeof(hash_ctl));
212
213 hash_ctl.keysize = NAMEDATALEN;
214 hash_ctl.entrysize = sizeof(plperl_proc_entry);
215
216 plperl_proc_hash = hash_create("PLPerl Procedures",
217 32,
218 &hash_ctl,
219 HASH_ELEM);
220
221 hash_ctl.entrysize = sizeof(plperl_query_entry);
222 plperl_query_hash = hash_create("PLPerl Queries",
223 32,
224 &hash_ctl,
225 HASH_ELEM);
226
227 plperl_init_interp();
228
229 inited = true;
230 }
231
232 /* Each of these macros must represent a single string literal */
233
234 #define PERLBOOT \
235 "SPI::bootstrap(); use vars qw(%_SHARED);" \
236 "sub ::plperl_warn { my $msg = shift; " \
237 " $msg =~ s/\\(eval \\d+\\) //g; &elog(&NOTICE, $msg); } " \
238 "$SIG{__WARN__} = \\&::plperl_warn; " \
239 "sub ::plperl_die { my $msg = shift; " \
240 " $msg =~ s/\\(eval \\d+\\) //g; die $msg; } " \
241 "$SIG{__DIE__} = \\&::plperl_die; " \
242 "sub ::mkunsafefunc {" \
243 " my $ret = eval(qq[ sub { $_[0] $_[1] } ]); " \
244 " $@ =~ s/\\(eval \\d+\\) //g if $@; return $ret; }" \
245 "use strict; " \
246 "sub ::mk_strict_unsafefunc {" \
247 " my $ret = eval(qq[ sub { use strict; $_[0] $_[1] } ]); " \
248 " $@ =~ s/\\(eval \\d+\\) //g if $@; return $ret; } " \
249 "sub ::_plperl_to_pg_array {" \
250 " my $arg = shift; ref $arg eq 'ARRAY' || return $arg; " \
251 " my $res = ''; my $first = 1; " \
252 " foreach my $elem (@$arg) " \
253 " { " \
254 " $res .= ', ' unless $first; $first = undef; " \
255 " if (ref $elem) " \
256 " { " \
257 " $res .= _plperl_to_pg_array($elem); " \
258 " } " \
259 " elsif (defined($elem)) " \
260 " { " \
261 " my $str = qq($elem); " \
262 " $str =~ s/([\"\\\\])/\\\\$1/g; " \
263 " $res .= qq(\"$str\"); " \
264 " } " \
265 " else " \
266 " { "\
267 " $res .= 'NULL' ; " \
268 " } "\
269 " } " \
270 " return qq({$res}); " \
271 "} "
272
273 #define SAFE_MODULE \
274 "require Safe; $Safe::VERSION"
275
276 /*
277 * The temporary enabling of the caller opcode here is to work around a
278 * bug in perl 5.10, which unkindly changed the way its Safe.pm works, without
279 * notice. It is quite safe, as caller is informational only, and in any case
280 * we only enable it while we load the 'strict' module.
281 */
282
283 #define SAFE_OK \
284 "use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');" \
285 "$PLContainer->permit_only(':default');" \
286 "$PLContainer->permit(qw[:base_math !:base_io sort time]);" \
287 "$PLContainer->share(qw[&elog &spi_exec_query &return_next " \
288 "&spi_query &spi_fetchrow &spi_cursor_close " \
289 "&spi_prepare &spi_exec_prepared &spi_query_prepared &spi_freeplan " \
290 "&_plperl_to_pg_array " \
291 "&DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED ]);" \
292 "sub ::mksafefunc {" \
293 " my $ret = $PLContainer->reval(qq[sub { $_[0] $_[1] }]); " \
294 " $@ =~ s/\\(eval \\d+\\) //g if $@; return $ret; }" \
295 "$PLContainer->permit(qw[require caller]); $PLContainer->reval('use strict;');" \
296 "$PLContainer->deny(qw[require caller]); " \
297 "sub ::mk_strict_safefunc {" \
298 " my $ret = $PLContainer->reval(qq[sub { BEGIN { strict->import(); } $_[0] $_[1] }]); " \
299 " $@ =~ s/\\(eval \\d+\\) //g if $@; return $ret; }"
300
301 #define SAFE_BAD \
302 "use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');" \
303 "$PLContainer->permit_only(':default');" \
304 "$PLContainer->share(qw[&elog &ERROR ]);" \
305 "sub ::mksafefunc { return $PLContainer->reval(qq[sub { " \
306 " elog(ERROR,'trusted Perl functions disabled - " \
307 " please upgrade Perl Safe module to version 2.09 or later');}]); }" \
308 "sub ::mk_strict_safefunc { return $PLContainer->reval(qq[sub { " \
309 " elog(ERROR,'trusted Perl functions disabled - " \
310 " please upgrade Perl Safe module to version 2.09 or later');}]); }"
311
312 #define TEST_FOR_MULTI \
313 "use Config; " \
314 "$Config{usemultiplicity} eq 'define' or " \
315 "($Config{usethreads} eq 'define' " \
316 " and $Config{useithreads} eq 'define')"
317
318
319 /********************************************************************
320 *
321 * We start out by creating a "held" interpreter that we can use in
322 * trusted or untrusted mode (but not both) as the need arises. Later, we
323 * assign that interpreter if it is available to either the trusted or
324 * untrusted interpreter. If it has already been assigned, and we need to
325 * create the other interpreter, we do that if we can, or error out.
326 * We detect if it is safe to run two interpreters during the setup of the
327 * dummy interpreter.
328 */
329
330
331 static void
332 check_interp(bool trusted)
333 {
334 if (interp_state == INTERP_HELD)
335 {
336 if (trusted)
337 {
338 plperl_trusted_interp = plperl_held_interp;
339 interp_state = INTERP_TRUSTED;
340 }
341 else
342 {
343 plperl_untrusted_interp = plperl_held_interp;
344 interp_state = INTERP_UNTRUSTED;
345 }
346 plperl_held_interp = NULL;
347 trusted_context = trusted;
348 }
349 else if (interp_state == INTERP_BOTH ||
350 (trusted && interp_state == INTERP_TRUSTED) ||
351 (!trusted && interp_state == INTERP_UNTRUSTED))
352 {
353 if (trusted_context != trusted)
354 {
355 if (trusted)
356 PERL_SET_CONTEXT(plperl_trusted_interp);
357 else
358 PERL_SET_CONTEXT(plperl_untrusted_interp);
359 trusted_context = trusted;
360 }
361 }
362 else if (can_run_two)
363 {
364 PERL_SET_CONTEXT(plperl_held_interp);
365 plperl_init_interp();
366 if (trusted)
367 plperl_trusted_interp = plperl_held_interp;
368 else
369 plperl_untrusted_interp = plperl_held_interp;
370 interp_state = INTERP_BOTH;
371 plperl_held_interp = NULL;
372 trusted_context = trusted;
373 }
374 else
375 {
376 elog(ERROR,
377 "cannot allocate second Perl interpreter on this platform");
378 }
379 }
380
381
382 static void
383 restore_context(bool old_context)
384 {
385 if (trusted_context != old_context)
386 {
387 if (old_context)
388 PERL_SET_CONTEXT(plperl_trusted_interp);
389 else
390 PERL_SET_CONTEXT(plperl_untrusted_interp);
391 trusted_context = old_context;
392 }
393 }
394
395 static void
396 plperl_init_interp(void)
397 {
398 static char *embedding[3] = {
399 "", "-e", PERLBOOT
400 };
401
402 #ifdef WIN32
403
404 /*
405 * The perl library on startup does horrible things like call
406 * setlocale(LC_ALL,""). We have protected against that on most platforms
407 * by setting the environment appropriately. However, on Windows,
408 * setlocale() does not consult the environment, so we need to save the
409 * existing locale settings before perl has a chance to mangle them and
410 * restore them after its dirty deeds are done.
411 *
412 * MSDN ref:
413 * http://msdn.microsoft.com/library/en-us/vclib/html/_crt_locale.asp
414 *
415 * It appears that we only need to do this on interpreter startup, and
416 * subsequent calls to the interpreter don't mess with the locale
417 * settings.
418 *
419 * We restore them using Perl's POSIX::setlocale() function so that Perl
420 * doesn't have a different idea of the locale from Postgres.
421 *
422 */
423
424 char *loc;
425 char *save_collate,
426 *save_ctype,
427 *save_monetary,
428 *save_numeric,
429 *save_time;
430 char buf[1024];
431
432 loc = setlocale(LC_COLLATE, NULL);
433 save_collate = loc ? pstrdup(loc) : NULL;
434 loc = setlocale(LC_CTYPE, NULL);
435 save_ctype = loc ? pstrdup(loc) : NULL;
436 loc = setlocale(LC_MONETARY, NULL);
437 save_monetary = loc ? pstrdup(loc) : NULL;
438 loc = setlocale(LC_NUMERIC, NULL);
439 save_numeric = loc ? pstrdup(loc) : NULL;
440 loc = setlocale(LC_TIME, NULL);
441 save_time = loc ? pstrdup(loc) : NULL;
442 #endif
443
444
445 plperl_held_interp = perl_alloc();
446 if (!plperl_held_interp)
447 elog(ERROR, "could not allocate Perl interpreter");
448
449 perl_construct(plperl_held_interp);
450 perl_parse(plperl_held_interp, plperl_init_shared_libs,
451 3, embedding, NULL);
452 perl_run(plperl_held_interp);
453
454 if (interp_state == INTERP_NONE)
455 {
456 SV *res;
457
458 res = eval_pv(TEST_FOR_MULTI, TRUE);
459 can_run_two = SvIV(res);
460 interp_state = INTERP_HELD;
461 }
462
463 #ifdef WIN32
464
465 eval_pv("use POSIX qw(locale_h);", TRUE); /* croak on failure */
466
467 if (save_collate != NULL)
468 {
469 snprintf(buf, sizeof(buf), "setlocale(%s,'%s');",
470 "LC_COLLATE", save_collate);
471 eval_pv(buf, TRUE);
472 pfree(save_collate);
473 }
474 if (save_ctype != NULL)
475 {
476 snprintf(buf, sizeof(buf), "setlocale(%s,'%s');",
477 "LC_CTYPE", save_ctype);
478 eval_pv(buf, TRUE);
479 pfree(save_ctype);
480 }
481 if (save_monetary != NULL)
482 {
483 snprintf(buf, sizeof(buf), "setlocale(%s,'%s');",
484 "LC_MONETARY", save_monetary);
485 eval_pv(buf, TRUE);
486 pfree(save_monetary);
487 }
488 if (save_numeric != NULL)
489 {
490 snprintf(buf, sizeof(buf), "setlocale(%s,'%s');",
491 "LC_NUMERIC", save_numeric);
492 eval_pv(buf, TRUE);
493 pfree(save_numeric);
494 }
495 if (save_time != NULL)
496 {
497 snprintf(buf, sizeof(buf), "setlocale(%s,'%s');",
498 "LC_TIME", save_time);
499 eval_pv(buf, TRUE);
500 pfree(save_time);
501 }
502 #endif
503
504 }
505
506
507 static void
508 plperl_safe_init(void)
509 {
510 SV *res;
511 double safe_version;
512
513 res = eval_pv(SAFE_MODULE, FALSE); /* TRUE = croak if failure */
514
515 safe_version = SvNV(res);
516
517 /*
518 * We actually want to reject safe_version < 2.09, but it's risky to
519 * assume that floating-point comparisons are exact, so use a slightly
520 * smaller comparison value.
521 */
522 if (safe_version < 2.0899)
523 {
524 /* not safe, so disallow all trusted funcs */
525 eval_pv(SAFE_BAD, FALSE);
526 }
527 else
528 {
529 eval_pv(SAFE_OK, FALSE);
530 if (GetDatabaseEncoding() == PG_UTF8)
531 {
532 /*
533 * Fill in just enough information to set up this perl
534 * function in the safe container and call it.
535 * For some reason not entirely clear, it prevents errors that
536 * can arise from the regex code later trying to load
537 * utf8 modules.
538 */
539 plperl_proc_desc desc;
540 FunctionCallInfoData fcinfo;
541 SV *ret;
542 SV *func;
543
544 /* make sure we don't call ourselves recursively */
545 plperl_safe_init_done = true;
546
547 /* compile the function */
548 func = plperl_create_sub("utf8fix",
549 "return shift =~ /\\xa9/i ? 'true' : 'false' ;",
550 true);
551
552 /* set up to call the function with a single text argument 'a' */
553 desc.reference = func;
554 desc.nargs = 1;
555 desc.arg_is_rowtype[0] = false;
556 fmgr_info(F_TEXTOUT, &(desc.arg_out_func[0]));
557
558 fcinfo.arg[0] = CStringGetTextDatum("a");
559 fcinfo.argnull[0] = false;
560
561 /* and make the call */
562 ret = plperl_call_perl_func(&desc, &fcinfo);
563 }
564 }
565
566 plperl_safe_init_done = true;
567 }
568
569 /*
570 * Perl likes to put a newline after its error messages; clean up such
571 */
572 static char *
573 strip_trailing_ws(const char *msg)
574 {
575 char *res = pstrdup(msg);
576 int len = strlen(res);
577
578 while (len > 0 && isspace((unsigned char) res[len - 1]))
579 res[--len] = '\0';
580 return res;
581 }
582
583
584 /* Build a tuple from a hash. */
585
586 static HeapTuple
587 plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
588 {
589 TupleDesc td = attinmeta->tupdesc;
590 char **values;
591 SV *val;
592 char *key;
593 I32 klen;
594 HeapTuple tup;
595
596 values = (char **) palloc0(td->natts * sizeof(char *));
597
598 hv_iterinit(perlhash);
599 while ((val = hv_iternextsv(perlhash, &key, &klen)))
600 {
601 int attn = SPI_fnumber(td, key);
602
603 if (attn <= 0 || td->attrs[attn - 1]->attisdropped)
604 ereport(ERROR,
605 (errcode(ERRCODE_UNDEFINED_COLUMN),
606 errmsg("Perl hash contains nonexistent column \"%s\"",
607 key)));
608 if (SvOK(val))
609 values[attn - 1] = SvPV(val, PL_na);
610 }
611 hv_iterinit(perlhash);
612
613 tup = BuildTupleFromCStrings(attinmeta, values);
614 pfree(values);
615 return tup;
616 }
617
618 /*
619 * convert perl array to postgres string representation
620 */
621 static SV *
622 plperl_convert_to_pg_array(SV *src)
623 {
624 SV *rv;
625 int count;
626
627 dSP;
628
629 PUSHMARK(SP);
630 XPUSHs(src);
631 PUTBACK;
632
633 count = call_pv("::_plperl_to_pg_array", G_SCALAR);
634
635 SPAGAIN;
636
637 if (count != 1)
638 elog(ERROR, "unexpected _plperl_to_pg_array failure");
639
640 rv = POPs;
641
642 PUTBACK;
643
644 return rv;
645 }
646
647
648 /* Set up the arguments for a trigger call. */
649
650 static SV *
651 plperl_trigger_build_args(FunctionCallInfo fcinfo)
652 {
653 TriggerData *tdata;
654 TupleDesc tupdesc;
655 int i;
656 char *level;
657 char *event;
658 char *relid;
659 char *when;
660 HV *hv;
661
662 hv = newHV();
663
664 tdata = (TriggerData *) fcinfo->context;
665 tupdesc = tdata->tg_relation->rd_att;
666
667 relid = DatumGetCString(
668 DirectFunctionCall1(oidout,
669 ObjectIdGetDatum(tdata->tg_relation->rd_id)
670 )
671 );
672
673 hv_store_string(hv, "name", newSVstring(tdata->tg_trigger->tgname));
674 hv_store_string(hv, "relid", newSVstring(relid));
675
676 if (TRIGGER_FIRED_BY_INSERT(tdata->tg_event))
677 {
678 event = "INSERT";
679 if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
680 hv_store_string(hv, "new",
681 plperl_hash_from_tuple(tdata->tg_trigtuple,
682 tupdesc));
683 }
684 else if (TRIGGER_FIRED_BY_DELETE(tdata->tg_event))
685 {
686 event = "DELETE";
687 if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
688 hv_store_string(hv, "old",
689 plperl_hash_from_tuple(tdata->tg_trigtuple,
690 tupdesc));
691 }
692 else if (TRIGGER_FIRED_BY_UPDATE(tdata->tg_event))
693 {
694 event = "UPDATE";
695 if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
696 {
697 hv_store_string(hv, "old",
698 plperl_hash_from_tuple(tdata->tg_trigtuple,
699 tupdesc));
700 hv_store_string(hv, "new",
701 plperl_hash_from_tuple(tdata->tg_newtuple,
702 tupdesc));
703 }
704 }
705 else if (TRIGGER_FIRED_BY_TRUNCATE(tdata->tg_event))
706 event = "TRUNCATE";
707 else
708 event = "UNKNOWN";
709
710 hv_store_string(hv, "event", newSVstring(event));
711 hv_store_string(hv, "argc", newSViv(tdata->tg_trigger->tgnargs));
712
713 if (tdata->tg_trigger->tgnargs > 0)
714 {
715 AV *av = newAV();
716
717 for (i = 0; i < tdata->tg_trigger->tgnargs; i++)
718 av_push(av, newSVstring(tdata->tg_trigger->tgargs[i]));
719 hv_store_string(hv, "args", newRV_noinc((SV *) av));
720 }
721
722 hv_store_string(hv, "relname",
723 newSVstring(SPI_getrelname(tdata->tg_relation)));
724
725 hv_store_string(hv, "table_name",
726 newSVstring(SPI_getrelname(tdata->tg_relation)));
727
728 hv_store_string(hv, "table_schema",
729 newSVstring(SPI_getnspname(tdata->tg_relation)));
730
731 if (TRIGGER_FIRED_BEFORE(tdata->tg_event))
732 when = "BEFORE";
733 else if (TRIGGER_FIRED_AFTER(tdata->tg_event))
734 when = "AFTER";
735 else
736 when = "UNKNOWN";
737 hv_store_string(hv, "when", newSVstring(when));
738
739 if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
740 level = "ROW";
741 else if (TRIGGER_FIRED_FOR_STATEMENT(tdata->tg_event))
742 level = "STATEMENT";
743 else
744 level = "UNKNOWN";
745 hv_store_string(hv, "level", newSVstring(level));
746
747 return newRV_noinc((SV *) hv);
748 }
749
750
751 /* Set up the new tuple returned from a trigger. */
752
753 static HeapTuple
754 plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
755 {
756 SV **svp;
757 HV *hvNew;
758 HeapTuple rtup;
759 SV *val;
760 char *key;
761 I32 klen;
762 int slotsused;
763 int *modattrs;
764 Datum *modvalues;
765 char *modnulls;
766
767 TupleDesc tupdesc;
768
769 tupdesc = tdata->tg_relation->rd_att;
770
771 svp = hv_fetch_string(hvTD, "new");
772 if (!svp)
773 ereport(ERROR,
774 (errcode(ERRCODE_UNDEFINED_COLUMN),
775 errmsg("$_TD->{new} does not exist")));
776 if (!SvOK(*svp) || SvTYPE(*svp) != SVt_RV || SvTYPE(SvRV(*svp)) != SVt_PVHV)
777 ereport(ERROR,
778 (errcode(ERRCODE_DATATYPE_MISMATCH),
779 errmsg("$_TD->{new} is not a hash reference")));
780 hvNew = (HV *) SvRV(*svp);
781
782 modattrs = palloc(tupdesc->natts * sizeof(int));
783 modvalues = palloc(tupdesc->natts * sizeof(Datum));
784 modnulls = palloc(tupdesc->natts * sizeof(char));
785 slotsused = 0;
786
787 hv_iterinit(hvNew);
788 while ((val = hv_iternextsv(hvNew, &key, &klen)))
789 {
790 int attn = SPI_fnumber(tupdesc, key);
791 Oid typinput;
792 Oid typioparam;
793 int32 atttypmod;
794 FmgrInfo finfo;
795
796 if (attn <= 0 || tupdesc->attrs[attn - 1]->attisdropped)
797 ereport(ERROR,
798 (errcode(ERRCODE_UNDEFINED_COLUMN),
799 errmsg("Perl hash contains nonexistent column \"%s\"",
800 key)));
801 /* XXX would be better to cache these lookups */
802 getTypeInputInfo(tupdesc->attrs[attn - 1]->atttypid,
803 &typinput, &typioparam);
804 fmgr_info(typinput, &finfo);
805 atttypmod = tupdesc->attrs[attn - 1]->atttypmod;
806 if (SvOK(val))
807 {
808 modvalues[slotsused] = InputFunctionCall(&finfo,
809 SvPV(val, PL_na),
810 typioparam,
811 atttypmod);
812 modnulls[slotsused] = ' ';
813 }
814 else
815 {
816 modvalues[slotsused] = InputFunctionCall(&finfo,
817 NULL,
818 typioparam,
819 atttypmod);
820 modnulls[slotsused] = 'n';
821 }
822 modattrs[slotsused] = attn;
823 slotsused++;
824 }
825 hv_iterinit(hvNew);
826
827 rtup = SPI_modifytuple(tdata->tg_relation, otup, slotsused,
828 modattrs, modvalues, modnulls);
829
830 pfree(modattrs);
831 pfree(modvalues);
832 pfree(modnulls);
833
834 if (rtup == NULL)
835 elog(ERROR, "SPI_modifytuple failed: %s",
836 SPI_result_code_string(SPI_result));
837
838 return rtup;
839 }
840
841
842 /*
843 * This is the only externally-visible part of the plperl call interface.
844 * The Postgres function and trigger managers call it to execute a
845 * perl function.
846 */
847 PG_FUNCTION_INFO_V1(plperl_call_handler);
848
849 Datum
850 plperl_call_handler(PG_FUNCTION_ARGS)
851 {
852 Datum retval;
853 plperl_call_data *save_call_data;
854
855 save_call_data = current_call_data;
856 PG_TRY();
857 {
858 if (CALLED_AS_TRIGGER(fcinfo))
859 retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
860 else
861 retval = plperl_func_handler(fcinfo);
862 }
863 PG_CATCH();
864 {
865 current_call_data = save_call_data;
866 PG_RE_THROW();
867 }
868 PG_END_TRY();
869
870 current_call_data = save_call_data;
871 return retval;
872 }
873
874 /*
875 * This is the other externally visible function - it is called when CREATE
876 * FUNCTION is issued to validate the function being created/replaced.
877 */
878 PG_FUNCTION_INFO_V1(plperl_validator);
879
880 Datum
881 plperl_validator(PG_FUNCTION_ARGS)
882 {
883 Oid funcoid = PG_GETARG_OID(0);
884 HeapTuple tuple;
885 Form_pg_proc proc;
886 char functyptype;
887 int numargs;
888 Oid *argtypes;
889 char **argnames;
890 char *argmodes;
891 bool istrigger = false;
892 int i;
893
894 /* Get the new function's pg_proc entry */
895 tuple = SearchSysCache(PROCOID,
896 ObjectIdGetDatum(funcoid),
897 0, 0, 0);
898 if (!HeapTupleIsValid(tuple))
899 elog(ERROR, "cache lookup failed for function %u", funcoid);
900 proc = (Form_pg_proc) GETSTRUCT(tuple);
901
902 functyptype = get_typtype(proc->prorettype);
903
904 /* Disallow pseudotype result */
905 /* except for TRIGGER, RECORD, or VOID */
906 if (functyptype == TYPTYPE_PSEUDO)
907 {
908 /* we assume OPAQUE with no arguments means a trigger */
909 if (proc->prorettype == TRIGGEROID ||
910 (proc->prorettype == OPAQUEOID && proc->pronargs == 0))
911 istrigger = true;
912 else if (proc->prorettype != RECORDOID &&
913 proc->prorettype != VOIDOID)
914 ereport(ERROR,
915 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
916 errmsg("PL/Perl functions cannot return type %s",
917 format_type_be(proc->prorettype))));
918 }
919
920 /* Disallow pseudotypes in arguments (either IN or OUT) */
921 numargs = get_func_arg_info(tuple,
922 &argtypes, &argnames, &argmodes);
923 for (i = 0; i < numargs; i++)
924 {
925 if (get_typtype(argtypes[i]) == TYPTYPE_PSEUDO)
926 ereport(ERROR,
927 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
928 errmsg("PL/Perl functions cannot accept type %s",
929 format_type_be(argtypes[i]))));
930 }
931
932 ReleaseSysCache(tuple);
933
934 /* Postpone body checks if !check_function_bodies */
935 if (check_function_bodies)
936 {
937 (void) compile_plperl_function(funcoid, istrigger);
938 }
939
940 /* the result of a validator is ignored */
941 PG_RETURN_VOID();
942 }
943
944
945 /*
946 * Uses mksafefunc/mkunsafefunc to create an anonymous sub whose text is
947 * supplied in s, and returns a reference to the closure.
948 */
949 static SV *
950 plperl_create_sub(char *proname, char *s, bool trusted)
951 {
952 dSP;
953 SV *subref;
954 int count;
955 char *compile_sub;
956
957 if (trusted && !plperl_safe_init_done)
958 {
959 plperl_safe_init();
960 SPAGAIN;
961 }
962
963 ENTER;
964 SAVETMPS;
965 PUSHMARK(SP);
966 XPUSHs(sv_2mortal(newSVstring("our $_TD; local $_TD=$_[0]; shift;")));
967 XPUSHs(sv_2mortal(newSVstring(s)));
968 PUTBACK;
969
970 /*
971 * G_KEEPERR seems to be needed here, else we don't recognize compile
972 * errors properly. Perhaps it's because there's another level of eval
973 * inside mksafefunc?
974 */
975
976 if (trusted && plperl_use_strict)
977 compile_sub = "::mk_strict_safefunc";
978 else if (plperl_use_strict)
979 compile_sub = "::mk_strict_unsafefunc";
980 else if (trusted)
981 compile_sub = "::mksafefunc";
982 else
983 compile_sub = "::mkunsafefunc";
984
985 count = perl_call_pv(compile_sub, G_SCALAR | G_EVAL | G_KEEPERR);
986 SPAGAIN;
987
988 if (count != 1)
989 {
990 PUTBACK;
991 FREETMPS;
992 LEAVE;
993 elog(ERROR, "didn't get a return item from mksafefunc");
994 }
995
996 if (SvTRUE(ERRSV))
997 {
998 (void) POPs;
999 PUTBACK;
1000 FREETMPS;
1001 LEAVE;
1002 ereport(ERROR,
1003 (errcode(ERRCODE_SYNTAX_ERROR),
1004 errmsg("creation of Perl function \"%s\" failed: %s",
1005 proname,
1006 strip_trailing_ws(SvPV(ERRSV, PL_na)))));
1007 }
1008
1009 /*
1010 * need to make a deep copy of the return. it comes off the stack as a
1011 * temporary.
1012 */
1013 subref = newSVsv(POPs);
1014
1015 if (!SvROK(subref) || SvTYPE(SvRV(subref)) != SVt_PVCV)
1016 {
1017 PUTBACK;
1018 FREETMPS;
1019 LEAVE;
1020
1021 /*
1022 * subref is our responsibility because it is not mortal
1023 */
1024 SvREFCNT_dec(subref);
1025 elog(ERROR, "didn't get a code ref");
1026 }
1027
1028 PUTBACK;
1029 FREETMPS;
1030 LEAVE;
1031
1032 return subref;
1033 }
1034
1035
1036 /**********************************************************************
1037 * plperl_init_shared_libs() -
1038 *
1039 * We cannot use the DynaLoader directly to get at the Opcode
1040 * module (used by Safe.pm). So, we link Opcode into ourselves
1041 * and do the initialization behind perl's back.
1042 *
1043 **********************************************************************/
1044
1045 EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
1046 EXTERN_C void boot_SPI(pTHX_ CV *cv);
1047
1048 static void
1049 plperl_init_shared_libs(pTHX)
1050 {
1051 char *file = __FILE__;
1052
1053 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
1054 newXS("SPI::bootstrap", boot_SPI, file);
1055 }
1056
1057
1058 static SV *
1059 plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
1060 {
1061 dSP;
1062 SV *retval;
1063 int i;
1064 int count;
1065 SV *sv;
1066
1067 ENTER;
1068 SAVETMPS;
1069
1070 PUSHMARK(SP);
1071
1072 XPUSHs(&PL_sv_undef); /* no trigger data */
1073
1074 for (i = 0; i < desc->nargs; i++)
1075 {
1076 if (fcinfo->argnull[i])
1077 XPUSHs(&PL_sv_undef);
1078 else if (desc->arg_is_rowtype[i])
1079 {
1080 HeapTupleHeader td;
1081 Oid tupType;
1082 int32 tupTypmod;
1083 TupleDesc tupdesc;
1084 HeapTupleData tmptup;
1085 SV *hashref;
1086
1087 td = DatumGetHeapTupleHeader(fcinfo->arg[i]);
1088 /* Extract rowtype info and find a tupdesc */
1089 tupType = HeapTupleHeaderGetTypeId(td);
1090 tupTypmod = HeapTupleHeaderGetTypMod(td);
1091 tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod);
1092 /* Build a temporary HeapTuple control structure */
1093 tmptup.t_len = HeapTupleHeaderGetDatumLength(td);
1094 tmptup.t_data = td;
1095
1096 hashref = plperl_hash_from_tuple(&tmptup, tupdesc);
1097 XPUSHs(sv_2mortal(hashref));
1098 ReleaseTupleDesc(tupdesc);
1099 }
1100 else
1101 {
1102 char *tmp;
1103
1104 tmp = OutputFunctionCall(&(desc->arg_out_func[i]),
1105 fcinfo->arg[i]);
1106 sv = newSVstring(tmp);
1107 XPUSHs(sv_2mortal(sv));
1108 pfree(tmp);
1109 }
1110 }
1111 PUTBACK;
1112
1113 /* Do NOT use G_KEEPERR here */
1114 count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL);
1115
1116 SPAGAIN;
1117
1118 if (count != 1)
1119 {
1120 PUTBACK;
1121 FREETMPS;
1122 LEAVE;
1123 elog(ERROR, "didn't get a return item from function");
1124 }
1125
1126 if (SvTRUE(ERRSV))
1127 {
1128 (void) POPs;
1129 PUTBACK;
1130 FREETMPS;
1131 LEAVE;
1132 /* XXX need to find a way to assign an errcode here */
1133 ereport(ERROR,
1134 (errmsg("error from Perl function \"%s\": %s",
1135 desc->proname,
1136 strip_trailing_ws(SvPV(ERRSV, PL_na)))));
1137 }
1138
1139 retval = newSVsv(POPs);
1140
1141 PUTBACK;
1142 FREETMPS;
1143 LEAVE;
1144
1145 return retval;
1146 }
1147
1148
1149 static SV *
1150 plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
1151 SV *td)
1152 {
1153 dSP;
1154 SV *retval;
1155 Trigger *tg_trigger;
1156 int i;
1157 int count;
1158
1159 ENTER;
1160 SAVETMPS;
1161
1162 PUSHMARK(sp);
1163
1164 XPUSHs(td);
1165
1166 tg_trigger = ((TriggerData *) fcinfo->context)->tg_trigger;
1167 for (i = 0; i < tg_trigger->tgnargs; i++)
1168 XPUSHs(sv_2mortal(newSVstring(tg_trigger->tgargs[i])));
1169 PUTBACK;
1170
1171 /* Do NOT use G_KEEPERR here */
1172 count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL);
1173
1174 SPAGAIN;
1175
1176 if (count != 1)
1177 {
1178 PUTBACK;
1179 FREETMPS;
1180 LEAVE;
1181 elog(ERROR, "didn't get a return item from trigger function");
1182 }
1183
1184 if (SvTRUE(ERRSV))
1185 {
1186 (void) POPs;
1187 PUTBACK;
1188 FREETMPS;
1189 LEAVE;
1190 /* XXX need to find a way to assign an errcode here */
1191 ereport(ERROR,
1192 (errmsg("error from Perl function \"%s\": %s",
1193 desc->proname,
1194 strip_trailing_ws(SvPV(ERRSV, PL_na)))));
1195 }
1196
1197 retval = newSVsv(POPs);
1198
1199 PUTBACK;
1200 FREETMPS;
1201 LEAVE;
1202
1203 return retval;
1204 }
1205
1206
1207 static Datum
1208 plperl_func_handler(PG_FUNCTION_ARGS)
1209 {
1210 plperl_proc_desc *prodesc;
1211 SV *perlret;
1212 Datum retval;
1213 ReturnSetInfo *rsi;
1214 SV *array_ret = NULL;
1215 bool oldcontext = trusted_context;
1216
1217 /*
1218 * Create the call_data beforing connecting to SPI, so that it is not
1219 * allocated in the SPI memory context
1220 */
1221 current_call_data = (plperl_call_data *) palloc0(sizeof(plperl_call_data));
1222 current_call_data->fcinfo = fcinfo;
1223
1224 if (SPI_connect() != SPI_OK_CONNECT)
1225 elog(ERROR, "could not connect to SPI manager");
1226
1227 prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
1228 current_call_data->prodesc = prodesc;
1229
1230 rsi = (ReturnSetInfo *) fcinfo->resultinfo;
1231
1232 if (prodesc->fn_retisset)
1233 {
1234 /* Check context before allowing the call to go through */
1235 if (!rsi || !IsA(rsi, ReturnSetInfo) ||
1236 (rsi->allowedModes & SFRM_Materialize) == 0 ||
1237 rsi->expectedDesc == NULL)
1238 ereport(ERROR,
1239 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1240 errmsg("set-valued function called in context that "
1241 "cannot accept a set")));
1242 }
1243
1244 check_interp(prodesc->lanpltrusted);
1245
1246 perlret = plperl_call_perl_func(prodesc, fcinfo);
1247
1248 /************************************************************
1249 * Disconnect from SPI manager and then create the return
1250 * values datum (if the input function does a palloc for it
1251 * this must not be allocated in the SPI memory context
1252 * because SPI_finish would free it).
1253 ************************************************************/
1254 if (SPI_finish() != SPI_OK_FINISH)
1255 elog(ERROR, "SPI_finish() failed");
1256
1257 if (prodesc->fn_retisset)
1258 {
1259 /*
1260 * If the Perl function returned an arrayref, we pretend that it
1261 * called return_next() for each element of the array, to handle old
1262 * SRFs that didn't know about return_next(). Any other sort of return
1263 * value is an error, except undef which means return an empty set.
1264 */
1265 if (SvOK(perlret) &&
1266 SvTYPE(perlret) == SVt_RV &&
1267 SvTYPE(SvRV(perlret)) == SVt_PVAV)
1268 {
1269 int i = 0;
1270 SV **svp = 0;
1271 AV *rav = (AV *) SvRV(perlret);
1272
1273 while ((svp = av_fetch(rav, i, FALSE)) != NULL)
1274 {
1275 plperl_return_next(*svp);
1276 i++;
1277 }
1278 }
1279 else if (SvOK(perlret))
1280 {
1281 ereport(ERROR,
1282 (errcode(ERRCODE_DATATYPE_MISMATCH),
1283 errmsg("set-returning PL/Perl function must return "
1284 "reference to array or use return_next")));
1285 }
1286
1287 rsi->returnMode = SFRM_Materialize;
1288 if (current_call_data->tuple_store)
1289 {
1290 rsi->setResult = current_call_data->tuple_store;
1291 rsi->setDesc = current_call_data->ret_tdesc;
1292 }
1293 retval = (Datum) 0;
1294 }
1295 else if (!SvOK(perlret))
1296 {
1297 /* Return NULL if Perl code returned undef */
1298 if (rsi && IsA(rsi, ReturnSetInfo))
1299 rsi->isDone = ExprEndResult;
1300 retval = InputFunctionCall(&prodesc->result_in_func, NULL,
1301 prodesc->result_typioparam, -1);
1302 fcinfo->isnull = true;
1303 }
1304 else if (prodesc->fn_retistuple)
1305 {
1306 /* Return a perl hash converted to a Datum */
1307 TupleDesc td;
1308 AttInMetadata *attinmeta;
1309 HeapTuple tup;
1310
1311 if (!SvOK(perlret) || SvTYPE(perlret) != SVt_RV ||
1312 SvTYPE(SvRV(perlret)) != SVt_PVHV)
1313 {
1314 ereport(ERROR,
1315 (errcode(ERRCODE_DATATYPE_MISMATCH),
1316 errmsg("composite-returning PL/Perl function "
1317 "must return reference to hash")));
1318 }
1319
1320 /* XXX should cache the attinmeta data instead of recomputing */
1321 if (get_call_result_type(fcinfo, NULL, &td) != TYPEFUNC_COMPOSITE)
1322 {
1323 ereport(ERROR,
1324 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1325 errmsg("function returning record called in context "
1326 "that cannot accept type record")));
1327 }
1328
1329 attinmeta = TupleDescGetAttInMetadata(td);
1330 tup = plperl_build_tuple_result((HV *) SvRV(perlret), attinmeta);
1331 retval = HeapTupleGetDatum(tup);
1332 }
1333 else
1334 {
1335 /* Return a perl string converted to a Datum */
1336 char *val;
1337
1338 if (prodesc->fn_retisarray && SvROK(perlret) &&
1339 SvTYPE(SvRV(perlret)) == SVt_PVAV)
1340 {
1341 array_ret = plperl_convert_to_pg_array(perlret);
1342 SvREFCNT_dec(perlret);
1343 perlret = array_ret;
1344 }
1345
1346 val = SvPV(perlret, PL_na);
1347
1348 retval = InputFunctionCall(&prodesc->result_in_func, val,
1349 prodesc->result_typioparam, -1);
1350 }
1351
1352 if (array_ret == NULL)
1353 SvREFCNT_dec(perlret);
1354
1355 current_call_data = NULL;
1356 restore_context(oldcontext);
1357
1358 return retval;
1359 }
1360
1361
1362 static Datum
1363 plperl_trigger_handler(PG_FUNCTION_ARGS)
1364 {
1365 plperl_proc_desc *prodesc;
1366 SV *perlret;
1367 Datum retval;
1368 SV *svTD;
1369 HV *hvTD;
1370 bool oldcontext = trusted_context;
1371
1372 /*
1373 * Create the call_data beforing connecting to SPI, so that it is not
1374 * allocated in the SPI memory context
1375 */
1376 current_call_data = (plperl_call_data *) palloc0(sizeof(plperl_call_data));
1377 current_call_data->fcinfo = fcinfo;
1378
1379 /* Connect to SPI manager */
1380 if (SPI_connect() != SPI_OK_CONNECT)
1381 elog(ERROR, "could not connect to SPI manager");
1382
1383 /* Find or compile the function */
1384 prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true);
1385 current_call_data->prodesc = prodesc;
1386
1387 check_interp(prodesc->lanpltrusted);
1388
1389 svTD = plperl_trigger_build_args(fcinfo);
1390 perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
1391 hvTD = (HV *) SvRV(svTD);
1392
1393 /************************************************************
1394 * Disconnect from SPI manager and then create the return
1395 * values datum (if the input function does a palloc for it
1396 * this must not be allocated in the SPI memory context
1397 * because SPI_finish would free it).
1398 ************************************************************/
1399 if (SPI_finish() != SPI_OK_FINISH)
1400 elog(ERROR, "SPI_finish() failed");
1401
1402 if (perlret == NULL || !SvOK(perlret))
1403 {
1404 /* undef result means go ahead with original tuple */
1405 TriggerData *trigdata = ((TriggerData *) fcinfo->context);
1406
1407 if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
1408 retval = (Datum) trigdata->tg_trigtuple;
1409 else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
1410 retval = (Datum) trigdata->tg_newtuple;
1411 else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
1412 retval = (Datum) trigdata->tg_trigtuple;
1413 else if (TRIGGER_FIRED_BY_TRUNCATE(trigdata->tg_event))
1414 retval = (Datum) trigdata->tg_trigtuple;
1415 else
1416 retval = (Datum) 0; /* can this happen? */
1417 }
1418 else
1419 {
1420 HeapTuple trv;
1421 char *tmp;
1422
1423 tmp = SvPV(perlret, PL_na);
1424
1425 if (pg_strcasecmp(tmp, "SKIP") == 0)
1426 trv = NULL;
1427 else if (pg_strcasecmp(tmp, "MODIFY") == 0)
1428 {
1429 TriggerData *trigdata = (TriggerData *) fcinfo->context;
1430
1431 if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
1432 trv = plperl_modify_tuple(hvTD, trigdata,
1433 trigdata->tg_trigtuple);
1434 else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
1435 trv = plperl_modify_tuple(hvTD, trigdata,
1436 trigdata->tg_newtuple);
1437 else
1438 {
1439 ereport(WARNING,
1440 (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
1441 errmsg("ignoring modified row in DELETE trigger")));
1442 trv = NULL;
1443 }
1444 }
1445 else
1446 {
1447 ereport(ERROR,
1448 (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
1449 errmsg("result of PL/Perl trigger function must be undef, "
1450 "\"SKIP\", or \"MODIFY\"")));
1451 trv = NULL;
1452 }
1453 retval = PointerGetDatum(trv);
1454 }
1455
1456 SvREFCNT_dec(svTD);
1457 if (perlret)
1458 SvREFCNT_dec(perlret);
1459
1460 current_call_data = NULL;
1461 restore_context(oldcontext);
1462 return retval;
1463 }
1464
1465
1466 static plperl_proc_desc *
1467 compile_plperl_function(Oid fn_oid, bool is_trigger)
1468 {
1469 HeapTuple procTup;
1470 Form_pg_proc procStruct;
1471 char internal_proname[NAMEDATALEN];
1472 plperl_proc_desc *prodesc = NULL;
1473 int i;
1474 plperl_proc_entry *hash_entry;
1475 bool found;
1476 bool oldcontext = trusted_context;
1477
1478 /* We'll need the pg_proc tuple in any case... */
1479 procTup = SearchSysCache(PROCOID,
1480 ObjectIdGetDatum(fn_oid),
1481 0, 0, 0);
1482 if (!HeapTupleIsValid(procTup))
1483 elog(ERROR, "cache lookup failed for function %u", fn_oid);
1484 procStruct = (Form_pg_proc) GETSTRUCT(procTup);
1485
1486 /************************************************************
1487 * Build our internal proc name from the function's Oid
1488 ************************************************************/
1489 if (!is_trigger)
1490 sprintf(internal_proname, "__PLPerl_proc_%u", fn_oid);
1491 else
1492 sprintf(internal_proname, "__PLPerl_proc_%u_trigger", fn_oid);
1493
1494 /************************************************************
1495 * Lookup the internal proc name in the hashtable
1496 ************************************************************/
1497 hash_entry = hash_search(plperl_proc_hash, internal_proname,
1498 HASH_FIND, NULL);
1499
1500 if (hash_entry)
1501 {
1502 bool uptodate;
1503
1504 prodesc = hash_entry->proc_data;
1505
1506 /************************************************************
1507 * If it's present, must check whether it's still up to date.
1508 * This is needed because CREATE OR REPLACE FUNCTION can modify the
1509 * function's pg_proc entry without changing its OID.
1510 ************************************************************/
1511 uptodate = (prodesc->fn_xmin == HeapTupleHeaderGetXmin(procTup->t_data) &&
1512 ItemPointerEquals(&prodesc->fn_tid, &procTup->t_self));
1513
1514 if (!uptodate)
1515 {
1516 free(prodesc->proname);
1517 free(prodesc);
1518 prodesc = NULL;
1519 hash_search(plperl_proc_hash, internal_proname,
1520 HASH_REMOVE, NULL);
1521 }
1522 }
1523
1524 /************************************************************
1525 * If we haven't found it in the hashtable, we analyze
1526 * the function's arguments and return type and store
1527 * the in-/out-functions in the prodesc block and create
1528 * a new hashtable entry for it.
1529 *
1530 * Then we load the procedure into the Perl interpreter.
1531 ************************************************************/
1532 if (prodesc == NULL)
1533 {
1534 HeapTuple langTup;
1535 HeapTuple typeTup;
1536 Form_pg_language langStruct;
1537 Form_pg_type typeStruct;
1538 Datum prosrcdatum;
1539 bool isnull;
1540 char *proc_source;
1541
1542 /************************************************************
1543 * Allocate a new procedure description block
1544 ************************************************************/
1545 prodesc = (plperl_proc_desc *) malloc(sizeof(plperl_proc_desc));
1546 if (prodesc == NULL)
1547 ereport(ERROR,
1548 (errcode(ERRCODE_OUT_OF_MEMORY),
1549 errmsg("out of memory")));
1550 MemSet(prodesc, 0, sizeof(plperl_proc_desc));
1551 prodesc->proname = strdup(NameStr(procStruct->proname));
1552 prodesc->fn_xmin = HeapTupleHeaderGetXmin(procTup->t_data);
1553 prodesc->fn_tid = procTup->t_self;
1554
1555 /* Remember if function is STABLE/IMMUTABLE */
1556 prodesc->fn_readonly =
1557 (procStruct->provolatile != PROVOLATILE_VOLATILE);
1558
1559 /************************************************************
1560 * Lookup the pg_language tuple by Oid
1561 ************************************************************/
1562 langTup = SearchSysCache(LANGOID,
1563 ObjectIdGetDatum(procStruct->prolang),
1564 0, 0, 0);
1565 if (!HeapTupleIsValid(langTup))
1566 {
1567 free(prodesc->proname);
1568 free(prodesc);
1569 elog(ERROR, "cache lookup failed for language %u",
1570 procStruct->prolang);
1571 }
1572 langStruct = (Form_pg_language) GETSTRUCT(langTup);
1573 prodesc->lanpltrusted = langStruct->lanpltrusted;
1574 ReleaseSysCache(langTup);
1575
1576 /************************************************************
1577 * Get the required information for input conversion of the
1578 * return value.
1579 ************************************************************/
1580 if (!is_trigger)
1581 {
1582 typeTup = SearchSysCache(TYPEOID,
1583 ObjectIdGetDatum(procStruct->prorettype),
1584 0, 0, 0);
1585 if (!HeapTupleIsValid(typeTup))
1586 {
1587 free(prodesc->proname);
1588 free(prodesc);
1589 elog(ERROR, "cache lookup failed for type %u",
1590 procStruct->prorettype);
1591 }
1592 typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
1593
1594 /* Disallow pseudotype result, except VOID or RECORD */
1595 if (typeStruct->typtype == TYPTYPE_PSEUDO)
1596 {
1597 if (procStruct->prorettype == VOIDOID ||
1598 procStruct->prorettype == RECORDOID)
1599 /* okay */ ;
1600 else if (procStruct->prorettype == TRIGGEROID)
1601 {
1602 free(prodesc->proname);
1603 free(prodesc);
1604 ereport(ERROR,
1605 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1606 errmsg("trigger functions can only be called "
1607 "as triggers")));
1608 }
1609 else
1610 {
1611 free(prodesc->proname);
1612 free(prodesc);
1613 ereport(ERROR,
1614 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1615 errmsg("PL/Perl functions cannot return type %s",
1616 format_type_be(procStruct->prorettype))));
1617 }
1618 }
1619
1620 prodesc->result_oid = procStruct->prorettype;
1621 prodesc->fn_retisset = procStruct->proretset;
1622 prodesc->fn_retistuple = (procStruct->prorettype == RECORDOID ||
1623 typeStruct->typtype == TYPTYPE_COMPOSITE);
1624
1625 prodesc->fn_retisarray =
1626 (typeStruct->typlen == -1 && typeStruct->typelem);
1627
1628 perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
1629 prodesc->result_typioparam = getTypeIOParam(typeTup);
1630
1631 ReleaseSysCache(typeTup);
1632 }
1633
1634 /************************************************************
1635 * Get the required information for output conversion
1636 * of all procedure arguments
1637 ************************************************************/
1638 if (!is_trigger)
1639 {
1640 prodesc->nargs = procStruct->pronargs;
1641 for (i = 0; i < prodesc->nargs; i++)
1642 {
1643 typeTup = SearchSysCache(TYPEOID,
1644 ObjectIdGetDatum(procStruct->proargtypes.values[i]),
1645 0, 0, 0);
1646 if (!HeapTupleIsValid(typeTup))
1647 {
1648 free(prodesc->proname);
1649 free(prodesc);
1650 elog(ERROR, "cache lookup failed for type %u",
1651 procStruct->proargtypes.values[i]);
1652 }
1653 typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
1654
1655 /* Disallow pseudotype argument */
1656 if (typeStruct->typtype == TYPTYPE_PSEUDO)
1657 {
1658 free(prodesc->proname);
1659 free(prodesc);
1660 ereport(ERROR,
1661 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1662 errmsg("PL/Perl functions cannot accept type %s",
1663 format_type_be(procStruct->proargtypes.values[i]))));
1664 }
1665
1666 if (typeStruct->typtype == TYPTYPE_COMPOSITE)
1667 prodesc->arg_is_rowtype[i] = true;
1668 else
1669 {
1670 prodesc->arg_is_rowtype[i] = false;
1671 perm_fmgr_info(typeStruct->typoutput,
1672 &(prodesc->arg_out_func[i]));
1673 }
1674
1675 ReleaseSysCache(typeTup);
1676 }
1677 }
1678
1679 /************************************************************
1680 * create the text of the anonymous subroutine.
1681 * we do not use a named subroutine so that we can call directly
1682 * through the reference.
1683 ************************************************************/
1684 prosrcdatum = SysCacheGetAttr(PROCOID, procTup,
1685 Anum_pg_proc_prosrc, &isnull);
1686 if (isnull)
1687 elog(ERROR, "null prosrc");
1688 proc_source = TextDatumGetCString(prosrcdatum);
1689
1690 /************************************************************
1691 * Create the procedure in the interpreter
1692 ************************************************************/
1693
1694 check_interp(prodesc->lanpltrusted);
1695
1696 prodesc->reference = plperl_create_sub(prodesc->proname,
1697 proc_source,
1698 prodesc->lanpltrusted);
1699
1700 restore_context(oldcontext);
1701
1702 pfree(proc_source);
1703 if (!prodesc->reference) /* can this happen? */
1704 {
1705 free(prodesc->proname);
1706 free(prodesc);
1707 elog(ERROR, "could not create internal procedure \"%s\"",
1708 internal_proname);
1709 }
1710
1711 hash_entry = hash_search(plperl_proc_hash, internal_proname,
1712 HASH_ENTER, &found);
1713 hash_entry->proc_data = prodesc;
1714 }
1715
1716 ReleaseSysCache(procTup);
1717
1718 return prodesc;
1719 }
1720
1721
1722 /* Build a hash from all attributes of a given tuple. */
1723
1724 static SV *
1725 plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
1726 {
1727 HV *hv;
1728 int i;
1729
1730 hv = newHV();
1731
1732 for (i = 0; i < tupdesc->natts; i++)
1733 {
1734 Datum attr;
1735 bool isnull;
1736 char *attname;
1737 char *outputstr;
1738 Oid typoutput;
1739 bool typisvarlena;
1740
1741 if (tupdesc->attrs[i]->attisdropped)
1742 continue;
1743
1744 attname = NameStr(tupdesc->attrs[i]->attname);
1745 attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
1746
1747 if (isnull)
1748 {
1749 /* Store (attname => undef) and move on. */
1750 hv_store_string(hv, attname, newSV(0));
1751 continue;
1752 }
1753
1754 /* XXX should have a way to cache these lookups */
1755 getTypeOutputInfo(tupdesc->attrs[i]->atttypid,
1756 &typoutput, &typisvarlena);
1757
1758 outputstr = OidOutputFunctionCall(typoutput, attr);
1759
1760 hv_store_string(hv, attname, newSVstring(outputstr));
1761
1762 pfree(outputstr);
1763 }
1764
1765 return newRV_noinc((SV *) hv);
1766 }
1767
1768
1769 HV *
1770 plperl_spi_exec(char *query, int limit)
1771 {
1772 HV *ret_hv;
1773
1774 /*
1775 * Execute the query inside a sub-transaction, so we can cope with errors
1776 * sanely
1777 */
1778 MemoryContext oldcontext = CurrentMemoryContext;
1779 ResourceOwner oldowner = CurrentResourceOwner;
1780
1781 BeginInternalSubTransaction(NULL);
1782 /* Want to run inside function's memory context */
1783 MemoryContextSwitchTo(oldcontext);
1784
1785 PG_TRY();
1786 {
1787 int spi_rv;
1788
1789 spi_rv = SPI_execute(query, current_call_data->prodesc->fn_readonly,
1790 limit);
1791 ret_hv = plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed,
1792 spi_rv);
1793
1794 /* Commit the inner transaction, return to outer xact context */
1795 ReleaseCurrentSubTransaction();
1796 MemoryContextSwitchTo(oldcontext);
1797 CurrentResourceOwner = oldowner;
1798
1799 /*
1800 * AtEOSubXact_SPI() should not have popped any SPI context, but just
1801 * in case it did, make sure we remain connected.
1802 */
1803 SPI_restore_connection();
1804 }
1805 PG_CATCH();
1806 {
1807 ErrorData *edata;
1808
1809 /* Save error info */
1810 MemoryContextSwitchTo(oldcontext);
1811 edata = CopyErrorData();
1812 FlushErrorState();
1813
1814 /* Abort the inner transaction */
1815 RollbackAndReleaseCurrentSubTransaction();
1816 MemoryContextSwitchTo(oldcontext);
1817 CurrentResourceOwner = oldowner;
1818
1819 /*
1820 * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
1821 * have left us in a disconnected state. We need this hack to return
1822 * to connected state.
1823 */
1824 SPI_restore_connection();
1825
1826 /* Punt the error to Perl */
1827 croak("%s", edata->message);
1828
1829 /* Can't get here, but keep compiler quiet */
1830 return NULL;
1831 }
1832 PG_END_TRY();
1833
1834 return ret_hv;
1835 }
1836
1837
1838 static HV *
1839 plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
1840 int status)
1841 {
1842 HV *result;
1843
1844 result = newHV();
1845
1846 hv_store_string(result, "status",
1847 newSVstring(SPI_result_code_string(status)));
1848 hv_store_string(result, "processed",
1849 newSViv(processed));
1850
1851 if (status > 0 && tuptable)
1852 {
1853 AV *rows;
1854 SV *row;
1855 int i;
1856
1857 rows = newAV();
1858 for (i = 0; i < processed; i++)
1859 {
1860 row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
1861 av_push(rows, row);
1862 }
1863 hv_store_string(result, "rows",
1864 newRV_noinc((SV *) rows));
1865 }
1866
1867 SPI_freetuptable(tuptable);
1868
1869 return result;
1870 }
1871
1872
1873 /*
1874 * Note: plperl_return_next is called both in Postgres and Perl contexts.
1875 * We report any errors in Postgres fashion (via ereport). If called in
1876 * Perl context, it is SPI.xs's responsibility to catch the error and
1877 * convert to a Perl error. We assume (perhaps without adequate justification)
1878 * that we need not abort the current transaction if the Perl code traps the
1879 * error.
1880 */
1881 void
1882 plperl_return_next(SV *sv)
1883 {
1884 plperl_proc_desc *prodesc;
1885 FunctionCallInfo fcinfo;
1886 ReturnSetInfo *rsi;
1887 MemoryContext old_cxt;
1888
1889 if (!sv)
1890 return;
1891
1892 prodesc = current_call_data->prodesc;
1893 fcinfo = current_call_data->fcinfo;
1894 rsi = (ReturnSetInfo *) fcinfo->resultinfo;
1895
1896 if (!prodesc->fn_retisset)
1897 ereport(ERROR,
1898 (errcode(ERRCODE_SYNTAX_ERROR),
1899 errmsg("cannot use return_next in a non-SETOF function")));
1900
1901 if (prodesc->fn_retistuple &&
1902 !(SvOK(sv) && SvTYPE(sv) == SVt_RV && SvTYPE(SvRV(sv)) == SVt_PVHV))
1903 ereport(ERROR,
1904 (errcode(ERRCODE_DATATYPE_MISMATCH),
1905 errmsg("SETOF-composite-returning PL/Perl function "
1906 "must call return_next with reference to hash")));
1907
1908 if (!current_call_data->ret_tdesc)
1909 {
1910 TupleDesc tupdesc;
1911
1912 Assert(!current_call_data->tuple_store);
1913 Assert(!current_call_data->attinmeta);
1914
1915 /*
1916 * This is the first call to return_next in the current PL/Perl
1917 * function call, so memoize some lookups
1918 */
1919 if (prodesc->fn_retistuple)
1920 (void) get_call_result_type(fcinfo, NULL, &tupdesc);
1921 else
1922 tupdesc = rsi->expectedDesc;
1923
1924 /*
1925 * Make sure the tuple_store and ret_tdesc are sufficiently
1926 * long-lived.
1927 */
1928 old_cxt = MemoryContextSwitchTo(rsi->econtext->ecxt_per_query_memory);
1929
1930 current_call_data->ret_tdesc = CreateTupleDescCopy(tupdesc);
1931 current_call_data->tuple_store =
1932 tuplestore_begin_heap(rsi->allowedModes & SFRM_Materialize_Random,
1933 false, work_mem);
1934 if (prodesc->fn_retistuple)
1935 {
1936 current_call_data->attinmeta =
1937 TupleDescGetAttInMetadata(current_call_data->ret_tdesc);
1938 }
1939
1940 MemoryContextSwitchTo(old_cxt);
1941 }
1942
1943 /*
1944 * Producing the tuple we want to return requires making plenty of
1945 * palloc() allocations that are not cleaned up. Since this function can
1946 * be called many times before the current memory context is reset, we
1947 * need to do those allocations in a temporary context.
1948 */
1949 if (!current_call_data->tmp_cxt)
1950 {
1951 current_call_data->tmp_cxt =
1952 AllocSetContextCreate(rsi->econtext->ecxt_per_tuple_memory,
1953 "PL/Perl return_next temporary cxt",
1954 ALLOCSET_DEFAULT_MINSIZE,
1955 ALLOCSET_DEFAULT_INITSIZE,
1956 ALLOCSET_DEFAULT_MAXSIZE);
1957 }
1958
1959 old_cxt = MemoryContextSwitchTo(current_call_data->tmp_cxt);
1960
1961 if (prodesc->fn_retistuple)
1962 {
1963 HeapTuple tuple;
1964
1965 tuple = plperl_build_tuple_result((HV *) SvRV(sv),
1966 current_call_data->attinmeta);
1967
1968 /* Make sure to store the tuple in a long-lived memory context */
1969 MemoryContextSwitchTo(rsi->econtext->ecxt_per_query_memory);
1970 tuplestore_puttuple(current_call_data->tuple_store, tuple);
1971 MemoryContextSwitchTo(old_cxt);
1972 }
1973 else
1974 {
1975 Datum ret;
1976 bool isNull;
1977
1978 if (SvOK(sv))
1979 {
1980 char *val = SvPV(sv, PL_na);
1981
1982 ret = InputFunctionCall(&prodesc->result_in_func, val,
1983 prodesc->result_typioparam, -1);
1984 isNull = false;
1985 }
1986 else
1987 {
1988 ret = InputFunctionCall(&prodesc->result_in_func, NULL,
1989 prodesc->result_typioparam, -1);
1990 isNull = true;
1991 }
1992
1993 /* Make sure to store the tuple in a long-lived memory context */
1994 MemoryContextSwitchTo(rsi->econtext->ecxt_per_query_memory);
1995 tuplestore_putvalues(current_call_data->tuple_store,
1996 current_call_data->ret_tdesc,
1997 &ret, &isNull);
1998 MemoryContextSwitchTo(old_cxt);
1999 }
2000
2001 MemoryContextReset(current_call_data->tmp_cxt);
2002 }
2003
2004
2005 SV *
2006 plperl_spi_query(char *query)
2007 {
2008 SV *cursor;
2009
2010 /*
2011 * Execute the query inside a sub-transaction, so we can cope with errors
2012 * sanely
2013 */
2014 MemoryContext oldcontext = CurrentMemoryContext;
2015 ResourceOwner oldowner = CurrentResourceOwner;
2016
2017 BeginInternalSubTransaction(NULL);
2018 /* Want to run inside function's memory context */
2019 MemoryContextSwitchTo(oldcontext);
2020
2021 PG_TRY();
2022 {
2023 void *plan;
2024 Portal portal;
2025
2026 /* Create a cursor for the query */
2027 plan = SPI_prepare(query, 0, NULL);
2028 if (plan == NULL)
2029 elog(ERROR, "SPI_prepare() failed:%s",
2030 SPI_result_code_string(SPI_result));
2031
2032 portal = SPI_cursor_open(NULL, plan, NULL, NULL, false);
2033 SPI_freeplan(plan);
2034 if (portal == NULL)
2035 elog(ERROR, "SPI_cursor_open() failed:%s",
2036 SPI_result_code_string(SPI_result));
2037 cursor = newSVstring(portal->name);
2038
2039 /* Commit the inner transaction, return to outer xact context */
2040 ReleaseCurrentSubTransaction();
2041 MemoryContextSwitchTo(oldcontext);
2042 CurrentResourceOwner = oldowner;
2043
2044 /*
2045 * AtEOSubXact_SPI() should not have popped any SPI context, but just
2046 * in case it did, make sure we remain connected.
2047 */
2048 SPI_restore_connection();
2049 }
2050 PG_CATCH();
2051 {
2052 ErrorData *edata;
2053
2054 /* Save error info */
2055 MemoryContextSwitchTo(oldcontext);
2056 edata = CopyErrorData();
2057 FlushErrorState();
2058
2059 /* Abort the inner transaction */
2060 RollbackAndReleaseCurrentSubTransaction();
2061 MemoryContextSwitchTo(oldcontext);
2062 CurrentResourceOwner = oldowner;
2063
2064 /*
2065 * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
2066 * have left us in a disconnected state. We need this hack to return
2067 * to connected state.
2068 */
2069 SPI_restore_connection();
2070
2071 /* Punt the error to Perl */
2072 croak("%s", edata->message);
2073
2074 /* Can't get here, but keep compiler quiet */
2075 return NULL;
2076 }
2077 PG_END_TRY();
2078
2079 return cursor;
2080 }
2081
2082
2083 SV *
2084 plperl_spi_fetchrow(char *cursor)
2085 {
2086 SV *row;
2087
2088 /*
2089 * Execute the FETCH inside a sub-transaction, so we can cope with errors
2090 * sanely
2091 */
2092 MemoryContext oldcontext = CurrentMemoryContext;
2093 ResourceOwner oldowner = CurrentResourceOwner;
2094
2095 BeginInternalSubTransaction(NULL);
2096 /* Want to run inside function's memory context */
2097 MemoryContextSwitchTo(oldcontext);
2098
2099 PG_TRY();
2100 {
2101 Portal p = SPI_cursor_find(cursor);
2102
2103 if (!p)
2104 {
2105 row = &PL_sv_undef;
2106 }
2107 else
2108 {
2109 SPI_cursor_fetch(p, true, 1);
2110 if (SPI_processed == 0)
2111 {
2112 SPI_cursor_close(p);
2113 row = &PL_sv_undef;
2114 }
2115 else
2116 {
2117 row = plperl_hash_from_tuple(SPI_tuptable->vals[0],
2118 SPI_tuptable->tupdesc);
2119 }
2120 SPI_freetuptable(SPI_tuptable);
2121 }
2122
2123 /* Commit the inner transaction, return to outer xact context */
2124 ReleaseCurrentSubTransaction();
2125 MemoryContextSwitchTo(oldcontext);
2126 CurrentResourceOwner = oldowner;
2127
2128 /*
2129 * AtEOSubXact_SPI() should not have popped any SPI context, but just
2130 * in case it did, make sure we remain connected.
2131 */
2132 SPI_restore_connection();
2133 }
2134 PG_CATCH();
2135 {
2136 ErrorData *edata;
2137
2138 /* Save error info */
2139 MemoryContextSwitchTo(oldcontext);
2140 edata = CopyErrorData();
2141 FlushErrorState();
2142
2143 /* Abort the inner transaction */
2144 RollbackAndReleaseCurrentSubTransaction();
2145 MemoryContextSwitchTo(oldcontext);
2146 CurrentResourceOwner = oldowner;
2147
2148 /*
2149 * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
2150 * have left us in a disconnected state. We need this hack to return
2151 * to connected state.
2152 */
2153 SPI_restore_connection();
2154
2155 /* Punt the error to Perl */
2156 croak("%s", edata->message);
2157
2158 /* Can't get here, but keep compiler quiet */
2159 return NULL;
2160 }
2161 PG_END_TRY();
2162
2163 return row;
2164 }
2165
2166 void
2167 plperl_spi_cursor_close(char *cursor)
2168 {
2169 Portal p = SPI_cursor_find(cursor);
2170
2171 if (p)
2172 SPI_cursor_close(p);
2173 }
2174
2175 SV *
2176 plperl_spi_prepare(char *query, int argc, SV **argv)
2177 {
2178 plperl_query_desc *qdesc;
2179 plperl_query_entry *hash_entry;
2180 bool found;
2181 void *plan;
2182 int i;
2183
2184 MemoryContext oldcontext = CurrentMemoryContext;
2185 ResourceOwner oldowner = CurrentResourceOwner;
2186
2187 BeginInternalSubTransaction(NULL);
2188 MemoryContextSwitchTo(oldcontext);
2189
2190 /************************************************************
2191 * Allocate the new querydesc structure
2192 ************************************************************/
2193 qdesc = (plperl_query_desc *) malloc(sizeof(plperl_query_desc));
2194 MemSet(qdesc, 0, sizeof(plperl_query_desc));
2195 snprintf(qdesc->qname, sizeof(qdesc->qname), "%lx", (long) qdesc);
2196 qdesc->nargs = argc;
2197 qdesc->argtypes = (Oid *) malloc(argc * sizeof(Oid));
2198 qdesc->arginfuncs = (FmgrInfo *) malloc(argc * sizeof(FmgrInfo));
2199 qdesc->argtypioparams = (Oid *) malloc(argc * sizeof(Oid));
2200
2201 PG_TRY();
2202 {
2203 /************************************************************
2204 * Resolve argument type names and then look them up by oid
2205 * in the system cache, and remember the required information
2206 * for input conversion.
2207 ************************************************************/
2208 for (i = 0; i < argc; i++)
2209 {
2210 Oid typId,
2211 typInput,
2212 typIOParam;
2213 int32 typmod;
2214
2215 parseTypeString(SvPV(argv[i], PL_na), &typId, &typmod);
2216
2217 getTypeInputInfo(typId, &typInput, &typIOParam);
2218
2219 qdesc->argtypes[i] = typId;
2220 perm_fmgr_info(typInput, &(qdesc->arginfuncs[i]));
2221 qdesc->argtypioparams[i] = typIOParam;
2222 }
2223
2224 /************************************************************
2225 * Prepare the plan and check for errors
2226 ************************************************************/
2227 plan = SPI_prepare(query, argc, qdesc->argtypes);
2228
2229 if (plan == NULL)
2230 elog(ERROR, "SPI_prepare() failed:%s",
2231 SPI_result_code_string(SPI_result));
2232
2233 /************************************************************
2234 * Save the plan into permanent memory (right now it's in the
2235 * SPI procCxt, which will go away at function end).
2236 ************************************************************/
2237 qdesc->plan = SPI_saveplan(plan);
2238 if (qdesc->plan == NULL)
2239 elog(ERROR, "SPI_saveplan() failed: %s",
2240 SPI_result_code_string(SPI_result));
2241
2242 /* Release the procCxt copy to avoid within-function memory leak */
2243 SPI_freeplan(plan);
2244
2245 /* Commit the inner transaction, return to outer xact context */
2246 ReleaseCurrentSubTransaction();
2247 MemoryContextSwitchTo(oldcontext);
2248 CurrentResourceOwner = oldowner;
2249
2250 /*
2251 * AtEOSubXact_SPI() should not have popped any SPI context, but just
2252 * in case it did, make sure we remain connected.
2253 */
2254 SPI_restore_connection();
2255 }
2256 PG_CATCH();
2257 {
2258 ErrorData *edata;
2259
2260 free(qdesc->argtypes);
2261 free(qdesc->arginfuncs);
2262 free(qdesc->argtypioparams);
2263 free(qdesc);
2264
2265 /* Save error info */
2266 MemoryContextSwitchTo(oldcontext);
2267 edata = CopyErrorData();
2268 FlushErrorState();
2269
2270 /* Abort the inner transaction */
2271 RollbackAndReleaseCurrentSubTransaction();
2272 MemoryContextSwitchTo(oldcontext);
2273 CurrentResourceOwner = oldowner;
2274
2275 /*
2276 * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
2277 * have left us in a disconnected state. We need this hack to return
2278 * to connected state.
2279 */
2280 SPI_restore_connection();
2281
2282 /* Punt the error to Perl */
2283 croak("%s", edata->message);
2284
2285 /* Can't get here, but keep compiler quiet */
2286 return NULL;
2287 }
2288 PG_END_TRY();
2289
2290 /************************************************************
2291 * Insert a hashtable entry for the plan and return
2292 * the key to the caller.
2293 ************************************************************/
2294
2295 hash_entry = hash_search(plperl_query_hash, qdesc->qname,
2296 HASH_ENTER, &found);
2297 hash_entry->query_data = qdesc;
2298
2299 return newSVstring(qdesc->qname);
2300 }
2301
2302 HV *
2303 plperl_spi_exec_prepared(char *query, HV *attr, int argc, SV **argv)
2304 {
2305 HV *ret_hv;
2306 SV **sv;
2307 int i,
2308 limit,
2309 spi_rv;
2310 char *nulls;
2311 Datum *argvalues;
2312 plperl_query_desc *qdesc;
2313 plperl_query_entry *hash_entry;
2314
2315 /*
2316 * Execute the query inside a sub-transaction, so we can cope with errors
2317 * sanely
2318 */
2319 MemoryContext oldcontext = CurrentMemoryContext;
2320 ResourceOwner oldowner = CurrentResourceOwner;
2321
2322 BeginInternalSubTransaction(NULL);
2323 /* Want to run inside function's memory context */
2324 MemoryContextSwitchTo(oldcontext);
2325
2326 PG_TRY();
2327 {
2328 /************************************************************
2329 * Fetch the saved plan descriptor, see if it's o.k.
2330 ************************************************************/
2331
2332 hash_entry = hash_search(plperl_query_hash, query,
2333 HASH_FIND, NULL);
2334 if (hash_entry == NULL)
2335 elog(ERROR, "spi_exec_prepared: Invalid prepared query passed");
2336
2337 qdesc = hash_entry->query_data;
2338
2339 if (qdesc == NULL)
2340 elog(ERROR, "spi_exec_prepared: panic - plperl_query_hash value vanished");
2341
2342 if (qdesc->nargs != argc)
2343 elog(ERROR, "spi_exec_prepared: expected %d argument(s), %d passed",
2344 qdesc->nargs, argc);
2345
2346 /************************************************************
2347 * Parse eventual attributes
2348 ************************************************************/
2349 limit = 0;
2350 if (attr != NULL)
2351 {
2352 sv = hv_fetch_string(attr, "limit");
2353 if (*sv && SvIOK(*sv))
2354 limit = SvIV(*sv);
2355 }
2356 /************************************************************
2357 * Set up arguments
2358 ************************************************************/
2359 if (argc > 0)
2360 {
2361 nulls = (char *) palloc(argc);
2362 argvalues = (Datum *) palloc(argc * sizeof(Datum));
2363 }
2364 else
2365 {
2366 nulls = NULL;
2367 argvalues = NULL;
2368 }
2369
2370 for (i = 0; i < argc; i++)
2371 {
2372 if (SvOK(argv[i]))
2373 {
2374 argvalues[i] = InputFunctionCall(&qdesc->arginfuncs[i],
2375 SvPV(argv[i], PL_na),
2376 qdesc->argtypioparams[i],
2377 -1);
2378 nulls[i] = ' ';
2379 }
2380 else
2381 {
2382 argvalues[i] = InputFunctionCall(&qdesc->arginfuncs[i],
2383 NULL,
2384 qdesc->argtypioparams[i],
2385 -1);
2386 nulls[i] = 'n';
2387 }
2388 }
2389
2390 /************************************************************
2391 * go
2392 ************************************************************/
2393 spi_rv = SPI_execute_plan(qdesc->plan, argvalues, nulls,
2394 current_call_data->prodesc->fn_readonly, limit);
2395 ret_hv = plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed,
2396 spi_rv);
2397 if (argc > 0)
2398 {
2399 pfree(argvalues);
2400 pfree(nulls);
2401 }
2402
2403 /* Commit the inner transaction, return to outer xact context */
2404 ReleaseCurrentSubTransaction();
2405 MemoryContextSwitchTo(oldcontext);
2406 CurrentResourceOwner = oldowner;
2407
2408 /*
2409 * AtEOSubXact_SPI() should not have popped any SPI context, but just
2410 * in case it did, make sure we remain connected.
2411 */
2412 SPI_restore_connection();
2413 }
2414 PG_CATCH();
2415 {
2416 ErrorData *edata;
2417
2418 /* Save error info */
2419 MemoryContextSwitchTo(oldcontext);
2420 edata = CopyErrorData();
2421 FlushErrorState();
2422
2423 /* Abort the inner transaction */
2424 RollbackAndReleaseCurrentSubTransaction();
2425 MemoryContextSwitchTo(oldcontext);
2426 CurrentResourceOwner = oldowner;
2427
2428 /*
2429 * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
2430 * have left us in a disconnected state. We need this hack to return
2431 * to connected state.
2432 */
2433 SPI_restore_connection();
2434
2435 /* Punt the error to Perl */
2436 croak("%s", edata->message);
2437
2438 /* Can't get here, but keep compiler quiet */
2439 return NULL;
2440 }
2441 PG_END_TRY();
2442
2443 return ret_hv;
2444 }
2445
2446 SV *
2447 plperl_spi_query_prepared(char *query, int argc, SV **argv)
2448 {
2449 int i;
2450 char *nulls;
2451 Datum *argvalues;
2452 plperl_query_desc *qdesc;
2453 plperl_query_entry *hash_entry;
2454 SV *cursor;
2455 Portal portal = NULL;
2456
2457 /*
2458 * Execute the query inside a sub-transaction, so we can cope with errors
2459 * sanely
2460 */
2461 MemoryContext oldcontext = CurrentMemoryContext;
2462 ResourceOwner oldowner = CurrentResourceOwner;
2463
2464 BeginInternalSubTransaction(NULL);
2465 /* Want to run inside function's memory context */
2466 MemoryContextSwitchTo(oldcontext);
2467
2468 PG_TRY();
2469 {
2470 /************************************************************
2471 * Fetch the saved plan descriptor, see if it's o.k.
2472 ************************************************************/
2473 hash_entry = hash_search(plperl_query_hash, query,
2474 HASH_FIND, NULL);
2475 if (hash_entry == NULL)
2476 elog(ERROR, "spi_exec_prepared: Invalid prepared query passed");
2477
2478 qdesc = hash_entry->query_data;
2479
2480 if (qdesc == NULL)
2481 elog(ERROR, "spi_query_prepared: panic - plperl_query_hash value vanished");
2482
2483 if (qdesc->nargs != argc)
2484 elog(ERROR, "spi_query_prepared: expected %d argument(s), %d passed",
2485 qdesc->nargs, argc);
2486
2487 /************************************************************
2488 * Set up arguments
2489 ************************************************************/
2490 if (argc > 0)
2491 {
2492 nulls = (char *) palloc(argc);
2493 argvalues = (Datum *) palloc(argc * sizeof(Datum));
2494 }
2495 else
2496 {
2497 nulls = NULL;
2498 argvalues = NULL;
2499 }
2500
2501 for (i = 0; i < argc; i++)
2502 {
2503 if (SvOK(argv[i]))
2504 {
2505 argvalues[i] = InputFunctionCall(&qdesc->arginfuncs[i],
2506 SvPV(argv[i], PL_na),
2507 qdesc->argtypioparams[i],
2508 -1);
2509 nulls[i] = ' ';
2510 }
2511 else
2512 {
2513 argvalues[i] = InputFunctionCall(&qdesc->arginfuncs[i],
2514 NULL,
2515 qdesc->argtypioparams[i],
2516 -1);
2517 nulls[i] = 'n';
2518 }
2519 }
2520
2521 /************************************************************
2522 * go
2523 ************************************************************/
2524 portal = SPI_cursor_open(NULL, qdesc->plan, argvalues, nulls,
2525 current_call_data->prodesc->fn_readonly);
2526 if (argc > 0)
2527 {
2528 pfree(argvalues);
2529 pfree(nulls);
2530 }
2531 if (portal == NULL)
2532 elog(ERROR, "SPI_cursor_open() failed:%s",
2533 SPI_result_code_string(SPI_result));
2534
2535 cursor = newSVstring(portal->name);
2536
2537 /* Commit the inner transaction, return to outer xact context */
2538 ReleaseCurrentSubTransaction();
2539 MemoryContextSwitchTo(oldcontext);
2540 CurrentResourceOwner = oldowner;
2541
2542 /*
2543 * AtEOSubXact_SPI() should not have popped any SPI context, but just
2544 * in case it did, make sure we remain connected.
2545 */
2546 SPI_restore_connection();
2547 }
2548 PG_CATCH();
2549 {
2550 ErrorData *edata;
2551
2552 /* Save error info */
2553 MemoryContextSwitchTo(oldcontext);
2554 edata = CopyErrorData();
2555 FlushErrorState();
2556
2557 /* Abort the inner transaction */
2558 RollbackAndReleaseCurrentSubTransaction();
2559 MemoryContextSwitchTo(oldcontext);
2560 CurrentResourceOwner = oldowner;
2561
2562 /*
2563 * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
2564 * have left us in a disconnected state. We need this hack to return
2565 * to connected state.
2566 */
2567 SPI_restore_connection();
2568
2569 /* Punt the error to Perl */
2570 croak("%s", edata->message);
2571
2572 /* Can't get here, but keep compiler quiet */
2573 return NULL;
2574 }
2575 PG_END_TRY();
2576
2577 return cursor;
2578 }
2579
2580 void
2581 plperl_spi_freeplan(char *query)
2582 {
2583 void *plan;
2584 plperl_query_desc *qdesc;
2585 plperl_query_entry *hash_entry;
2586
2587 hash_entry = hash_search(plperl_query_hash, query,
2588 HASH_FIND, NULL);
2589 if (hash_entry == NULL)
2590 elog(ERROR, "spi_exec_prepared: Invalid prepared query passed");
2591
2592 qdesc = hash_entry->query_data;
2593
2594 if (qdesc == NULL)
2595 elog(ERROR, "spi_exec_freeplan: panic - plperl_query_hash value vanished");
2596
2597 /*
2598 * free all memory before SPI_freeplan, so if it dies, nothing will be
2599 * left over
2600 */
2601 hash_search(plperl_query_hash, query,
2602 HASH_REMOVE, NULL);
2603
2604 plan = qdesc->plan;
2605 free(qdesc->argtypes);
2606 free(qdesc->arginfuncs);
2607 free(qdesc->argtypioparams);
2608 free(qdesc);
2609
2610 SPI_freeplan(plan);
2611 }
2612
2613 /*
2614 * Create a new SV from a string assumed to be in the current database's
2615 * encoding.
2616 */
2617 static SV *
2618 newSVstring(const char *str)
2619 {
2620 SV *sv;
2621
2622 sv = newSVpv(str, 0);
2623 #if PERL_BCDVERSION >= 0x5006000L
2624 if (GetDatabaseEncoding() == PG_UTF8)
2625 SvUTF8_on(sv);
2626 #endif
2627 return sv;
2628 }
2629
2630 /*
2631 * Store an SV into a hash table under a key that is a string assumed to be
2632 * in the current database's encoding.
2633 */
2634 static SV **
2635 hv_store_string(HV *hv, const char *key, SV *val)
2636 {
2637 int32 klen = strlen(key);
2638
2639 /*
2640 * This seems nowhere documented, but under Perl 5.8.0 and up, hv_store()
2641 * recognizes a negative klen parameter as meaning a UTF-8 encoded key. It
2642 * does not appear that hashes track UTF-8-ness of keys at all in Perl
2643 * 5.6.
2644 */
2645 #if PERL_BCDVERSION >= 0x5008000L
2646 if (GetDatabaseEncoding() == PG_UTF8)
2647 klen = -klen;
2648 #endif
2649 return hv_store(hv, key, klen, val, 0);
2650 }
2651
2652 /*
2653 * Fetch an SV from a hash table under a key that is a string assumed to be
2654 * in the current database's encoding.
2655 */
2656 static SV **
2657 hv_fetch_string(HV *hv, const char *key)
2658 {
2659 int32 klen = strlen(key);
2660
2661 /* See notes in hv_store_string */
2662 #if PERL_BCDVERSION >= 0x5008000L
2663 if (GetDatabaseEncoding() == PG_UTF8)
2664 klen = -klen;
2665 #endif
2666 return hv_fetch(hv, key, klen, 0);
2667 }
PostgreSQL from CVS