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.

Author: adunstan

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;
+}