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
