-<!-- $PostgreSQL: pgsql/doc/src/sgml/plperl.sgml,v 2.74 2010/01/20 03:37:10 rhaas Exp $ -->
+<!-- $PostgreSQL: pgsql/doc/src/sgml/plperl.sgml,v 2.75 2010/01/26 23:11:56 adunstan Exp $ -->
<chapter id="plperl">
<title>PL/Perl - Perl Procedural Language</title>
</para>
<para>
- If you wish to use the <literal>strict</> pragma with your code,
- the easiest way to do so is to <command>SET</>
- <literal>plperl.use_strict</literal> to true. This parameter affects
- subsequent compilations of <application>PL/Perl</> functions, but not
- functions already compiled in the current session. To set the
- parameter before <application>PL/Perl</> has been loaded, it is
- necessary to have added <quote><literal>plperl</></> to the <xref
- linkend="guc-custom-variable-classes"> list in
- <filename>postgresql.conf</filename>.
+ If you wish to use the <literal>strict</> pragma with your code you have a few options.
+ For temporary global use you can <command>SET</> <literal>plperl.use_strict</literal>
+ to true (see <xref linkend="plperl.use_strict">).
+ This will affect subsequent compilations of <application>PL/Perl</>
+ functions, but not functions already compiled in the current session.
+ For permanent global use you can set <literal>plperl.use_strict</literal>
+ to true in the <filename>postgresql.conf</filename> file.
</para>
<para>
- Another way to use the <literal>strict</> pragma is to put:
+ For permanent use in specific functions you can simply put:
<programlisting>
use strict;
</programlisting>
- in the function body. But this only works in <application>PL/PerlU</>
- functions, since the <literal>use</> triggers a <literal>require</>
- which is not a trusted operation. In
- <application>PL/Perl</> functions you can instead do:
-<programlisting>
-BEGIN { strict->import(); }
-</programlisting>
+ at the top of the function body.
+ </para>
+
+ <para>
+ The <literal>feature</> pragma is also available to <function>use</> if your Perl is version 5.10.0 or higher.
+ </para>
+
+ </sect1>
+
+ <sect1 id="plperl-data">
+ <title>Data Values in PL/Perl</title>
+
+ <para>
+ The argument values supplied to a PL/Perl function's code are
+ simply the input arguments converted to text form (just as if they
+ had been displayed by a <command>SELECT</command> statement).
+ Conversely, the <function>return</function> and <function>return_next</function>
+ commands will accept any string that is acceptable input format
+ for the function's declared return type.
</para>
</sect1>
</sect2>
</sect1>
- <sect1 id="plperl-data">
- <title>Data Values in PL/Perl</title>
-
- <para>
- The argument values supplied to a PL/Perl function's code are
- simply the input arguments converted to text form (just as if they
- had been displayed by a <command>SELECT</command> statement).
- Conversely, the <literal>return</> command will accept any string
- that is acceptable input format for the function's declared return
- type. So, within the PL/Perl function,
- all values are just text strings.
- </para>
</sect1>
<sect1 id="plperl-global">
<itemizedlist>
<listitem>
<para>
- PL/Perl functions cannot call each other directly (because they
- are anonymous subroutines inside Perl).
+ PL/Perl functions cannot call each other directly.
</para>
</listitem>
</listitem>
</itemizedlist>
</para>
+ </sect2>
+
</sect1>
</chapter>
/**********************************************************************
* 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 $
*
**********************************************************************/
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;
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()
*/
val = SvPV(sv, len);
pg_verifymbstr(val, len, false);
- return val;
+ return val;
}
/*
* 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)
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
{
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 *
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);
}
+/*
+ * 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)
{
/*
*/
plperl_proc_desc desc;
FunctionCallInfoData fcinfo;
+ SV *perlret;
desc.proname = "utf8fix";
desc.lanpltrusted = true;
/* 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);
}
}
}
{
SV *rv;
int count;
-
dSP;
PUSHMARK(SP);
HV *hv;
hv = newHV();
+ hv_ksplit(hv, 12); /* pre-grow the hash */
tdata = (TriggerData *) fcinfo->context;
tupdesc = tdata->tg_relation->rd_att;
{
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));
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");
/*
- * 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;
/*
* 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;
}
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;
tmptup.t_data = td;
hashref = plperl_hash_from_tuple(&tmptup, tupdesc);
- XPUSHs(sv_2mortal(hashref));
+ PUSHs(sv_2mortal(hashref));
ReleaseTupleDesc(tupdesc);
}
else
tmp = OutputFunctionCall(&(desc->arg_out_func[i]),
fcinfo->arg[i]);
sv = newSVstring(tmp);
- XPUSHs(sv_2mortal(sv));
+ PUSHs(sv_2mortal(sv));
pfree(tmp);
}
}
"cannot accept a set")));
}
- check_interp(prodesc->lanpltrusted);
+ select_perl_context(prodesc->lanpltrusted);
perlret = plperl_call_perl_func(prodesc, fcinfo);
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);
* 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);
int i;
hv = newHV();
+ hv_ksplit(hv, tupdesc->natts); /* pre-grow the hash */
for (i = 0; i < tupdesc->natts; i++)
{
int i;
rows = newAV();
+ av_extend(rows, processed);
for (i = 0; i < processed; i++)
{
row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
projects / postgresql / commitdiff