Support domains over composite types in PL/Perl.

In passing, don't insist on rsi->expectedDesc being set unless we
actually need it; this allows succeeding in a couple of cases where
PL/Perl functions returning setof composite would have failed before,
and makes the error message more apropos in other cases.

Discussion: https://postgr.es/m/4206.1499798337@sss.pgh.pa.us

5 files changed, 222 insertions, 38 deletions

diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out
index 14df5f42df..ebfba3eb8d 100644
--- a/src/pl/plperl/expected/plperl.out
+++ b/src/pl/plperl/expected/plperl.out
@@ -214,8 +214,10 @@ CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
     return undef;
 $$  LANGUAGE plperl;
 SELECT perl_record_set();
-ERROR:  set-valued function called in context that cannot accept a set
-CONTEXT:  PL/Perl function "perl_record_set"
+ perl_record_set 
+-----------------
+(0 rows)
+
 SELECT * FROM perl_record_set();
 ERROR:  a column definition list is required for functions returning "record"
 LINE 1: SELECT * FROM perl_record_set();
@@ -233,7 +235,7 @@ CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
     ];
 $$  LANGUAGE plperl;
 SELECT perl_record_set();
-ERROR:  set-valued function called in context that cannot accept a set
+ERROR:  function returning record called in context that cannot accept type record
 CONTEXT:  PL/Perl function "perl_record_set"
 SELECT * FROM perl_record_set();
 ERROR:  a column definition list is required for functions returning "record"
@@ -250,7 +252,7 @@ CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
     ];
 $$  LANGUAGE plperl;
 SELECT perl_record_set();
-ERROR:  set-valued function called in context that cannot accept a set
+ERROR:  function returning record called in context that cannot accept type record
 CONTEXT:  PL/Perl function "perl_record_set"
 SELECT * FROM perl_record_set();
 ERROR:  a column definition list is required for functions returning "record"
@@ -387,6 +389,44 @@ $$ LANGUAGE plperl;
 SELECT * FROM foo_set_bad();
 ERROR:  Perl hash contains nonexistent column "z"
 CONTEXT:  PL/Perl function "foo_set_bad"
+CREATE DOMAIN orderedfootype AS footype CHECK ((VALUE).x <= (VALUE).y);
+CREATE OR REPLACE FUNCTION foo_ordered() RETURNS orderedfootype AS $$
+    return {x => 3, y => 4};
+$$ LANGUAGE plperl;
+SELECT * FROM foo_ordered();
+ x | y 
+---+---
+ 3 | 4
+(1 row)
+
+CREATE OR REPLACE FUNCTION foo_ordered() RETURNS orderedfootype AS $$
+    return {x => 5, y => 4};
+$$ LANGUAGE plperl;
+SELECT * FROM foo_ordered();  -- fail
+ERROR:  value for domain orderedfootype violates check constraint "orderedfootype_check"
+CONTEXT:  PL/Perl function "foo_ordered"
+CREATE OR REPLACE FUNCTION foo_ordered_set() RETURNS SETOF orderedfootype AS $$
+return [
+    {x => 3, y => 4},
+    {x => 4, y => 7}
+];
+$$ LANGUAGE plperl;
+SELECT * FROM foo_ordered_set();
+ x | y 
+---+---
+ 3 | 4
+ 4 | 7
+(2 rows)
+
+CREATE OR REPLACE FUNCTION foo_ordered_set() RETURNS SETOF orderedfootype AS $$
+return [
+    {x => 3, y => 4},
+    {x => 9, y => 7}
+];
+$$ LANGUAGE plperl;
+SELECT * FROM foo_ordered_set();  -- fail
+ERROR:  value for domain orderedfootype violates check constraint "orderedfootype_check"
+CONTEXT:  PL/Perl function "foo_ordered_set"
 --
 -- Check passing a tuple argument
 --
@@ -411,6 +451,46 @@ SELECT perl_get_field((11,12), 'z');
                
 (1 row)
 
