Index: plperl.c
===================================================================
RCS file: /projects/cvsroot/pgsql-server/src/pl/plperl/plperl.c,v
retrieving revision 1.51
diff -c -w -r1.51 plperl.c
*** plperl.c	13 Sep 2004 20:08:59 -0000	1.51
--- plperl.c	30 Sep 2004 16:07:25 -0000
***************
*** 82,87 ****
--- 82,89 ----
  	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 "true" array*/
+ 	bool		fn_retispseudo; /* true, if function returns pseudo type*/
  	Oid			ret_oid;		/* Oid of returning type */
  	FmgrInfo	result_in_func;
  	Oid			result_typioparam;
***************
*** 89,94 ****
--- 91,97 ----
  	FmgrInfo	arg_out_func[FUNC_MAX_ARGS];
  	Oid			arg_typioparam[FUNC_MAX_ARGS];
  	bool		arg_is_rowtype[FUNC_MAX_ARGS];
+ 	bool		arg_is_p[FUNC_MAX_ARGS];
  	SV		   *reference;
  } plperl_proc_desc;
  
***************
*** 277,282 ****
--- 280,319 ----
  }
  
  /**********************************************************************
+  * convert perl array to the string representation
+  **********************************************************************/
+ static SV*
+ plperl_convert_to_pg_array(SV *src)
+ {
+ 	SV*	rv;
+ 	SV**	val;;
+ 	AV*	internal;
+ 	int	len,
+ 		i;
+ 
+ 	internal=(AV*)SvRV(src);
+ 	len = av_len(internal)+1;
+ 
+ 	rv = newSVpv("{ ",0);
+ 	for(i=0; i<len; i++)
+ 	{
+ 		val = av_fetch(internal, i, FALSE);
+ 		if (SvTYPE(*val)==SVt_RV)
+ 			if (SvTYPE(SvRV(*val))==SVt_PVAV)
+ 				sv_catpvf(rv, "%s", SvPV(plperl_convert_to_pg_array(*val),PL_na));
+ 			else
+ 				elog(ERROR, "plperl: check array structure");
+ 		else
+ 			sv_catpvf(rv, "%s", SvPV(*val,PL_na));
+ 		if (i != len-1) sv_catpvf(rv, ",");
+ 	}
+ 
+ 	sv_catpvf(rv, "}");
+ 
+ 	return rv;
+ }
+ 
+ /**********************************************************************
   * turn a tuple into a hash expression and add it to a list
   **********************************************************************/
  static void
***************
*** 752,757 ****
--- 789,807 ----
  	XPUSHs(sv_2mortal(newSVpv("undef", 0)));
  	for (i = 0; i < desc->nargs; i++)
  	{
+ 		if (desc->arg_is_p[i]){
+ 			HeapTuple	typeTup;
+ 			Form_pg_type	typeStruct;
+ 
+ 			typeTup = SearchSysCache(TYPEOID,
+ 							ObjectIdGetDatum(get_fn_expr_argtype(fcinfo->flinfo, i)),
+ 							0, 0, 0);
+ 			typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
+ 			perm_fmgr_info(typeStruct->typoutput, &(desc->arg_out_func[i]));
+ 			desc->arg_typioparam[i] = getTypeIOParam(typeTup);
+ 			ReleaseSysCache(typeTup);
+ 		}
+ 
  		if (desc->arg_is_rowtype[i])
  		{
  			if (fcinfo->argnull[i])
***************
*** 909,914 ****
--- 959,977 ----
  		perlret = srf_perlret;
  	}
  
+ 	if (prodesc->fn_retispseudo){
+ 		HeapTuple	retTypeTup;
+ 		Form_pg_type	retTypeStruct;
+ 
+ 		retTypeTup = SearchSysCache(TYPEOID,
+ 					    ObjectIdGetDatum(get_fn_expr_rettype(fcinfo->flinfo)),
+ 					    0, 0, 0);
+ 		retTypeStruct = (Form_pg_type) GETSTRUCT(retTypeTup);
+ 		perm_fmgr_info(retTypeStruct->typinput, &(prodesc->result_in_func));
+ 		prodesc->result_typioparam = getTypeIOParam(retTypeTup);
+ 		ReleaseSysCache(retTypeTup);
+ 	}
+ 
  	if (prodesc->fn_retisset && SRF_IS_FIRSTCALL())
  	{
  		if (prodesc->fn_retistuple)
***************
*** 1149,1161 ****
  
  		}
  		else
  /* perl string to Datum */
  
  			retval = FunctionCall3(&prodesc->result_in_func,
  								   PointerGetDatum(SvPV(perlret, PL_na)),
  							ObjectIdGetDatum(prodesc->result_typioparam),
  								   Int32GetDatum(-1));
! 
  	}
  
  	SvREFCNT_dec(perlret);
