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)