Skip to content

Commit 60651e4

Browse files
tglsfdctglsfdc
committed
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
1 parent c6fd5cd commit 60651e4

File tree

5 files changed

+222
-38
lines changed

5 files changed

+222
-38
lines changed

‎src/pl/plperl/expected/plperl.out‎

Lines changed: 84 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -214,8 +214,10 @@ CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
214214
return undef;
215215
$$ LANGUAGE plperl;
216216
SELECT perl_record_set();
217-
ERROR: set-valued function called in context that cannot accept a set
218-
CONTEXT: PL/Perl function "perl_record_set"
217+
perl_record_set
218+
-----------------
219+
(0 rows)
220+
219221
SELECT * FROM perl_record_set();
220222
ERROR: a column definition list is required for functions returning "record"
221223
LINE 1: SELECT * FROM perl_record_set();
@@ -233,7 +235,7 @@ CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
233235
];
234236
$$ LANGUAGE plperl;
235237
SELECT perl_record_set();
236-
ERROR: set-valued function called in context that cannot accept a set
238+
ERROR: function returning record called in context that cannot accept type record
237239
CONTEXT: PL/Perl function "perl_record_set"
238240
SELECT * FROM perl_record_set();
239241
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 $$
250252
];
251253
$$ LANGUAGE plperl;
252254
SELECT perl_record_set();
253-
ERROR: set-valued function called in context that cannot accept a set
255+
ERROR: function returning record called in context that cannot accept type record
254256
CONTEXT: PL/Perl function "perl_record_set"
255257
SELECT * FROM perl_record_set();
256258
ERROR: a column definition list is required for functions returning "record"
@@ -387,6 +389,44 @@ $$ LANGUAGE plperl;
387389
SELECT * FROM foo_set_bad();
388390
ERROR: Perl hash contains nonexistent column "z"
389391
CONTEXT: PL/Perl function "foo_set_bad"
392+
CREATE DOMAIN orderedfootype AS footype CHECK ((VALUE).x <= (VALUE).y);
393+
CREATE OR REPLACE FUNCTION foo_ordered() RETURNS orderedfootype AS $$
394+
return {x => 3, y => 4};
395+
$$ LANGUAGE plperl;
396+
SELECT * FROM foo_ordered();
397+
x | y
398+
---+---
399+
3 | 4
400+
(1 row)
401+
402+
CREATE OR REPLACE FUNCTION foo_ordered() RETURNS orderedfootype AS $$
403+
return {x => 5, y => 4};
404+
$$ LANGUAGE plperl;
405+
SELECT * FROM foo_ordered(); -- fail
406+
ERROR: value for domain orderedfootype violates check constraint "orderedfootype_check"
407+
CONTEXT: PL/Perl function "foo_ordered"
408+
CREATE OR REPLACE FUNCTION foo_ordered_set() RETURNS SETOF orderedfootype AS $$
409+
return [
410+
{x => 3, y => 4},
411+
{x => 4, y => 7}
412+
];
413+
$$ LANGUAGE plperl;
414+
SELECT * FROM foo_ordered_set();
415+
x | y
416+
---+---
417+
3 | 4
418+
4 | 7
419+
(2 rows)
420+
421+
CREATE OR REPLACE FUNCTION foo_ordered_set() RETURNS SETOF orderedfootype AS $$
422+
return [
423+
{x => 3, y => 4},
424+
{x => 9, y => 7}
425+
];
426+
$$ LANGUAGE plperl;
427+
SELECT * FROM foo_ordered_set(); -- fail
428+
ERROR: value for domain orderedfootype violates check constraint "orderedfootype_check"
429+
CONTEXT: PL/Perl function "foo_ordered_set"
390430
--
391431
-- Check passing a tuple argument
392432
--
@@ -411,6 +451,46 @@ SELECT perl_get_field((11,12), 'z');
411451

412452
(1 row)
413453

