@ -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 */
/**********************************************************************
* 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 ] ; /* internal name, eg
* __PLPerl_proc_39987 */
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
@ -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 ) ) ;
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 ) ;
/*
* 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 ( voi d)
set_interp_require ( bool truste d)
{
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 interpre ters . 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 ) ;
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 ) & &
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 ;
Tom Lane
15 years ago