diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out
index 5c1cd8cebfdc744de01ef700284e2f561afa275b..906dc15e0ca097ec962c6dce9a08b29cb31d35b5 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 be76f6cc240b7b4983c3d08c8524b6af3e433b21..829733fef4f8e389ee8da13873eb79c8f67aa8ba 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 784e137976c9e557f75b7fdabdf6d16cee3a148f..fb23ae2d935fb04bc16f78e7af999deaadffd799 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 4aaca2a27c55d4581d1977ed9a0482f9153c968c..a5e3840dac23667ff2d599c46b6e6887cc6875a8 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 bc67c1ad0df0171aaba740c371e7e9894f5a9207..818a48ec200d6c18d95e6e2e98e2f7c6bd49506c 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;