Re: BUG #7516: PL/Perl crash - Mailing list pgsql-bugs

I wrote:
> Hm.  Well, I can definitely reproduce a segfault using this example:

> CREATE OR REPLACE FUNCTION self_modify(INTEGER) RETURNS INTEGER AS $$
>    spi_exec_query('CREATE OR REPLACE FUNCTION self_modify(INTEGER) RETURNS INTEGER AS \'return $_[0] * 3;\' LANGUAGE
plperl;');
>    spi_exec_query('select self_modify(42) AS a');
>    return $_[0] * 2;
> $$ LANGUAGE plperl;

> select self_modify(42);

> So I think we need to institute a reference counting scheme for
> the plperl_proc_desc records ...

The attached patch fixes the problem I'm seeing.  I am not sure whether
it fixes what you saw; the crash you showed is in the right place, but
unless there was a recursive call to a pl/perl function, I don't see
how the existing code could have freed the prodesc too soon.

            regards, tom lane

diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out
index 906dc15e0ca097ec962c6dce9a08b29cb31d35b5..29c1d11c447e6087fee85565c0bf458cbc21486d 100644
*** a/src/pl/plperl/expected/plperl.out
--- b/src/pl/plperl/expected/plperl.out
*************** $$ LANGUAGE plperl;
*** 693,695 ****
--- 693,713 ----
  SELECT text_scalarref();
  ERROR:  PL/Perl function must return reference to hash or array
  CONTEXT:  PL/Perl function "text_scalarref"
+ -- check safe behavior when a function body is replaced during execution
+ CREATE OR REPLACE FUNCTION self_modify(INTEGER) RETURNS INTEGER AS $$
+    spi_exec_query('CREATE OR REPLACE FUNCTION self_modify(INTEGER) RETURNS INTEGER AS \'return $_[0] * 3;\' LANGUAGE
plperl;');
+    spi_exec_query('select self_modify(42) AS a');
+    return $_[0] * 2;
+ $$ LANGUAGE plperl;
+ SELECT self_modify(42);
+  self_modify
+ -------------
+           84
+ (1 row)
+
+ SELECT self_modify(42);
+  self_modify
+ -------------
+          126
+ (1 row)
+
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index bfa805d944f7b309428b6818b7160215c1b8e9fc..2c39edac5bd93ca8b446aafb88a17e0b7a5088db 100644
*** a/src/pl/plperl/plperl.c
--- b/src/pl/plperl/plperl.c
*************** PG_MODULE_MAGIC;
*** 70,75 ****
--- 70,76 ----
   *
   * The plperl_interp_desc structs are kept in a Postgres hash table indexed
   * by userid OID, with OID 0 used for the single untrusted interpreter.
+  * Once created, an interpreter is kept for the life of the process.
   *
   * We start out by creating a "held" interpreter, which we initialize
   * only as far as we can do without deciding if it will be trusted or
*************** typedef struct plperl_interp_desc
*** 95,122 ****

  /**********************************************************************
   * The information we cache about loaded procedures
   **********************************************************************/
  typedef struct plperl_proc_desc
  {
      char       *proname;        /* user name of procedure */
!     TransactionId fn_xmin;
      ItemPointerData fn_tid;
      plperl_interp_desc *interp; /* interpreter it's created in */
!     bool        fn_readonly;
!     bool        lanpltrusted;
      bool        fn_retistuple;    /* true, if function returns tuple */
      bool        fn_retisset;    /* true, if function returns set */
      bool        fn_retisarray;    /* true if function returns array */
      Oid            result_oid;        /* Oid of result type */
      FmgrInfo    result_in_func; /* I/O function and arg for result type */
      Oid            result_typioparam;
      int            nargs;
      FmgrInfo    arg_out_func[FUNC_MAX_ARGS];
      bool        arg_is_rowtype[FUNC_MAX_ARGS];
      Oid            arg_arraytype[FUNC_MAX_ARGS];    /* InvalidOid if not an array */
-     SV           *reference;
  } plperl_proc_desc;

  /**********************************************************************
   * For speedy lookup, we maintain a hash table mapping from
   * function OID + trigger flag + user OID to plperl_proc_desc pointers.
--- 96,139 ----

  /**********************************************************************
   * The information we cache about loaded procedures
+  *
+  * The refcount field counts the struct's reference from the hash table shown
+  * below, plus one reference for each function call level that is using the
+  * struct.  We can release the struct, and the associated Perl sub, when the
+  * refcount goes to zero.
   **********************************************************************/
  typedef struct plperl_proc_desc
  {
      char       *proname;        /* user name of procedure */
!     TransactionId fn_xmin;        /* xmin/TID of procedure's pg_proc tuple */
      ItemPointerData fn_tid;
+     int            refcount;        /* reference count of this struct */
+     SV           *reference;        /* CODE reference for Perl sub */
      plperl_interp_desc *interp; /* interpreter it's created in */
!     bool        fn_readonly;    /* is function readonly (not volatile)? */
!     bool        lanpltrusted;    /* is it plperl, rather than plperlu? */
      bool        fn_retistuple;    /* true, if function returns tuple */
      bool        fn_retisset;    /* true, if function returns set */
      bool        fn_retisarray;    /* true if function returns array */
+     /* Conversion info for function's result type: */
      Oid            result_oid;        /* Oid of result type */
      FmgrInfo    result_in_func; /* I/O function and arg for result type */
      Oid            result_typioparam;
+     /* Conversion info for function's argument types: */
      int            nargs;
      FmgrInfo    arg_out_func[FUNC_MAX_ARGS];
      bool        arg_is_rowtype[FUNC_MAX_ARGS];
      Oid            arg_arraytype[FUNC_MAX_ARGS];    /* InvalidOid if not an array */
  } plperl_proc_desc;

+ #define increment_prodesc_refcount(prodesc)  \
+     ((prodesc)->refcount++)
+ #define decrement_prodesc_refcount(prodesc)  \
+     do { \
+         if (--((prodesc)->refcount) <= 0) \
+             free_plperl_function(prodesc); \
+     } while(0)
+
  /**********************************************************************
   * For speedy lookup, we maintain a hash table mapping from
   * function OID + trigger flag + user OID to plperl_proc_desc pointers.
*************** static void set_interp_require(bool trus
*** 238,243 ****
--- 255,262 ----
  static Datum plperl_func_handler(PG_FUNCTION_ARGS);
  static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);

+ static void free_plperl_function(plperl_proc_desc *prodesc);
+
  static plperl_proc_desc *compile_plperl_function(Oid fn_oid, bool is_trigger);

  static SV  *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc);
*************** plperl_call_handler(PG_FUNCTION_ARGS)
*** 1689,1694 ****
--- 1708,1714 ----

      PG_TRY();
      {
+         current_call_data = NULL;
          if (CALLED_AS_TRIGGER(fcinfo))
              retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
          else
*************** plperl_call_handler(PG_FUNCTION_ARGS)
*** 1696,1707 ****
--- 1716,1731 ----
      }
      PG_CATCH();
      {
+         if (current_call_data && current_call_data->prodesc)
+             decrement_prodesc_refcount(current_call_data->prodesc);
          current_call_data = save_call_data;
          activate_interpreter(oldinterp);
          PG_RE_THROW();
      }
      PG_END_TRY();

+     if (current_call_data && current_call_data->prodesc)
+         decrement_prodesc_refcount(current_call_data->prodesc);
      current_call_data = save_call_data;
      activate_interpreter(oldinterp);
      return retval;
*************** plperl_inline_handler(PG_FUNCTION_ARGS)
*** 1753,1766 ****
      desc.nargs = 0;
      desc.reference = NULL;

-     current_call_data = (plperl_call_data *) palloc0(sizeof(plperl_call_data));
-     current_call_data->fcinfo = &fake_fcinfo;
-     current_call_data->prodesc = &desc;
-
      PG_TRY();
      {
          SV           *perlret;

          if (SPI_connect() != SPI_OK_CONNECT)
              elog(ERROR, "could not connect to SPI manager");

--- 1777,1791 ----
      desc.nargs = 0;
      desc.reference = NULL;

      PG_TRY();
      {
          SV           *perlret;

+         current_call_data = (plperl_call_data *) palloc0(sizeof(plperl_call_data));
+         current_call_data->fcinfo = &fake_fcinfo;
+         current_call_data->prodesc = &desc;
+         /* we do not bother with refcounting the fake prodesc */
+
          if (SPI_connect() != SPI_OK_CONNECT)
              elog(ERROR, "could not connect to SPI manager");

*************** plperl_func_handler(PG_FUNCTION_ARGS)
*** 2154,2159 ****
--- 2179,2185 ----

      prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
      current_call_data->prodesc = prodesc;
+     increment_prodesc_refcount(prodesc);

      /* Set a callback for error reporting */
      pl_error_context.callback = plperl_exec_callback;
*************** plperl_trigger_handler(PG_FUNCTION_ARGS)
*** 2274,2279 ****
--- 2300,2306 ----
      /* Find or compile the function */
      prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true);
      current_call_data->prodesc = prodesc;
+     increment_prodesc_refcount(prodesc);

      /* Set a callback for error reporting */
      pl_error_context.callback = plperl_exec_callback;
*************** validate_plperl_function(plperl_proc_ptr
*** 2383,2405 ****

          /* Otherwise, unlink the obsoleted entry from the hashtable ... */
          proc_ptr->proc_ptr = NULL;
!         /* ... and throw it away */
!         if (prodesc->reference)
!         {
!             plperl_interp_desc *oldinterp = plperl_active_interp;
!
!             activate_interpreter(prodesc->interp);
!             SvREFCNT_dec(prodesc->reference);
!             activate_interpreter(oldinterp);
!         }
!         free(prodesc->proname);
!         free(prodesc);
      }

      return false;
  }


  static plperl_proc_desc *
  compile_plperl_function(Oid fn_oid, bool is_trigger)
  {
--- 2410,2444 ----

          /* Otherwise, unlink the obsoleted entry from the hashtable ... */
          proc_ptr->proc_ptr = NULL;
!         /* ... and release the corresponding refcount, probably deleting it */
!         decrement_prodesc_refcount(prodesc);
      }

      return false;
  }


