Miscellaneous changes to plperl [PATCH]

diff --git a/doc/src/sgml/plperl.sgml b/doc/src/sgml/plperl.sgml
index 94db722..6fee031 100644
*** a/doc/src/sgml/plperl.sgml
--- b/doc/src/sgml/plperl.sgml
*************** SELECT * FROM perl_set();
*** 285,313 ****
    </para>
  
    <para>
!    If you wish to use the <literal>strict</> pragma with your code,
!    the easiest way to do so is to <command>SET</>
!    <literal>plperl.use_strict</literal> to true.  This parameter affects
!    subsequent compilations of <application>PL/Perl</> functions, but not
!    functions already compiled in the current session.  To set the
!    parameter before <application>PL/Perl</> has been loaded, it is
!    necessary to have added <quote><literal>plperl</></> to the <xref
!    linkend="guc-custom-variable-classes"> list in
!    <filename>postgresql.conf</filename>.
    </para>
  
    <para>
!    Another way to use the <literal>strict</> pragma is to put:
  <programlisting>
  use strict;
  </programlisting>
!    in the function body.  But this only works in <application>PL/PerlU</>
!    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(); }
! </programlisting>
    </para>
   </sect1>
  
--- 285,323 ----
    </para>
  
    <para>
!    If you wish to use the <literal>strict</> pragma with your code you have a few options.
!    For temporary global use you can <command>SET</> <literal>plperl.use_strict</literal>
!    to true (see <xref linkend="plperl.use_strict">).
!    This will affect subsequent compilations of <application>PL/Perl</>
!    functions, but not functions already compiled in the current session.
!    For permanent global use you can set <literal>plperl.use_strict</literal>
!    to true in the <filename>postgresql.conf</filename> file.
    </para>
  
    <para>
!    For permanent use in specific functions you can simply put:
  <programlisting>
  use strict;
  </programlisting>
!    at the top of the function body.
!   </para>
! 
!   <para>
!   The <literal>feature</> pragma is also available to <function>use</> if your Perl is version 5.10.0 or higher.
!   </para>
! 
!  </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>
  
*************** SELECT done();
*** 682,699 ****
   </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">
--- 692,697 ----
*************** CREATE TRIGGER test_valid_id_trig
*** 1042,1049 ****
     <itemizedlist>
      <listitem>
       <para>
!       PL/Perl functions cannot call each other directly (because they
!       are anonymous subroutines inside Perl).
       </para>
      </listitem>
  
--- 1040,1046 ----
     <itemizedlist>
      <listitem>
       <para>
!       PL/Perl functions cannot call each other directly.
       </para>
      </listitem>
  
*************** CREATE TRIGGER test_valid_id_trig
*** 1072,1077 ****
--- 1069,1076 ----
      </listitem>
     </itemizedlist>
    </para>
+  </sect2>
+ 
   </sect1>
  
  </chapter>
diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out
index b942739..ebf9afd 100644
*** a/src/pl/plperl/expected/plperl.out
--- b/src/pl/plperl/expected/plperl.out
*************** $$ LANGUAGE plperl;
*** 563,568 ****
  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;
! ERROR:  'require' trapped by operation mask at line 1.
  CONTEXT:  PL/Perl anonymous code block
--- 563,579 ----
  NOTICE:  This is a test
  CONTEXT:  PL/Perl anonymous code block
  -- check that restricted operations are rejected in a plperl DO block
! DO $$ eval "1+1"; $$ LANGUAGE plperl;
! 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
diff --git a/src/pl/plperl/expected/plperl_plperlu.out b/src/pl/plperl/expected/plperl_plperlu.out
index 80824e0..e940f71 100644
*** a/src/pl/plperl/expected/plperl_plperlu.out
--- b/src/pl/plperl/expected/plperl_plperlu.out
***************
*** 1,18 ****
  -- test plperl/plperlu interaction
  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
     
  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
     
