diff --git a/doc/src/sgml/plperl.sgml b/doc/src/sgml/plperl.sgml
index c4129510fc1ca42c10d4b042a8a5e5d7bb2edce5..7d17002acfff6de6b3fcc15485d755b92d79aa6e 100644
--- a/doc/src/sgml/plperl.sgml
+++ b/doc/src/sgml/plperl.sgml
@@ -1,4 +1,4 @@
-<!-- $PostgreSQL: pgsql/doc/src/sgml/plperl.sgml,v 2.83 2010/04/03 07:22:55 petere Exp $ -->
+<!-- $PostgreSQL: pgsql/doc/src/sgml/plperl.sgml,v 2.84 2010/05/13 16:39:43 adunstan Exp $ -->
<chapter id="plperl">
<title>PL/Perl - Perl Procedural Language</title>
@@ -1154,8 +1154,16 @@ CREATE TRIGGER test_valid_id_trig
into a module and loaded by the <literal>on_init</> string.
Examples:
<programlisting>
-plperl.on_init = '$ENV{NYTPROF}="start=no"; require Devel::NYTProf::PgPLPerl'
+plperl.on_init = 'require "plperlinit.pl"'
plperl.on_init = 'use lib "/my/app"; use MyApp::PgInit;'
+</programlisting>
+ </para>
+ <para>
+ Any modules loaded by <literal>plperl.on_init</>, either directly or
+ indirectly, will be available for use by <literal>plperl</>. This may
+ create a security risk. To see what modules have been loaded you can use:
+<programlisting>
+DO 'elog(WARNING, join ", ", sort keys %INC)' language plperl;
</programlisting>
</para>
<para>
diff --git a/src/pl/plperl/GNUmakefile b/src/pl/plperl/GNUmakefile
index e4fc226c336059f46d5a569e3cfdd9bc8d5459e8..6bbd1bfb239eccf51938bcda7ccba81d6b458d54 100644
--- a/src/pl/plperl/GNUmakefile
+++ b/src/pl/plperl/GNUmakefile
@@ -1,5 +1,5 @@
# Makefile for PL/Perl
-# $PostgreSQL: pgsql/src/pl/plperl/GNUmakefile,v 1.43 2010/02/12 19:35:25 adunstan Exp $
+# $PostgreSQL: pgsql/src/pl/plperl/GNUmakefile,v 1.44 2010/05/13 16:39:43 adunstan Exp $
subdir = src/pl/plperl
top_builddir = ../../..
@@ -36,7 +36,7 @@ NAME = plperl
OBJS = plperl.o SPI.o Util.o
-PERLCHUNKS = plc_perlboot.pl plc_safe_bad.pl plc_safe_ok.pl
+PERLCHUNKS = plc_perlboot.pl plc_trusted.pl
SHLIB_LINK = $(perl_embed_ldflags)
@@ -54,9 +54,12 @@ PSQLDIR = $(bindir)
include $(top_srcdir)/src/Makefile.shlib
-plperl.o: perlchunks.h
+plperl.o: perlchunks.h plperl_opmask.h
-perlchunks.h: $(PERLCHUNKS)
+plperl_opmask.h: plperl_opmask.pl
+ $(PERL) $< $@
+
+perlchunks.h: $(PERLCHUNKS)
$(PERL) $(srcdir)/text2macro.pl --strip='^(\#.*|\s*)$$' $^ > $@
all: all-lib
@@ -81,7 +84,7 @@ submake:
$(MAKE) -C $(top_builddir)/src/test/regress pg_regress$(X)
clean distclean maintainer-clean: clean-lib
- rm -f SPI.c Util.c $(OBJS) perlchunks.h
+ rm -f SPI.c Util.c $(OBJS) perlchunks.h plperl_opmask.h
rm -rf results
rm -f regression.diffs regression.out
diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out
index b3027f892684e9e3c258a141c308f4950eb564aa..e3e9ec7b6f82565f35c4c7e822ed3e1cf2533b94 100644
--- a/src/pl/plperl/expected/plperl.out
+++ b/src/pl/plperl/expected/plperl.out
@@ -563,8 +563,23 @@ $$ LANGUAGE plperl;
NOTICE: This is a test
CONTEXT: PL/Perl anonymous code block
-- check that restricted operations are rejected in a plperl DO block
-DO $$ eval "1+1"; $$ LANGUAGE plperl;
-ERROR: 'eval "string"' trapped by operation mask at line 1.
+DO $$ system("/nonesuch"); $$ LANGUAGE plperl;
+ERROR: 'system' trapped by operation mask at line 1.
+CONTEXT: PL/Perl anonymous code block
+DO $$ qx("/nonesuch"); $$ LANGUAGE plperl;
+ERROR: 'quoted execution (``, qx)' trapped by operation mask at line 1.
+CONTEXT: PL/Perl anonymous code block
+DO $$ open my $fh, "</nonesuch"; $$ LANGUAGE plperl;
+ERROR: 'open' trapped by operation mask at line 1.
+CONTEXT: PL/Perl anonymous code block
+-- check that eval is allowed and eval'd restricted ops are caught
+DO $$ eval q{chdir '.'}; warn "Caught: $@"; $$ LANGUAGE plperl;
+WARNING: Caught: 'chdir' trapped by operation mask at line 2.
+CONTEXT: PL/Perl anonymous code block
+-- check that compiling do (dofile opcode) is allowed
+-- but that executing it for a file not already loaded (via require) dies
+DO $$ warn do "/dev/null"; $$ LANGUAGE plperl;
+ERROR: Unable to load /dev/null into plperl at line 1.
CONTEXT: PL/Perl anonymous code block
-- check that we can't "use" a module that's not been loaded already
-- compile-time error: "Unable to load blib.pm into plperl"
diff --git a/src/pl/plperl/expected/plperl_init.out b/src/pl/plperl/expected/plperl_init.out
index dca5d8f0ec660ca33ce73a67eedc969ec54df150..b335dcc6d30edfd35ff910396730669d4f3b6291 100644
--- a/src/pl/plperl/expected/plperl_init.out
+++ b/src/pl/plperl/expected/plperl_init.out
@@ -1,14 +1,14 @@
-- test plperl.on_plperl_init errors are fatal
-- Avoid need for custom_variable_classes = 'plperl'
LOAD 'plperl';
-SET SESSION plperl.on_plperl_init = ' eval "1+1" ';
+SET SESSION plperl.on_plperl_init = ' system("/nonesuch") ';
SHOW plperl.on_plperl_init;
plperl.on_plperl_init
-----------------------
- eval "1+1"
+ system("/nonesuch")
(1 row)
DO $$ warn 42 $$ language plperl;
-ERROR: 'eval "string"' trapped by operation mask at line 2.
-CONTEXT: while executing plperl.on_plperl_init
+ERROR: 'system' trapped by operation mask at line 2.
+CONTEXT: While executing plperl.on_plperl_init.
PL/Perl anonymous code block
diff --git a/src/pl/plperl/expected/plperl_plperlu.out b/src/pl/plperl/expected/plperl_plperlu.out
index acc9dd4de3328a9023b3f2a6c5a3fbbbfa3883e2..479a902de438a8670de9021c2e1b813c96c19098 100644
--- a/src/pl/plperl/expected/plperl_plperlu.out
+++ b/src/pl/plperl/expected/plperl_plperlu.out
@@ -63,3 +63,31 @@ select bar('hey');
hey
(1 row)
+--
+-- Make sure we can't use/require things in plperl
+--
+CREATE OR REPLACE FUNCTION use_plperlu() RETURNS void LANGUAGE plperlu
+AS $$
+use Errno;
+$$;
+CREATE OR REPLACE FUNCTION use_plperl() RETURNS void LANGUAGE plperl
+AS $$
+use Errno;
+$$;
+ERROR: Unable to load Errno.pm into plperl at line 2.
+BEGIN failed--compilation aborted at line 2.
+CONTEXT: compilation of PL/Perl function "use_plperl"
+-- make sure our overloaded require op gets restored/set correctly
+select use_plperlu();
+ use_plperlu
+-------------
+
+(1 row)
+
+CREATE OR REPLACE FUNCTION use_plperl() RETURNS void LANGUAGE plperl
+AS $$
+use Errno;
+$$;
+ERROR: Unable to load Errno.pm into plperl at line 2.
+BEGIN failed--compilation aborted at line 2.
+CONTEXT: compilation of PL/Perl function "use_plperl"
diff --git a/src/pl/plperl/plc_perlboot.pl b/src/pl/plperl/plc_perlboot.pl
index d3bb614a5d0a6783efa04d03395a9783e95a14f3..379d4bfa5b7038114593eaefb1ab848f666f4791 100644
--- a/src/pl/plperl/plc_perlboot.pl
+++ b/src/pl/plperl/plc_perlboot.pl
@@ -1,5 +1,5 @@
-# $PostgreSQL: pgsql/src/pl/plperl/plc_perlboot.pl,v 1.5 2010/02/16 21:39:52 adunstan Exp $
+# $PostgreSQL: pgsql/src/pl/plperl/plc_perlboot.pl,v 1.6 2010/05/13 16:39:43 adunstan Exp $
use 5.008001;
@@ -33,15 +33,12 @@ sub mkfuncsrc {
} sort keys %$imports;
$BEGIN &&= "BEGIN { $BEGIN }";
- $name =~ s/\\/\\\\/g;
- $name =~ s/::|'/_/g; # avoid package delimiters
-
- return qq[ package main; undef *{'$name'}; *{'$name'} = sub { $BEGIN $prolog $src } ];
+ return qq[ package main; sub { $BEGIN $prolog $src } ];
}
-# see also mksafefunc() in plc_safe_ok.pl
-sub mkunsafefunc {
- no strict; # default to no strict for the eval
+sub mkfunc {
+ no strict; # default to no strict for the eval
+ no warnings; # default to no warnings for the eval
my $ret = eval(mkfuncsrc(@_));
$@ =~ s/\(eval \d+\) //g if $@;
return $ret;
diff --git a/src/pl/plperl/plc_safe_bad.pl b/src/pl/plperl/plc_safe_bad.pl
deleted file mode 100644
index 89eb11b642b6908a40009a385869b985c79ae12c..0000000000000000000000000000000000000000
--- a/src/pl/plperl/plc_safe_bad.pl
+++ /dev/null
@@ -1,16 +0,0 @@
-
-# $PostgreSQL: pgsql/src/pl/plperl/plc_safe_bad.pl,v 1.3 2010/01/26 23:11:56 adunstan Exp $
-
-# Minimal version of plc_safe_ok.pl
-# that's used if Safe is too old or doesn't load for any reason
-
-my $msg = 'trusted Perl functions disabled - please upgrade Perl Safe module';
-
-sub mksafefunc {
- my ($name, $pragma, $prolog, $src) = @_;
- # replace $src with code to generate an error
- $src = qq{ ::elog(::ERROR,"$msg\n") };
- my $ret = eval(::mkfuncsrc($name, $pragma, '', $src));
- $@ =~ s/\(eval \d+\) //g if $@;
- return $ret;
-}
diff --git a/src/pl/plperl/plc_safe_ok.pl b/src/pl/plperl/plc_safe_ok.pl
deleted file mode 100644
index b76900de765b6e93e1dbb449d66ae4183ed32e2d..0000000000000000000000000000000000000000
--- a/src/pl/plperl/plc_safe_ok.pl
+++ /dev/null
@@ -1,95 +0,0 @@
-
-
-# $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 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->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/plc_trusted.pl b/src/pl/plperl/plc_trusted.pl
new file mode 100644
index 0000000000000000000000000000000000000000..a76cc2f5adfd66cab3615e83ef9fe8f3e68448f3
--- /dev/null
+++ b/src/pl/plperl/plc_trusted.pl
@@ -0,0 +1,29 @@
+
+
+# $PostgreSQL: pgsql/src/pl/plperl/plc_trusted.pl,v 1.1 2010/05/13 16:39:43 adunstan Exp $
+
+package PostgreSQL::InServer::safe;
+
+# Load widely useful pragmas into plperl to make them available.
+#
+# SECURITY RISKS:
+#
+# Since these modules are free to compile unsafe opcodes they must
+# be trusted to now allow any code containing unsafe opcodes to be abused.
+# That's much harder than it sounds.
+#
+# Be aware that perl provides a wide variety of ways to subvert
+# pre-compiled code. For some examples, see this presentation:
+# http://www.slideshare.net/cdman83/barely-legal-xxx-perl-presentation
+#
+# If in ANY doubt about a module, or ANY of the modules down the chain of
+# dependencies it loads, then DO NOT add it to this list.
+#
+# To check if any of these modules use "unsafe" opcodes you can compile
+# plperl with the PLPERL_ENABLE_OPMASK_EARLY macro defined. See plperl.c
+
+require strict;
+require Carp;
+require Carp::Heavy;
+require warnings;
+require feature if $] >= 5.010000;
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index 9ad2d40d114778ae27918e27e5c5f9cbb20413c4..de6ddb288fd053afa9546110fbabda894514f9a1 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.174 2010/04/18 19:16:06 tgl Exp $
+ * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.175 2010/05/13 16:39:43 adunstan Exp $
*
**********************************************************************/
@@ -46,6 +46,8 @@
/* string literal macros defining chunks of perl code */
#include "perlchunks.h"
+/* defines PLPERL_SET_OPMASK */
+#include "plperl_opmask.h"
PG_MODULE_MAGIC;
@@ -134,6 +136,7 @@ static PerlInterpreter *plperl_trusted_interp = NULL;
static PerlInterpreter *plperl_untrusted_interp = NULL;
static PerlInterpreter *plperl_held_interp = NULL;
static OP *(*pp_require_orig) (pTHX) = NULL;
+static OP *pp_require_safe(pTHX);
static bool trusted_context;
static HTAB *plperl_proc_hash = NULL;
static HTAB *plperl_query_hash = NULL;
@@ -143,6 +146,8 @@ static char *plperl_on_init = NULL;
static char *plperl_on_plperl_init = NULL;
static char *plperl_on_plperlu_init = NULL;
static bool plperl_ending = false;
+static char plperl_opmask[MAXO];
+static void set_interp_require(void);
/* this is saved and restored by plperl_call_handler */
static plperl_call_data *current_call_data = NULL;
@@ -180,6 +185,9 @@ static void plperl_inline_callback(void *arg);
static char *strip_trailing_ws(const char *msg);
static OP *pp_require_safe(pTHX);
static int restore_context(bool);
+#ifdef WIN32
+static char *setlocale_perl(int category, char *locale);
+#endif
/*
* Convert an SV to char * and verify the encoding via pg_verifymbstr()
@@ -228,7 +236,13 @@ perm_fmgr_info(Oid functionId, FmgrInfo *finfo)
void
_PG_init(void)
{
- /* Be sure we do initialization only once (should be redundant now) */
+ /*
+ * Be sure we do initialization only once.
+ *
+ * If initialization fails due to, e.g., plperl_init_interp() throwing an
+ * exception, then we'll return here on the next usage and the user will
+ * get a rather cryptic: ERROR: attempt to redefine parameter "plperl.use_strict"
+ */
static bool inited = false;
HASHCTL hash_ctl;
@@ -296,6 +310,8 @@ _PG_init(void)
&hash_ctl,
HASH_ELEM);
+ PLPERL_SET_OPMASK(plperl_opmask);
+
plperl_held_interp = plperl_init_interp();
interp_state = INTERP_HELD;
@@ -303,6 +319,21 @@ _PG_init(void)
}
+static void
+set_interp_require(void)
+{
+ if (trusted_context)
+ {
+ PL_ppaddr[OP_REQUIRE] = pp_require_safe;
+ PL_ppaddr[OP_DOFILE] = pp_require_safe;
+ }
+ else
+ {
+ PL_ppaddr[OP_REQUIRE] = pp_require_orig;
+ PL_ppaddr[OP_DOFILE] = pp_require_orig;
+ }
+}
+
/*
* Cleanup perl interpreters, including running END blocks.
* Does not fully undo the actions of _PG_init() nor make it callable again.
@@ -335,9 +366,6 @@ plperl_fini(int code, Datum arg)
}
-#define SAFE_MODULE \
- "require Safe; $Safe::VERSION"
-
/********************************************************************
*
* We start out by creating a "held" interpreter that we can use in
@@ -406,6 +434,7 @@ select_perl_context(bool trusted)
}
plperl_held_interp = NULL;
trusted_context = trusted;
+ set_interp_require();
/*
* Since the timing of first use of PL/Perl can't be predicted, any
@@ -438,16 +467,12 @@ restore_context(bool trusted)
if (trusted_context != trusted)
{
if (trusted)
- {
PERL_SET_CONTEXT(plperl_trusted_interp);
- PL_ppaddr[OP_REQUIRE] = pp_require_safe;
- }
else
- {
PERL_SET_CONTEXT(plperl_untrusted_interp);
- PL_ppaddr[OP_REQUIRE] = pp_require_orig;
- }
+
trusted_context = trusted;
+ set_interp_require();
}
return 1; /* context restored */
}
@@ -484,7 +509,7 @@ plperl_init_interp(void)
* subsequent calls to the interpreter don't mess with the locale
* settings.
*
- * We restore them using Perl's POSIX::setlocale() function so that Perl
+ * We restore them using setlocale_perl(), defined below, so that Perl
* doesn't have a different idea of the locale from Postgres.
*
*/
@@ -495,7 +520,6 @@ plperl_init_interp(void)
*save_monetary,
*save_numeric,
*save_time;
- char buf[1024];
loc = setlocale(LC_COLLATE, NULL);
save_collate = loc ? pstrdup(loc) : NULL;
@@ -507,6 +531,12 @@ plperl_init_interp(void)
save_numeric = loc ? pstrdup(loc) : NULL;
loc = setlocale(LC_TIME, NULL);
save_time = loc ? pstrdup(loc) : NULL;
+
+#define PLPERL_RESTORE_LOCALE(name, saved) \
+ STMT_START { \
+ if (saved != NULL) { setlocale_perl(name, saved); pfree(saved); } \
+ } STMT_END
+
#endif
if (plperl_on_init)
@@ -548,13 +578,26 @@ plperl_init_interp(void)
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
/*
- * Record the original function for the 'require' opcode. Ensure it's used
- * for new interpreters.
+ * Record the original function for the 'require' and 'dofile' opcodes.
+ * (They share the same implementation.) Ensure it's used for new interpreters.
*/
if (!pp_require_orig)
pp_require_orig = PL_ppaddr[OP_REQUIRE];
- else
+ else
+ {
PL_ppaddr[OP_REQUIRE] = pp_require_orig;
+ PL_ppaddr[OP_DOFILE] = pp_require_orig;
+ }
+
+#ifdef PLPERL_ENABLE_OPMASK_EARLY
+ /*
+ * For regression testing to prove that the PLC_PERLBOOT and PLC_TRUSTED
+ * code doesn't even compile any unsafe ops. In future there may be a
+ * valid need for them to do so, in which case this could be softened
+ * (perhaps moved to plperl_trusted_init()) or removed.
+ */
+ PL_op_mask = plperl_opmask;
+#endif
if (perl_parse(plperl, plperl_init_shared_libs,
nargs, embedding, NULL) != 0)
@@ -567,45 +610,12 @@ plperl_init_interp(void)
(errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
errcontext("while running Perl initialization")));
-#ifdef WIN32
-
- eval_pv("use POSIX qw(locale_h);", TRUE); /* croak on failure */
-
- if (save_collate != NULL)
- {
- snprintf(buf, sizeof(buf), "setlocale(%s,'%s');",
- "LC_COLLATE", save_collate);
- eval_pv(buf, TRUE);
- pfree(save_collate);
- }
- if (save_ctype != NULL)
- {
- snprintf(buf, sizeof(buf), "setlocale(%s,'%s');",
- "LC_CTYPE", save_ctype);
- eval_pv(buf, TRUE);
- pfree(save_ctype);
- }
- if (save_monetary != NULL)
- {
- snprintf(buf, sizeof(buf), "setlocale(%s,'%s');",
- "LC_MONETARY", save_monetary);
- eval_pv(buf, TRUE);
- pfree(save_monetary);
- }
- if (save_numeric != NULL)
- {
- snprintf(buf, sizeof(buf), "setlocale(%s,'%s');",
- "LC_NUMERIC", save_numeric);
- eval_pv(buf, TRUE);
- pfree(save_numeric);
- }
- if (save_time != NULL)
- {
- snprintf(buf, sizeof(buf), "setlocale(%s,'%s');",
- "LC_TIME", save_time);
- eval_pv(buf, TRUE);
- pfree(save_time);
- }
+#ifdef PLPERL_RESTORE_LOCALE
+ PLPERL_RESTORE_LOCALE(LC_COLLATE, save_collate);
+ PLPERL_RESTORE_LOCALE(LC_CTYPE, save_ctype);
+ PLPERL_RESTORE_LOCALE(LC_MONETARY, save_monetary);
+ PLPERL_RESTORE_LOCALE(LC_NUMERIC, save_numeric);
+ PLPERL_RESTORE_LOCALE(LC_TIME, save_time);
#endif
return plperl;
@@ -683,70 +693,76 @@ plperl_destroy_interp(PerlInterpreter **interp)
static void
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_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 ||
- safe_version_x100 == 221)
+ HV *stash;
+ SV *sv;
+ char *key;
+ I32 klen;
+
+ /* use original require while we set up */
+ PL_ppaddr[OP_REQUIRE] = pp_require_orig;
+ PL_ppaddr[OP_DOFILE] = pp_require_orig;
+
+ eval_pv(PLC_TRUSTED, FALSE);
+ if (SvTRUE(ERRSV))
+ ereport(ERROR,
+ (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
+ errcontext("While executing PLC_TRUSTED.")));
+
+ if (GetDatabaseEncoding() == PG_UTF8)
{
- /* not safe, so disallow all trusted funcs */
- eval_pv(PLC_SAFE_BAD, FALSE);
+ /*
+ * Force loading of utf8 module now to prevent errors that can
+ * arise from the regex code later trying to load utf8 modules.
+ * See http://rt.perl.org/rt3/Ticket/Display.html?id=47576
+ */
+ eval_pv("my $a=chr(0x100); return $a =~ /\\xa9/i", FALSE);
if (SvTRUE(ERRSV))
ereport(ERROR,
(errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
- errcontext("while executing PLC_SAFE_BAD")));
+ errcontext("While executing utf8fix.")));
}
- else
+
+ /*
+ * Lock down the interpreter
+ */
+
+ /* switch to the safe require/dofile opcode for future code */
+ PL_ppaddr[OP_REQUIRE] = pp_require_safe;
+ PL_ppaddr[OP_DOFILE] = pp_require_safe;
+
+ /*
+ * prevent (any more) unsafe opcodes being compiled
+ * PL_op_mask is per interpreter, so this only needs to be set once
+ */
+ PL_op_mask = plperl_opmask;
+
+ /* delete the DynaLoader:: namespace so extensions can't be loaded */
+ stash = gv_stashpv("DynaLoader", GV_ADDWARN);
+ hv_iterinit(stash);
+ while ((sv = hv_iternextsv(stash, &key, &klen)))
{
- eval_pv(PLC_SAFE_OK, FALSE);
+ if (!isGV_with_GP(sv) || !GvCV(sv))
+ continue;
+ SvREFCNT_dec(GvCV(sv)); /* free the CV */
+ GvCV(sv) = NULL; /* prevent call via GV */
+ }
+ hv_clear(stash);
+
+ /* invalidate assorted caches */
+ ++PL_sub_generation;
+ hv_clear(PL_stashcache);
+
+ /*
+ * Execute plperl.on_plperl_init in the locked-down interpreter
+ */
+ if (plperl_on_plperl_init && *plperl_on_plperl_init)
+ {
+ eval_pv(plperl_on_plperl_init, FALSE);
if (SvTRUE(ERRSV))
ereport(ERROR,
(errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
- errcontext("while executing PLC_SAFE_OK")));
-
- if (GetDatabaseEncoding() == PG_UTF8)
- {
- /*
- * Force loading of utf8 module now to prevent errors that can
- * arise from the regex code later trying to load utf8 modules.
- * See http://rt.perl.org/rt3/Ticket/Display.html?id=47576
- */
- eval_pv("my $a=chr(0x100); return $a =~ /\\xa9/i", FALSE);
- if (SvTRUE(ERRSV))
- ereport(ERROR,
- (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
- errcontext("while executing utf8fix")));
- }
-
- /* switch to the safe require opcode */
- PL_ppaddr[OP_REQUIRE] = pp_require_safe;
-
- if (plperl_on_plperl_init && *plperl_on_plperl_init)
- {
- dSP;
-
- PUSHMARK(SP);
- XPUSHs(sv_2mortal(newSVstring(plperl_on_plperl_init)));
- PUTBACK;
-
- call_pv("PostgreSQL::InServer::safe::safe_eval", G_VOID);
- SPAGAIN;
-
- if (SvTRUE(ERRSV))
- ereport(ERROR,
- (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
- errcontext("while executing plperl.on_plperl_init")));
- }
-
+ errcontext("While executing plperl.on_plperl_init.")));
+
}
}
@@ -1250,12 +1266,10 @@ static void
plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid)
{
dSP;
- bool trusted = prodesc->lanpltrusted;
char subname[NAMEDATALEN + 40];
HV *pragma_hv = newHV();
SV *subref = NULL;
int count;
- char *compile_sub;
sprintf(subname, "%s__%u", prodesc->proname, fn_oid);
@@ -1277,22 +1291,17 @@ 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)
- ? "PostgreSQL::InServer::safe::mksafefunc"
- : "PostgreSQL::InServer::mkunsafefunc";
- count = perl_call_pv(compile_sub, G_SCALAR | G_EVAL | G_KEEPERR);
+ count = perl_call_pv("PostgreSQL::InServer::mkfunc",
+ G_SCALAR | G_EVAL | G_KEEPERR);
SPAGAIN;
if (count == 1)
{
- GV *sub_glob = (GV *) POPs;
+ SV *sub_rv = (SV *) POPs;
- if (sub_glob && SvTYPE(sub_glob) == SVt_PVGV)
+ if (sub_rv && SvROK(sub_rv) && SvTYPE(SvRV(sub_rv)) == SVt_PVCV)
{
- SV *sv = (SV *) GvCVu((GV *) sub_glob);
-
- if (sv)
- subref = newRV_inc(sv);
+ subref = newRV_inc(SvRV(sub_rv));
}
}
@@ -1307,22 +1316,21 @@ plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid)
if (!subref)
ereport(ERROR,
- (errmsg("did not get a GLOB from compiling function \"%s\" via %s",
- prodesc->proname, compile_sub)));
-
- prodesc->reference = newSVsv(subref);
-
+ (errmsg("didn't get a CODE ref from compiling %s",
+ prodesc->proname)));
+
+ /* give the subroutine a proper name in the main:: symbol table */
+ CvGV(SvRV(subref)) = (GV *) newSV(0);
+ gv_init(CvGV(SvRV(subref)), PL_defstash, subname, strlen(subname), TRUE);
+
+ prodesc->reference = subref;
+
return;
}
/**********************************************************************
* plperl_init_shared_libs() -
- *
- * We cannot use the DynaLoader directly to get at the Opcode
- * module (used by Safe.pm). So, we link Opcode into ourselves
- * and do the initialization behind perl's back.
- *
**********************************************************************/
static void
@@ -3041,3 +3049,72 @@ plperl_inline_callback(void *arg)
{
errcontext("PL/Perl anonymous code block");
}
+
+
+/*
+ * Perl's own setlocal() copied from POSIX.xs
+ * (needed because of the calls to new_*())
+ */
+#ifdef WIN32
+static char *
+setlocale_perl(int category, char *locale)
+{
+ char *RETVAL = setlocale(category, locale);
+ if (RETVAL) {
+#ifdef USE_LOCALE_CTYPE
+ if (category == LC_CTYPE
+#ifdef LC_ALL
+ || category == LC_ALL
+#endif
+ )
+ {
+ char *newctype;
+#ifdef LC_ALL
+ if (category == LC_ALL)
+ newctype = setlocale(LC_CTYPE, NULL);
+ else
+#endif
+ newctype = RETVAL;
+ new_ctype(newctype);
+ }
+#endif /* USE_LOCALE_CTYPE */
+#ifdef USE_LOCALE_COLLATE
+ if (category == LC_COLLATE
+#ifdef LC_ALL
+ || category == LC_ALL
+#endif
+ )
+ {
+ char *newcoll;
+#ifdef LC_ALL
+ if (category == LC_ALL)
+ newcoll = setlocale(LC_COLLATE, NULL);
+ else
+#endif
+ newcoll = RETVAL;
+ new_collate(newcoll);
+ }
+#endif /* USE_LOCALE_COLLATE */
+
+#ifdef USE_LOCALE_NUMERIC
+ if (category == LC_NUMERIC
+#ifdef LC_ALL
+ || category == LC_ALL
+#endif
+ )
+ {
+ char *newnum;
+#ifdef LC_ALL
+ if (category == LC_ALL)
+ newnum = setlocale(LC_NUMERIC, NULL);
+ else
+#endif
+ newnum = RETVAL;
+ new_numeric(newnum);
+ }
+#endif /* USE_LOCALE_NUMERIC */
+ }
+
+ return RETVAL;
+}
+#endif
diff --git a/src/pl/plperl/plperl_opmask.pl b/src/pl/plperl/plperl_opmask.pl
new file mode 100644
index 0000000000000000000000000000000000000000..3e9ecaa3c1badfff550c63a80d7c28372951235f
--- /dev/null
+++ b/src/pl/plperl/plperl_opmask.pl
@@ -0,0 +1,58 @@
+#!perl -w
+
+use strict;
+use warnings;
+
+use Opcode qw(opset opset_to_ops opdesc);
+
+my $plperl_opmask_h = shift
+ or die "Usage: $0 <output_filename.h>\n";
+
+my $plperl_opmask_tmp = $plperl_opmask_h."tmp";
+END { unlink $plperl_opmask_tmp }
+
+open my $fh, ">", "$plperl_opmask_tmp"
+ or die "Could not write to $plperl_opmask_tmp: $!";
+
+printf $fh "#define PLPERL_SET_OPMASK(opmask) \\\n";
+printf $fh " memset(opmask, 1, MAXO);\t/* disable all */ \\\n";
+printf $fh " /* then allow some... */ \\\n";
+
+my @allowed_ops = (
+ # basic set of opcodes
+ qw[:default :base_math !:base_io sort time],
+ # require is safe because we redirect the opcode
+ # entereval is safe as the opmask is now permanently set
+ # caller is safe because the entire interpreter is locked down
+ qw[require entereval caller],
+ # These are needed for utf8_heavy.pl:
+ # dofile is safe because we redirect the opcode like require above
+ # print is safe because the only writable filehandles are STDOUT & STDERR
+ # prtf (printf) is safe as it's the same as print + sprintf
+ qw[dofile print prtf],
+ # Disallow these opcodes that are in the :base_orig optag
+ # (included in :default) but aren't considered sufficiently safe
+ qw[!dbmopen !setpgrp !setpriority],
+ # custom is not deemed a likely security risk as it can't be generated from
+ # perl so would only be seen if the DBA had chosen to load a module that
+ # used it. Even then it's unlikely to be seen because it's typically
+ # generated by compiler plugins that operate after PL_op_mask checks.
+ # But we err on the side of caution and disable it
+ qw[!custom],
+);
+
+printf $fh " /* ALLOWED: @allowed_ops */ \\\n";
+
+foreach my $opname (opset_to_ops(opset(@allowed_ops))) {
+ printf $fh qq{ opmask[OP_%-12s] = 0;\t/* %s */ \\\n},
+ uc($opname), opdesc($opname);
+}
+printf $fh " /* end */ \n";
+
+close $fh
+ or die "Error closing $plperl_opmask_tmp: $!";
+
+rename $plperl_opmask_tmp, $plperl_opmask_h
+ or die "Error renaming $plperl_opmask_tmp to $plperl_opmask_h: $!";
+
+exit 0;
diff --git a/src/pl/plperl/sql/plperl.sql b/src/pl/plperl/sql/plperl.sql
index 6d4c5c2a85448d10cd2c570d2092e052b046d93a..651d5ee2b413689f5ffdd93a78a158c5efa5bfae 100644
--- a/src/pl/plperl/sql/plperl.sql
+++ b/src/pl/plperl/sql/plperl.sql
@@ -368,7 +368,16 @@ DO $$
$$ LANGUAGE plperl;
-- check that restricted operations are rejected in a plperl DO block
-DO $$ eval "1+1"; $$ LANGUAGE plperl;
+DO $$ system("/nonesuch"); $$ LANGUAGE plperl;
+DO $$ qx("/nonesuch"); $$ LANGUAGE plperl;
+DO $$ open my $fh, "</nonesuch"; $$ LANGUAGE plperl;
+
+-- check that eval is allowed and eval'd restricted ops are caught
+DO $$ eval q{chdir '.'}; warn "Caught: $@"; $$ LANGUAGE plperl;
+
+-- check that compiling do (dofile opcode) is allowed
+-- but that executing it for a file not already loaded (via require) dies
+DO $$ warn do "/dev/null"; $$ LANGUAGE plperl;
-- check that we can't "use" a module that's not been loaded already
-- compile-time error: "Unable to load blib.pm into plperl"
diff --git a/src/pl/plperl/sql/plperl_init.sql b/src/pl/plperl/sql/plperl_init.sql
index 69b12e9d25f6a8862435ec844ff8e19489036faf..f6a32b9bae4792ab449ef62cdb717384adca6bd8 100644
--- a/src/pl/plperl/sql/plperl_init.sql
+++ b/src/pl/plperl/sql/plperl_init.sql
@@ -3,7 +3,7 @@
-- Avoid need for custom_variable_classes = 'plperl'
LOAD 'plperl';
-SET SESSION plperl.on_plperl_init = ' eval "1+1" ';
+SET SESSION plperl.on_plperl_init = ' system("/nonesuch") ';
SHOW plperl.on_plperl_init;
diff --git a/src/pl/plperl/sql/plperl_plperlu.sql b/src/pl/plperl/sql/plperl_plperlu.sql
index cbc5080fa63d3074c2e8ad79390449dd8a83b537..65281c2df91bdd93295235334643117ccf824932 100644
--- a/src/pl/plperl/sql/plperl_plperlu.sql
+++ b/src/pl/plperl/sql/plperl_plperlu.sql
@@ -35,3 +35,24 @@ select bar('hey');
create or replace function bar(text) returns text language plperlu as 'shift';
select bar('hey');
+--
+-- Make sure we can't use/require things in plperl
+--
+
+CREATE OR REPLACE FUNCTION use_plperlu() RETURNS void LANGUAGE plperlu
+AS $$
+use Errno;
+$$;
+
+CREATE OR REPLACE FUNCTION use_plperl() RETURNS void LANGUAGE plperl
+AS $$
+use Errno;
+$$;
+
+-- make sure our overloaded require op gets restored/set correctly
+select use_plperlu();
+
+CREATE OR REPLACE FUNCTION use_plperl() RETURNS void LANGUAGE plperl
+AS $$
+use Errno;
+$$;