]> granicus.if.org Git - postgresql/commitdiff
PL/Perl portability fix: avoid including XSUB.h in plperl.c.
authorTom Lane <tgl@sss.pgh.pa.us>
Fri, 28 Jul 2017 16:25:43 +0000 (12:25 -0400)
committerTom Lane <tgl@sss.pgh.pa.us>
Fri, 28 Jul 2017 16:25:43 +0000 (12:25 -0400)
In Perl builds that define PERL_IMPLICIT_SYS, XSUB.h defines macros
that replace a whole lot of basic libc functions with Perl functions.
We can't tolerate that in plperl.c; it breaks at least PG_TRY and
probably other stuff.  The core idea of this patch is to include XSUB.h
only in the .xs files where it's really needed, and to move any code
broken by PERL_IMPLICIT_SYS out of the .xs files and into plperl.c.

The reason this hasn't been a problem before is that our build techniques
did not result in PERL_IMPLICIT_SYS appearing as a #define in PL/Perl,
even on some platforms where Perl thinks it is defined.  That's about to
change in order to fix a nasty portability issue, so we need this work to
make the code safe for that.

Rather unaccountably, the Perl people chose XSUB.h as the place to provide
the versions of the aTHX/aTHX_ macros that are needed by code that's not
explicitly aware of the MULTIPLICITY API conventions.  Hence, just removing
XSUB.h from plperl.c fails miserably.  But we can work around that by
defining PERL_NO_GET_CONTEXT (which would make the relevant stanza of
XSUB.h a no-op anyway).  As explained in perlguts.pod, that means we need
to add a "dTHX" macro call in every C function that calls a Perl API
function.  In most of them we just add this at the top; but since the
macro fetches the current Perl interpreter pointer, more care is needed
in functions that switch the active interpreter.  Lack of the macro is
easily recognized since it results in bleats about "my_perl" not being
defined.

