Re: [HACKERS] pl/perl extension fails on Windows

Andrew Dunstan <andrew.dunstan@2ndquadrant.com> writes:
> On 07/27/2017 04:33 PM, Tom Lane wrote:
>> So I was trying to figure a way to not include XSUB.h except in a very
>> limited part of plperl, like ideally just the .xs files.  It's looking
>> like that would take nontrivial refactoring though :-(.  Another problem
>> is that this critical bit of the library API is in XSUB.h:

> That's the sort of thing that prompted me to ask what was the minimal
> set of defines required to fix the original problem (assuming such a
> thing exists)
> We haven't used PERL_IMPLICIT_CONTEXT to date, and without ill effect.
> For example. it's in the ExtUtils::Embed::ccopts for the perl that
> jacana and bowerbird happily build and test against.

Well, actually, PERL_IMPLICIT_CONTEXT is turned on automatically in any
MULTIPLICITY build, and since it changes all the Perl ABIs, we *are*
relying on it.  However, after further study of the Perl docs I noticed
that we could dispense with XSUB.h if we defined PERL_NO_GET_CONTEXT
(which turns the quoted stanza into a no-op).  That results in needing to
sprinkle plperl.c with "dTHX" declarations, as explained in perlguts.pod.
They're slightly tricky to place correctly, because they load up a pointer
to the current Perl interpreter, so you have to be wary of where to put
them in functions that change interpreters.  But I seem to have it working
in the attached patch.  (One benefit of doing this extra work is that it
should be a bit more efficient, in that we load up a Perl interpreter
pointer only once per function called, not once per usage therein.  We
could remove many of those fetches too, if we wanted to sprinkle the
plperl code with yet more THX droppings; but I left that for another day.)

Armed with that, I got rid of XSUB.h in plperl.c and moved the
PG_TRY-using functions in the .xs files to plperl.c.  I think this would
fix Ashutosh's problem, though I am not in a position to try it with a
PERL_IMPLICIT_SYS build here.

            regards, tom lane

diff --git a/src/pl/plperl/SPI.xs b/src/pl/plperl/SPI.xs
index 0447c50..7651b62 100644
*** a/src/pl/plperl/SPI.xs
--- b/src/pl/plperl/SPI.xs
***************
*** 15,52 ****
  #undef _

  /* perl stuff */
  #include "plperl.h"
  #include "plperl_helpers.h"


- /*
-  * Interface routine to catch ereports and punt them to Perl
-  */
- static void
- do_plperl_return_next(SV *sv)
- {
-     MemoryContext oldcontext = CurrentMemoryContext;
-
-     PG_TRY();
-     {
-         plperl_return_next(sv);
-     }
-     PG_CATCH();
-     {
-         ErrorData  *edata;
-
-         /* Must reset elog.c's state */
-         MemoryContextSwitchTo(oldcontext);
-         edata = CopyErrorData();
-         FlushErrorState();
-
-         /* Punt the error to Perl */
-         croak_cstr(edata->message);
-     }
-     PG_END_TRY();
- }
-
-
  MODULE = PostgreSQL::InServer::SPI PREFIX = spi_

  PROTOTYPES: ENABLE
--- 15,25 ----
  #undef _

  /* perl stuff */
+ #define PG_NEED_PERL_XSUB_H
  #include "plperl.h"
  #include "plperl_helpers.h"


  MODULE = PostgreSQL::InServer::SPI PREFIX = spi_

  PROTOTYPES: ENABLE
*************** void
*** 76,82 ****
  spi_return_next(rv)
      SV *rv;
      CODE:
!         do_plperl_return_next(rv);

  SV *
  spi_spi_query(sv)
--- 49,55 ----
  spi_return_next(rv)
      SV *rv;
      CODE:
!         plperl_return_next(rv);

  SV *
  spi_spi_query(sv)
diff --git a/src/pl/plperl/Util.xs b/src/pl/plperl/Util.xs
index dbba0d7..862fec4 100644
*** a/src/pl/plperl/Util.xs
--- b/src/pl/plperl/Util.xs
***************
*** 20,67 ****
  #undef _

  /* perl stuff */
  #include "plperl.h"
  #include "plperl_helpers.h"

- /*
-  * Implementation of plperl's elog() function
-  *
-  * If the error level is less than ERROR, we'll just emit the message and
-  * return.  When it is ERROR, elog() will longjmp, which we catch and
-  * turn into a Perl croak().  Note we are assuming that elog() can't have
-  * any internal failures that are so bad as to require a transaction abort.
-  *
-  * This is out-of-line to suppress "might be clobbered by longjmp" warnings.
-  */
- static void
- do_util_elog(int level, SV *msg)
- {
-     MemoryContext oldcontext = CurrentMemoryContext;
-     char       * volatile cmsg = NULL;
-
-     PG_TRY();
-     {
-         cmsg = sv2cstr(msg);
-         elog(level, "%s", cmsg);
-         pfree(cmsg);
-     }
-     PG_CATCH();
-     {
-         ErrorData  *edata;
-
-         /* Must reset elog.c's state */
-         MemoryContextSwitchTo(oldcontext);
-         edata = CopyErrorData();
-         FlushErrorState();
-
-         if (cmsg)
-             pfree(cmsg);
-
-         /* Punt the error to Perl */
-         croak_cstr(edata->message);
-     }
-     PG_END_TRY();
- }

  static text *
  sv2text(SV *sv)
--- 20,29 ----
  #undef _

  /* perl stuff */
+ #define PG_NEED_PERL_XSUB_H
  #include "plperl.h"
  #include "plperl_helpers.h"


  static text *
  sv2text(SV *sv)
*************** util_elog(level, msg)
*** 105,111 ****
              level = ERROR;
          if (level < DEBUG5)
              level = DEBUG5;
!         do_util_elog(level, msg);

  SV *
  util_quote_literal(sv)
--- 67,73 ----
              level = ERROR;
          if (level < DEBUG5)
              level = DEBUG5;
!         plperl_util_elog(level, msg);

  SV *
  util_quote_literal(sv)
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index 5a45e3e..9a26470 100644
*** a/src/pl/plperl/plperl.c
--- b/src/pl/plperl/plperl.c
*************** static void plperl_init_shared_libs(pTHX
*** 285,290 ****
--- 285,291 ----
  static void plperl_trusted_init(void);
  static void plperl_untrusted_init(void);
  static HV  *plperl_spi_execute_fetch_result(SPITupleTable *, uint64, int);
+ static void plperl_return_next_internal(SV *sv);
  static char *hek2cstr(HE *he);
  static SV **hv_store_string(HV *hv, const char *key, SV *val);
  static SV **hv_fetch_string(HV *hv, const char *key);
*************** static char *setlocale_perl(int category
*** 303,313 ****
--- 304,326 ----
  #endif

  /*
+  * Decrement the refcount of the given SV within the active Perl interpreter
+  */
+ static inline void
+ SvREFCNT_dec_current(SV *sv)
+ {
+     dTHX;
+
+     SvREFCNT_dec(sv);
+ }
+
+ /*
   * convert a HE (hash entry) key to a cstr in the current database encoding
   */
  static char *
  hek2cstr(HE *he)
  {
+     dTHX;
      char       *ret;
      SV           *sv;

*************** select_perl_context(bool trusted)
*** 641,655 ****
       * to the database AFTER on_*_init code has run. See
       * http://archives.postgresql.org/pgsql-hackers/2010-01/msg02669.php
       */
!     newXS("PostgreSQL::InServer::SPI::bootstrap",
!           boot_PostgreSQL__InServer__SPI, __FILE__);

!     eval_pv("PostgreSQL::InServer::SPI::bootstrap()", FALSE);
!     if (SvTRUE(ERRSV))
!         ereport(ERROR,
!                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
!                  errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
!                  errcontext("while executing PostgreSQL::InServer::SPI::bootstrap")));

      /* Fully initialized, so mark the hashtable entry valid */
      interp_desc->interp = interp;
--- 654,672 ----
       * to the database AFTER on_*_init code has run. See
       * http://archives.postgresql.org/pgsql-hackers/2010-01/msg02669.php
       */
!     {
!         dTHX;

!         newXS("PostgreSQL::InServer::SPI::bootstrap",
!               boot_PostgreSQL__InServer__SPI, __FILE__);
!
!         eval_pv("PostgreSQL::InServer::SPI::bootstrap()", FALSE);
!         if (SvTRUE(ERRSV))
!             ereport(ERROR,
!                     (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
!                      errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
!                      errcontext("while executing PostgreSQL::InServer::SPI::bootstrap")));
!     }

      /* Fully initialized, so mark the hashtable entry valid */
      interp_desc->interp = interp;
*************** plperl_init_interp(void)
*** 792,844 ****
      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' and 'dofile' opcodes.
!      * (They share the same implementation.) Ensure it's used for new
!      * interpreters.
       */
-     if (!pp_require_orig)
-         pp_require_orig = PL_ppaddr[OP_REQUIRE];
-     else
      {
!         PL_ppaddr[OP_REQUIRE] = pp_require_orig;
!         PL_ppaddr[OP_DOFILE] = pp_require_orig;
!     }

  #ifdef PLPERL_ENABLE_OPMASK_EARLY

!     /*
!      * For regression testing to prove that the PLC_PERLBOOT and PLC_TRUSTED
!      * code doesn't even compile any unsafe ops. In future there may be a
!      * valid need for them to do so, in which case this could be softened
!      * (perhaps moved to plperl_trusted_init()) or removed.
!      */
!     PL_op_mask = plperl_opmask;
  #endif

!     if (perl_parse(plperl, plperl_init_shared_libs,
!                    nargs, embedding, NULL) != 0)
!         ereport(ERROR,
!                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
!                  errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
!                  errcontext("while parsing Perl initialization")));

!     if (perl_run(plperl) != 0)
!         ereport(ERROR,
!                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
!                  errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
!                  errcontext("while running Perl initialization")));

  #ifdef PLPERL_RESTORE_LOCALE
!     PLPERL_RESTORE_LOCALE(LC_COLLATE, save_collate);
!     PLPERL_RESTORE_LOCALE(LC_CTYPE, save_ctype);
!     PLPERL_RESTORE_LOCALE(LC_MONETARY, save_monetary);
!     PLPERL_RESTORE_LOCALE(LC_NUMERIC, save_numeric);
!     PLPERL_RESTORE_LOCALE(LC_TIME, save_time);
  #endif

      return plperl;
  }