! SELECT * FROM bar(); -- throws exception normally
  ERROR:  syntax error at or near "invalid" at line 4.
  CONTEXT:  PL/Perl function "bar"
! SELECT * FROM foo(); -- used to cause backend crash
  ERROR:  syntax error at or near "invalid" at line 4. at line 2.
  CONTEXT:  PL/Perl function "foo"
--- 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; -- compile plperl code
     
  CREATE OR REPLACE FUNCTION foo() RETURNS integer AS $$
      spi_exec_query("SELECT * FROM bar()");
      return 1;
! $$ LANGUAGE plperlu; -- compile plperlu code
     
! 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 (after switching to plperlu)
  ERROR:  syntax error at or near "invalid" at line 4. at line 2.
  CONTEXT:  PL/Perl function "foo"
diff --git a/src/pl/plperl/plc_perlboot.pl b/src/pl/plperl/plc_perlboot.pl
index b4d1e04..769721d 100644
*** a/src/pl/plperl/plc_perlboot.pl
--- b/src/pl/plperl/plc_perlboot.pl
*************** sub ::plperl_die {
*** 18,34 ****
  }
  $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;
  }
--- 18,45 ----
  }
  $SIG{__DIE__} = \&::plperl_die;
  
+ sub ::mkfuncsrc {
+ 	my ($name, $imports, $prolog, $src) = @_;
  
! 	my $BEGIN = join "\n", map {
! 		my $names = $imports->{$_} || [];
! 		"$_->import(qw(@$names));"
! 	} keys %$imports;
! 	$BEGIN &&= "BEGIN { $BEGIN }";
! 
! 	$name =~ s/\\/\\\\/g;
! 	$name =~ s/::|'/_/g; # avoid package delimiters
! 
! 	my $funcsrc;
! 	$funcsrc .= qq[ undef *{'$name'}; *{'$name'} = sub { $BEGIN $prolog $src } ];
! 	#warn "plperl mkfuncsrc: $funcsrc\n";
! 	return $funcsrc;
  }
  
! # see also mksafefunc() in plc_safe_ok.pl
! sub ::mkunsafefunc {
! 	no strict; # default to no strict for the eval
! 	my $ret = eval(::mkfuncsrc(@_));
  	$@ =~ s/\(eval \d+\) //g if $@;
  	return $ret;
  }
*************** sub ::encode_array_constructor {
*** 61,67 ****
  		if ref $arg ne 'ARRAY';
  	my $res = join ", ", map {
  		(ref $_) ? ::encode_array_constructor($_)
! 				 : ::quote_nullable($_)
  	} @$arg;
  	return "ARRAY[$res]";
  }
--- 72,78 ----
  		if ref $arg ne 'ARRAY';
  	my $res = join ", ", map {
  		(ref $_) ? ::encode_array_constructor($_)
! 		         : ::quote_nullable($_)
  	} @$arg;
  	return "ARRAY[$res]";
  }
diff --git a/src/pl/plperl/plc_safe_bad.pl b/src/pl/plperl/plc_safe_bad.pl
index 838ccc6..36ef6ae 100644
*** a/src/pl/plperl/plc_safe_bad.pl
--- b/src/pl/plperl/plc_safe_bad.pl
***************
*** 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') }]);
  }
- 
--- 1,13 ----
! # Minimal version of plc_safe_ok.pl
! # that's used if Safe is too old or doesn't load for any reason
  
! my $msg = 'trusted Perl functions disabled - please upgrade Perl Safe module';
  
! sub mksafefunc {
! 	my ($name, $pragma, $prolog, $src) = @_;
! 	# 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;
  }
diff --git a/src/pl/plperl/plc_safe_ok.pl b/src/pl/plperl/plc_safe_ok.pl
index aec5cdc..dc33dd6 100644
*** a/src/pl/plperl/plc_safe_ok.pl
--- b/src/pl/plperl/plc_safe_ok.pl
***************
*** 1,8 ****
  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
