Tidy up and refactor plperl.c.

- Changed MULTIPLICITY check from runtime to compiletime.
    No loads the large Config module.
- Changed plperl_init_interp() to return new interp
    and not alter the global interp_state
- Moved plperl_safe_init() call into check_interp().
- Removed plperl_safe_init_done state variable
    as interp_state now covers that role.
- Changed plperl_create_sub() to take a plperl_proc_desc argument.
- Simplified return value handling in plperl_create_sub.
- Changed perl.com link in the docs to perl.org and tweaked
    wording to clarify that require, not use, is what's blocked.
- Moved perl code in large multi-line C string literal macros
    out to plc_*.pl files.
- Added a test2macro.pl utility to convert the plc_*.pl files to
    macros in a perlchunks.h file which is #included
- Simplifed plperl_safe_init() slightly
- Optimized pg_verifymbstr calls to avoid unneeded strlen()s.

Patch from Tim Bunce, with minor editing from me.

doc/src/sgml/plperl.sgml

@@ -1,4 +1,4 @@
-<!-- $PostgreSQL: pgsql/doc/src/sgml/plperl.sgml,v 2.71 2009/11/29 03:02:27 tgl Exp $ -->
+<!-- $PostgreSQL: pgsql/doc/src/sgml/plperl.sgml,v 2.72 2010/01/09 02:40:50 adunstan Exp $ -->
 
  <chapter id="plperl">
   <title>PL/Perl - Perl Procedural Language</title>
@@ -14,7 +14,7 @@
   <para>
    PL/Perl is a loadable procedural language that enables you to write
    <productname>PostgreSQL</productname> functions in the 
-   <ulink url="http://www.perl.com">Perl programming language</ulink>.
+   <ulink url="http://www.perl.org">Perl programming language</ulink>.
   </para>
 
   <para>
@@ -313,7 +313,8 @@ SELECT * FROM perl_set();
 use strict;
 </programlisting>
    in the function body.  But this only works in <application>PL/PerlU</>
-   functions, since <literal>use</> is not a trusted operation.  In
+   functions, since the <literal>use</> triggers a <literal>require</>
+   which is not a trusted operation.  In
    <application>PL/Perl</> functions you can instead do:
 <programlisting>
 BEGIN { strict->import(); }

src/pl/plperl/GNUmakefile

@@ -1,5 +1,5 @@
 # Makefile for PL/Perl
-# $PostgreSQL: pgsql/src/pl/plperl/GNUmakefile,v 1.37 2009/06/05 18:29:56 adunstan Exp $
+# $PostgreSQL: pgsql/src/pl/plperl/GNUmakefile,v 1.38 2010/01/09 02:40:50 adunstan Exp $
 
 subdir = src/pl/plperl
 top_builddir = ../../..
@@ -45,6 +45,11 @@ PSQLDIR = $(bindir)
 
 include $(top_srcdir)/src/Makefile.shlib
 
+plperl.o: perlchunks.h
+
+perlchunks.h: plc_*.pl
+	$(PERL) text2macro.pl --strip='^(\#.*|\s*)$$' plc_*.pl > perlchunks.htmp
+	mv perlchunks.htmp perlchunks.h
 
 all: all-lib
 
@@ -65,7 +70,7 @@ submake:
 	$(MAKE) -C $(top_builddir)/src/test/regress pg_regress$(X)
 
 clean distclean maintainer-clean: clean-lib
-	rm -f SPI.c $(OBJS)
+	rm -f SPI.c $(OBJS) perlchunks.htmp perlchunks.h
 	rm -rf results
 	rm -f regression.diffs regression.out
 

src/pl/plperl/plc_perlboot.pl

