*** ./plperl.c.orig 2006-07-29 21:07:09.000000000 +0200 --- ./plperl.c 2006-07-30 22:50:56.000000000 +0200 *************** *** 52,57 **** --- 52,58 ---- FmgrInfo result_in_func; /* I/O function and arg for result type */ Oid result_typioparam; int nargs; + int num_out_args; /* number of out arguments */ FmgrInfo arg_out_func[FUNC_MAX_ARGS]; bool arg_is_rowtype[FUNC_MAX_ARGS]; SV *reference; *************** *** 117,122 **** --- 118,126 ---- static void plperl_init_shared_libs(pTHX); static HV *plperl_spi_execute_fetch_result(SPITupleTable *, int, int); + static SV *plperl_convert_to_pg_array(SV *src); + + /* * This routine is a crock, and so is everyplace that calls it. The problem * is that the cached form of plperl functions/queries is allocated permanently *************** *** 412,418 **** (errcode(ERRCODE_UNDEFINED_COLUMN), errmsg("Perl hash contains nonexistent column \"%s\"", key))); ! if (SvOK(val) && SvTYPE(val) != SVt_NULL) values[attn - 1] = SvPV(val, PL_na); } hv_iterinit(perlhash); --- 416,427 ---- (errcode(ERRCODE_UNDEFINED_COLUMN), errmsg("Perl hash contains nonexistent column \"%s\"", key))); ! ! /* if value is ref on array do to pg string array conversion */ ! if (SvTYPE(val) == SVt_RV && ! SvTYPE(SvRV(val)) == SVt_PVAV) ! values[attn - 1] = SvPV(plperl_convert_to_pg_array(val), PL_na); ! else if (SvOK(val) && SvTYPE(val) != SVt_NULL) values[attn - 1] = SvPV(val, PL_na); } hv_iterinit(perlhash); *************** *** 691,702 **** HeapTuple tuple; Form_pg_proc proc; char functyptype; - int numargs; - Oid *argtypes; - char **argnames; - char *argmodes; bool istrigger = false; - int i; /* Get the new function's pg_proc entry */ tuple = SearchSysCache(PROCOID, --- 700,706 ---- *************** *** 724,740 **** format_type_be(proc->prorettype)))); } - /* Disallow pseudotypes in arguments (either IN or OUT) */ - numargs = get_func_arg_info(tuple, - &argtypes, &argnames, &argmodes); - for (i = 0; i < numargs; i++) - { - if (get_typtype(argtypes[i]) == 'p') - ereport(ERROR, - (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), - errmsg("plperl functions cannot take type %s", - format_type_be(argtypes[i])))); - } ReleaseSysCache(tuple); --- 728,733 ---- *************** *** 1014,1019 **** --- 1007,1065 ---- return retval; } + /* + * Verify type of result if proc has out params and transform it + * to scalar if proc has only one out parameter + */ + + static SV * + plperl_transform_result(plperl_proc_desc *prodesc, SV *result) + { + bool exactly_one_field = false; + HV *hvr; + SV *val; + char *key; + I32 klen; + + + if (prodesc->num_out_args > 0) + { + if (!SvOK(result) || SvTYPE(result) != SVt_RV || + SvTYPE(SvRV(result)) != SVt_PVHV) + { + ereport(ERROR, + (errcode(ERRCODE_DATATYPE_MISMATCH), + errmsg("Perl function with OUT arguments" + " must return reference to hash"))); + } + + if (prodesc->num_out_args == 1) + { + hvr = (HV *) SvRV(result); + hv_iterinit(hvr); + + while ((val = hv_iternextsv(hvr, &key, &klen))) + { + if (exactly_one_field) + ereport(ERROR, + (errcode(ERRCODE_UNDEFINED_COLUMN), + errmsg("Perl hash contains nonexistent column \"%s\"", + key))); + exactly_one_field = true; + result = val; + } + + if (!exactly_one_field) + ereport(ERROR, + (errcode(ERRCODE_UNDEFINED_COLUMN), + errmsg("Perl hash is empty"))); + + hv_iterinit(hvr); + } + } + + return result; + } static Datum plperl_func_handler(PG_FUNCTION_ARGS) *************** *** 1079,1084 **** --- 1125,1131 ---- while ((svp = av_fetch(rav, i, FALSE)) != NULL) { + plperl_return_next(*svp); i++; } *************** *** 1120,1126 **** { ereport(ERROR, (errcode(ERRCODE_DATATYPE_MISMATCH), ! errmsg("composite-returning Perl function " "must return reference to hash"))); } --- 1167,1173 ---- { ereport(ERROR, (errcode(ERRCODE_DATATYPE_MISMATCH), ! errmsg("composite-returning Perl function or function with out parameters" "must return reference to hash"))); } *************** *** 1142,1149 **** /* Return a perl string converted to a Datum */ char *val; if (prodesc->fn_retisarray && SvROK(perlret) && ! SvTYPE(SvRV(perlret)) == SVt_PVAV) { array_ret = plperl_convert_to_pg_array(perlret); SvREFCNT_dec(perlret); --- 1189,1198 ---- /* Return a perl string converted to a Datum */ char *val; + perlret = plperl_transform_result(prodesc, perlret); + if (prodesc->fn_retisarray && SvROK(perlret) && ! SvTYPE(SvRV(perlret)) == SVt_PVAV ) { array_ret = plperl_convert_to_pg_array(perlret); SvREFCNT_dec(perlret); *************** *** 1272,1277 **** --- 1321,1330 ---- plperl_proc_desc *prodesc = NULL; int i; SV **svp; + int numargs; + Oid *argtypes; + char **argnames; + char *argmodes; /* We'll need the pg_proc tuple in any case... */ procTup = SearchSysCache(PROCOID, *************** *** 1281,1286 **** --- 1334,1340 ---- elog(ERROR, "cache lookup failed for function %u", fn_oid); procStruct = (Form_pg_proc) GETSTRUCT(procTup); + /************************************************************ * Build our internal proc name from the function's Oid ************************************************************/ *************** *** 1351,1356 **** --- 1405,1427 ---- prodesc->fn_readonly = (procStruct->provolatile != PROVOLATILE_VOLATILE); + + /* Disallow pseudotypes in arguments (either IN or OUT) and count procedure OUT arguments */ + numargs = get_func_arg_info(procTup, + &argtypes, &argnames, &argmodes); + + for (i = 0; i < numargs; i++) + { + if (get_typtype(argtypes[i]) == 'p') + ereport(ERROR, + (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), + errmsg("plperl functions cannot take type %s", + format_type_be(argtypes[i])))); + + if (argmodes && argmodes[i] == PROARGMODE_OUT) + prodesc->num_out_args++; + } + /************************************************************ * Lookup the pg_language tuple by Oid ************************************************************/ *************** *** 1690,1695 **** --- 1761,1768 ---- fcinfo = current_call_data->fcinfo; rsi = (ReturnSetInfo *) fcinfo->resultinfo; + sv = plperl_transform_result(prodesc, sv); + if (!prodesc->fn_retisset) ereport(ERROR, (errcode(ERRCODE_SYNTAX_ERROR), *************** *** 1764,1773 **** { Datum ret; bool isNull; if (SvOK(sv) && SvTYPE(sv) != SVt_NULL) { ! char *val = SvPV(sv, PL_na); ret = InputFunctionCall(&prodesc->result_in_func, val, prodesc->result_typioparam, -1); --- 1837,1854 ---- { Datum ret; bool isNull; + SV *array_ret; + char *val; if (SvOK(sv) && SvTYPE(sv) != SVt_NULL) { ! if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV ) ! { ! array_ret = plperl_convert_to_pg_array(sv); ! sv = array_ret; ! } ! ! val = SvPV(sv, PL_na); ret = InputFunctionCall(&prodesc->result_in_func, val, prodesc->result_typioparam, -1); *** ./sql/plperl.sql.orig 2006-07-30 22:52:04.000000000 +0200 --- ./sql/plperl.sql 2006-07-30 22:54:27.000000000 +0200 *************** *** 337,339 **** --- 337,391 ---- $$ LANGUAGE plperl; SELECT * from perl_spi_prepared_set(1,2); + --- + --- Some OUT and OUT array tests + --- + + -- wrong, OUT params needs hash + create or replace function test01(OUT a varchar) as $$ + return 'ahoj'; + $$ language plperl ; + select '01' as i,* from test01(); + + create or replace function test02(OUT a varchar, OUT b varchar) as $$ + return { a=> 'ahoj', b=>'svete'}; + $$ language plperl; + select '02' as i, * from test02(); + + create or replace function test03(OUT a varchar[]) as $$ + return {a=>['ahoj']}; + $$ language plperl; + select '03' as i,a[1] from test03(); + + create or replace function test04(OUT a varchar[], out b varchar[]) as $$ + return { a=> ['ahoj'], b=>['velky','svete']}; + $$ language plperl; + select '04' as i,* from test04(); + + create or replace function test05(OUT a varchar[], out b varchar[]) returns setof record as $$ + return_next { a=> ['ahoj'], b=>['velky','svete']}; + return_next { a=> ['ahoj'], b=>['velky','svete']}; + return_next { a=> ['ahoj'], b=>['velky','svete']}; + $$ language plperl; + select '05' as i,* from test05(); + + create or replace function test06(OUT a varchar[]) returns setof varchar[] as $$ + return_next { a=> ['ahoj']}; + return_next { a=> ['ahoj']}; + return_next { a=> ['ahoj']}; + $$ language plperl; + select '06' as i,* from test06(); + + create or replace function test07() returns setof varchar[] as $$ + return_next ['ahoj']; + return_next ['ahoj']; + $$ language plperl; + select '07' as i,* from test07(); + + drop function test02(); + drop function test03(); + drop function test04(); + drop function test05(); + drop function test06(); + drop function test07(); +