454+
CREATE OR REPLACE FUNCTION perl_get_cfield(orderedfootype, text) RETURNS integer AS $$
455+
return $_[0]->{$_[1]};
456+
$$ LANGUAGE plperl;
457+
SELECT perl_get_cfield((11,12), 'x');
458+
perl_get_cfield
459+
-----------------
460+
11
461+
(1 row)
462+
463+
SELECT perl_get_cfield((11,12), 'y');
464+
perl_get_cfield
465+
-----------------
466+
12
467+
(1 row)
468+
469+
SELECT perl_get_cfield((12,11), 'x'); -- fail
470+
ERROR: value for domain orderedfootype violates check constraint "orderedfootype_check"
471+
CREATE OR REPLACE FUNCTION perl_get_rfield(record, text) RETURNS integer AS $$
472+
return $_[0]->{$_[1]};
473+
$$ LANGUAGE plperl;
474+
SELECT perl_get_rfield((11,12), 'f1');
475+
perl_get_rfield
476+
-----------------
477+
11
478+
(1 row)
479+
480+
SELECT perl_get_rfield((11,12)::footype, 'y');
481+
perl_get_rfield
482+
-----------------
483+
12
484+
(1 row)
485+
486+
SELECT perl_get_rfield((11,12)::orderedfootype, 'x');
487+
perl_get_rfield
488+
-----------------
489+
11
490+
(1 row)
491+
492+
SELECT perl_get_rfield((12,11)::orderedfootype, 'x'); -- fail
493+
ERROR: value for domain orderedfootype violates check constraint "orderedfootype_check"
414494
--
415495
-- Test return_next
416496
--

‎src/pl/plperl/expected/plperl_util.out‎

Lines changed: 10 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -172,11 +172,13 @@ select perl_looks_like_number();
172172
-- test encode_typed_literal
173173
create type perl_foo as (a integer, b text[]);
174174
create type perl_bar as (c perl_foo[]);
175+
create domain perl_foo_pos as perl_foo check((value).a > 0);
175176
create or replace function perl_encode_typed_literal() returns setof text language plperl as $$
176177
return_next encode_typed_literal(undef, 'text');
177178
return_next encode_typed_literal([[1,2,3],[3,2,1],[1,3,2]], 'integer[]');
178179
return_next encode_typed_literal({a => 1, b => ['PL','/','Perl']}, 'perl_foo');
179180
return_next encode_typed_literal({c => [{a => 9, b => ['PostgreSQL']}, {b => ['Postgres'], a => 1}]}, 'perl_bar');
181+
return_next encode_typed_literal({a => 1, b => ['PL','/','Perl']}, 'perl_foo_pos');
180182
$$;
181183
select perl_encode_typed_literal();
182184
perl_encode_typed_literal
@@ -185,5 +187,12 @@ select perl_encode_typed_literal();
185187
{{1,2,3},{3,2,1},{1,3,2}}
186188
(1,"{PL,/,Perl}")
187189
("{""(9,{PostgreSQL})"",""(1,{Postgres})""}")
188-
(4 rows)
190+
(1,"{PL,/,Perl}")
191+
(5 rows)
189192

193+
create or replace function perl_encode_typed_literal() returns setof text language plperl as $$
194+
return_next encode_typed_literal({a => 0, b => ['PL','/','Perl']}, 'perl_foo_pos');
195+
$$;
196+
select perl_encode_typed_literal(); -- fail
197+
ERROR: value for domain perl_foo_pos violates check constraint "perl_foo_pos_check"
198+
CONTEXT: PL/Perl function "perl_encode_typed_literal"

‎src/pl/plperl/plperl.c‎

Lines changed: 70 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -179,8 +179,11 @@ typedef struct plperl_call_data
179179
{
180180
plperl_proc_desc *prodesc;
181181
FunctionCallInfo fcinfo;
182+
/* remaining fields are used only in a function returning set: */
182183
Tuplestorestate *tuple_store;
183184
TupleDesc ret_tdesc;
185+
Oid cdomain_oid; /* 0 unless returning domain-over-composite */
186+
void *cdomain_info;
184187
MemoryContext tmp_cxt;
185188
} plperl_call_data;
186189

@@ -1356,27 +1359,44 @@ plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod,
13561359
/* handle a hashref */
13571360
Datum ret;
13581361
TupleDesc td;
1362+
bool isdomain;
13591363

13601364
if (!type_is_rowtype(typid))
13611365
ereport(ERROR,
13621366
(errcode(ERRCODE_DATATYPE_MISMATCH),
13631367
errmsg("cannot convert Perl hash to non-composite type %s",
13641368
format_type_be(typid))));
13651369

