summaryrefslogtreecommitdiffstats
path: root/src/pl/plperl/expected
diff options
context:
space:
mode:
Diffstat (limited to 'src/pl/plperl/expected')
-rw-r--r--src/pl/plperl/expected/plperl.out794
-rw-r--r--src/pl/plperl/expected/plperl_array.out276
-rw-r--r--src/pl/plperl/expected/plperl_call.out72
-rw-r--r--src/pl/plperl/expected/plperl_elog.out112
-rw-r--r--src/pl/plperl/expected/plperl_elog_1.out112
-rw-r--r--src/pl/plperl/expected/plperl_init.out40
-rw-r--r--src/pl/plperl/expected/plperl_lc.out10
-rw-r--r--src/pl/plperl/expected/plperl_lc_1.out10
-rw-r--r--src/pl/plperl/expected/plperl_plperlu.out91
-rw-r--r--src/pl/plperl/expected/plperl_setup.out73
-rw-r--r--src/pl/plperl/expected/plperl_shared.out56
-rw-r--r--src/pl/plperl/expected/plperl_transaction.out244
-rw-r--r--src/pl/plperl/expected/plperl_trigger.out392
-rw-r--r--src/pl/plperl/expected/plperl_util.out198
-rw-r--r--src/pl/plperl/expected/plperlu.out15
15 files changed, 2495 insertions, 0 deletions
diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out
new file mode 100644
index 0000000..e3d7c88
--- /dev/null
+++ b/src/pl/plperl/expected/plperl.out
@@ -0,0 +1,794 @@
+--
+-- Test result value processing
+--
+CREATE OR REPLACE FUNCTION perl_int(int) RETURNS INTEGER AS $$
+return undef;
+$$ LANGUAGE plperl;
+SELECT perl_int(11);
+ perl_int
+----------
+
+(1 row)
+
+SELECT * FROM perl_int(42);
+ perl_int
+----------
+
+(1 row)
+
+CREATE OR REPLACE FUNCTION perl_int(int) RETURNS INTEGER AS $$
+return $_[0] + 1;
+$$ LANGUAGE plperl;
+SELECT perl_int(11);
+ perl_int
+----------
+ 12
+(1 row)
+
+SELECT * FROM perl_int(42);
+ perl_int
+----------
+ 43
+(1 row)
+
+CREATE OR REPLACE FUNCTION perl_set_int(int) RETURNS SETOF INTEGER AS $$
+return undef;
+$$ LANGUAGE plperl;
+SELECT perl_set_int(5);
+ perl_set_int
+--------------
+(0 rows)
+
+SELECT * FROM perl_set_int(5);
+ perl_set_int
+--------------
+(0 rows)
+
+CREATE OR REPLACE FUNCTION perl_set_int(int) RETURNS SETOF INTEGER AS $$
+return [0..$_[0]];
+$$ LANGUAGE plperl;
+SELECT perl_set_int(5);
+ perl_set_int
+--------------
+ 0
+ 1
+ 2
+ 3
+ 4
+ 5
+(6 rows)
+
+SELECT * FROM perl_set_int(5);
+ perl_set_int
+--------------
+ 0
+ 1
+ 2
+ 3
+ 4
+ 5
+(6 rows)
+
+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();
+ perl_row
+----------
+
+(1 row)
+
+SELECT * FROM perl_row();
+ f1 | f2 | f3 | f4
+----+----+----+----
+ | | |
+(1 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();
+ perl_row
+---------------------------
+ (1,hello,world,"({{1}})")
+(1 row)
+
+SELECT * FROM perl_row();
+ f1 | f2 | f3 | f4
+----+-------+-------+---------
+ 1 | hello | world | ({{1}})
+(1 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();
+ perl_row_lit
+---------------------------
+ (1,hello,world,"({{1}})")
+(1 row)
+
+CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
+ return undef;
+$$ LANGUAGE plperl;
+SELECT perl_set();
+ perl_set
+----------
+(0 rows)
+
+SELECT * FROM perl_set();
+ 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', '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();
+ERROR: SETOF-composite-returning PL/Perl function must call return_next with reference to hash
+CONTEXT: PL/Perl function "perl_set"
+SELECT * FROM perl_set();
+ERROR: SETOF-composite-returning PL/Perl function must call return_next with reference to hash
+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', '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,"()")
+ (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 | 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;
+$$ LANGUAGE plperl;
+SELECT perl_record();
+ perl_record
+-------------
+
+(1 row)
+
+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, f4 testnestperl);
+ f1 | f2 | f3 | f4
+----+----+----+----
+ | | |
+(1 row)
+
+CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$
+ 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
+CONTEXT: PL/Perl function "perl_record"
+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, f4 testnestperl);
+ f1 | f2 | f3 | f4
+----+-------+-------+-------
+ 1 | hello | world | ({1})
+(1 row)
+
+CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
+ return undef;
+$$ LANGUAGE plperl;
+SELECT perl_record_set();
+ perl_record_set
+-----------------
+(0 rows)
+
+SELECT * FROM perl_record_set();
+ERROR: a column definition list is required for functions returning "record"
+LINE 1: SELECT * FROM perl_record_set();
+ ^
+SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text);
+ f1 | f2 | f3
+----+----+----
+(0 rows)
+
+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();
+ERROR: function returning record called in context that cannot accept type record
+CONTEXT: PL/Perl function "perl_record_set"
+SELECT * FROM perl_record_set();
+ERROR: a column definition list is required for functions returning "record"
+LINE 1: SELECT * FROM perl_record_set();
+ ^
+SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text);
+ERROR: SETOF-composite-returning PL/Perl function must call return_next with reference to hash
+CONTEXT: PL/Perl function "perl_record_set"
+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();
+ERROR: function returning record called in context that cannot accept type record
+CONTEXT: PL/Perl function "perl_record_set"
+SELECT * FROM perl_record_set();
+ERROR: a column definition list is required for functions returning "record"
+LINE 1: SELECT * FROM perl_record_set();
+ ^
+SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text);
+ f1 | f2 | f3
+----+-------+------------
+ 1 | Hello | World
+ 2 | Hello | PostgreSQL
+ 3 | Hello | PL/Perl
+(3 rows)
+
+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();
+ perl_out_params
+-----------------
+ (1,hello,world)
+(1 row)
+
+SELECT * FROM perl_out_params();
+ f1 | f2 | f3
+----+-------+-------
+ 1 | hello | world
+(1 row)
+
+SELECT (perl_out_params()).f2;
+ f2
+-------
+ hello
+(1 row)
+
+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();
+ perl_out_params_set
+----------------------
+ (1,Hello,World)
+ (2,Hello,PostgreSQL)
+ (3,Hello,PL/Perl)
+(3 rows)
+
+SELECT * FROM perl_out_params_set();
+ f1 | f2 | f3
+----+-------+------------
+ 1 | Hello | World
+ 2 | Hello | PostgreSQL
+ 3 | Hello | PL/Perl
+(3 rows)
+
+SELECT (perl_out_params_set()).f3;
+ f3
+------------
+ World
+ PostgreSQL
+ PL/Perl
+(3 rows)
+
+--
+-- 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();
+ x | y
+---+---
+ 1 | 2
+ 3 | 4
+(2 rows)
+
+CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
+ return {y => 3, z => 4};
+$$ LANGUAGE plperl;
+SELECT * FROM foo_bad();
+ERROR: Perl hash contains nonexistent column "z"
+CONTEXT: PL/Perl function "foo_bad"
+CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
+return 42;
+$$ LANGUAGE plperl;
+SELECT * FROM foo_bad();
+ERROR: malformed record literal: "42"
+DETAIL: Missing left parenthesis.
+CONTEXT: PL/Perl function "foo_bad"
+CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
+return [
+ [1, 2],
+ [3, 4]
+];
+$$ LANGUAGE plperl;
+SELECT * FROM foo_bad();
+ERROR: cannot convert Perl array to non-array type footype
+CONTEXT: PL/Perl function "foo_bad"
+CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
+ return 42;
+$$ LANGUAGE plperl;
+SELECT * FROM foo_set_bad();
+ERROR: set-returning PL/Perl function must return reference to array or use return_next
+CONTEXT: PL/Perl function "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();
+ERROR: set-returning PL/Perl function must return reference to array or use return_next
+CONTEXT: PL/Perl function "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();
+ERROR: SETOF-composite-returning PL/Perl function must call return_next with reference to hash
+CONTEXT: PL/Perl function "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();
+ERROR: Perl hash contains nonexistent column "z"
+CONTEXT: PL/Perl function "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();
+ x | y
+---+---
+ 3 | 4
+(1 row)
+
+CREATE OR REPLACE FUNCTION foo_ordered() RETURNS orderedfootype AS $$
+ return {x => 5, y => 4};
+$$ LANGUAGE plperl;
+SELECT * FROM foo_ordered(); -- fail
+ERROR: value for domain orderedfootype violates check constraint "orderedfootype_check"
+CONTEXT: PL/Perl function "foo_ordered"
+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();
+ x | y
+---+---
+ 3 | 4
+ 4 | 7
+(2 rows)
+
+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
+ERROR: value for domain orderedfootype violates check constraint "orderedfootype_check"
+CONTEXT: PL/Perl function "foo_ordered_set"
+--
+-- 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');
+ perl_get_field
+----------------
+ 11
+(1 row)
+
+SELECT perl_get_field((11,12), 'y');
+ perl_get_field
+----------------
+ 12
+(1 row)
+
+SELECT perl_get_field((11,12), 'z');
+ perl_get_field
+----------------
+
+(1 row)
+
+CREATE OR REPLACE FUNCTION perl_get_cfield(orderedfootype, text) RETURNS integer AS $$
+ return $_[0]->{$_[1]};
+$$ LANGUAGE plperl;
+SELECT perl_get_cfield((11,12), 'x');
+ perl_get_cfield
+-----------------
+ 11
+(1 row)
+
+SELECT perl_get_cfield((11,12), 'y');
+ perl_get_cfield
+-----------------
+ 12
+(1 row)
+
+SELECT perl_get_cfield((12,11), 'x'); -- fail
+ERROR: value for domain orderedfootype violates check constraint "orderedfootype_check"
+CREATE OR REPLACE FUNCTION perl_get_rfield(record, text) RETURNS integer AS $$
+ return $_[0]->{$_[1]};
+$$ LANGUAGE plperl;
+SELECT perl_get_rfield((11,12), 'f1');
+ perl_get_rfield
+-----------------
+ 11
+(1 row)
+
+SELECT perl_get_rfield((11,12)::footype, 'y');
+ perl_get_rfield
+-----------------
+ 12
+(1 row)
+
+SELECT perl_get_rfield((11,12)::orderedfootype, 'x');
+ perl_get_rfield
+-----------------
+ 11
+(1 row)
+
+SELECT perl_get_rfield((12,11)::orderedfootype, 'x'); -- fail
+ERROR: value for domain orderedfootype violates check constraint "orderedfootype_check"
+--
+-- 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);
+ f1 | f2 | f3
+----+-------+------------
+ 1 | Hello | World
+ 2 | Hello | PostgreSQL
+ 3 | Hello | PL/Perl
+(3 rows)
+
+--
+-- 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();
+ perl_spi_func
+---------------
+ 1
+ 2
+(2 rows)
+
+--
+-- 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();
+ perl_spi_func2
+----------------
+ 0
+(1 row)
+
+---
+--- 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);
+ recurse
+---------
+ hello 1
+ hello 2
+(2 rows)
+
+SELECT * FROM recurse(3);
+ recurse
+--------------------
+ hello 1
+ hello 2
+ hello 3
+ recurse 3: hello 1
+ recurse 3: hello 2
+(5 rows)
+
+---
+--- 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();
+ array_of_text
+---------------------------------------
+ {{"a\"b",NULL,"c,d"},{"e\\f",NULL,g}}
+(1 row)
+
+--
+-- 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);
+ perl_spi_prepared
+-------------------
+ 43
+(1 row)
+
+--
+-- 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);
+ perl_spi_prepared_set
+-----------------------
+ 2
+ 4
+(2 rows)
+
+--
+-- 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";
+ double precision
+------------------
+ 43.5
+(1 row)
+
+--
+-- 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";
+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';
+ elog(NOTICE, $a);
+$$ LANGUAGE plperl;
+NOTICE: This is a test
+-- check that restricted operations are rejected in a plperl DO block
+DO $$ system("/nonesuch"); $$ LANGUAGE plperl;
+ERROR: 'system' trapped by operation mask at line 1.
+CONTEXT: PL/Perl anonymous code block
+DO $$ qx("/nonesuch"); $$ LANGUAGE plperl;
+ERROR: 'quoted execution (``, qx)' trapped by operation mask at line 1.
+CONTEXT: PL/Perl anonymous code block
+DO $$ open my $fh, "</nonesuch"; $$ LANGUAGE plperl;
+ERROR: 'open' trapped by operation mask at line 1.
+CONTEXT: PL/Perl anonymous code block
+-- check that eval is allowed and eval'd restricted ops are caught
+DO $$ eval q{chdir '.';}; warn "Caught: $@"; $$ LANGUAGE plperl;
+WARNING: Caught: 'chdir' trapped by operation mask at line 1.
+-- 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;
+ERROR: Unable to load /dev/null into plperl at line 1.
+CONTEXT: PL/Perl anonymous code block
+-- 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;
+ERROR: Unable to load blib.pm into plperl at line 1.
+BEGIN failed--compilation aborted at line 1.
+CONTEXT: PL/Perl anonymous code block
+-- 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;
+ERROR: Can't use string ("foo") as a SCALAR ref while "strict refs" in use at line 1.
+CONTEXT: PL/Perl anonymous code block
+-- 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;
+ERROR: Useless use of sort in void context at line 1.
+CONTEXT: PL/Perl anonymous code block
+-- 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();
+ myfuncs
+---------
+
+(1 row)
+
+-- 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();
+ERROR: cannot convert Perl array to non-array type text
+CONTEXT: PL/Perl function "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();
+ERROR: cannot convert Perl hash to non-composite type text
+CONTEXT: PL/Perl function "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();
+ERROR: cannot convert Perl hash to non-composite type text
+CONTEXT: PL/Perl function "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();
+ text_scalarref
+----------------
+ str
+(1 row)
+
+-- 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);
+ self_modify
+-------------
+ 84
+(1 row)
+
+SELECT self_modify(42);
+ self_modify
+-------------
+ 126
+(1 row)
+
diff --git a/src/pl/plperl/expected/plperl_array.out b/src/pl/plperl/expected/plperl_array.out
new file mode 100644
index 0000000..bd04a06
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_array.out
@@ -0,0 +1,276 @@
+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: malformed array literal: "{{{1,2,3}, {4,5,6,7}}, {{7,8,9}, {10, 11, 12}}}"
+LINE 1: select plperl_sum_array('{{{1,2,3}, {4,5,6,7}}, {{7,8,9}, {1...
+ ^
+DETAIL: Multidimensional arrays must have sub-arrays with matching dimensions.
+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)
+
+-- 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}}');
+ plperl_arrays_inout_l
+-----------------------
+ {{1},{2},{3}}
+(1 row)
+
+-- 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();
+ plperl_md_array_out
+---------------------
+ {{a},{b},{c}}
+(1 row)
+
+CREATE OR REPLACE FUNCTION plperl_md_array_out() RETURNS text[] AS $$
+ return [[], []];
+$$ LANGUAGE plperl;
+select plperl_md_array_out();
+ plperl_md_array_out
+---------------------
+ {}
+(1 row)
+
+CREATE OR REPLACE FUNCTION plperl_md_array_out() RETURNS text[] AS $$
+ return [[], [1]];
+$$ LANGUAGE plperl;
+select plperl_md_array_out(); -- fail
+ERROR: multidimensional arrays must have array expressions with matching dimensions
+CONTEXT: PL/Perl function "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
+ERROR: multidimensional arrays must have array expressions with matching dimensions
+CONTEXT: PL/Perl function "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
+ERROR: multidimensional arrays must have array expressions with matching dimensions
+CONTEXT: PL/Perl function "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
+ERROR: multidimensional arrays must have array expressions with matching dimensions
+CONTEXT: PL/Perl function "plperl_md_array_out"
+-- 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)
+
diff --git a/src/pl/plperl/expected/plperl_call.out b/src/pl/plperl/expected/plperl_call.out
new file mode 100644
index 0000000..a08b9ff
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_call.out
@@ -0,0 +1,72 @@
+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;
+ a
+----
+ 55
+(1 row)
+
+-- output arguments
+CREATE PROCEDURE test_proc5(INOUT a text)
+LANGUAGE plperl
+AS $$
+my ($a) = @_;
+return { a => "$a+$a" };
+$$;
+CALL test_proc5('abc');
+ a
+---------
+ abc+abc
+(1 row)
+
+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);
+ b | c
+---+---
+ 6 | 8
+(1 row)
+
+-- 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
+$$;
+NOTICE: a: 10, b:
+NOTICE: _a: 10, _b: 20
+DROP PROCEDURE test_proc1;
+DROP PROCEDURE test_proc2;
+DROP PROCEDURE test_proc3;
+DROP TABLE test1;
diff --git a/src/pl/plperl/expected/plperl_elog.out b/src/pl/plperl/expected/plperl_elog.out
new file mode 100644
index 0000000..a6d35cb
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_elog.out
@@ -0,0 +1,112 @@
+-- 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');
+NOTICE: explicit elog
+ perl_elog
+-----------
+
+(1 row)
+
+create or replace function perl_warn(text) returns void language plperl as $$
+
+ my $msg = shift;
+ warn($msg);
+
+$$;
+select perl_warn('implicit elog via warn');
+WARNING: implicit elog via warn at line 4.
+ perl_warn
+-----------
+
+(1 row)
+
+-- 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';
+
+$$;
+ERROR: Global symbol "$global" requires explicit package name at line 3.
+Global symbol "$other_global" requires explicit package name at line 4.
+CONTEXT: compilation of PL/Perl function "uses_global"
+select uses_global();
+ERROR: function uses_global() does not exist
+LINE 1: select uses_global();
+ ^
+HINT: No function matches the given name and argument types. You might need to add explicit type casts.
+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();
+ uses_global
+--------------------
+ uses_global worked
+(1 row)
+
+-- make sure we don't choke on readonly values
+do language plperl $$ elog(NOTICE, ${^TAINT}); $$;
+NOTICE: 0
+-- test recovery after "die"
+create or replace function just_die() returns void language plperl AS $$
+die "just die";
+$$;
+select just_die();
+ERROR: just die at line 2.
+CONTEXT: PL/Perl function "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();
+NOTICE: caught die
+ die_caller
+------------
+ 1
+(1 row)
+
+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();
+NOTICE: caught die
+NOTICE: caught die
+ indirect_die_caller
+---------------------
+ 2
+(1 row)
+
+-- 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();
+ERROR: this message contains a no-break space at line 2.
+CONTEXT: PL/Perl function "error_with_nbsp"
diff --git a/src/pl/plperl/expected/plperl_elog_1.out b/src/pl/plperl/expected/plperl_elog_1.out
new file mode 100644
index 0000000..85aa460
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_elog_1.out
@@ -0,0 +1,112 @@
+-- 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');
+NOTICE: explicit elog
+ perl_elog
+-----------
+
+(1 row)
+
+create or replace function perl_warn(text) returns void language plperl as $$
+
+ my $msg = shift;
+ warn($msg);
+
+$$;
+select perl_warn('implicit elog via warn');
+WARNING: implicit elog via warn at line 4.
+ perl_warn
+-----------
+
+(1 row)
+
+-- 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';
+
+$$;
+ERROR: Global symbol "$global" requires explicit package name (did you forget to declare "my $global"?) at line 3.
+Global symbol "$other_global" requires explicit package name (did you forget to declare "my $other_global"?) at line 4.
+CONTEXT: compilation of PL/Perl function "uses_global"
+select uses_global();
+ERROR: function uses_global() does not exist
+LINE 1: select uses_global();
+ ^
+HINT: No function matches the given name and argument types. You might need to add explicit type casts.
+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();
+ uses_global
+--------------------
+ uses_global worked
+(1 row)
+
+-- make sure we don't choke on readonly values
+do language plperl $$ elog(NOTICE, ${^TAINT}); $$;
+NOTICE: 0
+-- test recovery after "die"
+create or replace function just_die() returns void language plperl AS $$
+die "just die";
+$$;
+select just_die();
+ERROR: just die at line 2.
+CONTEXT: PL/Perl function "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();
+NOTICE: caught die
+ die_caller
+------------
+ 1
+(1 row)
+
+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();
+NOTICE: caught die
+NOTICE: caught die
+ indirect_die_caller
+---------------------
+ 2
+(1 row)
+
+-- 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();
+ERROR: this message contains a no-break space at line 2.
+CONTEXT: PL/Perl function "error_with_nbsp"
diff --git a/src/pl/plperl/expected/plperl_init.out b/src/pl/plperl/expected/plperl_init.out
new file mode 100644
index 0000000..4b7e925
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_init.out
@@ -0,0 +1,40 @@
+-- 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;
+ plperl.on_plperl_init
+------------------------
+ system("/nonesuch");
+(1 row)
+
+DO $$ warn 42 $$ language plperl;
+ERROR: 'system' trapped by operation mask at line 1.
+CONTEXT: while executing plperl.on_plperl_init
+PL/Perl anonymous code block
+--
+-- 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';
+WARNING: permission denied to set parameter "plperl.on_plperl_init"
+SHOW plperl.on_plperl_init;
+ plperl.on_plperl_init
+-----------------------
+
+(1 row)
+
+DO $$ warn 42 $$ language plperl;
+WARNING: 42 at line 1.
+-- 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';
+ERROR: permission denied to set parameter "plperl.on_plperl_init"
+RESET ROLE;
+DROP ROLE regress_plperl_user;
diff --git a/src/pl/plperl/expected/plperl_lc.out b/src/pl/plperl/expected/plperl_lc.out
new file mode 100644
index 0000000..4f8c08f
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_lc.out
@@ -0,0 +1,10 @@
+--
+-- 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();
+ERROR: invalid byte sequence for encoding "UTF8": 0x00
+CONTEXT: PL/Perl function "perl_zerob"
diff --git a/src/pl/plperl/expected/plperl_lc_1.out b/src/pl/plperl/expected/plperl_lc_1.out
new file mode 100644
index 0000000..022c3e2
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_lc_1.out
@@ -0,0 +1,10 @@
+--
+-- 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();
+ERROR: invalid byte sequence for encoding "SQL_ASCII": 0x00
+CONTEXT: PL/Perl function "perl_zerob"
diff --git a/src/pl/plperl/expected/plperl_plperlu.out b/src/pl/plperl/expected/plperl_plperlu.out
new file mode 100644
index 0000000..2be955f
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_plperlu.out
@@ -0,0 +1,91 @@
+-- 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)
+ERROR: syntax error at or near "invalid" at line 4.
+CONTEXT: PL/Perl function "bar"
+SELECT * FROM foo(); -- used to cause backend crash (after switching to plperlu)
+ERROR: syntax error at or near "invalid" at line 4. at line 2.
+CONTEXT: PL/Perl function "foo"
+-- 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');
+ foo
+-----
+ hey
+(1 row)
+
+create or replace function foo(text) returns text language plperlu as 'shift';
+select foo('hey');
+ foo
+-----
+ hey
+(1 row)
+
+create or replace function foo(text) returns text language plperl as 'shift';
+select foo('hey');
+ foo
+-----
+ hey
+(1 row)
+
+-- plperlu first
+create or replace function bar(text) returns text language plperlu as 'shift';
+select bar('hey');
+ bar
+-----
+ hey
+(1 row)
+
+create or replace function bar(text) returns text language plperl as 'shift';
+select bar('hey');
+ bar
+-----
+ hey
+(1 row)
+
+create or replace function bar(text) returns text language plperlu as 'shift';
+select bar('hey');
+ bar
+-----
+ hey
+(1 row)
+
+--
+-- 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;
+$$;
+ERROR: Unable to load Errno.pm into plperl at line 2.
+BEGIN failed--compilation aborted at line 2.
+CONTEXT: compilation of PL/Perl function "use_plperl"
+-- make sure our overloaded require op gets restored/set correctly
+select use_plperlu();
+ use_plperlu
+-------------
+
+(1 row)
+
+CREATE OR REPLACE FUNCTION use_plperl() RETURNS void LANGUAGE plperl
+AS $$
+use Errno;
+$$;
+ERROR: Unable to load Errno.pm into plperl at line 2.
+BEGIN failed--compilation aborted at line 2.
+CONTEXT: compilation of PL/Perl function "use_plperl"
diff --git a/src/pl/plperl/expected/plperl_setup.out b/src/pl/plperl/expected/plperl_setup.out
new file mode 100644
index 0000000..5537a95
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_setup.out
@@ -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
+ERROR: permission denied to create extension "plperl"
+HINT: Must have CREATE privilege on current database to create this extension.
+CREATE EXTENSION plperlu; -- fail
+ERROR: permission denied to create extension "plperlu"
+HINT: Must be superuser to create this extension.
+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
+ERROR: permission denied to create extension "plperlu"
+HINT: Must be superuser to create this extension.
+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();
+ foo1
+------
+ 1
+(1 row)
+
+-- 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
+ERROR: permission denied for language plperl
+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();
+ foo2
+------
+ 2
+(1 row)
+
+SET ROLE regress_plperl_user1;
+-- Should be able to drop the extension, but not the language per se
+DROP LANGUAGE plperl CASCADE;
+ERROR: cannot drop language plperl because extension plperl requires it
+HINT: You can drop extension plperl instead.
+DROP EXTENSION plperl CASCADE;
+NOTICE: drop cascades to 2 other objects
+DETAIL: drop cascades to function foo1()
+drop cascades to function foo2()
+-- 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/expected/plperl_shared.out b/src/pl/plperl/expected/plperl_shared.out
new file mode 100644
index 0000000..464e220
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_shared.out
@@ -0,0 +1,56 @@
+-- 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');
+ setme
+-------
+
+(1 row)
+
+select getme('ourkey');
+ getme
+--------
+ ourval
+(1 row)
+
+select getme('on_init');
+ getme
+-------
+ 42
+(1 row)
+
+-- 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();
+ perl_shared
+-------------
+
+(1 row)
+
+select perl_shared();
+ perl_shared
+-------------
+ 1
+(1 row)
+
diff --git a/src/pl/plperl/expected/plperl_transaction.out b/src/pl/plperl/expected/plperl_transaction.out
new file mode 100644
index 0000000..da4283c
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_transaction.out
@@ -0,0 +1,244 @@
+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;
+ a | b
+---+---
+ 0 |
+ 2 |
+ 4 |
+ 6 |
+ 8 |
+(5 rows)
+
+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;
+ a | b
+---+---
+ 0 |
+ 2 |
+ 4 |
+ 6 |
+ 8 |
+(5 rows)
+
+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();
+ERROR: invalid transaction termination at line 5.
+CONTEXT: PL/Perl function "transaction_test2"
+SELECT * FROM test1;
+ a | b
+---+---
+(0 rows)
+
+-- 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();
+ERROR: invalid transaction termination at line 5. at line 2.
+CONTEXT: PL/Perl function "transaction_test3"
+SELECT * FROM test1;
+ a | b
+---+---
+(0 rows)
+
+-- 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();
+ERROR: invalid transaction termination at line 1. at line 2.
+CONTEXT: PL/Perl function "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;
+ a | b
+---+---
+ 0 |
+ 1 |
+ 2 |
+ 3 |
+ 4 |
+(5 rows)
+
+-- check that this doesn't leak a holdable portal
+SELECT * FROM pg_cursors;
+ name | statement | is_holdable | is_binary | is_scrollable | creation_time
+------+-----------+-------------+-----------+---------------+---------------
+(0 rows)
+
+-- 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();
+}
+$$;
+ERROR: division by zero at line 5.
+CONTEXT: PL/Perl anonymous code block
+SELECT * FROM test1;
+ a | b
+-----+---
+ -6 |
+ -12 |
+(2 rows)
+
+SELECT * FROM pg_cursors;
+ name | statement | is_holdable | is_binary | is_scrollable | creation_time
+------+-----------+-------------+-----------+---------------+---------------
+(0 rows)
+
+-- 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;
+ a | b
+---+---
+(0 rows)
+
+SELECT * FROM pg_cursors;
+ name | statement | is_holdable | is_binary | is_scrollable | creation_time
+------+-----------+-------------+-----------+---------------+---------------
+(0 rows)
+
+-- 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;
+ a | b
+---+---
+ 0 |
+ 2 |
+ 4 |
+(3 rows)
+
+SELECT * FROM pg_cursors;
+ name | statement | is_holdable | is_binary | is_scrollable | creation_time
+------+-----------+-------------+-----------+---------------+---------------
+(0 rows)
+
+-- 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');
+$$;
+ERROR: insert or update on table "testfk" violates foreign key constraint "testfk_f1_fkey" at line 4.
+CONTEXT: PL/Perl anonymous code block
+SELECT * FROM testpk;
+ id
+----
+(0 rows)
+
+SELECT * FROM testfk;
+ f1
+----
+(0 rows)
+
+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)");
+$$;
+INFO: insert or update on table "testfk" violates foreign key constraint "testfk_f1_fkey" at line 5.
+
+SELECT * FROM testpk;
+ id
+----
+ 1
+(1 row)
+
+SELECT * FROM testfk;
+ f1
+----
+ 1
+(1 row)
+
+DROP TABLE test1;
+DROP TABLE test2;
diff --git a/src/pl/plperl/expected/plperl_trigger.out b/src/pl/plperl/expected/plperl_trigger.out
new file mode 100644
index 0000000..d4879e2
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_trigger.out
@@ -0,0 +1,392 @@
+-- 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)")');
+NOTICE: $_TD->{argc} = '2'
+NOTICE: $_TD->{args} = ['23', 'skidoo']
+NOTICE: $_TD->{event} = 'INSERT'
+NOTICE: $_TD->{level} = 'ROW'
+NOTICE: $_TD->{name} = 'show_trigger_data_trig'
+NOTICE: $_TD->{new} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'insert'}
+NOTICE: $_TD->{relid} = 'bogus:12345'
+NOTICE: $_TD->{relname} = 'trigger_test'
+NOTICE: $_TD->{table_name} = 'trigger_test'
+NOTICE: $_TD->{table_schema} = 'public'
+NOTICE: $_TD->{when} = 'BEFORE'
+update trigger_test set v = 'update' where i = 1;
+NOTICE: $_TD->{argc} = '2'
+NOTICE: $_TD->{args} = ['23', 'skidoo']
+NOTICE: $_TD->{event} = 'UPDATE'
+NOTICE: $_TD->{level} = 'ROW'
+NOTICE: $_TD->{name} = 'show_trigger_data_trig'
+NOTICE: $_TD->{new} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'update'}
+NOTICE: $_TD->{old} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'insert'}
+NOTICE: $_TD->{relid} = 'bogus:12345'
+NOTICE: $_TD->{relname} = 'trigger_test'
+NOTICE: $_TD->{table_name} = 'trigger_test'
+NOTICE: $_TD->{table_schema} = 'public'
+NOTICE: $_TD->{when} = 'BEFORE'
+delete from trigger_test;
+NOTICE: $_TD->{argc} = '2'
+NOTICE: $_TD->{args} = ['23', 'skidoo']
+NOTICE: $_TD->{event} = 'DELETE'
+NOTICE: $_TD->{level} = 'ROW'
+NOTICE: $_TD->{name} = 'show_trigger_data_trig'
+NOTICE: $_TD->{old} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'update'}
+NOTICE: $_TD->{relid} = 'bogus:12345'
+NOTICE: $_TD->{relname} = 'trigger_test'
+NOTICE: $_TD->{table_name} = 'trigger_test'
+NOTICE: $_TD->{table_schema} = 'public'
+NOTICE: $_TD->{when} = 'BEFORE'
+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);
+NOTICE: $_TD->{argc} = '0'
+NOTICE: $_TD->{event} = 'INSERT'
+NOTICE: $_TD->{level} = 'ROW'
+NOTICE: $_TD->{name} = 'show_trigger_data_trig_before'
+NOTICE: $_TD->{new} = {'i' => '1'}
+NOTICE: $_TD->{relid} = 'bogus:12345'
+NOTICE: $_TD->{relname} = 'trigger_test_generated'
+NOTICE: $_TD->{table_name} = 'trigger_test_generated'
+NOTICE: $_TD->{table_schema} = 'public'
+NOTICE: $_TD->{when} = 'BEFORE'
+NOTICE: $_TD->{argc} = '0'
+NOTICE: $_TD->{event} = 'INSERT'
+NOTICE: $_TD->{level} = 'ROW'
+NOTICE: $_TD->{name} = 'show_trigger_data_trig_after'
+NOTICE: $_TD->{new} = {'i' => '1', 'j' => '2'}
+NOTICE: $_TD->{relid} = 'bogus:12345'
+NOTICE: $_TD->{relname} = 'trigger_test_generated'
+NOTICE: $_TD->{table_name} = 'trigger_test_generated'
+NOTICE: $_TD->{table_schema} = 'public'
+NOTICE: $_TD->{when} = 'AFTER'
+update trigger_test_generated set i = 11 where i = 1;
+NOTICE: $_TD->{argc} = '0'
+NOTICE: $_TD->{event} = 'UPDATE'
+NOTICE: $_TD->{level} = 'ROW'
+NOTICE: $_TD->{name} = 'show_trigger_data_trig_before'
+NOTICE: $_TD->{new} = {'i' => '11'}
+NOTICE: $_TD->{old} = {'i' => '1', 'j' => '2'}
+NOTICE: $_TD->{relid} = 'bogus:12345'
+NOTICE: $_TD->{relname} = 'trigger_test_generated'
+NOTICE: $_TD->{table_name} = 'trigger_test_generated'
+NOTICE: $_TD->{table_schema} = 'public'
+NOTICE: $_TD->{when} = 'BEFORE'
+NOTICE: $_TD->{argc} = '0'
+NOTICE: $_TD->{event} = 'UPDATE'
+NOTICE: $_TD->{level} = 'ROW'
+NOTICE: $_TD->{name} = 'show_trigger_data_trig_after'
+NOTICE: $_TD->{new} = {'i' => '11', 'j' => '22'}
+NOTICE: $_TD->{old} = {'i' => '1', 'j' => '2'}
+NOTICE: $_TD->{relid} = 'bogus:12345'
+NOTICE: $_TD->{relname} = 'trigger_test_generated'
+NOTICE: $_TD->{table_name} = 'trigger_test_generated'
+NOTICE: $_TD->{table_schema} = 'public'
+NOTICE: $_TD->{when} = 'AFTER'
+delete from trigger_test_generated;
+NOTICE: $_TD->{argc} = '0'
+NOTICE: $_TD->{event} = 'DELETE'
+NOTICE: $_TD->{level} = 'ROW'
+NOTICE: $_TD->{name} = 'show_trigger_data_trig_before'
+NOTICE: $_TD->{old} = {'i' => '11', 'j' => '22'}
+NOTICE: $_TD->{relid} = 'bogus:12345'
+NOTICE: $_TD->{relname} = 'trigger_test_generated'
+NOTICE: $_TD->{table_name} = 'trigger_test_generated'
+NOTICE: $_TD->{table_schema} = 'public'
+NOTICE: $_TD->{when} = 'BEFORE'
+NOTICE: $_TD->{argc} = '0'
+NOTICE: $_TD->{event} = 'DELETE'
+NOTICE: $_TD->{level} = 'ROW'
+NOTICE: $_TD->{name} = 'show_trigger_data_trig_after'
+NOTICE: $_TD->{old} = {'i' => '11', 'j' => '22'}
+NOTICE: $_TD->{relid} = 'bogus:12345'
+NOTICE: $_TD->{relname} = 'trigger_test_generated'
+NOTICE: $_TD->{table_name} = 'trigger_test_generated'
+NOTICE: $_TD->{table_schema} = 'public'
+NOTICE: $_TD->{when} = 'AFTER'
+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)")');
+NOTICE: $_TD->{argc} = '2'
+NOTICE: $_TD->{args} = ['24', 'skidoo view']
+NOTICE: $_TD->{event} = 'INSERT'
+NOTICE: $_TD->{level} = 'ROW'
+NOTICE: $_TD->{name} = 'show_trigger_data_trig'
+NOTICE: $_TD->{new} = {'foo' => {'rfoo' => {'i' => '2'}}, 'i' => '2', 'v' => 'insert'}
+NOTICE: $_TD->{relid} = 'bogus:12345'
+NOTICE: $_TD->{relname} = 'trigger_test_view'
+NOTICE: $_TD->{table_name} = 'trigger_test_view'
+NOTICE: $_TD->{table_schema} = 'public'
+NOTICE: $_TD->{when} = 'INSTEAD OF'
+update trigger_test_view set v = 'update', foo = '("(3)")' where i = 1;
+NOTICE: $_TD->{argc} = '2'
+NOTICE: $_TD->{args} = ['24', 'skidoo view']
+NOTICE: $_TD->{event} = 'UPDATE'
+NOTICE: $_TD->{level} = 'ROW'
+NOTICE: $_TD->{name} = 'show_trigger_data_trig'
+NOTICE: $_TD->{new} = {'foo' => {'rfoo' => {'i' => '3'}}, 'i' => '1', 'v' => 'update'}
+NOTICE: $_TD->{old} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'insert'}
+NOTICE: $_TD->{relid} = 'bogus:12345'
+NOTICE: $_TD->{relname} = 'trigger_test_view'
+NOTICE: $_TD->{table_name} = 'trigger_test_view'
+NOTICE: $_TD->{table_schema} = 'public'
+NOTICE: $_TD->{when} = 'INSTEAD OF'
+delete from trigger_test_view;
+NOTICE: $_TD->{argc} = '2'
+NOTICE: $_TD->{args} = ['24', 'skidoo view']
+NOTICE: $_TD->{event} = 'DELETE'
+NOTICE: $_TD->{level} = 'ROW'
+NOTICE: $_TD->{name} = 'show_trigger_data_trig'
+NOTICE: $_TD->{old} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'insert'}
+NOTICE: $_TD->{relid} = 'bogus:12345'
+NOTICE: $_TD->{relname} = 'trigger_test_view'
+NOTICE: $_TD->{table_name} = 'trigger_test_view'
+NOTICE: $_TD->{table_schema} = 'public'
+NOTICE: $_TD->{when} = 'INSTEAD OF'
+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;
+ 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 | 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)
+
+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;
+ 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)")
+ 20000 | child |
+ 10000 | top |
+(6 rows)
+
+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;
+ i | v | foo
+---+----------+---------
+ 4 | immortal | ("(4)")
+(1 row)
+
+CREATE FUNCTION direct_trigger() RETURNS trigger AS $$
+ return;
+$$ LANGUAGE plperl;
+SELECT direct_trigger();
+ERROR: trigger functions can only be called as triggers
+CONTEXT: compilation of PL/Perl function "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';
+INFO: old: 1 -> a
+INFO: new: 1 -> 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;$$;
+NOTICE: perlsnitch: ddl_command_start CREATE FUNCTION
+NOTICE: perlsnitch: ddl_command_end CREATE FUNCTION
+alter function foobar() cost 77;
+NOTICE: perlsnitch: ddl_command_start ALTER FUNCTION
+NOTICE: perlsnitch: ddl_command_end ALTER FUNCTION
+drop function foobar();
+NOTICE: perlsnitch: ddl_command_start DROP FUNCTION
+NOTICE: perlsnitch: ddl_command_end DROP FUNCTION
+create table foo();
+NOTICE: perlsnitch: ddl_command_start CREATE TABLE
+NOTICE: perlsnitch: ddl_command_end CREATE TABLE
+drop table foo;
+NOTICE: perlsnitch: ddl_command_start DROP TABLE
+NOTICE: perlsnitch: ddl_command_end DROP TABLE
+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);
+ERROR: cannot set generated column "j"
+CONTEXT: PL/Perl function "generated_test_func1"
+SELECT * FROM trigger_test_generated;
+ i | j
+---+---
+(0 rows)
+
diff --git a/src/pl/plperl/expected/plperl_util.out b/src/pl/plperl/expected/plperl_util.out
new file mode 100644
index 0000000..698a8a1
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_util.out
@@ -0,0 +1,198 @@
+-- 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();
+ perl_quote_literal
+--------------------
+ undef:
+ foo: 'foo'
+ a'b: 'a''b'
+ a"b: 'a"b'
+ c''d: 'c''''d'
+ e\f: E'e\\f'
+ : ''
+(7 rows)
+
+-- 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();
+ perl_quote_nullable
+---------------------
+ undef: NULL
+ foo: 'foo'
+ a'b: 'a''b'
+ a"b: 'a"b'
+ c''d: 'c''''d'
+ e\f: E'e\\f'
+ : ''
+(7 rows)
+
+-- 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();
+ perl_quote_ident
+------------------
+ undef: ""
+ foo: foo
+ a'b: "a'b"
+ a"b: "a""b"
+ c''d: "c''d"
+ e\f: "e\f"
+ g.h: "g.h"
+ : ""
+(8 rows)
+
+-- 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();
+ perl_decode_bytea
+-------------------
+ undef:
+ foo: foo
+ a\047b: a'b
+ :
+(4 rows)
+
+-- 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();
+ perl_encode_bytea
+-------------------
+ \x
+ \x40
+ \x400140
+ \x400040
+ \x
+(5 rows)
+
+-- 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();
+ perl_encode_array_literal
+---------------------------
+
+ 0
+ 42
+ {}
+ {"0"}
+ {"1", "2", "3", "4", "5"}
+ {{}}
+ {{"1", "2", {"3"}}, "4"}
+ {}
+ {"0"}
+ {"1"|"2"|"3"|"4"|"5"}
+ {{}}
+ {{"1"|"2"|{"3"}}|"4"}
+(13 rows)
+
+-- 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();
+ perl_encode_array_constructor
+-----------------------------------------
+ NULL
+ '0'
+ '42'
+ ARRAY[]
+ ARRAY['0']
+ ARRAY['1', '2', '3', '4', '5']
+ ARRAY[ARRAY[]]
+ ARRAY[ARRAY['1', '2', ARRAY['3']], '4']
+(8 rows)
+
+-- 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();
+ perl_looks_like_number
+------------------------
+ undef is undef
+ 'foo': not number
+ '0': number
+ '1': number
+ '1.3': number
+ '+3.e-4': number
+ '42 x': not number
+ '99 ': number
+ ' 99': number
+ ' ': not 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 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();
+ perl_encode_typed_literal
+-----------------------------------------------
+
+ {{1,2,3},{3,2,1},{1,3,2}}
+ (1,"{PL,/,Perl}")
+ ("{""(9,{PostgreSQL})"",""(1,{Postgres})""}")
+ (1,"{PL,/,Perl}")
+(5 rows)
+
+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
+ERROR: value for domain perl_foo_pos violates check constraint "perl_foo_pos_check"
+CONTEXT: PL/Perl function "perl_encode_typed_literal"
diff --git a/src/pl/plperl/expected/plperlu.out b/src/pl/plperl/expected/plperlu.out
new file mode 100644
index 0000000..a3edb38
--- /dev/null
+++ b/src/pl/plperl/expected/plperlu.out
@@ -0,0 +1,15 @@
+-- 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;
+WARNING: 42 at line 1.
+--
+-- 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;
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-12 11:27:05 +0000