@@ -0,0 +1,50 @@
+SPI::bootstrap();
+use vars qw(%_SHARED);
+
+sub ::plperl_warn {
+	(my $msg = shift) =~ s/\(eval \d+\) //g;
+	&elog(&NOTICE, $msg);
+}
+$SIG{__WARN__} = \&::plperl_warn;
+
+sub ::plperl_die {
+	(my $msg = shift) =~ s/\(eval \d+\) //g;
+    die $msg;
+}
+$SIG{__DIE__} = \&::plperl_die;
+
+sub ::mkunsafefunc {
+	my $ret = eval(qq[ sub { $_[0] $_[1] } ]);
+	$@ =~ s/\(eval \d+\) //g if $@;
+	return $ret;
+}
+
+use strict;
+
+sub ::mk_strict_unsafefunc {
+	my $ret = eval(qq[ sub { use strict; $_[0] $_[1] } ]);
+	$@ =~ s/\(eval \d+\) //g if $@;
+	return $ret;
+}
+
+sub ::_plperl_to_pg_array {
+  my $arg = shift;
+  ref $arg eq 'ARRAY' || return $arg;
+  my $res = '';
+  my $first = 1;
+  foreach my $elem (@$arg) {
+    $res .= ', ' unless $first; $first = undef;
+    if (ref $elem) {
+      $res .= _plperl_to_pg_array($elem);
+    }
+    elsif (defined($elem)) {
+      my $str = qq($elem);
+      $str =~ s/([\"\\])/\\$1/g;
+      $res .= qq(\"$str\");
+    }
+    else {
+      $res .= 'NULL' ;
+    }
+  }
+  return qq({$res});
+}

src/pl/plperl/plc_safe_bad.pl

@@ -0,0 +1,15 @@
+use vars qw($PLContainer);
+
+$PLContainer = new Safe('PLPerl');
+$PLContainer->permit_only(':default');
+$PLContainer->share(qw[&elog &ERROR]);
+
+my $msg = 'trusted Perl functions disabled - please upgrade Perl Safe module to version 2.09 or later';
+sub ::mksafefunc {
+  return $PLContainer->reval(qq[sub { elog(ERROR,'$msg') }]);
+}
+
+sub ::mk_strict_safefunc {
+  return $PLContainer->reval(qq[sub { elog(ERROR,'$msg') }]);
+}
+

src/pl/plperl/plc_safe_ok.pl

@@ -0,0 +1,33 @@
+use vars qw($PLContainer);
+
+$PLContainer = new Safe('PLPerl');
+$PLContainer->permit_only(':default');
+$PLContainer->permit(qw[:base_math !:base_io sort time]);
+
+$PLContainer->share(qw[&elog &return_next
+	&spi_query &spi_fetchrow &spi_cursor_close &spi_exec_query
+	&spi_prepare &spi_exec_prepared &spi_query_prepared &spi_freeplan
+	&_plperl_to_pg_array
+	&DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED
+]);
+
+# Load strict into the container.
+# The temporary enabling of the caller opcode here is to work around a
+# bug in perl 5.10, which unkindly changed the way its Safe.pm works, without
+# notice. It is quite safe, as caller is informational only, and in any case
+# we only enable it while we load the 'strict' module.
+$PLContainer->permit(qw[require caller]);
+$PLContainer->reval('use strict;');
+$PLContainer->deny(qw[require caller]);
+
+sub ::mksafefunc {
+	my $ret = $PLContainer->reval(qq[sub { $_[0] $_[1] }]);
+	$@ =~ s/\(eval \d+\) //g if $@;
+	return $ret;
+}
+
+sub ::mk_strict_safefunc {
+	my $ret = $PLContainer->reval(qq[sub { BEGIN { strict->import(); } $_[0] $_[1] }]);
+	$@ =~ s/\(eval \d+\) //g if $@;
+	return $ret;
+}

src/pl/plperl/plperl.c

@@ -1,7 +1,7 @@
 /**********************************************************************
  * plperl.c - perl as a procedural language for PostgreSQL
  *
- *	  $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.158 2010/01/04 20:29:59 adunstan Exp $
+ *	  $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.159 2010/01/09 02:40:50 adunstan Exp $
  *
  **********************************************************************/
 
@@ -43,6 +43,9 @@
 /* perl stuff */
 #include "plperl.h"
 
+/* string literal macros defining chunks of perl code */
+#include "perlchunks.h"
+
 PG_MODULE_MAGIC;
 
 /**********************************************************************
@@ -125,9 +128,7 @@ typedef enum
 } InterpState;
 
 static InterpState interp_state = INTERP_NONE;
-static bool can_run_two = false;
 
-static bool plperl_safe_init_done = false;
 static PerlInterpreter *plperl_trusted_interp = NULL;
 static PerlInterpreter *plperl_untrusted_interp = NULL;
 static PerlInterpreter *plperl_held_interp = NULL;
@@ -148,7 +149,7 @@ Datum		plperl_inline_handler(PG_FUNCTION_ARGS);
 Datum		plperl_validator(PG_FUNCTION_ARGS);
 void		_PG_init(void);
 
-static void plperl_init_interp(void);
+static PerlInterpreter *plperl_init_interp(void);
 
 static Datum plperl_func_handler(PG_FUNCTION_ARGS);
 static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
@@ -157,16 +158,38 @@ static plperl_proc_desc *compile_plperl_function(Oid fn_oid, bool is_trigger);
 
 static SV  *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc);
 static void plperl_init_shared_libs(pTHX);
+static void plperl_safe_init(void);
 static HV  *plperl_spi_execute_fetch_result(SPITupleTable *, int, int);
 static SV  *newSVstring(const char *str);
 static SV **hv_store_string(HV *hv, const char *key, SV *val);
 static SV **hv_fetch_string(HV *hv, const char *key);
-static SV  *plperl_create_sub(const char *proname, const char *s, bool trusted);
+static void plperl_create_sub(plperl_proc_desc *desc, char *s);
 static SV  *plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo);
 static void plperl_compile_callback(void *arg);
 static void plperl_exec_callback(void *arg);
 static void plperl_inline_callback(void *arg);
 
+/*
+ * Convert an SV to char * and verify the encoding via pg_verifymbstr()
+ */
+static inline char *
+sv2text_mbverified(SV *sv)
+{
+	char * val;
+	STRLEN len;
+
+	/* The value returned here might include an
+	 * embedded nul byte, because perl allows such things.
+	 * That's OK, because pg_verifymbstr will choke on it,  If
+	 * we just used strlen() instead of getting perl's idea of
+	 * the length, whatever uses the "verified" value might
+	 * get something quite weird.
+	 */
+	val = SvPV(sv, len);
+	pg_verifymbstr(val, len, false);
+    return val;
+}
+
 /*
  * This routine is a crock, and so is everyplace that calls it.  The problem
  * is that the cached form of plperl functions/queries is allocated permanently
@@ -228,98 +251,15 @@ _PG_init(void)
 									&hash_ctl,
 									HASH_ELEM);
 
-	plperl_init_interp();
+	plperl_held_interp = plperl_init_interp();
+	interp_state = INTERP_HELD;
 
 	inited = true;
 }
 
-/* Each of these macros must represent a single string literal */
-
-#define PERLBOOT \
-	"SPI::bootstrap(); use vars qw(%_SHARED);" \
-	"sub ::plperl_warn { my $msg = shift; " \
-	"       $msg =~ s/\\(eval \\d+\\) //g; &elog(&NOTICE, $msg); } " \
-	"$SIG{__WARN__} = \\&::plperl_warn; " \
-	"sub ::plperl_die { my $msg = shift; " \
-	"       $msg =~ s/\\(eval \\d+\\) //g; die $msg; } " \
-	"$SIG{__DIE__} = \\&::plperl_die; " \
-	"sub ::mkunsafefunc {" \
-	"      my $ret = eval(qq[ sub { $_[0] $_[1] } ]); " \
-	"      $@ =~ s/\\(eval \\d+\\) //g if $@; return $ret; }" \
-	"use strict; " \
-	"sub ::mk_strict_unsafefunc {" \
-	"      my $ret = eval(qq[ sub { use strict; $_[0] $_[1] } ]); " \
-	"      $@ =~ s/\\(eval \\d+\\) //g if $@; return $ret; } " \
-	"sub ::_plperl_to_pg_array {" \
-	"  my $arg = shift; ref $arg eq 'ARRAY' || return $arg; " \
-	"  my $res = ''; my $first = 1; " \
-	"  foreach my $elem (@$arg) " \
-	"  { " \
-	"    $res .= ', ' unless $first; $first = undef; " \
-	"    if (ref $elem) " \
-	"    { " \
-	"      $res .= _plperl_to_pg_array($elem); " \
-	"    } " \
-	"    elsif (defined($elem)) " \
-	"    { " \
-	"      my $str = qq($elem); " \
-	"      $str =~ s/([\"\\\\])/\\\\$1/g; " \
-	"      $res .= qq(\"$str\"); " \
-	"    } " \
-	"    else " \
-	"    { "\
-	"      $res .= 'NULL' ; " \
-	"    } "\
-	"  } " \
-	"  return qq({$res}); " \
-	"} "
-
 #define SAFE_MODULE \
 	"require Safe; $Safe::VERSION"
 
-/*
- * The temporary enabling of the caller opcode here is to work around a
- * bug in perl 5.10, which unkindly changed the way its Safe.pm works, without
- * notice. It is quite safe, as caller is informational only, and in any case
- * we only enable it while we load the 'strict' module.
- */
-
-#define SAFE_OK \
-	"use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');" \
-	"$PLContainer->permit_only(':default');" \
-	"$PLContainer->permit(qw[:base_math !:base_io sort time]);" \
-	"$PLContainer->share(qw[&elog &spi_exec_query &return_next " \
-	"&spi_query &spi_fetchrow &spi_cursor_close " \
-	"&spi_prepare &spi_exec_prepared &spi_query_prepared &spi_freeplan " \
-	"&_plperl_to_pg_array " \
-	"&DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED ]);" \
-	"sub ::mksafefunc {" \
-	"      my $ret = $PLContainer->reval(qq[sub { $_[0] $_[1] }]); " \
-	"      $@ =~ s/\\(eval \\d+\\) //g if $@; return $ret; }" \
-	"$PLContainer->permit(qw[require caller]); $PLContainer->reval('use strict;');" \
-	"$PLContainer->deny(qw[require caller]); " \
-	"sub ::mk_strict_safefunc {" \
-	"      my $ret = $PLContainer->reval(qq[sub { BEGIN { strict->import(); } $_[0] $_[1] }]); " \
-	"      $@ =~ s/\\(eval \\d+\\) //g if $@; return $ret; }"
-
-#define SAFE_BAD \
-	"use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');" \
-	"$PLContainer->permit_only(':default');" \
-	"$PLContainer->share(qw[&elog &ERROR ]);" \
-	"sub ::mksafefunc { return $PLContainer->reval(qq[sub { " \
-	"      elog(ERROR,'trusted Perl functions disabled - " \
-	"      please upgrade Perl Safe module to version 2.09 or later');}]); }" \
-	"sub ::mk_strict_safefunc { return $PLContainer->reval(qq[sub { " \
-	"      elog(ERROR,'trusted Perl functions disabled - " \
-	"      please upgrade Perl Safe module to version 2.09 or later');}]); }"
-
-#define TEST_FOR_MULTI \
-	"use Config; " \
-	"$Config{usemultiplicity} eq 'define' or "	\
-	"($Config{usethreads} eq 'define' " \
-	" and $Config{useithreads} eq 'define')"
-
-
 /********************************************************************
  *
  * We start out by creating a "held" interpreter that we can use in
@@ -349,6 +289,8 @@ check_interp(bool trusted)
 		}
 		plperl_held_interp = NULL;
 		trusted_context = trusted;
+		if (trusted) /* done last to avoid recursion */
+			plperl_safe_init();
 	}
 	else if (interp_state == INTERP_BOTH ||
 			 (trusted && interp_state == INTERP_TRUSTED) ||
@@ -363,22 +305,23 @@ check_interp(bool trusted)
 			trusted_context = trusted;
 		}
 	}
-	else if (can_run_two)
+	else
 	{
-		PERL_SET_CONTEXT(plperl_held_interp);
+#ifdef MULTIPLICITY
-		plperl_init_interp();
+		PerlInterpreter *plperl = plperl_init_interp();
 		if (trusted)
-			plperl_trusted_interp = plperl_held_interp;
+			plperl_trusted_interp = plperl;
 		else
-			plperl_untrusted_interp = plperl_held_interp;
+			plperl_untrusted_interp = plperl;
-		interp_state = INTERP_BOTH;
 		plperl_held_interp = NULL;
 		trusted_context = trusted;
-	}
+		interp_state = INTERP_BOTH;
-	else
+		if (trusted) /* done last to avoid recursion */
-	{
+			plperl_safe_init();
+#else
 		elog(ERROR,
 			 "cannot allocate second Perl interpreter on this platform");
+#endif
 	}
 }
 
