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