--- Begin Message ---
Hello,
I sending this patch for review. I'll try separate this patch to a)
better array support, b) consistency in OUT parameters.
I invite any comments
Regards
Pavel Stehule
*** ./plperl.c.orig 2006-07-29 21:07:09.000000000 +0200
--- ./plperl.c 2006-07-30 22:50:56.000000000 +0200
***************
*** 52,57 ****
--- 52,58 ----
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;
***************
*** 117,122 ****
--- 118,126 ----
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);
+
+
/*
* 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
***************
*** 412,418 ****
(errcode(ERRCODE_UNDEFINED_COLUMN),
errmsg("Perl hash contains nonexistent column \"%s\"",
key)));
! if (SvOK(val) && SvTYPE(val) != SVt_NULL)
values[attn - 1] = SvPV(val, PL_na);
}
hv_iterinit(perlhash);
--- 416,427 ----
(errcode(ERRCODE_UNDEFINED_COLUMN),
errmsg("Perl hash contains nonexistent column \"%s\"",
key)));
!
! /* 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);
***************
*** 691,702 ****
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,
--- 700,706 ----
***************
*** 724,740 ****
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);
--- 728,733 ----
***************
*** 1014,1019 ****
--- 1007,1065 ----
return retval;
}
+ /*
+ * Verify type of result if proc has out params and transform it
+ * to scalar if proc has only one out parameter
+ */
+
+ 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 > 0)
+ {
+ if (!SvOK(result) || SvTYPE(result) != SVt_RV ||
+ SvTYPE(SvRV(result)) != SVt_PVHV)
+ {
+ ereport(ERROR,
+ (errcode(ERRCODE_DATATYPE_MISMATCH),
+ errmsg("Perl function with OUT arguments"
+ " must return reference to hash")));
+ }
+
+ if (prodesc->num_out_args == 1)
+ {
+ 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;
+ }
static Datum
plperl_func_handler(PG_FUNCTION_ARGS)
***************
*** 1079,1084 ****
--- 1125,1131 ----
while ((svp = av_fetch(rav, i, FALSE)) != NULL)
{
+
plperl_return_next(*svp);
i++;
}
***************
*** 1120,1126 ****
{
ereport(ERROR,
(errcode(ERRCODE_DATATYPE_MISMATCH),
! errmsg("composite-returning Perl function "
"must return reference to hash")));
}
--- 1167,1173 ----
{
ereport(ERROR,
(errcode(ERRCODE_DATATYPE_MISMATCH),
! errmsg("composite-returning Perl function or function with out parameters"
"must return reference to hash")));
}
***************
*** 1142,1149 ****
/* Return a perl string converted to a Datum */
char *val;
if (prodesc->fn_retisarray && SvROK(perlret) &&
! SvTYPE(SvRV(perlret)) == SVt_PVAV)
{
array_ret = plperl_convert_to_pg_array(perlret);
SvREFCNT_dec(perlret);
--- 1189,1198 ----
/* 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 )
{
array_ret = plperl_convert_to_pg_array(perlret);
SvREFCNT_dec(perlret);
***************
*** 1272,1277 ****
--- 1321,1330 ----
plperl_proc_desc *prodesc = NULL;
int i;
SV **svp;
+ int numargs;
+ Oid *argtypes;
+ char **argnames;
+ char *argmodes;
/* We'll need the pg_proc tuple in any case... */
procTup = SearchSysCache(PROCOID,
***************
*** 1281,1286 ****
--- 1334,1340 ----
elog(ERROR, "cache lookup failed for function %u", fn_oid);
procStruct = (Form_pg_proc) GETSTRUCT(procTup);
+
/************************************************************
* Build our internal proc name from the function's Oid
************************************************************/
***************
*** 1351,1356 ****
--- 1405,1427 ----
prodesc->fn_readonly =
(procStruct->provolatile != PROVOLATILE_VOLATILE);
+
+ /* Disallow pseudotypes in arguments (either IN or OUT) and count procedure 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
************************************************************/
***************
*** 1690,1695 ****
--- 1761,1768 ----
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),
***************
*** 1764,1773 ****
{
Datum ret;
bool isNull;
if (SvOK(sv) && SvTYPE(sv) != SVt_NULL)
{
! char *val = SvPV(sv, PL_na);
ret = InputFunctionCall(&prodesc->result_in_func, val,
prodesc->result_typioparam, -1);
--- 1837,1854 ----
{
Datum ret;
bool isNull;
+ SV *array_ret;
+ char *val;
if (SvOK(sv) && SvTYPE(sv) != SVt_NULL)
{
! 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);
*** ./sql/plperl.sql.orig 2006-07-30 22:52:04.000000000 +0200
--- ./sql/plperl.sql 2006-07-30 22:54:27.000000000 +0200
***************
*** 337,339 ****
--- 337,391 ----
$$ LANGUAGE plperl;
SELECT * from perl_spi_prepared_set(1,2);
+ ---
+ --- Some OUT and OUT array tests
+ ---
+
+ -- wrong, OUT params needs 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, OUT b varchar) as $$
+ return { a=> 'ahoj', b=>'svete'};
+ $$ language plperl;
+ select '02' as i, * from test02();
+
+ create or replace function test03(OUT a varchar[]) as $$
+ return {a=>['ahoj']};
+ $$ language plperl;
+ select '03' as i,a[1] from test03();
+
+ create or replace function test04(OUT a varchar[], out b varchar[]) as $$
+ return { a=> ['ahoj'], b=>['velky','svete']};
+ $$ language plperl;
+ select '04' as i,* from test04();
+
+ create or replace function test05(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 '05' as i,* 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 test02();
+ drop function test03();
+ drop function test04();
+ drop function test05();
+ drop function test06();
+ drop function test07();
+
--- End Message ---
