rdelaage
/
postgresql
mirror of https://git.postgresql.org/git/postgresql.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

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 2010-01-26 23:11:56 +00:00
parent d879697cd2
commit 1a7c2f9dea
9 changed files with 272 additions and 178 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,4 +1,4 @@
<!-- $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>
@ -285,29 +285,39 @@ SELECT * FROM perl_set();
</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>
@ -682,18 +692,6 @@ SELECT done();
</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">
@ -1042,8 +1040,7 @@ CREATE TRIGGER test_valid_id_trig
<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>
@ -1072,6 +1069,8 @@ CREATE TRIGGER test_valid_id_trig
</listitem>
</itemizedlist>
</para>
</sect2>
</sect1>
</chapter>

15
src/pl/plperl/expected/plperl.out
View File

@ -563,6 +563,17 @@ $$ 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 $$ use Config; $$ LANGUAGE plperl;
ERROR: 'require' trapped by operation mask at line 1.
DO $$ eval "1+1"; $$ LANGUAGE plperl;
ERROR: 'eval "string"' trapped by operation mask at line 1.
CONTEXT: PL/Perl anonymous code block
-- check that we can't "use" a module that's not been loaded already
-- compile-time error: "Unable to load blib.pm into plperl"
DO $$ use blib; $$ LANGUAGE plperl;
ERROR: Unable to load blib.pm into plperl at line 1.
BEGIN failed--compilation aborted at line 1.
CONTEXT: PL/Perl anonymous code block
-- check that we can "use" a module that has already been loaded
-- runtime error: "Can't use string ("foo") as a SCALAR ref while "strict refs" in use
DO $do$ use strict; my $name = "foo"; my $ref = $$name; $do$ LANGUAGE plperl;
ERROR: Can't use string ("foo") as a SCALAR ref while "strict refs" in use at line 1.
CONTEXT: PL/Perl anonymous code block

9
src/pl/plperl/expected/plperl_plperlu.out
View File

@ -1,18 +1,19 @@
-- test plperl/plperlu interaction
-- the language and call ordering of this test sequence is useful
CREATE OR REPLACE FUNCTION bar() RETURNS integer AS $$
#die 'BANG!'; # causes server process to exit(2)
# alternative - causes server process to exit(255)
spi_exec_query("invalid sql statement");
$$ language plperl; -- plperl or plperlu
$$ language plperl; -- compile plperl code
CREATE OR REPLACE FUNCTION foo() RETURNS integer AS $$
spi_exec_query("SELECT * FROM bar()");
return 1;
$$ LANGUAGE plperlu; -- must be opposite to language of bar
$$ LANGUAGE plperlu; -- compile plperlu code
SELECT * FROM bar(); -- throws exception normally
SELECT * FROM bar(); -- throws exception normally (running plperl)
ERROR: syntax error at or near "invalid" at line 4.
CONTEXT: PL/Perl function "bar"
SELECT * FROM foo(); -- used to cause backend crash
SELECT * FROM foo(); -- used to cause backend crash (after switching to plperlu)
ERROR: syntax error at or near "invalid" at line 4. at line 2.
CONTEXT: PL/Perl function "foo"

28
src/pl/plperl/plc_perlboot.pl
View File