@@ -398,11 +341,14 @@ restore_context(bool old_context)
 	}
 }
 
-static void
+static PerlInterpreter *
 plperl_init_interp(void)
 {
+	PerlInterpreter *plperl;
+	static int perl_sys_init_done;
+
 	static char *embedding[3] = {
-		"", "-e", PERLBOOT
+		"", "-e", PLC_PERLBOOT
 	};
 	int			nargs = 3;
 
@@ -459,31 +405,26 @@ plperl_init_interp(void)
 	 */
 #if defined(PERL_SYS_INIT3) && !defined(MYMALLOC)
 	/* only call this the first time through, as per perlembed man page */
-	if (interp_state == INTERP_NONE)
+	if (!perl_sys_init_done)
 	{
 		char	   *dummy_env[1] = {NULL};
 
 		PERL_SYS_INIT3(&nargs, (char ***) &embedding, (char ***) &dummy_env);
+		perl_sys_init_done = 1;
+		/* quiet warning if PERL_SYS_INIT3 doesn't use the third argument */
+		dummy_env[0] = NULL; 
 	}
 #endif
 
-	plperl_held_interp = perl_alloc();
+	plperl = perl_alloc();
-	if (!plperl_held_interp)
+	if (!plperl)
 		elog(ERROR, "could not allocate Perl interpreter");
 
-	perl_construct(plperl_held_interp);
+	PERL_SET_CONTEXT(plperl);
-	perl_parse(plperl_held_interp, plperl_init_shared_libs,
+	perl_construct(plperl);
+	perl_parse(plperl, plperl_init_shared_libs,
 			   nargs, embedding, NULL);
-	perl_run(plperl_held_interp);
+	perl_run(plperl);
-
-	if (interp_state == INTERP_NONE)
-	{
-		SV		   *res;
-
-		res = eval_pv(TEST_FOR_MULTI, TRUE);
-		can_run_two = SvIV(res);
-		interp_state = INTERP_HELD;
-	}
 
 #ifdef WIN32
 
@@ -526,32 +467,30 @@ plperl_init_interp(void)
 	}
 #endif
 
+	return plperl;
 }
 
 
 static void
 plperl_safe_init(void)
 {
-	SV		   *res;
+	SV		   *safe_version_sv;
-	double		safe_version;
 
-	res = eval_pv(SAFE_MODULE, FALSE);	/* TRUE = croak if failure */
+	safe_version_sv = eval_pv(SAFE_MODULE, FALSE);	/* TRUE = croak if failure */
-
-	safe_version = SvNV(res);
 
 	/*
-	 * We actually want to reject safe_version < 2.09, but it's risky to
+	 * We actually want to reject Safe version < 2.09, but it's risky to
 	 * assume that floating-point comparisons are exact, so use a slightly
 	 * smaller comparison value.
 	 */
-	if (safe_version < 2.0899)
+	if (SvNV(safe_version_sv) < 2.0899)
 	{
 		/* not safe, so disallow all trusted funcs */
-		eval_pv(SAFE_BAD, FALSE);
+		eval_pv(PLC_SAFE_BAD, FALSE);
 	}
 	else
 	{
-		eval_pv(SAFE_OK, FALSE);
+		eval_pv(PLC_SAFE_OK, FALSE);
 		if (GetDatabaseEncoding() == PG_UTF8)
 		{
 			/*
@@ -559,35 +498,29 @@ plperl_safe_init(void)
 			 * the safe container and call it. For some reason not entirely
 			 * clear, it prevents errors that can arise from the regex code
 			 * later trying to load utf8 modules.
+			 * See http://rt.perl.org/rt3/Ticket/Display.html?id=47576
 			 */
 			plperl_proc_desc desc;
 			FunctionCallInfoData fcinfo;
-			SV		   *ret;
-			SV		   *func;
-
-			/* make sure we don't call ourselves recursively */
-			plperl_safe_init_done = true;
 
-			/* compile the function */
+			desc.proname = "utf8fix";
-			func = plperl_create_sub("utf8fix",
+			desc.lanpltrusted = true;
-							 "return shift =~ /\\xa9/i ? 'true' : 'false' ;",
-									 true);
-
-			/* set up to call the function with a single text argument 'a' */
-			desc.reference = func;
 			desc.nargs = 1;
 			desc.arg_is_rowtype[0] = false;
 			fmgr_info(F_TEXTOUT, &(desc.arg_out_func[0]));
 
+			/* compile the function */
+			plperl_create_sub(&desc,
+					"return shift =~ /\\xa9/i ? 'true' : 'false' ;");
+
+			/* set up to call the function with a single text argument 'a' */
 			fcinfo.arg[0] = CStringGetTextDatum("a");
 			fcinfo.argnull[0] = false;
 
 			/* and make the call */
-			ret = plperl_call_perl_func(&desc, &fcinfo);
+			(void) plperl_call_perl_func(&desc, &fcinfo);
 		}
 	}
-
-	plperl_safe_init_done = true;
 }
 
 /*
@@ -631,11 +564,7 @@ plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
 							key)));
 		if (SvOK(val))
 		{
-			char * aval;
+			values[attn - 1] = sv2text_mbverified(val);
-
-			aval = SvPV_nolen(val);
-			pg_verifymbstr(aval, strlen(aval), false);
-			values[attn - 1] = aval;
 		}
 	}
 	hv_iterinit(perlhash);
@@ -835,12 +764,8 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
 		atttypmod = tupdesc->attrs[attn - 1]->atttypmod;
 		if (SvOK(val))
 		{
-			char * aval;
-
-			aval = SvPV_nolen(val);
-			pg_verifymbstr(aval,strlen(aval), false);
 			modvalues[slotsused] = InputFunctionCall(&finfo,
-													 aval,
+													 sv2text_mbverified(val),
 													 typioparam,
 													 atttypmod);
 			modnulls[slotsused] = ' ';
@@ -970,9 +895,7 @@ plperl_inline_handler(PG_FUNCTION_ARGS)
 
 		check_interp(desc.lanpltrusted);
 
-		desc.reference = plperl_create_sub(desc.proname,
+		plperl_create_sub(&desc, codeblock->source_text);
-										   codeblock->source_text,
-										   desc.lanpltrusted);
 
 		if (!desc.reference)	/* can this happen? */
 			elog(ERROR, "could not create internal procedure for anonymous code block");
