Clean up package namespace use and use of Safe in plperl.

Prevent use of another buggy version of Safe.pm.
Only register the exit handler if we have  successfully created an interpreter.
Change log level of perl warnings from NOTICE to WARNING.

The infrastructure is there if in future we decide to allow
DBAs to specify extra modules that will be allowed in trusted code.
However, for now the relevant variables are declared as lexicals
rather than as package variables, so that they are not (or should not be)
accessible.

Mostly code from Tim Bunce, reviewed by Alex Hunsaker, with some
tweaks by me.

src/pl/plperl/expected/plperl.out

@@ -577,3 +577,8 @@ CONTEXT:  PL/Perl anonymous code block
 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
+-- check that we can "use warnings" (in this case to turn a warn into an error)
+-- yields "ERROR:  Useless use of length in void context"
+DO $do$ use warnings FATAL => qw(void) ; length "abc" ; 1; $do$ LANGUAGE plperl;
+ERROR:  Useless use of length in void context at line 1.
+CONTEXT:  PL/Perl anonymous code block

src/pl/plperl/expected/plperl_elog.out

@@ -20,7 +20,7 @@ create or replace function perl_warn(text) returns void language plperl as $$
 
 $$;
 select perl_warn('implicit elog via warn');
-NOTICE:  implicit elog via warn at line 4.
+WARNING:  implicit elog via warn at line 4.
 CONTEXT:  PL/Perl function "perl_warn"
  perl_warn 
 -----------

src/pl/plperl/expected/plperlu.out

@@ -5,7 +5,7 @@ LOAD 'plperl';
 -- Test plperl.on_plperlu_init gets run
 SET plperl.on_plperlu_init = '$_SHARED{init} = 42';
 DO $$ warn $_SHARED{init} $$ language plperlu;
-NOTICE:  42 at line 1.
+WARNING:  42 at line 1.
 CONTEXT:  PL/Perl anonymous code block
 --
 -- Test compilation of unicode regex - regardless of locale.

src/pl/plperl/plc_perlboot.pl

 
-#  $PostgreSQL: pgsql/src/pl/plperl/plc_perlboot.pl,v 1.4 2010/01/30 01:46:57 adunstan Exp $
+#  $PostgreSQL: pgsql/src/pl/plperl/plc_perlboot.pl,v 1.5 2010/02/16 21:39:52 adunstan Exp $
+
+use 5.008001;
 
 PostgreSQL::InServer::Util::bootstrap();
 
+package PostgreSQL::InServer;
+
 use strict;
 use warnings;
 use vars qw(%_SHARED);
 
