I wrote:

I have made some progress with what I think is needed to have two interpreters for plperl. This is a lot harder than the pltcl case for two reasons: 1. there are no restrictions on having 2 tcl interpreters, and 2. tcl does not need to save and restore context as we have to do with perl. I think I have a conceptual siolution to these two problems, but what I have is currently segfaulting somewhat myteriously. Tracing a dynamically loaded library in a postgres backend with a debugger is less than fun, too. I am attaching what I currently have, liberally sprinkled with elog(NOTICE) calls as trace writes.



With a little more perseverance I found the problem. The attached patch passes regression. But it now needs plenty of eyeballs and testing.

cheers

andrew
Index: plperl.c
===================================================================
RCS file: /cvsroot/pgsql/src/pl/plperl/plperl.c,v
retrieving revision 1.121
diff -c -r1.121 plperl.c
*** plperl.c    19 Oct 2006 18:32:47 -0000      1.121
--- plperl.c    5 Nov 2006 22:20:16 -0000
***************
*** 27,32 ****
--- 27,33 ----
  #include "utils/lsyscache.h"
  #include "utils/memutils.h"
  #include "utils/typcache.h"
+ #include "utils/hsearch.h"
  
  /* perl stuff */
  #include "plperl.h"
***************
*** 55,60 ****
--- 56,69 ----
        SV                 *reference;
  } plperl_proc_desc;
  
+ /* hash table entry for proc desc  */
+ 
+ typedef struct plperl_proc_entry
+ {
+       char proc_name[NAMEDATALEN];
+       plperl_proc_desc *proc_data;
+ } plperl_proc_entry;
+ 
  /*
   * The information we cache for the duration of a single call to a
   * function.
***************
*** 82,94 ****
        Oid                *argtypioparams;
  } plperl_query_desc;
  
  /**********************************************************************
   * Global data
   **********************************************************************/
  static bool plperl_safe_init_done = false;
! static PerlInterpreter *plperl_interp = NULL;
! static HV  *plperl_proc_hash = NULL;
! static HV  *plperl_query_hash = NULL;
  
  static bool plperl_use_strict = false;
  
--- 91,128 ----
        Oid                *argtypioparams;
  } plperl_query_desc;
  
+ /* hash table entry for query desc  */
+ 
+ typedef struct plperl_query_entry
+ {
+       char query_name[NAMEDATALEN];
+       plperl_query_desc *query_data;
+ } plperl_query_entry;
+ 
  /**********************************************************************
   * 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 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 bool can_run_two;
! static bool trusted_context;
! static HTAB  *plperl_proc_hash = NULL;
! static HTAB  *plperl_query_hash = NULL;
  
  static bool plperl_use_strict = false;
  
***************
*** 144,149 ****
--- 178,184 ----
  {
        /* Be sure we do initialization only once (should be redundant now) */
        static bool inited = false;
+     HASHCTL     hash_ctl;
  
        if (inited)
                return;
***************
*** 157,162 ****
--- 192,213 ----
  
        EmitWarningsOnPlaceholders("plperl");
  
+       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);
+ 
+       hash_ctl.entrysize = sizeof(plperl_query_entry);
+       plperl_query_hash = hash_create("PLPerl Queries",
+                                                                       32,
+                                                                       
&hash_ctl,
+                                                                       
HASH_ELEM);
+ 
        plperl_init_interp();
  
        inited = true;
***************
*** 235,240 ****
--- 286,375 ----
        "      elog(ERROR,'trusted Perl functions disabled - " \
        "      please upgrade Perl Safe module to version 2.09 or later');}]); 
}"
  