@@ -1080,20 +1003,15 @@ plperl_validator(PG_FUNCTION_ARGS)
  * Uses mksafefunc/mkunsafefunc to create an anonymous sub whose text is
  * supplied in s, and returns a reference to the closure.
  */
-static SV  *
+static void
-plperl_create_sub(const char *proname, const char *s, bool trusted)
+plperl_create_sub(plperl_proc_desc *prodesc, char *s)
 {
 	dSP;
+	bool        trusted = prodesc->lanpltrusted;
 	SV		   *subref;
 	int			count;
 	char	   *compile_sub;
 
-	if (trusted && !plperl_safe_init_done)
-	{
-		plperl_safe_init();
-		SPAGAIN;
-	}
-
 	ENTER;
 	SAVETMPS;
 	PUSHMARK(SP);
@@ -1127,9 +1045,10 @@ plperl_create_sub(const char *proname, const char *s, bool trusted)
 		elog(ERROR, "didn't get a return item from mksafefunc");
 	}
 
+	subref = POPs;
+
 	if (SvTRUE(ERRSV))
 	{
-		(void) POPs;
 		PUTBACK;
 		FREETMPS;
 		LEAVE;
@@ -1138,30 +1057,25 @@ plperl_create_sub(const char *proname, const char *s, bool trusted)
 				 errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV)))));
 	}
 