+ static void
+ free_plperl_function(plperl_proc_desc *prodesc)
+ {
+     Assert(prodesc->refcount <= 0);
+     /* Release CODE reference, if we have one, from the appropriate interp */
+     if (prodesc->reference)
+     {
+         plperl_interp_desc *oldinterp = plperl_active_interp;
+
+         activate_interpreter(prodesc->interp);
+         SvREFCNT_dec(prodesc->reference);
+         activate_interpreter(oldinterp);
+     }
+     /* Get rid of what we conveniently can of our own structs */
+     /* (FmgrInfo subsidiary info will get leaked ...) */
+     if (prodesc->proname)
+         free(prodesc->proname);
+     free(prodesc);
+ }
+
+
  static plperl_proc_desc *
  compile_plperl_function(Oid fn_oid, bool is_trigger)
  {
*************** compile_plperl_function(Oid fn_oid, bool
*** 2470,2481 ****
--- 2509,2525 ----
              ereport(ERROR,
                      (errcode(ERRCODE_OUT_OF_MEMORY),
                       errmsg("out of memory")));
+         /* Initialize all fields to 0 so free_plperl_function is safe */
          MemSet(prodesc, 0, sizeof(plperl_proc_desc));
+
          prodesc->proname = strdup(NameStr(procStruct->proname));
          if (prodesc->proname == NULL)
+         {
+             free_plperl_function(prodesc);
              ereport(ERROR,
                      (errcode(ERRCODE_OUT_OF_MEMORY),
                       errmsg("out of memory")));
+         }
          prodesc->fn_xmin = HeapTupleHeaderGetXmin(procTup->t_data);
          prodesc->fn_tid = procTup->t_self;

*************** compile_plperl_function(Oid fn_oid, bool
*** 2490,2497 ****
                                    ObjectIdGetDatum(procStruct->prolang));
          if (!HeapTupleIsValid(langTup))
          {
!             free(prodesc->proname);
!             free(prodesc);
              elog(ERROR, "cache lookup failed for language %u",
                   procStruct->prolang);
          }
--- 2534,2540 ----
                                    ObjectIdGetDatum(procStruct->prolang));
          if (!HeapTupleIsValid(langTup))
          {
!             free_plperl_function(prodesc);
              elog(ERROR, "cache lookup failed for language %u",
                   procStruct->prolang);
          }
*************** compile_plperl_function(Oid fn_oid, bool
*** 2510,2517 ****
                                  ObjectIdGetDatum(procStruct->prorettype));
              if (!HeapTupleIsValid(typeTup))
              {
!                 free(prodesc->proname);
!                 free(prodesc);
                  elog(ERROR, "cache lookup failed for type %u",
                       procStruct->prorettype);
              }
--- 2553,2559 ----
                                  ObjectIdGetDatum(procStruct->prorettype));
              if (!HeapTupleIsValid(typeTup))
              {
!                 free_plperl_function(prodesc);
                  elog(ERROR, "cache lookup failed for type %u",
                       procStruct->prorettype);
              }