(A nice side benefit of this is that it significantly reduces the number
of fetches of the current interpreter pointer.  On my machine, plperl.so
gets more than 10% smaller, and there's probably some performance win too.
We could reduce the number of fetches still more by decorating the code
with pTHX_/aTHX_ macros to pass the interpreter pointer around, as
explained by perlguts.pod; but that's a task for another day.)

Formatting note: pgindent seems happy to treat "dTHX;" as a declaration
so long as it's the first thing after the left brace, as we'd already
observed with respect to the similar macro "dSP;".  If you try to put
it later in a set of declarations, pgindent puts ugly extra space
around it.

Having removed XSUB.h from plperl.c, we need only move the support
functions for spi_return_next and util_elog (both of which use PG_TRY)
out of the .xs files and into plperl.c.  This seems sufficient to
avoid the known problems caused by PERL_IMPLICIT_SYS, although we
could move more code if additional issues emerge.

This will need to be back-patched, but first let's see what the
buildfarm makes of it.

Patch by me, with some help from Ashutosh Sharma

Discussion: https://postgr.es/m/CANFyU97OVQ3+Mzfmt3MhuUm5NwPU=-FtbNH5Eb7nZL9ua8=rcA@mail.gmail.com

contrib/hstore_plperl/hstore_plperl.c
src/pl/plperl/SPI.xs
src/pl/plperl/Util.xs
src/pl/plperl/plperl.c
src/pl/plperl/plperl.h
src/pl/plperl/plperl_helpers.h

index 480212f341e247ffa4010cea29e83be4f3fe1545..cc46a525f6f7fc066d8fa0f54240087d6f4268d8 100644 (file)
@@ -67,6 +67,7 @@ PG_FUNCTION_INFO_V1(hstore_to_plperl);
 Datum
 hstore_to_plperl(PG_FUNCTION_ARGS)
 {
+       dTHX;
        HStore     *in = PG_GETARG_HS(0);
        int                     i;
        int                     count = HS_COUNT(in);
@@ -99,7 +100,8 @@ PG_FUNCTION_INFO_V1(plperl_to_hstore);
 Datum
 plperl_to_hstore(PG_FUNCTION_ARGS)
 {
-       HV                 *hv;
+       dTHX;
+       HV                 *hv = (HV *) SvRV((SV *) PG_GETARG_POINTER(0));
        HE                 *he;
        int32           buflen;
        int32           i;
@@ -107,8 +109,6 @@ plperl_to_hstore(PG_FUNCTION_ARGS)
        HStore     *out;
        Pairs      *pairs;
 
-       hv = (HV *) SvRV((SV *) PG_GETARG_POINTER(0));
-
        pcount = hv_iterinit(hv);
 
        pairs = palloc(pcount * sizeof(Pairs));
index 0447c50df19937a25cc8299f3edea3a52c4d5075..d9e6f579d419d73e8bd4b64bb7b836581329e375 100644 (file)
@@ -9,44 +9,16 @@
 
 /* this must be first: */
 #include "postgres.h"
-#include "mb/pg_wchar.h"       /* for GetDatabaseEncoding */
 
 /* Defined by Perl */
 #undef _
 
 /* perl stuff */
+#define PG_NEED_PERL_XSUB_H
 #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
@@ -76,7 +48,7 @@ void
 spi_return_next(rv)
        SV *rv;
        CODE:
-               do_plperl_return_next(rv);
+               plperl_return_next(rv);
 
 SV *
 spi_spi_query(sv)
index dbba0d7b8707695204025ff80ca2b479a8dfa3b6..686513d2e8dc2599d1dd5dcf0e1e49258524c90c 100644 (file)
 #include "fmgr.h"
 #include "utils/builtins.h"
 #include "utils/bytea.h"       /* for byteain & byteaout */
-#include "mb/pg_wchar.h"       /* for GetDatabaseEncoding */
+
 /* Defined by Perl */
 #undef _
 
 /* perl stuff */
+#define PG_NEED_PERL_XSUB_H
 #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)
@@ -105,7 +67,7 @@ util_elog(level, msg)
             level = ERROR;
         if (level < DEBUG5)
             level = DEBUG5;
-        do_util_elog(level, msg);
+        plperl_util_elog(level, msg);
 
 SV *
 util_quote_literal(sv)
index 5a45e3e0aa3aa02aaee6c3c1c5fb3a04741de2bb..b10b4434aa74033d7858dc76ad6da4d6c77035d5 100644 (file)
@@ -6,6 +6,7 @@
  **********************************************************************/
 
 #include "postgres.h"
+
 /* Defined by Perl */
 #undef _
 
@@ -285,6 +286,7 @@ static void plperl_init_shared_libs(pTHX);
 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);
@@ -302,12 +304,27 @@ static void activate_interpreter(plperl_interp_desc *interp_desc);
 static char *setlocale_perl(int category, char *locale);
 #endif
 
+/*
+ * Decrement the refcount of the given SV within the active Perl interpreter
+ *
+ * This is handy because it reloads the active-interpreter pointer, saving
+ * some notation in callers that switch the active 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;
 
@@ -641,15 +658,19 @@ select_perl_context(bool trusted)
         * 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__);
+       {
+               dTHX;
 
-       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")));
+               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;
@@ -792,53 +813,62 @@ 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' and 'dofile' opcodes.
-        * (They share the same implementation.) Ensure it's used for new
-        * interpreters.
+        * 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.
         */
-       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;
-       }
+               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;
+               /*
+                * 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_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")));
+               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);
+               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;
 }
@@ -904,6 +934,7 @@ plperl_destroy_interp(PerlInterpreter **interp)
                 * 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)
@@ -930,6 +961,7 @@ plperl_destroy_interp(PerlInterpreter **interp)
 static void
 plperl_trusted_init(void)
 {
+       dTHX;
        HV                 *stash;
        SV                 *sv;
        char       *key;
@@ -1010,6 +1042,8 @@ plperl_trusted_init(void)
 static void
 plperl_untrusted_init(void)
 {
+       dTHX;
+
        /*
         * Nothing to do except execute plperl.on_plperlu_init
         */
@@ -1045,6 +1079,7 @@ strip_trailing_ws(const char *msg)
 static HeapTuple
 plperl_build_tuple_result(HV *perlhash, TupleDesc td)
 {
+       dTHX;
        Datum      *values;
        bool       *nulls;
        HE                 *he;
@@ -1106,6 +1141,8 @@ plperl_hash_to_datum(SV *src, TupleDesc td)
 static SV  *
 get_perl_array_ref(SV *sv)
 {
+       dTHX;
+
        if (SvOK(sv) && SvROK(sv))
        {
                if (SvTYPE(SvRV(sv)) == SVt_PVAV)
@@ -1134,6 +1171,7 @@ array_to_datum_internal(AV *av, ArrayBuildState *astate,
                                                Oid arraytypid, Oid elemtypid, int32 typmod,
                                                FmgrInfo *finfo, Oid typioparam)
 {
+       dTHX;
        int                     i;
        int                     len = av_len(av) + 1;
 
@@ -1205,6 +1243,7 @@ array_to_datum_internal(AV *av, ArrayBuildState *astate,
 static Datum
 plperl_array_to_datum(SV *src, Oid typid, int32 typmod)
 {
+       dTHX;
        ArrayBuildState *astate;
        Oid                     elemtypid;
        FmgrInfo        finfo;
@@ -1407,6 +1446,7 @@ plperl_sv_to_literal(SV *sv, char *fqtypename)
 static SV  *
 plperl_ref_from_pg_array(Datum arg, Oid typid)
 {
+       dTHX;
        ArrayType  *ar = DatumGetArrayTypeP(arg);
        Oid                     elementtype = ARR_ELEMTYPE(ar);
        int16           typlen;
@@ -1485,6 +1525,7 @@ plperl_ref_from_pg_array(Datum arg, Oid typid)
 static SV  *
 split_array(plperl_array_info *info, int first, int last, int nest)
 {
+       dTHX;
        int                     i;
        AV                 *result;
 
@@ -1518,6 +1559,7 @@ split_array(plperl_array_info *info, int first, int last, int nest)
 static SV  *
 make_array_ref(plperl_array_info *info, int first, int last)
 {
+       dTHX;
        int                     i;
        AV                 *result = newAV();
 
@@ -1555,6 +1597,7 @@ make_array_ref(plperl_array_info *info, int first, int last)
 static SV  *
 plperl_trigger_build_args(FunctionCallInfo fcinfo)
 {
+       dTHX;
        TriggerData *tdata;
        TupleDesc       tupdesc;
        int                     i;
@@ -1661,6 +1704,7 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
 static SV  *
 plperl_event_trigger_build_args(FunctionCallInfo fcinfo)
 {
+       dTHX;
        EventTriggerData *tdata;
        HV                 *hv;
 
@@ -1678,6 +1722,7 @@ plperl_event_trigger_build_args(FunctionCallInfo fcinfo)
 static HeapTuple
 plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
 {
+       dTHX;
        SV                **svp;
        HV                 *hvNew;
        HE                 *he;
@@ -1874,7 +1919,7 @@ plperl_inline_handler(PG_FUNCTION_ARGS)
 
                perlret = plperl_call_perl_func(&desc, &fake_fcinfo);
 
-               SvREFCNT_dec(perlret);
+               SvREFCNT_dec_current(perlret);
 
                if (SPI_finish() != SPI_OK_FINISH)
                        elog(ERROR, "SPI_finish() failed");
@@ -1882,7 +1927,7 @@ plperl_inline_handler(PG_FUNCTION_ARGS)
        PG_CATCH();
        {
                if (desc.reference)
-                       SvREFCNT_dec(desc.reference);
+                       SvREFCNT_dec_current(desc.reference);
                current_call_data = save_call_data;
                activate_interpreter(oldinterp);
                PG_RE_THROW();
@@ -1890,7 +1935,7 @@ plperl_inline_handler(PG_FUNCTION_ARGS)
        PG_END_TRY();
 
        if (desc.reference)
-               SvREFCNT_dec(desc.reference);
+               SvREFCNT_dec_current(desc.reference);
 
        current_call_data = save_call_data;
        activate_interpreter(oldinterp);
@@ -2018,6 +2063,7 @@ plperlu_validator(PG_FUNCTION_ARGS)
 static void
 plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid)
 {
+       dTHX;
        dSP;
        char            subname[NAMEDATALEN + 40];
        HV                 *pragma_hv = newHV();
@@ -2104,6 +2150,7 @@ plperl_init_shared_libs(pTHX)
 static SV  *
 plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
 {
+       dTHX;
        dSP;
        SV                 *retval;
        int                     i;
@@ -2197,6 +2244,7 @@ static SV  *
 plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
                                                          SV *td)
 {
+       dTHX;
        dSP;
        SV                 *retval,
                           *TDsv;
@@ -2265,6 +2313,7 @@ plperl_call_perl_event_trigger_func(plperl_proc_desc *desc,
                                                                        FunctionCallInfo fcinfo,
                                                                        SV *td)
 {
+       dTHX;
        dSP;
        SV                 *retval,
                           *TDsv;
@@ -2384,13 +2433,14 @@ plperl_func_handler(PG_FUNCTION_ARGS)
                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(*svp);
+                               plperl_return_next_internal(*svp);
                                i++;
                        }
                }
@@ -2427,7 +2477,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
        /* Restore the previous error callback */
        error_context_stack = pl_error_context.previous;
 
-       SvREFCNT_dec(perlret);
+       SvREFCNT_dec_current(perlret);
 
        return retval;
 }
@@ -2538,9 +2588,9 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
        /* Restore the previous error callback */
        error_context_stack = pl_error_context.previous;
 
-       SvREFCNT_dec(svTD);
+       SvREFCNT_dec_current(svTD);
        if (perlret)
-               SvREFCNT_dec(perlret);
+               SvREFCNT_dec_current(perlret);
 
        return retval;
 }
@@ -2579,9 +2629,7 @@ plperl_event_trigger_handler(PG_FUNCTION_ARGS)
        /* Restore the previous error callback */
        error_context_stack = pl_error_context.previous;
 
-       SvREFCNT_dec(svTD);
-
-       return;
+       SvREFCNT_dec_current(svTD);
 }
 
 
@@ -2624,7 +2672,7 @@ free_plperl_function(plperl_proc_desc *prodesc)
                plperl_interp_desc *oldinterp = plperl_active_interp;
 
                activate_interpreter(prodesc->interp);
-               SvREFCNT_dec(prodesc->reference);
+               SvREFCNT_dec_current(prodesc->reference);
                activate_interpreter(oldinterp);
        }
        /* Release all PG-owned data for this proc */
@@ -2949,6 +2997,7 @@ plperl_hash_from_datum(Datum attr)
 static SV  *
 plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
 {
+       dTHX;
        HV                 *hv;
        int                     i;
 
@@ -3094,6 +3143,7 @@ static HV  *
 plperl_spi_execute_fetch_result(SPITupleTable *tuptable, uint64 processed,
                                                                int status)
 {
+       dTHX;
        HV                 *result;
 
        check_spi_usage_allowed();
@@ -3137,15 +3187,40 @@ plperl_spi_execute_fetch_result(SPITupleTable *tuptable, uint64 processed,
 
 
 /*
- * 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.
+ * 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;
@@ -3336,6 +3411,7 @@ plperl_spi_fetchrow(char *cursor)
 
        PG_TRY();
        {
+               dTHX;
                Portal          p = SPI_cursor_find(cursor);
 
                if (!p)
@@ -3577,6 +3653,8 @@ plperl_spi_exec_prepared(char *query, HV *attr, int argc, SV **argv)
 
        PG_TRY();
        {
+               dTHX;
+
                /************************************************************
                 * Fetch the saved plan descriptor, see if it's o.k.
                 ************************************************************/
@@ -3821,6 +3899,47 @@ plperl_spi_freeplan(char *query)
        SPI_freeplan(plan);
 }
 
+/*
+ * 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.
@@ -3828,6 +3947,7 @@ plperl_spi_freeplan(char *query)
 static SV **
 hv_store_string(HV *hv, const char *key, SV *val)
 {
+       dTHX;
        int32           hlen;
        char       *hkey;
        SV                **ret;
@@ -3854,6 +3974,7 @@ hv_store_string(HV *hv, const char *key, SV *val)
 static SV **
 hv_fetch_string(HV *hv, const char *key)
 {
+       dTHX;
        int32           hlen;
        char       *hkey;
        SV                **ret;
@@ -3912,6 +4033,7 @@ plperl_inline_callback(void *arg)
 static char *
 setlocale_perl(int category, char *locale)
 {
+       dTHX;
        char       *RETVAL = setlocale(category, locale);
 
        if (RETVAL)
@@ -3976,4 +4098,4 @@ setlocale_perl(int category, char *locale)
        return RETVAL;
 }
 
-#endif
+#endif                                                 /* WIN32 */
index eecd1928024d0195f65fd7dffb32efd397a0f4eb..c4e06d089f4118752c34a123ee9d13665f85c8b2 100644 (file)
@@ -24,7 +24,7 @@
 #ifdef isnan
 #undef isnan
 #endif
-#endif
+#endif                                                 /* WIN32 */
 
 /*
  * Supply a value of PERL_UNUSED_DECL that will satisfy gcc - the one
 #endif
 
 
-/* required for perl API */
+/*
+ * Get the basic Perl API.  We use PERL_NO_GET_CONTEXT mode so that our code
+ * can compile against MULTIPLICITY Perl builds without including XSUB.h.
+ */
+#define PERL_NO_GET_CONTEXT
 #include "EXTERN.h"
 #include "perl.h"
+
+/*
+ * We want to include XSUB.h only within .xs files, because on some platforms
+ * it undesirably redefines a lot of libc functions.  But it must appear
+ * before ppport.h, so use a #define flag to control inclusion here.
+ */
+#ifdef PG_NEED_PERL_XSUB_H
 #include "XSUB.h"
+#endif
 
 /* put back our snprintf and vsnprintf */
 #ifdef USE_REPL_SNPRINTF
@@ -106,5 +118,6 @@ SV             *plperl_spi_query_prepared(char *, int, SV **);
 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 */
index 76124edc07826869c41a2ea52864cbf1af90abbc..65b85a27aed261d18f2a67b6f6137c09df8c5f7e 100644 (file)
@@ -50,6 +50,7 @@ utf_e2u(const char *str)
 static inline char *
 sv2cstr(SV *sv)
 {
+       dTHX;
        char       *val,
                           *res;
        STRLEN          len;
@@ -107,6 +108,7 @@ sv2cstr(SV *sv)
 static inline SV *
 cstr2sv(const char *str)
 {
+       dTHX;
        SV                 *sv;
        char       *utf8_str;
 
@@ -134,6 +136,8 @@ cstr2sv(const char *str)
 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)));