Movatterモバイル変換

[0]ホーム
URL:

Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly

 Sign up
Appearance settings

Commitb563394

Browse files
committed
Re-apply plperl patch that allows OUT parameters to be placed into Perl
hash and array variables. (regression output updated)
1 parentf09fb71 commitb563394

File tree

3 files changed

+286
-21
lines changed

3 files changed

+286
-21
lines changed

‎src/pl/plperl/expected/plperl.out‎

Lines changed: 109 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -468,3 +468,112 @@ SELECT * from perl_spi_prepared_set(1,2);
468468
4
469469
(2 rows)
470470

471+
---
472+
--- Some OUT and OUT array tests
473+
---
474+
CREATE OR REPLACE FUNCTION test_out_params(OUT a varchar, OUT b varchar) AS $$
475+
return { a=> 'ahoj', b=>'svete'};
476+
$$ LANGUAGE plperl;
477+
SELECT '01' AS i, * FROM test_out_params();
478+
i | a | b
479+
----+------+-------
480+
01 | ahoj | svete
481+
(1 row)
482+
483+
CREATE OR REPLACE FUNCTION test_out_params_array(OUT a varchar[], OUT b varchar[]) AS $$
484+
return { a=> ['ahoj'], b=>['svete']};
485+
$$ LANGUAGE plperl;
486+
SELECT '02' AS i, * FROM test_out_params_array();
487+
ERROR: array value must start with "{" or dimension information
488+
CREATE OR REPLACE FUNCTION test_out_params_set(OUT a varchar, out b varchar) RETURNS SETOF RECORD AS $$
489+
return_next { a=> 'ahoj', b=>'svete'};
490+
return_next { a=> 'ahoj', b=>'svete'};
491+
return_next { a=> 'ahoj', b=>'svete'};
492+
$$ LANGUAGE plperl;
493+
SELECT '03' AS I,* FROM test_out_params_set();
494+
i | a | b
495+
----+------+-------
496+
03 | ahoj | svete
497+
03 | ahoj | svete
498+
03 | ahoj | svete
499+
(3 rows)
500+
501+
CREATE OR REPLACE FUNCTION test_out_params_set_array(OUT a varchar[], out b varchar[]) RETURNS SETOF RECORD AS $$
502+
return_next { a=> ['ahoj'], b=>['velky','svete']};
503+
return_next { a=> ['ahoj'], b=>['velky','svete']};
504+
return_next { a=> ['ahoj'], b=>['velky','svete']};
505+
$$ LANGUAGE plperl;
506+
SELECT '04' AS I,* FROM test_out_params_set_array();
507+
ERROR: error from Perl function: array value must start with "{" or dimension information at line 2.
508+
DROP FUNCTION test_out_params();
509+
DROP FUNCTION test_out_params_set();
510+
DROP FUNCTION test_out_params_array();
511+
DROP FUNCTION test_out_params_set_array();
512+
-- one out argument can be returned as scalar or hash
513+
CREATE OR REPLACE FUNCTION test01(OUT a varchar) AS $$
514+
return 'ahoj';
515+
$$ LANGUAGE plperl ;
516+
SELECT '01' AS i,* FROM test01();
517+
i | a
518+
----+------
519+
01 | ahoj
520+
(1 row)
521+
522+
CREATE OR REPLACE FUNCTION test02(OUT a varchar[]) AS $$
523+
return {a=>['ahoj']};
524+
$$ LANGUAGE plperl;
525+
SELECT '02' AS i,a[1] FROM test02();
526+
ERROR: array value must start with "{" or dimension information
527+
CREATE OR REPLACE FUNCTION test03(OUT a varchar[]) RETURNS SETOF varchar[] AS $$
528+
return_next { a=> ['ahoj']};
529+
return_next { a=> ['ahoj']};
530+
return_next { a=> ['ahoj']};
531+
$$ LANGUAGE plperl;
532+
SELECT '03' AS i,* FROM test03();
533+
ERROR: error from Perl function: array value must start with "{" or dimension information at line 2.
534+
CREATE OR REPLACE FUNCTION test04() RETURNS SETOF VARCHAR[] AS $$
535+
return_next ['ahoj'];
536+
return_next ['ahoj'];
537+
$$ LANGUAGE plperl;
538+
SELECT '04' AS i,* FROM test04();
539+
ERROR: error from Perl function: array value must start with "{" or dimension information at line 2.
540+
CREATE OR REPLACE FUNCTION test05(OUT a varchar) AS $$
541+
return {a=>'ahoj'};
542+
$$ LANGUAGE plperl;
543+
SELECT '05' AS i,a FROM test05();
544+
i | a
545+
----+-----------------
546+
05 | HASH(0x8558f9c)
547+
(1 row)
548+
549+
CREATE OR REPLACE FUNCTION test06(OUT a varchar) RETURNS SETOF varchar AS $$
550+
return_next { a=> 'ahoj'};
551+
return_next { a=> 'ahoj'};
552+
return_next { a=> 'ahoj'};
553+
$$ LANGUAGE plperl;
554+
SELECT '06' AS i,* FROM test06();
555+
i | a
556+
----+-----------------
557+
06 | HASH(0x8559230)
558+
06 | HASH(0x8559230)
559+
06 | HASH(0x8559230)
560+
(3 rows)
561+
562+
CREATE OR REPLACE FUNCTION test07() RETURNS SETOF VARCHAR AS $$
563+
return_next 'ahoj';
564+
return_next 'ahoj';
565+
$$ LANGUAGE plperl;
566+
SELECT '07' AS i,* FROM test07();
567+
i | test07
568+
----+--------
569+
07 | ahoj
570+
07 | ahoj
571+
(2 rows)
572+
573+
DROP FUNCTION test01();
574+
DROP FUNCTION test02();
575+
DROP FUNCTION test03();
576+
DROP FUNCTION test04();
577+
DROP FUNCTION test05();
578+
DROP FUNCTION test06();
579+
DROP FUNCTION test07();

