database/postgres
1
0
Fork 0
mirror of https://github.com/postgres/postgres.git synced 2025-06-27 23:21:58 +03:00
Code Activity

PL/Perl portability fix: avoid including XSUB.h in plperl.c.

Browse Source 
Back-patch of commit bebe174bb4,
which see for more info.

Patch by me, with some help from Ashutosh Sharma

Discussion: https://postgr.es/m/CANFyU97OVQ3+Mzfmt3MhuUm5NwPU=-FtbNH5Eb7nZL9ua8=rcA@mail.gmail.com
This commit is contained in:
Tom Lane
2017-07-31 12:10:36 -04:00
parent 7b38063603
commit b4b958251f
5 changed files with 205 additions and 130 deletions
Download Patch File Download Diff File Expand all files Collapse all files

32
src/pl/plperl/SPI.xs
View File

@ -9,44 +9,16 @@
/* this must be first: */
#include "postgres.h"
#include "mb/pg_wchar.h" /* for GetDatabaseEncoding */
/* Defined by Perl */
#undef _
/* perl stuff */
#define PG_NEED_PERL_XSUB_H
#include "plperl.h"
#include "plperl_helpers.h"
/*
* Interface routine to catch ereports and punt them to Perl
*/
static void
do_plperl_return_next(SV *sv)
{
MemoryContext oldcontext = CurrentMemoryContext;
PG_TRY();
{
plperl_return_next(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();
}
MODULE = PostgreSQL::InServer::SPI PREFIX = spi_
PROTOTYPES: ENABLE
@ -76,7 +48,7 @@ void
spi_return_next(rv)
SV *rv;
CODE:
do_plperl_return_next(rv);
plperl_return_next(rv);
SV *
spi_spi_query(sv)

44
src/pl/plperl/Util.xs
View File

@ -15,53 +15,15 @@
#include "fmgr.h"
#include "utils/builtins.h"
#include "utils/bytea.h" /* for byteain & byteaout */
#include "mb/pg_wchar.h" /* for GetDatabaseEncoding */
/* Defined by Perl */
#undef _
/* perl stuff */
#define PG_NEED_PERL_XSUB_H
#include "plperl.h"
#include "plperl_helpers.h"
/*
* 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.
*
* This is out-of-line to suppress "might be clobbered by longjmp" warnings.
*/
static void
do_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();
}
static text *
sv2text(SV *sv)
@ -105,7 +67,7 @@ util_elog(level, msg)
level = ERROR;
if (level < DEBUG5)
level = DEBUG5;
do_util_elog(level, msg);
plperl_util_elog(level, msg);
SV *
util_quote_literal(sv)

236
src/pl/plperl/plperl.c
View File

@ -6,6 +6,7 @@
**********************************************************************/
#include "postgres.h"
/* Defined by Perl */
#undef _
@ -281,6 +282,7 @@ 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 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);
@ -298,14 +300,29 @@ static void activate_interpreter(plperl_interp_desc *interp_desc);
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)
{
char *ret;
SV *sv;
dTHX;
char *ret;
SV *sv;
/*
* HeSVKEY_force will return a temporary mortal SV*, so we need to make
@ -655,14 +672,18 @@ select_perl_context(bool trusted)
* 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,
(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,
(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;
@ -805,51 +826,60 @@ plperl_init_interp(void)
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,
(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,
(errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
errcontext("while parsing Perl initialization")));
if (perl_run(plperl) != 0)
ereport(ERROR,
(errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
errcontext("while running Perl initialization")));
if (perl_run(plperl) != 0)
ereport(ERROR,
(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;
}
@ -906,6 +936,7 @@ plperl_destroy_interp(PerlInterpreter **interp)
* 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)
@ -932,6 +963,7 @@ plperl_destroy_interp(PerlInterpreter **interp)
static void
plperl_trusted_init(void)
{
dTHX;
HV *stash;
SV *sv;
char *key;
@ -1009,6 +1041,8 @@ plperl_trusted_init(void)
static void
plperl_untrusted_init(void)
{
dTHX;
/*
* Nothing to do except execute plperl.on_plperlu_init
*/
@ -1043,6 +1077,7 @@ strip_trailing_ws(const char *msg)
static HeapTuple
plperl_build_tuple_result(HV *perlhash, TupleDesc td)
{
dTHX;
Datum *values;
bool *nulls;
HE *he;
@ -1099,6 +1134,8 @@ plperl_hash_to_datum(SV *src, TupleDesc td)
static SV *
get_perl_array_ref(SV *sv)
{
dTHX;
if (SvOK(sv) && SvROK(sv))
{
if (SvTYPE(SvRV(sv)) == SVt_PVAV)
@ -1127,6 +1164,7 @@ array_to_datum_internal(AV *av, ArrayBuildState *astate,
Oid arraytypid, Oid elemtypid, int32 typmod,
FmgrInfo *finfo, Oid typioparam)
{
dTHX;
int i;
int len = av_len(av) + 1;
@ -1200,6 +1238,7 @@ array_to_datum_internal(AV *av, ArrayBuildState *astate,
static Datum
plperl_array_to_datum(SV *src, Oid typid, int32 typmod)
{
dTHX;
ArrayBuildState *astate;
Oid elemtypid;
FmgrInfo finfo;
@ -1394,6 +1433,7 @@ plperl_sv_to_literal(SV *sv, char *fqtypename)
static SV *
plperl_ref_from_pg_array(Datum arg, Oid typid)
{
dTHX;
ArrayType *ar = DatumGetArrayTypeP(arg);
Oid elementtype = ARR_ELEMTYPE(ar);
int16 typlen;
@ -1458,6 +1498,7 @@ plperl_ref_from_pg_array(Datum arg, Oid typid)
static SV *
split_array(plperl_array_info *info, int first, int last, int nest)
{
dTHX;
int i;
AV *result;
@ -1491,6 +1532,7 @@ split_array(plperl_array_info *info, int first, int last, int nest)
static SV *
make_array_ref(plperl_array_info *info, int first, int last)
{
dTHX;
int i;
AV *result = newAV();
@ -1526,6 +1568,7 @@ make_array_ref(plperl_array_info *info, int first, int last)
static SV *
plperl_trigger_build_args(FunctionCallInfo fcinfo)
{
dTHX;
TriggerData *tdata;
TupleDesc tupdesc;
int i;
@ -1633,6 +1676,7 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
static HeapTuple
plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
{
dTHX;
SV **svp;
HV *hvNew;
HE *he;
@ -1827,7 +1871,7 @@ plperl_inline_handler(PG_FUNCTION_ARGS)
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");
@ -1835,7 +1879,7 @@ plperl_inline_handler(PG_FUNCTION_ARGS)
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();
@ -1843,7 +1887,7 @@ plperl_inline_handler(PG_FUNCTION_ARGS)
PG_END_TRY();
if (desc.reference)
SvREFCNT_dec(desc.reference);
SvREFCNT_dec_current(desc.reference);
current_call_data = save_call_data;
activate_interpreter(oldinterp);
@ -1968,6 +2012,7 @@ plperlu_validator(PG_FUNCTION_ARGS)
static void
plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid)
{
dTHX;
dSP;
char subname[NAMEDATALEN + 40];
HV *pragma_hv = newHV();
@ -2053,6 +2098,7 @@ plperl_init_shared_libs(pTHX)
static SV *
plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
{
dTHX;
dSP;
SV *retval;
int i;
@ -2133,6 +2179,7 @@ static SV *
plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
SV *td)
{
dTHX;
dSP;
SV *retval,
*TDsv;
@ -2253,13 +2300,14 @@ plperl_func_handler(PG_FUNCTION_ARGS)
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++;
}
}
@ -2296,7 +2344,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
/* Restore the previous error callback */
error_context_stack = pl_error_context.previous;
SvREFCNT_dec(perlret);
SvREFCNT_dec_current(perlret);
return retval;
}
@ -2400,9 +2448,9 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
/* 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;
}
@ -2447,7 +2495,7 @@ free_plperl_function(plperl_proc_desc *prodesc)
plperl_interp_desc *oldinterp = plperl_active_interp;
activate_interpreter(prodesc->interp);
SvREFCNT_dec(prodesc->reference);
SvREFCNT_dec_current(prodesc->reference);
activate_interpreter(oldinterp);
}
/* Get rid of what we conveniently can of our own structs */
@ -2747,6 +2795,7 @@ plperl_hash_from_datum(Datum attr)
static SV *
plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
{
dTHX;
HV *hv;
int i;
@ -2902,6 +2951,7 @@ static HV *
plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
int status)
{
dTHX;
HV *result;
check_spi_usage_allowed();
@ -2937,15 +2987,40 @@ plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
/*
* 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;
@ -3151,6 +3226,7 @@ plperl_spi_fetchrow(char *cursor)
PG_TRY();
{
dTHX;
Portal p = SPI_cursor_find(cursor);
if (!p)
@ -3422,6 +3498,8 @@ plperl_spi_exec_prepared(char *query, HV *attr, int argc, SV **argv)
PG_TRY();
{
dTHX;
/************************************************************
* Fetch the saved plan descriptor, see if it's o.k.
************************************************************/
@ -3692,6 +3770,47 @@ plperl_spi_freeplan(char *query)
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.
@ -3699,6 +3818,7 @@ plperl_spi_freeplan(char *query)
static SV **
hv_store_string(HV *hv, const char *key, SV *val)
{
dTHX;
int32 hlen;
char *hkey;
SV **ret;
@ -3729,6 +3849,7 @@ hv_store_string(HV *hv, const char *key, SV *val)
static SV **
hv_fetch_string(HV *hv, const char *key)
{
dTHX;
int32 hlen;
char *hkey;
SV **ret;
@ -3789,6 +3910,7 @@ plperl_inline_callback(void *arg)
static char *
setlocale_perl(int category, char *locale)
{
dTHX;
char *RETVAL = setlocale(category, locale);
if (RETVAL)
@ -3853,4 +3975,4 @@ setlocale_perl(int category, char *locale)
return RETVAL;
}
#endif
#endif /* WIN32 */

17
src/pl/plperl/plperl.h
View File

@ -24,7 +24,7 @@
#ifdef isnan
#undef isnan
#endif
#endif
#endif /* WIN32 */
/*
* Supply a value of PERL_UNUSED_DECL that will satisfy gcc - the one
@ -45,10 +45,22 @@
#endif
/* required for perl API */
/*
* Get the basic Perl API. We use PERL_NO_GET_CONTEXT mode so that our code
* can compile against MULTIPLICITY Perl builds without including XSUB.h.
*/
#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
/*
* We want to include XSUB.h only within .xs files, because on some platforms
* it undesirably redefines a lot of libc functions. But it must appear
* before ppport.h, so use a #define flag to control inclusion here.
*/
#ifdef PG_NEED_PERL_XSUB_H
#include "XSUB.h"
#endif
/* put back our snprintf and vsnprintf */
#ifdef USE_REPL_SNPRINTF
@ -101,6 +113,7 @@ SV *plperl_spi_query_prepared(char *, int, SV **);
void plperl_spi_freeplan(char *);
void plperl_spi_cursor_close(char *);
char *plperl_sv_to_literal(SV *, char *);
void plperl_util_elog(int level, SV *msg);

6
src/pl/plperl/plperl_helpers.h
View File

@ -1,6 +1,8 @@
#ifndef PL_PERL_HELPERS_H
#define PL_PERL_HELPERS_H
#include "mb/pg_wchar.h"
/*
* convert from utf8 to database encoding
*
@ -59,6 +61,7 @@ utf_e2u(const char *str)
static inline char *
sv2cstr(SV *sv)
{
dTHX;
char *val,
*res;
STRLEN len;
@ -116,6 +119,7 @@ sv2cstr(SV *sv)
static inline SV *
cstr2sv(const char *str)
{
dTHX;
SV *sv;
char *utf8_str;
@ -143,6 +147,8 @@ cstr2sv(const char *str)
static inline void
croak_cstr(const char *str)
{
dTHX;
#ifdef croak_sv
/* Use sv_2mortal() to be sure the transient SV gets freed */
croak_sv(sv_2mortal(cstr2sv(str)));