--- 1,9 ----
+ use strict;
  use vars qw($PLContainer);
  
  $PLContainer = new Safe('PLPerl');
  $PLContainer->permit_only(':default');
! $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
*************** $PLContainer->share(qw[&elog &return_nex
*** 14,36 ****
  	&looks_like_number
  ]);
  
! # 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;
  }
--- 15,38 ----
  	&looks_like_number
  ]);
  
! # Load widely useful pragmas into the container to make them available.
! # (Temporarily enable caller here as work around for bug in perl 5.10,
! # which changed the way its Safe.pm works. It is quite safe, as caller is
! # informational only.)
! $PLContainer->permit(qw[caller]);
! ::safe_eval(q{
! 	require strict;
! 	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 {
! 	return ::safe_eval(::mkfuncsrc(@_));
  }
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index 6f577f0..9277072 100644
*** a/src/pl/plperl/plperl.c
--- b/src/pl/plperl/plperl.c
*************** static InterpState interp_state = INTERP
*** 132,137 ****
--- 132,138 ----
  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;
*************** static HV  *plperl_spi_execute_fetch_res
*** 163,173 ****
  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 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()
--- 164,177 ----
  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, 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()
*************** sv2text_mbverified(SV *sv)
*** 187,193 ****
  	 */
  	val = SvPV(sv, len);
  	pg_verifymbstr(val, len, false);
!     return val;
  }
  
  /*
--- 191,197 ----
  	 */
  	val = SvPV(sv, len);
  	pg_verifymbstr(val, len, false);
! 	return val;
  }
  
  /*
*************** _PG_init(void)
*** 267,280 ****
   * 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)
  {
  	if (interp_state == INTERP_HELD)
  	{
  		if (trusted)
--- 271,291 ----
   * 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.
   */
  
  
  static void
! 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)
*************** check_interp(bool trusted)
*** 287,309 ****
  			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
  	{
--- 298,303 ----
*************** check_interp(bool trusted)
*** 313,344 ****
  			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
  	}
  }
  
  /*
   * Restore previous interpreter selection, if two are active
   */
! static void
! restore_context(bool old_context)
  {
! 	if (interp_state == INTERP_BOTH && trusted_context != old_context)
  	{
! 		if (old_context)
! 			PERL_SET_CONTEXT(plperl_trusted_interp);
! 		else
! 			PERL_SET_CONTEXT(plperl_untrusted_interp);
! 		trusted_context = old_context;
  	}
  }
  
  static PerlInterpreter *
--- 307,358 ----
  			plperl_trusted_interp = plperl;
  		else
  			plperl_untrusted_interp = plperl;
  		interp_state = INTERP_BOTH;
  #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 int
! restore_context(bool trusted)
  {
! 	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);
! 				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 *
*************** plperl_init_interp(void)
*** 422,427 ****
--- 436,451 ----
  
  	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);
*************** plperl_init_interp(void)
*** 471,496 ****
  }
  
  
  static void
  plperl_safe_init(void)
  {
  	SV		   *safe_version_sv;
  
  	safe_version_sv = eval_pv(SAFE_MODULE, FALSE);	/* TRUE = croak if failure */
  
  	/*
! 	 * 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 (SvNV(safe_version_sv) < 2.0899)
  	{
  		/* not safe, so disallow all trusted funcs */
  		eval_pv(PLC_SAFE_BAD, FALSE);
  	}
  	else
  	{
  		eval_pv(PLC_SAFE_OK, FALSE);
  		if (GetDatabaseEncoding() == PG_UTF8)
  		{
  			/*
--- 495,565 ----
  }
  
  
+ /*
+  * 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);
  
  	/*
! 	 * Reject too-old versions of Safe and some others:
! 	 * 2.20: http://rt.perl.org/rt3/Ticket/Display.html?id=72068
  	 */
! 	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)
  		{
  			/*
*************** plperl_safe_init(void)
*** 502,507 ****
--- 571,577 ----
  			 */
  			plperl_proc_desc desc;
  			FunctionCallInfoData fcinfo;
+ 			SV *perlret;
  
  			desc.proname = "utf8fix";
  			desc.lanpltrusted = true;
*************** plperl_safe_init(void)
*** 511,524 ****
  
  			/* 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 */
! 			(void) plperl_call_perl_func(&desc, &fcinfo);
  		}
  	}
  }
