From 23610daf8af0f5b468b5c0d4774295cc02ad30a9 Mon Sep 17 00:00:00 2001
From: Tom Lane <tgl@sss.pgh.pa.us>
Date: Thu, 13 Oct 2011 18:02:43 -0400
Subject: [PATCH] Fix up Perl-to-Postgres datatype conversions in pl/perl.
This patch restores the pre-9.1 behavior that pl/perl functions returning
VOID ignore the result value of their last Perl statement. 9.1.0
unintentionally threw an error if the last statement returned a reference,
as reported by Amit Khandekar.
Also, make sure it works to return a string value for a composite type,
so long as the string meets the type's input format. We already allowed
the equivalent behavior for arrays, so it seems inconsistent to not allow
it for composites.
In addition, ensure we throw errors for attempts to return arrays or hashes
when the function's declared result type is not an array or composite type,
respectively. Pre-9.1 versions rather uselessly returned strings like
ARRAY(0x221a9a0) or HASH(0x221aa90), while 9.1.0 threw an error for the
hash case and returned a garbage value for the array case.
Also, clean up assorted grotty coding in Perl array conversion, including
use of a session-lifespan memory context to accumulate the array value
(resulting in session-lifespan memory leak on error), failure to apply the
declared typmod if any, and failure to detect some cases of non-rectangular
multi-dimensional arrays.
Alex Hunsaker and Tom Lane
---
src/pl/plperl/expected/plperl.out | 58 ++++-
src/pl/plperl/expected/plperl_array.out | 10 +
src/pl/plperl/plperl.c | 297 ++++++++++++++----------
src/pl/plperl/sql/plperl.sql | 47 ++++
src/pl/plperl/sql/plperl_array.sql | 7 +
5 files changed, 289 insertions(+), 130 deletions(-)
diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out
index 5c1cd8cebfd..906dc15e0ca 100644
--- a/src/pl/plperl/expected/plperl.out
+++ b/src/pl/plperl/expected/plperl.out
@@ -101,6 +101,16 @@ SELECT * FROM perl_row();
1 | hello | world | ({{1}})
(1 row)
+-- test returning a composite literal
+CREATE OR REPLACE FUNCTION perl_row_lit() RETURNS testrowperl AS $$
+ return '(1,hello,world,"({{1}})")';
+$$ LANGUAGE plperl;
+SELECT perl_row_lit();
+ perl_row_lit
+---------------------------
+ (1,hello,world,"({{1}})")
+(1 row)
+
CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
return undef;
$$ LANGUAGE plperl;
@@ -336,7 +346,8 @@ CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
return 42;
$$ LANGUAGE plperl;
SELECT * FROM foo_bad();
-ERROR: composite-returning PL/Perl function must return reference to hash
+ERROR: malformed record literal: "42"
+DETAIL: Missing left parenthesis.
CONTEXT: PL/Perl function "foo_bad"
CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
return [
@@ -345,7 +356,7 @@ return [
];
$$ LANGUAGE plperl;
SELECT * FROM foo_bad();
-ERROR: composite-returning PL/Perl function must return reference to hash
+ERROR: cannot convert Perl array to non-array type footype
CONTEXT: PL/Perl function "foo_bad"
CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
return 42;
@@ -639,3 +650,46 @@ CONTEXT: PL/Perl anonymous code block
DO $do$ use warnings FATAL => qw(void) ; my @y; my $x = sort @y; 1; $do$ LANGUAGE plperl;
ERROR: Useless use of sort in scalar context at line 1.
CONTEXT: PL/Perl anonymous code block
+-- make sure functions marked as VOID without an explicit return work
+CREATE OR REPLACE FUNCTION myfuncs() RETURNS void AS $$
+ $_SHARED{myquote} = sub {
+ my $arg = shift;
+ $arg =~ s/(['\\])/\\$1/g;
+ return "'$arg'";
+ };
+$$ LANGUAGE plperl;
+SELECT myfuncs();
+ myfuncs
+---------
+
+(1 row)
+
+-- make sure we can't return an array as a scalar
+CREATE OR REPLACE FUNCTION text_arrayref() RETURNS text AS $$
+ return ['array'];
+$$ LANGUAGE plperl;
+SELECT text_arrayref();
+ERROR: cannot convert Perl array to non-array type text
+CONTEXT: PL/Perl function "text_arrayref"
+--- make sure we can't return a hash as a scalar
+CREATE OR REPLACE FUNCTION text_hashref() RETURNS text AS $$
+ return {'hash'=>1};
+$$ LANGUAGE plperl;
+SELECT text_hashref();
+ERROR: cannot convert Perl hash to non-composite type text
+CONTEXT: PL/Perl function "text_hashref"
+---- make sure we can't return a blessed object as a scalar
+CREATE OR REPLACE FUNCTION text_obj() RETURNS text AS $$
+ return bless({}, 'Fake::Object');
+$$ LANGUAGE plperl;
+SELECT text_obj();
+ERROR: cannot convert Perl hash to non-composite type text
+CONTEXT: PL/Perl function "text_obj"
+----- make sure we can't return a scalar ref
+CREATE OR REPLACE FUNCTION text_scalarref() RETURNS text AS $$
+ my $str = 'str';
+ return \$str;
+$$ LANGUAGE plperl;
+SELECT text_scalarref();
+ERROR: PL/Perl function must return reference to hash or array
+CONTEXT: PL/Perl function "text_scalarref"
diff --git a/src/pl/plperl/expected/plperl_array.out b/src/pl/plperl/expected/plperl_array.out
index be76f6cc240..829733fef4f 100644
--- a/src/pl/plperl/expected/plperl_array.out
+++ b/src/pl/plperl/expected/plperl_array.out
@@ -204,6 +204,16 @@ select plperl_arrays_inout('{{1}, {2}, {3}}');
{{1},{2},{3}}
(1 row)
+-- check that we can return an array literal
+CREATE OR REPLACE FUNCTION plperl_arrays_inout_l(INTEGER[]) returns INTEGER[] AS $$
+ return shift.''; # stringify it
+$$ LANGUAGE plperl;
+select plperl_arrays_inout_l('{{1}, {2}, {3}}');
+ plperl_arrays_inout_l
+-----------------------
+ {{1},{2},{3}}
+(1 row)
+
-- make sure setof works
create or replace function perl_setof_array(integer[]) returns setof integer[] language plperl as $$
my $arr = shift;
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index 784e137976c..fb23ae2d935 100644
--- a/src/pl/plperl/plperl.c
+++ b/src/pl/plperl/plperl.c
@@ -155,7 +155,6 @@ typedef struct plperl_call_data
FunctionCallInfo fcinfo;
Tuplestorestate *tuple_store;
TupleDesc ret_tdesc;
- AttInMetadata *attinmeta;
MemoryContext tmp_cxt;
} plperl_call_data;
@@ -244,12 +243,16 @@ static SV *plperl_ref_from_pg_array(Datum arg, Oid typid);
static SV *split_array(plperl_array_info *info, int first, int last, int nest);
static SV *make_array_ref(plperl_array_info *info, int first, int last);
static SV *get_perl_array_ref(SV *sv);
-static Datum plperl_sv_to_datum(SV *sv, FmgrInfo *func, Oid typid,
- Oid typioparam, int32 typmod, bool *isnull);
-static void _sv_to_datum_finfo(FmgrInfo *fcinfo, Oid typid, Oid *typioparam);
-static Datum plperl_array_to_datum(SV *src, Oid typid);
-static ArrayBuildState *_array_to_datum(AV *av, int *ndims, int *dims,
- int cur_depth, ArrayBuildState *astate, Oid typid, Oid atypid);
+static Datum plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod,
+ FunctionCallInfo fcinfo,
+ FmgrInfo *finfo, Oid typioparam,
+ bool *isnull);
+static void _sv_to_datum_finfo(Oid typid, FmgrInfo *finfo, Oid *typioparam);
+static Datum plperl_array_to_datum(SV *src, Oid typid, int32 typmod);
+static ArrayBuildState *array_to_datum_internal(AV *av, ArrayBuildState *astate,
+ int *ndims, int *dims, int cur_depth,
+ Oid arraytypid, Oid elemtypid, int32 typmod,
+ FmgrInfo *finfo, Oid typioparam);
static Datum plperl_hash_to_datum(SV *src, TupleDesc td);
static void plperl_init_shared_libs(pTHX);
@@ -988,9 +991,8 @@ strip_trailing_ws(const char *msg)
/* Build a tuple from a hash. */
static HeapTuple
-plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
+plperl_build_tuple_result(HV *perlhash, TupleDesc td)
{
- TupleDesc td = attinmeta->tupdesc;
Datum *values;
bool *nulls;
HE *he;
@@ -1006,7 +1008,6 @@ plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
SV *val = HeVAL(he);
char *key = hek2cstr(he);
int attn = SPI_fnumber(td, key);
- bool isnull;
if (attn <= 0 || td->attrs[attn - 1]->attisdropped)
ereport(ERROR,
@@ -1015,12 +1016,12 @@ plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
key)));
values[attn - 1] = plperl_sv_to_datum(val,
- NULL,
td->attrs[attn - 1]->atttypid,
- InvalidOid,
td->attrs[attn - 1]->atttypmod,
- &isnull);
- nulls[attn - 1] = isnull;
+ NULL,
+ NULL,
+ InvalidOid,
+ &nulls[attn - 1]);
pfree(key);
}
@@ -1036,8 +1037,7 @@ plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
static Datum
plperl_hash_to_datum(SV *src, TupleDesc td)
{
- AttInMetadata *attinmeta = TupleDescGetAttInMetadata(td);
- HeapTuple tup = plperl_build_tuple_result((HV *) SvRV(src), attinmeta);
+ HeapTuple tup = plperl_build_tuple_result((HV *) SvRV(src), td);
return HeapTupleGetDatum(tup);
}
@@ -1069,13 +1069,15 @@ get_perl_array_ref(SV *sv)
}
/*
- * helper function for plperl_array_to_datum, does the main recursing
+ * helper function for plperl_array_to_datum, recurses for multi-D arrays
*/
static ArrayBuildState *
-_array_to_datum(AV *av, int *ndims, int *dims, int cur_depth,
- ArrayBuildState *astate, Oid typid, Oid atypid)
+array_to_datum_internal(AV *av, ArrayBuildState *astate,
+ int *ndims, int *dims, int cur_depth,
+ Oid arraytypid, Oid elemtypid, int32 typmod,
+ FmgrInfo *finfo, Oid typioparam)
{
- int i = 0;
+ int i;
int len = av_len(av) + 1;
for (i = 0; i < len; i++)
@@ -1091,36 +1093,51 @@ _array_to_datum(AV *av, int *ndims, int *dims, int cur_depth,
{
AV *nav = (AV *) SvRV(sav);
+ /* dimensionality checks */
if (cur_depth + 1 > MAXDIM)
ereport(ERROR,
(errcode(ERRCODE_PROGRAM_LIMIT_EXCEEDED),
errmsg("number of array dimensions (%d) exceeds the maximum allowed (%d)",
cur_depth + 1, MAXDIM)));
- /* size based off the first element */
+ /* set size when at first element in this level, else compare */
if (i == 0 && *ndims == cur_depth)
{
dims[*ndims] = av_len(nav) + 1;
(*ndims)++;
}
- else
- {
- if (av_len(nav) + 1 != dims[cur_depth])
- ereport(ERROR,
- (errcode(ERRCODE_INVALID_TEXT_REPRESENTATION),
- errmsg("multidimensional arrays must have array expressions with matching dimensions")));
- }
-
- astate = _array_to_datum(nav, ndims, dims, cur_depth + 1, astate,
- typid, atypid);
+ else if (av_len(nav) + 1 != dims[cur_depth])
+ ereport(ERROR,
+ (errcode(ERRCODE_INVALID_TEXT_REPRESENTATION),
+ errmsg("multidimensional arrays must have array expressions with matching dimensions")));
+
+ /* recurse to fetch elements of this sub-array */
+ astate = array_to_datum_internal(nav, astate,
+ ndims, dims, cur_depth + 1,
+ arraytypid, elemtypid, typmod,
+ finfo, typioparam);
}
else
{
+ Datum dat;
bool isnull;
- Datum dat = plperl_sv_to_datum(svp ? *svp : NULL, NULL,
- atypid, 0, -1, &isnull);
- astate = accumArrayResult(astate, dat, isnull, atypid, NULL);
+ /* scalar after some sub-arrays at same level? */
+ if (*ndims != cur_depth)
+ ereport(ERROR,
+ (errcode(ERRCODE_INVALID_TEXT_REPRESENTATION),
+ errmsg("multidimensional arrays must have array expressions with matching dimensions")));
+
+ dat = plperl_sv_to_datum(svp ? *svp : NULL,
+ elemtypid,
+ typmod,
+ NULL,
+ finfo,
+ typioparam,
+ &isnull);
+
+ astate = accumArrayResult(astate, dat, isnull,
+ elemtypid, CurrentMemoryContext);
}
}
@@ -1131,89 +1148,141 @@ _array_to_datum(AV *av, int *ndims, int *dims, int cur_depth,
* convert perl array ref to a datum
*/
static Datum
-plperl_array_to_datum(SV *src, Oid typid)
+plperl_array_to_datum(SV *src, Oid typid, int32 typmod)
{
- ArrayBuildState *astate = NULL;
- Oid atypid;
+ ArrayBuildState *astate;
+ Oid elemtypid;
+ FmgrInfo finfo;
+ Oid typioparam;
int dims[MAXDIM];
int lbs[MAXDIM];
int ndims = 1;
int i;
- atypid = get_element_type(typid);
- if (!atypid)
- atypid = typid;
+ elemtypid = get_element_type(typid);
+ if (!elemtypid)
+ ereport(ERROR,
+ (errcode(ERRCODE_DATATYPE_MISMATCH),
+ errmsg("cannot convert Perl array to non-array type %s",
+ format_type_be(typid))));
+
+ _sv_to_datum_finfo(elemtypid, &finfo, &typioparam);
memset(dims, 0, sizeof(dims));
dims[0] = av_len((AV *) SvRV(src)) + 1;
- astate = _array_to_datum((AV *) SvRV(src), &ndims, dims, 1, astate, typid,
- atypid);
+ astate = array_to_datum_internal((AV *) SvRV(src), NULL,
+ &ndims, dims, 1,
+ typid, elemtypid, typmod,
+ &finfo, typioparam);
if (!astate)
- return PointerGetDatum(construct_empty_array(atypid));
+ return PointerGetDatum(construct_empty_array(elemtypid));
for (i = 0; i < ndims; i++)
lbs[i] = 1;
- return makeMdArrayResult(astate, ndims, dims, lbs, CurrentMemoryContext, true);
+ return makeMdArrayResult(astate, ndims, dims, lbs,
+ CurrentMemoryContext, true);
}
+/* Get the information needed to convert data to the specified PG type */
static void
-_sv_to_datum_finfo(FmgrInfo *fcinfo, Oid typid, Oid *typioparam)
+_sv_to_datum_finfo(Oid typid, FmgrInfo *finfo, Oid *typioparam)
{
Oid typinput;
/* XXX would be better to cache these lookups */
getTypeInputInfo(typid,
&typinput, typioparam);
- fmgr_info(typinput, fcinfo);
+ fmgr_info(typinput, finfo);
}
/*
- * convert a sv to datum
- * fcinfo and typioparam are optional and will be looked-up if needed
+ * convert Perl SV to PG datum of type typid, typmod typmod
+ *
+ * Pass the PL/Perl function's fcinfo when attempting to convert to the
+ * function's result type; otherwise pass NULL. This is used when we need to
+ * resolve the actual result type of a function returning RECORD.
+ *
+ * finfo and typioparam should be the results of _sv_to_datum_finfo for the
+ * given typid, or NULL/InvalidOid to let this function do the lookups.
+ *
+ * *isnull is an output parameter.
*/
static Datum
-plperl_sv_to_datum(SV *sv, FmgrInfo *finfo, Oid typid, Oid typioparam,
- int32 typmod, bool *isnull)
+plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod,
+ FunctionCallInfo fcinfo,
+ FmgrInfo *finfo, Oid typioparam,
+ bool *isnull)
{
FmgrInfo tmp;
/* we might recurse */
check_stack_depth();
- if (isnull)
- *isnull = false;
+ *isnull = false;
- if (!sv || !SvOK(sv))
+ /*
+ * Return NULL if result is undef, or if we're in a function returning
+ * VOID. In the latter case, we should pay no attention to the last Perl
+ * statement's result, and this is a convenient means to ensure that.
+ */
+ if (!sv || !SvOK(sv) || typid == VOIDOID)
{
+ /* look up type info if they did not pass it */
if (!finfo)
{
- _sv_to_datum_finfo(&tmp, typid, &typioparam);
+ _sv_to_datum_finfo(typid, &tmp, &typioparam);
finfo = &tmp;
}
- if (isnull)
- *isnull = true;
+ *isnull = true;
+ /* must call typinput in case it wants to reject NULL */
return InputFunctionCall(finfo, NULL, typioparam, typmod);
}
else if (SvROK(sv))
{
+ /* handle references */
SV *sav = get_perl_array_ref(sv);
if (sav)
{
- return plperl_array_to_datum(sav, typid);
+ /* handle an arrayref */
+ return plperl_array_to_datum(sav, typid, typmod);
}
else if (SvTYPE(SvRV(sv)) == SVt_PVHV)
{
- TupleDesc td = lookup_rowtype_tupdesc(typid, typmod);
- Datum ret = plperl_hash_to_datum(sv, td);
+ /* handle a hashref */
+ Datum ret;
+ TupleDesc td;
+ if (!type_is_rowtype(typid))
+ ereport(ERROR,
+ (errcode(ERRCODE_DATATYPE_MISMATCH),
+ 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)
+ {
+ /* Try to look it up based on our result type */
+ if (fcinfo == NULL ||
+ get_call_result_type(fcinfo, NULL, &td) != TYPEFUNC_COMPOSITE)
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("function returning record called in context "
+ "that cannot accept type record")));
+ }
+
+ ret = plperl_hash_to_datum(sv, td);
+
+ /* Release on the result of get_call_result_type is harmless */
ReleaseTupleDesc(td);
+
return ret;
}
+ /* Reference, but not reference to hash or array ... */
ereport(ERROR,
(errcode(ERRCODE_DATATYPE_MISMATCH),
errmsg("PL/Perl function must return reference to hash or array")));
@@ -1221,12 +1290,14 @@ plperl_sv_to_datum(SV *sv, FmgrInfo *finfo, Oid typid, Oid typioparam,
}
else
{
+ /* handle a string/number */
Datum ret;
char *str = sv2cstr(sv);
+ /* did not pass in any typeinfo? look it up */
if (!finfo)
{
- _sv_to_datum_finfo(&tmp, typid, &typioparam);
+ _sv_to_datum_finfo(typid, &tmp, &typioparam);
finfo = &tmp;
}
@@ -1251,7 +1322,10 @@ plperl_sv_to_literal(SV *sv, char *fqtypename)
if (!OidIsValid(typid))
elog(ERROR, "lookup failed for type %s", fqtypename);
- datum = plperl_sv_to_datum(sv, NULL, typid, 0, -1, &isnull);
+ datum = plperl_sv_to_datum(sv,
+ typid, -1,
+ NULL, NULL, InvalidOid,
+ &isnull);
if (isnull)
return NULL;
@@ -1542,10 +1616,11 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
key)));
modvalues[slotsused] = plperl_sv_to_datum(val,
- NULL,
tupdesc->attrs[attn - 1]->atttypid,
- InvalidOid,
tupdesc->attrs[attn - 1]->atttypmod,
+ NULL,
+ NULL,
+ InvalidOid,
&isnull);
modnulls[slotsused] = isnull ? 'n' : ' ';
@@ -2043,10 +2118,9 @@ plperl_func_handler(PG_FUNCTION_ARGS)
Datum retval = 0;
ReturnSetInfo *rsi;
ErrorContextCallback pl_error_context;
- bool has_retval = false;
/*
- * Create the call_data beforing connecting to SPI, so that it is not
+ * Create the call_data before connecting to SPI, so that it is not
* allocated in the SPI memory context
*/
current_call_data = (plperl_call_data *) palloc0(sizeof(plperl_call_data));
@@ -2129,51 +2203,19 @@ plperl_func_handler(PG_FUNCTION_ARGS)
rsi->setDesc = current_call_data->ret_tdesc;
}
retval = (Datum) 0;
- has_retval = true;
}
- else if (!SvOK(perlret))
- {
- /* Return NULL if Perl code returned undef */
- if (rsi && IsA(rsi, ReturnSetInfo))
- rsi->isDone = ExprEndResult;
- }
- else if (prodesc->fn_retistuple)
- {
- /* Return a perl hash converted to a Datum */
- TupleDesc td;
-
- if (!SvOK(perlret) || !SvROK(perlret) ||
- SvTYPE(SvRV(perlret)) != SVt_PVHV)
- {
- ereport(ERROR,
- (errcode(ERRCODE_DATATYPE_MISMATCH),
- errmsg("composite-returning PL/Perl function "
- "must return reference to hash")));
- }
-
- /* XXX should cache the attinmeta data instead of recomputing */
- if (get_call_result_type(fcinfo, NULL, &td) != TYPEFUNC_COMPOSITE)
- {
- ereport(ERROR,
- (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
- errmsg("function returning record called in context "
- "that cannot accept type record")));
- }
-
- retval = plperl_hash_to_datum(perlret, td);
- has_retval = true;
- }
-
- if (!has_retval)
+ else
{
- bool isnull;
-
retval = plperl_sv_to_datum(perlret,
- &prodesc->result_in_func,
prodesc->result_oid,
- prodesc->result_typioparam, -1, &isnull);
- fcinfo->isnull = isnull;
- has_retval = true;
+ -1,
+ fcinfo,
+ &prodesc->result_in_func,
+ prodesc->result_typioparam,
+ &fcinfo->isnull);
+
+ if (fcinfo->isnull && rsi && IsA(rsi, ReturnSetInfo))
+ rsi->isDone = ExprEndResult;
}
/* Restore the previous error callback */
@@ -2196,7 +2238,7 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
ErrorContextCallback pl_error_context;
/*
- * Create the call_data beforing connecting to SPI, so that it is not
+ * Create the call_data before connecting to SPI, so that it is not
* allocated in the SPI memory context
*/
current_call_data = (plperl_call_data *) palloc0(sizeof(plperl_call_data));
@@ -2842,19 +2884,11 @@ plperl_return_next(SV *sv)
(errcode(ERRCODE_SYNTAX_ERROR),
errmsg("cannot use return_next in a non-SETOF function")));
- if (prodesc->fn_retistuple &&
- !(SvOK(sv) && SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV))
- ereport(ERROR,
- (errcode(ERRCODE_DATATYPE_MISMATCH),
- errmsg("SETOF-composite-returning PL/Perl function "
- "must call return_next with reference to hash")));
-
if (!current_call_data->ret_tdesc)
{
TupleDesc tupdesc;
Assert(!current_call_data->tuple_store);
- Assert(!current_call_data->attinmeta);
/*
* This is the first call to return_next in the current PL/Perl
@@ -2875,11 +2909,6 @@ plperl_return_next(SV *sv)
current_call_data->tuple_store =
tuplestore_begin_heap(rsi->allowedModes & SFRM_Materialize_Random,
false, work_mem);
- if (prodesc->fn_retistuple)
- {
- current_call_data->attinmeta =
- TupleDescGetAttInMetadata(current_call_data->ret_tdesc);
- }
MemoryContextSwitchTo(old_cxt);
}
@@ -2893,7 +2922,7 @@ plperl_return_next(SV *sv)
if (!current_call_data->tmp_cxt)
{
current_call_data->tmp_cxt =
- AllocSetContextCreate(rsi->econtext->ecxt_per_tuple_memory,
+ AllocSetContextCreate(CurrentMemoryContext,
"PL/Perl return_next temporary cxt",
ALLOCSET_DEFAULT_MINSIZE,
ALLOCSET_DEFAULT_INITSIZE,
@@ -2906,8 +2935,14 @@ plperl_return_next(SV *sv)
{
HeapTuple tuple;
+ if (!(SvOK(sv) && SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV))
+ ereport(ERROR,
+ (errcode(ERRCODE_DATATYPE_MISMATCH),
+ errmsg("SETOF-composite-returning PL/Perl function "
+ "must call return_next with reference to hash")));
+
tuple = plperl_build_tuple_result((HV *) SvRV(sv),
- current_call_data->attinmeta);
+ current_call_data->ret_tdesc);
tuplestore_puttuple(current_call_data->tuple_store, tuple);
}
else
@@ -2916,10 +2951,12 @@ plperl_return_next(SV *sv)
bool isNull;
ret = plperl_sv_to_datum(sv,
- &prodesc->result_in_func,
prodesc->result_oid,
+ -1,
+ fcinfo,
+ &prodesc->result_in_func,
prodesc->result_typioparam,
- -1, &isNull);
+ &isNull);
tuplestore_putvalues(current_call_data->tuple_store,
current_call_data->ret_tdesc,
@@ -3318,10 +3355,12 @@ plperl_spi_exec_prepared(char *query, HV *attr, int argc, SV **argv)
bool isnull;
argvalues[i] = plperl_sv_to_datum(argv[i],
- &qdesc->arginfuncs[i],
qdesc->argtypes[i],
+ -1,
+ NULL,
+ &qdesc->arginfuncs[i],
qdesc->argtypioparams[i],
- -1, &isnull);
+ &isnull);
nulls[i] = isnull ? 'n' : ' ';
}
@@ -3443,10 +3482,12 @@ plperl_spi_query_prepared(char *query, int argc, SV **argv)
bool isnull;
argvalues[i] = plperl_sv_to_datum(argv[i],
- &qdesc->arginfuncs[i],
qdesc->argtypes[i],
+ -1,
+ NULL,
+ &qdesc->arginfuncs[i],
qdesc->argtypioparams[i],
- -1, &isnull);
+ &isnull);
nulls[i] = isnull ? 'n' : ' ';
}
diff --git a/src/pl/plperl/sql/plperl.sql b/src/pl/plperl/sql/plperl.sql
index 4aaca2a27c5..a5e3840dac2 100644
--- a/src/pl/plperl/sql/plperl.sql
+++ b/src/pl/plperl/sql/plperl.sql
@@ -50,6 +50,13 @@ $$ LANGUAGE plperl;
SELECT perl_row();
SELECT * FROM perl_row();
+-- test returning a composite literal
+CREATE OR REPLACE FUNCTION perl_row_lit() RETURNS testrowperl AS $$
+ return '(1,hello,world,"({{1}})")';
+$$ LANGUAGE plperl;
+
+SELECT perl_row_lit();
+
CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
return undef;
@@ -415,3 +422,43 @@ DO $do$ use strict; my $name = "foo"; my $ref = $$name; $do$ LANGUAGE plperl;
-- check that we can "use warnings" (in this case to turn a warn into an error)
-- yields "ERROR: Useless use of sort in scalar context."
DO $do$ use warnings FATAL => qw(void) ; my @y; my $x = sort @y; 1; $do$ LANGUAGE plperl;
+
+-- make sure functions marked as VOID without an explicit return work
+CREATE OR REPLACE FUNCTION myfuncs() RETURNS void AS $$
+ $_SHARED{myquote} = sub {
+ my $arg = shift;
+ $arg =~ s/(['\\])/\\$1/g;
+ return "'$arg'";
+ };
+$$ LANGUAGE plperl;
+
+SELECT myfuncs();
+
+-- make sure we can't return an array as a scalar
+CREATE OR REPLACE FUNCTION text_arrayref() RETURNS text AS $$
+ return ['array'];
+$$ LANGUAGE plperl;
+
+SELECT text_arrayref();
+
+--- make sure we can't return a hash as a scalar
+CREATE OR REPLACE FUNCTION text_hashref() RETURNS text AS $$
+ return {'hash'=>1};
+$$ LANGUAGE plperl;
+
+SELECT text_hashref();
+
+---- make sure we can't return a blessed object as a scalar
+CREATE OR REPLACE FUNCTION text_obj() RETURNS text AS $$
+ return bless({}, 'Fake::Object');
+$$ LANGUAGE plperl;
+
+SELECT text_obj();
+
+----- make sure we can't return a scalar ref
+CREATE OR REPLACE FUNCTION text_scalarref() RETURNS text AS $$
+ my $str = 'str';
+ return \$str;
+$$ LANGUAGE plperl;
+
+SELECT text_scalarref();
diff --git a/src/pl/plperl/sql/plperl_array.sql b/src/pl/plperl/sql/plperl_array.sql
index bc67c1ad0df..818a48ec200 100644
--- a/src/pl/plperl/sql/plperl_array.sql
+++ b/src/pl/plperl/sql/plperl_array.sql
@@ -152,6 +152,13 @@ $$ LANGUAGE plperl;
select plperl_arrays_inout('{{1}, {2}, {3}}');
+-- check that we can return an array literal
+CREATE OR REPLACE FUNCTION plperl_arrays_inout_l(INTEGER[]) returns INTEGER[] AS $$
+ return shift.''; # stringify it
+$$ LANGUAGE plperl;
+
+select plperl_arrays_inout_l('{{1}, {2}, {3}}');
+
-- make sure setof works
create or replace function perl_setof_array(integer[]) returns setof integer[] language plperl as $$
my $arr = shift;
--
GitLab