Andrew Dunstan wrote:
I wrote:
I know it's late in the day, but ...
Attached is a patch and 2 replacement files for plperl. The work has
been done under the auspices of the plperlng project on pgfoundry.
The code (which has been through several iterations) comes from
CommandPrompt, and has had some minor editorializing by me (spelling,
indentation, function heading comments). It has also been reviewed
somewhat by Abhijit Menon-Sen, who supplied a small optimization. It
has been tested by me and by David Fetter.
My apologies. I should have tested more. It appears that the
optimization Abhijit sent us causes a memory error, at least onn my
machine. I have therefore reverted it. Please ignore the patch file
previously sent and use this one instead. The other files in my
previous post are still relevant - to save space I have not reattached
them.
This time it's attached ...
cheers
andrew
Index: GNUmakefile
===================================================================
RCS file: /projects/cvsroot/pgsql-server/src/pl/plperl/GNUmakefile,v
retrieving revision 1.12
diff -c -w -r1.12 GNUmakefile
*** GNUmakefile 21 Jan 2004 19:04:11 -0000 1.12
--- GNUmakefile 27 Jun 2004 20:51:24 -0000
***************
*** 15,21 ****
# The code isn't clean with regard to these warnings.
ifeq ($(GCC),yes)
! override CFLAGS := $(filter-out -Wall -Wmissing-declarations -Wmissing-prototypes,
$(CFLAGS))
endif
override CPPFLAGS := -I$(srcdir) -I$(perl_archlibexp)/CORE $(CPPFLAGS)
--- 15,21 ----
# The code isn't clean with regard to these warnings.
ifeq ($(GCC),yes)
! override CFLAGS := $(filter-out -Wall -Wmissing-declarations -Wmissing-prototypes,
$(CFLAGS), -Wl,-rpath,$(perl_archlibexp)/CORE)
endif
override CPPFLAGS := -I$(srcdir) -I$(perl_archlibexp)/CORE $(CPPFLAGS)
***************
*** 25,31 ****
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,31 ----
SO_MAJOR_VERSION = 0
SO_MINOR_VERSION = 0
! OBJS = plperl.o spi_internal.o SPI.o
SHLIB_LINK = $(perl_embed_ldflags) $(BE_DLLLIBS)
include $(top_srcdir)/src/Makefile.shlib
Index: SPI.xs
===================================================================
RCS file: /projects/cvsroot/pgsql-server/src/pl/plperl/SPI.xs,v
retrieving revision 1.5
diff -c -w -r1.5 SPI.xs
*** SPI.xs 4 Sep 2002 22:49:37 -0000 1.5
--- SPI.xs 27 Jun 2004 20:51:24 -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: plperl.c
===================================================================
RCS file: /projects/cvsroot/pgsql-server/src/pl/plperl/plperl.c,v
retrieving revision 1.44
diff -c -w -r1.44 plperl.c
*** plperl.c 6 Jun 2004 00:41:28 -0000 1.44
--- plperl.c 27 Jun 2004 20:51:24 -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,596 ----
}
+ /**********************************************************************
+ * 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;
+ char *tmp;
+
+ tmp = (char *) malloc(sizeof(int));
+
+ 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'");
+
+ sprintf(tmp, "%d", tdata->tg_trigger->tgnargs);
+ sv_catpvf(rv, ", argc => %s", tmp);
+
+ 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);
+
+ free(tmp);
+
+ return rv;
+ }
+
+
+ /**********************************************************************
+ * count keys in a hash
+ **********************************************************************/
+ static int
+ plperl_count_hv(HV * hv)
+ {
+ char *key;
+ I32 klen;
+ SV *val;
+ int key_count;
+
+ key_count = 0;
+
+ while (val = hv_iternextsv(hv, (char **) &key, &klen))
+ key_count++;
+
+ return key_count;
+ }
+
+
+ /**********************************************************************
+ * 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
+ **********************************************************************/
+ 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 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,
+ j,
+ attn,
+ atti;
+ int *volatile modattrs;
+ Datum *volatile modvalues;
+ char *volatile modnulls;
+ TupleDesc tupdesc;
+ HeapTuple typetup;
+
+ modattrs = NULL;
+ modvalues = NULL;
+ modnulls = NULL;
+ tupdesc = tdata->tg_relation->rd_att;
+
+ svp = hv_fetch(hvTD, "new", 3, FALSE);
+ hvNew = (HV *) SvRV(*svp);
+
+ if (SvTYPE(hvNew) != SVt_PVHV)
+ elog(ERROR, "plphp: $_TD->{new} is not a hash");
+
+ plkeys = plperl_get_keys(hvNew);
+ natts = plperl_count_hv(hvNew);
+ if (natts != tupdesc->natts)
+ elog(ERROR, "plphp: $_TD->{new} has an incorrect number of keys.");
+
+ modattrs = palloc(natts * sizeof(int));
+ modvalues = palloc(natts * sizeof(Datum));
+
+ for (i = 0; i < natts; i++)
+ {
+ modattrs[i] = i + 1;
+ modvalues[i] = (Datum) NULL;
+ }
+ modnulls = palloc(natts + 1);
+ memset(modnulls, 'n', natts);
+ modnulls[natts] = '\0';
+
+ tupdesc = tdata->tg_relation->rd_att;
+
+ for (j = 0; j < natts; j++)
+ {
+ char *src;
+ FmgrInfo finfo;
+ Oid typinput;
+ Oid typelem;
+
+
+ platt = plperl_get_key(plkeys, j);
+
+ attn = modattrs[j] = 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);
+ if (plval == NULL)
+ elog(FATAL, "plperl: interpreter is probably corrupted");
+
+ typetup = SearchSysCache(TYPEOID, ObjectIdGetDatum(tupdesc->attrs[attn
- 1]->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)
+ {
+ src = plval;
+ if (strlen(plval))
+ {
+ modvalues[j] = FunctionCall3(&finfo,
+
CStringGetDatum(src),
+
ObjectIdGetDatum(typelem),
+
Int32GetDatum(tupdesc->attrs[atti]->atttypmod));
+ modnulls[j] = ' ';
+ }
+ else
+ {
+ modvalues[i] = (Datum) 0;
+ modnulls[j] = 'n';
+ }
+ }
+ plval = NULL;
+ }
+ 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);
--- 623,629 ----
* call appropriate subhandler
************************************************************/
if (CALLED_AS_TRIGGER(fcinfo))
! retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
else
retval = plperl_func_handler(fcinfo);
***************
*** 295,300 ****
--- 646,652 ----
ENTER;
SAVETMPS;
PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVpv("my $_TD=$_[0]; shift;", 0)));
XPUSHs(sv_2mortal(newSVpv(s, 0)));
PUTBACK;
***************
*** 387,392 ****
--- 739,745 ----
SAVETMPS;
PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVpv("undef", 0)));
for (i = 0; i < desc->nargs; i++)
{
if (desc->arg_is_rowtype[i])
***************
*** 468,473 ****
--- 821,877 ----
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
--- 885,901 ----
/* 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
***************
*** 502,507 ****
--- 912,1050 ----
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;
+
+ 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 = RelationNameGetTupleDesc(
+ (char *) get_rel_name(prodesc->ret_oid));
+
+ 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 + 1) *
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 (strlen(elem))
+ {
+ values[i] = (char *)
palloc((strlen(elem) + 1) * sizeof(char));
+ snprintf(values[i], strlen(elem) + 1,
"%s", elem);
+ }
+ else
+ values[i] = NULL;
+ }
+ values[i + 1] = NULL;
+ }
+ else
+ {
+ int i;
+
+ values = (char **) palloc((g_attr_num + 1) *
sizeof(char *));
+ for (i = 0; i < tupdesc->natts; i++)
+ {
+ column_key = SPI_fname(tupdesc, i + 1);
+ elem = plperl_get_elem(ret_hv, column_key);
+ if (strlen(elem))
+ {
+ values[i] = (char *)
palloc((strlen(elem) * sizeof(char)));
+ snprintf(values[i], strlen(elem) + 1,
"%s", 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
{
retval = FunctionCall3(&prodesc->result_in_func,
***************
*** 511,520 ****
}
SvREFCNT_dec(perlret);
-
return retval;
}
/**********************************************************************
* compile_plperl_function - compile (or hopefully just look up) function
--- 1054,1154 ----
}
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 ****
--- 1178,1184 ----
sprintf(internal_proname, "__PLPerl_proc_%u", fn_oid);
else
sprintf(internal_proname, "__PLPerl_proc_%u_trigger", fn_oid);
+
proname_len = strlen(internal_proname);
/************************************************************
***************
*** 663,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));
--- 1298,1305 ----
if (typeStruct->typtype == 'c')
{
! prodesc->fn_retistuple = true;
! prodesc->ret_oid = typeStruct->typrelid;
}
perm_fmgr_info(typeStruct->typinput,
&(prodesc->result_in_func));
---------------------------(end of broadcast)---------------------------
TIP 2: you can get off all lists at once with the unregister command
(send "unregister YourEmailAddressHere" to [EMAIL PROTECTED])
