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();
];
$$ 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"
];
$$ 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"
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
--
(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
--
-- 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
{{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"
{
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;
/* handle a hashref */
Datum ret;
TupleDesc td;
+ bool isdomain;
if (!type_is_rowtype(typid))
ereport(ERROR,
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);
{
/* 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 "
************************************************************/
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 "
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);
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
{
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;
/*
* 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;
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
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
--
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
--
-- 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
projects / postgresql / commitdiff