From 1a7c2f9dea3682987a741f559ecf5e38b4ba5432 Mon Sep 17 00:00:00 2001 From: Andrew Dunstan 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 | 40 ++-- src/pl/plperl/plperl.c | 251 ++++++++++++++-------- src/pl/plperl/sql/plperl.sql | 10 +- src/pl/plperl/sql/plperl_plperlu.sql | 10 +- 9 files changed, 272 insertions(+), 178 deletions(-) diff --git a/doc/src/sgml/plperl.sgml b/doc/src/sgml/plperl.sgml index 8c56d56c86..90f63acdde 100644 --- a/doc/src/sgml/plperl.sgml +++ b/doc/src/sgml/plperl.sgml @@ -1,4 +1,4 @@ - + PL/Perl - Perl Procedural Language @@ -285,29 +285,39 @@ SELECT * FROM perl_set(); - If you wish to use the strict pragma with your code, - the easiest way to do so is to SET - plperl.use_strict to true. This parameter affects - subsequent compilations of PL/Perl functions, but not - functions already compiled in the current session. To set the - parameter before PL/Perl has been loaded, it is - necessary to have added plperl to the list in - postgresql.conf. + If you wish to use the strict pragma with your code you have a few options. + For temporary global use you can SET plperl.use_strict + to true (see ). + This will affect subsequent compilations of PL/Perl + functions, but not functions already compiled in the current session. + For permanent global use you can set plperl.use_strict + to true in the postgresql.conf file. - Another way to use the strict pragma is to put: + For permanent use in specific functions you can simply put: use strict; - in the function body. But this only works in PL/PerlU - functions, since the use triggers a require - which is not a trusted operation. In - PL/Perl functions you can instead do: - -BEGIN { strict->import(); } - + at the top of the function body. + + + + The feature pragma is also available to use if your Perl is version 5.10.0 or higher. + + + + + + Data Values in PL/Perl + + + 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 SELECT statement). + Conversely, the return and return_next + commands will accept any string that is acceptable input format + for the function's declared return type. @@ -682,18 +692,6 @@ SELECT done(); - - Data Values in PL/Perl - - - 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 SELECT statement). - Conversely, the 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. - @@ -1042,8 +1040,7 @@ CREATE TRIGGER test_valid_id_trig - PL/Perl functions cannot call each other directly (because they - are anonymous subroutines inside Perl). + PL/Perl functions cannot call each other directly. @@ -1072,6 +1069,8 @@ CREATE TRIGGER test_valid_id_trig + + diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out index b94273911d..ebf9afd904 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 80824e07ef..e940f711d5 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 29f7bed3dc..f0210e54f9 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 4193c81818..89eb11b642 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 cc4d3bdc3f..c7dc437d82 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]); +# 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(@_)); } diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c index 6daab687c3..09ffe3047b 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 08e5371083..e6ef5f069e 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 5b57a8276a..fc2bb7b806 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)