From a2b34b16bed5699aa3ba407d9a412df65f448323 Mon Sep 17 00:00:00 2001
From: Andrew Dunstan <andrew@dunslane.net>
Date: Sat, 9 Jan 2010 02:40:50 +0000
Subject: [PATCH] Tidy up and refactor plperl.c.
- 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.
- 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
- Simplifed plperl_safe_init() slightly
- Optimized pg_verifymbstr calls to avoid unneeded strlen()s.
Patch from Tim Bunce, with minor editing from me.
---
doc/src/sgml/plperl.sgml | 7 +-
src/pl/plperl/GNUmakefile | 9 +-
src/pl/plperl/plc_perlboot.pl | 50 ++++++
src/pl/plperl/plc_safe_bad.pl | 15 ++
src/pl/plperl/plc_safe_ok.pl | 33 ++++
src/pl/plperl/plperl.c | 291 +++++++++++-----------------------
src/pl/plperl/sql/plperl.sql | 1 +
src/pl/plperl/text2macro.pl | 98 ++++++++++++
8 files changed, 303 insertions(+), 201 deletions(-)
create mode 100644 src/pl/plperl/plc_perlboot.pl
create mode 100644 src/pl/plperl/plc_safe_bad.pl
create mode 100644 src/pl/plperl/plc_safe_ok.pl
create mode 100644 src/pl/plperl/text2macro.pl
diff --git a/doc/src/sgml/plperl.sgml b/doc/src/sgml/plperl.sgml
index 9211693d3d9..2db97aa9015 100644
--- a/doc/src/sgml/plperl.sgml
+++ b/doc/src/sgml/plperl.sgml
@@ -1,4 +1,4 @@
-<!-- $PostgreSQL: pgsql/doc/src/sgml/plperl.sgml,v 2.71 2009/11/29 03:02:27 tgl Exp $ -->
+<!-- $PostgreSQL: pgsql/doc/src/sgml/plperl.sgml,v 2.72 2010/01/09 02:40:50 adunstan Exp $ -->
<chapter id="plperl">
<title>PL/Perl - Perl Procedural Language</title>
@@ -14,7 +14,7 @@
<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>.
+ <ulink url="http://www.perl.org">Perl programming language</ulink>.
</para>
<para>
@@ -313,7 +313,8 @@ SELECT * FROM perl_set();
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
+ 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 1e27a5d8c26..8a30a62687d 100644
--- a/src/pl/plperl/GNUmakefile
+++ b/src/pl/plperl/GNUmakefile
@@ -1,5 +1,5 @@
# Makefile for PL/Perl
-# $PostgreSQL: pgsql/src/pl/plperl/GNUmakefile,v 1.37 2009/06/05 18:29:56 adunstan Exp $
+# $PostgreSQL: pgsql/src/pl/plperl/GNUmakefile,v 1.38 2010/01/09 02:40:50 adunstan Exp $
subdir = src/pl/plperl
top_builddir = ../../..
@@ -45,6 +45,11 @@ PSQLDIR = $(bindir)
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
@@ -65,7 +70,7 @@ submake:
$(MAKE) -C $(top_builddir)/src/test/regress pg_regress$(X)
clean distclean maintainer-clean: clean-lib
- rm -f SPI.c $(OBJS)
+ rm -f SPI.c $(OBJS) perlchunks.htmp perlchunks.h
rm -rf results
rm -f regression.diffs regression.out
diff --git a/src/pl/plperl/plc_perlboot.pl b/src/pl/plperl/plc_perlboot.pl
new file mode 100644
index 00000000000..d2d55184766
--- /dev/null
+++ b/src/pl/plperl/plc_perlboot.pl
@@ -0,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
new file mode 100644
index 00000000000..838ccc63af5
--- /dev/null
+++ b/src/pl/plperl/plc_safe_bad.pl
@@ -0,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
new file mode 100644
index 00000000000..73c5573ba89
--- /dev/null
+++ b/src/pl/plperl/plc_safe_ok.pl
@@ -0,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 f385b347ae8..1dd704ffd06 100644
--- a/src/pl/plperl/plperl.c
+++ b/src/pl/plperl/plperl.c
@@ -1,7 +1,7 @@
/**********************************************************************
* plperl.c - perl as a procedural language for PostgreSQL
*
- * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.158 2010/01/04 20:29:59 adunstan Exp $
+ * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.159 2010/01/09 02:40:50 adunstan Exp $
*
**********************************************************************/
@@ -43,6 +43,9 @@
/* perl stuff */
#include "plperl.h"
+/* string literal macros defining chunks of perl code */
+#include "perlchunks.h"
+
PG_MODULE_MAGIC;
/**********************************************************************
@@ -125,9 +128,7 @@ 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;
@@ -148,7 +149,7 @@ Datum plperl_inline_handler(PG_FUNCTION_ARGS);
Datum plperl_validator(PG_FUNCTION_ARGS);
void _PG_init(void);
-static void plperl_init_interp(void);
+static PerlInterpreter *plperl_init_interp(void);
static Datum plperl_func_handler(PG_FUNCTION_ARGS);
static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
@@ -157,16 +158,38 @@ 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 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 SV *plperl_create_sub(const char *proname, const char *s, bool trusted);
+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);
+/*
+ * Convert an SV to char * and verify the encoding via pg_verifymbstr()
+ */
+static inline char *
+sv2text_mbverified(SV *sv)
+{
+ char * val;
+ STRLEN len;
+
+ /* The value returned here might include an
+ * embedded nul byte, because perl allows such things.
+ * That's OK, because pg_verifymbstr will choke on it, If
+ * we just used strlen() instead of getting perl's idea of
+ * the length, whatever uses the "verified" value might
+ * get something quite weird.
+ */
+ val = SvPV(sv, len);
+ pg_verifymbstr(val, len, false);
+ return val;
+}
+
/*
* This routine is a crock, and so is everyplace that calls it. The problem
* is that the cached form of plperl functions/queries is allocated permanently
@@ -228,98 +251,15 @@ _PG_init(void)
&hash_ctl,
HASH_ELEM);
- plperl_init_interp();
+ plperl_held_interp = plperl_init_interp();
+ interp_state = INTERP_HELD;
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
@@ -349,6 +289,8 @@ check_interp(bool trusted)
}
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) ||
@@ -363,22 +305,23 @@ check_interp(bool trusted)
trusted_context = trusted;
}
}
- else if (can_run_two)
+ else
{
- PERL_SET_CONTEXT(plperl_held_interp);
- plperl_init_interp();
+#ifdef MULTIPLICITY
+ PerlInterpreter *plperl = plperl_init_interp();
if (trusted)
- plperl_trusted_interp = plperl_held_interp;
+ plperl_trusted_interp = plperl;
else
- plperl_untrusted_interp = plperl_held_interp;
- interp_state = INTERP_BOTH;
+ plperl_untrusted_interp = plperl;
plperl_held_interp = NULL;
trusted_context = trusted;
- }
- else
- {
+ 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
}
}
@@ -398,11 +341,14 @@ restore_context(bool old_context)
}
}
-static void
+static PerlInterpreter *
plperl_init_interp(void)
{
+ PerlInterpreter *plperl;
+ static int perl_sys_init_done;
+
static char *embedding[3] = {
- "", "-e", PERLBOOT
+ "", "-e", PLC_PERLBOOT
};
int nargs = 3;
@@ -459,31 +405,26 @@ 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)
+ if (!perl_sys_init_done)
{
char *dummy_env[1] = {NULL};
PERL_SYS_INIT3(&nargs, (char ***) &embedding, (char ***) &dummy_env);
+ perl_sys_init_done = 1;
+ /* quiet warning if PERL_SYS_INIT3 doesn't use the third argument */
+ dummy_env[0] = NULL;
}
#endif
- plperl_held_interp = perl_alloc();
- if (!plperl_held_interp)
+ plperl = perl_alloc();
+ if (!plperl)
elog(ERROR, "could not allocate Perl interpreter");
- perl_construct(plperl_held_interp);
- perl_parse(plperl_held_interp, plperl_init_shared_libs,
+ PERL_SET_CONTEXT(plperl);
+ perl_construct(plperl);
+ perl_parse(plperl, 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;
- }
+ perl_run(plperl);
#ifdef WIN32
@@ -526,32 +467,30 @@ plperl_init_interp(void)
}
#endif
+ return plperl;
}
static void
plperl_safe_init(void)
{
- SV *res;
- double safe_version;
-
- res = eval_pv(SAFE_MODULE, FALSE); /* TRUE = croak if failure */
+ SV *safe_version_sv;
- safe_version = SvNV(res);
+ 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
+ * We actually want to reject Safe version < 2.09, but it's risky to
* assume that floating-point comparisons are exact, so use a slightly
* smaller comparison value.
*/
- if (safe_version < 2.0899)
+ if (SvNV(safe_version_sv) < 2.0899)
{
/* not safe, so disallow all trusted funcs */
- eval_pv(SAFE_BAD, FALSE);
+ eval_pv(PLC_SAFE_BAD, FALSE);
}
else
{
- eval_pv(SAFE_OK, FALSE);
+ eval_pv(PLC_SAFE_OK, FALSE);
if (GetDatabaseEncoding() == PG_UTF8)
{
/*
@@ -559,35 +498,29 @@ 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.
+ * See http://rt.perl.org/rt3/Ticket/Display.html?id=47576
*/
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.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 */
- ret = plperl_call_perl_func(&desc, &fcinfo);
+ (void) plperl_call_perl_func(&desc, &fcinfo);
}
}
-
- plperl_safe_init_done = true;
}
/*
@@ -631,11 +564,7 @@ plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
key)));
if (SvOK(val))
{
- char * aval;
-
- aval = SvPV_nolen(val);
- pg_verifymbstr(aval, strlen(aval), false);
- values[attn - 1] = aval;
+ values[attn - 1] = sv2text_mbverified(val);
}
}
hv_iterinit(perlhash);
@@ -835,12 +764,8 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
atttypmod = tupdesc->attrs[attn - 1]->atttypmod;
if (SvOK(val))
{
- char * aval;
-
- aval = SvPV_nolen(val);
- pg_verifymbstr(aval,strlen(aval), false);
modvalues[slotsused] = InputFunctionCall(&finfo,
- aval,
+ sv2text_mbverified(val),
typioparam,
atttypmod);
modnulls[slotsused] = ' ';
@@ -970,9 +895,7 @@ plperl_inline_handler(PG_FUNCTION_ARGS)
check_interp(desc.lanpltrusted);
- desc.reference = plperl_create_sub(desc.proname,
- codeblock->source_text,
- 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");
@@ -1080,20 +1003,15 @@ 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(const char *proname, const char *s, bool trusted)
+static void
+plperl_create_sub(plperl_proc_desc *prodesc, char *s)
{
dSP;
+ bool trusted = prodesc->lanpltrusted;
SV *subref;
int count;
char *compile_sub;
- if (trusted && !plperl_safe_init_done)
- {
- plperl_safe_init();
- SPAGAIN;
- }
-
ENTER;
SAVETMPS;
PUSHMARK(SP);
@@ -1127,9 +1045,10 @@ plperl_create_sub(const char *proname, const char *s, bool trusted)
elog(ERROR, "didn't get a return item from mksafefunc");
}
+ subref = POPs;
+
if (SvTRUE(ERRSV))
{
- (void) POPs;
PUTBACK;
FREETMPS;
LEAVE;
@@ -1138,30 +1057,25 @@ plperl_create_sub(const char *proname, const char *s, bool trusted)
errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV)))));
}
- /*
- * 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");
}
+ /*
+ * need to make a copy of the return, it comes off the stack as a
+ * temporary.
+ */
+ prodesc->reference = newSVsv(subref);
+
PUTBACK;
FREETMPS;
LEAVE;
- return subref;
+ return;
}
@@ -1467,7 +1381,6 @@ plperl_func_handler(PG_FUNCTION_ARGS)
else
{
/* Return a perl string converted to a Datum */
- char *val;
if (prodesc->fn_retisarray && SvROK(perlret) &&
SvTYPE(SvRV(perlret)) == SVt_PVAV)
@@ -1477,9 +1390,8 @@ plperl_func_handler(PG_FUNCTION_ARGS)
perlret = array_ret;
}
- val = SvPV_nolen(perlret);
- pg_verifymbstr(val, strlen(val), false);
- retval = InputFunctionCall(&prodesc->result_in_func, val,
+ retval = InputFunctionCall(&prodesc->result_in_func,
+ sv2text_mbverified(perlret),
prodesc->result_typioparam, -1);
}
@@ -1843,9 +1755,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
check_interp(prodesc->lanpltrusted);
- prodesc->reference = plperl_create_sub(prodesc->proname,
- proc_source,
- prodesc->lanpltrusted);
+ plperl_create_sub(prodesc, proc_source);
restore_context(oldcontext);
@@ -2126,17 +2036,14 @@ plperl_return_next(SV *sv)
if (SvOK(sv))
{
- char *val;
-
if (prodesc->fn_retisarray && SvROK(sv) &&
SvTYPE(SvRV(sv)) == SVt_PVAV)
{
sv = plperl_convert_to_pg_array(sv);
}
- val = SvPV_nolen(sv);
- pg_verifymbstr(val, strlen(val), false);
- ret = InputFunctionCall(&prodesc->result_in_func, val,
+ ret = InputFunctionCall(&prodesc->result_in_func,
+ sv2text_mbverified(sv),
prodesc->result_typioparam, -1);
isNull = false;
}
@@ -2526,12 +2433,8 @@ plperl_spi_exec_prepared(char *query, HV *attr, int argc, SV **argv)
{
if (SvOK(argv[i]))
{
- char *val;
-
- val = SvPV_nolen(argv[i]);
- pg_verifymbstr(val, strlen(val), false);
argvalues[i] = InputFunctionCall(&qdesc->arginfuncs[i],
- val,
+ sv2text_mbverified(argv[i]),
qdesc->argtypioparams[i],
-1);
nulls[i] = ' ';
@@ -2661,12 +2564,8 @@ plperl_spi_query_prepared(char *query, int argc, SV **argv)
{
if (SvOK(argv[i]))
{
- char *val;
-
- val = SvPV_nolen(argv[i]);
- pg_verifymbstr(val, strlen(val), false);
argvalues[i] = InputFunctionCall(&qdesc->arginfuncs[i],
- val,
+ sv2text_mbverified(argv[i]),
qdesc->argtypioparams[i],
-1);
nulls[i] = ' ';
diff --git a/src/pl/plperl/sql/plperl.sql b/src/pl/plperl/sql/plperl.sql
index f12e2f72516..08e5371083d 100644
--- a/src/pl/plperl/sql/plperl.sql
+++ b/src/pl/plperl/sql/plperl.sql
@@ -369,3 +369,4 @@ $$ LANGUAGE plperl;
-- check that restricted operations are rejected in a plperl DO block
DO $$ use Config; $$ LANGUAGE plperl;
+
diff --git a/src/pl/plperl/text2macro.pl b/src/pl/plperl/text2macro.pl
new file mode 100644
index 00000000000..1628e8688d8
--- /dev/null
+++ b/src/pl/plperl/text2macro.pl
@@ -0,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";
+}
--
GitLab