PostgreSQL Source Code  git master
 All Data Structures Namespaces Files Functions Variables Typedefs Enumerations Enumerator Macros
plperl.c
Go to the documentation of this file.
1 /**********************************************************************
2  * plperl.c - perl as a procedural language for PostgreSQL
3  *
4  * src/pl/plperl/plperl.c
5  *
6  **********************************************************************/
7 
8 #include "postgres.h"
9 
10 /* Defined by Perl */
11 #undef _
12 
13 /* system stuff */
14 #include <ctype.h>
15 #include <fcntl.h>
16 #include <limits.h>
17 #include <unistd.h>
18 
19 /* postgreSQL stuff */
20 #include "access/htup_details.h"
21 #include "access/xact.h"
22 #include "catalog/pg_language.h"
23 #include "catalog/pg_proc.h"
24 #include "catalog/pg_proc_fn.h"
25 #include "catalog/pg_type.h"
26 #include "commands/event_trigger.h"
27 #include "commands/trigger.h"
28 #include "executor/spi.h"
29 #include "funcapi.h"
30 #include "mb/pg_wchar.h"
31 #include "miscadmin.h"
32 #include "nodes/makefuncs.h"
33 #include "parser/parse_type.h"
34 #include "storage/ipc.h"
35 #include "tcop/tcopprot.h"
36 #include "utils/builtins.h"
37 #include "utils/fmgroids.h"
38 #include "utils/guc.h"
39 #include "utils/hsearch.h"
40 #include "utils/lsyscache.h"
41 #include "utils/memutils.h"
42 #include "utils/rel.h"
43 #include "utils/syscache.h"
44 #include "utils/typcache.h"
45 
46 /* define our text domain for translations */
47 #undef TEXTDOMAIN
48 #define TEXTDOMAIN PG_TEXTDOMAIN("plperl")
49 
50 /* perl stuff */
51 #include "plperl.h"
52 #include "plperl_helpers.h"
53 
54 /* string literal macros defining chunks of perl code */
55 #include "perlchunks.h"
56 /* defines PLPERL_SET_OPMASK */
57 #include "plperl_opmask.h"
58 
59 EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
62 
64 
65 /**********************************************************************
66  * Information associated with a Perl interpreter. We have one interpreter
67  * that is used for all plperlu (untrusted) functions. For plperl (trusted)
68  * functions, there is a separate interpreter for each effective SQL userid.
69  * (This is needed to ensure that an unprivileged user can't inject Perl code
70  * that'll be executed with the privileges of some other SQL user.)
71  *
72  * The plperl_interp_desc structs are kept in a Postgres hash table indexed
73  * by userid OID, with OID 0 used for the single untrusted interpreter.
74  * Once created, an interpreter is kept for the life of the process.
75  *
76  * We start out by creating a "held" interpreter, which we initialize
77  * only as far as we can do without deciding if it will be trusted or
78  * untrusted. Later, when we first need to run a plperl or plperlu
79  * function, we complete the initialization appropriately and move the
80  * PerlInterpreter pointer into the plperl_interp_hash hashtable. If after
81  * that we need more interpreters, we create them as needed if we can, or
82  * fail if the Perl build doesn't support multiple interpreters.
83  *
84  * The reason for all the dancing about with a held interpreter is to make
85  * it possible for people to preload a lot of Perl code at postmaster startup
86  * (using plperl.on_init) and then use that code in backends. Of course this
87  * will only work for the first interpreter created in any backend, but it's
88  * still useful with that restriction.
89  **********************************************************************/
90 typedef struct plperl_interp_desc
91 {
92  Oid user_id; /* Hash key (must be first!) */
93  PerlInterpreter *interp; /* The interpreter */
94  HTAB *query_hash; /* plperl_query_entry structs */
96 
97 
98 /**********************************************************************
99  * The information we cache about loaded procedures
100  *
101  * The fn_refcount field counts the struct's reference from the hash table
102  * shown below, plus one reference for each function call level that is using
103  * the struct. We can release the struct, and the associated Perl sub, when
104  * the fn_refcount goes to zero. Releasing the struct itself is done by
105  * deleting the fn_cxt, which also gets rid of all subsidiary data.
106  **********************************************************************/
107 typedef struct plperl_proc_desc
108 {
109  char *proname; /* user name of procedure */
110  MemoryContext fn_cxt; /* memory context for this procedure */
111  unsigned long fn_refcount; /* number of active references */
112  TransactionId fn_xmin; /* xmin/TID of procedure's pg_proc tuple */
114  SV *reference; /* CODE reference for Perl sub */
115  plperl_interp_desc *interp; /* interpreter it's created in */
116  bool fn_readonly; /* is function readonly (not volatile)? */
119  bool lanpltrusted; /* is it plperl, rather than plperlu? */
120  bool fn_retistuple; /* true, if function returns tuple */
121  bool fn_retisset; /* true, if function returns set */
122  bool fn_retisarray; /* true if function returns array */
123  /* Conversion info for function's result type: */
124  Oid result_oid; /* Oid of result type */
125  FmgrInfo result_in_func; /* I/O function and arg for result type */
127  /* Per-argument info for function's argument types: */
128  int nargs;
129  FmgrInfo *arg_out_func; /* output fns for arg types */
130  bool *arg_is_rowtype; /* is each arg composite? */
131  Oid *arg_arraytype; /* InvalidOid if not an array */
133 
134 #define increment_prodesc_refcount(prodesc) \
135  ((prodesc)->fn_refcount++)
136 #define decrement_prodesc_refcount(prodesc) \
137  do { \
138  Assert((prodesc)->fn_refcount > 0); \
139  if (--((prodesc)->fn_refcount) == 0) \
140  free_plperl_function(prodesc); \
141  } while(0)
142 
143 /**********************************************************************
144  * For speedy lookup, we maintain a hash table mapping from
145  * function OID + trigger flag + user OID to plperl_proc_desc pointers.
146  * The reason the plperl_proc_desc struct isn't directly part of the hash
147  * entry is to simplify recovery from errors during compile_plperl_function.
148  *
149  * Note: if the same function is called by multiple userIDs within a session,
150  * there will be a separate plperl_proc_desc entry for each userID in the case
151  * of plperl functions, but only one entry for plperlu functions, because we
152  * set user_id = 0 for that case. If the user redeclares the same function
153  * from plperl to plperlu or vice versa, there might be multiple
154  * plperl_proc_ptr entries in the hashtable, but only one is valid.
155  **********************************************************************/
156 typedef struct plperl_proc_key
157 {
158  Oid proc_id; /* Function OID */
159 
160  /*
161  * is_trigger is really a bool, but declare as Oid to ensure this struct
162  * contains no padding
163  */
164  Oid is_trigger; /* is it a trigger function? */
165  Oid user_id; /* User calling the function, or 0 */
167 
168 typedef struct plperl_proc_ptr
169 {
170  plperl_proc_key proc_key; /* Hash key (must be first!) */
173 
174 /*
175  * The information we cache for the duration of a single call to a
176  * function.
177  */
178 typedef struct plperl_call_data
179 {
186 
187 /**********************************************************************
188  * The information we cache about prepared and saved plans
189  **********************************************************************/
190 typedef struct plperl_query_desc
191 {
192  char qname[24];
193  MemoryContext plan_cxt; /* context holding this struct */
195  int nargs;
200 
201 /* hash table entry for query desc */
202 
203 typedef struct plperl_query_entry
204 {
208 
209 /**********************************************************************
210  * Information for PostgreSQL - Perl array conversion.
211  **********************************************************************/
212 typedef struct plperl_array_info
213 {
214  int ndims;
215  bool elem_is_rowtype; /* 't' if element type is a rowtype */
217  bool *nulls;
218  int *nelems;
222 
223 /**********************************************************************
224  * Global data
225  **********************************************************************/
226 
230 
231 /* If we have an unassigned "held" interpreter, it's stored here */
232 static PerlInterpreter *plperl_held_interp = NULL;
233 
234 /* GUC variables */
235 static bool plperl_use_strict = false;
236 static char *plperl_on_init = NULL;
239 
240 static bool plperl_ending = false;
241 static OP *(*pp_require_orig) (pTHX) = NULL;
242 static char plperl_opmask[MAXO];
243 
244 /* this is saved and restored by plperl_call_handler */
246 
247 /**********************************************************************
248  * Forward declarations
249  **********************************************************************/
250 void _PG_init(void);
251 
252 static PerlInterpreter *plperl_init_interp(void);
253 static void plperl_destroy_interp(PerlInterpreter **);
254 static void plperl_fini(int code, Datum arg);
255 static void set_interp_require(bool trusted);
256 
260 
261 static void free_plperl_function(plperl_proc_desc *prodesc);
262 
264  bool is_trigger,
265  bool is_event_trigger);
266 
267 static SV *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc);
268 static SV *plperl_hash_from_datum(Datum attr);
269 static SV *plperl_ref_from_pg_array(Datum arg, Oid typid);
270 static SV *split_array(plperl_array_info *info, int first, int last, int nest);
271 static SV *make_array_ref(plperl_array_info *info, int first, int last);
272 static SV *get_perl_array_ref(SV *sv);
273 static Datum plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod,
274  FunctionCallInfo fcinfo,
275  FmgrInfo *finfo, Oid typioparam,
276  bool *isnull);
277 static void _sv_to_datum_finfo(Oid typid, FmgrInfo *finfo, Oid *typioparam);
278 static Datum plperl_array_to_datum(SV *src, Oid typid, int32 typmod);
279 static void array_to_datum_internal(AV *av, ArrayBuildState *astate,
280  int *ndims, int *dims, int cur_depth,
281  Oid arraytypid, Oid elemtypid, int32 typmod,
282  FmgrInfo *finfo, Oid typioparam);
283 static Datum plperl_hash_to_datum(SV *src, TupleDesc td);
284 
285 static void plperl_init_shared_libs(pTHX);
286 static void plperl_trusted_init(void);
287 static void plperl_untrusted_init(void);
288 static HV *plperl_spi_execute_fetch_result(SPITupleTable *, uint64, int);
289 static void plperl_return_next_internal(SV *sv);
290 static char *hek2cstr(HE *he);
291 static SV **hv_store_string(HV *hv, const char *key, SV *val);
292 static SV **hv_fetch_string(HV *hv, const char *key);
293 static void plperl_create_sub(plperl_proc_desc *desc, char *s, Oid fn_oid);
294 static SV *plperl_call_perl_func(plperl_proc_desc *desc,
295  FunctionCallInfo fcinfo);
296 static void plperl_compile_callback(void *arg);
297 static void plperl_exec_callback(void *arg);
298 static void plperl_inline_callback(void *arg);
299 static char *strip_trailing_ws(const char *msg);
300 static OP *pp_require_safe(pTHX);
301 static void activate_interpreter(plperl_interp_desc *interp_desc);
302 
303 #ifdef WIN32
304 static char *setlocale_perl(int category, char *locale);
305 #endif
306 
307 /*
308  * Decrement the refcount of the given SV within the active Perl interpreter
309  *
310  * This is handy because it reloads the active-interpreter pointer, saving
311  * some notation in callers that switch the active interpreter.
312  */
313 static inline void
315 {
316  dTHX;
317 
318  SvREFCNT_dec(sv);
319 }
320 
321 /*
322  * convert a HE (hash entry) key to a cstr in the current database encoding
323  */
324 static char *
325 hek2cstr(HE *he)
326 {
327  dTHX;
328  char *ret;
329  SV *sv;
330 
331  /*
332  * HeSVKEY_force will return a temporary mortal SV*, so we need to make
333  * sure to free it with ENTER/SAVE/FREE/LEAVE
334  */
335  ENTER;
336  SAVETMPS;
337 
338  /*-------------------------
339  * Unfortunately, while HeUTF8 is true for most things > 256, for values
340  * 128..255 it's not, but perl will treat them as unicode code points if
341  * the utf8 flag is not set ( see The "Unicode Bug" in perldoc perlunicode
342  * for more)
343  *
344  * So if we did the expected:
345  * if (HeUTF8(he))
346  * utf_u2e(key...);
347  * else // must be ascii
348  * return HePV(he);
349  * we won't match columns with codepoints from 128..255
350  *
351  * For a more concrete example given a column with the name of the unicode
352  * codepoint U+00ae (registered sign) and a UTF8 database and the perl
353  * return_next { "\N{U+00ae}=>'text } would always fail as heUTF8 returns
354  * 0 and HePV() would give us a char * with 1 byte contains the decimal
355  * value 174
356  *
357  * Perl has the brains to know when it should utf8 encode 174 properly, so
358  * here we force it into an SV so that perl will figure it out and do the
359  * right thing
360  *-------------------------
361  */
362 
363  sv = HeSVKEY_force(he);
364  if (HeUTF8(he))
365  SvUTF8_on(sv);
366  ret = sv2cstr(sv);
367 
368  /* free sv */
369  FREETMPS;
370  LEAVE;
371 
372  return ret;
373 }
374 
375 
376 /*
377  * _PG_init() - library load-time initialization
378  *
379  * DO NOT make this static nor change its name!
380  */
381 void
382 _PG_init(void)
383 {
384  /*
385  * Be sure we do initialization only once.
386  *
387  * If initialization fails due to, e.g., plperl_init_interp() throwing an
388  * exception, then we'll return here on the next usage and the user will
389  * get a rather cryptic: ERROR: attempt to redefine parameter
390  * "plperl.use_strict"
391  */
392  static bool inited = false;
393  HASHCTL hash_ctl;
394 
395  if (inited)
396  return;
397 
398  /*
399  * Support localized messages.
400  */
402 
403  /*
404  * Initialize plperl's GUCs.
405  */
406  DefineCustomBoolVariable("plperl.use_strict",
407  gettext_noop("If true, trusted and untrusted Perl code will be compiled in strict mode."),
408  NULL,
410  false,
411  PGC_USERSET, 0,
412  NULL, NULL, NULL);
413 
414  /*
415  * plperl.on_init is marked PGC_SIGHUP to support the idea that it might
416  * be executed in the postmaster (if plperl is loaded into the postmaster
417  * via shared_preload_libraries). This isn't really right either way,
418  * though.
419  */
420  DefineCustomStringVariable("plperl.on_init",
421  gettext_noop("Perl initialization code to execute when a Perl interpreter is initialized."),
422  NULL,
424  NULL,
425  PGC_SIGHUP, 0,
426  NULL, NULL, NULL);
427 
428  /*
429  * plperl.on_plperl_init is marked PGC_SUSET to avoid issues whereby a
430  * user who might not even have USAGE privilege on the plperl language
431  * could nonetheless use SET plperl.on_plperl_init='...' to influence the
432  * behaviour of any existing plperl function that they can execute (which
433  * might be SECURITY DEFINER, leading to a privilege escalation). See
434  * http://archives.postgresql.org/pgsql-hackers/2010-02/msg00281.php and
435  * the overall thread.
436  *
437  * Note that because plperl.use_strict is USERSET, a nefarious user could
438  * set it to be applied against other people's functions. This is judged
439  * OK since the worst result would be an error. Your code oughta pass
440  * use_strict anyway ;-)
441  */
442  DefineCustomStringVariable("plperl.on_plperl_init",
443  gettext_noop("Perl initialization code to execute once when plperl is first used."),
444  NULL,
446  NULL,
447  PGC_SUSET, 0,
448  NULL, NULL, NULL);
449 
450  DefineCustomStringVariable("plperl.on_plperlu_init",
451  gettext_noop("Perl initialization code to execute once when plperlu is first used."),
452  NULL,
454  NULL,
455  PGC_SUSET, 0,
456  NULL, NULL, NULL);
457 
458  EmitWarningsOnPlaceholders("plperl");
459 
460  /*
461  * Create hash tables.
462  */
463  memset(&hash_ctl, 0, sizeof(hash_ctl));
464  hash_ctl.keysize = sizeof(Oid);
465  hash_ctl.entrysize = sizeof(plperl_interp_desc);
466  plperl_interp_hash = hash_create("PL/Perl interpreters",
467  8,
468  &hash_ctl,
470 
471  memset(&hash_ctl, 0, sizeof(hash_ctl));
472  hash_ctl.keysize = sizeof(plperl_proc_key);
473  hash_ctl.entrysize = sizeof(plperl_proc_ptr);
474  plperl_proc_hash = hash_create("PL/Perl procedures",
475  32,
476  &hash_ctl,
478 
479  /*
480  * Save the default opmask.
481  */
482  PLPERL_SET_OPMASK(plperl_opmask);
483 
484  /*
485  * Create the first Perl interpreter, but only partially initialize it.
486  */
488 
489  inited = true;
490 }
491 
492 
493 static void
494 set_interp_require(bool trusted)
495 {
496  if (trusted)
497  {
498  PL_ppaddr[OP_REQUIRE] = pp_require_safe;
499  PL_ppaddr[OP_DOFILE] = pp_require_safe;
500  }
501  else
502  {
503  PL_ppaddr[OP_REQUIRE] = pp_require_orig;
504  PL_ppaddr[OP_DOFILE] = pp_require_orig;
505  }
506 }
507 
508 /*
509  * Cleanup perl interpreters, including running END blocks.
510  * Does not fully undo the actions of _PG_init() nor make it callable again.
511  */
512 static void
514 {
515  HASH_SEQ_STATUS hash_seq;
516  plperl_interp_desc *interp_desc;
517 
518  elog(DEBUG3, "plperl_fini");
519 
520  /*
521  * Indicate that perl is terminating. Disables use of spi_* functions when
522  * running END/DESTROY code. See check_spi_usage_allowed(). Could be
523  * enabled in future, with care, using a transaction
524  * http://archives.postgresql.org/pgsql-hackers/2010-01/msg02743.php
525  */
526  plperl_ending = true;
527 
528  /* Only perform perl cleanup if we're exiting cleanly */
529  if (code)
530  {
531  elog(DEBUG3, "plperl_fini: skipped");
532  return;
533  }
534 
535  /* Zap the "held" interpreter, if we still have it */
537 
538  /* Zap any fully-initialized interpreters */
539  hash_seq_init(&hash_seq, plperl_interp_hash);
540  while ((interp_desc = hash_seq_search(&hash_seq)) != NULL)
541  {
542  if (interp_desc->interp)
543  {
544  activate_interpreter(interp_desc);
545  plperl_destroy_interp(&interp_desc->interp);
546  }
547  }
548 
549  elog(DEBUG3, "plperl_fini: done");
550 }
551 
552 
553 /*
554  * Select and activate an appropriate Perl interpreter.
555  */
556 static void
557 select_perl_context(bool trusted)
558 {
559  Oid user_id;
560  plperl_interp_desc *interp_desc;
561  bool found;
562  PerlInterpreter *interp = NULL;
563 
564  /* Find or create the interpreter hashtable entry for this userid */
565  if (trusted)
566  user_id = GetUserId();
567  else
568  user_id = InvalidOid;
569 
570  interp_desc = hash_search(plperl_interp_hash, &user_id,
571  HASH_ENTER,
572  &found);
573  if (!found)
574  {
575  /* Initialize newly-created hashtable entry */
576  interp_desc->interp = NULL;
577  interp_desc->query_hash = NULL;
578  }
579 
580  /* Make sure we have a query_hash for this interpreter */
581  if (interp_desc->query_hash == NULL)
582  {
583  HASHCTL hash_ctl;
584 
585  memset(&hash_ctl, 0, sizeof(hash_ctl));
586  hash_ctl.keysize = NAMEDATALEN;
587  hash_ctl.entrysize = sizeof(plperl_query_entry);
588  interp_desc->query_hash = hash_create("PL/Perl queries",
589  32,
590  &hash_ctl,
591  HASH_ELEM);
592  }
593 
594  /*
595  * Quick exit if already have an interpreter
596  */
597  if (interp_desc->interp)
598  {
599  activate_interpreter(interp_desc);
600  return;
601  }
602 
603  /*
604  * adopt held interp if free, else create new one if possible
605  */
606  if (plperl_held_interp != NULL)
607  {
608  /* first actual use of a perl interpreter */
609  interp = plperl_held_interp;
610 
611  /*
612  * Reset the plperl_held_interp pointer first; if we fail during init
613  * we don't want to try again with the partially-initialized interp.
614  */
616 
617  if (trusted)
619  else
621 
622  /* successfully initialized, so arrange for cleanup */
624  }
625  else
626  {
627 #ifdef MULTIPLICITY
628 
629  /*
630  * plperl_init_interp will change Perl's idea of the active
631  * interpreter. Reset plperl_active_interp temporarily, so that if we
632  * hit an error partway through here, we'll make sure to switch back
633  * to a non-broken interpreter before running any other Perl
634  * functions.
635  */
636  plperl_active_interp = NULL;
637 
638  /* Now build the new interpreter */
639  interp = plperl_init_interp();
640 
641  if (trusted)
643  else
645 #else
646  ereport(ERROR,
647  (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
648  errmsg("cannot allocate multiple Perl interpreters on this platform")));
649 #endif
650  }
651 
652  set_interp_require(trusted);
653 
654  /*
655  * Since the timing of first use of PL/Perl can't be predicted, any
656  * database interaction during initialization is problematic. Including,
657  * but not limited to, security definer issues. So we only enable access
658  * to the database AFTER on_*_init code has run. See
659  * http://archives.postgresql.org/pgsql-hackers/2010-01/msg02669.php
660  */
661  {
662  dTHX;
663 
664  newXS("PostgreSQL::InServer::SPI::bootstrap",
666 
667  eval_pv("PostgreSQL::InServer::SPI::bootstrap()", FALSE);
668  if (SvTRUE(ERRSV))
669  ereport(ERROR,
670  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
672  errcontext("while executing PostgreSQL::InServer::SPI::bootstrap")));
673  }
674 
675  /* Fully initialized, so mark the hashtable entry valid */
676  interp_desc->interp = interp;
677 
678  /* And mark this as the active interpreter */
679  plperl_active_interp = interp_desc;
680 }
681 
682 /*
683  * Make the specified interpreter the active one
684  *
685  * A call with NULL does nothing. This is so that "restoring" to a previously
686  * null state of plperl_active_interp doesn't result in useless thrashing.
687  */
688 static void
690 {
691  if (interp_desc && plperl_active_interp != interp_desc)
692  {
693  Assert(interp_desc->interp);
694  PERL_SET_CONTEXT(interp_desc->interp);
695  /* trusted iff user_id isn't InvalidOid */
696  set_interp_require(OidIsValid(interp_desc->user_id));
697  plperl_active_interp = interp_desc;
698  }
699 }
700 
701 /*
702  * Create a new Perl interpreter.
703  *
704  * We initialize the interpreter as far as we can without knowing whether
705  * it will become a trusted or untrusted interpreter; in particular, the
706  * plperl.on_init code will get executed. Later, either plperl_trusted_init
707  * or plperl_untrusted_init must be called to complete the initialization.
708  */
709 static PerlInterpreter *
711 {
712  PerlInterpreter *plperl;
713 
714  static char *embedding[3 + 2] = {
715  "", "-e", PLC_PERLBOOT
716  };
717  int nargs = 3;
718 
719 #ifdef WIN32
720 
721  /*
722  * The perl library on startup does horrible things like call
723  * setlocale(LC_ALL,""). We have protected against that on most platforms
724  * by setting the environment appropriately. However, on Windows,
725  * setlocale() does not consult the environment, so we need to save the
726  * existing locale settings before perl has a chance to mangle them and
727  * restore them after its dirty deeds are done.
728  *
729  * MSDN ref:
730  * http://msdn.microsoft.com/library/en-us/vclib/html/_crt_locale.asp
731  *
732  * It appears that we only need to do this on interpreter startup, and
733  * subsequent calls to the interpreter don't mess with the locale
734  * settings.
735  *
736  * We restore them using setlocale_perl(), defined below, so that Perl
737  * doesn't have a different idea of the locale from Postgres.
738  *
739  */
740 
741  char *loc;
742  char *save_collate,
743  *save_ctype,
744  *save_monetary,
745  *save_numeric,
746  *save_time;
747 
748  loc = setlocale(LC_COLLATE, NULL);
749  save_collate = loc ? pstrdup(loc) : NULL;
750  loc = setlocale(LC_CTYPE, NULL);
751  save_ctype = loc ? pstrdup(loc) : NULL;
752  loc = setlocale(LC_MONETARY, NULL);
753  save_monetary = loc ? pstrdup(loc) : NULL;
754  loc = setlocale(LC_NUMERIC, NULL);
755  save_numeric = loc ? pstrdup(loc) : NULL;
756  loc = setlocale(LC_TIME, NULL);
757  save_time = loc ? pstrdup(loc) : NULL;
758 
759 #define PLPERL_RESTORE_LOCALE(name, saved) \
760  STMT_START { \
761  if (saved != NULL) { setlocale_perl(name, saved); pfree(saved); } \
762  } STMT_END
763 #endif /* WIN32 */
764 
766  {
767  embedding[nargs++] = "-e";
768  embedding[nargs++] = plperl_on_init;
769  }
770 
771  /*
772  * The perl API docs state that PERL_SYS_INIT3 should be called before
773  * allocating interpreters. Unfortunately, on some platforms this fails in
774  * the Perl_do_taint() routine, which is called when the platform is using
775  * the system's malloc() instead of perl's own. Other platforms, notably
776  * Windows, fail if PERL_SYS_INIT3 is not called. So we call it if it's
777  * available, unless perl is using the system malloc(), which is true when
778  * MYMALLOC is set.
779  */
780 #if defined(PERL_SYS_INIT3) && !defined(MYMALLOC)
781  {
782  static int perl_sys_init_done;
783 
784  /* only call this the first time through, as per perlembed man page */
785  if (!perl_sys_init_done)
786  {
787  char *dummy_env[1] = {NULL};
788 
789  PERL_SYS_INIT3(&nargs, (char ***) &embedding, (char ***) &dummy_env);
790 
791  /*
792  * For unclear reasons, PERL_SYS_INIT3 sets the SIGFPE handler to
793  * SIG_IGN. Aside from being extremely unfriendly behavior for a
794  * library, this is dumb on the grounds that the results of a
795  * SIGFPE in this state are undefined according to POSIX, and in
796  * fact you get a forced process kill at least on Linux. Hence,
797  * restore the SIGFPE handler to the backend's standard setting.
798  * (See Perl bug 114574 for more information.)
799  */
801 
802  perl_sys_init_done = 1;
803  /* quiet warning if PERL_SYS_INIT3 doesn't use the third argument */
804  dummy_env[0] = NULL;
805  }
806  }
807 #endif
808 
809  plperl = perl_alloc();
810  if (!plperl)
811  elog(ERROR, "could not allocate Perl interpreter");
812 
813  PERL_SET_CONTEXT(plperl);
814  perl_construct(plperl);
815 
816  /*
817  * Run END blocks in perl_destruct instead of perl_run. Note that dTHX
818  * loads up a pointer to the current interpreter, so we have to postpone
819  * it to here rather than put it at the function head.
820  */
821  {
822  dTHX;
823 
824  PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
825 
826  /*
827  * Record the original function for the 'require' and 'dofile'
828  * opcodes. (They share the same implementation.) Ensure it's used
829  * for new interpreters.
830  */
831  if (!pp_require_orig)
832  pp_require_orig = PL_ppaddr[OP_REQUIRE];
833  else
834  {
835  PL_ppaddr[OP_REQUIRE] = pp_require_orig;
836  PL_ppaddr[OP_DOFILE] = pp_require_orig;
837  }
838 
839 #ifdef PLPERL_ENABLE_OPMASK_EARLY
840 
841  /*
842  * For regression testing to prove that the PLC_PERLBOOT and
843  * PLC_TRUSTED code doesn't even compile any unsafe ops. In future
844  * there may be a valid need for them to do so, in which case this
845  * could be softened (perhaps moved to plperl_trusted_init()) or
846  * removed.
847  */
848  PL_op_mask = plperl_opmask;
849 #endif
850 
851  if (perl_parse(plperl, plperl_init_shared_libs,
852  nargs, embedding, NULL) != 0)
853  ereport(ERROR,
854  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
856  errcontext("while parsing Perl initialization")));
857 
858  if (perl_run(plperl) != 0)
859  ereport(ERROR,
860  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
862  errcontext("while running Perl initialization")));
863 
864 #ifdef PLPERL_RESTORE_LOCALE
865  PLPERL_RESTORE_LOCALE(LC_COLLATE, save_collate);
866  PLPERL_RESTORE_LOCALE(LC_CTYPE, save_ctype);
867  PLPERL_RESTORE_LOCALE(LC_MONETARY, save_monetary);
868  PLPERL_RESTORE_LOCALE(LC_NUMERIC, save_numeric);
869  PLPERL_RESTORE_LOCALE(LC_TIME, save_time);
870 #endif
871  }
872 
873  return plperl;
874 }
875 
876 
877 /*
878  * Our safe implementation of the require opcode.
879  * This is safe because it's completely unable to load any code.
880  * If the requested file/module has already been loaded it'll return true.
881  * If not, it'll die.
882  * So now "use Foo;" will work iff Foo has already been loaded.
883  */
884 static OP *
886 {
887  dVAR;
888  dSP;
889  SV *sv,
890  **svp;
891  char *name;
892  STRLEN len;
893 
894  sv = POPs;
895  name = SvPV(sv, len);
896  if (!(name && len > 0 && *name))
897  RETPUSHNO;
898 
899  svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
900  if (svp && *svp != &PL_sv_undef)
901  RETPUSHYES;
902 
903  DIE(aTHX_ "Unable to load %s into plperl", name);
904 
905  /*
906  * In most Perl versions, DIE() expands to a return statement, so the next
907  * line is not necessary. But in versions between but not including
908  * 5.11.1 and 5.13.3 it does not, so the next line is necessary to avoid a
909  * "control reaches end of non-void function" warning from gcc. Other
910  * compilers such as Solaris Studio will, however, issue a "statement not
911  * reached" warning instead.
912  */
913  return NULL;
914 }
915 
916 
917 /*
918  * Destroy one Perl interpreter ... actually we just run END blocks.
919  *
920  * Caller must have ensured this interpreter is the active one.
921  */
922 static void
923 plperl_destroy_interp(PerlInterpreter **interp)
924 {
925  if (interp && *interp)
926  {
927  /*
928  * Only a very minimal destruction is performed: - just call END
929  * blocks.
930  *
931  * We could call perl_destruct() but we'd need to audit its actions
932  * very carefully and work-around any that impact us. (Calling
933  * sv_clean_objs() isn't an option because it's not part of perl's
934  * public API so isn't portably available.) Meanwhile END blocks can
935  * be used to perform manual cleanup.
936  */
937  dTHX;
938 
939  /* Run END blocks - based on perl's perl_destruct() */
940  if (PL_exit_flags & PERL_EXIT_DESTRUCT_END)
941  {
942  dJMPENV;
943  int x = 0;
944 
945  JMPENV_PUSH(x);
946  PERL_UNUSED_VAR(x);
947  if (PL_endav && !PL_minus_c)
948  call_list(PL_scopestack_ix, PL_endav);
949  JMPENV_POP;
950  }
951  LEAVE;
952  FREETMPS;
953 
954  *interp = NULL;
955  }
956 }
957 
958 /*
959  * Initialize the current Perl interpreter as a trusted interp
960  */
961 static void
963 {
964  dTHX;
965  HV *stash;
966  SV *sv;
967  char *key;
968  I32 klen;
969 
970  /* use original require while we set up */
971  PL_ppaddr[OP_REQUIRE] = pp_require_orig;
972  PL_ppaddr[OP_DOFILE] = pp_require_orig;
973 
974  eval_pv(PLC_TRUSTED, FALSE);
975  if (SvTRUE(ERRSV))
976  ereport(ERROR,
977  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
979  errcontext("while executing PLC_TRUSTED")));
980 
981  /*
982  * Force loading of utf8 module now to prevent errors that can arise from
983  * the regex code later trying to load utf8 modules. See
984  * http://rt.perl.org/rt3/Ticket/Display.html?id=47576
985  */
986  eval_pv("my $a=chr(0x100); return $a =~ /\\xa9/i", FALSE);
987  if (SvTRUE(ERRSV))
988  ereport(ERROR,
989  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
991  errcontext("while executing utf8fix")));
992 
993  /*
994  * Lock down the interpreter
995  */
996 
997  /* switch to the safe require/dofile opcode for future code */
998  PL_ppaddr[OP_REQUIRE] = pp_require_safe;
999  PL_ppaddr[OP_DOFILE] = pp_require_safe;
1000 
1001  /*
1002  * prevent (any more) unsafe opcodes being compiled PL_op_mask is per
1003  * interpreter, so this only needs to be set once
1004  */
1005  PL_op_mask = plperl_opmask;
1006 
1007  /* delete the DynaLoader:: namespace so extensions can't be loaded */
1008  stash = gv_stashpv("DynaLoader", GV_ADDWARN);
1009  hv_iterinit(stash);
1010  while ((sv = hv_iternextsv(stash, &key, &klen)))
1011  {
1012  if (!isGV_with_GP(sv) || !GvCV(sv))
1013  continue;
1014  SvREFCNT_dec(GvCV(sv)); /* free the CV */
1015  GvCV_set(sv, NULL); /* prevent call via GV */
1016  }
1017  hv_clear(stash);
1018 
1019  /* invalidate assorted caches */
1020  ++PL_sub_generation;
1021  hv_clear(PL_stashcache);
1022 
1023  /*
1024  * Execute plperl.on_plperl_init in the locked-down interpreter
1025  */
1027  {
1029  /* XXX need to find a way to determine a better errcode here */
1030  if (SvTRUE(ERRSV))
1031  ereport(ERROR,
1032  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
1034  errcontext("while executing plperl.on_plperl_init")));
1035  }
1036 }
1037 
1038 
1039 /*
1040  * Initialize the current Perl interpreter as an untrusted interp
1041  */
1042 static void
1044 {
1045  dTHX;
1046 
1047  /*
1048  * Nothing to do except execute plperl.on_plperlu_init
1049  */
1051  {
1053  if (SvTRUE(ERRSV))
1054  ereport(ERROR,
1055  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
1057  errcontext("while executing plperl.on_plperlu_init")));
1058  }
1059 }
1060 
1061 
1062 /*
1063  * Perl likes to put a newline after its error messages; clean up such
1064  */
1065 static char *
1066 strip_trailing_ws(const char *msg)
1067 {
1068  char *res = pstrdup(msg);
1069  int len = strlen(res);
1070 
1071  while (len > 0 && isspace((unsigned char) res[len - 1]))
1072  res[--len] = '\0';
1073  return res;
1074 }
1075 
1076 
1077 /* Build a tuple from a hash. */
1078 
1079 static HeapTuple
1081 {
1082  dTHX;
1083  Datum *values;
1084  bool *nulls;
1085  HE *he;
1086  HeapTuple tup;
1087 
1088  values = palloc0(sizeof(Datum) * td->natts);
1089  nulls = palloc(sizeof(bool) * td->natts);
1090  memset(nulls, true, sizeof(bool) * td->natts);
1091 
1092  hv_iterinit(perlhash);
1093  while ((he = hv_iternext(perlhash)))
1094  {
1095  SV *val = HeVAL(he);
1096  char *key = hek2cstr(he);
1097  int attn = SPI_fnumber(td, key);
1098 
1099  if (attn == SPI_ERROR_NOATTRIBUTE)
1100  ereport(ERROR,
1101  (errcode(ERRCODE_UNDEFINED_COLUMN),
1102  errmsg("Perl hash contains nonexistent column \"%s\"",
1103  key)));
1104  if (attn <= 0)
1105  ereport(ERROR,
1106  (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1107  errmsg("cannot set system attribute \"%s\"",
1108  key)));
1109 
1110  values[attn - 1] = plperl_sv_to_datum(val,
1111  td->attrs[attn - 1]->atttypid,
1112  td->attrs[attn - 1]->atttypmod,
1113  NULL,
1114  NULL,
1115  InvalidOid,
1116  &nulls[attn - 1]);
1117 
1118  pfree(key);
1119  }
1120  hv_iterinit(perlhash);
1121 
1122  tup = heap_form_tuple(td, values, nulls);
1123  pfree(values);
1124  pfree(nulls);
1125  return tup;
1126 }
1127 
1128 /* convert a hash reference to a datum */
1129 static Datum
1131 {
1132  HeapTuple tup = plperl_build_tuple_result((HV *) SvRV(src), td);
1133 
1134  return HeapTupleGetDatum(tup);
1135 }
1136 
1137 /*
1138  * if we are an array ref return the reference. this is special in that if we
1139  * are a PostgreSQL::InServer::ARRAY object we will return the 'magic' array.
1140  */
1141 static SV *
1143 {
1144  dTHX;
1145 
1146  if (SvOK(sv) && SvROK(sv))
1147  {
1148  if (SvTYPE(SvRV(sv)) == SVt_PVAV)
1149  return sv;
1150  else if (sv_isa(sv, "PostgreSQL::InServer::ARRAY"))
1151  {
1152  HV *hv = (HV *) SvRV(sv);
1153  SV **sav = hv_fetch_string(hv, "array");
1154 
1155  if (*sav && SvOK(*sav) && SvROK(*sav) &&
1156  SvTYPE(SvRV(*sav)) == SVt_PVAV)
1157  return *sav;
1158 
1159  elog(ERROR, "could not get array reference from PostgreSQL::InServer::ARRAY object");
1160  }
1161  }
1162  return NULL;
1163 }
1164 
1165 /*
1166  * helper function for plperl_array_to_datum, recurses for multi-D arrays
1167  */
1168 static void
1170  int *ndims, int *dims, int cur_depth,
1171  Oid arraytypid, Oid elemtypid, int32 typmod,
1172  FmgrInfo *finfo, Oid typioparam)
1173 {
1174  dTHX;
1175  int i;
1176  int len = av_len(av) + 1;
1177 
1178  for (i = 0; i < len; i++)
1179  {
1180  /* fetch the array element */
1181  SV **svp = av_fetch(av, i, FALSE);
1182 
1183  /* see if this element is an array, if so get that */
1184  SV *sav = svp ? get_perl_array_ref(*svp) : NULL;
1185 
1186  /* multi-dimensional array? */
1187  if (sav)
1188  {
1189  AV *nav = (AV *) SvRV(sav);
1190 
1191  /* dimensionality checks */
1192  if (cur_depth + 1 > MAXDIM)
1193  ereport(ERROR,
1194  (errcode(ERRCODE_PROGRAM_LIMIT_EXCEEDED),
1195  errmsg("number of array dimensions (%d) exceeds the maximum allowed (%d)",
1196  cur_depth + 1, MAXDIM)));
1197 
1198  /* set size when at first element in this level, else compare */
1199  if (i == 0 && *ndims == cur_depth)
1200  {
1201  dims[*ndims] = av_len(nav) + 1;
1202  (*ndims)++;
1203  }
1204  else if (av_len(nav) + 1 != dims[cur_depth])
1205  ereport(ERROR,
1206  (errcode(ERRCODE_INVALID_TEXT_REPRESENTATION),
1207  errmsg("multidimensional arrays must have array expressions with matching dimensions")));
1208 
1209  /* recurse to fetch elements of this sub-array */
1210  array_to_datum_internal(nav, astate,
1211  ndims, dims, cur_depth + 1,
1212  arraytypid, elemtypid, typmod,
1213  finfo, typioparam);
1214  }
1215  else
1216  {
1217  Datum dat;
1218  bool isnull;
1219 
1220  /* scalar after some sub-arrays at same level? */
1221  if (*ndims != cur_depth)
1222  ereport(ERROR,
1223  (errcode(ERRCODE_INVALID_TEXT_REPRESENTATION),
1224  errmsg("multidimensional arrays must have array expressions with matching dimensions")));
1225 
1226  dat = plperl_sv_to_datum(svp ? *svp : NULL,
1227  elemtypid,
1228  typmod,
1229  NULL,
1230  finfo,
1231  typioparam,
1232  &isnull);
1233 
1234  (void) accumArrayResult(astate, dat, isnull,
1235  elemtypid, CurrentMemoryContext);
1236  }
1237  }
1238 }
1239 
1240 /*
1241  * convert perl array ref to a datum
1242  */
1243 static Datum
1244 plperl_array_to_datum(SV *src, Oid typid, int32 typmod)
1245 {
1246  dTHX;
1247  ArrayBuildState *astate;
1248  Oid elemtypid;
1249  FmgrInfo finfo;
1250  Oid typioparam;
1251  int dims[MAXDIM];
1252  int lbs[MAXDIM];
1253  int ndims = 1;
1254  int i;
1255 
1256  elemtypid = get_element_type(typid);
1257  if (!elemtypid)
1258  ereport(ERROR,
1259  (errcode(ERRCODE_DATATYPE_MISMATCH),
1260  errmsg("cannot convert Perl array to non-array type %s",
1261  format_type_be(typid))));
1262 
1263  astate = initArrayResult(elemtypid, CurrentMemoryContext, true);
1264 
1265  _sv_to_datum_finfo(elemtypid, &finfo, &typioparam);
1266 
1267  memset(dims, 0, sizeof(dims));
1268  dims[0] = av_len((AV *) SvRV(src)) + 1;
1269 
1270  array_to_datum_internal((AV *) SvRV(src), astate,
1271  &ndims, dims, 1,
1272  typid, elemtypid, typmod,
1273  &finfo, typioparam);
1274 
1275  /* ensure we get zero-D array for no inputs, as per PG convention */
1276  if (dims[0] <= 0)
1277  ndims = 0;
1278 
1279  for (i = 0; i < ndims; i++)
1280  lbs[i] = 1;
1281 
1282  return makeMdArrayResult(astate, ndims, dims, lbs,
1283  CurrentMemoryContext, true);
1284 }
1285 
1286 /* Get the information needed to convert data to the specified PG type */
1287 static void
1288 _sv_to_datum_finfo(Oid typid, FmgrInfo *finfo, Oid *typioparam)
1289 {
1290  Oid typinput;
1291 
1292  /* XXX would be better to cache these lookups */
1293  getTypeInputInfo(typid,
1294  &typinput, typioparam);
1295  fmgr_info(typinput, finfo);
1296 }
1297 
1298 /*
1299  * convert Perl SV to PG datum of type typid, typmod typmod
1300  *
1301  * Pass the PL/Perl function's fcinfo when attempting to convert to the
1302  * function's result type; otherwise pass NULL. This is used when we need to
1303  * resolve the actual result type of a function returning RECORD.
1304  *
1305  * finfo and typioparam should be the results of _sv_to_datum_finfo for the
1306  * given typid, or NULL/InvalidOid to let this function do the lookups.
1307  *
1308  * *isnull is an output parameter.
1309  */
1310 static Datum
1311 plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod,
1312  FunctionCallInfo fcinfo,
1313  FmgrInfo *finfo, Oid typioparam,
1314  bool *isnull)
1315 {
1316  FmgrInfo tmp;
1317  Oid funcid;
1318 
1319  /* we might recurse */
1321 
1322  *isnull = false;
1323 
1324  /*
1325  * Return NULL if result is undef, or if we're in a function returning
1326  * VOID. In the latter case, we should pay no attention to the last Perl
1327  * statement's result, and this is a convenient means to ensure that.
1328  */
1329  if (!sv || !SvOK(sv) || typid == VOIDOID)
1330  {
1331  /* look up type info if they did not pass it */
1332  if (!finfo)
1333  {
1334  _sv_to_datum_finfo(typid, &tmp, &typioparam);
1335  finfo = &tmp;
1336  }
1337  *isnull = true;
1338  /* must call typinput in case it wants to reject NULL */
1339  return InputFunctionCall(finfo, NULL, typioparam, typmod);
1340  }
1341  else if ((funcid = get_transform_tosql(typid, current_call_data->prodesc->lang_oid, current_call_data->prodesc->trftypes)))
1342  return OidFunctionCall1(funcid, PointerGetDatum(sv));
1343  else if (SvROK(sv))
1344  {
1345  /* handle references */
1346  SV *sav = get_perl_array_ref(sv);
1347 
1348  if (sav)
1349  {
1350  /* handle an arrayref */
1351  return plperl_array_to_datum(sav, typid, typmod);
1352  }
1353  else if (SvTYPE(SvRV(sv)) == SVt_PVHV)
1354  {
1355  /* handle a hashref */
1356  Datum ret;
1357  TupleDesc td;
1358 
1359  if (!type_is_rowtype(typid))
1360  ereport(ERROR,
1361  (errcode(ERRCODE_DATATYPE_MISMATCH),
1362  errmsg("cannot convert Perl hash to non-composite type %s",
1363  format_type_be(typid))));
1364 
1365  td = lookup_rowtype_tupdesc_noerror(typid, typmod, true);
1366  if (td == NULL)
1367  {
1368  /* Try to look it up based on our result type */
1369  if (fcinfo == NULL ||
1370  get_call_result_type(fcinfo, NULL, &td) != TYPEFUNC_COMPOSITE)
1371  ereport(ERROR,
1372  (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1373  errmsg("function returning record called in context "
1374  "that cannot accept type record")));
1375  }
1376 
1377  ret = plperl_hash_to_datum(sv, td);
1378 
1379  /* Release on the result of get_call_result_type is harmless */
1380  ReleaseTupleDesc(td);
1381 
1382  return ret;
1383  }
1384 
1385  /* Reference, but not reference to hash or array ... */
1386  ereport(ERROR,
1387  (errcode(ERRCODE_DATATYPE_MISMATCH),
1388  errmsg("PL/Perl function must return reference to hash or array")));
1389  return (Datum) 0; /* shut up compiler */
1390  }
1391  else
1392  {
1393  /* handle a string/number */
1394  Datum ret;
1395  char *str = sv2cstr(sv);
1396 
1397  /* did not pass in any typeinfo? look it up */
1398  if (!finfo)
1399  {
1400  _sv_to_datum_finfo(typid, &tmp, &typioparam);
1401  finfo = &tmp;
1402  }
1403 
1404  ret = InputFunctionCall(finfo, str, typioparam, typmod);
1405  pfree(str);
1406 
1407  return ret;
1408  }
1409 }
1410 
1411 /* Convert the perl SV to a string returned by the type output function */
1412 char *
1413 plperl_sv_to_literal(SV *sv, char *fqtypename)
1414 {
1415  Datum str = CStringGetDatum(fqtypename);
1416  Oid typid = DirectFunctionCall1(regtypein, str);
1417  Oid typoutput;
1418  Datum datum;
1419  bool typisvarlena,
1420  isnull;
1421 
1422  if (!OidIsValid(typid))
1423  ereport(ERROR,
1424  (errcode(ERRCODE_UNDEFINED_OBJECT),
1425  errmsg("lookup failed for type %s", fqtypename)));
1426 
1427  datum = plperl_sv_to_datum(sv,
1428  typid, -1,
1429  NULL, NULL, InvalidOid,
1430  &isnull);
1431 
1432  if (isnull)
1433  return NULL;
1434 
1435  getTypeOutputInfo(typid,
1436  &typoutput, &typisvarlena);
1437 
1438  return OidOutputFunctionCall(typoutput, datum);
1439 }
1440 
1441 /*
1442  * Convert PostgreSQL array datum to a perl array reference.
1443  *
1444  * typid is arg's OID, which must be an array type.
1445  */
1446 static SV *
1448 {
1449  dTHX;
1450  ArrayType *ar = DatumGetArrayTypeP(arg);
1451  Oid elementtype = ARR_ELEMTYPE(ar);
1452  int16 typlen;
1453  bool typbyval;
1454  char typalign,
1455  typdelim;
1456  Oid typioparam;
1457  Oid typoutputfunc;
1458  Oid transform_funcid;
1459  int i,
1460  nitems,
1461  *dims;
1462  plperl_array_info *info;
1463  SV *av;
1464  HV *hv;
1465 
1466  /*
1467  * Currently we make no effort to cache any of the stuff we look up here,
1468  * which is bad.
1469  */
1470  info = palloc0(sizeof(plperl_array_info));
1471 
1472  /* get element type information, including output conversion function */
1473  get_type_io_data(elementtype, IOFunc_output,
1474  &typlen, &typbyval, &typalign,
1475  &typdelim, &typioparam, &typoutputfunc);
1476 
1477  /* Check for a transform function */
1478  transform_funcid = get_transform_fromsql(elementtype,
1479  current_call_data->prodesc->lang_oid,
1480  current_call_data->prodesc->trftypes);
1481 
1482  /* Look up transform or output function as appropriate */
1483  if (OidIsValid(transform_funcid))
1484  fmgr_info(transform_funcid, &info->transform_proc);
1485  else
1486  fmgr_info(typoutputfunc, &info->proc);
1487 
1488  info->elem_is_rowtype = type_is_rowtype(elementtype);
1489 
1490  /* Get the number and bounds of array dimensions */
1491  info->ndims = ARR_NDIM(ar);
1492  dims = ARR_DIMS(ar);
1493 
1494  /* No dimensions? Return an empty array */
1495  if (info->ndims == 0)
1496  {
1497  av = newRV_noinc((SV *) newAV());
1498  }
1499  else
1500  {
1501  deconstruct_array(ar, elementtype, typlen, typbyval,
1502  typalign, &info->elements, &info->nulls,
1503  &nitems);
1504 
1505  /* Get total number of elements in each dimension */
1506  info->nelems = palloc(sizeof(int) * info->ndims);
1507  info->nelems[0] = nitems;
1508  for (i = 1; i < info->ndims; i++)
1509  info->nelems[i] = info->nelems[i - 1] / dims[i - 1];
1510 
1511  av = split_array(info, 0, nitems, 0);
1512  }
1513 
1514  hv = newHV();
1515  (void) hv_store(hv, "array", 5, av, 0);
1516  (void) hv_store(hv, "typeoid", 7, newSVuv(typid), 0);
1517 
1518  return sv_bless(newRV_noinc((SV *) hv),
1519  gv_stashpv("PostgreSQL::InServer::ARRAY", 0));
1520 }
1521 
1522 /*
1523  * Recursively form array references from splices of the initial array
1524  */
1525 static SV *
1526 split_array(plperl_array_info *info, int first, int last, int nest)
1527 {
1528  dTHX;
1529  int i;
1530  AV *result;
1531 
1532  /* we should only be called when we have something to split */
1533  Assert(info->ndims > 0);
1534 
1535  /* since this function recurses, it could be driven to stack overflow */
1537 
1538  /*
1539  * Base case, return a reference to a single-dimensional array
1540  */
1541  if (nest >= info->ndims - 1)
1542  return make_array_ref(info, first, last);
1543 
1544  result = newAV();
1545  for (i = first; i < last; i += info->nelems[nest + 1])
1546  {
1547  /* Recursively form references to arrays of lower dimensions */
1548  SV *ref = split_array(info, i, i + info->nelems[nest + 1], nest + 1);
1549 
1550  av_push(result, ref);
1551  }
1552  return newRV_noinc((SV *) result);
1553 }
1554 
1555 /*
1556  * Create a Perl reference from a one-dimensional C array, converting
1557  * composite type elements to hash references.
1558  */
1559 static SV *
1560 make_array_ref(plperl_array_info *info, int first, int last)
1561 {
1562  dTHX;
1563  int i;
1564  AV *result = newAV();
1565 
1566  for (i = first; i < last; i++)
1567  {
1568  if (info->nulls[i])
1569  {
1570  /*
1571  * We can't use &PL_sv_undef here. See "AVs, HVs and undefined
1572  * values" in perlguts.
1573  */
1574  av_push(result, newSV(0));
1575  }
1576  else
1577  {
1578  Datum itemvalue = info->elements[i];
1579 
1580  if (info->transform_proc.fn_oid)
1581  av_push(result, (SV *) DatumGetPointer(FunctionCall1(&info->transform_proc, itemvalue)));
1582  else if (info->elem_is_rowtype)
1583  /* Handle composite type elements */
1584  av_push(result, plperl_hash_from_datum(itemvalue));
1585  else
1586  {
1587  char *val = OutputFunctionCall(&info->proc, itemvalue);
1588 
1589  av_push(result, cstr2sv(val));
1590  }
1591  }
1592  }
1593  return newRV_noinc((SV *) result);
1594 }
1595 
1596 /* Set up the arguments for a trigger call. */
1597 static SV *
1599 {
1600  dTHX;
1601  TriggerData *tdata;
1602  TupleDesc tupdesc;
1603  int i;
1604  char *level;
1605  char *event;
1606  char *relid;
1607  char *when;
1608  HV *hv;
1609 
1610  hv = newHV();
1611  hv_ksplit(hv, 12); /* pre-grow the hash */
1612 
1613  tdata = (TriggerData *) fcinfo->context;
1614  tupdesc = tdata->tg_relation->rd_att;
1615 
1616  relid = DatumGetCString(
1619  )
1620  );
1621 
1622  hv_store_string(hv, "name", cstr2sv(tdata->tg_trigger->tgname));
1623  hv_store_string(hv, "relid", cstr2sv(relid));
1624 
1625  if (TRIGGER_FIRED_BY_INSERT(tdata->tg_event))
1626  {
1627  event = "INSERT";
1628  if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
1629  hv_store_string(hv, "new",
1631  tupdesc));
1632  }
1633  else if (TRIGGER_FIRED_BY_DELETE(tdata->tg_event))
1634  {
1635  event = "DELETE";
1636  if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
1637  hv_store_string(hv, "old",
1639  tupdesc));
1640  }
1641  else if (TRIGGER_FIRED_BY_UPDATE(tdata->tg_event))
1642  {
1643  event = "UPDATE";
1644  if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
1645  {
1646  hv_store_string(hv, "old",
1648  tupdesc));
1649  hv_store_string(hv, "new",
1651  tupdesc));
1652  }
1653  }
1654  else if (TRIGGER_FIRED_BY_TRUNCATE(tdata->tg_event))
1655  event = "TRUNCATE";
1656  else
1657  event = "UNKNOWN";
1658 
1659  hv_store_string(hv, "event", cstr2sv(event));
1660  hv_store_string(hv, "argc", newSViv(tdata->tg_trigger->tgnargs));
1661 
1662  if (tdata->tg_trigger->tgnargs > 0)
1663  {
1664  AV *av = newAV();
1665 
1666  av_extend(av, tdata->tg_trigger->tgnargs);
1667  for (i = 0; i < tdata->tg_trigger->tgnargs; i++)
1668  av_push(av, cstr2sv(tdata->tg_trigger->tgargs[i]));
1669  hv_store_string(hv, "args", newRV_noinc((SV *) av));
1670  }
1671 
1672  hv_store_string(hv, "relname",
1674 
1675  hv_store_string(hv, "table_name",
1677 
1678  hv_store_string(hv, "table_schema",
1680 
1681  if (TRIGGER_FIRED_BEFORE(tdata->tg_event))
1682  when = "BEFORE";
1683  else if (TRIGGER_FIRED_AFTER(tdata->tg_event))
1684  when = "AFTER";
1685  else if (TRIGGER_FIRED_INSTEAD(tdata->tg_event))
1686  when = "INSTEAD OF";
1687  else
1688  when = "UNKNOWN";
1689  hv_store_string(hv, "when", cstr2sv(when));
1690 
1691  if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
1692  level = "ROW";
1693  else if (TRIGGER_FIRED_FOR_STATEMENT(tdata->tg_event))
1694  level = "STATEMENT";
1695  else
1696  level = "UNKNOWN";
1697  hv_store_string(hv, "level", cstr2sv(level));
1698 
1699  return newRV_noinc((SV *) hv);
1700 }
1701 
1702 
1703 /* Set up the arguments for an event trigger call. */
1704 static SV *
1706 {
1707  dTHX;
1708  EventTriggerData *tdata;
1709  HV *hv;
1710 
1711  hv = newHV();
1712 
1713  tdata = (EventTriggerData *) fcinfo->context;
1714 
1715  hv_store_string(hv, "event", cstr2sv(tdata->event));
1716  hv_store_string(hv, "tag", cstr2sv(tdata->tag));
1717 
1718  return newRV_noinc((SV *) hv);
1719 }
1720 
1721 /* Construct the modified new tuple to be returned from a trigger. */
1722 static HeapTuple
1724 {
1725  dTHX;
1726  SV **svp;
1727  HV *hvNew;
1728  HE *he;
1729  HeapTuple rtup;
1730  TupleDesc tupdesc;
1731  int natts;
1732  Datum *modvalues;
1733  bool *modnulls;
1734  bool *modrepls;
1735 
1736  svp = hv_fetch_string(hvTD, "new");
1737  if (!svp)
1738  ereport(ERROR,
1739  (errcode(ERRCODE_UNDEFINED_COLUMN),
1740  errmsg("$_TD->{new} does not exist")));
1741  if (!SvOK(*svp) || !SvROK(*svp) || SvTYPE(SvRV(*svp)) != SVt_PVHV)
1742  ereport(ERROR,
1743  (errcode(ERRCODE_DATATYPE_MISMATCH),
1744  errmsg("$_TD->{new} is not a hash reference")));
1745  hvNew = (HV *) SvRV(*svp);
1746 
1747  tupdesc = tdata->tg_relation->rd_att;
1748  natts = tupdesc->natts;
1749 
1750  modvalues = (Datum *) palloc0(natts * sizeof(Datum));
1751  modnulls = (bool *) palloc0(natts * sizeof(bool));
1752  modrepls = (bool *) palloc0(natts * sizeof(bool));
1753 
1754  hv_iterinit(hvNew);
1755  while ((he = hv_iternext(hvNew)))
1756  {
1757  char *key = hek2cstr(he);
1758  SV *val = HeVAL(he);
1759  int attn = SPI_fnumber(tupdesc, key);
1760 
1761  if (attn == SPI_ERROR_NOATTRIBUTE)
1762  ereport(ERROR,
1763  (errcode(ERRCODE_UNDEFINED_COLUMN),
1764  errmsg("Perl hash contains nonexistent column \"%s\"",
1765  key)));
1766  if (attn <= 0)
1767  ereport(ERROR,
1768  (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1769  errmsg("cannot set system attribute \"%s\"",
1770  key)));
1771 
1772  modvalues[attn - 1] = plperl_sv_to_datum(val,
1773  tupdesc->attrs[attn - 1]->atttypid,
1774  tupdesc->attrs[attn - 1]->atttypmod,
1775  NULL,
1776  NULL,
1777  InvalidOid,
1778  &modnulls[attn - 1]);
1779  modrepls[attn - 1] = true;
1780 
1781  pfree(key);
1782  }
1783  hv_iterinit(hvNew);
1784 
1785  rtup = heap_modify_tuple(otup, tupdesc, modvalues, modnulls, modrepls);
1786 
1787  pfree(modvalues);
1788  pfree(modnulls);
1789  pfree(modrepls);
1790 
1791  return rtup;
1792 }
1793 
1794 
1795 /*
1796  * There are three externally visible pieces to plperl: plperl_call_handler,
1797  * plperl_inline_handler, and plperl_validator.
1798  */
1799 
1800 /*
1801  * The call handler is called to run normal functions (including trigger
1802  * functions) that are defined in pg_proc.
1803  */
1805 
1806 Datum
1808 {
1809  Datum retval;
1810  plperl_call_data *volatile save_call_data = current_call_data;
1811  plperl_interp_desc *volatile oldinterp = plperl_active_interp;
1812  plperl_call_data this_call_data;
1813 
1814  /* Initialize current-call status record */
1815  MemSet(&this_call_data, 0, sizeof(this_call_data));
1816  this_call_data.fcinfo = fcinfo;
1817 
1818  PG_TRY();
1819  {
1820  current_call_data = &this_call_data;
1821  if (CALLED_AS_TRIGGER(fcinfo))
1822  retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
1823  else if (CALLED_AS_EVENT_TRIGGER(fcinfo))
1824  {
1826  retval = (Datum) 0;
1827  }
1828  else
1829  retval = plperl_func_handler(fcinfo);
1830  }
1831  PG_CATCH();
1832  {
1833  current_call_data = save_call_data;
1834  activate_interpreter(oldinterp);
1835  if (this_call_data.prodesc)
1836  decrement_prodesc_refcount(this_call_data.prodesc);
1837  PG_RE_THROW();
1838  }
1839  PG_END_TRY();
1840 
1841  current_call_data = save_call_data;
1842  activate_interpreter(oldinterp);
1843  if (this_call_data.prodesc)
1844  decrement_prodesc_refcount(this_call_data.prodesc);
1845  return retval;
1846 }
1847 
1848 /*
1849  * The inline handler runs anonymous code blocks (DO blocks).
1850  */
1852 
1853 Datum
1855 {
1857  FunctionCallInfoData fake_fcinfo;
1858  FmgrInfo flinfo;
1859  plperl_proc_desc desc;
1860  plperl_call_data *volatile save_call_data = current_call_data;
1861  plperl_interp_desc *volatile oldinterp = plperl_active_interp;
1862  plperl_call_data this_call_data;
1863  ErrorContextCallback pl_error_context;
1864 
1865  /* Initialize current-call status record */
1866  MemSet(&this_call_data, 0, sizeof(this_call_data));
1867 
1868  /* Set up a callback for error reporting */
1869  pl_error_context.callback = plperl_inline_callback;
1870  pl_error_context.previous = error_context_stack;
1871  pl_error_context.arg = NULL;
1872  error_context_stack = &pl_error_context;
1873 
1874  /*
1875  * Set up a fake fcinfo and descriptor with just enough info to satisfy
1876  * plperl_call_perl_func(). In particular note that this sets things up
1877  * with no arguments passed, and a result type of VOID.
1878  */
1879  MemSet(&fake_fcinfo, 0, sizeof(fake_fcinfo));
1880  MemSet(&flinfo, 0, sizeof(flinfo));
1881  MemSet(&desc, 0, sizeof(desc));
1882  fake_fcinfo.flinfo = &flinfo;
1883  flinfo.fn_oid = InvalidOid;
1884  flinfo.fn_mcxt = CurrentMemoryContext;
1885 
1886  desc.proname = "inline_code_block";
1887  desc.fn_readonly = false;
1888 
1889  desc.lang_oid = codeblock->langOid;
1890  desc.trftypes = NIL;
1891  desc.lanpltrusted = codeblock->langIsTrusted;
1892 
1893  desc.fn_retistuple = false;
1894  desc.fn_retisset = false;
1895  desc.fn_retisarray = false;
1896  desc.result_oid = VOIDOID;
1897  desc.nargs = 0;
1898  desc.reference = NULL;
1899 
1900  this_call_data.fcinfo = &fake_fcinfo;
1901  this_call_data.prodesc = &desc;
1902  /* we do not bother with refcounting the fake prodesc */
1903 
1904  PG_TRY();
1905  {
1906  SV *perlret;
1907 
1908  current_call_data = &this_call_data;
1909 
1910  if (SPI_connect() != SPI_OK_CONNECT)
1911  elog(ERROR, "could not connect to SPI manager");
1912 
1914 
1915  plperl_create_sub(&desc, codeblock->source_text, 0);
1916 
1917  if (!desc.reference) /* can this happen? */
1918  elog(ERROR, "could not create internal procedure for anonymous code block");
1919 
1920  perlret = plperl_call_perl_func(&desc, &fake_fcinfo);
1921 
1922  SvREFCNT_dec_current(perlret);
1923 
1924  if (SPI_finish() != SPI_OK_FINISH)
1925  elog(ERROR, "SPI_finish() failed");
1926  }
1927  PG_CATCH();
1928  {
1929  if (desc.reference)
1931  current_call_data = save_call_data;
1932  activate_interpreter(oldinterp);
1933  PG_RE_THROW();
1934  }
1935  PG_END_TRY();
1936 
1937  if (desc.reference)
1939 
1940  current_call_data = save_call_data;
1941  activate_interpreter(oldinterp);
1942 
1943  error_context_stack = pl_error_context.previous;
1944 
1945  PG_RETURN_VOID();
1946 }
1947 
1948 /*
1949  * The validator is called during CREATE FUNCTION to validate the function
1950  * being created/replaced. The precise behavior of the validator may be
1951  * modified by the check_function_bodies GUC.
1952  */
1954 
1955 Datum
1957 {
1958  Oid funcoid = PG_GETARG_OID(0);
1959  HeapTuple tuple;
1960  Form_pg_proc proc;
1961  char functyptype;
1962  int numargs;
1963  Oid *argtypes;
1964  char **argnames;
1965  char *argmodes;
1966  bool is_trigger = false;
1967  bool is_event_trigger = false;
1968  int i;
1969 
1970  if (!CheckFunctionValidatorAccess(fcinfo->flinfo->fn_oid, funcoid))
1971  PG_RETURN_VOID();
1972 
1973  /* Get the new function's pg_proc entry */
1974  tuple = SearchSysCache1(PROCOID, ObjectIdGetDatum(funcoid));
1975  if (!HeapTupleIsValid(tuple))
1976  elog(ERROR, "cache lookup failed for function %u", funcoid);
1977  proc = (Form_pg_proc) GETSTRUCT(tuple);
1978 
1979  functyptype = get_typtype(proc->prorettype);
1980 
1981  /* Disallow pseudotype result */
1982  /* except for TRIGGER, EVTTRIGGER, RECORD, or VOID */
1983  if (functyptype == TYPTYPE_PSEUDO)
1984  {
1985  /* we assume OPAQUE with no arguments means a trigger */
1986  if (proc->prorettype == TRIGGEROID ||
1987  (proc->prorettype == OPAQUEOID && proc->pronargs == 0))
1988  is_trigger = true;
1989  else if (proc->prorettype == EVTTRIGGEROID)
1990  is_event_trigger = true;
1991  else if (proc->prorettype != RECORDOID &&
1992  proc->prorettype != VOIDOID)
1993  ereport(ERROR,
1994  (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1995  errmsg("PL/Perl functions cannot return type %s",
1996  format_type_be(proc->prorettype))));
1997  }
1998 
1999  /* Disallow pseudotypes in arguments (either IN or OUT) */
2000  numargs = get_func_arg_info(tuple,
2001  &argtypes, &argnames, &argmodes);
2002  for (i = 0; i < numargs; i++)
2003  {
2004  if (get_typtype(argtypes[i]) == TYPTYPE_PSEUDO &&
2005  argtypes[i] != RECORDOID)
2006  ereport(ERROR,
2007  (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
2008  errmsg("PL/Perl functions cannot accept type %s",
2009  format_type_be(argtypes[i]))));
2010  }
2011 
2012  ReleaseSysCache(tuple);
2013 
2014  /* Postpone body checks if !check_function_bodies */
2016  {
2017  (void) compile_plperl_function(funcoid, is_trigger, is_event_trigger);
2018  }
2019 
2020  /* the result of a validator is ignored */
2021  PG_RETURN_VOID();
2022 }
2023 
2024 
2025 /*
2026  * plperlu likewise requires three externally visible functions:
2027  * plperlu_call_handler, plperlu_inline_handler, and plperlu_validator.
2028  * These are currently just aliases that send control to the plperl
2029  * handler functions, and we decide whether a particular function is
2030  * trusted or not by inspecting the actual pg_language tuple.
2031  */
2032 
2034 
2035 Datum
2037 {
2038  return plperl_call_handler(fcinfo);
2039 }
2040 
2042 
2043 Datum
2045 {
2046  return plperl_inline_handler(fcinfo);
2047 }
2048 
2050 
2051 Datum
2053 {
2054  /* call plperl validator with our fcinfo so it gets our oid */
2055  return plperl_validator(fcinfo);
2056 }
2057 
2058 
2059 /*
2060  * Uses mksafefunc/mkunsafefunc to create a subroutine whose text is
2061  * supplied in s, and returns a reference to it
2062  */
2063 static void
2064 plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid)
2065 {
2066  dTHX;
2067  dSP;
2068  char subname[NAMEDATALEN + 40];
2069  HV *pragma_hv = newHV();
2070  SV *subref = NULL;
2071  int count;
2072 
2073  sprintf(subname, "%s__%u", prodesc->proname, fn_oid);
2074 
2075  if (plperl_use_strict)
2076  hv_store_string(pragma_hv, "strict", (SV *) newAV());
2077 
2078  ENTER;
2079  SAVETMPS;
2080  PUSHMARK(SP);
2081  EXTEND(SP, 4);
2082  PUSHs(sv_2mortal(cstr2sv(subname)));
2083  PUSHs(sv_2mortal(newRV_noinc((SV *) pragma_hv)));
2084 
2085  /*
2086  * Use 'false' for $prolog in mkfunc, which is kept for compatibility in
2087  * case a module such as PostgreSQL::PLPerl::NYTprof replaces the function
2088  * compiler.
2089  */
2090  PUSHs(&PL_sv_no);
2091  PUSHs(sv_2mortal(cstr2sv(s)));
2092  PUTBACK;
2093 
2094  /*
2095  * G_KEEPERR seems to be needed here, else we don't recognize compile
2096  * errors properly. Perhaps it's because there's another level of eval
2097  * inside mksafefunc?
2098  */
2099  count = perl_call_pv("PostgreSQL::InServer::mkfunc",
2100  G_SCALAR | G_EVAL | G_KEEPERR);
2101  SPAGAIN;
2102 
2103  if (count == 1)
2104  {
2105  SV *sub_rv = (SV *) POPs;
2106 
2107  if (sub_rv && SvROK(sub_rv) && SvTYPE(SvRV(sub_rv)) == SVt_PVCV)
2108  {
2109  subref = newRV_inc(SvRV(sub_rv));
2110  }
2111  }
2112 
2113  PUTBACK;
2114  FREETMPS;
2115  LEAVE;
2116 
2117  if (SvTRUE(ERRSV))
2118  ereport(ERROR,
2119  (errcode(ERRCODE_SYNTAX_ERROR),
2121 
2122  if (!subref)
2123  ereport(ERROR,
2124  (errcode(ERRCODE_SYNTAX_ERROR),
2125  errmsg("didn't get a CODE reference from compiling function \"%s\"",
2126  prodesc->proname)));
2127 
2128  prodesc->reference = subref;
2129 
2130  return;
2131 }
2132 
2133 
2134 /**********************************************************************
2135  * plperl_init_shared_libs() -
2136  **********************************************************************/
2137 
2138 static void
2140 {
2141  char *file = __FILE__;
2142 
2143  newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
2144  newXS("PostgreSQL::InServer::Util::bootstrap",
2146  /* newXS for...::SPI::bootstrap is in select_perl_context() */
2147 }
2148 
2149 
2150 static SV *
2152 {
2153  dTHX;
2154  dSP;
2155  SV *retval;
2156  int i;
2157  int count;
2158  Oid *argtypes = NULL;
2159  int nargs = 0;
2160 
2161  ENTER;
2162  SAVETMPS;
2163 
2164  PUSHMARK(SP);
2165  EXTEND(sp, desc->nargs);
2166 
2167  /* Get signature for true functions; inline blocks have no args. */
2168  if (fcinfo->flinfo->fn_oid)
2169  get_func_signature(fcinfo->flinfo->fn_oid, &argtypes, &nargs);
2170  Assert(nargs == desc->nargs);
2171 
2172  for (i = 0; i < desc->nargs; i++)
2173  {
2174  if (fcinfo->argnull[i])
2175  PUSHs(&PL_sv_undef);
2176  else if (desc->arg_is_rowtype[i])
2177  {
2178  SV *sv = plperl_hash_from_datum(fcinfo->arg[i]);
2179 
2180  PUSHs(sv_2mortal(sv));
2181  }
2182  else
2183  {
2184  SV *sv;
2185  Oid funcid;
2186 
2187  if (OidIsValid(desc->arg_arraytype[i]))
2188  sv = plperl_ref_from_pg_array(fcinfo->arg[i], desc->arg_arraytype[i]);
2189  else if ((funcid = get_transform_fromsql(argtypes[i], current_call_data->prodesc->lang_oid, current_call_data->prodesc->trftypes)))
2190  sv = (SV *) DatumGetPointer(OidFunctionCall1(funcid, fcinfo->arg[i]));
2191  else
2192  {
2193  char *tmp;
2194 
2195  tmp = OutputFunctionCall(&(desc->arg_out_func[i]),
2196  fcinfo->arg[i]);
2197  sv = cstr2sv(tmp);
2198  pfree(tmp);
2199  }
2200 
2201  PUSHs(sv_2mortal(sv));
2202  }
2203  }
2204  PUTBACK;
2205 
2206  /* Do NOT use G_KEEPERR here */
2207  count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL);
2208 
2209  SPAGAIN;
2210 
2211  if (count != 1)
2212  {
2213  PUTBACK;
2214  FREETMPS;
2215  LEAVE;
2216  ereport(ERROR,
2217  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
2218  errmsg("didn't get a return item from function")));
2219  }
2220 
2221  if (SvTRUE(ERRSV))
2222  {
2223  (void) POPs;
2224  PUTBACK;
2225  FREETMPS;
2226  LEAVE;
2227  /* XXX need to find a way to determine a better errcode here */
2228  ereport(ERROR,
2229  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
2231  }
2232 
2233  retval = newSVsv(POPs);
2234 
2235  PUTBACK;
2236  FREETMPS;
2237  LEAVE;
2238 
2239  return retval;
2240 }
2241 
2242 
2243 static SV *
2245  SV *td)
2246 {
2247  dTHX;
2248  dSP;
2249  SV *retval,
2250  *TDsv;
2251  int i,
2252  count;
2253  Trigger *tg_trigger = ((TriggerData *) fcinfo->context)->tg_trigger;
2254 
2255  ENTER;
2256  SAVETMPS;
2257 
2258  TDsv = get_sv("main::_TD", 0);
2259  if (!TDsv)
2260  ereport(ERROR,
2261  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
2262  errmsg("couldn't fetch $_TD")));
2263 
2264  save_item(TDsv); /* local $_TD */
2265  sv_setsv(TDsv, td);
2266 
2267  PUSHMARK(sp);
2268  EXTEND(sp, tg_trigger->tgnargs);
2269 
2270  for (i = 0; i < tg_trigger->tgnargs; i++)
2271  PUSHs(sv_2mortal(cstr2sv(tg_trigger->tgargs[i])));
2272  PUTBACK;
2273 
2274  /* Do NOT use G_KEEPERR here */
2275  count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL);
2276 
2277  SPAGAIN;
2278 
2279  if (count != 1)
2280  {
2281  PUTBACK;
2282  FREETMPS;
2283  LEAVE;
2284  ereport(ERROR,
2285  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
2286  errmsg("didn't get a return item from trigger function")));
2287  }
2288 
2289  if (SvTRUE(ERRSV))
2290  {
2291  (void) POPs;
2292  PUTBACK;
2293  FREETMPS;
2294  LEAVE;
2295  /* XXX need to find a way to determine a better errcode here */
2296  ereport(ERROR,
2297  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
2299  }
2300 
2301  retval = newSVsv(POPs);
2302 
2303  PUTBACK;
2304  FREETMPS;
2305  LEAVE;
2306 
2307  return retval;
2308 }
2309 
2310 
2311 static void
2313  FunctionCallInfo fcinfo,
2314  SV *td)
2315 {
2316  dTHX;
2317  dSP;
2318  SV *retval,
2319  *TDsv;
2320  int count;
2321 
2322  ENTER;
2323  SAVETMPS;
2324 
2325  TDsv = get_sv("main::_TD", 0);
2326  if (!TDsv)
2327  ereport(ERROR,
2328  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
2329  errmsg("couldn't fetch $_TD")));
2330 
2331  save_item(TDsv); /* local $_TD */
2332  sv_setsv(TDsv, td);
2333 
2334  PUSHMARK(sp);
2335  PUTBACK;
2336 
2337  /* Do NOT use G_KEEPERR here */
2338  count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL);
2339 
2340  SPAGAIN;
2341 
2342  if (count != 1)
2343  {
2344  PUTBACK;
2345  FREETMPS;
2346  LEAVE;
2347  ereport(ERROR,
2348  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
2349  errmsg("didn't get a return item from trigger function")));
2350  }
2351 
2352  if (SvTRUE(ERRSV))
2353  {
2354  (void) POPs;
2355  PUTBACK;
2356  FREETMPS;
2357  LEAVE;
2358  /* XXX need to find a way to determine a better errcode here */
2359  ereport(ERROR,
2360  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
2362  }
2363 
2364  retval = newSVsv(POPs);
2365  (void) retval; /* silence compiler warning */
2366 
2367  PUTBACK;
2368  FREETMPS;
2369  LEAVE;
2370 
2371  return;
2372 }
2373 
2374 static Datum
2376 {
2377  plperl_proc_desc *prodesc;
2378  SV *perlret;
2379  Datum retval = 0;
2380  ReturnSetInfo *rsi;
2381  ErrorContextCallback pl_error_context;
2382 
2383  if (SPI_connect() != SPI_OK_CONNECT)
2384  elog(ERROR, "could not connect to SPI manager");
2385 
2386  prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false, false);
2387  current_call_data->prodesc = prodesc;
2388  increment_prodesc_refcount(prodesc);
2389 
2390  /* Set a callback for error reporting */
2391  pl_error_context.callback = plperl_exec_callback;
2392  pl_error_context.previous = error_context_stack;
2393  pl_error_context.arg = prodesc->proname;
2394  error_context_stack = &pl_error_context;
2395 
2396  rsi = (ReturnSetInfo *) fcinfo->resultinfo;
2397 
2398  if (prodesc->fn_retisset)
2399  {
2400  /* Check context before allowing the call to go through */
2401  if (!rsi || !IsA(rsi, ReturnSetInfo) ||
2402  (rsi->allowedModes & SFRM_Materialize) == 0 ||
2403  rsi->expectedDesc == NULL)
2404  ereport(ERROR,
2405  (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
2406  errmsg("set-valued function called in context that "
2407  "cannot accept a set")));
2408  }
2409 
2410  activate_interpreter(prodesc->interp);
2411 
2412  perlret = plperl_call_perl_func(prodesc, fcinfo);
2413 
2414  /************************************************************
2415  * Disconnect from SPI manager and then create the return
2416  * values datum (if the input function does a palloc for it
2417  * this must not be allocated in the SPI memory context
2418  * because SPI_finish would free it).
2419  ************************************************************/
2420  if (SPI_finish() != SPI_OK_FINISH)
2421  elog(ERROR, "SPI_finish() failed");
2422 
2423  if (prodesc->fn_retisset)
2424  {
2425  SV *sav;
2426 
2427  /*
2428  * If the Perl function returned an arrayref, we pretend that it
2429  * called return_next() for each element of the array, to handle old
2430  * SRFs that didn't know about return_next(). Any other sort of return
2431  * value is an error, except undef which means return an empty set.
2432  */
2433  sav = get_perl_array_ref(perlret);
2434  if (sav)
2435  {
2436  dTHX;
2437  int i = 0;
2438  SV **svp = 0;
2439  AV *rav = (AV *) SvRV(sav);
2440 
2441  while ((svp = av_fetch(rav, i, FALSE)) != NULL)
2442  {
2444  i++;
2445  }
2446  }
2447  else if (SvOK(perlret))
2448  {
2449  ereport(ERROR,
2450  (errcode(ERRCODE_DATATYPE_MISMATCH),
2451  errmsg("set-returning PL/Perl function must return "
2452  "reference to array or use return_next")));
2453  }
2454 
2456  if (current_call_data->tuple_store)
2457  {
2458  rsi->setResult = current_call_data->tuple_store;
2459  rsi->setDesc = current_call_data->ret_tdesc;
2460  }
2461  retval = (Datum) 0;
2462  }
2463  else
2464  {
2465  retval = plperl_sv_to_datum(perlret,
2466  prodesc->result_oid,
2467  -1,
2468  fcinfo,
2469  &prodesc->result_in_func,
2470  prodesc->result_typioparam,
2471  &fcinfo->isnull);
2472 
2473  if (fcinfo->isnull && rsi && IsA(rsi, ReturnSetInfo))
2474  rsi->isDone = ExprEndResult;
2475  }
2476 
2477  /* Restore the previous error callback */
2478  error_context_stack = pl_error_context.previous;
2479 
2480  SvREFCNT_dec_current(perlret);
2481 
2482  return retval;
2483 }
2484 
2485 
2486 static Datum
2488 {
2489  plperl_proc_desc *prodesc;
2490  SV *perlret;
2491  Datum retval;
2492  SV *svTD;
2493  HV *hvTD;
2494  ErrorContextCallback pl_error_context;
2495  TriggerData *tdata;
2496  int rc PG_USED_FOR_ASSERTS_ONLY;
2497 
2498  /* Connect to SPI manager */
2499  if (SPI_connect() != SPI_OK_CONNECT)
2500  elog(ERROR, "could not connect to SPI manager");
2501 
2502  /* Make transition tables visible to this SPI connection */
2503  tdata = (TriggerData *) fcinfo->context;
2504  rc = SPI_register_trigger_data(tdata);
2505  Assert(rc >= 0);
2506 
2507  /* Find or compile the function */
2508  prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true, false);
2509  current_call_data->prodesc = prodesc;
2510  increment_prodesc_refcount(prodesc);
2511 
2512  /* Set a callback for error reporting */
2513  pl_error_context.callback = plperl_exec_callback;
2514  pl_error_context.previous = error_context_stack;
2515  pl_error_context.arg = prodesc->proname;
2516  error_context_stack = &pl_error_context;
2517 
2518  activate_interpreter(prodesc->interp);
2519 
2520  svTD = plperl_trigger_build_args(fcinfo);
2521  perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
2522  hvTD = (HV *) SvRV(svTD);
2523 
2524  /************************************************************
2525  * Disconnect from SPI manager and then create the return
2526  * values datum (if the input function does a palloc for it
2527  * this must not be allocated in the SPI memory context
2528  * because SPI_finish would free it).
2529  ************************************************************/
2530  if (SPI_finish() != SPI_OK_FINISH)
2531  elog(ERROR, "SPI_finish() failed");
2532 
2533  if (perlret == NULL || !SvOK(perlret))
2534  {
2535  /* undef result means go ahead with original tuple */
2536  TriggerData *trigdata = ((TriggerData *) fcinfo->context);
2537 
2538  if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
2539  retval = (Datum) trigdata->tg_trigtuple;
2540  else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
2541  retval = (Datum) trigdata->tg_newtuple;
2542  else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
2543  retval = (Datum) trigdata->tg_trigtuple;
2544  else if (TRIGGER_FIRED_BY_TRUNCATE(trigdata->tg_event))
2545  retval = (Datum) trigdata->tg_trigtuple;
2546  else
2547  retval = (Datum) 0; /* can this happen? */
2548  }
2549  else
2550  {
2551  HeapTuple trv;
2552  char *tmp;
2553 
2554  tmp = sv2cstr(perlret);
2555 
2556  if (pg_strcasecmp(tmp, "SKIP") == 0)
2557  trv = NULL;
2558  else if (pg_strcasecmp(tmp, "MODIFY") == 0)
2559  {
2560  TriggerData *trigdata = (TriggerData *) fcinfo->context;
2561 
2562  if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
2563  trv = plperl_modify_tuple(hvTD, trigdata,
2564  trigdata->tg_trigtuple);
2565  else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
2566  trv = plperl_modify_tuple(hvTD, trigdata,
2567  trigdata->tg_newtuple);
2568  else
2569  {
2570  ereport(WARNING,
2571  (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
2572  errmsg("ignoring modified row in DELETE trigger")));
2573  trv = NULL;
2574  }
2575  }
2576  else
2577  {
2578  ereport(ERROR,
2579  (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
2580  errmsg("result of PL/Perl trigger function must be undef, "
2581  "\"SKIP\", or \"MODIFY\"")));
2582  trv = NULL;
2583  }
2584  retval = PointerGetDatum(trv);
2585  pfree(tmp);
2586  }
2587 
2588  /* Restore the previous error callback */
2589  error_context_stack = pl_error_context.previous;
2590 
2591  SvREFCNT_dec_current(svTD);
2592  if (perlret)
2593  SvREFCNT_dec_current(perlret);
2594 
2595  return retval;
2596 }
2597 
2598 
2599 static void
2601 {
2602  plperl_proc_desc *prodesc;
2603  SV *svTD;
2604  ErrorContextCallback pl_error_context;
2605 
2606  /* Connect to SPI manager */
2607  if (SPI_connect() != SPI_OK_CONNECT)
2608  elog(ERROR, "could not connect to SPI manager");
2609 
2610  /* Find or compile the function */
2611  prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false, true);
2612  current_call_data->prodesc = prodesc;
2613  increment_prodesc_refcount(prodesc);
2614 
2615  /* Set a callback for error reporting */
2616  pl_error_context.callback = plperl_exec_callback;
2617  pl_error_context.previous = error_context_stack;
2618  pl_error_context.arg = prodesc->proname;
2619  error_context_stack = &pl_error_context;
2620 
2621  activate_interpreter(prodesc->interp);
2622 
2623  svTD = plperl_event_trigger_build_args(fcinfo);
2624  plperl_call_perl_event_trigger_func(prodesc, fcinfo, svTD);
2625 
2626  if (SPI_finish() != SPI_OK_FINISH)
2627  elog(ERROR, "SPI_finish() failed");
2628 
2629  /* Restore the previous error callback */
2630  error_context_stack = pl_error_context.previous;
2631 
2632  SvREFCNT_dec_current(svTD);
2633 }
2634 
2635 
2636 static bool
2638 {
2639  if (proc_ptr && proc_ptr->proc_ptr)
2640  {
2641  plperl_proc_desc *prodesc = proc_ptr->proc_ptr;
2642  bool uptodate;
2643 
2644  /************************************************************
2645  * If it's present, must check whether it's still up to date.
2646  * This is needed because CREATE OR REPLACE FUNCTION can modify the
2647  * function's pg_proc entry without changing its OID.
2648  ************************************************************/
2649  uptodate = (prodesc->fn_xmin == HeapTupleHeaderGetRawXmin(procTup->t_data) &&
2650  ItemPointerEquals(&prodesc->fn_tid, &procTup->t_self));
2651 
2652  if (uptodate)
2653  return true;
2654 
2655  /* Otherwise, unlink the obsoleted entry from the hashtable ... */
2656  proc_ptr->proc_ptr = NULL;
2657  /* ... and release the corresponding refcount, probably deleting it */
2658  decrement_prodesc_refcount(prodesc);
2659  }
2660 
2661  return false;
2662 }
2663 
2664 
2665 static void
2667 {
2668  Assert(prodesc->fn_refcount == 0);
2669  /* Release CODE reference, if we have one, from the appropriate interp */
2670  if (prodesc->reference)
2671  {
2673 
2674  activate_interpreter(prodesc->interp);
2675  SvREFCNT_dec_current(prodesc->reference);
2676  activate_interpreter(oldinterp);
2677  }
2678  /* Release all PG-owned data for this proc */
2679  MemoryContextDelete(prodesc->fn_cxt);
2680 }
2681 
2682 
2683 static plperl_proc_desc *
2684 compile_plperl_function(Oid fn_oid, bool is_trigger, bool is_event_trigger)
2685 {
2686  HeapTuple procTup;
2687  Form_pg_proc procStruct;
2688  plperl_proc_key proc_key;
2689  plperl_proc_ptr *proc_ptr;
2690  plperl_proc_desc *volatile prodesc = NULL;
2691  volatile MemoryContext proc_cxt = NULL;
2693  ErrorContextCallback plperl_error_context;
2694 
2695  /* We'll need the pg_proc tuple in any case... */
2696  procTup = SearchSysCache1(PROCOID, ObjectIdGetDatum(fn_oid));
2697  if (!HeapTupleIsValid(procTup))
2698  elog(ERROR, "cache lookup failed for function %u", fn_oid);
2699  procStruct = (Form_pg_proc) GETSTRUCT(procTup);
2700 
2701  /*
2702  * Try to find function in plperl_proc_hash. The reason for this
2703  * overcomplicated-seeming lookup procedure is that we don't know whether
2704  * it's plperl or plperlu, and don't want to spend a lookup in pg_language
2705  * to find out.
2706  */
2707  proc_key.proc_id = fn_oid;
2708  proc_key.is_trigger = is_trigger;
2709  proc_key.user_id = GetUserId();
2710  proc_ptr = hash_search(plperl_proc_hash, &proc_key,
2711  HASH_FIND, NULL);
2712  if (validate_plperl_function(proc_ptr, procTup))
2713  {
2714  /* Found valid plperl entry */
2715  ReleaseSysCache(procTup);
2716  return proc_ptr->proc_ptr;
2717  }
2718 
2719  /* If not found or obsolete, maybe it's plperlu */
2720  proc_key.user_id = InvalidOid;
2721  proc_ptr = hash_search(plperl_proc_hash, &proc_key,
2722  HASH_FIND, NULL);
2723  if (validate_plperl_function(proc_ptr, procTup))
2724  {
2725  /* Found valid plperlu entry */
2726  ReleaseSysCache(procTup);
2727  return proc_ptr->proc_ptr;
2728  }
2729 
2730  /************************************************************
2731  * If we haven't found it in the hashtable, we analyze
2732  * the function's arguments and return type and store
2733  * the in-/out-functions in the prodesc block,
2734  * then we load the procedure into the Perl interpreter,
2735  * and last we create a new hashtable entry for it.
2736  ************************************************************/
2737 
2738  /* Set a callback for reporting compilation errors */
2739  plperl_error_context.callback = plperl_compile_callback;
2740  plperl_error_context.previous = error_context_stack;
2741  plperl_error_context.arg = NameStr(procStruct->proname);
2742  error_context_stack = &plperl_error_context;
2743 
2744  PG_TRY();
2745  {
2746  HeapTuple langTup;
2747  HeapTuple typeTup;
2748  Form_pg_language langStruct;
2749  Form_pg_type typeStruct;
2750  Datum protrftypes_datum;
2751  Datum prosrcdatum;
2752  bool isnull;
2753  char *proc_source;
2754  MemoryContext oldcontext;
2755 
2756  /************************************************************
2757  * Allocate a context that will hold all PG data for the procedure.
2758  ************************************************************/
2760  NameStr(procStruct->proname),
2762 
2763  /************************************************************
2764  * Allocate and fill a new procedure description block.
2765  * struct prodesc and subsidiary data must all live in proc_cxt.
2766  ************************************************************/
2767  oldcontext = MemoryContextSwitchTo(proc_cxt);
2768  prodesc = (plperl_proc_desc *) palloc0(sizeof(plperl_proc_desc));
2769  prodesc->proname = pstrdup(NameStr(procStruct->proname));
2770  prodesc->fn_cxt = proc_cxt;
2771  prodesc->fn_refcount = 0;
2772  prodesc->fn_xmin = HeapTupleHeaderGetRawXmin(procTup->t_data);
2773  prodesc->fn_tid = procTup->t_self;
2774  prodesc->nargs = procStruct->pronargs;
2775  prodesc->arg_out_func = (FmgrInfo *) palloc0(prodesc->nargs * sizeof(FmgrInfo));
2776  prodesc->arg_is_rowtype = (bool *) palloc0(prodesc->nargs * sizeof(bool));
2777  prodesc->arg_arraytype = (Oid *) palloc0(prodesc->nargs * sizeof(Oid));
2778  MemoryContextSwitchTo(oldcontext);
2779 
2780  /* Remember if function is STABLE/IMMUTABLE */
2781  prodesc->fn_readonly =
2782  (procStruct->provolatile != PROVOLATILE_VOLATILE);
2783 
2784  /* Fetch protrftypes */
2785  protrftypes_datum = SysCacheGetAttr(PROCOID, procTup,
2786  Anum_pg_proc_protrftypes, &isnull);
2787  MemoryContextSwitchTo(proc_cxt);
2788  prodesc->trftypes = isnull ? NIL : oid_array_to_list(protrftypes_datum);
2789  MemoryContextSwitchTo(oldcontext);
2790 
2791  /************************************************************
2792  * Lookup the pg_language tuple by Oid
2793  ************************************************************/
2794  langTup = SearchSysCache1(LANGOID,
2795  ObjectIdGetDatum(procStruct->prolang));
2796  if (!HeapTupleIsValid(langTup))
2797  elog(ERROR, "cache lookup failed for language %u",
2798  procStruct->prolang);
2799  langStruct = (Form_pg_language) GETSTRUCT(langTup);
2800  prodesc->lang_oid = HeapTupleGetOid(langTup);
2801  prodesc->lanpltrusted = langStruct->lanpltrusted;
2802  ReleaseSysCache(langTup);
2803 
2804  /************************************************************
2805  * Get the required information for input conversion of the
2806  * return value.
2807  ************************************************************/
2808  if (!is_trigger && !is_event_trigger)
2809  {
2810  typeTup =
2812  ObjectIdGetDatum(procStruct->prorettype));
2813  if (!HeapTupleIsValid(typeTup))
2814  elog(ERROR, "cache lookup failed for type %u",
2815  procStruct->prorettype);
2816  typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
2817 
2818  /* Disallow pseudotype result, except VOID or RECORD */
2819  if (typeStruct->typtype == TYPTYPE_PSEUDO)
2820  {
2821  if (procStruct->prorettype == VOIDOID ||
2822  procStruct->prorettype == RECORDOID)
2823  /* okay */ ;
2824  else if (procStruct->prorettype == TRIGGEROID ||
2825  procStruct->prorettype == EVTTRIGGEROID)
2826  ereport(ERROR,
2827  (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
2828  errmsg("trigger functions can only be called "
2829  "as triggers")));
2830  else
2831  ereport(ERROR,
2832  (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
2833  errmsg("PL/Perl functions cannot return type %s",
2834  format_type_be(procStruct->prorettype))));
2835  }
2836 
2837  prodesc->result_oid = procStruct->prorettype;
2838  prodesc->fn_retisset = procStruct->proretset;
2839  prodesc->fn_retistuple = (procStruct->prorettype == RECORDOID ||
2840  typeStruct->typtype == TYPTYPE_COMPOSITE);
2841 
2842  prodesc->fn_retisarray =
2843  (typeStruct->typlen == -1 && typeStruct->typelem);
2844 
2845  fmgr_info_cxt(typeStruct->typinput,
2846  &(prodesc->result_in_func),
2847  proc_cxt);
2848  prodesc->result_typioparam = getTypeIOParam(typeTup);
2849 
2850  ReleaseSysCache(typeTup);
2851  }
2852 
2853  /************************************************************
2854  * Get the required information for output conversion
2855  * of all procedure arguments
2856  ************************************************************/
2857  if (!is_trigger && !is_event_trigger)
2858  {
2859  int i;
2860 
2861  for (i = 0; i < prodesc->nargs; i++)
2862  {
2863  typeTup = SearchSysCache1(TYPEOID,
2864  ObjectIdGetDatum(procStruct->proargtypes.values[i]));
2865  if (!HeapTupleIsValid(typeTup))
2866  elog(ERROR, "cache lookup failed for type %u",
2867  procStruct->proargtypes.values[i]);
2868  typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
2869 
2870  /* Disallow pseudotype argument */
2871  if (typeStruct->typtype == TYPTYPE_PSEUDO &&
2872  procStruct->proargtypes.values[i] != RECORDOID)
2873  ereport(ERROR,
2874  (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
2875  errmsg("PL/Perl functions cannot accept type %s",
2876  format_type_be(procStruct->proargtypes.values[i]))));
2877 
2878  if (typeStruct->typtype == TYPTYPE_COMPOSITE ||
2879  procStruct->proargtypes.values[i] == RECORDOID)
2880  prodesc->arg_is_rowtype[i] = true;
2881  else
2882  {
2883  prodesc->arg_is_rowtype[i] = false;
2884  fmgr_info_cxt(typeStruct->typoutput,
2885  &(prodesc->arg_out_func[i]),
2886  proc_cxt);
2887  }
2888 
2889  /* Identify array attributes */
2890  if (typeStruct->typelem != 0 && typeStruct->typlen == -1)
2891  prodesc->arg_arraytype[i] = procStruct->proargtypes.values[i];
2892  else
2893  prodesc->arg_arraytype[i] = InvalidOid;
2894 
2895  ReleaseSysCache(typeTup);
2896  }
2897  }
2898 
2899  /************************************************************
2900  * create the text of the anonymous subroutine.
2901  * we do not use a named subroutine so that we can call directly
2902  * through the reference.
2903  ************************************************************/
2904  prosrcdatum = SysCacheGetAttr(PROCOID, procTup,
2905  Anum_pg_proc_prosrc, &isnull);
2906  if (isnull)
2907  elog(ERROR, "null prosrc");
2908  proc_source = TextDatumGetCString(prosrcdatum);
2909 
2910  /************************************************************
2911  * Create the procedure in the appropriate interpreter
2912  ************************************************************/
2913 
2915 
2916  prodesc->interp = plperl_active_interp;
2917 
2918  plperl_create_sub(prodesc, proc_source, fn_oid);
2919 
2920  activate_interpreter(oldinterp);
2921 
2922  pfree(proc_source);
2923 
2924  if (!prodesc->reference) /* can this happen? */
2925  elog(ERROR, "could not create PL/Perl internal procedure");
2926 
2927  /************************************************************
2928  * OK, link the procedure into the correct hashtable entry.
2929  * Note we assume that the hashtable entry either doesn't exist yet,
2930  * or we already cleared its proc_ptr during the validation attempts
2931  * above. So no need to decrement an old refcount here.
2932  ************************************************************/
2933  proc_key.user_id = prodesc->lanpltrusted ? GetUserId() : InvalidOid;
2934 
2935  proc_ptr = hash_search(plperl_proc_hash, &proc_key,
2936  HASH_ENTER, NULL);
2937  /* We assume these two steps can't throw an error: */
2938  proc_ptr->proc_ptr = prodesc;
2939  increment_prodesc_refcount(prodesc);
2940  }
2941  PG_CATCH();
2942  {
2943  /*
2944  * If we got as far as creating a reference, we should be able to use
2945  * free_plperl_function() to clean up. If not, then at most we have
2946  * some PG memory resources in proc_cxt, which we can just delete.
2947  */
2948  if (prodesc && prodesc->reference)
2949  free_plperl_function(prodesc);
2950  else if (proc_cxt)
2951  MemoryContextDelete(proc_cxt);
2952 
2953  /* Be sure to restore the previous interpreter, too, for luck */
2954  activate_interpreter(oldinterp);
2955 
2956  PG_RE_THROW();
2957  }
2958  PG_END_TRY();
2959 
2960  /* restore previous error callback */
2961  error_context_stack = plperl_error_context.previous;
2962 
2963  ReleaseSysCache(procTup);
2964 
2965  return prodesc;
2966 }
2967 
2968 /* Build a hash from a given composite/row datum */
2969 static SV *
2971 {
2972  HeapTupleHeader td;
2973  Oid tupType;
2974  int32 tupTypmod;
2975  TupleDesc tupdesc;
2976  HeapTupleData tmptup;
2977  SV *sv;
2978 
2979  td = DatumGetHeapTupleHeader(attr);
2980 
2981  /* Extract rowtype info and find a tupdesc */
2982  tupType = HeapTupleHeaderGetTypeId(td);
2983  tupTypmod = HeapTupleHeaderGetTypMod(td);
2984  tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod);
2985 
2986  /* Build a temporary HeapTuple control structure */
2987  tmptup.t_len = HeapTupleHeaderGetDatumLength(td);
2988  tmptup.t_data = td;
2989 
2990  sv = plperl_hash_from_tuple(&tmptup, tupdesc);
2991  ReleaseTupleDesc(tupdesc);
2992 
2993  return sv;
2994 }
2995 
2996 /* Build a hash from all attributes of a given tuple. */
2997 static SV *
2999 {
3000  dTHX;
3001  HV *hv;
3002  int i;
3003 
3004  /* since this function recurses, it could be driven to stack overflow */
3006 
3007  hv = newHV();
3008  hv_ksplit(hv, tupdesc->natts); /* pre-grow the hash */
3009 
3010  for (i = 0; i < tupdesc->natts; i++)
3011  {
3012  Datum attr;
3013  bool isnull,
3014  typisvarlena;
3015  char *attname;
3016  Oid typoutput;
3017 
3018  if (tupdesc->attrs[i]->attisdropped)
3019  continue;
3020 
3021  attname = NameStr(tupdesc->attrs[i]->attname);
3022  attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
3023 
3024  if (isnull)
3025  {
3026  /*
3027  * Store (attname => undef) and move on. Note we can't use
3028  * &PL_sv_undef here; see "AVs, HVs and undefined values" in
3029  * perlguts for an explanation.
3030  */
3031  hv_store_string(hv, attname, newSV(0));
3032  continue;
3033  }
3034 
3035  if (type_is_rowtype(tupdesc->attrs[i]->atttypid))
3036  {
3037  SV *sv = plperl_hash_from_datum(attr);
3038 
3039  hv_store_string(hv, attname, sv);
3040  }
3041  else
3042  {
3043  SV *sv;
3044  Oid funcid;
3045 
3046  if (OidIsValid(get_base_element_type(tupdesc->attrs[i]->atttypid)))
3047  sv = plperl_ref_from_pg_array(attr, tupdesc->attrs[i]->atttypid);
3048  else if ((funcid = get_transform_fromsql(tupdesc->attrs[i]->atttypid, current_call_data->prodesc->lang_oid, current_call_data->prodesc->trftypes)))
3049  sv = (SV *) DatumGetPointer(OidFunctionCall1(funcid, attr));
3050  else
3051  {
3052  char *outputstr;
3053 
3054  /* XXX should have a way to cache these lookups */
3055  getTypeOutputInfo(tupdesc->attrs[i]->atttypid,
3056  &typoutput, &typisvarlena);
3057 
3058  outputstr = OidOutputFunctionCall(typoutput, attr);
3059  sv = cstr2sv(outputstr);
3060  pfree(outputstr);
3061  }
3062 
3063  hv_store_string(hv, attname, sv);
3064  }
3065  }
3066  return newRV_noinc((SV *) hv);
3067 }
3068 
3069 
3070 static void
3072 {
3073  /* see comment in plperl_fini() */
3074  if (plperl_ending)
3075  {
3076  /* simple croak as we don't want to involve PostgreSQL code */
3077  croak("SPI functions can not be used in END blocks");
3078  }
3079 }
3080 
3081 
3082 HV *
3083 plperl_spi_exec(char *query, int limit)
3084 {
3085  HV *ret_hv;
3086 
3087  /*
3088  * Execute the query inside a sub-transaction, so we can cope with errors
3089  * sanely
3090  */
3091  MemoryContext oldcontext = CurrentMemoryContext;
3093 
3095 
3097  /* Want to run inside function's memory context */
3098  MemoryContextSwitchTo(oldcontext);
3099 
3100  PG_TRY();
3101  {
3102  int spi_rv;
3103 
3104  pg_verifymbstr(query, strlen(query), false);
3105 
3106  spi_rv = SPI_execute(query, current_call_data->prodesc->fn_readonly,
3107  limit);
3109  spi_rv);
3110 
3111  /* Commit the inner transaction, return to outer xact context */
3113  MemoryContextSwitchTo(oldcontext);
3114  CurrentResourceOwner = oldowner;
3115  }
3116  PG_CATCH();
3117  {
3118  ErrorData *edata;
3119 
3120  /* Save error info */
3121  MemoryContextSwitchTo(oldcontext);
3122  edata = CopyErrorData();
3123  FlushErrorState();
3124 
3125  /* Abort the inner transaction */
3127  MemoryContextSwitchTo(oldcontext);
3128  CurrentResourceOwner = oldowner;
3129 
3130  /* Punt the error to Perl */
3131  croak_cstr(edata->message);
3132 
3133  /* Can't get here, but keep compiler quiet */
3134  return NULL;
3135  }
3136  PG_END_TRY();
3137 
3138  return ret_hv;
3139 }
3140 
3141 
3142 static HV *
3144  int status)
3145 {
3146  dTHX;
3147  HV *result;
3148 
3150 
3151  result = newHV();
3152 
3153  hv_store_string(result, "status",
3154  cstr2sv(SPI_result_code_string(status)));
3155  hv_store_string(result, "processed",
3156  (processed > (uint64) UV_MAX) ?
3157  newSVnv((NV) processed) :
3158  newSVuv((UV) processed));
3159 
3160  if (status > 0 && tuptable)
3161  {
3162  AV *rows;
3163  SV *row;
3164  uint64 i;
3165 
3166  /* Prevent overflow in call to av_extend() */
3167  if (processed > (uint64) AV_SIZE_MAX)
3168  ereport(ERROR,
3169  (errcode(ERRCODE_PROGRAM_LIMIT_EXCEEDED),
3170  errmsg("query result has too many rows to fit in a Perl array")));
3171 
3172  rows = newAV();
3173  av_extend(rows, processed);
3174  for (i = 0; i < processed; i++)
3175  {
3176  row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
3177  av_push(rows, row);
3178  }
3179  hv_store_string(result, "rows",
3180  newRV_noinc((SV *) rows));
3181  }
3182 
3183  SPI_freetuptable(tuptable);
3184 
3185  return result;
3186 }
3187 
3188 
3189 /*
3190  * plperl_return_next catches any error and converts it to a Perl error.
3191  * We assume (perhaps without adequate justification) that we need not abort
3192  * the current transaction if the Perl code traps the error.
3193  */
3194 void
3196 {
3197  MemoryContext oldcontext = CurrentMemoryContext;
3198 
3199  PG_TRY();
3200  {
3202  }
3203  PG_CATCH();
3204  {
3205  ErrorData *edata;
3206 
3207  /* Must reset elog.c's state */
3208  MemoryContextSwitchTo(oldcontext);
3209  edata = CopyErrorData();
3210  FlushErrorState();
3211 
3212  /* Punt the error to Perl */
3213  croak_cstr(edata->message);
3214  }
3215  PG_END_TRY();
3216 }
3217 
3218 /*
3219  * plperl_return_next_internal reports any errors in Postgres fashion
3220  * (via ereport).
3221  */
3222 static void
3224 {
3225  plperl_proc_desc *prodesc;
3226  FunctionCallInfo fcinfo;
3227  ReturnSetInfo *rsi;
3228  MemoryContext old_cxt;
3229 
3230  if (!sv)
3231  return;
3232 
3233  prodesc = current_call_data->prodesc;
3234  fcinfo = current_call_data->fcinfo;
3235  rsi = (ReturnSetInfo *) fcinfo->resultinfo;
3236 
3237  if (!prodesc->fn_retisset)
3238  ereport(ERROR,
3239  (errcode(ERRCODE_SYNTAX_ERROR),
3240  errmsg("cannot use return_next in a non-SETOF function")));
3241 
3242  if (!current_call_data->ret_tdesc)
3243  {
3244  TupleDesc tupdesc;
3245 
3246  Assert(!current_call_data->tuple_store);
3247 
3248  /*
3249  * This is the first call to return_next in the current PL/Perl
3250  * function call, so identify the output tuple descriptor and create a
3251  * tuplestore to hold the result rows.
3252  */
3253  if (prodesc->fn_retistuple)
3254  (void) get_call_result_type(fcinfo, NULL, &tupdesc);
3255  else
3256  {
3257  tupdesc = rsi->expectedDesc;
3258  /* Protect assumption below that we return exactly one column */
3259  if (tupdesc == NULL || tupdesc->natts != 1)
3260  elog(ERROR, "expected single-column result descriptor for non-composite SETOF result");
3261  }
3262 
3263  /*
3264  * Make sure the tuple_store and ret_tdesc are sufficiently
3265  * long-lived.
3266  */
3268 
3269  current_call_data->ret_tdesc = CreateTupleDescCopy(tupdesc);
3270  current_call_data->tuple_store =
3272  false, work_mem);
3273 
3274  MemoryContextSwitchTo(old_cxt);
3275  }
3276 
3277  /*
3278  * Producing the tuple we want to return requires making plenty of
3279  * palloc() allocations that are not cleaned up. Since this function can
3280  * be called many times before the current memory context is reset, we
3281  * need to do those allocations in a temporary context.
3282  */
3283  if (!current_call_data->tmp_cxt)
3284  {
3285  current_call_data->tmp_cxt =
3287  "PL/Perl return_next temporary cxt",
3289  }
3290 
3291  old_cxt = MemoryContextSwitchTo(current_call_data->tmp_cxt);
3292 
3293  if (prodesc->fn_retistuple)
3294  {
3295  HeapTuple tuple;
3296 
3297  if (!(SvOK(sv) && SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV))
3298  ereport(ERROR,
3299  (errcode(ERRCODE_DATATYPE_MISMATCH),
3300  errmsg("SETOF-composite-returning PL/Perl function "
3301  "must call return_next with reference to hash")));
3302 
3303  tuple = plperl_build_tuple_result((HV *) SvRV(sv),
3304  current_call_data->ret_tdesc);
3305  tuplestore_puttuple(current_call_data->tuple_store, tuple);
3306  }
3307  else
3308  {
3309  Datum ret[1];
3310  bool isNull[1];
3311 
3312  ret[0] = plperl_sv_to_datum(sv,
3313  prodesc->result_oid,
3314  -1,
3315  fcinfo,
3316  &prodesc->result_in_func,
3317  prodesc->result_typioparam,
3318  &isNull[0]);
3319 
3320  tuplestore_putvalues(current_call_data->tuple_store,
3321  current_call_data->ret_tdesc,
3322  ret, isNull);
3323  }
3324 
3325  MemoryContextSwitchTo(old_cxt);
3326  MemoryContextReset(current_call_data->tmp_cxt);
3327 }
3328 
3329 
3330 SV *
3331 plperl_spi_query(char *query)
3332 {
3333  SV *cursor;
3334 
3335  /*
3336  * Execute the query inside a sub-transaction, so we can cope with errors
3337  * sanely
3338  */
3339  MemoryContext oldcontext = CurrentMemoryContext;
3341 
3343 
3345  /* Want to run inside function's memory context */
3346  MemoryContextSwitchTo(oldcontext);
3347 
3348  PG_TRY();
3349  {
3350  SPIPlanPtr plan;
3351  Portal portal;
3352 
3353  /* Make sure the query is validly encoded */
3354  pg_verifymbstr(query, strlen(query), false);
3355 
3356  /* Create a cursor for the query */
3357  plan = SPI_prepare(query, 0, NULL);
3358  if (plan == NULL)
3359  elog(ERROR, "SPI_prepare() failed:%s",
3361 
3362  portal = SPI_cursor_open(NULL, plan, NULL, NULL, false);
3363  SPI_freeplan(plan);
3364  if (portal == NULL)
3365  elog(ERROR, "SPI_cursor_open() failed:%s",
3367  cursor = cstr2sv(portal->name);
3368 
3369  /* Commit the inner transaction, return to outer xact context */
3371  MemoryContextSwitchTo(oldcontext);
3372  CurrentResourceOwner = oldowner;
3373  }
3374  PG_CATCH();
3375  {
3376  ErrorData *edata;
3377 
3378  /* Save error info */
3379  MemoryContextSwitchTo(oldcontext);
3380  edata = CopyErrorData();
3381  FlushErrorState();
3382 
3383  /* Abort the inner transaction */
3385  MemoryContextSwitchTo(oldcontext);
3386  CurrentResourceOwner = oldowner;
3387 
3388  /* Punt the error to Perl */
3389  croak_cstr(edata->message);
3390 
3391  /* Can't get here, but keep compiler quiet */
3392  return NULL;
3393  }
3394  PG_END_TRY();
3395 
3396  return cursor;
3397 }
3398 
3399 
3400 SV *
3402 {
3403  SV *row;
3404 
3405  /*
3406  * Execute the FETCH inside a sub-transaction, so we can cope with errors
3407  * sanely
3408  */
3409  MemoryContext oldcontext = CurrentMemoryContext;
3411 
3413 
3415  /* Want to run inside function's memory context */
3416  MemoryContextSwitchTo(oldcontext);
3417 
3418  PG_TRY();
3419  {
3420  dTHX;
3421  Portal p = SPI_cursor_find(cursor);
3422 
3423  if (!p)
3424  {
3425  row = &PL_sv_undef;
3426  }
3427  else
3428  {
3429  SPI_cursor_fetch(p, true, 1);
3430  if (SPI_processed == 0)
3431  {
3432  SPI_cursor_close(p);
3433  row = &PL_sv_undef;
3434  }
3435  else
3436  {
3439  }
3441  }
3442 
3443  /* Commit the inner transaction, return to outer xact context */
3445  MemoryContextSwitchTo(oldcontext);
3446  CurrentResourceOwner = oldowner;
3447  }
3448  PG_CATCH();
3449  {
3450  ErrorData *edata;
3451 
3452  /* Save error info */
3453  MemoryContextSwitchTo(oldcontext);
3454  edata = CopyErrorData();
3455  FlushErrorState();
3456 
3457  /* Abort the inner transaction */
3459  MemoryContextSwitchTo(oldcontext);
3460  CurrentResourceOwner = oldowner;
3461 
3462  /* Punt the error to Perl */
3463  croak_cstr(edata->message);
3464 
3465  /* Can't get here, but keep compiler quiet */
3466  return NULL;
3467  }
3468  PG_END_TRY();
3469 
3470  return row;
3471 }
3472 
3473 void
3475 {
3476  Portal p;
3477 
3479 
3480  p = SPI_cursor_find(cursor);
3481 
3482  if (p)
3483  SPI_cursor_close(p);
3484 }
3485 
3486 SV *
3487 plperl_spi_prepare(char *query, int argc, SV **argv)
3488 {
3489  volatile SPIPlanPtr plan = NULL;
3490  volatile MemoryContext plan_cxt = NULL;
3491  plperl_query_desc *volatile qdesc = NULL;
3492  plperl_query_entry *volatile hash_entry = NULL;
3493  MemoryContext oldcontext = CurrentMemoryContext;
3495  MemoryContext work_cxt;
3496  bool found;
3497  int i;
3498 
3500 
3502  MemoryContextSwitchTo(oldcontext);
3503 
3504  PG_TRY();
3505  {
3507 
3508  /************************************************************
3509  * Allocate the new querydesc structure
3510  *
3511  * The qdesc struct, as well as all its subsidiary data, lives in its
3512  * plan_cxt. But note that the SPIPlan does not.
3513  ************************************************************/
3515  "PL/Perl spi_prepare query",
3517  MemoryContextSwitchTo(plan_cxt);
3518  qdesc = (plperl_query_desc *) palloc0(sizeof(plperl_query_desc));
3519  snprintf(qdesc->qname, sizeof(qdesc->qname), "%p", qdesc);
3520  qdesc->plan_cxt = plan_cxt;
3521  qdesc->nargs = argc;
3522  qdesc->argtypes = (Oid *) palloc(argc * sizeof(Oid));
3523  qdesc->arginfuncs = (FmgrInfo *) palloc(argc * sizeof(FmgrInfo));
3524  qdesc->argtypioparams = (Oid *) palloc(argc * sizeof(Oid));
3525  MemoryContextSwitchTo(oldcontext);
3526 
3527  /************************************************************
3528  * Do the following work in a short-lived context so that we don't
3529  * leak a lot of memory in the PL/Perl function's SPI Proc context.
3530  ************************************************************/
3532  "PL/Perl spi_prepare workspace",
3534  MemoryContextSwitchTo(work_cxt);
3535 
3536  /************************************************************
3537  * Resolve argument type names and then look them up by oid
3538  * in the system cache, and remember the required information
3539  * for input conversion.
3540  ************************************************************/
3541  for (i = 0; i < argc; i++)
3542  {
3543  Oid typId,
3544  typInput,
3545  typIOParam;
3546  int32 typmod;
3547  char *typstr;
3548 
3549  typstr = sv2cstr(argv[i]);
3550  parseTypeString(typstr, &typId, &typmod, false);
3551  pfree(typstr);
3552 
3553  getTypeInputInfo(typId, &typInput, &typIOParam);
3554 
3555  qdesc->argtypes[i] = typId;
3556  fmgr_info_cxt(typInput, &(qdesc->arginfuncs[i]), plan_cxt);
3557  qdesc->argtypioparams[i] = typIOParam;
3558  }
3559 
3560  /* Make sure the query is validly encoded */
3561  pg_verifymbstr(query, strlen(query), false);
3562 
3563  /************************************************************
3564  * Prepare the plan and check for errors
3565  ************************************************************/
3566  plan = SPI_prepare(query, argc, qdesc->argtypes);
3567 
3568  if (plan == NULL)
3569  elog(ERROR, "SPI_prepare() failed:%s",
3571 
3572  /************************************************************
3573  * Save the plan into permanent memory (right now it's in the
3574  * SPI procCxt, which will go away at function end).
3575  ************************************************************/
3576  if (SPI_keepplan(plan))
3577  elog(ERROR, "SPI_keepplan() failed");
3578  qdesc->plan = plan;
3579 
3580  /************************************************************
3581  * Insert a hashtable entry for the plan.
3582  ************************************************************/
3583  hash_entry = hash_search(plperl_active_interp->query_hash,
3584  qdesc->qname,
3585  HASH_ENTER, &found);
3586  hash_entry->query_data = qdesc;
3587 
3588  /* Get rid of workspace */
3589  MemoryContextDelete(work_cxt);
3590 
3591  /* Commit the inner transaction, return to outer xact context */
3593  MemoryContextSwitchTo(oldcontext);
3594  CurrentResourceOwner = oldowner;
3595  }
3596  PG_CATCH();
3597  {
3598  ErrorData *edata;
3599 
3600  /* Save error info */
3601  MemoryContextSwitchTo(oldcontext);
3602  edata = CopyErrorData();
3603  FlushErrorState();
3604 
3605  /* Drop anything we managed to allocate */
3606  if (hash_entry)
3607  hash_search(plperl_active_interp->query_hash,
3608  qdesc->qname,
3609  HASH_REMOVE, NULL);
3610  if (plan_cxt)
3611  MemoryContextDelete(plan_cxt);
3612  if (plan)
3613  SPI_freeplan(plan);
3614 
3615  /* Abort the inner transaction */
3617  MemoryContextSwitchTo(oldcontext);
3618  CurrentResourceOwner = oldowner;
3619 
3620  /* Punt the error to Perl */
3621  croak_cstr(edata->message);
3622 
3623  /* Can't get here, but keep compiler quiet */
3624  return NULL;
3625  }
3626  PG_END_TRY();
3627 
3628  /************************************************************
3629  * Return the query's hash key to the caller.
3630  ************************************************************/
3631  return cstr2sv(qdesc->qname);
3632 }
3633 
3634 HV *
3635 plperl_spi_exec_prepared(char *query, HV *attr, int argc, SV **argv)
3636 {
3637  HV *ret_hv;
3638  SV **sv;
3639  int i,
3640  limit,
3641  spi_rv;
3642  char *nulls;
3643  Datum *argvalues;
3644  plperl_query_desc *qdesc;
3645  plperl_query_entry *hash_entry;
3646 
3647  /*
3648  * Execute the query inside a sub-transaction, so we can cope with errors
3649  * sanely
3650  */
3651  MemoryContext oldcontext = CurrentMemoryContext;
3653 
3655 
3657  /* Want to run inside function's memory context */
3658  MemoryContextSwitchTo(oldcontext);
3659 
3660  PG_TRY();
3661  {
3662  dTHX;
3663 
3664  /************************************************************
3665  * Fetch the saved plan descriptor, see if it's o.k.
3666  ************************************************************/
3667  hash_entry = hash_search(plperl_active_interp->query_hash, query,
3668  HASH_FIND, NULL);
3669  if (hash_entry == NULL)
3670  elog(ERROR, "spi_exec_prepared: Invalid prepared query passed");
3671 
3672  qdesc = hash_entry->query_data;
3673  if (qdesc == NULL)
3674  elog(ERROR, "spi_exec_prepared: plperl query_hash value vanished");
3675 
3676  if (qdesc->nargs != argc)
3677  elog(ERROR, "spi_exec_prepared: expected %d argument(s), %d passed",
3678  qdesc->nargs, argc);
3679 
3680  /************************************************************
3681  * Parse eventual attributes
3682  ************************************************************/
3683  limit = 0;
3684  if (attr != NULL)
3685  {
3686  sv = hv_fetch_string(attr, "limit");
3687  if (sv && *sv && SvIOK(*sv))
3688  limit = SvIV(*sv);
3689  }
3690  /************************************************************
3691  * Set up arguments
3692  ************************************************************/
3693  if (argc > 0)
3694  {
3695  nulls = (char *) palloc(argc);
3696  argvalues = (Datum *) palloc(argc * sizeof(Datum));
3697  }
3698  else
3699  {
3700  nulls = NULL;
3701  argvalues = NULL;
3702  }
3703 
3704  for (i = 0; i < argc; i++)
3705  {
3706  bool isnull;
3707 
3708  argvalues[i] = plperl_sv_to_datum(argv[i],
3709  qdesc->argtypes[i],
3710  -1,
3711  NULL,
3712  &qdesc->arginfuncs[i],
3713  qdesc->argtypioparams[i],
3714  &isnull);
3715  nulls[i] = isnull ? 'n' : ' ';
3716  }
3717 
3718  /************************************************************
3719  * go
3720  ************************************************************/
3721  spi_rv = SPI_execute_plan(qdesc->plan, argvalues, nulls,
3722  current_call_data->prodesc->fn_readonly, limit);
3724  spi_rv);
3725  if (argc > 0)
3726  {
3727  pfree(argvalues);
3728  pfree(nulls);
3729  }
3730 
3731  /* Commit the inner transaction, return to outer xact context */
3733  MemoryContextSwitchTo(oldcontext);
3734  CurrentResourceOwner = oldowner;
3735  }
3736  PG_CATCH();
3737  {
3738  ErrorData *edata;
3739 
3740  /* Save error info */
3741  MemoryContextSwitchTo(oldcontext);
3742  edata = CopyErrorData();
3743  FlushErrorState();
3744 
3745  /* Abort the inner transaction */
3747  MemoryContextSwitchTo(oldcontext);
3748  CurrentResourceOwner = oldowner;
3749 
3750  /* Punt the error to Perl */
3751  croak_cstr(edata->message);
3752 
3753  /* Can't get here, but keep compiler quiet */
3754  return NULL;
3755  }
3756  PG_END_TRY();
3757 
3758  return ret_hv;
3759 }
3760 
3761 SV *
3762 plperl_spi_query_prepared(char *query, int argc, SV **argv)
3763 {
3764  int i;
3765  char *nulls;
3766  Datum *argvalues;
3767  plperl_query_desc *qdesc;
3768  plperl_query_entry *hash_entry;
3769  SV *cursor;
3770  Portal portal = NULL;
3771 
3772  /*
3773  * Execute the query inside a sub-transaction, so we can cope with errors
3774  * sanely
3775  */
3776  MemoryContext oldcontext = CurrentMemoryContext;
3778 
3780 
3782  /* Want to run inside function's memory context */
3783  MemoryContextSwitchTo(oldcontext);
3784 
3785  PG_TRY();
3786  {
3787  /************************************************************
3788  * Fetch the saved plan descriptor, see if it's o.k.
3789  ************************************************************/
3790  hash_entry = hash_search(plperl_active_interp->query_hash, query,
3791  HASH_FIND, NULL);
3792  if (hash_entry == NULL)
3793  elog(ERROR, "spi_query_prepared: Invalid prepared query passed");
3794 
3795  qdesc = hash_entry->query_data;
3796  if (qdesc == NULL)
3797  elog(ERROR, "spi_query_prepared: plperl query_hash value vanished");
3798 
3799  if (qdesc->nargs != argc)
3800  elog(ERROR, "spi_query_prepared: expected %d argument(s), %d passed",
3801  qdesc->nargs, argc);
3802 
3803  /************************************************************
3804  * Set up arguments
3805  ************************************************************/
3806  if (argc > 0)
3807  {
3808  nulls = (char *) palloc(argc);
3809  argvalues = (Datum *) palloc(argc * sizeof(Datum));
3810  }
3811  else
3812  {
3813  nulls = NULL;
3814  argvalues = NULL;
3815  }
3816 
3817  for (i = 0; i < argc; i++)
3818  {
3819  bool isnull;
3820 
3821  argvalues[i] = plperl_sv_to_datum(argv[i],
3822  qdesc->argtypes[i],
3823  -1,
3824  NULL,
3825  &qdesc->arginfuncs[i],
3826  qdesc->argtypioparams[i],
3827  &isnull);
3828  nulls[i] = isnull ? 'n' : ' ';
3829  }
3830 
3831  /************************************************************
3832  * go
3833  ************************************************************/
3834  portal = SPI_cursor_open(NULL, qdesc->plan, argvalues, nulls,
3835  current_call_data->prodesc->fn_readonly);
3836  if (argc > 0)
3837  {
3838  pfree(argvalues);
3839  pfree(nulls);
3840  }
3841  if (portal == NULL)
3842  elog(ERROR, "SPI_cursor_open() failed:%s",
3844 
3845  cursor = cstr2sv(portal->name);
3846 
3847  /* Commit the inner transaction, return to outer xact context */
3849  MemoryContextSwitchTo(oldcontext);
3850  CurrentResourceOwner = oldowner;
3851  }
3852  PG_CATCH();
3853  {
3854  ErrorData *edata;
3855 
3856  /* Save error info */
3857  MemoryContextSwitchTo(oldcontext);
3858  edata = CopyErrorData();
3859  FlushErrorState();
3860 
3861  /* Abort the inner transaction */
3863  MemoryContextSwitchTo(oldcontext);
3864  CurrentResourceOwner = oldowner;
3865 
3866  /* Punt the error to Perl */
3867  croak_cstr(edata->message);
3868 
3869  /* Can't get here, but keep compiler quiet */
3870  return NULL;
3871  }
3872  PG_END_TRY();
3873 
3874  return cursor;
3875 }
3876 
3877 void
3879 {
3880  SPIPlanPtr plan;
3881  plperl_query_desc *qdesc;
3882  plperl_query_entry *hash_entry;
3883 
3885 
3886  hash_entry = hash_search(plperl_active_interp->query_hash, query,
3887  HASH_FIND, NULL);
3888  if (hash_entry == NULL)
3889  elog(ERROR, "spi_freeplan: Invalid prepared query passed");
3890 
3891  qdesc = hash_entry->query_data;
3892  if (qdesc == NULL)
3893  elog(ERROR, "spi_freeplan: plperl query_hash value vanished");
3894  plan = qdesc->plan;
3895 
3896  /*
3897  * free all memory before SPI_freeplan, so if it dies, nothing will be
3898  * left over
3899  */
3900  hash_search(plperl_active_interp->query_hash, query,
3901  HASH_REMOVE, NULL);
3902 
3903  MemoryContextDelete(qdesc->plan_cxt);
3904 
3905  SPI_freeplan(plan);
3906 }
3907 
3908 /*
3909  * Implementation of plperl's elog() function
3910  *
3911  * If the error level is less than ERROR, we'll just emit the message and
3912  * return. When it is ERROR, elog() will longjmp, which we catch and
3913  * turn into a Perl croak(). Note we are assuming that elog() can't have
3914  * any internal failures that are so bad as to require a transaction abort.
3915  *
3916  * The main reason this is out-of-line is to avoid conflicts between XSUB.h
3917  * and the PG_TRY macros.
3918  */
3919 void
3920 plperl_util_elog(int level, SV *msg)
3921 {
3922  MemoryContext oldcontext = CurrentMemoryContext;
3923  char *volatile cmsg = NULL;
3924 
3925  PG_TRY();
3926  {
3927  cmsg = sv2cstr(msg);
3928  elog(level, "%s", cmsg);
3929  pfree(cmsg);
3930  }
3931  PG_CATCH();
3932  {
3933  ErrorData *edata;
3934 
3935  /* Must reset elog.c's state */
3936  MemoryContextSwitchTo(oldcontext);
3937  edata = CopyErrorData();
3938  FlushErrorState();
3939 
3940  if (cmsg)
3941  pfree(cmsg);
3942 
3943  /* Punt the error to Perl */
3944  croak_cstr(edata->message);
3945  }
3946  PG_END_TRY();
3947 }
3948 
3949 /*
3950  * Store an SV into a hash table under a key that is a string assumed to be
3951  * in the current database's encoding.
3952  */
3953 static SV **
3954 hv_store_string(HV *hv, const char *key, SV *val)
3955 {
3956  dTHX;
3957  int32 hlen;
3958  char *hkey;
3959  SV **ret;
3960 
3961  hkey = pg_server_to_any(key, strlen(key), PG_UTF8);
3962 
3963  /*
3964  * hv_store() recognizes a negative klen parameter as meaning a UTF-8
3965  * encoded key.
3966  */
3967  hlen = -(int) strlen(hkey);
3968  ret = hv_store(hv, hkey, hlen, val, 0);
3969 
3970  if (hkey != key)
3971  pfree(hkey);
3972 
3973  return ret;
3974 }
3975 
3976 /*
3977  * Fetch an SV from a hash table under a key that is a string assumed to be
3978  * in the current database's encoding.
3979  */
3980 static SV **
3981 hv_fetch_string(HV *hv, const char *key)
3982 {
3983  dTHX;
3984  int32 hlen;
3985  char *hkey;
3986  SV **ret;
3987 
3988  hkey = pg_server_to_any(key, strlen(key), PG_UTF8);
3989 
3990  /* See notes in hv_store_string */
3991  hlen = -(int) strlen(hkey);
3992  ret = hv_fetch(hv, hkey, hlen, 0);
3993 
3994  if (hkey != key)
3995  pfree(hkey);
3996 
3997  return ret;
3998 }
3999 
4000 /*
4001  * Provide function name for PL/Perl execution errors
4002  */
4003 static void
4005 {
4006  char *procname = (char *) arg;
4007 
4008  if (procname)
4009  errcontext("PL/Perl function \"%s\"", procname);
4010 }
4011 
4012 /*
4013  * Provide function name for PL/Perl compilation errors
4014  */
4015 static void
4017 {
4018  char *procname = (char *) arg;
4019 
4020  if (procname)
4021  errcontext("compilation of PL/Perl function \"%s\"", procname);
4022 }
4023 
4024 /*
4025  * Provide error context for the inline handler
4026  */
4027 static void
4029 {
4030  errcontext("PL/Perl anonymous code block");
4031 }
4032 
4033 
4034 /*
4035  * Perl's own setlocale(), copied from POSIX.xs
4036  * (needed because of the calls to new_*())
4037  */
4038 #ifdef WIN32
4039 static char *
4040 setlocale_perl(int category, char *locale)
4041 {
4042  dTHX;
4043  char *RETVAL = setlocale(category, locale);
4044 
4045  if (RETVAL)
4046  {
4047 #ifdef USE_LOCALE_CTYPE
4048  if (category == LC_CTYPE
4049 #ifdef LC_ALL
4050  || category == LC_ALL
4051 #endif
4052  )
4053  {
4054  char *newctype;
4055 
4056 #ifdef LC_ALL
4057  if (category == LC_ALL)
4058  newctype = setlocale(LC_CTYPE, NULL);
4059  else
4060 #endif
4061  newctype = RETVAL;
4062  new_ctype(newctype);
4063  }
4064 #endif /* USE_LOCALE_CTYPE */
4065 #ifdef USE_LOCALE_COLLATE
4066  if (category == LC_COLLATE
4067 #ifdef LC_ALL
4068  || category == LC_ALL
4069 #endif
4070  )
4071  {
4072  char *newcoll;
4073 
4074 #ifdef LC_ALL
4075  if (category == LC_ALL)
4076  newcoll = setlocale(LC_COLLATE, NULL);
4077  else
4078 #endif
4079  newcoll = RETVAL;
4080  new_collate(newcoll);
4081  }
4082 #endif /* USE_LOCALE_COLLATE */
4083 
4084 #ifdef USE_LOCALE_NUMERIC
4085  if (category == LC_NUMERIC
4086 #ifdef LC_ALL
4087  || category == LC_ALL
4088 #endif
4089  )
4090  {
4091  char *newnum;
4092 
4093 #ifdef LC_ALL
4094  if (category == LC_ALL)
4095  newnum = setlocale(LC_NUMERIC, NULL);
4096  else
4097 #endif
4098  newnum = RETVAL;
4099  new_numeric(newnum);
4100  }
4101 #endif /* USE_LOCALE_NUMERIC */
4102  }
4103 
4104  return RETVAL;
4105 }
4106 
4107 #endif /* WIN32 */
int SPI_fnumber(TupleDesc tupdesc, const char *fname)
Definition: spi.c:761
void tuplestore_putvalues(Tuplestorestate *state, TupleDesc tdesc, Datum *values, bool *isnull)
Definition: tuplestore.c:750
signed short int16
Definition: c.h:255
#define eval_pv(a, b)
Definition: ppport.h:4314
Datum makeMdArrayResult(ArrayBuildState *astate, int ndims, int *dims, int *lbs, MemoryContext rcontext, bool release)
Definition: arrayfuncs.c:5086
#define NIL
Definition: pg_list.h:69
#define HeUTF8(he)
Definition: plperl.h:93
static SV * plperl_ref_from_pg_array(Datum arg, Oid typid)
Definition: plperl.c:1447
FmgrInfo transform_proc
Definition: plperl.c:220
EXTERN_C void boot_PostgreSQL__InServer__SPI(pTHX_ CV *cv)
#define SPI_OK_CONNECT
Definition: spi.h:50
Oid get_transform_fromsql(Oid typid, Oid langid, List *trftypes)
Definition: lsyscache.c:1872
static char plperl_opmask[MAXO]
Definition: plperl.c:242
static PerlInterpreter * plperl_init_interp(void)
Definition: plperl.c:710
Definition: fmgr.h:56
Definition: plperl.c:203
static bool validate_plperl_function(plperl_proc_ptr *proc_ptr, HeapTuple procTup)
Definition: plperl.c:2637
#define CALLED_AS_EVENT_TRIGGER(fcinfo)
Definition: event_trigger.h:40
TupleDesc CreateTupleDescCopy(TupleDesc tupdesc)
Definition: tupdesc.c:141
static Datum plperl_func_handler(PG_FUNCTION_ARGS)
Definition: plperl.c:2375
#define IsA(nodeptr, _type_)
Definition: nodes.h:560
List * trftypes
Definition: plperl.c:118
void MemoryContextDelete(MemoryContext context)
Definition: mcxt.c:200
#define PL_ppaddr
Definition: ppport.h:4085
static HTAB * plperl_proc_hash
Definition: plperl.c:228
#define decrement_prodesc_refcount(prodesc)
Definition: plperl.c:136
TypeFuncClass get_call_result_type(FunctionCallInfo fcinfo, Oid *resultTypeId, TupleDesc *resultTupleDesc)
Definition: funcapi.c:211
struct plperl_call_data plperl_call_data
static SV * get_perl_array_ref(SV *sv)
Definition: plperl.c:1142
bool * arg_is_rowtype
Definition: plperl.c:130
void getTypeOutputInfo(Oid type, Oid *typOutput, bool *typIsVarlena)
Definition: lsyscache.c:2632
#define GETSTRUCT(TUP)
Definition: htup_details.h:656
#define TEXTDOMAIN
Definition: plperl.c:48
MemoryContext fn_mcxt
Definition: fmgr.h:65
static char * hek2cstr(HE *he)
Definition: plperl.c:325
static Datum plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod, FunctionCallInfo fcinfo, FmgrInfo *finfo, Oid typioparam, bool *isnull)
Definition: plperl.c:1311
HTAB * query_hash
Definition: plperl.c:94
static Datum plperl_array_to_datum(SV *src, Oid typid, int32 typmod)
Definition: plperl.c:1244
#define HASH_ELEM
Definition: hsearch.h:87
static char * plperl_on_init
Definition: plperl.c:236
static void plperl_init_shared_libs(pTHX)
Definition: plperl.c:2139
TupleDesc lookup_rowtype_tupdesc(Oid type_id, int32 typmod)
Definition: typcache.c:1257
static bool plperl_ending
Definition: plperl.c:240
uint32 TransactionId
Definition: c.h:397
FunctionCallInfo fcinfo
Definition: plperl.c:181
ArrayBuildState * initArrayResult(Oid element_type, MemoryContext rcontext, bool subcontext)
Definition: arrayfuncs.c:4951
#define dTHX
Definition: ppport.h:3208
static void select_perl_context(bool trusted)
Definition: plperl.c:557
#define MAXDIM
Definition: c.h:419
#define DEBUG3
Definition: elog.h:23
Oid GetUserId(void)
Definition: miscinit.c:284
SPIPlanPtr plan
Definition: plperl.c:194
EXTERN_C void boot_DynaLoader(pTHX_ CV *cv)
int SPI_connect(void)
Definition: spi.c:84
SV * plperl_spi_query(char *query)
Definition: plperl.c:3331
static HeapTuple plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
Definition: plperl.c:1723
#define TYPTYPE_COMPOSITE
Definition: pg_type.h:721
void on_proc_exit(pg_on_exit_callback function, Datum arg)
Definition: ipc.c:292
ErrorData * CopyErrorData(void)
Definition: elog.c:1497
fmNodePtr context
Definition: fmgr.h:80
Oid get_element_type(Oid typid)
Definition: lsyscache.c:2484
struct plperl_proc_desc plperl_proc_desc
#define PointerGetDatum(X)
Definition: postgres.h:562
#define GvCV_set(gv, cv)
Definition: plperl.h:100
Oid * argtypioparams
Definition: plperl.c:198
ResourceOwner CurrentResourceOwner
Definition: resowner.c:138
char * pstrdup(const char *in)
Definition: mcxt.c:1077
SPIPlanPtr SPI_prepare(const char *src, int nargs, Oid *argtypes)
Definition: spi.c:482
#define ALLOCSET_SMALL_SIZES
Definition: memutils.h:175
void ReleaseCurrentSubTransaction(void)
Definition: xact.c:4126
static void set_interp_require(bool trusted)
Definition: plperl.c:494
int SPI_finish(void)
Definition: spi.c:148
struct plperl_interp_desc plperl_interp_desc
Form_pg_attribute * attrs
Definition: tupdesc.h:74
#define AV_SIZE_MAX
Definition: plperl.h:107
int get_func_arg_info(HeapTuple procTup, Oid **p_argtypes, char ***p_argnames, char **p_argmodes)
Definition: funcapi.c:791
static MemoryContext MemoryContextSwitchTo(MemoryContext context)
Definition: palloc.h:109
#define Anum_pg_proc_prosrc
Definition: pg_proc.h:115
Oid get_func_signature(Oid funcid, Oid **argtypes, int *nargs)
Definition: lsyscache.c:1500
SV * plperl_spi_fetchrow(char *cursor)
Definition: plperl.c:3401
Size entrysize
Definition: hsearch.h:73
#define gettext_noop(x)
Definition: c.h:139
SPITupleTable * SPI_tuptable
Definition: spi.c:41
#define PL_sv_undef
Definition: ppport.h:4129
int errcode(int sqlerrcode)
Definition: elog.c:575
#define ERRSV
Definition: ppport.h:3859
static SV ** hv_fetch_string(HV *hv, const char *key)
Definition: plperl.c:3981
char get_typtype(Oid typid)
Definition: lsyscache.c:2379
MemoryContext fn_cxt
Definition: plperl.c:110
#define MemSet(start, val, len)
Definition: c.h:858
static SV * plperl_hash_from_datum(Datum attr)
Definition: plperl.c:2970
char * format_type_be(Oid type_oid)
Definition: format_type.c:94
const char * tag
Definition: event_trigger.h:28
#define Anum_pg_proc_protrftypes
Definition: pg_proc.h:114
void plperl_spi_cursor_close(char *cursor)
Definition: plperl.c:3474
static plperl_interp_desc * plperl_active_interp
Definition: plperl.c:229
return result
Definition: formatting.c:1633
int snprintf(char *str, size_t count, const char *fmt,...) pg_attribute_printf(3
#define PG_GETARG_POINTER(n)
Definition: fmgr.h:241
void MemoryContextReset(MemoryContext context)
Definition: mcxt.c:135
Portal SPI_cursor_open(const char *name, SPIPlanPtr plan, Datum *Values, const char *Nulls, bool read_only)
Definition: spi.c:1029
HeapTuple heap_form_tuple(TupleDesc tupleDescriptor, Datum *values, bool *isnull)
Definition: heaptuple.c:692
#define DirectFunctionCall1(func, arg1)
Definition: fmgr.h:584
int pg_strcasecmp(const char *s1, const char *s2)
Definition: pgstrcasecmp.c:36
struct plperl_query_desc plperl_query_desc
void * hash_search(HTAB *hashp, const void *keyPtr, HASHACTION action, bool *foundPtr)
Definition: dynahash.c:902
FormData_pg_type * Form_pg_type
Definition: pg_type.h:233
PerlInterpreter * interp
Definition: plperl.c:93
bool check_function_bodies
Definition: guc.c:447
static SV ** hv_store_string(HV *hv, const char *key, SV *val)
Definition: plperl.c:3954
unsigned int Oid
Definition: postgres_ext.h:31
HeapTuple * vals
Definition: spi.h:28
#define TRIGGER_FIRED_AFTER(event)
Definition: trigger.h:137
Datum oidout(PG_FUNCTION_ARGS)
Definition: oid.c:127
FmgrInfo * arg_out_func
Definition: plperl.c:129
struct ErrorContextCallback * previous
Definition: elog.h:238
#define OidIsValid(objectId)
Definition: c.h:538
#define DatumGetHeapTupleHeader(X)
Definition: fmgr.h:259
SV * plperl_spi_prepare(char *query, int argc, SV **argv)
Definition: plperl.c:3487
plperl_proc_key proc_key
Definition: plperl.c:170
#define aTHX_
Definition: ppport.h:3227
int natts
Definition: tupdesc.h:73
#define dVAR
Definition: ppport.h:3934
void FlushErrorState(void)
Definition: elog.c:1587
uint64 SPI_processed
Definition: spi.c:39
#define TRIGGER_FIRED_FOR_STATEMENT(event)
Definition: trigger.h:131
#define SearchSysCache1(cacheId, key1)
Definition: syscache.h:156
static void plperl_event_trigger_handler(PG_FUNCTION_ARGS)
Definition: plperl.c:2600
HeapTuple tg_trigtuple
Definition: trigger.h:35
char * pg_server_to_any(const char *s, int len, int encoding)
Definition: mbutils.c:645
signed int int32
Definition: c.h:256
#define PERL_UNUSED_VAR(x)
Definition: ppport.h:3730
static SV * split_array(plperl_array_info *info, int first, int last, int nest)
Definition: plperl.c:1526
char * OutputFunctionCall(FmgrInfo *flinfo, Datum val)
Definition: fmgr.c:1667
Portal SPI_cursor_find(const char *name)
Definition: spi.c:1335
HeapTupleHeader t_data
Definition: htup.h:67
static void plperl_call_perl_event_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo, SV *td)
Definition: plperl.c:2312
ErrorContextCallback * error_context_stack
Definition: elog.c:88
#define HeapTupleHeaderGetTypMod(tup)
Definition: htup_details.h:455
void plperl_spi_freeplan(char *query)
Definition: plperl.c:3878
#define NAMEDATALEN
List * oid_array_to_list(Datum datum)
Definition: pg_proc.c:1156
#define EXTERN_C
Definition: ppport.h:3808
int SPI_result
Definition: spi.c:42
FmgrInfo * flinfo
Definition: fmgr.h:79
static void plperl_untrusted_init(void)
Definition: plperl.c:1043
Definition: dynahash.c:208
TupleDesc expectedDesc
Definition: execnodes.h:267
NVTYPE NV
Definition: ppport.h:3754
static Datum plperl_trigger_handler(PG_FUNCTION_ARGS)
Definition: plperl.c:2487
void pfree(void *pointer)
Definition: mcxt.c:950
const char * name
Definition: portal.h:117
static SV * make_array_ref(plperl_array_info *info, int first, int last)
Definition: plperl.c:1560
#define TRIGGER_FIRED_BY_TRUNCATE(event)
Definition: trigger.h:125
bool fn_retisset
Definition: plperl.c:121
#define VOIDOID
Definition: pg_type.h:690
#define OPAQUEOID
Definition: pg_type.h:700
#define ObjectIdGetDatum(X)
Definition: postgres.h:513
#define ERROR
Definition: elog.h:43
plperl_proc_desc * proc_ptr
Definition: plperl.c:171
#define DatumGetCString(X)
Definition: postgres.h:572
ItemPointerData fn_tid
Definition: plperl.c:113
bool CheckFunctionValidatorAccess(Oid validatorOid, Oid functionOid)
Definition: fmgr.c:2101
char * tgname
Definition: reltrigger.h:27
#define FALSE
Definition: c.h:221
#define newSVuv(uv)
Definition: ppport.h:3596
#define ARR_DIMS(a)
Definition: array.h:275
void fmgr_info(Oid functionId, FmgrInfo *finfo)
Definition: fmgr.c:127
const char * event
Definition: event_trigger.h:26
Definition: guc.h:75
void EmitWarningsOnPlaceholders(const char *className)
Definition: guc.c:7879
#define TRIGGEROID
Definition: pg_type.h:692
ItemPointerData t_self
Definition: htup.h:65
int SPI_execute_plan(SPIPlanPtr plan, Datum *Values, const char *Nulls, bool read_only, long tcount)
Definition: spi.c:339
FmgrInfo result_in_func
Definition: plperl.c:125
#define OidFunctionCall1(functionId, arg1)
Definition: fmgr.h:622
const char * SPI_result_code_string(int code)
Definition: spi.c:1513
#define ALLOCSET_DEFAULT_SIZES
Definition: memutils.h:165
void tuplestore_puttuple(Tuplestorestate *state, HeapTuple tuple)
Definition: tuplestore.c:730
uint32 t_len
Definition: htup.h:64
static plperl_proc_desc * compile_plperl_function(Oid fn_oid, bool is_trigger, bool is_event_trigger)
Definition: plperl.c:2684
char query_name[NAMEDATALEN]
Definition: plperl.c:205
static OP *(* pp_require_orig)(pTHX)
Definition: plperl.c:241
int SPI_keepplan(SPIPlanPtr plan)
Definition: spi.c:560
Datum plperl_call_handler(PG_FUNCTION_ARGS)
Definition: plperl.c:1807
static void plperl_trusted_init(void)
Definition: plperl.c:962
void RollbackAndReleaseCurrentSubTransaction(void)
Definition: xact.c:4160
#define PG_GETARG_OID(n)
Definition: fmgr.h:240
void check_stack_depth(void)
Definition: postgres.c:3117
static void plperl_fini(int code, Datum arg)
Definition: plperl.c:513
#define SPI_ERROR_NOATTRIBUTE
Definition: spi.h:44
#define pTHX_
Definition: ppport.h:3219
#define CStringGetDatum(X)
Definition: postgres.h:584
Definition: type.h:124
static void activate_interpreter(plperl_interp_desc *interp_desc)
Definition: plperl.c:689
fmNodePtr resultinfo
Definition: fmgr.h:81
static Datum plperl_hash_to_datum(SV *src, TupleDesc td)
Definition: plperl.c:1130
Oid * argtypes
Definition: plperl.c:196
#define RECORDOID
Definition: pg_type.h:680
bool argnull[FUNC_MAX_ARGS]
Definition: fmgr.h:86
MemoryContext CurrentMemoryContext
Definition: mcxt.c:37
TupleDesc lookup_rowtype_tupdesc_noerror(Oid type_id, int32 typmod, bool noError)
Definition: typcache.c:1274
MemoryContext plan_cxt
Definition: plperl.c:193
Definition: type.h:82
bool type_is_rowtype(Oid typid)
Definition: lsyscache.c:2404
static void plperl_exec_callback(void *arg)
Definition: plperl.c:4004
void fmgr_info_cxt(Oid functionId, FmgrInfo *finfo, MemoryContext mcxt)
Definition: fmgr.c:137
#define increment_prodesc_refcount(prodesc)
Definition: plperl.c:134
Oid result_typioparam
Definition: plperl.c:126
void getTypeInputInfo(Oid type, Oid *typInput, Oid *typIOParam)
Definition: lsyscache.c:2599
#define ereport(elevel, rest)
Definition: elog.h:122
int SPI_register_trigger_data(TriggerData *tdata)
Definition: spi.c:2730
void plperl_util_elog(int level, SV *msg)
Definition: plperl.c:3920
Oid * arg_arraytype
Definition: plperl.c:131
MemoryContext TopMemoryContext
Definition: mcxt.c:43
Oid rd_id
Definition: rel.h:116
unsigned long fn_refcount
Definition: plperl.c:111
char * plperl_sv_to_literal(SV *sv, char *fqtypename)
Definition: plperl.c:1413
Definition: guc.h:72
#define PROVOLATILE_VOLATILE
Definition: pg_proc.h:5488
PG_MODULE_MAGIC
Definition: plperl.c:63
static SV * plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
Definition: plperl.c:2998
#define WARNING
Definition: elog.h:40
#define heap_getattr(tup, attnum, tupleDesc, isnull)
Definition: htup_details.h:769
void SPI_freetuptable(SPITupleTable *tuptable)
Definition: spi.c:970
char ** tgargs
Definition: reltrigger.h:40
#define newRV_noinc(a)
Definition: ppport.h:4456
#define TRIGGER_FIRED_BY_DELETE(event)
Definition: trigger.h:119
Tuplestorestate * tuplestore_begin_heap(bool randomAccess, bool interXact, int maxKBytes)
Definition: tuplestore.c:318
struct @18::@19 av[32]
#define HASH_BLOBS
Definition: hsearch.h:88
#define TextDatumGetCString(d)
Definition: builtins.h:92
static void plperl_return_next_internal(SV *sv)
Definition: plperl.c:3223
Datum regtypein(PG_FUNCTION_ARGS)
Definition: regproc.c:1061
MemoryContext AllocSetContextCreate(MemoryContext parent, const char *name, Size minContextSize, Size initBlockSize, Size maxBlockSize)
Definition: aset.c:322
Oid is_trigger
Definition: plperl.c:164
void * palloc0(Size size)
Definition: mcxt.c:878
char qname[24]
Definition: plperl.c:192
void DefineCustomStringVariable(const char *name, const char *short_desc, const char *long_desc, char **valueAddr, const char *bootValue, GucContext context, int flags, GucStringCheckHook check_hook, GucStringAssignHook assign_hook, GucShowHook show_hook)
Definition: guc.c:7826
HTAB * hash_create(const char *tabname, long nelem, HASHCTL *info, int flags)
Definition: dynahash.c:316
uintptr_t Datum
Definition: postgres.h:372
SV * plperl_spi_query_prepared(char *query, int argc, SV **argv)
Definition: plperl.c:3762
void ReleaseSysCache(HeapTuple tuple)
Definition: syscache.c:1117
Datum SysCacheGetAttr(int cacheId, HeapTuple tup, AttrNumber attributeNumber, bool *isNull)
Definition: syscache.c:1279
static void free_plperl_function(plperl_proc_desc *prodesc)
Definition: plperl.c:2666
FmgrInfo * arginfuncs
Definition: plperl.c:197
static void croak_cstr(const char *str)
#define HeapTupleHeaderGetTypeId(tup)
Definition: htup_details.h:445
Size keysize
Definition: hsearch.h:72
int work_mem
Definition: globals.c:113
#define newRV_inc(sv)
Definition: ppport.h:4442
TupleDesc tupdesc
Definition: spi.h:27
Tuplestorestate * tuple_store
Definition: plperl.c:182
Trigger * tg_trigger
Definition: trigger.h:37
TupleDesc rd_att
Definition: rel.h:115
HeapTuple tg_newtuple
Definition: trigger.h:36
static void plperl_destroy_interp(PerlInterpreter **)
Definition: plperl.c:923
bool elem_is_rowtype
Definition: plperl.c:215
FormData_pg_proc * Form_pg_proc
Definition: pg_proc.h:83
static SV * cstr2sv(const char *str)
void parseTypeString(const char *str, Oid *typeid_p, int32 *typmod_p, bool missing_ok)
Definition: parse_type.c:781
Datum InputFunctionCall(FmgrInfo *flinfo, char *str, Oid typioparam, int32 typmod)
Definition: fmgr.c:1623
#define UV_MAX
Definition: ppport.h:3566
char * SPI_getrelname(Relation rel)
Definition: spi.c:910
static void SvREFCNT_dec_current(SV *sv)
Definition: plperl.c:314
#define InvalidOid
Definition: postgres_ext.h:36
Oid fn_oid
Definition: fmgr.h:59
static void plperl_create_sub(plperl_proc_desc *desc, char *s, Oid fn_oid)
Definition: plperl.c:2064
int allowedModes
Definition: execnodes.h:268
TupleDesc ret_tdesc
Definition: plperl.c:183
static void plperl_inline_callback(void *arg)
Definition: plperl.c:4028
bool fn_readonly
Definition: plperl.c:116
Datum arg[FUNC_MAX_ARGS]
Definition: fmgr.h:85
pqsigfunc pqsignal(int signum, pqsigfunc handler)
Definition: signal.c:168
static SV * plperl_trigger_build_args(FunctionCallInfo fcinfo)
Definition: plperl.c:1598
#define PG_RETURN_VOID()
Definition: fmgr.h:309
MemoryContext tmp_cxt
Definition: plperl.c:184
EXTERN_C void boot_PostgreSQL__InServer__Util(pTHX_ CV *cv)
SetFunctionReturnMode returnMode
Definition: execnodes.h:270
#define PG_CATCH()
Definition: elog.h:293
#define HeapTupleIsValid(tuple)
Definition: htup.h:77
static char * plperl_on_plperl_init
Definition: plperl.c:237
#define EVTTRIGGEROID
Definition: pg_type.h:694
#define NULL
Definition: c.h:229
#define CALLED_AS_TRIGGER(fcinfo)
Definition: trigger.h:25
#define Assert(condition)
Definition: c.h:676
static bool plperl_use_strict
Definition: plperl.c:235
TriggerEvent tg_event
Definition: trigger.h:33
SV * reference
Definition: plperl.c:114
char * SPI_getnspname(Relation rel)
Definition: spi.c:916
void BeginInternalSubTransaction(char *name)
Definition: xact.c:4056
void plperl_return_next(SV *sv)
Definition: plperl.c:3195
#define SPI_OK_FINISH
Definition: spi.h:51
static SV * plperl_event_trigger_build_args(FunctionCallInfo fcinfo)
Definition: plperl.c:1705
#define HeapTupleHeaderGetRawXmin(tup)
Definition: htup_details.h:302
#define PG_RE_THROW()
Definition: elog.h:314
static char * strip_trailing_ws(const char *msg)
Definition: plperl.c:1066
#define HeapTupleGetDatum(tuple)
Definition: funcapi.h:222
void * hash_seq_search(HASH_SEQ_STATUS *status)
Definition: dynahash.c:1385
static char * plperl_on_plperlu_init
Definition: plperl.c:238
MemoryContext ecxt_per_query_memory
Definition: execnodes.h:202
#define ARR_NDIM(a)
Definition: array.h:271
struct plperl_proc_key plperl_proc_key
bool ItemPointerEquals(ItemPointer pointer1, ItemPointer pointer2)
Definition: itemptr.c:29
void hash_seq_init(HASH_SEQ_STATUS *status, HTAB *hashp)
Definition: dynahash.c:1375
const char * name
Definition: encode.c:521
static HeapTuple plperl_build_tuple_result(HV *perlhash, TupleDesc td)
Definition: plperl.c:1080
FmgrInfo proc
Definition: plperl.c:219
Oid get_transform_tosql(Oid typid, Oid langid, List *trftypes)
Definition: lsyscache.c:1893
#define TYPTYPE_PSEUDO
Definition: pg_type.h:724
Tuplestorestate * setResult
Definition: execnodes.h:273
#define DatumGetPointer(X)
Definition: postgres.h:555
static void check_spi_usage_allowed(void)
Definition: plperl.c:3071
#define pTHX
Definition: ppport.h:3215
PG_FUNCTION_INFO_V1(plperl_call_handler)
#define TRIGGER_FIRED_BEFORE(event)
Definition: trigger.h:134
void deconstruct_array(ArrayType *array, Oid elmtype, int elmlen, bool elmbyval, char elmalign, Datum **elemsp, bool **nullsp, int *nelemsp)
Definition: arrayfuncs.c:3475
static void plperl_compile_callback(void *arg)
Definition: plperl.c:4016
int SPI_freeplan(SPIPlanPtr plan)
Definition: spi.c:609
static Datum values[MAXATTR]
Definition: bootstrap.c:163
void SPI_cursor_close(Portal portal)
Definition: spi.c:1403
#define TRIGGER_FIRED_INSTEAD(event)
Definition: trigger.h:140
static PerlInterpreter * plperl_held_interp
Definition: plperl.c:232
ArrayBuildState * accumArrayResult(ArrayBuildState *astate, Datum dvalue, bool disnull, Oid element_type, MemoryContext rcontext)
Definition: arrayfuncs.c:4990
Oid get_base_element_type(Oid typid)
Definition: lsyscache.c:2557
ExprContext * econtext
Definition: execnodes.h:266
bool * nulls
Definition: plperl.c:217
static OP * pp_require_safe(pTHX)
Definition: plperl.c:885
static HTAB * plperl_interp_hash
Definition: plperl.c:227
#define TRIGGER_FIRED_BY_INSERT(event)
Definition: trigger.h:116
TupleDesc setDesc
Definition: execnodes.h:274
void(* callback)(void *arg)
Definition: elog.h:239
char * OidOutputFunctionCall(Oid functionId, Datum val)
Definition: fmgr.c:1747
FormData_pg_language * Form_pg_language
Definition: pg_language.h:51
void * palloc(Size size)
Definition: mcxt.c:849
Datum plperlu_validator(PG_FUNCTION_ARGS)
Definition: plperl.c:2052
int errmsg(const char *fmt,...)
Definition: elog.c:797
#define get_sv
Definition: ppport.h:3878
bool fn_retistuple
Definition: plperl.c:120
Datum plperl_inline_handler(PG_FUNCTION_ARGS)
Definition: plperl.c:1854
int i
void FloatExceptionHandler(SIGNAL_ARGS)
Definition: postgres.c:2669
Oid getTypeIOParam(HeapTuple typeTuple)
Definition: lsyscache.c:2053
void pg_bindtextdomain(const char *domain)
Definition: miscinit.c:1511
Datum * elements
Definition: plperl.c:216
#define FunctionCall1(flinfo, arg1)
Definition: fmgr.h:602
int16 tgnargs
Definition: reltrigger.h:37
#define NameStr(name)
Definition: c.h:499
#define errcontext
Definition: elog.h:164
static char * locale
Definition: initdb.c:123
static HV * plperl_spi_execute_fetch_result(SPITupleTable *, uint64, int)
Definition: plperl.c:3143
void * arg
struct plperl_query_entry plperl_query_entry
void SPI_cursor_fetch(Portal portal, bool forward, long count)
Definition: spi.c:1347
char * proname
Definition: plperl.c:109
char * source_text
Definition: parsenodes.h:2782
bool pg_verifymbstr(const char *mbstr, int len, bool noError)
Definition: wchar.c:1866
#define PG_FUNCTION_ARGS
Definition: fmgr.h:158
plperl_proc_desc * prodesc
Definition: plperl.c:180
#define CHECK_FOR_INTERRUPTS()
Definition: miscadmin.h:98
TransactionId fn_xmin
Definition: plperl.c:112
HV * plperl_spi_exec(char *query, int limit)
Definition: plperl.c:3083
#define elog
Definition: elog.h:219
static void _sv_to_datum_finfo(Oid typid, FmgrInfo *finfo, Oid *typioparam)
Definition: plperl.c:1288
ExprDoneCond isDone
Definition: execnodes.h:271
static void array_to_datum_internal(AV *av, ArrayBuildState *astate, int *ndims, int *dims, int cur_depth, Oid arraytypid, Oid elemtypid, int32 typmod, FmgrInfo *finfo, Oid typioparam)
Definition: plperl.c:1169
#define HeapTupleGetOid(tuple)
Definition: htup_details.h:695
static void static void status(const char *fmt,...) pg_attribute_printf(1
Definition: pg_regress.c:224
#define PG_USED_FOR_ASSERTS_ONLY
Definition: c.h:991
#define ReleaseTupleDesc(tupdesc)
Definition: tupdesc.h:107
#define PG_TRY()
Definition: elog.h:284
plperl_interp_desc * interp
Definition: plperl.c:115
#define TRIGGER_FIRED_FOR_ROW(event)
Definition: trigger.h:128
HeapTuple heap_modify_tuple(HeapTuple tuple, TupleDesc tupleDesc, Datum *replValues, bool *replIsnull, bool *doReplace)
Definition: heaptuple.c:791
#define PL_sv_no
Definition: ppport.h:4128
struct plperl_array_info plperl_array_info
void DefineCustomBoolVariable(const char *name, const char *short_desc, const char *long_desc, bool *valueAddr, bool bootValue, GucContext context, int flags, GucBoolCheckHook check_hook, GucBoolAssignHook assign_hook, GucShowHook show_hook)
Definition: guc.c:7740
Definition: pg_list.h:45
Datum plperl_validator(PG_FUNCTION_ARGS)
Definition: plperl.c:1956
static plperl_call_data * current_call_data
Definition: plperl.c:245
#define TRIGGER_FIRED_BY_UPDATE(event)
Definition: trigger.h:122
#define ARR_ELEMTYPE(a)
Definition: array.h:273
Datum plperlu_call_handler(PG_FUNCTION_ARGS)
Definition: plperl.c:2036
Datum plperlu_inline_handler(PG_FUNCTION_ARGS)
Definition: plperl.c:2044
long val
Definition: informix.c:689
HV * plperl_spi_exec_prepared(char *query, HV *attr, int argc, SV **argv)
Definition: plperl.c:3635
#define isGV_with_GP(gv)
Definition: ppport.h:5367
#define PG_END_TRY()
Definition: elog.h:300
char * message
Definition: elog.h:343
static SV * plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo, SV *td)
Definition: plperl.c:2244
static char * sv2cstr(SV *sv)
bool lanpltrusted
Definition: plperl.c:119
static SV * plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
Definition: plperl.c:2151
bool fn_retisarray
Definition: plperl.c:122
void _PG_init(void)
Definition: plperl.c:382
int SPI_execute(const char *src, bool read_only, long tcount)
Definition: spi.c:304
struct plperl_proc_ptr plperl_proc_ptr
Relation tg_relation
Definition: trigger.h:34
#define HeapTupleHeaderGetDatumLength(tup)
Definition: htup_details.h:439
#define DatumGetArrayTypeP(X)
Definition: array.h:242
void get_type_io_data(Oid typid, IOFuncSelector which_func, int16 *typlen, bool *typbyval, char *typalign, char *typdelim, Oid *typioparam, Oid *func)
Definition: lsyscache.c:2075
plperl_query_desc * query_data
Definition: plperl.c:206