diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out index ebf9afd904bedab21189126cdc5542c238adc083..0e7c65dc2b0a0f751bca9f08f40783f9a0f15650 100644 --- a/src/pl/plperl/expected/plperl.out +++ b/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 diff --git a/src/pl/plperl/expected/plperl_elog.out b/src/pl/plperl/expected/plperl_elog.out index 89497e3236d48b80fe042ea1598b1f9f49b61cc3..02497d9e02bea1b865b35d148c6750a2f7649d0f 100644 --- a/src/pl/plperl/expected/plperl_elog.out +++ b/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 ----------- diff --git a/src/pl/plperl/expected/plperlu.out b/src/pl/plperl/expected/plperlu.out index a37262c1c27a9b9287cd9f3a4235cabc4f30c0cb..25ac007b7a27b71558356c37adb2e2e9856b87b4 100644 --- a/src/pl/plperl/expected/plperlu.out +++ b/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. diff --git a/src/pl/plperl/plc_perlboot.pl b/src/pl/plperl/plc_perlboot.pl index 9364a30ece3b9fd0533e1b7bca9e4852e48e43a2..d3bb614a5d0a6783efa04d03395a9783e95a14f3 100644 --- a/src/pl/plperl/plc_perlboot.pl +++ b/src/pl/plperl/plc_perlboot.pl @@ -1,26 +1,30 @@ -# $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($_) diff --git a/src/pl/plperl/plc_safe_ok.pl b/src/pl/plperl/plc_safe_ok.pl index 6e17f45e654849cc1bf7db825be3934270b116ff..b76900de765b6e93e1dbb449d66ae4183ed32e2d 100644 --- a/src/pl/plperl/plc_safe_ok.pl +++ b/src/pl/plperl/plc_safe_ok.pl @@ -1,43 +1,95 @@ -# $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; + +# @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. + +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 + "e_literal "e_nullable "e_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 = 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 - "e_literal "e_nullable "e_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_plperl_init -sub ::safe_eval { +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(@_)); } diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c index f181c39610c7c699bfe6bf8cf0e5cfa32b276cf5..31ff7057a0944f9663c3956c892acee728e54105 100644 --- a/src/pl/plperl/plperl.c +++ b/src/pl/plperl/plperl.c @@ -1,7 +1,7 @@ /********************************************************************** * 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; diff --git a/src/pl/plperl/sql/plperl.sql b/src/pl/plperl/sql/plperl.sql index e6ef5f069effa3dcfb06082d699f44f9fd4ce23e..905e9187d408dd090c75c57cebad9126a9c2d7c3 100644 --- a/src/pl/plperl/sql/plperl.sql +++ b/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; +