From 28e9b26f4dfc5f3521c96c9de6758fa3240307d1 Mon Sep 17 00:00:00 2001 From: Tom Lane Date: Tue, 23 Nov 2004 00:21:24 +0000 Subject: [PATCH] Further plperl cleanup: be more paranoid about checking the type of data returned from Perl. Consolidate multiple bits of code to convert a Perl hash to a tuple, and drive the conversion off the keys present in the hash rather than the tuple column names, so we detect error if the hash contains keys it shouldn't. (This means keys not in the hash will silently default to NULL, which seems ok to me.) Fix a bunch of reference-count leaks too. --- src/pl/plperl/plperl.c | 415 ++++++++++++++---------------------- src/pl/plperl/test/test.expected | 84 +++++++- src/pl/plperl/test/test_queries.sql | 77 +++++++ 3 files changed, 323 insertions(+), 253 deletions(-) diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c index 9aa5102e19..ef5b35dbac 100644 --- a/src/pl/plperl/plperl.c +++ b/src/pl/plperl/plperl.c @@ -33,7 +33,7 @@ * ENHANCEMENTS, OR MODIFICATIONS. * * IDENTIFICATION - * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.62 2004/11/22 20:31:53 tgl Exp $ + * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.63 2004/11/23 00:21:17 tgl Exp $ * **********************************************************************/ @@ -45,17 +45,10 @@ #include /* postgreSQL stuff */ -#include "access/heapam.h" -#include "catalog/pg_language.h" -#include "catalog/pg_proc.h" -#include "catalog/pg_type.h" -#include "funcapi.h" /* need for SRF support */ #include "commands/trigger.h" #include "executor/spi.h" -#include "fmgr.h" -#include "tcop/tcopprot.h" +#include "funcapi.h" #include "utils/lsyscache.h" -#include "utils/syscache.h" #include "utils/typcache.h" /* perl stuff */ @@ -121,7 +114,7 @@ static Datum plperl_func_handler(PG_FUNCTION_ARGS); static Datum plperl_trigger_handler(PG_FUNCTION_ARGS); static plperl_proc_desc *compile_plperl_function(Oid fn_oid, bool is_trigger); -static SV *plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc); +static SV *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc); static void plperl_init_shared_libs(pTHX); static HV *plperl_spi_execute_fetch_result(SPITupleTable *, int, int); @@ -272,26 +265,36 @@ strip_trailing_ws(const char *msg) } -static HV * -plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc) +/* + * Build a tuple from a hash + */ +static HeapTuple +plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta) { - int i; - HV *hv = newHV(); - for (i = 0; i < tupdesc->natts; i++) - { - SV *value; + TupleDesc td = attinmeta->tupdesc; + char **values; + SV *val; + char *key; + I32 klen; + HeapTuple tup; - char *key = SPI_fname(tupdesc, i+1); - char *val = SPI_getvalue(tuple, tupdesc, i + 1); + values = (char **) palloc0(td->natts * sizeof(char *)); - if (val) - value = newSVpv(val, 0); - else - value = newSV(0); + hv_iterinit(perlhash); + while ((val = hv_iternextsv(perlhash, &key, &klen))) + { + int attn = SPI_fnumber(td, key); - hv_store(hv, key, strlen(key), value, 0); + if (attn <= 0 || td->attrs[attn - 1]->attisdropped) + elog(ERROR, "plperl: invalid attribute \"%s\" in hash", key); + if (SvTYPE(val) != SVt_NULL) + values[attn - 1] = SvPV(val, PL_na); } - return hv; + hv_iterinit(perlhash); + + tup = BuildTupleFromCStrings(attinmeta, values); + pfree(values); + return tup; } @@ -303,7 +306,7 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo) { TriggerData *tdata; TupleDesc tupdesc; - int i = 0; + int i; char *level; char *event; char *relid; @@ -316,8 +319,8 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo) tupdesc = tdata->tg_relation->rd_att; relid = DatumGetCString( - DirectFunctionCall1( - oidout, ObjectIdGetDatum(tdata->tg_relation->rd_id) + DirectFunctionCall1(oidout, + ObjectIdGetDatum(tdata->tg_relation->rd_id) ) ); @@ -328,28 +331,24 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo) { event = "INSERT"; hv_store(hv, "new", 3, - newRV((SV *)plperl_hash_from_tuple(tdata->tg_trigtuple, - tupdesc)), + plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc), 0); } else if (TRIGGER_FIRED_BY_DELETE(tdata->tg_event)) { event = "DELETE"; hv_store(hv, "old", 3, - newRV((SV *)plperl_hash_from_tuple(tdata->tg_trigtuple, - tupdesc)), + plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc), 0); } else if (TRIGGER_FIRED_BY_UPDATE(tdata->tg_event)) { event = "UPDATE"; hv_store(hv, "old", 3, - newRV((SV *)plperl_hash_from_tuple(tdata->tg_trigtuple, - tupdesc)), + plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc), 0); hv_store(hv, "new", 3, - newRV((SV *)plperl_hash_from_tuple(tdata->tg_newtuple, - tupdesc)), + plperl_hash_from_tuple(tdata->tg_newtuple, tupdesc), 0); } else { @@ -364,7 +363,7 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo) AV *av = newAV(); for (i=0; i < tdata->tg_trigger->tgnargs; i++) av_push(av, newSVpv(tdata->tg_trigger->tgargs[i], 0)); - hv_store(hv, "args", 4, newRV((SV *)av), 0); + hv_store(hv, "args", 4, newRV_noinc((SV *)av), 0); } hv_store(hv, "relname", 7, @@ -386,61 +385,9 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo) level = "UNKNOWN"; hv_store(hv, "level", 5, newSVpv(level, 0), 0); - return newRV((SV*)hv); -} - - -/********************************************************************** - * extract a list of keys from a hash - **********************************************************************/ -static AV * -plperl_get_keys(HV *hv) -{ - AV *ret; - SV *val; - char *key; - I32 klen; - - ret = newAV(); - - hv_iterinit(hv); - while ((val = hv_iternextsv(hv, (char **) &key, &klen))) - av_push(ret, newSVpv(key, 0)); - hv_iterinit(hv); - - return ret; + return newRV_noinc((SV*)hv); } -/********************************************************************** - * extract a given key (by index) from a list of keys - **********************************************************************/ -static char * -plperl_get_key(AV *keys, int index) -{ - SV **svp; - int len; - - len = av_len(keys) + 1; - if (index < len) - svp = av_fetch(keys, index, FALSE); - else - return NULL; - return SvPV(*svp, PL_na); -} - -/********************************************************************** - * extract a value for a given key from a hash - * - * return NULL on error or if we got an undef - **********************************************************************/ -static char * -plperl_get_elem(HV *hash, char *key) -{ - SV **svp = hv_fetch(hash, key, strlen(key), FALSE); - if (!svp) - elog(ERROR, "plperl: key \"%s\" not found", key); - return SvTYPE(*svp) == SVt_NULL ? NULL : SvPV(*svp, PL_na); -} /* * Obtain tuple descriptor for a function returning tuple @@ -468,84 +415,78 @@ get_function_tupdesc(Oid result_type, ReturnSetInfo *rsinfo) * set up the new tuple returned from a trigger **********************************************************************/ static HeapTuple -plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup, Oid fn_oid) +plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup) { SV **svp; HV *hvNew; - AV *plkeys; - char *platt; - char *plval; HeapTuple rtup; - int natts, - i, - attn, - atti; - int *volatile modattrs = NULL; - Datum *volatile modvalues = NULL; - char *volatile modnulls = NULL; + SV *val; + char *key; + I32 klen; + int slotsused; + int *modattrs; + Datum *modvalues; + char *modnulls; + TupleDesc tupdesc; - HeapTuple typetup; tupdesc = tdata->tg_relation->rd_att; svp = hv_fetch(hvTD, "new", 3, FALSE); + if (!svp) + elog(ERROR, "plperl: key \"new\" not found"); + if (SvTYPE(*svp) != SVt_RV || SvTYPE(SvRV(*svp)) != SVt_PVHV) + elog(ERROR, "plperl: $_TD->{new} is not a hash reference"); hvNew = (HV *) SvRV(*svp); - if (SvTYPE(hvNew) != SVt_PVHV) - elog(ERROR, "plperl: $_TD->{new} is not a hash"); + modattrs = palloc(tupdesc->natts * sizeof(int)); + modvalues = palloc(tupdesc->natts * sizeof(Datum)); + modnulls = palloc(tupdesc->natts * sizeof(char)); + slotsused = 0; - plkeys = plperl_get_keys(hvNew); - natts = av_len(plkeys) + 1; - if (natts != tupdesc->natts) - elog(ERROR, "plperl: $_TD->{new} has an incorrect number of keys"); - - modattrs = palloc0(natts * sizeof(int)); - modvalues = palloc0(natts * sizeof(Datum)); - modnulls = palloc0(natts * sizeof(char)); - - for (i = 0; i < natts; i++) + hv_iterinit(hvNew); + while ((val = hv_iternextsv(hvNew, &key, &klen))) { - FmgrInfo finfo; - Oid typinput; - Oid typelem; - - platt = plperl_get_key(plkeys, i); + int attn = SPI_fnumber(tupdesc, key); - attn = modattrs[i] = SPI_fnumber(tupdesc, platt); - - if (attn == SPI_ERROR_NOATTRIBUTE) - elog(ERROR, "plperl: invalid attribute \"%s\" in tuple", platt); - atti = attn - 1; - - plval = plperl_get_elem(hvNew, platt); - - typetup = SearchSysCache(TYPEOID, ObjectIdGetDatum(tupdesc->attrs[atti]->atttypid), 0, 0, 0); - typinput = ((Form_pg_type) GETSTRUCT(typetup))->typinput; - typelem = ((Form_pg_type) GETSTRUCT(typetup))->typelem; - ReleaseSysCache(typetup); - fmgr_info(typinput, &finfo); - - if (plval) + if (attn <= 0 || tupdesc->attrs[attn - 1]->attisdropped) + elog(ERROR, "plperl: invalid attribute \"%s\" in hash", key); + if (SvTYPE(val) != SVt_NULL) { - modvalues[i] = FunctionCall3(&finfo, - CStringGetDatum(plval), - ObjectIdGetDatum(typelem), - Int32GetDatum(tupdesc->attrs[atti]->atttypmod)); - modnulls[i] = ' '; + Oid typinput; + Oid typioparam; + FmgrInfo finfo; + + /* XXX would be better to cache these lookups */ + getTypeInputInfo(tupdesc->attrs[attn - 1]->atttypid, + &typinput, &typioparam); + fmgr_info(typinput, &finfo); + modvalues[slotsused] = FunctionCall3(&finfo, + CStringGetDatum(SvPV(val, PL_na)), + ObjectIdGetDatum(typioparam), + Int32GetDatum(tupdesc->attrs[attn - 1]->atttypmod)); + modnulls[slotsused] = ' '; } else { - modvalues[i] = (Datum) 0; - modnulls[i] = 'n'; + modvalues[slotsused] = (Datum) 0; + modnulls[slotsused] = 'n'; } + modattrs[slotsused] = attn; + slotsused++; } - rtup = SPI_modifytuple(tdata->tg_relation, otup, natts, modattrs, modvalues, modnulls); + hv_iterinit(hvNew); + + rtup = SPI_modifytuple(tdata->tg_relation, otup, slotsused, + modattrs, modvalues, modnulls); pfree(modattrs); pfree(modvalues); pfree(modnulls); + if (rtup == NULL) - elog(ERROR, "plperl: SPI_modifytuple failed -- error: %d", SPI_result); + elog(ERROR, "plperl: SPI_modifytuple failed: %s", + SPI_result_code_string(SPI_result)); return rtup; } @@ -701,7 +642,7 @@ plperl_init_shared_libs(pTHX) /********************************************************************** * plperl_call_perl_func() - calls a perl function through the RV - * stored in the prodesc structure. massages the input parms properly + * stored in the prodesc structure. massages the input parms properly **********************************************************************/ static SV * plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo) @@ -715,7 +656,9 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo) SAVETMPS; PUSHMARK(SP); - XPUSHs(sv_2mortal(newSVpv("undef", 0))); + + XPUSHs(sv_2mortal(newSVpv("undef", 0))); /* no trigger data */ + for (i = 0; i < desc->nargs; i++) { if (fcinfo->argnull[i]) @@ -738,9 +681,8 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo) tmptup.t_len = HeapTupleHeaderGetDatumLength(td); tmptup.t_data = td; - /* plperl_build_tuple_argument better return a mortal SV */ - hashref = plperl_build_tuple_argument(&tmptup, tupdesc); - XPUSHs(hashref); + hashref = plperl_hash_from_tuple(&tmptup, tupdesc); + XPUSHs(sv_2mortal(hashref)); } else { @@ -789,11 +731,12 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo) } /********************************************************************** - * plperl_call_perl_trigger_func() - calls a perl function affected by trigger - * through the RV stored in the prodesc structure. massages the input parms properly + * plperl_call_perl_trigger_func() - calls a perl trigger function + * through the RV stored in the prodesc structure. **********************************************************************/ static SV * -plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo, SV *td) +plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo, + SV *td) { dSP; SV *retval; @@ -805,13 +748,16 @@ plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo, S SAVETMPS; PUSHMARK(sp); + XPUSHs(td); + tg_trigger = ((TriggerData *) fcinfo->context)->tg_trigger; for (i = 0; i < tg_trigger->tgnargs; i++) XPUSHs(sv_2mortal(newSVpv(tg_trigger->tgargs[i], 0))); PUTBACK; - count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL | G_KEEPERR); + /* Do NOT use G_KEEPERR here */ + count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL); SPAGAIN; @@ -897,21 +843,18 @@ plperl_func_handler(PG_FUNCTION_ARGS) PG_RETURN_NULL(); } - if (prodesc->fn_retisset && - (SvTYPE(perlret) != SVt_RV || SvTYPE(SvRV(perlret)) != SVt_PVAV)) - elog(ERROR, "plperl: set-returning function must return reference to array"); - - if (prodesc->fn_retistuple && SvTYPE(perlret) != SVt_RV) - elog(ERROR, "plperl: composite-returning function must return a reference"); - if (prodesc->fn_retisset && prodesc->fn_retistuple) { /* set of tuples */ - AV *ret_av = (AV *) SvRV(perlret); + AV *ret_av; FuncCallContext *funcctx; TupleDesc tupdesc; AttInMetadata *attinmeta; + if (SvTYPE(perlret) != SVt_RV || SvTYPE(SvRV(perlret)) != SVt_PVAV) + elog(ERROR, "plperl: set-returning function must return reference to array"); + ret_av = (AV *) SvRV(perlret); + if (SRF_IS_FIRSTCALL()) { MemoryContext oldcontext; @@ -939,25 +882,16 @@ plperl_func_handler(PG_FUNCTION_ARGS) { SV **svp; HV *row_hv; - char **values; HeapTuple tuple; - int i; svp = av_fetch(ret_av, funcctx->call_cntr, FALSE); + Assert(svp != NULL); - if (SvTYPE(*svp) != SVt_RV) - elog(ERROR, "plperl: check your return value structure"); + if (SvTYPE(*svp) != SVt_RV || SvTYPE(SvRV(*svp)) != SVt_PVHV) + elog(ERROR, "plperl: element of result array is not a reference to hash"); row_hv = (HV *) SvRV(*svp); - values = (char **) palloc(tupdesc->natts * sizeof(char *)); - for (i = 0; i < tupdesc->natts; i++) - { - char *column_key; - - column_key = SPI_fname(tupdesc, i + 1); - values[i] = plperl_get_elem(row_hv, column_key); - } - tuple = BuildTupleFromCStrings(attinmeta, values); + tuple = plperl_build_tuple_result(row_hv, attinmeta); retval = HeapTupleGetDatum(tuple); SRF_RETURN_NEXT(funcctx, retval); } @@ -970,9 +904,13 @@ plperl_func_handler(PG_FUNCTION_ARGS) else if (prodesc->fn_retisset) { /* set of non-tuples */ - AV *ret_av = (AV *) SvRV(perlret); + AV *ret_av; FuncCallContext *funcctx; + if (SvTYPE(perlret) != SVt_RV || SvTYPE(SvRV(perlret)) != SVt_PVAV) + elog(ERROR, "plperl: set-returning function must return reference to array"); + ret_av = (AV *) SvRV(perlret); + if (SRF_IS_FIRSTCALL()) { funcctx = SRF_FIRSTCALL_INIT(); @@ -989,6 +927,7 @@ plperl_func_handler(PG_FUNCTION_ARGS) SV **svp; svp = av_fetch(ret_av, funcctx->call_cntr, FALSE); + Assert(svp != NULL); if (SvTYPE(*svp) != SVt_NULL) { @@ -1016,30 +955,24 @@ plperl_func_handler(PG_FUNCTION_ARGS) else if (prodesc->fn_retistuple) { /* singleton perl hash to Datum */ - HV *perlhash = (HV *) SvRV(perlret); + HV *perlhash; TupleDesc td; - int i; - char **values; AttInMetadata *attinmeta; HeapTuple tup; + if (SvTYPE(perlret) != SVt_RV || SvTYPE(SvRV(perlret)) != SVt_PVHV) + elog(ERROR, "plperl: composite-returning function must return a reference to hash"); + perlhash = (HV *) SvRV(perlret); + /* - * XXX should cache the attinmetadata instead of recomputing + * XXX should cache the attinmeta data instead of recomputing */ td = get_function_tupdesc(prodesc->result_oid, (ReturnSetInfo *) fcinfo->resultinfo); /* td = CreateTupleDescCopy(td); */ attinmeta = TupleDescGetAttInMetadata(td); - values = (char **) palloc(td->natts * sizeof(char *)); - for (i = 0; i < td->natts; i++) - { - char *key; - - key = SPI_fname(td, i + 1); - values[i] = plperl_get_elem(perlhash, key); - } - tup = BuildTupleFromCStrings(attinmeta, values); + tup = plperl_build_tuple_result(perlhash, attinmeta); retval = HeapTupleGetDatum(tup); } else @@ -1066,7 +999,6 @@ plperl_trigger_handler(PG_FUNCTION_ARGS) plperl_proc_desc *prodesc; SV *perlret; Datum retval; - char *tmp; SV *svTD; HV *hvTD; @@ -1092,8 +1024,6 @@ plperl_trigger_handler(PG_FUNCTION_ARGS) hvTD = (HV *) SvRV(svTD); /* convert SV TD structure to Perl Hash * structure */ - tmp = SvPV(perlret, PL_na); - /************************************************************ * Disconnect from SPI manager and then create the return * values datum (if the input function does a palloc for it @@ -1103,8 +1033,9 @@ plperl_trigger_handler(PG_FUNCTION_ARGS) if (SPI_finish() != SPI_OK_FINISH) elog(ERROR, "plperl: SPI_finish() failed"); - if (!(perlret && SvOK(perlret))) + if (!(perlret && SvOK(perlret) && SvTYPE(perlret) != SVt_NULL)) { + /* undef result means go ahead with original tuple */ TriggerData *trigdata = ((TriggerData *) fcinfo->context); if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event)) @@ -1118,45 +1049,41 @@ plperl_trigger_handler(PG_FUNCTION_ARGS) } else { - if (!fcinfo->isnull) - { - HeapTuple trv; + HeapTuple trv; + char *tmp; - if (strcasecmp(tmp, "SKIP") == 0) - trv = NULL; - else if (strcasecmp(tmp, "MODIFY") == 0) - { - TriggerData *trigdata = (TriggerData *) fcinfo->context; + tmp = SvPV(perlret, PL_na); - if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event)) - trv = plperl_modify_tuple(hvTD, trigdata, trigdata->tg_trigtuple, fcinfo->flinfo->fn_oid); - else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event)) - trv = plperl_modify_tuple(hvTD, trigdata, trigdata->tg_newtuple, fcinfo->flinfo->fn_oid); - else - { - trv = NULL; - elog(WARNING, "plperl: Ignoring modified tuple in DELETE trigger"); - } - } - else if (strcasecmp(tmp, "OK")) - { - trv = NULL; - elog(ERROR, "plperl: Expected return to be undef, 'SKIP' or 'MODIFY'"); - } + if (pg_strcasecmp(tmp, "SKIP") == 0) + trv = NULL; + else if (pg_strcasecmp(tmp, "MODIFY") == 0) + { + TriggerData *trigdata = (TriggerData *) fcinfo->context; + + if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event)) + trv = plperl_modify_tuple(hvTD, trigdata, + trigdata->tg_trigtuple); + else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event)) + trv = plperl_modify_tuple(hvTD, trigdata, + trigdata->tg_newtuple); else { + elog(WARNING, "plperl: ignoring modified tuple in DELETE trigger"); trv = NULL; - elog(ERROR, "plperl: Expected return to be undef, 'SKIP' or 'MODIFY'"); } - retval = PointerGetDatum(trv); } else - retval = (Datum) 0; + { + elog(ERROR, "plperl: expected trigger result to be undef, \"SKIP\" or \"MODIFY\""); + trv = NULL; + } + retval = PointerGetDatum(trv); } - SvREFCNT_dec(perlret); + SvREFCNT_dec(svTD); + if (perlret) + SvREFCNT_dec(perlret); - fcinfo->isnull = false; return retval; } @@ -1408,31 +1335,32 @@ compile_plperl_function(Oid fn_oid, bool is_trigger) /********************************************************************** - * plperl_build_tuple_argument() - Build a string for a ref to a hash + * plperl_hash_from_tuple() - Build a ref to a hash * from all attributes of a given tuple **********************************************************************/ static SV * -plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc) +plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc) { - int i; HV *hv; - Datum attr; - bool isnull; - char *attname; - char *outputstr; - HeapTuple typeTup; - Oid typoutput; - Oid typioparam; - int namelen; + int i; hv = newHV(); for (i = 0; i < tupdesc->natts; i++) { + Datum attr; + bool isnull; + char *attname; + char *outputstr; + Oid typoutput; + Oid typioparam; + bool typisvarlena; + int namelen; + if (tupdesc->attrs[i]->attisdropped) continue; - attname = tupdesc->attrs[i]->attname.data; + attname = NameStr(tupdesc->attrs[i]->attname); namelen = strlen(attname); attr = heap_getattr(tuple, i + 1, tupdesc, &isnull); @@ -1442,24 +1370,11 @@ plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc) continue; } - /************************************************************ - * Lookup the attribute type in the syscache - * for the output function - ************************************************************/ - typeTup = SearchSysCache(TYPEOID, - ObjectIdGetDatum(tupdesc->attrs[i]->atttypid), - 0, 0, 0); - if (!HeapTupleIsValid(typeTup)) - elog(ERROR, "cache lookup failed for type %u", - tupdesc->attrs[i]->atttypid); + /* XXX should have a way to cache these lookups */ - typoutput = ((Form_pg_type) GETSTRUCT(typeTup))->typoutput; - typioparam = getTypeIOParam(typeTup); - ReleaseSysCache(typeTup); + getTypeOutputInfo(tupdesc->attrs[i]->atttypid, + &typoutput, &typioparam, &typisvarlena); - /************************************************************ - * Append the attribute name and the value to the list. - ************************************************************/ outputstr = DatumGetCString(OidFunctionCall3(typoutput, attr, ObjectIdGetDatum(typioparam), @@ -1468,7 +1383,7 @@ plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc) hv_store(hv, attname, namelen, newSVpv(outputstr, 0), 0); } - return sv_2mortal(newRV((SV *)hv)); + return newRV_noinc((SV *) hv); } @@ -1558,14 +1473,14 @@ plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed, if (status == SPI_OK_SELECT) { AV *rows; - HV *row; + SV *row; int i; rows = newAV(); for (i = 0; i < processed; i++) { row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc); - av_push(rows, newRV_noinc((SV *)row)); + av_push(rows, row); } hv_store(result, "rows", strlen("rows"), newRV_noinc((SV *) rows), 0); diff --git a/src/pl/plperl/test/test.expected b/src/pl/plperl/test/test.expected index ec9b304ab6..c5b928f820 100644 --- a/src/pl/plperl/test/test.expected +++ b/src/pl/plperl/test/test.expected @@ -119,9 +119,9 @@ CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$ ]; $$ LANGUAGE plperl; SELECT perl_set(); -ERROR: plperl: check your return value structure +ERROR: plperl: element of result array is not a reference to hash SELECT * FROM perl_set(); -ERROR: plperl: check your return value structure +ERROR: plperl: element of result array is not a reference to hash CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$ return [ { f1 => 1, f2 => 'Hello', f3 => 'World' }, @@ -202,7 +202,7 @@ ERROR: could not determine row description for function returning record SELECT * FROM perl_record_set(); ERROR: a column definition list is required for functions returning "record" SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text); -ERROR: plperl: check your return value structure +ERROR: plperl: element of result array is not a reference to hash CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$ return [ { f1 => 1, f2 => 'Hello', f3 => 'World' }, @@ -222,3 +222,81 @@ SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text); 3 | Hello | PL/Perl (3 rows) +CREATE TYPE footype AS (x INTEGER, y INTEGER); +CREATE OR REPLACE FUNCTION foo_good() RETURNS SETOF footype AS $$ +return [ + {x => 1, y => 2}, + {x => 3, y => 4} +]; +$$ LANGUAGE plperl; +SELECT * FROM foo_good(); + x | y +---+--- + 1 | 2 + 3 | 4 +(2 rows) + +CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$ + return {y => 3, z => 4}; +$$ LANGUAGE plperl; +SELECT * FROM foo_bad(); +ERROR: plperl: invalid attribute "z" in hash +CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$ +return 42; +$$ LANGUAGE plperl; +SELECT * FROM foo_bad(); +ERROR: plperl: composite-returning function must return a reference to hash +CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$ +return [ + [1, 2], + [3, 4] +]; +$$ LANGUAGE plperl; +SELECT * FROM foo_bad(); +ERROR: plperl: composite-returning function must return a reference to hash +CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ + return 42; +$$ LANGUAGE plperl; +SELECT * FROM foo_set_bad(); +ERROR: plperl: set-returning function must return reference to array +CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ + return {y => 3, z => 4}; +$$ LANGUAGE plperl; +SELECT * FROM foo_set_bad(); +ERROR: plperl: set-returning function must return reference to array +CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ +return [ + [1, 2], + [3, 4] +]; +$$ LANGUAGE plperl; +SELECT * FROM foo_set_bad(); +ERROR: plperl: element of result array is not a reference to hash +CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ +return [ + {y => 3, z => 4} +]; +$$ LANGUAGE plperl; +SELECT * FROM foo_set_bad(); +ERROR: plperl: invalid attribute "z" in hash +CREATE OR REPLACE FUNCTION perl_get_field(footype, text) RETURNS integer AS $$ + return $_[0]->{$_[1]}; +$$ LANGUAGE plperl; +SELECT perl_get_field((11,12), 'x'); + perl_get_field +---------------- + 11 +(1 row) + +SELECT perl_get_field((11,12), 'y'); + perl_get_field +---------------- + 12 +(1 row) + +SELECT perl_get_field((11,12), 'z'); + perl_get_field +---------------- + +(1 row) + diff --git a/src/pl/plperl/test/test_queries.sql b/src/pl/plperl/test/test_queries.sql index 63fc8cfa26..37a0ce9160 100644 --- a/src/pl/plperl/test/test_queries.sql +++ b/src/pl/plperl/test/test_queries.sql @@ -134,3 +134,80 @@ $$ LANGUAGE plperl; SELECT perl_record_set(); SELECT * FROM perl_record_set(); SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text); + +-- +-- Check behavior with erroneous return values +-- + +CREATE TYPE footype AS (x INTEGER, y INTEGER); + +CREATE OR REPLACE FUNCTION foo_good() RETURNS SETOF footype AS $$ +return [ + {x => 1, y => 2}, + {x => 3, y => 4} +]; +$$ LANGUAGE plperl; + +SELECT * FROM foo_good(); + +CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$ + return {y => 3, z => 4}; +$$ LANGUAGE plperl; + +SELECT * FROM foo_bad(); + +CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$ +return 42; +$$ LANGUAGE plperl; + +SELECT * FROM foo_bad(); + +CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$ +return [ + [1, 2], + [3, 4] +]; +$$ LANGUAGE plperl; + +SELECT * FROM foo_bad(); + +CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ + return 42; +$$ LANGUAGE plperl; + +SELECT * FROM foo_set_bad(); + +CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ + return {y => 3, z => 4}; +$$ LANGUAGE plperl; + +SELECT * FROM foo_set_bad(); + +CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ +return [ + [1, 2], + [3, 4] +]; +$$ LANGUAGE plperl; + +SELECT * FROM foo_set_bad(); + +CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ +return [ + {y => 3, z => 4} +]; +$$ LANGUAGE plperl; + +SELECT * FROM foo_set_bad(); + +-- +-- Check passing a tuple argument +-- + +CREATE OR REPLACE FUNCTION perl_get_field(footype, text) RETURNS integer AS $$ + return $_[0]->{$_[1]}; +$$ LANGUAGE plperl; + +SELECT perl_get_field((11,12), 'x'); +SELECT perl_get_field((11,12), 'y'); +SELECT perl_get_field((11,12), 'z'); -- 2.11.0