Convert Postgres arrays to Perl arrays on PL/perl input arguments

More generally, arrays are turned in Perl array references, and row and
composite types are turned into Perl hash references.  This is done
recursively, in a way that's natural to every Perl programmer.

To avoid a backwards compatibility hit, the string representation of
each structure is also available if the function requests it.

Authors: Alexey Klyukin and Alex Hunsaker.
Some code cleanups by me.

doc/src/sgml/plperl.sgml

@@ -198,6 +198,42 @@ select returns_array();
 </programlisting>
   </para>
 
+  <para>
+   Perl passes <productname>PostgreSQL</productname> arrays as a blessed
+   PostgreSQL::InServer::ARRAY object. This object may be treated as an array
+   reference or a string, allowing for backwards compatibility with Perl
+   code written for <productname>PostgreSQL</productname> versions below 9.1 to
+   run.  For example:
+
+<programlisting>
+CREATE OR REPLACE FUNCTION concat_array_elements(text[]) RETURNS TEXT AS $$
+    my $arg = shift;
+    my $result = "";
+    return undef if (!defined $arg);
+
+    # as an array reference
+    for (@$arg) {
+        $result .= $_;
+    }
+
+    # also works as a string
+    $result .= $arg;
+
+    return $result;
+$$ LANGUAGE plperl;
+
+SELECT concat_array_elements(ARRAY['PL','/','Perl']);
+</programlisting>
+
+  <note>
+   <para>
+    Multi-dimensional arrays are represented as references to
+    lower-dimensional arrays of references in a way common to every Perl
+    programmer.
+   </para>
+  </note>
+  </para>
+
   <para>
    Composite-type arguments are passed to the function as references
    to hashes.  The keys of the hash are the attribute names of the
@@ -740,6 +776,22 @@ SELECT release_hosts_query();
      </listitem>
     </varlistentry>
 
+    <varlistentry>
+     <indexterm>
+      <primary>encode_typed_literal</primary>
+      <secondary>in PL/Perl</secondary>
+     </indexterm>
+
+     <term><literal><function>encode_typed_literal(<replaceable>value</replaceable>, <replaceable>typename</replaceable>)</function></literal></term>
+      <listitem>
+       <para>
+         Converts a Perl variable to the value of the datatype passed as a
+         second argument and returns a string representation of this value.
+         Correctly handles nested arrays and values of composite types.
+       </para>
+      </listitem>
+    </varlistentry>
+
     <varlistentry>
      <indexterm>
       <primary>encode_array_constructor</primary>
@@ -775,6 +827,22 @@ SELECT release_hosts_query();
      </listitem>
     </varlistentry>
 
+    <varlistentry>
+     <indexterm>
+      <primary>is_array_ref</primary>
+      <secondary>in PL/Perl</secondary>
+     </indexterm>
+
+     <term><literal><function>is_array_ref(<replaceable>argument</replaceable>)</function></literal></term>
+     <listitem>
+      <para>
+        Returns a true value if the given argument may be treated as an
+        array reference, that is, if ref of the argument is <literal>ARRAY</> or
+        <literal>PostgreSQL::InServer::ARRAY</>.  Returns false otherwise.
+      </para>
+     </listitem>
+    </varlistentry>
+
    </variablelist>
   </sect2>
  </sect1>

src/pl/plperl/GNUmakefile

@@ -41,7 +41,7 @@ PERLCHUNKS = plc_perlboot.pl plc_trusted.pl
 SHLIB_LINK = $(perl_embed_ldflags)
 
 REGRESS_OPTS = --dbname=$(PL_TESTDB) --load-language=plperl  --load-language=plperlu
-REGRESS = plperl plperl_trigger plperl_shared plperl_elog plperl_util plperl_init plperlu
+REGRESS = plperl plperl_trigger plperl_shared plperl_elog plperl_util plperl_init plperlu plperl_array
 # if Perl can support two interpreters in one backend,
 # test plperl-and-plperlu cases
 ifneq ($(PERL),)

src/pl/plperl/Util.xs

@@ -198,6 +198,20 @@ looks_like_number(sv)
     OUTPUT:
     RETVAL
 
+SV *
+encode_typed_literal(sv, typname)
+	SV 	   *sv
+	char   *typname;
+	PREINIT:
+		char 	*outstr;
+	CODE:
+		outstr = plperl_sv_to_literal(sv, typname);
+		if (outstr == NULL)
+			RETVAL = &PL_sv_undef;
+		else
+			RETVAL = cstr2sv(outstr);
+	OUTPUT:
+	RETVAL
 
 BOOT:
     items = 0;  /* avoid 'unused variable' warning */

src/pl/plperl/expected/plperl.out

@@ -69,7 +69,8 @@ SELECT * FROM perl_set_int(5);
             5
 (6 rows)
 
-CREATE TYPE testrowperl AS (f1 integer, f2 text, f3 text);
+CREATE TYPE testnestperl AS (f5 integer[]);
+CREATE TYPE testrowperl AS (f1 integer, f2 text, f3 text, f4 testnestperl);
 CREATE OR REPLACE FUNCTION perl_row() RETURNS testrowperl AS $$
     return undef;
 $$ LANGUAGE plperl;
@@ -80,24 +81,24 @@ SELECT perl_row();
 (1 row)
 
 SELECT * FROM perl_row();
- f1 | f2 | f3 
-----+----+----
-    |    | 
+ f1 | f2 | f3 | f4 
+----+----+----+----
+    |    |    | 
 (1 row)
 
 CREATE OR REPLACE FUNCTION perl_row() RETURNS testrowperl AS $$
-    return {f2 => 'hello', f1 => 1, f3 => 'world'};
+    return {f2 => 'hello', f1 => 1, f3 => 'world', 'f4' => { 'f5' => [[1]] } };
 $$ LANGUAGE plperl;
 SELECT perl_row();
          perl_row          
------------------
- (1,hello,world)
+---------------------------
+ (1,hello,world,"({{1}})")
 (1 row)
 
 SELECT * FROM perl_row();
- f1 |  f2   |  f3   
-----+-------+-------
-  1 | hello | world
+ f1 |  f2   |  f3   |   f4    
+----+-------+-------+---------
+  1 | hello | world | ({{1}})
 (1 row)
 
 CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
@@ -109,15 +110,18 @@ SELECT perl_set();
 (0 rows)
 
 SELECT * FROM perl_set();
- f1 | f2 | f3 
-----+----+----
+ f1 | f2 | f3 | f4 
+----+----+----+----
 (0 rows)
 
 CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
     return [
         { f1 => 1, f2 => 'Hello', f3 =>  'World' },
         undef,
-        { f1 => 3, f2 => 'Hello', f3 =>  'PL/Perl' }
+        { f1 => 3, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => {} },
+        { f1 => 4, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => { 'f5' => undef }},
+        { f1 => 5, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => { 'f5' => '{1}' }},
+        { f1 => 6, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => { 'f5' => [1] }},
     ];
 $$  LANGUAGE plperl;
 SELECT perl_set();