--- 581,596 ----
  
  			/* compile the function */
  			plperl_create_sub(&desc,
! 					"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 */
! 			perlret = plperl_call_perl_func(&desc, &fcinfo);
! 
! 			SvREFCNT_dec(perlret);
  		}
  	}
  }
*************** plperl_convert_to_pg_array(SV *src)
*** 582,588 ****
  {
  	SV		   *rv;
  	int			count;
- 
  	dSP;
  
  	PUSHMARK(SP);
--- 654,659 ----
*************** plperl_trigger_build_args(FunctionCallIn
*** 619,624 ****
--- 690,696 ----
  	HV		   *hv;
  
  	hv = newHV();
+ 	hv_ksplit(hv, 12); /* pre-grow the hash */
  
  	tdata = (TriggerData *) fcinfo->context;
  	tupdesc = tdata->tg_relation->rd_att;
*************** plperl_trigger_build_args(FunctionCallIn
*** 673,678 ****
--- 745,751 ----
  	{
  		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));
*************** plperl_inline_handler(PG_FUNCTION_ARGS)
*** 893,901 ****
  		if (SPI_connect() != SPI_OK_CONNECT)
  			elog(ERROR, "could not connect to SPI manager");
  
! 		check_interp(desc.lanpltrusted);
  
! 		plperl_create_sub(&desc, codeblock->source_text);
  
  		if (!desc.reference)	/* can this happen? */
  			elog(ERROR, "could not create internal procedure for anonymous code block");
--- 966,974 ----
  		if (SPI_connect() != SPI_OK_CONNECT)
  			elog(ERROR, "could not connect to SPI manager");
  
! 		select_perl_context(desc.lanpltrusted);
  
! 		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");
*************** plperl_validator(PG_FUNCTION_ARGS)
*** 1000,1022 ****
  
  
  /*
!  * Uses mksafefunc/mkunsafefunc to create an anonymous sub whose text is
!  * supplied in s, and returns a reference to the closure.
   */
  static void
! plperl_create_sub(plperl_proc_desc *prodesc, char *s)
  {
  	dSP;
  	bool        trusted = prodesc->lanpltrusted;
! 	SV		   *subref;
! 	int			count;
! 	char	   *compile_sub;
  
  	ENTER;
  	SAVETMPS;
  	PUSHMARK(SP);
! 	XPUSHs(sv_2mortal(newSVstring("our $_TD; local $_TD=$_[0]; shift;")));
! 	XPUSHs(sv_2mortal(newSVstring(s)));
  	PUTBACK;
  
  	/*
--- 1073,1105 ----
  
  
  /*
!  * Uses mksafefunc/mkunsafefunc to create a subroutine whose text is
!  * supplied in s, and returns a reference to it
   */
  static void
! plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid)
  {
  	dSP;
  	bool        trusted = prodesc->lanpltrusted;
! 	char        subname[NAMEDATALEN+40];
! 	HV         *pragma_hv = newHV();
! 	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);
! 	EXTEND(SP,4);
! 	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;
  
  	/*
*************** plperl_create_sub(plperl_proc_desc *prod
*** 1024,1080 ****
  	 * errors properly.  Perhaps it's because there's another level of eval
  	 * inside mksafefunc?
  	 */
! 
! 	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)
! 	{
! 		PUTBACK;
! 		FREETMPS;
! 		LEAVE;
! 		elog(ERROR, "didn't get a return item from mksafefunc");
  	}
  
! 	subref = POPs;
  
  	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)
  	{
! 		PUTBACK;
! 		FREETMPS;
! 		LEAVE;
! 		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;
  }
  
