Building on my earlier plperl refactoring patch, here's a draft of my
first plperl feature patch.
Significant changes in this patch:
- New GUC plperl.on_perl_init='...perl...' for admin use.
- New GUC plperl.on_trusted_init='...perl...' for plperl user use.
- New GUC plperl.on_untrusted_init='...perl...' for plperlu user use.
- END blocks now run at backend exit (fixes bug #5066).
- Stored procedure subs are now given names ($name__$oid).
- More error checking and reporting.
- Warnings no longer have an extra newline in the NOTICE text.
- Various minor optimizations like pre-growing data structures.
I'm working on adding tests and documentation now, meanwhile I'd very
much appreciate any feedback on the patch.
Tim.
p.s. Once this patch is complete I plan to work on patches that:
- add quote_literal and quote_identifier functions in C.
- generalize the Safe setup code to enable more control.
- formalize namespace usage, moving things out of main::
- add a way to perform inter-sub calling (at least for simple cases).
- possibly rewrite _plperl_to_pg_array in C.
diff --git a/src/pl/plperl/GNUmakefile b/src/pl/plperl/GNUmakefile
index 8989b14..5a9ad2f 100644
*** a/src/pl/plperl/GNUmakefile
--- b/src/pl/plperl/GNUmakefile
*************** include $(top_srcdir)/src/Makefile.shlib
*** 48,54 ****
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
--- 48,54 ----
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
diff --git a/src/pl/plperl/expected/plperl_elog.out b/src/pl/plperl/expected/plperl_elog.out
index 1791d3c..89497e3 100644
*** a/src/pl/plperl/expected/plperl_elog.out
--- b/src/pl/plperl/expected/plperl_elog.out
*************** create or replace function perl_warn(tex
*** 21,27 ****
$$;
select perl_warn('implicit elog via warn');
NOTICE: implicit elog via warn at line 4.
-
CONTEXT: PL/Perl function "perl_warn"
perl_warn
-----------
--- 21,26 ----
diff --git a/src/pl/plperl/plc_perlboot.pl b/src/pl/plperl/plc_perlboot.pl
index d2d5518..b9c6878 100644
*** a/src/pl/plperl/plc_perlboot.pl
--- b/src/pl/plperl/plc_perlboot.pl
***************
*** 1,8 ****
--- 1,12 ----
SPI::bootstrap();
+
+ use strict;
+ use warnings;
use vars qw(%_SHARED);
sub ::plperl_warn {
(my $msg = shift) =~ s/\(eval \d+\) //g;
+ chomp $msg;
&elog(&NOTICE, $msg);
}
$SIG{__WARN__} = \&::plperl_warn;
*************** sub ::plperl_die {
*** 13,28 ****
}
$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;
}
--- 17,44 ----
}
$SIG{__DIE__} = \&::plperl_die;
! sub ::mkfuncsrc {
! my ($name, $imports, $prolog, $src) = @_;
! my $BEGIN = join "\n", map {
! my $names = $imports->{$_} || [];
! "$_->import(qw(@$names));"
! } keys %$imports;
! $BEGIN &&= "BEGIN { $BEGIN }";
! $name =~ s/\\/\\\\/g;
! $name =~ s/::|'/_/g; # avoid package delimiters
!
! my $funcsrc;
! $funcsrc .= qq[ undef *{'$name'}; *{'$name'} = sub { $BEGIN $prolog $src } ];
! #warn "plperl mkfuncsrc: $funcsrc\n";
! return $funcsrc;
! }
!
! # see also mksafefunc() in plc_safe_ok.pl
! sub ::mkunsafefunc {
! no strict; # default to no strict for the eval
! my $ret = eval(::mkfuncsrc(@_));
$@ =~ s/\(eval \d+\) //g if $@;
return $ret;
}
*************** sub ::_plperl_to_pg_array {
*** 39,46 ****
}
elsif (defined($elem)) {
my $str = qq($elem);
! $str =~ s/([\"\\])/\\$1/g;
! $res .= qq(\"$str\");
}
else {
$res .= 'NULL' ;
--- 55,62 ----
}
elsif (defined($elem)) {
my $str = qq($elem);
! $str =~ s/(["\\])/\\$1/g;
! $res .= qq("$str");
}
else {
$res .= 'NULL' ;
diff --git a/src/pl/plperl/plc_safe_bad.pl b/src/pl/plperl/plc_safe_bad.pl
index 838ccc6..da47341 100644
*** a/src/pl/plperl/plc_safe_bad.pl
--- b/src/pl/plperl/plc_safe_bad.pl
***************
*** 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') }]);
}
-
--- 1,13 ----
! # Minimal version of plc_safe_ok.pl
! # Executed if Safe is too old or doesn't load for any reason
my $msg = 'trusted Perl functions disabled - please upgrade Perl Safe module to version 2.09 or later';
! sub mksafefunc {
! my ($name, $pragma, $prolog, $src) = @_;
! # replace $src with code to generate an error
! $src = qq{ ::elog(::ERROR,"$msg\n") };
! my $ret = eval(::mkfuncsrc($name, $pragma, '', $src));
! $@ =~ s/\(eval \d+\) //g if $@;
! return $ret;
}
diff --git a/src/pl/plperl/plc_safe_ok.pl b/src/pl/plperl/plc_safe_ok.pl
index 73c5573..cc8f433 100644
*** a/src/pl/plperl/plc_safe_ok.pl
--- b/src/pl/plperl/plc_safe_ok.pl
***************
*** 1,3 ****
--- 1,5 ----
+ use strict;
+ use warnings;
use vars qw($PLContainer);
$PLContainer = new Safe('PLPerl');
*************** $PLContainer->share(qw[&elog &return_nex
*** 17,33 ****
# 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;
}
--- 19,34 ----
# 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('require strict;') or die $@;
$PLContainer->deny(qw[require caller]);
! # called directly for plperl.on_trusted_init
! sub ::safe_eval {
! my $ret = $PLContainer->reval(shift);
$@ =~ s/\(eval \d+\) //g if $@;
return $ret;
}
! sub ::mksafefunc {
! return ::safe_eval(::mkfuncsrc(@_));
}
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index f919f04..812d8ae 100644
*** a/src/pl/plperl/plperl.c
--- b/src/pl/plperl/plperl.c
*************** static HTAB *plperl_proc_hash = NULL;
*** 137,142 ****
--- 137,145 ----
static HTAB *plperl_query_hash = NULL;
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;
/* this is saved and restored by plperl_call_handler */
static plperl_call_data *current_call_data = NULL;
*************** Datum plperl_inline_handler(PG_FUNCTION
*** 149,155 ****
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);
--- 152,160 ----
Datum plperl_validator(PG_FUNCTION_ARGS);
void _PG_init(void);
! static PerlInterpreter *plperl_create_interp(void);
! static void plperl_destroy_interp(PerlInterpreter **);
! static void plperl_fini(void);
static Datum plperl_func_handler(PG_FUNCTION_ARGS);
static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
*************** static plperl_proc_desc *compile_plperl_
*** 159,173 ****
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);
static void plperl_inline_callback(void *arg);
/*
* This routine is a crock, and so is everyplace that calls it. The problem
--- 164,180 ----
static SV *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc);
static void plperl_init_shared_libs(pTHX);
static void plperl_safe_init(void);
+ static SV *plperl_eval_pv(const char *src, const char *errfmt);
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, Oid fn_oid);
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);
static void plperl_inline_callback(void *arg);
+ static char *strip_trailing_ws(const char *msg);
/*
* This routine is a crock, and so is everyplace that calls it. The problem
*************** _PG_init(void)
*** 212,217 ****
--- 219,248 ----
PGC_USERSET, 0,
NULL, NULL);
+ DefineCustomStringVariable("plperl.on_perl_init",
+ gettext_noop("Perl code to execute when interpreter is initialized."),
+ NULL,
+ &plperl_on_perl_init,
+ NULL,
+ PGC_SUSET, 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));
*************** _PG_init(void)
*** 230,241 ****
&hash_ctl,
HASH_ELEM);
! plperl_held_interp = plperl_init_interp();
interp_state = INTERP_HELD;
inited = true;
}
#define SAFE_MODULE \
"require Safe; $Safe::VERSION"
--- 261,288 ----
&hash_ctl,
HASH_ELEM);
! plperl_held_interp = plperl_create_interp();
interp_state = INTERP_HELD;
+ atexit(plperl_fini);
+
inited = true;
}
+
+ /*
+ * Cleanup perl interpreters, including running END blocks.
+ * Does not fully undo the actions of _PG_init() nor make it callable again.
+ */
+ static void
+ plperl_fini(void)
+ {
+ plperl_destroy_interp(&plperl_trusted_interp);
+ plperl_destroy_interp(&plperl_untrusted_interp);
+ plperl_destroy_interp(&plperl_held_interp);
+ }
+
+
#define SAFE_MODULE \
"require Safe; $Safe::VERSION"
*************** _PG_init(void)
*** 246,259 ****
* assign that interpreter if it is available to either the trusted or
* untrusted interpreter. If it has already been assigned, and we need to
* create the other interpreter, we do that if we can, or error out.
- * We detect if it is safe to run two interpreters during the setup of the
- * dummy interpreter.
*/
static void
check_interp(bool trusted)
{
if (interp_state == INTERP_HELD)
{
if (trusted)
--- 293,325 ----
* assign that interpreter if it is available to either the trusted or
* untrusted interpreter. If it has already been assigned, and we need to
* create the other interpreter, we do that if we can, or error out.
*/
static void
check_interp(bool trusted)
{
+ /*
+ * handle simple cases
+ */
+ if (interp_state == INTERP_BOTH ||
+ ( trusted && interp_state == INTERP_TRUSTED) ||
+ (!trusted && interp_state == INTERP_UNTRUSTED))
+ {
+ if (trusted_context != trusted)
+ {
+ if (trusted)
+ PERL_SET_CONTEXT(plperl_trusted_interp);
+ else
+ PERL_SET_CONTEXT(plperl_untrusted_interp);
+ trusted_context = trusted;
+ }
+ return;
+ }
+
+ /*
+ * adopt held interp if free, else create new one if possible
+ */
if (interp_state == INTERP_HELD)
{
if (trusted)
*************** check_interp(bool trusted)
*** 266,307 ****
plperl_untrusted_interp = plperl_held_interp;
interp_state = INTERP_UNTRUSTED;
}
- 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) ||
- (!trusted && interp_state == INTERP_UNTRUSTED))
- {
- if (trusted_context != trusted)
- {
- if (trusted)
- PERL_SET_CONTEXT(plperl_trusted_interp);
- else
- PERL_SET_CONTEXT(plperl_untrusted_interp);
- 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
}
}
/*
--- 332,369 ----
plperl_untrusted_interp = plperl_held_interp;
interp_state = INTERP_UNTRUSTED;
}
}
else
{
#ifdef MULTIPLICITY
! PerlInterpreter *plperl = plperl_create_interp();
if (trusted)
plperl_trusted_interp = plperl;
else
plperl_untrusted_interp = plperl;
interp_state = INTERP_BOTH;
#else
elog(ERROR,
"cannot allocate second Perl interpreter on this platform");
#endif
}
+ plperl_held_interp = NULL;
+ trusted_context = trusted;
+
+ /*
+ * initialization - done last to ensure a clean state
+ * (and thereby avoid recursion via plperl_safe_init)
+ */
+ if (trusted)
+ plperl_safe_init();
+ else
+ {
+ if (plperl_on_untrusted_init && *plperl_on_untrusted_init)
+ {
+ plperl_eval_pv(plperl_on_untrusted_init,
+ "Error executing plperl.on_untrusted_init: %s");
+ }
+ }
}
/*
*************** restore_context(bool old_context)
*** 321,336 ****
}
static PerlInterpreter *
! plperl_init_interp(void)
{
PerlInterpreter *plperl;
static int perl_sys_init_done;
! static char *embedding[3] = {
"", "-e", PLC_PERLBOOT
};
int nargs = 3;
#ifdef WIN32
/*
--- 383,408 ----
}
static PerlInterpreter *
! plperl_create_interp(void)
{
PerlInterpreter *plperl;
static int perl_sys_init_done;
! /*
! * The perl interpreter configuration can be altered via the environment variables
! * like PERL5LIB, PERL5OPT, PERL_UNICODE etc., documented in the perlrun documentation.
! */
! static char *embedding[3+2] = {
"", "-e", PLC_PERLBOOT
};
int nargs = 3;
+ if (plperl_on_perl_init)
+ {
+ embedding[nargs++] = "-e";
+ embedding[nargs++] = plperl_on_perl_init;
+ }
+
#ifdef WIN32
/*
*************** plperl_init_interp(void)
*** 399,404 ****
--- 471,478 ----
PERL_SET_CONTEXT(plperl);
perl_construct(plperl);
+ PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
+
perl_parse(plperl, plperl_init_shared_libs,
nargs, embedding, NULL);
perl_run(plperl);
*************** plperl_init_interp(void)
*** 449,459 ****
static void
plperl_safe_init(void)
{
SV *safe_version_sv;
! safe_version_sv = eval_pv(SAFE_MODULE, FALSE); /* TRUE = croak if failure */
/*
* We actually want to reject Safe version < 2.09, but it's risky to
--- 523,545 ----
static void
+ plperl_destroy_interp(PerlInterpreter **interp)
+ {
+ if (interp && *interp)
+ {
+ perl_destruct(*interp);
+ perl_free(*interp);
+ *interp = NULL;
+ }
+ }
+
+
+ static void
plperl_safe_init(void)
{
SV *safe_version_sv;
! safe_version_sv = plperl_eval_pv(SAFE_MODULE, "%s");
/*
* We actually want to reject Safe version < 2.09, but it's risky to
*************** plperl_safe_init(void)
*** 463,473 ****
if (SvNV(safe_version_sv) < 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)
{
/*
--- 549,560 ----
if (SvNV(safe_version_sv) < 2.0899)
{
/* not safe, so disallow all trusted funcs */
! plperl_eval_pv(PLC_SAFE_BAD, "Error initializing stub plperl: %s");
}
else
{
! plperl_eval_pv(PLC_SAFE_OK, "Error initializing plperl: %s");
!
if (GetDatabaseEncoding() == PG_UTF8)
{
/*
*************** plperl_safe_init(void)
*** 488,494 ****
/* 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");
--- 575,581 ----
/* 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");
*************** plperl_safe_init(void)
*** 497,506 ****
--- 584,626 ----
/* and make the call */
(void) plperl_call_perl_func(&desc, &fcinfo);
}
+
+ 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);
+
+ if (SvTRUE(ERRSV))
+ {
+ elog(ERROR, "Error executing plperl.on_trusted_init: %s",
+ strip_trailing_ws(SvPV_nolen(ERRSV)));
+ }
+ }
}
}
/*
+ * wrapper for eval_pv that calls elog on error
+ */
+ static SV *
+ plperl_eval_pv(const char *src, const char *errfmt)
+ {
+ SV *sv;
+
+ sv = eval_pv(src, (errfmt) ? FALSE : TRUE); /* croak if error and errfmt is NULL */
+ if (SvTRUE(ERRSV))
+ {
+ elog(ERROR, errfmt, strip_trailing_ws(SvPV_nolen(ERRSV)));
+ }
+ return sv;
+ }
+
+ /*
* Perl likes to put a newline after its error messages; clean up such
*/
static char *
*************** plperl_convert_to_pg_array(SV *src)
*** 557,563 ****
{
SV *rv;
int count;
-
dSP;
PUSHMARK(SP);
--- 677,682 ----
*************** plperl_trigger_build_args(FunctionCallIn
*** 594,599 ****
--- 713,719 ----
HV *hv;
hv = newHV();
+ hv_ksplit(hv, 12); /* pre-grow the hash */
tdata = (TriggerData *) fcinfo->context;
tupdesc = tdata->tg_relation->rd_att;
*************** plperl_trigger_build_args(FunctionCallIn
*** 648,653 ****
--- 768,774 ----
{
AV *av = newAV();
+ av_extend(av, tdata->tg_trigger->tgnargs);
for (i = 0; i < tdata->tg_trigger->tgnargs; i++)
av_push(av, newSVstring(tdata->tg_trigger->tgargs[i]));
hv_store_string(hv, "args", newRV_noinc((SV *) av));
*************** plperl_inline_handler(PG_FUNCTION_ARGS)
*** 870,876 ****
check_interp(desc.lanpltrusted);
! plperl_create_sub(&desc, codeblock->source_text);
if (!desc.reference) /* can this happen? */
elog(ERROR, "could not create internal procedure for anonymous code block");
--- 991,997 ----
check_interp(desc.lanpltrusted);
! plperl_create_sub(&desc, codeblock->source_text, 0);
if (!desc.reference) /* can this happen? */
elog(ERROR, "could not create internal procedure for anonymous code block");
*************** plperl_validator(PG_FUNCTION_ARGS)
*** 975,997 ****
/*
! * 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);
! XPUSHs(sv_2mortal(newSVstring("our $_TD; local $_TD=$_[0]; shift;")));
! XPUSHs(sv_2mortal(newSVstring(s)));
PUTBACK;
/*
--- 1096,1128 ----
/*
! * Uses mksafefunc/mkunsafefunc to create a subroutine whose text is
! * supplied in s, and returns a reference to it
*/
static void
! plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid)
{
dSP;
bool trusted = prodesc->lanpltrusted;
! char subname[NAMEDATALEN+40];
! HV *pragma_hv = newHV();
! SV *subref = NULL;
! int count;
! char *compile_sub;
!
! sprintf(subname, "%s__%u", prodesc->proname, fn_oid);
!
! if (plperl_use_strict)
! hv_store_string(pragma_hv, "strict", (SV*)newAV());
ENTER;
SAVETMPS;
PUSHMARK(SP);
! EXTEND(SP,4);
! PUSHs(sv_2mortal(newSVstring(subname)));
! PUSHs(sv_2mortal(newRV_noinc((SV*)pragma_hv)));
! PUSHs(sv_2mortal(newSVstring("our $_TD; local $_TD=shift;")));
! PUSHs(sv_2mortal(newSVstring(s)));
PUTBACK;
/*
*************** plperl_create_sub(plperl_proc_desc *prod
*** 999,1055 ****
* errors properly. Perhaps it's because there's another level of eval
* inside mksafefunc?
*/
!
! if (trusted && plperl_use_strict)
! compile_sub = "::mk_strict_safefunc";
! else if (plperl_use_strict)
! compile_sub = "::mk_strict_unsafefunc";
! else if (trusted)
! compile_sub = "::mksafefunc";
! else
! compile_sub = "::mkunsafefunc";
!
count = perl_call_pv(compile_sub, G_SCALAR | G_EVAL | G_KEEPERR);
SPAGAIN;
! if (count != 1)
! {
! PUTBACK;
! FREETMPS;
! LEAVE;
! elog(ERROR, "didn't get a return item from mksafefunc");
}
! subref = POPs;
if (SvTRUE(ERRSV))
{
- PUTBACK;
- FREETMPS;
- LEAVE;
ereport(ERROR,
(errcode(ERRCODE_SYNTAX_ERROR),
errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV)))));
}
! 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;
}
--- 1130,1165 ----
* errors properly. Perhaps it's because there's another level of eval
* inside mksafefunc?
*/
! compile_sub = (trusted) ? "::mksafefunc" : "::mkunsafefunc";
count = perl_call_pv(compile_sub, G_SCALAR | G_EVAL | G_KEEPERR);
SPAGAIN;
! if (count == 1) {
! GV *sub_glob = (GV*)POPs;
! if (sub_glob && SvTYPE(sub_glob) == SVt_PVGV)
! subref = newRV((SV*)GvCVu((GV*)sub_glob));
}
! PUTBACK;
! FREETMPS;
! LEAVE;
if (SvTRUE(ERRSV))
{
ereport(ERROR,
(errcode(ERRCODE_SYNTAX_ERROR),
errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV)))));
}
! if (!subref)
{
! ereport(ERROR,
! (errcode(ERRCODE_INTERNAL_ERROR),
! errmsg("didn't get a GLOB from compiling %s via %s", prodesc->proname, compile_sub)));
}
prodesc->reference = newSVsv(subref);
return;
}
*************** plperl_call_perl_func(plperl_proc_desc *
*** 1089,1101 ****
SAVETMPS;
PUSHMARK(SP);
! XPUSHs(&PL_sv_undef); /* no trigger data */
for (i = 0; i < desc->nargs; i++)
{
if (fcinfo->argnull[i])
! XPUSHs(&PL_sv_undef);
else if (desc->arg_is_rowtype[i])
{
HeapTupleHeader td;
--- 1199,1212 ----
SAVETMPS;
PUSHMARK(SP);
+ EXTEND(sp, 1 + desc->nargs);
! PUSHs(&PL_sv_undef); /* no trigger data */
for (i = 0; i < desc->nargs; i++)
{
if (fcinfo->argnull[i])
! PUSHs(&PL_sv_undef);
else if (desc->arg_is_rowtype[i])
{
HeapTupleHeader td;
*************** plperl_call_perl_func(plperl_proc_desc *
*** 1115,1121 ****
tmptup.t_data = td;
hashref = plperl_hash_from_tuple(&tmptup, tupdesc);
! XPUSHs(sv_2mortal(hashref));
ReleaseTupleDesc(tupdesc);
}
else
--- 1226,1232 ----
tmptup.t_data = td;
hashref = plperl_hash_from_tuple(&tmptup, tupdesc);
! PUSHs(sv_2mortal(hashref));
ReleaseTupleDesc(tupdesc);
}
else
*************** plperl_call_perl_func(plperl_proc_desc *
*** 1125,1131 ****
tmp = OutputFunctionCall(&(desc->arg_out_func[i]),
fcinfo->arg[i]);
sv = newSVstring(tmp);
! XPUSHs(sv_2mortal(sv));
pfree(tmp);
}
}
--- 1236,1242 ----
tmp = OutputFunctionCall(&(desc->arg_out_func[i]),
fcinfo->arg[i]);
sv = newSVstring(tmp);
! PUSHs(sv_2mortal(sv));
pfree(tmp);
}
}
*************** compile_plperl_function(Oid fn_oid, bool
*** 1732,1738 ****
check_interp(prodesc->lanpltrusted);
! plperl_create_sub(prodesc, proc_source);
restore_context(oldcontext);
--- 1843,1849 ----
check_interp(prodesc->lanpltrusted);
! plperl_create_sub(prodesc, proc_source, fn_oid);
restore_context(oldcontext);
*************** plperl_hash_from_tuple(HeapTuple tuple,
*** 1768,1773 ****
--- 1879,1885 ----
int i;
hv = newHV();
+ hv_ksplit(hv, tupdesc->natts); /* pre-grow the hash */
for (i = 0; i < tupdesc->natts; i++)
{
*************** plperl_spi_execute_fetch_result(SPITuple
*** 1895,1900 ****
--- 2007,2013 ----
int i;
rows = newAV();
+ av_extend(rows, processed);
for (i = 0; i < processed; i++)
{
row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
--
Sent via pgsql-hackers mailing list (pgsql-hackers@postgresql.org)
To make changes to your subscription:
http://www.postgresql.org/mailpref/pgsql-hackers