+CREATE OR REPLACE FUNCTION perl_get_cfield(orderedfootype, text) RETURNS integer AS $$
+    return $_[0]->{$_[1]};
+$$ LANGUAGE plperl;
+SELECT perl_get_cfield((11,12), 'x');
+ perl_get_cfield 
+-----------------
+              11
+(1 row)
+
+SELECT perl_get_cfield((11,12), 'y');
+ perl_get_cfield 
+-----------------
+              12
+(1 row)
+
+SELECT perl_get_cfield((12,11), 'x');  -- fail
+ERROR:  value for domain orderedfootype violates check constraint "orderedfootype_check"
+CREATE OR REPLACE FUNCTION perl_get_rfield(record, text) RETURNS integer AS $$
+    return $_[0]->{$_[1]};
+$$ LANGUAGE plperl;
+SELECT perl_get_rfield((11,12), 'f1');
+ perl_get_rfield 
+-----------------
+              11
+(1 row)
+
+SELECT perl_get_rfield((11,12)::footype, 'y');
+ perl_get_rfield 
+-----------------
+              12
+(1 row)
+
+SELECT perl_get_rfield((11,12)::orderedfootype, 'x');
+ perl_get_rfield 
+-----------------
+              11
+(1 row)
+
+SELECT perl_get_rfield((12,11)::orderedfootype, 'x');  -- fail
+ERROR:  value for domain orderedfootype violates check constraint "orderedfootype_check"
 --
 -- Test return_next
 --
diff --git a/src/pl/plperl/expected/plperl_util.out b/src/pl/plperl/expected/plperl_util.out
index 7cd027f33e..698a8a17fe 100644
--- a/src/pl/plperl/expected/plperl_util.out
+++ b/src/pl/plperl/expected/plperl_util.out
@@ -172,11 +172,13 @@ select perl_looks_like_number();
 -- test encode_typed_literal
 create type perl_foo as (a integer, b text[]);
 create type perl_bar as (c perl_foo[]);
+create domain perl_foo_pos as perl_foo check((value).a > 0);
 create or replace function perl_encode_typed_literal() returns setof text language plperl as $$
 	return_next encode_typed_literal(undef, 'text');
 	return_next encode_typed_literal([[1,2,3],[3,2,1],[1,3,2]], 'integer[]');
 	return_next encode_typed_literal({a => 1, b => ['PL','/','Perl']}, 'perl_foo');
 	return_next encode_typed_literal({c => [{a => 9, b => ['PostgreSQL']}, {b => ['Postgres'], a => 1}]}, 'perl_bar');
+	return_next encode_typed_literal({a => 1, b => ['PL','/','Perl']}, 'perl_foo_pos');
 $$;
 select perl_encode_typed_literal();
            perl_encode_typed_literal           
@@ -185,5 +187,12 @@ select perl_encode_typed_literal();
  {{1,2,3},{3,2,1},{1,3,2}}
  (1,"{PL,/,Perl}")
  ("{""(9,{PostgreSQL})"",""(1,{Postgres})""}")
-(4 rows)
+ (1,"{PL,/,Perl}")
+(5 rows)
 
+create or replace function perl_encode_typed_literal() returns setof text language plperl as $$
+	return_next encode_typed_literal({a => 0, b => ['PL','/','Perl']}, 'perl_foo_pos');
+$$;
+select perl_encode_typed_literal();  -- fail
+ERROR:  value for domain perl_foo_pos violates check constraint "perl_foo_pos_check"
+CONTEXT:  PL/Perl function "perl_encode_typed_literal"
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index 5a575bdbe4..ca0d1bccf8 100644
--- a/src/pl/plperl/plperl.c
+++ b/src/pl/plperl/plperl.c
@@ -179,8 +179,11 @@ typedef struct plperl_call_data
 {
 	plperl_proc_desc *prodesc;
 	FunctionCallInfo fcinfo;
+	/* remaining fields are used only in a function returning set: */
 	Tuplestorestate *tuple_store;
 	TupleDesc	ret_tdesc;
+	Oid			cdomain_oid;	/* 0 unless returning domain-over-composite */
+	void	   *cdomain_info;
 	MemoryContext tmp_cxt;
 } plperl_call_data;
 
@@ -1356,6 +1359,7 @@ plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod,
 			/* handle a hashref */
 			Datum		ret;
 			TupleDesc	td;
