Adding upstream version 16.2.upstream/16.2

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>

14 files changed, 1744 insertions, 0 deletions

diff --git a/src/pl/plperl/sql/plperl.sql b/src/pl/plperl/sql/plperl.sql
new file mode 100644
index 0000000..bb0b8ce
--- /dev/null
+++ b/src/pl/plperl/sql/plperl.sql
@@ -0,0 +1,523 @@
+--
+-- Test result value processing
+--
+
+CREATE OR REPLACE FUNCTION perl_int(int) RETURNS INTEGER AS $$
+return undef;
+$$ LANGUAGE plperl;
+
+SELECT perl_int(11);
+SELECT * FROM perl_int(42);
+
+CREATE OR REPLACE FUNCTION perl_int(int) RETURNS INTEGER AS $$
+return $_[0] + 1;
+$$ LANGUAGE plperl;
+
+SELECT perl_int(11);
+SELECT * FROM perl_int(42);
+
+
+CREATE OR REPLACE FUNCTION perl_set_int(int) RETURNS SETOF INTEGER AS $$
+return undef;
+$$ LANGUAGE plperl;
+
+SELECT perl_set_int(5);
+SELECT * FROM perl_set_int(5);
+
+CREATE OR REPLACE FUNCTION perl_set_int(int) RETURNS SETOF INTEGER AS $$
+return [0..$_[0]];
+$$ LANGUAGE plperl;
+
+SELECT perl_set_int(5);
+SELECT * FROM perl_set_int(5);
+
+
+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;
+
+SELECT perl_row();
+SELECT * FROM perl_row();
+
+
+CREATE OR REPLACE FUNCTION perl_row() RETURNS testrowperl AS $$
+    return {f2 => 'hello', f1 => 1, f3 => 'world', 'f4' => { 'f5' => [[1]] } };
+$$ LANGUAGE plperl;
+
+SELECT perl_row();
+SELECT * FROM perl_row();
+
+-- test returning a composite literal
+CREATE OR REPLACE FUNCTION perl_row_lit() RETURNS testrowperl AS $$
+    return '(1,hello,world,"({{1}})")';
+$$ LANGUAGE plperl;
+
+SELECT perl_row_lit();
+
+
+CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
+    return undef;
+$$  LANGUAGE plperl;
+
+SELECT perl_set();
+SELECT * FROM perl_set();
+
+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', '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();
+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', '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, f4 testnestperl);
+
+CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$
+    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, f4 testnestperl);
+
+
+CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
+    return undef;
+$$  LANGUAGE plperl;
+
+SELECT perl_record_set();
+SELECT * FROM perl_record_set();
+SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text);
+
+CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
+    return [
+        { f1 => 1, f2 => 'Hello', f3 =>  'World' },
+        undef,
+        { f1 => 3, f2 => 'Hello', f3 =>  'PL/Perl' }
+    ];
+$$  LANGUAGE plperl;
+
+SELECT perl_record_set();
+SELECT * FROM perl_record_set();
+SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text);
+
+CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
+    return [
+        { f1 => 1, f2 => 'Hello', f3 =>  'World' },
+        { f1 => 2, f2 => 'Hello', f3 =>  'PostgreSQL' },
+        { f1 => 3, f2 => 'Hello', f3 =>  'PL/Perl' }
+    ];
+$$  LANGUAGE plperl;
+
+SELECT perl_record_set();
+SELECT * FROM perl_record_set();
+SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text);
+
+CREATE OR REPLACE FUNCTION
+perl_out_params(f1 out integer, f2 out text, f3 out text) AS $$
+    return {f2 => 'hello', f1 => 1, f3 => 'world'};
+$$ LANGUAGE plperl;
+
+SELECT perl_out_params();
+SELECT * FROM perl_out_params();
+SELECT (perl_out_params()).f2;
+
+CREATE OR REPLACE FUNCTION
+perl_out_params_set(out f1 integer, out f2 text, out f3 text)
+RETURNS SETOF record AS $$
+    return [
+        { f1 => 1, f2 => 'Hello', f3 =>  'World' },
+        { f1 => 2, f2 => 'Hello', f3 =>  'PostgreSQL' },
+        { f1 => 3, f2 => 'Hello', f3 =>  'PL/Perl' }
+    ];
+$$  LANGUAGE plperl;
+
+SELECT perl_out_params_set();
+SELECT * FROM perl_out_params_set();
+SELECT (perl_out_params_set()).f3;
+
+--
+-- Check behavior with erroneous return values
+--
+
+CREATE TYPE footype AS (x INTEGER, y INTEGER);
+
+CREATE OR REPLACE FUNCTION foo_good() RETURNS SETOF footype AS $$
+return [
+    {x => 1, y => 2},
+    {x => 3, y => 4}
+];
+$$ LANGUAGE plperl;
+
+SELECT * FROM foo_good();
+
+CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
+    return {y => 3, z => 4};
+$$ LANGUAGE plperl;
+
+SELECT * FROM foo_bad();
+
+CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
+return 42;
+$$ LANGUAGE plperl;
+
+SELECT * FROM foo_bad();
+
+CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
+return [
+    [1, 2],
+    [3, 4]
+];
+$$ LANGUAGE plperl;
+
+SELECT * FROM foo_bad();
+
+CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
+    return 42;
+$$ LANGUAGE plperl;
+
+SELECT * FROM foo_set_bad();
+
+CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
+    return {y => 3, z => 4};
+$$ LANGUAGE plperl;
+
+SELECT * FROM foo_set_bad();
+
+CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
+return [
+    [1, 2],
+    [3, 4]
+];
+$$ LANGUAGE plperl;
+
+SELECT * FROM foo_set_bad();
+
+CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
+return [
+    {y => 3, z => 4}
+];
+$$ LANGUAGE plperl;
+
+SELECT * FROM foo_set_bad();
+
+CREATE DOMAIN orderedfootype AS footype CHECK ((VALUE).x <= (VALUE).y);
+
+CREATE OR REPLACE FUNCTION foo_ordered() RETURNS orderedfootype AS $$
+    return {x => 3, y => 4};
+$$ LANGUAGE plperl;
+
+SELECT * FROM foo_ordered();
+
+CREATE OR REPLACE FUNCTION foo_ordered() RETURNS orderedfootype AS $$
+    return {x => 5, y => 4};
+$$ LANGUAGE plperl;
+
+SELECT * FROM foo_ordered();  -- fail
+
+CREATE OR REPLACE FUNCTION foo_ordered_set() RETURNS SETOF orderedfootype AS $$
+return [
+    {x => 3, y => 4},
+    {x => 4, y => 7}
+];
+$$ LANGUAGE plperl;
+
+SELECT * FROM foo_ordered_set();
+
+CREATE OR REPLACE FUNCTION foo_ordered_set() RETURNS SETOF orderedfootype AS $$
+return [
+    {x => 3, y => 4},
+    {x => 9, y => 7}
+];
+$$ LANGUAGE plperl;
+
+SELECT * FROM foo_ordered_set();  -- fail
+
+--
+-- Check passing a tuple argument
+--
+
+CREATE OR REPLACE FUNCTION perl_get_field(footype, text) RETURNS integer AS $$
+    return $_[0]->{$_[1]};
+$$ LANGUAGE plperl;
+
+SELECT perl_get_field((11,12), 'x');
+SELECT perl_get_field((11,12), 'y');
+SELECT perl_get_field((11,12), 'z');
+
+CREATE OR REPLACE FUNCTION perl_get_cfield(orderedfootype, text) RETURNS integer AS $$
+    return $_[0]->{$_[1]};
+$$ LANGUAGE plperl;
+
+SELECT perl_get_cfield((11,12), 'x');
+SELECT perl_get_cfield((11,12), 'y');
+SELECT perl_get_cfield((12,11), 'x');  -- fail
+
+CREATE OR REPLACE FUNCTION perl_get_rfield(record, text) RETURNS integer AS $$
+    return $_[0]->{$_[1]};
+$$ LANGUAGE plperl;
+
+SELECT perl_get_rfield((11,12), 'f1');
+SELECT perl_get_rfield((11,12)::footype, 'y');
+SELECT perl_get_rfield((11,12)::orderedfootype, 'x');
+SELECT perl_get_rfield((12,11)::orderedfootype, 'x');  -- fail
+
+--
+-- Test return_next
+--
+
+CREATE OR REPLACE FUNCTION perl_srf_rn() RETURNS SETOF RECORD AS $$
+my $i = 0;
+for ("World", "PostgreSQL", "PL/Perl") {
+    return_next({f1=>++$i, f2=>'Hello', f3=>$_});
+}
+return;
+$$ language plperl;
+SELECT * from perl_srf_rn() AS (f1 INTEGER, f2 TEXT, f3 TEXT);
+
+--
+-- Test spi_query/spi_fetchrow
+--
+
+CREATE OR REPLACE FUNCTION perl_spi_func() RETURNS SETOF INTEGER AS $$
+my $x = spi_query("select 1 as a union select 2 as a");
+while (defined (my $y = spi_fetchrow($x))) {
+    return_next($y->{a});
+}
+return;
+$$ LANGUAGE plperl;
+SELECT * from perl_spi_func();
+
+--
+-- Test spi_fetchrow abort
+--
+CREATE OR REPLACE FUNCTION perl_spi_func2() RETURNS INTEGER AS $$
+my $x = spi_query("select 1 as a union select 2 as a");
+spi_cursor_close( $x);
+return 0;
+$$ LANGUAGE plperl;
+SELECT * from perl_spi_func2();
+
+
+---
+--- Test recursion via SPI
+---
+
+
+CREATE OR REPLACE FUNCTION recurse(i int) RETURNS SETOF TEXT LANGUAGE plperl
+AS $$
+
+  my $i = shift;
+  foreach my $x (1..$i)
+  {
+    return_next "hello $x";
+  }
+  if ($i > 2)
+  {
+    my $z = $i-1;
+    my $cursor = spi_query("select * from recurse($z)");
+    while (defined(my $row = spi_fetchrow($cursor)))
+    {
+      return_next "recurse $i: $row->{recurse}";
+    }
+  }
+  return undef;
+
+$$;
+
+SELECT * FROM recurse(2);
+SELECT * FROM recurse(3);
+
+
+---
+--- Test array return
+---
+CREATE OR REPLACE FUNCTION  array_of_text() RETURNS TEXT[][]
+LANGUAGE plperl as $$
+    return [['a"b',undef,'c,d'],['e\\f',undef,'g']];
+$$;
+
+SELECT array_of_text();
+
+--
+-- Test spi_prepare/spi_exec_prepared/spi_freeplan
+--
+CREATE OR REPLACE FUNCTION perl_spi_prepared(INTEGER) RETURNS INTEGER AS $$
+   my $x = spi_prepare('select $1 AS a', 'INTEGER');
+   my $q = spi_exec_prepared( $x, $_[0] + 1);
+   spi_freeplan($x);
+return $q->{rows}->[0]->{a};
+$$ LANGUAGE plperl;
+SELECT * from perl_spi_prepared(42);
+
+--
+-- Test spi_prepare/spi_query_prepared/spi_freeplan
+--
+CREATE OR REPLACE FUNCTION perl_spi_prepared_set(INTEGER, INTEGER) RETURNS SETOF INTEGER AS $$
+  my $x = spi_prepare('SELECT $1 AS a union select $2 as a', 'INT4', 'INT4');
+  my $q = spi_query_prepared( $x, 1+$_[0], 2+$_[1]);
+  while (defined (my $y = spi_fetchrow($q))) {
+      return_next $y->{a};
+  }
+  spi_freeplan($x);
+  return;
+$$ LANGUAGE plperl;
+SELECT * from perl_spi_prepared_set(1,2);
+
+--
+-- Test prepare with a type with spaces
+--
+CREATE OR REPLACE FUNCTION perl_spi_prepared_double(double precision) RETURNS double precision AS $$
+  my $x = spi_prepare('SELECT 10.0 * $1 AS a', 'DOUBLE PRECISION');
+  my $q = spi_query_prepared($x,$_[0]);
+  my $result;
+  while (defined (my $y = spi_fetchrow($q))) {
+      $result = $y->{a};
+  }
+  spi_freeplan($x);
+  return $result;
+$$ LANGUAGE plperl;
+SELECT perl_spi_prepared_double(4.35) as "double precision";
+
+--
+-- Test with a bad type
+--
+CREATE OR REPLACE FUNCTION perl_spi_prepared_bad(double precision) RETURNS double precision AS $$
+  my $x = spi_prepare('SELECT 10.0 * $1 AS a', 'does_not_exist');
+  my $q = spi_query_prepared($x,$_[0]);
+  my $result;
+  while (defined (my $y = spi_fetchrow($q))) {
+      $result = $y->{a};
+  }
+  spi_freeplan($x);
+  return $result;
+$$ 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';
+  elog(NOTICE, $a);
+$$ LANGUAGE plperl;
+
+-- check that restricted operations are rejected in a plperl DO block
+DO $$ system("/nonesuch"); $$ LANGUAGE plperl;
+DO $$ qx("/nonesuch"); $$ LANGUAGE plperl;
+DO $$ open my $fh, "</nonesuch"; $$ LANGUAGE plperl;
+
+-- check that eval is allowed and eval'd restricted ops are caught
+DO $$ eval q{chdir '.';}; warn "Caught: $@"; $$ LANGUAGE plperl;
+
+-- check that compiling do (dofile opcode) is allowed
+-- but that executing it for a file not already loaded (via require) dies
+DO $$ warn do "/dev/null"; $$ LANGUAGE plperl;
+
+-- check that we can't "use" a module that's not been loaded already
+-- compile-time error: "Unable to load blib.pm into plperl"
+DO $$ use blib; $$ LANGUAGE plperl;
+
+-- check that we can "use" a module that has already been loaded
+-- runtime error: "Can't use string ("foo") as a SCALAR ref while "strict refs" in use
+DO $do$ use strict; my $name = "foo"; my $ref = $$name; $do$ LANGUAGE plperl;
+
+-- check that we can "use warnings" (in this case to turn a warn into an error)
+-- yields "ERROR:  Useless use of sort in void context."
+DO $do$ use warnings FATAL => qw(void) ; my @y; sort @y; 1; $do$ LANGUAGE plperl;
+
+-- make sure functions marked as VOID without an explicit return work
+CREATE OR REPLACE FUNCTION myfuncs() RETURNS void AS $$
+   $_SHARED{myquote} = sub {
+       my $arg = shift;
+       $arg =~ s/(['\\])/\\$1/g;
+       return "'$arg'";
+   };
+$$ LANGUAGE plperl;
+
+SELECT myfuncs();
+
+-- make sure we can't return an array as a scalar
+CREATE OR REPLACE FUNCTION text_arrayref() RETURNS text AS $$
+	return ['array'];
+$$ LANGUAGE plperl;
+
+SELECT text_arrayref();
+
+--- make sure we can't return a hash as a scalar
+CREATE OR REPLACE FUNCTION text_hashref() RETURNS text AS $$
+	return {'hash'=>1};
+$$ LANGUAGE plperl;
+
+SELECT text_hashref();
+
+---- make sure we can't return a blessed object as a scalar
+CREATE OR REPLACE FUNCTION text_obj() RETURNS text AS $$
+	return bless({}, 'Fake::Object');
+$$ LANGUAGE plperl;
+
+SELECT text_obj();
+
+-- test looking through a scalar ref
+CREATE OR REPLACE FUNCTION text_scalarref() RETURNS text AS $$
+	my $str = 'str';
+	return \$str;
+$$ LANGUAGE plperl;
+
+SELECT text_scalarref();
+
+-- check safe behavior when a function body is replaced during execution
+CREATE OR REPLACE FUNCTION self_modify(INTEGER) RETURNS INTEGER AS $$
+   spi_exec_query('CREATE OR REPLACE FUNCTION self_modify(INTEGER) RETURNS INTEGER AS \'return $_[0] * 3;\' LANGUAGE plperl;');
+   spi_exec_query('select self_modify(42) AS a');
+   return $_[0] * 2;
+$$ LANGUAGE plperl;
+
+SELECT self_modify(42);
+SELECT self_modify(42);
diff --git a/src/pl/plperl/sql/plperl_array.sql b/src/pl/plperl/sql/plperl_array.sql
new file mode 100644
index 0000000..ca63b5d
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_array.sql
@@ -0,0 +1,208 @@
+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}}');
+
+-- check that we can return an array literal
+CREATE OR REPLACE FUNCTION plperl_arrays_inout_l(INTEGER[]) returns INTEGER[] AS $$
+	return shift.''; # stringify it
+$$ LANGUAGE plperl;
+
+select plperl_arrays_inout_l('{{1}, {2}, {3}}');
+
+-- check output of multi-dimensional arrays
+CREATE FUNCTION plperl_md_array_out() RETURNS text[] AS $$
+	return [['a'], ['b'], ['c']];
+$$ LANGUAGE plperl;
+
+select plperl_md_array_out();
+
+CREATE OR REPLACE FUNCTION plperl_md_array_out() RETURNS text[] AS $$
+	return [[], []];
+$$ LANGUAGE plperl;
+
+select plperl_md_array_out();
+
+CREATE OR REPLACE FUNCTION plperl_md_array_out() RETURNS text[] AS $$
+	return [[], [1]];
+$$ LANGUAGE plperl;
+
+select plperl_md_array_out();  -- fail
+
+CREATE OR REPLACE FUNCTION plperl_md_array_out() RETURNS text[] AS $$
+	return [[], 1];
+$$ LANGUAGE plperl;
+
+select plperl_md_array_out();  -- fail
+
+CREATE OR REPLACE FUNCTION plperl_md_array_out() RETURNS text[] AS $$
+	return [1, []];
+$$ LANGUAGE plperl;
+
+select plperl_md_array_out();  -- fail
+
+CREATE OR REPLACE FUNCTION plperl_md_array_out() RETURNS text[] AS $$
+	return [[1], [[]]];
+$$ LANGUAGE plperl;
+
+select plperl_md_array_out();  -- fail
+
+-- 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}}');
diff --git a/src/pl/plperl/sql/plperl_call.sql b/src/pl/plperl/sql/plperl_call.sql
new file mode 100644
index 0000000..bbea85f
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_call.sql
@@ -0,0 +1,78 @@
+CREATE PROCEDURE test_proc1()
+LANGUAGE plperl
+AS $$
+undef;
+$$;
+
+CALL test_proc1();
+
+
+CREATE PROCEDURE test_proc2()
+LANGUAGE plperl
+AS $$
+return 5
+$$;
+
+CALL test_proc2();
+
+
+CREATE TABLE test1 (a int);
+
+CREATE PROCEDURE test_proc3(x int)
+LANGUAGE plperl
+AS $$
+spi_exec_query("INSERT INTO test1 VALUES ($_[0])");
+$$;
+
+CALL test_proc3(55);
+
+SELECT * FROM test1;
+
+
+-- output arguments
+
+CREATE PROCEDURE test_proc5(INOUT a text)
+LANGUAGE plperl
+AS $$
+my ($a) = @_;
+return { a => "$a+$a" };
+$$;
+
+CALL test_proc5('abc');
+
+
+CREATE PROCEDURE test_proc6(a int, INOUT b int, INOUT c int)
+LANGUAGE plperl
+AS $$
+my ($a, $b, $c) = @_;
+return { b => $b * $a, c => $c * $a };
+$$;
+
+CALL test_proc6(2, 3, 4);
+
+
+-- OUT parameters
+
+CREATE PROCEDURE test_proc9(IN a int, OUT b int)
+LANGUAGE plperl
+AS $$
+my ($a, $b) = @_;
+elog(NOTICE, "a: $a, b: $b");
+return { b => $a * 2 };
+$$;
+
+DO $$
+DECLARE _a int; _b int;
+BEGIN
+  _a := 10; _b := 30;
+  CALL test_proc9(_a, _b);
+  RAISE NOTICE '_a: %, _b: %', _a, _b;
+END
+$$;
+
+
+DROP PROCEDURE test_proc1;
+DROP PROCEDURE test_proc2;
+DROP PROCEDURE test_proc3;
+
+DROP TABLE test1;
diff --git a/src/pl/plperl/sql/plperl_elog.sql b/src/pl/plperl/sql/plperl_elog.sql
new file mode 100644
index 0000000..9ea1350
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_elog.sql
@@ -0,0 +1,93 @@
+-- test warnings and errors from plperl
+
+create or replace function perl_elog(text) returns void language plperl as $$
+
+  my $msg = shift;
+  elog(NOTICE,$msg);
+
+$$;
+
+select perl_elog('explicit elog');
+
+create or replace function perl_warn(text) returns void language plperl as $$
+
+  my $msg = shift;
+  warn($msg);
+
+$$;
+
+select perl_warn('implicit elog via warn');
+
+-- test strict mode on/off
+
+SET plperl.use_strict = true;
+
+create or replace function uses_global() returns text language plperl as $$
+
+  $global = 1;
+  $other_global = 2;
+  return 'uses_global worked';
+
+$$;
+
+select uses_global();
+
+SET plperl.use_strict = false;
+
+create or replace function uses_global() returns text language plperl as $$
+
+  $global = 1;
+  $other_global=2;
+  return 'uses_global worked';
+
+$$;
+
+select uses_global();
+
+-- make sure we don't choke on readonly values
+do language plperl $$ elog(NOTICE, ${^TAINT}); $$;
+
+-- test recovery after "die"
+
+create or replace function just_die() returns void language plperl AS $$
+die "just die";
+$$;
+
+select just_die();
+
+create or replace function die_caller() returns int language plpgsql as $$
+BEGIN
+  BEGIN
+    PERFORM just_die();
+  EXCEPTION WHEN OTHERS THEN
+    RAISE NOTICE 'caught die';
+  END;
+  RETURN 1;
+END;
+$$;
+
+select die_caller();
+
+create or replace function indirect_die_caller() returns int language plperl as $$
+my $prepared = spi_prepare('SELECT die_caller() AS fx');
+my $a = spi_exec_prepared($prepared)->{rows}->[0]->{fx};
+my $b = spi_exec_prepared($prepared)->{rows}->[0]->{fx};
+return $a + $b;
+$$;
+
+select indirect_die_caller();
+
+-- Test non-ASCII error messages
+--
+-- Note: this test case is known to fail if the database encoding is
+-- EUC_CN, EUC_JP, EUC_KR, or EUC_TW, for lack of any equivalent to
+-- U+00A0 (no-break space) in those encodings.  However, testing with
+-- plain ASCII data would be rather useless, so we must live with that.
+
+SET client_encoding TO UTF8;
+
+create or replace function error_with_nbsp() returns void language plperl as $$
+  elog(ERROR, "this message contains a no-break space");
+$$;
+
+select error_with_nbsp();
diff --git a/src/pl/plperl/sql/plperl_end.sql b/src/pl/plperl/sql/plperl_end.sql
new file mode 100644
index 0000000..90f49dc
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_end.sql
@@ -0,0 +1,29 @@
+-- test END block handling
+
+-- Not included in the normal testing
+-- because it's beyond the scope of the test harness.
+-- Available here for manual developer testing.
+
+DO $do$
+	my $testlog = "/tmp/pgplperl_test.log";
+
+	warn "Run test, then examine contents of $testlog (which must already exist)\n";
+	return unless -f $testlog;
+
+    use IO::Handle; # for autoflush
+	open my $fh, '>', $testlog
+		or die "Can't write to $testlog: $!";
+    $fh->autoflush(1);
+
+    print $fh "# you should see just 3 'Warn: ...' lines: PRE, END and SPI ...\n";
+    $SIG{__WARN__} = sub { print $fh "Warn: @_" };
+    $SIG{__DIE__}  = sub { print $fh "Die: @_" unless $^S; die @_ };
+
+	END {
+		warn "END\n";
+		eval { spi_exec_query("select 1") };
+		warn $@;
+	}
+    warn "PRE\n";
+
+$do$ language plperlu;
diff --git a/src/pl/plperl/sql/plperl_init.sql b/src/pl/plperl/sql/plperl_init.sql
new file mode 100644
index 0000000..2aa3811
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_init.sql
@@ -0,0 +1,41 @@
+-- test plperl.on_plperl_init
+
+-- This test tests setting on_plperl_init after loading plperl
+LOAD 'plperl';
+
+SET SESSION plperl.on_plperl_init = ' system("/nonesuch"); ';
+
+SHOW plperl.on_plperl_init;
+
+DO $$ warn 42 $$ language plperl;
+
+--
+-- Reconnect (to unload plperl), then test setting on_plperl_init
+-- as an unprivileged user
+--
+
+\c -
+
+CREATE ROLE regress_plperl_user;
+
+SET ROLE regress_plperl_user;
+
+-- this succeeds, since the GUC isn't known yet
+SET SESSION plperl.on_plperl_init = 'test';
+
+RESET ROLE;
+
+LOAD 'plperl';
+
+SHOW plperl.on_plperl_init;
+
+DO $$ warn 42 $$ language plperl;
+
+-- now we won't be allowed to set it in the first place
+SET ROLE regress_plperl_user;
+
+SET SESSION plperl.on_plperl_init = 'test';
+
+RESET ROLE;
+
+DROP ROLE regress_plperl_user;
diff --git a/src/pl/plperl/sql/plperl_lc.sql b/src/pl/plperl/sql/plperl_lc.sql
new file mode 100644
index 0000000..a4a06e7
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_lc.sql
@@ -0,0 +1,8 @@
+--
+-- Make sure strings are validated
+-- Should fail for all encodings, as nul bytes are never permitted.
+--
+CREATE OR REPLACE FUNCTION perl_zerob() RETURNS TEXT AS $$
+  return "abcd\0efg";
+$$ LANGUAGE plperl;
+SELECT perl_zerob();
diff --git a/src/pl/plperl/sql/plperl_plperlu.sql b/src/pl/plperl/sql/plperl_plperlu.sql
new file mode 100644
index 0000000..bbd79b6
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_plperlu.sql
@@ -0,0 +1,58 @@
+-- test plperl/plperlu interaction
+
+-- the language and call ordering of this test sequence is useful
+
+CREATE OR REPLACE FUNCTION bar() RETURNS integer AS $$
+    #die 'BANG!'; # causes server process to exit(2)
+    # alternative - causes server process to exit(255)
+    spi_exec_query("invalid sql statement");
+$$ language plperl; -- compile plperl code
+
+CREATE OR REPLACE FUNCTION foo() RETURNS integer AS $$
+    spi_exec_query("SELECT * FROM bar()");
+    return 1;
+$$ LANGUAGE plperlu; -- compile plperlu code
+
+SELECT * FROM bar(); -- throws exception normally (running plperl)
+SELECT * FROM foo(); -- used to cause backend crash (after switching to plperlu)
+
+-- test redefinition of specific SP switching languages
+-- http://archives.postgresql.org/pgsql-bugs/2010-01/msg00116.php
+
+-- plperl first
+create or replace function foo(text) returns text language plperl  as 'shift';
+select foo('hey');
+create or replace function foo(text) returns text language plperlu as 'shift';
+select foo('hey');
+create or replace function foo(text) returns text language plperl  as 'shift';
+select foo('hey');
+
+-- plperlu first
+create or replace function bar(text) returns text language plperlu as 'shift';
+select bar('hey');
+create or replace function bar(text) returns text language plperl  as 'shift';
+select bar('hey');
+create or replace function bar(text) returns text language plperlu as 'shift';
+select bar('hey');
+
+--
+-- Make sure we can't use/require things in plperl
+--
+
+CREATE OR REPLACE FUNCTION use_plperlu() RETURNS void LANGUAGE plperlu
+AS $$
+use Errno;
+$$;
+
+CREATE OR REPLACE FUNCTION use_plperl() RETURNS void LANGUAGE plperl
+AS $$
+use Errno;
+$$;
+
+-- make sure our overloaded require op gets restored/set correctly
+select use_plperlu();
+
+CREATE OR REPLACE FUNCTION use_plperl() RETURNS void LANGUAGE plperl
+AS $$
+use Errno;
+$$;
diff --git a/src/pl/plperl/sql/plperl_setup.sql b/src/pl/plperl/sql/plperl_setup.sql
new file mode 100644
index 0000000..0eac915
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_setup.sql
@@ -0,0 +1,73 @@
+--
+-- Install the plperl and plperlu extensions
+--
+
+-- Before going ahead with the to-be-tested installations, verify that
+-- a non-superuser is allowed to install plperl (but not plperlu) when
+-- suitable permissions have been granted.
+
+CREATE USER regress_plperl_user1;
+CREATE USER regress_plperl_user2;
+
+SET ROLE regress_plperl_user1;
+
+CREATE EXTENSION plperl;  -- fail
+CREATE EXTENSION plperlu;  -- fail
+
+RESET ROLE;
+
+DO $$
+begin
+  execute format('grant create on database %I to regress_plperl_user1',
+                 current_database());
+end;
+$$;
+
+SET ROLE regress_plperl_user1;
+
+CREATE EXTENSION plperl;
+CREATE EXTENSION plperlu;  -- fail
+CREATE SCHEMA plperl_setup_scratch;
+SET search_path = plperl_setup_scratch;
+GRANT ALL ON SCHEMA plperl_setup_scratch TO regress_plperl_user2;
+
+CREATE FUNCTION foo1() returns int language plperl as '1;';
+SELECT foo1();
+
+-- Must reconnect to avoid failure with non-MULTIPLICITY Perl interpreters
+\c -
+SET search_path = plperl_setup_scratch;
+
+SET ROLE regress_plperl_user1;
+
+-- Should be able to change privileges on the language
+revoke all on language plperl from public;
+
+SET ROLE regress_plperl_user2;
+
+CREATE FUNCTION foo2() returns int language plperl as '2;';  -- fail
+
+SET ROLE regress_plperl_user1;
+
+grant usage on language plperl to regress_plperl_user2;
+
+SET ROLE regress_plperl_user2;
+
+CREATE FUNCTION foo2() returns int language plperl as '2;';
+SELECT foo2();
+
+SET ROLE regress_plperl_user1;
+
+-- Should be able to drop the extension, but not the language per se
+DROP LANGUAGE plperl CASCADE;
+DROP EXTENSION plperl CASCADE;
+
+-- Clean up
+RESET ROLE;
+DROP OWNED BY regress_plperl_user1;
+DROP USER regress_plperl_user1;
+DROP USER regress_plperl_user2;
+
+-- Now install the versions that will be used by subsequent test scripts.
+CREATE EXTENSION plperl;
+CREATE EXTENSION plperlu;
diff --git a/src/pl/plperl/sql/plperl_shared.sql b/src/pl/plperl/sql/plperl_shared.sql
new file mode 100644
index 0000000..b60e114
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_shared.sql
@@ -0,0 +1,41 @@
+-- test plperl.on_plperl_init via the shared hash
+-- (must be done before plperl is first used)
+
+-- This test tests setting on_plperl_init before loading plperl
+
+-- testing on_plperl_init gets run, and that it can alter %_SHARED
+SET plperl.on_plperl_init = '$_SHARED{on_init} = 42';
+
+-- test the shared hash
+
+create function setme(key text, val text) returns void language plperl as $$
+
+  my $key = shift;
+  my $val = shift;
+  $_SHARED{$key}= $val;
+
+$$;
+
+create function getme(key text) returns text language plperl as $$
+
+  my $key = shift;
+  return $_SHARED{$key};
+
+$$;
+
+select setme('ourkey','ourval');
+
+select getme('ourkey');
+
+select getme('on_init');
+
+-- verify that we can use $_SHARED in strict mode
+create or replace function perl_shared() returns int as $$
+use strict;
+my $val = $_SHARED{'stuff'};
+$_SHARED{'stuff'} = '1';
+return $val;
+$$ language plperl;
+
+select perl_shared();
+select perl_shared();
diff --git a/src/pl/plperl/sql/plperl_transaction.sql b/src/pl/plperl/sql/plperl_transaction.sql
new file mode 100644
index 0000000..d10c8be
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_transaction.sql
@@ -0,0 +1,195 @@
+CREATE TABLE test1 (a int, b text);
+
+
+CREATE PROCEDURE transaction_test1()
+LANGUAGE plperl
+AS $$
+foreach my $i (0..9) {
+    spi_exec_query("INSERT INTO test1 (a) VALUES ($i)");
+    if ($i % 2 == 0) {
+        spi_commit();
+    } else {
+        spi_rollback();
+    }
+}
+$$;
+
+CALL transaction_test1();
+
+SELECT * FROM test1;
+
+
+TRUNCATE test1;
+
+DO
+LANGUAGE plperl
+$$
+foreach my $i (0..9) {
+    spi_exec_query("INSERT INTO test1 (a) VALUES ($i)");
+    if ($i % 2 == 0) {
+        spi_commit();
+    } else {
+        spi_rollback();
+    }
+}
+$$;
+
+SELECT * FROM test1;
+
+
+TRUNCATE test1;
+
+-- not allowed in a function
+CREATE FUNCTION transaction_test2() RETURNS int
+LANGUAGE plperl
+AS $$
+foreach my $i (0..9) {
+    spi_exec_query("INSERT INTO test1 (a) VALUES ($i)");
+    if ($i % 2 == 0) {
+        spi_commit();
+    } else {
+        spi_rollback();
+    }
+}
+return 1;
+$$;
+
+SELECT transaction_test2();
+
+SELECT * FROM test1;
+
+
+-- also not allowed if procedure is called from a function
+CREATE FUNCTION transaction_test3() RETURNS int
+LANGUAGE plperl
+AS $$
+spi_exec_query("CALL transaction_test1()");
+return 1;
+$$;
+
+SELECT transaction_test3();
+
+SELECT * FROM test1;
+
+
+-- DO block inside function
+CREATE FUNCTION transaction_test4() RETURNS int
+LANGUAGE plperl
+AS $$
+spi_exec_query('DO LANGUAGE plperl $x$ spi_commit(); $x$');
+return 1;
+$$;
+
+SELECT transaction_test4();
+
+
+-- commit inside cursor loop
+CREATE TABLE test2 (x int);
+INSERT INTO test2 VALUES (0), (1), (2), (3), (4);
+
+TRUNCATE test1;
+
+DO LANGUAGE plperl $$
+my $sth = spi_query("SELECT * FROM test2 ORDER BY x");
+my $row;
+while (defined($row = spi_fetchrow($sth))) {
+    spi_exec_query("INSERT INTO test1 (a) VALUES (" . $row->{x} . ")");
+    spi_commit();
+}
+$$;
+
+SELECT * FROM test1;
+
+-- check that this doesn't leak a holdable portal
+SELECT * FROM pg_cursors;
+
+
+-- error in cursor loop with commit
+TRUNCATE test1;
+
+DO LANGUAGE plperl $$
+my $sth = spi_query("SELECT * FROM test2 ORDER BY x");
+my $row;
+while (defined($row = spi_fetchrow($sth))) {
+    spi_exec_query("INSERT INTO test1 (a) VALUES (12/(" . $row->{x} . "-2))");
+    spi_commit();
+}
+$$;
+
+SELECT * FROM test1;
+
+SELECT * FROM pg_cursors;
+
+
+-- rollback inside cursor loop
+TRUNCATE test1;
+
+DO LANGUAGE plperl $$
+my $sth = spi_query("SELECT * FROM test2 ORDER BY x");
+my $row;
+while (defined($row = spi_fetchrow($sth))) {
+    spi_exec_query("INSERT INTO test1 (a) VALUES (" . $row->{x} . ")");
+    spi_rollback();
+}
+$$;
+
+SELECT * FROM test1;
+
+SELECT * FROM pg_cursors;
+
+
+-- first commit then rollback inside cursor loop
+TRUNCATE test1;
+
+DO LANGUAGE plperl $$
+my $sth = spi_query("SELECT * FROM test2 ORDER BY x");
+my $row;
+while (defined($row = spi_fetchrow($sth))) {
+    spi_exec_query("INSERT INTO test1 (a) VALUES (" . $row->{x} . ")");
+    if ($row->{x} % 2 == 0) {
+        spi_commit();
+    } else {
+        spi_rollback();
+    }
+}
+$$;
+
+SELECT * FROM test1;
+
+SELECT * FROM pg_cursors;
+
+
+-- check handling of an error during COMMIT
+CREATE TABLE testpk (id int PRIMARY KEY);
+CREATE TABLE testfk(f1 int REFERENCES testpk DEFERRABLE INITIALLY DEFERRED);
+
+DO LANGUAGE plperl $$
+# this insert will fail during commit:
+spi_exec_query("INSERT INTO testfk VALUES (0)");
+spi_commit();
+elog(WARNING, 'should not get here');
+$$;
+
+SELECT * FROM testpk;
+SELECT * FROM testfk;
+
+DO LANGUAGE plperl $$
+# this insert will fail during commit:
+spi_exec_query("INSERT INTO testfk VALUES (0)");
+eval {
+    spi_commit();
+};
+if ($@) {
+    elog(INFO, $@);
+}
+# these inserts should work:
+spi_exec_query("INSERT INTO testpk VALUES (1)");
+spi_exec_query("INSERT INTO testfk VALUES (1)");
+$$;
+
+SELECT * FROM testpk;
+SELECT * FROM testfk;
+
+
+DROP TABLE test1;
+DROP TABLE test2;
diff --git a/src/pl/plperl/sql/plperl_trigger.sql b/src/pl/plperl/sql/plperl_trigger.sql
new file mode 100644
index 0000000..4adddeb
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_trigger.sql
@@ -0,0 +1,259 @@
+-- test plperl triggers
+
+CREATE TYPE rowcomp as (i int);
+CREATE TYPE rowcompnest as (rfoo rowcomp);
+CREATE TABLE trigger_test (
+        i int,
+        v varchar,
+		foo rowcompnest
+);
+
+CREATE TABLE trigger_test_generated (
+    i int,
+    j int GENERATED ALWAYS AS (i * 2) STORED
+);
+
+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
+
+  sub str {
+	  my $val = shift;
+
+	  if (!defined $val)
+	  {
+		  return 'NULL';
+	  }
+	  elsif (ref $val eq 'HASH')
+	  {
+		my $str = '';
+		foreach my $rowkey (sort keys %$val)
+		{
+		  $str .= ", " if $str;
+		  my $rowval = str($val->{$rowkey});
+		  $str .= "'$rowkey' => $rowval";
+		}
+		return '{'. $str .'}';
+	  }
+	  elsif (ref $val eq 'ARRAY')
+	  {
+		  my $str = '';
+		  for my $argval (@$val)
+		  {
+			  $str .= ", " if $str;
+			  $str .= str($argval);
+		  }
+		  return '['. $str .']';
+	  }
+	  else
+	  {
+		  return "'$val'";
+	  }
+  }
+
+  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', '("(1)")');
+update trigger_test set v = 'update' where i = 1;
+delete from trigger_test;
+
+DROP TRIGGER show_trigger_data_trig on trigger_test;
+
+CREATE TRIGGER show_trigger_data_trig_before
+BEFORE INSERT OR UPDATE OR DELETE ON trigger_test_generated
+FOR EACH ROW EXECUTE PROCEDURE trigger_data();
+
+CREATE TRIGGER show_trigger_data_trig_after
+AFTER INSERT OR UPDATE OR DELETE ON trigger_test_generated
+FOR EACH ROW EXECUTE PROCEDURE trigger_data();
+
+insert into trigger_test_generated (i) values (1);
+update trigger_test_generated set i = 11 where i = 1;
+delete from trigger_test_generated;
+
+DROP TRIGGER show_trigger_data_trig_before ON trigger_test_generated;
+DROP TRIGGER show_trigger_data_trig_after ON trigger_test_generated;
+
+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', '("(2)")');
+update trigger_test_view set v = 'update', foo = '("(3)")' where i = 1;
+delete from trigger_test_view;
+
+DROP VIEW trigger_test_view;
+delete from trigger_test;
+
+DROP FUNCTION trigger_data();
+
+CREATE OR REPLACE FUNCTION valid_id() RETURNS trigger AS $$
+
+    if (($_TD->{new}{i}>=100) || ($_TD->{new}{i}<=0))
+    {
+        return "SKIP";   # Skip INSERT/UPDATE command
+    }
+    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
+    {
+        return;          # Proceed INSERT/UPDATE command
+    }
+$$ 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, 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;
+
+UPDATE trigger_test SET i = 5 where i=3;
+
+UPDATE trigger_test SET i = 100 where i=1;
+
+SELECT * FROM trigger_test;
+
+DROP TRIGGER "test_valid_id_trig" ON trigger_test;
+
+CREATE OR REPLACE FUNCTION trigger_recurse() RETURNS trigger AS $$
+	use strict;
+
+	if ($_TD->{new}{i} == 10000)
+	{
+		spi_exec_query("insert into trigger_test (i, v) values (20000, 'child');");
+
+		if ($_TD->{new}{i} != 10000)
+		{
+			die "recursive trigger modified: ". $_TD->{new}{i};
+		}
+	}
+    return;
+$$ LANGUAGE plperl;
+
+CREATE TRIGGER "test_trigger_recurse" BEFORE INSERT ON trigger_test
+FOR EACH ROW EXECUTE PROCEDURE "trigger_recurse"();
+
+INSERT INTO trigger_test (i, v) values (10000, 'top');
+
+SELECT * FROM trigger_test;
+
+CREATE OR REPLACE FUNCTION immortal() RETURNS trigger AS $$
+    if ($_TD->{old}{v} eq $_TD->{args}[0])
+    {
+        return "SKIP"; # Skip DELETE command
+    }
+    else
+    {
+        return;        # Proceed DELETE command
+    };
+$$ LANGUAGE plperl;
+
+CREATE TRIGGER "immortal_trig" BEFORE DELETE ON trigger_test
+FOR EACH ROW EXECUTE PROCEDURE immortal('immortal');
+
+DELETE FROM trigger_test;
+
+SELECT * FROM trigger_test;
+
+CREATE FUNCTION direct_trigger() RETURNS trigger AS $$
+    return;
+$$ LANGUAGE plperl;
+
+SELECT direct_trigger();
+
+-- check that SQL run in trigger code can see transition tables
+
+CREATE TABLE transition_table_test (id int, name text);
+INSERT INTO transition_table_test VALUES (1, 'a');
+
+CREATE FUNCTION transition_table_test_f() RETURNS trigger LANGUAGE plperl AS
+$$
+    my $cursor = spi_query("SELECT * FROM old_table");
+    my $row = spi_fetchrow($cursor);
+    defined($row) || die "expected a row";
+    elog(INFO, "old: " . $row->{id} . " -> " . $row->{name});
+    my $row = spi_fetchrow($cursor);
+    !defined($row) || die "expected no more rows";
+
+    my $cursor = spi_query("SELECT * FROM new_table");
+    my $row = spi_fetchrow($cursor);
+    defined($row) || die "expected a row";
+    elog(INFO, "new: " . $row->{id} . " -> " . $row->{name});
+    my $row = spi_fetchrow($cursor);
+    !defined($row) || die "expected no more rows";
+
+    return undef;
+$$;
+
+CREATE TRIGGER a_t AFTER UPDATE ON transition_table_test
+  REFERENCING OLD TABLE AS old_table NEW TABLE AS new_table
+  FOR EACH STATEMENT EXECUTE PROCEDURE transition_table_test_f();
+UPDATE transition_table_test SET name = 'b';
+
+DROP TABLE transition_table_test;
+DROP FUNCTION transition_table_test_f();
+
+-- test plperl command triggers
+create or replace function perlsnitch() returns event_trigger language plperl as $$
+  elog(NOTICE, "perlsnitch: " . $_TD->{event} . " " . $_TD->{tag} . " ");
+$$;
+
+create event trigger perl_a_snitch on ddl_command_start
+   execute procedure perlsnitch();
+create event trigger perl_b_snitch on ddl_command_end
+   execute procedure perlsnitch();
+
+create or replace function foobar() returns int language sql as $$select 1;$$;
+alter function foobar() cost 77;
+drop function foobar();
+
+create table foo();
+drop table foo;
+
+drop event trigger perl_a_snitch;
+drop event trigger perl_b_snitch;
+
+-- dealing with generated columns
+
+CREATE FUNCTION generated_test_func1() RETURNS trigger
+LANGUAGE plperl
+AS $$
+$_TD->{new}{j} = 5;  # not allowed
+return 'MODIFY';
+$$;
+
+CREATE TRIGGER generated_test_trigger1 BEFORE INSERT ON trigger_test_generated
+FOR EACH ROW EXECUTE PROCEDURE generated_test_func1();
+
+TRUNCATE trigger_test_generated;
+INSERT INTO trigger_test_generated (i) VALUES (1);
+SELECT * FROM trigger_test_generated;
diff --git a/src/pl/plperl/sql/plperl_util.sql b/src/pl/plperl/sql/plperl_util.sql
new file mode 100644
index 0000000..5b31605
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_util.sql
@@ -0,0 +1,121 @@
+-- test plperl utility functions (defined in Util.xs)
+
+-- test quote_literal
+
+create or replace function perl_quote_literal() returns setof text language plperl as $$
+	return_next "undef: ".quote_literal(undef);
+	return_next sprintf"$_: ".quote_literal($_)
+		for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{};
+	return undef;
+$$;
+
+select perl_quote_literal();
+
+-- test quote_nullable
+
+create or replace function perl_quote_nullable() returns setof text language plperl as $$
+	return_next "undef: ".quote_nullable(undef);
+	return_next sprintf"$_: ".quote_nullable($_)
+		for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{};
+	return undef;
+$$;
+
+select perl_quote_nullable();
+
+-- test quote_ident
+
+create or replace function perl_quote_ident() returns setof text language plperl as $$
+	return_next "undef: ".quote_ident(undef); # generates undef warning if warnings enabled
+	return_next "$_: ".quote_ident($_)
+		for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{g.h}, q{};
+	return undef;
+$$;
+
+select perl_quote_ident();
+
+-- test decode_bytea
+
+create or replace function perl_decode_bytea() returns setof text language plperl as $$
+	return_next "undef: ".decode_bytea(undef); # generates undef warning if warnings enabled
+	return_next "$_: ".decode_bytea($_)
+		for q{foo}, q{a\047b}, q{};
+	return undef;
+$$;
+
+select perl_decode_bytea();
+
+-- test encode_bytea
+
+create or replace function perl_encode_bytea() returns setof text language plperl as $$
+	return_next encode_bytea(undef); # generates undef warning if warnings enabled
+	return_next encode_bytea($_)
+		for q{@}, qq{@\x01@}, qq{@\x00@}, q{};
+	return undef;
+$$;
+
+select perl_encode_bytea();
+
+-- test encode_array_literal
+
+create or replace function perl_encode_array_literal() returns setof text language plperl as $$
+	return_next encode_array_literal(undef);
+	return_next encode_array_literal(0);
+	return_next encode_array_literal(42);
+	return_next encode_array_literal($_)
+		for [], [0], [1..5], [[]], [[1,2,[3]],4];
+	return_next encode_array_literal($_,'|')
+		for [], [0], [1..5], [[]], [[1,2,[3]],4];
+	return undef;
+$$;
+
+select perl_encode_array_literal();
+
+-- test encode_array_constructor
+
+create or replace function perl_encode_array_constructor() returns setof text language plperl as $$
+	return_next encode_array_constructor(undef);
+	return_next encode_array_constructor(0);
+	return_next encode_array_constructor(42);
+	return_next encode_array_constructor($_)
+		for [], [0], [1..5], [[]], [[1,2,[3]],4];
+	return undef;
+$$;
+
+select perl_encode_array_constructor();
+
+-- test looks_like_number
+
+create or replace function perl_looks_like_number() returns setof text language plperl as $$
+	return_next "undef is undef" if not defined looks_like_number(undef);
+	return_next quote_nullable($_).": ". (looks_like_number($_) ? "number" : "not number")
+		for 'foo', 0, 1, 1.3, '+3.e-4',
+			'42 x', # trailing garbage
+			'99  ', # trailing space
+			'  99', # leading space
+			'    ', # only space
+			'';     # empty string
+	return undef;
+$$;
+
+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 domain perl_foo_pos as perl_foo check((value).a > 0);
+
+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');
+	return_next encode_typed_literal({a => 1, b => ['PL','/','Perl']}, 'perl_foo_pos');
+$$;
+
+select perl_encode_typed_literal();
+
+create or replace function perl_encode_typed_literal() returns setof text language plperl as $$
+	return_next encode_typed_literal({a => 0, b => ['PL','/','Perl']}, 'perl_foo_pos');
+$$;
+
+select perl_encode_typed_literal();  -- fail
diff --git a/src/pl/plperl/sql/plperlu.sql b/src/pl/plperl/sql/plperlu.sql
new file mode 100644
index 0000000..be43df5
--- /dev/null
+++ b/src/pl/plperl/sql/plperlu.sql
@@ -0,0 +1,17 @@
+-- Use ONLY plperlu tests here. For plperl/plerlu combined tests
+-- see plperl_plperlu.sql
+
+-- This test tests setting on_plperlu_init after loading plperl
+LOAD 'plperl';
+
+-- Test plperl.on_plperlu_init gets run
+SET plperl.on_plperlu_init = '$_SHARED{init} = 42';
+DO $$ warn $_SHARED{init} $$ language plperlu;
+
+--
+-- Test compilation of unicode regex - regardless of locale.
+-- This code fails in plain plperl in a non-UTF8 database.
+--
+CREATE OR REPLACE FUNCTION perl_unicode_regex(text) RETURNS INTEGER AS $$
+  return ($_[0] =~ /\x{263A}|happy/i) ? 1 : 0; # unicode smiley
+$$ LANGUAGE plperlu;