*** pgsql/src/pl/plperl/plperl.c 2010/03/09 22:35:25 1.67.4.11 --- pgsql/src/pl/plperl/plperl.c 2010/05/13 16:44:03 1.67.4.12 *************** *** 33,39 **** * ENHANCEMENTS, OR MODIFICATIONS. * * IDENTIFICATION ! * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.67.4.10 2009/06/05 20:32:58 adunstan Exp $ * **********************************************************************/ --- 33,39 ---- * ENHANCEMENTS, OR MODIFICATIONS. * * IDENTIFICATION ! * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.67.4.11 2010/03/09 22:35:25 tgl Exp $ * **********************************************************************/ *************** *** 49,63 **** #include "commands/trigger.h" #include "executor/spi.h" #include "funcapi.h" #include "utils/lsyscache.h" #include "utils/typcache.h" /* perl stuff */ /* stop perl from hijacking stdio and other stuff */ #ifdef WIN32 #define WIN32IO_IS_STDIO ! #endif #include "EXTERN.h" #include "perl.h" --- 49,65 ---- #include "commands/trigger.h" #include "executor/spi.h" #include "funcapi.h" + #include "mb/pg_wchar.h" #include "utils/lsyscache.h" #include "utils/typcache.h" + #include "utils/hsearch.h" /* perl stuff */ /* stop perl from hijacking stdio and other stuff */ #ifdef WIN32 #define WIN32IO_IS_STDIO ! #endif #include "EXTERN.h" #include "perl.h" *************** *** 75,80 **** --- 77,85 ---- #undef bool #endif + /* defines PLPERL_SET_OPMASK */ + #include "plperl_opmask.h" + /********************************************************************** * The information we cache about loaded procedures *************** typedef struct plperl_proc_desc *** 89,95 **** bool fn_retistuple; /* true, if function returns tuple */ bool fn_retisset; /* true, if function returns set */ Oid result_oid; /* Oid of result type */ ! FmgrInfo result_in_func; /* I/O function and arg for result type */ Oid result_typioparam; int nargs; FmgrInfo arg_out_func[FUNC_MAX_ARGS]; --- 94,100 ---- bool fn_retistuple; /* true, if function returns tuple */ bool fn_retisset; /* true, if function returns set */ Oid result_oid; /* Oid of result type */ ! FmgrInfo result_in_func; /* I/O function and arg for result type */ Oid result_typioparam; int nargs; FmgrInfo arg_out_func[FUNC_MAX_ARGS]; *************** typedef struct plperl_proc_desc *** 98,111 **** SV *reference; } plperl_proc_desc; - /********************************************************************** * Global data **********************************************************************/ static int plperl_firstcall = 1; static bool plperl_safe_init_done = false; ! static PerlInterpreter *plperl_interp = NULL; ! static HV *plperl_proc_hash = NULL; /* this is saved and restored by plperl_call_handler */ static plperl_proc_desc *plperl_current_prodesc = NULL; --- 103,135 ---- SV *reference; } plperl_proc_desc; /********************************************************************** * 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 int plperl_firstcall = 1; 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_proc_hash = NULL; ! static char plperl_opmask[MAXO]; ! static void set_interp_require(void); /* this is saved and restored by plperl_call_handler */ static plperl_proc_desc *plperl_current_prodesc = NULL; *************** static plperl_proc_desc *compile_plperl_ *** 129,135 **** --- 153,173 ---- static SV *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc); static void plperl_init_shared_libs(pTHX); static HV *plperl_spi_execute_fetch_result(SPITupleTable *, int, int); + static void check_interp(bool trusted); + static char *strip_trailing_ws(const char *msg); + + #ifdef WIN32 + static char *setlocale_perl(int category, char *locale); + #endif + + /* hash table entry for proc desc */ + + typedef struct plperl_proc_entry + { + char proc_name[NAMEDATALEN]; + plperl_proc_desc *proc_data; + } plperl_proc_entry; /* * This routine is a crock, and so is everyplace that calls it. The problem *************** perm_fmgr_info(Oid functionId, FmgrInfo *** 158,172 **** --- 196,224 ---- void plperl_init(void) { + HASHCTL hash_ctl; + /************************************************************ * Do initialization only once ************************************************************/ if (!plperl_firstcall) return; + 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", + 32, + &hash_ctl, + HASH_ELEM); + /************************************************************ * Create the Perl interpreter ************************************************************/ + PLPERL_SET_OPMASK(plperl_opmask); + plperl_init_interp(); plperl_firstcall = 0; *************** plperl_init_all(void) *** 192,197 **** --- 244,356 ---- } + #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) + { + if (trusted_context) + { + PL_ppaddr[OP_REQUIRE] = pp_require_safe; + PL_ppaddr[OP_DOFILE] = pp_require_safe; + } + else + { + PL_ppaddr[OP_REQUIRE] = pp_require_orig; + PL_ppaddr[OP_DOFILE] = pp_require_orig; + } + } + + /******************************************************************** + * + * 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. + */ + + + static void + check_interp(bool trusted) + { + if (interp_state == INTERP_HELD) + { + 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(); + } + else if (interp_state == INTERP_BOTH || + (trusted && interp_state == INTERP_TRUSTED) || + (!trusted && interp_state == INTERP_UNTRUSTED)) + { + 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(); + } + } + else if (can_run_two) + { + PERL_SET_CONTEXT(plperl_held_interp); + plperl_init_interp(); + if (trusted) + plperl_trusted_interp = plperl_held_interp; + else + plperl_untrusted_interp = plperl_held_interp; + interp_state = INTERP_BOTH; + plperl_held_interp = NULL; + trusted_context = trusted; + set_interp_require(); + } + else + { + elog(ERROR, + "can not allocate second Perl interpreter on this platform"); + + } + + } + + + static void + restore_context(bool old_context) + { + if (trusted_context != old_context) + { + if (old_context) + PERL_SET_CONTEXT(plperl_trusted_interp); + else + PERL_SET_CONTEXT(plperl_untrusted_interp); + + trusted_context = old_context; + set_interp_require(); + } + } /********************************************************************** * plperl_init_interp() - Create the Perl interpreter *************** plperl_init_all(void) *** 199,228 **** static void plperl_init_interp(void) { ! static char *embedding[3] = { "", "-e", /* ! * no commas between the next lines please. They are supposed to ! * be one string */ "SPI::bootstrap(); use vars qw(%_SHARED);" ! "sub ::mkunsafefunc {return eval(qq[ sub { $_[0] $_[1] } ]); }" }; - int nargs = 3; - - char *dummy_perl_env[1] = { NULL }; - #ifdef WIN32 ! /* * The perl library on startup does horrible things like call ! * setlocale(LC_ALL,""). We have protected against that on most ! * platforms by setting the environment appropriately. However, on ! * Windows, setlocale() does not consult the environment, so we need ! * to save the excisting locale settings before perl has a chance to ! * mangle them and restore them after its dirty deeds are done. * * MSDN ref: * http://msdn.microsoft.com/library/en-us/vclib/html/_crt_locale.asp --- 358,383 ---- static void plperl_init_interp(void) { ! static char *embedding[3] = { "", "-e", /* ! * no commas between the next lines please. They are supposed to be ! * one string */ "SPI::bootstrap(); use vars qw(%_SHARED);" ! "sub ::mkfunc {return eval(qq[ sub { $_[0] $_[1] } ]); }" }; #ifdef WIN32 ! /* * The perl library on startup does horrible things like call ! * setlocale(LC_ALL,""). We have protected against that on most platforms ! * by setting the environment appropriately. However, on Windows, ! * setlocale() does not consult the environment, so we need to save the ! * excisting locale settings before perl has a chance to mangle them and ! * restore them after its dirty deeds are done. * * MSDN ref: * http://msdn.microsoft.com/library/en-us/vclib/html/_crt_locale.asp *************** plperl_init_interp(void) *** 231,256 **** * subsequent calls to the interpreter don't mess with the locale * settings. * ! * We restore them using Perl's POSIX::setlocale() function so that ! * Perl doesn't have a different idea of the locale from Postgres. * */ ! char *loc; ! char *save_collate, *save_ctype, *save_monetary, *save_numeric, *save_time; ! char buf[1024]; ! loc = setlocale(LC_COLLATE,NULL); save_collate = loc ? pstrdup(loc) : NULL; ! loc = setlocale(LC_CTYPE,NULL); save_ctype = loc ? pstrdup(loc) : NULL; ! loc = setlocale(LC_MONETARY,NULL); save_monetary = loc ? pstrdup(loc) : NULL; ! loc = setlocale(LC_NUMERIC,NULL); save_numeric = loc ? pstrdup(loc) : NULL; ! loc = setlocale(LC_TIME,NULL); save_time = loc ? pstrdup(loc) : NULL; #endif /**** --- 386,418 ---- * subsequent calls to the interpreter don't mess with the locale * settings. * ! * We restore them using Perl's perl_setlocale() function so that Perl ! * doesn't have a different idea of the locale from Postgres. * */ ! char *loc; ! char *save_collate, ! *save_ctype, ! *save_monetary, ! *save_numeric, ! *save_time; ! loc = setlocale(LC_COLLATE, NULL); save_collate = loc ? pstrdup(loc) : NULL; ! loc = setlocale(LC_CTYPE, NULL); save_ctype = loc ? pstrdup(loc) : NULL; ! loc = setlocale(LC_MONETARY, NULL); save_monetary = loc ? pstrdup(loc) : NULL; ! loc = setlocale(LC_NUMERIC, NULL); save_numeric = loc ? pstrdup(loc) : NULL; ! loc = setlocale(LC_TIME, NULL); save_time = loc ? pstrdup(loc) : NULL; + #define PLPERL_RESTORE_LOCALE(name, saved) \ + STMT_START { \ + if (saved != NULL) { setlocale_perl(name, saved); pfree(saved); } \ + } STMT_END #endif /**** *************** plperl_init_interp(void) *** 263,381 **** * true when MYMALLOC is set. */ #if defined(PERL_SYS_INIT3) && !defined(MYMALLOC) ! PERL_SYS_INIT3(&nargs, (char ***)&embedding, (char***)&dummy_perl_env); #endif ! plperl_interp = perl_alloc(); ! if (!plperl_interp) elog(ERROR, "could not allocate Perl interpreter"); ! perl_construct(plperl_interp); ! perl_parse(plperl_interp, plperl_init_shared_libs, nargs, embedding, NULL); ! perl_run(plperl_interp); ! /************************************************************ ! * Initialize the procedure hash table ! ************************************************************/ ! plperl_proc_hash = newHV(); ! ! #ifdef WIN32 ! ! eval_pv("use POSIX qw(locale_h);", TRUE); /* croak on failure */ ! ! if (save_collate != NULL) ! { ! snprintf(buf, sizeof(buf),"setlocale(%s,'%s');", ! "LC_COLLATE",save_collate); ! eval_pv(buf,TRUE); ! pfree(save_collate); ! } ! if (save_ctype != NULL) ! { ! snprintf(buf, sizeof(buf),"setlocale(%s,'%s');", ! "LC_CTYPE",save_ctype); ! eval_pv(buf,TRUE); ! pfree(save_ctype); ! } ! if (save_monetary != NULL) { ! snprintf(buf, sizeof(buf),"setlocale(%s,'%s');", ! "LC_MONETARY",save_monetary); ! eval_pv(buf,TRUE); ! pfree(save_monetary); } ! if (save_numeric != NULL) { ! snprintf(buf, sizeof(buf),"setlocale(%s,'%s');", ! "LC_NUMERIC",save_numeric); ! eval_pv(buf,TRUE); ! pfree(save_numeric); } ! if (save_time != NULL) { ! snprintf(buf, sizeof(buf),"setlocale(%s,'%s');", ! "LC_TIME",save_time); ! eval_pv(buf,TRUE); ! pfree(save_time); } #endif } static void plperl_safe_init(void) { ! static char *safe_module = ! "require Safe; $Safe::VERSION"; ! static char *safe_ok = ! "use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');" ! "$PLContainer->permit_only(':default');" ! "$PLContainer->permit(qw[:base_math !:base_io sort time]);" ! "$PLContainer->share(qw[&elog &spi_exec_query &DEBUG &LOG " ! "&INFO &NOTICE &WARNING &ERROR %_SHARED ]);" ! "sub ::mksafefunc { return $PLContainer->reval(qq[sub { $_[0] $_[1]}]); }" ! ; ! ! static char *safe_bad = ! "use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');" ! "$PLContainer->permit_only(':default');" ! "$PLContainer->share(qw[&elog &ERROR ]);" ! "sub ::mksafefunc { return $PLContainer->reval(qq[sub { " ! "elog(ERROR,'trusted Perl functions disabled - " ! "please upgrade Perl Safe module to version 2.09 or later');}]); }" ! ; ! SV *res; ! double safe_version; ! res = eval_pv(safe_module, FALSE); /* TRUE = croak if failure */ ! safe_version = SvNV(res); /* ! * We actually want to reject safe_version < 2.09, but it's risky to ! * assume that floating-point comparisons are exact, so use a slightly ! * smaller comparison value. */ ! eval_pv((safe_version < 2.0899 ? safe_bad : safe_ok), FALSE); plperl_safe_init_done = true; } - /* * Perl likes to put a newline after its error messages; clean up such */ static char * strip_trailing_ws(const char *msg) { ! char *res = pstrdup(msg); ! int len = strlen(res); ! while (len > 0 && isspace((unsigned char) res[len-1])) res[--len] = '\0'; return res; } --- 425,594 ---- * true when MYMALLOC is set. */ #if defined(PERL_SYS_INIT3) && !defined(MYMALLOC) ! if (interp_state == INTERP_NONE) ! { ! int nargs; ! char *dummy_perl_env[1]; ! ! /* initialize this way to silence silly compiler warnings */ ! nargs = 3; ! dummy_perl_env[0] = NULL; ! PERL_SYS_INIT3(&nargs, (char ***) &embedding, (char ***) &dummy_perl_env); ! } #endif ! plperl_held_interp = perl_alloc(); ! if (!plperl_held_interp) elog(ERROR, "could not allocate Perl interpreter"); ! perl_construct(plperl_held_interp); ! /* ! * Record the original function for the 'require' and 'dofile' opcodes. ! * (They share the same implementation.) Ensure it's used for new ! * interpreters. ! */ ! if (!pp_require_orig) { ! pp_require_orig = PL_ppaddr[OP_REQUIRE]; } ! else { ! PL_ppaddr[OP_REQUIRE] = pp_require_orig; ! PL_ppaddr[OP_DOFILE] = pp_require_orig; } ! ! perl_parse(plperl_held_interp, plperl_init_shared_libs, ! 3, embedding, NULL); ! perl_run(plperl_held_interp); ! ! if (interp_state == INTERP_NONE) { ! SV *res; ! ! res = eval_pv(TEST_FOR_MULTI, TRUE); ! can_run_two = SvIV(res); ! interp_state = INTERP_HELD; } + #ifdef PLPERL_RESTORE_LOCALE + PLPERL_RESTORE_LOCALE(LC_COLLATE, save_collate); + PLPERL_RESTORE_LOCALE(LC_CTYPE, save_ctype); + PLPERL_RESTORE_LOCALE(LC_MONETARY, save_monetary); + PLPERL_RESTORE_LOCALE(LC_NUMERIC, save_numeric); + PLPERL_RESTORE_LOCALE(LC_TIME, save_time); #endif + } + /* + * Our safe implementation of the require opcode. + * This is safe because it's completely unable to load any code. + * If the requested file/module has already been loaded it'll return true. + * If not, it'll die. + * So now "use Foo;" will work iff Foo has already been loaded. + */ + static OP * + pp_require_safe(pTHX) + { + dVAR; + dSP; + SV *sv, + **svp; + char *name; + STRLEN len; + + sv = POPs; + name = SvPV(sv, len); + if (!(name && len > 0 && *name)) + RETPUSHNO; + + svp = hv_fetch(GvHVn(PL_incgv), name, len, 0); + if (svp && *svp != &PL_sv_undef) + RETPUSHYES; + + DIE(aTHX_ "Unable to load %s into plperl", name); } + static void plperl_safe_init(void) { ! HV *stash; ! SV *sv; ! char *key; ! I32 klen; ! /* use original require while we set up */ ! PL_ppaddr[OP_REQUIRE] = pp_require_orig; ! PL_ppaddr[OP_DOFILE] = pp_require_orig; ! eval_pv(PLC_TRUSTED, FALSE); ! if (SvTRUE(ERRSV)) ! ereport(ERROR, ! (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))), ! errcontext("While executing PLC_TRUSTED."))); ! if (GetDatabaseEncoding() == PG_UTF8) ! { ! /* ! * Force loading of utf8 module now to prevent errors that can arise ! * from the regex code later trying to load utf8 modules. See ! * http://rt.perl.org/rt3/Ticket/Display.html?id=47576 ! */ ! eval_pv("my $a=chr(0x100); return $a =~ /\\xa9/i", FALSE); ! if (SvTRUE(ERRSV)) ! ereport(ERROR, ! (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))), ! errcontext("While executing utf8fix."))); ! } /* ! * Lock down the interpreter ! */ ! ! /* switch to the safe require/dofile opcode for future code */ ! 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 */ ! PL_op_mask = plperl_opmask; ! ! /* delete the DynaLoader:: namespace so extensions can't be loaded */ ! stash = gv_stashpv("DynaLoader", GV_ADDWARN); ! hv_iterinit(stash); ! while ((sv = hv_iternextsv(stash, &key, &klen))) ! { ! if (!isGV_with_GP(sv) || !GvCV(sv)) ! continue; ! SvREFCNT_dec(GvCV(sv)); /* free the CV */ ! GvCV(sv) = NULL; /* prevent call via GV */ ! } ! ! hv_clear(stash); ! /* invalidate assorted caches */ ! ++PL_sub_generation; ! #ifdef PL_stashcache ! hv_clear(PL_stashcache); ! #endif plperl_safe_init_done = true; } /* * Perl likes to put a newline after its error messages; clean up such */ static char * strip_trailing_ws(const char *msg) { ! char *res = pstrdup(msg); ! int len = strlen(res); ! while (len > 0 && isspace((unsigned char) res[len - 1])) res[--len] = '\0'; return res; } *************** plperl_trigger_build_args(FunctionCallIn *** 438,496 **** tupdesc = tdata->tg_relation->rd_att; relid = DatumGetCString( ! DirectFunctionCall1(oidout, ! ObjectIdGetDatum(tdata->tg_relation->rd_id) ! ) ! ); ! hv_store(hv, "name", 4, newSVpv(tdata->tg_trigger->tgname, 0), 0); ! hv_store(hv, "relid", 5, newSVpv(relid, 0), 0); if (TRIGGER_FIRED_BY_INSERT(tdata->tg_event)) { event = "INSERT"; if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event)) ! hv_store(hv, "new", 3, ! plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc), ! 0); } else if (TRIGGER_FIRED_BY_DELETE(tdata->tg_event)) { event = "DELETE"; if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event)) ! hv_store(hv, "old", 3, ! plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc), ! 0); } else if (TRIGGER_FIRED_BY_UPDATE(tdata->tg_event)) { event = "UPDATE"; if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event)) { ! hv_store(hv, "old", 3, ! plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc), ! 0); ! hv_store(hv, "new", 3, ! plperl_hash_from_tuple(tdata->tg_newtuple, tupdesc), ! 0); } } else event = "UNKNOWN"; ! hv_store(hv, "event", 5, newSVpv(event, 0), 0); ! hv_store(hv, "argc", 4, newSViv(tdata->tg_trigger->tgnargs), 0); if (tdata->tg_trigger->tgnargs > 0) { ! AV *av = newAV(); ! for (i=0; i < tdata->tg_trigger->tgnargs; i++) av_push(av, newSVpv(tdata->tg_trigger->tgargs[i], 0)); ! hv_store(hv, "args", 4, newRV_noinc((SV *)av), 0); } ! hv_store(hv, "relname", 7, ! newSVpv(SPI_getrelname(tdata->tg_relation), 0), 0); if (TRIGGER_FIRED_BEFORE(tdata->tg_event)) when = "BEFORE"; --- 651,710 ---- tupdesc = tdata->tg_relation->rd_att; relid = DatumGetCString( ! DirectFunctionCall1(oidout, ! ObjectIdGetDatum(tdata->tg_relation->rd_id) ! ) ! ); ! (void) hv_store(hv, "name", 4, newSVpv(tdata->tg_trigger->tgname, 0), 0); ! (void) hv_store(hv, "relid", 5, newSVpv(relid, 0), 0); if (TRIGGER_FIRED_BY_INSERT(tdata->tg_event)) { event = "INSERT"; if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event)) ! (void) hv_store(hv, "new", 3, ! plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc), ! 0); } else if (TRIGGER_FIRED_BY_DELETE(tdata->tg_event)) { event = "DELETE"; if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event)) ! (void) hv_store(hv, "old", 3, ! plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc), ! 0); } else if (TRIGGER_FIRED_BY_UPDATE(tdata->tg_event)) { event = "UPDATE"; if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event)) { ! (void) hv_store(hv, "old", 3, ! plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc), ! 0); ! (void) hv_store(hv, "new", 3, ! plperl_hash_from_tuple(tdata->tg_newtuple, tupdesc), ! 0); } } else event = "UNKNOWN"; ! (void) hv_store(hv, "event", 5, newSVpv(event, 0), 0); ! (void) hv_store(hv, "argc", 4, newSViv(tdata->tg_trigger->tgnargs), 0); if (tdata->tg_trigger->tgnargs > 0) { ! AV *av = newAV(); ! ! for (i = 0; i < tdata->tg_trigger->tgnargs; i++) av_push(av, newSVpv(tdata->tg_trigger->tgargs[i], 0)); ! (void) hv_store(hv, "args", 4, newRV_noinc((SV *) av), 0); } ! (void) hv_store(hv, "relname", 7, ! newSVpv(SPI_getrelname(tdata->tg_relation), 0), 0); if (TRIGGER_FIRED_BEFORE(tdata->tg_event)) when = "BEFORE"; *************** plperl_trigger_build_args(FunctionCallIn *** 498,504 **** when = "AFTER"; else when = "UNKNOWN"; ! hv_store(hv, "when", 4, newSVpv(when, 0), 0); if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event)) level = "ROW"; --- 712,718 ---- when = "AFTER"; else when = "UNKNOWN"; ! (void) hv_store(hv, "when", 4, newSVpv(when, 0), 0); if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event)) level = "ROW"; *************** plperl_trigger_build_args(FunctionCallIn *** 506,514 **** level = "STATEMENT"; else level = "UNKNOWN"; ! hv_store(hv, "level", 5, newSVpv(level, 0), 0); ! return newRV_noinc((SV*)hv); } --- 720,728 ---- level = "STATEMENT"; else level = "UNKNOWN"; ! (void) hv_store(hv, "level", 5, newSVpv(level, 0), 0); ! return newRV_noinc((SV *) hv); } *************** get_function_tupdesc(Oid result_type, Re *** 531,537 **** "that cannot accept type record"))); return rsinfo->expectedDesc; } ! else /* ordinary composite type */ return lookup_rowtype_tupdesc(result_type, -1); } --- 745,751 ---- "that cannot accept type record"))); return rsinfo->expectedDesc; } ! else /* ordinary composite type */ return lookup_rowtype_tupdesc(result_type, -1); } *************** plperl_modify_tuple(HV *hvTD, TriggerDat *** 593,600 **** &typinput, &typioparam); fmgr_info(typinput, &finfo); modvalues[slotsused] = FunctionCall3(&finfo, ! CStringGetDatum(SvPV(val, PL_na)), ! ObjectIdGetDatum(typioparam), Int32GetDatum(tupdesc->attrs[attn - 1]->atttypmod)); modnulls[slotsused] = ' '; } --- 807,814 ---- &typinput, &typioparam); fmgr_info(typinput, &finfo); modvalues[slotsused] = FunctionCall3(&finfo, ! CStringGetDatum(SvPV(val, PL_na)), ! ObjectIdGetDatum(typioparam), Int32GetDatum(tupdesc->attrs[attn - 1]->atttypmod)); modnulls[slotsused] = ' '; } *************** plperl_call_handler(PG_FUNCTION_ARGS) *** 637,642 **** --- 851,857 ---- { Datum retval; plperl_proc_desc *save_prodesc; + bool oldcontext = trusted_context; /* * Initialize interpreter if first time through *************** plperl_call_handler(PG_FUNCTION_ARGS) *** 651,658 **** PG_TRY(); { /* ! * Determine if called as function or trigger and ! * call appropriate subhandler */ if (CALLED_AS_TRIGGER(fcinfo)) retval = PointerGetDatum(plperl_trigger_handler(fcinfo)); --- 866,873 ---- PG_TRY(); { /* ! * Determine if called as function or trigger and call appropriate ! * subhandler */ if (CALLED_AS_TRIGGER(fcinfo)) retval = PointerGetDatum(plperl_trigger_handler(fcinfo)); *************** plperl_call_handler(PG_FUNCTION_ARGS) *** 662,673 **** PG_CATCH(); { plperl_current_prodesc = save_prodesc; PG_RE_THROW(); } PG_END_TRY(); plperl_current_prodesc = save_prodesc; ! return retval; } --- 877,889 ---- PG_CATCH(); { plperl_current_prodesc = save_prodesc; + restore_context(oldcontext); PG_RE_THROW(); } PG_END_TRY(); plperl_current_prodesc = save_prodesc; ! restore_context(oldcontext); return retval; } *************** plperl_create_sub(char *s, bool trusted) *** 699,709 **** /* * G_KEEPERR seems to be needed here, else we don't recognize compile ! * errors properly. Perhaps it's because there's another level of ! * eval inside mksafefunc? */ ! count = perl_call_pv((trusted ? "::mksafefunc" : "::mkunsafefunc"), ! G_SCALAR | G_EVAL | G_KEEPERR); SPAGAIN; if (count != 1) --- 915,924 ---- /* * G_KEEPERR seems to be needed here, else we don't recognize compile ! * errors properly. Perhaps it's because there's another level of eval ! * inside mkfunc? */ ! count = perl_call_pv("::mkfunc", G_SCALAR | G_EVAL | G_KEEPERR); SPAGAIN; if (count != 1) *************** plperl_create_sub(char *s, bool trusted) *** 711,717 **** PUTBACK; FREETMPS; LEAVE; ! elog(ERROR, "didn't get a return item from mksafefunc"); } if (SvTRUE(ERRSV)) --- 926,932 ---- PUTBACK; FREETMPS; LEAVE; ! elog(ERROR, "didn't get a return item from mkfunc"); } if (SvTRUE(ERRSV)) *************** plperl_create_sub(char *s, bool trusted) *** 756,762 **** * plperl_init_shared_libs() - * * We cannot use the DynaLoader directly to get at the Opcode ! * module (used by Safe.pm). So, we link Opcode into ourselves * and do the initialization behind perl's back. * **********************************************************************/ --- 971,977 ---- * plperl_init_shared_libs() - * * We cannot use the DynaLoader directly to get at the Opcode ! * module. So, we link Opcode into ourselves * and do the initialization behind perl's back. * **********************************************************************/ *************** plperl_call_perl_func(plperl_proc_desc * *** 790,796 **** PUSHMARK(SP); ! XPUSHs(sv_2mortal(newSVpv("undef", 0))); /* no trigger data */ for (i = 0; i < desc->nargs; i++) { --- 1005,1011 ---- PUSHMARK(SP); ! XPUSHs(sv_2mortal(newSVpv("undef", 0))); /* no trigger data */ for (i = 0; i < desc->nargs; i++) { *************** plperl_call_perl_func(plperl_proc_desc * *** 825,831 **** tmp = DatumGetCString(FunctionCall3(&(desc->arg_out_func[i]), fcinfo->arg[i], ! ObjectIdGetDatum(desc->arg_typioparam[i]), Int32GetDatum(-1))); XPUSHs(sv_2mortal(newSVpv(tmp, 0))); pfree(tmp); --- 1040,1046 ---- tmp = DatumGetCString(FunctionCall3(&(desc->arg_out_func[i]), fcinfo->arg[i], ! ObjectIdGetDatum(desc->arg_typioparam[i]), Int32GetDatum(-1))); XPUSHs(sv_2mortal(newSVpv(tmp, 0))); pfree(tmp); *************** plperl_func_handler(PG_FUNCTION_ARGS) *** 946,951 **** --- 1161,1168 ---- plperl_current_prodesc = prodesc; + check_interp(prodesc->lanpltrusted); + /************************************************************ * Call the Perl function if not returning set ************************************************************/ *************** plperl_func_handler(PG_FUNCTION_ARGS) *** 1009,1015 **** /* Cache a copy of the result's tupdesc and attinmeta */ oldcontext = MemoryContextSwitchTo(funcctx->multi_call_memory_ctx); tupdesc = get_function_tupdesc(prodesc->result_oid, ! (ReturnSetInfo *) fcinfo->resultinfo); tupdesc = CreateTupleDescCopy(tupdesc); funcctx->attinmeta = TupleDescGetAttInMetadata(tupdesc); MemoryContextSwitchTo(oldcontext); --- 1226,1232 ---- /* Cache a copy of the result's tupdesc and attinmeta */ oldcontext = MemoryContextSwitchTo(funcctx->multi_call_memory_ctx); tupdesc = get_function_tupdesc(prodesc->result_oid, ! (ReturnSetInfo *) fcinfo->resultinfo); tupdesc = CreateTupleDescCopy(tupdesc); funcctx->attinmeta = TupleDescGetAttInMetadata(tupdesc); MemoryContextSwitchTo(oldcontext); *************** plperl_func_handler(PG_FUNCTION_ARGS) *** 1081,1087 **** fcinfo->isnull = false; retval = FunctionCall3(&prodesc->result_in_func, PointerGetDatum(val), ! ObjectIdGetDatum(prodesc->result_typioparam), Int32GetDatum(-1)); } else --- 1298,1304 ---- fcinfo->isnull = false; retval = FunctionCall3(&prodesc->result_in_func, PointerGetDatum(val), ! ObjectIdGetDatum(prodesc->result_typioparam), Int32GetDatum(-1)); } else *************** plperl_func_handler(PG_FUNCTION_ARGS) *** 1134,1139 **** --- 1351,1357 ---- } SvREFCNT_dec(perlret); + return retval; } *************** plperl_trigger_handler(PG_FUNCTION_ARGS) *** 1162,1167 **** --- 1380,1387 ---- * Call the Perl function ************************************************************/ + check_interp(prodesc->lanpltrusted); + /* * call perl trigger function and build TD hash */ *************** plperl_trigger_handler(PG_FUNCTION_ARGS) *** 1192,1198 **** else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event)) retval = (Datum) trigdata->tg_trigtuple; else ! retval = (Datum) 0; /* can this happen? */ } else { --- 1412,1418 ---- else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event)) retval = (Datum) trigdata->tg_trigtuple; else ! retval = (Datum) 0; /* can this happen? */ } else { *************** plperl_trigger_handler(PG_FUNCTION_ARGS) *** 1217,1223 **** { ereport(WARNING, (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED), ! errmsg("ignoring modified tuple in DELETE trigger"))); trv = NULL; } } --- 1437,1443 ---- { ereport(WARNING, (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED), ! errmsg("ignoring modified tuple in DELETE trigger"))); trv = NULL; } } *************** compile_plperl_function(Oid fn_oid, bool *** 1250,1256 **** int proname_len; plperl_proc_desc *prodesc = NULL; int i; ! SV **svp; /* We'll need the pg_proc tuple in any case... */ procTup = SearchSysCache(PROCOID, --- 1470,1478 ---- int proname_len; plperl_proc_desc *prodesc = NULL; int i; ! plperl_proc_entry *hash_entry; ! bool found; ! bool oldcontext = trusted_context; /* We'll need the pg_proc tuple in any case... */ procTup = SearchSysCache(PROCOID, *************** compile_plperl_function(Oid fn_oid, bool *** 1273,1284 **** /************************************************************ * Lookup the internal proc name in the hashtable ************************************************************/ ! svp = hv_fetch(plperl_proc_hash, internal_proname, proname_len, FALSE); ! if (svp) { bool uptodate; ! prodesc = (plperl_proc_desc *) SvIV(*svp); /************************************************************ * If it's present, must check whether it's still up to date. --- 1495,1508 ---- /************************************************************ * 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. *************** compile_plperl_function(Oid fn_oid, bool *** 1286,1296 **** * 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) { ! /* need we delete old entry? */ prodesc = NULL; } } --- 1510,1529 ---- * 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; } } *************** compile_plperl_function(Oid fn_oid, bool *** 1354,1360 **** if (!is_trigger) { typeTup = SearchSysCache(TYPEOID, ! ObjectIdGetDatum(procStruct->prorettype), 0, 0, 0); if (!HeapTupleIsValid(typeTup)) { --- 1587,1593 ---- if (!is_trigger) { typeTup = SearchSysCache(TYPEOID, ! ObjectIdGetDatum(procStruct->prorettype), 0, 0, 0); if (!HeapTupleIsValid(typeTup)) { *************** compile_plperl_function(Oid fn_oid, bool *** 1385,1392 **** free(prodesc); ereport(ERROR, (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), ! errmsg("plperl functions cannot return type %s", ! format_type_be(procStruct->prorettype)))); } } --- 1618,1625 ---- free(prodesc); ereport(ERROR, (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), ! errmsg("plperl functions cannot return type %s", ! format_type_be(procStruct->prorettype)))); } } *************** compile_plperl_function(Oid fn_oid, bool *** 1411,1417 **** for (i = 0; i < prodesc->nargs; i++) { typeTup = SearchSysCache(TYPEOID, ! ObjectIdGetDatum(procStruct->proargtypes[i]), 0, 0, 0); if (!HeapTupleIsValid(typeTup)) { --- 1644,1650 ---- for (i = 0; i < prodesc->nargs; i++) { typeTup = SearchSysCache(TYPEOID, ! ObjectIdGetDatum(procStruct->proargtypes[i]), 0, 0, 0); if (!HeapTupleIsValid(typeTup)) { *************** compile_plperl_function(Oid fn_oid, bool *** 1429,1436 **** free(prodesc); ereport(ERROR, (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), ! errmsg("plperl functions cannot take type %s", ! format_type_be(procStruct->proargtypes[i])))); } if (typeStruct->typtype == 'c') --- 1662,1669 ---- free(prodesc); ereport(ERROR, (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), ! errmsg("plperl functions cannot take type %s", ! format_type_be(procStruct->proargtypes[i])))); } if (typeStruct->typtype == 'c') *************** compile_plperl_function(Oid fn_oid, bool *** 1462,1470 **** /************************************************************ * Create the procedure in the interpreter ************************************************************/ prodesc->reference = plperl_create_sub(proc_source, prodesc->lanpltrusted); pfree(proc_source); ! if (!prodesc->reference) /* can this happen? */ { free(prodesc->proname); free(prodesc); --- 1695,1709 ---- /************************************************************ * Create the procedure in the interpreter ************************************************************/ + + check_interp(prodesc->lanpltrusted); + prodesc->reference = plperl_create_sub(proc_source, prodesc->lanpltrusted); + + restore_context(oldcontext); + pfree(proc_source); ! if (!prodesc->reference) /* can this happen? */ { free(prodesc->proname); free(prodesc); *************** compile_plperl_function(Oid fn_oid, bool *** 1475,1482 **** /************************************************************ * Add the proc description block to the hashtable ************************************************************/ ! hv_store(plperl_proc_hash, internal_proname, proname_len, ! newSViv((IV) prodesc), 0); } ReleaseSysCache(procTup); --- 1714,1722 ---- /************************************************************ * Add the proc description block to the hashtable ************************************************************/ ! hash_entry = hash_search(plperl_proc_hash, internal_proname, ! HASH_ENTER, &found); ! hash_entry->proc_data = prodesc; } ReleaseSysCache(procTup); *************** plperl_hash_from_tuple(HeapTuple tuple, *** 1515,1523 **** namelen = strlen(attname); attr = heap_getattr(tuple, i + 1, tupdesc, &isnull); ! if (isnull) { /* Store (attname => undef) and move on. */ ! hv_store(hv, attname, namelen, newSV(0), 0); continue; } --- 1755,1764 ---- namelen = strlen(attname); attr = heap_getattr(tuple, i + 1, tupdesc, &isnull); ! if (isnull) ! { /* Store (attname => undef) and move on. */ ! (void) hv_store(hv, attname, namelen, newSV(0), 0); continue; } *************** plperl_hash_from_tuple(HeapTuple tuple, *** 1528,1537 **** outputstr = DatumGetCString(OidFunctionCall3(typoutput, attr, ! ObjectIdGetDatum(typioparam), ! Int32GetDatum(tupdesc->attrs[i]->atttypmod))); ! hv_store(hv, attname, namelen, newSVpv(outputstr, 0), 0); pfree(outputstr); } --- 1769,1778 ---- outputstr = DatumGetCString(OidFunctionCall3(typoutput, attr, ! ObjectIdGetDatum(typioparam), ! Int32GetDatum(tupdesc->attrs[i]->atttypmod))); ! (void) hv_store(hv, attname, namelen, newSVpv(outputstr, 0), 0); pfree(outputstr); } *************** plperl_spi_exec(char *query, int limit) *** 1549,1556 **** HV *ret_hv; /* ! * Execute the query inside a sub-transaction, so we can cope with ! * errors sanely */ MemoryContext oldcontext = CurrentMemoryContext; ResourceOwner oldowner = CurrentResourceOwner; --- 1790,1797 ---- HV *ret_hv; /* ! * Execute the query inside a sub-transaction, so we can cope with errors ! * sanely */ MemoryContext oldcontext = CurrentMemoryContext; ResourceOwner oldowner = CurrentResourceOwner; *************** plperl_spi_exec(char *query, int limit) *** 1572,1580 **** ReleaseCurrentSubTransaction(); MemoryContextSwitchTo(oldcontext); CurrentResourceOwner = oldowner; /* ! * AtEOSubXact_SPI() should not have popped any SPI context, ! * but just in case it did, make sure we remain connected. */ SPI_restore_connection(); } --- 1813,1822 ---- ReleaseCurrentSubTransaction(); MemoryContextSwitchTo(oldcontext); CurrentResourceOwner = oldowner; + /* ! * AtEOSubXact_SPI() should not have popped any SPI context, but just ! * in case it did, make sure we remain connected. */ SPI_restore_connection(); } *************** plperl_spi_exec(char *query, int limit) *** 1593,1601 **** CurrentResourceOwner = oldowner; /* ! * If AtEOSubXact_SPI() popped any SPI context of the subxact, ! * it will have left us in a disconnected state. We need this ! * hack to return to connected state. */ SPI_restore_connection(); --- 1835,1843 ---- CurrentResourceOwner = oldowner; /* ! * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will ! * have left us in a disconnected state. We need this hack to return ! * to connected state. */ SPI_restore_connection(); *************** plperl_spi_execute_fetch_result(SPITuple *** 1618,1627 **** result = newHV(); ! hv_store(result, "status", strlen("status"), ! newSVpv((char *) SPI_result_code_string(status), 0), 0); ! hv_store(result, "processed", strlen("processed"), ! newSViv(processed), 0); if (status == SPI_OK_SELECT) { --- 1860,1869 ---- result = newHV(); ! (void) hv_store(result, "status", strlen("status"), ! newSVpv((char *) SPI_result_code_string(status), 0), 0); ! (void) hv_store(result, "processed", strlen("processed"), ! newSViv(processed), 0); if (status == SPI_OK_SELECT) { *************** plperl_spi_execute_fetch_result(SPITuple *** 1635,1645 **** row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc); av_push(rows, row); } ! hv_store(result, "rows", strlen("rows"), ! newRV_noinc((SV *) rows), 0); } SPI_freetuptable(tuptable); return result; } --- 1877,1963 ---- row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc); av_push(rows, row); } ! (void) hv_store(result, "rows", strlen("rows"), ! newRV_noinc((SV *) rows), 0); } SPI_freetuptable(tuptable); return result; } + + + /* + * Perl's own setlocal() copied from POSIX.xs + * (needed because of the calls to new_*()) + */ + #ifdef WIN32 + static char * + setlocale_perl(int category, char *locale) + { + char *RETVAL = setlocale(category, locale); + + if (RETVAL) + { + #ifdef USE_LOCALE_CTYPE + if (category == LC_CTYPE + #ifdef LC_ALL + || category == LC_ALL + #endif + ) + { + char *newctype; + + #ifdef LC_ALL + if (category == LC_ALL) + newctype = setlocale(LC_CTYPE, NULL); + else + #endif + newctype = RETVAL; + new_ctype(newctype); + } + #endif /* USE_LOCALE_CTYPE */ + #ifdef USE_LOCALE_COLLATE + if (category == LC_COLLATE + #ifdef LC_ALL + || category == LC_ALL + #endif + ) + { + char *newcoll; + + #ifdef LC_ALL + if (category == LC_ALL) + newcoll = setlocale(LC_COLLATE, NULL); + else + #endif + newcoll = RETVAL; + new_collate(newcoll); + } + #endif /* USE_LOCALE_COLLATE */ + + + #ifdef USE_LOCALE_NUMERIC + if (category == LC_NUMERIC + #ifdef LC_ALL + || category == LC_ALL + #endif + ) + { + char *newnum; + + #ifdef LC_ALL + if (category == LC_ALL) + newnum = setlocale(LC_NUMERIC, NULL); + else + #endif + newnum = RETVAL; + new_numeric(newnum); + } + #endif /* USE_LOCALE_NUMERIC */ + } + + return RETVAL; + } + + #endif