@@ -129,25 +133,37 @@ CONTEXT:  PL/Perl function "perl_set"
 CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
     return [
         { f1 => 1, f2 => 'Hello', f3 =>  'World' },
-        { f1 => 2, f2 => 'Hello', f3 =>  'PostgreSQL' },
-        { f1 => 3, f2 => 'Hello', f3 =>  'PL/Perl' }
+        { f1 => 2, f2 => 'Hello', f3 =>  'PostgreSQL', 'f4' => undef },
+        { f1 => 3, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => {} },
+        { f1 => 4, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => { 'f5' => undef }},
+        { f1 => 5, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => { 'f5' => '{1}' }},
+        { f1 => 6, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => { 'f5' => [1] }},
+        { f1 => 7, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => '({1})' },
     ];
 $$  LANGUAGE plperl;
 SELECT perl_set();
          perl_set          
-----------------------
- (1,Hello,World)
- (2,Hello,PostgreSQL)
- (3,Hello,PL/Perl)
-(3 rows)
+---------------------------
+ (1,Hello,World,)
+ (2,Hello,PostgreSQL,)
+ (3,Hello,PL/Perl,"()")
+ (4,Hello,PL/Perl,"()")
+ (5,Hello,PL/Perl,"({1})")
+ (6,Hello,PL/Perl,"({1})")
+ (7,Hello,PL/Perl,"({1})")
+(7 rows)
 
 SELECT * FROM perl_set();
- f1 |  f2   |     f3     
-----+-------+------------
-  1 | Hello | World
-  2 | Hello | PostgreSQL
-  3 | Hello | PL/Perl
-(3 rows)
+ f1 |  f2   |     f3     |  f4   
+----+-------+------------+-------
+  1 | Hello | World      | 
+  2 | Hello | PostgreSQL | 
+  3 | Hello | PL/Perl    | ()
+  4 | Hello | PL/Perl    | ()
+  5 | Hello | PL/Perl    | ({1})
+  6 | Hello | PL/Perl    | ({1})
+  7 | Hello | PL/Perl    | ({1})
+(7 rows)
 
 CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$
     return undef;
@@ -162,14 +178,14 @@ SELECT * FROM perl_record();
 ERROR:  a column definition list is required for functions returning "record"
 LINE 1: SELECT * FROM perl_record();
                       ^
-SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text);
- f1 | f2 | f3 
-----+----+----
-    |    | 
+SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text, f4 testnestperl);
+ f1 | f2 | f3 | f4 
+----+----+----+----
+    |    |    | 
 (1 row)
 
 CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$
-    return {f2 => 'hello', f1 => 1, f3 => 'world'};
+    return {f2 => 'hello', f1 => 1, f3 => 'world', 'f4' => { 'f5' => [1] } };
 $$ LANGUAGE plperl;
 SELECT perl_record();
 ERROR:  function returning record called in context that cannot accept type record
@@ -178,10 +194,10 @@ SELECT * FROM perl_record();
 ERROR:  a column definition list is required for functions returning "record"
 LINE 1: SELECT * FROM perl_record();
                       ^
-SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text);
- f1 |  f2   |  f3   
-----+-------+-------
-  1 | hello | world
+SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text, f4 testnestperl);
+ f1 |  f2   |  f3   |  f4   
+----+-------+-------+-------
+  1 | hello | world | ({1})
 (1 row)
 
 CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
@@ -474,7 +490,7 @@ SELECT * FROM recurse(3);
 (5 rows)
 
 ---
---- Test arrary return
+--- Test array return
 ---
 CREATE OR REPLACE FUNCTION  array_of_text() RETURNS TEXT[][]
 LANGUAGE plperl as $$
@@ -555,6 +571,32 @@ $$ LANGUAGE plperl;
 SELECT perl_spi_prepared_bad(4.35) as "double precision";
 ERROR:  type "does_not_exist" does not exist at line 2.
 CONTEXT:  PL/Perl function "perl_spi_prepared_bad"
+-- Test with a row type
+CREATE OR REPLACE FUNCTION perl_spi_prepared() RETURNS INTEGER AS $$
+   my $x = spi_prepare('select $1::footype AS a', 'footype');
+   my $q = spi_exec_prepared( $x, '(1, 2)');
+   spi_freeplan($x);
+return $q->{rows}->[0]->{a}->{x};
+$$ LANGUAGE plperl;
+SELECT * from perl_spi_prepared();
+ perl_spi_prepared 
+-------------------
+                 1
+(1 row)
+
+CREATE OR REPLACE FUNCTION perl_spi_prepared_row(footype) RETURNS footype AS $$
+   my $footype = shift;
+   my $x = spi_prepare('select $1 AS a', 'footype');
+   my $q = spi_exec_prepared( $x, {}, $footype );
+   spi_freeplan($x);
+return $q->{rows}->[0]->{a};
+$$ LANGUAGE plperl;
+SELECT * from perl_spi_prepared_row('(1, 2)');
+ x | y 
+---+---
+ 1 | 2
+(1 row)
+
 -- simple test of a DO block
 DO $$
   $a = 'This is a test';

src/pl/plperl/expected/plperl_array.out

