Following on from my earlier draft plperl.c refactoring patch, here's a
new version that's complete (from my perspective at least).
I've started work on the enhancements to plperl I outlined on pg-general
(in the "Wishlist of PL/Perl Enhancements for 8.5" 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.
- Added a test for the effect of the utf8fix function.
- Changed perl.com link in the docs to perl.org and tweaked
wording to clarify that require, not use, is what's blocked.
- Moved perl code in large multi-line C string literal macros
out to plc_*.pl files.
- Added a test2macro.pl utility to convert the plc_*.pl files to
macros in a perlchunks.h file which is #included
I'd appreciate any feedback on the patch.
Tim.
diff --git a/doc/src/sgml/plperl.sgml b/doc/src/sgml/plperl.sgml
index 49631f2..4c26561 100644
*** a/doc/src/sgml/plperl.sgml
--- b/doc/src/sgml/plperl.sgml
***************
*** 14,20 ****
<para>
PL/Perl is a loadable procedural language that enables you to write
<productname>PostgreSQL</productname> functions in the
! <ulink url="http://www.perl.com";>Perl programming language</ulink>.
</para>
<para>
--- 14,20 ----
<para>
PL/Perl is a loadable procedural language that enables you to write
<productname>PostgreSQL</productname> functions in the
! <ulink url="http://www.perl.org";>Perl programming language</ulink>.
</para>
<para>
*************** SELECT * FROM perl_set();
*** 298,304 ****
use strict;
</programlisting>
in the function body. But this only works in <application>PL/PerlU</>
! functions, since <literal>use</> is not a trusted operation. In
<application>PL/Perl</> functions you can instead do:
<programlisting>
BEGIN { strict->import(); }
--- 298,305 ----
use strict;
</programlisting>
in the function body. But this only works in <application>PL/PerlU</>
! functions, since the <literal>use</> triggers a <literal>require</>
! which is not a trusted operation. In
<application>PL/Perl</> functions you can instead do:
<programlisting>
BEGIN { strict->import(); }
diff --git a/src/pl/plperl/GNUmakefile b/src/pl/plperl/GNUmakefile
index a3c3495..8989b14 100644
*** a/src/pl/plperl/GNUmakefile
--- b/src/pl/plperl/GNUmakefile
*************** PSQLDIR = $(bindir)
*** 45,50 ****
--- 45,55 ----
include $(top_srcdir)/src/Makefile.shlib
+ plperl.o: perlchunks.h
+
+ perlchunks.h: plc_*.pl
+ $(PERL) text2macro.pl --strip='^(\#.*|\s*)$$' plc_*.pl > perlchunks.htmp
+ mv perlchunks.htmp perlchunks.h
all: all-lib
*************** submake:
*** 65,71 ****
$(MAKE) -C $(top_builddir)/src/test/regress pg_regress$(X)
clean distclean maintainer-clean: clean-lib
! rm -f SPI.c $(OBJS)
rm -rf results
rm -f regression.diffs regression.out
--- 70,76 ----
$(MAKE) -C $(top_builddir)/src/test/regress pg_regress$(X)
clean distclean maintainer-clean: clean-lib
! rm -f SPI.c $(OBJS) perlchunks.htmp perlchunks.h
rm -rf results
rm -f regression.diffs regression.out
diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out
index c8a8fdb..e9f5324 100644
*** a/src/pl/plperl/expected/plperl.out
--- b/src/pl/plperl/expected/plperl.out
*************** $$ LANGUAGE plperl;
*** 555,557 ****
--- 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;
diff --git a/src/pl/plperl/plc_perlboot.pl b/src/pl/plperl/plc_perlboot.pl
index ...f4739df .
*** a/src/pl/plperl/plc_perlboot.pl
--- b/src/pl/plperl/plc_perlboot.pl
***************
*** 0 ****
--- 1,50 ----
+ SPI::bootstrap();
+ use vars qw(%_SHARED);
+
+ sub ::plperl_warn {
+ (my $msg = shift) =~ s/\(eval \d+\) //g;
+ &elog(&NOTICE, $msg);
+ }
+ $SIG{__WARN__} = \&::plperl_warn;
+
+ sub ::plperl_die {
+ (my $msg = shift) =~ s/\(eval \d+\) //g;
+ die $msg;
+ }
+ $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;
+ }
+
+ sub ::_plperl_to_pg_array {
+ my $arg = shift;
+ ref $arg eq 'ARRAY' || return $arg;
+ my $res = '';
+ my $first = 1;
+ foreach my $elem (@$arg) {
+ $res .= ', ' unless $first; $first = undef;
+ if (ref $elem) {
+ $res .= _plperl_to_pg_array($elem);
+ }
+ elsif (defined($elem)) {
+ my $str = qq($elem);
+ $str =~ s/([\"\\])/\\$1/g;
+ $res .= qq(\"$str\");
+ }
+ else {
+ $res .= 'NULL' ;
+ }
+ }
+ return qq({$res});
+ }
diff --git a/src/pl/plperl/plc_safe_bad.pl b/src/pl/plperl/plc_safe_bad.pl
index ...838ccc6 .
*** a/src/pl/plperl/plc_safe_bad.pl
--- b/src/pl/plperl/plc_safe_bad.pl
***************
*** 0 ****
--- 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') }]);
+ }
+
diff --git a/src/pl/plperl/plc_safe_ok.pl b/src/pl/plperl/plc_safe_ok.pl
index ...15c6297 .
*** a/src/pl/plperl/plc_safe_ok.pl
--- b/src/pl/plperl/plc_safe_ok.pl
***************
*** 0 ****
--- 1,33 ----
+ 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
+ &spi_prepare &spi_exec_prepared &spi_query_prepared &spi_freeplan
+ &_plperl_to_pg_array
+ &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED
+ ]);
+
+ # 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;
+ }
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index 4ed4f59..c6037d8 100644
*** a/src/pl/plperl/plperl.c
--- b/src/pl/plperl/plperl.c
***************
*** 43,48 ****
--- 43,51 ----
/* perl stuff */
#include "plperl.h"
+ /* string literal macros defining chunks of perl code */
+ #include "perlchunks.h"
+
PG_MODULE_MAGIC;
/**********************************************************************
*************** typedef enum
*** 125,133 ****
} 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;
--- 128,134 ----
*************** Datum plperl_call_handler(PG_FUNCTION_A
*** 147,153 ****
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);
--- 148,154 ----
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);
*************** static plperl_proc_desc *compile_plperl_
*** 156,166 ****
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);
--- 157,168 ----
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);
*************** _PG_init(void)
*** 226,323 ****
&hash_ctl,
HASH_ELEM);
! plperl_init_interp();
inited = true;
}
- /* Each of these macros must represent a single string literal */
-
- #define PERLBOOT \
- "SPI::bootstrap(); use vars qw(%_SHARED);" \
- "sub ::plperl_warn { my $msg = shift; " \
- " $msg =~ s/\\(eval \\d+\\) //g; &elog(&NOTICE, $msg); } " \
- "$SIG{__WARN__} = \\&::plperl_warn; " \
- "sub ::plperl_die { my $msg = shift; " \
- " $msg =~ s/\\(eval \\d+\\) //g; die $msg; } " \
- "$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; } " \
- "sub ::_plperl_to_pg_array {" \
- " my $arg = shift; ref $arg eq 'ARRAY' || return $arg; " \
- " my $res = ''; my $first = 1; " \
- " foreach my $elem (@$arg) " \
- " { " \
- " $res .= ', ' unless $first; $first = undef; " \
- " if (ref $elem) " \
- " { " \
- " $res .= _plperl_to_pg_array($elem); " \
- " } " \
- " elsif (defined($elem)) " \
- " { " \
- " my $str = qq($elem); " \
- " $str =~ s/([\"\\\\])/\\\\$1/g; " \
- " $res .= qq(\"$str\"); " \
- " } " \
- " else " \
- " { "\
- " $res .= 'NULL' ; " \
- " } "\
- " } " \
- " return qq({$res}); " \
- "} "
-
#define SAFE_MODULE \
"require Safe; $Safe::VERSION"
- /*
- * 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.
- */
-
- #define SAFE_OK \
- "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 &spi_exec_query &return_next " \
- "&spi_query &spi_fetchrow &spi_cursor_close " \
- "&spi_prepare &spi_exec_prepared &spi_query_prepared &spi_freeplan " \
- "&_plperl_to_pg_array " \
- "&DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED ]);" \
- "sub ::mksafefunc {" \
- " my $ret = $PLContainer->reval(qq[sub { $_[0] $_[1] }]); " \
- " $@ =~ s/\\(eval \\d+\\) //g if $@; return $ret; }" \
- "$PLContainer->permit(qw[require caller]); $PLContainer->reval('use strict;');" \
- "$PLContainer->deny(qw[require caller]); " \
- "sub ::mk_strict_safefunc {" \
- " my $ret = $PLContainer->reval(qq[sub { BEGIN { strict->import(); } $_[0] $_[1] }]); " \
- " $@ =~ s/\\(eval \\d+\\) //g if $@; return $ret; }"
-
- #define SAFE_BAD \
- "use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');" \
- "$PLContainer->permit_only(':default');" \
- "$PLContainer->share(qw[&elog &ERROR ]);" \
- "sub ::mksafefunc { return $PLContainer->reval(qq[sub { " \
- " elog(ERROR,'trusted Perl functions disabled - " \
- " please upgrade Perl Safe module to version 2.09 or later');}]); }" \
- "sub ::mk_strict_safefunc { return $PLContainer->reval(qq[sub { " \
- " 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')"
-
-
/********************************************************************
*
* We start out by creating a "held" interpreter that we can use in
--- 228,242 ----
&hash_ctl,
HASH_ELEM);
! plperl_held_interp = plperl_init_interp();
! interp_state = INTERP_HELD;
inited = true;
}
#define SAFE_MODULE \
"require Safe; $Safe::VERSION"
/********************************************************************
*
* We start out by creating a "held" interpreter that we can use in
*************** check_interp(bool trusted)
*** 347,352 ****
--- 266,273 ----
}
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) ||
*************** check_interp(bool trusted)
*** 361,382 ****
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");
}
}
--- 282,304 ----
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
}
}
*************** restore_context(bool old_context)
*** 396,406 ****
}
}
! static void
plperl_init_interp(void)
{
static char *embedding[3] = {
! "", "-e", PERLBOOT
};
int nargs = 3;
--- 318,331 ----
}
}
! static PerlInterpreter *
plperl_init_interp(void)
{
+ PerlInterpreter *plperl;
+ static int perl_sys_init_done;
+
static char *embedding[3] = {
! "", "-e", PLC_PERLBOOT
};
int nargs = 3;
*************** plperl_init_interp(void)
*** 457,487 ****
*/
#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
--- 382,405 ----
*/
#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
*************** plperl_init_interp(void)
*** 524,529 ****
--- 442,448 ----
}
#endif
+ return plperl;
}
*************** plperl_safe_init(void)
*** 545,555 ****
if (safe_version < 2.0899)
{
/* not safe, so disallow all trusted funcs */
! eval_pv(SAFE_BAD, FALSE);
}
else
{
! eval_pv(SAFE_OK, FALSE);
if (GetDatabaseEncoding() == PG_UTF8)
{
/*
--- 464,474 ----
if (safe_version < 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)
{
/*
*************** plperl_safe_init(void)
*** 557,591 ****
* 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;
}
/*
--- 476,504 ----
* 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);
}
}
}
/*
*************** plperl_validator(PG_FUNCTION_ARGS)
*** 970,989 ****
* 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);
--- 883,897 ----
* 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);
*************** plperl_create_sub(char *proname, char *s
*** 1017,1025 ****
elog(ERROR, "didn't get a return item from mksafefunc");
}
if (SvTRUE(ERRSV))
{
- (void) POPs;
PUTBACK;
FREETMPS;
LEAVE;
--- 925,934 ----
elog(ERROR, "didn't get a return item from mksafefunc");
}
+ subref = POPs;
+
if (SvTRUE(ERRSV))
{
PUTBACK;
FREETMPS;
LEAVE;
*************** plperl_create_sub(char *proname, char *s
*** 1028,1057 ****
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;
}
--- 937,961 ----
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;
}
*************** compile_plperl_function(Oid fn_oid, bool
*** 1731,1739 ****
check_interp(prodesc->lanpltrusted);
! prodesc->reference = plperl_create_sub(prodesc->proname,
! proc_source,
! prodesc->lanpltrusted);
restore_context(oldcontext);
--- 1635,1641 ----
check_interp(prodesc->lanpltrusted);
! plperl_create_sub(prodesc, proc_source);
restore_context(oldcontext);
diff --git a/src/pl/plperl/sql/plperl.sql b/src/pl/plperl/sql/plperl.sql
index df17834..292b1c0 100644
*** a/src/pl/plperl/sql/plperl.sql
--- b/src/pl/plperl/sql/plperl.sql
*************** CREATE OR REPLACE FUNCTION perl_spi_prep
*** 361,363 ****
--- 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;
diff --git a/src/pl/plperl/text2macro.pl b/src/pl/plperl/text2macro.pl
index ...1628e86 .
*** a/src/pl/plperl/text2macro.pl
--- b/src/pl/plperl/text2macro.pl
***************
*** 0 ****
--- 1,98 ----
+ =head1 NAME
+
+ text2macro.pl - convert text files into C string-literal macro definitions
+
+ =head1 SYNOPSIS
+
+ text2macro [options] file ... > output.h
+
+ Options:
+
+ --prefix=S - add prefix S to the names of the macros
+ --name=S - use S as the macro name (assumes only one file)
+ --strip=S - don't include lines that match perl regex S
+
+ =head1 DESCRIPTION
+
+ Reads one or more text files and outputs a corresponding series of C
+ pre-processor macro definitions. Each macro defines a string literal that
+ contains the contents of the corresponding text file. The basename of the text
+ file as capitalized and used as the name of the macro, along with an optional prefix.
+
+ =cut
+
+ use strict;
+ use warnings;
+
+ use Getopt::Long;
+
+ GetOptions(
+ 'prefix=s' => \my $opt_prefix,
+ 'name=s' => \my $opt_name,
+ 'strip=s' => \my $opt_strip,
+ 'selftest!' => sub { exit selftest() },
+ ) or exit 1;
+
+ die "No text files specified"
+ unless @ARGV;
+
+ print qq{
+ /*
+ * DO NOT EDIT - THIS FILE IS AUTOGENERATED - CHANGES WILL BE LOST
+ * Written by $0 from @ARGV
+ */
+ };
+
+ for my $src_file (@ARGV) {
+
+ (my $macro = $src_file) =~ s/ .*? (\w+) (?:\.\w+) $/$1/x;
+
+ open my $src_fh, $src_file # not 3-arg form
+ or die "Can't open $src_file: $!";
+
+ printf qq{#define %s%s \\\n},
+ $opt_prefix || '',
+ ($opt_name) ? $opt_name : uc $macro;
+ while (<$src_fh>) {
+ chomp;
+
+ next if $opt_strip and m/$opt_strip/o;
+
+ # escape the text to suite C string literal rules
+ s/\\/\\\\/g;
+ s/"/\\"/g;
+
+ printf qq{"%s\\n" \\\n}, $_;
+ }
+ print qq{""\n\n};
+ }
+
+ print "/* end */\n";
+
+ exit 0;
+
+
+ sub selftest {
+ my $tmp = "text2macro_tmp";
+ my $string = q{a '' '\\'' "" "\\"" "\\\\" "\\\\n" b};
+
+ open my $fh, ">$tmp.pl" or die;
+ print $fh $string;
+ close $fh;
+
+ system("perl $0 --name=X $tmp.pl > $tmp.c") == 0 or die;
+ open $fh, ">>$tmp.c";
+ print $fh "#include <stdio.h>\n";
+ print $fh "int main() { puts(X); return 0; }\n";
+ close $fh;
+ system("cat -n $tmp.c");
+
+ system("make $tmp") == 0 or die;
+ open $fh, "./$tmp |" or die;
+ my $result = <$fh>;
+ unlink <$tmp.*>;
+
+ warn "Test string: $string\n";
+ warn "Result : $result";
+ die "Failed!" if $result ne "$string\n";
+ }
--
Sent via pgsql-hackers mailing list (pgsql-hackers@postgresql.org)
To make changes to your subscription:
http://www.postgresql.org/mailpref/pgsql-hackers
