Andrew Dunstan wrote:
Quick head up - I have a fix for the count hash keys 'fix' I reverted yesterday, and also a patch from Joe Coway to allow returning record and setof record.
Revised patch will be forthcoming after some testing.
The attached patch (and 2 new files incorporating previous eloglvl.[ch] as before) has the following changes in plperl.c over previously sent patch:
- fixed optimization for counting hash keys (Abhijit Menon-Sen)
- allow return of 'record' and 'setof record' - removed previously advisied limitation (Joe Conway)
- fix off by 1 errors in SRF code that caused memory errors (Joe Conway)
- minor cleanup (me)
There is a new known issue which will be addressed quickly: - empty string is interpreted as NULL - only undef should translate as NULL
enjoy
andrew
#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";
}
#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);
Index: src/pl/plperl/GNUmakefile
===================================================================
RCS file: /projects/cvsroot/pgsql-server/src/pl/plperl/GNUmakefile,v
retrieving revision 1.12
diff -c -w -r1.12 GNUmakefile
*** src/pl/plperl/GNUmakefile 21 Jan 2004 19:04:11 -0000 1.12
--- src/pl/plperl/GNUmakefile 29 Jun 2004 16:35:55 -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: src/pl/plperl/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
*** src/pl/plperl/SPI.xs 4 Sep 2002 22:49:37 -0000 1.5
--- src/pl/plperl/SPI.xs 29 Jun 2004 16:35:55 -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/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
*** src/pl/plperl/plperl.c 6 Jun 2004 00:41:28 -0000 1.44
--- src/pl/plperl/plperl.c 29 Jun 2004 16:35:55 -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,576 ----
}
+ /**********************************************************************
+ * 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;
+ }
+
+
+ /**********************************************************************
+ * 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, "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 = 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);
--- 603,609 ----
* call appropriate subhandler
************************************************************/
if (CALLED_AS_TRIGGER(fcinfo))
! retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
else
retval = plperl_func_handler(fcinfo);
***************
*** 295,300 ****
--- 626,632 ----
ENTER;
SAVETMPS;
PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVpv("my $_TD=$_[0]; shift;", 0)));
XPUSHs(sv_2mortal(newSVpv(s, 0)));
PUTBACK;
***************
*** 387,392 ****
--- 719,725 ----
SAVETMPS;
PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVpv("undef", 0)));
for (i = 0; i < desc->nargs; i++)
{
if (desc->arg_is_rowtype[i])
***************
*** 468,473 ****
--- 801,857 ----
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
--- 865,881 ----
/* 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 ****
--- 892,1030 ----
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 (strlen(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 (strlen(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
{
retval = FunctionCall3(&prodesc->result_in_func,
***************
*** 511,520 ****
}
SvREFCNT_dec(perlret);
-
return retval;
}
/**********************************************************************
* compile_plperl_function - compile (or hopefully just look up) function
--- 1034,1134 ----
}
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 ****
--- 1158,1164 ----
sprintf(internal_proname, "__PLPerl_proc_%u", fn_oid);
else
sprintf(internal_proname, "__PLPerl_proc_%u_trigger", fn_oid);
+
proname_len = strlen(internal_proname);
/************************************************************
***************
*** 640,646 ****
/* Disallow pseudotype result, except VOID */
if (typeStruct->typtype == 'p')
{
! if (procStruct->prorettype == VOIDOID)
/* okay */ ;
else if (procStruct->prorettype == TRIGGEROID)
{
--- 1255,1262 ----
/* Disallow pseudotype result, except VOID */
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));
--- 1277,1286 ----
}
}
! 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));
---------------------------(end of broadcast)--------------------------- TIP 4: Don't 'kill -9' the postmaster
