Make plperl work with OUT parameters.

src/pl/plperl/plperl.c

@@ -33,7 +33,7 @@
  *	  ENHANCEMENTS, OR MODIFICATIONS.
  *
  * IDENTIFICATION
- *	  $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.70 2005/03/29 00:17:20 tgl Exp $
+ *	  $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.71 2005/04/01 19:34:06 tgl Exp $
  *
  **********************************************************************/
 
@@ -409,21 +409,16 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
  * NB: copy the result if needed for any great length of time
  */
 static TupleDesc
-get_function_tupdesc(Oid result_type, ReturnSetInfo *rsinfo)
+get_function_tupdesc(FunctionCallInfo fcinfo)
 {
-	if (result_type == RECORDOID)
-	{
-		/* We must get the information from call context */
-		if (!rsinfo || !IsA(rsinfo, ReturnSetInfo) ||
-			rsinfo->expectedDesc == NULL)
-			ereport(ERROR,
-					(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
-					 errmsg("function returning record called in context "
-							"that cannot accept type record")));
-		return rsinfo->expectedDesc;
-	}
-	else				/* ordinary composite type */
-		return lookup_rowtype_tupdesc(result_type, -1);
+	TupleDesc	result;
+
+	if (get_call_result_type(fcinfo, NULL, &result) != TYPEFUNC_COMPOSITE)
+		ereport(ERROR,
+				(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+				 errmsg("function returning record called in context "
+						"that cannot accept type record")));
+	return result;
 }
 
 /**********************************************************************
@@ -897,8 +892,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
 
 			/* Cache a copy of the result's tupdesc and attinmeta */
 			oldcontext = MemoryContextSwitchTo(funcctx->multi_call_memory_ctx);
-			tupdesc = get_function_tupdesc(prodesc->result_oid,
-										(ReturnSetInfo *) fcinfo->resultinfo);
+			tupdesc = get_function_tupdesc(fcinfo);
 			tupdesc = CreateTupleDescCopy(tupdesc);
 			funcctx->attinmeta = TupleDescGetAttInMetadata(tupdesc);
 			MemoryContextSwitchTo(oldcontext);
@@ -1003,8 +997,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
 		/*
 		 * XXX should cache the attinmeta data instead of recomputing
 		 */
-		td = get_function_tupdesc(prodesc->result_oid,
-								  (ReturnSetInfo *) fcinfo->resultinfo);
+		td = get_function_tupdesc(fcinfo);
 		/* td = CreateTupleDescCopy(td); */
 		attinmeta = TupleDescGetAttInMetadata(td);
 

src/pl/plperl/test/test.expected

@@ -222,6 +222,61 @@ SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text);
   3 | Hello | PL/Perl
 (3 rows)
 
+CREATE OR REPLACE FUNCTION
+perl_out_params(f1 out integer, f2 out text, f3 out text) AS $$
+    return {f2 => 'hello', f1 => 1, f3 => 'world'};
+$$ LANGUAGE plperl;
+SELECT perl_out_params();
+ perl_out_params 
+-----------------
+ (1,hello,world)
+(1 row)
+
+SELECT * FROM perl_out_params();
+ f1 |  f2   |  f3   
+----+-------+-------
+  1 | hello | world
+(1 row)
+
+SELECT (perl_out_params()).f2;
+  f2   
+-------
+ hello
+(1 row)
+
+CREATE OR REPLACE FUNCTION
+perl_out_params_set(out f1 integer, out f2 text, out f3 text)
+RETURNS SETOF record AS $$
+    return [
+        { f1 => 1, f2 => 'Hello', f3 =>  'World' },
+        { f1 => 2, f2 => 'Hello', f3 =>  'PostgreSQL' },
+        { f1 => 3, f2 => 'Hello', f3 =>  'PL/Perl' }
+    ];
+$$  LANGUAGE plperl;
+SELECT perl_out_params_set();
+ perl_out_params_set  
+----------------------
+ (1,Hello,World)
+ (2,Hello,PostgreSQL)
+ (3,Hello,PL/Perl)
+(3 rows)
+
+SELECT * FROM perl_out_params_set();
+ f1 |  f2   |     f3     
+----+-------+------------
+  1 | Hello | World
+  2 | Hello | PostgreSQL
+  3 | Hello | PL/Perl
+(3 rows)
+
+SELECT (perl_out_params_set()).f3;
+     f3     
+------------
+ World
+ PostgreSQL
+ PL/Perl
+(3 rows)
+
 CREATE TYPE footype AS (x INTEGER, y INTEGER);
 CREATE OR REPLACE FUNCTION foo_good() RETURNS SETOF footype AS $$
 return [

src/pl/plperl/test/test_queries.sql

@@ -135,6 +135,29 @@ SELECT perl_record_set();
 SELECT * FROM perl_record_set();
 SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text);
 
+CREATE OR REPLACE FUNCTION
+perl_out_params(f1 out integer, f2 out text, f3 out text) AS $$
+    return {f2 => 'hello', f1 => 1, f3 => 'world'};
+$$ LANGUAGE plperl;
+
+SELECT perl_out_params();
+SELECT * FROM perl_out_params();
+SELECT (perl_out_params()).f2;
+
+CREATE OR REPLACE FUNCTION
+perl_out_params_set(out f1 integer, out f2 text, out f3 text)
+RETURNS SETOF record AS $$
+    return [
+        { f1 => 1, f2 => 'Hello', f3 =>  'World' },
+        { f1 => 2, f2 => 'Hello', f3 =>  'PostgreSQL' },
+        { f1 => 3, f2 => 'Hello', f3 =>  'PL/Perl' }
+    ];
+$$  LANGUAGE plperl;
+
+SELECT perl_out_params_set();
+SELECT * FROM perl_out_params_set();
+SELECT (perl_out_params_set()).f3;
+
 --
 -- Check behavior with erroneous return values
 --