--- 809,870 ----
      PERL_SET_CONTEXT(plperl);
      perl_construct(plperl);

      /*
!      * Run END blocks in perl_destruct instead of perl_run.  Note that dTHX
!      * loads up a pointer to the current interpreter, so we have to postpone
!      * it to here rather than put it at the function head.
       */
      {
!         dTHX;
!
!         PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
!
!         /*
!          * Record the original function for the 'require' and 'dofile'
!          * opcodes.  (They share the same implementation.)  Ensure it's used
!          * for new interpreters.
!          */
!         if (!pp_require_orig)
!             pp_require_orig = PL_ppaddr[OP_REQUIRE];
!         else
!         {
!             PL_ppaddr[OP_REQUIRE] = pp_require_orig;
!             PL_ppaddr[OP_DOFILE] = pp_require_orig;
!         }

  #ifdef PLPERL_ENABLE_OPMASK_EARLY

!         /*
!          * For regression testing to prove that the PLC_PERLBOOT and
!          * PLC_TRUSTED code doesn't even compile any unsafe ops.  In future
!          * there may be a valid need for them to do so, in which case this
!          * could be softened (perhaps moved to plperl_trusted_init()) or
!          * removed.
!          */
!         PL_op_mask = plperl_opmask;
  #endif

!         if (perl_parse(plperl, plperl_init_shared_libs,
!                        nargs, embedding, NULL) != 0)
!             ereport(ERROR,
!                     (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
!                      errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
!                      errcontext("while parsing Perl initialization")));

!         if (perl_run(plperl) != 0)
!             ereport(ERROR,
!                     (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
!                      errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
!                      errcontext("while running Perl initialization")));

  #ifdef PLPERL_RESTORE_LOCALE
!         PLPERL_RESTORE_LOCALE(LC_COLLATE, save_collate);
!         PLPERL_RESTORE_LOCALE(LC_CTYPE, save_ctype);
!         PLPERL_RESTORE_LOCALE(LC_MONETARY, save_monetary);
!         PLPERL_RESTORE_LOCALE(LC_NUMERIC, save_numeric);
!         PLPERL_RESTORE_LOCALE(LC_TIME, save_time);
  #endif
+     }

      return plperl;
  }
