1 /**********************************************************************
2 * plperl.c - perl as a procedural language for PostgreSQL
4 * src/pl/plperl/plperl.c
6 **********************************************************************/
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"
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"
46 /* define our text domain for translations */
48 #define TEXTDOMAIN PG_TEXTDOMAIN("plperl")
52 #include "plperl_helpers.h"
54 /* string literal macros defining chunks of perl code */
55 #include "perlchunks.h"
56 /* defines PLPERL_SET_OPMASK */
57 #include "plperl_opmask.h"
59 EXTERN_C
void boot_DynaLoader(pTHX_ CV
*cv
);
60 EXTERN_C
void boot_PostgreSQL__InServer__Util(pTHX_ CV
*cv
);
61 EXTERN_C
void boot_PostgreSQL__InServer__SPI(pTHX_ CV
*cv
);
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.)
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.
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.
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
92 Oid user_id
; /* Hash key (must be first!) */
93 PerlInterpreter
*interp
; /* The interpreter */
94 HTAB
*query_hash
; /* plperl_query_entry structs */
98 /**********************************************************************
99 * The information we cache about loaded procedures
101 * The refcount field counts the struct's reference from the hash table shown
102 * below, plus one reference for each function call level that is using the
103 * struct. We can release the struct, and the associated Perl sub, when the
104 * refcount goes to zero.
105 **********************************************************************/
106 typedef struct plperl_proc_desc
108 char *proname
; /* user name of procedure */
109 TransactionId fn_xmin
; /* xmin/TID of procedure's pg_proc tuple */
110 ItemPointerData fn_tid
;
111 int refcount
; /* reference count of this struct */
112 SV
*reference
; /* CODE reference for Perl sub */
113 plperl_interp_desc
*interp
; /* interpreter it's created in */
114 bool fn_readonly
; /* is function readonly (not volatile)? */
117 bool lanpltrusted
; /* is it plperl, rather than plperlu? */
118 bool fn_retistuple
; /* true, if function returns tuple */
119 bool fn_retisset
; /* true, if function returns set */
120 bool fn_retisarray
; /* true if function returns array */
121 /* Conversion info for function's result type: */
122 Oid result_oid
; /* Oid of result type */
123 FmgrInfo result_in_func
; /* I/O function and arg for result type */
124 Oid result_typioparam
;
125 /* Conversion info for function's argument types: */
127 FmgrInfo arg_out_func
[FUNC_MAX_ARGS
];
128 bool arg_is_rowtype
[FUNC_MAX_ARGS
];
129 Oid arg_arraytype
[FUNC_MAX_ARGS
]; /* InvalidOid if not an array */
132 #define increment_prodesc_refcount(prodesc) \
133 ((prodesc)->refcount++)
134 #define decrement_prodesc_refcount(prodesc) \
136 if (--((prodesc)->refcount) <= 0) \
137 free_plperl_function(prodesc); \
140 /**********************************************************************
141 * For speedy lookup, we maintain a hash table mapping from
142 * function OID + trigger flag + user OID to plperl_proc_desc pointers.
143 * The reason the plperl_proc_desc struct isn't directly part of the hash
144 * entry is to simplify recovery from errors during compile_plperl_function.
146 * Note: if the same function is called by multiple userIDs within a session,
147 * there will be a separate plperl_proc_desc entry for each userID in the case
148 * of plperl functions, but only one entry for plperlu functions, because we
149 * set user_id = 0 for that case. If the user redeclares the same function
150 * from plperl to plperlu or vice versa, there might be multiple
151 * plperl_proc_ptr entries in the hashtable, but only one is valid.
152 **********************************************************************/
153 typedef struct plperl_proc_key
155 Oid proc_id
; /* Function OID */
158 * is_trigger is really a bool, but declare as Oid to ensure this struct
159 * contains no padding
161 Oid is_trigger
; /* is it a trigger function? */
162 Oid user_id
; /* User calling the function, or 0 */
165 typedef struct plperl_proc_ptr
167 plperl_proc_key proc_key
; /* Hash key (must be first!) */
168 plperl_proc_desc
*proc_ptr
;
172 * The information we cache for the duration of a single call to a
175 typedef struct plperl_call_data
177 plperl_proc_desc
*prodesc
;
178 FunctionCallInfo fcinfo
;
179 Tuplestorestate
*tuple_store
;
181 MemoryContext tmp_cxt
;
184 /**********************************************************************
185 * The information we cache about prepared and saved plans
186 **********************************************************************/
187 typedef struct plperl_query_desc
190 MemoryContext plan_cxt
; /* context holding this struct */
194 FmgrInfo
*arginfuncs
;
198 /* hash table entry for query desc */
200 typedef struct plperl_query_entry
202 char query_name
[NAMEDATALEN
];
203 plperl_query_desc
*query_data
;
204 } plperl_query_entry
;
206 /**********************************************************************
207 * Information for PostgreSQL - Perl array conversion.
208 **********************************************************************/
209 typedef struct plperl_array_info
212 bool elem_is_rowtype
; /* 't' if element type is a rowtype */
217 FmgrInfo transform_proc
;
220 /**********************************************************************
222 **********************************************************************/
224 static HTAB
*plperl_interp_hash
= NULL
;
225 static HTAB
*plperl_proc_hash
= NULL
;
226 static plperl_interp_desc
*plperl_active_interp
= NULL
;
228 /* If we have an unassigned "held" interpreter, it's stored here */
229 static PerlInterpreter
*plperl_held_interp
= NULL
;
232 static bool plperl_use_strict
= false;
233 static char *plperl_on_init
= NULL
;
234 static char *plperl_on_plperl_init
= NULL
;
235 static char *plperl_on_plperlu_init
= NULL
;
237 static bool plperl_ending
= false;
238 static OP
*(*pp_require_orig
) (pTHX
) = NULL
;
239 static char plperl_opmask
[MAXO
];
241 /* this is saved and restored by plperl_call_handler */
242 static plperl_call_data
*current_call_data
= NULL
;
244 /**********************************************************************
245 * Forward declarations
246 **********************************************************************/
249 static PerlInterpreter
*plperl_init_interp(void);
250 static void plperl_destroy_interp(PerlInterpreter
**);
251 static void plperl_fini(int code
, Datum arg
);
252 static void set_interp_require(bool trusted
);
254 static Datum
plperl_func_handler(PG_FUNCTION_ARGS
);
255 static Datum
plperl_trigger_handler(PG_FUNCTION_ARGS
);
256 static void plperl_event_trigger_handler(PG_FUNCTION_ARGS
);
258 static void free_plperl_function(plperl_proc_desc
*prodesc
);
260 static plperl_proc_desc
*compile_plperl_function(Oid fn_oid
,
262 bool is_event_trigger
);
264 static SV
*plperl_hash_from_tuple(HeapTuple tuple
, TupleDesc tupdesc
);
265 static SV
*plperl_hash_from_datum(Datum attr
);
266 static SV
*plperl_ref_from_pg_array(Datum arg
, Oid typid
);
267 static SV
*split_array(plperl_array_info
*info
, int first
, int last
, int nest
);
268 static SV
*make_array_ref(plperl_array_info
*info
, int first
, int last
);
269 static SV
*get_perl_array_ref(SV
*sv
);
270 static Datum
plperl_sv_to_datum(SV
*sv
, Oid typid
, int32 typmod
,
271 FunctionCallInfo fcinfo
,
272 FmgrInfo
*finfo
, Oid typioparam
,
274 static void _sv_to_datum_finfo(Oid typid
, FmgrInfo
*finfo
, Oid
*typioparam
);
275 static Datum
plperl_array_to_datum(SV
*src
, Oid typid
, int32 typmod
);
276 static void array_to_datum_internal(AV
*av
, ArrayBuildState
*astate
,
277 int *ndims
, int *dims
, int cur_depth
,
278 Oid arraytypid
, Oid elemtypid
, int32 typmod
,
279 FmgrInfo
*finfo
, Oid typioparam
);
280 static Datum
plperl_hash_to_datum(SV
*src
, TupleDesc td
);
282 static void plperl_init_shared_libs(pTHX
);
283 static void plperl_trusted_init(void);
284 static void plperl_untrusted_init(void);
285 static HV
*plperl_spi_execute_fetch_result(SPITupleTable
*, uint64
, int);
286 static char *hek2cstr(HE
*he
);
287 static SV
**hv_store_string(HV
*hv
, const char *key
, SV
*val
);
288 static SV
**hv_fetch_string(HV
*hv
, const char *key
);
289 static void plperl_create_sub(plperl_proc_desc
*desc
, char *s
, Oid fn_oid
);
290 static SV
*plperl_call_perl_func(plperl_proc_desc
*desc
,
291 FunctionCallInfo fcinfo
);
292 static void plperl_compile_callback(void *arg
);
293 static void plperl_exec_callback(void *arg
);
294 static void plperl_inline_callback(void *arg
);
295 static char *strip_trailing_ws(const char *msg
);
296 static OP
*pp_require_safe(pTHX
);
297 static void activate_interpreter(plperl_interp_desc
*interp_desc
);
300 static char *setlocale_perl(int category
, char *locale
);
304 * convert a HE (hash entry) key to a cstr in the current database encoding
313 * HeSVKEY_force will return a temporary mortal SV*, so we need to make
314 * sure to free it with ENTER/SAVE/FREE/LEAVE
319 /*-------------------------
320 * Unfortunately, while HeUTF8 is true for most things > 256, for values
321 * 128..255 it's not, but perl will treat them as unicode code points if
322 * the utf8 flag is not set ( see The "Unicode Bug" in perldoc perlunicode
325 * So if we did the expected:
328 * else // must be ascii
330 * we won't match columns with codepoints from 128..255
332 * For a more concrete example given a column with the name of the unicode
333 * codepoint U+00ae (registered sign) and a UTF8 database and the perl
334 * return_next { "\N{U+00ae}=>'text } would always fail as heUTF8 returns
335 * 0 and HePV() would give us a char * with 1 byte contains the decimal
338 * Perl has the brains to know when it should utf8 encode 174 properly, so
339 * here we force it into an SV so that perl will figure it out and do the
341 *-------------------------
344 sv
= HeSVKEY_force(he
);
357 * This routine is a crock, and so is everyplace that calls it. The problem
358 * is that the cached form of plperl functions/queries is allocated permanently
359 * (mostly via malloc()) and never released until backend exit. Subsidiary
360 * data structures such as fmgr info records therefore must live forever
361 * as well. A better implementation would store all this stuff in a per-
362 * function memory context that could be reclaimed at need. In the meantime,
363 * fmgr_info_cxt must be called specifying TopMemoryContext so that whatever
364 * it might allocate, and whatever the eventual function might allocate using
365 * fn_mcxt, will live forever too.
368 perm_fmgr_info(Oid functionId
, FmgrInfo
*finfo
)
370 fmgr_info_cxt(functionId
, finfo
, TopMemoryContext
);
375 * _PG_init() - library load-time initialization
377 * DO NOT make this static nor change its name!
383 * Be sure we do initialization only once.
385 * If initialization fails due to, e.g., plperl_init_interp() throwing an
386 * exception, then we'll return here on the next usage and the user will
387 * get a rather cryptic: ERROR: attempt to redefine parameter
388 * "plperl.use_strict"
390 static bool inited
= false;
397 * Support localized messages.
399 pg_bindtextdomain(TEXTDOMAIN
);
402 * Initialize plperl's GUCs.
404 DefineCustomBoolVariable("plperl.use_strict",
405 gettext_noop("If true, trusted and untrusted Perl code will be compiled in strict mode."),
413 * plperl.on_init is marked PGC_SIGHUP to support the idea that it might
414 * be executed in the postmaster (if plperl is loaded into the postmaster
415 * via shared_preload_libraries). This isn't really right either way,
418 DefineCustomStringVariable("plperl.on_init",
419 gettext_noop("Perl initialization code to execute when a Perl interpreter is initialized."),
427 * plperl.on_plperl_init is marked PGC_SUSET to avoid issues whereby a
428 * user who might not even have USAGE privilege on the plperl language
429 * could nonetheless use SET plperl.on_plperl_init='...' to influence the
430 * behaviour of any existing plperl function that they can execute (which
431 * might be SECURITY DEFINER, leading to a privilege escalation). See
432 * http://archives.postgresql.org/pgsql-hackers/2010-02/msg00281.php and
433 * the overall thread.
435 * Note that because plperl.use_strict is USERSET, a nefarious user could
436 * set it to be applied against other people's functions. This is judged
437 * OK since the worst result would be an error. Your code oughta pass
438 * use_strict anyway ;-)
440 DefineCustomStringVariable("plperl.on_plperl_init",
441 gettext_noop("Perl initialization code to execute once when plperl is first used."),
443 &plperl_on_plperl_init
,
448 DefineCustomStringVariable("plperl.on_plperlu_init",
449 gettext_noop("Perl initialization code to execute once when plperlu is first used."),
451 &plperl_on_plperlu_init
,
456 EmitWarningsOnPlaceholders("plperl");
459 * Create hash tables.
461 memset(&hash_ctl
, 0, sizeof(hash_ctl
));
462 hash_ctl
.keysize
= sizeof(Oid
);
463 hash_ctl
.entrysize
= sizeof(plperl_interp_desc
);
464 plperl_interp_hash
= hash_create("PL/Perl interpreters",
467 HASH_ELEM
| HASH_BLOBS
);
469 memset(&hash_ctl
, 0, sizeof(hash_ctl
));
470 hash_ctl
.keysize
= sizeof(plperl_proc_key
);
471 hash_ctl
.entrysize
= sizeof(plperl_proc_ptr
);
472 plperl_proc_hash
= hash_create("PL/Perl procedures",
475 HASH_ELEM
| HASH_BLOBS
);
478 * Save the default opmask.
480 PLPERL_SET_OPMASK(plperl_opmask
);
483 * Create the first Perl interpreter, but only partially initialize it.
485 plperl_held_interp
= plperl_init_interp();
492 set_interp_require(bool trusted
)
496 PL_ppaddr
[OP_REQUIRE
] = pp_require_safe
;
497 PL_ppaddr
[OP_DOFILE
] = pp_require_safe
;
501 PL_ppaddr
[OP_REQUIRE
] = pp_require_orig
;
502 PL_ppaddr
[OP_DOFILE
] = pp_require_orig
;
507 * Cleanup perl interpreters, including running END blocks.
508 * Does not fully undo the actions of _PG_init() nor make it callable again.
511 plperl_fini(int code
, Datum arg
)
513 HASH_SEQ_STATUS hash_seq
;
514 plperl_interp_desc
*interp_desc
;
516 elog(DEBUG3
, "plperl_fini");
519 * Indicate that perl is terminating. Disables use of spi_* functions when
520 * running END/DESTROY code. See check_spi_usage_allowed(). Could be
521 * enabled in future, with care, using a transaction
522 * http://archives.postgresql.org/pgsql-hackers/2010-01/msg02743.php
524 plperl_ending
= true;
526 /* Only perform perl cleanup if we're exiting cleanly */
529 elog(DEBUG3
, "plperl_fini: skipped");
533 /* Zap the "held" interpreter, if we still have it */
534 plperl_destroy_interp(&plperl_held_interp
);
536 /* Zap any fully-initialized interpreters */
537 hash_seq_init(&hash_seq
, plperl_interp_hash
);
538 while ((interp_desc
= hash_seq_search(&hash_seq
)) != NULL
)
540 if (interp_desc
->interp
)
542 activate_interpreter(interp_desc
);
543 plperl_destroy_interp(&interp_desc
->interp
);
547 elog(DEBUG3
, "plperl_fini: done");
552 * Select and activate an appropriate Perl interpreter.
555 select_perl_context(bool trusted
)
558 plperl_interp_desc
*interp_desc
;
560 PerlInterpreter
*interp
= NULL
;
562 /* Find or create the interpreter hashtable entry for this userid */
564 user_id
= GetUserId();
566 user_id
= InvalidOid
;
568 interp_desc
= hash_search(plperl_interp_hash
, &user_id
,
573 /* Initialize newly-created hashtable entry */
574 interp_desc
->interp
= NULL
;
575 interp_desc
->query_hash
= NULL
;
578 /* Make sure we have a query_hash for this interpreter */
579 if (interp_desc
->query_hash
== NULL
)
583 memset(&hash_ctl
, 0, sizeof(hash_ctl
));
584 hash_ctl
.keysize
= NAMEDATALEN
;
585 hash_ctl
.entrysize
= sizeof(plperl_query_entry
);
586 interp_desc
->query_hash
= hash_create("PL/Perl queries",
593 * Quick exit if already have an interpreter
595 if (interp_desc
->interp
)
597 activate_interpreter(interp_desc
);
602 * adopt held interp if free, else create new one if possible
604 if (plperl_held_interp
!= NULL
)
606 /* first actual use of a perl interpreter */
607 interp
= plperl_held_interp
;
610 * Reset the plperl_held_interp pointer first; if we fail during init
611 * we don't want to try again with the partially-initialized interp.
613 plperl_held_interp
= NULL
;
616 plperl_trusted_init();
618 plperl_untrusted_init();
620 /* successfully initialized, so arrange for cleanup */
621 on_proc_exit(plperl_fini
, 0);
628 * plperl_init_interp will change Perl's idea of the active
629 * interpreter. Reset plperl_active_interp temporarily, so that if we
630 * hit an error partway through here, we'll make sure to switch back
631 * to a non-broken interpreter before running any other Perl
634 plperl_active_interp
= NULL
;
636 /* Now build the new interpreter */
637 interp
= plperl_init_interp();
640 plperl_trusted_init();
642 plperl_untrusted_init();
645 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED
),
646 errmsg("cannot allocate multiple Perl interpreters on this platform")));
650 set_interp_require(trusted
);
653 * Since the timing of first use of PL/Perl can't be predicted, any
654 * database interaction during initialization is problematic. Including,
655 * but not limited to, security definer issues. So we only enable access
656 * to the database AFTER on_*_init code has run. See
657 * http://archives.postgresql.org/pgsql-hackers/2010-01/msg02669.php
659 newXS("PostgreSQL::InServer::SPI::bootstrap",
660 boot_PostgreSQL__InServer__SPI
, __FILE__
);
662 eval_pv("PostgreSQL::InServer::SPI::bootstrap()", FALSE
);
665 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION
),
666 errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV
))),
667 errcontext("while executing PostgreSQL::InServer::SPI::bootstrap")));
669 /* Fully initialized, so mark the hashtable entry valid */
670 interp_desc
->interp
= interp
;
672 /* And mark this as the active interpreter */
673 plperl_active_interp
= interp_desc
;
677 * Make the specified interpreter the active one
679 * A call with NULL does nothing. This is so that "restoring" to a previously
680 * null state of plperl_active_interp doesn't result in useless thrashing.
683 activate_interpreter(plperl_interp_desc
*interp_desc
)
685 if (interp_desc
&& plperl_active_interp
!= interp_desc
)
687 Assert(interp_desc
->interp
);
688 PERL_SET_CONTEXT(interp_desc
->interp
);
689 /* trusted iff user_id isn't InvalidOid */
690 set_interp_require(OidIsValid(interp_desc
->user_id
));
691 plperl_active_interp
= interp_desc
;
696 * Create a new Perl interpreter.
698 * We initialize the interpreter as far as we can without knowing whether
699 * it will become a trusted or untrusted interpreter; in particular, the
700 * plperl.on_init code will get executed. Later, either plperl_trusted_init
701 * or plperl_untrusted_init must be called to complete the initialization.
703 static PerlInterpreter
*
704 plperl_init_interp(void)
706 PerlInterpreter
*plperl
;
708 static char *embedding
[3 + 2] = {
709 "", "-e", PLC_PERLBOOT
716 * The perl library on startup does horrible things like call
717 * setlocale(LC_ALL,""). We have protected against that on most platforms
718 * by setting the environment appropriately. However, on Windows,
719 * setlocale() does not consult the environment, so we need to save the
720 * existing locale settings before perl has a chance to mangle them and
721 * restore them after its dirty deeds are done.
724 * http://msdn.microsoft.com/library/en-us/vclib/html/_crt_locale.asp
726 * It appears that we only need to do this on interpreter startup, and
727 * subsequent calls to the interpreter don't mess with the locale
730 * We restore them using setlocale_perl(), defined below, so that Perl
731 * doesn't have a different idea of the locale from Postgres.
742 loc
= setlocale(LC_COLLATE
, NULL
);
743 save_collate
= loc
? pstrdup(loc
) : NULL
;
744 loc
= setlocale(LC_CTYPE
, NULL
);
745 save_ctype
= loc
? pstrdup(loc
) : NULL
;
746 loc
= setlocale(LC_MONETARY
, NULL
);
747 save_monetary
= loc
? pstrdup(loc
) : NULL
;
748 loc
= setlocale(LC_NUMERIC
, NULL
);
749 save_numeric
= loc
? pstrdup(loc
) : NULL
;
750 loc
= setlocale(LC_TIME
, NULL
);
751 save_time
= loc
? pstrdup(loc
) : NULL
;
753 #define PLPERL_RESTORE_LOCALE(name, saved) \
755 if (saved != NULL) { setlocale_perl(name, saved); pfree(saved); } \
759 if (plperl_on_init
&& *plperl_on_init
)
761 embedding
[nargs
++] = "-e";
762 embedding
[nargs
++] = plperl_on_init
;
766 * The perl API docs state that PERL_SYS_INIT3 should be called before
767 * allocating interpreters. Unfortunately, on some platforms this fails in
768 * the Perl_do_taint() routine, which is called when the platform is using
769 * the system's malloc() instead of perl's own. Other platforms, notably
770 * Windows, fail if PERL_SYS_INIT3 is not called. So we call it if it's
771 * available, unless perl is using the system malloc(), which is true when
774 #if defined(PERL_SYS_INIT3) && !defined(MYMALLOC)
776 static int perl_sys_init_done
;
778 /* only call this the first time through, as per perlembed man page */
779 if (!perl_sys_init_done
)
781 char *dummy_env
[1] = {NULL
};
783 PERL_SYS_INIT3(&nargs
, (char ***) &embedding
, (char ***) &dummy_env
);
786 * For unclear reasons, PERL_SYS_INIT3 sets the SIGFPE handler to
787 * SIG_IGN. Aside from being extremely unfriendly behavior for a
788 * library, this is dumb on the grounds that the results of a
789 * SIGFPE in this state are undefined according to POSIX, and in
790 * fact you get a forced process kill at least on Linux. Hence,
791 * restore the SIGFPE handler to the backend's standard setting.
792 * (See Perl bug 114574 for more information.)
794 pqsignal(SIGFPE
, FloatExceptionHandler
);
796 perl_sys_init_done
= 1;
797 /* quiet warning if PERL_SYS_INIT3 doesn't use the third argument */
803 plperl
= perl_alloc();
805 elog(ERROR
, "could not allocate Perl interpreter");
807 PERL_SET_CONTEXT(plperl
);
808 perl_construct(plperl
);
810 /* run END blocks in perl_destruct instead of perl_run */
811 PL_exit_flags
|= PERL_EXIT_DESTRUCT_END
;
814 * Record the original function for the 'require' and 'dofile' opcodes.
815 * (They share the same implementation.) Ensure it's used for new
818 if (!pp_require_orig
)
819 pp_require_orig
= PL_ppaddr
[OP_REQUIRE
];
822 PL_ppaddr
[OP_REQUIRE
] = pp_require_orig
;
823 PL_ppaddr
[OP_DOFILE
] = pp_require_orig
;
826 #ifdef PLPERL_ENABLE_OPMASK_EARLY
829 * For regression testing to prove that the PLC_PERLBOOT and PLC_TRUSTED
830 * code doesn't even compile any unsafe ops. In future there may be a
831 * valid need for them to do so, in which case this could be softened
832 * (perhaps moved to plperl_trusted_init()) or removed.
834 PL_op_mask
= plperl_opmask
;
837 if (perl_parse(plperl
, plperl_init_shared_libs
,
838 nargs
, embedding
, NULL
) != 0)
840 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION
),
841 errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV
))),
842 errcontext("while parsing Perl initialization")));
844 if (perl_run(plperl
) != 0)
846 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION
),
847 errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV
))),
848 errcontext("while running Perl initialization")));
850 #ifdef PLPERL_RESTORE_LOCALE
851 PLPERL_RESTORE_LOCALE(LC_COLLATE
, save_collate
);
852 PLPERL_RESTORE_LOCALE(LC_CTYPE
, save_ctype
);
853 PLPERL_RESTORE_LOCALE(LC_MONETARY
, save_monetary
);
854 PLPERL_RESTORE_LOCALE(LC_NUMERIC
, save_numeric
);
855 PLPERL_RESTORE_LOCALE(LC_TIME
, save_time
);
863 * Our safe implementation of the require opcode.
864 * This is safe because it's completely unable to load any code.
865 * If the requested file/module has already been loaded it'll return true.
867 * So now "use Foo;" will work iff Foo has already been loaded.
870 pp_require_safe(pTHX
)
880 name
= SvPV(sv
, len
);
881 if (!(name
&& len
> 0 && *name
))
884 svp
= hv_fetch(GvHVn(PL_incgv
), name
, len
, 0);
885 if (svp
&& *svp
!= &PL_sv_undef
)
888 DIE(aTHX_
"Unable to load %s into plperl", name
);
891 * In most Perl versions, DIE() expands to a return statement, so the next
892 * line is not necessary. But in versions between but not including
893 * 5.11.1 and 5.13.3 it does not, so the next line is necessary to avoid a
894 * "control reaches end of non-void function" warning from gcc. Other
895 * compilers such as Solaris Studio will, however, issue a "statement not
896 * reached" warning instead.
903 * Destroy one Perl interpreter ... actually we just run END blocks.
905 * Caller must have ensured this interpreter is the active one.
908 plperl_destroy_interp(PerlInterpreter
**interp
)
910 if (interp
&& *interp
)
913 * Only a very minimal destruction is performed: - just call END
916 * We could call perl_destruct() but we'd need to audit its actions
917 * very carefully and work-around any that impact us. (Calling
918 * sv_clean_objs() isn't an option because it's not part of perl's
919 * public API so isn't portably available.) Meanwhile END blocks can
920 * be used to perform manual cleanup.
923 /* Run END blocks - based on perl's perl_destruct() */
924 if (PL_exit_flags
& PERL_EXIT_DESTRUCT_END
)
931 if (PL_endav
&& !PL_minus_c
)
932 call_list(PL_scopestack_ix
, PL_endav
);
943 * Initialize the current Perl interpreter as a trusted interp
946 plperl_trusted_init(void)
953 /* use original require while we set up */
954 PL_ppaddr
[OP_REQUIRE
] = pp_require_orig
;
955 PL_ppaddr
[OP_DOFILE
] = pp_require_orig
;
957 eval_pv(PLC_TRUSTED
, FALSE
);
960 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION
),
961 errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV
))),
962 errcontext("while executing PLC_TRUSTED")));
965 * Force loading of utf8 module now to prevent errors that can arise from
966 * the regex code later trying to load utf8 modules. See
967 * http://rt.perl.org/rt3/Ticket/Display.html?id=47576
969 eval_pv("my $a=chr(0x100); return $a =~ /\\xa9/i", FALSE
);
972 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION
),
973 errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV
))),
974 errcontext("while executing utf8fix")));
977 * Lock down the interpreter
980 /* switch to the safe require/dofile opcode for future code */
981 PL_ppaddr
[OP_REQUIRE
] = pp_require_safe
;
982 PL_ppaddr
[OP_DOFILE
] = pp_require_safe
;
985 * prevent (any more) unsafe opcodes being compiled PL_op_mask is per
986 * interpreter, so this only needs to be set once
988 PL_op_mask
= plperl_opmask
;
990 /* delete the DynaLoader:: namespace so extensions can't be loaded */
991 stash
= gv_stashpv("DynaLoader", GV_ADDWARN
);
993 while ((sv
= hv_iternextsv(stash
, &key
, &klen
)))
995 if (!isGV_with_GP(sv
) || !GvCV(sv
))
997 SvREFCNT_dec(GvCV(sv
)); /* free the CV */
998 GvCV_set(sv
, NULL
); /* prevent call via GV */
1002 /* invalidate assorted caches */
1003 ++PL_sub_generation
;
1004 hv_clear(PL_stashcache
);
1007 * Execute plperl.on_plperl_init in the locked-down interpreter
1009 if (plperl_on_plperl_init
&& *plperl_on_plperl_init
)
1011 eval_pv(plperl_on_plperl_init
, FALSE
);
1012 /* XXX need to find a way to determine a better errcode here */
1015 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION
),
1016 errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV
))),
1017 errcontext("while executing plperl.on_plperl_init")));
1023 * Initialize the current Perl interpreter as an untrusted interp
1026 plperl_untrusted_init(void)
1029 * Nothing to do except execute plperl.on_plperlu_init
1031 if (plperl_on_plperlu_init
&& *plperl_on_plperlu_init
)
1033 eval_pv(plperl_on_plperlu_init
, FALSE
);
1036 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION
),
1037 errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV
))),
1038 errcontext("while executing plperl.on_plperlu_init")));
1044 * Perl likes to put a newline after its error messages; clean up such
1047 strip_trailing_ws(const char *msg
)
1049 char *res
= pstrdup(msg
);
1050 int len
= strlen(res
);
1052 while (len
> 0 && isspace((unsigned char) res
[len
- 1]))
1058 /* Build a tuple from a hash. */
1061 plperl_build_tuple_result(HV
*perlhash
, TupleDesc td
)
1068 values
= palloc0(sizeof(Datum
) * td
->natts
);
1069 nulls
= palloc(sizeof(bool) * td
->natts
);
1070 memset(nulls
, true, sizeof(bool) * td
->natts
);
1072 hv_iterinit(perlhash
);
1073 while ((he
= hv_iternext(perlhash
)))
1075 SV
*val
= HeVAL(he
);
1076 char *key
= hek2cstr(he
);
1077 int attn
= SPI_fnumber(td
, key
);
1079 if (attn
<= 0 || td
->attrs
[attn
- 1]->attisdropped
)
1081 (errcode(ERRCODE_UNDEFINED_COLUMN
),
1082 errmsg("Perl hash contains nonexistent column \"%s\"",
1085 values
[attn
- 1] = plperl_sv_to_datum(val
,
1086 td
->attrs
[attn
- 1]->atttypid
,
1087 td
->attrs
[attn
- 1]->atttypmod
,
1095 hv_iterinit(perlhash
);
1097 tup
= heap_form_tuple(td
, values
, nulls
);
1103 /* convert a hash reference to a datum */
1105 plperl_hash_to_datum(SV
*src
, TupleDesc td
)
1107 HeapTuple tup
= plperl_build_tuple_result((HV
*) SvRV(src
), td
);
1109 return HeapTupleGetDatum(tup
);
1113 * if we are an array ref return the reference. this is special in that if we
1114 * are a PostgreSQL::InServer::ARRAY object we will return the 'magic' array.
1117 get_perl_array_ref(SV
*sv
)
1119 if (SvOK(sv
) && SvROK(sv
))
1121 if (SvTYPE(SvRV(sv
)) == SVt_PVAV
)
1123 else if (sv_isa(sv
, "PostgreSQL::InServer::ARRAY"))
1125 HV
*hv
= (HV
*) SvRV(sv
);
1126 SV
**sav
= hv_fetch_string(hv
, "array");
1128 if (*sav
&& SvOK(*sav
) && SvROK(*sav
) &&
1129 SvTYPE(SvRV(*sav
)) == SVt_PVAV
)
1132 elog(ERROR
, "could not get array reference from PostgreSQL::InServer::ARRAY object");
1139 * helper function for plperl_array_to_datum, recurses for multi-D arrays
1142 array_to_datum_internal(AV
*av
, ArrayBuildState
*astate
,
1143 int *ndims
, int *dims
, int cur_depth
,
1144 Oid arraytypid
, Oid elemtypid
, int32 typmod
,
1145 FmgrInfo
*finfo
, Oid typioparam
)
1148 int len
= av_len(av
) + 1;
1150 for (i
= 0; i
< len
; i
++)
1152 /* fetch the array element */
1153 SV
**svp
= av_fetch(av
, i
, FALSE
);
1155 /* see if this element is an array, if so get that */
1156 SV
*sav
= svp
? get_perl_array_ref(*svp
) : NULL
;
1158 /* multi-dimensional array? */
1161 AV
*nav
= (AV
*) SvRV(sav
);
1163 /* dimensionality checks */
1164 if (cur_depth
+ 1 > MAXDIM
)
1166 (errcode(ERRCODE_PROGRAM_LIMIT_EXCEEDED
),
1167 errmsg("number of array dimensions (%d) exceeds the maximum allowed (%d)",
1168 cur_depth
+ 1, MAXDIM
)));
1170 /* set size when at first element in this level, else compare */
1171 if (i
== 0 && *ndims
== cur_depth
)
1173 dims
[*ndims
] = av_len(nav
) + 1;
1176 else if (av_len(nav
) + 1 != dims
[cur_depth
])
1178 (errcode(ERRCODE_INVALID_TEXT_REPRESENTATION
),
1179 errmsg("multidimensional arrays must have array expressions with matching dimensions")));
1181 /* recurse to fetch elements of this sub-array */
1182 array_to_datum_internal(nav
, astate
,
1183 ndims
, dims
, cur_depth
+ 1,
1184 arraytypid
, elemtypid
, typmod
,
1192 /* scalar after some sub-arrays at same level? */
1193 if (*ndims
!= cur_depth
)
1195 (errcode(ERRCODE_INVALID_TEXT_REPRESENTATION
),
1196 errmsg("multidimensional arrays must have array expressions with matching dimensions")));
1198 dat
= plperl_sv_to_datum(svp
? *svp
: NULL
,
1206 (void) accumArrayResult(astate
, dat
, isnull
,
1207 elemtypid
, CurrentMemoryContext
);
1213 * convert perl array ref to a datum
1216 plperl_array_to_datum(SV
*src
, Oid typid
, int32 typmod
)
1218 ArrayBuildState
*astate
;
1227 elemtypid
= get_element_type(typid
);
1230 (errcode(ERRCODE_DATATYPE_MISMATCH
),
1231 errmsg("cannot convert Perl array to non-array type %s",
1232 format_type_be(typid
))));
1234 astate
= initArrayResult(elemtypid
, CurrentMemoryContext
, true);
1236 _sv_to_datum_finfo(elemtypid
, &finfo
, &typioparam
);
1238 memset(dims
, 0, sizeof(dims
));
1239 dims
[0] = av_len((AV
*) SvRV(src
)) + 1;
1241 array_to_datum_internal((AV
*) SvRV(src
), astate
,
1243 typid
, elemtypid
, typmod
,
1244 &finfo
, typioparam
);
1246 /* ensure we get zero-D array for no inputs, as per PG convention */
1250 for (i
= 0; i
< ndims
; i
++)
1253 return makeMdArrayResult(astate
, ndims
, dims
, lbs
,
1254 CurrentMemoryContext
, true);
1257 /* Get the information needed to convert data to the specified PG type */
1259 _sv_to_datum_finfo(Oid typid
, FmgrInfo
*finfo
, Oid
*typioparam
)
1263 /* XXX would be better to cache these lookups */
1264 getTypeInputInfo(typid
,
1265 &typinput
, typioparam
);
1266 fmgr_info(typinput
, finfo
);
1270 * convert Perl SV to PG datum of type typid, typmod typmod
1272 * Pass the PL/Perl function's fcinfo when attempting to convert to the
1273 * function's result type; otherwise pass NULL. This is used when we need to
1274 * resolve the actual result type of a function returning RECORD.
1276 * finfo and typioparam should be the results of _sv_to_datum_finfo for the
1277 * given typid, or NULL/InvalidOid to let this function do the lookups.
1279 * *isnull is an output parameter.
1282 plperl_sv_to_datum(SV
*sv
, Oid typid
, int32 typmod
,
1283 FunctionCallInfo fcinfo
,
1284 FmgrInfo
*finfo
, Oid typioparam
,
1290 /* we might recurse */
1291 check_stack_depth();
1296 * Return NULL if result is undef, or if we're in a function returning
1297 * VOID. In the latter case, we should pay no attention to the last Perl
1298 * statement's result, and this is a convenient means to ensure that.
1300 if (!sv
|| !SvOK(sv
) || typid
== VOIDOID
)
1302 /* look up type info if they did not pass it */
1305 _sv_to_datum_finfo(typid
, &tmp
, &typioparam
);
1309 /* must call typinput in case it wants to reject NULL */
1310 return InputFunctionCall(finfo
, NULL
, typioparam
, typmod
);
1312 else if ((funcid
= get_transform_tosql(typid
, current_call_data
->prodesc
->lang_oid
, current_call_data
->prodesc
->trftypes
)))
1313 return OidFunctionCall1(funcid
, PointerGetDatum(sv
));
1316 /* handle references */
1317 SV
*sav
= get_perl_array_ref(sv
);
1321 /* handle an arrayref */
1322 return plperl_array_to_datum(sav
, typid
, typmod
);
1324 else if (SvTYPE(SvRV(sv
)) == SVt_PVHV
)
1326 /* handle a hashref */
1330 if (!type_is_rowtype(typid
))
1332 (errcode(ERRCODE_DATATYPE_MISMATCH
),
1333 errmsg("cannot convert Perl hash to non-composite type %s",
1334 format_type_be(typid
))));
1336 td
= lookup_rowtype_tupdesc_noerror(typid
, typmod
, true);
1339 /* Try to look it up based on our result type */
1340 if (fcinfo
== NULL
||
1341 get_call_result_type(fcinfo
, NULL
, &td
) != TYPEFUNC_COMPOSITE
)
1343 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED
),
1344 errmsg("function returning record called in context "
1345 "that cannot accept type record")));
1348 ret
= plperl_hash_to_datum(sv
, td
);
1350 /* Release on the result of get_call_result_type is harmless */
1351 ReleaseTupleDesc(td
);
1356 /* Reference, but not reference to hash or array ... */
1358 (errcode(ERRCODE_DATATYPE_MISMATCH
),
1359 errmsg("PL/Perl function must return reference to hash or array")));
1360 return (Datum
) 0; /* shut up compiler */
1364 /* handle a string/number */
1366 char *str
= sv2cstr(sv
);
1368 /* did not pass in any typeinfo? look it up */
1371 _sv_to_datum_finfo(typid
, &tmp
, &typioparam
);
1375 ret
= InputFunctionCall(finfo
, str
, typioparam
, typmod
);
1382 /* Convert the perl SV to a string returned by the type output function */
1384 plperl_sv_to_literal(SV
*sv
, char *fqtypename
)
1386 Datum str
= CStringGetDatum(fqtypename
);
1387 Oid typid
= DirectFunctionCall1(regtypein
, str
);
1393 if (!OidIsValid(typid
))
1395 (errcode(ERRCODE_UNDEFINED_OBJECT
),
1396 errmsg("lookup failed for type %s", fqtypename
)));
1398 datum
= plperl_sv_to_datum(sv
,
1400 NULL
, NULL
, InvalidOid
,
1406 getTypeOutputInfo(typid
,
1407 &typoutput
, &typisvarlena
);
1409 return OidOutputFunctionCall(typoutput
, datum
);
1413 * Convert PostgreSQL array datum to a perl array reference.
1415 * typid is arg's OID, which must be an array type.
1418 plperl_ref_from_pg_array(Datum arg
, Oid typid
)
1420 ArrayType
*ar
= DatumGetArrayTypeP(arg
);
1421 Oid elementtype
= ARR_ELEMTYPE(ar
);
1428 Oid transform_funcid
;
1432 plperl_array_info
*info
;
1436 info
= palloc0(sizeof(plperl_array_info
));
1438 /* get element type information, including output conversion function */
1439 get_type_io_data(elementtype
, IOFunc_output
,
1440 &typlen
, &typbyval
, &typalign
,
1441 &typdelim
, &typioparam
, &typoutputfunc
);
1443 if ((transform_funcid
= get_transform_fromsql(elementtype
, current_call_data
->prodesc
->lang_oid
, current_call_data
->prodesc
->trftypes
)))
1444 perm_fmgr_info(transform_funcid
, &info
->transform_proc
);
1446 perm_fmgr_info(typoutputfunc
, &info
->proc
);
1448 info
->elem_is_rowtype
= type_is_rowtype(elementtype
);
1450 /* Get the number and bounds of array dimensions */
1451 info
->ndims
= ARR_NDIM(ar
);
1452 dims
= ARR_DIMS(ar
);
1454 /* No dimensions? Return an empty array */
1455 if (info
->ndims
== 0)
1457 av
= newRV_noinc((SV
*) newAV());
1461 deconstruct_array(ar
, elementtype
, typlen
, typbyval
,
1462 typalign
, &info
->elements
, &info
->nulls
,
1465 /* Get total number of elements in each dimension */
1466 info
->nelems
= palloc(sizeof(int) * info
->ndims
);
1467 info
->nelems
[0] = nitems
;
1468 for (i
= 1; i
< info
->ndims
; i
++)
1469 info
->nelems
[i
] = info
->nelems
[i
- 1] / dims
[i
- 1];
1471 av
= split_array(info
, 0, nitems
, 0);
1475 (void) hv_store(hv
, "array", 5, av
, 0);
1476 (void) hv_store(hv
, "typeoid", 7, newSVuv(typid
), 0);
1478 return sv_bless(newRV_noinc((SV
*) hv
),
1479 gv_stashpv("PostgreSQL::InServer::ARRAY", 0));
1483 * Recursively form array references from splices of the initial array
1486 split_array(plperl_array_info
*info
, int first
, int last
, int nest
)
1491 /* we should only be called when we have something to split */
1492 Assert(info
->ndims
> 0);
1494 /* since this function recurses, it could be driven to stack overflow */
1495 check_stack_depth();
1498 * Base case, return a reference to a single-dimensional array
1500 if (nest
>= info
->ndims
- 1)
1501 return make_array_ref(info
, first
, last
);
1504 for (i
= first
; i
< last
; i
+= info
->nelems
[nest
+ 1])
1506 /* Recursively form references to arrays of lower dimensions */
1507 SV
*ref
= split_array(info
, i
, i
+ info
->nelems
[nest
+ 1], nest
+ 1);
1509 av_push(result
, ref
);
1511 return newRV_noinc((SV
*) result
);
1515 * Create a Perl reference from a one-dimensional C array, converting
1516 * composite type elements to hash references.
1519 make_array_ref(plperl_array_info
*info
, int first
, int last
)
1522 AV
*result
= newAV();
1524 for (i
= first
; i
< last
; i
++)
1529 * We can't use &PL_sv_undef here. See "AVs, HVs and undefined
1530 * values" in perlguts.
1532 av_push(result
, newSV(0));
1536 Datum itemvalue
= info
->elements
[i
];
1538 if (info
->transform_proc
.fn_oid
)
1539 av_push(result
, (SV
*) DatumGetPointer(FunctionCall1(&info
->transform_proc
, itemvalue
)));
1540 else if (info
->elem_is_rowtype
)
1541 /* Handle composite type elements */
1542 av_push(result
, plperl_hash_from_datum(itemvalue
));
1545 char *val
= OutputFunctionCall(&info
->proc
, itemvalue
);
1547 av_push(result
, cstr2sv(val
));
1551 return newRV_noinc((SV
*) result
);
1554 /* Set up the arguments for a trigger call. */
1556 plperl_trigger_build_args(FunctionCallInfo fcinfo
)
1568 hv_ksplit(hv
, 12); /* pre-grow the hash */
1570 tdata
= (TriggerData
*) fcinfo
->context
;
1571 tupdesc
= tdata
->tg_relation
->rd_att
;
1573 relid
= DatumGetCString(
1574 DirectFunctionCall1(oidout
,
1575 ObjectIdGetDatum(tdata
->tg_relation
->rd_id
)
1579 hv_store_string(hv
, "name", cstr2sv(tdata
->tg_trigger
->tgname
));
1580 hv_store_string(hv
, "relid", cstr2sv(relid
));
1582 if (TRIGGER_FIRED_BY_INSERT(tdata
->tg_event
))
1585 if (TRIGGER_FIRED_FOR_ROW(tdata
->tg_event
))
1586 hv_store_string(hv
, "new",
1587 plperl_hash_from_tuple(tdata
->tg_trigtuple
,
1590 else if (TRIGGER_FIRED_BY_DELETE(tdata
->tg_event
))
1593 if (TRIGGER_FIRED_FOR_ROW(tdata
->tg_event
))
1594 hv_store_string(hv
, "old",
1595 plperl_hash_from_tuple(tdata
->tg_trigtuple
,
1598 else if (TRIGGER_FIRED_BY_UPDATE(tdata
->tg_event
))
1601 if (TRIGGER_FIRED_FOR_ROW(tdata
->tg_event
))
1603 hv_store_string(hv
, "old",
1604 plperl_hash_from_tuple(tdata
->tg_trigtuple
,
1606 hv_store_string(hv
, "new",
1607 plperl_hash_from_tuple(tdata
->tg_newtuple
,
1611 else if (TRIGGER_FIRED_BY_TRUNCATE(tdata
->tg_event
))
1616 hv_store_string(hv
, "event", cstr2sv(event
));
1617 hv_store_string(hv
, "argc", newSViv(tdata
->tg_trigger
->tgnargs
));
1619 if (tdata
->tg_trigger
->tgnargs
> 0)
1623 av_extend(av
, tdata
->tg_trigger
->tgnargs
);
1624 for (i
= 0; i
< tdata
->tg_trigger
->tgnargs
; i
++)
1625 av_push(av
, cstr2sv(tdata
->tg_trigger
->tgargs
[i
]));
1626 hv_store_string(hv
, "args", newRV_noinc((SV
*) av
));
1629 hv_store_string(hv
, "relname",
1630 cstr2sv(SPI_getrelname(tdata
->tg_relation
)));
1632 hv_store_string(hv
, "table_name",
1633 cstr2sv(SPI_getrelname(tdata
->tg_relation
)));
1635 hv_store_string(hv
, "table_schema",
1636 cstr2sv(SPI_getnspname(tdata
->tg_relation
)));
1638 if (TRIGGER_FIRED_BEFORE(tdata
->tg_event
))
1640 else if (TRIGGER_FIRED_AFTER(tdata
->tg_event
))
1642 else if (TRIGGER_FIRED_INSTEAD(tdata
->tg_event
))
1643 when
= "INSTEAD OF";
1646 hv_store_string(hv
, "when", cstr2sv(when
));
1648 if (TRIGGER_FIRED_FOR_ROW(tdata
->tg_event
))
1650 else if (TRIGGER_FIRED_FOR_STATEMENT(tdata
->tg_event
))
1651 level
= "STATEMENT";
1654 hv_store_string(hv
, "level", cstr2sv(level
));
1656 return newRV_noinc((SV
*) hv
);
1660 /* Set up the arguments for an event trigger call. */
1662 plperl_event_trigger_build_args(FunctionCallInfo fcinfo
)
1664 EventTriggerData
*tdata
;
1669 tdata
= (EventTriggerData
*) fcinfo
->context
;
1671 hv_store_string(hv
, "event", cstr2sv(tdata
->event
));
1672 hv_store_string(hv
, "tag", cstr2sv(tdata
->tag
));
1674 return newRV_noinc((SV
*) hv
);
1677 /* Set up the new tuple returned from a trigger. */
1680 plperl_modify_tuple(HV
*hvTD
, TriggerData
*tdata
, HeapTuple otup
)
1693 tupdesc
= tdata
->tg_relation
->rd_att
;
1695 svp
= hv_fetch_string(hvTD
, "new");
1698 (errcode(ERRCODE_UNDEFINED_COLUMN
),
1699 errmsg("$_TD->{new} does not exist")));
1700 if (!SvOK(*svp
) || !SvROK(*svp
) || SvTYPE(SvRV(*svp
)) != SVt_PVHV
)
1702 (errcode(ERRCODE_DATATYPE_MISMATCH
),
1703 errmsg("$_TD->{new} is not a hash reference")));
1704 hvNew
= (HV
*) SvRV(*svp
);
1706 modattrs
= palloc(tupdesc
->natts
* sizeof(int));
1707 modvalues
= palloc(tupdesc
->natts
* sizeof(Datum
));
1708 modnulls
= palloc(tupdesc
->natts
* sizeof(char));
1712 while ((he
= hv_iternext(hvNew
)))
1715 char *key
= hek2cstr(he
);
1716 SV
*val
= HeVAL(he
);
1717 int attn
= SPI_fnumber(tupdesc
, key
);
1719 if (attn
<= 0 || tupdesc
->attrs
[attn
- 1]->attisdropped
)
1721 (errcode(ERRCODE_UNDEFINED_COLUMN
),
1722 errmsg("Perl hash contains nonexistent column \"%s\"",
1725 modvalues
[slotsused
] = plperl_sv_to_datum(val
,
1726 tupdesc
->attrs
[attn
- 1]->atttypid
,
1727 tupdesc
->attrs
[attn
- 1]->atttypmod
,
1733 modnulls
[slotsused
] = isnull
? 'n' : ' ';
1734 modattrs
[slotsused
] = attn
;
1741 rtup
= SPI_modifytuple(tdata
->tg_relation
, otup
, slotsused
,
1742 modattrs
, modvalues
, modnulls
);
1749 elog(ERROR
, "SPI_modifytuple failed: %s",
1750 SPI_result_code_string(SPI_result
));
1757 * There are three externally visible pieces to plperl: plperl_call_handler,
1758 * plperl_inline_handler, and plperl_validator.
1762 * The call handler is called to run normal functions (including trigger
1763 * functions) that are defined in pg_proc.
1765 PG_FUNCTION_INFO_V1(plperl_call_handler
);
1768 plperl_call_handler(PG_FUNCTION_ARGS
)
1771 plperl_call_data
*save_call_data
= current_call_data
;
1772 plperl_interp_desc
*oldinterp
= plperl_active_interp
;
1773 plperl_call_data this_call_data
;
1775 /* Initialize current-call status record */
1776 MemSet(&this_call_data
, 0, sizeof(this_call_data
));
1777 this_call_data
.fcinfo
= fcinfo
;
1781 current_call_data
= &this_call_data
;
1782 if (CALLED_AS_TRIGGER(fcinfo
))
1783 retval
= PointerGetDatum(plperl_trigger_handler(fcinfo
));
1784 else if (CALLED_AS_EVENT_TRIGGER(fcinfo
))
1786 plperl_event_trigger_handler(fcinfo
);
1790 retval
= plperl_func_handler(fcinfo
);
1794 if (this_call_data
.prodesc
)
1795 decrement_prodesc_refcount(this_call_data
.prodesc
);
1796 current_call_data
= save_call_data
;
1797 activate_interpreter(oldinterp
);
1802 if (this_call_data
.prodesc
)
1803 decrement_prodesc_refcount(this_call_data
.prodesc
);
1804 current_call_data
= save_call_data
;
1805 activate_interpreter(oldinterp
);
1810 * The inline handler runs anonymous code blocks (DO blocks).
1812 PG_FUNCTION_INFO_V1(plperl_inline_handler
);
1815 plperl_inline_handler(PG_FUNCTION_ARGS
)
1817 InlineCodeBlock
*codeblock
= (InlineCodeBlock
*) PG_GETARG_POINTER(0);
1818 FunctionCallInfoData fake_fcinfo
;
1820 plperl_proc_desc desc
;
1821 plperl_call_data
*save_call_data
= current_call_data
;
1822 plperl_interp_desc
*oldinterp
= plperl_active_interp
;
1823 plperl_call_data this_call_data
;
1824 ErrorContextCallback pl_error_context
;
1826 /* Initialize current-call status record */
1827 MemSet(&this_call_data
, 0, sizeof(this_call_data
));
1829 /* Set up a callback for error reporting */
1830 pl_error_context
.callback
= plperl_inline_callback
;
1831 pl_error_context
.previous
= error_context_stack
;
1832 pl_error_context
.arg
= NULL
;
1833 error_context_stack
= &pl_error_context
;
1836 * Set up a fake fcinfo and descriptor with just enough info to satisfy
1837 * plperl_call_perl_func(). In particular note that this sets things up
1838 * with no arguments passed, and a result type of VOID.
1840 MemSet(&fake_fcinfo
, 0, sizeof(fake_fcinfo
));
1841 MemSet(&flinfo
, 0, sizeof(flinfo
));
1842 MemSet(&desc
, 0, sizeof(desc
));
1843 fake_fcinfo
.flinfo
= &flinfo
;
1844 flinfo
.fn_oid
= InvalidOid
;
1845 flinfo
.fn_mcxt
= CurrentMemoryContext
;
1847 desc
.proname
= "inline_code_block";
1848 desc
.fn_readonly
= false;
1850 desc
.lang_oid
= codeblock
->langOid
;
1851 desc
.trftypes
= NIL
;
1852 desc
.lanpltrusted
= codeblock
->langIsTrusted
;
1854 desc
.fn_retistuple
= false;
1855 desc
.fn_retisset
= false;
1856 desc
.fn_retisarray
= false;
1857 desc
.result_oid
= VOIDOID
;
1859 desc
.reference
= NULL
;
1861 this_call_data
.fcinfo
= &fake_fcinfo
;
1862 this_call_data
.prodesc
= &desc
;
1863 /* we do not bother with refcounting the fake prodesc */
1869 current_call_data
= &this_call_data
;
1871 if (SPI_connect() != SPI_OK_CONNECT
)
1872 elog(ERROR
, "could not connect to SPI manager");
1874 select_perl_context(desc
.lanpltrusted
);
1876 plperl_create_sub(&desc
, codeblock
->source_text
, 0);
1878 if (!desc
.reference
) /* can this happen? */
1879 elog(ERROR
, "could not create internal procedure for anonymous code block");
1881 perlret
= plperl_call_perl_func(&desc
, &fake_fcinfo
);
1883 SvREFCNT_dec(perlret
);
1885 if (SPI_finish() != SPI_OK_FINISH
)
1886 elog(ERROR
, "SPI_finish() failed");
1891 SvREFCNT_dec(desc
.reference
);
1892 current_call_data
= save_call_data
;
1893 activate_interpreter(oldinterp
);
1899 SvREFCNT_dec(desc
.reference
);
1901 current_call_data
= save_call_data
;
1902 activate_interpreter(oldinterp
);
1904 error_context_stack
= pl_error_context
.previous
;
1910 * The validator is called during CREATE FUNCTION to validate the function
1911 * being created/replaced. The precise behavior of the validator may be
1912 * modified by the check_function_bodies GUC.
1914 PG_FUNCTION_INFO_V1(plperl_validator
);
1917 plperl_validator(PG_FUNCTION_ARGS
)
1919 Oid funcoid
= PG_GETARG_OID(0);
1927 bool is_trigger
= false;
1928 bool is_event_trigger
= false;
1931 if (!CheckFunctionValidatorAccess(fcinfo
->flinfo
->fn_oid
, funcoid
))
1934 /* Get the new function's pg_proc entry */
1935 tuple
= SearchSysCache1(PROCOID
, ObjectIdGetDatum(funcoid
));
1936 if (!HeapTupleIsValid(tuple
))
1937 elog(ERROR
, "cache lookup failed for function %u", funcoid
);
1938 proc
= (Form_pg_proc
) GETSTRUCT(tuple
);
1940 functyptype
= get_typtype(proc
->prorettype
);
1942 /* Disallow pseudotype result */
1943 /* except for TRIGGER, EVTTRIGGER, RECORD, or VOID */
1944 if (functyptype
== TYPTYPE_PSEUDO
)
1946 /* we assume OPAQUE with no arguments means a trigger */
1947 if (proc
->prorettype
== TRIGGEROID
||
1948 (proc
->prorettype
== OPAQUEOID
&& proc
->pronargs
== 0))
1950 else if (proc
->prorettype
== EVTTRIGGEROID
)
1951 is_event_trigger
= true;
1952 else if (proc
->prorettype
!= RECORDOID
&&
1953 proc
->prorettype
!= VOIDOID
)
1955 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED
),
1956 errmsg("PL/Perl functions cannot return type %s",
1957 format_type_be(proc
->prorettype
))));
1960 /* Disallow pseudotypes in arguments (either IN or OUT) */
1961 numargs
= get_func_arg_info(tuple
,
1962 &argtypes
, &argnames
, &argmodes
);
1963 for (i
= 0; i
< numargs
; i
++)
1965 if (get_typtype(argtypes
[i
]) == TYPTYPE_PSEUDO
&&
1966 argtypes
[i
] != RECORDOID
)
1968 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED
),
1969 errmsg("PL/Perl functions cannot accept type %s",
1970 format_type_be(argtypes
[i
]))));
1973 ReleaseSysCache(tuple
);
1975 /* Postpone body checks if !check_function_bodies */
1976 if (check_function_bodies
)
1978 (void) compile_plperl_function(funcoid
, is_trigger
, is_event_trigger
);
1981 /* the result of a validator is ignored */
1987 * plperlu likewise requires three externally visible functions:
1988 * plperlu_call_handler, plperlu_inline_handler, and plperlu_validator.
1989 * These are currently just aliases that send control to the plperl
1990 * handler functions, and we decide whether a particular function is
1991 * trusted or not by inspecting the actual pg_language tuple.
1994 PG_FUNCTION_INFO_V1(plperlu_call_handler
);
1997 plperlu_call_handler(PG_FUNCTION_ARGS
)
1999 return plperl_call_handler(fcinfo
);
2002 PG_FUNCTION_INFO_V1(plperlu_inline_handler
);
2005 plperlu_inline_handler(PG_FUNCTION_ARGS
)
2007 return plperl_inline_handler(fcinfo
);
2010 PG_FUNCTION_INFO_V1(plperlu_validator
);
2013 plperlu_validator(PG_FUNCTION_ARGS
)
2015 /* call plperl validator with our fcinfo so it gets our oid */
2016 return plperl_validator(fcinfo
);
2021 * Uses mksafefunc/mkunsafefunc to create a subroutine whose text is
2022 * supplied in s, and returns a reference to it
2025 plperl_create_sub(plperl_proc_desc
*prodesc
, char *s
, Oid fn_oid
)
2028 char subname
[NAMEDATALEN
+ 40];
2029 HV
*pragma_hv
= newHV();
2033 sprintf(subname
, "%s__%u", prodesc
->proname
, fn_oid
);
2035 if (plperl_use_strict
)
2036 hv_store_string(pragma_hv
, "strict", (SV
*) newAV());
2042 PUSHs(sv_2mortal(cstr2sv(subname
)));
2043 PUSHs(sv_2mortal(newRV_noinc((SV
*) pragma_hv
)));
2046 * Use 'false' for $prolog in mkfunc, which is kept for compatibility in
2047 * case a module such as PostgreSQL::PLPerl::NYTprof replaces the function
2051 PUSHs(sv_2mortal(cstr2sv(s
)));
2055 * G_KEEPERR seems to be needed here, else we don't recognize compile
2056 * errors properly. Perhaps it's because there's another level of eval
2057 * inside mksafefunc?
2059 count
= perl_call_pv("PostgreSQL::InServer::mkfunc",
2060 G_SCALAR
| G_EVAL
| G_KEEPERR
);
2065 SV
*sub_rv
= (SV
*) POPs
;
2067 if (sub_rv
&& SvROK(sub_rv
) && SvTYPE(SvRV(sub_rv
)) == SVt_PVCV
)
2069 subref
= newRV_inc(SvRV(sub_rv
));
2079 (errcode(ERRCODE_SYNTAX_ERROR
),
2080 errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV
)))));
2084 (errcode(ERRCODE_SYNTAX_ERROR
),
2085 errmsg("didn't get a CODE reference from compiling function \"%s\"",
2086 prodesc
->proname
)));
2088 prodesc
->reference
= subref
;
2094 /**********************************************************************
2095 * plperl_init_shared_libs() -
2096 **********************************************************************/
2099 plperl_init_shared_libs(pTHX
)
2101 char *file
= __FILE__
;
2103 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader
, file
);
2104 newXS("PostgreSQL::InServer::Util::bootstrap",
2105 boot_PostgreSQL__InServer__Util
, file
);
2106 /* newXS for...::SPI::bootstrap is in select_perl_context() */
2111 plperl_call_perl_func(plperl_proc_desc
*desc
, FunctionCallInfo fcinfo
)
2117 Oid
*argtypes
= NULL
;
2124 EXTEND(sp
, desc
->nargs
);
2126 /* Get signature for true functions; inline blocks have no args. */
2127 if (fcinfo
->flinfo
->fn_oid
)
2128 get_func_signature(fcinfo
->flinfo
->fn_oid
, &argtypes
, &nargs
);
2129 Assert(nargs
== desc
->nargs
);
2131 for (i
= 0; i
< desc
->nargs
; i
++)
2133 if (fcinfo
->argnull
[i
])
2134 PUSHs(&PL_sv_undef
);
2135 else if (desc
->arg_is_rowtype
[i
])
2137 SV
*sv
= plperl_hash_from_datum(fcinfo
->arg
[i
]);
2139 PUSHs(sv_2mortal(sv
));
2146 if (OidIsValid(desc
->arg_arraytype
[i
]))
2147 sv
= plperl_ref_from_pg_array(fcinfo
->arg
[i
], desc
->arg_arraytype
[i
]);
2148 else if ((funcid
= get_transform_fromsql(argtypes
[i
], current_call_data
->prodesc
->lang_oid
, current_call_data
->prodesc
->trftypes
)))
2149 sv
= (SV
*) DatumGetPointer(OidFunctionCall1(funcid
, fcinfo
->arg
[i
]));
2154 tmp
= OutputFunctionCall(&(desc
->arg_out_func
[i
]),
2160 PUSHs(sv_2mortal(sv
));
2165 /* Do NOT use G_KEEPERR here */
2166 count
= perl_call_sv(desc
->reference
, G_SCALAR
| G_EVAL
);
2176 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION
),
2177 errmsg("didn't get a return item from function")));
2186 /* XXX need to find a way to determine a better errcode here */
2188 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION
),
2189 errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV
)))));
2192 retval
= newSVsv(POPs
);
2203 plperl_call_perl_trigger_func(plperl_proc_desc
*desc
, FunctionCallInfo fcinfo
,
2211 Trigger
*tg_trigger
= ((TriggerData
*) fcinfo
->context
)->tg_trigger
;
2216 TDsv
= get_sv("main::_TD", 0);
2219 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION
),
2220 errmsg("couldn't fetch $_TD")));
2222 save_item(TDsv
); /* local $_TD */
2226 EXTEND(sp
, tg_trigger
->tgnargs
);
2228 for (i
= 0; i
< tg_trigger
->tgnargs
; i
++)
2229 PUSHs(sv_2mortal(cstr2sv(tg_trigger
->tgargs
[i
])));
2232 /* Do NOT use G_KEEPERR here */
2233 count
= perl_call_sv(desc
->reference
, G_SCALAR
| G_EVAL
);
2243 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION
),
2244 errmsg("didn't get a return item from trigger function")));
2253 /* XXX need to find a way to determine a better errcode here */
2255 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION
),
2256 errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV
)))));
2259 retval
= newSVsv(POPs
);
2270 plperl_call_perl_event_trigger_func(plperl_proc_desc
*desc
,
2271 FunctionCallInfo fcinfo
,
2282 TDsv
= get_sv("main::_TD", 0);
2285 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION
),
2286 errmsg("couldn't fetch $_TD")));
2288 save_item(TDsv
); /* local $_TD */
2294 /* Do NOT use G_KEEPERR here */
2295 count
= perl_call_sv(desc
->reference
, G_SCALAR
| G_EVAL
);
2305 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION
),
2306 errmsg("didn't get a return item from trigger function")));
2315 /* XXX need to find a way to determine a better errcode here */
2317 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION
),
2318 errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV
)))));
2321 retval
= newSVsv(POPs
);
2322 (void) retval
; /* silence compiler warning */
2332 plperl_func_handler(PG_FUNCTION_ARGS
)
2334 plperl_proc_desc
*prodesc
;
2338 ErrorContextCallback pl_error_context
;
2340 if (SPI_connect() != SPI_OK_CONNECT
)
2341 elog(ERROR
, "could not connect to SPI manager");
2343 prodesc
= compile_plperl_function(fcinfo
->flinfo
->fn_oid
, false, false);
2344 current_call_data
->prodesc
= prodesc
;
2345 increment_prodesc_refcount(prodesc
);
2347 /* Set a callback for error reporting */
2348 pl_error_context
.callback
= plperl_exec_callback
;
2349 pl_error_context
.previous
= error_context_stack
;
2350 pl_error_context
.arg
= prodesc
->proname
;
2351 error_context_stack
= &pl_error_context
;
2353 rsi
= (ReturnSetInfo
*) fcinfo
->resultinfo
;
2355 if (prodesc
->fn_retisset
)
2357 /* Check context before allowing the call to go through */
2358 if (!rsi
|| !IsA(rsi
, ReturnSetInfo
) ||
2359 (rsi
->allowedModes
& SFRM_Materialize
) == 0 ||
2360 rsi
->expectedDesc
== NULL
)
2362 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED
),
2363 errmsg("set-valued function called in context that "
2364 "cannot accept a set")));
2367 activate_interpreter(prodesc
->interp
);
2369 perlret
= plperl_call_perl_func(prodesc
, fcinfo
);
2371 /************************************************************
2372 * Disconnect from SPI manager and then create the return
2373 * values datum (if the input function does a palloc for it
2374 * this must not be allocated in the SPI memory context
2375 * because SPI_finish would free it).
2376 ************************************************************/
2377 if (SPI_finish() != SPI_OK_FINISH
)
2378 elog(ERROR
, "SPI_finish() failed");
2380 if (prodesc
->fn_retisset
)
2385 * If the Perl function returned an arrayref, we pretend that it
2386 * called return_next() for each element of the array, to handle old
2387 * SRFs that didn't know about return_next(). Any other sort of return
2388 * value is an error, except undef which means return an empty set.
2390 sav
= get_perl_array_ref(perlret
);
2395 AV
*rav
= (AV
*) SvRV(sav
);
2397 while ((svp
= av_fetch(rav
, i
, FALSE
)) != NULL
)
2399 plperl_return_next(*svp
);
2403 else if (SvOK(perlret
))
2406 (errcode(ERRCODE_DATATYPE_MISMATCH
),
2407 errmsg("set-returning PL/Perl function must return "
2408 "reference to array or use return_next")));
2411 rsi
->returnMode
= SFRM_Materialize
;
2412 if (current_call_data
->tuple_store
)
2414 rsi
->setResult
= current_call_data
->tuple_store
;
2415 rsi
->setDesc
= current_call_data
->ret_tdesc
;
2421 retval
= plperl_sv_to_datum(perlret
,
2422 prodesc
->result_oid
,
2425 &prodesc
->result_in_func
,
2426 prodesc
->result_typioparam
,
2429 if (fcinfo
->isnull
&& rsi
&& IsA(rsi
, ReturnSetInfo
))
2430 rsi
->isDone
= ExprEndResult
;
2433 /* Restore the previous error callback */
2434 error_context_stack
= pl_error_context
.previous
;
2436 SvREFCNT_dec(perlret
);
2443 plperl_trigger_handler(PG_FUNCTION_ARGS
)
2445 plperl_proc_desc
*prodesc
;
2450 ErrorContextCallback pl_error_context
;
2452 /* Connect to SPI manager */
2453 if (SPI_connect() != SPI_OK_CONNECT
)
2454 elog(ERROR
, "could not connect to SPI manager");
2456 /* Find or compile the function */
2457 prodesc
= compile_plperl_function(fcinfo
->flinfo
->fn_oid
, true, false);
2458 current_call_data
->prodesc
= prodesc
;
2459 increment_prodesc_refcount(prodesc
);
2461 /* Set a callback for error reporting */
2462 pl_error_context
.callback
= plperl_exec_callback
;
2463 pl_error_context
.previous
= error_context_stack
;
2464 pl_error_context
.arg
= prodesc
->proname
;
2465 error_context_stack
= &pl_error_context
;
2467 activate_interpreter(prodesc
->interp
);
2469 svTD
= plperl_trigger_build_args(fcinfo
);
2470 perlret
= plperl_call_perl_trigger_func(prodesc
, fcinfo
, svTD
);
2471 hvTD
= (HV
*) SvRV(svTD
);
2473 /************************************************************
2474 * Disconnect from SPI manager and then create the return
2475 * values datum (if the input function does a palloc for it
2476 * this must not be allocated in the SPI memory context
2477 * because SPI_finish would free it).
2478 ************************************************************/
2479 if (SPI_finish() != SPI_OK_FINISH
)
2480 elog(ERROR
, "SPI_finish() failed");
2482 if (perlret
== NULL
|| !SvOK(perlret
))
2484 /* undef result means go ahead with original tuple */
2485 TriggerData
*trigdata
= ((TriggerData
*) fcinfo
->context
);
2487 if (TRIGGER_FIRED_BY_INSERT(trigdata
->tg_event
))
2488 retval
= (Datum
) trigdata
->tg_trigtuple
;
2489 else if (TRIGGER_FIRED_BY_UPDATE(trigdata
->tg_event
))
2490 retval
= (Datum
) trigdata
->tg_newtuple
;
2491 else if (TRIGGER_FIRED_BY_DELETE(trigdata
->tg_event
))
2492 retval
= (Datum
) trigdata
->tg_trigtuple
;
2493 else if (TRIGGER_FIRED_BY_TRUNCATE(trigdata
->tg_event
))
2494 retval
= (Datum
) trigdata
->tg_trigtuple
;
2496 retval
= (Datum
) 0; /* can this happen? */
2503 tmp
= sv2cstr(perlret
);
2505 if (pg_strcasecmp(tmp
, "SKIP") == 0)
2507 else if (pg_strcasecmp(tmp
, "MODIFY") == 0)
2509 TriggerData
*trigdata
= (TriggerData
*) fcinfo
->context
;
2511 if (TRIGGER_FIRED_BY_INSERT(trigdata
->tg_event
))
2512 trv
= plperl_modify_tuple(hvTD
, trigdata
,
2513 trigdata
->tg_trigtuple
);
2514 else if (TRIGGER_FIRED_BY_UPDATE(trigdata
->tg_event
))
2515 trv
= plperl_modify_tuple(hvTD
, trigdata
,
2516 trigdata
->tg_newtuple
);
2520 (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED
),
2521 errmsg("ignoring modified row in DELETE trigger")));
2528 (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED
),
2529 errmsg("result of PL/Perl trigger function must be undef, "
2530 "\"SKIP\", or \"MODIFY\"")));
2533 retval
= PointerGetDatum(trv
);
2537 /* Restore the previous error callback */
2538 error_context_stack
= pl_error_context
.previous
;
2542 SvREFCNT_dec(perlret
);
2549 plperl_event_trigger_handler(PG_FUNCTION_ARGS
)
2551 plperl_proc_desc
*prodesc
;
2553 ErrorContextCallback pl_error_context
;
2555 /* Connect to SPI manager */
2556 if (SPI_connect() != SPI_OK_CONNECT
)
2557 elog(ERROR
, "could not connect to SPI manager");
2559 /* Find or compile the function */
2560 prodesc
= compile_plperl_function(fcinfo
->flinfo
->fn_oid
, false, true);
2561 current_call_data
->prodesc
= prodesc
;
2562 increment_prodesc_refcount(prodesc
);
2564 /* Set a callback for error reporting */
2565 pl_error_context
.callback
= plperl_exec_callback
;
2566 pl_error_context
.previous
= error_context_stack
;
2567 pl_error_context
.arg
= prodesc
->proname
;
2568 error_context_stack
= &pl_error_context
;
2570 activate_interpreter(prodesc
->interp
);
2572 svTD
= plperl_event_trigger_build_args(fcinfo
);
2573 plperl_call_perl_event_trigger_func(prodesc
, fcinfo
, svTD
);
2575 if (SPI_finish() != SPI_OK_FINISH
)
2576 elog(ERROR
, "SPI_finish() failed");
2578 /* Restore the previous error callback */
2579 error_context_stack
= pl_error_context
.previous
;
2588 validate_plperl_function(plperl_proc_ptr
*proc_ptr
, HeapTuple procTup
)
2590 if (proc_ptr
&& proc_ptr
->proc_ptr
)
2592 plperl_proc_desc
*prodesc
= proc_ptr
->proc_ptr
;
2595 /************************************************************
2596 * If it's present, must check whether it's still up to date.
2597 * This is needed because CREATE OR REPLACE FUNCTION can modify the
2598 * function's pg_proc entry without changing its OID.
2599 ************************************************************/
2600 uptodate
= (prodesc
->fn_xmin
== HeapTupleHeaderGetRawXmin(procTup
->t_data
) &&
2601 ItemPointerEquals(&prodesc
->fn_tid
, &procTup
->t_self
));
2606 /* Otherwise, unlink the obsoleted entry from the hashtable ... */
2607 proc_ptr
->proc_ptr
= NULL
;
2608 /* ... and release the corresponding refcount, probably deleting it */
2609 decrement_prodesc_refcount(prodesc
);
2617 free_plperl_function(plperl_proc_desc
*prodesc
)
2619 Assert(prodesc
->refcount
<= 0);
2620 /* Release CODE reference, if we have one, from the appropriate interp */
2621 if (prodesc
->reference
)
2623 plperl_interp_desc
*oldinterp
= plperl_active_interp
;
2625 activate_interpreter(prodesc
->interp
);
2626 SvREFCNT_dec(prodesc
->reference
);
2627 activate_interpreter(oldinterp
);
2629 /* Get rid of what we conveniently can of our own structs */
2630 /* (FmgrInfo subsidiary info will get leaked ...) */
2631 if (prodesc
->proname
)
2632 free(prodesc
->proname
);
2633 list_free(prodesc
->trftypes
);
2638 static plperl_proc_desc
*
2639 compile_plperl_function(Oid fn_oid
, bool is_trigger
, bool is_event_trigger
)
2642 Form_pg_proc procStruct
;
2643 plperl_proc_key proc_key
;
2644 plperl_proc_ptr
*proc_ptr
;
2645 plperl_proc_desc
*prodesc
= NULL
;
2647 plperl_interp_desc
*oldinterp
= plperl_active_interp
;
2648 ErrorContextCallback plperl_error_context
;
2650 /* We'll need the pg_proc tuple in any case... */
2651 procTup
= SearchSysCache1(PROCOID
, ObjectIdGetDatum(fn_oid
));
2652 if (!HeapTupleIsValid(procTup
))
2653 elog(ERROR
, "cache lookup failed for function %u", fn_oid
);
2654 procStruct
= (Form_pg_proc
) GETSTRUCT(procTup
);
2656 /* Set a callback for reporting compilation errors */
2657 plperl_error_context
.callback
= plperl_compile_callback
;
2658 plperl_error_context
.previous
= error_context_stack
;
2659 plperl_error_context
.arg
= NameStr(procStruct
->proname
);
2660 error_context_stack
= &plperl_error_context
;
2662 /* Try to find function in plperl_proc_hash */
2663 proc_key
.proc_id
= fn_oid
;
2664 proc_key
.is_trigger
= is_trigger
;
2665 proc_key
.user_id
= GetUserId();
2667 proc_ptr
= hash_search(plperl_proc_hash
, &proc_key
,
2670 if (validate_plperl_function(proc_ptr
, procTup
))
2671 prodesc
= proc_ptr
->proc_ptr
;
2674 /* If not found or obsolete, maybe it's plperlu */
2675 proc_key
.user_id
= InvalidOid
;
2676 proc_ptr
= hash_search(plperl_proc_hash
, &proc_key
,
2678 if (validate_plperl_function(proc_ptr
, procTup
))
2679 prodesc
= proc_ptr
->proc_ptr
;
2682 /************************************************************
2683 * If we haven't found it in the hashtable, we analyze
2684 * the function's arguments and return type and store
2685 * the in-/out-functions in the prodesc block and create
2686 * a new hashtable entry for it.
2688 * Then we load the procedure into the Perl interpreter.
2689 ************************************************************/
2690 if (prodesc
== NULL
)
2694 Form_pg_language langStruct
;
2695 Form_pg_type typeStruct
;
2696 Datum protrftypes_datum
;
2701 /************************************************************
2702 * Allocate a new procedure description block
2703 ************************************************************/
2704 prodesc
= (plperl_proc_desc
*) malloc(sizeof(plperl_proc_desc
));
2705 if (prodesc
== NULL
)
2707 (errcode(ERRCODE_OUT_OF_MEMORY
),
2708 errmsg("out of memory")));
2709 /* Initialize all fields to 0 so free_plperl_function is safe */
2710 MemSet(prodesc
, 0, sizeof(plperl_proc_desc
));
2712 prodesc
->proname
= strdup(NameStr(procStruct
->proname
));
2713 if (prodesc
->proname
== NULL
)
2715 free_plperl_function(prodesc
);
2717 (errcode(ERRCODE_OUT_OF_MEMORY
),
2718 errmsg("out of memory")));
2720 prodesc
->fn_xmin
= HeapTupleHeaderGetRawXmin(procTup
->t_data
);
2721 prodesc
->fn_tid
= procTup
->t_self
;
2723 /* Remember if function is STABLE/IMMUTABLE */
2724 prodesc
->fn_readonly
=
2725 (procStruct
->provolatile
!= PROVOLATILE_VOLATILE
);
2728 MemoryContext oldcxt
;
2730 protrftypes_datum
= SysCacheGetAttr(PROCOID
, procTup
,
2731 Anum_pg_proc_protrftypes
, &isnull
);
2732 oldcxt
= MemoryContextSwitchTo(TopMemoryContext
);
2733 prodesc
->trftypes
= isnull
? NIL
: oid_array_to_list(protrftypes_datum
);
2734 MemoryContextSwitchTo(oldcxt
);
2737 /************************************************************
2738 * Lookup the pg_language tuple by Oid
2739 ************************************************************/
2740 langTup
= SearchSysCache1(LANGOID
,
2741 ObjectIdGetDatum(procStruct
->prolang
));
2742 if (!HeapTupleIsValid(langTup
))
2744 free_plperl_function(prodesc
);
2745 elog(ERROR
, "cache lookup failed for language %u",
2746 procStruct
->prolang
);
2748 langStruct
= (Form_pg_language
) GETSTRUCT(langTup
);
2749 prodesc
->lang_oid
= HeapTupleGetOid(langTup
);
2750 prodesc
->lanpltrusted
= langStruct
->lanpltrusted
;
2751 ReleaseSysCache(langTup
);
2753 /************************************************************
2754 * Get the required information for input conversion of the
2756 ************************************************************/
2757 if (!is_trigger
&& !is_event_trigger
)
2760 SearchSysCache1(TYPEOID
,
2761 ObjectIdGetDatum(procStruct
->prorettype
));
2762 if (!HeapTupleIsValid(typeTup
))
2764 free_plperl_function(prodesc
);
2765 elog(ERROR
, "cache lookup failed for type %u",
2766 procStruct
->prorettype
);
2768 typeStruct
= (Form_pg_type
) GETSTRUCT(typeTup
);
2770 /* Disallow pseudotype result, except VOID or RECORD */
2771 if (typeStruct
->typtype
== TYPTYPE_PSEUDO
)
2773 if (procStruct
->prorettype
== VOIDOID
||
2774 procStruct
->prorettype
== RECORDOID
)
2776 else if (procStruct
->prorettype
== TRIGGEROID
||
2777 procStruct
->prorettype
== EVTTRIGGEROID
)
2779 free_plperl_function(prodesc
);
2781 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED
),
2782 errmsg("trigger functions can only be called "
2787 free_plperl_function(prodesc
);
2789 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED
),
2790 errmsg("PL/Perl functions cannot return type %s",
2791 format_type_be(procStruct
->prorettype
))));
2795 prodesc
->result_oid
= procStruct
->prorettype
;
2796 prodesc
->fn_retisset
= procStruct
->proretset
;
2797 prodesc
->fn_retistuple
= (procStruct
->prorettype
== RECORDOID
||
2798 typeStruct
->typtype
== TYPTYPE_COMPOSITE
);
2800 prodesc
->fn_retisarray
=
2801 (typeStruct
->typlen
== -1 && typeStruct
->typelem
);
2803 perm_fmgr_info(typeStruct
->typinput
, &(prodesc
->result_in_func
));
2804 prodesc
->result_typioparam
= getTypeIOParam(typeTup
);
2806 ReleaseSysCache(typeTup
);
2809 /************************************************************
2810 * Get the required information for output conversion
2811 * of all procedure arguments
2812 ************************************************************/
2813 if (!is_trigger
&& !is_event_trigger
)
2815 prodesc
->nargs
= procStruct
->pronargs
;
2816 for (i
= 0; i
< prodesc
->nargs
; i
++)
2818 typeTup
= SearchSysCache1(TYPEOID
,
2819 ObjectIdGetDatum(procStruct
->proargtypes
.values
[i
]));
2820 if (!HeapTupleIsValid(typeTup
))
2822 free_plperl_function(prodesc
);
2823 elog(ERROR
, "cache lookup failed for type %u",
2824 procStruct
->proargtypes
.values
[i
]);
2826 typeStruct
= (Form_pg_type
) GETSTRUCT(typeTup
);
2828 /* Disallow pseudotype argument */
2829 if (typeStruct
->typtype
== TYPTYPE_PSEUDO
&&
2830 procStruct
->proargtypes
.values
[i
] != RECORDOID
)
2832 free_plperl_function(prodesc
);
2834 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED
),
2835 errmsg("PL/Perl functions cannot accept type %s",
2836 format_type_be(procStruct
->proargtypes
.values
[i
]))));
2839 if (typeStruct
->typtype
== TYPTYPE_COMPOSITE
||
2840 procStruct
->proargtypes
.values
[i
] == RECORDOID
)
2841 prodesc
->arg_is_rowtype
[i
] = true;
2844 prodesc
->arg_is_rowtype
[i
] = false;
2845 perm_fmgr_info(typeStruct
->typoutput
,
2846 &(prodesc
->arg_out_func
[i
]));
2849 /* Identify array attributes */
2850 if (typeStruct
->typelem
!= 0 && typeStruct
->typlen
== -1)
2851 prodesc
->arg_arraytype
[i
] = procStruct
->proargtypes
.values
[i
];
2853 prodesc
->arg_arraytype
[i
] = InvalidOid
;
2855 ReleaseSysCache(typeTup
);
2859 /************************************************************
2860 * create the text of the anonymous subroutine.
2861 * we do not use a named subroutine so that we can call directly
2862 * through the reference.
2863 ************************************************************/
2864 prosrcdatum
= SysCacheGetAttr(PROCOID
, procTup
,
2865 Anum_pg_proc_prosrc
, &isnull
);
2867 elog(ERROR
, "null prosrc");
2868 proc_source
= TextDatumGetCString(prosrcdatum
);
2870 /************************************************************
2871 * Create the procedure in the appropriate interpreter
2872 ************************************************************/
2874 select_perl_context(prodesc
->lanpltrusted
);
2876 prodesc
->interp
= plperl_active_interp
;
2878 plperl_create_sub(prodesc
, proc_source
, fn_oid
);
2880 activate_interpreter(oldinterp
);
2883 if (!prodesc
->reference
) /* can this happen? */
2885 free_plperl_function(prodesc
);
2886 elog(ERROR
, "could not create PL/Perl internal procedure");
2889 /************************************************************
2890 * OK, link the procedure into the correct hashtable entry
2891 ************************************************************/
2892 proc_key
.user_id
= prodesc
->lanpltrusted
? GetUserId() : InvalidOid
;
2894 proc_ptr
= hash_search(plperl_proc_hash
, &proc_key
,
2896 proc_ptr
->proc_ptr
= prodesc
;
2897 increment_prodesc_refcount(prodesc
);
2900 /* restore previous error callback */
2901 error_context_stack
= plperl_error_context
.previous
;
2903 ReleaseSysCache(procTup
);
2908 /* Build a hash from a given composite/row datum */
2910 plperl_hash_from_datum(Datum attr
)
2916 HeapTupleData tmptup
;
2919 td
= DatumGetHeapTupleHeader(attr
);
2921 /* Extract rowtype info and find a tupdesc */
2922 tupType
= HeapTupleHeaderGetTypeId(td
);
2923 tupTypmod
= HeapTupleHeaderGetTypMod(td
);
2924 tupdesc
= lookup_rowtype_tupdesc(tupType
, tupTypmod
);
2926 /* Build a temporary HeapTuple control structure */
2927 tmptup
.t_len
= HeapTupleHeaderGetDatumLength(td
);
2930 sv
= plperl_hash_from_tuple(&tmptup
, tupdesc
);
2931 ReleaseTupleDesc(tupdesc
);
2936 /* Build a hash from all attributes of a given tuple. */
2938 plperl_hash_from_tuple(HeapTuple tuple
, TupleDesc tupdesc
)
2943 /* since this function recurses, it could be driven to stack overflow */
2944 check_stack_depth();
2947 hv_ksplit(hv
, tupdesc
->natts
); /* pre-grow the hash */
2949 for (i
= 0; i
< tupdesc
->natts
; i
++)
2957 if (tupdesc
->attrs
[i
]->attisdropped
)
2960 attname
= NameStr(tupdesc
->attrs
[i
]->attname
);
2961 attr
= heap_getattr(tuple
, i
+ 1, tupdesc
, &isnull
);
2966 * Store (attname => undef) and move on. Note we can't use
2967 * &PL_sv_undef here; see "AVs, HVs and undefined values" in
2968 * perlguts for an explanation.
2970 hv_store_string(hv
, attname
, newSV(0));
2974 if (type_is_rowtype(tupdesc
->attrs
[i
]->atttypid
))
2976 SV
*sv
= plperl_hash_from_datum(attr
);
2978 hv_store_string(hv
, attname
, sv
);
2985 if (OidIsValid(get_base_element_type(tupdesc
->attrs
[i
]->atttypid
)))
2986 sv
= plperl_ref_from_pg_array(attr
, tupdesc
->attrs
[i
]->atttypid
);
2987 else if ((funcid
= get_transform_fromsql(tupdesc
->attrs
[i
]->atttypid
, current_call_data
->prodesc
->lang_oid
, current_call_data
->prodesc
->trftypes
)))
2988 sv
= (SV
*) DatumGetPointer(OidFunctionCall1(funcid
, attr
));
2993 /* XXX should have a way to cache these lookups */
2994 getTypeOutputInfo(tupdesc
->attrs
[i
]->atttypid
,
2995 &typoutput
, &typisvarlena
);
2997 outputstr
= OidOutputFunctionCall(typoutput
, attr
);
2998 sv
= cstr2sv(outputstr
);
3002 hv_store_string(hv
, attname
, sv
);
3005 return newRV_noinc((SV
*) hv
);
3010 check_spi_usage_allowed(void)
3012 /* see comment in plperl_fini() */
3015 /* simple croak as we don't want to involve PostgreSQL code */
3016 croak("SPI functions can not be used in END blocks");
3022 plperl_spi_exec(char *query
, int limit
)
3027 * Execute the query inside a sub-transaction, so we can cope with errors
3030 MemoryContext oldcontext
= CurrentMemoryContext
;
3031 ResourceOwner oldowner
= CurrentResourceOwner
;
3033 check_spi_usage_allowed();
3035 BeginInternalSubTransaction(NULL
);
3036 /* Want to run inside function's memory context */
3037 MemoryContextSwitchTo(oldcontext
);
3043 pg_verifymbstr(query
, strlen(query
), false);
3045 spi_rv
= SPI_execute(query
, current_call_data
->prodesc
->fn_readonly
,
3047 ret_hv
= plperl_spi_execute_fetch_result(SPI_tuptable
, SPI_processed
,
3050 /* Commit the inner transaction, return to outer xact context */
3051 ReleaseCurrentSubTransaction();
3052 MemoryContextSwitchTo(oldcontext
);
3053 CurrentResourceOwner
= oldowner
;
3056 * AtEOSubXact_SPI() should not have popped any SPI context, but just
3057 * in case it did, make sure we remain connected.
3059 SPI_restore_connection();
3065 /* Save error info */
3066 MemoryContextSwitchTo(oldcontext
);
3067 edata
= CopyErrorData();
3070 /* Abort the inner transaction */
3071 RollbackAndReleaseCurrentSubTransaction();
3072 MemoryContextSwitchTo(oldcontext
);
3073 CurrentResourceOwner
= oldowner
;
3076 * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
3077 * have left us in a disconnected state. We need this hack to return
3078 * to connected state.
3080 SPI_restore_connection();
3082 /* Punt the error to Perl */
3083 croak_cstr(edata
->message
);
3085 /* Can't get here, but keep compiler quiet */
3095 plperl_spi_execute_fetch_result(SPITupleTable
*tuptable
, uint64 processed
,
3100 check_spi_usage_allowed();
3104 hv_store_string(result
, "status",
3105 cstr2sv(SPI_result_code_string(status
)));
3106 hv_store_string(result
, "processed",
3107 (processed
> (uint64
) UV_MAX
) ?
3108 newSVnv((NV
) processed
) :
3109 newSVuv((UV
) processed
));
3111 if (status
> 0 && tuptable
)
3117 /* Prevent overflow in call to av_extend() */
3118 if (processed
> (uint64
) AV_SIZE_MAX
)
3120 (errcode(ERRCODE_PROGRAM_LIMIT_EXCEEDED
),
3121 errmsg("query result has too many rows to fit in a Perl array")));
3124 av_extend(rows
, processed
);
3125 for (i
= 0; i
< processed
; i
++)
3127 row
= plperl_hash_from_tuple(tuptable
->vals
[i
], tuptable
->tupdesc
);
3130 hv_store_string(result
, "rows",
3131 newRV_noinc((SV
*) rows
));
3134 SPI_freetuptable(tuptable
);
3141 * Note: plperl_return_next is called both in Postgres and Perl contexts.
3142 * We report any errors in Postgres fashion (via ereport). If called in
3143 * Perl context, it is SPI.xs's responsibility to catch the error and
3144 * convert to a Perl error. We assume (perhaps without adequate justification)
3145 * that we need not abort the current transaction if the Perl code traps the
3149 plperl_return_next(SV
*sv
)
3151 plperl_proc_desc
*prodesc
;
3152 FunctionCallInfo fcinfo
;
3154 MemoryContext old_cxt
;
3159 prodesc
= current_call_data
->prodesc
;
3160 fcinfo
= current_call_data
->fcinfo
;
3161 rsi
= (ReturnSetInfo
*) fcinfo
->resultinfo
;
3163 if (!prodesc
->fn_retisset
)
3165 (errcode(ERRCODE_SYNTAX_ERROR
),
3166 errmsg("cannot use return_next in a non-SETOF function")));
3168 if (!current_call_data
->ret_tdesc
)
3172 Assert(!current_call_data
->tuple_store
);
3175 * This is the first call to return_next in the current PL/Perl
3176 * function call, so memoize some lookups
3178 if (prodesc
->fn_retistuple
)
3179 (void) get_call_result_type(fcinfo
, NULL
, &tupdesc
);
3181 tupdesc
= rsi
->expectedDesc
;
3184 * Make sure the tuple_store and ret_tdesc are sufficiently
3187 old_cxt
= MemoryContextSwitchTo(rsi
->econtext
->ecxt_per_query_memory
);
3189 current_call_data
->ret_tdesc
= CreateTupleDescCopy(tupdesc
);
3190 current_call_data
->tuple_store
=
3191 tuplestore_begin_heap(rsi
->allowedModes
& SFRM_Materialize_Random
,
3194 MemoryContextSwitchTo(old_cxt
);
3198 * Producing the tuple we want to return requires making plenty of
3199 * palloc() allocations that are not cleaned up. Since this function can
3200 * be called many times before the current memory context is reset, we
3201 * need to do those allocations in a temporary context.
3203 if (!current_call_data
->tmp_cxt
)
3205 current_call_data
->tmp_cxt
=
3206 AllocSetContextCreate(CurrentMemoryContext
,
3207 "PL/Perl return_next temporary cxt",
3208 ALLOCSET_DEFAULT_MINSIZE
,
3209 ALLOCSET_DEFAULT_INITSIZE
,
3210 ALLOCSET_DEFAULT_MAXSIZE
);
3213 old_cxt
= MemoryContextSwitchTo(current_call_data
->tmp_cxt
);
3215 if (prodesc
->fn_retistuple
)
3219 if (!(SvOK(sv
) && SvROK(sv
) && SvTYPE(SvRV(sv
)) == SVt_PVHV
))
3221 (errcode(ERRCODE_DATATYPE_MISMATCH
),
3222 errmsg("SETOF-composite-returning PL/Perl function "
3223 "must call return_next with reference to hash")));
3225 tuple
= plperl_build_tuple_result((HV
*) SvRV(sv
),
3226 current_call_data
->ret_tdesc
);
3227 tuplestore_puttuple(current_call_data
->tuple_store
, tuple
);
3234 ret
= plperl_sv_to_datum(sv
,
3235 prodesc
->result_oid
,
3238 &prodesc
->result_in_func
,
3239 prodesc
->result_typioparam
,
3242 tuplestore_putvalues(current_call_data
->tuple_store
,
3243 current_call_data
->ret_tdesc
,
3247 MemoryContextSwitchTo(old_cxt
);
3248 MemoryContextReset(current_call_data
->tmp_cxt
);
3253 plperl_spi_query(char *query
)
3258 * Execute the query inside a sub-transaction, so we can cope with errors
3261 MemoryContext oldcontext
= CurrentMemoryContext
;
3262 ResourceOwner oldowner
= CurrentResourceOwner
;
3264 check_spi_usage_allowed();
3266 BeginInternalSubTransaction(NULL
);
3267 /* Want to run inside function's memory context */
3268 MemoryContextSwitchTo(oldcontext
);
3275 /* Make sure the query is validly encoded */
3276 pg_verifymbstr(query
, strlen(query
), false);
3278 /* Create a cursor for the query */
3279 plan
= SPI_prepare(query
, 0, NULL
);
3281 elog(ERROR
, "SPI_prepare() failed:%s",
3282 SPI_result_code_string(SPI_result
));
3284 portal
= SPI_cursor_open(NULL
, plan
, NULL
, NULL
, false);
3287 elog(ERROR
, "SPI_cursor_open() failed:%s",
3288 SPI_result_code_string(SPI_result
));
3289 cursor
= cstr2sv(portal
->name
);
3291 /* Commit the inner transaction, return to outer xact context */
3292 ReleaseCurrentSubTransaction();
3293 MemoryContextSwitchTo(oldcontext
);
3294 CurrentResourceOwner
= oldowner
;
3297 * AtEOSubXact_SPI() should not have popped any SPI context, but just
3298 * in case it did, make sure we remain connected.
3300 SPI_restore_connection();
3306 /* Save error info */
3307 MemoryContextSwitchTo(oldcontext
);
3308 edata
= CopyErrorData();
3311 /* Abort the inner transaction */
3312 RollbackAndReleaseCurrentSubTransaction();
3313 MemoryContextSwitchTo(oldcontext
);
3314 CurrentResourceOwner
= oldowner
;
3317 * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
3318 * have left us in a disconnected state. We need this hack to return
3319 * to connected state.
3321 SPI_restore_connection();
3323 /* Punt the error to Perl */
3324 croak_cstr(edata
->message
);
3326 /* Can't get here, but keep compiler quiet */
3336 plperl_spi_fetchrow(char *cursor
)
3341 * Execute the FETCH inside a sub-transaction, so we can cope with errors
3344 MemoryContext oldcontext
= CurrentMemoryContext
;
3345 ResourceOwner oldowner
= CurrentResourceOwner
;
3347 check_spi_usage_allowed();
3349 BeginInternalSubTransaction(NULL
);
3350 /* Want to run inside function's memory context */
3351 MemoryContextSwitchTo(oldcontext
);
3355 Portal p
= SPI_cursor_find(cursor
);
3363 SPI_cursor_fetch(p
, true, 1);
3364 if (SPI_processed
== 0)
3366 SPI_cursor_close(p
);
3371 row
= plperl_hash_from_tuple(SPI_tuptable
->vals
[0],
3372 SPI_tuptable
->tupdesc
);
3374 SPI_freetuptable(SPI_tuptable
);
3377 /* Commit the inner transaction, return to outer xact context */
3378 ReleaseCurrentSubTransaction();
3379 MemoryContextSwitchTo(oldcontext
);
3380 CurrentResourceOwner
= oldowner
;
3383 * AtEOSubXact_SPI() should not have popped any SPI context, but just
3384 * in case it did, make sure we remain connected.
3386 SPI_restore_connection();
3392 /* Save error info */
3393 MemoryContextSwitchTo(oldcontext
);
3394 edata
= CopyErrorData();
3397 /* Abort the inner transaction */
3398 RollbackAndReleaseCurrentSubTransaction();
3399 MemoryContextSwitchTo(oldcontext
);
3400 CurrentResourceOwner
= oldowner
;
3403 * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
3404 * have left us in a disconnected state. We need this hack to return
3405 * to connected state.
3407 SPI_restore_connection();
3409 /* Punt the error to Perl */
3410 croak_cstr(edata
->message
);
3412 /* Can't get here, but keep compiler quiet */
3421 plperl_spi_cursor_close(char *cursor
)
3425 check_spi_usage_allowed();
3427 p
= SPI_cursor_find(cursor
);
3430 SPI_cursor_close(p
);
3434 plperl_spi_prepare(char *query
, int argc
, SV
**argv
)
3436 volatile SPIPlanPtr plan
= NULL
;
3437 volatile MemoryContext plan_cxt
= NULL
;
3438 plperl_query_desc
*volatile qdesc
= NULL
;
3439 plperl_query_entry
*volatile hash_entry
= NULL
;
3440 MemoryContext oldcontext
= CurrentMemoryContext
;
3441 ResourceOwner oldowner
= CurrentResourceOwner
;
3442 MemoryContext work_cxt
;
3446 check_spi_usage_allowed();
3448 BeginInternalSubTransaction(NULL
);
3449 MemoryContextSwitchTo(oldcontext
);
3453 CHECK_FOR_INTERRUPTS();
3455 /************************************************************
3456 * Allocate the new querydesc structure
3458 * The qdesc struct, as well as all its subsidiary data, lives in its
3459 * plan_cxt. But note that the SPIPlan does not.
3460 ************************************************************/
3461 plan_cxt
= AllocSetContextCreate(TopMemoryContext
,
3462 "PL/Perl spi_prepare query",
3463 ALLOCSET_SMALL_MINSIZE
,
3464 ALLOCSET_SMALL_INITSIZE
,
3465 ALLOCSET_SMALL_MAXSIZE
);
3466 MemoryContextSwitchTo(plan_cxt
);
3467 qdesc
= (plperl_query_desc
*) palloc0(sizeof(plperl_query_desc
));
3468 snprintf(qdesc
->qname
, sizeof(qdesc
->qname
), "%p", qdesc
);
3469 qdesc
->plan_cxt
= plan_cxt
;
3470 qdesc
->nargs
= argc
;
3471 qdesc
->argtypes
= (Oid
*) palloc(argc
* sizeof(Oid
));
3472 qdesc
->arginfuncs
= (FmgrInfo
*) palloc(argc
* sizeof(FmgrInfo
));
3473 qdesc
->argtypioparams
= (Oid
*) palloc(argc
* sizeof(Oid
));
3474 MemoryContextSwitchTo(oldcontext
);
3476 /************************************************************
3477 * Do the following work in a short-lived context so that we don't
3478 * leak a lot of memory in the PL/Perl function's SPI Proc context.
3479 ************************************************************/
3480 work_cxt
= AllocSetContextCreate(CurrentMemoryContext
,
3481 "PL/Perl spi_prepare workspace",
3482 ALLOCSET_DEFAULT_MINSIZE
,
3483 ALLOCSET_DEFAULT_INITSIZE
,
3484 ALLOCSET_DEFAULT_MAXSIZE
);
3485 MemoryContextSwitchTo(work_cxt
);
3487 /************************************************************
3488 * Resolve argument type names and then look them up by oid
3489 * in the system cache, and remember the required information
3490 * for input conversion.
3491 ************************************************************/
3492 for (i
= 0; i
< argc
; i
++)
3500 typstr
= sv2cstr(argv
[i
]);
3501 parseTypeString(typstr
, &typId
, &typmod
, false);
3504 getTypeInputInfo(typId
, &typInput
, &typIOParam
);
3506 qdesc
->argtypes
[i
] = typId
;
3507 fmgr_info_cxt(typInput
, &(qdesc
->arginfuncs
[i
]), plan_cxt
);
3508 qdesc
->argtypioparams
[i
] = typIOParam
;
3511 /* Make sure the query is validly encoded */
3512 pg_verifymbstr(query
, strlen(query
), false);
3514 /************************************************************
3515 * Prepare the plan and check for errors
3516 ************************************************************/
3517 plan
= SPI_prepare(query
, argc
, qdesc
->argtypes
);
3520 elog(ERROR
, "SPI_prepare() failed:%s",
3521 SPI_result_code_string(SPI_result
));
3523 /************************************************************
3524 * Save the plan into permanent memory (right now it's in the
3525 * SPI procCxt, which will go away at function end).
3526 ************************************************************/
3527 if (SPI_keepplan(plan
))
3528 elog(ERROR
, "SPI_keepplan() failed");
3531 /************************************************************
3532 * Insert a hashtable entry for the plan.
3533 ************************************************************/
3534 hash_entry
= hash_search(plperl_active_interp
->query_hash
,
3536 HASH_ENTER
, &found
);
3537 hash_entry
->query_data
= qdesc
;
3539 /* Get rid of workspace */
3540 MemoryContextDelete(work_cxt
);
3542 /* Commit the inner transaction, return to outer xact context */
3543 ReleaseCurrentSubTransaction();
3544 MemoryContextSwitchTo(oldcontext
);
3545 CurrentResourceOwner
= oldowner
;
3548 * AtEOSubXact_SPI() should not have popped any SPI context, but just
3549 * in case it did, make sure we remain connected.
3551 SPI_restore_connection();
3557 /* Save error info */
3558 MemoryContextSwitchTo(oldcontext
);
3559 edata
= CopyErrorData();
3562 /* Drop anything we managed to allocate */
3564 hash_search(plperl_active_interp
->query_hash
,
3568 MemoryContextDelete(plan_cxt
);
3572 /* Abort the inner transaction */
3573 RollbackAndReleaseCurrentSubTransaction();
3574 MemoryContextSwitchTo(oldcontext
);
3575 CurrentResourceOwner
= oldowner
;
3578 * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
3579 * have left us in a disconnected state. We need this hack to return
3580 * to connected state.
3582 SPI_restore_connection();
3584 /* Punt the error to Perl */
3585 croak_cstr(edata
->message
);
3587 /* Can't get here, but keep compiler quiet */
3592 /************************************************************
3593 * Return the query's hash key to the caller.
3594 ************************************************************/
3595 return cstr2sv(qdesc
->qname
);
3599 plperl_spi_exec_prepared(char *query
, HV
*attr
, int argc
, SV
**argv
)
3608 plperl_query_desc
*qdesc
;
3609 plperl_query_entry
*hash_entry
;
3612 * Execute the query inside a sub-transaction, so we can cope with errors
3615 MemoryContext oldcontext
= CurrentMemoryContext
;
3616 ResourceOwner oldowner
= CurrentResourceOwner
;
3618 check_spi_usage_allowed();
3620 BeginInternalSubTransaction(NULL
);
3621 /* Want to run inside function's memory context */
3622 MemoryContextSwitchTo(oldcontext
);
3626 /************************************************************
3627 * Fetch the saved plan descriptor, see if it's o.k.
3628 ************************************************************/
3629 hash_entry
= hash_search(plperl_active_interp
->query_hash
, query
,
3631 if (hash_entry
== NULL
)
3632 elog(ERROR
, "spi_exec_prepared: Invalid prepared query passed");
3634 qdesc
= hash_entry
->query_data
;
3636 elog(ERROR
, "spi_exec_prepared: plperl query_hash value vanished");
3638 if (qdesc
->nargs
!= argc
)
3639 elog(ERROR
, "spi_exec_prepared: expected %d argument(s), %d passed",
3640 qdesc
->nargs
, argc
);
3642 /************************************************************
3643 * Parse eventual attributes
3644 ************************************************************/
3648 sv
= hv_fetch_string(attr
, "limit");
3649 if (sv
&& *sv
&& SvIOK(*sv
))
3652 /************************************************************
3654 ************************************************************/
3657 nulls
= (char *) palloc(argc
);
3658 argvalues
= (Datum
*) palloc(argc
* sizeof(Datum
));
3666 for (i
= 0; i
< argc
; i
++)
3670 argvalues
[i
] = plperl_sv_to_datum(argv
[i
],
3674 &qdesc
->arginfuncs
[i
],
3675 qdesc
->argtypioparams
[i
],
3677 nulls
[i
] = isnull
? 'n' : ' ';
3680 /************************************************************
3682 ************************************************************/
3683 spi_rv
= SPI_execute_plan(qdesc
->plan
, argvalues
, nulls
,
3684 current_call_data
->prodesc
->fn_readonly
, limit
);
3685 ret_hv
= plperl_spi_execute_fetch_result(SPI_tuptable
, SPI_processed
,
3693 /* Commit the inner transaction, return to outer xact context */
3694 ReleaseCurrentSubTransaction();
3695 MemoryContextSwitchTo(oldcontext
);
3696 CurrentResourceOwner
= oldowner
;
3699 * AtEOSubXact_SPI() should not have popped any SPI context, but just
3700 * in case it did, make sure we remain connected.
3702 SPI_restore_connection();
3708 /* Save error info */
3709 MemoryContextSwitchTo(oldcontext
);
3710 edata
= CopyErrorData();
3713 /* Abort the inner transaction */
3714 RollbackAndReleaseCurrentSubTransaction();
3715 MemoryContextSwitchTo(oldcontext
);
3716 CurrentResourceOwner
= oldowner
;
3719 * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
3720 * have left us in a disconnected state. We need this hack to return
3721 * to connected state.
3723 SPI_restore_connection();
3725 /* Punt the error to Perl */
3726 croak_cstr(edata
->message
);
3728 /* Can't get here, but keep compiler quiet */
3737 plperl_spi_query_prepared(char *query
, int argc
, SV
**argv
)
3742 plperl_query_desc
*qdesc
;
3743 plperl_query_entry
*hash_entry
;
3745 Portal portal
= NULL
;
3748 * Execute the query inside a sub-transaction, so we can cope with errors
3751 MemoryContext oldcontext
= CurrentMemoryContext
;
3752 ResourceOwner oldowner
= CurrentResourceOwner
;
3754 check_spi_usage_allowed();
3756 BeginInternalSubTransaction(NULL
);
3757 /* Want to run inside function's memory context */
3758 MemoryContextSwitchTo(oldcontext
);
3762 /************************************************************
3763 * Fetch the saved plan descriptor, see if it's o.k.
3764 ************************************************************/
3765 hash_entry
= hash_search(plperl_active_interp
->query_hash
, query
,
3767 if (hash_entry
== NULL
)
3768 elog(ERROR
, "spi_query_prepared: Invalid prepared query passed");
3770 qdesc
= hash_entry
->query_data
;
3772 elog(ERROR
, "spi_query_prepared: plperl query_hash value vanished");
3774 if (qdesc
->nargs
!= argc
)
3775 elog(ERROR
, "spi_query_prepared: expected %d argument(s), %d passed",
3776 qdesc
->nargs
, argc
);
3778 /************************************************************
3780 ************************************************************/
3783 nulls
= (char *) palloc(argc
);
3784 argvalues
= (Datum
*) palloc(argc
* sizeof(Datum
));
3792 for (i
= 0; i
< argc
; i
++)
3796 argvalues
[i
] = plperl_sv_to_datum(argv
[i
],
3800 &qdesc
->arginfuncs
[i
],
3801 qdesc
->argtypioparams
[i
],
3803 nulls
[i
] = isnull
? 'n' : ' ';
3806 /************************************************************
3808 ************************************************************/
3809 portal
= SPI_cursor_open(NULL
, qdesc
->plan
, argvalues
, nulls
,
3810 current_call_data
->prodesc
->fn_readonly
);
3817 elog(ERROR
, "SPI_cursor_open() failed:%s",
3818 SPI_result_code_string(SPI_result
));
3820 cursor
= cstr2sv(portal
->name
);
3822 /* Commit the inner transaction, return to outer xact context */
3823 ReleaseCurrentSubTransaction();
3824 MemoryContextSwitchTo(oldcontext
);
3825 CurrentResourceOwner
= oldowner
;
3828 * AtEOSubXact_SPI() should not have popped any SPI context, but just
3829 * in case it did, make sure we remain connected.
3831 SPI_restore_connection();
3837 /* Save error info */
3838 MemoryContextSwitchTo(oldcontext
);
3839 edata
= CopyErrorData();
3842 /* Abort the inner transaction */
3843 RollbackAndReleaseCurrentSubTransaction();
3844 MemoryContextSwitchTo(oldcontext
);
3845 CurrentResourceOwner
= oldowner
;
3848 * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
3849 * have left us in a disconnected state. We need this hack to return
3850 * to connected state.
3852 SPI_restore_connection();
3854 /* Punt the error to Perl */
3855 croak_cstr(edata
->message
);
3857 /* Can't get here, but keep compiler quiet */
3866 plperl_spi_freeplan(char *query
)
3869 plperl_query_desc
*qdesc
;
3870 plperl_query_entry
*hash_entry
;
3872 check_spi_usage_allowed();
3874 hash_entry
= hash_search(plperl_active_interp
->query_hash
, query
,
3876 if (hash_entry
== NULL
)
3877 elog(ERROR
, "spi_freeplan: Invalid prepared query passed");
3879 qdesc
= hash_entry
->query_data
;
3881 elog(ERROR
, "spi_freeplan: plperl query_hash value vanished");
3885 * free all memory before SPI_freeplan, so if it dies, nothing will be
3888 hash_search(plperl_active_interp
->query_hash
, query
,
3891 MemoryContextDelete(qdesc
->plan_cxt
);
3897 * Store an SV into a hash table under a key that is a string assumed to be
3898 * in the current database's encoding.
3901 hv_store_string(HV
*hv
, const char *key
, SV
*val
)
3907 hkey
= pg_server_to_any(key
, strlen(key
), PG_UTF8
);
3910 * This seems nowhere documented, but under Perl 5.8.0 and up, hv_store()
3911 * recognizes a negative klen parameter as meaning a UTF-8 encoded key. It
3912 * does not appear that hashes track UTF-8-ness of keys at all in Perl
3915 hlen
= -(int) strlen(hkey
);
3916 ret
= hv_store(hv
, hkey
, hlen
, val
, 0);
3925 * Fetch an SV from a hash table under a key that is a string assumed to be
3926 * in the current database's encoding.
3929 hv_fetch_string(HV
*hv
, const char *key
)
3935 hkey
= pg_server_to_any(key
, strlen(key
), PG_UTF8
);
3937 /* See notes in hv_store_string */
3938 hlen
= -(int) strlen(hkey
);
3939 ret
= hv_fetch(hv
, hkey
, hlen
, 0);
3948 * Provide function name for PL/Perl execution errors
3951 plperl_exec_callback(void *arg
)
3953 char *procname
= (char *) arg
;
3956 errcontext("PL/Perl function \"%s\"", procname
);
3960 * Provide function name for PL/Perl compilation errors
3963 plperl_compile_callback(void *arg
)
3965 char *procname
= (char *) arg
;
3968 errcontext("compilation of PL/Perl function \"%s\"", procname
);
3972 * Provide error context for the inline handler
3975 plperl_inline_callback(void *arg
)
3977 errcontext("PL/Perl anonymous code block");
3982 * Perl's own setlocal() copied from POSIX.xs
3983 * (needed because of the calls to new_*())
3987 setlocale_perl(int category
, char *locale
)
3989 char *RETVAL
= setlocale(category
, locale
);
3993 #ifdef USE_LOCALE_CTYPE
3994 if (category
== LC_CTYPE
3996 || category
== LC_ALL
4003 if (category
== LC_ALL
)
4004 newctype
= setlocale(LC_CTYPE
, NULL
);
4008 new_ctype(newctype
);
4010 #endif /* USE_LOCALE_CTYPE */
4011 #ifdef USE_LOCALE_COLLATE
4012 if (category
== LC_COLLATE
4014 || category
== LC_ALL
4021 if (category
== LC_ALL
)
4022 newcoll
= setlocale(LC_COLLATE
, NULL
);
4026 new_collate(newcoll
);
4028 #endif /* USE_LOCALE_COLLATE */
4030 #ifdef USE_LOCALE_NUMERIC
4031 if (category
== LC_NUMERIC
4033 || category
== LC_ALL
4040 if (category
== LC_ALL
)
4041 newnum
= setlocale(LC_NUMERIC
, NULL
);
4045 new_numeric(newnum
);
4047 #endif /* USE_LOCALE_NUMERIC */