+ #define TEST_FOR_MULTI \
+       "use Config; " \
+       "$Config{usemultiplicity} eq 'define' or "  \
+     "($Config{usethreads} eq 'define' " \
+       " and $Config{useithreads} eq 'define')"
+ 
+ 
+ /********************************************************************
+  *
+  * 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;
+       }
+       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;
+               }
+       }
+       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;
+       }
+       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;
+       }
+ }
  
  static void
  plperl_init_interp(void)
***************
*** 285,300 ****
        save_time = loc ? pstrdup(loc) : NULL;
  #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, 3, embedding, NULL);
!       perl_run(plperl_interp);
  
!       plperl_proc_hash = newHV();
!       plperl_query_hash = newHV();
  
  #ifdef WIN32
  
--- 420,443 ----
        save_time = loc ? pstrdup(loc) : NULL;
  #endif
  
  
!       plperl_held_interp = perl_alloc();
!       if (!plperl_held_interp)
!               elog(ERROR, "could not allocate Perl interpreter");
  
!       perl_construct(plperl_held_interp);
!       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 WIN32
  
***************
*** 1009,1014 ****
--- 1152,1158 ----
        Datum           retval;
        ReturnSetInfo *rsi;
        SV                 *array_ret = NULL;
+       bool       oldcontext = trusted_context;
  
        /*
         * Create the call_data beforing connecting to SPI, so that it is not
***************
*** 1037,1042 ****
--- 1181,1188 ----
                                                        "cannot accept a 
set")));
        }
  
+       check_interp(prodesc->lanpltrusted);
+ 
        perlret = plperl_call_perl_func(prodesc, fcinfo);
  
        /************************************************************
***************
*** 1146,1151 ****
--- 1292,1299 ----
                SvREFCNT_dec(perlret);
  
        current_call_data = NULL;
+       restore_context(oldcontext);
+ 
        return retval;
  }
  
***************
*** 1158,1163 ****
--- 1306,1312 ----
        Datum           retval;
        SV                 *svTD;
        HV                 *hvTD;
+       bool       oldcontext = trusted_context;
  
        /*
         * Create the call_data beforing connecting to SPI, so that it is not
***************
*** 1174,1179 ****
--- 1323,1330 ----
        prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true);
        current_call_data->prodesc = prodesc;
  
+       check_interp(prodesc->lanpltrusted);
+ 
        svTD = plperl_trigger_build_args(fcinfo);
        perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
        hvTD = (HV *) SvRV(svTD);
***************
*** 1244,1249 ****
--- 1395,1401 ----
                SvREFCNT_dec(perlret);
  
        current_call_data = NULL;
+       restore_context(oldcontext);
        return retval;
  }
  
***************
*** 1256,1262 ****
        char            internal_proname[64];
        plperl_proc_desc *prodesc = NULL;
        int                     i;
!       SV                **svp;
  
        /* We'll need the pg_proc tuple in any case... */
        procTup = SearchSysCache(PROCOID,
--- 1408,1416 ----
        char            internal_proname[64];
        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,
***************
*** 1277,1288 ****
        /************************************************************
         * Lookup the internal proc name in the hashtable
         ************************************************************/
!       svp = hv_fetch_string(plperl_proc_hash, internal_proname);
!       if (svp)
        {
                bool            uptodate;
  
!               prodesc = INT2PTR(plperl_proc_desc *, SvUV(*svp));
  
                /************************************************************
                 * If it's present, must check whether it's still up to date.
--- 1431,1444 ----
        /************************************************************
         * 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.
***************
*** 1294,1301 ****
  
                if (!uptodate)
                {
!                       /* need we delete old entry? */
                        prodesc = NULL;
                }
        }
  
--- 1450,1459 ----
  
                if (!uptodate)
                {
!                       free(prodesc); /* are we leaking memory here? */
                        prodesc = NULL;
+                       hash_search(plperl_proc_hash, internal_proname,
+                                               HASH_REMOVE,NULL);
                }
        }
  
***************
*** 1469,1475 ****
--- 1627,1639 ----
                /************************************************************
                 * 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? */
                {
***************
*** 1479,1486 ****
                                 internal_proname);
                }
  
!               hv_store_string(plperl_proc_hash, internal_proname,
!                                               newSVuv(PTR2UV(prodesc)));
        }
  
        ReleaseSysCache(procTup);
--- 1643,1651 ----
                                 internal_proname);
                }
  
!               hash_entry = hash_search(plperl_proc_hash, internal_proname,
!                                                                HASH_ENTER, 
&found);
!               hash_entry->proc_data = prodesc;
        }
  
        ReleaseSysCache(procTup);
***************
*** 1939,1944 ****
--- 2104,2111 ----
  plperl_spi_prepare(char *query, int argc, SV **argv)
  {
        plperl_query_desc *qdesc;
+       plperl_query_entry *hash_entry;
+       bool        found;
        void       *plan;
        int                     i;
  
***************
*** 2051,2057 ****
         * Insert a hashtable entry for the plan and return
         * the key to the caller.
         ************************************************************/
!       hv_store_string(plperl_query_hash, qdesc->qname, 
newSVuv(PTR2UV(qdesc)));
  
        return newSVstring(qdesc->qname);
  }
--- 2218,2227 ----
         * Insert a hashtable entry for the plan and return
         * the key to the caller.
         ************************************************************/
! 
!       hash_entry = hash_search(plperl_query_hash, qdesc->qname,
!                                                        HASH_ENTER,&found);
!       hash_entry->query_data = qdesc;
  
        return newSVstring(qdesc->qname);
  }
***************
*** 2067,2072 ****
--- 2237,2243 ----
        char       *nulls;
        Datum      *argvalues;
        plperl_query_desc *qdesc;
+       plperl_query_entry *hash_entry;
  
        /*
         * Execute the query inside a sub-transaction, so we can cope with 
errors
***************
*** 2084,2096 ****
                /************************************************************
                 * Fetch the saved plan descriptor, see if it's o.k.
                 ************************************************************/
