From: Bruce Momjian Date: Fri, 11 Aug 2006 19:42:35 +0000 (+0000) Subject: plperl: X-Git-Tag: REL8_2_BETA1~345 X-Git-Url: https://granicus.if.org/sourcecode?a=commitdiff_plain;h=c07fbcf57701a26dfafd44ebe3edc4070fa6c6d0;p=postgresql plperl: Allow conversion from perl to postgresql array in OUT parameters. Second, allow hash form output from procedures with one OUT argument. Pavel Stehule --- diff --git a/doc/src/FAQ/FAQ_DEV.html b/doc/src/FAQ/FAQ_DEV.html index c46bc10992..8d796733a2 100644 --- a/doc/src/FAQ/FAQ_DEV.html +++ b/doc/src/FAQ/FAQ_DEV.html @@ -13,7 +13,7 @@

Developer's Frequently Asked Questions (FAQ) for PostgreSQL

-

Last updated: Fri Aug 11 15:15:40 EDT 2006

+

Last updated: Fri Aug 11 15:34:12 EDT 2006

Current maintainer: Bruce Momjian (bruce@momjian.us)
@@ -374,7 +374,14 @@ or - (c-add-style "pgsql" +(add-hook 'c-mode-hook + (function + (lambda nil + (if (string-match "pgsql" buffer-file-name) + (progn + (c-set-style "bsd") + (setq c-basic-offset 4) + (setq tab-width (c-add-style "pgsql" '("bsd" (indent-tabs-mode . t) (c-basic-offset . 4) diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c index 8e0f309d05..914bc94066 100644 --- a/src/pl/plperl/plperl.c +++ b/src/pl/plperl/plperl.c @@ -1,7 +1,7 @@ /********************************************************************** * plperl.c - perl as a procedural language for PostgreSQL * - * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.113 2006/08/08 19:15:09 tgl Exp $ + * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.114 2006/08/11 19:42:35 momjian Exp $ * **********************************************************************/ @@ -52,6 +52,7 @@ typedef struct plperl_proc_desc 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; @@ -115,6 +116,9 @@ 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); +static SV *plperl_convert_to_pg_array(SV *src); +static SV *plperl_transform_result(plperl_proc_desc *prodesc, SV *result); + /* * 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 @@ -404,7 +408,12 @@ plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta) (errcode(ERRCODE_UNDEFINED_COLUMN), errmsg("Perl hash contains nonexistent column \"%s\"", key))); - if (SvOK(val) && SvTYPE(val) != SVt_NULL) + + /* 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); @@ -681,12 +690,7 @@ plperl_validator(PG_FUNCTION_ARGS) 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, @@ -714,18 +718,6 @@ plperl_validator(PG_FUNCTION_ARGS) 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); /* Postpone body checks if !check_function_bodies */ @@ -1128,6 +1120,8 @@ plperl_func_handler(PG_FUNCTION_ARGS) /* 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) { @@ -1256,7 +1250,6 @@ compile_plperl_function(Oid fn_oid, bool is_trigger) char internal_proname[64]; int proname_len; plperl_proc_desc *prodesc = NULL; - int i; SV **svp; /* We'll need the pg_proc tuple in any case... */ @@ -1319,6 +1312,12 @@ compile_plperl_function(Oid fn_oid, bool is_trigger) Datum prosrcdatum; bool isnull; char *proc_source; + int i; + int numargs; + Oid *argtypes; + char **argnames; + char *argmodes; + /************************************************************ * Allocate a new procedure description block @@ -1337,6 +1336,25 @@ compile_plperl_function(Oid fn_oid, bool is_trigger) prodesc->fn_readonly = (procStruct->provolatile != PROVOLATILE_VOLATILE); + + /* Disallow pseudotypes in arguments (either IN or OUT) */ + /* Count number of 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 ************************************************************/ @@ -1676,6 +1694,8 @@ plperl_return_next(SV *sv) 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), @@ -1753,7 +1773,16 @@ plperl_return_next(SV *sv) if (SvOK(sv) && SvTYPE(sv) != SVt_NULL) { - char *val = SvPV(sv, PL_na); + char *val; + SV *array_ret; + + 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); @@ -2368,3 +2397,46 @@ plperl_spi_freeplan(char *query) SPI_freeplan( plan); } + +/* + * If plerl result is hash and fce result is scalar, it's hash form of + * out argument. Then, transform it to scalar + */ + +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 == 1 && SvOK(result) + && SvTYPE(result) == SVt_RV && SvTYPE(SvRV(result)) == SVt_PVHV) + { + 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; +} diff --git a/src/pl/plperl/sql/plperl.sql b/src/pl/plperl/sql/plperl.sql index e312cd24dc..40420a0ff5 100644 --- a/src/pl/plperl/sql/plperl.sql +++ b/src/pl/plperl/sql/plperl.sql @@ -337,3 +337,87 @@ CREATE OR REPLACE FUNCTION perl_spi_prepared_set(INTEGER, INTEGER) RETURNS SETOF $$ LANGUAGE plperl; SELECT * from perl_spi_prepared_set(1,2); +--- +--- Some OUT and OUT array tests +--- + +CREATE OR REPLACE FUNCTION test_out_params(OUT a varchar, OUT b varchar) AS $$ + return { a=> 'ahoj', b=>'svete'}; +$$ LANGUAGE plperl; +SELECT '01' AS i, * FROM test_out_params(); + +CREATE OR REPLACE FUNCTION test_out_params_array(OUT a varchar[], OUT b varchar[]) AS $$ + return { a=> ['ahoj'], b=>['svete']}; +$$ LANGUAGE plperl; +SELECT '02' AS i, * FROM test_out_params_array(); + +CREATE OR REPLACE FUNCTION test_out_params_set(OUT a varchar, out b varchar) RETURNS SETOF RECORD AS $$ + return_next { a=> 'ahoj', b=>'svete'}; + return_next { a=> 'ahoj', b=>'svete'}; + return_next { a=> 'ahoj', b=>'svete'}; +$$ LANGUAGE plperl; +SELECT '03' AS I,* FROM test_out_params_set(); + +CREATE OR REPLACE FUNCTION test_out_params_set_array(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 '04' AS I,* FROM test_out_params_set_array(); + + +DROP FUNCTION test_out_params(); +DROP FUNCTION test_out_params_set(); +DROP FUNCTION test_out_params_array(); +DROP FUNCTION test_out_params_set_array(); + +-- one out argument can be returned as scalar or 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[]) AS $$ + return {a=>['ahoj']}; +$$ LANGUAGE plperl; +SELECT '02' AS i,a[1] FROM test02(); + +CREATE OR REPLACE FUNCTION test03(OUT a varchar[]) RETURNS SETOF varchar[] AS $$ + return_next { a=> ['ahoj']}; + return_next { a=> ['ahoj']}; + return_next { a=> ['ahoj']}; +$$ LANGUAGE plperl; +SELECT '03' AS i,* FROM test03(); + +CREATE OR REPLACE FUNCTION test04() RETURNS SETOF VARCHAR[] AS $$ + return_next ['ahoj']; + return_next ['ahoj']; +$$ LANGUAGE plperl; +SELECT '04' AS i,* FROM test04(); + +CREATE OR REPLACE FUNCTION test05(OUT a varchar) AS $$ + return {a=>'ahoj'}; +$$ LANGUAGE plperl; +SELECT '05' AS i,a 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 test01(); +DROP FUNCTION test02(); +DROP FUNCTION test03(); +DROP FUNCTION test04(); +DROP FUNCTION test05(); +DROP FUNCTION test06(); +DROP FUNCTION test07(); +