**********************************************************************/
#include "postgres.h"
+
/* Defined by Perl */
#undef _
static void plperl_trusted_init(void);
static void plperl_untrusted_init(void);
static HV *plperl_spi_execute_fetch_result(SPITupleTable *, uint64, int);
+static void plperl_return_next_internal(SV *sv);
static char *hek2cstr(HE *he);
static SV **hv_store_string(HV *hv, const char *key, SV *val);
static SV **hv_fetch_string(HV *hv, const char *key);
static char *setlocale_perl(int category, char *locale);
#endif
+/*
+ * Decrement the refcount of the given SV within the active Perl interpreter
+ *
+ * This is handy because it reloads the active-interpreter pointer, saving
+ * some notation in callers that switch the active interpreter.
+ */
+static inline void
+SvREFCNT_dec_current(SV *sv)
+{
+ dTHX;
+
+ SvREFCNT_dec(sv);
+}
+
/*
* convert a HE (hash entry) key to a cstr in the current database encoding
*/
static char *
hek2cstr(HE *he)
{
+ dTHX;
char *ret;
SV *sv;
* to the database AFTER on_*_init code has run. See
* http://archives.postgresql.org/pgsql-hackers/2010-01/msg02669.php
*/
- newXS("PostgreSQL::InServer::SPI::bootstrap",
- boot_PostgreSQL__InServer__SPI, __FILE__);
+ {
+ dTHX;
- eval_pv("PostgreSQL::InServer::SPI::bootstrap()", FALSE);
- if (SvTRUE(ERRSV))
- ereport(ERROR,
- (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
- errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
- errcontext("while executing PostgreSQL::InServer::SPI::bootstrap")));
+ newXS("PostgreSQL::InServer::SPI::bootstrap",
+ boot_PostgreSQL__InServer__SPI, __FILE__);
+
+ eval_pv("PostgreSQL::InServer::SPI::bootstrap()", FALSE);
+ if (SvTRUE(ERRSV))
+ ereport(ERROR,
+ (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
+ errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
+ errcontext("while executing PostgreSQL::InServer::SPI::bootstrap")));
+ }
/* Fully initialized, so mark the hashtable entry valid */
interp_desc->interp = interp;
PERL_SET_CONTEXT(plperl);
perl_construct(plperl);
- /* run END blocks in perl_destruct instead of perl_run */
- PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
-
/*
- * Record the original function for the 'require' and 'dofile' opcodes.
- * (They share the same implementation.) Ensure it's used for new
- * interpreters.
+ * Run END blocks in perl_destruct instead of perl_run. Note that dTHX
+ * loads up a pointer to the current interpreter, so we have to postpone
+ * it to here rather than put it at the function head.
*/
- 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;
- }
+ dTHX;
+
+ PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
+
+ /*
+ * 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;
+ /*
+ * 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)
- ereport(ERROR,
- (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
- errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
- errcontext("while parsing Perl initialization")));
+ if (perl_parse(plperl, plperl_init_shared_libs,
+ nargs, embedding, NULL) != 0)
+ ereport(ERROR,
+ (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
+ errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
+ errcontext("while parsing Perl initialization")));
- if (perl_run(plperl) != 0)
- ereport(ERROR,
- (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
- errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
- errcontext("while running Perl initialization")));
+ if (perl_run(plperl) != 0)
+ ereport(ERROR,
+ (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
+ errmsg("%s", strip_trailing_ws(sv2cstr(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);
+ 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;
}
* public API so isn't portably available.) Meanwhile END blocks can
* be used to perform manual cleanup.
*/
+ dTHX;
/* Run END blocks - based on perl's perl_destruct() */
if (PL_exit_flags & PERL_EXIT_DESTRUCT_END)
static void
plperl_trusted_init(void)
{
+ dTHX;
HV *stash;
SV *sv;
char *key;
static void
plperl_untrusted_init(void)
{
+ dTHX;
+
/*
* Nothing to do except execute plperl.on_plperlu_init
*/
static HeapTuple
plperl_build_tuple_result(HV *perlhash, TupleDesc td)
{
+ dTHX;
Datum *values;
bool *nulls;
HE *he;
static SV *
get_perl_array_ref(SV *sv)
{
+ dTHX;
+
if (SvOK(sv) && SvROK(sv))
{
if (SvTYPE(SvRV(sv)) == SVt_PVAV)
Oid arraytypid, Oid elemtypid, int32 typmod,
FmgrInfo *finfo, Oid typioparam)
{
+ dTHX;
int i;
int len = av_len(av) + 1;
static Datum
plperl_array_to_datum(SV *src, Oid typid, int32 typmod)
{
+ dTHX;
ArrayBuildState *astate;
Oid elemtypid;
FmgrInfo finfo;
static SV *
plperl_ref_from_pg_array(Datum arg, Oid typid)
{
+ dTHX;
ArrayType *ar = DatumGetArrayTypeP(arg);
Oid elementtype = ARR_ELEMTYPE(ar);
int16 typlen;
static SV *
split_array(plperl_array_info *info, int first, int last, int nest)
{
+ dTHX;
int i;
AV *result;
static SV *
make_array_ref(plperl_array_info *info, int first, int last)
{
+ dTHX;
int i;
AV *result = newAV();
static SV *
plperl_trigger_build_args(FunctionCallInfo fcinfo)
{
+ dTHX;
TriggerData *tdata;
TupleDesc tupdesc;
int i;
static SV *
plperl_event_trigger_build_args(FunctionCallInfo fcinfo)
{
+ dTHX;
EventTriggerData *tdata;
HV *hv;
static HeapTuple
plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
{
+ dTHX;
SV **svp;
HV *hvNew;
HE *he;
perlret = plperl_call_perl_func(&desc, &fake_fcinfo);
- SvREFCNT_dec(perlret);
+ SvREFCNT_dec_current(perlret);
if (SPI_finish() != SPI_OK_FINISH)
elog(ERROR, "SPI_finish() failed");
PG_CATCH();
{
if (desc.reference)
- SvREFCNT_dec(desc.reference);
+ SvREFCNT_dec_current(desc.reference);
current_call_data = save_call_data;
activate_interpreter(oldinterp);
PG_RE_THROW();
PG_END_TRY();
if (desc.reference)
- SvREFCNT_dec(desc.reference);
+ SvREFCNT_dec_current(desc.reference);
current_call_data = save_call_data;
activate_interpreter(oldinterp);
static void
plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid)
{
+ dTHX;
dSP;
char subname[NAMEDATALEN + 40];
HV *pragma_hv = newHV();
static SV *
plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
{
+ dTHX;
dSP;
SV *retval;
int i;
plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
SV *td)
{
+ dTHX;
dSP;
SV *retval,
*TDsv;
FunctionCallInfo fcinfo,
SV *td)
{
+ dTHX;
dSP;
SV *retval,
*TDsv;
sav = get_perl_array_ref(perlret);
if (sav)
{
+ dTHX;
int i = 0;
SV **svp = 0;
AV *rav = (AV *) SvRV(sav);
while ((svp = av_fetch(rav, i, FALSE)) != NULL)
{
- plperl_return_next(*svp);
+ plperl_return_next_internal(*svp);
i++;
}
}
/* Restore the previous error callback */
error_context_stack = pl_error_context.previous;
- SvREFCNT_dec(perlret);
+ SvREFCNT_dec_current(perlret);
return retval;
}
/* Restore the previous error callback */
error_context_stack = pl_error_context.previous;
- SvREFCNT_dec(svTD);
+ SvREFCNT_dec_current(svTD);
if (perlret)
- SvREFCNT_dec(perlret);
+ SvREFCNT_dec_current(perlret);
return retval;
}
/* Restore the previous error callback */
error_context_stack = pl_error_context.previous;
- SvREFCNT_dec(svTD);
-
- return;
+ SvREFCNT_dec_current(svTD);
}
plperl_interp_desc *oldinterp = plperl_active_interp;
activate_interpreter(prodesc->interp);
- SvREFCNT_dec(prodesc->reference);
+ SvREFCNT_dec_current(prodesc->reference);
activate_interpreter(oldinterp);
}
/* Release all PG-owned data for this proc */
static SV *
plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
{
+ dTHX;
HV *hv;
int i;
plperl_spi_execute_fetch_result(SPITupleTable *tuptable, uint64 processed,
int status)
{
+ dTHX;
HV *result;
check_spi_usage_allowed();
/*
- * Note: plperl_return_next is called both in Postgres and Perl contexts.
- * We report any errors in Postgres fashion (via ereport). If called in
- * Perl context, it is SPI.xs's responsibility to catch the error and
- * convert to a Perl error. We assume (perhaps without adequate justification)
- * that we need not abort the current transaction if the Perl code traps the
- * error.
+ * plperl_return_next catches any error and converts it to a Perl error.
+ * We assume (perhaps without adequate justification) that we need not abort
+ * the current transaction if the Perl code traps the error.
*/
void
plperl_return_next(SV *sv)
+{
+ MemoryContext oldcontext = CurrentMemoryContext;
+
+ PG_TRY();
+ {
+ plperl_return_next_internal(sv);
+ }
+ PG_CATCH();
+ {
+ ErrorData *edata;
+
+ /* Must reset elog.c's state */
+ MemoryContextSwitchTo(oldcontext);
+ edata = CopyErrorData();
+ FlushErrorState();
+
+ /* Punt the error to Perl */
+ croak_cstr(edata->message);
+ }
+ PG_END_TRY();
+}
+
+/*
+ * plperl_return_next_internal reports any errors in Postgres fashion
+ * (via ereport).
+ */
+static void
+plperl_return_next_internal(SV *sv)
{
plperl_proc_desc *prodesc;
FunctionCallInfo fcinfo;
PG_TRY();
{
+ dTHX;
Portal p = SPI_cursor_find(cursor);
if (!p)
PG_TRY();
{
+ dTHX;
+
/************************************************************
* Fetch the saved plan descriptor, see if it's o.k.
************************************************************/
SPI_freeplan(plan);
}
+/*
+ * Implementation of plperl's elog() function
+ *
+ * If the error level is less than ERROR, we'll just emit the message and
+ * return. When it is ERROR, elog() will longjmp, which we catch and
+ * turn into a Perl croak(). Note we are assuming that elog() can't have
+ * any internal failures that are so bad as to require a transaction abort.
+ *
+ * The main reason this is out-of-line is to avoid conflicts between XSUB.h
+ * and the PG_TRY macros.
+ */
+void
+plperl_util_elog(int level, SV *msg)
+{
+ MemoryContext oldcontext = CurrentMemoryContext;
+ char *volatile cmsg = NULL;
+
+ PG_TRY();
+ {
+ cmsg = sv2cstr(msg);
+ elog(level, "%s", cmsg);
+ pfree(cmsg);
+ }
+ PG_CATCH();
+ {
+ ErrorData *edata;
+
+ /* Must reset elog.c's state */
+ MemoryContextSwitchTo(oldcontext);
+ edata = CopyErrorData();
+ FlushErrorState();
+
+ if (cmsg)
+ pfree(cmsg);
+
+ /* Punt the error to Perl */
+ croak_cstr(edata->message);
+ }
+ PG_END_TRY();
+}
+
/*
* Store an SV into a hash table under a key that is a string assumed to be
* in the current database's encoding.
static SV **
hv_store_string(HV *hv, const char *key, SV *val)
{
+ dTHX;
int32 hlen;
char *hkey;
SV **ret;
static SV **
hv_fetch_string(HV *hv, const char *key)
{
+ dTHX;
int32 hlen;
char *hkey;
SV **ret;
static char *
setlocale_perl(int category, char *locale)
{
+ dTHX;
char *RETVAL = setlocale(category, locale);
if (RETVAL)
return RETVAL;
}
-#endif
+#endif /* WIN32 */
projects / postgresql / commitdiff