+			bool		isdomain;
 
 			if (!type_is_rowtype(typid))
 				ereport(ERROR,
@@ -1363,20 +1367,36 @@ plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod,
 						 errmsg("cannot convert Perl hash to non-composite type %s",
 								format_type_be(typid))));
 
-			td = lookup_rowtype_tupdesc_noerror(typid, typmod, true);
-			if (td == NULL)
+			td = lookup_rowtype_tupdesc_domain(typid, typmod, true);
+			if (td != NULL)
 			{
-				/* Try to look it up based on our result type */
-				if (fcinfo == NULL ||
-					get_call_result_type(fcinfo, NULL, &td) != TYPEFUNC_COMPOSITE)
+				/* Did we look through a domain? */
+				isdomain = (typid != td->tdtypeid);
+			}
+			else
+			{
+				/* Must be RECORD, try to resolve based on call info */
+				TypeFuncClass funcclass;
+
+				if (fcinfo)
+					funcclass = get_call_result_type(fcinfo, &typid, &td);
+				else
+					funcclass = TYPEFUNC_OTHER;
+				if (funcclass != TYPEFUNC_COMPOSITE &&
+					funcclass != TYPEFUNC_COMPOSITE_DOMAIN)
 					ereport(ERROR,
 							(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
 							 errmsg("function returning record called in context "
 									"that cannot accept type record")));
+				Assert(td);
+				isdomain = (funcclass == TYPEFUNC_COMPOSITE_DOMAIN);
 			}
 
 			ret = plperl_hash_to_datum(sv, td);
 
+			if (isdomain)
+				domain_check(ret, false, typid, NULL, NULL);
+
 			/* Release on the result of get_call_result_type is harmless */
 			ReleaseTupleDesc(td);
 
@@ -2401,8 +2421,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
 	{
 		/* Check context before allowing the call to go through */
 		if (!rsi || !IsA(rsi, ReturnSetInfo) ||
-			(rsi->allowedModes & SFRM_Materialize) == 0 ||
-			rsi->expectedDesc == NULL)
+			(rsi->allowedModes & SFRM_Materialize) == 0)
 			ereport(ERROR,
 					(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
 					 errmsg("set-valued function called in context that "
@@ -2809,22 +2828,21 @@ compile_plperl_function(Oid fn_oid, bool is_trigger, bool is_event_trigger)
 		 ************************************************************/
 		if (!is_trigger && !is_event_trigger)
 		{
-			typeTup =
-				SearchSysCache1(TYPEOID,
-								ObjectIdGetDatum(procStruct->prorettype));
+			Oid			rettype = procStruct->prorettype;
+
+			typeTup = SearchSysCache1(TYPEOID, ObjectIdGetDatum(rettype));
 			if (!HeapTupleIsValid(typeTup))
-				elog(ERROR, "cache lookup failed for type %u",
-					 procStruct->prorettype);
+				elog(ERROR, "cache lookup failed for type %u", rettype);
 			typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
 
 			/* Disallow pseudotype result, except VOID or RECORD */
 			if (typeStruct->typtype == TYPTYPE_PSEUDO)
 			{
-				if (procStruct->prorettype == VOIDOID ||
-					procStruct->prorettype == RECORDOID)
+				if (rettype == VOIDOID ||
+					rettype == RECORDOID)
 					 /* okay */ ;
-				else if (procStruct->prorettype == TRIGGEROID ||
-						 procStruct->prorettype == EVTTRIGGEROID)
+				else if (rettype == TRIGGEROID ||
+						 rettype == EVTTRIGGEROID)
 					ereport(ERROR,
 							(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
 							 errmsg("trigger functions can only be called "
@@ -2833,13 +2851,12 @@ compile_plperl_function(Oid fn_oid, bool is_trigger, bool is_event_trigger)
 					ereport(ERROR,
 							(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
 							 errmsg("PL/Perl functions cannot return type %s",
-									format_type_be(procStruct->prorettype))));
+									format_type_be(rettype))));
 			}
 
-			prodesc->result_oid = procStruct->prorettype;
+			prodesc->result_oid = rettype;
 			prodesc->fn_retisset = procStruct->proretset;
-			prodesc->fn_retistuple = (procStruct->prorettype == RECORDOID ||
-									  typeStruct->typtype == TYPTYPE_COMPOSITE);
+			prodesc->fn_retistuple = type_is_rowtype(rettype);
 
 			prodesc->fn_retisarray =
 				(typeStruct->typlen == -1 && typeStruct->typelem);
@@ -2862,23 +2879,22 @@ compile_plperl_function(Oid fn_oid, bool is_trigger, bool is_event_trigger)
 
 			for (i = 0; i < prodesc->nargs; i++)
 			{
-				typeTup = SearchSysCache1(TYPEOID,
-										  ObjectIdGetDatum(procStruct->proargtypes.values[i]));
+				Oid			argtype = procStruct->proargtypes.values[i];
+
+				typeTup = SearchSysCache1(TYPEOID, ObjectIdGetDatum(argtype));
 				if (!HeapTupleIsValid(typeTup))
-					elog(ERROR, "cache lookup failed for type %u",
-						 procStruct->proargtypes.values[i]);
+					elog(ERROR, "cache lookup failed for type %u", argtype);
 				typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
 
-				/* Disallow pseudotype argument */
+				/* Disallow pseudotype argument, except RECORD */
 				if (typeStruct->typtype == TYPTYPE_PSEUDO &&
-					procStruct->proargtypes.values[i] != RECORDOID)
+					argtype != RECORDOID)
 					ereport(ERROR,
 							(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
 							 errmsg("PL/Perl functions cannot accept type %s",
-									format_type_be(procStruct->proargtypes.values[i]))));
+									format_type_be(argtype))));
 
-				if (typeStruct->typtype == TYPTYPE_COMPOSITE ||
-					procStruct->proargtypes.values[i] == RECORDOID)
+				if (type_is_rowtype(argtype))
 					prodesc->arg_is_rowtype[i] = true;
 				else
 				{
@@ -2888,9 +2904,9 @@ compile_plperl_function(Oid fn_oid, bool is_trigger, bool is_event_trigger)
 								  proc_cxt);
 				}
 