1366-
td = lookup_rowtype_tupdesc_noerror(typid, typmod, true);
1367-
if (td == NULL)
1370+
td = lookup_rowtype_tupdesc_domain(typid, typmod, true);
1371+
if (td != NULL)
13681372
{
1369-
/* Try to look it up based on our result type */
1370-
if (fcinfo == NULL ||
1371-
get_call_result_type(fcinfo, NULL, &td) != TYPEFUNC_COMPOSITE)
1373+
/* Did we look through a domain? */
1374+
isdomain = (typid != td->tdtypeid);
1375+
}
1376+
else
1377+
{
1378+
/* Must be RECORD, try to resolve based on call info */
1379+
TypeFuncClass funcclass;
1380+
1381+
if (fcinfo)
1382+
funcclass = get_call_result_type(fcinfo, &typid, &td);
1383+
else
1384+
funcclass = TYPEFUNC_OTHER;
1385+
if (funcclass != TYPEFUNC_COMPOSITE &&
1386+
funcclass != TYPEFUNC_COMPOSITE_DOMAIN)
13721387
ereport(ERROR,
13731388
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
13741389
errmsg("function returning record called in context "
13751390
"that cannot accept type record")));
1391+
Assert(td);
1392+
isdomain = (funcclass == TYPEFUNC_COMPOSITE_DOMAIN);
13761393
}
13771394

13781395
ret = plperl_hash_to_datum(sv, td);
13791396

1397+
if (isdomain)
1398+
domain_check(ret, false, typid, NULL, NULL);
1399+
13801400
/* Release on the result of get_call_result_type is harmless */
13811401
ReleaseTupleDesc(td);
13821402

@@ -2401,8 +2421,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
24012421
{
24022422
/* Check context before allowing the call to go through */
24032423
if (!rsi || !IsA(rsi, ReturnSetInfo) ||
2404-
(rsi->allowedModes & SFRM_Materialize) == 0 ||
2405-
rsi->expectedDesc == NULL)
2424+
(rsi->allowedModes & SFRM_Materialize) == 0)
24062425
ereport(ERROR,
24072426
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
24082427
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)
28092828
************************************************************/
28102829
if (!is_trigger && !is_event_trigger)
28112830
{
2812-
typeTup =
2813-
SearchSysCache1(TYPEOID,
2814-
ObjectIdGetDatum(procStruct->prorettype));
2831+
Oid rettype = procStruct->prorettype;
2832+
2833+
typeTup = SearchSysCache1(TYPEOID, ObjectIdGetDatum(rettype));
28152834
if (!HeapTupleIsValid(typeTup))
2816-
elog(ERROR, "cache lookup failed for type %u",
2817-
procStruct->prorettype);
2835+
elog(ERROR, "cache lookup failed for type %u", rettype);
28182836
typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
28192837

28202838
/* Disallow pseudotype result, except VOID or RECORD */
28212839
if (typeStruct->typtype == TYPTYPE_PSEUDO)
28222840
{
2823-
if (procStruct->prorettype == VOIDOID ||
2824-
procStruct->prorettype == RECORDOID)
2841+
if (rettype == VOIDOID ||
2842+
rettype == RECORDOID)
28252843
/* okay */ ;
2826-
else if (procStruct->prorettype == TRIGGEROID ||
2827-
procStruct->prorettype == EVTTRIGGEROID)
2844+
else if (rettype == TRIGGEROID ||
2845+
rettype == EVTTRIGGEROID)
28282846
ereport(ERROR,
28292847
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
28302848
errmsg("trigger functions can only be called "
@@ -2833,13 +2851,12 @@ compile_plperl_function(Oid fn_oid, bool is_trigger, bool is_event_trigger)
28332851
ereport(ERROR,
28342852
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
28352853
errmsg("PL/Perl functions cannot return type %s",
2836-
format_type_be(procStruct->prorettype))));
2854+
format_type_be(rettype))));
28372855
}
28382856

2839-
prodesc->result_oid = procStruct->prorettype;
2857+
prodesc->result_oid = rettype;
28402858
prodesc->fn_retisset = procStruct->proretset;
2841-
prodesc->fn_retistuple = (procStruct->prorettype == RECORDOID ||
2842-
typeStruct->typtype == TYPTYPE_COMPOSITE);
2859+
prodesc->fn_retistuple = type_is_rowtype(rettype);
28432860

