Index: plperl.c
===================================================================
RCS file: /projects/cvsroot/pgsql-server/src/pl/plperl/plperl.c,v
retrieving revision 1.45
diff -c -w -r1.45 plperl.c
*** plperl.c	1 Jul 2004 20:50:22 -0000	1.45
--- plperl.c	7 Jul 2004 15:35:35 -0000
***************
*** 80,85 ****
--- 80,86 ----
  	CommandId	fn_cmin;
  	bool		lanpltrusted;
  	bool		fn_retistuple;	/* true, if function returns tuple */
+ 	bool		fn_retisset;		/*true, if function returns set*/
  	Oid			ret_oid;		/* Oid of returning type */
  	FmgrInfo	result_in_func;
  	Oid			result_typioparam;
***************
*** 95,105 ****
   * Global data
   **********************************************************************/
  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
--- 96,108 ----
   * Global data
   **********************************************************************/
  static int	plperl_firstcall = 1;
+ static bool plperl_safe_init_done = false;
  static PerlInterpreter *plperl_interp = NULL;
  static HV  *plperl_proc_hash = NULL;
! static AV		   *g_row_keys = NULL;
! static AV		   *g_column_keys = NULL;
! static SV		   *srf_perlret=NULL; /*keep returned value*/
! static int			g_attr_num = 0;
  
  /**********************************************************************
   * Forward declarations
***************
*** 215,225 ****
  		 * 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] } ]); }"
  	};
  
--- 218,224 ----
  		 * no commas between the next lines please. They are supposed to be
  		 * one string
  		 */
! 		"SPI::bootstrap(); use vars qw(%_SHARED);"
  		"sub ::mkunsafefunc {return eval(qq[ sub { $_[0] $_[1] } ]); }"
  	};
  
***************
*** 238,243 ****
--- 237,277 ----
  
  }
  
+ 
+ static void
+ plperl_safe_init(void)
+ {
+ 	static char *safe_module  =
+ 		"require Safe; $Safe::VERSION";
+ 
+ 	static char * safe_ok =
+ 		"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]}]); }"
+ 		;
+ 
+ 	static char * safe_bad = 
+ 		"use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');"
+ 		"$PLContainer->permit_only(':default');$PLContainer->permit(':base_math');"
+ 		"$PLContainer->share(qw[&elog &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %SHARED ]);"
+ 		"sub ::mksafefunc { return $PLContainer->reval(qq[sub { "
+ 		"elog(ERROR,'trusted perl functions disabled - please upgrade perl Safe module to at least 2.09');}]); }"
+ 		;
+ 
+ 	SV * res;
+ 
+ 	float safe_version;
+ 
+ 	res = eval_pv(safe_module,FALSE); /* TRUE = croak if failure */
+ 
+ 	safe_version = SvNV(res);
+ 
+ 	eval_pv((safe_version < 2.09 ? safe_bad : safe_ok),FALSE);
+ 
+ 	plperl_safe_init_done = true;
+ }
+ 
  /**********************************************************************
   * turn a tuple into a hash expression and add it to a list
   **********************************************************************/
***************
*** 596,601 ****
--- 630,638 ----
  	SV		   *subref;
  	int			count;
  
+ 	if(trusted && !plperl_safe_init_done)
+ 		plperl_safe_init();
+ 
  	ENTER;
  	SAVETMPS;
  	PUSHMARK(SP);
***************
*** 839,853 ****
  	/* 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();
  	}
  
  	/************************************************************
--- 876,897 ----
  	/* Find or compile the function */
  	prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
  	/************************************************************
! 	 * Call the Perl function if not returning set
  	 ************************************************************/
+ 	 if (!prodesc->fn_retisset)
  		perlret = plperl_call_perl_func(prodesc, fcinfo);
! 	 else 
  	 {
+ 		if (SRF_IS_FIRSTCALL()) /*call function only once*/
+ 			srf_perlret = plperl_call_perl_func(prodesc, fcinfo);
+ 		perlret = srf_perlret;
+ 	 }
  
