Andrew Dunstan wrote:
> I will do some checking on these changes, but with those caveats they look
> good to me.
Attached is an all inclusive revised patch. Please review and comment.
If there are no objections, I'll commit in a few hours.
As a side note, I think it would be *really* helpful if there were a
more comprehensive test script, and an expected results file available.
Not sure though if it could be included in the standard regression tests
on a configure-conditional basis -- anyone know?
Joe
Index: src/pl/plperl/GNUmakefile
===================================================================
RCS file: /cvsroot/pgsql-server/src/pl/plperl/GNUmakefile,v
retrieving revision 1.12
diff -c -r1.12 GNUmakefile
*** src/pl/plperl/GNUmakefile 21 Jan 2004 19:04:11 -0000 1.12
--- src/pl/plperl/GNUmakefile 1 Jul 2004 16:24:53 -0000
***************
*** 25,32 ****
SO_MAJOR_VERSION = 0
SO_MINOR_VERSION = 0
! OBJS = plperl.o eloglvl.o SPI.o
SHLIB_LINK = $(perl_embed_ldflags) $(BE_DLLLIBS)
include $(top_srcdir)/src/Makefile.shlib
--- 25,37 ----
SO_MAJOR_VERSION = 0
SO_MINOR_VERSION = 0
! OBJS = plperl.o spi_internal.o SPI.o
!
! ifeq ($(enable_rpath), yes)
SHLIB_LINK = $(perl_embed_ldflags) $(BE_DLLLIBS)
+ else
+ SHLIB_LINK = $(perl_embed_ldflags) $(BE_DLLLIBS) -Wl,-rpath,$(perl_archlibexp)/CORE
+ endif
include $(top_srcdir)/src/Makefile.shlib
Index: src/pl/plperl/SPI.xs
===================================================================
RCS file: /cvsroot/pgsql-server/src/pl/plperl/SPI.xs,v
retrieving revision 1.5
diff -c -r1.5 SPI.xs
*** src/pl/plperl/SPI.xs 4 Sep 2002 22:49:37 -0000 1.5
--- src/pl/plperl/SPI.xs 1 Jul 2004 16:24:53 -0000
***************
*** 6,22 ****
#include "perl.h"
#include "XSUB.h"
! #include "eloglvl.h"
! MODULE = SPI PREFIX = elog_
PROTOTYPES: ENABLE
VERSIONCHECK: DISABLE
void
! elog_elog(level, message)
int level
char* message
CODE:
--- 6,22 ----
#include "perl.h"
#include "XSUB.h"
! #include "spi_internal.h"
! MODULE = SPI PREFIX = spi_
PROTOTYPES: ENABLE
VERSIONCHECK: DISABLE
void
! spi_elog(level, message)
int level
char* message
CODE:
***************
*** 24,44 ****
int
! elog_DEBUG()
int
! elog_LOG()
int
! elog_INFO()
int
! elog_NOTICE()
int
! elog_WARNING()
int
! elog_ERROR()
!
--- 24,56 ----
int
! spi_DEBUG()
int
! spi_LOG()
int
! spi_INFO()
int
! spi_NOTICE()
int
! spi_WARNING()
int
! spi_ERROR()
+ SV*
+ spi_spi_exec_query(query, ...)
+ char* query;
+ PREINIT:
+ HV *ret_hash;
+ int limit=0;
+ CODE:
+ if (items>2) Perl_croak(aTHX_ "Usage: spi_exec_query(query, limit) or spi_exec_query(query)");
+ if (items == 2) limit = SvIV(ST(1));
+ ret_hash=plperl_spi_exec(query, limit);
+ RETVAL = newRV_noinc((SV*)ret_hash);
+ OUTPUT:
+ RETVAL
Index: src/pl/plperl/eloglvl.c
===================================================================
RCS file: src/pl/plperl/eloglvl.c
diff -N src/pl/plperl/eloglvl.c
*** src/pl/plperl/eloglvl.c 25 Jul 2003 23:37:28 -0000 1.9
--- /dev/null 1 Jan 1970 00:00:00 -0000
***************
*** 1,45 ****
- #include "postgres.h"
-
- /*
- * This kludge is necessary because of the conflicting
- * definitions of 'DEBUG' between postgres and perl.
- * we'll live.
- */
-
- #include "eloglvl.h"
-
- int
- elog_DEBUG(void)
- {
- return DEBUG2;
- }
-
- int
- elog_LOG(void)
- {
- return LOG;
- }
-
- int
- elog_INFO(void)
- {
- return INFO;
- }
-
- int
- elog_NOTICE(void)
- {
- return NOTICE;
- }
-
- int
- elog_WARNING(void)
- {
- return WARNING;
- }
-
- int
- elog_ERROR(void)
- {
- return ERROR;
- }
--- 0 ----
Index: src/pl/plperl/eloglvl.h
===================================================================
RCS file: src/pl/plperl/eloglvl.h
diff -N src/pl/plperl/eloglvl.h
*** src/pl/plperl/eloglvl.h 4 Sep 2002 20:31:47 -0000 1.5
--- /dev/null 1 Jan 1970 00:00:00 -0000
***************
*** 1,12 ****
-
- int elog_DEBUG(void);
-
- int elog_LOG(void);
-
- int elog_INFO(void);
-
- int elog_NOTICE(void);
-
- int elog_WARNING(void);
-
- int elog_ERROR(void);
--- 0 ----
Index: src/pl/plperl/plperl.c
===================================================================
RCS file: /cvsroot/pgsql-server/src/pl/plperl/plperl.c,v
retrieving revision 1.44
diff -c -r1.44 plperl.c
*** src/pl/plperl/plperl.c 6 Jun 2004 00:41:28 -0000 1.44
--- src/pl/plperl/plperl.c 1 Jul 2004 16:24:53 -0000
***************
*** 49,54 ****
--- 49,55 ----
#include "catalog/pg_language.h"
#include "catalog/pg_proc.h"
#include "catalog/pg_type.h"
+ #include "funcapi.h" /* need for SRF support */
#include "commands/trigger.h"
#include "executor/spi.h"
#include "fmgr.h"
***************
*** 78,83 ****
--- 79,86 ----
TransactionId fn_xmin;
CommandId fn_cmin;
bool lanpltrusted;
+ bool fn_retistuple; /* true, if function returns tuple */
+ Oid ret_oid; /* Oid of returning type */
FmgrInfo result_in_func;
Oid result_typioparam;
int nargs;
***************
*** 94,99 ****
--- 97,105 ----
static int plperl_firstcall = 1;
static PerlInterpreter *plperl_interp = NULL;
static HV *plperl_proc_hash = NULL;
+ AV *g_row_keys = NULL;
+ AV *g_column_keys = NULL;
+ int g_attr_num = 0;
/**********************************************************************
* Forward declarations
***************
*** 106,111 ****
--- 112,118 ----
static Datum plperl_func_handler(PG_FUNCTION_ARGS);
+ static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
static plperl_proc_desc *compile_plperl_function(Oid fn_oid, bool is_trigger);
static SV *plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc);
***************
*** 205,218 ****
"", "-e",
/*
! * no commas between the next 5 please. They are supposed to be
* one string
*/
! "require Safe; SPI::bootstrap();"
! "sub ::mksafefunc { my $x = new Safe; $x->permit_only(':default');$x->permit(':base_math');"
! "$x->share(qw[&elog &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR]);"
! " return $x->reval(qq[sub { $_[0] }]); }"
! "sub ::mkunsafefunc {return eval(qq[ sub { $_[0] } ]); }"
};
plperl_interp = perl_alloc();
--- 212,226 ----
"", "-e",
/*
! * no commas between the next lines please. They are supposed to be
* one string
*/
! "require Safe; SPI::bootstrap(); use vars qw(%_SHARED);"
! "use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');"
! "$PLContainer->permit_only(':default');$PLContainer->permit(':base_math');"
! "$PLContainer->share(qw[&elog &spi_exec_query &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %SHARED ]);"
! "sub ::mksafefunc { return $PLContainer->reval(qq[sub { $_[0] $_[1]}]); }"
! "sub ::mkunsafefunc {return eval(qq[ sub { $_[0] $_[1] } ]); }"
};
plperl_interp = perl_alloc();
***************
*** 230,235 ****
--- 238,549 ----
}
+ /**********************************************************************
+ * turn a tuple into a hash expression and add it to a list
+ **********************************************************************/
+ static void
+ plperl_sv_add_tuple_value(SV * rv, HeapTuple tuple, TupleDesc tupdesc)
+ {
+ int i;
+ char *value;
+ char *key;
+
+ sv_catpvf(rv, "{ ");
+
+ for (i = 0; i < tupdesc->natts; i++)
+ {
+ key = SPI_fname(tupdesc, i + 1);
+ value = SPI_getvalue(tuple, tupdesc, i + 1);
+ if (value)
+ sv_catpvf(rv, "%s => '%s'", key, value);
+ else
+ sv_catpvf(rv, "%s => undef", key);
+ if (i != tupdesc->natts - 1)
+ sv_catpvf(rv, ", ");
+ }
+
+ sv_catpvf(rv, " }");
+ }
+
+ /**********************************************************************
+ * set up arguments for a trigger call
+ **********************************************************************/
+ static SV *
+ plperl_trigger_build_args(FunctionCallInfo fcinfo)
+ {
+ TriggerData *tdata;
+ TupleDesc tupdesc;
+ int i = 0;
+ SV *rv;
+
+ rv = newSVpv("{ ", 0);
+
+ tdata = (TriggerData *) fcinfo->context;
+
+ tupdesc = tdata->tg_relation->rd_att;
+
+ sv_catpvf(rv, "name => '%s'", tdata->tg_trigger->tgname);
+ sv_catpvf(rv, ", relid => '%s'", DatumGetCString(DirectFunctionCall1(oidout,
ObjectIdGetDatum(tdata->tg_relation->rd_id))));
+
+ if (TRIGGER_FIRED_BY_INSERT(tdata->tg_event))
+ {
+ sv_catpvf(rv, ", event => 'INSERT'");
+ sv_catpvf(rv, ", new =>");
+ plperl_sv_add_tuple_value(rv, tdata->tg_trigtuple, tupdesc);
+ }
+ else if (TRIGGER_FIRED_BY_DELETE(tdata->tg_event))
+ {
+ sv_catpvf(rv, ", event => 'DELETE'");
+ sv_catpvf(rv, ", old => ");
+ plperl_sv_add_tuple_value(rv, tdata->tg_trigtuple, tupdesc);
+ }
+ else if (TRIGGER_FIRED_BY_UPDATE(tdata->tg_event))
+ {
+ sv_catpvf(rv, ", event => 'UPDATE'");
+
+ sv_catpvf(rv, ", new =>");
+ plperl_sv_add_tuple_value(rv, tdata->tg_newtuple, tupdesc);
+
+ sv_catpvf(rv, ", old => ");
+ plperl_sv_add_tuple_value(rv, tdata->tg_trigtuple, tupdesc);
+ }
+ else
+ sv_catpvf(rv, ", event => 'UNKNOWN'");
+
+ sv_catpvf(rv, ", argc => %d", tdata->tg_trigger->tgnargs);
+
+ if (tdata->tg_trigger->tgnargs != 0)
+ {
+ sv_catpvf(rv, ", args => [ ");
+ for (i = 0; i < tdata->tg_trigger->tgnargs; i++)
+ {
+ sv_catpvf(rv, "%s", tdata->tg_trigger->tgargs[i]);
+ if (i != tdata->tg_trigger->tgnargs - 1)
+ sv_catpvf(rv, ", ");
+ }
+ sv_catpvf(rv, " ]");
+ }
+ sv_catpvf(rv, ", relname => '%s'", SPI_getrelname(tdata->tg_relation));
+
+ if (TRIGGER_FIRED_BEFORE(tdata->tg_event))
+ sv_catpvf(rv, ", when => 'BEFORE'");
+ else if (TRIGGER_FIRED_AFTER(tdata->tg_event))
+ sv_catpvf(rv, ", when => 'AFTER'");
+ else
+ sv_catpvf(rv, ", when => 'UNKNOWN'");
+
+ if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
+ sv_catpvf(rv, ", level => 'ROW'");
+ else if (TRIGGER_FIRED_FOR_STATEMENT(tdata->tg_event))
+ sv_catpvf(rv, ", level => 'STATEMENT'");
+ else
+ sv_catpvf(rv, ", level => 'UNKNOWN'");
+
+ sv_catpvf(rv, " }");
+
+ rv = perl_eval_pv(SvPV(rv, PL_na), TRUE);
+
+ return rv;
+ }
+
+
+ /**********************************************************************
+ * check return value from plperl function
+ **********************************************************************/
+ static int
+ plperl_is_set(SV * sv)
+ {
+ int i = 0;
+ int len = 0;
+ int set = 0;
+ int other = 0;
+ AV *input_av;
+ SV **val;
+
+ if (SvTYPE(sv) != SVt_RV)
+ return 0;
+
+ if (SvTYPE(SvRV(sv)) == SVt_PVHV)
+ return 0;
+
+ if (SvTYPE(SvRV(sv)) == SVt_PVAV)
+ {
+ input_av = (AV *) SvRV(sv);
+ len = av_len(input_av) + 1;
+
+ for (i = 0; i < len; i++)
+ {
+ val = av_fetch(input_av, i, FALSE);
+ if (SvTYPE(*val) == SVt_RV)
+ set = 1;
+ else
+ other = 1;
+ }
+ }
+
+ if (len == 0)
+ return 1;
+ if (set && !other)
+ return 1;
+ if (!set && other)
+ return 0;
+ if (set && other)
+ elog(ERROR, "plperl: check your return value structure");
+ if (!set && !other)
+ elog(ERROR, "plperl: check your return value structure");
+
+ return 0; /* for compiler */
+ }
+
+ /**********************************************************************
+ * extract a list of keys from a hash
+ **********************************************************************/
+ static AV *
+ plperl_get_keys(HV * hv)
+ {
+ AV *ret;
+ SV **svp;
+ int key_count;
+ SV *val;
+ char *key;
+ I32 klen;
+
+ key_count = 0;
+ ret = newAV();
+
+ hv_iterinit(hv);
+ while (val = hv_iternextsv(hv, (char **) &key, &klen))
+ {
+ av_store(ret, key_count, eval_pv(key, TRUE));
+ key_count++;
+ }
+ hv_iterinit(hv);
+ return ret;
+ }
+
+ /**********************************************************************
+ * extract a given key (by index) from a list of keys
+ **********************************************************************/
+ static char *
+ plperl_get_key(AV * keys, int index)
+ {
+ SV **svp;
+ int len;
+
+ len = av_len(keys) + 1;
+ if (index < len)
+ svp = av_fetch(keys, index, FALSE);
+ else
+ return NULL;
+ return SvPV(*svp, PL_na);
+ }
+
+ /**********************************************************************
+ * extract a value for a given key from a hash
+ *
+ * return NULL on error or if we got an undef
+ *
+ **********************************************************************/
+ static char *
+ plperl_get_elem(HV * hash, char *key)
+ {
+ SV **svp;
+
+ if (hv_exists_ent(hash, eval_pv(key, TRUE), FALSE))
+ svp = hv_fetch(hash, key, strlen(key), FALSE);
+ else
+ {
+ elog(ERROR, "plperl: key '%s' not found", key);
+ return NULL;
+ }
+ return SvTYPE(*svp) == SVt_NULL ? NULL : SvPV(*svp, PL_na);
+ }
+
+ /**********************************************************************
+ * set up the new tuple returned from a trigger
+ **********************************************************************/
+ static HeapTuple
+ plperl_modify_tuple(HV * hvTD, TriggerData *tdata, HeapTuple otup, Oid fn_oid)
+ {
+ SV **svp;
+ HV *hvNew;
+ AV *plkeys;
+ char *platt;
+ char *plval;
+ HeapTuple rtup;
+ int natts,
+ i,
+ attn,
+ atti;
+ int *volatile modattrs = NULL;
+ Datum *volatile modvalues = NULL;
+ char *volatile modnulls = NULL;
+ TupleDesc tupdesc;
+ HeapTuple typetup;
+
+ tupdesc = tdata->tg_relation->rd_att;
+
+ svp = hv_fetch(hvTD, "new", 3, FALSE);
+ hvNew = (HV *) SvRV(*svp);
+
+ if (SvTYPE(hvNew) != SVt_PVHV)
+ elog(ERROR, "plperl: $_TD->{new} is not a hash");
+
+ plkeys = plperl_get_keys(hvNew);
+ natts = av_len(plkeys)+1;
+ if (natts != tupdesc->natts)
+ elog(ERROR, "plperl: $_TD->{new} has an incorrect number of keys.");
+
+ modattrs = palloc0(natts * sizeof(int));
+ modvalues = palloc0(natts * sizeof(Datum));
+ modnulls = palloc0(natts * sizeof(char));
+
+ for (i = 0; i < natts; i++)
+ {
+ FmgrInfo finfo;
+ Oid typinput;
+ Oid typelem;
+
+ platt = plperl_get_key(plkeys, i);
+
+ attn = modattrs[i] = SPI_fnumber(tupdesc, platt);
+
+ if (attn == SPI_ERROR_NOATTRIBUTE)
+ elog(ERROR, "plperl: invalid attribute `%s' in tuple.", platt);
+ atti = attn - 1;
+
+ plval = plperl_get_elem(hvNew, platt);
+
+ typetup = SearchSysCache(TYPEOID, ObjectIdGetDatum(tupdesc->attrs[atti]->atttypid), 0, 0, 0);
+ typinput = ((Form_pg_type) GETSTRUCT(typetup))->typinput;
+ typelem = ((Form_pg_type) GETSTRUCT(typetup))->typelem;
+ ReleaseSysCache(typetup);
+ fmgr_info(typinput, &finfo);
+
+ if (plval)
+ {
+ modvalues[i] = FunctionCall3(&finfo,
+ CStringGetDatum(plval),
+ ObjectIdGetDatum(typelem),
+ Int32GetDatum(tupdesc->attrs[atti]->atttypmod));
+ modnulls[i] = ' ';
+ }
+ else
+ {
+ modvalues[i] = (Datum) 0;
+ modnulls[i] = 'n';
+ }
+ }
+ rtup = SPI_modifytuple(tdata->tg_relation, otup, natts, modattrs, modvalues, modnulls);
+
+ pfree(modattrs);
+ pfree(modvalues);
+ pfree(modnulls);
+ if (rtup == NULL)
+ elog(ERROR, "plperl: SPI_modifytuple failed -- error: %d", SPI_result);
+
+ return rtup;
+ }
/**********************************************************************
* plperl_call_handler - This is the only visible function
***************
*** 262,278 ****
* call appropriate subhandler
************************************************************/
if (CALLED_AS_TRIGGER(fcinfo))
! {
! ereport(ERROR,
! (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
! errmsg("cannot use perl in triggers yet")));
!
! /*
! * retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
! */
! /* make the compiler happy */
! retval = (Datum) 0;
! }
else
retval = plperl_func_handler(fcinfo);
--- 576,582 ----
* call appropriate subhandler
************************************************************/
if (CALLED_AS_TRIGGER(fcinfo))
! retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
else
retval = plperl_func_handler(fcinfo);
***************
*** 295,300 ****
--- 599,605 ----
ENTER;
SAVETMPS;
PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVpv("my $_TD=$_[0]; shift;", 0)));
XPUSHs(sv_2mortal(newSVpv(s, 0)));
PUTBACK;
***************
*** 387,392 ****
--- 692,698 ----
SAVETMPS;
PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVpv("undef", 0)));
for (i = 0; i < desc->nargs; i++)
{
if (desc->arg_is_rowtype[i])
***************
*** 468,473 ****
--- 774,830 ----
return retval;
}
+ /**********************************************************************
+ * plperl_call_perl_trigger_func() - calls a perl function affected by trigger
+ * through the RV stored in the prodesc structure. massages the input parms properly
+ **********************************************************************/
+ static SV *
+ plperl_call_perl_trigger_func(plperl_proc_desc * desc, FunctionCallInfo fcinfo, SV * td)
+ {
+ dSP;
+ SV *retval;
+ int i;
+ int count;
+ char *ret_test;
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(sp);
+ XPUSHs(td);
+ for (i = 0; i < ((TriggerData *) fcinfo->context)->tg_trigger->tgnargs; i++)
+ XPUSHs(sv_2mortal(newSVpv(((TriggerData *) fcinfo->context)->tg_trigger->tgargs[i], 0)));
+ PUTBACK;
+
+ count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL | G_KEEPERR);
+
+ SPAGAIN;
+
+ if (count != 1)
+ {
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ elog(ERROR, "plperl: didn't get a return item from function");
+ }
+
+ if (SvTRUE(ERRSV))
+ {
+ POPs;
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ elog(ERROR, "plperl: error from function: %s", SvPV(ERRSV, PL_na));
+ }
+
+ retval = newSVsv(POPs);
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ return retval;
+ }
/**********************************************************************
* plperl_func_handler() - Handler for regular function calls
***************
*** 481,491 ****
/* Find or compile the function */
prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
-
/************************************************************
* Call the Perl function
************************************************************/
perlret = plperl_call_perl_func(prodesc, fcinfo);
/************************************************************
* Disconnect from SPI manager and then create the return
--- 838,854 ----
/* Find or compile the function */
prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
/************************************************************
* Call the Perl function
************************************************************/
perlret = plperl_call_perl_func(prodesc, fcinfo);
+ if (prodesc->fn_retistuple && SRF_IS_FIRSTCALL())
+ {
+
+ if (SvTYPE(perlret) != SVt_RV)
+ elog(ERROR, "plperl: this function must return a reference");
+ g_column_keys = newAV();
+ }
/************************************************************
* Disconnect from SPI manager and then create the return
***************
*** 496,509 ****
if (SPI_finish() != SPI_OK_FINISH)
elog(ERROR, "SPI_finish() failed");
! if (!(perlret && SvOK(perlret)))
{
/* return NULL if Perl code returned undef */
retval = (Datum) 0;
fcinfo->isnull = true;
}
else
{
retval = FunctionCall3(&prodesc->result_in_func,
PointerGetDatum(SvPV(perlret, PL_na)),
ObjectIdGetDatum(prodesc->result_typioparam),
--- 859,1004 ----
if (SPI_finish() != SPI_OK_FINISH)
elog(ERROR, "SPI_finish() failed");
! if (!(perlret && SvOK(perlret) && SvTYPE(perlret)!=SVt_NULL ))
{
/* return NULL if Perl code returned undef */
retval = (Datum) 0;
fcinfo->isnull = true;
}
+
+ if (prodesc->fn_retistuple)
+ {
+ /* SRF support */
+ HV *ret_hv;
+ AV *ret_av;
+
+ FuncCallContext *funcctx;
+ int call_cntr;
+ int max_calls;
+ TupleDesc tupdesc;
+ TupleTableSlot *slot;
+ AttInMetadata *attinmeta;
+ bool isset = 0;
+ char **values = NULL;
+ ReturnSetInfo *rsinfo = (ReturnSetInfo *) fcinfo->resultinfo;
+
+ if (!rsinfo)
+ ereport(ERROR,
+ (errcode(ERRCODE_SYNTAX_ERROR),
+ errmsg("returning a composite type is not allowed in this context"),
+ errhint("This function is intended for use in the FROM clause.")));
+
+ if (SvTYPE(perlret) != SVt_RV)
+ elog(ERROR, "plperl: this function must return a reference");
+
+ isset = plperl_is_set(perlret);
+
+ if (SvTYPE(SvRV(perlret)) == SVt_PVHV)
+ ret_hv = (HV *) SvRV(perlret);
+ else
+ ret_av = (AV *) SvRV(perlret);
+
+ if (SRF_IS_FIRSTCALL())
+ {
+ MemoryContext oldcontext;
+ int i;
+
+ funcctx = SRF_FIRSTCALL_INIT();
+
+ oldcontext = MemoryContextSwitchTo(funcctx->multi_call_memory_ctx);
+
+ if (SvTYPE(SvRV(perlret)) == SVt_PVHV)
+ {
+ if (isset)
+ funcctx->max_calls = hv_iterinit(ret_hv);
+ else
+ funcctx->max_calls = 1;
+ }
+ else
+ {
+ if (isset)
+ funcctx->max_calls = av_len(ret_av) + 1;
+ else
+ funcctx->max_calls = 1;
+ }
+
+ tupdesc = CreateTupleDescCopy(rsinfo->expectedDesc);
+
+ g_attr_num = tupdesc->natts;
+
+ for (i = 0; i < tupdesc->natts; i++)
+ av_store(g_column_keys, i + 1, eval_pv(SPI_fname(tupdesc, i + 1), TRUE));
+
+ slot = TupleDescGetSlot(tupdesc);
+ funcctx->slot = slot;
+ attinmeta = TupleDescGetAttInMetadata(tupdesc);
+ funcctx->attinmeta = attinmeta;
+ MemoryContextSwitchTo(oldcontext);
+ }
+
+ funcctx = SRF_PERCALL_SETUP();
+ call_cntr = funcctx->call_cntr;
+ max_calls = funcctx->max_calls;
+ slot = funcctx->slot;
+ attinmeta = funcctx->attinmeta;
+
+ if (call_cntr < max_calls)
+ {
+ HeapTuple tuple;
+ Datum result;
+ int i;
+ char *column_key;
+ char *elem;
+
+ if (isset)
+ {
+ HV *row_hv;
+ SV **svp;
+ char *row_key;
+
+ svp = av_fetch(ret_av, call_cntr, FALSE);
+
+ row_hv = (HV *) SvRV(*svp);
+
+ values = (char **) palloc(g_attr_num * sizeof(char *));
+
+ for (i = 0; i < g_attr_num; i++)
+ {
+ column_key = plperl_get_key(g_column_keys, i + 1);
+ elem = plperl_get_elem(row_hv, column_key);
+ if (elem)
+ values[i] = elem;
+ else
+ values[i] = NULL;
+ }
+ }
else
{
+ int i;
+
+ values = (char **) palloc(g_attr_num * sizeof(char *));
+ for (i = 0; i < g_attr_num; i++)
+ {
+ column_key = SPI_fname(tupdesc, i + 1);
+ elem = plperl_get_elem(ret_hv, column_key);
+ if (elem)
+ values[i] = elem;
+ else
+ values[i] = NULL;
+ }
+ }
+ tuple = BuildTupleFromCStrings(attinmeta, values);
+ result = TupleGetDatum(slot, tuple);
+ SRF_RETURN_NEXT(funcctx, result);
+ }
+ else
+ {
+ SvREFCNT_dec(perlret);
+ SRF_RETURN_DONE(funcctx);
+ }
+ }
+ else if (! fcinfo->isnull)
+ {
retval = FunctionCall3(&prodesc->result_in_func,
PointerGetDatum(SvPV(perlret, PL_na)),
ObjectIdGetDatum(prodesc->result_typioparam),
***************
*** 511,520 ****
}
SvREFCNT_dec(perlret);
-
return retval;
}
/**********************************************************************
* compile_plperl_function - compile (or hopefully just look up) function
--- 1006,1106 ----
}
SvREFCNT_dec(perlret);
return retval;
}
+ /**********************************************************************
+ * plperl_trigger_handler() - Handler for trigger function calls
+ **********************************************************************/
+ static Datum
+ plperl_trigger_handler(PG_FUNCTION_ARGS)
+ {
+ plperl_proc_desc *prodesc;
+ SV *perlret;
+ Datum retval;
+ char *tmp;
+ SV *svTD;
+ HV *hvTD;
+
+ /* Find or compile the function */
+ prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true);
+
+ /************************************************************
+ * Call the Perl function
+ ************************************************************/
+ /*
+ * call perl trigger function and build TD hash
+ */
+ svTD = plperl_trigger_build_args(fcinfo);
+ perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
+
+ hvTD = (HV *) SvRV(svTD); /* convert SV TD structure to Perl Hash
+ * structure */
+
+ tmp = SvPV(perlret, PL_na);
+
+ /************************************************************
+ * Disconnect from SPI manager and then create the return
+ * values datum (if the input function does a palloc for it
+ * this must not be allocated in the SPI memory context
+ * because SPI_finish would free it).
+ ************************************************************/
+ if (SPI_finish() != SPI_OK_FINISH)
+ elog(ERROR, "plperl: SPI_finish() failed");
+
+ if (!(perlret && SvOK(perlret)))
+ {
+ TriggerData *trigdata = ((TriggerData *) fcinfo->context);
+
+ if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
+ retval = (Datum) trigdata->tg_trigtuple;
+ else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
+ retval = (Datum) trigdata->tg_newtuple;
+ else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
+ retval = (Datum) trigdata->tg_trigtuple;
+ }
+ else
+ {
+ if (!fcinfo->isnull)
+ {
+
+ HeapTuple trv;
+
+ if (strcasecmp(tmp, "SKIP") == 0)
+ trv = NULL;
+ else if (strcasecmp(tmp, "MODIFY") == 0)
+ {
+ TriggerData *trigdata = (TriggerData *) fcinfo->context;
+
+ if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
+ trv = plperl_modify_tuple(hvTD, trigdata, trigdata->tg_trigtuple, fcinfo->flinfo->fn_oid);
+ else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
+ trv = plperl_modify_tuple(hvTD, trigdata, trigdata->tg_newtuple, fcinfo->flinfo->fn_oid);
+ else
+ {
+ trv = NULL;
+ elog(WARNING, "plperl: Ignoring modified tuple in DELETE trigger");
+ }
+ }
+ else if (strcasecmp(tmp, "OK"))
+ {
+ trv = NULL;
+ elog(ERROR, "plperl: Expected return to be undef, 'SKIP' or 'MODIFY'");
+ }
+ else
+ {
+ trv = NULL;
+ elog(ERROR, "plperl: Expected return to be undef, 'SKIP' or 'MODIFY'");
+ }
+ retval = PointerGetDatum(trv);
+ }
+ }
+
+ SvREFCNT_dec(perlret);
+
+ fcinfo->isnull = false;
+ return retval;
+ }
/**********************************************************************
* compile_plperl_function - compile (or hopefully just look up) function
***************
*** 544,549 ****
--- 1130,1136 ----
sprintf(internal_proname, "__PLPerl_proc_%u", fn_oid);
else
sprintf(internal_proname, "__PLPerl_proc_%u_trigger", fn_oid);
+
proname_len = strlen(internal_proname);
/************************************************************
***************
*** 637,646 ****
}
typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
! /* Disallow pseudotype result, except VOID */
if (typeStruct->typtype == 'p')
{
! if (procStruct->prorettype == VOIDOID)
/* okay */ ;
else if (procStruct->prorettype == TRIGGEROID)
{
--- 1224,1234 ----
}
typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
! /* Disallow pseudotype result, except VOID or RECORD */
if (typeStruct->typtype == 'p')
{
! if (procStruct->prorettype == VOIDOID ||
! procStruct->prorettype == RECORDOID)
/* okay */ ;
else if (procStruct->prorettype == TRIGGEROID)
{
***************
*** 661,673 ****
}
}
! if (typeStruct->typtype == 'c')
{
! free(prodesc->proname);
! free(prodesc);
! ereport(ERROR,
! (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
! errmsg("plperl functions cannot return tuples yet")));
}
perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
--- 1249,1258 ----
}
}
! if (typeStruct->typtype == 'c' || procStruct->prorettype == RECORDOID)
{
! prodesc->fn_retistuple = true;
! prodesc->ret_oid = typeStruct->typrelid;
}
perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
Index: src/pl/plperl/spi_internal.c
===================================================================
RCS file: src/pl/plperl/spi_internal.c
diff -N src/pl/plperl/spi_internal.c
*** /dev/null 1 Jan 1970 00:00:00 -0000
--- src/pl/plperl/spi_internal.c 1 Jul 2004 16:24:53 -0000
***************
*** 0 ****
--- 1,179 ----
+ #include "postgres.h"
+ #include "executor/spi.h"
+ #include "utils/syscache.h"
+ /*
+ * This kludge is necessary because of the conflicting
+ * definitions of 'DEBUG' between postgres and perl.
+ * we'll live.
+ */
+
+ #include "spi_internal.h"
+
+ static char* plperl_spi_status_string(int);
+
+ static HV* plperl_spi_execute_fetch_result(SPITupleTable*, int, int );
+
+ int
+ spi_DEBUG(void)
+ {
+ return DEBUG2;
+ }
+
+ int
+ spi_LOG(void)
+ {
+ return LOG;
+ }
+
+ int
+ spi_INFO(void)
+ {
+ return INFO;
+ }
+
+ int
+ spi_NOTICE(void)
+ {
+ return NOTICE;
+ }
+
+ int
+ spi_WARNING(void)
+ {
+ return WARNING;
+ }
+
+ int
+ spi_ERROR(void)
+ {
+ return ERROR;
+ }
+
+ HV*
+ plperl_spi_exec(char* query, int limit)
+ {
+ HV *ret_hv;
+ int spi_rv;
+
+ spi_rv = SPI_exec(query, limit);
+ ret_hv=plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed, spi_rv);
+
+ return ret_hv;
+ }
+
+ static HV*
+ plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
+ {
+ int i;
+ char *attname;
+ char *attdata;
+
+ HV *array;
+
+ array = newHV();
+
+ for (i = 0; i < tupdesc->natts; i++) {
+ /************************************************************
+ * Get the attribute name
+ ************************************************************/
+ attname = tupdesc->attrs[i]->attname.data;
+
+ /************************************************************
+ * Get the attributes value
+ ************************************************************/
+ attdata = SPI_getvalue(tuple, tupdesc, i+1);
+ hv_store(array, attname, strlen(attname), newSVpv(attdata,0), 0);
+ }
+ return array;
+ }
+
+ static HV*
+ plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int rows, int status)
+ {
+
+ HV *result;
+ int i;
+
+ result = newHV();
+
+ if (status == SPI_OK_UTILITY)
+ {
+ hv_store(result, "status", strlen("status"), newSVpv("SPI_OK_UTILITY",0), 0);
+ hv_store(result, "rows", strlen("rows"), newSViv(rows), 0);
+ }
+ else if (status != SPI_OK_SELECT)
+ {
+ hv_store(result, "status", strlen("status"), newSVpv((char*)plperl_spi_status_string(status),0), 0);
+ hv_store(result, "rows", strlen("rows"), newSViv(rows), 0);
+ }
+ else
+ {
+ if (rows)
+ {
+ char* key=palloc(sizeof(int));
+ HV *row;
+ for (i = 0; i < rows; i++)
+ {
+ row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
+ sprintf(key, "%i", i);
+ hv_store(result, key, strlen(key), newRV_noinc((SV*)row), 0);
+ }
+ SPI_freetuptable(tuptable);
+ }
+ }
+ return result;
+ }
+
+ static char*
+ plperl_spi_status_string(int status)
+ {
+ switch(status){
+ /*errors*/
+ case SPI_ERROR_TYPUNKNOWN:
+ return "SPI_ERROR_TYPUNKNOWN";
+ case SPI_ERROR_NOOUTFUNC:
+ return "SPI_ERROR_NOOUTFUNC";
+ case SPI_ERROR_NOATTRIBUTE:
+ return "SPI_ERROR_NOATTRIBUTE";
+ case SPI_ERROR_TRANSACTION:
+ return "SPI_ERROR_TRANSACTION";
+ case SPI_ERROR_PARAM:
+ return "SPI_ERROR_PARAM";
+ case SPI_ERROR_ARGUMENT:
+ return "SPI_ERROR_ARGUMENT";
+ case SPI_ERROR_CURSOR:
+ return "SPI_ERROR_CURSOR";
+ case SPI_ERROR_UNCONNECTED:
+ return "SPI_ERROR_UNCONNECTED";
+ case SPI_ERROR_OPUNKNOWN:
+ return "SPI_ERROR_OPUNKNOWN";
+ case SPI_ERROR_COPY:
+ return "SPI_ERROR_COPY";
+ case SPI_ERROR_CONNECT:
+ return "SPI_ERROR_CONNECT";
+ /*ok*/
+ case SPI_OK_CONNECT:
+ return "SPI_OK_CONNECT";
+ case SPI_OK_FINISH:
+ return "SPI_OK_FINISH";
+ case SPI_OK_FETCH:
+ return "SPI_OK_FETCH";
+ case SPI_OK_UTILITY:
+ return "SPI_OK_UTILITY";
+ case SPI_OK_SELECT:
+ return "SPI_OK_SELECT";
+ case SPI_OK_SELINTO:
+ return "SPI_OK_SELINTO";
+ case SPI_OK_INSERT:
+ return "SPI_OK_INSERT";
+ case SPI_OK_DELETE:
+ return "SPI_OK_DELETE";
+ case SPI_OK_UPDATE:
+ return "SPI_OK_UPDATE";
+ case SPI_OK_CURSOR:
+ return "SPI_OK_CURSOR";
+ }
+
+ return "Unknown or Invalid code";
+ }
+
Index: src/pl/plperl/spi_internal.h
===================================================================
RCS file: src/pl/plperl/spi_internal.h
diff -N src/pl/plperl/spi_internal.h
*** /dev/null 1 Jan 1970 00:00:00 -0000
--- src/pl/plperl/spi_internal.h 1 Jul 2004 16:24:53 -0000
***************
*** 0 ****
--- 1,19 ----
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "XSUB.h"
+
+ int spi_DEBUG(void);
+
+ int spi_LOG(void);
+
+ int spi_INFO(void);
+
+ int spi_NOTICE(void);
+
+ int spi_WARNING(void);
+
+ int spi_ERROR(void);
+
+ HV* plperl_spi_exec(char*, int);
+
+