28442861
prodesc->fn_retisarray =
28452862
(typeStruct->typlen == -1 && typeStruct->typelem);
@@ -2862,23 +2879,22 @@ compile_plperl_function(Oid fn_oid, bool is_trigger, bool is_event_trigger)
28622879

28632880
for (i = 0; i < prodesc->nargs; i++)
28642881
{
2865-
typeTup = SearchSysCache1(TYPEOID,
2866-
ObjectIdGetDatum(procStruct->proargtypes.values[i]));
2882+
Oid argtype = procStruct->proargtypes.values[i];
2883+
2884+
typeTup = SearchSysCache1(TYPEOID, ObjectIdGetDatum(argtype));
28672885
if (!HeapTupleIsValid(typeTup))
2868-
elog(ERROR, "cache lookup failed for type %u",
2869-
procStruct->proargtypes.values[i]);
2886+
elog(ERROR, "cache lookup failed for type %u", argtype);
28702887
typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
28712888

2872-
/* Disallow pseudotype argument */
2889+
/* Disallow pseudotype argument, except RECORD */
28732890
if (typeStruct->typtype == TYPTYPE_PSEUDO &&
2874-
procStruct->proargtypes.values[i] != RECORDOID)
2891+
argtype != RECORDOID)
28752892
ereport(ERROR,
28762893
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
28772894
errmsg("PL/Perl functions cannot accept type %s",
2878-
format_type_be(procStruct->proargtypes.values[i]))));
2895+
format_type_be(argtype))));
28792896

2880-
if (typeStruct->typtype == TYPTYPE_COMPOSITE ||
2881-
procStruct->proargtypes.values[i] == RECORDOID)
2897+
if (type_is_rowtype(argtype))
28822898
prodesc->arg_is_rowtype[i] = true;
28832899
else
28842900
{
@@ -2888,9 +2904,9 @@ compile_plperl_function(Oid fn_oid, bool is_trigger, bool is_event_trigger)
28882904
proc_cxt);
28892905
}
28902906

2891-
/* Identify array attributes */
2907+
/* Identify array-type arguments */
28922908
if (typeStruct->typelem != 0 && typeStruct->typlen == -1)
2893-
prodesc->arg_arraytype[i] = procStruct->proargtypes.values[i];
2909+
prodesc->arg_arraytype[i] = argtype;
28942910
else
28952911
prodesc->arg_arraytype[i] = InvalidOid;
28962912

@@ -3249,11 +3265,25 @@ plperl_return_next_internal(SV *sv)
32493265

32503266
/*
32513267
* This is the first call to return_next in the current PL/Perl
3252-
* function call, so identify the output tuple descriptor and create a
3268+
* function call, so identify the output tuple type and create a
32533269
* tuplestore to hold the result rows.
32543270
*/
32553271
if (prodesc->fn_retistuple)
3256-
(void) get_call_result_type(fcinfo, NULL, &tupdesc);
3272+
{
3273+
TypeFuncClass funcclass;
3274+
Oid typid;
3275+
3276+
funcclass = get_call_result_type(fcinfo, &typid, &tupdesc);
3277+
if (funcclass != TYPEFUNC_COMPOSITE &&
3278+
funcclass != TYPEFUNC_COMPOSITE_DOMAIN)
3279+
ereport(ERROR,
3280+
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
3281+
errmsg("function returning record called in context "
3282+
"that cannot accept type record")));
3283+
/* if domain-over-composite, remember the domain's type OID */
3284+
if (funcclass == TYPEFUNC_COMPOSITE_DOMAIN)
3285+
current_call_data->cdomain_oid = typid;
3286+
}
32573287
else
32583288
{
32593289
tupdesc = rsi->expectedDesc;
@@ -3304,6 +3334,13 @@ plperl_return_next_internal(SV *sv)
33043334

33053335
tuple = plperl_build_tuple_result((HV *) SvRV(sv),
33063336
current_call_data->ret_tdesc);
3337+
3338+
if (OidIsValid(current_call_data->cdomain_oid))
3339+
domain_check(HeapTupleGetDatum(tuple), false,
3340+
current_call_data->cdomain_oid,
3341+
&current_call_data->cdomain_info,
3342+
rsi->econtext->ecxt_per_query_memory);
3343+
33073344
tuplestore_puttuple(current_call_data->tuple_store, tuple);
33083345
}
33093346
else

0 commit comments

Comments
 (0)