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