mirror of
https://github.com/postgres/postgres.git
synced 2025-06-30 21:42:05 +03:00
Various small improvements and cleanups for PL/Perl.
- Allow (ineffective) use of 'require' in plperl
If the required module is not already loaded then it dies.
So "use strict;" now works in plperl.
- Pre-load the feature module if perl >= 5.10.
So "use feature :5.10;" now works in plperl.
- Stored procedure subs are now given names.
The names are not visible in ordinary use, but they make
tools like Devel::NYTProf and Devel::Cover much more useful.
- Simplified and generalized the subroutine creation code.
Now one code path for generating sub source code, not four.
Can generate multiple 'use' statements with specific imports
(which handles plperl.use_strict currently and can easily
be extended to handle a plperl.use_feature=':5.12' in future).
- Disallows use of Safe version 2.20 which is broken for PL/Perl.
http://rt.perl.org/rt3/Ticket/Display.html?id=72068
- Assorted minor optimizations by pre-growing data structures.
Patch from Tim Bunce, reviewed by Alex Hunsaker.
This commit is contained in:
Andrew Dunstan
@ -1,7 +1,7 @@
|
||||
/**********************************************************************
|
||||
* plperl.c - perl as a procedural language for PostgreSQL
|
||||
*
|
||||
* $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.160 2010/01/20 01:08:21 adunstan Exp $
|
||||
* $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.161 2010/01/26 23:11:56 adunstan Exp $
|
||||
*
|
||||
**********************************************************************/
|
||||
|
||||
@ -132,6 +132,7 @@ static InterpState interp_state = INTERP_NONE;
|
||||
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 bool trusted_context;
|
||||
static HTAB *plperl_proc_hash = NULL;
|
||||
static HTAB *plperl_query_hash = NULL;
|
||||
@ -163,11 +164,14 @@ static HV *plperl_spi_execute_fetch_result(SPITupleTable *, int, int);
|
||||
static SV *newSVstring(const char *str);
|
||||
static SV **hv_store_string(HV *hv, const char *key, SV *val);
|
||||
static SV **hv_fetch_string(HV *hv, const char *key);
|
||||
static void plperl_create_sub(plperl_proc_desc *desc, char *s);
|
||||
static void plperl_create_sub(plperl_proc_desc *desc, char *s, Oid fn_oid);
|
||||
static SV *plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo);
|
||||
static void plperl_compile_callback(void *arg);
|
||||
static void plperl_exec_callback(void *arg);
|
||||
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);
|
||||
|
||||
/*
|
||||
* Convert an SV to char * and verify the encoding via pg_verifymbstr()
|
||||
@ -187,7 +191,7 @@ sv2text_mbverified(SV *sv)
|
||||
*/
|
||||
val = SvPV(sv, len);
|
||||
pg_verifymbstr(val, len, false);
|
||||
return val;
|
||||
return val;
|
||||
}
|
||||
|
||||
/*
|
||||
@ -267,14 +271,21 @@ _PG_init(void)
|
||||
* 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)
|
||||
select_perl_context(bool trusted)
|
||||
{
|
||||
/*
|
||||
* handle simple cases
|
||||
*/
|
||||
if (restore_context(trusted))
|
||||
return;
|
||||
|
||||
/*
|
||||
* adopt held interp if free, else create new one if possible
|
||||
*/
|
||||
if (interp_state == INTERP_HELD)
|
||||
{
|
||||
if (trusted)
|
||||
@ -287,23 +298,6 @@ check_interp(bool trusted)
|
||||
plperl_untrusted_interp = plperl_held_interp;
|
||||
interp_state = INTERP_UNTRUSTED;
|
||||
}
|
||||
plperl_held_interp = NULL;
|
||||
trusted_context = trusted;
|
||||
if (trusted) /* done last to avoid recursion */
|
||||
plperl_safe_init();
|
||||
}
|
||||
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;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
@ -313,32 +307,52 @@ check_interp(bool trusted)
|
||||
plperl_trusted_interp = plperl;
|
||||
else
|
||||
plperl_untrusted_interp = plperl;
|
||||
plperl_held_interp = NULL;
|
||||
trusted_context = trusted;
|
||||
interp_state = INTERP_BOTH;
|
||||
if (trusted) /* done last to avoid recursion */
|
||||
plperl_safe_init();
|
||||
#else
|
||||
elog(ERROR,
|
||||
"cannot allocate second Perl interpreter on this platform");
|
||||
#endif
|
||||
}
|
||||
plperl_held_interp = NULL;
|
||||
trusted_context = trusted;
|
||||
|
||||
/*
|
||||
* initialization - done after plperl_*_interp and trusted_context
|
||||
* updates above to ensure a clean state (and thereby avoid recursion via
|
||||
* plperl_safe_init caling plperl_call_perl_func for utf8fix)
|
||||
*/
|
||||
if (trusted) {
|
||||
plperl_safe_init();
|
||||
PL_ppaddr[OP_REQUIRE] = pp_require_safe;
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* Restore previous interpreter selection, if two are active
|
||||
*/
|
||||
static void
|
||||
restore_context(bool old_context)
|
||||
static int
|
||||
restore_context(bool trusted)
|
||||
{
|
||||
if (interp_state == INTERP_BOTH && trusted_context != old_context)
|
||||
if (interp_state == INTERP_BOTH ||
|
||||
( trusted && interp_state == INTERP_TRUSTED) ||
|
||||
(!trusted && interp_state == INTERP_UNTRUSTED))
|
||||
{
|
||||
if (old_context)
|
||||
PERL_SET_CONTEXT(plperl_trusted_interp);
|
||||
else
|
||||
PERL_SET_CONTEXT(plperl_untrusted_interp);
|
||||
trusted_context = old_context;
|
||||
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;
|
||||
}
|
||||
return 1; /* context restored */
|
||||
}
|
||||
|
||||
return 0; /* unable - appropriate interpreter not available */
|
||||
}
|
||||
|
||||
static PerlInterpreter *
|
||||
@ -422,6 +436,16 @@ plperl_init_interp(void)
|
||||
|
||||
PERL_SET_CONTEXT(plperl);
|
||||
perl_construct(plperl);
|
||||
|
||||
/*
|
||||
* Record the original function for the 'require' opcode.
|
||||
* Ensure it's used for new interpreters.
|
||||
*/
|
||||
if (!pp_require_orig)
|
||||
pp_require_orig = PL_ppaddr[OP_REQUIRE];
|
||||
else
|
||||
PL_ppaddr[OP_REQUIRE] = pp_require_orig;
|
||||
|
||||
perl_parse(plperl, plperl_init_shared_libs,
|
||||
nargs, embedding, NULL);
|
||||
perl_run(plperl);
|
||||
@ -471,26 +495,71 @@ plperl_init_interp(void)
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
* 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)
|
||||
{
|
||||
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);
|
||||
|
||||
/*
|
||||
* 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.
|
||||
* Reject too-old versions of Safe and some others:
|
||||
* 2.20: http://rt.perl.org/rt3/Ticket/Display.html?id=72068
|
||||
*/
|
||||
if (SvNV(safe_version_sv) < 2.0899)
|
||||
if (safe_version_x100 < 209 || safe_version_x100 == 220)
|
||||
{
|
||||
/* not safe, so disallow all trusted funcs */
|
||||
eval_pv(PLC_SAFE_BAD, FALSE);
|
||||
if (SvTRUE(ERRSV))
|
||||
{
|
||||
ereport(ERROR,
|
||||
(errcode(ERRCODE_INTERNAL_ERROR),
|
||||
errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
|
||||
errdetail("While executing PLC_SAFE_BAD")));
|
||||
}
|
||||
|
||||
}
|
||||
else
|
||||
{
|
||||
eval_pv(PLC_SAFE_OK, FALSE);
|
||||
if (SvTRUE(ERRSV))
|
||||
{
|
||||
ereport(ERROR,
|
||||
(errcode(ERRCODE_INTERNAL_ERROR),
|
||||
errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
|
||||
errdetail("While executing PLC_SAFE_OK")));
|
||||
}
|
||||
|
||||
if (GetDatabaseEncoding() == PG_UTF8)
|
||||
{
|
||||
/*
|
||||
@ -502,6 +571,7 @@ plperl_safe_init(void)
|
||||
*/
|
||||
plperl_proc_desc desc;
|
||||
FunctionCallInfoData fcinfo;
|
||||
SV *perlret;
|
||||
|
||||
desc.proname = "utf8fix";
|
||||
desc.lanpltrusted = true;
|
||||
@ -511,14 +581,16 @@ plperl_safe_init(void)
|
||||
|
||||
/* compile the function */
|
||||
plperl_create_sub(&desc,
|
||||
"return shift =~ /\\xa9/i ? 'true' : 'false' ;");
|
||||
"return shift =~ /\\xa9/i ? 'true' : 'false' ;", 0);
|
||||
|
||||
/* set up to call the function with a single text argument 'a' */
|
||||
fcinfo.arg[0] = CStringGetTextDatum("a");
|
||||
fcinfo.argnull[0] = false;
|
||||
|
||||
/* and make the call */
|
||||
(void) plperl_call_perl_func(&desc, &fcinfo);
|
||||
perlret = plperl_call_perl_func(&desc, &fcinfo);
|
||||
|
||||
SvREFCNT_dec(perlret);
|
||||
}
|
||||
}
|
||||
}
|
||||
@ -582,7 +654,6 @@ plperl_convert_to_pg_array(SV *src)
|
||||
{
|
||||
SV *rv;
|
||||
int count;
|
||||
|
||||
dSP;
|
||||
|
||||
PUSHMARK(SP);
|
||||
@ -619,6 +690,7 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
|
||||
HV *hv;
|
||||
|
||||
hv = newHV();
|
||||
hv_ksplit(hv, 12); /* pre-grow the hash */
|
||||
|
||||
tdata = (TriggerData *) fcinfo->context;
|
||||
tupdesc = tdata->tg_relation->rd_att;
|
||||
@ -673,6 +745,7 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
|
||||
{
|
||||
AV *av = newAV();
|
||||
|
||||
av_extend(av, tdata->tg_trigger->tgnargs);
|
||||
for (i = 0; i < tdata->tg_trigger->tgnargs; i++)
|
||||
av_push(av, newSVstring(tdata->tg_trigger->tgargs[i]));
|
||||
hv_store_string(hv, "args", newRV_noinc((SV *) av));
|
||||
@ -893,9 +966,9 @@ plperl_inline_handler(PG_FUNCTION_ARGS)
|
||||
if (SPI_connect() != SPI_OK_CONNECT)
|
||||
elog(ERROR, "could not connect to SPI manager");
|
||||
|
||||
check_interp(desc.lanpltrusted);
|
||||
select_perl_context(desc.lanpltrusted);
|
||||
|
||||
plperl_create_sub(&desc, codeblock->source_text);
|
||||
plperl_create_sub(&desc, codeblock->source_text, 0);
|
||||
|
||||
if (!desc.reference) /* can this happen? */
|
||||
elog(ERROR, "could not create internal procedure for anonymous code block");
|
||||
@ -1000,23 +1073,33 @@ plperl_validator(PG_FUNCTION_ARGS)
|
||||
|
||||
|
||||
/*
|
||||
* Uses mksafefunc/mkunsafefunc to create an anonymous sub whose text is
|
||||
* supplied in s, and returns a reference to the closure.
|
||||
* Uses mksafefunc/mkunsafefunc to create a subroutine whose text is
|
||||
* supplied in s, and returns a reference to it
|
||||
*/
|
||||
static void
|
||||
plperl_create_sub(plperl_proc_desc *prodesc, char *s)
|
||||
plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid)
|
||||
{
|
||||
dSP;
|
||||
bool trusted = prodesc->lanpltrusted;
|
||||
SV *subref;
|
||||
int count;
|
||||
char *compile_sub;
|
||||
char subname[NAMEDATALEN+40];
|
||||
HV *pragma_hv = newHV();
|
||||
SV *subref = NULL;
|
||||
int count;
|
||||
char *compile_sub;
|
||||
|
||||
sprintf(subname, "%s__%u", prodesc->proname, fn_oid);
|
||||
|
||||
if (plperl_use_strict)
|
||||
hv_store_string(pragma_hv, "strict", (SV*)newAV());
|
||||
|
||||
ENTER;
|
||||
SAVETMPS;
|
||||
PUSHMARK(SP);
|
||||
XPUSHs(sv_2mortal(newSVstring("our $_TD; local $_TD=$_[0]; shift;")));
|
||||
XPUSHs(sv_2mortal(newSVstring(s)));
|
||||
EXTEND(SP,4);
|
||||
PUSHs(sv_2mortal(newSVstring(subname)));
|
||||
PUSHs(sv_2mortal(newRV_noinc((SV*)pragma_hv)));
|
||||
PUSHs(sv_2mortal(newSVstring("our $_TD; local $_TD=shift;")));
|
||||
PUSHs(sv_2mortal(newSVstring(s)));
|
||||
PUTBACK;
|
||||
|
||||
/*
|
||||
@ -1024,57 +1107,36 @@ plperl_create_sub(plperl_proc_desc *prodesc, char *s)
|
||||
* errors properly. Perhaps it's because there's another level of eval
|
||||
* inside mksafefunc?
|
||||
*/
|
||||
|
||||
if (trusted && plperl_use_strict)
|
||||
compile_sub = "::mk_strict_safefunc";
|
||||
else if (plperl_use_strict)
|
||||
compile_sub = "::mk_strict_unsafefunc";
|
||||
else if (trusted)
|
||||
compile_sub = "::mksafefunc";
|
||||
else
|
||||
compile_sub = "::mkunsafefunc";
|
||||
|
||||
compile_sub = (trusted) ? "::mksafefunc" : "::mkunsafefunc";
|
||||
count = perl_call_pv(compile_sub, G_SCALAR | G_EVAL | G_KEEPERR);
|
||||
SPAGAIN;
|
||||
|
||||
if (count != 1)
|
||||
{
|
||||
PUTBACK;
|
||||
FREETMPS;
|
||||
LEAVE;
|
||||
elog(ERROR, "didn't get a return item from mksafefunc");
|
||||
if (count == 1) {
|
||||
GV *sub_glob = (GV*)POPs;
|
||||
if (sub_glob && SvTYPE(sub_glob) == SVt_PVGV)
|
||||
subref = newRV_inc((SV*)GvCVu((GV*)sub_glob));
|
||||
}
|
||||
|
||||
subref = POPs;
|
||||
PUTBACK;
|
||||
FREETMPS;
|
||||
LEAVE;
|
||||
|
||||
if (SvTRUE(ERRSV))
|
||||
{
|
||||
PUTBACK;
|
||||
FREETMPS;
|
||||
LEAVE;
|
||||
ereport(ERROR,
|
||||
(errcode(ERRCODE_SYNTAX_ERROR),
|
||||
errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV)))));
|
||||
}
|
||||
|
||||
if (!SvROK(subref) || SvTYPE(SvRV(subref)) != SVt_PVCV)
|
||||
if (!subref)
|
||||
{
|
||||
PUTBACK;
|
||||
FREETMPS;
|
||||
LEAVE;
|
||||
elog(ERROR, "didn't get a code ref");
|
||||
ereport(ERROR,
|
||||
(errcode(ERRCODE_INTERNAL_ERROR),
|
||||
errmsg("didn't get a GLOB from compiling %s via %s", prodesc->proname, compile_sub)));
|
||||
}
|
||||
|
||||
/*
|
||||
* need to make a copy of the return, it comes off the stack as a
|
||||
* temporary.
|
||||
*/
|
||||
prodesc->reference = newSVsv(subref);
|
||||
|
||||
PUTBACK;
|
||||
FREETMPS;
|
||||
LEAVE;
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
@ -1118,13 +1180,14 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
|
||||
SAVETMPS;
|
||||
|
||||
PUSHMARK(SP);
|
||||
EXTEND(sp, 1 + desc->nargs);
|
||||
|
||||
XPUSHs(&PL_sv_undef); /* no trigger data */
|
||||
PUSHs(&PL_sv_undef); /* no trigger data */
|
||||
|
||||
for (i = 0; i < desc->nargs; i++)
|
||||
{
|
||||
if (fcinfo->argnull[i])
|
||||
XPUSHs(&PL_sv_undef);
|
||||
PUSHs(&PL_sv_undef);
|
||||
else if (desc->arg_is_rowtype[i])
|
||||
{
|
||||
HeapTupleHeader td;
|
||||
@ -1144,7 +1207,7 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
|
||||
tmptup.t_data = td;
|
||||
|
||||
hashref = plperl_hash_from_tuple(&tmptup, tupdesc);
|
||||
XPUSHs(sv_2mortal(hashref));
|
||||
PUSHs(sv_2mortal(hashref));
|
||||
ReleaseTupleDesc(tupdesc);
|
||||
}
|
||||
else
|
||||
@ -1154,7 +1217,7 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
|
||||
tmp = OutputFunctionCall(&(desc->arg_out_func[i]),
|
||||
fcinfo->arg[i]);
|
||||
sv = newSVstring(tmp);
|
||||
XPUSHs(sv_2mortal(sv));
|
||||
PUSHs(sv_2mortal(sv));
|
||||
pfree(tmp);
|
||||
}
|
||||
}
|
||||
@ -1293,7 +1356,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
|
||||
"cannot accept a set")));
|
||||
}
|
||||
|
||||
check_interp(prodesc->lanpltrusted);
|
||||
select_perl_context(prodesc->lanpltrusted);
|
||||
|
||||
perlret = plperl_call_perl_func(prodesc, fcinfo);
|
||||
|
||||
@ -1440,7 +1503,7 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
|
||||
pl_error_context.arg = prodesc->proname;
|
||||
error_context_stack = &pl_error_context;
|
||||
|
||||
check_interp(prodesc->lanpltrusted);
|
||||
select_perl_context(prodesc->lanpltrusted);
|
||||
|
||||
svTD = plperl_trigger_build_args(fcinfo);
|
||||
perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
|
||||
@ -1757,9 +1820,9 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
|
||||
* Create the procedure in the interpreter
|
||||
************************************************************/
|
||||
|
||||
check_interp(prodesc->lanpltrusted);
|
||||
select_perl_context(prodesc->lanpltrusted);
|
||||
|
||||
plperl_create_sub(prodesc, proc_source);
|
||||
plperl_create_sub(prodesc, proc_source, fn_oid);
|
||||
|
||||
restore_context(oldcontext);
|
||||
|
||||
@ -1795,6 +1858,7 @@ plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
|
||||
int i;
|
||||
|
||||
hv = newHV();
|
||||
hv_ksplit(hv, tupdesc->natts); /* pre-grow the hash */
|
||||
|
||||
for (i = 0; i < tupdesc->natts; i++)
|
||||
{
|
||||
@ -1922,6 +1986,7 @@ plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
|
||||
int i;
|
||||
|
||||
rows = newAV();
|
||||
av_extend(rows, processed);
|
||||
for (i = 0; i < processed; i++)
|
||||
{
|
||||
row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
|
||||
|
||||
Reference in New Issue
Block a user