Add plperl.on_perl_init setting to provide for initializing the perl library on load...

Database access is disallowed during both these operations, although it might be allowed in END blocks in future.

Patch from Tim Bunce.

diff --git a/doc/src/sgml/plperl.sgml b/doc/src/sgml/plperl.sgml
index cb231bd791a974d4ea91cf3d35e002b9d88b0c99..2128972c131db68606b4274f6355112098c934cd 100644 (file)
--- a/doc/src/sgml/plperl.sgml
+++ b/doc/src/sgml/plperl.sgml
@@ -1,4 +1,4 @@
-
+
 
  
   PL/Perl - Perl Procedural Language
@@ -1028,7 +1028,72 @@ CREATE TRIGGER test_valid_id_trig
   
  
 
- 
+ 
+  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
 
   
@@ -1063,10 +1128,21 @@ CREATE TRIGGER test_valid_id_trig
         return_next for each row returned, as shown
         previously.
      
-
     
+
+     
+      
+        When a session ends normally, not due to a fatal error, any
+        END blocks that have been defined are executed.
+        Currently no other actions are performed. Specifically, 
+        file handles are not automatically flushed and objects are 
+        not automatically destroyed.
+      
+     
    
   
+ 
+
  
 
 

diff --git a/src/pl/plperl/plc_perlboot.pl b/src/pl/plperl/plc_perlboot.pl
index f0210e54f902ef5dfe8302065f772453de525159..9364a30ece3b9fd0533e1b7bca9e4852e48e43a2 100644 (file)
--- a/src/pl/plperl/plc_perlboot.pl
+++ b/src/pl/plperl/plc_perlboot.pl
@@ -1,8 +1,7 @@
 
-#  $PostgreSQL: pgsql/src/pl/plperl/plc_perlboot.pl,v 1.3 2010/01/26 23:11:56 adunstan Exp $
+#  $PostgreSQL: pgsql/src/pl/plperl/plc_perlboot.pl,v 1.4 2010/01/30 01:46:57 adunstan Exp $
 
 PostgreSQL::InServer::Util::bootstrap();
-PostgreSQL::InServer::SPI::bootstrap();
 
 use strict;
 use warnings;

diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index 1a1e264e9d411e2e290308d03a65b9d86ee1d506..97471edc9bad090cc3c72de41e9bccbbb73319dd 100644 (file)
--- a/src/pl/plperl/plperl.c
+++ b/src/pl/plperl/plperl.c
@@ -1,7 +1,7 @@
 /**********************************************************************
  * plperl.c - perl as a procedural language for PostgreSQL
  *
- *   $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.162 2010/01/28 23:06:09 adunstan Exp $
+ *   $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.163 2010/01/30 01:46:57 adunstan Exp $
  *
  **********************************************************************/
 
@@ -27,6 +27,7 @@
 #include "miscadmin.h"
 #include "nodes/makefuncs.h"
 #include "parser/parse_type.h"
+#include "storage/ipc.h"
 #include "utils/builtins.h"
 #include "utils/fmgroids.h"
 #include "utils/guc.h"
@@ -138,6 +139,8 @@ static HTAB *plperl_proc_hash = NULL;
 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;
@@ -151,6 +154,8 @@ Datum       plperl_validator(PG_FUNCTION_ARGS);
 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 Datum plperl_func_handler(PG_FUNCTION_ARGS);
 static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
@@ -237,6 +242,14 @@ _PG_init(void)
                             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));
@@ -261,6 +274,37 @@ _PG_init(void)
    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(int code, Datum arg)
+{
+   elog(DEBUG3, "plperl_fini");
+
+   /*
+    * Disable use of spi_* functions when running END/DESTROY code.
+    * Could be enabled in future, with care, using a transaction
+    * http://archives.postgresql.org/pgsql-hackers/2010-01/msg02743.php
+    */
+   plperl_ending = true;
+
+   /* Only perform perl cleanup if we're exiting cleanly */
+   if (code) {
+       elog(DEBUG3, "plperl_fini: skipped");
+       return;
+   }
+
+   plperl_destroy_interp(&plperl_trusted_interp);
+   plperl_destroy_interp(&plperl_untrusted_interp);
+   plperl_destroy_interp(&plperl_held_interp);
+
+   elog(DEBUG3, "plperl_fini: done");
+}
+
+
 #define SAFE_MODULE \
    "require Safe; $Safe::VERSION"
 
