Folks,

Pavel Stehule sent this to me, thinking I could review it.  I can't
just yet.  It refers to

<http://archives.postgresql.org/pgsql-hackers/2006-07/msg01421.php>

Thanks in advance :)

Cheers,
D
-- 
David Fetter <[EMAIL PROTECTED]> http://fetter.org/
phone: +1 415 235 3778        AIM: dfetter666
                              Skype: davidfetter

Remember to vote!
--- Begin Message ---
Hello,

I sending this patch for review. I'll try separate this patch to a)
better array support, b) consistency in OUT parameters.

I invite any comments

Regards
Pavel Stehule
*** ./plperl.c.orig	2006-07-29 21:07:09.000000000 +0200
--- ./plperl.c	2006-07-30 22:50:56.000000000 +0200
***************
*** 52,57 ****
--- 52,58 ----
  	FmgrInfo	result_in_func; /* I/O function and arg for result type */
  	Oid			result_typioparam;
  	int			nargs;
+   int num_out_args; /* number of out arguments */
  	FmgrInfo	arg_out_func[FUNC_MAX_ARGS];
  	bool		arg_is_rowtype[FUNC_MAX_ARGS];
  	SV		   *reference;
***************
*** 117,122 ****
--- 118,126 ----
  static void plperl_init_shared_libs(pTHX);
  static HV  *plperl_spi_execute_fetch_result(SPITupleTable *, int, int);
  
+ static SV  *plperl_convert_to_pg_array(SV *src);
+ 
+ 
  /*
   * This routine is a crock, and so is everyplace that calls it.  The problem
   * is that the cached form of plperl functions/queries is allocated permanently
***************
*** 412,418 ****
  					(errcode(ERRCODE_UNDEFINED_COLUMN),
  					 errmsg("Perl hash contains nonexistent column \"%s\"",
  							key)));
! 		if (SvOK(val) && SvTYPE(val) != SVt_NULL)
  			values[attn - 1] = SvPV(val, PL_na);
  	}
  	hv_iterinit(perlhash);
--- 416,427 ----
  					(errcode(ERRCODE_UNDEFINED_COLUMN),
  					 errmsg("Perl hash contains nonexistent column \"%s\"",
  							key)));
! 
! 		/* if value is ref on array do to pg string array conversion */
! 		if (SvTYPE(val) == SVt_RV &&
! 			SvTYPE(SvRV(val)) == SVt_PVAV)
! 			values[attn - 1] = SvPV(plperl_convert_to_pg_array(val), PL_na);
! 		else if (SvOK(val) && SvTYPE(val) != SVt_NULL)
  			values[attn - 1] = SvPV(val, PL_na);
  	}
  	hv_iterinit(perlhash);
***************
*** 691,702 ****
  	HeapTuple	tuple;
  	Form_pg_proc proc;
  	char		functyptype;
- 	int			numargs;
- 	Oid		   *argtypes;
- 	char	  **argnames;
- 	char	   *argmodes;
  	bool		istrigger = false;
- 	int			i;
  
  	/* Get the new function's pg_proc entry */
  	tuple = SearchSysCache(PROCOID,
--- 700,706 ----
***************
*** 724,740 ****
  							format_type_be(proc->prorettype))));
  	}
  
- 	/* Disallow pseudotypes in arguments (either IN or OUT) */
- 	numargs = get_func_arg_info(tuple,
- 								&argtypes, &argnames, &argmodes);
- 	for (i = 0; i < numargs; i++)
- 	{
- 		if (get_typtype(argtypes[i]) == 'p')
- 			ereport(ERROR,
- 					(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
- 					 errmsg("plperl functions cannot take type %s",
- 							format_type_be(argtypes[i]))));
- 	}
  
  	ReleaseSysCache(tuple);
  
--- 728,733 ----
***************
*** 1014,1019 ****
--- 1007,1065 ----
  	return retval;
  }
  