+CREATE OR REPLACE FUNCTION plperl_sum_array(INTEGER[]) RETURNS text AS $$
+	my $array_arg = shift;
+	my $result = 0;
+	my @arrays;
+
+	push @arrays, @$array_arg;
+
+	while (@arrays > 0) {
+		my $el = shift @arrays;
+		if (is_array_ref($el)) {
+			push @arrays, @$el;
+		} else {
+			$result += $el;
+		}
+	}
+	return $result.' '.$array_arg;
+$$ LANGUAGE plperl;
+select plperl_sum_array('{1,2,NULL}');
+ plperl_sum_array 
+------------------
+ 3 {1,2,NULL}
+(1 row)
+
+select plperl_sum_array('{}');
+ plperl_sum_array 
+------------------
+ 0 {}
+(1 row)
+
+select plperl_sum_array('{{1,2,3}, {4,5,6}}');
+   plperl_sum_array   
+----------------------
+ 21 {{1,2,3},{4,5,6}}
+(1 row)
+
+select plperl_sum_array('{{{1,2,3}, {4,5,6}}, {{7,8,9}, {10,11,12}}}');
+              plperl_sum_array               
+---------------------------------------------
+ 78 {{{1,2,3},{4,5,6}},{{7,8,9},{10,11,12}}}
+(1 row)
+
+-- check whether we can handle arrays of maximum dimension (6)
+select plperl_sum_array(ARRAY[[[[[[1,2],[3,4]],[[5,6],[7,8]]],[[[9,10],[11,12]],
+[[13,14],[15,16]]]],
+[[[[17,18],[19,20]],[[21,22],[23,24]]],[[[25,26],[27,28]],[[29,30],[31,32]]]]],
+[[[[[1,2],[3,4]],[[5,6],[7,8]]],[[[9,10],[11,12]],[[13,14],[15,16]]]],
+[[[[17,18],[19,20]],[[21,22],[23,24]]],[[[25,26],[27,28]],[[29,30],[31,32]]]]]]);
+                                                                                                                                                 plperl_sum_array                                                                                                                                                 
+------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
+ 1056 {{{{{{1,2},{3,4}},{{5,6},{7,8}}},{{{9,10},{11,12}},{{13,14},{15,16}}}},{{{{17,18},{19,20}},{{21,22},{23,24}}},{{{25,26},{27,28}},{{29,30},{31,32}}}}},{{{{{1,2},{3,4}},{{5,6},{7,8}}},{{{9,10},{11,12}},{{13,14},{15,16}}}},{{{{17,18},{19,20}},{{21,22},{23,24}}},{{{25,26},{27,28}},{{29,30},{31,32}}}}}}
+(1 row)
+
+-- what would we do with the arrays exceeding maximum dimension (7)
+select plperl_sum_array('{{{{{{{1,2},{3,4}},{{5,6},{7,8}}},{{{9,10},{11,12}},
+{{13,14},{15,16}}}},
+{{{{17,18},{19,20}},{{21,22},{23,24}}},{{{25,26},{27,28}},{{29,30},{31,32}}}}},
+{{{{{1,2},{3,4}},{{5,6},{7,8}}},{{{9,10},{11,12}},{{13,14},{15,16}}}},
+{{{{17,18},{19,20}},{{21,22},{23,24}}},{{{25,26},{27,28}},{{29,30},{31,32}}}}}},
+{{{{{{1,2},{3,4}},{{5,6},{7,8}}},{{{9,10},{11,12}},{{13,14},{15,16}}}},
+{{{{17,18},{19,20}},{{21,22},{23,24}}},{{{25,26},{27,28}},{{29,30},{31,32}}}}},
+{{{{{1,2},{3,4}},{{5,6},{7,8}}},{{{9,10},{11,12}},{{13,14},{15,16}}}},
+{{{{17,18},{19,20}},{{21,22},{23,24}}},{{{25,26},{27,28}},{{29,30},{31,32}}}}}}}'
+);
+ERROR:  number of array dimensions (7) exceeds the maximum allowed (6)
+LINE 1: select plperl_sum_array('{{{{{{{1,2},{3,4}},{{5,6},{7,8}}},{...
+                                ^
+select plperl_sum_array('{{{1,2,3}, {4,5,6,7}}, {{7,8,9}, {10, 11, 12}}}');
+ERROR:  multidimensional arrays must have array expressions with matching dimensions
+LINE 1: select plperl_sum_array('{{{1,2,3}, {4,5,6,7}}, {{7,8,9}, {1...
+                                ^
+CREATE OR REPLACE FUNCTION plperl_concat(TEXT[]) RETURNS TEXT AS $$
+	my $array_arg = shift;
+	my $result = "";
+	my @arrays;
+	
+	push @arrays, @$array_arg;
+	while (@arrays > 0) {
+		my $el = shift @arrays;
+		if (is_array_ref($el)) {
+			push @arrays, @$el;
+		} else {
+			$result .= $el;
+		}
+	}
+	return $result.' '.$array_arg;
+$$ LANGUAGE plperl;
+select plperl_concat('{"NULL","NULL","NULL''"}');
+            plperl_concat            
+-------------------------------------
+ NULLNULLNULL' {"NULL","NULL",NULL'}
+(1 row)
+
+select plperl_concat('{{NULL,NULL,NULL}}');
+    plperl_concat    
+---------------------
+  {{NULL,NULL,NULL}}
+(1 row)
+
+select plperl_concat('{"hello"," ","world!"}');
+          plperl_concat          
+---------------------------------
+ hello world! {hello," ",world!}
+(1 row)
+
+-- array of rows --
+CREATE TYPE foo AS (bar INTEGER, baz TEXT);
+CREATE OR REPLACE FUNCTION plperl_array_of_rows(foo[]) RETURNS TEXT AS $$
+	my $array_arg = shift;
+	my $result = "";
+	
+	for my $row_ref (@$array_arg) {
+		die "not a hash reference" unless (ref $row_ref eq "HASH");
+			$result .= $row_ref->{bar}." items of ".$row_ref->{baz}.";";
+	}
+	return $result .' '. $array_arg;
+$$ LANGUAGE plperl;
+select plperl_array_of_rows(ARRAY[ ROW(2, 'coffee'), ROW(0, 'sugar')]::foo[]);
+                      plperl_array_of_rows                      
+----------------------------------------------------------------
+ 2 items of coffee;0 items of sugar; {"(2,coffee)","(0,sugar)"}
+(1 row)
+
+-- composite type containing arrays
+CREATE TYPE rowfoo AS (bar INTEGER, baz INTEGER[]);
+CREATE OR REPLACE FUNCTION plperl_sum_row_elements(rowfoo) RETURNS TEXT AS $$
+	my $row_ref = shift;
+	my $result;
+	
+	if (ref $row_ref ne 'HASH') {
+		$result = 0;
+	}
+	else {
+		$result = $row_ref->{bar};
+		die "not an array reference".ref ($row_ref->{baz}) 
+		unless (is_array_ref($row_ref->{baz}));
+		# process a single-dimensional array
+		foreach my $elem (@{$row_ref->{baz}}) {
+			$result += $elem unless ref $elem;
+		}
+	}
+	return $result;
+$$ LANGUAGE plperl;
+select plperl_sum_row_elements(ROW(1, ARRAY[2,3,4,5,6,7,8,9,10])::rowfoo);
+ plperl_sum_row_elements 
+-------------------------
+ 55
+(1 row)
+
+-- composite type containing array of another composite type, which, in order,
+-- contains an array of integers.
+CREATE TYPE rowbar AS (foo rowfoo[]);
+CREATE OR REPLACE FUNCTION plperl_sum_array_of_rows(rowbar) RETURNS TEXT AS $$
+	my $rowfoo_ref = shift;
+	my $result = 0;
+	
+	if (ref $rowfoo_ref eq 'HASH') {
+		my $row_array_ref = $rowfoo_ref->{foo};
+		if (is_array_ref($row_array_ref)) {
+			foreach my $row_ref (@{$row_array_ref}) {
+				if (ref $row_ref eq 'HASH') {
+					$result += $row_ref->{bar};
+					die "not an array reference".ref ($row_ref->{baz}) 
+					unless (is_array_ref($row_ref->{baz}));
+					foreach my $elem (@{$row_ref->{baz}}) {
+						$result += $elem unless ref $elem;
+					}
+				}
+				else {
+					die "element baz is not a reference to a rowfoo";
+				}
+			}
+		} else {
+			die "not a reference to an array of rowfoo elements"
+		}
+	} else {
+		die "not a reference to type rowbar";
+	}
+	return $result;
+$$ LANGUAGE plperl;
+select plperl_sum_array_of_rows(ROW(ARRAY[ROW(1, ARRAY[2,3,4,5,6,7,8,9,10])::rowfoo, 
+ROW(11, ARRAY[12,13,14,15,16,17,18,19,20])::rowfoo])::rowbar);
+ plperl_sum_array_of_rows 
+--------------------------
+ 210
+(1 row)
+
+-- check arrays as out parameters
+CREATE OR REPLACE FUNCTION plperl_arrays_out(OUT INTEGER[]) AS $$
+	return [[1,2,3],[4,5,6]];
+$$ LANGUAGE plperl;
+select plperl_arrays_out();
+ plperl_arrays_out 
+-------------------
+ {{1,2,3},{4,5,6}}
+(1 row)
+
+-- check that we can return the array we passed in
+CREATE OR REPLACE FUNCTION plperl_arrays_inout(INTEGER[]) returns INTEGER[] AS $$
+	return shift;
+$$ LANGUAGE plperl;
+select plperl_arrays_inout('{{1}, {2}, {3}}');
+ plperl_arrays_inout 
+---------------------
+ {{1},{2},{3}}
+(1 row)
+
+-- make sure setof works
+create or replace function perl_setof_array(integer[]) returns setof integer[] language plperl as $$
+	my $arr = shift;
+	for my $r (@$arr) {
+		return_next $r;
+	}
+	return undef;
+$$;
+select perl_setof_array('{{1}, {2}, {3}}');
+ perl_setof_array 
+------------------
+ {1}
+ {2}
+ {3}
+(3 rows)
+

src/pl/plperl/expected/plperl_trigger.out

 -- test plperl triggers
+CREATE TYPE rowcomp as (i int);
+CREATE TYPE rowcompnest as (rfoo rowcomp);
 CREATE TABLE trigger_test (
         i int,
-        v varchar
+        v varchar,
+		foo rowcompnest
 );
 CREATE OR REPLACE FUNCTION trigger_data() RETURNS trigger LANGUAGE plperl AS $$
 
   # make sure keys are sorted for consistent results - perl no longer
   # hashes in  repeatable fashion across runs
 
-  foreach my $key (sort keys %$_TD)
-  {
-
-    my $val = $_TD->{$key};
+  sub str {
+	  my $val = shift;
 
-	# relid is variable, so we can not use it repeatably
-	$val = "bogus:12345" if $key eq 'relid';
-
-	if (! defined $val)
-	{
-	  elog(NOTICE, "\$_TD->\{$key\} = NULL");
-	}
-	elsif (not ref $val)
+	  if (!defined $val)
 	  {
-	  elog(NOTICE, "\$_TD->\{$key\} = '$val'");
+		  return 'NULL';
 	  }
 	  elsif (ref $val eq 'HASH')
 	  {
-	  my $str = "";
+		my $str = '';
 		foreach my $rowkey (sort keys %$val)
 		{
 		  $str .= ", " if $str;
-	    my $rowval = $val->{$rowkey};
-	    $str .= "'$rowkey' => '$rowval'";
+		  my $rowval = str($val->{$rowkey});
+		  $str .= "'$rowkey' => $rowval";
 		}
-	  elog(NOTICE, "\$_TD->\{$key\} = \{$str\}");
+		return '{'. $str .'}';
 	  }
 	  elsif (ref $val eq 'ARRAY')
 	  {
-	  my $str = "";
-	  foreach my $argval (@$val)
+		  my $str = '';
+		  for my $argval (@$val)
 		  {
 			  $str .= ", " if $str;
-	    $str .= "'$argval'";
+			  $str .= str($argval);
+		  }
+		  return '['. $str .']';
+	  }
+	  else
+	  {
+		  return "'$val'";
 	  }
-	  elog(NOTICE, "\$_TD->\{$key\} = \[$str\]");
   }
+
+  foreach my $key (sort keys %$_TD)
+  {
+
+    my $val = $_TD->{$key};
+
+	# relid is variable, so we can not use it repeatably
+	$val = "bogus:12345" if $key eq 'relid';
+
+	elog(NOTICE, "\$_TD->\{$key\} = ". str($val));
   }
   return undef; # allow statement to proceed;
 $$;
 CREATE TRIGGER show_trigger_data_trig
 BEFORE INSERT OR UPDATE OR DELETE ON trigger_test
 FOR EACH ROW EXECUTE PROCEDURE trigger_data(23,'skidoo');
-insert into trigger_test values(1,'insert');
+insert into trigger_test values(1,'insert', '("(1)")');
 NOTICE:  $_TD->{argc} = '2'
 CONTEXT:  PL/Perl function "trigger_data"
 NOTICE:  $_TD->{args} = ['23', 'skidoo']
@@ -62,7 +71,7 @@ NOTICE:  $_TD->{level} = 'ROW'
 CONTEXT:  PL/Perl function "trigger_data"
 NOTICE:  $_TD->{name} = 'show_trigger_data_trig'
 CONTEXT:  PL/Perl function "trigger_data"
-NOTICE:  $_TD->{new} = {'i' => '1', 'v' => 'insert'}
+NOTICE:  $_TD->{new} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'insert'}
 CONTEXT:  PL/Perl function "trigger_data"
 NOTICE:  $_TD->{relid} = 'bogus:12345'
 CONTEXT:  PL/Perl function "trigger_data"
@@ -85,9 +94,9 @@ NOTICE:  $_TD->{level} = 'ROW'
 CONTEXT:  PL/Perl function "trigger_data"
 NOTICE:  $_TD->{name} = 'show_trigger_data_trig'
 CONTEXT:  PL/Perl function "trigger_data"
-NOTICE:  $_TD->{new} = {'i' => '1', 'v' => 'update'}
+NOTICE:  $_TD->{new} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'update'}
 CONTEXT:  PL/Perl function "trigger_data"
