Various small improvements and cleanups for PL/Perl.

- Allow (ineffective) use of 'require' in plperl
    If the required module is not already loaded then it dies.
    So "use strict;" now works in plperl.

- Pre-load the feature module if perl >= 5.10.
    So "use feature :5.10;" now works in plperl.

- Stored procedure subs are now given names.
    The names are not visible in ordinary use, but they make
    tools like Devel::NYTProf and Devel::Cover much more useful.

- Simplified and generalized the subroutine creation code.
    Now one code path for generating sub source code, not four.
    Can generate multiple 'use' statements with specific imports
    (which handles plperl.use_strict currently and can easily
    be extended to handle a plperl.use_feature=':5.12' in future).

- Disallows use of Safe version 2.20 which is broken for PL/Perl.
    http://rt.perl.org/rt3/Ticket/Display.html?id=72068

- Assorted minor optimizations by pre-growing data structures.

Patch from Tim Bunce, reviewed by Alex Hunsaker.

doc/src/sgml/plperl.sgml

@@ -1,4 +1,4 @@
-<!-- $PostgreSQL: pgsql/doc/src/sgml/plperl.sgml,v 2.74 2010/01/20 03:37:10 rhaas Exp $ -->
+<!-- $PostgreSQL: pgsql/doc/src/sgml/plperl.sgml,v 2.75 2010/01/26 23:11:56 adunstan Exp $ -->
 
  <chapter id="plperl">
   <title>PL/Perl - Perl Procedural Language</title>
@@ -285,29 +285,39 @@ SELECT * FROM perl_set();
   </para>
 
   <para>
-   If you wish to use the <literal>strict</> pragma with your code,
+   If you wish to use the <literal>strict</> pragma with your code you have a few options.
-   the easiest way to do so is to <command>SET</>
+   For temporary global use you can <command>SET</> <literal>plperl.use_strict</literal>
-   <literal>plperl.use_strict</literal> to true.  This parameter affects
+   to true (see <xref linkend="plperl.use_strict">).
-   subsequent compilations of <application>PL/Perl</> functions, but not
+   This will affect subsequent compilations of <application>PL/Perl</>
-   functions already compiled in the current session.  To set the
+   functions, but not functions already compiled in the current session.
-   parameter before <application>PL/Perl</> has been loaded, it is
+   For permanent global use you can set <literal>plperl.use_strict</literal>
-   necessary to have added <quote><literal>plperl</></> to the <xref
+   to true in the <filename>postgresql.conf</filename> file.
-   linkend="guc-custom-variable-classes"> list in
-   <filename>postgresql.conf</filename>.
   </para>
 
   <para>
-   Another way to use the <literal>strict</> pragma is to put:
+   For permanent use in specific functions you can simply put:
 <programlisting>
 use strict;
 </programlisting>
-   in the function body.  But this only works in <application>PL/PerlU</>
+   at the top of the function body.
-   functions, since the <literal>use</> triggers a <literal>require</>
+  </para>
-   which is not a trusted operation.  In
+
-   <application>PL/Perl</> functions you can instead do:
+  <para>
-<programlisting>
+  The <literal>feature</> pragma is also available to <function>use</> if your Perl is version 5.10.0 or higher.
-BEGIN { strict->import(); }
+  </para>
-</programlisting>
+
+ </sect1>
+
+ <sect1 id="plperl-data">
+  <title>Data Values in PL/Perl</title>
+
+  <para>
+   The argument values supplied to a PL/Perl function's code are
+   simply the input arguments converted to text form (just as if they
+   had been displayed by a <command>SELECT</command> statement).
+   Conversely, the <function>return</function> and <function>return_next</function>
+   commands will accept any string that is acceptable input format
+   for the function's declared return type.
   </para>
  </sect1>
 
@@ -682,18 +692,6 @@ SELECT done();
  </sect2>
  </sect1>
 