-sub ::plperl_warn {
+sub plperl_warn {
 	(my $msg = shift) =~ s/\(eval \d+\) //g;
 	chomp $msg;
-	&elog(&NOTICE, $msg);
+	&::elog(&::WARNING, $msg);
 }
-$SIG{__WARN__} = \&::plperl_warn;
+$SIG{__WARN__} = \&plperl_warn;
 
-sub ::plperl_die {
+sub plperl_die {
 	(my $msg = shift) =~ s/\(eval \d+\) //g;
 	die $msg;
 }
-$SIG{__DIE__} = \&::plperl_die;
+$SIG{__DIE__} = \&plperl_die;
 
-sub ::mkfuncsrc {
+sub mkfuncsrc {
 	my ($name, $imports, $prolog, $src) = @_;
 
 	my $BEGIN = join "\n", map {
@@ -32,13 +36,13 @@ sub ::mkfuncsrc {
 	$name =~ s/\\/\\\\/g;
 	$name =~ s/::|'/_/g; # avoid package delimiters
 
-	return qq[ undef *{'$name'}; *{'$name'} = sub { $BEGIN $prolog $src } ];
+	return qq[ package main; undef *{'$name'}; *{'$name'} = sub { $BEGIN $prolog $src } ];
 }
 
 # see also mksafefunc() in plc_safe_ok.pl
-sub ::mkunsafefunc {
+sub mkunsafefunc {
 	no strict; # default to no strict for the eval
-	my $ret = eval(::mkfuncsrc(@_));
+	my $ret = eval(mkfuncsrc(@_));
 	$@ =~ s/\(eval \d+\) //g if $@;
 	return $ret;
 }
@@ -67,7 +71,7 @@ sub ::encode_array_literal {
 
 sub ::encode_array_constructor {
 	my $arg = shift;
-	return quote_nullable($arg)
+	return ::quote_nullable($arg)
 		if ref $arg ne 'ARRAY';
 	my $res = join ", ", map {
 		(ref $_) ? ::encode_array_constructor($_)

src/pl/plperl/plc_safe_ok.pl

 
 
-#  $PostgreSQL: pgsql/src/pl/plperl/plc_safe_ok.pl,v 1.4 2010/02/12 19:35:25 adunstan Exp $
+#  $PostgreSQL: pgsql/src/pl/plperl/plc_safe_ok.pl,v 1.5 2010/02/16 21:39:52 adunstan Exp $
+
+package PostgreSQL::InServer::safe;
  
 use strict;
-use vars qw($PLContainer);
+use warnings;
+use Safe;
 
-$PLContainer = new Safe('PLPerl');
-$PLContainer->permit_only(':default');
-$PLContainer->permit(qw[:base_math !:base_io sort time require]);
+# @EvalInSafe    = ( [ "string to eval", "extra,opcodes,to,allow" ], ...)
+# @ShareIntoSafe = ( [ from_class => \@symbols ], ...)
+
+# these are currently declared "my" so they can't be monkeyed with using init
+# code. If we later decide to change that policy, we could change one or more
+# to make them visible by using "use vars".
+my($PLContainer,$SafeClass,@EvalInSafe,@ShareIntoSafe);
+  
+# --- configuration ---
+
+# ensure we only alter the configuration variables once to avoid any
+# problems if this code is run multiple times due to an exception generated
+# from plperl.on_trusted_init code leaving the interp_state unchanged.
 
-$PLContainer->share(qw[&elog &return_next
+if (not our $_init++) {
+
+  # Load widely useful pragmas into the container to make them available.
+  # These must be trusted to not expose a way to execute a string eval
+  # or any kind of unsafe action that the untrusted code could exploit.
+  # If in ANY doubt about a module then DO NOT add it to this list.
+
+  unshift @EvalInSafe,
+      [ 'require strict',   'caller' ],
+      [ 'require Carp',     'caller,entertry'  ], # load Carp before warnings
+      [ 'require warnings', 'caller'  ];
+  push @EvalInSafe,
+      [ 'require feature' ] if $] >= 5.010000;
+
+  push @ShareIntoSafe, [
+      main => [ qw(
+          &elog &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR
           &spi_query &spi_fetchrow &spi_cursor_close &spi_exec_query
           &spi_prepare &spi_exec_prepared &spi_query_prepared &spi_freeplan
-	&DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED
+          &return_next &_SHARED
           &quote_literal &quote_nullable &quote_ident
-	&encode_bytea &decode_bytea
+          &encode_bytea &decode_bytea &looks_like_number
           &encode_array_literal &encode_array_constructor
-	&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]);
-
-# called directly for plperl.on_plperl_init
-sub ::safe_eval {
+      ) ],
+  ];
+}
+
+# --- create and initialize a new container ---
+
+$SafeClass ||= 'Safe';
+$PLContainer = $SafeClass->new('PostgreSQL::InServer::safe_container');
+
+$PLContainer->permit_only(':default');
+$PLContainer->permit(qw[:base_math !:base_io sort time require]);
+
+for my $do (@EvalInSafe) {
+  my $perform = sub { # private closure
+      my ($container, $src, $ops) = @_;
+      my $mask = $container->mask;
+      $container->permit(split /\s*,\s*/, $ops);
+      my $ok = safe_eval("$src; 1");
+      $container->mask($mask);
+      main::elog(main::ERROR(), "$src failed: $@") unless $ok;
+  };
+  
+  my $ops = $do->[1] || '';
+  # For old perls we add entereval if entertry is listed
+  # due to http://rt.perl.org/rt3/Ticket/Display.html?id=70970
+  # Testing with a recent perl (>=5.11.4) ensures this doesn't
+  # allow any use of actual entereval (eval "...") opcodes.
+  $ops = "entereval,$ops"
+      if $] < 5.011004 and $ops =~ /\bentertry\b/;
+
+  $perform->($PLContainer, $do->[0], $ops);
+}
+
+$PLContainer->share_from(@$_) for @ShareIntoSafe;
+
+
+# --- runtime interface ---
+
+# called directly for plperl.on_trusted_init and @EvalInSafe
+sub safe_eval {
 	my $ret = $PLContainer->reval(shift);
 	$@ =~ s/\(eval \d+\) //g if $@;
 	return $ret;
 }
 
-sub ::mksafefunc {
-	return ::safe_eval(::mkfuncsrc(@_));
+sub mksafefunc {
+!   return safe_eval(PostgreSQL::InServer::mkfuncsrc(@_));
 }

src/pl/plperl/plperl.c

 /**********************************************************************
  * plperl.c - perl as a procedural language for PostgreSQL
  *
- *	  $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.167 2010/02/15 22:23:25 alvherre Exp $
+ *	  $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.168 2010/02/16 21:39:52 adunstan Exp $
  *
  **********************************************************************/
 
@@ -365,8 +365,6 @@ select_perl_context(bool trusted)
 	{
 		/* first actual use of a perl interpreter */
 
-		on_proc_exit(plperl_fini, 0);
-
 		if (trusted)
 		{
 			plperl_trusted_init();
@@ -379,6 +377,10 @@ select_perl_context(bool trusted)
 			plperl_untrusted_interp = plperl_held_interp;
 			interp_state = INTERP_UNTRUSTED;
 		}
+
+		/* successfully initialized, so arrange for cleanup */
+		on_proc_exit(plperl_fini, 0);
+
 	}
 	else
 	{
@@ -673,14 +675,16 @@ plperl_trusted_init(void)
 	SV		   *safe_version_sv;
 	IV			safe_version_x100;
 
-	safe_version_sv = eval_pv(SAFE_MODULE, FALSE);	/* TRUE = croak if failure */
+	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
+	 * 2.21: http://rt.perl.org/rt3/Ticket/Display.html?id=72700
 	 */
-	if (safe_version_x100 < 209 || safe_version_x100 == 220)
+	if (safe_version_x100 < 209 || safe_version_x100 == 220 || 
+		safe_version_x100 == 221)
 	{
 		/* not safe, so disallow all trusted funcs */
 		eval_pv(PLC_SAFE_BAD, FALSE);
@@ -722,7 +726,7 @@ plperl_trusted_init(void)
 			XPUSHs(sv_2mortal(newSVstring(plperl_on_plperl_init)));
 			PUTBACK;
 
-			call_pv("::safe_eval", G_VOID);
+			call_pv("PostgreSQL::InServer::safe::safe_eval", G_VOID);
 			SPAGAIN;
 
 			if (SvTRUE(ERRSV))
@@ -1259,7 +1263,9 @@ plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid)
 	 * errors properly.  Perhaps it's because there's another level of eval
 	 * inside mksafefunc?
 	 */
-	compile_sub = (trusted) ? "::mksafefunc" : "::mkunsafefunc";
+	compile_sub = (trusted)
+		? "PostgreSQL::InServer::safe::mksafefunc"
+		: "PostgreSQL::InServer::mkunsafefunc";
 	count = perl_call_pv(compile_sub, G_SCALAR | G_EVAL | G_KEEPERR);
 	SPAGAIN;
 

src/pl/plperl/sql/plperl.sql

@@ -378,3 +378,7 @@ DO $$ use blib; $$ LANGUAGE plperl;
 -- 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;
 
+-- check that we can "use warnings" (in this case to turn a warn into an error)
+-- yields "ERROR:  Useless use of length in void context"
+DO $do$ use warnings FATAL => qw(void) ; length "abc" ; 1; $do$ LANGUAGE plperl;
+