This is the second of the patches to be split out from the former
'plperl feature patch 1'.
Changes in this patch:
- 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.
This patch will apply cleanly over the 'add functions' patch:
https://commitfest.postgresql.org/action/patch_view?id=264
Tim.
diff --git a/doc/src/sgml/plperl.sgml b/doc/src/sgml/plperl.sgml
index 94db722..6fee031 100644
*** a/doc/src/sgml/plperl.sgml
--- b/doc/src/sgml/plperl.sgml
*************** SELECT * FROM perl_set();
*** 285,313 ****
</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>.
</para>
<para>
! Another way to use the <literal>strict</> pragma is to 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>
</para>
</sect1>
--- 285,323 ----
</para>
<para>
! 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>
! For permanent use in specific functions you can simply put:
<programlisting>
use strict;
</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>
*************** SELECT done();
*** 682,699 ****
</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">
--- 692,697 ----
*************** CREATE TRIGGER test_valid_id_trig
*** 1042,1049 ****
<itemizedlist>
<listitem>
<para>
! PL/Perl functions cannot call each other directly (because they
! are anonymous subroutines inside Perl).
</para>
</listitem>
--- 1040,1046 ----
<itemizedlist>
<listitem>
<para>
! PL/Perl functions cannot call each other directly.
</para>
</listitem>
*************** CREATE TRIGGER test_valid_id_trig
*** 1072,1077 ****
--- 1069,1076 ----
</listitem>
</itemizedlist>
</para>
+ </sect2>
+
</sect1>
</chapter>
diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out
index b942739..ebf9afd 100644
*** a/src/pl/plperl/expected/plperl.out
--- b/src/pl/plperl/expected/plperl.out
*************** $$ LANGUAGE plperl;
*** 563,568 ****
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.
CONTEXT: PL/Perl anonymous code block
--- 563,579 ----
NOTICE: This is a test
CONTEXT: PL/Perl anonymous code block
-- check that restricted operations are rejected in a plperl DO block
! 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 80824e0..e940f71 100644
*** a/src/pl/plperl/expected/plperl_plperlu.out
--- b/src/pl/plperl/expected/plperl_plperlu.out
***************
*** 1,18 ****
-- test plperl/plperlu interaction
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
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
! SELECT * FROM bar(); -- throws exception normally
ERROR: syntax error at or near "invalid" at line 4.
CONTEXT: PL/Perl function "bar"
! SELECT * FROM foo(); -- used to cause backend crash
ERROR: syntax error at or near "invalid" at line 4. at line 2.
CONTEXT: PL/Perl function "foo"
--- 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; -- compile plperl code
CREATE OR REPLACE FUNCTION foo() RETURNS integer AS $$
spi_exec_query("SELECT * FROM bar()");
return 1;
! $$ LANGUAGE plperlu; -- compile plperlu code
! 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 (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 b4d1e04..769721d 100644
*** a/src/pl/plperl/plc_perlboot.pl
--- b/src/pl/plperl/plc_perlboot.pl
*************** sub ::plperl_die {
*** 18,34 ****
}
$SIG{__DIE__} = \&::plperl_die;
! sub ::mkunsafefunc {
! my $ret = eval(qq[ sub { $_[0] $_[1] } ]);
! $@ =~ s/\(eval \d+\) //g if $@;
! return $ret;
}
-
- use strict;
! sub ::mk_strict_unsafefunc {
! my $ret = eval(qq[ sub { use strict; $_[0] $_[1] } ]);
$@ =~ s/\(eval \d+\) //g if $@;
return $ret;
}
--- 18,45 ----
}
$SIG{__DIE__} = \&::plperl_die;
+ sub ::mkfuncsrc {
+ my ($name, $imports, $prolog, $src) = @_;
! my $BEGIN = join "\n", map {
! my $names = $imports->{$_} || [];
! "$_->import(qw(@$names));"
! } keys %$imports;
! $BEGIN &&= "BEGIN { $BEGIN }";
!
! $name =~ s/\\/\\\\/g;
! $name =~ s/::|'/_/g; # avoid package delimiters
!
! my $funcsrc;
! $funcsrc .= qq[ undef *{'$name'}; *{'$name'} = sub { $BEGIN $prolog $src } ];
! #warn "plperl mkfuncsrc: $funcsrc\n";
! return $funcsrc;
}
! # 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;
}
*************** sub ::encode_array_constructor {
*** 61,67 ****
if ref $arg ne 'ARRAY';
my $res = join ", ", map {
(ref $_) ? ::encode_array_constructor($_)
! : ::quote_nullable($_)
} @$arg;
return "ARRAY[$res]";
}
--- 72,78 ----
if ref $arg ne 'ARRAY';
my $res = join ", ", map {
(ref $_) ? ::encode_array_constructor($_)
! : ::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 838ccc6..36ef6ae 100644
*** a/src/pl/plperl/plc_safe_bad.pl
--- b/src/pl/plperl/plc_safe_bad.pl
***************
*** 1,15 ****
! use vars qw($PLContainer);
!
! $PLContainer = new Safe('PLPerl');
! $PLContainer->permit_only(':default');
! $PLContainer->share(qw[&elog &ERROR]);
! 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 ::mk_strict_safefunc {
! return $PLContainer->reval(qq[sub { elog(ERROR,'$msg') }]);
}
-
--- 1,13 ----
! # Minimal version of plc_safe_ok.pl
! # that's used if Safe is too old or doesn't load for any reason
! my $msg = 'trusted Perl functions disabled - please upgrade Perl Safe module';
! 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;
}
diff --git a/src/pl/plperl/plc_safe_ok.pl b/src/pl/plperl/plc_safe_ok.pl
index aec5cdc..dc33dd6 100644
*** a/src/pl/plperl/plc_safe_ok.pl
--- b/src/pl/plperl/plc_safe_ok.pl
***************
*** 1,8 ****
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 &return_next
&spi_query &spi_fetchrow &spi_cursor_close &spi_exec_query
--- 1,9 ----
+ use strict;
use vars qw($PLContainer);
$PLContainer = new Safe('PLPerl');
$PLContainer->permit_only(':default');
! $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
*************** $PLContainer->share(qw[&elog &return_nex
*** 14,36 ****
&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] }]);
$@ =~ 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;
}
--- 15,38 ----
&looks_like_number
]);
! # 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 {
! return ::safe_eval(::mkfuncsrc(@_));
}
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index 6f577f0..9277072 100644
*** a/src/pl/plperl/plperl.c
--- b/src/pl/plperl/plperl.c
*************** static InterpState interp_state = INTERP
*** 132,137 ****
--- 132,138 ----
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 HV *plperl_spi_execute_fetch_res
*** 163,173 ****
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 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);
/*
* Convert an SV to char * and verify the encoding via pg_verifymbstr()
--- 164,177 ----
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, 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()
*************** sv2text_mbverified(SV *sv)
*** 187,193 ****
*/
val = SvPV(sv, len);
pg_verifymbstr(val, len, false);
! return val;
}
/*
--- 191,197 ----
*/
val = SvPV(sv, len);
pg_verifymbstr(val, len, false);
! return val;
}
/*
*************** _PG_init(void)
*** 267,280 ****
* 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)
--- 271,291 ----
* 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.
*/
static void
! 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)
*************** check_interp(bool trusted)
*** 287,309 ****
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
{
--- 298,303 ----
*************** check_interp(bool trusted)
*** 313,344 ****
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
}
}
/*
* Restore previous interpreter selection, if two are active
*/
! static void
! restore_context(bool old_context)
{
! if (interp_state == INTERP_BOTH && trusted_context != old_context)
{
! if (old_context)
! PERL_SET_CONTEXT(plperl_trusted_interp);
! else
! PERL_SET_CONTEXT(plperl_untrusted_interp);
! trusted_context = old_context;
}
}
static PerlInterpreter *
--- 307,358 ----
plperl_trusted_interp = plperl;
else
plperl_untrusted_interp = plperl;
interp_state = INTERP_BOTH;
#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 int
! restore_context(bool trusted)
{
! 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);
! 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 *
*************** plperl_init_interp(void)
*** 422,427 ****
--- 436,451 ----
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);
*************** plperl_init_interp(void)
*** 471,496 ****
}
static void
plperl_safe_init(void)
{
SV *safe_version_sv;
safe_version_sv = eval_pv(SAFE_MODULE, FALSE); /* TRUE = croak if failure */
/*
! * 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.
*/
! if (SvNV(safe_version_sv) < 2.0899)
{
/* not safe, so disallow all trusted funcs */
eval_pv(PLC_SAFE_BAD, FALSE);
}
else
{
eval_pv(PLC_SAFE_OK, FALSE);
if (GetDatabaseEncoding() == PG_UTF8)
{
/*
--- 495,565 ----
}
+ /*
+ * 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);
/*
! * Reject too-old versions of Safe and some others:
! * 2.20: http://rt.perl.org/rt3/Ticket/Display.html?id=72068
*/
! 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_safe_init(void)
*** 502,507 ****
--- 571,577 ----
*/
plperl_proc_desc desc;
FunctionCallInfoData fcinfo;
+ SV *perlret;
desc.proname = "utf8fix";
desc.lanpltrusted = true;
*************** plperl_safe_init(void)
*** 511,524 ****
/* compile the function */
plperl_create_sub(&desc,
! "return shift =~ /\\xa9/i ? 'true' : 'false' ;");
/* 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);
}
}
}
--- 581,596 ----
/* compile the function */
plperl_create_sub(&desc,
! "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 */
! perlret = plperl_call_perl_func(&desc, &fcinfo);
!
! SvREFCNT_dec(perlret);
}
}
}
*************** plperl_convert_to_pg_array(SV *src)
*** 582,588 ****
{
SV *rv;
int count;
-
dSP;
PUSHMARK(SP);
--- 654,659 ----
*************** plperl_trigger_build_args(FunctionCallIn
*** 619,624 ****
--- 690,696 ----
HV *hv;
hv = newHV();
+ hv_ksplit(hv, 12); /* pre-grow the hash */
tdata = (TriggerData *) fcinfo->context;
tupdesc = tdata->tg_relation->rd_att;
*************** plperl_trigger_build_args(FunctionCallIn
*** 673,678 ****
--- 745,751 ----
{
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));
*************** plperl_inline_handler(PG_FUNCTION_ARGS)
*** 893,901 ****
if (SPI_connect() != SPI_OK_CONNECT)
elog(ERROR, "could not connect to SPI manager");
! check_interp(desc.lanpltrusted);
! plperl_create_sub(&desc, codeblock->source_text);
if (!desc.reference) /* can this happen? */
elog(ERROR, "could not create internal procedure for anonymous code block");
--- 966,974 ----
if (SPI_connect() != SPI_OK_CONNECT)
elog(ERROR, "could not connect to SPI manager");
! select_perl_context(desc.lanpltrusted);
! 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");
*************** plperl_validator(PG_FUNCTION_ARGS)
*** 1000,1022 ****
/*
! * Uses mksafefunc/mkunsafefunc to create an anonymous sub whose text is
! * supplied in s, and returns a reference to the closure.
*/
static void
! plperl_create_sub(plperl_proc_desc *prodesc, char *s)
{
dSP;
bool trusted = prodesc->lanpltrusted;
! SV *subref;
! int count;
! char *compile_sub;
ENTER;
SAVETMPS;
PUSHMARK(SP);
! XPUSHs(sv_2mortal(newSVstring("our $_TD; local $_TD=$_[0]; shift;")));
! XPUSHs(sv_2mortal(newSVstring(s)));
PUTBACK;
/*
--- 1073,1105 ----
/*
! * 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, Oid fn_oid)
{
dSP;
bool trusted = prodesc->lanpltrusted;
! 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);
! 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;
/*
*************** plperl_create_sub(plperl_proc_desc *prod
*** 1024,1080 ****
* 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";
!
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");
}
! subref = POPs;
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)
{
! PUTBACK;
! FREETMPS;
! LEAVE;
! elog(ERROR, "didn't get a code ref");
}
- /*
- * need to make a copy of the return, it comes off the stack as a
- * temporary.
- */
prodesc->reference = newSVsv(subref);
- PUTBACK;
- FREETMPS;
- LEAVE;
-
return;
}
--- 1107,1142 ----
* errors properly. Perhaps it's because there's another level of eval
* inside mksafefunc?
*/
! compile_sub = (trusted) ? "::mksafefunc" : "::mkunsafefunc";
count = perl_call_pv(compile_sub, G_SCALAR | G_EVAL | G_KEEPERR);
SPAGAIN;
! if (count == 1) {
! GV *sub_glob = (GV*)POPs;
! if (sub_glob && SvTYPE(sub_glob) == SVt_PVGV)
! subref = newRV_inc((SV*)GvCVu((GV*)sub_glob));
}
! PUTBACK;
! FREETMPS;
! LEAVE;
if (SvTRUE(ERRSV))
{
ereport(ERROR,
(errcode(ERRCODE_SYNTAX_ERROR),
errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV)))));
}
! if (!subref)
{
! ereport(ERROR,
! (errcode(ERRCODE_INTERNAL_ERROR),
! errmsg("didn't get a GLOB from compiling %s via %s", prodesc->proname, compile_sub)));
}
prodesc->reference = newSVsv(subref);
return;
}
*************** plperl_call_perl_func(plperl_proc_desc *
*** 1118,1130 ****
SAVETMPS;
PUSHMARK(SP);
! XPUSHs(&PL_sv_undef); /* no trigger data */
for (i = 0; i < desc->nargs; i++)
{
if (fcinfo->argnull[i])
! XPUSHs(&PL_sv_undef);
else if (desc->arg_is_rowtype[i])
{
HeapTupleHeader td;
--- 1180,1193 ----
SAVETMPS;
PUSHMARK(SP);
+ EXTEND(sp, 1 + desc->nargs);
! PUSHs(&PL_sv_undef); /* no trigger data */
for (i = 0; i < desc->nargs; i++)
{
if (fcinfo->argnull[i])
! PUSHs(&PL_sv_undef);
else if (desc->arg_is_rowtype[i])
{
HeapTupleHeader td;
*************** plperl_call_perl_func(plperl_proc_desc *
*** 1144,1150 ****
tmptup.t_data = td;
hashref = plperl_hash_from_tuple(&tmptup, tupdesc);
! XPUSHs(sv_2mortal(hashref));
ReleaseTupleDesc(tupdesc);
}
else
--- 1207,1213 ----
tmptup.t_data = td;
hashref = plperl_hash_from_tuple(&tmptup, tupdesc);
! PUSHs(sv_2mortal(hashref));
ReleaseTupleDesc(tupdesc);
}
else
*************** plperl_call_perl_func(plperl_proc_desc *
*** 1154,1160 ****
tmp = OutputFunctionCall(&(desc->arg_out_func[i]),
fcinfo->arg[i]);
sv = newSVstring(tmp);
! XPUSHs(sv_2mortal(sv));
pfree(tmp);
}
}
--- 1217,1223 ----
tmp = OutputFunctionCall(&(desc->arg_out_func[i]),
fcinfo->arg[i]);
sv = newSVstring(tmp);
! PUSHs(sv_2mortal(sv));
pfree(tmp);
}
}
*************** plperl_func_handler(PG_FUNCTION_ARGS)
*** 1293,1299 ****
"cannot accept a set")));
}
! check_interp(prodesc->lanpltrusted);
perlret = plperl_call_perl_func(prodesc, fcinfo);
--- 1356,1362 ----
"cannot accept a set")));
}
! select_perl_context(prodesc->lanpltrusted);
perlret = plperl_call_perl_func(prodesc, fcinfo);
*************** plperl_trigger_handler(PG_FUNCTION_ARGS)
*** 1440,1446 ****
pl_error_context.arg = prodesc->proname;
error_context_stack = &pl_error_context;
! check_interp(prodesc->lanpltrusted);
svTD = plperl_trigger_build_args(fcinfo);
perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
--- 1503,1509 ----
pl_error_context.arg = prodesc->proname;
error_context_stack = &pl_error_context;
! select_perl_context(prodesc->lanpltrusted);
svTD = plperl_trigger_build_args(fcinfo);
perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
*************** compile_plperl_function(Oid fn_oid, bool
*** 1757,1765 ****
* Create the procedure in the interpreter
************************************************************/
! check_interp(prodesc->lanpltrusted);
! plperl_create_sub(prodesc, proc_source);
restore_context(oldcontext);
--- 1820,1828 ----
* Create the procedure in the interpreter
************************************************************/
! select_perl_context(prodesc->lanpltrusted);
! plperl_create_sub(prodesc, proc_source, fn_oid);
restore_context(oldcontext);
*************** plperl_hash_from_tuple(HeapTuple tuple,
*** 1795,1800 ****
--- 1858,1864 ----
int i;
hv = newHV();
+ hv_ksplit(hv, tupdesc->natts); /* pre-grow the hash */
for (i = 0; i < tupdesc->natts; i++)
{
*************** plperl_spi_execute_fetch_result(SPITuple
*** 1922,1927 ****
--- 1986,1992 ----
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 08e5371..e6ef5f0 100644
*** a/src/pl/plperl/sql/plperl.sql
--- b/src/pl/plperl/sql/plperl.sql
*************** DO $$
*** 368,372 ****
$$ LANGUAGE plperl;
-- check that restricted operations are rejected in a plperl DO block
! DO $$ use Config; $$ LANGUAGE plperl;
--- 368,380 ----
$$ LANGUAGE plperl;
-- check that restricted operations are rejected in a plperl DO block
! 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 5b57a82..fc2bb7b 100644
*** a/src/pl/plperl/sql/plperl_plperlu.sql
--- b/src/pl/plperl/sql/plperl_plperlu.sql
***************
*** 1,17 ****
-- test plperl/plperlu interaction
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
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
! SELECT * FROM bar(); -- throws exception normally
! SELECT * FROM foo(); -- used to cause backend crash
--- 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; -- compile plperl code
CREATE OR REPLACE FUNCTION foo() RETURNS integer AS $$
spi_exec_query("SELECT * FROM bar()");
return 1;
! $$ LANGUAGE plperlu; -- compile plperlu code
! SELECT * FROM bar(); -- throws exception normally (running plperl)
! SELECT * FROM foo(); -- used to cause backend crash (after switching to plperlu)
--
Sent via pgsql-hackers mailing list (pgsql-hackers@postgresql.org)
To make changes to your subscription:
http://www.postgresql.org/mailpref/pgsql-hackers
