database/postgres
1
0
Fork 0
mirror of https://github.com/postgres/postgres.git synced 2025-08-09 17:03:00 +03:00
Code Activity

Abandon the use of Perl's Safe.pm to enforce restrictions in plperl, as it is

Browse Source 
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
This commit is contained in:
Andrew Dunstan
2010-05-13 16:44:03 +00:00
parent 2824dd4f4f
commit e089e04d3e
10 changed files with 790 additions and 192 deletions
Download Patch File Download Diff File Expand all files Collapse all files

21
doc/src/sgml/plperl.sgml
View File

@@ -1,5 +1,5 @@
<!--
$PostgreSQL: pgsql/doc/src/sgml/plperl.sgml,v 2.37 2005/01/17 17:29:49 momjian Exp $
$PostgreSQL: pgsql/doc/src/sgml/plperl.sgml,v 2.37.4.1 2010/05/13 16:44:03 adunstan Exp $
-->
<chapter id="plperl">
@@ -458,6 +458,25 @@ $$ LANGUAGE plperl;
If the above function was created by a superuser using the language
<literal>plperlu</>, execution would succeed.
</para>
<note>
<para>
For security reasons, to stop a leak of privileged operations from
<application>PL/PerlU</> to <application>PL/Perl</>, these two languages
have to run in separate instances of the Perl interpreter. If your
Perl installation has been appropriately compiled, this is not a problem.
However, not all installations are compiled with the requisite flags.
If <productname>PostgreSQL</> detects that this is the case then it will
not start a second interpreter, but instead create an error. In
consequence, in such an installation, you cannot use both
<application>PL/PerlU</> and <application>PL/Perl</> in the same backend
process. The remedy for this is to obtain a Perl installation created
with the appropriate flags, namely either <literal>usemultiplicity</> or
both <literal>usethreads</> and <literal>useithreads</>.
For more details,see the <literal>perlembed</> manual page.
</para>
</note>
</sect1>
<sect1 id="plperl-triggers">

13
src/pl/plperl/GNUmakefile
View File

@@ -1,5 +1,5 @@
# Makefile for PL/Perl
# $PostgreSQL: pgsql/src/pl/plperl/GNUmakefile,v 1.18.4.1 2005/07/17 04:05:49 tgl Exp $
# $PostgreSQL: pgsql/src/pl/plperl/GNUmakefile,v 1.18.4.2 2010/05/13 16:44:03 adunstan Exp $
subdir = src/pl/plperl
top_builddir = ../../..
@@ -23,7 +23,7 @@ perl_embed_ldflags := -L$(perl_archlibexp)/CORE -lperl58
override CPPFLAGS += -DPLPERL_HAVE_UID_GID
endif
override CPPFLAGS := -I$(srcdir) $(CPPFLAGS) -I$(perl_archlibexp)/CORE
override CPPFLAGS := -I. -I$(srcdir) $(CPPFLAGS) -I$(perl_archlibexp)/CORE
rpathdir = $(perl_archlibexp)/CORE
@@ -41,6 +41,13 @@ include $(top_srcdir)/src/Makefile.shlib
all: all-lib
plperl.o: plperl_opmask.h
plperl_opmask.h: plperl_opmask.pl
$(PERL) $< $@
SPI.c: SPI.xs
$(PERL) $(perl_privlibexp)/ExtUtils/xsubpp -typemap $(perl_privlibexp)/ExtUtils/typemap $< >$@
@@ -60,7 +67,7 @@ uninstall:
rm -f $(DESTDIR)$(pkglibdir)/plperl$(DLSUFFIX)
clean distclean maintainer-clean: clean-lib
rm -f SPI.c $(OBJS)
rm -f SPI.c $(OBJS) plperl_opmask.h
else # can't build

588
src/pl/plperl/plperl.c
View File

