plperl_array.diff

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}}');