arrays as input parameters in plperl
Hi,
I'd like to improve the way PL/Perl handles arrays as function input parameters. In PL/Perl arrays are passed as plain text strings, and getting a value of an array element requires additional perl code to parse that string. I'd like to make this easier by converting each postgresq array passed as an input parameter to the reference to the corresponding perl array. The patch in attachment illustrates this. it's limited to one-dimensional array output. The list of upcoming improvements is:
- convert n-dimensional array to the perl equivalent (a reference to a list of references)
- proper support for arrays of composite types
- compatibility with existing plperl functions by introducing a new custom variable, i.e. plperl.pass_array_refs that triggers the new behavior. I think it should be disabled by default.
- documentation and additional tests
The patch adds a new attribute to the plperl_proc_desc struct, that records whether Nth argument is an array. The function plperl_ref_from_pg_array does the actual job of converting array input parameter to the perl array reference. I considered writing a perl routine instead of a C function, although I though it would be less readable, more complex and slower due to double conversion of input. The disadvantage of a C function is a code duplication with array_out, on which my function is based, although it can be avoided by putting a relevant part of array_out into a separate function.
The patch is attached.
Anybody interested in this feature ? Ideas, improvements, suggestions ?
Regards,
--
Alexey Klyukin http://www.CommandPrompt.com/
The PostgreSQL Company - Command Prompt, Inc
Attachments:
plperl_array.diffapplication/octet-stream; name=plperl_array.diffDownload
diff --git a/src/pl/plperl/GNUmakefile b/src/pl/plperl/GNUmakefile
index a3c3495..5729459 100644
--- a/src/pl/plperl/GNUmakefile
+++ b/src/pl/plperl/GNUmakefile
@@ -39,7 +39,7 @@ OBJS = plperl.o spi_internal.o SPI.o
SHLIB_LINK = $(perl_embed_ldflags)
REGRESS_OPTS = --dbname=$(PL_TESTDB) --load-language=plperl
-REGRESS = plperl plperl_trigger plperl_shared plperl_elog
+REGRESS = plperl plperl_trigger plperl_shared plperl_elog plperl_array
# where to find psql for running the tests
PSQLDIR = $(bindir)
diff --git a/src/pl/plperl/expected/plperl_array.out b/src/pl/plperl/expected/plperl_array.out
new file mode 100644
index 0000000..ee37a5f
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_array.out
@@ -0,0 +1,54 @@
+CREATE OR REPLACE FUNCTION input_array(INTEGER[]) RETURNS INTEGER AS $$
+ my $arref = shift;
+ my $result = 0;
+
+ foreach (@$arref) {
+ $result += $_;
+ }
+ return $result;
+$$ LANGUAGE plperl;
+select input_array('{1,2,NULL}');
+ input_array
+-------------
+ 3
+(1 row)
+
+select input_array('{}');
+ input_array
+-------------
+ 0
+(1 row)
+
+select input_array('{{1,2,3}, {4,5,6}}');
+ input_array
+-------------
+ 21
+(1 row)
+
+CREATE OR REPLACE FUNCTION plperl_concat(TEXT[]) RETURNS TEXT AS $$
+ my $arref = shift;
+ my $result = "";
+
+ foreach (@$arref) {
+ $result .= $_;
+ }
+ return $result;
+$$ LANGUAGE plperl;
+select plperl_concat('{"hello"," ","world!"}');
+ plperl_concat
+---------------
+ hello world!
+(1 row)
+
+select plperl_concat('{"NULL","NULL","NULL''"}');
+ plperl_concat
+---------------
+ NULLNULLNULL'
+(1 row)
+
+select plperl_concat('{{NULL,NULL,NULL}}');
+ plperl_concat
+---------------
+
+(1 row)
+
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index 4ed4f59..832eb21 100644
--- a/src/pl/plperl/plperl.c
+++ b/src/pl/plperl/plperl.c
@@ -64,6 +64,7 @@ typedef struct plperl_proc_desc
int nargs;
FmgrInfo arg_out_func[FUNC_MAX_ARGS];
bool arg_is_rowtype[FUNC_MAX_ARGS];
+ bool arg_is_array[FUNC_MAX_ARGS];
SV *reference;
} plperl_proc_desc;
@@ -162,6 +163,7 @@ static SV **hv_store_string(HV *hv, const char *key, SV *val);
static SV **hv_fetch_string(HV *hv, const char *key);
static SV *plperl_create_sub(char *proname, char *s, bool trusted);
static SV *plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo);
+static SV *plperl_ref_from_pg_array(Datum arg);
static void plperl_compile_callback(void *arg);
static void plperl_exec_callback(void *arg);
@@ -575,6 +577,7 @@ plperl_safe_init(void)
desc.reference = func;
desc.nargs = 1;
desc.arg_is_rowtype[0] = false;
+ desc.arg_is_array[0] = false;
fmgr_info(F_TEXTOUT, &(desc.arg_out_func[0]));
fcinfo.arg[0] = CStringGetTextDatum("a");
@@ -1119,6 +1122,13 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
XPUSHs(sv_2mortal(hashref));
ReleaseTupleDesc(tupdesc);
}
+ else if (desc->arg_is_array[i])
+ {
+ SV *arrayref;
+ /* Get perl array reference from the postgresql array */
+ arrayref = plperl_ref_from_pg_array(fcinfo->arg[i]);
+ XPUSHs(sv_2mortal(arrayref));
+ }
else
{
char *tmp;
@@ -1709,6 +1719,12 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
perm_fmgr_info(typeStruct->typoutput,
&(prodesc->arg_out_func[i]));
}
+
+ /* Set flag for array attributes */
+ if (typeStruct->typlen == -1 && typeStruct->typelem)
+ prodesc->arg_is_array[i] = true;
+ else
+ prodesc->arg_is_array[i] = false;
ReleaseSysCache(typeTup);
}
@@ -2736,3 +2752,81 @@ plperl_compile_callback(void *arg)
if (procname)
errcontext("compilation of PL/Perl function \"%s\"", procname);
}
+
+/*
+ * Convert PostgreSQL array to a perl array reference.
+ * The code is heavily based on array_out.
+ */
+static SV *
+plperl_ref_from_pg_array(Datum arg)
+{
+ ArrayType *ar = DatumGetArrayTypeP(arg);
+ Oid elementtype = ARR_ELEMTYPE(ar);
+ AV *result;
+ int16 typlen;
+ bool typbyval;
+ char typalign,
+ typdelim;
+ Oid typioparam;
+ Oid typoutputfunc;
+ FmgrInfo proc;
+ int i,
+ nitems,
+ ndims,
+ *dims,
+ *lb;
+ bits8 *bitmap;
+ int bitmask;
+ char *data;
+
+
+ /* get element type information, including output coversion function */
+ get_type_io_data(elementtype, IOFunc_output,
+ &typlen, &typbyval, &typalign,
+ &typdelim, &typioparam, &typoutputfunc);
+
+ perm_fmgr_info(typoutputfunc, &proc);
+
+ ndims = ARR_NDIM(ar);
+ dims = ARR_DIMS(ar);
+ lb = ARR_LBOUND(ar);
+ nitems = ArrayGetNItems(ndims, dims);
+
+ bitmap = ARR_NULLBITMAP(ar);
+ bitmask = 1;
+ data = ARR_DATA_PTR(ar);
+
+ result = newAV();
+
+ for (i = 0; i < nitems; i++ )
+ {
+ /* write undef on NULL elements*/
+ if (bitmap && (*bitmap & bitmask) == 0)
+ av_push(result, newSV(0));
+ else
+ {
+ Datum itemvalue;
+ char *val;
+
+ itemvalue = fetch_att(data, typbyval, typlen);
+ val = OutputFunctionCall(&proc, itemvalue);
+ av_push(result, newSVstring(val));
+ /* get to the next array element */
+ data = att_addlength_pointer(data, typlen, data);
+ data = (char *) att_align_nominal(data, typalign);
+ }
+
+ /* advance bitmap pointer if any */
+ if (bitmap)
+ {
+ bitmask <<= 1;
+ if (bitmask == 0x100)
+ {
+ bitmap++;
+ bitmask = 1;
+ }
+ }
+
+ }
+ return newRV_noinc((SV *) result);
+}
diff --git a/src/pl/plperl/sql/plperl_array.sql b/src/pl/plperl/sql/plperl_array.sql
new file mode 100644
index 0000000..b84eed3
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_array.sql
@@ -0,0 +1,27 @@
+CREATE OR REPLACE FUNCTION input_array(INTEGER[]) RETURNS INTEGER AS $$
+ my $arref = shift;
+ my $result = 0;
+
+ foreach (@$arref) {
+ $result += $_;
+ }
+ return $result;
+$$ LANGUAGE plperl;
+
+select input_array('{1,2,NULL}');
+select input_array('{}');
+select input_array('{{1,2,3}, {4,5,6}}');
+
+CREATE OR REPLACE FUNCTION plperl_concat(TEXT[]) RETURNS TEXT AS $$
+ my $arref = shift;
+ my $result = "";
+
+ foreach (@$arref) {
+ $result .= $_;
+ }
+ return $result;
+$$ LANGUAGE plperl;
+
+select plperl_concat('{"hello"," ","world!"}');
+select plperl_concat('{"NULL","NULL","NULL''"}');
+select plperl_concat('{{NULL,NULL,NULL}}');