database/postgres
1
0
Fork 0
mirror of https://github.com/postgres/postgres.git synced 2025-06-30 21:42:05 +03:00
Code Activity

Use a separate interpreter for each calling SQL userid in plperl and pltcl.

Browse Source 
There are numerous methods by which a Perl or Tcl function can subvert
the behavior of another such function executed later; for example, by
redefining standard functions or operators called by the target function.
If the target function is SECURITY DEFINER, or is called by such a
function, this means that any ordinary SQL user with Perl or Tcl language
usage rights can do essentially anything with the privileges of the target
function's owner.

To close this security hole, create a separate Perl or Tcl interpreter for
each SQL userid under which plperl or pltcl functions are executed within
a session.  However, all plperlu or pltclu functions run within a session
still share a single interpreter, since they all execute at the trust
level of a database superuser anyway.

Note: this change results in a functionality loss when libperl has been
built without the "multiplicity" option: it's no longer possible to call
plperl functions under different userids in one session, since such a
libperl can't support multiple interpreters in one process.  However, such
a libperl already failed to support concurrent use of plperl and plperlu,
so it's likely that few people use such versions with Postgres.

Security: CVE-2010-3433
This commit is contained in:
Tom Lane
2010-09-30 17:18:51 -04:00
parent 1f0eb5de9e
commit 50595b5fce
12 changed files with 921 additions and 397 deletions
Download Patch File Download Diff File Expand all files Collapse all files

518
src/pl/plperl/plperl.c
View File

