Support domains over composite types in PL/Tcl.

Since PL/Tcl does little with SQL types internally, this is just a
matter of making it work with composite-domain function arguments
and results.

In passing, make it allow RECORD-type arguments --- that's a trivial
change that nobody had bothered with up to now.

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

src/pl/tcl/expected/pltcl_queries.out

@@ -327,6 +327,46 @@ select tcl_composite_arg_ref2(row('tkey', 42, 'ref2'));
  ref2                
 (1 row)
 
+-- More tests for composite argument/result types
+create domain d_dta1 as T_dta1 check ((value).ref1 > 0);
+create function tcl_record_arg(record, fldname text) returns int as '
+    return $1($2)
+' language pltcl;
+select tcl_record_arg(row('tkey', 42, 'ref2')::T_dta1, 'ref1');
+ tcl_record_arg 
+----------------
+             42
+(1 row)
+
+select tcl_record_arg(row('tkey', 42, 'ref2')::d_dta1, 'ref1');
+ tcl_record_arg 
+----------------
+             42
+(1 row)
+
+select tcl_record_arg(row(2,4), 'f2');
+ tcl_record_arg 
+----------------
+              4
+(1 row)
+
+create function tcl_cdomain_arg(d_dta1) returns int as '
+    return $1(ref1)
+' language pltcl;
+select tcl_cdomain_arg(row('tkey', 42, 'ref2'));
+ tcl_cdomain_arg 
+-----------------
+              42
+(1 row)
+
+select tcl_cdomain_arg(row('tkey', 42, 'ref2')::T_dta1);
+ tcl_cdomain_arg 
+-----------------
+              42
+(1 row)
+
+select tcl_cdomain_arg(row('tkey', -1, 'ref2'));  -- fail
+ERROR:  value for domain d_dta1 violates check constraint "d_dta1_check"
 -- Test argisnull primitive
 select tcl_argisnull('foo');
  tcl_argisnull 
@@ -438,6 +478,60 @@ return_next [list a 1 b 2 cow 3]
 $$ language pltcl;
 select bad_field_srf();
 ERROR:  column name/value list contains nonexistent column name "cow"
+-- test composite and domain-over-composite results
+create function tcl_composite_result(int) returns T_dta1 as $$
+return [list tkey tkey1 ref1 $1 ref2 ref22]
+$$ language pltcl;
+select tcl_composite_result(1001);
+            tcl_composite_result            
+--------------------------------------------
+ ("tkey1     ",1001,"ref22               ")
+(1 row)
+
+select * from tcl_composite_result(1002);
+    tkey    | ref1 |         ref2         
+------------+------+----------------------
+ tkey1      | 1002 | ref22               
+(1 row)
+
+create function tcl_dcomposite_result(int) returns d_dta1 as $$
+return [list tkey tkey2 ref1 $1 ref2 ref42]
+$$ language pltcl;
+select tcl_dcomposite_result(1001);
+           tcl_dcomposite_result            
+--------------------------------------------
+ ("tkey2     ",1001,"ref42               ")
+(1 row)
+
+select * from tcl_dcomposite_result(1002);
+    tkey    | ref1 |         ref2         
+------------+------+----------------------
+ tkey2      | 1002 | ref42               
+(1 row)
+
+select * from tcl_dcomposite_result(-1);  -- fail
+ERROR:  value for domain d_dta1 violates check constraint "d_dta1_check"
+create function tcl_record_result(int) returns record as $$
+return [list q1 sometext q2 $1 q3 moretext]
+$$ language pltcl;
+select tcl_record_result(42);  -- fail
+ERROR:  function returning record called in context that cannot accept type record
+select * from tcl_record_result(42);  -- fail
+ERROR:  a column definition list is required for functions returning "record" at character 15
+select * from tcl_record_result(42) as (q1 text, q2 int, q3 text);
+    q1    | q2 |    q3    
+----------+----+----------
+ sometext | 42 | moretext
+(1 row)
+
+select * from tcl_record_result(42) as (q1 text, q2 int, q3 text, q4 int);
+    q1    | q2 |    q3    | q4 
+----------+----+----------+----
+ sometext | 42 | moretext |   
+(1 row)
+
+select * from tcl_record_result(42) as (q1 text, q2 int, q4 int);  -- fail
+ERROR:  column name/value list contains nonexistent column name "q3"
 -- test quote
 select tcl_eval('quote foo bar');
 ERROR:  wrong # args: should be "quote string"

src/pl/tcl/pltcl.c

@@ -143,10 +143,13 @@ typedef struct pltcl_proc_desc
 	bool		fn_readonly;	/* is function readonly? */
 	bool		lanpltrusted;	/* is it pltcl (vs. pltclu)? */
 	pltcl_interp_desc *interp_desc; /* interpreter to use */
