diff options
Diffstat (limited to 'src/pl/plperl/plperl.c')
| -rw-r--r-- | src/pl/plperl/plperl.c | 555 |
1 files changed, 342 insertions, 213 deletions
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c index 525acac981e..d3b86533ece 100644 --- a/src/pl/plperl/plperl.c +++ b/src/pl/plperl/plperl.c @@ -35,8 +35,44 @@ /* defines PLPERL_SET_OPMASK */ #include "plperl_opmask.h" +EXTERN_C void boot_DynaLoader(pTHX_ CV *cv); +EXTERN_C void boot_SPI(pTHX_ CV *cv); + PG_MODULE_MAGIC; + +/********************************************************************** + * Information associated with a Perl interpreter. We have one interpreter + * that is used for all plperlu (untrusted) functions. For plperl (trusted) + * functions, there is a separate interpreter for each effective SQL userid. + * (This is needed to ensure that an unprivileged user can't inject Perl code + * that'll be executed with the privileges of some other SQL user.) + * + * The plperl_interp_desc structs are kept in a Postgres hash table indexed + * by userid OID, with OID 0 used for the single untrusted interpreter. + * + * We start out by creating a "held" interpreter, which we initialize + * only as far as we can do without deciding if it will be trusted or + * untrusted. Later, when we first need to run a plperl or plperlu + * function, we complete the initialization appropriately and move the + * PerlInterpreter pointer into the plperl_interp_hash hashtable. If after + * that we need more interpreters, we create them as needed if we can, or + * fail if the Perl build doesn't support multiple interpreters. + * + * The reason for all the dancing about with a held interpreter is to make + * it possible for people to preload a lot of Perl code at postmaster startup + * (using plperl.on_init) and then use that code in backends. Of course this + * will only work for the first interpreter created in any backend, but it's + * still useful with that restriction. + **********************************************************************/ +typedef struct plperl_interp_desc +{ + Oid user_id; /* Hash key (must be first!) */ + PerlInterpreter *interp; /* The interpreter */ + HTAB *query_hash; /* plperl_query_entry structs */ +} plperl_interp_desc; + + /********************************************************************** * The information we cache about loaded procedures **********************************************************************/ @@ -45,6 +81,7 @@ typedef struct plperl_proc_desc char *proname; TransactionId fn_xmin; CommandId fn_cmin; + plperl_interp_desc *interp; /* interpreter it's created in */ bool fn_readonly; bool lanpltrusted; bool fn_retistuple; /* true, if function returns tuple */ @@ -59,13 +96,35 @@ typedef struct plperl_proc_desc SV *reference; } plperl_proc_desc; -/* hash table entry for proc desc */ +/********************************************************************** + * For speedy lookup, we maintain a hash table mapping from + * function OID + trigger flag + user OID to plperl_proc_desc pointers. + * The reason the plperl_proc_desc struct isn't directly part of the hash + * entry is to simplify recovery from errors during compile_plperl_function. + * + * Note: if the same function is called by multiple userIDs within a session, + * there will be a separate plperl_proc_desc entry for each userID in the case + * of plperl functions, but only one entry for plperlu functions, because we + * set user_id = 0 for that case. If the user redeclares the same function + * from plperl to plperlu or vice versa, there might be multiple + * plperl_proc_ptr entries in the hashtable, but only one is valid. + **********************************************************************/ +typedef struct plperl_proc_key +{ + Oid proc_id; /* Function OID */ + /* + * is_trigger is really a bool, but declare as Oid to ensure this struct + * contains no padding + */ + Oid is_trigger; /* is it a trigger function? */ + Oid user_id; /* User calling the function, or 0 */ +} plperl_proc_key; -typedef struct plperl_proc_entry +typedef struct plperl_proc_ptr { - char proc_name[NAMEDATALEN]; - plperl_proc_desc *proc_data; -} plperl_proc_entry; + plperl_proc_key proc_key; /* Hash key (must be first!) */ + plperl_proc_desc *proc_ptr; +} plperl_proc_ptr; /* * The information we cache for the duration of a single call to a @@ -86,7 +145,7 @@ typedef struct plperl_call_data **********************************************************************/ typedef struct plperl_query_desc { - char qname[sizeof(long) * 2 + 1]; + char qname[24]; void *plan; int nargs; Oid *argtypes; @@ -106,32 +165,18 @@ typedef struct plperl_query_entry * Global data **********************************************************************/ -typedef enum -{ - INTERP_NONE, - INTERP_HELD, - INTERP_TRUSTED, - INTERP_UNTRUSTED, - INTERP_BOTH -} InterpState; - -static InterpState interp_state = INTERP_NONE; -static bool can_run_two = false; - -static bool plperl_safe_init_done = false; -static PerlInterpreter *plperl_trusted_interp = NULL; -static PerlInterpreter *plperl_untrusted_interp = NULL; -static PerlInterpreter *plperl_held_interp = NULL; -static OP *(*pp_require_orig) (pTHX) = NULL; -static OP *pp_require_safe(pTHX); -static bool trusted_context; +static HTAB *plperl_interp_hash = NULL; static HTAB *plperl_proc_hash = NULL; -static HTAB *plperl_query_hash = NULL; -static char plperl_opmask[MAXO]; -static void set_interp_require(void); +static plperl_interp_desc *plperl_active_interp = NULL; +/* If we have an unassigned "held" interpreter, it's stored here */ +static PerlInterpreter *plperl_held_interp = NULL; +/* GUC variables */ static bool plperl_use_strict = false; +static OP *(*pp_require_orig) (pTHX) = NULL; +static char plperl_opmask[MAXO]; + /* this is saved and restored by plperl_call_handler */ static plperl_call_data *current_call_data = NULL; @@ -142,7 +187,8 @@ Datum plperl_call_handler(PG_FUNCTION_ARGS); Datum plperl_validator(PG_FUNCTION_ARGS); void _PG_init(void); -static void plperl_init_interp(void); +static PerlInterpreter *plperl_init_interp(void); +static void set_interp_require(bool trusted); static Datum plperl_func_handler(PG_FUNCTION_ARGS); static Datum plperl_trigger_handler(PG_FUNCTION_ARGS); @@ -151,13 +197,17 @@ static plperl_proc_desc *compile_plperl_function(Oid fn_oid, bool is_trigger); static SV *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc); static void plperl_init_shared_libs(pTHX); +static void plperl_trusted_init(void); +static void plperl_untrusted_init(void); static HV *plperl_spi_execute_fetch_result(SPITupleTable *, int, int); static SV *newSVstring(const char *str); static SV **hv_store_string(HV *hv, const char *key, SV *val); static SV **hv_fetch_string(HV *hv, const char *key); -static SV *plperl_create_sub(char *s, bool trusted); +static void plperl_create_sub(plperl_proc_desc *desc, char *s, Oid fn_oid); static SV *plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo); static char *strip_trailing_ws(const char *msg); +static OP *pp_require_safe(pTHX); +static void activate_interpreter(plperl_interp_desc *interp_desc); #ifdef WIN32 static char *setlocale_perl(int category, char *locale); @@ -205,25 +255,36 @@ _PG_init(void) EmitWarningsOnPlaceholders("plperl"); - MemSet(&hash_ctl, 0, sizeof(hash_ctl)); - - hash_ctl.keysize = NAMEDATALEN; - hash_ctl.entrysize = sizeof(plperl_proc_entry); - - plperl_proc_hash = hash_create("PLPerl Procedures", + /* + * Create hash tables. + */ + memset(&hash_ctl, 0, sizeof(hash_ctl)); + hash_ctl.keysize = sizeof(Oid); + hash_ctl.entrysize = sizeof(plperl_interp_desc); + hash_ctl.hash = oid_hash; + plperl_interp_hash = hash_create("PL/Perl interpreters", + 8, + &hash_ctl, + HASH_ELEM | HASH_FUNCTION); + + memset(&hash_ctl, 0, sizeof(hash_ctl)); + hash_ctl.keysize = sizeof(plperl_proc_key); + hash_ctl.entrysize = sizeof(plperl_proc_ptr); + hash_ctl.hash = tag_hash; + plperl_proc_hash = hash_create("PL/Perl procedures", 32, &hash_ctl, - HASH_ELEM); - - hash_ctl.entrysize = sizeof(plperl_query_entry); - plperl_query_hash = hash_create("PLPerl Queries", - 32, - &hash_ctl, - HASH_ELEM); + HASH_ELEM | HASH_FUNCTION); + /* + * Save the default opmask. + */ PLPERL_SET_OPMASK(plperl_opmask); - plperl_init_interp(); + /* + * Create the first Perl interpreter, but only partially initialize it. + */ + plperl_held_interp = plperl_init_interp(); inited = true; } @@ -273,17 +334,10 @@ _PG_init(void) #define PLC_TRUSTED \ "require strict; " -#define TEST_FOR_MULTI \ - "use Config; " \ - "$Config{usemultiplicity} eq 'define' or " \ - "($Config{usethreads} eq 'define' " \ - " and $Config{useithreads} eq 'define')" - - static void -set_interp_require(void) +set_interp_require(bool trusted) { - if (trusted_context) + if (trusted) { PL_ppaddr[OP_REQUIRE] = pp_require_safe; PL_ppaddr[OP_DOFILE] = pp_require_safe; @@ -295,94 +349,142 @@ set_interp_require(void) } } -/******************************************************************** - * - * We start out by creating a "held" interpreter that we can use in - * trusted or untrusted mode (but not both) as the need arises. Later, we - * assign that interpreter if it is available to either the trusted or - * untrusted interpreter. If it has already been assigned, and we need to - * create the other interpreter, we do that if we can, or error out. - * We detect if it is safe to run two interpreters during the setup of the - * dummy interpreter. +/* + * Select and activate an appropriate Perl interpreter. */ - - static void -check_interp(bool trusted) +select_perl_context(bool trusted) { - if (interp_state == INTERP_HELD) + Oid user_id; + plperl_interp_desc *interp_desc; + bool found; + PerlInterpreter *interp = NULL; + + /* Find or create the interpreter hashtable entry for this userid */ + if (trusted) + user_id = GetUserId(); + else + user_id = InvalidOid; + + interp_desc = hash_search(plperl_interp_hash, &user_id, + HASH_ENTER, + &found); + if (!found) { - if (trusted) - { - plperl_trusted_interp = plperl_held_interp; - interp_state = INTERP_TRUSTED; - } - else - { - plperl_untrusted_interp = plperl_held_interp; - interp_state = INTERP_UNTRUSTED; - } - plperl_held_interp = NULL; - trusted_context = trusted; - set_interp_require(); + /* Initialize newly-created hashtable entry */ + interp_desc->interp = NULL; + interp_desc->query_hash = NULL; } - else if (interp_state == INTERP_BOTH || - (trusted && interp_state == INTERP_TRUSTED) || - (!trusted && interp_state == INTERP_UNTRUSTED)) + + /* Make sure we have a query_hash for this interpreter */ + if (interp_desc->query_hash == NULL) { - if (trusted_context != trusted) - { - if (trusted) - PERL_SET_CONTEXT(plperl_trusted_interp); - else - PERL_SET_CONTEXT(plperl_untrusted_interp); - trusted_context = trusted; - set_interp_require(); - } + HASHCTL hash_ctl; + + memset(&hash_ctl, 0, sizeof(hash_ctl)); + hash_ctl.keysize = NAMEDATALEN; + hash_ctl.entrysize = sizeof(plperl_query_entry); + interp_desc->query_hash = hash_create("PL/Perl queries", + 32, + &hash_ctl, + HASH_ELEM); } - else if (can_run_two) + + /* + * Quick exit if already have an interpreter + */ + if (interp_desc->interp) { - PERL_SET_CONTEXT(plperl_held_interp); - plperl_init_interp(); + activate_interpreter(interp_desc); + return; + } + + /* + * adopt held interp if free, else create new one if possible + */ + if (plperl_held_interp != NULL) + { + /* first actual use of a perl interpreter */ + interp = plperl_held_interp; + + /* + * Reset the plperl_held_interp pointer first; if we fail during init + * we don't want to try again with the partially-initialized interp. + */ + plperl_held_interp = NULL; + if (trusted) - plperl_trusted_interp = plperl_held_interp; + plperl_trusted_init(); else - plperl_untrusted_interp = plperl_held_interp; - interp_state = INTERP_BOTH; - plperl_held_interp = NULL; - trusted_context = trusted; - set_interp_require(); + plperl_untrusted_init(); } else { - elog(ERROR, - "can not allocate second Perl interpreter on this platform"); +#ifdef MULTIPLICITY + /* + * plperl_init_interp will change Perl's idea of the active + * interpreter. Reset plperl_active_interp temporarily, so that if we + * hit an error partway through here, we'll make sure to switch back + * to a non-broken interpreter before running any other Perl + * functions. + */ + plperl_active_interp = NULL; + + /* Now build the new interpreter */ + interp = plperl_init_interp(); + if (trusted) + plperl_trusted_init(); + else + plperl_untrusted_init(); +#else + elog(ERROR, + "cannot allocate multiple Perl interpreters on this platform"); +#endif } + set_interp_require(trusted); + + /* Fully initialized, so mark the hashtable entry valid */ + interp_desc->interp = interp; + + /* And mark this as the active interpreter */ + plperl_active_interp = interp_desc; } /* - * Restore previous interpreter selection, if two are active + * Make the specified interpreter the active one + * + * A call with NULL does nothing. This is so that "restoring" to a previously + * null state of plperl_active_interp doesn't result in useless thrashing. */ static void -restore_context(bool old_context) +activate_interpreter(plperl_interp_desc *interp_desc) { - if (interp_state == INTERP_BOTH && trusted_context != old_context) + if (interp_desc && plperl_active_interp != interp_desc) { - if (old_context) - PERL_SET_CONTEXT(plperl_trusted_interp); - else - PERL_SET_CONTEXT(plperl_untrusted_interp); - - trusted_context = old_context; - set_interp_require(); + Assert(interp_desc->interp); + PERL_SET_CONTEXT(interp_desc->interp); + /* trusted iff user_id isn't InvalidOid */ + set_interp_require(OidIsValid(interp_desc->user_id)); + plperl_active_interp = interp_desc; } } -static void +/* + * Create a new Perl interpreter. + * + * We initialize the interpreter as far as we can without knowing whether + * it will become a trusted or untrusted interpreter; in particular, the + * plperl.on_init code will get executed. Later, either plperl_trusted_init + * or plperl_untrusted_init must be called to complete the initialization. + */ +static PerlInterpreter * plperl_init_interp(void) { + PerlInterpreter *plperl; + static int perl_sys_init_done; + static char *embedding[3] = { "", "-e", PERLBOOT }; @@ -448,15 +550,19 @@ plperl_init_interp(void) */ #if defined(PERL_SYS_INIT3) && !defined(MYMALLOC) /* only call this the first time through, as per perlembed man page */ - if (interp_state == INTERP_NONE) + if (!perl_sys_init_done) + { PERL_SYS_INIT3(&nargs, (char ***) &embedding, (char ***) &dummy_perl_env); + perl_sys_init_done = 1; + } #endif - plperl_held_interp = perl_alloc(); - if (!plperl_held_interp) + plperl = perl_alloc(); + if (!plperl) elog(ERROR, "could not allocate Perl interpreter"); - perl_construct(plperl_held_interp); + PERL_SET_CONTEXT(plperl); + perl_construct(plperl); /* * Record the original function for the 'require' and 'dofile' opcodes. @@ -473,18 +579,16 @@ plperl_init_interp(void) PL_ppaddr[OP_DOFILE] = pp_require_orig; } - perl_parse(plperl_held_interp, plperl_init_shared_libs, - nargs, embedding, NULL); - perl_run(plperl_held_interp); - - if (interp_state == INTERP_NONE) - { - SV *res; + if (perl_parse(plperl, plperl_init_shared_libs, + nargs, embedding, NULL) != 0) + ereport(ERROR, + (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))), + errcontext("while parsing Perl initialization"))); - res = eval_pv(TEST_FOR_MULTI, TRUE); - can_run_two = SvIV(res); - interp_state = INTERP_HELD; - } + if (perl_run(plperl) != 0) + ereport(ERROR, + (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))), + errcontext("while running Perl initialization"))); #ifdef PLPERL_RESTORE_LOCALE PLPERL_RESTORE_LOCALE(LC_COLLATE, save_collate); @@ -494,6 +598,7 @@ plperl_init_interp(void) PLPERL_RESTORE_LOCALE(LC_TIME, save_time); #endif + return plperl; } /* @@ -525,9 +630,11 @@ pp_require_safe(pTHX) DIE(aTHX_ "Unable to load %s into plperl", name); } - +/* + * Initialize the current Perl interpreter as a trusted interp + */ static void -plperl_safe_init(void) +plperl_trusted_init(void) { HV *stash; SV *sv; @@ -566,9 +673,9 @@ plperl_safe_init(void) PL_ppaddr[OP_REQUIRE] = pp_require_safe; PL_ppaddr[OP_DOFILE] = pp_require_safe; - /* - * prevent (any more) unsafe opcodes being compiled - * PL_op_mask is per interpreter, so this only needs to be set once + /* + * prevent (any more) unsafe opcodes being compiled + * PL_op_mask is per interpreter, so this only needs to be set once */ PL_op_mask = plperl_opmask; @@ -588,8 +695,17 @@ plperl_safe_init(void) #ifdef PL_stashcache hv_clear(PL_stashcache); #endif +} - plperl_safe_init_done = true; +/* + * Initialize the current Perl interpreter as an untrusted interp + */ +static void +plperl_untrusted_init(void) +{ + /* + * Nothing to do here + */ } /* @@ -875,7 +991,7 @@ plperl_call_handler(PG_FUNCTION_ARGS) { Datum retval; plperl_call_data *save_call_data = current_call_data; - bool oldcontext = trusted_context; + plperl_interp_desc *oldinterp = plperl_active_interp; PG_TRY(); { @@ -887,13 +1003,13 @@ plperl_call_handler(PG_FUNCTION_ARGS) PG_CATCH(); { current_call_data = save_call_data; - restore_context(oldcontext); + activate_interpreter(oldinterp); PG_RE_THROW(); } PG_END_TRY(); current_call_data = save_call_data; - restore_context(oldcontext); + activate_interpreter(oldinterp); return retval; } @@ -972,20 +1088,14 @@ plperl_validator(PG_FUNCTION_ARGS) * Uses mkfunc to create an anonymous sub whose text is * supplied in s, and returns a reference to the closure. */ -static SV * -plperl_create_sub(char *s, bool trusted) +static void +plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid) { dSP; SV *subref; int count; char *compile_sub; - if (trusted && !plperl_safe_init_done) - { - plperl_safe_init(); - SPAGAIN; - } - ENTER; SAVETMPS; PUSHMARK(SP); @@ -1050,7 +1160,7 @@ plperl_create_sub(char *s, bool trusted) FREETMPS; LEAVE; - return subref; + prodesc->reference = subref; } @@ -1062,10 +1172,6 @@ plperl_create_sub(char *s, bool trusted) * and do the initialization behind perl's back. * **********************************************************************/ - -EXTERN_C void boot_DynaLoader(pTHX_ CV *cv); -EXTERN_C void boot_SPI(pTHX_ CV *cv); - static void plperl_init_shared_libs(pTHX) { @@ -1259,7 +1365,7 @@ plperl_func_handler(PG_FUNCTION_ARGS) "cannot accept a set"))); } - check_interp(prodesc->lanpltrusted); + activate_interpreter(prodesc->interp); perlret = plperl_call_perl_func(prodesc, fcinfo); @@ -1398,7 +1504,7 @@ plperl_trigger_handler(PG_FUNCTION_ARGS) prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true); current_call_data->prodesc = prodesc; - check_interp(prodesc->lanpltrusted); + activate_interpreter(prodesc->interp); svTD = plperl_trigger_build_args(fcinfo); perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD); @@ -1473,17 +1579,54 @@ plperl_trigger_handler(PG_FUNCTION_ARGS) } +static bool +validate_plperl_function(plperl_proc_ptr *proc_ptr, HeapTuple procTup) +{ + if (proc_ptr && proc_ptr->proc_ptr) + { + plperl_proc_desc *prodesc = proc_ptr->proc_ptr; + bool uptodate; + + /************************************************************ + * If it's present, must check whether it's still up to date. + * This is needed because CREATE OR REPLACE FUNCTION can modify the + * function's pg_proc entry without changing its OID. + ************************************************************/ + uptodate = (prodesc->fn_xmin == HeapTupleHeaderGetXmin(procTup->t_data) && + prodesc->fn_cmin == HeapTupleHeaderGetCmin(procTup->t_data)); + + if (uptodate) + return true; + + /* Otherwise, unlink the obsoleted entry from the hashtable ... */ + proc_ptr->proc_ptr = NULL; + /* ... and throw it away */ + if (prodesc->reference) + { + plperl_interp_desc *oldinterp = plperl_active_interp; + + activate_interpreter(prodesc->interp); + SvREFCNT_dec(prodesc->reference); + activate_interpreter(oldinterp); + } + free(prodesc->proname); + free(prodesc); + } + + return false; +} + + static plperl_proc_desc * compile_plperl_function(Oid fn_oid, bool is_trigger) { HeapTuple procTup; Form_pg_proc procStruct; - char internal_proname[64]; + plperl_proc_key proc_key; + plperl_proc_ptr *proc_ptr; plperl_proc_desc *prodesc = NULL; int i; - plperl_proc_entry *hash_entry; - bool found; - bool oldcontext = trusted_context; + plperl_interp_desc *oldinterp = plperl_active_interp; /* We'll need the pg_proc tuple in any case... */ procTup = SearchSysCache(PROCOID, @@ -1493,48 +1636,24 @@ compile_plperl_function(Oid fn_oid, bool is_trigger) elog(ERROR, "cache lookup failed for function %u", fn_oid); procStruct = (Form_pg_proc) GETSTRUCT(procTup); - /************************************************************ - * Build our internal proc name from the function's Oid - ************************************************************/ - if (!is_trigger) - sprintf(internal_proname, "__PLPerl_proc_%u", fn_oid); - else - sprintf(internal_proname, "__PLPerl_proc_%u_trigger", fn_oid); + /* Try to find function in plperl_proc_hash */ + proc_key.proc_id = fn_oid; + proc_key.is_trigger = is_trigger; + proc_key.user_id = GetUserId(); - /************************************************************ - * Lookup the internal proc name in the hashtable - ************************************************************/ - hash_entry = hash_search(plperl_proc_hash, internal_proname, - HASH_FIND, NULL); + proc_ptr = hash_search(plperl_proc_hash, &proc_key, + HASH_FIND, NULL); - if (hash_entry) + if (validate_plperl_function(proc_ptr, procTup)) + prodesc = proc_ptr->proc_ptr; + else { - bool uptodate; - - prodesc = hash_entry->proc_data; - - /************************************************************ - * If it's present, must check whether it's still up to date. - * This is needed because CREATE OR REPLACE FUNCTION can modify the - * function's pg_proc entry without changing its OID. - ************************************************************/ - uptodate = (prodesc->fn_xmin == HeapTupleHeaderGetXmin(procTup->t_data) && - prodesc->fn_cmin == HeapTupleHeaderGetCmin(procTup->t_data)); - - if (!uptodate) - { - hash_search(plperl_proc_hash, internal_proname, - HASH_REMOVE, NULL); - if (prodesc->reference) - { - check_interp(prodesc->lanpltrusted); - SvREFCNT_dec(prodesc->reference); - restore_context(oldcontext); - } - free(prodesc->proname); - free(prodesc); - prodesc = NULL; - } + /* If not found or obsolete, maybe it's plperlu */ + proc_key.user_id = InvalidOid; + proc_ptr = hash_search(plperl_proc_hash, &proc_key, + HASH_FIND, NULL); + if (validate_plperl_function(proc_ptr, procTup)) + prodesc = proc_ptr->proc_ptr; } /************************************************************ @@ -1564,7 +1683,11 @@ compile_plperl_function(Oid fn_oid, bool is_trigger) (errcode(ERRCODE_OUT_OF_MEMORY), errmsg("out of memory"))); MemSet(prodesc, 0, sizeof(plperl_proc_desc)); - prodesc->proname = strdup(internal_proname); + prodesc->proname = strdup(NameStr(procStruct->proname)); + if (prodesc->proname == NULL) + ereport(ERROR, + (errcode(ERRCODE_OUT_OF_MEMORY), + errmsg("out of memory"))); prodesc->fn_xmin = HeapTupleHeaderGetXmin(procTup->t_data); prodesc->fn_cmin = HeapTupleHeaderGetCmin(procTup->t_data); @@ -1705,27 +1828,33 @@ compile_plperl_function(Oid fn_oid, bool is_trigger) prosrcdatum)); /************************************************************ - * Create the procedure in the interpreter + * Create the procedure in the appropriate interpreter ************************************************************/ - check_interp(prodesc->lanpltrusted); + select_perl_context(prodesc->lanpltrusted); + + prodesc->interp = plperl_active_interp; - prodesc->reference = plperl_create_sub(proc_source, prodesc->lanpltrusted); + plperl_create_sub(prodesc, proc_source, fn_oid); - restore_context(oldcontext); + activate_interpreter(oldinterp); pfree(proc_source); if (!prodesc->reference) /* can this happen? */ { free(prodesc->proname); free(prodesc); - elog(ERROR, "could not create internal procedure \"%s\"", - internal_proname); + elog(ERROR, "could not create PL/Perl internal procedure"); } - hash_entry = hash_search(plperl_proc_hash, internal_proname, - HASH_ENTER, &found); - hash_entry->proc_data = prodesc; + /************************************************************ + * OK, link the procedure into the correct hashtable entry + ************************************************************/ + proc_key.user_id = prodesc->lanpltrusted ? GetUserId() : InvalidOid; + + proc_ptr = hash_search(plperl_proc_hash, &proc_key, + HASH_ENTER, NULL); + proc_ptr->proc_ptr = prodesc; } ReleaseSysCache(procTup); @@ -2305,7 +2434,7 @@ plperl_spi_prepare(char *query, int argc, SV **argv) * the key to the caller. ************************************************************/ - hash_entry = hash_search(plperl_query_hash, qdesc->qname, + hash_entry = hash_search(plperl_active_interp->query_hash, qdesc->qname, HASH_ENTER, &found); hash_entry->query_data = qdesc; @@ -2342,7 +2471,7 @@ plperl_spi_exec_prepared(char *query, HV *attr, int argc, SV **argv) * Fetch the saved plan descriptor, see if it's o.k. ************************************************************/ - hash_entry = hash_search(plperl_query_hash, query, + hash_entry = hash_search(plperl_active_interp->query_hash, query, HASH_FIND, NULL); if (hash_entry == NULL) elog(ERROR, "spi_exec_prepared: Invalid prepared query passed"); @@ -2350,7 +2479,7 @@ plperl_spi_exec_prepared(char *query, HV *attr, int argc, SV **argv) qdesc = hash_entry->query_data; if (qdesc == NULL) - elog(ERROR, "spi_exec_prepared: panic - plperl_query_hash value vanished"); + elog(ERROR, "spi_exec_prepared: panic - plperl query_hash value vanished"); if (qdesc->nargs != argc) elog(ERROR, "spi_exec_prepared: expected %d argument(s), %d passed", @@ -2483,7 +2612,7 @@ plperl_spi_query_prepared(char *query, int argc, SV **argv) /************************************************************ * Fetch the saved plan descriptor, see if it's o.k. ************************************************************/ - hash_entry = hash_search(plperl_query_hash, query, + hash_entry = hash_search(plperl_active_interp->query_hash, query, HASH_FIND, NULL); if (hash_entry == NULL) elog(ERROR, "spi_exec_prepared: Invalid prepared query passed"); @@ -2491,7 +2620,7 @@ plperl_spi_query_prepared(char *query, int argc, SV **argv) qdesc = hash_entry->query_data; if (qdesc == NULL) - elog(ERROR, "spi_query_prepared: panic - plperl_query_hash value vanished"); + elog(ERROR, "spi_query_prepared: panic - plperl query_hash value vanished"); if (qdesc->nargs != argc) elog(ERROR, "spi_query_prepared: expected %d argument(s), %d passed", @@ -2597,7 +2726,7 @@ plperl_spi_freeplan(char *query) plperl_query_desc *qdesc; plperl_query_entry *hash_entry; - hash_entry = hash_search(plperl_query_hash, query, + hash_entry = hash_search(plperl_active_interp->query_hash, query, HASH_FIND, NULL); if (hash_entry == NULL) elog(ERROR, "spi_exec_prepared: Invalid prepared query passed"); @@ -2605,13 +2734,13 @@ plperl_spi_freeplan(char *query) qdesc = hash_entry->query_data; if (qdesc == NULL) - elog(ERROR, "spi_exec_freeplan: panic - plperl_query_hash value vanished"); + elog(ERROR, "spi_exec_freeplan: panic - plperl query_hash value vanished"); /* * free all memory before SPI_freeplan, so if it dies, nothing will be * left over */ - hash_search(plperl_query_hash, query, + hash_search(plperl_active_interp->query_hash, query, HASH_REMOVE, NULL); plan = qdesc->plan; |