‎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.115 2006/08/12 04:16:45 momjian Exp $
4+
* $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.116 2006/08/13 02:37:11 momjian Exp $
55
*
66
**********************************************************************/
77

@@ -52,6 +52,7 @@ typedef struct plperl_proc_desc
5252
FmgrInforesult_in_func;/* I/O function and arg for result type */
5353
Oidresult_typioparam;
5454
intnargs;
55+
intnum_out_args;/* number of out arguments */
5556
FmgrInfoarg_out_func[FUNC_MAX_ARGS];
5657
boolarg_is_rowtype[FUNC_MAX_ARGS];
5758
SV*reference;
@@ -115,6 +116,9 @@ static SV *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc);
115116
staticvoidplperl_init_shared_libs(pTHX);
116117
staticHV*plperl_spi_execute_fetch_result(SPITupleTable*,int,int);
117118

119+
staticSV*plperl_convert_to_pg_array(SV*src);
120+
staticSV*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+
elseif (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
HeapTupletuple;
682691
Form_pg_procproc;
683692
charfunctyptype;
684-
intnumargs;
685-
Oid*argtypes;
686-
char**argnames;
687-
char*argmodes;
688693
boolistrigger= false;
689-
inti;
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
charinternal_proname[64];
12571251
intproname_len;
12581252
plperl_proc_desc*prodesc=NULL;
1259-
inti;
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
Datumprosrcdatum;
13201313
boolisnull;
13211314
char*proc_source;
1315+
inti;
1316+
intnumargs;
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+
staticSV*
2407+
plperl_transform_result(plperl_proc_desc*prodesc,SV*result)
2408+
{
2409+
boolexactly_one_field= false;
2410+
HV*hvr;
2411+
SV*val;
2412+
char*key;
2413+
I32klen;
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+
returnresult;
2442+
}

0 commit comments

Comments
 (0)
[8]ページ先頭
©2009-2025 Movatter.jp