Package namespace and Safe init cleanup for plperl UPDATE 3 [PATCH]

diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out
index ebf9afd..0e7c65d 100644
*** a/src/pl/plperl/expected/plperl.out
--- b/src/pl/plperl/expected/plperl.out
*************** CONTEXT:  PL/Perl anonymous code block
*** 577,579 ****
--- 577,584 ----
  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
diff --git a/src/pl/plperl/plc_perlboot.pl b/src/pl/plperl/plc_perlboot.pl
index 5d2e962..74b2a47 100644
*** a/src/pl/plperl/plc_perlboot.pl
--- b/src/pl/plperl/plc_perlboot.pl
***************
*** 1,26 ****
  
  #  $PostgreSQL$
  
  PostgreSQL::InServer::Util::bootstrap();
  
  use strict;
  use warnings;
  use vars qw(%_SHARED);
  
! sub ::plperl_warn {
  	(my $msg = shift) =~ s/\(eval \d+\) //g;
  	chomp $msg;
! 	&elog(&NOTICE, $msg);
  }
! $SIG{__WARN__} = \&::plperl_warn;
  
! sub ::plperl_die {
  	(my $msg = shift) =~ s/\(eval \d+\) //g;
  	die $msg;
  }
! $SIG{__DIE__} = \&::plperl_die;
  
! sub ::mkfuncsrc {
  	my ($name, $imports, $prolog, $src) = @_;
  
  	my $BEGIN = join "\n", map {
--- 1,30 ----
  
  #  $PostgreSQL$
  
+ use 5.008001;
+ 
  PostgreSQL::InServer::Util::bootstrap();
  
+ package PostgreSQL::InServer;
+ 
  use strict;
  use warnings;
  use vars qw(%_SHARED);
  
! sub plperl_warn {
  	(my $msg = shift) =~ s/\(eval \d+\) //g;
  	chomp $msg;
! 	&::elog(&::NOTICE, $msg);
  }
! $SIG{__WARN__} = \&plperl_warn;
  
! sub plperl_die {
  	(my $msg = shift) =~ s/\(eval \d+\) //g;
  	die $msg;
  }
! $SIG{__DIE__} = \&plperl_die;
  
! sub mkfuncsrc {
  	my ($name, $imports, $prolog, $src) = @_;
  
  	my $BEGIN = join "\n", map {
*************** sub ::mkfuncsrc {
*** 32,44 ****
  	$name =~ s/\\/\\\\/g;
  	$name =~ s/::|'/_/g; # avoid package delimiters
  
! 	return qq[ undef *{'$name'}; *{'$name'} = sub { $BEGIN $prolog $src } ];
  }
  
  # 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;
  }
--- 36,48 ----
  	$name =~ s/\\/\\\\/g;
  	$name =~ s/::|'/_/g; # avoid package delimiters
  
! 	return qq[ package main; undef *{'$name'}; *{'$name'} = sub { $BEGIN $prolog $src } ];
  }
  
  # 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_literal {
*** 67,73 ****
  
  sub ::encode_array_constructor {
  	my $arg = shift;
! 	return quote_nullable($arg)
  		if ref $arg ne 'ARRAY';
  	my $res = join ", ", map {
  		(ref $_) ? ::encode_array_constructor($_)
--- 71,77 ----
  
  sub ::encode_array_constructor {
  	my $arg = shift;
! 	return ::quote_nullable($arg)
  		if ref $arg ne 'ARRAY';
  	my $res = join ", ", map {
  		(ref $_) ? ::encode_array_constructor($_)
diff --git a/src/pl/plperl/plc_safe_ok.pl b/src/pl/plperl/plc_safe_ok.pl
index e3666f2..5d0fc93 100644
*** a/src/pl/plperl/plc_safe_ok.pl
--- b/src/pl/plperl/plc_safe_ok.pl
***************
*** 1,43 ****
  
- 
  #  $PostgreSQL$
  
  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
- 	&spi_prepare &spi_exec_prepared &spi_query_prepared &spi_freeplan
- 	&DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED
- 	&quote_literal &quote_nullable &quote_ident
- 	&encode_bytea &decode_bytea
- 	&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_trusted_init
! sub ::safe_eval {
  	my $ret = $PLContainer->reval(shift);
  	$@ =~ s/\(eval \d+\) //g if $@;
  	return $ret;
  }
  
! sub ::mksafefunc {
! 	return ::safe_eval(::mkfuncsrc(@_));
  }
--- 1,91 ----
  
  #  $PostgreSQL$
  
+ package PostgreSQL::InServer::safe;
+ 
  use strict;
! use warnings;
! use Safe;
! 
! # @EvalInSafe    = ( [ "string to eval", "extra,opcodes,to,allow" ], ...)
! # @ShareIntoSafe = ( [ from_class => \@symbols ], ...)
! use vars qw($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.
! 
! 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
! 			&return_next &_SHARED
! 			&quote_literal &quote_nullable &quote_ident
! 			&encode_bytea &decode_bytea &looks_like_number
! 			&encode_array_literal &encode_array_constructor
! 		) ],
! 	];
! }
! 
! # --- 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(PostgreSQL::InServer::mkfuncsrc(@_));
  }
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index 2b6ec2f..44cb5a3 100644
*** a/src/pl/plperl/plperl.c
--- b/src/pl/plperl/plperl.c
*************** plperl_trusted_init(void)
*** 724,730 ****
  			XPUSHs(sv_2mortal(newSVstring(plperl_on_trusted_init)));
  			PUTBACK;
  
! 			call_pv("::safe_eval", G_VOID);
  			SPAGAIN;
  
  			if (SvTRUE(ERRSV))
--- 724,730 ----
  			XPUSHs(sv_2mortal(newSVstring(plperl_on_trusted_init)));
  			PUTBACK;
  
! 			call_pv("PostgreSQL::InServer::safe::safe_eval", G_VOID);
  			SPAGAIN;
  
  			if (SvTRUE(ERRSV))
*************** plperl_create_sub(plperl_proc_desc *prod
*** 1269,1275 ****
  	 * 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;
  
--- 1269,1277 ----
  	 * errors properly.  Perhaps it's because there's another level of eval
  	 * inside mksafefunc?
  	 */
! 	compile_sub = (trusted)
! 		? "PostgreSQL::InServer::safe::mksafefunc"
! 		: "PostgreSQL::InServer::mkunsafefunc";
  	count = perl_call_pv(compile_sub, G_SCALAR | G_EVAL | G_KEEPERR);
  	SPAGAIN;
  
*************** plperl_create_sub(plperl_proc_desc *prod
*** 1297,1303 ****
  	{
  		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);
--- 1299,1305 ----
  	{
  		ereport(ERROR,
  				(errcode(ERRCODE_INTERNAL_ERROR),
! 				 errmsg_internal("didn't get a GLOB from compiling %s via %s", prodesc->proname, compile_sub)));
  	}
  
  	prodesc->reference = newSVsv(subref);
diff --git a/src/pl/plperl/sql/plperl.sql b/src/pl/plperl/sql/plperl.sql
index e6ef5f0..905e918 100644
*** a/src/pl/plperl/sql/plperl.sql
--- b/src/pl/plperl/sql/plperl.sql
*************** DO $$ use blib; $$ LANGUAGE plperl;
*** 378,380 ****
--- 378,384 ----
  -- 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;
+