diff options
| -rw-r--r-- | src/pl/plperl/GNUmakefile | 9 | ||||
| -rw-r--r-- | src/pl/plperl/SPI.xs | 34 | ||||
| -rw-r--r-- | src/pl/plperl/eloglvl.c | 45 | ||||
| -rw-r--r-- | src/pl/plperl/eloglvl.h | 12 | ||||
| -rw-r--r-- | src/pl/plperl/plperl.c | 643 | ||||
| -rw-r--r-- | src/pl/plperl/spi_internal.c | 179 | ||||
| -rw-r--r-- | src/pl/plperl/spi_internal.h | 19 |
7 files changed, 842 insertions, 99 deletions
diff --git a/src/pl/plperl/GNUmakefile b/src/pl/plperl/GNUmakefile index 459ad3f1d53..5b065aa7d9e 100644 --- a/src/pl/plperl/GNUmakefile +++ b/src/pl/plperl/GNUmakefile @@ -1,5 +1,5 @@ # Makefile for PL/Perl -# $PostgreSQL: pgsql/src/pl/plperl/GNUmakefile,v 1.12 2004/01/21 19:04:11 tgl Exp $ +# $PostgreSQL: pgsql/src/pl/plperl/GNUmakefile,v 1.13 2004/07/01 20:50:22 joe Exp $ subdir = src/pl/plperl top_builddir = ../../.. @@ -25,8 +25,13 @@ NAME = plperl SO_MAJOR_VERSION = 0 SO_MINOR_VERSION = 0 -OBJS = plperl.o eloglvl.o SPI.o +OBJS = plperl.o spi_internal.o SPI.o + +ifeq ($(enable_rpath), yes) +SHLIB_LINK = $(perl_embed_ldflags) $(BE_DLLLIBS) -Wl,-rpath,$(perl_archlibexp)/CORE +else SHLIB_LINK = $(perl_embed_ldflags) $(BE_DLLLIBS) +endif include $(top_srcdir)/src/Makefile.shlib diff --git a/src/pl/plperl/SPI.xs b/src/pl/plperl/SPI.xs index c1eb2576ffc..ee0d6022693 100644 --- a/src/pl/plperl/SPI.xs +++ b/src/pl/plperl/SPI.xs @@ -6,17 +6,17 @@ #include "perl.h" #include "XSUB.h" -#include "eloglvl.h" +#include "spi_internal.h" -MODULE = SPI PREFIX = elog_ +MODULE = SPI PREFIX = spi_ PROTOTYPES: ENABLE VERSIONCHECK: DISABLE void -elog_elog(level, message) +spi_elog(level, message) int level char* message CODE: @@ -24,21 +24,33 @@ elog_elog(level, message) int -elog_DEBUG() +spi_DEBUG() int -elog_LOG() +spi_LOG() int -elog_INFO() +spi_INFO() int -elog_NOTICE() +spi_NOTICE() int -elog_WARNING() +spi_WARNING() int -elog_ERROR() - - +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 diff --git a/src/pl/plperl/eloglvl.c b/src/pl/plperl/eloglvl.c deleted file mode 100644 index 3baf0279017..00000000000 --- a/src/pl/plperl/eloglvl.c +++ /dev/null @@ -1,45 +0,0 @@ -#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; -} diff --git a/src/pl/plperl/eloglvl.h b/src/pl/plperl/eloglvl.h deleted file mode 100644 index 5452586a926..00000000000 --- a/src/pl/plperl/eloglvl.h +++ /dev/null @@ -1,12 +0,0 @@ - -int elog_DEBUG(void); - -int elog_LOG(void); - -int elog_INFO(void); - -int elog_NOTICE(void); - -int elog_WARNING(void); - -int elog_ERROR(void); diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c index 7bb2ac34331..7d9cd583af2 100644 --- a/src/pl/plperl/plperl.c +++ b/src/pl/plperl/plperl.c @@ -33,7 +33,7 @@ * ENHANCEMENTS, OR MODIFICATIONS. * * IDENTIFICATION - * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.44 2004/06/06 00:41:28 tgl Exp $ + * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.45 2004/07/01 20:50:22 joe Exp $ * **********************************************************************/ @@ -49,6 +49,7 @@ #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,6 +79,8 @@ typedef struct plperl_proc_desc 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,6 +97,9 @@ typedef struct plperl_proc_desc 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,6 +112,7 @@ void plperl_init(void); 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,14 +212,15 @@ plperl_init_interp(void) "", "-e", /* - * no commas between the next 5 please. They are supposed to be + * no commas between the next lines 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] } ]); }" + "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,6 +238,312 @@ plperl_init_interp(void) } +/********************************************************************** + * 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,17 +576,7 @@ plperl_call_handler(PG_FUNCTION_ARGS) * 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; - } + retval = PointerGetDatum(plperl_trigger_handler(fcinfo)); else retval = plperl_func_handler(fcinfo); @@ -295,6 +599,7 @@ plperl_create_sub(char *s, bool trusted) ENTER; SAVETMPS; PUSHMARK(SP); + XPUSHs(sv_2mortal(newSVpv("my $_TD=$_[0]; shift;", 0))); XPUSHs(sv_2mortal(newSVpv(s, 0))); PUTBACK; @@ -387,6 +692,7 @@ plperl_call_perl_func(plperl_proc_desc * desc, FunctionCallInfo fcinfo) SAVETMPS; PUSHMARK(SP); + XPUSHs(sv_2mortal(newSVpv("undef", 0))); for (i = 0; i < desc->nargs; i++) { if (desc->arg_is_rowtype[i]) @@ -468,6 +774,57 @@ plperl_call_perl_func(plperl_proc_desc * desc, FunctionCallInfo fcinfo) 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,11 +838,17 @@ plperl_func_handler(PG_FUNCTION_ARGS) /* 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,14 +859,146 @@ plperl_func_handler(PG_FUNCTION_ARGS) if (SPI_finish() != SPI_OK_FINISH) elog(ERROR, "SPI_finish() failed"); - if (!(perlret && SvOK(perlret))) + 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,10 +1006,101 @@ plperl_func_handler(PG_FUNCTION_ARGS) } 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,6 +1130,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger) sprintf(internal_proname, "__PLPerl_proc_%u", fn_oid); else sprintf(internal_proname, "__PLPerl_proc_%u_trigger", fn_oid); + proname_len = strlen(internal_proname); /************************************************************ @@ -637,10 +1224,11 @@ compile_plperl_function(Oid fn_oid, bool is_trigger) } typeStruct = (Form_pg_type) GETSTRUCT(typeTup); - /* Disallow pseudotype result, except VOID */ + /* Disallow pseudotype result, except VOID or RECORD */ if (typeStruct->typtype == 'p') { - if (procStruct->prorettype == VOIDOID) + if (procStruct->prorettype == VOIDOID || + procStruct->prorettype == RECORDOID) /* okay */ ; else if (procStruct->prorettype == TRIGGEROID) { @@ -661,13 +1249,10 @@ compile_plperl_function(Oid fn_oid, bool is_trigger) } } - if (typeStruct->typtype == 'c') + if (typeStruct->typtype == 'c' || procStruct->prorettype == RECORDOID) { - free(prodesc->proname); - free(prodesc); - ereport(ERROR, - (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), - errmsg("plperl functions cannot return tuples yet"))); + prodesc->fn_retistuple = true; + prodesc->ret_oid = typeStruct->typrelid; } perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func)); diff --git a/src/pl/plperl/spi_internal.c b/src/pl/plperl/spi_internal.c new file mode 100644 index 00000000000..582039c9018 --- /dev/null +++ b/src/pl/plperl/spi_internal.c @@ -0,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"; +} + diff --git a/src/pl/plperl/spi_internal.h b/src/pl/plperl/spi_internal.h new file mode 100644 index 00000000000..e8fce7c7dce --- /dev/null +++ b/src/pl/plperl/spi_internal.h @@ -0,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); + + |