--- 1212,1234 ----
  
  		}
  		else
+ 		{
+ 			SV* ret;
+ 
+ 			if (prodesc->fn_retisarray)
+ 			{
+ 				if(SvTYPE(SvRV(perlret))!=SVt_PVAV) elog(ERROR, "plperl: this function must return reference to array");
+ 				ret = plperl_convert_to_pg_array(perlret);
+ 				SvREFCNT_dec(perlret);
+ 				perlret = ret;
+ 			}
  /* perl string to Datum */
  
  			retval = FunctionCall3(&prodesc->result_in_func,
  								   PointerGetDatum(SvPV(perlret, PL_na)),
  							ObjectIdGetDatum(prodesc->result_typioparam),
  								   Int32GetDatum(-1));
! 		}
  	}
  
  	SvREFCNT_dec(perlret);
***************
*** 1384,1395 ****
  			}
  			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)
  				{
  					free(prodesc->proname);
--- 1457,1471 ----
  			}
  			typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
  
! 			/* Disallow pseudotype result, except VOID, RECORD, ANYELEMENT or ANYARRAY */
  			if (typeStruct->typtype == 'p')
  			{
  				if (procStruct->prorettype == VOIDOID ||
! 					procStruct->prorettype == RECORDOID ||
! 					procStruct->prorettype == ANYARRAYOID ||
! 					procStruct->prorettype == ANYELEMENTOID)
! 					 /* okay */
! 					 prodesc->fn_retispseudo=true;
  				else if (procStruct->prorettype == TRIGGEROID)
  				{
  					free(prodesc->proname);
***************
*** 1421,1426 ****
--- 1497,1509 ----
  					procStruct->prorettype;
  			}
  
+ 			if (procStruct->prorettype != ANYARRAYOID)
+ 				if (typeStruct->typlen == -1 && typeStruct->typelem)  /*true, if function returns "true" array*/
+ 					prodesc->fn_retisarray = true;
+ 				else
+ 					prodesc->fn_retisarray = false;
+ 			else prodesc->fn_retisarray = true;
+ 
  			perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
  			prodesc->result_typioparam = getTypeIOParam(typeTup);
  
***************
*** 1448,1455 ****
  				}
  				typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
  
! 				/* Disallow pseudotype argument */
  				if (typeStruct->typtype == 'p')
  				{
  					free(prodesc->proname);
  					free(prodesc);
--- 1531,1543 ----
  				}
  				typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
  
! 				/* Disallow pseudotype argument, except ANYELEMENT or ANYARRAY */
  				if (typeStruct->typtype == 'p')
+ 					if (procStruct->proargtypes[i] == ANYARRAYOID ||
+ 						procStruct->proargtypes[i] == ANYELEMENTOID)
+ 					 /* okay */
+ 						prodesc->arg_is_p[i] = true;
+ 					else
  					{
  						free(prodesc->proname);
  						free(prodesc);
***************
*** 1458,1463 ****
--- 1546,1553 ----
  							   errmsg("plperl functions cannot take type %s",
  							   format_type_be(procStruct->proargtypes[i]))));
  					}
+ 				else
+ 					prodesc->arg_is_p[i] = false;
  
  				if (typeStruct->typtype == 'c')
  					prodesc->arg_is_rowtype[i] = true;