Re-apply plperl patch that allows OUT parameters to be placed into Perl

bmomjian · bmomjian · commit b5633943cbbb · 2006-08-13T02:37:11.000Z
hash and array variables.  (regression output updated)
diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out
@@ -468,3 +468,112 @@ SELECT * from perl_spi_prepared_set(1,2);
                      4
 (2 rows)
 
+--- 
+--- Some OUT and OUT array tests
+---
+CREATE OR REPLACE FUNCTION test_out_params(OUT a varchar, OUT b varchar) AS $$
+  return { a=> 'ahoj', b=>'svete'};
+$$ LANGUAGE plperl;
+SELECT '01' AS i, * FROM test_out_params();
+ i  |  a   |   b   
+----+------+-------
+ 01 | ahoj | svete
+(1 row)
+
+CREATE OR REPLACE FUNCTION test_out_params_array(OUT a varchar[], OUT b varchar[]) AS $$
+  return { a=> ['ahoj'], b=>['svete']};
+$$ LANGUAGE plperl;
+SELECT '02' AS i, * FROM test_out_params_array();
+ERROR:  array value must start with "{" or dimension information
+CREATE OR REPLACE FUNCTION test_out_params_set(OUT a varchar, out b varchar) RETURNS SETOF RECORD AS $$
+  return_next { a=> 'ahoj', b=>'svete'};
+  return_next { a=> 'ahoj', b=>'svete'};
+  return_next { a=> 'ahoj', b=>'svete'};
+$$ LANGUAGE plperl;
+SELECT '03' AS I,* FROM test_out_params_set();
+ i  |  a   |   b   
+----+------+-------
+ 03 | ahoj | svete
+ 03 | ahoj | svete
+ 03 | ahoj | svete
+(3 rows)
+
+CREATE OR REPLACE FUNCTION test_out_params_set_array(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 '04' AS I,* FROM test_out_params_set_array();
+ERROR:  error from Perl function: array value must start with "{" or dimension information at line 2.
+DROP FUNCTION test_out_params();
+DROP FUNCTION test_out_params_set();
+DROP FUNCTION test_out_params_array();
+DROP FUNCTION test_out_params_set_array();
+-- one out argument can be returned as scalar or hash
+CREATE OR REPLACE FUNCTION test01(OUT a varchar) AS $$
+  return 'ahoj';
+$$ LANGUAGE plperl ;
+SELECT '01' AS i,* FROM test01();
+ i  |  a   
+----+------
+ 01 | ahoj
+(1 row)
+
+CREATE OR REPLACE FUNCTION test02(OUT a varchar[]) AS $$
+  return {a=>['ahoj']};
+$$ LANGUAGE plperl;
+SELECT '02' AS i,a[1] FROM test02();
+ERROR:  array value must start with "{" or dimension information
+CREATE OR REPLACE FUNCTION test03(OUT a varchar[]) RETURNS SETOF varchar[] AS $$
+  return_next { a=> ['ahoj']};
+  return_next { a=> ['ahoj']};
+  return_next { a=> ['ahoj']};
+$$ LANGUAGE plperl;
+SELECT '03' AS i,* FROM test03();
+ERROR:  error from Perl function: array value must start with "{" or dimension information at line 2.
+CREATE OR REPLACE FUNCTION test04() RETURNS SETOF VARCHAR[] AS $$
+  return_next ['ahoj'];
+  return_next ['ahoj'];
+$$ LANGUAGE plperl;
+SELECT '04' AS i,* FROM test04();
+ERROR:  error from Perl function: array value must start with "{" or dimension information at line 2.
+CREATE OR REPLACE FUNCTION test05(OUT a varchar) AS $$
+  return {a=>'ahoj'};
+$$ LANGUAGE plperl;
+SELECT '05' AS i,a FROM test05();
+ i  |        a        
+----+-----------------
+ 05 | HASH(0x8558f9c)
+(1 row)
+
+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();
+ i  |        a        
+----+-----------------
+ 06 | HASH(0x8559230)
+ 06 | HASH(0x8559230)
+ 06 | HASH(0x8559230)
+(3 rows)
+
+CREATE OR REPLACE FUNCTION test07() RETURNS SETOF VARCHAR AS $$
+  return_next 'ahoj';
+  return_next 'ahoj';
+$$ LANGUAGE plperl;
+SELECT '07' AS i,* FROM test07();
+ i  | test07 
+----+--------
+ 07 | ahoj
+ 07 | ahoj
+(2 rows)
+
+DROP FUNCTION test01();
+DROP FUNCTION test02();
+DROP FUNCTION test03();
+DROP FUNCTION test04();
+DROP FUNCTION test05();
+DROP FUNCTION test06();
+DROP FUNCTION test07();
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
@@ -1,7 +1,7 @@
 /**********************************************************************
  * plperl.c - perl as a procedural language for PostgreSQL
  *
- *	  $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.115 2006/08/12 04:16:45 momjian Exp $
+ *	  $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.116 2006/08/13 02:37:11 momjian Exp $
  *
  **********************************************************************/
 
@@ -52,6 +52,7 @@ typedef struct plperl_proc_desc
 	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;
@@ -115,6 +116,9 @@ static SV  *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc);
 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);
