diff options
| -rw-r--r-- | src/pl/plperl/expected/plperl.out | 58 | ||||
| -rw-r--r-- | src/pl/plperl/expected/plperl_array.out | 10 | ||||
| -rw-r--r-- | src/pl/plperl/plperl.c | 297 | ||||
| -rw-r--r-- | src/pl/plperl/sql/plperl.sql | 47 | ||||
| -rw-r--r-- | 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; |