- <sect1 id="plperl-data">
-  <title>Data Values in PL/Perl</title>
-
-  <para>
-   The argument values supplied to a PL/Perl function's code are
-   simply the input arguments converted to text form (just as if they
-   had been displayed by a <command>SELECT</command> statement).
-   Conversely, the <literal>return</> command will accept any string
-   that is acceptable input format for the function's declared return
-   type.  So, within the PL/Perl function,
-   all values are just text strings.
-  </para>
  </sect1>
 
  <sect1 id="plperl-global">
@@ -1042,8 +1040,7 @@ CREATE TRIGGER test_valid_id_trig
    <itemizedlist>
     <listitem>
      <para>
-      PL/Perl functions cannot call each other directly (because they
+      PL/Perl functions cannot call each other directly.
-      are anonymous subroutines inside Perl).
      </para>
     </listitem>
 
@@ -1072,6 +1069,8 @@ CREATE TRIGGER test_valid_id_trig
     </listitem>
    </itemizedlist>
   </para>
+ </sect2>
+
  </sect1>
 
 </chapter>

src/pl/plperl/expected/plperl.out

@@ -563,6 +563,17 @@ $$ LANGUAGE plperl;
 NOTICE:  This is a test
 CONTEXT:  PL/Perl anonymous code block
 -- check that restricted operations are rejected in a plperl DO block
-DO $$ use Config; $$ LANGUAGE plperl;
+DO $$ eval "1+1"; $$ LANGUAGE plperl;
-ERROR:  'require' trapped by operation mask at line 1.
+ERROR:  'eval "string"' trapped by operation mask at line 1.
+CONTEXT:  PL/Perl anonymous code block
+-- check that we can't "use" a module that's not been loaded already
+-- compile-time error: "Unable to load blib.pm into plperl"
+DO $$ use blib; $$ LANGUAGE plperl;
+ERROR:  Unable to load blib.pm into plperl at line 1.
+BEGIN failed--compilation aborted at line 1.
+CONTEXT:  PL/Perl anonymous code block
+-- check that we can "use" a module that has already been loaded
+-- runtime error: "Can't use string ("foo") as a SCALAR ref while "strict refs" in use
+DO $do$ use strict; my $name = "foo"; my $ref = $$name; $do$ LANGUAGE plperl;
+ERROR:  Can't use string ("foo") as a SCALAR ref while "strict refs" in use at line 1.
 CONTEXT:  PL/Perl anonymous code block

src/pl/plperl/expected/plperl_plperlu.out

@@ -1,18 +1,19 @@
 -- test plperl/plperlu interaction
+-- the language and call ordering of this test sequence is useful
 CREATE OR REPLACE FUNCTION bar() RETURNS integer AS $$
     #die 'BANG!'; # causes server process to exit(2)
     # alternative - causes server process to exit(255)
     spi_exec_query("invalid sql statement");
-$$ language plperl; -- plperl or plperlu
+$$ language plperl; -- compile plperl code
    
 CREATE OR REPLACE FUNCTION foo() RETURNS integer AS $$
     spi_exec_query("SELECT * FROM bar()");
     return 1;
-$$ LANGUAGE plperlu; -- must be opposite to language of bar
+$$ LANGUAGE plperlu; -- compile plperlu code
    
-SELECT * FROM bar(); -- throws exception normally
+SELECT * FROM bar(); -- throws exception normally (running plperl)
 ERROR:  syntax error at or near "invalid" at line 4.
 CONTEXT:  PL/Perl function "bar"
-SELECT * FROM foo(); -- used to cause backend crash
+SELECT * FROM foo(); -- used to cause backend crash (after switching to plperlu)
 ERROR:  syntax error at or near "invalid" at line 4. at line 2.
 CONTEXT:  PL/Perl function "foo"

src/pl/plperl/plc_perlboot.pl

@@ -1,5 +1,5 @@
 
-#  $PostgreSQL: pgsql/src/pl/plperl/plc_perlboot.pl,v 1.2 2010/01/20 01:08:21 adunstan Exp $
+#  $PostgreSQL: pgsql/src/pl/plperl/plc_perlboot.pl,v 1.3 2010/01/26 23:11:56 adunstan Exp $
 
 PostgreSQL::InServer::Util::bootstrap();
 PostgreSQL::InServer::SPI::bootstrap();