-				/* Identify array attributes */
+				/* Identify array-type arguments */
 				if (typeStruct->typelem != 0 && typeStruct->typlen == -1)
-					prodesc->arg_arraytype[i] = procStruct->proargtypes.values[i];
+					prodesc->arg_arraytype[i] = argtype;
 				else
 					prodesc->arg_arraytype[i] = InvalidOid;
 
@@ -3249,11 +3265,25 @@ plperl_return_next_internal(SV *sv)
 
 		/*
 		 * This is the first call to return_next in the current PL/Perl
-		 * function call, so identify the output tuple descriptor and create a
+		 * function call, so identify the output tuple type and create a
 		 * tuplestore to hold the result rows.
 		 */
 		if (prodesc->fn_retistuple)
-			(void) get_call_result_type(fcinfo, NULL, &tupdesc);
+		{
+			TypeFuncClass funcclass;
+			Oid			typid;
+
+			funcclass = get_call_result_type(fcinfo, &typid, &tupdesc);
+			if (funcclass != TYPEFUNC_COMPOSITE &&
+				funcclass != TYPEFUNC_COMPOSITE_DOMAIN)
+				ereport(ERROR,
+						(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+						 errmsg("function returning record called in context "
+								"that cannot accept type record")));
+			/* if domain-over-composite, remember the domain's type OID */
+			if (funcclass == TYPEFUNC_COMPOSITE_DOMAIN)
+				current_call_data->cdomain_oid = typid;
+		}
 		else
 		{
 			tupdesc = rsi->expectedDesc;
@@ -3304,6 +3334,13 @@ plperl_return_next_internal(SV *sv)
 
 		tuple = plperl_build_tuple_result((HV *) SvRV(sv),
 										  current_call_data->ret_tdesc);
+
+		if (OidIsValid(current_call_data->cdomain_oid))
+			domain_check(HeapTupleGetDatum(tuple), false,
+						 current_call_data->cdomain_oid,
+						 &current_call_data->cdomain_info,
+						 rsi->econtext->ecxt_per_query_memory);
+
 		tuplestore_puttuple(current_call_data->tuple_store, tuple);
 	}
 	else
