This is an update the fourth of the patches to be split out from the former 'plperl feature patch 1'.
Changes in this patch: - Adds plperl.on_trusted_init and plperl.on_untrusted_init GUCs on_trusted_init is PGC_USERSET, on_untrusted_init is PGC_SUSET SPI functions are not available when the code is run. Errors are detected and reported as ereport(ERROR, ...) Corresponding documentation. - select_perl_context() state management improved An error during interpreter initialization will leave the state (interp_state etc) unchanged. - The utf8fix code has been greatly simplified. Tim.
diff --git a/doc/src/sgml/plperl.sgml b/doc/src/sgml/plperl.sgml index ea56b99..0add7d1 100644 *** a/doc/src/sgml/plperl.sgml --- b/doc/src/sgml/plperl.sgml *************** CREATE TRIGGER test_valid_id_trig *** 1058,1066 **** or subtransaction to be aborted. </para> <para> ! The perl code is limited to a single string. Longer code can be placed ! into a module and loaded by the <literal>on_perl_init</> string. ! Examples: <programlisting> plplerl.on_perl_init = '$ENV{NYTPROF}="start=no"; require Devel::NYTProf::PgPLPerl' plplerl.on_perl_init = 'use lib "/my/app"; use MyApp::PgInit;' --- 1058,1066 ---- or subtransaction to be aborted. </para> <para> ! The perl code is limited to a single string. Longer code can be placed ! into a module and loaded by the <literal>on_perl_init</> string. ! Examples: <programlisting> plplerl.on_perl_init = '$ENV{NYTPROF}="start=no"; require Devel::NYTProf::PgPLPerl' plplerl.on_perl_init = 'use lib "/my/app"; use MyApp::PgInit;' *************** plplerl.on_perl_init = 'use lib "/my/app *** 1077,1082 **** --- 1077,1128 ---- </listitem> </varlistentry> + <varlistentry id="guc-plperl-on-trusted-init" xreflabel="plperl.on_trusted_init"> + <term><varname>plperl.on_trusted_init</varname> (<type>string</type>)</term> + <indexterm> + <primary><varname>plperl.on_trusted_init</> configuration parameter</primary> + </indexterm> + <listitem> + <para> + Specifies perl code to be executed when the <literal>plperl</> language + is first used in a session. Changes made after the <literal>plperl</> + language has been used will have no effect. + The perl code can only perform trusted operations. + The SPI functions are not available when this code is executed. + </para> + <para> + If the code fails with an error it will abort the initialization and + propagate out to the calling query, causing the current transaction or + subtransaction to be aborted. Any changes within the perl won't be + undone. If the <literal>plperl</> language is used again the + initialization will be repeated. + </para> + </listitem> + </varlistentry> + + <varlistentry id="guc-plperl-on-untrusted-init" xreflabel="plperl.on_untrusted_init"> + <term><varname>plperl.on_untrusted_init</varname> (<type>string</type>)</term> + <indexterm> + <primary><varname>plperl.on_untrusted_init</> configuration parameter</primary> + </indexterm> + <listitem> + <para> + Specifies perl code to be executed when the <literal>plperlu</> perl language + is first used in a session. Changes made after the <literal>plperlu</> + language has been used will have no effect. + The SPI functions are not available when this code is executed. + Only superusers can change this settings. + </para> + <para> + If the code fails with an error it will abort the initialization and + propagate out to the calling query, causing the current transaction or + subtransaction to be aborted. Any changes within the perl won't be + undone. If the <literal>plperlu</> language is used again the + initialization will be repeated. + </para> + </listitem> + </varlistentry> + <varlistentry id="guc-plperl-use-strict" xreflabel="plperl.use_strict"> <term><varname>plperl.use_strict</varname> (<type>boolean</type>)</term> <indexterm> diff --git a/src/pl/plperl/GNUmakefile b/src/pl/plperl/GNUmakefile index a9bb003..165e90d 100644 *** a/src/pl/plperl/GNUmakefile --- b/src/pl/plperl/GNUmakefile *************** PERLCHUNKS = plc_perlboot.pl plc_safe_ba *** 41,47 **** SHLIB_LINK = $(perl_embed_ldflags) REGRESS_OPTS = --dbname=$(PL_TESTDB) --load-language=plperl --load-language=plperlu ! REGRESS = plperl plperl_trigger plperl_shared plperl_elog plperl_util plperlu # if Perl can support two interpreters in one backend, # test plperl-and-plperlu cases ifneq ($(PERL),) --- 41,47 ---- SHLIB_LINK = $(perl_embed_ldflags) REGRESS_OPTS = --dbname=$(PL_TESTDB) --load-language=plperl --load-language=plperlu ! REGRESS = plperl plperl_trigger plperl_shared plperl_elog plperl_util plperl_init plperlu # if Perl can support two interpreters in one backend, # test plperl-and-plperlu cases ifneq ($(PERL),) diff --git a/src/pl/plperl/expected/plperl_init.out b/src/pl/plperl/expected/plperl_init.out index ...f7eff68 . *** a/src/pl/plperl/expected/plperl_init.out --- b/src/pl/plperl/expected/plperl_init.out *************** *** 0 **** --- 1,12 ---- + -- test plperl.on_trusted_init errors are fatal + SET SESSION plperl.on_trusted_init = ' eval "1+1" '; + SHOW plperl.on_trusted_init; + plperl.on_trusted_init + ------------------------ + eval "1+1" + (1 row) + + DO $$ warn 42 $$ language plperl; + ERROR: while executing plperl.on_trusted_init + DETAIL: 'eval "string"' trapped by operation mask at line 2. + CONTEXT: PL/Perl anonymous code block diff --git a/src/pl/plperl/expected/plperl_shared.out b/src/pl/plperl/expected/plperl_shared.out index 72ae1ba..c1c12c1 100644 *** a/src/pl/plperl/expected/plperl_shared.out --- b/src/pl/plperl/expected/plperl_shared.out *************** *** 1,3 **** --- 1,7 ---- + -- test plperl.on_plperl_init via the shared hash + -- (must be done before plperl is initialized) + -- testing on_trusted_init gets run, and that it can alter %_SHARED + SET plperl.on_trusted_init = '$_SHARED{on_init} = 42'; -- test the shared hash create function setme(key text, val text) returns void language plperl as $$ *************** select getme('ourkey'); *** 24,26 **** --- 28,36 ---- ourval (1 row) + select getme('on_init'); + getme + ------- + 42 + (1 row) + diff --git a/src/pl/plperl/plc_safe_ok.pl b/src/pl/plperl/plc_safe_ok.pl index 0999d40..e3666f2 100644 *** a/src/pl/plperl/plc_safe_ok.pl --- b/src/pl/plperl/plc_safe_ok.pl *************** $PLContainer->permit(qw[caller]); *** 31,36 **** --- 31,37 ---- }) or die $@; $PLContainer->deny(qw[caller]); + # called directly for plperl.on_trusted_init sub ::safe_eval { my $ret = $PLContainer->reval(shift); $@ =~ s/\(eval \d+\) //g if $@; diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c index 1a559f3..2b6ec2f 100644 *** a/src/pl/plperl/plperl.c --- b/src/pl/plperl/plperl.c *************** static HTAB *plperl_query_hash = NULL; *** 140,145 **** --- 140,147 ---- static bool plperl_use_strict = false; static char *plperl_on_perl_init = NULL; + static char *plperl_on_trusted_init = NULL; + static char *plperl_on_untrusted_init = NULL; static bool plperl_ending = false; /* this is saved and restored by plperl_call_handler */ *************** static plperl_proc_desc *compile_plperl_ *** 164,170 **** static SV *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc); static void plperl_init_shared_libs(pTHX); ! static void plperl_safe_init(void); 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); --- 166,173 ---- static SV *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc); static void plperl_init_shared_libs(pTHX); ! static void plperl_trusted_init(void); ! static void plperl_untrusted_init(void); 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); *************** _PG_init(void) *** 243,255 **** NULL, NULL); DefineCustomStringVariable("plperl.on_perl_init", ! gettext_noop("Perl code to execute when the perl interpreter is initialized."), NULL, &plperl_on_perl_init, NULL, PGC_SIGHUP, 0, NULL, NULL); EmitWarningsOnPlaceholders("plperl"); MemSet(&hash_ctl, 0, sizeof(hash_ctl)); --- 246,274 ---- NULL, NULL); DefineCustomStringVariable("plperl.on_perl_init", ! gettext_noop("Perl initialization code to execute when a perl interpreter is initialized."), NULL, &plperl_on_perl_init, NULL, PGC_SIGHUP, 0, NULL, NULL); + DefineCustomStringVariable("plperl.on_trusted_init", + gettext_noop("Perl initialization code to execute once when plperl is first used."), + NULL, + &plperl_on_trusted_init, + NULL, + PGC_USERSET, 0, + NULL, NULL); + + DefineCustomStringVariable("plperl.on_untrusted_init", + gettext_noop("Perl initialization code to execute once when plperlu is first used."), + NULL, + &plperl_on_untrusted_init, + NULL, + PGC_SUSET, 0, + NULL, NULL); + EmitWarningsOnPlaceholders("plperl"); MemSet(&hash_ctl, 0, sizeof(hash_ctl)); *************** select_perl_context(bool trusted) *** 340,350 **** --- 359,371 ---- if (trusted) { + plperl_trusted_init(); plperl_trusted_interp = plperl_held_interp; interp_state = INTERP_TRUSTED; } else { + plperl_untrusted_init(); plperl_untrusted_interp = plperl_held_interp; interp_state = INTERP_UNTRUSTED; } *************** select_perl_context(bool trusted) *** 353,362 **** { #ifdef MULTIPLICITY PerlInterpreter *plperl = plperl_init_interp(); ! if (trusted) plperl_trusted_interp = plperl; ! else plperl_untrusted_interp = plperl; interp_state = INTERP_BOTH; #else elog(ERROR, --- 374,387 ---- { #ifdef MULTIPLICITY PerlInterpreter *plperl = plperl_init_interp(); ! if (trusted) { ! plperl_trusted_init(); plperl_trusted_interp = plperl; ! } ! else { ! plperl_untrusted_init(); plperl_untrusted_interp = plperl; + } interp_state = INTERP_BOTH; #else elog(ERROR, *************** select_perl_context(bool trusted) *** 367,382 **** 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; - } - - /* * enable access to the database */ newXS("PostgreSQL::InServer::SPI::bootstrap", --- 392,397 ---- *************** plperl_destroy_interp(PerlInterpreter ** *** 645,651 **** static void ! plperl_safe_init(void) { SV *safe_version_sv; IV safe_version_x100; --- 660,666 ---- static void ! plperl_trusted_init(void) { SV *safe_version_sv; IV safe_version_x100; *************** plperl_safe_init(void) *** 684,721 **** if (GetDatabaseEncoding() == PG_UTF8) { /* ! * Fill in just enough information to set up this perl function in ! * the safe container and call it. For some reason not entirely ! * clear, it prevents errors that can arise from the regex code ! * later trying to load utf8 modules. * See http://rt.perl.org/rt3/Ticket/Display.html?id=47576 */ ! plperl_proc_desc desc; ! FunctionCallInfoData fcinfo; ! SV *perlret; ! desc.proname = "utf8fix"; ! desc.lanpltrusted = true; ! desc.nargs = 1; ! desc.arg_is_rowtype[0] = false; ! fmgr_info(F_TEXTOUT, &(desc.arg_out_func[0])); ! /* 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); } } } /* * Perl likes to put a newline after its error messages; clean up such */ --- 699,762 ---- if (GetDatabaseEncoding() == PG_UTF8) { /* ! * Force loading of utf8 module now to prevent errors that can ! * arise from the regex code later trying to load utf8 modules. * See http://rt.perl.org/rt3/Ticket/Display.html?id=47576 */ ! eval_pv("my $a=chr(0x100); return $a =~ /\\xa9/i", FALSE); ! if (SvTRUE(ERRSV)) ! { ! ereport(ERROR, ! (errcode(ERRCODE_INTERNAL_ERROR), ! errmsg("while executing utf8fix"), ! errdetail("%s", strip_trailing_ws(SvPV_nolen(ERRSV))) )); ! } ! } ! /* switch to the safe require opcode */ ! PL_ppaddr[OP_REQUIRE] = pp_require_safe; ! if (plperl_on_trusted_init && *plperl_on_trusted_init) ! { ! dSP; ! PUSHMARK(SP); ! XPUSHs(sv_2mortal(newSVstring(plperl_on_trusted_init))); ! PUTBACK; ! call_pv("::safe_eval", G_VOID); ! SPAGAIN; ! if (SvTRUE(ERRSV)) ! { ! ereport(ERROR, ! (errcode(ERRCODE_INTERNAL_ERROR), ! errmsg("while executing plperl.on_trusted_init"), ! errdetail("%s", strip_trailing_ws(SvPV_nolen(ERRSV))) )); ! } ! } ! ! } ! } ! ! ! static void ! plperl_untrusted_init(void) ! { ! if (plperl_on_untrusted_init && *plperl_on_untrusted_init) ! { ! eval_pv(plperl_on_untrusted_init, FALSE); ! if (SvTRUE(ERRSV)) ! { ! ereport(ERROR, ! (errcode(ERRCODE_INTERNAL_ERROR), ! errmsg("while executing plperl.on_untrusted_init"), ! errdetail("%s", strip_trailing_ws(SvPV_nolen(ERRSV))) )); } } } + /* * Perl likes to put a newline after its error messages; clean up such */ diff --git a/src/pl/plperl/sql/plperl_init.sql b/src/pl/plperl/sql/plperl_init.sql index ...5f6b963 . *** a/src/pl/plperl/sql/plperl_init.sql --- b/src/pl/plperl/sql/plperl_init.sql *************** *** 0 **** --- 1,7 ---- + -- test plperl.on_trusted_init errors are fatal + + SET SESSION plperl.on_trusted_init = ' eval "1+1" '; + + SHOW plperl.on_trusted_init; + + DO $$ warn 42 $$ language plperl; diff --git a/src/pl/plperl/sql/plperl_shared.sql b/src/pl/plperl/sql/plperl_shared.sql index 3e99e59..83cc5f0 100644 *** a/src/pl/plperl/sql/plperl_shared.sql --- b/src/pl/plperl/sql/plperl_shared.sql *************** *** 1,3 **** --- 1,9 ---- + -- test plperl.on_plperl_init via the shared hash + -- (must be done before plperl is initialized) + + -- testing on_trusted_init gets run, and that it can alter %_SHARED + SET plperl.on_trusted_init = '$_SHARED{on_init} = 42'; + -- test the shared hash create function setme(key text, val text) returns void language plperl as $$ *************** select setme('ourkey','ourval'); *** 19,22 **** select getme('ourkey'); ! --- 25,28 ---- select getme('ourkey'); ! select getme('on_init');
-- Sent via pgsql-hackers mailing list (pgsql-hackers@postgresql.org) To make changes to your subscription: http://www.postgresql.org/mailpref/pgsql-hackers