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 ----