*************** compile_plperl_function(Oid fn_oid, bool
*** 2525,2532 ****
                       /* okay */ ;
                  else if (procStruct->prorettype == TRIGGEROID)
                  {
!                     free(prodesc->proname);
!                     free(prodesc);
                      ereport(ERROR,
                              (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
                               errmsg("trigger functions can only be called "
--- 2567,2573 ----
                       /* okay */ ;
                  else if (procStruct->prorettype == TRIGGEROID)
                  {
!                     free_plperl_function(prodesc);
                      ereport(ERROR,
                              (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
                               errmsg("trigger functions can only be called "
*************** compile_plperl_function(Oid fn_oid, bool
*** 2534,2541 ****
                  }
                  else
                  {
!                     free(prodesc->proname);
!                     free(prodesc);
                      ereport(ERROR,
                              (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
                               errmsg("PL/Perl functions cannot return type %s",
--- 2575,2581 ----
                  }
                  else
                  {
!                     free_plperl_function(prodesc);
                      ereport(ERROR,
                              (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
                               errmsg("PL/Perl functions cannot return type %s",
*************** compile_plperl_function(Oid fn_oid, bool
*** 2570,2577 ****
                          ObjectIdGetDatum(procStruct->proargtypes.values[i]));
                  if (!HeapTupleIsValid(typeTup))
                  {
!                     free(prodesc->proname);
!                     free(prodesc);
                      elog(ERROR, "cache lookup failed for type %u",
                           procStruct->proargtypes.values[i]);
                  }
--- 2610,2616 ----
                          ObjectIdGetDatum(procStruct->proargtypes.values[i]));
                  if (!HeapTupleIsValid(typeTup))
                  {
!                     free_plperl_function(prodesc);
                      elog(ERROR, "cache lookup failed for type %u",
                           procStruct->proargtypes.values[i]);
                  }
*************** compile_plperl_function(Oid fn_oid, bool
*** 2581,2588 ****
                  if (typeStruct->typtype == TYPTYPE_PSEUDO &&
                      procStruct->proargtypes.values[i] != RECORDOID)
                  {
!                     free(prodesc->proname);
!                     free(prodesc);
                      ereport(ERROR,
                              (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
                               errmsg("PL/Perl functions cannot accept type %s",
--- 2620,2626 ----
                  if (typeStruct->typtype == TYPTYPE_PSEUDO &&
                      procStruct->proargtypes.values[i] != RECORDOID)
                  {
!                     free_plperl_function(prodesc);
                      ereport(ERROR,
                              (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
                               errmsg("PL/Perl functions cannot accept type %s",
*************** compile_plperl_function(Oid fn_oid, bool
*** 2635,2642 ****
          pfree(proc_source);
          if (!prodesc->reference)    /* can this happen? */
          {
!             free(prodesc->proname);
!             free(prodesc);
              elog(ERROR, "could not create PL/Perl internal procedure");
          }

--- 2673,2679 ----
          pfree(proc_source);
          if (!prodesc->reference)    /* can this happen? */
          {
!             free_plperl_function(prodesc);
              elog(ERROR, "could not create PL/Perl internal procedure");
          }

*************** compile_plperl_function(Oid fn_oid, bool
*** 2648,2653 ****
--- 2685,2691 ----
          proc_ptr = hash_search(plperl_proc_hash, &proc_key,
                                 HASH_ENTER, NULL);
          proc_ptr->proc_ptr = prodesc;
+         increment_prodesc_refcount(prodesc);
      }

      /* restore previous error callback */
diff --git a/src/pl/plperl/sql/plperl.sql b/src/pl/plperl/sql/plperl.sql
index a5e3840dac23667ff2d599c46b6e6887cc6875a8..ad361614c488fa7f04dbd10a6f4844f8cf506d1b 100644
*** a/src/pl/plperl/sql/plperl.sql
--- b/src/pl/plperl/sql/plperl.sql
*************** CREATE OR REPLACE FUNCTION text_scalarre
*** 462,464 ****
--- 462,474 ----
  $$ LANGUAGE plperl;

  SELECT text_scalarref();
+
+ -- check safe behavior when a function body is replaced during execution
+ CREATE OR REPLACE FUNCTION self_modify(INTEGER) RETURNS INTEGER AS $$
+    spi_exec_query('CREATE OR REPLACE FUNCTION self_modify(INTEGER) RETURNS INTEGER AS \'return $_[0] * 3;\' LANGUAGE
plperl;');
+    spi_exec_query('select self_modify(42) AS a');
+    return $_[0] * 2;
+ $$ LANGUAGE plperl;
+
+ SELECT self_modify(42);
+ SELECT self_modify(42);