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

-<!-- $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

 # 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

+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

+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

+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/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

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