-NOTICE:  $_TD->{old} = {'i' => '1', 'v' => 'insert'}
+NOTICE:  $_TD->{old} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'insert'}
 CONTEXT:  PL/Perl function "trigger_data"
 NOTICE:  $_TD->{relid} = 'bogus:12345'
 CONTEXT:  PL/Perl function "trigger_data"
@@ -110,7 +119,7 @@ NOTICE:  $_TD->{level} = 'ROW'
 CONTEXT:  PL/Perl function "trigger_data"
 NOTICE:  $_TD->{name} = 'show_trigger_data_trig'
 CONTEXT:  PL/Perl function "trigger_data"
-NOTICE:  $_TD->{old} = {'i' => '1', 'v' => 'update'}
+NOTICE:  $_TD->{old} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'update'}
 CONTEXT:  PL/Perl function "trigger_data"
 NOTICE:  $_TD->{relid} = 'bogus:12345'
 CONTEXT:  PL/Perl function "trigger_data"
@@ -123,12 +132,12 @@ CONTEXT:  PL/Perl function "trigger_data"
 NOTICE:  $_TD->{when} = 'BEFORE'
 CONTEXT:  PL/Perl function "trigger_data"
 DROP TRIGGER show_trigger_data_trig on trigger_test;
-insert into trigger_test values(1,'insert');
+insert into trigger_test values(1,'insert', '("(1)")');
 CREATE VIEW trigger_test_view AS SELECT * FROM trigger_test;
 CREATE TRIGGER show_trigger_data_trig
 INSTEAD OF INSERT OR UPDATE OR DELETE ON trigger_test_view
 FOR EACH ROW EXECUTE PROCEDURE trigger_data(24,'skidoo view');
-insert into trigger_test_view values(2,'insert');
+insert into trigger_test_view values(2,'insert', '("(2)")');
 NOTICE:  $_TD->{argc} = '2'
 CONTEXT:  PL/Perl function "trigger_data"
 NOTICE:  $_TD->{args} = ['24', 'skidoo view']
@@ -139,7 +148,7 @@ NOTICE:  $_TD->{level} = 'ROW'
 CONTEXT:  PL/Perl function "trigger_data"
 NOTICE:  $_TD->{name} = 'show_trigger_data_trig'
 CONTEXT:  PL/Perl function "trigger_data"
-NOTICE:  $_TD->{new} = {'i' => '2', 'v' => 'insert'}
+NOTICE:  $_TD->{new} = {'foo' => {'rfoo' => {'i' => '2'}}, 'i' => '2', 'v' => 'insert'}
 CONTEXT:  PL/Perl function "trigger_data"
 NOTICE:  $_TD->{relid} = 'bogus:12345'
 CONTEXT:  PL/Perl function "trigger_data"
