sharpetronics/PostgreSQL
1
0
Fork 0
mirror of https://github.com/postgres/postgres.git synced 2025-05-31 00:01:57 -04:00
Code Issues Projects Releases Wiki Activity

Support domains over composite types in PL/Perl.

Browse Source 
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
This commit is contained in:
Tom Lane 2017-10-28 14:02:21 -04:00
parent c6fd5cd706
commit 60651e4cdd
5 changed files with 222 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
src/pl/plperl/expected/plperl.out
View File

@ -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
--

11
src/pl/plperl/expected/plperl_util.out
View File

@ -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"

103
src/pl/plperl/plperl.c
View File

@ -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

49
src/pl/plperl/sql/plperl.sql
View File

@ -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
--

9
src/pl/plperl/sql/plperl_util.sql
View File

@ -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