-	/*
-	 * need to make a deep copy of the return. it comes off the stack as a
-	 * temporary.
-	 */
-	subref = newSVsv(POPs);
-
 	if (!SvROK(subref) || SvTYPE(SvRV(subref)) != SVt_PVCV)
 	{
 		PUTBACK;
 		FREETMPS;
 		LEAVE;
+		elog(ERROR, "didn't get a code ref");
+	}
 
 	/*
-		 * subref is our responsibility because it is not mortal
+	 * need to make a copy of the return, it comes off the stack as a
+	 * temporary.
 	 */
-		SvREFCNT_dec(subref);
+	prodesc->reference = newSVsv(subref);
-		elog(ERROR, "didn't get a code ref");
-	}
 
 	PUTBACK;
 	FREETMPS;
 	LEAVE;
 
-	return subref;
+	return;
 }
 
 
@@ -1467,7 +1381,6 @@ plperl_func_handler(PG_FUNCTION_ARGS)
 	else
 	{
 		/* Return a perl string converted to a Datum */
-		char	   *val;
 
 		if (prodesc->fn_retisarray && SvROK(perlret) &&
 			SvTYPE(SvRV(perlret)) == SVt_PVAV)
@@ -1477,9 +1390,8 @@ plperl_func_handler(PG_FUNCTION_ARGS)
 			perlret = array_ret;
 		}
 
