On Fri, Jul 28, 2006 at 10:42:49AM +0200, Pavel Stehule wrote:
> Hello,
> 
> I miss better support OUT arguments in plerlu:
> 
> create or replace function foo(out p varchar[]) as $$ return { p => [pavel, 
> jana] }; $$ language plperlu;
> postgres=# select foo();
> ERROR:  array value must start with "{" or dimension information
> postgres=#
> 
> I starting work on it. I hope It will be done before current feature freeze.
> 
> Regards
> Pavel Stehule

It seems Pavel missed sending the preliminary patch, so here it is :)

Cheers,
D
-- 
David Fetter <[EMAIL PROTECTED]> http://fetter.org/
phone: +1 415 235 3778        AIM: dfetter666
                              Skype: davidfetter

Remember to vote!
*** ./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 of broadcast)---------------------------
TIP 9: In versions below 8.0, the planner will ignore your desire to
       choose an index scan if your joining column's datatypes do not
       match

Reply via email to