Andrew Dunstan wrote:
I will do some checking on these changes, but with those caveats they look
good to me.

Attached is an all inclusive revised patch. Please review and comment. If there are no objections, I'll commit in a few hours.


As a side note, I think it would be *really* helpful if there were a more comprehensive test script, and an expected results file available. Not sure though if it could be included in the standard regression tests on a configure-conditional basis -- anyone know?

Joe
Index: src/pl/plperl/GNUmakefile
===================================================================
RCS file: /cvsroot/pgsql-server/src/pl/plperl/GNUmakefile,v
retrieving revision 1.12
diff -c -r1.12 GNUmakefile
*** src/pl/plperl/GNUmakefile	21 Jan 2004 19:04:11 -0000	1.12
--- src/pl/plperl/GNUmakefile	1 Jul 2004 16:24:53 -0000
***************
*** 25,32 ****
  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,37 ----
  SO_MAJOR_VERSION = 0
  SO_MINOR_VERSION = 0
  
! OBJS = plperl.o spi_internal.o SPI.o
! 
! ifeq ($(enable_rpath), yes)
  SHLIB_LINK = $(perl_embed_ldflags) $(BE_DLLLIBS)
+ else
+ SHLIB_LINK = $(perl_embed_ldflags) $(BE_DLLLIBS) -Wl,-rpath,$(perl_archlibexp)/CORE
+ endif
  
  include $(top_srcdir)/src/Makefile.shlib
  
Index: src/pl/plperl/SPI.xs
===================================================================
RCS file: /cvsroot/pgsql-server/src/pl/plperl/SPI.xs,v
retrieving revision 1.5
diff -c -r1.5 SPI.xs
*** src/pl/plperl/SPI.xs	4 Sep 2002 22:49:37 -0000	1.5
--- src/pl/plperl/SPI.xs	1 Jul 2004 16:24:53 -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/eloglvl.c
===================================================================
RCS file: src/pl/plperl/eloglvl.c
diff -N src/pl/plperl/eloglvl.c
*** src/pl/plperl/eloglvl.c	25 Jul 2003 23:37:28 -0000	1.9
--- /dev/null	1 Jan 1970 00:00:00 -0000
***************
*** 1,45 ****
- #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;
- }
--- 0 ----
Index: src/pl/plperl/eloglvl.h
===================================================================
RCS file: src/pl/plperl/eloglvl.h
diff -N src/pl/plperl/eloglvl.h
*** src/pl/plperl/eloglvl.h	4 Sep 2002 20:31:47 -0000	1.5
--- /dev/null	1 Jan 1970 00:00:00 -0000
***************
*** 1,12 ****
- 
- int			elog_DEBUG(void);
- 
- int			elog_LOG(void);
- 
- int			elog_INFO(void);
- 
- int			elog_NOTICE(void);
- 
- int			elog_WARNING(void);
- 
- int			elog_ERROR(void);
--- 0 ----
Index: src/pl/plperl/plperl.c
===================================================================
RCS file: /cvsroot/pgsql-server/src/pl/plperl/plperl.c,v
retrieving revision 1.44
diff -c -r1.44 plperl.c
*** src/pl/plperl/plperl.c	6 Jun 2004 00:41:28 -0000	1.44
--- src/pl/plperl/plperl.c	1 Jul 2004 16:24:53 -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,549 ----
  
  }
  
+ /**********************************************************************
+  * 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,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);
  
--- 576,582 ----
  	 * call appropriate subhandler
  	 ************************************************************/
  	if (CALLED_AS_TRIGGER(fcinfo))
! 		retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
  	else
  		retval = plperl_func_handler(fcinfo);
  
***************
*** 295,300 ****
--- 599,605 ----
  	ENTER;
  	SAVETMPS;
  	PUSHMARK(SP);
+ 	XPUSHs(sv_2mortal(newSVpv("my $_TD=$_[0]; shift;", 0)));
  	XPUSHs(sv_2mortal(newSVpv(s, 0)));
  	PUTBACK;
  
***************
*** 387,392 ****
--- 692,698 ----
  	SAVETMPS;
  
  	PUSHMARK(SP);
+ 	XPUSHs(sv_2mortal(newSVpv("undef", 0)));
  	for (i = 0; i < desc->nargs; i++)
  	{
  		if (desc->arg_is_rowtype[i])
***************
*** 468,473 ****
--- 774,830 ----
  	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
--- 838,854 ----
  
  	/* 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,509 ****
  	if (SPI_finish() != SPI_OK_FINISH)
  		elog(ERROR, "SPI_finish() failed");
  
! 	if (!(perlret && SvOK(perlret)))
  	{
  		/* return NULL if Perl code returned undef */
  		retval = (Datum) 0;
  		fcinfo->isnull = true;
  	}
  	else
  	{
  		retval = FunctionCall3(&prodesc->result_in_func,
  							   PointerGetDatum(SvPV(perlret, PL_na)),
  							   ObjectIdGetDatum(prodesc->result_typioparam),
--- 859,1004 ----
  	if (SPI_finish() != SPI_OK_FINISH)
  		elog(ERROR, "SPI_finish() failed");
  
! 	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,520 ****
  	}
  
  	SvREFCNT_dec(perlret);
- 
  	return retval;
  }
  
  
  /**********************************************************************
   * compile_plperl_function	- compile (or hopefully just look up) function
--- 1006,1106 ----
  	}
  
  	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 ****
--- 1130,1136 ----
  		sprintf(internal_proname, "__PLPerl_proc_%u", fn_oid);
  	else
  		sprintf(internal_proname, "__PLPerl_proc_%u_trigger", fn_oid);
+ 
  	proname_len = strlen(internal_proname);
  
  	/************************************************************
***************
*** 637,646 ****
  			}
  			typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
  
! 			/* Disallow pseudotype result, except VOID */
  			if (typeStruct->typtype == 'p')
  			{
! 				if (procStruct->prorettype == VOIDOID)
  					 /* okay */ ;
  				else if (procStruct->prorettype == TRIGGEROID)
  				{
--- 1224,1234 ----
  			}
  			typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
  
! 			/* Disallow pseudotype result, except VOID or RECORD */
  			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));
--- 1249,1258 ----
  				}
  			}
  
! 			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));
Index: src/pl/plperl/spi_internal.c
===================================================================
RCS file: src/pl/plperl/spi_internal.c
diff -N src/pl/plperl/spi_internal.c
*** /dev/null	1 Jan 1970 00:00:00 -0000
--- src/pl/plperl/spi_internal.c	1 Jul 2004 16:24:53 -0000
***************
*** 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";
+ }
+ 
Index: src/pl/plperl/spi_internal.h
===================================================================
RCS file: src/pl/plperl/spi_internal.h
diff -N src/pl/plperl/spi_internal.h
*** /dev/null	1 Jan 1970 00:00:00 -0000
--- src/pl/plperl/spi_internal.h	1 Jul 2004 16:24:53 -0000
***************
*** 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);
+ 
+ 
---------------------------(end of broadcast)---------------------------
TIP 9: the planner will ignore your desire to choose an index scan if your
      joining column's datatypes do not match

Reply via email to