@ -49,8 +49,45 @@
/* defines PLPERL_SET_OPMASK */
#include "plperl_opmask.h"
EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
EXTERN_C void boot_PostgreSQL__InServer__Util(pTHX_ CV *cv);
EXTERN_C void boot_PostgreSQL__InServer__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
**********************************************************************/
@ -59,6 +96,7 @@ typedef struct plperl_proc_desc
char *proname; /* user name of procedure */
TransactionId fn_xmin;
ItemPointerData fn_tid;
plperl_interp_desc *interp; /* interpreter it's created in */
bool fn_readonly;
bool lanpltrusted;
bool fn_retistuple; /* true, if function returns tuple */
@ -73,14 +111,35 @@ typedef struct plperl_proc_desc
SV *reference;
} plperl_proc_desc;
/* hash table entry for proc desc */
typedef struct plperl_proc_entry
/**********************************************************************
* 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
{
char proc_name[NAMEDATALEN]; /* internal name, eg
* __PLPerl_proc_39987 */
plperl_proc_desc *proc_data;
} plperl_proc_entry;
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_ptr
{
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
@ -101,7 +160,7 @@ typedef struct plperl_call_data
**********************************************************************/
typedef struct plperl_query_desc
{
char qname[20];
char qname[24];
void *plan;
int nargs;
Oid *argtypes;
@ -121,33 +180,21 @@ 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 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 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 char *plperl_on_init = NULL;
static char *plperl_on_plperl_init = NULL;
static char *plperl_on_plperlu_init = NULL;
static bool plperl_ending = false;
static OP *(*pp_require_orig) (pTHX) = NULL;
static char plperl_opmask[MAXO];
static void set_interp_require(void);
/* this is saved and restored by plperl_call_handler */
static plperl_call_data *current_call_data = NULL;
@ -163,6 +210,7 @@ void _PG_init(void);
static PerlInterpreter *plperl_init_interp(void);
static void plperl_destroy_interp(PerlInterpreter **);
static void plperl_fini(int code, Datum arg);
static void set_interp_require(bool trusted);
static Datum plperl_func_handler(PG_FUNCTION_ARGS);
static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
@ -184,7 +232,7 @@ static void plperl_exec_callback(void *arg);
static void plperl_inline_callback(void *arg);
static char *strip_trailing_ws(const char *msg);
static OP *pp_require_safe(pTHX);
static int restore_context(bool);
static void activate_interpreter(plperl_interp_desc *interp_desc);
#ifdef WIN32
static char *setlocale_perl(int category, char *locale);
@ -251,8 +299,14 @@ _PG_init(void)
if (inited)
return;
/*
* Support localized messages.
*/
pg_bindtextdomain(TEXTDOMAIN);
/*
* Initialize plperl's GUCs.
*/
DefineCustomBoolVariable("plperl.use_strict",
gettext_noop("If true, trusted and untrusted Perl code will be compiled in strict mode."),
NULL,
@ -261,6 +315,12 @@ _PG_init(void)
PGC_USERSET, 0,
NULL, NULL);
/*
* plperl.on_init is marked PGC_SIGHUP to support the idea that it might
* be executed in the postmaster (if plperl is loaded into the postmaster
* via shared_preload_libraries). This isn't really right either way,
* though.
*/
DefineCustomStringVariable("plperl.on_init",
gettext_noop("Perl initialization code to execute when a Perl interpreter is initialized."),
NULL,
@ -270,13 +330,18 @@ _PG_init(void)
NULL, NULL);
/*
* plperl.on_plperl_init is currently PGC_SUSET to avoid issues whereby a
* user who doesn't have USAGE privileges on the plperl language could
* possibly use SET plperl.on_plperl_init='...' to influence the behaviour
* of any existing plperl function that they can EXECUTE (which may be
* security definer). Set
* plperl.on_plperl_init is marked PGC_SUSET to avoid issues whereby a
* user who might not even have USAGE privilege on the plperl language
* could nonetheless use SET plperl.on_plperl_init='...' to influence the
* behaviour of any existing plperl function that they can execute (which
* might be SECURITY DEFINER, leading to a privilege escalation). See
* http://archives.postgresql.org/pgsql-hackers/2010-02/msg00281.php and
* the overall thread.
*
* Note that because plperl.use_strict is USERSET, a nefarious user could
* set it to be applied against other people's functions. This is judged
* OK since the worst result would be an error. Your code oughta pass
* use_strict anyway ;-)
*/
DefineCustomStringVariable("plperl.on_plperl_init",
gettext_noop("Perl initialization code to execute once when plperl is first used."),
@ -296,35 +361,45 @@ _PG_init(void)
EmitWarningsOnPlaceholders("plperl");
MemSet(&hash_ctl, 0, sizeof(hash_ctl));
/*
* 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);
hash_ctl.keysize = NAMEDATALEN;
hash_ctl.entrysize = sizeof(plperl_proc_entry);
plperl_proc_hash = hash_create("PLPerl Procedures",
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);
/*
* Create the first Perl interpreter, but only partially initialize it.
*/
plperl_held_interp = plperl_init_interp();
interp_state = INTERP_HELD;
inited = true;
}
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;
@ -343,6 +418,9 @@ set_interp_require(void)
static void
plperl_fini(int code, Datum arg)
{
HASH_SEQ_STATUS hash_seq;
plperl_interp_desc *interp_desc;
elog(DEBUG3, "plperl_fini");
/*
@ -360,91 +438,129 @@ plperl_fini(int code, Datum arg)
return;
}
plperl_destroy_interp(&plperl_trusted_interp);
plperl_destroy_interp(&plperl_untrusted_interp);
/* Zap the "held" interpreter, if we still have it */
plperl_destroy_interp(&plperl_held_interp);
/* Zap any fully-initialized interpreters */
hash_seq_init(&hash_seq, plperl_interp_hash);
while ((interp_desc = hash_seq_search(&hash_seq)) != NULL)
{
if (interp_desc->interp)
{
activate_interpreter(interp_desc);
plperl_destroy_interp(&interp_desc->interp);
}
}
elog(DEBUG3, "plperl_fini: done");
}
/********************************************************************
*
* 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.
/*
* Select and activate an appropriate Perl interpreter.
*/
static void
select_perl_context(bool trusted)
{
EXTERN_C void boot_PostgreSQL__InServer__SPI(pTHX_ CV *cv);
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)
{
/* Initialize newly-created hashtable entry */
interp_desc->interp = NULL;
interp_desc->query_hash = NULL;
}
/* Make sure we have a query_hash for this interpreter */
if (interp_desc->query_hash == NULL)
{
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);
}
/*
* handle simple cases
* Quick exit if already have an interpreter
*/
if (restore_context(trusted))
if (interp_desc->interp)
{
activate_interpreter(interp_desc);
return;
}
/*
* adopt held interp if free, else create new one if possible
*/
if (interp_state == INTERP_HELD)
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_init();
plperl_trusted_interp = plperl_held_interp;
interp_state = INTERP_TRUSTED;
}
else
{
plperl_untrusted_init();
plperl_untrusted_interp = plperl_held_interp;
interp_state = INTERP_UNTRUSTED;
}
/* successfully initialized, so arrange for cleanup */
on_proc_exit(plperl_fini, 0);
}
else
{
#ifdef MULTIPLICITY
PerlInterpreter *plperl = plperl_init_interp();
/*
* 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();
plperl_trusted_interp = plperl;
}
else
{
plperl_untrusted_init();
plperl_untrusted_interp = plperl;
}
interp_state = INTERP_BOTH;
#else
elog(ERROR,
"cannot allocate second Perl interpreter on this platform");
"cannot allocate multiple Perl interpreters on this platform");
#endif
}
plperl_held_interp = NULL;
trusted_context = trusted;
set_interp_require();
set_interp_require(trusted);
/*
* Since the timing of first use of PL/Perl can't be predicted, any
* database interaction during initialization is problematic. Including,
* but not limited to, security definer issues. So we only enable access
* to the database AFTER on_*_init code has run. See
* http://archives.postgresql.org/message-id/20100127143318.GE713@timac.loc
* al
* http://archives.postgresql.org/pgsql-hackers/2010-01/msg02669.php
*/
newXS("PostgreSQL::InServer::SPI::bootstrap",
boot_PostgreSQL__InServer__SPI, __FILE__);
@ -454,35 +570,41 @@ select_perl_context(bool trusted)
ereport(ERROR,
(errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
errcontext("while executing PostgreSQL::InServer::SPI::bootstrap")));
/* 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 int
restore_context(bool trusted)
static void
activate_interpreter(plperl_interp_desc *interp_desc)
{
if (interp_state == INTERP_BOTH ||
(trusted && interp_state == INTERP_TRUSTED) ||
(!trusted && interp_state == INTERP_UNTRUSTED))
if (interp_desc && plperl_active_interp != interp_desc)
{
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();
}
return 1; /* context restored */
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;
}
return 0; /* unable - appropriate interpreter not
* available */
}
/*
* 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)
{
@ -538,17 +660,17 @@ plperl_init_interp(void)
STMT_START { \
if (saved != NULL) { setlocale_perl(name, saved); pfree(saved); } \
} STMT_END
#endif
#endif /* WIN32 */
if (plperl_on_init)
if (plperl_on_init && *plperl_on_init)
{
embedding[nargs++] = "-e";
embedding[nargs++] = plperl_on_init;
}
/****
/*
* The perl API docs state that PERL_SYS_INIT3 should be called before
* allocating interprters. Unfortunately, on some platforms this fails
* allocating interpreters. Unfortunately, on some platforms this fails
* in the Perl_do_taint() routine, which is called when the platform is
* using the system's malloc() instead of perl's own. Other platforms,
* notably Windows, fail if PERL_SYS_INIT3 is not called. So we call it
@ -655,6 +777,11 @@ pp_require_safe(pTHX)
}
/*
* Destroy one Perl interpreter ... actually we just run END blocks.
*
* Caller must have ensured this interpreter is the active one.
*/
static void
plperl_destroy_interp(PerlInterpreter **interp)
{
@ -671,8 +798,6 @@ plperl_destroy_interp(PerlInterpreter **interp)
* be used to perform manual cleanup.
*/
PERL_SET_CONTEXT(*interp);
/* Run END blocks - based on perl's perl_destruct() */
if (PL_exit_flags & PERL_EXIT_DESTRUCT_END)
{
@ -692,7 +817,9 @@ plperl_destroy_interp(PerlInterpreter **interp)
}
}
/*
* Initialize the current Perl interpreter as a trusted interp
*/
static void
plperl_trusted_init(void)
{
@ -770,9 +897,15 @@ plperl_trusted_init(void)
}
/*
* Initialize the current Perl interpreter as an untrusted interp
*/
static void
plperl_untrusted_init(void)
{
/*
* Nothing to do except execute plperl.on_plperlu_init
*/
if (plperl_on_plperlu_init && *plperl_on_plperlu_init)
{
eval_pv(plperl_on_plperlu_init, FALSE);
@ -1077,7 +1210,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();
{
@ -1089,13 +1222,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;
}
@ -1112,7 +1245,7 @@ plperl_inline_handler(PG_FUNCTION_ARGS)
FmgrInfo flinfo;
plperl_proc_desc desc;
plperl_call_data *save_call_data = current_call_data;
bool oldcontext = trusted_context;
plperl_interp_desc *oldinterp = plperl_active_interp;
ErrorContextCallback pl_error_context;
/* Set up a callback for error reporting */
@ -1175,7 +1308,7 @@ plperl_inline_handler(PG_FUNCTION_ARGS)
if (desc.reference)
SvREFCNT_dec(desc.reference);
current_call_data = save_call_data;
restore_context(oldcontext);
activate_interpreter(oldinterp);
PG_RE_THROW();
}
PG_END_TRY();
@ -1184,7 +1317,7 @@ plperl_inline_handler(PG_FUNCTION_ARGS)
SvREFCNT_dec(desc.reference);
current_call_data = save_call_data;
restore_context(oldcontext);
activate_interpreter(oldinterp);
error_context_stack = pl_error_context.previous;
@ -1336,8 +1469,6 @@ static void
plperl_init_shared_libs(pTHX)
{
char *file = __FILE__;
EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
EXTERN_C void boot_PostgreSQL__InServer__Util(pTHX_ CV *cv);
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
newXS("PostgreSQL::InServer::Util::bootstrap",
@ -1535,7 +1666,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
"cannot accept a set")));
}
select_perl_context(prodesc->lanpltrusted);
activate_interpreter(prodesc->interp);
perlret = plperl_call_perl_func(prodesc, fcinfo);
@ -1682,7 +1813,7 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
pl_error_context.arg = prodesc->proname;
error_context_stack = &pl_error_context;
select_perl_context(prodesc->lanpltrusted);
activate_interpreter(prodesc->interp);
svTD = plperl_trigger_build_args(fcinfo);
perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
@ -1762,17 +1893,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) &&
ItemPointerEquals(&prodesc->fn_tid, &procTup->t_self));
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[NAMEDATALEN];
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;
ErrorContextCallback plperl_error_context;
/* We'll need the pg_proc tuple in any case... */
@ -1787,48 +1955,24 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
plperl_error_context.arg = NameStr(procStruct->proname);
error_context_stack = &plperl_error_context;
/************************************************************
* Build our internal proc name from the function's Oid
************************************************************/
if (!is_trigger)
sprintf(internal_proname, "__PLPerl_proc_%u", 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();
proc_ptr = hash_search(plperl_proc_hash, &proc_key,
HASH_FIND, NULL);
if (validate_plperl_function(proc_ptr, procTup))
prodesc = proc_ptr->proc_ptr;
else
sprintf(internal_proname, "__PLPerl_proc_%u_trigger", fn_oid);
/************************************************************
* Lookup the internal proc name in the hashtable
************************************************************/
hash_entry = hash_search(plperl_proc_hash, internal_proname,
HASH_FIND, NULL);
if (hash_entry)
{
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) &&
ItemPointerEquals(&prodesc->fn_tid, &procTup->t_self));
if (!uptodate)
{
hash_search(plperl_proc_hash, internal_proname,
HASH_REMOVE, NULL);
if (prodesc->reference)
{
select_perl_context(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;
}
/************************************************************
@ -1859,6 +2003,10 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
errmsg("out of memory")));
MemSet(prodesc, 0, sizeof(plperl_proc_desc));
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_tid = procTup->t_self;
@ -1996,27 +2144,33 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
proc_source = TextDatumGetCString(prosrcdatum);
/************************************************************
* Create the procedure in the interpreter
* Create the procedure in the appropriate interpreter
************************************************************/
select_perl_context(prodesc->lanpltrusted);
prodesc->interp = plperl_active_interp;
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;
}
/* restore previous error callback */
@ -2636,7 +2790,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;
@ -2675,7 +2829,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");
@ -2683,7 +2837,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",
@ -2818,7 +2972,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");
@ -2826,7 +2980,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",
@ -2934,7 +3088,7 @@ plperl_spi_freeplan(char *query)
check_spi_usage_allowed();
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");
@ -2942,13 +3096,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;