This is 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
Both are PGC_USERSET.
SPI functions are not available when the code is run.
Errors are detected and reported as ereport(ERROR, ...)
- 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 0054f5a..f2c91a9 100644
*** a/doc/src/sgml/plperl.sgml
--- b/doc/src/sgml/plperl.sgml
*************** plplerl.on_perl_init = 'use lib "/my/app
*** 1079,1084 ****
--- 1079,1120 ----
</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</> perl interpreter
+ is first initialized in a session. The perl code can only perform trusted operations.
+ The SPI functions are not available when this code is executed.
+ Changes made after a <literal>plperl</> perl interpreter has been initialized will have no effect.
+ If the code fails with an error it will abort the initialization of the interpreter
+ and propagate out to the calling query, causing the current transaction
+ or subtransaction to be aborted.
+ </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 interpreter
+ is first initialized in a session.
+ The SPI functions are not available when this code is executed.
+ Changes made after a <literal>plperlu</> perl interpreter has been initialized will have no effect.
+ If the code fails with an error it will abort the initialization of the interpreter
+ and propagate out to the calling query, causing the current transaction
+ or subtransaction to be aborted.
+ </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 7cd5721..f3cabad 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 ...e69de29 .
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 dc33dd6..7b36e33 100644
*** a/src/pl/plperl/plc_safe_ok.pl
--- b/src/pl/plperl/plc_safe_ok.pl
*************** $PLContainer->permit(qw[caller]);
*** 27,32 ****
--- 27,33 ----
}) 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 8315d5a..2eef4a7 100644
*** a/src/pl/plperl/plperl.c
--- b/src/pl/plperl/plperl.c
*************** static HTAB *plperl_query_hash = NULL;
*** 139,144 ****
--- 139,146 ----
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_
*** 163,169 ****
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);
--- 165,172 ----
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)
*** 249,254 ****
--- 252,273 ----
PGC_SIGHUP, 0,
NULL, NULL);
+ DefineCustomStringVariable("plperl.on_trusted_init",
+ gettext_noop("Perl code to execute when plperl is initialized for user."),
+ NULL,
+ &plperl_on_trusted_init,
+ NULL,
+ PGC_USERSET, 0,
+ NULL, NULL);
+
+ DefineCustomStringVariable("plperl.on_untrusted_init",
+ gettext_noop("Perl code to execute when plperlu is initialized for user."),
+ NULL,
+ &plperl_on_untrusted_init,
+ NULL,
+ PGC_USERSET, 0,
+ NULL, NULL);
+
EmitWarningsOnPlaceholders("plperl");
MemSet(&hash_ctl, 0, sizeof(hash_ctl));
*************** select_perl_context(bool trusted)
*** 323,333 ****
--- 342,354 ----
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)
*** 336,345 ****
{
#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,
--- 357,370 ----
{
#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)
*** 350,365 ****
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",
--- 375,380 ----
*************** plperl_destroy_interp(PerlInterpreter **
*** 603,609 ****
static void
! plperl_safe_init(void)
{
SV *safe_version_sv;
IV safe_version_x100;
--- 618,624 ----
static void
! plperl_trusted_init(void)
{
SV *safe_version_sv;
IV safe_version_x100;
*************** plperl_safe_init(void)
*** 642,679 ****
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
*/
--- 657,720 ----
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 ([email protected])
To make changes to your subscription:
http://www.postgresql.org/mailpref/pgsql-hackers