*************** plperl_destroy_interp(PerlInterpreter **
*** 904,909 ****
--- 930,936 ----
           * public API so isn't portably available.) Meanwhile END blocks can
           * be used to perform manual cleanup.
           */
+         dTHX;

          /* Run END blocks - based on perl's perl_destruct() */
          if (PL_exit_flags & PERL_EXIT_DESTRUCT_END)
*************** plperl_destroy_interp(PerlInterpreter **
*** 930,935 ****
--- 957,963 ----
  static void
  plperl_trusted_init(void)
  {
+     dTHX;
      HV           *stash;
      SV           *sv;
      char       *key;
*************** plperl_trusted_init(void)
*** 1010,1015 ****
--- 1038,1045 ----
  static void
  plperl_untrusted_init(void)
  {
+     dTHX;
+
      /*
       * Nothing to do except execute plperl.on_plperlu_init
       */
*************** strip_trailing_ws(const char *msg)
*** 1045,1050 ****
--- 1075,1081 ----
  static HeapTuple
  plperl_build_tuple_result(HV *perlhash, TupleDesc td)
  {
+     dTHX;
      Datum       *values;
      bool       *nulls;
      HE           *he;
*************** plperl_hash_to_datum(SV *src, TupleDesc
*** 1106,1111 ****
--- 1137,1144 ----
  static SV  *
  get_perl_array_ref(SV *sv)
  {
+     dTHX;
+
      if (SvOK(sv) && SvROK(sv))
      {
          if (SvTYPE(SvRV(sv)) == SVt_PVAV)
*************** array_to_datum_internal(AV *av, ArrayBui
*** 1134,1139 ****
--- 1167,1173 ----
                          Oid arraytypid, Oid elemtypid, int32 typmod,
                          FmgrInfo *finfo, Oid typioparam)
  {
+     dTHX;
      int            i;
      int            len = av_len(av) + 1;

*************** array_to_datum_internal(AV *av, ArrayBui
*** 1205,1210 ****
--- 1239,1245 ----
  static Datum
  plperl_array_to_datum(SV *src, Oid typid, int32 typmod)
  {
+     dTHX;
      ArrayBuildState *astate;
      Oid            elemtypid;
      FmgrInfo    finfo;
*************** plperl_sv_to_literal(SV *sv, char *fqtyp
*** 1407,1412 ****
--- 1442,1448 ----
  static SV  *
  plperl_ref_from_pg_array(Datum arg, Oid typid)
  {
+     dTHX;
      ArrayType  *ar = DatumGetArrayTypeP(arg);
      Oid            elementtype = ARR_ELEMTYPE(ar);
      int16        typlen;
*************** plperl_ref_from_pg_array(Datum arg, Oid
*** 1485,1490 ****
--- 1521,1527 ----
  static SV  *
  split_array(plperl_array_info *info, int first, int last, int nest)
  {
+     dTHX;
      int            i;
      AV           *result;

*************** split_array(plperl_array_info *info, int
*** 1518,1523 ****
--- 1555,1561 ----
  static SV  *
  make_array_ref(plperl_array_info *info, int first, int last)
  {
+     dTHX;
      int            i;
      AV           *result = newAV();

*************** make_array_ref(plperl_array_info *info,
*** 1555,1560 ****
--- 1593,1599 ----
  static SV  *
  plperl_trigger_build_args(FunctionCallInfo fcinfo)
  {
+     dTHX;
      TriggerData *tdata;
      TupleDesc    tupdesc;
      int            i;
*************** plperl_trigger_build_args(FunctionCallIn
*** 1661,1666 ****
--- 1700,1706 ----
  static SV  *
  plperl_event_trigger_build_args(FunctionCallInfo fcinfo)
  {
+     dTHX;
      EventTriggerData *tdata;
      HV           *hv;

*************** plperl_event_trigger_build_args(Function
*** 1678,1683 ****
--- 1718,1724 ----
  static HeapTuple
  plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
  {
+     dTHX;
      SV          **svp;
      HV           *hvNew;
      HE           *he;
*************** plperl_inline_handler(PG_FUNCTION_ARGS)
*** 1874,1880 ****

          perlret = plperl_call_perl_func(&desc, &fake_fcinfo);

!         SvREFCNT_dec(perlret);

          if (SPI_finish() != SPI_OK_FINISH)
              elog(ERROR, "SPI_finish() failed");
--- 1915,1921 ----

          perlret = plperl_call_perl_func(&desc, &fake_fcinfo);

!         SvREFCNT_dec_current(perlret);

          if (SPI_finish() != SPI_OK_FINISH)
              elog(ERROR, "SPI_finish() failed");
*************** plperl_inline_handler(PG_FUNCTION_ARGS)
*** 1882,1888 ****
      PG_CATCH();
      {
          if (desc.reference)
!             SvREFCNT_dec(desc.reference);
          current_call_data = save_call_data;
          activate_interpreter(oldinterp);
          PG_RE_THROW();
--- 1923,1929 ----
      PG_CATCH();
      {
          if (desc.reference)
!             SvREFCNT_dec_current(desc.reference);
          current_call_data = save_call_data;
          activate_interpreter(oldinterp);
          PG_RE_THROW();
*************** plperl_inline_handler(PG_FUNCTION_ARGS)
*** 1890,1896 ****
      PG_END_TRY();

      if (desc.reference)
!         SvREFCNT_dec(desc.reference);

      current_call_data = save_call_data;
      activate_interpreter(oldinterp);
--- 1931,1937 ----
      PG_END_TRY();

      if (desc.reference)
!         SvREFCNT_dec_current(desc.reference);

      current_call_data = save_call_data;
      activate_interpreter(oldinterp);
*************** plperlu_validator(PG_FUNCTION_ARGS)
*** 2018,2023 ****
--- 2059,2065 ----
  static void
  plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid)
  {
+     dTHX;
      dSP;
      char        subname[NAMEDATALEN + 40];
      HV           *pragma_hv = newHV();
*************** plperl_init_shared_libs(pTHX)
*** 2104,2109 ****
--- 2146,2152 ----
  static SV  *
  plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
  {
+     dTHX;
      dSP;
      SV           *retval;
      int            i;
*************** static SV  *
*** 2197,2202 ****
--- 2240,2246 ----
  plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
                                SV *td)
  {
+     dTHX;
      dSP;
      SV           *retval,
                 *TDsv;
*************** plperl_call_perl_event_trigger_func(plpe
*** 2265,2270 ****
--- 2309,2315 ----
                                      FunctionCallInfo fcinfo,
                                      SV *td)
  {
+     dTHX;
      dSP;
      SV           *retval,
                 *TDsv;
*************** plperl_func_handler(PG_FUNCTION_ARGS)
*** 2384,2396 ****
          sav = get_perl_array_ref(perlret);
          if (sav)
          {
              int            i = 0;
              SV          **svp = 0;
              AV           *rav = (AV *) SvRV(sav);

              while ((svp = av_fetch(rav, i, FALSE)) != NULL)
              {
!                 plperl_return_next(*svp);
                  i++;
              }
          }
--- 2429,2442 ----
          sav = get_perl_array_ref(perlret);
          if (sav)
          {
+             dTHX;
              int            i = 0;
              SV          **svp = 0;
              AV           *rav = (AV *) SvRV(sav);

              while ((svp = av_fetch(rav, i, FALSE)) != NULL)
              {
!                 plperl_return_next_internal(*svp);
                  i++;
              }
          }
*************** plperl_func_handler(PG_FUNCTION_ARGS)
*** 2427,2433 ****
      /* Restore the previous error callback */
      error_context_stack = pl_error_context.previous;

!     SvREFCNT_dec(perlret);

      return retval;
  }
--- 2473,2479 ----
      /* Restore the previous error callback */
      error_context_stack = pl_error_context.previous;

!     SvREFCNT_dec_current(perlret);

      return retval;
  }
*************** plperl_trigger_handler(PG_FUNCTION_ARGS)
*** 2538,2546 ****
      /* Restore the previous error callback */
      error_context_stack = pl_error_context.previous;

!     SvREFCNT_dec(svTD);
      if (perlret)
!         SvREFCNT_dec(perlret);

      return retval;
  }
--- 2584,2592 ----
      /* Restore the previous error callback */
      error_context_stack = pl_error_context.previous;

!     SvREFCNT_dec_current(svTD);
      if (perlret)
!         SvREFCNT_dec_current(perlret);

      return retval;
  }
*************** plperl_event_trigger_handler(PG_FUNCTION
*** 2579,2587 ****
      /* Restore the previous error callback */
      error_context_stack = pl_error_context.previous;

!     SvREFCNT_dec(svTD);
!
!     return;
  }


--- 2625,2631 ----
      /* Restore the previous error callback */
      error_context_stack = pl_error_context.previous;

!     SvREFCNT_dec_current(svTD);
  }


*************** free_plperl_function(plperl_proc_desc *p
*** 2624,2630 ****
          plperl_interp_desc *oldinterp = plperl_active_interp;

          activate_interpreter(prodesc->interp);
!         SvREFCNT_dec(prodesc->reference);
          activate_interpreter(oldinterp);
      }
      /* Release all PG-owned data for this proc */
--- 2668,2674 ----
          plperl_interp_desc *oldinterp = plperl_active_interp;

          activate_interpreter(prodesc->interp);
!         SvREFCNT_dec_current(prodesc->reference);
          activate_interpreter(oldinterp);
      }
      /* Release all PG-owned data for this proc */
*************** plperl_hash_from_datum(Datum attr)
*** 2949,2954 ****
--- 2993,2999 ----
  static SV  *
  plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
  {
+     dTHX;
      HV           *hv;
      int            i;

*************** static HV  *
*** 3094,3099 ****
--- 3139,3145 ----
  plperl_spi_execute_fetch_result(SPITupleTable *tuptable, uint64 processed,
                                  int status)
  {
+     dTHX;
      HV           *result;

      check_spi_usage_allowed();
*************** plperl_spi_execute_fetch_result(SPITuple
*** 3137,3152 ****


  /*
!  * Note: plperl_return_next is called both in Postgres and Perl contexts.
!  * We report any errors in Postgres fashion (via ereport).  If called in
!  * Perl context, it is SPI.xs's responsibility to catch the error and
!  * convert to a Perl error.  We assume (perhaps without adequate justification)
!  * that we need not abort the current transaction if the Perl code traps the
!  * error.
   */
  void
  plperl_return_next(SV *sv)
  {
      plperl_proc_desc *prodesc;
      FunctionCallInfo fcinfo;
      ReturnSetInfo *rsi;
--- 3183,3223 ----


  /*
!  * plperl_return_next catches any error and converts it to a Perl error.
!  * We assume (perhaps without adequate justification) that we need not abort
!  * the current transaction if the Perl code traps the error.
   */
  void
  plperl_return_next(SV *sv)
  {
+     MemoryContext oldcontext = CurrentMemoryContext;
+
+     PG_TRY();
+     {
+         plperl_return_next_internal(sv);
+     }
+     PG_CATCH();
+     {
+         ErrorData  *edata;
+
+         /* Must reset elog.c's state */
+         MemoryContextSwitchTo(oldcontext);
+         edata = CopyErrorData();
+         FlushErrorState();
+
+         /* Punt the error to Perl */
+         croak_cstr(edata->message);
+     }
+     PG_END_TRY();
+ }
+
+ /*
+  * plperl_return_next_internal reports any errors in Postgres fashion
+  * (via ereport).
+  */
+ static void
+ plperl_return_next_internal(SV *sv)
+ {
      plperl_proc_desc *prodesc;
      FunctionCallInfo fcinfo;
      ReturnSetInfo *rsi;
*************** plperl_spi_fetchrow(char *cursor)
*** 3336,3341 ****
--- 3407,3413 ----

      PG_TRY();
      {
+         dTHX;
          Portal        p = SPI_cursor_find(cursor);

          if (!p)
*************** plperl_spi_exec_prepared(char *query, HV
*** 3577,3582 ****
--- 3649,3656 ----

      PG_TRY();
      {
+         dTHX;
+
          /************************************************************
           * Fetch the saved plan descriptor, see if it's o.k.
           ************************************************************/
*************** plperl_spi_freeplan(char *query)
*** 3822,3833 ****
--- 3896,3949 ----
  }

  /*
+  * Implementation of plperl's elog() function
+  *
+  * If the error level is less than ERROR, we'll just emit the message and
+  * return.  When it is ERROR, elog() will longjmp, which we catch and
+  * turn into a Perl croak().  Note we are assuming that elog() can't have
+  * any internal failures that are so bad as to require a transaction abort.
+  *
+  * The main reason this is out-of-line is to avoid conflicts between XSUB.h
+  * and the PG_TRY macros.
+  */
+ void
+ plperl_util_elog(int level, SV *msg)
+ {
+     MemoryContext oldcontext = CurrentMemoryContext;
+     char       *volatile cmsg = NULL;
+
+     PG_TRY();
+     {
+         cmsg = sv2cstr(msg);
+         elog(level, "%s", cmsg);
+         pfree(cmsg);
+     }
+     PG_CATCH();
+     {
+         ErrorData  *edata;
+
+         /* Must reset elog.c's state */
+         MemoryContextSwitchTo(oldcontext);
+         edata = CopyErrorData();
+         FlushErrorState();
+
+         if (cmsg)
+             pfree(cmsg);
+
+         /* Punt the error to Perl */
+         croak_cstr(edata->message);
+     }
+     PG_END_TRY();
+ }
+
+ /*
   * Store an SV into a hash table under a key that is a string assumed to be
   * in the current database's encoding.
   */
  static SV **
  hv_store_string(HV *hv, const char *key, SV *val)
  {
+     dTHX;
      int32        hlen;
      char       *hkey;
      SV          **ret;
*************** hv_store_string(HV *hv, const char *key,
*** 3854,3859 ****
--- 3970,3976 ----
  static SV **
  hv_fetch_string(HV *hv, const char *key)
  {
+     dTHX;
      int32        hlen;
      char       *hkey;
      SV          **ret;
diff --git a/src/pl/plperl/plperl.h b/src/pl/plperl/plperl.h
index eecd192..3f3cce9 100644
*** a/src/pl/plperl/plperl.h
--- b/src/pl/plperl/plperl.h
***************
*** 44,52 ****
--- 44,60 ----


  /* required for perl API */
+ #define PERL_NO_GET_CONTEXT
  #include "EXTERN.h"
  #include "perl.h"
+
+ /*
+  * We want to include this only within .xs files, but it must come before
+  * ppport.h, so use a #define flag to control inclusion.
+  */
+ #ifdef PG_NEED_PERL_XSUB_H
  #include "XSUB.h"
+ #endif

  /* put back our snprintf and vsnprintf */
  #ifdef USE_REPL_SNPRINTF
*************** SV           *plperl_spi_query_prepared(char *
*** 106,110 ****
--- 114,119 ----
  void        plperl_spi_freeplan(char *);
  void        plperl_spi_cursor_close(char *);
  char       *plperl_sv_to_literal(SV *, char *);
+ void        plperl_util_elog(int level, SV *msg);

  #endif                            /* PL_PERL_H */
diff --git a/src/pl/plperl/plperl_helpers.h b/src/pl/plperl/plperl_helpers.h
index 76124ed..5acac60 100644
*** a/src/pl/plperl/plperl_helpers.h
--- b/src/pl/plperl/plperl_helpers.h
*************** sv2cstr(SV *sv)
*** 54,59 ****
--- 54,61 ----
                 *res;
      STRLEN        len;

+     dTHX;
+
      /*
       * get a utf8 encoded char * out of perl. *note* it may not be valid utf8!
       */
*************** cstr2sv(const char *str)
*** 110,115 ****
--- 112,119 ----
      SV           *sv;
      char       *utf8_str;

+     dTHX;
+
      /* no conversion when SQL_ASCII */
      if (GetDatabaseEncoding() == PG_SQL_ASCII)
          return newSVpv(str, 0);
*************** cstr2sv(const char *str)
*** 134,139 ****
--- 138,145 ----
  static inline void
  croak_cstr(const char *str)
  {
+     dTHX;
+
  #ifdef croak_sv
      /* Use sv_2mortal() to be sure the transient SV gets freed */
      croak_sv(sv_2mortal(cstr2sv(str)));

-- 
Sent via pgsql-hackers mailing list (pgsql-hackers@postgresql.org)
To make changes to your subscription:
http://www.postgresql.org/mailpref/pgsql-hackers