@@ -21,17 +21,25 @@ sub ::plperl_die {
 }
 $SIG{__DIE__} = \&::plperl_die;
 
+sub ::mkfuncsrc {
+	my ($name, $imports, $prolog, $src) = @_;
 
-sub ::mkunsafefunc {
+	my $BEGIN = join "\n", map {
-	my $ret = eval(qq[ sub { $_[0] $_[1] } ]);
+		my $names = $imports->{$_} || [];
-	$@ =~ s/\(eval \d+\) //g if $@;
+		"$_->import(qw(@$names));"
-	return $ret;
+	} sort keys %$imports;
+	$BEGIN &&= "BEGIN { $BEGIN }";
+
+	$name =~ s/\\/\\\\/g;
+	$name =~ s/::|'/_/g; # avoid package delimiters
+
+	return qq[ undef *{'$name'}; *{'$name'} = sub { $BEGIN $prolog $src } ];
 }
-  
-use strict;
 
-sub ::mk_strict_unsafefunc {
+# see also mksafefunc() in plc_safe_ok.pl
-	my $ret = eval(qq[ sub { use strict; $_[0] $_[1] } ]);
+sub ::mkunsafefunc {
+	no strict; # default to no strict for the eval
+	my $ret = eval(::mkfuncsrc(@_));
 	$@ =~ s/\(eval \d+\) //g if $@;
 	return $ret;
 }
@@ -64,7 +72,7 @@ sub ::encode_array_constructor {
 		if ref $arg ne 'ARRAY';
 	my $res = join ", ", map {
 		(ref $_) ? ::encode_array_constructor($_)
-				 : ::quote_nullable($_)
+		         : ::quote_nullable($_)
 	} @$arg;
 	return "ARRAY[$res]";
 }

src/pl/plperl/plc_safe_bad.pl

@@ -1,18 +1,16 @@
 
-#  $PostgreSQL: pgsql/src/pl/plperl/plc_safe_bad.pl,v 1.2 2010/01/20 01:08:21 adunstan Exp $
+#  $PostgreSQL: pgsql/src/pl/plperl/plc_safe_bad.pl,v 1.3 2010/01/26 23:11:56 adunstan Exp $
 
-use vars qw($PLContainer);
+# Minimal version of plc_safe_ok.pl
+# that's used if Safe is too old or doesn't load for any reason
 
-$PLContainer = new Safe('PLPerl');
+my $msg = 'trusted Perl functions disabled - please upgrade Perl Safe module';
-$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 {
-sub ::mksafefunc {
+	my ($name, $pragma, $prolog, $src) = @_;
-  return $PLContainer->reval(qq[sub { elog(ERROR,'$msg') }]);
+	# replace $src with code to generate an error
+	$src = qq{ ::elog(::ERROR,"$msg\n") };
+	my $ret = eval(::mkfuncsrc($name, $pragma, '', $src));
+	$@ =~ s/\(eval \d+\) //g if $@;
+	return $ret;
 }
-
-sub ::mk_strict_safefunc {
-  return $PLContainer->reval(qq[sub { elog(ERROR,'$msg') }]);
-}
-

src/pl/plperl/plc_safe_ok.pl

@@ -1,12 +1,13 @@
 
 
-#  $PostgreSQL: pgsql/src/pl/plperl/plc_safe_ok.pl,v 1.2 2010/01/20 01:08:21 adunstan Exp $
+#  $PostgreSQL: pgsql/src/pl/plperl/plc_safe_ok.pl,v 1.3 2010/01/26 23:11:56 adunstan Exp $
 
+use strict;
 use vars qw($PLContainer);
 
 $PLContainer = new Safe('PLPerl');
 $PLContainer->permit_only(':default');
-$PLContainer->permit(qw[:base_math !:base_io sort time]);
+$PLContainer->permit(qw[:base_math !:base_io sort time require]);
 
 $PLContainer->share(qw[&elog &return_next
 	&spi_query &spi_fetchrow &spi_cursor_close &spi_exec_query
@@ -18,23 +19,24 @@ $PLContainer->share(qw[&elog &return_next
 	&looks_like_number
 ]);
 
-# Load strict into the container.
+# Load widely useful pragmas into the container to make them available.
-# The temporary enabling of the caller opcode here is to work around a
+# (Temporarily enable caller here as work around for bug in perl 5.10,
-# bug in perl 5.10, which unkindly changed the way its Safe.pm works, without
+# which changed the way its Safe.pm works. It is quite safe, as caller is
-# notice. It is quite safe, as caller is informational only, and in any case
+# informational only.)
-# we only enable it while we load the 'strict' module.
+$PLContainer->permit(qw[caller]);
-$PLContainer->permit(qw[require caller]);
+::safe_eval(q{
-$PLContainer->reval('use strict;');
+	require strict;
-$PLContainer->deny(qw[require caller]);
+	require feature if $] >= 5.010000;
+	1;
+}) or die $@;
+$PLContainer->deny(qw[caller]);
+
+sub ::safe_eval {
+	my $ret = $PLContainer->reval(shift);
+	$@ =~ s/\(eval \d+\) //g if $@;
+	return $ret;
+}
 
 sub ::mksafefunc {
-	my $ret = $PLContainer->reval(qq[sub { $_[0] $_[1] }]);
+	return ::safe_eval(::mkfuncsrc(@_));
-	$@ =~ 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.160 2010/01/20 01:08:21 adunstan Exp $
+ *	  $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.161 2010/01/26 23:11:56 adunstan Exp $
  *
  **********************************************************************/
 
@@ -132,6 +132,7 @@ static InterpState interp_state = INTERP_NONE;
 static PerlInterpreter *plperl_trusted_interp = NULL;
 static PerlInterpreter *plperl_untrusted_interp = NULL;
 static PerlInterpreter *plperl_held_interp = NULL;
+static OP *(*pp_require_orig)(pTHX) = NULL;
 static bool trusted_context;
 static HTAB *plperl_proc_hash = NULL;
 static HTAB *plperl_query_hash = NULL;
@@ -163,11 +164,14 @@ 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 void plperl_create_sub(plperl_proc_desc *desc, char *s);
+static void plperl_create_sub(plperl_proc_desc *desc, char *s, Oid fn_oid);
 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);
+static char *strip_trailing_ws(const char *msg);
+static OP * pp_require_safe(pTHX);
+static int restore_context(bool);
 
 /*
  * Convert an SV to char * and verify the encoding via pg_verifymbstr()
@@ -187,7 +191,7 @@ sv2text_mbverified(SV *sv)
 	 */
 	val = SvPV(sv, len);
 	pg_verifymbstr(val, len, false);
-    return val;
+	return val;
 }
 
 /*
@@ -267,14 +271,21 @@ _PG_init(void)
  * assign that interpreter if it is available to either the trusted or
  * untrusted interpreter. If it has already been assigned, and we need to
  * create the other interpreter, we do that if we can, or error out.
- * We detect if it is safe to run two interpreters during the setup of the
- * dummy interpreter.
  */
 
 
 static void
-check_interp(bool trusted)
+select_perl_context(bool trusted)
 {
+	/*
+	 * handle simple cases
+	 */
+	if (restore_context(trusted))
+		return;
+
+	/*
+	 * adopt held interp if free, else create new one if possible
+	 */
 	if (interp_state == INTERP_HELD)
 	{
 		if (trusted)
@@ -287,23 +298,6 @@ check_interp(bool trusted)
 			plperl_untrusted_interp = plperl_held_interp;
 			interp_state = INTERP_UNTRUSTED;
 		}
-		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) ||
-			 (!trusted && interp_state == INTERP_UNTRUSTED))
-	{
-		if (trusted_context != trusted)
-		{
-			if (trusted)
-				PERL_SET_CONTEXT(plperl_trusted_interp);
-			else
-				PERL_SET_CONTEXT(plperl_untrusted_interp);
-			trusted_context = trusted;
-		}
 	}
 	else
 	{
@@ -313,32 +307,52 @@ check_interp(bool trusted)
 			plperl_trusted_interp = plperl;
 		else
 			plperl_untrusted_interp = plperl;
-		plperl_held_interp = NULL;
-		trusted_context = trusted;
 		interp_state = INTERP_BOTH;
-		if (trusted) /* done last to avoid recursion */
-			plperl_safe_init();
 #else
 		elog(ERROR,
 			 "cannot allocate second Perl interpreter on this platform");
 #endif
 	}
+	plperl_held_interp = NULL;
+	trusted_context = trusted;
+
+	/*
+	 * initialization - done after plperl_*_interp and trusted_context
+	 * updates above to ensure a clean state (and thereby avoid recursion via
+	 * plperl_safe_init caling plperl_call_perl_func for utf8fix)
+	 */
+	if (trusted) {
+		plperl_safe_init();
+		PL_ppaddr[OP_REQUIRE] = pp_require_safe;
+	}
 }
 
 /*
  * Restore previous interpreter selection, if two are active
  */
-static void
+static int
-restore_context(bool old_context)
+restore_context(bool trusted)
 {
-	if (interp_state == INTERP_BOTH && trusted_context != old_context)
+	if (interp_state == INTERP_BOTH ||
+		( trusted && interp_state == INTERP_TRUSTED) ||
+		(!trusted && interp_state == INTERP_UNTRUSTED))
 	{
-		if (old_context)
+		if (trusted_context != trusted)
-			PERL_SET_CONTEXT(plperl_trusted_interp);
+		{
-		else
+			if (trusted) {
-			PERL_SET_CONTEXT(plperl_untrusted_interp);
+				PERL_SET_CONTEXT(plperl_trusted_interp);
-		trusted_context = old_context;
+				PL_ppaddr[OP_REQUIRE] = pp_require_safe;
+			}
+			else {
+				PERL_SET_CONTEXT(plperl_untrusted_interp);
+				PL_ppaddr[OP_REQUIRE] = pp_require_orig;
+			}
+			trusted_context = trusted;
+		}
+		return 1; /* context restored */
 	}
+
+	return 0;     /* unable - appropriate interpreter not available */
 }
 
 static PerlInterpreter *
@@ -422,6 +436,16 @@ plperl_init_interp(void)
 
 	PERL_SET_CONTEXT(plperl);
 	perl_construct(plperl);
+
+	/*
+	 * Record the original function for the 'require' opcode.
+	 * 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;
+
 	perl_parse(plperl, plperl_init_shared_libs,
 			   nargs, embedding, NULL);
 	perl_run(plperl);
@@ -471,26 +495,71 @@ plperl_init_interp(void)
 }
 
 
+/*
+ * Our safe implementation of the require opcode.
+ * This is safe because it's completely unable to load any code.
+ * If the requested file/module has already been loaded it'll return true.
+ * If not, it'll die.
+ * So now "use Foo;" will work iff Foo has already been loaded.
+ */
+static OP *
+pp_require_safe(pTHX)
+{
+	dVAR; dSP;
+	SV *sv, **svp;
+	char *name;
+	STRLEN len;
+
+    sv = POPs;
+    name = SvPV(sv, len);
+    if (!(name && len > 0 && *name))
+        RETPUSHNO;
+
+	svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+	if (svp && *svp != &PL_sv_undef)
+		RETPUSHYES;
+
+	DIE(aTHX_ "Unable to load %s into plperl", name);
+}
+
+
 static void
 plperl_safe_init(void)
 {
 	SV		   *safe_version_sv;
+	IV			safe_version_x100;
 
 	safe_version_sv = eval_pv(SAFE_MODULE, FALSE);	/* TRUE = croak if failure */
+	safe_version_x100 = (int)(SvNV(safe_version_sv) * 100);
 
 	/*
-	 * We actually want to reject Safe version < 2.09, but it's risky to
+	 * Reject too-old versions of Safe and some others:
-	 * assume that floating-point comparisons are exact, so use a slightly
+	 * 2.20: http://rt.perl.org/rt3/Ticket/Display.html?id=72068
-	 * smaller comparison value.
 	 */
-	if (SvNV(safe_version_sv) < 2.0899)
+	if (safe_version_x100 < 209 || safe_version_x100 == 220)
 	{
 		/* not safe, so disallow all trusted funcs */
 		eval_pv(PLC_SAFE_BAD, FALSE);
+		if (SvTRUE(ERRSV))
+		{
+			ereport(ERROR,
+				(errcode(ERRCODE_INTERNAL_ERROR),
+				 errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
+				 errdetail("While executing PLC_SAFE_BAD")));
+		}
+
 	}
 	else
 	{
 		eval_pv(PLC_SAFE_OK, FALSE);
+		if (SvTRUE(ERRSV))
+		{
+			ereport(ERROR,
+				(errcode(ERRCODE_INTERNAL_ERROR),
+				 errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
+				 errdetail("While executing PLC_SAFE_OK")));
+		}
+
 		if (GetDatabaseEncoding() == PG_UTF8)
 		{
 			/*
@@ -502,6 +571,7 @@ plperl_safe_init(void)
 			 */
 			plperl_proc_desc desc;
 			FunctionCallInfoData fcinfo;
+			SV *perlret;
 
 			desc.proname = "utf8fix";
 			desc.lanpltrusted = true;
@@ -511,14 +581,16 @@ plperl_safe_init(void)
 
 			/* compile the function */
 			plperl_create_sub(&desc,
-					"return shift =~ /\\xa9/i ? 'true' : 'false' ;");
+					"return shift =~ /\\xa9/i ? 'true' : 'false' ;", 0);
 
 			/* 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 */
-			(void) plperl_call_perl_func(&desc, &fcinfo);
+			perlret = plperl_call_perl_func(&desc, &fcinfo);
+
+			SvREFCNT_dec(perlret);
 		}
 	}
 }