+	Oid			result_typid;	/* OID of fn's result type */
 	FmgrInfo	result_in_func; /* input function for fn's result type */
 	Oid			result_typioparam;	/* param to pass to same */
 	bool		fn_retisset;	/* true if function returns a set */
 	bool		fn_retistuple;	/* true if function returns composite */
+	bool		fn_retisdomain; /* true if function returns domain */
+	void	   *domain_info;	/* opaque cache for domain checks */
 	int			nargs;			/* number of arguments */
 	/* these arrays have nargs entries: */
 	FmgrInfo   *arg_out_func;	/* output fns for arg types */
@@ -988,11 +991,26 @@ pltcl_func_handler(PG_FUNCTION_ARGS, pltcl_call_state *call_state,
 		 * result type is a named composite type, so it's not exactly trivial.
 		 * Maybe worth improving someday.
 		 */
-		if (get_call_result_type(fcinfo, NULL, &td) != TYPEFUNC_COMPOSITE)
+		switch (get_call_result_type(fcinfo, NULL, &td))
-			ereport(ERROR,
+		{
-					(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+			case TYPEFUNC_COMPOSITE:
-					 errmsg("function returning record called in context "
+				/* success */
-							"that cannot accept type record")));
+				break;
+			case TYPEFUNC_COMPOSITE_DOMAIN:
+				Assert(prodesc->fn_retisdomain);
+				break;
+			case TYPEFUNC_RECORD:
+				/* failed to determine actual type of RECORD */
+				ereport(ERROR,
+						(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+						 errmsg("function returning record called in context "
+								"that cannot accept type record")));
+				break;
+			default:
+				/* result type isn't composite? */
+				elog(ERROR, "return type must be a row type");
+				break;
+		}
 
 		Assert(!call_state->ret_tupdesc);
 		Assert(!call_state->attinmeta);
@@ -1490,22 +1508,21 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid,
 		 ************************************************************/
 		if (!is_trigger && !is_event_trigger)
 		{
-			typeTup =
+			Oid			rettype = procStruct->prorettype;
-				SearchSysCache1(TYPEOID,
+
-								ObjectIdGetDatum(procStruct->prorettype));
+			typeTup = SearchSysCache1(TYPEOID, ObjectIdGetDatum(rettype));
 			if (!HeapTupleIsValid(typeTup))
-				elog(ERROR, "cache lookup failed for type %u",
+				elog(ERROR, "cache lookup failed for type %u", rettype);
-					 procStruct->prorettype);
 			typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
 
 			/* Disallow pseudotype result, except VOID and RECORD */
 			if (typeStruct->typtype == TYPTYPE_PSEUDO)
 			{
-				if (procStruct->prorettype == VOIDOID ||
+				if (rettype == VOIDOID ||
-					procStruct->prorettype == RECORDOID)
+					rettype == RECORDOID)
 					 /* okay */ ;
-				else if (procStruct->prorettype == TRIGGEROID ||
+				else if (rettype == TRIGGEROID ||
-						 procStruct->prorettype == EVTTRIGGEROID)
+						 rettype == EVTTRIGGEROID)
 					ereport(ERROR,
 							(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
 							 errmsg("trigger functions can only be called as triggers")));
@@ -1513,17 +1530,19 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid,
 					ereport(ERROR,
 							(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
 							 errmsg("PL/Tcl functions cannot return type %s",
-									format_type_be(procStruct->prorettype))));
+									format_type_be(rettype))));
 			}
 
+			prodesc->result_typid = rettype;
 			fmgr_info_cxt(typeStruct->typinput,
 						  &(prodesc->result_in_func),
 						  proc_cxt);
 			prodesc->result_typioparam = getTypeIOParam(typeTup);
 
 			prodesc->fn_retisset = procStruct->proretset;
-			prodesc->fn_retistuple = (procStruct->prorettype == RECORDOID ||
+			prodesc->fn_retistuple = type_is_rowtype(rettype);
-									  typeStruct->typtype == TYPTYPE_COMPOSITE);
+			prodesc->fn_retisdomain = (typeStruct->typtype == TYPTYPE_DOMAIN);
+			prodesc->domain_info = NULL;
 
 			ReleaseSysCache(typeTup);
 		}