+ 	 if (prodesc->fn_retisset && SRF_IS_FIRSTCALL())
+ 	 {
+ 		 if (prodesc->fn_retistuple) g_column_keys = newAV();
  		 if (SvTYPE(perlret) != SVt_RV) 
! 			 elog(ERROR, "plperl: set-returning function must return reference");
  	}
  
  	/************************************************************
***************
*** 882,895 ****
  		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);
  
--- 926,940 ----
  		char	  **values = NULL;
  		ReturnSetInfo  *rsinfo = (ReturnSetInfo *) fcinfo->resultinfo;
  
! 		if (prodesc->fn_retisset && !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: composite-returning function must return a reference");
! 
  
  		isset = plperl_is_set(perlret);
  
***************
*** 997,1002 ****
--- 1042,1094 ----
  			SRF_RETURN_DONE(funcctx);
  		}
  	}
+ 	else if (prodesc->fn_retisset)
+ 	{
+ 		FuncCallContext	*funcctx;
+ 		
+ 		if (SRF_IS_FIRSTCALL())
+ 		{
+ 			MemoryContext oldcontext;
+ 			int i;
+ 
+ 			funcctx = SRF_FIRSTCALL_INIT();
+ 			oldcontext = MemoryContextSwitchTo(funcctx->multi_call_memory_ctx);
+ 
+ 			if(SvTYPE(SvRV(perlret))!=SVt_PVAV) elog(ERROR, "plperl: set-returning function must return reference to array");
+ 				else funcctx->max_calls =  av_len((AV*)SvRV(perlret))+1;
+ 		}
+ 		
+ 		funcctx = SRF_PERCALL_SETUP();
+ 		
+ 		if (funcctx->call_cntr < funcctx->max_calls)
+ 		{
+ 			Datum		result;
+ 			AV* 		array;
+ 			SV** 		svp;
+ 			int 			i;
+ 
+ 			array = (AV*)SvRV(perlret);
+ 			svp = av_fetch(array, funcctx->call_cntr, FALSE);
+ 
+ 			if (SvTYPE(*svp) != SVt_NULL)
+ 				result = FunctionCall3(&prodesc->result_in_func,
+ 								   PointerGetDatum(SvPV(*svp, PL_na)),
+ 								   ObjectIdGetDatum(prodesc->result_typioparam),
+ 								   Int32GetDatum(-1));
+ 			else
+ 			{
+ 				fcinfo->isnull = true;
+ 				result = (Datum) 0;
+ 			}
+ 			SRF_RETURN_NEXT(funcctx, result);
+ 			fcinfo->isnull = false;
+ 		} 
+ 		else
+ 		{
+ 			if (perlret) SvREFCNT_dec(perlret);
+ 			SRF_RETURN_DONE(funcctx);
+ 		}
+ 	 }
  	else if (! fcinfo->isnull)
  	{
  		retval = FunctionCall3(&prodesc->result_in_func,
***************
*** 1248,1253 ****
--- 1340,1347 ----
  								format_type_be(procStruct->prorettype))));
  				}
  			}
+ 
+ 			prodesc->fn_retisset = procStruct->proretset; /*true, if function returns set*/
  
  			if (typeStruct->typtype == 'c' || procStruct->prorettype == RECORDOID)
  			{
Index: spi_internal.c
===================================================================
RCS file: /projects/cvsroot/pgsql-server/src/pl/plperl/spi_internal.c,v
retrieving revision 1.1
diff -c -w -r1.1 spi_internal.c
*** spi_internal.c	1 Jul 2004 20:50:22 -0000	1.1
--- spi_internal.c	7 Jul 2004 15:35:35 -0000
***************
*** 82,123 ****
  		* 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);
  		}
  	}
--- 82,129 ----
  		* Get the attributes value
  		************************************************************/
  		attdata = SPI_getvalue(tuple, tupdesc, i+1);
+ 		if(attdata)
  			hv_store(array, attname, strlen(attname), newSVpv(attdata,0), 0);
+ 		else
+ 			hv_store(array, attname, strlen(attname), newSVpv("undef",0), 0);
  	}
  	return array;
  }
  
  static HV*
! plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed, int status)
  {
  
  	HV *result;
+ 	 AV *rows;
  	int i;
  
  	result = newHV();
+ 	rows = newAV();
  
  	if (status == SPI_OK_UTILITY)
  	{
  		hv_store(result, "status", strlen("status"), newSVpv("SPI_OK_UTILITY",0), 0);
! 		hv_store(result, "processed", strlen("processed"), newSViv(processed), 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, "processed", strlen("processed"), newSViv(processed), 0);
  	}
  	else
  	{
! 		hv_store(result, "status", strlen("status"), newSVpv((char*)plperl_spi_status_string(status),0), 0);
! 		hv_store(result, "processed", strlen("processed"), newSViv(processed), 0);
! 		if (processed)
  		{
  			HV *row;
! 			for (i = 0; i < processed; i++)
  			{
  				row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
! 				 av_store(rows, i, newRV_noinc((SV*)row));
  			}
+ 			hv_store(result, "rows", strlen("rows"), newRV_noinc((SV*)rows), 0);
  			SPI_freetuptable(tuptable);
  		}
  	}
Index: spi_internal.h
===================================================================
RCS file: /projects/cvsroot/pgsql-server/src/pl/plperl/spi_internal.h,v
retrieving revision 1.1
diff -c -w -r1.1 spi_internal.h
*** spi_internal.h	1 Jul 2004 20:50:22 -0000	1.1
--- spi_internal.h	7 Jul 2004 15:35:35 -0000
***************
*** 1,6 ****
--- 1,7 ----
  #include "EXTERN.h"
  #include "perl.h"
  #include "XSUB.h"
+ #include "ppport.h"
  
  int			spi_DEBUG(void);