diff --git a/doc/src/sgml/plperl.sgml b/doc/src/sgml/plperl.sgml index 6fee031..0054f5a 100644 *** a/doc/src/sgml/plperl.sgml --- b/doc/src/sgml/plperl.sgml *************** CREATE TRIGGER test_valid_id_trig *** 1030,1036 **** ! Limitations and Missing Features --- 1030,1100 ---- ! ! PL/Perl Under the Hood ! ! ! Configuration ! ! ! This section lists configuration parameters that affect PL/Perl. ! To set any of these parameters before PL/Perl has been loaded, ! it is necessary to have added plperl to the ! list in ! postgresql.conf. ! ! ! ! ! ! plperl.on_perl_init (string) ! ! plperl.on_perl_init configuration parameter ! ! ! ! Specifies perl code to be executed when a perl interpreter is first initialized. ! The SPI functions are not available when this code is executed. ! If the code fails with an error it will abort the initialization of the interpreter ! and propagate out to the calling query, causing the current transaction ! or subtransaction to be aborted. ! ! ! The perl code is limited to a single string. Longer code can be placed ! into a module and loaded by the on_perl_init string. ! Examples: ! ! plplerl.on_perl_init = '$ENV{NYTPROF}="start=no"; require Devel::NYTProf::PgPLPerl' ! plplerl.on_perl_init = 'use lib "/my/app"; use MyApp::PgInit;' ! ! ! ! Initialization will happen in the postmaster if the plperl library is included ! in shared_preload_libraries (see ), ! in which case extra consideration should be given to the risk of destabilizing the postmaster. ! ! ! This parameter can only be set in the postgresql.conf file or on the server command line. ! ! ! ! ! ! plperl.use_strict (boolean) ! ! plperl.use_strict configuration parameter ! ! ! ! When set true subsequent compilations of PL/Perl functions have the strict pragma enabled. ! This parameter does not affect functions already compiled in the current session. ! ! ! ! ! ! ! Limitations and Missing Features diff --git a/src/pl/plperl/plc_perlboot.pl b/src/pl/plperl/plc_perlboot.pl index 769721d..5f6ae91 100644 *** a/src/pl/plperl/plc_perlboot.pl --- b/src/pl/plperl/plc_perlboot.pl *************** *** 1,5 **** PostgreSQL::InServer::Util::bootstrap(); - PostgreSQL::InServer::SPI::bootstrap(); use strict; use warnings; --- 1,4 ---- diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c index 9277072..8315d5a 100644 *** a/src/pl/plperl/plperl.c --- b/src/pl/plperl/plperl.c *************** static HTAB *plperl_proc_hash = NULL; *** 138,143 **** --- 138,145 ---- static HTAB *plperl_query_hash = NULL; static bool plperl_use_strict = false; + static char *plperl_on_perl_init = NULL; + static bool plperl_ending = false; /* this is saved and restored by plperl_call_handler */ static plperl_call_data *current_call_data = NULL; *************** Datum plperl_validator(PG_FUNCTION_ARGS *** 151,156 **** --- 153,160 ---- void _PG_init(void); static PerlInterpreter *plperl_init_interp(void); + static void plperl_destroy_interp(PerlInterpreter **); + static void plperl_fini(void); static Datum plperl_func_handler(PG_FUNCTION_ARGS); static Datum plperl_trigger_handler(PG_FUNCTION_ARGS); *************** _PG_init(void) *** 237,242 **** --- 241,254 ---- PGC_USERSET, 0, NULL, NULL); + DefineCustomStringVariable("plperl.on_perl_init", + gettext_noop("Perl code to execute when the perl interpreter is initialized."), + NULL, + &plperl_on_perl_init, + NULL, + PGC_SIGHUP, 0, + NULL, NULL); + EmitWarningsOnPlaceholders("plperl"); MemSet(&hash_ctl, 0, sizeof(hash_ctl)); *************** _PG_init(void) *** 261,266 **** --- 273,293 ---- inited = true; } + + /* + * Cleanup perl interpreters, including running END blocks. + * Does not fully undo the actions of _PG_init() nor make it callable again. + */ + static void + plperl_fini(void) + { + plperl_ending = true; + plperl_destroy_interp(&plperl_trusted_interp); + plperl_destroy_interp(&plperl_untrusted_interp); + plperl_destroy_interp(&plperl_held_interp); + } + + #define SAFE_MODULE \ "require Safe; $Safe::VERSION" *************** _PG_init(void) *** 277,282 **** --- 304,311 ---- static void select_perl_context(bool trusted) { + EXTERN_C void boot_PostgreSQL__InServer__SPI(pTHX_ CV *cv); + /* * handle simple cases */ *************** select_perl_context(bool trusted) *** 288,293 **** --- 317,326 ---- */ if (interp_state == INTERP_HELD) { + /* first actual use of a perl interpreter */ + + atexit(plperl_fini); + if (trusted) { plperl_trusted_interp = plperl_held_interp; *************** select_perl_context(bool trusted) *** 325,330 **** --- 358,379 ---- plperl_safe_init(); PL_ppaddr[OP_REQUIRE] = pp_require_safe; } + + /* + * enable access to the database + */ + newXS("PostgreSQL::InServer::SPI::bootstrap", + boot_PostgreSQL__InServer__SPI, __FILE__); + + eval_pv("PostgreSQL::InServer::SPI::bootstrap()", FALSE); + if (SvTRUE(ERRSV)) + { + ereport(ERROR, + (errcode(ERRCODE_INTERNAL_ERROR), + errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))), + errdetail("While executing PostgreSQL::InServer::SPI::bootstrap"))); + } + } /* *************** plperl_init_interp(void) *** 361,371 **** PerlInterpreter *plperl; static int perl_sys_init_done; ! static char *embedding[3] = { "", "-e", PLC_PERLBOOT }; int nargs = 3; #ifdef WIN32 /* --- 410,426 ---- PerlInterpreter *plperl; static int perl_sys_init_done; ! static char *embedding[3+2] = { "", "-e", PLC_PERLBOOT }; int nargs = 3; + if (plperl_on_perl_init) + { + embedding[nargs++] = "-e"; + embedding[nargs++] = plperl_on_perl_init; + } + #ifdef WIN32 /* *************** plperl_init_interp(void) *** 437,442 **** --- 492,500 ---- 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' opcode. * Ensure it's used for new interpreters. *************** plperl_init_interp(void) *** 446,454 **** else PL_ppaddr[OP_REQUIRE] = pp_require_orig; ! perl_parse(plperl, plperl_init_shared_libs, ! nargs, embedding, NULL); ! perl_run(plperl); #ifdef WIN32 --- 504,521 ---- else PL_ppaddr[OP_REQUIRE] = pp_require_orig; ! if (perl_parse(plperl, plperl_init_shared_libs, ! nargs, embedding, NULL) != 0) ! ereport(ERROR, ! (errcode(ERRCODE_INTERNAL_ERROR), ! errmsg("while parsing perl initialization"), ! errdetail("%s", strip_trailing_ws(SvPV_nolen(ERRSV))) )); ! ! if (perl_run(plperl) != 0) ! ereport(ERROR, ! (errcode(ERRCODE_INTERNAL_ERROR), ! errmsg("while running perl initialization"), ! errdetail("%s", strip_trailing_ws(SvPV_nolen(ERRSV))) )); #ifdef WIN32 *************** pp_require_safe(pTHX) *** 524,529 **** --- 591,608 ---- static void + plperl_destroy_interp(PerlInterpreter **interp) + { + if (interp && *interp) + { + perl_destruct(*interp); + perl_free(*interp); + *interp = NULL; + } + } + + + static void plperl_safe_init(void) { SV *safe_version_sv; *************** plperl_safe_init(void) *** 544,551 **** { ereport(ERROR, (errcode(ERRCODE_INTERNAL_ERROR), ! errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))), ! errdetail("While executing PLC_SAFE_BAD"))); } } --- 623,630 ---- { ereport(ERROR, (errcode(ERRCODE_INTERNAL_ERROR), ! errmsg("while executing PLC_SAFE_BAD"), ! errdetail("%s", strip_trailing_ws(SvPV_nolen(ERRSV))) )); } } *************** plperl_safe_init(void) *** 556,563 **** { ereport(ERROR, (errcode(ERRCODE_INTERNAL_ERROR), ! errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))), ! errdetail("While executing PLC_SAFE_OK"))); } if (GetDatabaseEncoding() == PG_UTF8) --- 635,642 ---- { ereport(ERROR, (errcode(ERRCODE_INTERNAL_ERROR), ! errmsg("while executing PLC_SAFE_OK"), ! errdetail("%s", strip_trailing_ws(SvPV_nolen(ERRSV))) )); } if (GetDatabaseEncoding() == PG_UTF8) *************** plperl_create_sub(plperl_proc_desc *prod *** 1150,1167 **** * **********************************************************************/ - EXTERN_C void boot_DynaLoader(pTHX_ CV *cv); - EXTERN_C void boot_PostgreSQL__InServer__SPI(pTHX_ CV *cv); - EXTERN_C void boot_PostgreSQL__InServer__Util(pTHX_ CV *cv); - static void plperl_init_shared_libs(pTHX) { char *file = __FILE__; newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); - newXS("PostgreSQL::InServer::SPI::bootstrap", - boot_PostgreSQL__InServer__SPI, file); newXS("PostgreSQL::InServer::Util::bootstrap", boot_PostgreSQL__InServer__Util, file); } --- 1229,1242 ---- * **********************************************************************/ 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", boot_PostgreSQL__InServer__Util, file); } *************** plperl_hash_from_tuple(HeapTuple tuple, *** 1897,1902 **** --- 1972,1987 ---- } + static void + check_spi_usage_allowed() + { + if (plperl_ending) { + /* simple croak as we don't want to involve PostgreSQL code */ + croak("SPI functions can not be used in END blocks"); + } + } + + HV * plperl_spi_exec(char *query, int limit) { *************** plperl_spi_exec(char *query, int limit) *** 1909,1914 **** --- 1994,2001 ---- MemoryContext oldcontext = CurrentMemoryContext; ResourceOwner oldowner = CurrentResourceOwner; + check_spi_usage_allowed(); + BeginInternalSubTransaction(NULL); /* Want to run inside function's memory context */ MemoryContextSwitchTo(oldcontext); *************** plperl_spi_execute_fetch_result(SPITuple *** 1972,1977 **** --- 2059,2066 ---- { HV *result; + check_spi_usage_allowed(); + result = newHV(); hv_store_string(result, "status", *************** plperl_spi_query(char *query) *** 2145,2150 **** --- 2234,2241 ---- MemoryContext oldcontext = CurrentMemoryContext; ResourceOwner oldowner = CurrentResourceOwner; + check_spi_usage_allowed(); + BeginInternalSubTransaction(NULL); /* Want to run inside function's memory context */ MemoryContextSwitchTo(oldcontext); *************** plperl_spi_fetchrow(char *cursor) *** 2223,2228 **** --- 2314,2321 ---- MemoryContext oldcontext = CurrentMemoryContext; ResourceOwner oldowner = CurrentResourceOwner; + check_spi_usage_allowed(); + BeginInternalSubTransaction(NULL); /* Want to run inside function's memory context */ MemoryContextSwitchTo(oldcontext); *************** plperl_spi_fetchrow(char *cursor) *** 2297,2303 **** void plperl_spi_cursor_close(char *cursor) { ! Portal p = SPI_cursor_find(cursor); if (p) SPI_cursor_close(p); --- 2390,2400 ---- void plperl_spi_cursor_close(char *cursor) { ! Portal p; ! ! check_spi_usage_allowed(); ! ! p = SPI_cursor_find(cursor); if (p) SPI_cursor_close(p); *************** plperl_spi_prepare(char *query, int argc *** 2315,2320 **** --- 2412,2419 ---- MemoryContext oldcontext = CurrentMemoryContext; ResourceOwner oldowner = CurrentResourceOwner; + check_spi_usage_allowed(); + BeginInternalSubTransaction(NULL); MemoryContextSwitchTo(oldcontext); *************** plperl_spi_exec_prepared(char *query, HV *** 2450,2455 **** --- 2549,2556 ---- MemoryContext oldcontext = CurrentMemoryContext; ResourceOwner oldowner = CurrentResourceOwner; + check_spi_usage_allowed(); + BeginInternalSubTransaction(NULL); /* Want to run inside function's memory context */ MemoryContextSwitchTo(oldcontext); *************** plperl_spi_query_prepared(char *query, i *** 2592,2597 **** --- 2693,2700 ---- MemoryContext oldcontext = CurrentMemoryContext; ResourceOwner oldowner = CurrentResourceOwner; + check_spi_usage_allowed(); + BeginInternalSubTransaction(NULL); /* Want to run inside function's memory context */ MemoryContextSwitchTo(oldcontext); *************** plperl_spi_freeplan(char *query) *** 2715,2720 **** --- 2818,2825 ---- plperl_query_desc *qdesc; plperl_query_entry *hash_entry; + check_spi_usage_allowed(); + hash_entry = hash_search(plperl_query_hash, query, HASH_FIND, NULL); if (hash_entry == NULL) diff --git a/src/pl/plperl/sql/plperl_end.sql b/src/pl/plperl/sql/plperl_end.sql index ...d4f1444 . *** a/src/pl/plperl/sql/plperl_end.sql --- b/src/pl/plperl/sql/plperl_end.sql *************** *** 0 **** --- 1,18 ---- + -- test END block handling + + -- Not included in the normal testing + -- because it's beyond the scope of the test harness. + -- Available here for manual developer testing. + + DO $do$ + open my $fh, ">/tmp/plperl_end.$$.log"; + $SIG{__WARN__} = sub { printf $fh "Warn: @_" }; + $SIG{__DIE__} = sub { printf $fh "Die: @_"; die @_ }; + END { + warn "end\n"; + eval { + spi_exec_query("select 1"); + }; + warn "spi_exec_query: $@"; + } + $do$ language plperlu; diff --git a/src/pl/plperl/sql/plperl_plperlu.sql b/src/pl/plperl/sql/plperl_plperlu.sql index fc2bb7b..15b5aa2 100644 *** a/src/pl/plperl/sql/plperl_plperlu.sql --- b/src/pl/plperl/sql/plperl_plperlu.sql *************** $$ LANGUAGE plperlu; -- compile plperlu *** 16,19 **** SELECT * FROM bar(); -- throws exception normally (running plperl) SELECT * FROM foo(); -- used to cause backend crash (after switching to plperlu) - --- 16,18 ----