@@ -33,7 +33,7 @@
* ENHANCEMENTS, OR MODIFICATIONS.
*
* IDENTIFICATION
* $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.67.4.11 2010/03/09 22:35:25 tgl Exp $
* $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.67.4.12 2010/05/13 16:44:03 adunstan Exp $
*
**********************************************************************/
@@ -49,8 +49,10 @@
#include "commands/trigger.h"
#include "executor/spi.h"
#include "funcapi.h"
#include "mb/pg_wchar.h"
#include "utils/lsyscache.h"
#include "utils/typcache.h"
#include "utils/hsearch.h"
/* perl stuff */
@@ -75,6 +77,9 @@
#undef bool
#endif
/* defines PLPERL_SET_OPMASK */
#include "plperl_opmask.h"
/**********************************************************************
* The information we cache about loaded procedures
@@ -98,14 +103,33 @@ typedef struct plperl_proc_desc
SV *reference;
} plperl_proc_desc;
/**********************************************************************
* Global data
**********************************************************************/
typedef enum
{
INTERP_NONE,
INTERP_HELD,
INTERP_TRUSTED,
INTERP_UNTRUSTED,
INTERP_BOTH
} InterpState;
static InterpState interp_state = INTERP_NONE;
static bool can_run_two = false;
static int plperl_firstcall = 1;
static bool plperl_safe_init_done = false;
static PerlInterpreter *plperl_interp = NULL;
static HV *plperl_proc_hash = NULL;
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 char plperl_opmask[MAXO];
static void set_interp_require(void);
/* this is saved and restored by plperl_call_handler */
static plperl_proc_desc *plperl_current_prodesc = NULL;
@@ -129,7 +153,21 @@ static plperl_proc_desc *compile_plperl_function(Oid fn_oid, bool is_trigger);
static SV *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc);
static void plperl_init_shared_libs(pTHX);
static HV *plperl_spi_execute_fetch_result(SPITupleTable *, int, int);
static void check_interp(bool trusted);
static char *strip_trailing_ws(const char *msg);
#ifdef WIN32
static char *setlocale_perl(int category, char *locale);
#endif
/* hash table entry for proc desc */
typedef struct plperl_proc_entry
{
char proc_name[NAMEDATALEN];
plperl_proc_desc *proc_data;
} plperl_proc_entry;
/*
* This routine is a crock, and so is everyplace that calls it. The problem
@@ -158,15 +196,29 @@ perm_fmgr_info(Oid functionId, FmgrInfo *finfo)
void
plperl_init(void)
{
HASHCTL hash_ctl;
/************************************************************
* Do initialization only once
************************************************************/
if (!plperl_firstcall)
return;
MemSet(&hash_ctl, 0, sizeof(hash_ctl));
hash_ctl.keysize = NAMEDATALEN;
hash_ctl.entrysize = sizeof(plperl_proc_entry);
plperl_proc_hash = hash_create("PLPerl Procedures",
32,
&hash_ctl,
HASH_ELEM);
/************************************************************
* Create the Perl interpreter
************************************************************/
PLPERL_SET_OPMASK(plperl_opmask);
plperl_init_interp();
plperl_firstcall = 0;
@@ -192,6 +244,113 @@ plperl_init_all(void)
}
#define PLC_TRUSTED \
"require strict; "
#define TEST_FOR_MULTI \
"use Config; " \
"$Config{usemultiplicity} eq 'define' or " \
"($Config{usethreads} eq 'define' " \
" and $Config{useithreads} eq 'define')"
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;
}
}
/********************************************************************
*
* We start out by creating a "held" interpreter that we can use in
* trusted or untrusted mode (but not both) as the need arises. Later, we
* assign that interpreter if it is available to either the trusted or
* untrusted interpreter. If it has already been assigned, and we need to
* create the other interpreter, we do that if we can, or error out.
* We detect if it is safe to run two interpreters during the setup of the
* dummy interpreter.
*/
static void
check_interp(bool trusted)
{
if (interp_state == INTERP_HELD)
{
if (trusted)
{
plperl_trusted_interp = plperl_held_interp;
interp_state = INTERP_TRUSTED;
}
else
{
plperl_untrusted_interp = plperl_held_interp;
interp_state = INTERP_UNTRUSTED;
}
plperl_held_interp = NULL;
trusted_context = trusted;
set_interp_require();
}
else if (interp_state == INTERP_BOTH ||
(trusted && interp_state == INTERP_TRUSTED) ||
(!trusted && interp_state == INTERP_UNTRUSTED))
{
if (trusted_context != trusted)
{
if (trusted)
PERL_SET_CONTEXT(plperl_trusted_interp);
else
PERL_SET_CONTEXT(plperl_untrusted_interp);
trusted_context = trusted;
set_interp_require();
}
}
else if (can_run_two)
{
PERL_SET_CONTEXT(plperl_held_interp);
plperl_init_interp();
if (trusted)
plperl_trusted_interp = plperl_held_interp;
else
plperl_untrusted_interp = plperl_held_interp;
interp_state = INTERP_BOTH;
plperl_held_interp = NULL;
trusted_context = trusted;
set_interp_require();
}
else
{
elog(ERROR,
"can not allocate second Perl interpreter on this platform");
}
}
static void
restore_context(bool old_context)
{
if (trusted_context != old_context)
{
if (old_context)
PERL_SET_CONTEXT(plperl_trusted_interp);
else
PERL_SET_CONTEXT(plperl_untrusted_interp);
trusted_context = old_context;
set_interp_require();
}
}
/**********************************************************************
* plperl_init_interp() - Create the Perl interpreter
@@ -203,26 +362,22 @@ plperl_init_interp(void)
"", "-e",
/*
* no commas between the next lines please. They are supposed to
* be one string
* no commas between the next lines please. They are supposed to be
* one string
*/
"SPI::bootstrap(); use vars qw(%_SHARED);"
"sub ::mkunsafefunc {return eval(qq[ sub { $_[0] $_[1] } ]); }"
"sub ::mkfunc {return eval(qq[ sub { $_[0] $_[1] } ]); }"
};
int nargs = 3;
char *dummy_perl_env[1] = { NULL };
#ifdef WIN32
/*
* The perl library on startup does horrible things like call
* setlocale(LC_ALL,""). We have protected against that on most
* platforms by setting the environment appropriately. However, on
* Windows, setlocale() does not consult the environment, so we need
* to save the excisting locale settings before perl has a chance to
* mangle them and restore them after its dirty deeds are done.
* setlocale(LC_ALL,""). We have protected against that on most platforms
* by setting the environment appropriately. However, on Windows,
* setlocale() does not consult the environment, so we need to save the
* excisting locale settings before perl has a chance to mangle them and
* restore them after its dirty deeds are done.
*
* MSDN ref:
* http://msdn.microsoft.com/library/en-us/vclib/html/_crt_locale.asp
@@ -231,14 +386,17 @@ 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 doesn't have a different idea of the locale from Postgres.
* We restore them using Perl's perl_setlocale() function so that Perl
* doesn't have a different idea of the locale from Postgres.
*
*/
char *loc;
char *save_collate, *save_ctype, *save_monetary, *save_numeric, *save_time;
char buf[1024];
char *save_collate,
*save_ctype,
*save_monetary,
*save_numeric,
*save_time;
loc = setlocale(LC_COLLATE, NULL);
save_collate = loc ? pstrdup(loc) : NULL;
@@ -251,6 +409,10 @@ plperl_init_interp(void)
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
/****
@@ -263,109 +425,160 @@ plperl_init_interp(void)
* true when MYMALLOC is set.
*/
#if defined(PERL_SYS_INIT3) && !defined(MYMALLOC)
if (interp_state == INTERP_NONE)
{
int nargs;
char *dummy_perl_env[1];
/* initialize this way to silence silly compiler warnings */
nargs = 3;
dummy_perl_env[0] = NULL;
PERL_SYS_INIT3(&nargs, (char ***) &embedding, (char ***) &dummy_perl_env);
}
#endif
plperl_interp = perl_alloc();
if (!plperl_interp)
plperl_held_interp = perl_alloc();
if (!plperl_held_interp)
elog(ERROR, "could not allocate Perl interpreter");
perl_construct(plperl_interp);
perl_parse(plperl_interp, plperl_init_shared_libs, nargs, embedding, NULL);
perl_run(plperl_interp);
perl_construct(plperl_held_interp);
/************************************************************
* Initialize the procedure hash table
************************************************************/
plperl_proc_hash = newHV();
#ifdef WIN32
eval_pv("use POSIX qw(locale_h);", TRUE); /* croak on failure */
if (save_collate != NULL)
/*
* 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)
{
snprintf(buf, sizeof(buf),"setlocale(%s,'%s');",
"LC_COLLATE",save_collate);
eval_pv(buf,TRUE);
pfree(save_collate);
pp_require_orig = PL_ppaddr[OP_REQUIRE];
}
if (save_ctype != NULL)
else
{
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);
PL_ppaddr[OP_REQUIRE] = pp_require_orig;
PL_ppaddr[OP_DOFILE] = pp_require_orig;
}
perl_parse(plperl_held_interp, plperl_init_shared_libs,
3, embedding, NULL);
perl_run(plperl_held_interp);
if (interp_state == INTERP_NONE)
{
SV *res;
res = eval_pv(TEST_FOR_MULTI, TRUE);
can_run_two = SvIV(res);
interp_state = INTERP_HELD;
}
#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
}
/*
* Our safe implementation of the require opcode.
* This is safe because it's completely unable to load any code.
* If the requested file/module has already been loaded it'll return true.
* If not, it'll die.
* So now "use Foo;" will work iff Foo has already been loaded.
*/
static OP *
pp_require_safe(pTHX)
{
dVAR;
dSP;
SV *sv,
**svp;
char *name;
STRLEN len;
sv = POPs;
name = SvPV(sv, len);
if (!(name && len > 0 && *name))
RETPUSHNO;
svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
if (svp && *svp != &PL_sv_undef)
RETPUSHYES;
DIE(aTHX_ "Unable to load %s into plperl", name);
}
static void
plperl_safe_init(void)
{
static char *safe_module =
"require Safe; $Safe::VERSION";
HV *stash;
SV *sv;
char *key;
I32 klen;
static char *safe_ok =
"use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');"
"$PLContainer->permit_only(':default');"
"$PLContainer->permit(qw[:base_math !:base_io sort time]);"
"$PLContainer->share(qw[&elog &spi_exec_query &DEBUG &LOG "
"&INFO &NOTICE &WARNING &ERROR %_SHARED ]);"
"sub ::mksafefunc { return $PLContainer->reval(qq[sub { $_[0] $_[1]}]); }"
;
/* use original require while we set up */
PL_ppaddr[OP_REQUIRE] = pp_require_orig;
PL_ppaddr[OP_DOFILE] = pp_require_orig;
static char *safe_bad =
"use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');"
"$PLContainer->permit_only(':default');"
"$PLContainer->share(qw[&elog &ERROR ]);"
"sub ::mksafefunc { return $PLContainer->reval(qq[sub { "
"elog(ERROR,'trusted Perl functions disabled - "
"please upgrade Perl Safe module to version 2.09 or later');}]); }"
;
eval_pv(PLC_TRUSTED, FALSE);
if (SvTRUE(ERRSV))
ereport(ERROR,
(errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
errcontext("While executing PLC_TRUSTED.")));
SV *res;
double safe_version;
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.")));
res = eval_pv(safe_module, FALSE); /* TRUE = croak if failure */
safe_version = SvNV(res);
}
/*
* We actually want to reject safe_version < 2.09, but it's risky to
* assume that floating-point comparisons are exact, so use a slightly
* smaller comparison value.
* Lock down the interpreter
*/
eval_pv((safe_version < 2.0899 ? safe_bad : safe_ok), FALSE);
/* 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)))
{
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;
#ifdef PL_stashcache
hv_clear(PL_stashcache);
#endif
plperl_safe_init_done = true;
}
/*
* Perl likes to put a newline after its error messages; clean up such
*/
@@ -443,14 +656,14 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
)
);
hv_store(hv, "name", 4, newSVpv(tdata->tg_trigger->tgname, 0), 0);
hv_store(hv, "relid", 5, newSVpv(relid, 0), 0);
(void) hv_store(hv, "name", 4, newSVpv(tdata->tg_trigger->tgname, 0), 0);
(void) hv_store(hv, "relid", 5, newSVpv(relid, 0), 0);
if (TRIGGER_FIRED_BY_INSERT(tdata->tg_event))
{
event = "INSERT";
if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
hv_store(hv, "new", 3,
(void) hv_store(hv, "new", 3,
plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc),
0);
}
@@ -458,7 +671,7 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
{
event = "DELETE";
if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
hv_store(hv, "old", 3,
(void) hv_store(hv, "old", 3,
plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc),
0);
}
@@ -467,10 +680,10 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
event = "UPDATE";
if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
{
hv_store(hv, "old", 3,
(void) hv_store(hv, "old", 3,
plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc),
0);
hv_store(hv, "new", 3,
(void) hv_store(hv, "new", 3,
plperl_hash_from_tuple(tdata->tg_newtuple, tupdesc),
0);
}
@@ -478,18 +691,19 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
else
event = "UNKNOWN";
hv_store(hv, "event", 5, newSVpv(event, 0), 0);
hv_store(hv, "argc", 4, newSViv(tdata->tg_trigger->tgnargs), 0);
(void) hv_store(hv, "event", 5, newSVpv(event, 0), 0);
(void) hv_store(hv, "argc", 4, newSViv(tdata->tg_trigger->tgnargs), 0);
if (tdata->tg_trigger->tgnargs > 0)
{
AV *av = newAV();
for (i = 0; i < tdata->tg_trigger->tgnargs; i++)
av_push(av, newSVpv(tdata->tg_trigger->tgargs[i], 0));
hv_store(hv, "args", 4, newRV_noinc((SV *)av), 0);
(void) hv_store(hv, "args", 4, newRV_noinc((SV *) av), 0);
}
hv_store(hv, "relname", 7,
(void) hv_store(hv, "relname", 7,
newSVpv(SPI_getrelname(tdata->tg_relation), 0), 0);
if (TRIGGER_FIRED_BEFORE(tdata->tg_event))
@@ -498,7 +712,7 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
when = "AFTER";
else
when = "UNKNOWN";
hv_store(hv, "when", 4, newSVpv(when, 0), 0);
(void) hv_store(hv, "when", 4, newSVpv(when, 0), 0);
if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
level = "ROW";
@@ -506,7 +720,7 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
level = "STATEMENT";
else
level = "UNKNOWN";
hv_store(hv, "level", 5, newSVpv(level, 0), 0);
(void) hv_store(hv, "level", 5, newSVpv(level, 0), 0);
return newRV_noinc((SV *) hv);
}
@@ -637,6 +851,7 @@ plperl_call_handler(PG_FUNCTION_ARGS)
{
Datum retval;
plperl_proc_desc *save_prodesc;
bool oldcontext = trusted_context;
/*
* Initialize interpreter if first time through
@@ -651,8 +866,8 @@ plperl_call_handler(PG_FUNCTION_ARGS)
PG_TRY();
{
/*
* Determine if called as function or trigger and
* call appropriate subhandler
* Determine if called as function or trigger and call appropriate
* subhandler
*/
if (CALLED_AS_TRIGGER(fcinfo))
retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
@@ -662,12 +877,13 @@ plperl_call_handler(PG_FUNCTION_ARGS)
PG_CATCH();
{
plperl_current_prodesc = save_prodesc;
restore_context(oldcontext);
PG_RE_THROW();
}
PG_END_TRY();
plperl_current_prodesc = save_prodesc;
restore_context(oldcontext);
return retval;
}
@@ -699,11 +915,10 @@ plperl_create_sub(char *s, bool trusted)
/*
* G_KEEPERR seems to be needed here, else we don't recognize compile
* errors properly. Perhaps it's because there's another level of
* eval inside mksafefunc?
* errors properly. Perhaps it's because there's another level of eval
* inside mkfunc?
*/
count = perl_call_pv((trusted ? "::mksafefunc" : "::mkunsafefunc"),
G_SCALAR | G_EVAL | G_KEEPERR);
count = perl_call_pv("::mkfunc", G_SCALAR | G_EVAL | G_KEEPERR);
SPAGAIN;
if (count != 1)
@@ -711,7 +926,7 @@ plperl_create_sub(char *s, bool trusted)
PUTBACK;
FREETMPS;
LEAVE;
elog(ERROR, "didn't get a return item from mksafefunc");
elog(ERROR, "didn't get a return item from mkfunc");
}
if (SvTRUE(ERRSV))
@@ -756,7 +971,7 @@ plperl_create_sub(char *s, bool trusted)
* 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
* module. So, we link Opcode into ourselves
* and do the initialization behind perl's back.
*
**********************************************************************/
@@ -946,6 +1161,8 @@ plperl_func_handler(PG_FUNCTION_ARGS)
plperl_current_prodesc = prodesc;
check_interp(prodesc->lanpltrusted);
/************************************************************
* Call the Perl function if not returning set
************************************************************/
@@ -1134,6 +1351,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
}
SvREFCNT_dec(perlret);
return retval;
}
@@ -1162,6 +1380,8 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
* Call the Perl function
************************************************************/
check_interp(prodesc->lanpltrusted);
/*
* call perl trigger function and build TD hash
*/
@@ -1250,7 +1470,9 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
int proname_len;
plperl_proc_desc *prodesc = NULL;
int i;
SV **svp;
plperl_proc_entry *hash_entry;
bool found;
bool oldcontext = trusted_context;
/* We'll need the pg_proc tuple in any case... */
procTup = SearchSysCache(PROCOID,
@@ -1273,12 +1495,14 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
/************************************************************
* Lookup the internal proc name in the hashtable
************************************************************/
svp = hv_fetch(plperl_proc_hash, internal_proname, proname_len, FALSE);
if (svp)
hash_entry = hash_search(plperl_proc_hash, internal_proname,
HASH_FIND, NULL);
if (hash_entry)
{
bool uptodate;
prodesc = (plperl_proc_desc *) SvIV(*svp);
prodesc = hash_entry->proc_data;
/************************************************************
* If it's present, must check whether it's still up to date.
@@ -1290,7 +1514,16 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
if (!uptodate)
{
/* need we delete old entry? */
hash_search(plperl_proc_hash, internal_proname,
HASH_REMOVE, NULL);
if (prodesc->reference)
{
check_interp(prodesc->lanpltrusted);
SvREFCNT_dec(prodesc->reference);
restore_context(oldcontext);
}
free(prodesc->proname);
free(prodesc);
prodesc = NULL;
}
}
@@ -1462,7 +1695,13 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
/************************************************************
* Create the procedure in the interpreter
************************************************************/
check_interp(prodesc->lanpltrusted);
prodesc->reference = plperl_create_sub(proc_source, prodesc->lanpltrusted);
restore_context(oldcontext);
pfree(proc_source);
if (!prodesc->reference) /* can this happen? */
{
@@ -1475,8 +1714,9 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
/************************************************************
* Add the proc description block to the hashtable
************************************************************/
hv_store(plperl_proc_hash, internal_proname, proname_len,
newSViv((IV) prodesc), 0);
hash_entry = hash_search(plperl_proc_hash, internal_proname,
HASH_ENTER, &found);
hash_entry->proc_data = prodesc;
}
ReleaseSysCache(procTup);
@@ -1515,9 +1755,10 @@ plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
namelen = strlen(attname);
attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
if (isnull) {
if (isnull)
{
/* Store (attname => undef) and move on. */
hv_store(hv, attname, namelen, newSV(0), 0);
(void) hv_store(hv, attname, namelen, newSV(0), 0);
continue;
}
@@ -1531,7 +1772,7 @@ plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
ObjectIdGetDatum(typioparam),
Int32GetDatum(tupdesc->attrs[i]->atttypmod)));
hv_store(hv, attname, namelen, newSVpv(outputstr, 0), 0);
(void) hv_store(hv, attname, namelen, newSVpv(outputstr, 0), 0);
pfree(outputstr);
}
@@ -1549,8 +1790,8 @@ plperl_spi_exec(char *query, int limit)
HV *ret_hv;
/*
* Execute the query inside a sub-transaction, so we can cope with
* errors sanely
* Execute the query inside a sub-transaction, so we can cope with errors
* sanely
*/
MemoryContext oldcontext = CurrentMemoryContext;
ResourceOwner oldowner = CurrentResourceOwner;
@@ -1572,9 +1813,10 @@ plperl_spi_exec(char *query, int limit)
ReleaseCurrentSubTransaction();
MemoryContextSwitchTo(oldcontext);
CurrentResourceOwner = oldowner;
/*
* AtEOSubXact_SPI() should not have popped any SPI context,
* but just in case it did, make sure we remain connected.
* AtEOSubXact_SPI() should not have popped any SPI context, but just
* in case it did, make sure we remain connected.
*/
SPI_restore_connection();
}
@@ -1593,9 +1835,9 @@ plperl_spi_exec(char *query, int limit)
CurrentResourceOwner = oldowner;
/*
* If AtEOSubXact_SPI() popped any SPI context of the subxact,
* it will have left us in a disconnected state. We need this
* hack to return to connected state.
* If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
* have left us in a disconnected state. We need this hack to return
* to connected state.
*/
SPI_restore_connection();
@@ -1618,9 +1860,9 @@ plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
result = newHV();
hv_store(result, "status", strlen("status"),
(void) hv_store(result, "status", strlen("status"),
newSVpv((char *) SPI_result_code_string(status), 0), 0);
hv_store(result, "processed", strlen("processed"),
(void) hv_store(result, "processed", strlen("processed"),
newSViv(processed), 0);
if (status == SPI_OK_SELECT)
@@ -1635,7 +1877,7 @@ plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
av_push(rows, row);
}
hv_store(result, "rows", strlen("rows"),
(void) hv_store(result, "rows", strlen("rows"),
newRV_noinc((SV *) rows), 0);
}
@@ -1643,3 +1885,79 @@ plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
return result;
}
/*
* 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

62
src/pl/plperl/plperl_opmask.pl Normal file
View File

@@ -0,0 +1,62 @@
#!perl -w
use strict;
use warnings;
use Opcode qw(opset opset_to_ops opdesc full_opset);
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],
);
if (grep { /^custom$/ } opset_to_ops(full_opset) ) {
# 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, if it is actually
# defined.
push(@allowed_ops,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;

71
src/pl/plperl/test/plperlu_plperl.expected Normal file
View File

@@ -0,0 +1,71 @@
CREATE OR REPLACE FUNCTION recurse_plperl(i int) RETURNS SETOF TEXT LANGUAGE plperl
AS $$
my $i = shift;
my $res = [];
return $res unless $i > 0;
push @$res, "plperl $i entry: ".((eval "stat;1") ? "ok" : $@);
push @$res, $_
for map { $_->{recurse_plperlu} }
@{spi_exec_query("select * from recurse_plperlu($i-1)")->{rows}};
return $res;
$$;
CREATE OR REPLACE FUNCTION recurse_plperlu(i int) RETURNS SETOF TEXT LANGUAGE plperlu
AS $$
my $i = shift;
my $res = [];
return $res unless $i > 0;
push @$res, "plperlu $i entry: ".((eval "stat;1") ? "ok" : $@);
push @$res, $_
for map { $_->{recurse_plperl} }
@{spi_exec_query("select * from recurse_plperl($i-1)")->{rows}};
return $res;
$$;
SELECT * FROM recurse_plperl(5);
recurse_plperl
------------------------------------------------------------------------
plperl 5 entry: 'stat' trapped by operation mask at (eval 4) line 1.
plperlu 4 entry: ok
plperl 3 entry: 'stat' trapped by operation mask at (eval 5) line 1.
plperlu 2 entry: ok
plperl 1 entry: 'stat' trapped by operation mask at (eval 6) line 1.
(5 rows)
SELECT * FROM recurse_plperlu(5);
recurse_plperlu
------------------------------------------------------------------------
plperlu 5 entry: ok
plperl 4 entry: 'stat' trapped by operation mask at (eval 7) line 1.
plperlu 3 entry: ok
plperl 2 entry: 'stat' trapped by operation mask at (eval 8) line 1.
plperlu 1 entry: ok
(5 rows)
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;
$$;
select use_plperl();
ERROR: creation of Perl function failed: Unable to load Errno.pm into plperl at (eval 9) line 2.
BEGIN failed--compilation aborted at (eval 9) line 2.
select use_plperlu();
use_plperlu
-------------
(1 row)
CREATE OR REPLACE FUNCTION use_plperl() RETURNS void LANGUAGE plperl
AS $$
use Errno;
$$;
select use_plperl();
ERROR: creation of Perl function failed: Unable to load Errno.pm into plperl at (eval 10) line 2.
BEGIN failed--compilation aborted at (eval 10) line 2.

59
src/pl/plperl/test/plperlu_plperl.sql Normal file
View File

@@ -0,0 +1,59 @@
--
-- Test that recursing between plperl and plperlu doesn't allow plperl to perform unsafe ops
--
-- recurse between a plperl and plperlu function that are identical except that
-- each calls the other. Each also checks if an unsafe opcode can be executed.
CREATE OR REPLACE FUNCTION recurse_plperl(i int) RETURNS SETOF TEXT LANGUAGE plperl
AS $$
my $i = shift;
my $res = [];
return $res unless $i > 0;
push @$res, "plperl $i entry: ".((eval "stat;1") ? "ok" : $@);
push @$res, $_
for map { $_->{recurse_plperlu} }
@{spi_exec_query("select * from recurse_plperlu($i-1)")->{rows}};
return $res;
$$;
CREATE OR REPLACE FUNCTION recurse_plperlu(i int) RETURNS SETOF TEXT LANGUAGE plperlu
AS $$
my $i = shift;
my $res = [];
return $res unless $i > 0;
push @$res, "plperlu $i entry: ".((eval "stat;1") ? "ok" : $@);
push @$res, $_
for map { $_->{recurse_plperl} }
@{spi_exec_query("select * from recurse_plperl($i-1)")->{rows}};
return $res;
$$;
SELECT * FROM recurse_plperl(5);
SELECT * FROM recurse_plperlu(5);
--
-- 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;
$$;
select use_plperl();
-- 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;
$$;
select use_plperl();

18
src/pl/plperl/test/runtest
View File

@@ -14,6 +14,10 @@ createdb $DBNAME
echo "**** Create procedural language plperl ****"
createlang plperl $DBNAME
echo "**** Create procedural language plperlu ****"
createlang plperlu $DBNAME
echo "**** Running test queries ****"
psql -q -n -e $DBNAME <test_queries.sql > test.out 2>&1
@@ -24,3 +28,17 @@ else
echo " Tests failed - look at diffs between"
echo " test.expected and test.out"
fi
echo "**** Running plperlu_plperl tests ****"
psql -q -n -e $DBNAME <plperlu_plperl.sql > plperlu_plperl.out 2>&1
if diff plperlu_plperl.expected plperlu_plperl.out >/dev/null 2>&1 || \
diff plperlu_plperl.expected_alt plperlu_plperl.out >/dev/null 2>&1
then
echo " Tests passed O.K."
rm plperlu_plperl.out
else
echo " Tests failed - look at diffs between"
echo " plperlu_plperl.expected{_alt} and plperlu_plperl.out"
fi

31
src/pl/plperl/test/runtest.no-multiplicity Normal file
View File

@@ -0,0 +1,31 @@
#!/bin/sh
DBNAME=plperl_test
export DBNAME
echo "**** Destroy old database $DBNAME ****"
dropdb $DBNAME
sleep 1
echo "**** Create test database $DBNAME ****"
createdb $DBNAME
echo "**** Create procedural language plperl ****"
createlang plperl $DBNAME
echo "**** Create procedural language plperlu ****"
createlang plperlu $DBNAME
echo "**** Running test queries ****"
psql -q -n -e $DBNAME <test_queries.sql > test.out 2>&1
if diff test.expected test.out >/dev/null 2>&1 ; then
echo " Tests passed O.K."
rm test.out
else
echo " Tests failed - look at diffs between"
echo " test.expected and test.out"
fi

5
src/pl/plperl/test/test.expected
View File

@@ -300,3 +300,8 @@ SELECT perl_get_field((11,12), 'z');
(1 row)
CREATE OR REPLACE FUNCTION perl_unsafe1() RETURNS void AS $$
my $fd = fileno STDERR;
$$ LANGUAGE plperl;
select perl_unsafe1();
ERROR: creation of Perl function failed: 'fileno' trapped by operation mask at (eval 26) line 2.

8
src/pl/plperl/test/test_queries.sql
View File

@@ -211,3 +211,11 @@ $$ LANGUAGE plperl;
SELECT perl_get_field((11,12), 'x');
SELECT perl_get_field((11,12), 'y');
SELECT perl_get_field((11,12), 'z');
--
-- Test detection of unsafe operations
CREATE OR REPLACE FUNCTION perl_unsafe1() RETURNS void AS $$
my $fd = fileno STDERR;
$$ LANGUAGE plperl;
select perl_unsafe1();