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.

Author: adunstan

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,
-   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>.
+   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>
-   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</>
-   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>
+   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>
 
@@ -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
-      are anonymous subroutines inside Perl).
+      PL/Perl functions cannot call each other directly.
      </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;
-ERROR:  'require' trapped by operation mask at line 1.
+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

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 $ret = eval(qq[ sub { $_[0] $_[1] } ]);
-	$@ =~ s/\(eval \d+\) //g if $@;
-	return $ret;
+	my $BEGIN = join "\n", map {
+		my $names = $imports->{$_} || [];
+		"$_->import(qw(@$names));"
+	} 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 {
-	my $ret = eval(qq[ sub { use strict; $_[0] $_[1] } ]);
+# 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;
 }
@@ -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');
-$PLContainer->permit_only(':default');
-$PLContainer->share(qw[&elog &ERROR]);
+my $msg = 'trusted Perl functions disabled - please upgrade Perl Safe module';
 
-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 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;
 }
-
-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 @@
 	&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] }]);
+# 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 ::mk_strict_safefunc {
-	my $ret = $PLContainer->reval(qq[sub { BEGIN { strict->import(); } $_[0] $_[1] }]);
-	$@ =~ s/\(eval \d+\) //g if $@;
-	return $ret;
+sub ::mksafefunc {
+	return ::safe_eval(::mkfuncsrc(@_));
 }