diff --git a/src/pl/plperl/sql/plperl.sql b/src/pl/plperl/sql/plperl.sql
index dc6b169464..c36da0ff04 100644
--- a/src/pl/plperl/sql/plperl.sql
+++ b/src/pl/plperl/sql/plperl.sql
@@ -231,6 +231,38 @@ $$ LANGUAGE plperl;
 
 SELECT * FROM foo_set_bad();
 
+CREATE DOMAIN orderedfootype AS footype CHECK ((VALUE).x <= (VALUE).y);
+
+CREATE OR REPLACE FUNCTION foo_ordered() RETURNS orderedfootype AS $$
+    return {x => 3, y => 4};
+$$ LANGUAGE plperl;
+
+SELECT * FROM foo_ordered();
+
+CREATE OR REPLACE FUNCTION foo_ordered() RETURNS orderedfootype AS $$
+    return {x => 5, y => 4};
+$$ LANGUAGE plperl;
+
+SELECT * FROM foo_ordered();  -- fail
+
+CREATE OR REPLACE FUNCTION foo_ordered_set() RETURNS SETOF orderedfootype AS $$
+return [
+    {x => 3, y => 4},
+    {x => 4, y => 7}
+];
+$$ LANGUAGE plperl;
+
+SELECT * FROM foo_ordered_set();
+
+CREATE OR REPLACE FUNCTION foo_ordered_set() RETURNS SETOF orderedfootype AS $$
+return [
+    {x => 3, y => 4},
+    {x => 9, y => 7}
+];
+$$ LANGUAGE plperl;
+
+SELECT * FROM foo_ordered_set();  -- fail
+
 --
 -- Check passing a tuple argument
 --
@@ -243,6 +275,23 @@ SELECT perl_get_field((11,12), 'x');
 SELECT perl_get_field((11,12), 'y');
 SELECT perl_get_field((11,12), 'z');
 
+CREATE OR REPLACE FUNCTION perl_get_cfield(orderedfootype, text) RETURNS integer AS $$
+    return $_[0]->{$_[1]};
+$$ LANGUAGE plperl;
+
+SELECT perl_get_cfield((11,12), 'x');
+SELECT perl_get_cfield((11,12), 'y');
+SELECT perl_get_cfield((12,11), 'x');  -- fail
+
+CREATE OR REPLACE FUNCTION perl_get_rfield(record, text) RETURNS integer AS $$
+    return $_[0]->{$_[1]};
+$$ LANGUAGE plperl;
+
+SELECT perl_get_rfield((11,12), 'f1');
+SELECT perl_get_rfield((11,12)::footype, 'y');
+SELECT perl_get_rfield((11,12)::orderedfootype, 'x');
+SELECT perl_get_rfield((12,11)::orderedfootype, 'x');  -- fail
+
 --
 -- Test return_next
 --
diff --git a/src/pl/plperl/sql/plperl_util.sql b/src/pl/plperl/sql/plperl_util.sql
index 143d047802..5b31605ccd 100644
--- a/src/pl/plperl/sql/plperl_util.sql
+++ b/src/pl/plperl/sql/plperl_util.sql
@@ -102,11 +102,20 @@ select perl_looks_like_number();
 -- test encode_typed_literal
 create type perl_foo as (a integer, b text[]);
 create type perl_bar as (c perl_foo[]);
+create domain perl_foo_pos as perl_foo check((value).a > 0);
+
 create or replace function perl_encode_typed_literal() returns setof text language plperl as $$
 	return_next encode_typed_literal(undef, 'text');
 	return_next encode_typed_literal([[1,2,3],[3,2,1],[1,3,2]], 'integer[]');
 	return_next encode_typed_literal({a => 1, b => ['PL','/','Perl']}, 'perl_foo');
 	return_next encode_typed_literal({c => [{a => 9, b => ['PostgreSQL']}, {b => ['Postgres'], a => 1}]}, 'perl_bar');
+	return_next encode_typed_literal({a => 1, b => ['PL','/','Perl']}, 'perl_foo_pos');
 $$;
 
 select perl_encode_typed_literal();
+
+create or replace function perl_encode_typed_literal() returns setof text language plperl as $$
+	return_next encode_typed_literal({a => 0, b => ['PL','/','Perl']}, 'perl_foo_pos');
+$$;
+
+select perl_encode_typed_literal();  -- fail