+ /*
+  * Verify type of result if proc has out params and transform it
+  * to scalar if proc has only one out parameter
+  */
+ 
+ static SV *
+ plperl_transform_result(plperl_proc_desc *prodesc, SV *result)
+ {
+ 	bool        exactly_one_field = false;
+ 	HV         *hvr;
+ 	SV		   *val;
+ 	char	   *key;
+ 	I32			klen;
+ 
+ 
+ 	if (prodesc->num_out_args > 0)
+ 	{
+ 		if (!SvOK(result) || SvTYPE(result) != SVt_RV ||
+ 			SvTYPE(SvRV(result)) != SVt_PVHV)
+ 		{
+ 			ereport(ERROR,
+ 					(errcode(ERRCODE_DATATYPE_MISMATCH),
+ 					 errmsg("Perl function with OUT arguments"
+ 							" must return reference to hash")));
+ 		}
+ 
+ 		if (prodesc->num_out_args == 1)
+ 		{
+ 			hvr = (HV *) SvRV(result);
+ 			hv_iterinit(hvr);
+ 
+ 			while ((val = hv_iternextsv(hvr, &key, &klen)))
+ 			{
+ 				if (exactly_one_field)
+ 					ereport(ERROR,
+ 							(errcode(ERRCODE_UNDEFINED_COLUMN),
+ 							 errmsg("Perl hash contains nonexistent column \"%s\"",
+ 									key)));
+ 				exactly_one_field = true;
+ 				result = val;
+ 			}
+ 
+ 			if (!exactly_one_field)
+ 				ereport(ERROR,
+ 						(errcode(ERRCODE_UNDEFINED_COLUMN),
+ 						 errmsg("Perl hash is empty")));
+ 			
+ 			hv_iterinit(hvr);
+ 		}	    
+ 	}
+ 
+ 	return result;
+ }
  
  static Datum
  plperl_func_handler(PG_FUNCTION_ARGS)
***************
*** 1079,1084 ****
--- 1125,1131 ----
  
  			while ((svp = av_fetch(rav, i, FALSE)) != NULL)
  			{
+ 				
  				plperl_return_next(*svp);
  				i++;
  			}
***************
*** 1120,1126 ****
  		{
  			ereport(ERROR,
  					(errcode(ERRCODE_DATATYPE_MISMATCH),
! 					 errmsg("composite-returning Perl function "
  							"must return reference to hash")));
  		}
  
--- 1167,1173 ----
  		{
  			ereport(ERROR,
  					(errcode(ERRCODE_DATATYPE_MISMATCH),
! 					 errmsg("composite-returning Perl function or function with out parameters"
  							"must return reference to hash")));
  		}
  
