* IDENTIFICATION
*
* This software is copyrighted by Mark Hollomon
- * but is shameless cribbed from pltcl.c by Jan Wieck.
+ * but is shamelessly cribbed from pltcl.c by Jan Wieck.
*
* The author hereby grants permission to use, copy, modify,
* distribute, and license this software and its documentation
* ENHANCEMENTS, OR MODIFICATIONS.
*
* IDENTIFICATION
- * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.95 2005/11/18 17:00:28 adunstan Exp $
+ * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.103 2006/02/28 23:38:13 neilc Exp $
*
**********************************************************************/
#include <ctype.h>
#include <fcntl.h>
#include <unistd.h>
+#include <locale.h>
/* postgreSQL stuff */
#include "commands/trigger.h"
#include "miscadmin.h"
#include "mb/pg_wchar.h"
-/* perl stuff */
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-#include "ppport.h"
-#include "spi_internal.h"
-
-/* just in case these symbols aren't provided */
-#ifndef pTHX_
-#define pTHX_
-#define pTHX void
-#endif
+/* define this before the perl headers get a chance to mangle DLLIMPORT */
+extern DLLIMPORT bool check_function_bodies;
+/* perl stuff */
+#include "plperl.h"
/**********************************************************************
* The information we cache about loaded procedures
FmgrInfo arg_out_func[FUNC_MAX_ARGS];
bool arg_is_rowtype[FUNC_MAX_ARGS];
SV *reference;
-} plperl_proc_desc;
+} plperl_proc_desc;
+
+/*
+ * The information we cache for the duration of a single call to a
+ * function.
+ */
+typedef struct plperl_call_data
+{
+ plperl_proc_desc *prodesc;
+ FunctionCallInfo fcinfo;
+ Tuplestorestate *tuple_store;
+ TupleDesc ret_tdesc;
+ AttInMetadata *attinmeta;
+ MemoryContext tmp_cxt;
+} plperl_call_data;
/**********************************************************************
* Global data
**********************************************************************/
-static int plperl_firstcall = 1;
+static bool plperl_firstcall = true;
static bool plperl_safe_init_done = false;
static PerlInterpreter *plperl_interp = NULL;
static HV *plperl_proc_hash = NULL;
static bool plperl_use_strict = false;
-/* these are saved and restored by plperl_call_handler */
-static plperl_proc_desc *plperl_current_prodesc = NULL;
-static FunctionCallInfo plperl_current_caller_info;
-static Tuplestorestate *plperl_current_tuple_store;
-static TupleDesc plperl_current_tuple_desc;
+/* this is saved and restored by plperl_call_handler */
+static plperl_call_data *current_call_data = NULL;
/**********************************************************************
* Forward declarations
EmitWarningsOnPlaceholders("plperl");
plperl_init_interp();
- plperl_firstcall = 0;
+ plperl_firstcall = false;
}
"", "-e", PERLBOOT
};
+#ifdef WIN32
+
+ /*
+ * The perl library on startup does horrible things like call
+ * setlocale(LC_ALL,""). We have protected against that on most
+ * platforms by setting the environment appropriately. However, on
+ * Windows, setlocale() does not consult the environment, so we need
+ * to save the existing locale settings before perl has a chance to
+ * mangle them and restore them after its dirty deeds are done.
+ *
+ * MSDN ref:
+ * http://msdn.microsoft.com/library/en-us/vclib/html/_crt_locale.asp
+ *
+ * It appears that we only need to do this on interpreter startup, and
+ * subsequent calls to the interpreter don't mess with the locale
+ * settings.
+ *
+ * We restore them using Perl's POSIX::setlocale() function so that
+ * Perl doesn't have a different idea of the locale from Postgres.
+ *
+ */
+
+ char *loc;
+ char *save_collate, *save_ctype, *save_monetary, *save_numeric, *save_time;
+ char buf[1024];
+
+ loc = setlocale(LC_COLLATE,NULL);
+ save_collate = loc ? pstrdup(loc) : NULL;
+ loc = setlocale(LC_CTYPE,NULL);
+ save_ctype = loc ? pstrdup(loc) : NULL;
+ loc = setlocale(LC_MONETARY,NULL);
+ save_monetary = loc ? pstrdup(loc) : NULL;
+ loc = setlocale(LC_NUMERIC,NULL);
+ save_numeric = loc ? pstrdup(loc) : NULL;
+ loc = setlocale(LC_TIME,NULL);
+ save_time = loc ? pstrdup(loc) : NULL;
+
+#endif
+
plperl_interp = perl_alloc();
if (!plperl_interp)
elog(ERROR, "could not allocate Perl interpreter");
perl_run(plperl_interp);
plperl_proc_hash = newHV();
+
+#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);
+ }
+
+#endif
+
}
plperl_safe_init_done = true;
}
-
/*
* Perl likes to put a newline after its error messages; clean up such
*/
/* Build a tuple from a hash. */
static HeapTuple
-plperl_build_tuple_result(HV * perlhash, AttInMetadata *attinmeta)
+plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
{
TupleDesc td = attinmeta->tupdesc;
char **values;
* convert perl array to postgres string representation
*/
static SV *
-plperl_convert_to_pg_array(SV * src)
+plperl_convert_to_pg_array(SV *src)
{
SV *rv;
int count;
/* Set up the new tuple returned from a trigger. */
static HeapTuple
-plperl_modify_tuple(HV * hvTD, TriggerData *tdata, HeapTuple otup)
+plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
{
SV **svp;
HV *hvNew;
plperl_call_handler(PG_FUNCTION_ARGS)
{
Datum retval;
- plperl_proc_desc *save_prodesc;
- FunctionCallInfo save_caller_info;
- Tuplestorestate *save_tuple_store;
- TupleDesc save_tuple_desc;
+ plperl_call_data *save_call_data;
plperl_init_all();
- save_prodesc = plperl_current_prodesc;
- save_caller_info = plperl_current_caller_info;
- save_tuple_store = plperl_current_tuple_store;
- save_tuple_desc = plperl_current_tuple_desc;
-
+ save_call_data = current_call_data;
PG_TRY();
{
if (CALLED_AS_TRIGGER(fcinfo))
}
PG_CATCH();
{
- plperl_current_prodesc = save_prodesc;
- plperl_current_caller_info = save_caller_info;
- plperl_current_tuple_store = save_tuple_store;
- plperl_current_tuple_desc = save_tuple_desc;
+ current_call_data = save_call_data;
PG_RE_THROW();
}
PG_END_TRY();
- plperl_current_prodesc = save_prodesc;
- plperl_current_caller_info = save_caller_info;
- plperl_current_tuple_store = save_tuple_store;
- plperl_current_tuple_desc = save_tuple_desc;
-
+ current_call_data = save_call_data;
return retval;
}
Oid funcoid = PG_GETARG_OID(0);
HeapTuple tuple;
Form_pg_proc proc;
+ char functyptype;
+ int numargs;
+ Oid *argtypes;
+ char **argnames;
+ char *argmodes;
bool istrigger = false;
- plperl_proc_desc *prodesc;
-
- plperl_init_all();
+ int i;
/* Get the new function's pg_proc entry */
tuple = SearchSysCache(PROCOID,
elog(ERROR, "cache lookup failed for function %u", funcoid);
proc = (Form_pg_proc) GETSTRUCT(tuple);
- /* we assume OPAQUE with no arguments means a trigger */
- if (proc->prorettype == TRIGGEROID ||
- (proc->prorettype == OPAQUEOID && proc->pronargs == 0))
- istrigger = true;
+ functyptype = get_typtype(proc->prorettype);
+
+ /* Disallow pseudotype result */
+ /* except for TRIGGER, RECORD, or VOID */
+ if (functyptype == 'p')
+ {
+ /* we assume OPAQUE with no arguments means a trigger */
+ if (proc->prorettype == TRIGGEROID ||
+ (proc->prorettype == OPAQUEOID && proc->pronargs == 0))
+ istrigger = true;
+ else if (proc->prorettype != RECORDOID &&
+ proc->prorettype != VOIDOID)
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("plperl functions cannot return type %s",
+ format_type_be(proc->prorettype))));
+ }
+
+ /* Disallow pseudotypes in arguments (either IN or OUT) */
+ numargs = get_func_arg_info(tuple,
+ &argtypes, &argnames, &argmodes);
+ for (i = 0; i < numargs; i++)
+ {
+ if (get_typtype(argtypes[i]) == 'p')
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("plperl functions cannot take type %s",
+ format_type_be(argtypes[i]))));
+ }
ReleaseSysCache(tuple);
- prodesc = compile_plperl_function(funcoid, istrigger);
+ /* Postpone body checks if !check_function_bodies */
+ if (check_function_bodies)
+ {
+ plperl_proc_desc *prodesc;
+
+ plperl_init_all();
+
+ prodesc = compile_plperl_function(funcoid, istrigger);
+ }
/* the result of a validator is ignored */
PG_RETURN_VOID();
*
**********************************************************************/
-EXTERN_C void boot_DynaLoader(pTHX_ CV * cv);
-EXTERN_C void boot_SPI(pTHX_ CV * cv);
+EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
+EXTERN_C void boot_SPI(pTHX_ CV *cv);
static void
plperl_init_shared_libs(pTHX)
static SV *
-plperl_call_perl_func(plperl_proc_desc * desc, FunctionCallInfo fcinfo)
+plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
{
dSP;
SV *retval;
static SV *
-plperl_call_perl_trigger_func(plperl_proc_desc * desc, FunctionCallInfo fcinfo,
- SV * td)
+plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
+ SV *td)
{
dSP;
SV *retval;
ReturnSetInfo *rsi;
SV *array_ret = NULL;
+ /*
+ * Create the call_data beforing connecting to SPI, so that it is
+ * not allocated in the SPI memory context
+ */
+ current_call_data = (plperl_call_data *) palloc0(sizeof(plperl_call_data));
+ current_call_data->fcinfo = fcinfo;
+
if (SPI_connect() != SPI_OK_CONNECT)
elog(ERROR, "could not connect to SPI manager");
prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
-
- plperl_current_prodesc = prodesc;
- plperl_current_caller_info = fcinfo;
- plperl_current_tuple_store = 0;
- plperl_current_tuple_desc = 0;
+ current_call_data->prodesc = prodesc;
rsi = (ReturnSetInfo *) fcinfo->resultinfo;
}
rsi->returnMode = SFRM_Materialize;
- if (plperl_current_tuple_store)
+ if (current_call_data->tuple_store)
{
- rsi->setResult = plperl_current_tuple_store;
- rsi->setDesc = plperl_current_tuple_desc;
+ rsi->setResult = current_call_data->tuple_store;
+ rsi->setDesc = current_call_data->ret_tdesc;
}
retval = (Datum) 0;
}
if (array_ret == NULL)
SvREFCNT_dec(perlret);
+ current_call_data = NULL;
return retval;
}
SV *svTD;
HV *hvTD;
+ /*
+ * Create the call_data beforing connecting to SPI, so that it is
+ * not allocated in the SPI memory context
+ */
+ current_call_data = (plperl_call_data *) palloc0(sizeof(plperl_call_data));
+ current_call_data->fcinfo = fcinfo;
+
/* Connect to SPI manager */
if (SPI_connect() != SPI_OK_CONNECT)
elog(ERROR, "could not connect to SPI manager");
/* Find or compile the function */
prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true);
-
- plperl_current_prodesc = prodesc;
+ current_call_data->prodesc = prodesc;
svTD = plperl_trigger_build_args(fcinfo);
perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
if (perlret)
SvREFCNT_dec(perlret);
+ current_call_data = NULL;
return retval;
}
procStruct = (Form_pg_proc) GETSTRUCT(procTup);
/************************************************************
- * Build our internal proc name from the functions Oid
+ * Build our internal proc name from the function's Oid
************************************************************/
if (!is_trigger)
sprintf(internal_proname, "__PLPerl_proc_%u", fn_oid);
/************************************************************
* If we haven't found it in the hashtable, we analyze
- * the functions arguments and returntype and store
+ * the function's arguments and return type and store
* the in-/out-functions in the prodesc block and create
* a new hashtable entry for it.
*
{
int spi_rv;
- spi_rv = SPI_execute(query, plperl_current_prodesc->fn_readonly,
+ spi_rv = SPI_execute(query, current_call_data->prodesc->fn_readonly,
limit);
ret_hv = plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed,
spi_rv);
/*
* Note: plperl_return_next is called both in Postgres and Perl contexts.
- * We report any errors in Postgres fashion (via ereport). If called in
+ * 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
void
plperl_return_next(SV *sv)
{
- plperl_proc_desc *prodesc = plperl_current_prodesc;
- FunctionCallInfo fcinfo = plperl_current_caller_info;
- ReturnSetInfo *rsi = (ReturnSetInfo *) fcinfo->resultinfo;
- MemoryContext cxt;
+ plperl_proc_desc *prodesc;
+ FunctionCallInfo fcinfo;
+ ReturnSetInfo *rsi;
+ MemoryContext old_cxt;
HeapTuple tuple;
- TupleDesc tupdesc;
if (!sv)
return;
+ prodesc = current_call_data->prodesc;
+ fcinfo = current_call_data->fcinfo;
+ rsi = (ReturnSetInfo *) fcinfo->resultinfo;
+
if (!prodesc->fn_retisset)
ereport(ERROR,
(errcode(ERRCODE_SYNTAX_ERROR),
errmsg("setof-composite-returning Perl function "
"must call return_next with reference to hash")));
- cxt = MemoryContextSwitchTo(rsi->econtext->ecxt_per_query_memory);
+ if (!current_call_data->ret_tdesc)
+ {
+ TupleDesc tupdesc;
+
+ Assert(!current_call_data->tuple_store);
+ Assert(!current_call_data->attinmeta);
+
+ /*
+ * This is the first call to return_next in the current
+ * PL/Perl function call, so memoize some lookups
+ */
+ if (prodesc->fn_retistuple)
+ (void) get_call_result_type(fcinfo, NULL, &tupdesc);
+ else
+ tupdesc = rsi->expectedDesc;
+
+ /*
+ * Make sure the tuple_store and ret_tdesc are sufficiently
+ * long-lived.
+ */
+ old_cxt = MemoryContextSwitchTo(rsi->econtext->ecxt_per_query_memory);
- if (!plperl_current_tuple_store)
- plperl_current_tuple_store =
+ current_call_data->ret_tdesc = CreateTupleDescCopy(tupdesc);
+ current_call_data->tuple_store =
tuplestore_begin_heap(true, false, work_mem);
+ if (prodesc->fn_retistuple)
+ {
+ current_call_data->attinmeta =
+ TupleDescGetAttInMetadata(current_call_data->ret_tdesc);
+ }
- if (prodesc->fn_retistuple)
+ MemoryContextSwitchTo(old_cxt);
+ }
+
+ /*
+ * Producing the tuple we want to return requires making plenty of
+ * palloc() allocations that are not cleaned up. Since this
+ * function can be called many times before the current memory
+ * context is reset, we need to do those allocations in a
+ * temporary context.
+ */
+ if (!current_call_data->tmp_cxt)
{
- TypeFuncClass rettype;
- AttInMetadata *attinmeta;
+ current_call_data->tmp_cxt =
+ AllocSetContextCreate(rsi->econtext->ecxt_per_tuple_memory,
+ "PL/Perl return_next temporary cxt",
+ ALLOCSET_DEFAULT_MINSIZE,
+ ALLOCSET_DEFAULT_INITSIZE,
+ ALLOCSET_DEFAULT_MAXSIZE);
+ }
+
+ old_cxt = MemoryContextSwitchTo(current_call_data->tmp_cxt);
- rettype = get_call_result_type(fcinfo, NULL, &tupdesc);
- tupdesc = CreateTupleDescCopy(tupdesc);
- attinmeta = TupleDescGetAttInMetadata(tupdesc);
- tuple = plperl_build_tuple_result((HV *) SvRV(sv), attinmeta);
+ if (prodesc->fn_retistuple)
+ {
+ tuple = plperl_build_tuple_result((HV *) SvRV(sv),
+ current_call_data->attinmeta);
}
else
{
- Datum ret;
- bool isNull;
-
- tupdesc = CreateTupleDescCopy(rsi->expectedDesc);
+ Datum ret = (Datum) 0;
+ bool isNull = true;
if (SvOK(sv) && SvTYPE(sv) != SVt_NULL)
{
Int32GetDatum(-1));
isNull = false;
}
- else
- {
- ret = (Datum) 0;
- isNull = true;
- }
- tuple = heap_form_tuple(tupdesc, &ret, &isNull);
+ tuple = heap_form_tuple(current_call_data->ret_tdesc, &ret, &isNull);
}
- if (!plperl_current_tuple_desc)
- plperl_current_tuple_desc = tupdesc;
+ /* Make sure to store the tuple in a long-lived memory context */
+ MemoryContextSwitchTo(rsi->econtext->ecxt_per_query_memory);
+ tuplestore_puttuple(current_call_data->tuple_store, tuple);
+ MemoryContextSwitchTo(old_cxt);
- tuplestore_puttuple(plperl_current_tuple_store, tuple);
- heap_freetuple(tuple);
- MemoryContextSwitchTo(cxt);
+ MemoryContextReset(current_call_data->tmp_cxt);
}
projects / postgresql / blobdiff