@@ -151,7 +160,7 @@ NOTICE:  $_TD->{table_schema} = 'public'
 CONTEXT:  PL/Perl function "trigger_data"
 NOTICE:  $_TD->{when} = 'INSTEAD OF'
 CONTEXT:  PL/Perl function "trigger_data"
-update trigger_test_view set v = 'update' where i = 1;
+update trigger_test_view set v = 'update', foo = '("(3)")' where i = 1;
 NOTICE:  $_TD->{argc} = '2'
 CONTEXT:  PL/Perl function "trigger_data"
 NOTICE:  $_TD->{args} = ['24', 'skidoo view']
@@ -162,9 +171,9 @@ NOTICE:  $_TD->{level} = 'ROW'
 CONTEXT:  PL/Perl function "trigger_data"
 NOTICE:  $_TD->{name} = 'show_trigger_data_trig'
 CONTEXT:  PL/Perl function "trigger_data"
-NOTICE:  $_TD->{new} = {'i' => '1', 'v' => 'update'}
+NOTICE:  $_TD->{new} = {'foo' => {'rfoo' => {'i' => '3'}}, 'i' => '1', 'v' => 'update'}
 CONTEXT:  PL/Perl function "trigger_data"
-NOTICE:  $_TD->{old} = {'i' => '1', 'v' => 'insert'}
+NOTICE:  $_TD->{old} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'insert'}
 CONTEXT:  PL/Perl function "trigger_data"
 NOTICE:  $_TD->{relid} = 'bogus:12345'
 CONTEXT:  PL/Perl function "trigger_data"
@@ -187,7 +196,7 @@ NOTICE:  $_TD->{level} = 'ROW'
 CONTEXT:  PL/Perl function "trigger_data"
 NOTICE:  $_TD->{name} = 'show_trigger_data_trig'
 CONTEXT:  PL/Perl function "trigger_data"
-NOTICE:  $_TD->{old} = {'i' => '1', 'v' => 'insert'}
+NOTICE:  $_TD->{old} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'insert'}
 CONTEXT:  PL/Perl function "trigger_data"
 NOTICE:  $_TD->{relid} = 'bogus:12345'
 CONTEXT:  PL/Perl function "trigger_data"
@@ -211,6 +220,7 @@ CREATE OR REPLACE FUNCTION valid_id() RETURNS trigger AS $$
     elsif ($_TD->{new}{v} ne "immortal")
     {
         $_TD->{new}{v} .= "(modified by trigger)";
+		$_TD->{new}{foo}{rfoo}{i}++;
         return "MODIFY"; # Modify tuple and proceed INSERT/UPDATE command
     }
     else
@@ -220,29 +230,29 @@ CREATE OR REPLACE FUNCTION valid_id() RETURNS trigger AS $$
 $$ LANGUAGE plperl;
 CREATE TRIGGER "test_valid_id_trig" BEFORE INSERT OR UPDATE ON trigger_test
 FOR EACH ROW EXECUTE PROCEDURE "valid_id"();
-INSERT INTO trigger_test (i, v) VALUES (1,'first line');
-INSERT INTO trigger_test (i, v) VALUES (2,'second line');
-INSERT INTO trigger_test (i, v) VALUES (3,'third line');
-INSERT INTO trigger_test (i, v) VALUES (4,'immortal');
+INSERT INTO trigger_test (i, v, foo) VALUES (1,'first line', '("(1)")');
+INSERT INTO trigger_test (i, v, foo) VALUES (2,'second line', '("(2)")');
+INSERT INTO trigger_test (i, v, foo) VALUES (3,'third line', '("(3)")');
+INSERT INTO trigger_test (i, v, foo) VALUES (4,'immortal', '("(4)")');
 INSERT INTO trigger_test (i, v) VALUES (101,'bad id');
 SELECT * FROM trigger_test;
- i |                v                 
----+----------------------------------
- 1 | first line(modified by trigger)
- 2 | second line(modified by trigger)
- 3 | third line(modified by trigger)
- 4 | immortal
+ i |                v                 |   foo   
+---+----------------------------------+---------
+ 1 | first line(modified by trigger)  | ("(2)")
+ 2 | second line(modified by trigger) | ("(3)")
+ 3 | third line(modified by trigger)  | ("(4)")
+ 4 | immortal                         | ("(4)")
 (4 rows)
 
 UPDATE trigger_test SET i = 5 where i=3;
 UPDATE trigger_test SET i = 100 where i=1;
 SELECT * FROM trigger_test;
- i |                          v                           
----+------------------------------------------------------
- 1 | first line(modified by trigger)
- 2 | second line(modified by trigger)
- 4 | immortal
- 5 | third line(modified by trigger)(modified by trigger)
+ i |                          v                           |   foo   
+---+------------------------------------------------------+---------
+ 1 | first line(modified by trigger)                      | ("(2)")
+ 2 | second line(modified by trigger)                     | ("(3)")
+ 4 | immortal                                             | ("(4)")
+ 5 | third line(modified by trigger)(modified by trigger) | ("(5)")
 (4 rows)
 
 CREATE OR REPLACE FUNCTION immortal() RETURNS trigger AS $$
@@ -259,9 +269,9 @@ CREATE TRIGGER "immortal_trig" BEFORE DELETE ON trigger_test
 FOR EACH ROW EXECUTE PROCEDURE immortal('immortal');
 DELETE FROM trigger_test;
 SELECT * FROM trigger_test;
- i |    v     
----+----------
- 4 | immortal
+ i |    v     |   foo   
+---+----------+---------
+ 4 | immortal | ("(4)")
 (1 row)
 
 CREATE FUNCTION direct_trigger() RETURNS trigger AS $$

src/pl/plperl/expected/plperl_util.out

@@ -169,3 +169,21 @@ select perl_looks_like_number();
  '': not number
 (11 rows)
 
+-- test encode_typed_literal
+create type perl_foo as (a integer, b text[]);
+create type perl_bar as (c perl_foo[]);
+create or replace function perl_encode_typed_literal() returns setof text language plperl as $$
+	return_next encode_typed_literal(undef, 'text');
+	return_next encode_typed_literal([[1,2,3],[3,2,1],[1,3,2]], 'integer[]');
+	return_next encode_typed_literal({a => 1, b => ['PL','/','Perl']}, 'perl_foo');
+	return_next encode_typed_literal({c => [{a => 9, b => ['PostgreSQL']}, {b => ['Postgres'], a => 1}]}, 'perl_bar');
+$$;
+select perl_encode_typed_literal();
+           perl_encode_typed_literal           
+-----------------------------------------------
+ 
+ {{1,2,3},{3,2,1},{1,3,2}}
+ (1,"{PL,/,Perl}")
+ ("{""(9,{PostgreSQL})"",""(1,{Postgres})""}")
+(4 rows)
+

src/pl/plperl/plc_perlboot.pl

@@ -5,8 +5,45 @@ use vars qw(%_SHARED);
 
 PostgreSQL::InServer::Util::bootstrap();
 