+static SV *plperl_transform_result(plperl_proc_desc *prodesc, SV *result);
+
 /*
  * 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
@@ -404,7 +408,12 @@ plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
 					(errcode(ERRCODE_UNDEFINED_COLUMN),
 					 errmsg("Perl hash contains nonexistent column \"%s\"",
 							key)));
-		if (SvOK(val) && SvTYPE(val) != SVt_NULL)
+
+		/* 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);
@@ -681,12 +690,7 @@ plperl_validator(PG_FUNCTION_ARGS)
 	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,
@@ -714,18 +718,6 @@ plperl_validator(PG_FUNCTION_ARGS)
 							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);
 
 	/* Postpone body checks if !check_function_bodies */
@@ -1128,6 +1120,8 @@ plperl_func_handler(PG_FUNCTION_ARGS)
 		/* 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)
 		{
@@ -1256,7 +1250,6 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
 	char		internal_proname[64];
 	int			proname_len;
 	plperl_proc_desc *prodesc = NULL;
-	int			i;
 	SV		  **svp;
 
 	/* We'll need the pg_proc tuple in any case... */
@@ -1319,6 +1312,12 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
 		Datum		prosrcdatum;
 		bool		isnull;
 		char	   *proc_source;
+		int			i;
+		int			numargs;
+		Oid		   *argtypes;
+		char	  **argnames;
+		char	   *argmodes;
+
 
 		/************************************************************
 		 * Allocate a new procedure description block
@@ -1337,6 +1336,25 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
 		prodesc->fn_readonly =
 			(procStruct->provolatile != PROVOLATILE_VOLATILE);
 
+
+		/* Disallow pseudotypes in arguments (either IN or OUT) */
+		/* Count number of 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
 		 ************************************************************/
@@ -1676,6 +1694,8 @@ plperl_return_next(SV *sv)
 	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),
@@ -1753,7 +1773,16 @@ plperl_return_next(SV *sv)
 
 		if (SvOK(sv) && SvTYPE(sv) != SVt_NULL)
 		{
-			char	   *val = SvPV(sv, PL_na);
+			char	   *val;
+			SV         *array_ret;
+
+			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);
@@ -2368,3 +2397,46 @@ plperl_spi_freeplan(char *query)
 
 	SPI_freeplan( plan);
 }
+
+/*
+ * If plerl result is hash and fce result is scalar, it's hash form of
+ * out argument. Then, transform it to scalar
+ */
+
+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 == 1 && SvOK(result) 
+		&& SvTYPE(result) == SVt_RV && SvTYPE(SvRV(result)) == SVt_PVHV)
+	{
+		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;
+}
diff --git a/src/pl/plperl/sql/plperl.sql b/src/pl/plperl/sql/plperl.sql