!               sv = hv_fetch_string(plperl_query_hash, query);
!               if (sv == NULL)
                        elog(ERROR, "spi_exec_prepared: Invalid prepared query 
passed");
-               if (*sv == NULL || !SvOK(*sv))
-                       elog(ERROR, "spi_exec_prepared: panic - 
plperl_query_hash value corrupted");
  
!               qdesc = INT2PTR(plperl_query_desc *, SvUV(*sv));
                if (qdesc == NULL)
                        elog(ERROR, "spi_exec_prepared: panic - 
plperl_query_hash value vanished");
  
--- 2255,2268 ----
                /************************************************************
                 * Fetch the saved plan descriptor, see if it's o.k.
                 ************************************************************/
! 
!               hash_entry = hash_search(plperl_query_hash, query,
!                                                                               
 HASH_FIND,NULL);
!               if (hash_entry == NULL)
                        elog(ERROR, "spi_exec_prepared: Invalid prepared query 
passed");
  
!               qdesc = hash_entry->query_data;
! 
                if (qdesc == NULL)
                        elog(ERROR, "spi_exec_prepared: panic - 
plperl_query_hash value vanished");
  
***************
*** 2201,2211 ****
  SV *
  plperl_spi_query_prepared(char *query, int argc, SV **argv)
  {
-       SV                **sv;
        int                     i;
        char       *nulls;
        Datum      *argvalues;
        plperl_query_desc *qdesc;
        SV                 *cursor;
        Portal          portal = NULL;
  
--- 2373,2383 ----
  SV *
  plperl_spi_query_prepared(char *query, int argc, SV **argv)
  {
        int                     i;
        char       *nulls;
        Datum      *argvalues;
        plperl_query_desc *qdesc;
+       plperl_query_entry *hash_entry;
        SV                 *cursor;
        Portal          portal = NULL;
  
***************
*** 2225,2237 ****
                /************************************************************
                 * Fetch the saved plan descriptor, see if it's o.k.
                 ************************************************************/
!               sv = hv_fetch_string(plperl_query_hash, query);
!               if (sv == NULL)
!                       elog(ERROR, "spi_query_prepared: Invalid prepared query 
passed");
!               if (*sv == NULL || !SvOK(*sv))
!                       elog(ERROR, "spi_query_prepared: panic - 
plperl_query_hash value corrupted");
  
-               qdesc = INT2PTR(plperl_query_desc *, SvUV(*sv));
                if (qdesc == NULL)
                        elog(ERROR, "spi_query_prepared: panic - 
plperl_query_hash value vanished");
  
--- 2397,2409 ----
                /************************************************************
                 * Fetch the saved plan descriptor, see if it's o.k.
                 ************************************************************/
!               hash_entry = hash_search(plperl_query_hash, query,
!                                                                               
 HASH_FIND,NULL);
!               if (hash_entry == NULL)
!                       elog(ERROR, "spi_exec_prepared: Invalid prepared query 
passed");
! 
!               qdesc = hash_entry->query_data;
  
                if (qdesc == NULL)
                        elog(ERROR, "spi_query_prepared: panic - 
plperl_query_hash value vanished");
  
***************
*** 2335,2351 ****
  void
  plperl_spi_freeplan(char *query)
  {
-       SV                **sv;
        void       *plan;
        plperl_query_desc *qdesc;
  
!       sv = hv_fetch_string(plperl_query_hash, query);
!       if (sv == NULL)
!               elog(ERROR, "spi_exec_freeplan: Invalid prepared query passed");
!       if (*sv == NULL || !SvOK(*sv))
!               elog(ERROR, "spi_exec_freeplan: panic - plperl_query_hash value 
corrupted");
  
-       qdesc = INT2PTR(plperl_query_desc *, SvUV(*sv));
        if (qdesc == NULL)
                elog(ERROR, "spi_exec_freeplan: panic - plperl_query_hash value 
vanished");
  
--- 2507,2523 ----
  void
  plperl_spi_freeplan(char *query)
  {
        void       *plan;
        plperl_query_desc *qdesc;
+       plperl_query_entry *hash_entry;
  
!       hash_entry = hash_search(plperl_query_hash, query,
!                                                                               
 HASH_FIND,NULL);
!       if (hash_entry == NULL)
!               elog(ERROR, "spi_exec_prepared: Invalid prepared query passed");
! 
!       qdesc = hash_entry->query_data;
  
        if (qdesc == NULL)
                elog(ERROR, "spi_exec_freeplan: panic - plperl_query_hash value 
vanished");
  
***************
*** 2353,2359 ****
         * free all memory before SPI_freeplan, so if it dies, nothing will be
         * left over
         */
!       hv_delete(plperl_query_hash, query, strlen(query), G_DISCARD);
        plan = qdesc->plan;
        free(qdesc->argtypes);
        free(qdesc->arginfuncs);
--- 2525,2533 ----
         * free all memory before SPI_freeplan, so if it dies, nothing will be
         * left over
         */
!       hash_search(plperl_query_hash, query, 
!                               HASH_REMOVE,NULL);
! 
        plan = qdesc->plan;
        free(qdesc->argtypes);
        free(qdesc->arginfuncs);
---------------------------(end of broadcast)---------------------------
TIP 7: You can help support the PostgreSQL project by donating at

                http://www.postgresql.org/about/donate

Reply via email to