@@ -582,7 +654,6 @@ plperl_convert_to_pg_array(SV *src)
 {
 	SV		   *rv;
 	int			count;
-
 	dSP;
 
 	PUSHMARK(SP);
@@ -619,6 +690,7 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
 	HV		   *hv;
 
 	hv = newHV();
+	hv_ksplit(hv, 12); /* pre-grow the hash */
 
 	tdata = (TriggerData *) fcinfo->context;
 	tupdesc = tdata->tg_relation->rd_att;
@@ -673,6 +745,7 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
 	{
 		AV		   *av = newAV();
 
+		av_extend(av, tdata->tg_trigger->tgnargs);
 		for (i = 0; i < tdata->tg_trigger->tgnargs; i++)
 			av_push(av, newSVstring(tdata->tg_trigger->tgargs[i]));
 		hv_store_string(hv, "args", newRV_noinc((SV *) av));
@@ -893,9 +966,9 @@ plperl_inline_handler(PG_FUNCTION_ARGS)
 		if (SPI_connect() != SPI_OK_CONNECT)
 			elog(ERROR, "could not connect to SPI manager");
 
-		check_interp(desc.lanpltrusted);
+		select_perl_context(desc.lanpltrusted);
 
-		plperl_create_sub(&desc, codeblock->source_text);
+		plperl_create_sub(&desc, codeblock->source_text, 0);
 
 		if (!desc.reference)	/* can this happen? */
 			elog(ERROR, "could not create internal procedure for anonymous code block");
@@ -1000,23 +1073,33 @@ plperl_validator(PG_FUNCTION_ARGS)
 
 
 /*
- * Uses mksafefunc/mkunsafefunc to create an anonymous sub whose text is
+ * Uses mksafefunc/mkunsafefunc to create a subroutine whose text is
- * supplied in s, and returns a reference to the closure.
+ * supplied in s, and returns a reference to it
  */
 static void
-plperl_create_sub(plperl_proc_desc *prodesc, char *s)
+plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid)
 {
 	dSP;
 	bool        trusted = prodesc->lanpltrusted;
-	SV		   *subref;
+	char        subname[NAMEDATALEN+40];
-	int			count;
+	HV         *pragma_hv = newHV();
-	char	   *compile_sub;
+	SV         *subref = NULL;
+	int         count;
+	char       *compile_sub;
+
+	sprintf(subname, "%s__%u", prodesc->proname, fn_oid);
+
+	if (plperl_use_strict)
+		hv_store_string(pragma_hv, "strict", (SV*)newAV());
 
 	ENTER;
 	SAVETMPS;
 	PUSHMARK(SP);
-	XPUSHs(sv_2mortal(newSVstring("our $_TD; local $_TD=$_[0]; shift;")));
+	EXTEND(SP,4);
-	XPUSHs(sv_2mortal(newSVstring(s)));
+	PUSHs(sv_2mortal(newSVstring(subname)));
+	PUSHs(sv_2mortal(newRV_noinc((SV*)pragma_hv)));
+	PUSHs(sv_2mortal(newSVstring("our $_TD; local $_TD=shift;")));
+	PUSHs(sv_2mortal(newSVstring(s)));
 	PUTBACK;
 
 	/*
@@ -1024,57 +1107,36 @@ plperl_create_sub(plperl_proc_desc *prodesc, char *s)
 	 * errors properly.  Perhaps it's because there's another level of eval
 	 * inside mksafefunc?
 	 */
-
+	compile_sub = (trusted) ? "::mksafefunc" : "::mkunsafefunc";
-	if (trusted && plperl_use_strict)
-		compile_sub = "::mk_strict_safefunc";
-	else if (plperl_use_strict)
-		compile_sub = "::mk_strict_unsafefunc";
-	else if (trusted)
-		compile_sub = "::mksafefunc";
-	else
-		compile_sub = "::mkunsafefunc";
-
 	count = perl_call_pv(compile_sub, G_SCALAR | G_EVAL | G_KEEPERR);
 	SPAGAIN;
 
-	if (count != 1)
+	if (count == 1) {
-	{
+		GV *sub_glob = (GV*)POPs;
-		PUTBACK;
+		if (sub_glob && SvTYPE(sub_glob) == SVt_PVGV)
-		FREETMPS;
+			subref = newRV_inc((SV*)GvCVu((GV*)sub_glob));
-		LEAVE;
-		elog(ERROR, "didn't get a return item from mksafefunc");
 	}
 
-	subref = POPs;
+	PUTBACK;
+	FREETMPS;
+	LEAVE;
 
 	if (SvTRUE(ERRSV))
 	{
-		PUTBACK;
-		FREETMPS;
-		LEAVE;
 		ereport(ERROR,
 				(errcode(ERRCODE_SYNTAX_ERROR),
 				 errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV)))));
 	}
 