-		val = SvPV_nolen(perlret);
+		retval = InputFunctionCall(&prodesc->result_in_func,
-		pg_verifymbstr(val, strlen(val), false);
+								   sv2text_mbverified(perlret),
-		retval = InputFunctionCall(&prodesc->result_in_func, val,
 								   prodesc->result_typioparam, -1);
 	}
 
@@ -1843,9 +1755,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
 
 		check_interp(prodesc->lanpltrusted);
 
-		prodesc->reference = plperl_create_sub(prodesc->proname,
+		plperl_create_sub(prodesc, proc_source);
-											   proc_source,
-											   prodesc->lanpltrusted);
 
 		restore_context(oldcontext);
 
@@ -2126,17 +2036,14 @@ plperl_return_next(SV *sv)
 
 		if (SvOK(sv))
 		{
-			char	   *val;
-
 			if (prodesc->fn_retisarray && SvROK(sv) &&
 				SvTYPE(SvRV(sv)) == SVt_PVAV)
 			{
 				sv = plperl_convert_to_pg_array(sv);
 			}
 
-			val = SvPV_nolen(sv);
+			ret = InputFunctionCall(&prodesc->result_in_func,
-			pg_verifymbstr(val, strlen(val), false);
+									sv2text_mbverified(sv),
-			ret = InputFunctionCall(&prodesc->result_in_func, val,
 									prodesc->result_typioparam, -1);
 			isNull = false;
 		}
@@ -2526,12 +2433,8 @@ plperl_spi_exec_prepared(char *query, HV *attr, int argc, SV **argv)
 		{
 			if (SvOK(argv[i]))
 			{
-				char *val;
-
-				val = SvPV_nolen(argv[i]);
-				pg_verifymbstr(val, strlen(val), false);
 				argvalues[i] = InputFunctionCall(&qdesc->arginfuncs[i],
-												 val,
+												 sv2text_mbverified(argv[i]),
 												 qdesc->argtypioparams[i],
 												 -1);
 				nulls[i] = ' ';
@@ -2661,12 +2564,8 @@ plperl_spi_query_prepared(char *query, int argc, SV **argv)
 		{
 			if (SvOK(argv[i]))
 			{
-				char *val;
-				
-				val = SvPV_nolen(argv[i]);
-				pg_verifymbstr(val, strlen(val), false);
 				argvalues[i] = InputFunctionCall(&qdesc->arginfuncs[i],
-												 val,
+												 sv2text_mbverified(argv[i]),
 												 qdesc->argtypioparams[i],
 												 -1);
 				nulls[i] = ' ';

src/pl/plperl/sql/plperl.sql

@@ -369,3 +369,4 @@ $$ LANGUAGE plperl;
 
 -- check that restricted operations are rejected in a plperl DO block
 DO $$ use Config; $$ LANGUAGE plperl;
+

src/pl/plperl/text2macro.pl

@@ -0,0 +1,98 @@
+=head1 NAME
+
+text2macro.pl - convert text files into C string-literal macro definitions
+
+=head1 SYNOPSIS
+
+  text2macro [options] file ... > output.h
+
+Options:
+
+  --prefix=S   - add prefix S to the names of the macros
+  --name=S     - use S as the macro name (assumes only one file)
+  --strip=S    - don't include lines that match perl regex S
+
+=head1 DESCRIPTION
+
+Reads one or more text files and outputs a corresponding series of C
+pre-processor macro definitions. Each macro defines a string literal that
+contains the contents of the corresponding text file. The basename of the text
+file as capitalized and used as the name of the macro, along with an optional prefix.
+
+=cut
+
+use strict;
+use warnings;
+
+use Getopt::Long;
+
+GetOptions(
+	'prefix=s'  => \my $opt_prefix,
+	'name=s'    => \my $opt_name,
+	'strip=s'   => \my $opt_strip,
+	'selftest!' => sub { exit selftest() },
+) or exit 1;
+
+die "No text files specified"
+	unless @ARGV;
+
+print qq{
+/*
+ * DO NOT EDIT - THIS FILE IS AUTOGENERATED - CHANGES WILL BE LOST
+ * Written by $0 from @ARGV
+ */
+};
+
+for my $src_file (@ARGV) {
+
+	(my $macro = $src_file) =~ s/ .*? (\w+) (?:\.\w+) $/$1/x;
+
+	open my $src_fh, $src_file # not 3-arg form
+		or die "Can't open $src_file: $!";
+
+	printf qq{#define %s%s \\\n},
+		$opt_prefix || '',
+		($opt_name) ? $opt_name : uc $macro;
+	while (<$src_fh>) {
+		chomp;
+
+		next if $opt_strip and m/$opt_strip/o;
+
+		# escape the text to suite C string literal rules
+		s/\\/\\\\/g;
+		s/"/\\"/g;
+
+		printf qq{"%s\\n" \\\n}, $_;
+	}
+	print qq{""\n\n};
+}
+
+print "/* end */\n";
+
+exit 0;
+
+
+sub selftest {
+	my $tmp = "text2macro_tmp";
+	my $string = q{a '' '\\'' "" "\\"" "\\\\" "\\\\n" b};
+
+	open my $fh, ">$tmp.pl" or die;
+	print $fh $string;
+	close $fh;
+
+	system("perl $0 --name=X $tmp.pl > $tmp.c") == 0 or die;
+	open $fh, ">>$tmp.c";
+	print $fh "#include <stdio.h>\n";
+	print $fh "int main() { puts(X); return 0; }\n";
+	close $fh;
+	system("cat -n $tmp.c");
+	
+	system("make $tmp") == 0 or die;
+	open $fh, "./$tmp |" or die;
+	my $result = <$fh>;
+	unlink <$tmp.*>;
+
+	warn "Test string: $string\n";
+	warn "Result     : $result";
+	die "Failed!" if $result ne "$string\n";
+}