@@ -277,6 +321,8 @@ _PG_init(void)
 static void
 select_perl_context(bool trusted)
 {
+   EXTERN_C void boot_PostgreSQL__InServer__SPI(pTHX_ CV *cv);
+
    /*
     * handle simple cases
     */
@@ -288,6 +334,10 @@ select_perl_context(bool trusted)
     */
    if (interp_state == INTERP_HELD)
    {
+       /* first actual use of a perl interpreter */
+
+       on_proc_exit(plperl_fini, 0);
+
        if (trusted)
        {
            plperl_trusted_interp = plperl_held_interp;
@@ -325,6 +375,22 @@ select_perl_context(bool trusted)
        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")));
+   }
+
 }
 
 /*
@@ -361,7 +427,7 @@ plperl_init_interp(void)
    PerlInterpreter *plperl;
    static int perl_sys_init_done;
 
-   static char *embedding[3] = {
+   static char *embedding[3+2] = {
        "", "-e", PLC_PERLBOOT
    };
    int         nargs = 3;
@@ -408,6 +474,12 @@ plperl_init_interp(void)
    save_time = loc ? pstrdup(loc) : NULL;
 #endif
 
+   if (plperl_on_perl_init)
+   {
+       embedding[nargs++] = "-e";
+       embedding[nargs++] = plperl_on_perl_init;
+   }
+
    /****
     * The perl API docs state that PERL_SYS_INIT3 should be called before
     * allocating interprters. Unfortunately, on some platforms this fails
@@ -437,6 +509,9 @@ 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' opcode.
     * Ensure it's used for new interpreters.
@@ -446,9 +521,18 @@ plperl_init_interp(void)
    else
        PL_ppaddr[OP_REQUIRE] = pp_require_orig;
 
-   perl_parse(plperl, plperl_init_shared_libs,
-              nargs, embedding, NULL);
-   perl_run(plperl);
+   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
 
@@ -523,6 +607,43 @@ pp_require_safe(pTHX)
 }
 
 
+static void
+plperl_destroy_interp(PerlInterpreter **interp)
+{
+   if (interp && *interp)
+   {
+       /*
+        * Only a very minimal destruction is performed:
+        * - just call END blocks.
+        *
+        * We could call perl_destruct() but we'd need to audit its
+        * actions very carefully and work-around any that impact us.
+        * (Calling sv_clean_objs() isn't an option because it's not
+        * part of perl's public API so isn't portably available.)
+        * Meanwhile END blocks can 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) {
+           dJMPENV;
+           int x = 0;
+
+           JMPENV_PUSH(x);
+           PERL_UNUSED_VAR(x);
+           if (PL_endav && !PL_minus_c)
+               call_list(PL_scopestack_ix, PL_endav);
+           JMPENV_POP;
+       }
+       LEAVE;
+       FREETMPS;
+
+       *interp = NULL;
+   }
+}
+
+
 static void
 plperl_safe_init(void)
 {
@@ -544,8 +665,8 @@ plperl_safe_init(void)
        {
            ereport(ERROR,
                (errcode(ERRCODE_INTERNAL_ERROR),
-                errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
-                errdetail("While executing PLC_SAFE_BAD")));
+                errmsg("while executing PLC_SAFE_BAD"),
+                errdetail("%s", strip_trailing_ws(SvPV_nolen(ERRSV))) ));
        }
 
    }
@@ -556,8 +677,8 @@ plperl_safe_init(void)
        {
            ereport(ERROR,
                (errcode(ERRCODE_INTERNAL_ERROR),
-                errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
-                errdetail("While executing PLC_SAFE_OK")));
+                errmsg("while executing PLC_SAFE_OK"),
+                errdetail("%s", strip_trailing_ws(SvPV_nolen(ERRSV))) ));
        }
 
        if (GetDatabaseEncoding() == PG_UTF8)
@@ -1153,18 +1274,14 @@ plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid)
  *
  **********************************************************************/
 
-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__;
+   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::SPI::bootstrap",
-         boot_PostgreSQL__InServer__SPI, file);
    newXS("PostgreSQL::InServer::Util::bootstrap",
        boot_PostgreSQL__InServer__Util, file);
 }
@@ -1900,6 +2017,16 @@ plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
 }
 
 
