open-dsi
/
postgres
mirror of https://github.com/postgres/postgres
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Re-apply plperl patch that allows OUT parameters to be placed into Perl

Browse Source 
hash and array variables.  (regression output updated)
REL8_2_STABLE
Bruce Momjian 19 years ago
parent f09fb71af9
commit b5633943cb
3 changed files with 286 additions and 21 deletions
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Show Stats Download Patch File Download Diff File
  1. 109
      src/pl/plperl/expected/plperl.out
  2. 114
      src/pl/plperl/plperl.c
  3. 84
      src/pl/plperl/sql/plperl.sql

109
src/pl/plperl/expected/plperl.out
Unescape View File

@ -468,3 +468,112 @@ SELECT * from perl_spi_prepared_set(1,2);
4
(2 rows)
---
--- 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();
i | a | b
----+------+-------
01 | ahoj | svete
(1 row)
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();
ERROR: array value must start with "{" or dimension information
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();
i | a | b
----+------+-------
03 | ahoj | svete
03 | ahoj | svete
03 | ahoj | svete
(3 rows)
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();
ERROR: error from Perl function: array value must start with "{" or dimension information at line 2.
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();
i | a
----+------
01 | ahoj
(1 row)
CREATE OR REPLACE FUNCTION test02(OUT a varchar[]) AS $$
return {a=>['ahoj']};
$$ LANGUAGE plperl;
SELECT '02' AS i,a[1] FROM test02();
ERROR: array value must start with "{" or dimension information
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();
ERROR: error from Perl function: array value must start with "{" or dimension information at line 2.
CREATE OR REPLACE FUNCTION test04() RETURNS SETOF VARCHAR[] AS $$
return_next ['ahoj'];
return_next ['ahoj'];
$$ LANGUAGE plperl;
SELECT '04' AS i,* FROM test04();
ERROR: error from Perl function: array value must start with "{" or dimension information at line 2.
CREATE OR REPLACE FUNCTION test05(OUT a varchar) AS $$
return {a=>'ahoj'};
$$ LANGUAGE plperl;
SELECT '05' AS i,a FROM test05();
i | a
----+-----------------
05 | HASH(0x8558f9c)
(1 row)
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();
i | a
----+-----------------
06 | HASH(0x8559230)
06 | HASH(0x8559230)
06 | HASH(0x8559230)
(3 rows)
CREATE OR REPLACE FUNCTION test07() RETURNS SETOF VARCHAR AS $$
return_next 'ahoj';
return_next 'ahoj';
$$ LANGUAGE plperl;
SELECT '07' AS i,* FROM test07();
i | test07
----+--------
07 | ahoj
07 | ahoj
(2 rows)
DROP FUNCTION test01();
DROP FUNCTION test02();
DROP FUNCTION test03();
DROP FUNCTION test04();
DROP FUNCTION test05();
DROP FUNCTION test06();
DROP FUNCTION test07();

114
src/pl/plperl/plperl.c
Unescape View File

@ -1,7 +1,7 @@
/**********************************************************************
* plperl.c - perl as a procedural language for PostgreSQL
*
* $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.115 2006/08/12 04:16:45 momjian Exp $
* $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.116 2006/08/13 02:37:11 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;
}

84
src/pl/plperl/sql/plperl.sql
Unescape View File

@ -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();

Write Preview
Loading…
Cancel
Save