From 60651e4cddbb77e8f1a0c7fc0be6a7e7bf626fe0 Mon Sep 17 00:00:00 2001 From: Tom Lane Date: Sat, 28 Oct 2017 14:02:21 -0400 Subject: [PATCH] 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 --- src/pl/plperl/expected/plperl.out | 88 ++++++++++++++++++++- src/pl/plperl/expected/plperl_util.out | 11 ++- src/pl/plperl/plperl.c | 103 +++++++++++++++++-------- src/pl/plperl/sql/plperl.sql | 49 ++++++++++++ src/pl/plperl/sql/plperl_util.sql | 9 +++ 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, + ¤t_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 -- 2.40.0