/**********************************************************************
* plperl.c - perl as a procedural language for PostgreSQL
*
- * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.157 2009/12/31 19:41:37 tgl Exp $
+ * src/pl/plperl/plperl.c
*
**********************************************************************/
#include "miscadmin.h"
#include "nodes/makefuncs.h"
#include "parser/parse_type.h"
+#include "storage/ipc.h"
#include "utils/builtins.h"
#include "utils/fmgroids.h"
#include "utils/guc.h"
/* perl stuff */
#include "plperl.h"
+/* string literal macros defining chunks of perl code */
+#include "perlchunks.h"
+/* defines PLPERL_SET_OPMASK */
+#include "plperl_opmask.h"
+
PG_MODULE_MAGIC;
/**********************************************************************
} 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;
+static OP *(*pp_require_orig) (pTHX) = NULL;
+static OP *pp_require_safe(pTHX);
static bool trusted_context;
static HTAB *plperl_proc_hash = NULL;
static HTAB *plperl_query_hash = NULL;
static bool plperl_use_strict = false;
+static char *plperl_on_init = NULL;
+static char *plperl_on_plperl_init = NULL;
+static char *plperl_on_plperlu_init = NULL;
+static bool plperl_ending = false;
+static char plperl_opmask[MAXO];
+static void set_interp_require(void);
/* this is saved and restored by plperl_call_handler */
static plperl_call_data *current_call_data = NULL;
Datum plperl_validator(PG_FUNCTION_ARGS);
void _PG_init(void);
-static void plperl_init_interp(void);
+static PerlInterpreter *plperl_init_interp(void);
+static void plperl_destroy_interp(PerlInterpreter **);
+static void plperl_fini(int code, Datum arg);
static Datum plperl_func_handler(PG_FUNCTION_ARGS);
static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
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);
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, 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);
+static OP *pp_require_safe(pTHX);
+static int restore_context(bool);
+
+#ifdef WIN32
+static char *setlocale_perl(int category, char *locale);
+#endif
+
+/*
+ * 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
void
_PG_init(void)
{
- /* Be sure we do initialization only once (should be redundant now) */
+ /*
+ * Be sure we do initialization only once.
+ *
+ * If initialization fails due to, e.g., plperl_init_interp() throwing an
+ * exception, then we'll return here on the next usage and the user will
+ * get a rather cryptic: ERROR: attempt to redefine parameter
+ * "plperl.use_strict"
+ */
static bool inited = false;
HASHCTL hash_ctl;
PGC_USERSET, 0,
NULL, NULL);
+ DefineCustomStringVariable("plperl.on_init",
+ gettext_noop("Perl initialization code to execute when a Perl interpreter is initialized."),
+ NULL,
+ &plperl_on_init,
+ NULL,
+ PGC_SIGHUP, 0,
+ NULL, NULL);
+
+ /*
+ * plperl.on_plperl_init is currently PGC_SUSET to avoid issues whereby a
+ * user who doesn't have USAGE privileges on the plperl language could
+ * possibly use SET plperl.on_plperl_init='...' to influence the behaviour
+ * of any existing plperl function that they can EXECUTE (which may be
+ * security definer). Set
+ * http://archives.postgresql.org/pgsql-hackers/2010-02/msg00281.php and
+ * the overall thread.
+ */
+ DefineCustomStringVariable("plperl.on_plperl_init",
+ gettext_noop("Perl initialization code to execute once when plperl is first used."),
+ NULL,
+ &plperl_on_plperl_init,
+ NULL,
+ PGC_SUSET, 0,
+ NULL, NULL);
+
+ DefineCustomStringVariable("plperl.on_plperlu_init",
+ gettext_noop("Perl initialization code to execute once when plperlu is first used."),
+ NULL,
+ &plperl_on_plperlu_init,
+ NULL,
+ PGC_SUSET, 0,
+ NULL, NULL);
+
EmitWarningsOnPlaceholders("plperl");
MemSet(&hash_ctl, 0, sizeof(hash_ctl));
&hash_ctl,
HASH_ELEM);
- plperl_init_interp();
+ PLPERL_SET_OPMASK(plperl_opmask);
+
+ 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"
+
+static void
+set_interp_require(void)
+{
+ if (trusted_context)
+ {
+ PL_ppaddr[OP_REQUIRE] = pp_require_safe;
+ PL_ppaddr[OP_DOFILE] = pp_require_safe;
+ }
+ else
+ {
+ PL_ppaddr[OP_REQUIRE] = pp_require_orig;
+ PL_ppaddr[OP_DOFILE] = pp_require_orig;
+ }
+}
/*
- * 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.
+ * 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(int code, Datum arg)
+{
+ elog(DEBUG3, "plperl_fini");
-#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')"
+ /*
+ * Indicate that perl is terminating. Disables use of spi_* functions when
+ * running END/DESTROY code. See check_spi_usage_allowed(). Could be
+ * enabled in future, with care, using a transaction
+ * http://archives.postgresql.org/pgsql-hackers/2010-01/msg02743.php
+ */
+ plperl_ending = true;
+
+ /* Only perform perl cleanup if we're exiting cleanly */
+ if (code)
+ {
+ elog(DEBUG3, "plperl_fini: skipped");
+ return;
+ }
+
+ plperl_destroy_interp(&plperl_trusted_interp);
+ plperl_destroy_interp(&plperl_untrusted_interp);
+ plperl_destroy_interp(&plperl_held_interp);
+
+ elog(DEBUG3, "plperl_fini: done");
+}
/********************************************************************
* 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)
+select_perl_context(bool trusted)
{
+ EXTERN_C void boot_PostgreSQL__InServer__SPI(pTHX_ CV *cv);
+
+ /*
+ * handle simple cases
+ */
+ if (restore_context(trusted))
+ return;
+
+ /*
+ * adopt held interp if free, else create new one if possible
+ */
if (interp_state == INTERP_HELD)
{
+ /* first actual use of a perl interpreter */
+
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;
}
- plperl_held_interp = NULL;
- trusted_context = trusted;
+
+ /* successfully initialized, so arrange for cleanup */
+ on_proc_exit(plperl_fini, 0);
+
}
- else if (interp_state == INTERP_BOTH ||
- (trusted && interp_state == INTERP_TRUSTED) ||
- (!trusted && interp_state == INTERP_UNTRUSTED))
+ else
{
- if (trusted_context != trusted)
+#ifdef MULTIPLICITY
+ PerlInterpreter *plperl = plperl_init_interp();
+
+ if (trusted)
{
- if (trusted)
- PERL_SET_CONTEXT(plperl_trusted_interp);
- else
- PERL_SET_CONTEXT(plperl_untrusted_interp);
- trusted_context = trusted;
+ plperl_trusted_init();
+ plperl_trusted_interp = plperl;
}
- }
- 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;
+ {
+ plperl_untrusted_init();
+ plperl_untrusted_interp = plperl;
+ }
interp_state = INTERP_BOTH;
- plperl_held_interp = NULL;
- trusted_context = trusted;
- }
- else
- {
+#else
elog(ERROR,
"cannot allocate second Perl interpreter on this platform");
+#endif
}
+ plperl_held_interp = NULL;
+ trusted_context = trusted;
+ set_interp_require();
+
+ /*
+ * Since the timing of first use of PL/Perl can't be predicted, any
+ * database interaction during initialization is problematic. Including,
+ * but not limited to, security definer issues. So we only enable access
+ * to the database AFTER on_*_init code has run. See
+ * http://archives.postgresql.org/message-id/20100127143318.GE713@timac.loc
+ * al
+ */
+ newXS("PostgreSQL::InServer::SPI::bootstrap",
+ boot_PostgreSQL__InServer__SPI, __FILE__);
+
+ eval_pv("PostgreSQL::InServer::SPI::bootstrap()", FALSE);
+ if (SvTRUE(ERRSV))
+ ereport(ERROR,
+ (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
+ errcontext("while executing PostgreSQL::InServer::SPI::bootstrap")));
}
/*
* Restore previous interpreter selection, if two are active
*/
-static void
-restore_context(bool old_context)
+static int
+restore_context(bool trusted)
{
- if (interp_state == INTERP_BOTH && trusted_context != old_context)
+ if (interp_state == INTERP_BOTH ||
+ (trusted && interp_state == INTERP_TRUSTED) ||
+ (!trusted && interp_state == INTERP_UNTRUSTED))
{
- if (old_context)
- PERL_SET_CONTEXT(plperl_trusted_interp);
- else
- PERL_SET_CONTEXT(plperl_untrusted_interp);
- trusted_context = old_context;
+ if (trusted_context != trusted)
+ {
+ if (trusted)
+ PERL_SET_CONTEXT(plperl_trusted_interp);
+ else
+ PERL_SET_CONTEXT(plperl_untrusted_interp);
+
+ trusted_context = trusted;
+ set_interp_require();
+ }
+ return 1; /* context restored */
}
+
+ return 0; /* unable - appropriate interpreter not
+ * available */
}
-static void
+static PerlInterpreter *
plperl_init_interp(void)
{
- static char *embedding[3] = {
- "", "-e", PERLBOOT
+ PerlInterpreter *plperl;
+ static int perl_sys_init_done;
+
+ static char *embedding[3 + 2] = {
+ "", "-e", PLC_PERLBOOT
};
int nargs = 3;
* subsequent calls to the interpreter don't mess with the locale
* settings.
*
- * We restore them using Perl's POSIX::setlocale() function so that Perl
+ * We restore them using setlocale_perl(), defined below, so that Perl
* doesn't have a different idea of the locale from Postgres.
*
*/
*save_monetary,
*save_numeric,
*save_time;
- char buf[1024];
loc = setlocale(LC_COLLATE, NULL);
save_collate = loc ? pstrdup(loc) : NULL;
save_numeric = loc ? pstrdup(loc) : NULL;
loc = setlocale(LC_TIME, NULL);
save_time = loc ? pstrdup(loc) : NULL;
+
+#define PLPERL_RESTORE_LOCALE(name, saved) \
+ STMT_START { \
+ if (saved != NULL) { setlocale_perl(name, saved); pfree(saved); } \
+ } STMT_END
#endif
+ if (plperl_on_init)
+ {
+ embedding[nargs++] = "-e";
+ embedding[nargs++] = plperl_on_init;
+ }
+
/****
* The perl API docs state that PERL_SYS_INIT3 should be called before
* allocating interprters. Unfortunately, on some platforms this fails
*/
#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,
- nargs, embedding, NULL);
- perl_run(plperl_held_interp);
+ PERL_SET_CONTEXT(plperl);
+ perl_construct(plperl);
- if (interp_state == INTERP_NONE)
- {
- SV *res;
+ /* run END blocks in perl_destruct instead of perl_run */
+ PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
- res = eval_pv(TEST_FOR_MULTI, TRUE);
- can_run_two = SvIV(res);
- interp_state = INTERP_HELD;
+ /*
+ * Record the original function for the 'require' and 'dofile' opcodes.
+ * (They share the same implementation.) Ensure it's used for new
+ * interpreters.
+ */
+ if (!pp_require_orig)
+ pp_require_orig = PL_ppaddr[OP_REQUIRE];
+ else
+ {
+ PL_ppaddr[OP_REQUIRE] = pp_require_orig;
+ PL_ppaddr[OP_DOFILE] = pp_require_orig;
}
-#ifdef WIN32
+#ifdef PLPERL_ENABLE_OPMASK_EARLY
- eval_pv("use POSIX qw(locale_h);", TRUE); /* croak on failure */
+ /*
+ * For regression testing to prove that the PLC_PERLBOOT and PLC_TRUSTED
+ * code doesn't even compile any unsafe ops. In future there may be a
+ * valid need for them to do so, in which case this could be softened
+ * (perhaps moved to plperl_trusted_init()) or removed.
+ */
+ PL_op_mask = plperl_opmask;
+#endif
- if (save_collate != NULL)
- {
- snprintf(buf, sizeof(buf), "setlocale(%s,'%s');",
- "LC_COLLATE", save_collate);
- eval_pv(buf, TRUE);
- pfree(save_collate);
- }
- if (save_ctype != NULL)
- {
- snprintf(buf, sizeof(buf), "setlocale(%s,'%s');",
- "LC_CTYPE", save_ctype);
- eval_pv(buf, TRUE);
- pfree(save_ctype);
- }
- if (save_monetary != NULL)
- {
- snprintf(buf, sizeof(buf), "setlocale(%s,'%s');",
- "LC_MONETARY", save_monetary);
- eval_pv(buf, TRUE);
- pfree(save_monetary);
- }
- if (save_numeric != NULL)
- {
- snprintf(buf, sizeof(buf), "setlocale(%s,'%s');",
- "LC_NUMERIC", save_numeric);
- eval_pv(buf, TRUE);
- pfree(save_numeric);
- }
- if (save_time != NULL)
- {
- snprintf(buf, sizeof(buf), "setlocale(%s,'%s');",
- "LC_TIME", save_time);
- eval_pv(buf, TRUE);
- pfree(save_time);
- }
+ if (perl_parse(plperl, plperl_init_shared_libs,
+ nargs, embedding, NULL) != 0)
+ ereport(ERROR,
+ (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
+ errcontext("while parsing Perl initialization")));
+
+ if (perl_run(plperl) != 0)
+ ereport(ERROR,
+ (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
+ errcontext("while running Perl initialization")));
+
+#ifdef PLPERL_RESTORE_LOCALE
+ PLPERL_RESTORE_LOCALE(LC_COLLATE, save_collate);
+ PLPERL_RESTORE_LOCALE(LC_CTYPE, save_ctype);
+ PLPERL_RESTORE_LOCALE(LC_MONETARY, save_monetary);
+ PLPERL_RESTORE_LOCALE(LC_NUMERIC, save_numeric);
+ PLPERL_RESTORE_LOCALE(LC_TIME, save_time);
#endif
+ return plperl;
+}
+
+
+/*
+ * Our safe implementation of the require opcode.
+ * This is safe because it's completely unable to load any code.
+ * If the requested file/module has already been loaded it'll return true.
+ * If not, it'll die.
+ * So now "use Foo;" will work iff Foo has already been loaded.
+ */
+static OP *
+pp_require_safe(pTHX)
+{
+ dVAR;
+ dSP;
+ SV *sv,
+ **svp;
+ char *name;
+ STRLEN len;
+
+ sv = POPs;
+ name = SvPV(sv, len);
+ if (!(name && len > 0 && *name))
+ RETPUSHNO;
+
+ svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+ if (svp && *svp != &PL_sv_undef)
+ RETPUSHYES;
+
+ DIE(aTHX_ "Unable to load %s into plperl", name);
}
static void
-plperl_safe_init(void)
+plperl_destroy_interp(PerlInterpreter **interp)
{
- SV *res;
- double safe_version;
+ if (interp && *interp)
+ {
+ /*
+ * Only a very minimal destruction is performed: - just call END
+ * blocks.
+ *
+ * We could call perl_destruct() but we'd need to audit its actions
+ * very carefully and work-around any that impact us. (Calling
+ * sv_clean_objs() isn't an option because it's not part of perl's
+ * public API so isn't portably available.) Meanwhile END blocks can
+ * be used to perform manual cleanup.
+ */
+
+ PERL_SET_CONTEXT(*interp);
+
+ /* Run END blocks - based on perl's perl_destruct() */
+ if (PL_exit_flags & PERL_EXIT_DESTRUCT_END)
+ {
+ dJMPENV;
+ int x = 0;
+
+ JMPENV_PUSH(x);
+ PERL_UNUSED_VAR(x);
+ if (PL_endav && !PL_minus_c)
+ call_list(PL_scopestack_ix, PL_endav);
+ JMPENV_POP;
+ }
+ LEAVE;
+ FREETMPS;
+
+ *interp = NULL;
+ }
+}
- res = eval_pv(SAFE_MODULE, FALSE); /* TRUE = croak if failure */
- safe_version = SvNV(res);
+static void
+plperl_trusted_init(void)
+{
+ HV *stash;
+ SV *sv;
+ char *key;
+ I32 klen;
+
+ /* use original require while we set up */
+ PL_ppaddr[OP_REQUIRE] = pp_require_orig;
+ PL_ppaddr[OP_DOFILE] = pp_require_orig;
+
+ eval_pv(PLC_TRUSTED, FALSE);
+ if (SvTRUE(ERRSV))
+ ereport(ERROR,
+ (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
+ errcontext("while executing PLC_TRUSTED")));
+
+ 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,
+ (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
+ errcontext("while executing utf8fix")));
+ }
/*
- * 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.
+ * Lock down the interpreter
*/
- if (safe_version < 2.0899)
+
+ /* switch to the safe require/dofile opcode for future code */
+ PL_ppaddr[OP_REQUIRE] = pp_require_safe;
+ PL_ppaddr[OP_DOFILE] = pp_require_safe;
+
+ /*
+ * prevent (any more) unsafe opcodes being compiled PL_op_mask is per
+ * interpreter, so this only needs to be set once
+ */
+ PL_op_mask = plperl_opmask;
+
+ /* delete the DynaLoader:: namespace so extensions can't be loaded */
+ stash = gv_stashpv("DynaLoader", GV_ADDWARN);
+ hv_iterinit(stash);
+ while ((sv = hv_iternextsv(stash, &key, &klen)))
{
- /* not safe, so disallow all trusted funcs */
- eval_pv(SAFE_BAD, FALSE);
+ if (!isGV_with_GP(sv) || !GvCV(sv))
+ continue;
+ SvREFCNT_dec(GvCV(sv)); /* free the CV */
+ GvCV(sv) = NULL; /* prevent call via GV */
}
- else
+ hv_clear(stash);
+
+ /* invalidate assorted caches */
+ ++PL_sub_generation;
+ hv_clear(PL_stashcache);
+
+ /*
+ * Execute plperl.on_plperl_init in the locked-down interpreter
+ */
+ if (plperl_on_plperl_init && *plperl_on_plperl_init)
{
- eval_pv(SAFE_OK, FALSE);
- 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.
- */
- 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);
- }
+ eval_pv(plperl_on_plperl_init, FALSE);
+ if (SvTRUE(ERRSV))
+ ereport(ERROR,
+ (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
+ errcontext("while executing plperl.on_plperl_init")));
+
}
+}
- plperl_safe_init_done = true;
+
+static void
+plperl_untrusted_init(void)
+{
+ if (plperl_on_plperlu_init && *plperl_on_plperlu_init)
+ {
+ eval_pv(plperl_on_plperlu_init, FALSE);
+ if (SvTRUE(ERRSV))
+ ereport(ERROR,
+ (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
+ errcontext("while executing plperl.on_plperlu_init")));
+ }
}
+
/*
* Perl likes to put a newline after its error messages; clean up such
*/
errmsg("Perl hash contains nonexistent column \"%s\"",
key)));
if (SvOK(val))
- values[attn - 1] = SvPV(val, PL_na);
+ {
+ values[attn - 1] = sv2text_mbverified(val);
+ }
}
hv_iterinit(perlhash);
XPUSHs(src);
PUTBACK;
- count = call_pv("::_plperl_to_pg_array", G_SCALAR);
+ count = perl_call_pv("::encode_array_literal", G_SCALAR);
SPAGAIN;
if (count != 1)
- elog(ERROR, "unexpected _plperl_to_pg_array failure");
+ elog(ERROR, "unexpected encode_array_literal failure");
rv = POPs;
HV *hv;
hv = newHV();
+ hv_ksplit(hv, 12); /* pre-grow the hash */
tdata = (TriggerData *) fcinfo->context;
tupdesc = tdata->tg_relation->rd_att;
{
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));
ereport(ERROR,
(errcode(ERRCODE_UNDEFINED_COLUMN),
errmsg("$_TD->{new} does not exist")));
- if (!SvOK(*svp) || SvTYPE(*svp) != SVt_RV || SvTYPE(SvRV(*svp)) != SVt_PVHV)
+ if (!SvOK(*svp) || !SvROK(*svp) || SvTYPE(SvRV(*svp)) != SVt_PVHV)
ereport(ERROR,
(errcode(ERRCODE_DATATYPE_MISMATCH),
errmsg("$_TD->{new} is not a hash reference")));
if (SvOK(val))
{
modvalues[slotsused] = InputFunctionCall(&finfo,
- SvPV(val, PL_na),
+ sv2text_mbverified(val),
typioparam,
atttypmod);
modnulls[slotsused] = ' ';
{
InlineCodeBlock *codeblock = (InlineCodeBlock *) PG_GETARG_POINTER(0);
FunctionCallInfoData fake_fcinfo;
- FmgrInfo flinfo;
+ FmgrInfo flinfo;
plperl_proc_desc desc;
plperl_call_data *save_call_data = current_call_data;
bool oldcontext = trusted_context;
if (SPI_connect() != SPI_OK_CONNECT)
elog(ERROR, "could not connect to SPI manager");
- check_interp(desc.lanpltrusted);
+ select_perl_context(desc.lanpltrusted);
- desc.reference = plperl_create_sub(desc.proname,
- codeblock->source_text,
- 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");
}
PG_CATCH();
{
- current_call_data = save_call_data;
- restore_context(oldcontext);
if (desc.reference)
SvREFCNT_dec(desc.reference);
+ current_call_data = save_call_data;
+ restore_context(oldcontext);
PG_RE_THROW();
}
PG_END_TRY();
- current_call_data = save_call_data;
- restore_context(oldcontext);
if (desc.reference)
SvREFCNT_dec(desc.reference);
+ current_call_data = save_call_data;
+ restore_context(oldcontext);
+
error_context_stack = pl_error_context.previous;
PG_RETURN_VOID();
int i;
/* Get the new function's pg_proc entry */
- tuple = SearchSysCache(PROCOID,
- ObjectIdGetDatum(funcoid),
- 0, 0, 0);
+ tuple = SearchSysCache1(PROCOID, ObjectIdGetDatum(funcoid));
if (!HeapTupleIsValid(tuple))
elog(ERROR, "cache lookup failed for function %u", funcoid);
proc = (Form_pg_proc) GETSTRUCT(tuple);
/*
- * Uses mksafefunc/mkunsafefunc to create an anonymous sub whose text is
- * supplied in s, and returns a reference to the closure.
+ * Uses mksafefunc/mkunsafefunc to create a subroutine whose text is
+ * supplied in s, and returns a reference to it
*/
-static SV *
-plperl_create_sub(const char *proname, const char *s, bool trusted)
+static void
+plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid)
{
dSP;
- SV *subref;
+ char subname[NAMEDATALEN + 40];
+ HV *pragma_hv = newHV();
+ SV *subref = NULL;
int count;
- char *compile_sub;
- if (trusted && !plperl_safe_init_done)
- {
- plperl_safe_init();
- SPAGAIN;
- }
+ sprintf(subname, "%s__%u", prodesc->proname, fn_oid);
+
+ if (plperl_use_strict)
+ hv_store_string(pragma_hv, "strict", (SV *) newAV());
ENTER;
SAVETMPS;
PUSHMARK(SP);
- XPUSHs(sv_2mortal(newSVstring("our $_TD; local $_TD=$_[0]; shift;")));
- XPUSHs(sv_2mortal(newSVstring(s)));
+ 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;
/*
* 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);
+ count = perl_call_pv("PostgreSQL::InServer::mkfunc",
+ G_SCALAR | G_EVAL | G_KEEPERR);
SPAGAIN;
- if (count != 1)
+ if (count == 1)
{
- PUTBACK;
- FREETMPS;
- LEAVE;
- elog(ERROR, "didn't get a return item from mksafefunc");
+ SV *sub_rv = (SV *) POPs;
+
+ if (sub_rv && SvROK(sub_rv) && SvTYPE(SvRV(sub_rv)) == SVt_PVCV)
+ {
+ subref = newRV_inc(SvRV(sub_rv));
+ }
}
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
if (SvTRUE(ERRSV))
- {
- (void) POPs;
- PUTBACK;
- FREETMPS;
- LEAVE;
ereport(ERROR,
(errcode(ERRCODE_SYNTAX_ERROR),
- errmsg("%s", strip_trailing_ws(SvPV(ERRSV, PL_na)))));
- }
+ 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");
- }
+ if (!subref)
+ ereport(ERROR,
+ (errmsg("didn't get a CODE reference from compiling function \"%s\"",
+ prodesc->proname)));
- PUTBACK;
- FREETMPS;
- LEAVE;
+ prodesc->reference = subref;
- return subref;
+ return;
}
/**********************************************************************
* plperl_init_shared_libs() -
- *
- * We cannot use the DynaLoader directly to get at the Opcode
- * module (used by Safe.pm). So, we link Opcode into ourselves
- * and do the initialization behind perl's back.
- *
**********************************************************************/
-EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
-EXTERN_C void boot_SPI(pTHX_ CV *cv);
-
static void
plperl_init_shared_libs(pTHX)
{
char *file = __FILE__;
+ EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
+ EXTERN_C void boot_PostgreSQL__InServer__Util(pTHX_ CV *cv);
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
- newXS("SPI::bootstrap", boot_SPI, file);
+ newXS("PostgreSQL::InServer::Util::bootstrap",
+ boot_PostgreSQL__InServer__Util, file);
+ /* newXS for...::SPI::bootstrap is in select_perl_context() */
}
SAVETMPS;
PUSHMARK(SP);
+ EXTEND(sp, 1 + desc->nargs);
- XPUSHs(&PL_sv_undef); /* no trigger data */
+ PUSHs(&PL_sv_undef); /* no trigger data */
for (i = 0; i < desc->nargs; i++)
{
if (fcinfo->argnull[i])
- XPUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_undef);
else if (desc->arg_is_rowtype[i])
{
HeapTupleHeader td;
tmptup.t_data = td;
hashref = plperl_hash_from_tuple(&tmptup, tupdesc);
- XPUSHs(sv_2mortal(hashref));
+ PUSHs(sv_2mortal(hashref));
ReleaseTupleDesc(tupdesc);
}
else
tmp = OutputFunctionCall(&(desc->arg_out_func[i]),
fcinfo->arg[i]);
sv = newSVstring(tmp);
- XPUSHs(sv_2mortal(sv));
+ PUSHs(sv_2mortal(sv));
pfree(tmp);
}
}
LEAVE;
/* XXX need to find a way to assign an errcode here */
ereport(ERROR,
- (errmsg("%s", strip_trailing_ws(SvPV(ERRSV, PL_na)))));
+ (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV)))));
}
retval = newSVsv(POPs);
LEAVE;
/* XXX need to find a way to assign an errcode here */
ereport(ERROR,
- (errmsg("%s", strip_trailing_ws(SvPV(ERRSV, PL_na)))));
+ (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV)))));
}
retval = newSVsv(POPs);
"cannot accept a set")));
}
- check_interp(prodesc->lanpltrusted);
+ select_perl_context(prodesc->lanpltrusted);
perlret = plperl_call_perl_func(prodesc, fcinfo);
* value is an error, except undef which means return an empty set.
*/
if (SvOK(perlret) &&
- SvTYPE(perlret) == SVt_RV &&
+ SvROK(perlret) &&
SvTYPE(SvRV(perlret)) == SVt_PVAV)
{
int i = 0;
AttInMetadata *attinmeta;
HeapTuple tup;
- if (!SvOK(perlret) || SvTYPE(perlret) != SVt_RV ||
+ if (!SvOK(perlret) || !SvROK(perlret) ||
SvTYPE(SvRV(perlret)) != SVt_PVHV)
{
ereport(ERROR,
else
{
/* Return a perl string converted to a Datum */
- char *val;
if (prodesc->fn_retisarray && SvROK(perlret) &&
SvTYPE(SvRV(perlret)) == SVt_PVAV)
perlret = array_ret;
}
- val = SvPV(perlret, PL_na);
-
- retval = InputFunctionCall(&prodesc->result_in_func, val,
+ retval = InputFunctionCall(&prodesc->result_in_func,
+ sv2text_mbverified(perlret),
prodesc->result_typioparam, -1);
}
pl_error_context.arg = prodesc->proname;
error_context_stack = &pl_error_context;
- check_interp(prodesc->lanpltrusted);
+ select_perl_context(prodesc->lanpltrusted);
svTD = plperl_trigger_build_args(fcinfo);
perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
HeapTuple trv;
char *tmp;
- tmp = SvPV(perlret, PL_na);
+ tmp = SvPV_nolen(perlret);
if (pg_strcasecmp(tmp, "SKIP") == 0)
trv = NULL;
ErrorContextCallback plperl_error_context;
/* We'll need the pg_proc tuple in any case... */
- procTup = SearchSysCache(PROCOID,
- ObjectIdGetDatum(fn_oid),
- 0, 0, 0);
+ procTup = SearchSysCache1(PROCOID, ObjectIdGetDatum(fn_oid));
if (!HeapTupleIsValid(procTup))
elog(ERROR, "cache lookup failed for function %u", fn_oid);
procStruct = (Form_pg_proc) GETSTRUCT(procTup);
hash_search(plperl_proc_hash, internal_proname,
HASH_REMOVE, NULL);
if (prodesc->reference)
+ {
+ select_perl_context(prodesc->lanpltrusted);
SvREFCNT_dec(prodesc->reference);
+ restore_context(oldcontext);
+ }
free(prodesc->proname);
free(prodesc);
prodesc = NULL;
/************************************************************
* Lookup the pg_language tuple by Oid
************************************************************/
- langTup = SearchSysCache(LANGOID,
- ObjectIdGetDatum(procStruct->prolang),
- 0, 0, 0);
+ langTup = SearchSysCache1(LANGOID,
+ ObjectIdGetDatum(procStruct->prolang));
if (!HeapTupleIsValid(langTup))
{
free(prodesc->proname);
************************************************************/
if (!is_trigger)
{
- typeTup = SearchSysCache(TYPEOID,
- ObjectIdGetDatum(procStruct->prorettype),
- 0, 0, 0);
+ typeTup =
+ SearchSysCache1(TYPEOID,
+ ObjectIdGetDatum(procStruct->prorettype));
if (!HeapTupleIsValid(typeTup))
{
free(prodesc->proname);
prodesc->nargs = procStruct->pronargs;
for (i = 0; i < prodesc->nargs; i++)
{
- typeTup = SearchSysCache(TYPEOID,
- ObjectIdGetDatum(procStruct->proargtypes.values[i]),
- 0, 0, 0);
+ typeTup = SearchSysCache1(TYPEOID,
+ ObjectIdGetDatum(procStruct->proargtypes.values[i]));
if (!HeapTupleIsValid(typeTup))
{
free(prodesc->proname);
* Create the procedure in the interpreter
************************************************************/
- check_interp(prodesc->lanpltrusted);
+ select_perl_context(prodesc->lanpltrusted);
- prodesc->reference = plperl_create_sub(prodesc->proname,
- proc_source,
- prodesc->lanpltrusted);
+ plperl_create_sub(prodesc, proc_source, fn_oid);
restore_context(oldcontext);
int i;
hv = newHV();
+ hv_ksplit(hv, tupdesc->natts); /* pre-grow the hash */
for (i = 0; i < tupdesc->natts; i++)
{
}
+static void
+check_spi_usage_allowed()
+{
+ /* see comment in plperl_fini() */
+ if (plperl_ending)
+ {
+ /* simple croak as we don't want to involve PostgreSQL code */
+ croak("SPI functions can not be used in END blocks");
+ }
+}
+
+
HV *
plperl_spi_exec(char *query, int limit)
{
MemoryContext oldcontext = CurrentMemoryContext;
ResourceOwner oldowner = CurrentResourceOwner;
+ check_spi_usage_allowed();
+
BeginInternalSubTransaction(NULL);
/* Want to run inside function's memory context */
MemoryContextSwitchTo(oldcontext);
{
int spi_rv;
+ pg_verifymbstr(query, strlen(query), false);
+
spi_rv = SPI_execute(query, current_call_data->prodesc->fn_readonly,
limit);
ret_hv = plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed,
{
HV *result;
+ check_spi_usage_allowed();
+
result = newHV();
hv_store_string(result, "status",
int i;
rows = newAV();
+ av_extend(rows, processed);
for (i = 0; i < processed; i++)
{
row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
errmsg("cannot use return_next in a non-SETOF function")));
if (prodesc->fn_retistuple &&
- !(SvOK(sv) && SvTYPE(sv) == SVt_RV && SvTYPE(SvRV(sv)) == SVt_PVHV))
+ !(SvOK(sv) && SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV))
ereport(ERROR,
(errcode(ERRCODE_DATATYPE_MISMATCH),
errmsg("SETOF-composite-returning PL/Perl function "
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(sv, PL_na);
-
- ret = InputFunctionCall(&prodesc->result_in_func, val,
+ ret = InputFunctionCall(&prodesc->result_in_func,
+ sv2text_mbverified(sv),
prodesc->result_typioparam, -1);
isNull = false;
}
MemoryContext oldcontext = CurrentMemoryContext;
ResourceOwner oldowner = CurrentResourceOwner;
+ check_spi_usage_allowed();
+
BeginInternalSubTransaction(NULL);
/* Want to run inside function's memory context */
MemoryContextSwitchTo(oldcontext);
void *plan;
Portal portal;
+ /* Make sure the query is validly encoded */
+ pg_verifymbstr(query, strlen(query), false);
+
/* Create a cursor for the query */
plan = SPI_prepare(query, 0, NULL);
if (plan == NULL)
MemoryContext oldcontext = CurrentMemoryContext;
ResourceOwner oldowner = CurrentResourceOwner;
+ check_spi_usage_allowed();
+
BeginInternalSubTransaction(NULL);
/* Want to run inside function's memory context */
MemoryContextSwitchTo(oldcontext);
void
plperl_spi_cursor_close(char *cursor)
{
- Portal p = SPI_cursor_find(cursor);
+ Portal p;
+
+ check_spi_usage_allowed();
+
+ p = SPI_cursor_find(cursor);
if (p)
SPI_cursor_close(p);
MemoryContext oldcontext = CurrentMemoryContext;
ResourceOwner oldowner = CurrentResourceOwner;
+ check_spi_usage_allowed();
+
BeginInternalSubTransaction(NULL);
MemoryContextSwitchTo(oldcontext);
typIOParam;
int32 typmod;
- parseTypeString(SvPV(argv[i], PL_na), &typId, &typmod);
+ parseTypeString(SvPV_nolen(argv[i]), &typId, &typmod);
getTypeInputInfo(typId, &typInput, &typIOParam);
qdesc->argtypioparams[i] = typIOParam;
}
+ /* Make sure the query is validly encoded */
+ pg_verifymbstr(query, strlen(query), false);
+
/************************************************************
* Prepare the plan and check for errors
************************************************************/
MemoryContext oldcontext = CurrentMemoryContext;
ResourceOwner oldowner = CurrentResourceOwner;
+ check_spi_usage_allowed();
+
BeginInternalSubTransaction(NULL);
/* Want to run inside function's memory context */
MemoryContextSwitchTo(oldcontext);
if (SvOK(argv[i]))
{
argvalues[i] = InputFunctionCall(&qdesc->arginfuncs[i],
- SvPV(argv[i], PL_na),
+ sv2text_mbverified(argv[i]),
qdesc->argtypioparams[i],
-1);
nulls[i] = ' ';
MemoryContext oldcontext = CurrentMemoryContext;
ResourceOwner oldowner = CurrentResourceOwner;
+ check_spi_usage_allowed();
+
BeginInternalSubTransaction(NULL);
/* Want to run inside function's memory context */
MemoryContextSwitchTo(oldcontext);
if (SvOK(argv[i]))
{
argvalues[i] = InputFunctionCall(&qdesc->arginfuncs[i],
- SvPV(argv[i], PL_na),
+ sv2text_mbverified(argv[i]),
qdesc->argtypioparams[i],
-1);
nulls[i] = ' ';
plperl_query_desc *qdesc;
plperl_query_entry *hash_entry;
+ check_spi_usage_allowed();
+
hash_entry = hash_search(plperl_query_hash, query,
HASH_FIND, NULL);
if (hash_entry == NULL)
static void
plperl_exec_callback(void *arg)
{
- char *procname = (char *) arg;
+ char *procname = (char *) arg;
+
if (procname)
errcontext("PL/Perl function \"%s\"", procname);
}
static void
plperl_compile_callback(void *arg)
{
- char *procname = (char *) arg;
+ char *procname = (char *) arg;
+
if (procname)
errcontext("compilation of PL/Perl function \"%s\"", procname);
}
{
errcontext("PL/Perl anonymous code block");
}
+
+
+/*
+ * Perl's own setlocal() copied from POSIX.xs
+ * (needed because of the calls to new_*())
+ */
+#ifdef WIN32
+static char *
+setlocale_perl(int category, char *locale)
+{
+ char *RETVAL = setlocale(category, locale);
+
+ if (RETVAL)
+ {
+#ifdef USE_LOCALE_CTYPE
+ if (category == LC_CTYPE
+#ifdef LC_ALL
+ || category == LC_ALL
+#endif
+ )
+ {
+ char *newctype;
+
+#ifdef LC_ALL
+ if (category == LC_ALL)
+ newctype = setlocale(LC_CTYPE, NULL);
+ else
+#endif
+ newctype = RETVAL;
+ new_ctype(newctype);
+ }
+#endif /* USE_LOCALE_CTYPE */
+#ifdef USE_LOCALE_COLLATE
+ if (category == LC_COLLATE
+#ifdef LC_ALL
+ || category == LC_ALL
+#endif
+ )
+ {
+ char *newcoll;
+
+#ifdef LC_ALL
+ if (category == LC_ALL)
+ newcoll = setlocale(LC_COLLATE, NULL);
+ else
+#endif
+ newcoll = RETVAL;
+ new_collate(newcoll);
+ }
+#endif /* USE_LOCALE_COLLATE */
+
+#ifdef USE_LOCALE_NUMERIC
+ if (category == LC_NUMERIC
+#ifdef LC_ALL
+ || category == LC_ALL
+#endif
+ )
+ {
+ char *newnum;
+
+#ifdef LC_ALL
+ if (category == LC_ALL)
+ newnum = setlocale(LC_NUMERIC, NULL);
+ else
+#endif
+ newnum = RETVAL;
+ new_numeric(newnum);
+ }
+#endif /* USE_LOCALE_NUMERIC */
+ }
+
+ return RETVAL;
+}
+
+#endif
projects / postgresql / blobdiff