Skip to content

Commit c07fbcf

Browse files
bmomjianbmomjian
committed
plperl:
Allow conversion from perl to postgresql array in OUT parameters. Second, allow hash form output from procedures with one OUT argument. Pavel Stehule
1 parent 33bf73a commit c07fbcf

File tree

3 files changed

+186
-23
lines changed

3 files changed

+186
-23
lines changed

‎doc/src/FAQ/FAQ_DEV.html

Lines changed: 9 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,7 @@
1313
<H1>Developer's Frequently Asked Questions (FAQ) for
1414
PostgreSQL</H1>
1515

16-
<P>Last updated: Fri Aug 11 15:15:40 EDT 2006</P>
16+
<P>Last updated: Fri Aug 11 15:34:12 EDT 2006</P>
1717

1818
<P>Current maintainer: Bruce Momjian (<A href=
1919
"mailto:bruce@momjian.us">bruce@momjian.us</A>)<BR>
@@ -374,7 +374,14 @@ <H3 id="item1.9">1.9) What tools are available for
374374

375375
or
376376

377-
(c-add-style "pgsql"
377+
(add-hook 'c-mode-hook
378+
(function
379+
(lambda nil
380+
(if (string-match "pgsql" buffer-file-name)
381+
(progn
382+
(c-set-style "bsd")
383+
(setq c-basic-offset 4)
384+
(setq tab-width (c-add-style "pgsql"
378385
'("bsd"
379386
(indent-tabs-mode . t)
380387
(c-basic-offset . 4)

‎src/pl/plperl/plperl.c

Lines changed: 93 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
/**********************************************************************
22
* plperl.c - perl as a procedural language for PostgreSQL
33
*
4-
* $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.113 2006/08/08 19:15:09 tgl Exp $
4+
* $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.114 2006/08/11 19:42:35 momjian Exp $
55
*
66
**********************************************************************/
77

@@ -52,6 +52,7 @@ typedef struct plperl_proc_desc
5252
FmgrInfo result_in_func; /* I/O function and arg for result type */
5353
Oid result_typioparam;
5454
int nargs;
55+
int num_out_args; /* number of out arguments */
5556
FmgrInfo arg_out_func[FUNC_MAX_ARGS];
5657
bool arg_is_rowtype[FUNC_MAX_ARGS];
5758
SV *reference;
@@ -115,6 +116,9 @@ static SV *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc);
115116
static void plperl_init_shared_libs(pTHX);
116117
static HV *plperl_spi_execute_fetch_result(SPITupleTable *, int, int);
117118

119+
static SV *plperl_convert_to_pg_array(SV *src);
120+
static SV *plperl_transform_result(plperl_proc_desc *prodesc, SV *result);
121+
118122
/*
119123
* This routine is a crock, and so is everyplace that calls it. The problem
120124
* is that the cached form of plperl functions/queries is allocated permanently
@@ -404,7 +408,12 @@ plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
404408
(errcode(ERRCODE_UNDEFINED_COLUMN),
405409
errmsg("Perl hash contains nonexistent column \"%s\"",
406410
key)));
407-
if (SvOK(val) && SvTYPE(val) != SVt_NULL)
411+
412+
/* if value is ref on array do to pg string array conversion */
413+
if (SvTYPE(val) == SVt_RV &&
414+
SvTYPE(SvRV(val)) == SVt_PVAV)
415+
values[attn - 1] = SvPV(plperl_convert_to_pg_array(val), PL_na);
416+
else if (SvOK(val) && SvTYPE(val) != SVt_NULL)
408417
values[attn - 1] = SvPV(val, PL_na);
409418
}
410419
hv_iterinit(perlhash);
@@ -681,12 +690,7 @@ plperl_validator(PG_FUNCTION_ARGS)
681690
HeapTuple tuple;
682691
Form_pg_proc proc;
683692
char functyptype;
684-
int numargs;
685-
Oid *argtypes;
686-
char **argnames;
687-
char *argmodes;
688693
bool istrigger = false;
689-
int i;
690694

691695
/* Get the new function's pg_proc entry */
692696
tuple = SearchSysCache(PROCOID,
@@ -714,18 +718,6 @@ plperl_validator(PG_FUNCTION_ARGS)
714718
format_type_be(proc->prorettype))));
715719
}
716720

717-
/* Disallow pseudotypes in arguments (either IN or OUT) */
718-
numargs = get_func_arg_info(tuple,
719-
&argtypes, &argnames, &argmodes);
720-
for (i = 0; i < numargs; i++)
721-
{
722-
if (get_typtype(argtypes[i]) == 'p')
723-
ereport(ERROR,
724-
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
725-
errmsg("plperl functions cannot take type %s",
726-
format_type_be(argtypes[i]))));
727-
}
728-
729721
ReleaseSysCache(tuple);
730722

731723
/* Postpone body checks if !check_function_bodies */
@@ -1128,6 +1120,8 @@ plperl_func_handler(PG_FUNCTION_ARGS)
11281120
/* Return a perl string converted to a Datum */
11291121
char *val;
11301122

1123+
perlret = plperl_transform_result(prodesc, perlret);
1124+
11311125
if (prodesc->fn_retisarray && SvROK(perlret) &&
11321126
SvTYPE(SvRV(perlret)) == SVt_PVAV)
11331127
{
@@ -1256,7 +1250,6 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
12561250
char internal_proname[64];
12571251
int proname_len;
12581252
plperl_proc_desc *prodesc = NULL;
1259-
int i;
12601253
SV **svp;
12611254

12621255
/* We'll need the pg_proc tuple in any case... */
@@ -1319,6 +1312,12 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
13191312
Datum prosrcdatum;
13201313
bool isnull;
13211314
char *proc_source;
1315+
int i;
1316+
int numargs;
1317+
Oid *argtypes;
1318+
char **argnames;
1319+
char *argmodes;
1320+
13221321

13231322
/************************************************************
13241323
* Allocate a new procedure description block
@@ -1337,6 +1336,25 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
13371336
prodesc->fn_readonly =
13381337
(procStruct->provolatile != PROVOLATILE_VOLATILE);
13391338

1339+
1340+
/* Disallow pseudotypes in arguments (either IN or OUT) */
1341+
/* Count number of out arguments */
1342+
numargs = get_func_arg_info(procTup,
1343+
&argtypes, &argnames, &argmodes);
1344+
for (i = 0; i < numargs; i++)
1345+
{
1346+
if (get_typtype(argtypes[i]) == 'p')
1347+
ereport(ERROR,
1348+
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1349+
errmsg("plperl functions cannot take type %s",
1350+
format_type_be(argtypes[i]))));
1351+
1352+
if (argmodes && argmodes[i] == PROARGMODE_OUT)
1353+
prodesc->num_out_args++;
1354+
1355+
}
1356+
1357+
13401358
/************************************************************
13411359
* Lookup the pg_language tuple by Oid
13421360
************************************************************/
@@ -1676,6 +1694,8 @@ plperl_return_next(SV *sv)
16761694
fcinfo = current_call_data->fcinfo;
16771695
rsi = (ReturnSetInfo *) fcinfo->resultinfo;
16781696

1697+
sv = plperl_transform_result(prodesc, sv);
1698+
16791699
if (!prodesc->fn_retisset)
16801700
ereport(ERROR,
16811701
(errcode(ERRCODE_SYNTAX_ERROR),
@@ -1753,7 +1773,16 @@ plperl_return_next(SV *sv)
17531773

17541774
if (SvOK(sv) && SvTYPE(sv) != SVt_NULL)
17551775
{
1756-
char *val = SvPV(sv, PL_na);
1776+
char *val;
1777+
SV *array_ret;
1778+
1779+
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV )
1780+
{
1781+
array_ret = plperl_convert_to_pg_array(sv);
1782+
sv = array_ret;
1783+
}
1784+
1785+
val = SvPV(sv, PL_na);
17571786

17581787
ret = InputFunctionCall(&prodesc->result_in_func, val,
17591788
prodesc->result_typioparam, -1);
@@ -2368,3 +2397,46 @@ plperl_spi_freeplan(char *query)
23682397

23692398
SPI_freeplan( plan);
23702399
}
2400+
2401+
/*
2402+
* If plerl result is hash and fce result is scalar, it's hash form of
2403+
* out argument. Then, transform it to scalar
2404+
*/
2405+
2406+
static SV *
2407+
plperl_transform_result(plperl_proc_desc *prodesc, SV *result)
2408+
{
2409+
bool exactly_one_field = false;
2410+
HV *hvr;
2411+
SV *val;
2412+
char *key;
2413+
I32 klen;
2414+
2415+
2416+
if (prodesc->num_out_args == 1 && SvOK(result)
2417+
&& SvTYPE(result) == SVt_RV && SvTYPE(SvRV(result)) == SVt_PVHV)
2418+
{
2419+
hvr = (HV *) SvRV(result);
2420+
hv_iterinit(hvr);
2421+
2422+
while ((val = hv_iternextsv(hvr, &key, &klen)))
2423+
{
2424+
if (exactly_one_field)
2425+
ereport(ERROR,
2426+
(errcode(ERRCODE_UNDEFINED_COLUMN),
2427+
errmsg("Perl hash contains nonexistent column \"%s\"",
2428+
key)));
2429+
exactly_one_field = true;
2430+
result = val;
2431+
}
2432+
2433+
if (!exactly_one_field)
2434+
ereport(ERROR,
2435+
(errcode(ERRCODE_UNDEFINED_COLUMN),
2436+
errmsg("Perl hash is empty")));
2437+
2438+
hv_iterinit(hvr);
2439+
}
2440+
2441+
return result;
2442+
}

‎src/pl/plperl/sql/plperl.sql

Lines changed: 84 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -337,3 +337,87 @@ CREATE OR REPLACE FUNCTION perl_spi_prepared_set(INTEGER, INTEGER) RETURNS SETOF
337337
$$ LANGUAGE plperl;
338338
SELECT * from perl_spi_prepared_set(1,2);
339339

340+
---
341+
--- Some OUT and OUT array tests
342+
---
343+
344+
CREATE OR REPLACE FUNCTION test_out_params(OUT a varchar, OUT b varchar) AS $$
345+
return { a=> 'ahoj', b=>'svete'};
346+
$$ LANGUAGE plperl;
347+
SELECT '01' AS i, * FROM test_out_params();
348+
349+
CREATE OR REPLACE FUNCTION test_out_params_array(OUT a varchar[], OUT b varchar[]) AS $$
350+
return { a=> ['ahoj'], b=>['svete']};
351+
$$ LANGUAGE plperl;
352+
SELECT '02' AS i, * FROM test_out_params_array();
353+
354+
CREATE OR REPLACE FUNCTION test_out_params_set(OUT a varchar, out b varchar) RETURNS SETOF RECORD AS $$
355+
return_next { a=> 'ahoj', b=>'svete'};
356+
return_next { a=> 'ahoj', b=>'svete'};
357+
return_next { a=> 'ahoj', b=>'svete'};
358+
$$ LANGUAGE plperl;
359+
SELECT '03' AS I,* FROM test_out_params_set();
360+
361+
CREATE OR REPLACE FUNCTION test_out_params_set_array(OUT a varchar[], out b varchar[]) RETURNS SETOF RECORD AS $$
362+
return_next { a=> ['ahoj'], b=>['velky','svete']};
363+
return_next { a=> ['ahoj'], b=>['velky','svete']};
364+
return_next { a=> ['ahoj'], b=>['velky','svete']};
365+
$$ LANGUAGE plperl;
366+
SELECT '04' AS I,* FROM test_out_params_set_array();
367+
368+
369+
DROP FUNCTION test_out_params();
370+
DROP FUNCTION test_out_params_set();
371+
DROP FUNCTION test_out_params_array();
372+
DROP FUNCTION test_out_params_set_array();
373+
374+
-- one out argument can be returned as scalar or hash
375+
CREATE OR REPLACE FUNCTION test01(OUT a varchar) AS $$
376+
return 'ahoj';
377+
$$ LANGUAGE plperl ;
378+
SELECT '01' AS i,* FROM test01();
379+
380+
CREATE OR REPLACE FUNCTION test02(OUT a varchar[]) AS $$
381+
return {a=>['ahoj']};
382+
$$ LANGUAGE plperl;
383+
SELECT '02' AS i,a[1] FROM test02();
384+
385+
CREATE OR REPLACE FUNCTION test03(OUT a varchar[]) RETURNS SETOF varchar[] AS $$
386+
return_next { a=> ['ahoj']};
387+
return_next { a=> ['ahoj']};
388+
return_next { a=> ['ahoj']};
389+
$$ LANGUAGE plperl;
390+
SELECT '03' AS i,* FROM test03();
391+
392+
CREATE OR REPLACE FUNCTION test04() RETURNS SETOF VARCHAR[] AS $$
393+
return_next ['ahoj'];
394+
return_next ['ahoj'];
395+
$$ LANGUAGE plperl;
396+
SELECT '04' AS i,* FROM test04();
397+
398+
CREATE OR REPLACE FUNCTION test05(OUT a varchar) AS $$
399+
return {a=>'ahoj'};
400+
$$ LANGUAGE plperl;
401+
SELECT '05' AS i,a FROM test05();
402+
403+
CREATE OR REPLACE FUNCTION test06(OUT a varchar) RETURNS SETOF varchar AS $$
404+
return_next { a=> 'ahoj'};
405+
return_next { a=> 'ahoj'};
406+
return_next { a=> 'ahoj'};
407+
$$ LANGUAGE plperl;
408+
SELECT '06' AS i,* FROM test06();
409+
410+
CREATE OR REPLACE FUNCTION test07() RETURNS SETOF VARCHAR AS $$
411+
return_next 'ahoj';
412+
return_next 'ahoj';
413+
$$ LANGUAGE plperl;
414+
SELECT '07' AS i,* FROM test07();
415+
416+
DROP FUNCTION test01();
417+
DROP FUNCTION test02();
418+
DROP FUNCTION test03();
419+
DROP FUNCTION test04();
420+
DROP FUNCTION test05();
421+
DROP FUNCTION test06();
422+
DROP FUNCTION test07();
423+

0 commit comments

Comments
 (0)
pFad - Phonifier reborn

Pfad - The Proxy pFad of © 2024 Garber Painting. All rights reserved.

Note: This service is not intended for secure transactions such as banking, social media, email, or purchasing. Use at your own risk. We assume no liability whatsoever for broken pages.


Alternative Proxies:

Alternative Proxy

pFad Proxy

pFad v3 Proxy

pFad v4 Proxy