Index: plperl.c
===================================================================
RCS file: /projects/cvsroot/pgsql/src/pl/plperl/plperl.c,v
retrieving revision 1.78
diff -c -r1.78 plperl.c
*** plperl.c	22 Jun 2005 16:45:51 -0000	1.78
--- plperl.c	1 Jul 2005 16:13:06 -0000
***************
*** 81,86 ****
--- 81,87 ----
  	bool		lanpltrusted;
  	bool		fn_retistuple;	/* true, if function returns tuple */
  	bool		fn_retisset;	/* true, if function returns set */
+ 	bool        fn_retisarray;  /* true if function returns array */
  	Oid			result_oid;		/* Oid of result type */
  	FmgrInfo	result_in_func;	/* I/O function and arg for result type */
  	Oid			result_typioparam;
***************
*** 191,198 ****
--- 192,220 ----
  		/* all one string follows (no commas please) */
  		"SPI::bootstrap(); use vars qw(%_SHARED);"
  		"sub ::mkunsafefunc {return eval(qq[ sub { $_[0] $_[1] } ]); }"
+ 		"sub ::_plperl_to_pg_array"
+ 		"{"
+ 		"  my $arg = shift; ref $arg eq 'ARRAY' || return $arg; "
+ 		"  my $res = ''; my $first = 1; "
+ 		"  foreach my $elem (@$arg) "
+ 		"  { "
+ 		"    $res .= ', ' unless $first; $first = undef; "
+ 		"    if (ref $elem) "
+ 		"    { "
+ 		"      $res .= _plperl_to_pg_array($elem); "
+ 		"    } "
+ 		"    else "
+ 		"    { "
+ 		"      my $str = qq($elem); "
+ 		"      $str =~ s/([\"\\\\])/\\\\$1/g; "
+ 		"      $res .= qq(\"$str\"); "
+ 		"    } "
+ 		"  } "
+ 		"  return qq({$res}); "
+ 		"} "
  	};
  
+ 
  	static char	   *strict_embedding[3] = {
  		"", "-e",
  		/* all one string follows (no commas please) */
***************
*** 225,230 ****
--- 247,253 ----
  	"$PLContainer->permit_only(':default');"
  	"$PLContainer->permit(qw[:base_math !:base_io sort time]);"
  	"$PLContainer->share(qw[&elog &spi_exec_query &return_next "
+ 	"&_plperl_to_pg_array "
  	"&DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED ]);"
  			   ;
  
***************
*** 325,330 ****
--- 348,381 ----
  	return tup;
  }
  
+ /*
+  * convert perl array to postgres string representation
+  */
+ static SV*
+ plperl_convert_to_pg_array(SV *src)
+ {
+     SV* rv;
+ 	int count;
+ 	dSP ;
+ 
+ 	PUSHMARK(SP) ;
+ 	XPUSHs(src);
+ 	PUTBACK ;
+ 
+ 	count = call_pv("_plperl_to_pg_array", G_SCALAR);
+ 
+ 	SPAGAIN ;
+ 
+ 	if (count != 1)
+ 		croak("Big trouble\n") ;
+ 
+ 	rv = POPs;
+ 			   
+ 	PUTBACK ;
+ 
+     return rv;
+ }
+ 
  
  /* Set up the arguments for a trigger call. */
  
***************
*** 863,869 ****
  
  	rsi = (ReturnSetInfo *)fcinfo->resultinfo;
  
! 	if (prodesc->fn_retisset) {
  		if (!rsi || !IsA(rsi, ReturnSetInfo) ||
  			(rsi->allowedModes & SFRM_Materialize) == 0 ||
  			rsi->expectedDesc == NULL)
--- 914,921 ----
  
  	rsi = (ReturnSetInfo *)fcinfo->resultinfo;
  
! 	if (prodesc->fn_retisset) 
! 	{
  		if (!rsi || !IsA(rsi, ReturnSetInfo) ||
  			(rsi->allowedModes & SFRM_Materialize) == 0 ||
  			rsi->expectedDesc == NULL)
***************
*** 884,890 ****
  			int i = 0;
  			SV **svp = 0;
  			AV *rav = (AV *)SvRV(perlret);
! 			while ((svp = av_fetch(rav, i, FALSE)) != NULL) {
  				plperl_return_next(*svp);
  				i++;
  			}
--- 936,943 ----
  			int i = 0;
  			SV **svp = 0;
  			AV *rav = (AV *)SvRV(perlret);
! 			while ((svp = av_fetch(rav, i, FALSE)) != NULL) 
! 			{
  				plperl_return_next(*svp);
  				i++;
  			}
***************
*** 898,904 ****
  		}
  
  		rsi->returnMode = SFRM_Materialize;
! 		if (prodesc->tuple_store) {
  			rsi->setResult = prodesc->tuple_store;
  			rsi->setDesc = prodesc->tuple_desc;
  		}
--- 951,958 ----
  		}
  
  		rsi->returnMode = SFRM_Materialize;
! 		if (prodesc->tuple_store) 
! 		{
  			rsi->setResult = prodesc->tuple_store;
  			rsi->setDesc = prodesc->tuple_desc;
  		}
***************
*** 943,950 ****
  	}
  	else
  	{
! 		/* Return a perl string converted to a Datum */
! 		char *val = SvPV(perlret, PL_na);
  		retval = FunctionCall3(&prodesc->result_in_func,
  							   CStringGetDatum(val),
  							   ObjectIdGetDatum(prodesc->result_typioparam),
--- 997,1016 ----
  	}
  	else
  	{
!         /* Return a perl string converted to a Datum */
!         char *val;
!         SV* array_ret;
!  
! 
!         if (prodesc->fn_retisarray && SvTYPE(SvRV(perlret)) == SVt_PVAV)
!         {
!             array_ret = plperl_convert_to_pg_array(perlret);
!             SvREFCNT_dec(perlret);
!             perlret = array_ret;
!         }
! 
! 		val = SvPV(perlret, PL_na);
! 
  		retval = FunctionCall3(&prodesc->result_in_func,
  							   CStringGetDatum(val),
  							   ObjectIdGetDatum(prodesc->result_typioparam),
***************
*** 1202,1207 ****
--- 1268,1276 ----
  			prodesc->fn_retistuple = (typeStruct->typtype == 'c' ||
  									  procStruct->prorettype == RECORDOID);
  
+ 			prodesc->fn_retisarray = 
+ 				(typeStruct->typlen == -1 && typeStruct->typelem) ;
+ 
  			perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
  			prodesc->result_typioparam = getTypeIOParam(typeTup);