-	if (!SvROK(subref) || SvTYPE(SvRV(subref)) != SVt_PVCV)
+	if (!subref)
 	{
-		PUTBACK;
+		ereport(ERROR,
-		FREETMPS;
+				(errcode(ERRCODE_INTERNAL_ERROR),
-		LEAVE;
+				 errmsg("didn't get a GLOB from compiling %s via %s", prodesc->proname, compile_sub)));
-		elog(ERROR, "didn't get a code ref");
 	}
 
-	/*
-	 * need to make a copy of the return, it comes off the stack as a
-	 * temporary.
-	 */
 	prodesc->reference = newSVsv(subref);
 
-	PUTBACK;
-	FREETMPS;
-	LEAVE;
-
 	return;
 }
 
@@ -1118,13 +1180,14 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
 	SAVETMPS;
 
 	PUSHMARK(SP);
+	EXTEND(sp, 1 + desc->nargs);
 
-	XPUSHs(&PL_sv_undef);		/* no trigger data */
+	PUSHs(&PL_sv_undef);		/* no trigger data */
 
 	for (i = 0; i < desc->nargs; i++)
 	{
 		if (fcinfo->argnull[i])
-			XPUSHs(&PL_sv_undef);
+			PUSHs(&PL_sv_undef);
 		else if (desc->arg_is_rowtype[i])
 		{
 			HeapTupleHeader td;
@@ -1144,7 +1207,7 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
 			tmptup.t_data = td;
 
 			hashref = plperl_hash_from_tuple(&tmptup, tupdesc);
-			XPUSHs(sv_2mortal(hashref));
+			PUSHs(sv_2mortal(hashref));
 			ReleaseTupleDesc(tupdesc);
 		}
 		else
@@ -1154,7 +1217,7 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
 			tmp = OutputFunctionCall(&(desc->arg_out_func[i]),
 									 fcinfo->arg[i]);
 			sv = newSVstring(tmp);
-			XPUSHs(sv_2mortal(sv));
+			PUSHs(sv_2mortal(sv));
 			pfree(tmp);
 		}
 	}
