PL/Perl portability fix: avoid including XSUB.h in plperl.c.

Back-patch of commit bebe174bb4462ef079a1d7eeafb82ff969f160a4,
which see for more info.

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

@@ -13,6 +13,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);
@@ -45,7 +46,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;
@@ -53,8 +55,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));

src/pl/plperl/SPI.xs

@@ -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)

src/pl/plperl/Util.xs

@@ -15,53 +15,15 @@
 #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)

src/pl/plperl/plperl.c

@@ -6,6 +6,7 @@
  **********************************************************************/
 
 #include "postgres.h"
+
 /* Defined by Perl */
 #undef _
 
@@ -282,6 +283,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 *, int, 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);
@@ -299,12 +301,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;
 
@@ -655,6 +672,9 @@ 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
 	 */
+	{
+		dTHX;
+
 		newXS("PostgreSQL::InServer::SPI::bootstrap",
 			  boot_PostgreSQL__InServer__SPI, __FILE__);
 
@@ -664,6 +684,7 @@ select_perl_context(bool trusted)
 					(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;
@@ -806,13 +827,20 @@ plperl_init_interp(void)
 	PERL_SET_CONTEXT(plperl);
 	perl_construct(plperl);
 
-	/* run END blocks in perl_destruct instead of perl_run */
+	/*
+	 * 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.
+		 * Record the original function for the 'require' and 'dofile'
-	 * (They share the same implementation.) Ensure it's used for new
+		 * opcodes.  (They share the same implementation.)  Ensure it's used
-	 * interpreters.
+		 * for new interpreters.
 		 */
 		if (!pp_require_orig)
 			pp_require_orig = PL_ppaddr[OP_REQUIRE];
@@ -825,10 +853,11 @@ plperl_init_interp(void)
 #ifdef PLPERL_ENABLE_OPMASK_EARLY
 
 		/*
-	 * For regression testing to prove that the PLC_PERLBOOT and PLC_TRUSTED
+		 * For regression testing to prove that the PLC_PERLBOOT and
-	 * code doesn't even compile any unsafe ops. In future there may be a
+		 * PLC_TRUSTED code doesn't even compile any unsafe ops.  In future
-	 * valid need for them to do so, in which case this could be softened
+		 * there may be a valid need for them to do so, in which case this
-	 * (perhaps moved to plperl_trusted_init()) or removed.
+		 * could be softened (perhaps moved to plperl_trusted_init()) or
+		 * removed.
 		 */
 		PL_op_mask = plperl_opmask;
 #endif
@@ -853,6 +882,7 @@ plperl_init_interp(void)
 		PLPERL_RESTORE_LOCALE(LC_NUMERIC, save_numeric);
 		PLPERL_RESTORE_LOCALE(LC_TIME, save_time);
 #endif
+	}
 
 	return plperl;
 }
@@ -918,6 +948,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)
@@ -944,6 +975,7 @@ plperl_destroy_interp(PerlInterpreter **interp)
 static void
 plperl_trusted_init(void)
 {
+	dTHX;
 	HV		   *stash;
 	SV		   *sv;
 	char	   *key;
@@ -1024,6 +1056,8 @@ plperl_trusted_init(void)
 static void
 plperl_untrusted_init(void)
 {
+	dTHX;
+
 	/*
 	 * Nothing to do except execute plperl.on_plperlu_init
 	 */
@@ -1059,6 +1093,7 @@ strip_trailing_ws(const char *msg)
 static HeapTuple
 plperl_build_tuple_result(HV *perlhash, TupleDesc td)
 {
+	dTHX;
 	Datum	   *values;
 	bool	   *nulls;
 	HE		   *he;
@@ -1115,6 +1150,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)
@@ -1143,6 +1180,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;
 
@@ -1214,6 +1252,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;
@@ -1416,6 +1455,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;
@@ -1484,6 +1524,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;
 
@@ -1517,6 +1558,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();
 
@@ -1554,6 +1596,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;
@@ -1660,6 +1703,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;
@@ -1879,7 +1924,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");
@@ -1887,7 +1932,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();
@@ -1895,7 +1940,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);
@@ -2023,6 +2068,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();
@@ -2109,6 +2155,7 @@ plperl_init_shared_libs(pTHX)
 static SV  *
 plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
 {
+	dTHX;
 	dSP;
 	SV		   *retval;
 	int			i;
@@ -2202,6 +2249,7 @@ static SV  *
 plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
 							  SV *td)
 {
+	dTHX;
 	dSP;
 	SV		   *retval,
 			   *TDsv;
@@ -2270,6 +2318,7 @@ plperl_call_perl_event_trigger_func(plperl_proc_desc *desc,
 									FunctionCallInfo fcinfo,
 									SV *td)
 {
+	dTHX;
 	dSP;
 	SV		   *retval,
 			   *TDsv;
@@ -2389,13 +2438,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++;
 			}
 		}
@@ -2432,7 +2482,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;
 }
@@ -2536,9 +2586,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;
 }
@@ -2577,9 +2627,7 @@ plperl_event_trigger_handler(PG_FUNCTION_ARGS)
 	/* Restore the previous error callback */
 	error_context_stack = pl_error_context.previous;
 
-	SvREFCNT_dec(svTD);
+	SvREFCNT_dec_current(svTD);
-
-	return;
 }
 
 
@@ -2622,7 +2670,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);
 	}
 	/* Get rid of what we conveniently can of our own structs */
@@ -2936,6 +2984,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, int processed,
 								int status)
 {
+	dTHX;
 	HV		   *result;
 
 	check_spi_usage_allowed();
@@ -3129,15 +3179,40 @@ plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
 
 
 /*
- * Note: plperl_return_next is called both in Postgres and Perl contexts.
+ * plperl_return_next catches any error and converts it to a Perl error.
- * We report any errors in Postgres fashion (via ereport).  If called in
+ * We assume (perhaps without adequate justification) that we need not abort
- * Perl context, it is SPI.xs's responsibility to catch the error and
+ * the current transaction if the Perl code traps the error.
- * 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)
+{
+	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;
@@ -3343,6 +3418,7 @@ plperl_spi_fetchrow(char *cursor)
 
 	PG_TRY();
 	{
+		dTHX;
 		Portal		p = SPI_cursor_find(cursor);
 
 		if (!p)
@@ -3614,6 +3690,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.
 		 ************************************************************/
@@ -3884,6 +3962,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.
@@ -3891,6 +4010,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;
@@ -3919,6 +4039,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;
@@ -3977,6 +4098,7 @@ plperl_inline_callback(void *arg)
 static char *
 setlocale_perl(int category, char *locale)
 {
+	dTHX;
 	char	   *RETVAL = setlocale(category, locale);
 
 	if (RETVAL)
@@ -4041,4 +4163,4 @@ setlocale_perl(int category, char *locale)
 	return RETVAL;
 }
 
-#endif
+#endif							/* WIN32 */

src/pl/plperl/plperl.h

@@ -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
@@ -43,10 +43,22 @@
 #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
@@ -99,5 +111,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 */

src/pl/plperl/plperl_helpers.h

@@ -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)));