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