@@ -1293,7 +1356,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
 							"cannot accept a set")));
 	}
 
-	check_interp(prodesc->lanpltrusted);
+	select_perl_context(prodesc->lanpltrusted);
 
 	perlret = plperl_call_perl_func(prodesc, fcinfo);
 
@@ -1440,7 +1503,7 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
 	pl_error_context.arg = prodesc->proname;
 	error_context_stack = &pl_error_context;
 
-	check_interp(prodesc->lanpltrusted);
+	select_perl_context(prodesc->lanpltrusted);
 
 	svTD = plperl_trigger_build_args(fcinfo);
 	perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
@@ -1757,9 +1820,9 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
 		 * Create the procedure in the interpreter
 		 ************************************************************/
 
-		check_interp(prodesc->lanpltrusted);
+		select_perl_context(prodesc->lanpltrusted);
 
-		plperl_create_sub(prodesc, proc_source);
+		plperl_create_sub(prodesc, proc_source, fn_oid);
 
 		restore_context(oldcontext);
 
@@ -1795,6 +1858,7 @@ plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
 	int			i;
 
 	hv = newHV();
+	hv_ksplit(hv, tupdesc->natts); /* pre-grow the hash */
 
 	for (i = 0; i < tupdesc->natts; i++)
 	{
@@ -1922,6 +1986,7 @@ plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
 		int			i;
 
 		rows = newAV();
+		av_extend(rows, processed);
 		for (i = 0; i < processed; i++)
 		{
 			row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);

src/pl/plperl/sql/plperl.sql

@@ -368,5 +368,13 @@ DO $$
 $$ LANGUAGE plperl;
 
 -- check that restricted operations are rejected in a plperl DO block
-DO $$ use Config; $$ LANGUAGE plperl;
+DO $$ eval "1+1"; $$ LANGUAGE plperl;
+
+-- check that we can't "use" a module that's not been loaded already
+-- compile-time error: "Unable to load blib.pm into plperl"
+DO $$ use blib; $$ LANGUAGE plperl;
+
+-- check that we can "use" a module that has already been loaded
+-- runtime error: "Can't use string ("foo") as a SCALAR ref while "strict refs" in use
+DO $do$ use strict; my $name = "foo"; my $ref = $$name; $do$ LANGUAGE plperl;
 

src/pl/plperl/sql/plperl_plperlu.sql

@@ -1,17 +1,19 @@
 -- test plperl/plperlu interaction
 
+-- the language and call ordering of this test sequence is useful
+
 CREATE OR REPLACE FUNCTION bar() RETURNS integer AS $$
     #die 'BANG!'; # causes server process to exit(2)
     # alternative - causes server process to exit(255)
     spi_exec_query("invalid sql statement");
-$$ language plperl; -- plperl or plperlu
+$$ language plperl; -- compile plperl code
    
 CREATE OR REPLACE FUNCTION foo() RETURNS integer AS $$
     spi_exec_query("SELECT * FROM bar()");
     return 1;
-$$ LANGUAGE plperlu; -- must be opposite to language of bar
+$$ LANGUAGE plperlu; -- compile plperlu code
    
-SELECT * FROM bar(); -- throws exception normally
+SELECT * FROM bar(); -- throws exception normally (running plperl)
-SELECT * FROM foo(); -- used to cause backend crash
+SELECT * FROM foo(); -- used to cause backend crash (after switching to plperlu)