Following up a previous thought I had, yesterday I realised how to

return arays nicely without having to make the plperl programmer aware
of anything. The attached patch allows plperl to return an arrayref
where the function returns an array type. It silently calls a perl
function to stringify the array before passing it to the pg array
parser. Non-array returns are handled as before (i.e. passed through
this process) so it is backwards compatible. I will presently submit
regression tests and docs.

example:

andrew=# create or replace function blah() returns text[][] language
plperl as $$ return [['a"b','c,d'],['e\\f','g']]; $$;
CREATE FUNCTION
andrew=# select blah();
            blah
-----------------------------
 {{"a\"b","c,d"},{"e\\f",g}}

This would complete half of the TODO item:

  . Pass arrays natively instead of as text between plperl and postgres

(The other half is translating pg array arguments to perl arrays - that
will have to wait for 8.1).

Some of this patch is adapted from a previously submitted patch from
Sergej Sergeev. Both he and Abhijit Menon-Sen have looked it over
briefly and tentatively said it looks ok.

Andrew Dunstan

diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index 9fa71d94ccdeab4c93e483dc2e214d5c93d8f68d..836502b7e7664ae0eff86edf01ce0e5bfb75e708 100644 (file)
--- a/src/pl/plperl/plperl.c
+++ b/src/pl/plperl/plperl.c
@@ -33,7 +33,7 @@
  *       ENHANCEMENTS, OR MODIFICATIONS.
  *
  * IDENTIFICATION
- *       $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.82 2005/07/10 15:19:43 momjian Exp $
+ *       $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.83 2005/07/10 15:32:47 momjian Exp $
  *
  **********************************************************************/
 
@@ -81,6 +81,7 @@ typedef struct plperl_proc_desc
        bool            lanpltrusted;
        bool            fn_retistuple;  /* true, if function returns tuple */
        bool            fn_retisset;    /* true, if function returns set */
+       bool        fn_retisarray;  /* true if function returns array */
        Oid                     result_oid;             /* Oid of result type */
        FmgrInfo        result_in_func; /* I/O function and arg for result type */
        Oid                     result_typioparam;
@@ -194,8 +195,29 @@ plperl_init_interp(void)
                "sub ::plperl_warn { my $msg = shift; &elog(&NOTICE, $msg); } "
                "$SIG{__WARN__} = \\&::plperl_warn; "
                "sub ::mkunsafefunc {return eval(qq[ sub { $_[0] $_[1] } ]); }"
+               "sub ::_plperl_to_pg_array"
+               "{"
+               "  my $arg = shift; ref $arg eq 'ARRAY' || return $arg; "
+               "  my $res = ''; my $first = 1; "
+               "  foreach my $elem (@$arg) "
+               "  { "
+               "    $res .= ', ' unless $first; $first = undef; "
+               "    if (ref $elem) "
+               "    { "
+               "      $res .= _plperl_to_pg_array($elem); "
+               "    } "
+               "    else "
+               "    { "
+               "      my $str = qq($elem); "
+               "      $str =~ s/([\"\\\\])/\\\\$1/g; "
+               "      $res .= qq(\"$str\"); "
+               "    } "
+               "  } "
+               "  return qq({$res}); "
+               "} "
        };
 
+
        static char        *strict_embedding[3] = {
                "", "-e",
                /* all one string follows (no commas please) */
@@ -231,6 +253,7 @@ plperl_safe_init(void)
        "$PLContainer->permit(qw[:base_math !:base_io sort time]);"
        "$PLContainer->share(qw[&elog &spi_exec_query &return_next "
        "&spi_query &spi_fetchrow "
+       "&_plperl_to_pg_array "
        "&DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED ]);"
                           ;
 
@@ -331,6 +354,34 @@ plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
        return tup;
 }
 
+/*
+ * convert perl array to postgres string representation
+ */
+static SV*
+plperl_convert_to_pg_array(SV *src)
+{
+    SV* rv;
+       int count;
+       dSP ;
+
+       PUSHMARK(SP) ;
+       XPUSHs(src);
+       PUTBACK ;
+
+       count = call_pv("_plperl_to_pg_array", G_SCALAR);
+
+       SPAGAIN ;
+
+       if (count != 1)
+               croak("Big trouble\n") ;
+
+       rv = POPs;
+                          
+       PUTBACK ;
+
+    return rv;
+}
+
 
 /* Set up the arguments for a trigger call. */
 
@@ -869,7 +920,8 @@ plperl_func_handler(PG_FUNCTION_ARGS)
 
        rsi = (ReturnSetInfo *)fcinfo->resultinfo;
 
-       if (prodesc->fn_retisset) {
+       if (prodesc->fn_retisset) 
+       {
                if (!rsi || !IsA(rsi, ReturnSetInfo) ||
                        (rsi->allowedModes & SFRM_Materialize) == 0 ||
                        rsi->expectedDesc == NULL)
@@ -890,7 +942,8 @@ plperl_func_handler(PG_FUNCTION_ARGS)
                        int i = 0;
                        SV **svp = 0;
                        AV *rav = (AV *)SvRV(perlret);
-                       while ((svp = av_fetch(rav, i, FALSE)) != NULL) {
+                       while ((svp = av_fetch(rav, i, FALSE)) != NULL) 
+                       {
                                plperl_return_next(*svp);
                                i++;
                        }
@@ -904,7 +957,8 @@ plperl_func_handler(PG_FUNCTION_ARGS)
                }
 
                rsi->returnMode = SFRM_Materialize;
-               if (prodesc->tuple_store) {
+               if (prodesc->tuple_store) 
+               {
                        rsi->setResult = prodesc->tuple_store;
                        rsi->setDesc = prodesc->tuple_desc;
                }
@@ -949,8 +1003,20 @@ plperl_func_handler(PG_FUNCTION_ARGS)
        }
        else
        {
-               /* Return a perl string converted to a Datum */
-               char *val = SvPV(perlret, PL_na);
+        /* Return a perl string converted to a Datum */
+        char *val;
+        SV* array_ret;
+ 
+
+        if (prodesc->fn_retisarray && SvTYPE(SvRV(perlret)) == SVt_PVAV)
+        {
+            array_ret = plperl_convert_to_pg_array(perlret);
+            SvREFCNT_dec(perlret);
+            perlret = array_ret;
+        }
+
+               val = SvPV(perlret, PL_na);
+
                retval = FunctionCall3(&prodesc->result_in_func,
                                                           CStringGetDatum(val),
                                                           ObjectIdGetDatum(prodesc->result_typioparam),
@@ -1208,6 +1274,9 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
                        prodesc->fn_retistuple = (typeStruct->typtype == 'c' ||
                                                                          procStruct->prorettype == RECORDOID);
 
+                       prodesc->fn_retisarray = 
+                               (typeStruct->typlen == -1 && typeStruct->typelem) ;
+
                        perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
                        prodesc->result_typioparam = getTypeIOParam(typeTup);