-package PostgreSQL::InServer;
+# globals
+
+sub ::is_array_ref {
+	return ref($_[0]) =~ m/^(?:PostgreSQL::InServer::)?ARRAY$/;
+}
 
+sub ::encode_array_literal {
+	my ($arg, $delim) = @_;
+	return $arg unless(::is_array_ref($arg));
+	$delim = ', ' unless defined $delim;
+	my $res = '';
+	foreach my $elem (@$arg) {
+		$res .= $delim if length $res;
+		if (ref $elem) {
+			$res .= ::encode_array_literal($elem, $delim);
+		}
+		elsif (defined $elem) {
+			(my $str = $elem) =~ s/(["\\])/\\$1/g;
+			$res .= qq("$str");
+		}
+		else {
+			$res .= 'NULL';
+		}
+	}
+	return qq({$res});
+}
+
+sub ::encode_array_constructor {
+	my $arg = shift;
+	return ::quote_nullable($arg) unless ::is_array_ref($arg);
+	my $res = join ", ", map {
+		(ref $_) ? ::encode_array_constructor($_)
+		         : ::quote_nullable($_)
+	} @$arg;
+	return "ARRAY[$res]";
+}
+
+{
+package PostgreSQL::InServer;
 use strict;
 use warnings;
 
@@ -43,35 +80,26 @@ sub mkfunc {
 	return $ret;
 }
 
-sub ::encode_array_literal {
-	my ($arg, $delim) = @_;
-	return $arg
-		if ref $arg ne 'ARRAY';
-	$delim = ', ' unless defined $delim;
-	my $res = '';
-	foreach my $elem (@$arg) {
-		$res .= $delim if length $res;
-		if (ref $elem) {
-			$res .= ::encode_array_literal($elem, $delim);
-		}
-		elsif (defined $elem) {
-			(my $str = $elem) =~ s/(["\\])/\\$1/g;
-			$res .= qq("$str");
-		}
-		else {
-			$res .= 'NULL';
-		}
-	}
-	return qq({$res});
+1;
 }
 
-sub ::encode_array_constructor {
-	my $arg = shift;
-	return ::quote_nullable($arg)
-		if ref $arg ne 'ARRAY';
-	my $res = join ", ", map {
-		(ref $_) ? ::encode_array_constructor($_)
-		         : ::quote_nullable($_)
-	} @$arg;
-	return "ARRAY[$res]";
+{
+package PostgreSQL::InServer::ARRAY;
+use strict;
+use warnings;
+
+use overload
+	'""'=>\&to_str,
+	'@{}'=>\&to_arr;
+
+sub to_str {
+	my $self = shift;
+	return ::encode_typed_literal($self->{'array'}, $self->{'typeoid'});
+}
+
+sub to_arr {
+	return shift->{'array'};
+}
+
+1;
 }

src/pl/plperl/plperl.h

@@ -59,6 +59,7 @@ HV		   *plperl_spi_exec_prepared(char *, HV *, int, SV **);
 SV		   *plperl_spi_query_prepared(char *, int, SV **);
 void		plperl_spi_freeplan(char *);
 void		plperl_spi_cursor_close(char *);
+char 	   *plperl_sv_to_literal(SV *, char *);
 
 
 

src/pl/plperl/sql/plperl.sql

@@ -32,7 +32,8 @@ SELECT perl_set_int(5);
 SELECT * FROM perl_set_int(5);
 
 
-CREATE TYPE testrowperl AS (f1 integer, f2 text, f3 text);
+CREATE TYPE testnestperl AS (f5 integer[]);
+CREATE TYPE testrowperl AS (f1 integer, f2 text, f3 text, f4 testnestperl);
 
 CREATE OR REPLACE FUNCTION perl_row() RETURNS testrowperl AS $$
     return undef;
@@ -41,8 +42,9 @@ $$ LANGUAGE plperl;
 SELECT perl_row();
 SELECT * FROM perl_row();
 
+
 CREATE OR REPLACE FUNCTION perl_row() RETURNS testrowperl AS $$
-    return {f2 => 'hello', f1 => 1, f3 => 'world'};
+    return {f2 => 'hello', f1 => 1, f3 => 'world', 'f4' => { 'f5' => [[1]] } };
 $$ LANGUAGE plperl;
 
 SELECT perl_row();
@@ -60,7 +62,10 @@ CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
     return [
         { f1 => 1, f2 => 'Hello', f3 =>  'World' },
         undef,
-        { f1 => 3, f2 => 'Hello', f3 =>  'PL/Perl' }
+        { f1 => 3, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => {} },
+        { f1 => 4, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => { 'f5' => undef }},
+        { f1 => 5, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => { 'f5' => '{1}' }},
+        { f1 => 6, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => { 'f5' => [1] }},
     ];
 $$  LANGUAGE plperl;
 
@@ -70,31 +75,33 @@ SELECT * FROM perl_set();
 CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
     return [
         { f1 => 1, f2 => 'Hello', f3 =>  'World' },
-        { f1 => 2, f2 => 'Hello', f3 =>  'PostgreSQL' },
-        { f1 => 3, f2 => 'Hello', f3 =>  'PL/Perl' }
+        { f1 => 2, f2 => 'Hello', f3 =>  'PostgreSQL', 'f4' => undef },
+        { f1 => 3, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => {} },
+        { f1 => 4, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => { 'f5' => undef }},
+        { f1 => 5, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => { 'f5' => '{1}' }},
+        { f1 => 6, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => { 'f5' => [1] }},
+        { f1 => 7, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => '({1})' },
     ];
 $$  LANGUAGE plperl;
 
 SELECT perl_set();
 SELECT * FROM perl_set();
 
-
-
 CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$
     return undef;
 $$ LANGUAGE plperl;
 
 SELECT perl_record();
 SELECT * FROM perl_record();
-SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text);
+SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text, f4 testnestperl);
 
 CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$
-    return {f2 => 'hello', f1 => 1, f3 => 'world'};
+    return {f2 => 'hello', f1 => 1, f3 => 'world', 'f4' => { 'f5' => [1] } };
 $$ LANGUAGE plperl;
 
 SELECT perl_record();
 SELECT * FROM perl_record();
-SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text);
+SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text, f4 testnestperl);
 
 
 CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
@@ -297,7 +304,7 @@ SELECT * FROM recurse(3);
 
 
 ---
---- Test arrary return
+--- Test array return
 ---
 CREATE OR REPLACE FUNCTION  array_of_text() RETURNS TEXT[][]
 LANGUAGE plperl as $$
@@ -361,6 +368,24 @@ CREATE OR REPLACE FUNCTION perl_spi_prepared_bad(double precision) RETURNS doubl
 $$ LANGUAGE plperl;
 SELECT perl_spi_prepared_bad(4.35) as "double precision";
 
+-- Test with a row type
+CREATE OR REPLACE FUNCTION perl_spi_prepared() RETURNS INTEGER AS $$
+   my $x = spi_prepare('select $1::footype AS a', 'footype');
+   my $q = spi_exec_prepared( $x, '(1, 2)');
+   spi_freeplan($x);
+return $q->{rows}->[0]->{a}->{x};
+$$ LANGUAGE plperl;
+SELECT * from perl_spi_prepared();
+
+CREATE OR REPLACE FUNCTION perl_spi_prepared_row(footype) RETURNS footype AS $$
+   my $footype = shift;
+   my $x = spi_prepare('select $1 AS a', 'footype');
+   my $q = spi_exec_prepared( $x, {}, $footype );
+   spi_freeplan($x);
+return $q->{rows}->[0]->{a};
+$$ LANGUAGE plperl;
+SELECT * from perl_spi_prepared_row('(1, 2)');
+
 -- simple test of a DO block
 DO $$
   $a = 'This is a test';

src/pl/plperl/sql/plperl_array.sql

+CREATE OR REPLACE FUNCTION plperl_sum_array(INTEGER[]) RETURNS text AS $$
+	my $array_arg = shift;
+	my $result = 0;
+	my @arrays;
+
+	push @arrays, @$array_arg;
+
+	while (@arrays > 0) {
+		my $el = shift @arrays;
+		if (is_array_ref($el)) {
+			push @arrays, @$el;
+		} else {
+			$result += $el;
+		}
+	}
+	return $result.' '.$array_arg;
+$$ LANGUAGE plperl;
+
+select plperl_sum_array('{1,2,NULL}');
+select plperl_sum_array('{}');
+select plperl_sum_array('{{1,2,3}, {4,5,6}}');
+select plperl_sum_array('{{{1,2,3}, {4,5,6}}, {{7,8,9}, {10,11,12}}}');
+
+-- check whether we can handle arrays of maximum dimension (6)
+select plperl_sum_array(ARRAY[[[[[[1,2],[3,4]],[[5,6],[7,8]]],[[[9,10],[11,12]],
+[[13,14],[15,16]]]],
+[[[[17,18],[19,20]],[[21,22],[23,24]]],[[[25,26],[27,28]],[[29,30],[31,32]]]]],
+[[[[[1,2],[3,4]],[[5,6],[7,8]]],[[[9,10],[11,12]],[[13,14],[15,16]]]],
+[[[[17,18],[19,20]],[[21,22],[23,24]]],[[[25,26],[27,28]],[[29,30],[31,32]]]]]]);
+
+-- what would we do with the arrays exceeding maximum dimension (7)
+select plperl_sum_array('{{{{{{{1,2},{3,4}},{{5,6},{7,8}}},{{{9,10},{11,12}},
+{{13,14},{15,16}}}},
+{{{{17,18},{19,20}},{{21,22},{23,24}}},{{{25,26},{27,28}},{{29,30},{31,32}}}}},
+{{{{{1,2},{3,4}},{{5,6},{7,8}}},{{{9,10},{11,12}},{{13,14},{15,16}}}},
+{{{{17,18},{19,20}},{{21,22},{23,24}}},{{{25,26},{27,28}},{{29,30},{31,32}}}}}},
+{{{{{{1,2},{3,4}},{{5,6},{7,8}}},{{{9,10},{11,12}},{{13,14},{15,16}}}},
+{{{{17,18},{19,20}},{{21,22},{23,24}}},{{{25,26},{27,28}},{{29,30},{31,32}}}}},
+{{{{{1,2},{3,4}},{{5,6},{7,8}}},{{{9,10},{11,12}},{{13,14},{15,16}}}},
+{{{{17,18},{19,20}},{{21,22},{23,24}}},{{{25,26},{27,28}},{{29,30},{31,32}}}}}}}'
+);
+
+select plperl_sum_array('{{{1,2,3}, {4,5,6,7}}, {{7,8,9}, {10, 11, 12}}}');
+
+CREATE OR REPLACE FUNCTION plperl_concat(TEXT[]) RETURNS TEXT AS $$
+	my $array_arg = shift;
+	my $result = "";
+	my @arrays;
+	
+	push @arrays, @$array_arg;
+	while (@arrays > 0) {
+		my $el = shift @arrays;
+		if (is_array_ref($el)) {
+			push @arrays, @$el;
+		} else {
+			$result .= $el;
+		}
+	}
+	return $result.' '.$array_arg;
+$$ LANGUAGE plperl;
+
+select plperl_concat('{"NULL","NULL","NULL''"}');
+select plperl_concat('{{NULL,NULL,NULL}}');
+select plperl_concat('{"hello"," ","world!"}');
+
+-- array of rows --
+CREATE TYPE foo AS (bar INTEGER, baz TEXT);
+CREATE OR REPLACE FUNCTION plperl_array_of_rows(foo[]) RETURNS TEXT AS $$
+	my $array_arg = shift;
+	my $result = "";
+	
+	for my $row_ref (@$array_arg) {
+		die "not a hash reference" unless (ref $row_ref eq "HASH");
+			$result .= $row_ref->{bar}." items of ".$row_ref->{baz}.";";
+	}
+	return $result .' '. $array_arg;
+$$ LANGUAGE plperl;
+
+select plperl_array_of_rows(ARRAY[ ROW(2, 'coffee'), ROW(0, 'sugar')]::foo[]);
+
+-- composite type containing arrays
+CREATE TYPE rowfoo AS (bar INTEGER, baz INTEGER[]);
+
+CREATE OR REPLACE FUNCTION plperl_sum_row_elements(rowfoo) RETURNS TEXT AS $$
+	my $row_ref = shift;
+	my $result;
+	
+	if (ref $row_ref ne 'HASH') {
+		$result = 0;
+	}
+	else {
+		$result = $row_ref->{bar};
+		die "not an array reference".ref ($row_ref->{baz}) 
+		unless (is_array_ref($row_ref->{baz}));
+		# process a single-dimensional array
+		foreach my $elem (@{$row_ref->{baz}}) {
+			$result += $elem unless ref $elem;
+		}
+	}
+	return $result;
+$$ LANGUAGE plperl;
+
+select plperl_sum_row_elements(ROW(1, ARRAY[2,3,4,5,6,7,8,9,10])::rowfoo);
+
+-- composite type containing array of another composite type, which, in order,
+-- contains an array of integers.
+CREATE TYPE rowbar AS (foo rowfoo[]);
+
+CREATE OR REPLACE FUNCTION plperl_sum_array_of_rows(rowbar) RETURNS TEXT AS $$
+	my $rowfoo_ref = shift;
+	my $result = 0;
+	
+	if (ref $rowfoo_ref eq 'HASH') {
+		my $row_array_ref = $rowfoo_ref->{foo};
+		if (is_array_ref($row_array_ref)) {
+			foreach my $row_ref (@{$row_array_ref}) {
+				if (ref $row_ref eq 'HASH') {
+					$result += $row_ref->{bar};
+					die "not an array reference".ref ($row_ref->{baz}) 
+					unless (is_array_ref($row_ref->{baz}));
+					foreach my $elem (@{$row_ref->{baz}}) {
+						$result += $elem unless ref $elem;
+					}
+				}
+				else {
+					die "element baz is not a reference to a rowfoo";
+				}
+			}
+		} else {
+			die "not a reference to an array of rowfoo elements"
+		}
+	} else {
+		die "not a reference to type rowbar";
+	}
+	return $result;
+$$ LANGUAGE plperl;
+
+select plperl_sum_array_of_rows(ROW(ARRAY[ROW(1, ARRAY[2,3,4,5,6,7,8,9,10])::rowfoo, 
+ROW(11, ARRAY[12,13,14,15,16,17,18,19,20])::rowfoo])::rowbar);
+
+-- check arrays as out parameters
+CREATE OR REPLACE FUNCTION plperl_arrays_out(OUT INTEGER[]) AS $$
+	return [[1,2,3],[4,5,6]];
+$$ LANGUAGE plperl;
+
+select plperl_arrays_out();
+
+-- check that we can return the array we passed in
+CREATE OR REPLACE FUNCTION plperl_arrays_inout(INTEGER[]) returns INTEGER[] AS $$
+	return shift;
+$$ LANGUAGE plperl;
+
+select plperl_arrays_inout('{{1}, {2}, {3}}');
+
+-- make sure setof works
+create or replace function perl_setof_array(integer[]) returns setof integer[] language plperl as $$
+	my $arr = shift;
+	for my $r (@$arr) {
+		return_next $r;
+	}
+	return undef;
+$$;
+
+select perl_setof_array('{{1}, {2}, {3}}');