***************
*** 1142,1149 ****
  		/* Return a perl string converted to a Datum */
  		char	   *val;
  
  		if (prodesc->fn_retisarray && SvROK(perlret) &&
! 			SvTYPE(SvRV(perlret)) == SVt_PVAV)
  		{
  			array_ret = plperl_convert_to_pg_array(perlret);
  			SvREFCNT_dec(perlret);
--- 1189,1198 ----
  		/* Return a perl string converted to a Datum */
  		char	   *val;
  
+ 		perlret = plperl_transform_result(prodesc, perlret);
+ 
  		if (prodesc->fn_retisarray && SvROK(perlret) &&
! 			SvTYPE(SvRV(perlret)) == SVt_PVAV )
  		{
  			array_ret = plperl_convert_to_pg_array(perlret);
  			SvREFCNT_dec(perlret);
***************
*** 1272,1277 ****
--- 1321,1330 ----
  	plperl_proc_desc *prodesc = NULL;
  	int			i;
  	SV		  **svp;
+ 	int			numargs;
+ 	Oid		   *argtypes;
+ 	char	  **argnames;
+ 	char	   *argmodes;
  
  	/* We'll need the pg_proc tuple in any case... */
  	procTup = SearchSysCache(PROCOID,
***************
*** 1281,1286 ****
--- 1334,1340 ----
  		elog(ERROR, "cache lookup failed for function %u", fn_oid);
  	procStruct = (Form_pg_proc) GETSTRUCT(procTup);
  
+ 
  	/************************************************************
  	 * Build our internal proc name from the function's Oid
  	 ************************************************************/
***************
*** 1351,1356 ****
--- 1405,1427 ----
  		prodesc->fn_readonly =
  			(procStruct->provolatile != PROVOLATILE_VOLATILE);
  
+ 
+ 		/* Disallow pseudotypes in arguments (either IN or OUT) and count procedure OUT arguments */
+ 		numargs = get_func_arg_info(procTup,
+ 									&argtypes, &argnames, &argmodes);
+ 
+ 		for (i = 0; i < numargs; i++)
+ 		{
+ 		    if (get_typtype(argtypes[i]) == 'p')
+ 				ereport(ERROR,
+ 						(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ 						 errmsg("plperl functions cannot take type %s",
+ 								format_type_be(argtypes[i]))));
+ 
+ 		    if (argmodes && argmodes[i] == PROARGMODE_OUT)
+ 				prodesc->num_out_args++;
+ 		}
+ 
  		/************************************************************
  		 * Lookup the pg_language tuple by Oid
  		 ************************************************************/
***************
*** 1690,1695 ****
--- 1761,1768 ----
  	fcinfo = current_call_data->fcinfo;
  	rsi = (ReturnSetInfo *) fcinfo->resultinfo;
  
+ 	sv = plperl_transform_result(prodesc, sv);
+ 
  	if (!prodesc->fn_retisset)
  		ereport(ERROR,
  				(errcode(ERRCODE_SYNTAX_ERROR),
***************
*** 1764,1773 ****
  	{
  		Datum		ret;
  		bool		isNull;
  
  		if (SvOK(sv) && SvTYPE(sv) != SVt_NULL)
  		{
! 			char	   *val = SvPV(sv, PL_na);
  
  			ret = InputFunctionCall(&prodesc->result_in_func, val,
  									prodesc->result_typioparam, -1);
--- 1837,1854 ----
  	{
  		Datum		ret;
  		bool		isNull;
+ 		SV         *array_ret;
+ 		char       *val;
  
  		if (SvOK(sv) && SvTYPE(sv) != SVt_NULL)
  		{
! 			if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV )
! 			{
! 				array_ret = plperl_convert_to_pg_array(sv);
! 				sv = array_ret;
! 			}
! 
! 			val = SvPV(sv, PL_na);
  
  			ret = InputFunctionCall(&prodesc->result_in_func, val,
  									prodesc->result_typioparam, -1);
*** ./sql/plperl.sql.orig	2006-07-30 22:52:04.000000000 +0200
--- ./sql/plperl.sql	2006-07-30 22:54:27.000000000 +0200
***************
*** 337,339 ****
--- 337,391 ----
  $$ LANGUAGE plperl;
  SELECT * from perl_spi_prepared_set(1,2);
  
+ --- 
+ --- Some OUT and OUT array tests
+ ---
+ 
+ -- wrong, OUT params needs hash
+ create or replace function test01(OUT a varchar) as $$
+   return 'ahoj';
+ $$ language plperl ;
+ select '01' as i,* from test01();
+ 
+ create or replace function test02(OUT a varchar, OUT b varchar) as $$
+   return { a=> 'ahoj', b=>'svete'};
+ $$ language plperl;
+ select '02' as i, * from test02();
+   
+ create or replace function test03(OUT a varchar[]) as $$
+   return {a=>['ahoj']};
+ $$ language plperl;
+ select '03' as i,a[1] from test03();
+ 
+ create or replace function test04(OUT a varchar[], out b varchar[]) as $$
+   return { a=> ['ahoj'], b=>['velky','svete']};
+ $$ language plperl;
+ select '04' as i,* from test04();
+ 
+ create or replace function test05(OUT a varchar[], out b varchar[]) returns setof record as $$
+   return_next { a=> ['ahoj'], b=>['velky','svete']};
+   return_next { a=> ['ahoj'], b=>['velky','svete']};
+   return_next { a=> ['ahoj'], b=>['velky','svete']};
+ $$ language plperl;
+ select '05' as i,* from test05();
+ 
+ create or replace function test06(OUT a varchar[]) returns setof varchar[] as $$
+   return_next { a=> ['ahoj']};
+   return_next { a=> ['ahoj']};
+   return_next { a=> ['ahoj']};
+ $$ language plperl;
+ select '06' as i,* from test06();
+ 
+ create or replace function test07() returns setof varchar[] as $$
+   return_next ['ahoj'];
+   return_next ['ahoj'];
+ $$ language plperl;
+ select '07' as i,* from test07();
+ 
+ drop function test02();
+ drop function test03();
+ drop function test04();
+ drop function test05();
+ drop function test06();
+ drop function test07();
+ 

--- End Message ---
---------------------------(end of broadcast)---------------------------
TIP 3: Have you checked our extensive FAQ?

               http://www.postgresql.org/docs/faq

Reply via email to