@ -1,5 +1,5 @@
# $PostgreSQL: pgsql/src/pl/plperl/plc_perlboot.pl,v 1.2 2010/01/20 01:08:21 adunstan Exp $
# $PostgreSQL: pgsql/src/pl/plperl/plc_perlboot.pl,v 1.3 2010/01/26 23:11:56 adunstan Exp $
PostgreSQL::InServer::Util::bootstrap();
PostgreSQL::InServer::SPI::bootstrap();
@ -21,17 +21,25 @@ sub ::plperl_die {
}
$SIG{__DIE__} = \&::plperl_die;
sub ::mkfuncsrc {
my ($name, $imports, $prolog, $src) = @_;
sub ::mkunsafefunc {
my $ret = eval(qq[ sub { $_[0] $_[1] } ]);
$@ =~ s/\(eval \d+\) //g if $@;
return $ret;
my $BEGIN = join "\n", map {
my $names = $imports->{$_} || [];
"$_->import(qw(@$names));"
} sort keys %$imports;
$BEGIN &&= "BEGIN { $BEGIN }";
$name =~ s/\\/\\\\/g;
$name =~ s/::|'/_/g; # avoid package delimiters
return qq[ undef *{'$name'}; *{'$name'} = sub { $BEGIN $prolog $src } ];
}
use strict;
sub ::mk_strict_unsafefunc {
my $ret = eval(qq[ sub { use strict; $_[0] $_[1] } ]);
# see also mksafefunc() in plc_safe_ok.pl
sub ::mkunsafefunc {
no strict; # default to no strict for the eval
my $ret = eval(::mkfuncsrc(@_));
$@ =~ s/\(eval \d+\) //g if $@;
return $ret;
}
@ -64,7 +72,7 @@ sub ::encode_array_constructor {
if ref $arg ne 'ARRAY';
my $res = join ", ", map {
(ref $_) ? ::encode_array_constructor($_)
: ::quote_nullable($_)
: ::quote_nullable($_)
} @$arg;
return "ARRAY[$res]";
}

24
src/pl/plperl/plc_safe_bad.pl
View File

@ -1,18 +1,16 @@
# $PostgreSQL: pgsql/src/pl/plperl/plc_safe_bad.pl,v 1.2 2010/01/20 01:08:21 adunstan Exp $
# $PostgreSQL: pgsql/src/pl/plperl/plc_safe_bad.pl,v 1.3 2010/01/26 23:11:56 adunstan Exp $
use vars qw($PLContainer);
# Minimal version of plc_safe_ok.pl
# that's used if Safe is too old or doesn't load for any reason
$PLContainer = new Safe('PLPerl');
$PLContainer->permit_only(':default');
$PLContainer->share(qw[&elog &ERROR]);
my $msg = 'trusted Perl functions disabled - please upgrade Perl Safe module';
my $msg = 'trusted Perl functions disabled - please upgrade Perl Safe module to version 2.09 or later';
sub ::mksafefunc {
return $PLContainer->reval(qq[sub { elog(ERROR,'$msg') }]);
sub mksafefunc {
my ($name, $pragma, $prolog, $src) = @_;
# replace $src with code to generate an error
$src = qq{ ::elog(::ERROR,"$msg\n") };
my $ret = eval(::mkfuncsrc($name, $pragma, '', $src));
$@ =~ s/\(eval \d+\) //g if $@;
return $ret;
}
sub ::mk_strict_safefunc {
return $PLContainer->reval(qq[sub { elog(ERROR,'$msg') }]);
}

40
src/pl/plperl/plc_safe_ok.pl
View File

@ -1,12 +1,13 @@
# $PostgreSQL: pgsql/src/pl/plperl/plc_safe_ok.pl,v 1.2 2010/01/20 01:08:21 adunstan Exp $
# $PostgreSQL: pgsql/src/pl/plperl/plc_safe_ok.pl,v 1.3 2010/01/26 23:11:56 adunstan Exp $
use strict;
use vars qw($PLContainer);
$PLContainer = new Safe('PLPerl');
$PLContainer->permit_only(':default');
$PLContainer->permit(qw[:base_math !:base_io sort time]);
$PLContainer->permit(qw[:base_math !:base_io sort time require]);
$PLContainer->share(qw[&elog &return_next
&spi_query &spi_fetchrow &spi_cursor_close &spi_exec_query
@ -18,23 +19,24 @@ $PLContainer->share(qw[&elog &return_next
&looks_like_number
]);
# Load strict into the container.
# The temporary enabling of the caller opcode here is to work around a
# bug in perl 5.10, which unkindly changed the way its Safe.pm works, without
# notice. It is quite safe, as caller is informational only, and in any case
# we only enable it while we load the 'strict' module.
$PLContainer->permit(qw[require caller]);
$PLContainer->reval('use strict;');
$PLContainer->deny(qw[require caller]);
# Load widely useful pragmas into the container to make them available.
# (Temporarily enable caller here as work around for bug in perl 5.10,
# which changed the way its Safe.pm works. It is quite safe, as caller is
# informational only.)
$PLContainer->permit(qw[caller]);
::safe_eval(q{
require strict;
require feature if $] >= 5.010000;
1;
}) or die $@;
$PLContainer->deny(qw[caller]);
sub ::safe_eval {
my $ret = $PLContainer->reval(shift);
$@ =~ s/\(eval \d+\) //g if $@;
return $ret;
}
sub ::mksafefunc {
my $ret = $PLContainer->reval(qq[sub { $_[0] $_[1] }]);
$@ =~ s/\(eval \d+\) //g if $@;
return $ret;
}
sub ::mk_strict_safefunc {
my $ret = $PLContainer->reval(qq[sub { BEGIN { strict->import(); } $_[0] $_[1] }]);
$@ =~ s/\(eval \d+\) //g if $@;
return $ret;
return ::safe_eval(::mkfuncsrc(@_));
}

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

@ -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);

10
src/pl/plperl/sql/plperl.sql
View File

@ -368,5 +368,13 @@ DO $$
$$ LANGUAGE plperl;
-- check that restricted operations are rejected in a plperl DO block
DO $$ use Config; $$ LANGUAGE plperl;
DO $$ eval "1+1"; $$ LANGUAGE plperl;
-- check that we can't "use" a module that's not been loaded already
-- compile-time error: "Unable to load blib.pm into plperl"
DO $$ use blib; $$ LANGUAGE plperl;
-- check that we can "use" a module that has already been loaded
-- runtime error: "Can't use string ("foo") as a SCALAR ref while "strict refs" in use
DO $do$ use strict; my $name = "foo"; my $ref = $$name; $do$ LANGUAGE plperl;

10
src/pl/plperl/sql/plperl_plperlu.sql
View File

@ -1,17 +1,19 @@
-- test plperl/plperlu interaction
-- the language and call ordering of this test sequence is useful
CREATE OR REPLACE FUNCTION bar() RETURNS integer AS $$
#die 'BANG!'; # causes server process to exit(2)
# alternative - causes server process to exit(255)
spi_exec_query("invalid sql statement");
$$ language plperl; -- plperl or plperlu
$$ language plperl; -- compile plperl code
CREATE OR REPLACE FUNCTION foo() RETURNS integer AS $$
spi_exec_query("SELECT * FROM bar()");
return 1;
$$ LANGUAGE plperlu; -- must be opposite to language of bar
$$ LANGUAGE plperlu; -- compile plperlu code
SELECT * FROM bar(); -- throws exception normally
SELECT * FROM foo(); -- used to cause backend crash
SELECT * FROM bar(); -- throws exception normally (running plperl)
SELECT * FROM foo(); -- used to cause backend crash (after switching to plperlu)