+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)
 {
@@ -1912,6 +2039,8 @@ plperl_spi_exec(char *query, int limit)
    MemoryContext oldcontext = CurrentMemoryContext;
    ResourceOwner oldowner = CurrentResourceOwner;
 
+   check_spi_usage_allowed();
+
    BeginInternalSubTransaction(NULL);
    /* Want to run inside function's memory context */
    MemoryContextSwitchTo(oldcontext);
@@ -1975,6 +2104,8 @@ plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
 {
    HV         *result;
 
+   check_spi_usage_allowed();
+
    result = newHV();
 
    hv_store_string(result, "status",
@@ -2148,6 +2279,8 @@ plperl_spi_query(char *query)
    MemoryContext oldcontext = CurrentMemoryContext;
    ResourceOwner oldowner = CurrentResourceOwner;
 
+   check_spi_usage_allowed();
+
    BeginInternalSubTransaction(NULL);
    /* Want to run inside function's memory context */
    MemoryContextSwitchTo(oldcontext);
@@ -2226,6 +2359,8 @@ plperl_spi_fetchrow(char *cursor)
    MemoryContext oldcontext = CurrentMemoryContext;
    ResourceOwner oldowner = CurrentResourceOwner;
 
+   check_spi_usage_allowed();
+
    BeginInternalSubTransaction(NULL);
    /* Want to run inside function's memory context */
    MemoryContextSwitchTo(oldcontext);
@@ -2300,7 +2435,11 @@ plperl_spi_fetchrow(char *cursor)
 void
 plperl_spi_cursor_close(char *cursor)
 {
-   Portal      p = SPI_cursor_find(cursor);
+   Portal      p;
+
+   check_spi_usage_allowed();
+
+   p = SPI_cursor_find(cursor);
 
    if (p)
        SPI_cursor_close(p);
@@ -2318,6 +2457,8 @@ plperl_spi_prepare(char *query, int argc, SV **argv)
    MemoryContext oldcontext = CurrentMemoryContext;
    ResourceOwner oldowner = CurrentResourceOwner;
 
+   check_spi_usage_allowed();
+
    BeginInternalSubTransaction(NULL);
    MemoryContextSwitchTo(oldcontext);
 
@@ -2453,6 +2594,8 @@ plperl_spi_exec_prepared(char *query, HV *attr, int argc, SV **argv)
    MemoryContext oldcontext = CurrentMemoryContext;
    ResourceOwner oldowner = CurrentResourceOwner;
 
+   check_spi_usage_allowed();
+
    BeginInternalSubTransaction(NULL);
    /* Want to run inside function's memory context */
    MemoryContextSwitchTo(oldcontext);
@@ -2595,6 +2738,8 @@ plperl_spi_query_prepared(char *query, int argc, SV **argv)
    MemoryContext oldcontext = CurrentMemoryContext;
    ResourceOwner oldowner = CurrentResourceOwner;
 
+   check_spi_usage_allowed();
+
    BeginInternalSubTransaction(NULL);
    /* Want to run inside function's memory context */
    MemoryContextSwitchTo(oldcontext);
@@ -2718,6 +2863,8 @@ plperl_spi_freeplan(char *query)
    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
new file mode 100644 (file)
index 0000000..90f49dc
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_end.sql
@@ -0,0 +1,29 @@
+-- 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$
+   my $testlog = "/tmp/pgplperl_test.log";
+
+   warn "Run test, then examine contents of $testlog (which must already exist)\n";
+   return unless -f $testlog;
+
+    use IO::Handle; # for autoflush
+   open my $fh, '>', $testlog
+       or die "Can't write to $testlog: $!";
+    $fh->autoflush(1);
+
+    print $fh "# you should see just 3 'Warn: ...' lines: PRE, END and SPI ...\n";
+    $SIG{__WARN__} = sub { print $fh "Warn: @_" };
+    $SIG{__DIE__}  = sub { print $fh "Die: @_" unless $^S; die @_ };
+
+   END {
+       warn "END\n";
+       eval { spi_exec_query("select 1") };
+       warn $@;
+   }
+    warn "PRE\n";
+
+$do$ language plperlu;

diff --git a/src/pl/plperl/sql/plperl_plperlu.sql b/src/pl/plperl/sql/plperl_plperlu.sql
index fc2bb7b80676e039b8cedd9dc594d5fd2babe257..15b5aa29687f93cd6f3f0ef270fd8bbc48cf44e6 100644 (file)
--- a/src/pl/plperl/sql/plperl_plperlu.sql
+++ b/src/pl/plperl/sql/plperl_plperlu.sql
@@ -16,4 +16,3 @@ $$ LANGUAGE plperlu; -- compile plperlu code
 SELECT * FROM bar(); -- throws exception normally (running plperl)
 SELECT * FROM foo(); -- used to cause backend crash (after switching to plperlu)
 
-