aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/pl/plperl/expected/plperl.out5
-rw-r--r--src/pl/plperl/expected/plperl_elog.out2
-rw-r--r--src/pl/plperl/expected/plperlu.out2
-rw-r--r--src/pl/plperl/plc_perlboot.pl26
-rw-r--r--src/pl/plperl/plc_safe_ok.pl110
-rw-r--r--src/pl/plperl/plperl.c20
-rw-r--r--src/pl/plperl/sql/plperl.sql4
7 files changed, 120 insertions, 49 deletions
diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out
index ebf9afd904b..0e7c65dc2b0 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 89497e3236d..02497d9e02b 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 a37262c1c27..25ac007b7a2 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 9364a30ece3..d3bb614a5d0 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 6e17f45e654..b76900de765 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
+ &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 = 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_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 f181c39610c..31ff7057a09 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 e6ef5f069ef..905e9187d40 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;
+
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-24 22:55:57 +0000