--- 1107,1142 ----
  	 * errors properly.  Perhaps it's because there's another level of eval
  	 * inside mksafefunc?
  	 */
! 	compile_sub = (trusted) ? "::mksafefunc" : "::mkunsafefunc";
  	count = perl_call_pv(compile_sub, G_SCALAR | G_EVAL | G_KEEPERR);
  	SPAGAIN;
  
! 	if (count == 1) {
! 		GV *sub_glob = (GV*)POPs;
! 		if (sub_glob && SvTYPE(sub_glob) == SVt_PVGV)
! 			subref = newRV_inc((SV*)GvCVu((GV*)sub_glob));
  	}
  
! 	PUTBACK;
! 	FREETMPS;
! 	LEAVE;
  
  	if (SvTRUE(ERRSV))
  	{
  		ereport(ERROR,
  				(errcode(ERRCODE_SYNTAX_ERROR),
  				 errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV)))));
  	}
  
! 	if (!subref)
  	{
! 		ereport(ERROR,
! 				(errcode(ERRCODE_INTERNAL_ERROR),
! 				 errmsg("didn't get a GLOB from compiling %s via %s", prodesc->proname, compile_sub)));
  	}
  
  	prodesc->reference = newSVsv(subref);
  
  	return;
  }
  
*************** plperl_call_perl_func(plperl_proc_desc *
*** 1118,1130 ****
  	SAVETMPS;
  
  	PUSHMARK(SP);
  
! 	XPUSHs(&PL_sv_undef);		/* no trigger data */
  
  	for (i = 0; i < desc->nargs; i++)
  	{
  		if (fcinfo->argnull[i])
! 			XPUSHs(&PL_sv_undef);
  		else if (desc->arg_is_rowtype[i])
  		{
  			HeapTupleHeader td;
--- 1180,1193 ----
  	SAVETMPS;
  
  	PUSHMARK(SP);
+ 	EXTEND(sp, 1 + desc->nargs);
  
! 	PUSHs(&PL_sv_undef);		/* no trigger data */
  
  	for (i = 0; i < desc->nargs; i++)
  	{
  		if (fcinfo->argnull[i])
! 			PUSHs(&PL_sv_undef);
  		else if (desc->arg_is_rowtype[i])
  		{
  			HeapTupleHeader td;
*************** plperl_call_perl_func(plperl_proc_desc *
*** 1144,1150 ****
  			tmptup.t_data = td;
  
  			hashref = plperl_hash_from_tuple(&tmptup, tupdesc);
! 			XPUSHs(sv_2mortal(hashref));
  			ReleaseTupleDesc(tupdesc);
  		}
  		else
--- 1207,1213 ----
  			tmptup.t_data = td;
  
  			hashref = plperl_hash_from_tuple(&tmptup, tupdesc);
! 			PUSHs(sv_2mortal(hashref));
  			ReleaseTupleDesc(tupdesc);
  		}
  		else
*************** plperl_call_perl_func(plperl_proc_desc *
*** 1154,1160 ****
  			tmp = OutputFunctionCall(&(desc->arg_out_func[i]),
  									 fcinfo->arg[i]);
  			sv = newSVstring(tmp);
! 			XPUSHs(sv_2mortal(sv));
  			pfree(tmp);
  		}
  	}
--- 1217,1223 ----
  			tmp = OutputFunctionCall(&(desc->arg_out_func[i]),
  									 fcinfo->arg[i]);
  			sv = newSVstring(tmp);
! 			PUSHs(sv_2mortal(sv));
  			pfree(tmp);
  		}
  	}
*************** plperl_func_handler(PG_FUNCTION_ARGS)
*** 1293,1299 ****
  							"cannot accept a set")));
  	}
  