@@ -1537,21 +1556,22 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid,
 			proc_internal_args[0] = '\0';
 			for (i = 0; i < prodesc->nargs; i++)
 			{
-				typeTup = SearchSysCache1(TYPEOID,
+				Oid			argtype = procStruct->proargtypes.values[i];
-										  ObjectIdGetDatum(procStruct->proargtypes.values[i]));
+
+				typeTup = SearchSysCache1(TYPEOID, ObjectIdGetDatum(argtype));
 				if (!HeapTupleIsValid(typeTup))
-					elog(ERROR, "cache lookup failed for type %u",
+					elog(ERROR, "cache lookup failed for type %u", argtype);
-						 procStruct->proargtypes.values[i]);
 				typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
 
-				/* Disallow pseudotype argument */
+				/* Disallow pseudotype argument, except RECORD */
-				if (typeStruct->typtype == TYPTYPE_PSEUDO)
+				if (typeStruct->typtype == TYPTYPE_PSEUDO &&
+					argtype != RECORDOID)
 					ereport(ERROR,
 							(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
 							 errmsg("PL/Tcl functions cannot accept type %s",
-									format_type_be(procStruct->proargtypes.values[i]))));
+									format_type_be(argtype))));
 
-				if (typeStruct->typtype == TYPTYPE_COMPOSITE)
+				if (type_is_rowtype(argtype))
 				{
 					prodesc->arg_is_rowtype[i] = true;
 					snprintf(buf, sizeof(buf), "__PLTcl_Tup_%d", i + 1);
@@ -3075,6 +3095,7 @@ static HeapTuple
 pltcl_build_tuple_result(Tcl_Interp *interp, Tcl_Obj **kvObjv, int kvObjc,
 						 pltcl_call_state *call_state)
 {
+	HeapTuple	tuple;
 	TupleDesc	tupdesc;
 	AttInMetadata *attinmeta;
 	char	  **values;
@@ -3133,7 +3154,16 @@ pltcl_build_tuple_result(Tcl_Interp *interp, Tcl_Obj **kvObjv, int kvObjc,
 		values[attn - 1] = utf_u2e(Tcl_GetString(kvObjv[i + 1]));
 	}
 
-	return BuildTupleFromCStrings(attinmeta, values);
+	tuple = BuildTupleFromCStrings(attinmeta, values);
+
+	/* if result type is domain-over-composite, check domain constraints */
+	if (call_state->prodesc->fn_retisdomain)
+		domain_check(HeapTupleGetDatum(tuple), false,
+					 call_state->prodesc->result_typid,
+					 &call_state->prodesc->domain_info,
+					 call_state->prodesc->fn_cxt);
+
+	return tuple;
 }
 
 /**********************************************************************

src/pl/tcl/sql/pltcl_queries.sql

@@ -89,6 +89,26 @@ truncate trigger_test;
 select tcl_composite_arg_ref1(row('tkey', 42, 'ref2'));
 select tcl_composite_arg_ref2(row('tkey', 42, 'ref2'));
 
+-- More tests for composite argument/result types
+
+create domain d_dta1 as T_dta1 check ((value).ref1 > 0);
+
+create function tcl_record_arg(record, fldname text) returns int as '
+    return $1($2)
+' language pltcl;
+
+select tcl_record_arg(row('tkey', 42, 'ref2')::T_dta1, 'ref1');
+select tcl_record_arg(row('tkey', 42, 'ref2')::d_dta1, 'ref1');
+select tcl_record_arg(row(2,4), 'f2');
+
+create function tcl_cdomain_arg(d_dta1) returns int as '
+    return $1(ref1)
+' language pltcl;
+
+select tcl_cdomain_arg(row('tkey', 42, 'ref2'));
+select tcl_cdomain_arg(row('tkey', 42, 'ref2')::T_dta1);
+select tcl_cdomain_arg(row('tkey', -1, 'ref2'));  -- fail
+
 -- Test argisnull primitive
 select tcl_argisnull('foo');
 select tcl_argisnull('');
@@ -136,6 +156,29 @@ return_next [list a 1 b 2 cow 3]
 $$ language pltcl;
 select bad_field_srf();
 
+-- test composite and domain-over-composite results
+create function tcl_composite_result(int) returns T_dta1 as $$
+return [list tkey tkey1 ref1 $1 ref2 ref22]
+$$ language pltcl;
+select tcl_composite_result(1001);
+select * from tcl_composite_result(1002);
+
+create function tcl_dcomposite_result(int) returns d_dta1 as $$
+return [list tkey tkey2 ref1 $1 ref2 ref42]
+$$ language pltcl;
+select tcl_dcomposite_result(1001);
+select * from tcl_dcomposite_result(1002);
+select * from tcl_dcomposite_result(-1);  -- fail
+
+create function tcl_record_result(int) returns record as $$
+return [list q1 sometext q2 $1 q3 moretext]
+$$ language pltcl;
+select tcl_record_result(42);  -- fail
+select * from tcl_record_result(42);  -- fail
+select * from tcl_record_result(42) as (q1 text, q2 int, q3 text);
+select * from tcl_record_result(42) as (q1 text, q2 int, q3 text, q4 int);
+select * from tcl_record_result(42) as (q1 text, q2 int, q4 int);  -- fail
+
 -- test quote
 select tcl_eval('quote foo bar');
 select tcl_eval('quote [format %c 39]');