Mailing-List: contact commits-help@hawq.incubator.apache.org; run by ezmlm
Precedence: bulk
Reply-To: dev@hawq.incubator.apache.org
Content-Type: text/plain; charset="us-ascii"
MIME-Version: 1.0
Content-Transfer-Encoding: 8bit
From: huor@apache.org
To: commits@hawq.incubator.apache.org
Date: Fri, 20 May 2016 10:21:05 -0000
Message-Id: <18ec1509badf4d098b0ad8dcca5a79df@git.apache.org>
Subject: [1/5] incubator-hawq git commit: HAWQ-744. Add plperl code
archived-at: Fri, 20 May 2016 10:21:15 -0000

Repository: incubator-hawq
Updated Branches:
  refs/heads/master 970edfee1 -> 120ee70ba


http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/sql/plperl.sql
----------------------------------------------------------------------
diff --git a/src/pl/plperl/sql/plperl.sql b/src/pl/plperl/sql/plperl.sql
new file mode 100644
index 0000000..5d6e172
--- /dev/null
+++ b/src/pl/plperl/sql/plperl.sql
@@ -0,0 +1,388 @@
+--
+-- 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();
+
+
+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();
+
+--
+-- 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');
+
+--
+-- 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)');
+

http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/sql/plperl_array.sql
----------------------------------------------------------------------
diff --git a/src/pl/plperl/sql/plperl_array.sql b/src/pl/plperl/sql/plperl_array.sql
new file mode 100644
index 0000000..492b6b9
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_array.sql
@@ -0,0 +1,113 @@
+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!"}');
+
+-- 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);
+
+-- check arrays as out parameters
+CREATE OR REPLACE FUNCTION plperl_arrays_out(OUT INTEGER[]) AS $$
+	return [[1,2,3],[4,5,6]];
+$$ LANGUAGE plperl;
+
+select plperl_arrays_out();
+
+-- check that we can return the array we passed in
+CREATE OR REPLACE FUNCTION plperl_arrays_inout(INTEGER[]) returns INTEGER[] AS $$
+	return shift;
+$$ LANGUAGE plperl;
+
+select plperl_arrays_inout('{{1}, {2}, {3}}');
+
+-- make sure setof works
+create or replace function perl_setof_array(integer[]) returns setof integer[] language plperl as $$
+	my $arr = shift;
+	for my $r (@$arr) {
+		return_next $r;
+	}
+	return undef;
+$$;
+
+select perl_setof_array('{{1}, {2}, {3}}');

http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/sql/plperl_elog.sql
----------------------------------------------------------------------
diff --git a/src/pl/plperl/sql/plperl_elog.sql b/src/pl/plperl/sql/plperl_elog.sql
new file mode 100644
index 0000000..4f1c014
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_elog.sql
@@ -0,0 +1,45 @@
+-- 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();

http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/sql/plperl_end.sql
----------------------------------------------------------------------
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;

http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/sql/plperl_init.sql
----------------------------------------------------------------------
diff --git a/src/pl/plperl/sql/plperl_init.sql b/src/pl/plperl/sql/plperl_init.sql
new file mode 100644
index 0000000..993b641
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_init.sql
@@ -0,0 +1,9 @@
+-- test plperl.on_plperl_init errors are fatal
+
+-- Avoid need for custom_variable_classes = 'plperl'
+LOAD 'plperl';
+
+SET SESSION plperl.on_plperl_init = ' system("/nonesuch") ';
+
+SHOW plperl.on_plperl_init;
+

http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/sql/plperl_plperlu.sql
----------------------------------------------------------------------
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;
+$$;

http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/sql/plperl_shared.sql
----------------------------------------------------------------------
diff --git a/src/pl/plperl/sql/plperl_shared.sql b/src/pl/plperl/sql/plperl_shared.sql
new file mode 100644
index 0000000..3e99e59
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_shared.sql
@@ -0,0 +1,22 @@
+-- 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');
+
+

http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/sql/plperl_stress.sql
----------------------------------------------------------------------
diff --git a/src/pl/plperl/sql/plperl_stress.sql b/src/pl/plperl/sql/plperl_stress.sql
new file mode 100644
index 0000000..c0f3c85
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_stress.sql
@@ -0,0 +1,54 @@
+--Test to return large scale data over a table with large number of rows,
+--and each result set is of different size.    
+CREATE TABLE test (a int) DISTRIBUTED RANDOMLY;
+
+
+CREATE TABLE table10000 AS SELECT * from generate_series(1,10000) DISTRIBUTED RANDOMLY;
+
+
+-- Create Function to return setof random number of integers 
+--
+CREATE OR REPLACE FUNCTION setof_int()
+RETURNS SETOF INTEGER AS $$
+    my $range = 20000;
+    my $random_number = int(rand($range));
+    foreach (1..$random_number) {
+        return_next(1);
+    }
+    return undef;
+$$ LANGUAGE plperl;
+
+
+--(1) Return " setof integer " with ten thousands of tuplestores and each tuplestore containing  random number(1…20000) of integers, 
+--    so totally handle about 400 Megabytes. 
+CREATE TABLE setofIntRes AS SELECT setof_int() from table10000 DISTRIBUTED RANDOMLY;
+DROP TABLE setofIntRes;
+
+
+DROP FUNCTION setof_int();
+
+
+--Create Function to return setof random number of rows 
+--
+CREATE OR REPLACE FUNCTION setof_table_random ()
+RETURNS SETOF test AS $$
+    my $range = 20000;
+    my $random_number = int(rand($range));
+    foreach (1..$random_number) {
+        return_next({a=>1});
+    }
+    return undef;
+$$ LANGUAGE plperl;
+
+
+--(2) Return "setof table" with ten thousands of tuplestores and each tuplestore containing random number(1…20000) of rows(each row just has one int 
+--    column),so totally handle about  400 Megabytes.
+CREATE TABLE setofTableRes AS SELECT setof_table_random() from table10000 DISTRIBUTED RANDOMLY;
+DROP TABLE setofTableRes;
+
+
+DROP FUNCTION setof_table_random ();
+
+DROP TABLE test;
+
+DROP TABLE table10000;

