I've started work on the enhancements to plperl I outlined on pg-general
(XXX thread)
I have a working implementation of those changes, plus some performance
enhancements, that I'm now re-working into a clean set of tested and
polished patches.
This patch is a first step that doesn't add any extra functionality.
It refactors the internals to make adding the extra functionality
easier (and more clearly visible).
Changes in this patch:
- Changed MULTIPLICITY check from runtime to compiletime.
No loads the large Config module.
- Changed plperl_init_interp() to return new interp
and not alter the global interp_state
- Moved plperl_safe_init() call into check_interp().
- Removed plperl_safe_init_done state variable
as interp_state now covers that role.
- Changed plperl_create_sub() to take a plperl_proc_desc argument.
- Simplified return value handling in plperl_create_sub.
- Adds a test for the effect of the utf8fix function.
I'd appreciate any feedback on the patch.
The next step I plan is to move the large multi-line string literal
macros (PERLBOOT, SAFE_OK etc) into external perl code files.
That'll make refactoring, extending and maintaining that perl
code far simpler.
A $pkglib_path/perl directory seems an appropriate place for this code.
Assuming that's okay, how should I go about creating that directory and
putting files there during build/installation?
I could implement that and include it as an update to this patch, or as
a new patch on top. Which would be preferable?
Tim.
*** a/src/pl/plperl/expected/plperl.out
--- b/src/pl/plperl/expected/plperl.out
***************
*** 555,557 **** $$ LANGUAGE plperl;
--- 555,564 ----
SELECT perl_spi_prepared_bad(4.35) as "double precision";
ERROR: type "does_not_exist" does not exist at line 2.
CONTEXT: PL/Perl function "perl_spi_prepared_bad"
+ --
+ -- Test compilation of unicode regex
+ --
+ CREATE OR REPLACE FUNCTION perl_unicode_regex(text) RETURNS INTEGER AS $$
+ # see http://rt.perl.org/rt3/Ticket/Display.html?id=47576
+ return ($_[0] =~ /\x{263A}|happy/i) ? 1 : 0; # unicode smiley
+ $$ LANGUAGE plperl;
*** a/src/pl/plperl/plperl.c
--- b/src/pl/plperl/plperl.c
***************
*** 125,133 **** typedef enum
} InterpState;
static InterpState interp_state = INTERP_NONE;
- static bool can_run_two = false;
- static bool plperl_safe_init_done = false;
static PerlInterpreter *plperl_trusted_interp = NULL;
static PerlInterpreter *plperl_untrusted_interp = NULL;
static PerlInterpreter *plperl_held_interp = NULL;
--- 125,131 ----
***************
*** 147,153 **** Datum plperl_call_handler(PG_FUNCTION_ARGS);
Datum plperl_validator(PG_FUNCTION_ARGS);
void _PG_init(void);
! static void plperl_init_interp(void);
static Datum plperl_func_handler(PG_FUNCTION_ARGS);
static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
--- 145,151 ----
Datum plperl_validator(PG_FUNCTION_ARGS);
void _PG_init(void);
! static PerlInterpreter *plperl_init_interp(void);
static Datum plperl_func_handler(PG_FUNCTION_ARGS);
static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
***************
*** 156,166 **** static plperl_proc_desc *compile_plperl_function(Oid fn_oid, bool is_trigger);
static SV *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc);
static void plperl_init_shared_libs(pTHX);
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 SV *plperl_create_sub(char *proname, char *s, bool trusted);
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);
--- 154,165 ----
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);
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);
***************
*** 226,232 **** _PG_init(void)
&hash_ctl,
HASH_ELEM);
! plperl_init_interp();
inited = true;
}
--- 225,232 ----
&hash_ctl,
HASH_ELEM);
! plperl_held_interp = plperl_init_interp();
! interp_state = INTERP_HELD;
inited = true;
}
***************
*** 311,322 **** _PG_init(void)
" elog(ERROR,'trusted Perl functions disabled - " \
" please upgrade Perl Safe module to version 2.09 or later');}]); }"
- #define TEST_FOR_MULTI \
- "use Config; " \
- "$Config{usemultiplicity} eq 'define' or " \
- "($Config{usethreads} eq 'define' " \
- " and $Config{useithreads} eq 'define')"
-
/********************************************************************
*
--- 311,316 ----
***************
*** 347,352 **** check_interp(bool trusted)
--- 341,348 ----
}
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) ||
***************
*** 361,382 **** check_interp(bool trusted)
trusted_context = trusted;
}
}
! else if (can_run_two)
{
! PERL_SET_CONTEXT(plperl_held_interp);
! plperl_init_interp();
if (trusted)
! plperl_trusted_interp = plperl_held_interp;
else
! plperl_untrusted_interp = plperl_held_interp;
! interp_state = INTERP_BOTH;
plperl_held_interp = NULL;
trusted_context = trusted;
! }
! else
! {
elog(ERROR,
"cannot allocate second Perl interpreter on this platform");
}
}
--- 357,379 ----
trusted_context = trusted;
}
}
! else
{
! #ifdef MULTIPLICITY
! PerlInterpreter *plperl = plperl_init_interp();
if (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
}
}
***************
*** 396,404 **** restore_context(bool old_context)
}
}
! static void
plperl_init_interp(void)
{
static char *embedding[3] = {
"", "-e", PERLBOOT
};
--- 393,404 ----
}
}
! static PerlInterpreter *
plperl_init_interp(void)
{
+ PerlInterpreter *plperl;
+ static int perl_sys_init_done;
+
static char *embedding[3] = {
"", "-e", PERLBOOT
};
***************
*** 457,487 **** plperl_init_interp(void)
*/
#if defined(PERL_SYS_INIT3) && !defined(MYMALLOC)
/* only call this the first time through, as per perlembed man page */
! if (interp_state == INTERP_NONE)
{
char *dummy_env[1] = {NULL};
PERL_SYS_INIT3(&nargs, (char ***) &embedding, (char ***) &dummy_env);
}
#endif
! plperl_held_interp = perl_alloc();
! if (!plperl_held_interp)
elog(ERROR, "could not allocate Perl interpreter");
! perl_construct(plperl_held_interp);
! perl_parse(plperl_held_interp, plperl_init_shared_libs,
nargs, embedding, NULL);
! perl_run(plperl_held_interp);
!
! if (interp_state == INTERP_NONE)
! {
! SV *res;
!
! res = eval_pv(TEST_FOR_MULTI, TRUE);
! can_run_two = SvIV(res);
! interp_state = INTERP_HELD;
! }
#ifdef WIN32
--- 457,480 ----
*/
#if defined(PERL_SYS_INIT3) && !defined(MYMALLOC)
/* only call this the first time through, as per perlembed man page */
! if (!perl_sys_init_done)
{
char *dummy_env[1] = {NULL};
PERL_SYS_INIT3(&nargs, (char ***) &embedding, (char ***) &dummy_env);
+ perl_sys_init_done = 1;
}
#endif
! plperl = perl_alloc();
! if (!plperl)
elog(ERROR, "could not allocate Perl interpreter");
! PERL_SET_CONTEXT(plperl);
! perl_construct(plperl);
! perl_parse(plperl, plperl_init_shared_libs,
nargs, embedding, NULL);
! perl_run(plperl);
#ifdef WIN32
***************
*** 524,529 **** plperl_init_interp(void)
--- 517,523 ----
}
#endif
+ return plperl;
}
***************
*** 557,591 **** plperl_safe_init(void)
* 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.
*/
plperl_proc_desc desc;
FunctionCallInfoData fcinfo;
- SV *ret;
- SV *func;
! /* make sure we don't call ourselves recursively */
! plperl_safe_init_done = true;
!
! /* compile the function */
! func = plperl_create_sub("utf8fix",
! "return shift =~ /\\xa9/i ? 'true' : 'false' ;",
! true);
!
! /* set up to call the function with a single text argument 'a' */
! desc.reference = func;
desc.nargs = 1;
desc.arg_is_rowtype[0] = false;
fmgr_info(F_TEXTOUT, &(desc.arg_out_func[0]));
fcinfo.arg[0] = CStringGetTextDatum("a");
fcinfo.argnull[0] = false;
/* and make the call */
! ret = plperl_call_perl_func(&desc, &fcinfo);
}
}
-
- plperl_safe_init_done = true;
}
/*
--- 551,579 ----
* 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;
! 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' ;");
+
+ /* 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);
}
}
}
/*
***************
*** 970,989 **** 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.
*/
! static SV *
! plperl_create_sub(char *proname, char *s, bool trusted)
{
dSP;
SV *subref;
int count;
char *compile_sub;
- if (trusted && !plperl_safe_init_done)
- {
- plperl_safe_init();
- SPAGAIN;
- }
-
ENTER;
SAVETMPS;
PUSHMARK(SP);
--- 958,972 ----
* 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);
***************
*** 1017,1025 **** plperl_create_sub(char *proname, char *s, bool trusted)
elog(ERROR, "didn't get a return item from mksafefunc");
}
if (SvTRUE(ERRSV))
{
- (void) POPs;
PUTBACK;
FREETMPS;
LEAVE;
--- 1000,1009 ----
elog(ERROR, "didn't get a return item from mksafefunc");
}
+ subref = POPs;
+
if (SvTRUE(ERRSV))
{
PUTBACK;
FREETMPS;
LEAVE;
***************
*** 1028,1057 **** plperl_create_sub(char *proname, char *s, bool trusted)
errmsg("%s", strip_trailing_ws(SvPV(ERRSV, PL_na)))));
}
- /*
- * need to make a deep copy of the return. it comes off the stack as a
- * temporary.
- */
- subref = newSVsv(POPs);
-
if (!SvROK(subref) || SvTYPE(SvRV(subref)) != SVt_PVCV)
{
PUTBACK;
FREETMPS;
LEAVE;
-
- /*
- * subref is our responsibility because it is not mortal
- */
- SvREFCNT_dec(subref);
elog(ERROR, "didn't get a code ref");
}
PUTBACK;
FREETMPS;
LEAVE;
! return subref;
}
--- 1012,1036 ----
errmsg("%s", strip_trailing_ws(SvPV(ERRSV, PL_na)))));
}
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;
}
***************
*** 1731,1739 **** compile_plperl_function(Oid fn_oid, bool is_trigger)
check_interp(prodesc->lanpltrusted);
! prodesc->reference = plperl_create_sub(prodesc->proname,
! proc_source,
! prodesc->lanpltrusted);
restore_context(oldcontext);
--- 1710,1716 ----
check_interp(prodesc->lanpltrusted);
! plperl_create_sub(prodesc, proc_source);
restore_context(oldcontext);
*** a/src/pl/plperl/sql/plperl.sql
--- b/src/pl/plperl/sql/plperl.sql
***************
*** 361,363 **** CREATE OR REPLACE FUNCTION perl_spi_prepared_bad(double precision) RETURNS doubl
--- 361,370 ----
$$ LANGUAGE plperl;
SELECT perl_spi_prepared_bad(4.35) as "double precision";
+ --
+ -- Test compilation of unicode regex
+ --
+ CREATE OR REPLACE FUNCTION perl_unicode_regex(text) RETURNS INTEGER AS $$
+ # see http://rt.perl.org/rt3/Ticket/Display.html?id=47576
+ return ($_[0] =~ /\x{263A}|happy/i) ? 1 : 0; # unicode smiley
+ $$ LANGUAGE plperl;
--
Sent via pgsql-hackers mailing list (pgsql-hackers@postgresql.org)
To make changes to your subscription:
http://www.postgresql.org/mailpref/pgsql-hackers
