diff --git a/contrib/hstore_plperl/hstore_plperl.c b/contrib/hstore_plperl/hstore_plperl.c index 480212f..3489ece 100644 --- a/contrib/hstore_plperl/hstore_plperl.c +++ b/contrib/hstore_plperl/hstore_plperl.c @@ -73,6 +73,7 @@ hstore_to_plperl(PG_FUNCTION_ARGS) char *base = STRPTR(in); HEntry *entries = ARRPTR(in); HV *hv; + dTHX; hv = newHV(); @@ -106,6 +107,7 @@ plperl_to_hstore(PG_FUNCTION_ARGS) int32 pcount; HStore *out; Pairs *pairs; + dTHX; hv = (HV *) SvRV((SV *) PG_GETARG_POINTER(0)); diff --git a/src/pl/plperl/SPI.xs b/src/pl/plperl/SPI.xs index 0447c50..7651b62 100644 --- a/src/pl/plperl/SPI.xs +++ b/src/pl/plperl/SPI.xs @@ -15,38 +15,11 @@ #undef _ /* perl stuff */ +#define PG_NEED_PERL_XSUB_H #include "plperl.h" #include "plperl_helpers.h" -/* - * Interface routine to catch ereports and punt them to Perl - */ -static void -do_plperl_return_next(SV *sv) -{ - MemoryContext oldcontext = CurrentMemoryContext; - - PG_TRY(); - { - plperl_return_next(sv); - } - PG_CATCH(); - { - ErrorData *edata; - - /* Must reset elog.c's state */ - MemoryContextSwitchTo(oldcontext); - edata = CopyErrorData(); - FlushErrorState(); - - /* Punt the error to Perl */ - croak_cstr(edata->message); - } - PG_END_TRY(); -} - - MODULE = PostgreSQL::InServer::SPI PREFIX = spi_ PROTOTYPES: ENABLE @@ -76,7 +49,7 @@ void spi_return_next(rv) SV *rv; CODE: - do_plperl_return_next(rv); + plperl_return_next(rv); SV * spi_spi_query(sv) diff --git a/src/pl/plperl/Util.xs b/src/pl/plperl/Util.xs index dbba0d7..862fec4 100644 --- a/src/pl/plperl/Util.xs +++ b/src/pl/plperl/Util.xs @@ -20,48 +20,10 @@ #undef _ /* perl stuff */ +#define PG_NEED_PERL_XSUB_H #include "plperl.h" #include "plperl_helpers.h" -/* - * Implementation of plperl's elog() function - * - * If the error level is less than ERROR, we'll just emit the message and - * return. When it is ERROR, elog() will longjmp, which we catch and - * turn into a Perl croak(). Note we are assuming that elog() can't have - * any internal failures that are so bad as to require a transaction abort. - * - * This is out-of-line to suppress "might be clobbered by longjmp" warnings. - */ -static void -do_util_elog(int level, SV *msg) -{ - MemoryContext oldcontext = CurrentMemoryContext; - char * volatile cmsg = NULL; - - PG_TRY(); - { - cmsg = sv2cstr(msg); - elog(level, "%s", cmsg); - pfree(cmsg); - } - PG_CATCH(); - { - ErrorData *edata; - - /* Must reset elog.c's state */ - MemoryContextSwitchTo(oldcontext); - edata = CopyErrorData(); - FlushErrorState(); - - if (cmsg) - pfree(cmsg); - - /* Punt the error to Perl */ - croak_cstr(edata->message); - } - PG_END_TRY(); -} static text * sv2text(SV *sv) @@ -105,7 +67,7 @@ util_elog(level, msg) level = ERROR; if (level < DEBUG5) level = DEBUG5; - do_util_elog(level, msg); + plperl_util_elog(level, msg); SV * util_quote_literal(sv) diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c index 5a45e3e..cbac1af 100644 --- a/src/pl/plperl/plperl.c +++ b/src/pl/plperl/plperl.c @@ -285,6 +285,7 @@ static void plperl_init_shared_libs(pTHX); static void plperl_trusted_init(void); static void plperl_untrusted_init(void); static HV *plperl_spi_execute_fetch_result(SPITupleTable *, uint64, int); +static void plperl_return_next_internal(SV *sv); static char *hek2cstr(HE *he); static SV **hv_store_string(HV *hv, const char *key, SV *val); static SV **hv_fetch_string(HV *hv, const char *key); @@ -303,11 +304,23 @@ static char *setlocale_perl(int category, char *locale); #endif /* + * Decrement the refcount of the given SV within the active Perl interpreter + */ +static inline void +SvREFCNT_dec_current(SV *sv) +{ + dTHX; + + SvREFCNT_dec(sv); +} + +/* * convert a HE (hash entry) key to a cstr in the current database encoding */ static char * hek2cstr(HE *he) { + dTHX; char *ret; SV *sv; @@ -641,15 +654,19 @@ select_perl_context(bool trusted) * to the database AFTER on_*_init code has run. See * http://archives.postgresql.org/pgsql-hackers/2010-01/msg02669.php */ - newXS("PostgreSQL::InServer::SPI::bootstrap", - boot_PostgreSQL__InServer__SPI, __FILE__); + { + dTHX; - eval_pv("PostgreSQL::InServer::SPI::bootstrap()", FALSE); - if (SvTRUE(ERRSV)) - ereport(ERROR, - (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), - errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))), - errcontext("while executing PostgreSQL::InServer::SPI::bootstrap"))); + newXS("PostgreSQL::InServer::SPI::bootstrap", + boot_PostgreSQL__InServer__SPI, __FILE__); + + eval_pv("PostgreSQL::InServer::SPI::bootstrap()", FALSE); + if (SvTRUE(ERRSV)) + ereport(ERROR, + (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), + errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))), + errcontext("while executing PostgreSQL::InServer::SPI::bootstrap"))); + } /* Fully initialized, so mark the hashtable entry valid */ interp_desc->interp = interp; @@ -792,53 +809,62 @@ plperl_init_interp(void) PERL_SET_CONTEXT(plperl); perl_construct(plperl); - /* run END blocks in perl_destruct instead of perl_run */ - PL_exit_flags |= PERL_EXIT_DESTRUCT_END; - /* - * Record the original function for the 'require' and 'dofile' opcodes. - * (They share the same implementation.) Ensure it's used for new - * interpreters. + * Run END blocks in perl_destruct instead of perl_run. Note that dTHX + * loads up a pointer to the current interpreter, so we have to postpone + * it to here rather than put it at the function head. */ - 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; - } + dTHX; + + PL_exit_flags |= PERL_EXIT_DESTRUCT_END; + + /* + * 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; + } #ifdef PLPERL_ENABLE_OPMASK_EARLY - /* - * For regression testing to prove that the PLC_PERLBOOT and PLC_TRUSTED - * code doesn't even compile any unsafe ops. In future there may be a - * valid need for them to do so, in which case this could be softened - * (perhaps moved to plperl_trusted_init()) or removed. - */ - PL_op_mask = plperl_opmask; + /* + * For regression testing to prove that the PLC_PERLBOOT and + * PLC_TRUSTED code doesn't even compile any unsafe ops. In future + * there may be a valid need for them to do so, in which case this + * could be softened (perhaps moved to plperl_trusted_init()) or + * removed. + */ + PL_op_mask = plperl_opmask; #endif - if (perl_parse(plperl, plperl_init_shared_libs, - nargs, embedding, NULL) != 0) - ereport(ERROR, - (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), - errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))), - errcontext("while parsing Perl initialization"))); + if (perl_parse(plperl, plperl_init_shared_libs, + nargs, embedding, NULL) != 0) + ereport(ERROR, + (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), + errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))), + errcontext("while parsing Perl initialization"))); - if (perl_run(plperl) != 0) - ereport(ERROR, - (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), - errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))), - errcontext("while running Perl initialization"))); + if (perl_run(plperl) != 0) + ereport(ERROR, + (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), + errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))), + errcontext("while running Perl initialization"))); #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); + 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 + } return plperl; } @@ -904,6 +930,7 @@ plperl_destroy_interp(PerlInterpreter **interp) * public API so isn't portably available.) Meanwhile END blocks can * be used to perform manual cleanup. */ + dTHX; /* Run END blocks - based on perl's perl_destruct() */ if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) @@ -930,6 +957,7 @@ plperl_destroy_interp(PerlInterpreter **interp) static void plperl_trusted_init(void) { + dTHX; HV *stash; SV *sv; char *key; @@ -1010,6 +1038,8 @@ plperl_trusted_init(void) static void plperl_untrusted_init(void) { + dTHX; + /* * Nothing to do except execute plperl.on_plperlu_init */ @@ -1045,6 +1075,7 @@ strip_trailing_ws(const char *msg) static HeapTuple plperl_build_tuple_result(HV *perlhash, TupleDesc td) { + dTHX; Datum *values; bool *nulls; HE *he; @@ -1106,6 +1137,8 @@ plperl_hash_to_datum(SV *src, TupleDesc td) static SV * get_perl_array_ref(SV *sv) { + dTHX; + if (SvOK(sv) && SvROK(sv)) { if (SvTYPE(SvRV(sv)) == SVt_PVAV) @@ -1134,6 +1167,7 @@ array_to_datum_internal(AV *av, ArrayBuildState *astate, Oid arraytypid, Oid elemtypid, int32 typmod, FmgrInfo *finfo, Oid typioparam) { + dTHX; int i; int len = av_len(av) + 1; @@ -1205,6 +1239,7 @@ array_to_datum_internal(AV *av, ArrayBuildState *astate, static Datum plperl_array_to_datum(SV *src, Oid typid, int32 typmod) { + dTHX; ArrayBuildState *astate; Oid elemtypid; FmgrInfo finfo; @@ -1407,6 +1442,7 @@ plperl_sv_to_literal(SV *sv, char *fqtypename) static SV * plperl_ref_from_pg_array(Datum arg, Oid typid) { + dTHX; ArrayType *ar = DatumGetArrayTypeP(arg); Oid elementtype = ARR_ELEMTYPE(ar); int16 typlen; @@ -1485,6 +1521,7 @@ plperl_ref_from_pg_array(Datum arg, Oid typid) static SV * split_array(plperl_array_info *info, int first, int last, int nest) { + dTHX; int i; AV *result; @@ -1518,6 +1555,7 @@ split_array(plperl_array_info *info, int first, int last, int nest) static SV * make_array_ref(plperl_array_info *info, int first, int last) { + dTHX; int i; AV *result = newAV(); @@ -1555,6 +1593,7 @@ make_array_ref(plperl_array_info *info, int first, int last) static SV * plperl_trigger_build_args(FunctionCallInfo fcinfo) { + dTHX; TriggerData *tdata; TupleDesc tupdesc; int i; @@ -1661,6 +1700,7 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo) static SV * plperl_event_trigger_build_args(FunctionCallInfo fcinfo) { + dTHX; EventTriggerData *tdata; HV *hv; @@ -1678,6 +1718,7 @@ plperl_event_trigger_build_args(FunctionCallInfo fcinfo) static HeapTuple plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup) { + dTHX; SV **svp; HV *hvNew; HE *he; @@ -1874,7 +1915,7 @@ plperl_inline_handler(PG_FUNCTION_ARGS) perlret = plperl_call_perl_func(&desc, &fake_fcinfo); - SvREFCNT_dec(perlret); + SvREFCNT_dec_current(perlret); if (SPI_finish() != SPI_OK_FINISH) elog(ERROR, "SPI_finish() failed"); @@ -1882,7 +1923,7 @@ plperl_inline_handler(PG_FUNCTION_ARGS) PG_CATCH(); { if (desc.reference) - SvREFCNT_dec(desc.reference); + SvREFCNT_dec_current(desc.reference); current_call_data = save_call_data; activate_interpreter(oldinterp); PG_RE_THROW(); @@ -1890,7 +1931,7 @@ plperl_inline_handler(PG_FUNCTION_ARGS) PG_END_TRY(); if (desc.reference) - SvREFCNT_dec(desc.reference); + SvREFCNT_dec_current(desc.reference); current_call_data = save_call_data; activate_interpreter(oldinterp); @@ -2018,6 +2059,7 @@ plperlu_validator(PG_FUNCTION_ARGS) static void plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid) { + dTHX; dSP; char subname[NAMEDATALEN + 40]; HV *pragma_hv = newHV(); @@ -2104,6 +2146,7 @@ plperl_init_shared_libs(pTHX) static SV * plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo) { + dTHX; dSP; SV *retval; int i; @@ -2197,6 +2240,7 @@ static SV * plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo, SV *td) { + dTHX; dSP; SV *retval, *TDsv; @@ -2265,6 +2309,7 @@ plperl_call_perl_event_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo, SV *td) { + dTHX; dSP; SV *retval, *TDsv; @@ -2384,13 +2429,14 @@ plperl_func_handler(PG_FUNCTION_ARGS) sav = get_perl_array_ref(perlret); if (sav) { + dTHX; int i = 0; SV **svp = 0; AV *rav = (AV *) SvRV(sav); while ((svp = av_fetch(rav, i, FALSE)) != NULL) { - plperl_return_next(*svp); + plperl_return_next_internal(*svp); i++; } } @@ -2427,7 +2473,7 @@ plperl_func_handler(PG_FUNCTION_ARGS) /* Restore the previous error callback */ error_context_stack = pl_error_context.previous; - SvREFCNT_dec(perlret); + SvREFCNT_dec_current(perlret); return retval; } @@ -2538,9 +2584,9 @@ plperl_trigger_handler(PG_FUNCTION_ARGS) /* Restore the previous error callback */ error_context_stack = pl_error_context.previous; - SvREFCNT_dec(svTD); + SvREFCNT_dec_current(svTD); if (perlret) - SvREFCNT_dec(perlret); + SvREFCNT_dec_current(perlret); return retval; } @@ -2579,9 +2625,7 @@ plperl_event_trigger_handler(PG_FUNCTION_ARGS) /* Restore the previous error callback */ error_context_stack = pl_error_context.previous; - SvREFCNT_dec(svTD); - - return; + SvREFCNT_dec_current(svTD); } @@ -2624,7 +2668,7 @@ free_plperl_function(plperl_proc_desc *prodesc) plperl_interp_desc *oldinterp = plperl_active_interp; activate_interpreter(prodesc->interp); - SvREFCNT_dec(prodesc->reference); + SvREFCNT_dec_current(prodesc->reference); activate_interpreter(oldinterp); } /* Release all PG-owned data for this proc */ @@ -2949,6 +2993,7 @@ plperl_hash_from_datum(Datum attr) static SV * plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc) { + dTHX; HV *hv; int i; @@ -3094,6 +3139,7 @@ static HV * plperl_spi_execute_fetch_result(SPITupleTable *tuptable, uint64 processed, int status) { + dTHX; HV *result; check_spi_usage_allowed(); @@ -3137,16 +3183,41 @@ plperl_spi_execute_fetch_result(SPITupleTable *tuptable, uint64 processed, /* - * Note: plperl_return_next is called both in Postgres and Perl contexts. - * We report any errors in Postgres fashion (via ereport). If called in - * Perl context, it is SPI.xs's responsibility to catch the error and - * convert to a Perl error. We assume (perhaps without adequate justification) - * that we need not abort the current transaction if the Perl code traps the - * error. + * plperl_return_next catches any error and converts it to a Perl error. + * We assume (perhaps without adequate justification) that we need not abort + * the current transaction if the Perl code traps the error. */ void plperl_return_next(SV *sv) { + MemoryContext oldcontext = CurrentMemoryContext; + + PG_TRY(); + { + plperl_return_next_internal(sv); + } + PG_CATCH(); + { + ErrorData *edata; + + /* Must reset elog.c's state */ + MemoryContextSwitchTo(oldcontext); + edata = CopyErrorData(); + FlushErrorState(); + + /* Punt the error to Perl */ + croak_cstr(edata->message); + } + PG_END_TRY(); +} + +/* + * plperl_return_next_internal reports any errors in Postgres fashion + * (via ereport). + */ +static void +plperl_return_next_internal(SV *sv) +{ plperl_proc_desc *prodesc; FunctionCallInfo fcinfo; ReturnSetInfo *rsi; @@ -3336,6 +3407,7 @@ plperl_spi_fetchrow(char *cursor) PG_TRY(); { + dTHX; Portal p = SPI_cursor_find(cursor); if (!p) @@ -3577,6 +3649,8 @@ plperl_spi_exec_prepared(char *query, HV *attr, int argc, SV **argv) PG_TRY(); { + dTHX; + /************************************************************ * Fetch the saved plan descriptor, see if it's o.k. ************************************************************/ @@ -3822,12 +3896,54 @@ plperl_spi_freeplan(char *query) } /* + * Implementation of plperl's elog() function + * + * If the error level is less than ERROR, we'll just emit the message and + * return. When it is ERROR, elog() will longjmp, which we catch and + * turn into a Perl croak(). Note we are assuming that elog() can't have + * any internal failures that are so bad as to require a transaction abort. + * + * The main reason this is out-of-line is to avoid conflicts between XSUB.h + * and the PG_TRY macros. + */ +void +plperl_util_elog(int level, SV *msg) +{ + MemoryContext oldcontext = CurrentMemoryContext; + char *volatile cmsg = NULL; + + PG_TRY(); + { + cmsg = sv2cstr(msg); + elog(level, "%s", cmsg); + pfree(cmsg); + } + PG_CATCH(); + { + ErrorData *edata; + + /* Must reset elog.c's state */ + MemoryContextSwitchTo(oldcontext); + edata = CopyErrorData(); + FlushErrorState(); + + if (cmsg) + pfree(cmsg); + + /* Punt the error to Perl */ + croak_cstr(edata->message); + } + PG_END_TRY(); +} + +/* * Store an SV into a hash table under a key that is a string assumed to be * in the current database's encoding. */ static SV ** hv_store_string(HV *hv, const char *key, SV *val) { + dTHX; int32 hlen; char *hkey; SV **ret; @@ -3854,6 +3970,7 @@ hv_store_string(HV *hv, const char *key, SV *val) static SV ** hv_fetch_string(HV *hv, const char *key) { + dTHX; int32 hlen; char *hkey; SV **ret; @@ -3913,6 +4030,7 @@ static char * setlocale_perl(int category, char *locale) { char *RETVAL = setlocale(category, locale); + dTHX; if (RETVAL) { diff --git a/src/pl/plperl/plperl.h b/src/pl/plperl/plperl.h index eecd192..3f3cce9 100644 --- a/src/pl/plperl/plperl.h +++ b/src/pl/plperl/plperl.h @@ -44,9 +44,17 @@ /* required for perl API */ +#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" + +/* + * We want to include this only within .xs files, but it must come before + * ppport.h, so use a #define flag to control inclusion. + */ +#ifdef PG_NEED_PERL_XSUB_H #include "XSUB.h" +#endif /* put back our snprintf and vsnprintf */ #ifdef USE_REPL_SNPRINTF @@ -106,5 +114,6 @@ SV *plperl_spi_query_prepared(char *, int, SV **); void plperl_spi_freeplan(char *); void plperl_spi_cursor_close(char *); char *plperl_sv_to_literal(SV *, char *); +void plperl_util_elog(int level, SV *msg); #endif /* PL_PERL_H */ diff --git a/src/pl/plperl/plperl_helpers.h b/src/pl/plperl/plperl_helpers.h index 76124ed..5acac60 100644 --- a/src/pl/plperl/plperl_helpers.h +++ b/src/pl/plperl/plperl_helpers.h @@ -54,6 +54,8 @@ sv2cstr(SV *sv) *res; STRLEN len; + dTHX; + /* * get a utf8 encoded char * out of perl. *note* it may not be valid utf8! */ @@ -110,6 +112,8 @@ cstr2sv(const char *str) SV *sv; char *utf8_str; + dTHX; + /* no conversion when SQL_ASCII */ if (GetDatabaseEncoding() == PG_SQL_ASCII) return newSVpv(str, 0); @@ -134,6 +138,8 @@ cstr2sv(const char *str) static inline void croak_cstr(const char *str) { + dTHX; + #ifdef croak_sv /* Use sv_2mortal() to be sure the transient SV gets freed */ croak_sv(sv_2mortal(cstr2sv(str)));