! 	check_interp(prodesc->lanpltrusted);
  
  	perlret = plperl_call_perl_func(prodesc, fcinfo);
  
--- 1356,1362 ----
  							"cannot accept a set")));
  	}
  
! 	select_perl_context(prodesc->lanpltrusted);
  
  	perlret = plperl_call_perl_func(prodesc, fcinfo);
  
*************** plperl_trigger_handler(PG_FUNCTION_ARGS)
*** 1440,1446 ****
  	pl_error_context.arg = prodesc->proname;
  	error_context_stack = &pl_error_context;
  
! 	check_interp(prodesc->lanpltrusted);
  
  	svTD = plperl_trigger_build_args(fcinfo);
  	perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
--- 1503,1509 ----
  	pl_error_context.arg = prodesc->proname;
  	error_context_stack = &pl_error_context;
  
! 	select_perl_context(prodesc->lanpltrusted);
  
  	svTD = plperl_trigger_build_args(fcinfo);
  	perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
*************** compile_plperl_function(Oid fn_oid, bool
*** 1757,1765 ****
  		 * Create the procedure in the interpreter
  		 ************************************************************/
  
! 		check_interp(prodesc->lanpltrusted);
  
! 		plperl_create_sub(prodesc, proc_source);
  
  		restore_context(oldcontext);
  
--- 1820,1828 ----
  		 * Create the procedure in the interpreter
  		 ************************************************************/
  
! 		select_perl_context(prodesc->lanpltrusted);
  
! 		plperl_create_sub(prodesc, proc_source, fn_oid);
  
  		restore_context(oldcontext);
  
*************** plperl_hash_from_tuple(HeapTuple tuple, 
*** 1795,1800 ****
--- 1858,1864 ----
  	int			i;
  
  	hv = newHV();
+ 	hv_ksplit(hv, tupdesc->natts); /* pre-grow the hash */
  
  	for (i = 0; i < tupdesc->natts; i++)
  	{
*************** plperl_spi_execute_fetch_result(SPITuple
*** 1922,1927 ****
--- 1986,1992 ----
  		int			i;
  
  		rows = newAV();
+ 		av_extend(rows, processed);
  		for (i = 0; i < processed; i++)
  		{
  			row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
diff --git a/src/pl/plperl/sql/plperl.sql b/src/pl/plperl/sql/plperl.sql
index 08e5371..e6ef5f0 100644
*** a/src/pl/plperl/sql/plperl.sql
--- b/src/pl/plperl/sql/plperl.sql
*************** DO $$
*** 368,372 ****
  $$ LANGUAGE plperl;
  
  -- check that restricted operations are rejected in a plperl DO block
! DO $$ use Config; $$ LANGUAGE plperl;
  
--- 368,380 ----
  $$ LANGUAGE plperl;
  
  -- check that restricted operations are rejected in a plperl DO block
! 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;
  
diff --git a/src/pl/plperl/sql/plperl_plperlu.sql b/src/pl/plperl/sql/plperl_plperlu.sql
index 5b57a82..fc2bb7b 100644
*** a/src/pl/plperl/sql/plperl_plperlu.sql
--- b/src/pl/plperl/sql/plperl_plperlu.sql
***************
*** 1,17 ****
  -- test plperl/plperlu interaction
  
  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
     
  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
     
! SELECT * FROM bar(); -- throws exception normally
! SELECT * FROM foo(); -- used to cause backend crash
  
  
--- 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; -- compile plperl code
     
  CREATE OR REPLACE FUNCTION foo() RETURNS integer AS $$
      spi_exec_query("SELECT * FROM bar()");
      return 1;
! $$ LANGUAGE plperlu; -- compile plperlu code
     
! SELECT * FROM bar(); -- throws exception normally (running plperl)
! SELECT * FROM foo(); -- used to cause backend crash (after switching to plperlu)