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 **** ! 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. ! Another way to use the strict pragma is to 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(); } ! --- 285,323 ---- ! 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. ! For permanent use in specific functions you can simply put: use strict; ! 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. *************** SELECT done(); *** 682,699 **** - - 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. - --- 692,697 ---- *************** CREATE TRIGGER test_valid_id_trig *** 1042,1049 **** ! PL/Perl functions cannot call each other directly (because they ! are anonymous subroutines inside Perl). --- 1040,1046 ---- ! PL/Perl functions cannot call each other directly. *************** CREATE TRIGGER test_valid_id_trig *** 1072,1077 **** --- 1069,1076 ---- + + 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)