/**********************************************************************
* plperl.c - perl as a procedural language for PostgreSQL
*
- * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.168 2010/02/16 21:39:52 adunstan Exp $
+ * src/pl/plperl/plperl.c
*
**********************************************************************/
/* string literal macros defining chunks of perl code */
#include "perlchunks.h"
+/* defines PLPERL_SET_OPMASK */
+#include "plperl_opmask.h"
PG_MODULE_MAGIC;
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_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 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;
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);
+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.
+ 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);
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;
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);
+ 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.
+ * 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);
+ 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);
+ 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");
&hash_ctl,
HASH_ELEM);
+ PLPERL_SET_OPMASK(plperl_opmask);
+
plperl_held_interp = plperl_init_interp();
interp_state = INTERP_HELD;
}
+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;
+ }
+}
+
/*
* Cleanup perl interpreters, including running END blocks.
* Does not fully undo the actions of _PG_init() nor make it callable again.
elog(DEBUG3, "plperl_fini");
/*
- * 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
+ * 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) {
+ if (code)
+ {
elog(DEBUG3, "plperl_fini: skipped");
return;
}
}
-#define SAFE_MODULE \
- "require Safe; $Safe::VERSION"
-
/********************************************************************
*
* We start out by creating a "held" interpreter that we can use in
{
#ifdef MULTIPLICITY
PerlInterpreter *plperl = plperl_init_interp();
- if (trusted) {
+
+ if (trusted)
+ {
plperl_trusted_init();
plperl_trusted_interp = plperl;
}
- else {
+ else
+ {
plperl_untrusted_init();
plperl_untrusted_interp = plperl;
}
}
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.local
+ * 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__);
+ 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))),
- errdetail("While executing PostgreSQL::InServer::SPI::bootstrap.")));
+ errcontext("while executing PostgreSQL::InServer::SPI::bootstrap")));
}
/*
restore_context(bool trusted)
{
if (interp_state == INTERP_BOTH ||
- ( trusted && interp_state == INTERP_TRUSTED) ||
+ (trusted && interp_state == INTERP_TRUSTED) ||
(!trusted && interp_state == INTERP_UNTRUSTED))
{
if (trusted_context != trusted)
{
- if (trusted) {
+ if (trusted)
PERL_SET_CONTEXT(plperl_trusted_interp);
- PL_ppaddr[OP_REQUIRE] = pp_require_safe;
- }
- else {
+ else
PERL_SET_CONTEXT(plperl_untrusted_interp);
- PL_ppaddr[OP_REQUIRE] = pp_require_orig;
- }
+
trusted_context = trusted;
+ set_interp_require();
}
- return 1; /* context restored */
+ return 1; /* context restored */
}
- return 0; /* unable - appropriate interpreter not available */
+ return 0; /* unable - appropriate interpreter not
+ * available */
}
static PerlInterpreter *
plperl_init_interp(void)
{
PerlInterpreter *plperl;
- static int perl_sys_init_done;
+ static int perl_sys_init_done;
- static char *embedding[3+2] = {
+ 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)
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;
+ dummy_env[0] = NULL;
}
#endif
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
/*
- * Record the original function for the 'require' opcode.
- * Ensure it's used for new interpreters.
+ * 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 PLPERL_ENABLE_OPMASK_EARLY
+
+ /*
+ * 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 (perl_parse(plperl, plperl_init_shared_libs,
- nargs, embedding, NULL) != 0)
+ nargs, embedding, NULL) != 0)
ereport(ERROR,
(errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
- errcontext("While parsing perl initialization.")));
+ 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 WIN32
-
- eval_pv("use POSIX qw(locale_h);", TRUE); /* croak on failure */
-
- 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);
- }
+ 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;
* If not, it'll die.
* So now "use Foo;" will work iff Foo has already been loaded.
*/
-static OP *
+static OP *
pp_require_safe(pTHX)
{
- dVAR; dSP;
- SV *sv, **svp;
- char *name;
- STRLEN len;
+ dVAR;
+ dSP;
+ SV *sv,
+ **svp;
+ char *name;
+ STRLEN len;
- sv = POPs;
- name = SvPV(sv, len);
- if (!(name && len > 0 && *name))
- RETPUSHNO;
+ 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)
if (interp && *interp)
{
/*
- * Only a very minimal destruction is performed:
- * - just call END blocks.
+ * 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.
+ * 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) {
+ if (PL_exit_flags & PERL_EXIT_DESTRUCT_END)
+ {
dJMPENV;
- int x = 0;
+ int x = 0;
JMPENV_PUSH(x);
PERL_UNUSED_VAR(x);
static void
plperl_trusted_init(void)
{
- SV *safe_version_sv;
- IV safe_version_x100;
+ HV *stash;
+ SV *sv;
+ char *key;
+ I32 klen;
- safe_version_sv = eval_pv(SAFE_MODULE, FALSE);/* TRUE = croak if failure */
- safe_version_x100 = (int)(SvNV(safe_version_sv) * 100);
+ /* use original require while we set up */
+ PL_ppaddr[OP_REQUIRE] = pp_require_orig;
+ PL_ppaddr[OP_DOFILE] = pp_require_orig;
- /*
- * Reject too-old versions of Safe and some others:
- * 2.20: http://rt.perl.org/rt3/Ticket/Display.html?id=72068
- * 2.21: http://rt.perl.org/rt3/Ticket/Display.html?id=72700
- */
- if (safe_version_x100 < 209 || safe_version_x100 == 220 ||
- safe_version_x100 == 221)
+ 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)
{
- /* not safe, so disallow all trusted funcs */
- eval_pv(PLC_SAFE_BAD, FALSE);
+ /*
+ * 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 PLC_SAFE_BAD.")));
+ errcontext("while executing utf8fix")));
}
- else
- {
- eval_pv(PLC_SAFE_OK, FALSE);
- if (SvTRUE(ERRSV))
- ereport(ERROR,
- (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
- errcontext("While executing PLC_SAFE_OK.")));
- 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.")));
- }
+ /*
+ * Lock down the interpreter
+ */
- /* switch to the safe require opcode */
- PL_ppaddr[OP_REQUIRE] = pp_require_safe;
+ /* switch to the safe require/dofile opcode for future code */
+ PL_ppaddr[OP_REQUIRE] = pp_require_safe;
+ PL_ppaddr[OP_DOFILE] = pp_require_safe;
- if (plperl_on_plperl_init && *plperl_on_plperl_init)
- {
- dSP;
+ /*
+ * 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;
- PUSHMARK(SP);
- XPUSHs(sv_2mortal(newSVstring(plperl_on_plperl_init)));
- PUTBACK;
+ /* 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)))
+ {
+ if (!isGV_with_GP(sv) || !GvCV(sv))
+ continue;
+ SvREFCNT_dec(GvCV(sv)); /* free the CV */
+ GvCV(sv) = NULL; /* prevent call via GV */
+ }
+ hv_clear(stash);
- call_pv("PostgreSQL::InServer::safe::safe_eval", G_VOID);
- SPAGAIN;
+ /* invalidate assorted caches */
+ ++PL_sub_generation;
+ hv_clear(PL_stashcache);
- if (SvTRUE(ERRSV))
- ereport(ERROR,
- (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
- errcontext("While executing plperl.on_plperl_init.")));
- }
+ /*
+ * Execute plperl.on_plperl_init in the locked-down interpreter
+ */
+ if (plperl_on_plperl_init && *plperl_on_plperl_init)
+ {
+ 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")));
}
}
if (SvTRUE(ERRSV))
ereport(ERROR,
(errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
- errcontext("While executing plperl.on_plperlu_init.")));
+ errcontext("while executing plperl.on_plperlu_init")));
}
}
{
SV *rv;
int count;
+
dSP;
PUSHMARK(SP);
HV *hv;
hv = newHV();
- hv_ksplit(hv, 12); /* pre-grow the hash */
+ hv_ksplit(hv, 12); /* pre-grow the hash */
tdata = (TriggerData *) fcinfo->context;
tupdesc = tdata->tg_relation->rd_att;
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")));
{
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;
}
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();
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;
+ char subname[NAMEDATALEN + 40];
+ HV *pragma_hv = newHV();
+ SV *subref = NULL;
+ int count;
sprintf(subname, "%s__%u", prodesc->proname, fn_oid);
if (plperl_use_strict)
- hv_store_string(pragma_hv, "strict", (SV*)newAV());
+ hv_store_string(pragma_hv, "strict", (SV *) newAV());
ENTER;
SAVETMPS;
PUSHMARK(SP);
- EXTEND(SP,4);
+ EXTEND(SP, 4);
PUSHs(sv_2mortal(newSVstring(subname)));
- PUSHs(sv_2mortal(newRV_noinc((SV*)pragma_hv)));
+ 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?
*/
- compile_sub = (trusted)
- ? "PostgreSQL::InServer::safe::mksafefunc"
- : "PostgreSQL::InServer::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) {
- GV *sub_glob = (GV*)POPs;
- if (sub_glob && SvTYPE(sub_glob) == SVt_PVGV) {
- SV *sv = (SV*)GvCVu((GV*)sub_glob);
- if (sv)
- subref = newRV_inc(sv);
+ if (count == 1)
+ {
+ SV *sub_rv = (SV *) POPs;
+
+ if (sub_rv && SvROK(sub_rv) && SvTYPE(SvRV(sub_rv)) == SVt_PVCV)
+ {
+ subref = newRV_inc(SvRV(sub_rv));
}
}
if (!subref)
ereport(ERROR,
- (errmsg("didn't get a GLOB from compiling %s via %s",
- prodesc->proname, compile_sub)));
+ (errmsg("didn't get a CODE reference from compiling function \"%s\"",
+ prodesc->proname)));
- prodesc->reference = newSVsv(subref);
+ prodesc->reference = 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.
- *
**********************************************************************/
static void
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
newXS("PostgreSQL::InServer::Util::bootstrap",
- boot_PostgreSQL__InServer__Util, file);
+ boot_PostgreSQL__InServer__Util, file);
/* newXS for...::SPI::bootstrap is in select_perl_context() */
}
* 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,
{
hash_search(plperl_proc_hash, internal_proname,
HASH_REMOVE, NULL);
- if (prodesc->reference) {
+ if (prodesc->reference)
+ {
select_perl_context(prodesc->lanpltrusted);
SvREFCNT_dec(prodesc->reference);
restore_context(oldcontext);
{
typeTup =
SearchSysCache1(TYPEOID,
- ObjectIdGetDatum(procStruct->prorettype));
+ ObjectIdGetDatum(procStruct->prorettype));
if (!HeapTupleIsValid(typeTup))
{
free(prodesc->proname);
for (i = 0; i < prodesc->nargs; i++)
{
typeTup = SearchSysCache1(TYPEOID,
- ObjectIdGetDatum(procStruct->proargtypes.values[i]));
+ ObjectIdGetDatum(procStruct->proargtypes.values[i]));
if (!HeapTupleIsValid(typeTup))
{
free(prodesc->proname);
int i;
hv = newHV();
- hv_ksplit(hv, tupdesc->natts); /* pre-grow the hash */
+ hv_ksplit(hv, tupdesc->natts); /* pre-grow the hash */
for (i = 0; i < tupdesc->natts; i++)
{
check_spi_usage_allowed()
{
/* see comment in plperl_fini() */
- if (plperl_ending) {
+ if (plperl_ending)
+ {
/* simple croak as we don't want to involve PostgreSQL code */
croak("SPI functions can not be used in END blocks");
}
{
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,
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 "
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)
qdesc->argtypioparams[i] = typIOParam;
}
+ /* Make sure the query is validly encoded */
+ pg_verifymbstr(query, strlen(query), false);
+
/************************************************************
* Prepare the plan and check for errors
************************************************************/
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