From 1a7c2f9dea3682987a741f559ecf5e38b4ba5432 Mon Sep 17 00:00:00 2001
From: Andrew Dunstan <andrew@dunslane.net>
Date: Tue, 26 Jan 2010 23:11:56 +0000
Subject: [PATCH] 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.
---
doc/src/sgml/plperl.sgml | 63 +++---
src/pl/plperl/expected/plperl.out | 15 +-
src/pl/plperl/expected/plperl_plperlu.out | 9 +-
src/pl/plperl/plc_perlboot.pl | 28 ++-
src/pl/plperl/plc_safe_bad.pl | 24 +--
src/pl/plperl/plc_safe_ok.pl | 36 ++--
src/pl/plperl/plperl.c | 251 ++++++++++++++--------
src/pl/plperl/sql/plperl.sql | 10 +-
src/pl/plperl/sql/plperl_plperlu.sql | 10 +-
9 files changed, 270 insertions(+), 176 deletions(-)
diff --git a/doc/src/sgml/plperl.sgml b/doc/src/sgml/plperl.sgml
index 8c56d56c865..90f63acdded 100644
--- a/doc/src/sgml/plperl.sgml
+++ b/doc/src/sgml/plperl.sgml
@@ -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>
diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out
index b94273911de..ebf9afd904b 100644
--- a/src/pl/plperl/expected/plperl.out
+++ b/src/pl/plperl/expected/plperl.out
@@ -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
diff --git a/src/pl/plperl/expected/plperl_plperlu.out b/src/pl/plperl/expected/plperl_plperlu.out
index 80824e07ef1..e940f711d52 100644
--- a/src/pl/plperl/expected/plperl_plperlu.out
+++ b/src/pl/plperl/expected/plperl_plperlu.out
@@ -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"
diff --git a/src/pl/plperl/plc_perlboot.pl b/src/pl/plperl/plc_perlboot.pl
index 29f7bed3dc4..f0210e54f90 100644
--- a/src/pl/plperl/plc_perlboot.pl
+++ b/src/pl/plperl/plc_perlboot.pl
@@ -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]";
}
diff --git a/src/pl/plperl/plc_safe_bad.pl b/src/pl/plperl/plc_safe_bad.pl
index 4193c818180..89eb11b642b 100644
--- a/src/pl/plperl/plc_safe_bad.pl
+++ b/src/pl/plperl/plc_safe_bad.pl
@@ -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') }]);
-}
-
diff --git a/src/pl/plperl/plc_safe_ok.pl b/src/pl/plperl/plc_safe_ok.pl
index cc4d3bdc3fa..c7dc437d82b 100644
--- a/src/pl/plperl/plc_safe_ok.pl
+++ b/src/pl/plperl/plc_safe_ok.pl
@@ -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]);
-
-sub ::mksafefunc {
- my $ret = $PLContainer->reval(qq[sub { $_[0] $_[1] }]);
+# 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 ::mk_strict_safefunc {
- my $ret = $PLContainer->reval(qq[sub { BEGIN { strict->import(); } $_[0] $_[1] }]);
- $@ =~ s/\(eval \d+\) //g if $@;
- return $ret;
+sub ::mksafefunc {
+ return ::safe_eval(::mkfuncsrc(@_));
}
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index 6daab687c3b..09ffe3047ba 100644
--- a/src/pl/plperl/plperl.c
+++ b/src/pl/plperl/plperl.c
@@ -1,7 +1,7 @@
/**********************************************************************
* plperl.c - perl as a procedural language for PostgreSQL
*
- * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.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);
diff --git a/src/pl/plperl/sql/plperl.sql b/src/pl/plperl/sql/plperl.sql
index 08e5371083d..e6ef5f069ef 100644
--- a/src/pl/plperl/sql/plperl.sql
+++ b/src/pl/plperl/sql/plperl.sql
@@ -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;
diff --git a/src/pl/plperl/sql/plperl_plperlu.sql b/src/pl/plperl/sql/plperl_plperlu.sql
index 5b57a8276ae..fc2bb7b8067 100644
--- a/src/pl/plperl/sql/plperl_plperlu.sql
+++ b/src/pl/plperl/sql/plperl_plperlu.sql
@@ -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)
--
GitLab