From 1f474d299d02c398fa627d09d23a7a6a1079a310 Mon Sep 17 00:00:00 2001 From: Andrew Dunstan Date: Thu, 13 May 2010 16:39:43 +0000 Subject: [PATCH] Abandon the use of Perl's Safe.pm to enforce restrictions in plperl, as it is fundamentally insecure. Instead apply an opmask to the whole interpreter that imposes restrictions on unsafe operations. These restrictions are much harder to subvert than is Safe.pm, since there is no container to be broken out of. Backported to release 7.4. In releases 7.4, 8.0 and 8.1 this also includes the necessary backporting of the two interpreters model for plperl and plperlu adopted in release 8.2. In versions 8.0 and up, the use of Perl's POSIX module to undo its locale mangling on Windows has become insecure with these changes, so it is replaced by our own routine, which is also faster. Nice side effects of the changes include that it is now possible to use perl's "strict" pragma in a natural way in plperl, and that perl's $a and $b variables now work as expected in sort routines, and that function compilation is significantly faster. Tim Bunce and Andrew Dunstan, with reviews from Alex Hunsaker and Alexey Klyukin. Security: CVE-2010-1169 --- doc/src/sgml/plperl.sgml | 12 +- src/pl/plperl/GNUmakefile | 13 +- src/pl/plperl/expected/plperl.out | 19 +- src/pl/plperl/expected/plperl_init.out | 8 +- src/pl/plperl/expected/plperl_plperlu.out | 28 ++ src/pl/plperl/plc_perlboot.pl | 13 +- src/pl/plperl/plc_safe_bad.pl | 16 - src/pl/plperl/plc_safe_ok.pl | 95 ------ src/pl/plperl/plc_trusted.pl | 29 ++ src/pl/plperl/plperl.c | 341 +++++++++++++--------- src/pl/plperl/plperl_opmask.pl | 58 ++++ src/pl/plperl/sql/plperl.sql | 11 +- src/pl/plperl/sql/plperl_init.sql | 2 +- src/pl/plperl/sql/plperl_plperlu.sql | 21 ++ 14 files changed, 400 insertions(+), 266 deletions(-) delete mode 100644 src/pl/plperl/plc_safe_bad.pl delete mode 100644 src/pl/plperl/plc_safe_ok.pl create mode 100644 src/pl/plperl/plc_trusted.pl create mode 100644 src/pl/plperl/plperl_opmask.pl diff --git a/doc/src/sgml/plperl.sgml b/doc/src/sgml/plperl.sgml index c4129510fc..7d17002acf 100644 --- a/doc/src/sgml/plperl.sgml +++ b/doc/src/sgml/plperl.sgml @@ -1,4 +1,4 @@ - + PL/Perl - Perl Procedural Language @@ -1154,8 +1154,16 @@ CREATE TRIGGER test_valid_id_trig into a module and loaded by the on_init string. Examples: -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;' + + + + Any modules loaded by plperl.on_init, either directly or + indirectly, will be available for use by plperl. This may + create a security risk. To see what modules have been loaded you can use: + +DO 'elog(WARNING, join ", ", sort keys %INC)' language plperl; diff --git a/src/pl/plperl/GNUmakefile b/src/pl/plperl/GNUmakefile index e4fc226c33..6bbd1bfb23 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 b3027f8926..e3e9ec7b6f 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, " \@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 0000000000..a76cc2f5ad --- /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 9ad2d40d11..de6ddb288f 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 0000000000..3e9ecaa3c1 --- /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 \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 6d4c5c2a85..651d5ee2b4 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, "