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

diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out
index 5c1cd8cebfdc744de01ef700284e2f561afa275b..906dc15e0ca097ec962c6dce9a08b29cb31d35b5 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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;