src/pl/plperl/sql/plperl_trigger.sql

 -- test plperl triggers
 
+CREATE TYPE rowcomp as (i int);
+CREATE TYPE rowcompnest as (rfoo rowcomp);
 CREATE TABLE trigger_test (
         i int,
-        v varchar
+        v varchar,
+		foo rowcompnest
 );
 
 CREATE OR REPLACE FUNCTION trigger_data() RETURNS trigger LANGUAGE plperl AS $$
@@ -10,43 +13,49 @@ CREATE OR REPLACE FUNCTION trigger_data() RETURNS trigger LANGUAGE plperl AS $$
   # make sure keys are sorted for consistent results - perl no longer
   # hashes in  repeatable fashion across runs
 
-  foreach my $key (sort keys %$_TD)
-  {
-
-    my $val = $_TD->{$key};
+  sub str {
+	  my $val = shift;
 
-	# relid is variable, so we can not use it repeatably
-	$val = "bogus:12345" if $key eq 'relid';
-
-	if (! defined $val)
-	{
-	  elog(NOTICE, "\$_TD->\{$key\} = NULL");
-	}
-	elsif (not ref $val)
+	  if (!defined $val)
 	  {
-	  elog(NOTICE, "\$_TD->\{$key\} = '$val'");
+		  return 'NULL';
 	  }
 	  elsif (ref $val eq 'HASH')
 	  {
-	  my $str = "";
+		my $str = '';
 		foreach my $rowkey (sort keys %$val)
 		{
 		  $str .= ", " if $str;
-	    my $rowval = $val->{$rowkey};
-	    $str .= "'$rowkey' => '$rowval'";
+		  my $rowval = str($val->{$rowkey});
+		  $str .= "'$rowkey' => $rowval";
 		}
-	  elog(NOTICE, "\$_TD->\{$key\} = \{$str\}");
+		return '{'. $str .'}';
 	  }
 	  elsif (ref $val eq 'ARRAY')
 	  {
-	  my $str = "";
-	  foreach my $argval (@$val)
+		  my $str = '';
+		  for my $argval (@$val)
 		  {
 			  $str .= ", " if $str;
-	    $str .= "'$argval'";
+			  $str .= str($argval);
+		  }
+		  return '['. $str .']';
+	  }
+	  else
+	  {
+		  return "'$val'";
 	  }
-	  elog(NOTICE, "\$_TD->\{$key\} = \[$str\]");
   }
+
+  foreach my $key (sort keys %$_TD)
+  {
+
+    my $val = $_TD->{$key};
+
+	# relid is variable, so we can not use it repeatably
+	$val = "bogus:12345" if $key eq 'relid';
+
+	elog(NOTICE, "\$_TD->\{$key\} = ". str($val));
   }
   return undef; # allow statement to proceed;
 $$;
@@ -55,21 +64,21 @@ CREATE TRIGGER show_trigger_data_trig
 BEFORE INSERT OR UPDATE OR DELETE ON trigger_test
 FOR EACH ROW EXECUTE PROCEDURE trigger_data(23,'skidoo');
 
-insert into trigger_test values(1,'insert');
+insert into trigger_test values(1,'insert', '("(1)")');
 update trigger_test set v = 'update' where i = 1;
 delete from trigger_test;
 
 DROP TRIGGER show_trigger_data_trig on trigger_test;
 
-insert into trigger_test values(1,'insert');
+insert into trigger_test values(1,'insert', '("(1)")');
 CREATE VIEW trigger_test_view AS SELECT * FROM trigger_test;
 
 CREATE TRIGGER show_trigger_data_trig
 INSTEAD OF INSERT OR UPDATE OR DELETE ON trigger_test_view
 FOR EACH ROW EXECUTE PROCEDURE trigger_data(24,'skidoo view');
 
-insert into trigger_test_view values(2,'insert');
-update trigger_test_view set v = 'update' where i = 1;
+insert into trigger_test_view values(2,'insert', '("(2)")');
+update trigger_test_view set v = 'update', foo = '("(3)")' where i = 1;
 delete from trigger_test_view;
 
 DROP VIEW trigger_test_view;
@@ -86,6 +95,7 @@ CREATE OR REPLACE FUNCTION valid_id() RETURNS trigger AS $$
     elsif ($_TD->{new}{v} ne "immortal")
     {
         $_TD->{new}{v} .= "(modified by trigger)";
+		$_TD->{new}{foo}{rfoo}{i}++;
         return "MODIFY"; # Modify tuple and proceed INSERT/UPDATE command
     }
     else
@@ -97,10 +107,10 @@ $$ LANGUAGE plperl;
 CREATE TRIGGER "test_valid_id_trig" BEFORE INSERT OR UPDATE ON trigger_test
 FOR EACH ROW EXECUTE PROCEDURE "valid_id"();
 
-INSERT INTO trigger_test (i, v) VALUES (1,'first line');
-INSERT INTO trigger_test (i, v) VALUES (2,'second line');
-INSERT INTO trigger_test (i, v) VALUES (3,'third line');
-INSERT INTO trigger_test (i, v) VALUES (4,'immortal');
+INSERT INTO trigger_test (i, v, foo) VALUES (1,'first line', '("(1)")');
+INSERT INTO trigger_test (i, v, foo) VALUES (2,'second line', '("(2)")');
+INSERT INTO trigger_test (i, v, foo) VALUES (3,'third line', '("(3)")');
+INSERT INTO trigger_test (i, v, foo) VALUES (4,'immortal', '("(4)")');
 
 INSERT INTO trigger_test (i, v) VALUES (101,'bad id');
 

src/pl/plperl/sql/plperl_util.sql

@@ -98,3 +98,15 @@ create or replace function perl_looks_like_number() returns setof text language
 $$;
 
 select perl_looks_like_number();
+
+-- test encode_typed_literal
+create type perl_foo as (a integer, b text[]);
+create type perl_bar as (c perl_foo[]);
+create or replace function perl_encode_typed_literal() returns setof text language plperl as $$
+	return_next encode_typed_literal(undef, 'text');
+	return_next encode_typed_literal([[1,2,3],[3,2,1],[1,3,2]], 'integer[]');
+	return_next encode_typed_literal({a => 1, b => ['PL','/','Perl']}, 'perl_foo');
+	return_next encode_typed_literal({c => [{a => 9, b => ['PostgreSQL']}, {b => ['Postgres'], a => 1}]}, 'perl_bar');
+$$;
+
+select perl_encode_typed_literal();