http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/sql/plperl_trigger.sql
----------------------------------------------------------------------
diff --git a/src/pl/plperl/sql/plperl_trigger.sql b/src/pl/plperl/sql/plperl_trigger.sql
new file mode 100644
index 0000000..df6fdb2
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_trigger.sql
@@ -0,0 +1,133 @@
+-- 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
+) distributed by (i);
+
+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;
+
+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;
+
+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();

http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/sql/plperl_util.sql
----------------------------------------------------------------------
diff --git a/src/pl/plperl/sql/plperl_util.sql b/src/pl/plperl/sql/plperl_util.sql
new file mode 100644
index 0000000..ff3ff7d
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_util.sql
@@ -0,0 +1,101 @@
+-- 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_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 or replace function perl_encode_typed_literal() returns setof text language plperl as $$
+	return_next encode_typed_literal(undef, 'text');
+	return_next encode_typed_literal([[1,2,3],[3,2,1],[1,3,2]], 'integer[]');
+	return_next encode_typed_literal({a => 1, b => ['PL','/','Perl']}, 'perl_foo');
+	return_next encode_typed_literal({c => [{a => 9, b => ['PostgreSQL']}, {b => ['Postgres'], a => 1}]}, 'perl_bar');
+$$;
+
+select perl_encode_typed_literal();

http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/sql/plperlu.sql
----------------------------------------------------------------------
diff --git a/src/pl/plperl/sql/plperlu.sql b/src/pl/plperl/sql/plperlu.sql
new file mode 100644
index 0000000..63cd7c4
--- /dev/null
+++ b/src/pl/plperl/sql/plperlu.sql
@@ -0,0 +1,16 @@
+-- Use ONLY plperlu tests here. For plperl/plerlu combined tests
+-- see plperl_plperlu.sql
+
+-- Avoid need for custom_variable_classes = 'plperl'
+LOAD 'plperl';
+
+-- Test plperl.on_plperlu_init gets run
+SET plperl.on_plperlu_init = '$_SHARED{init} = 42';
+
+--
+-- 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;

http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/text2macro.pl
----------------------------------------------------------------------
diff --git a/src/pl/plperl/text2macro.pl b/src/pl/plperl/text2macro.pl
new file mode 100644
index 0000000..88241e2
--- /dev/null
+++ b/src/pl/plperl/text2macro.pl
@@ -0,0 +1,100 @@
+# src/pl/plperl/text2macro.pl
+
+=head1 NAME
+
+text2macro.pl - convert text files into C string-literal macro definitions
+
+=head1 SYNOPSIS
+
+  text2macro [options] file ... > output.h
+
+Options:
+
+  --prefix=S   - add prefix S to the names of the macros
+  --name=S     - use S as the macro name (assumes only one file)
+  --strip=S    - don't include lines that match perl regex S
+
+=head1 DESCRIPTION
+
+Reads one or more text files and outputs a corresponding series of C
+pre-processor macro definitions. Each macro defines a string literal that
+contains the contents of the corresponding text file. The basename of the text
+file as capitalized and used as the name of the macro, along with an optional prefix.
+
+=cut
+
+use strict;
+use warnings;
+
+use Getopt::Long;
+
+GetOptions(
+	'prefix=s'  => \my $opt_prefix,
+	'name=s'    => \my $opt_name,
+	'strip=s'   => \my $opt_strip,
+	'selftest!' => sub { exit selftest() },
+) or exit 1;
+
+die "No text files specified"
+	unless @ARGV;
+
+print qq{
+/*
+ * DO NOT EDIT - THIS FILE IS AUTOGENERATED - CHANGES WILL BE LOST
+ * Written by $0 from @ARGV
+ */
+};
+
+for my $src_file (@ARGV) {
+
+	(my $macro = $src_file) =~ s/ .*? (\w+) (?:\.\w+) $/$1/x;
+
+	open my $src_fh, $src_file # not 3-arg form
+		or die "Can't open $src_file: $!";
+
+	printf qq{#define %s%s \\\n},
+		$opt_prefix || '',
+		($opt_name) ? $opt_name : uc $macro;
+	while (<$src_fh>) {
+		chomp;
+
+		next if $opt_strip and m/$opt_strip/o;
+
+		# escape the text to suite C string literal rules
+		s/\\/\\\\/g;
+		s/"/\\"/g;
+
+		printf qq{"%s\\n" \\\n}, $_;
+	}
+	print qq{""\n\n};
+}
+
+print "/* end */\n";
+
+exit 0;
+
+
+sub selftest {
+	my $tmp = "text2macro_tmp";
+	my $string = q{a '' '\\'' "" "\\"" "\\\\" "\\\\n" b};
+
+	open my $fh, ">$tmp.pl" or die;
+	print $fh $string;
+	close $fh;
+
+	system("perl $0 --name=X $tmp.pl > $tmp.c") == 0 or die;
+	open $fh, ">>$tmp.c";
+	print $fh "#include <stdio.h>\n";
+	print $fh "int main() { puts(X); return 0; }\n";
+	close $fh;
+	system("cat -n $tmp.c");
+
+	system("make $tmp") == 0 or die;
+	open $fh, "./$tmp |" or die;
+	my $result = <$fh>;
+	unlink <$tmp.*>;
+
+	warn "Test string: $string\n";
+	warn "Result     : $result";
+	die "Failed!" if $result ne "$string\n";
+}