summaryrefslogtreecommitdiffstats
path: root/src/pl/plperl/sql
diff options
context:
space:
mode:
Diffstat (limited to 'src/pl/plperl/sql')
-rw-r--r--src/pl/plperl/sql/plperl.sql523
-rw-r--r--src/pl/plperl/sql/plperl_array.sql208
-rw-r--r--src/pl/plperl/sql/plperl_call.sql78
-rw-r--r--src/pl/plperl/sql/plperl_elog.sql93
-rw-r--r--src/pl/plperl/sql/plperl_end.sql29
-rw-r--r--src/pl/plperl/sql/plperl_init.sql41
-rw-r--r--src/pl/plperl/sql/plperl_lc.sql8
-rw-r--r--src/pl/plperl/sql/plperl_plperlu.sql58
-rw-r--r--src/pl/plperl/sql/plperl_setup.sql73
-rw-r--r--src/pl/plperl/sql/plperl_shared.sql41
-rw-r--r--src/pl/plperl/sql/plperl_transaction.sql195
-rw-r--r--src/pl/plperl/sql/plperl_trigger.sql259
-rw-r--r--src/pl/plperl/sql/plperl_util.sql121
-rw-r--r--src/pl/plperl/sql/plperlu.sql17
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;
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-04 17:41:41 +0000