plperl update from Andrew Dunstan, deriving (I believe) from Command Prompt's

plperlNG. Review and minor cleanup/improvements by Joe Conway.

Summary of new functionality:
- Shared data space and namespace. There is a new global variable %_SHARED
  that functions can use to store and save data between invocations of a
  function, or between different functions. Also, all trusted plperl function
  now share a common Safe container (this is an optimization, also), which
  they can use for storing non-lexical variables, functions, etc.
- Triggers are now supported
- Records can now be returned (as a hash reference)
- Sets of records can now be returned (as a reference to an array of hash
  references).
- New function spi_exec_query() provided for performing db functions or
  getting data from db.
- Optimization for counting hash keys (Abhijit Menon-Sen)
- Allow return of 'record' and 'setof record'

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
 

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

src/pl/plperl/eloglvl.c

@@ -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;
-}

src/pl/plperl/eloglvl.h

@@ -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);

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();"
+		"require Safe; SPI::bootstrap(); use vars qw(%_SHARED);"
-		"sub ::mksafefunc { my $x = new Safe; $x->permit_only(':default');$x->permit(':base_math');"
+		"use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');"
-		"$x->share(qw[&elog &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR]);"
+		"$PLContainer->permit_only(':default');$PLContainer->permit(':base_math');"
-		" return $x->reval(qq[sub { $_[0] }]); }"
+		"$PLContainer->share(qw[&elog &spi_exec_query &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %SHARED ]);"
-		"sub ::mkunsafefunc {return eval(qq[ sub { $_[0] } ]); }"
+		"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))
-	{
+		retval = PointerGetDatum(plperl_trigger_handler(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);
 
@@ -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,13 +859,145 @@ 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)),
@@ -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);
+				prodesc->fn_retistuple = true;
-				free(prodesc);
+				prodesc->ret_oid = typeStruct->typrelid;
-				ereport(ERROR,
-						(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
-				   errmsg("plperl functions cannot return tuples yet")));
 			}
 
 			perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));

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";
+}
+

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);
+
+