You are viewing a plain text version of this content. The canonical link for it is here.
Posted to commits@hawq.apache.org by hu...@apache.org on 2016/05/20 10:21:05 UTC
[1/5] incubator-hawq git commit: HAWQ-744. Add plperl code
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\u202620000) 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\u202620000) 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";
+}
[4/5] incubator-hawq git commit: HAWQ-744. Add plperl code
Posted by hu...@apache.org.
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/plperl.c
----------------------------------------------------------------------
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
new file mode 100644
index 0000000..77525f2
--- /dev/null
+++ b/src/pl/plperl/plperl.c
@@ -0,0 +1,3778 @@
+/*
+ * Licensed to the Apache Software Foundation (ASF) under one
+ * or more contributor license agreements. See the NOTICE file
+ * distributed with this work for additional information
+ * regarding copyright ownership. The ASF licenses this file
+ * to you under the Apache License, Version 2.0 (the
+ * "License"); you may not use this file except in compliance
+ * with the License. You may obtain a copy of the License at
+ *
+ * http://www.apache.org/licenses/LICENSE-2.0
+ *
+ * Unless required by applicable law or agreed to in writing,
+ * software distributed under the License is distributed on an
+ * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
+ * KIND, either express or implied. See the License for the
+ * specific language governing permissions and limitations
+ * under the License.
+ */
+
+/**********************************************************************
+ * plperl.c - perl as a procedural language for PostgreSQL
+ *
+ * src/pl/plperl/plperl.c
+ *
+ **********************************************************************/
+
+#include "postgres.h"
+/* Defined by Perl */
+#undef _
+
+/* system stuff */
+#include <ctype.h>
+#include <fcntl.h>
+#include <unistd.h>
+#include <locale.h>
+
+/* postgreSQL stuff */
+#include "access/xact.h"
+#include "catalog/pg_language.h"
+#include "catalog/pg_proc.h"
+#include "catalog/pg_type.h"
+#include "commands/trigger.h"
+#include "executor/spi.h"
+#include "funcapi.h"
+#include "mb/pg_wchar.h"
+#include "miscadmin.h"
+#include "nodes/makefuncs.h"
+#include "parser/parse_type.h"
+#include "storage/ipc.h"
+#include "utils/builtins.h"
+#include "utils/fmgroids.h"
+#include "utils/guc.h"
+#include "utils/hsearch.h"
+#include "utils/lsyscache.h"
+#include "utils/memutils.h"
+#include "utils/syscache.h"
+#include "utils/typcache.h"
+
+/* define our text domain for translations */
+#undef TEXTDOMAIN
+#define TEXTDOMAIN PG_TEXTDOMAIN("plperl")
+
+/* perl stuff */
+#include "plperl.h"
+#include "plperl_helpers.h"
+
+/* string literal macros defining chunks of perl code */
+#include "perlchunks.h"
+/* defines PLPERL_SET_OPMASK */
+#include "plperl_opmask.h"
+
+EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
+EXTERN_C void boot_PostgreSQL__InServer__Util(pTHX_ CV *cv);
+EXTERN_C void boot_PostgreSQL__InServer__SPI(pTHX_ CV *cv);
+
+PG_MODULE_MAGIC;
+
+
+/**********************************************************************
+ * Information associated with a Perl interpreter. We have one interpreter
+ * that is used for all plperlu (untrusted) functions. For plperl (trusted)
+ * functions, there is a separate interpreter for each effective SQL userid.
+ * (This is needed to ensure that an unprivileged user can't inject Perl code
+ * that'll be executed with the privileges of some other SQL user.)
+ *
+ * The plperl_interp_desc structs are kept in a Postgres hash table indexed
+ * by userid OID, with OID 0 used for the single untrusted interpreter.
+ *
+ * We start out by creating a "held" interpreter, which we initialize
+ * only as far as we can do without deciding if it will be trusted or
+ * untrusted. Later, when we first need to run a plperl or plperlu
+ * function, we complete the initialization appropriately and move the
+ * PerlInterpreter pointer into the plperl_interp_hash hashtable. If after
+ * that we need more interpreters, we create them as needed if we can, or
+ * fail if the Perl build doesn't support multiple interpreters.
+ *
+ * The reason for all the dancing about with a held interpreter is to make
+ * it possible for people to preload a lot of Perl code at postmaster startup
+ * (using plperl.on_init) and then use that code in backends. Of course this
+ * will only work for the first interpreter created in any backend, but it's
+ * still useful with that restriction.
+ **********************************************************************/
+typedef struct plperl_interp_desc
+{
+ Oid user_id; /* Hash key (must be first!) */
+ PerlInterpreter *interp; /* The interpreter */
+ HTAB *query_hash; /* plperl_query_entry structs */
+} plperl_interp_desc;
+
+
+/**********************************************************************
+ * The information we cache about loaded procedures
+ **********************************************************************/
+typedef struct plperl_proc_desc
+{
+ char *proname; /* name of the sql function */
+ TransactionId fn_xmin;
+ CommandId fn_cmin;
+ plperl_interp_desc *interp; /* interpreter it's created in */
+ bool fn_readonly;
+ bool lanpltrusted;
+ bool fn_retistuple; /* true, if function returns tuple */
+ bool fn_retisset; /* true, if function returns set */
+ bool fn_retisarray; /* true if function returns array */
+ Oid result_oid; /* Oid of result type */
+ FmgrInfo result_in_func; /* I/O function and arg for result type */
+ Oid result_typioparam;
+ int nargs;
+ FmgrInfo arg_out_func[FUNC_MAX_ARGS];
+ bool arg_is_rowtype[FUNC_MAX_ARGS];
+ Oid arg_arraytype[FUNC_MAX_ARGS]; /* InvalidOid if not an array */
+ SV *reference;
+} plperl_proc_desc;
+
+/**********************************************************************
+ * For speedy lookup, we maintain a hash table mapping from
+ * function OID + trigger flag + user OID to plperl_proc_desc pointers.
+ * The reason the plperl_proc_desc struct isn't directly part of the hash
+ * entry is to simplify recovery from errors during compile_plperl_function.
+ *
+ * Note: if the same function is called by multiple userIDs within a session,
+ * there will be a separate plperl_proc_desc entry for each userID in the case
+ * of plperl functions, but only one entry for plperlu functions, because we
+ * set user_id = 0 for that case. If the user redeclares the same function
+ * from plperl to plperlu or vice versa, there might be multiple
+ * plperl_proc_ptr entries in the hashtable, but only one is valid.
+ **********************************************************************/
+typedef struct plperl_proc_key
+{
+ Oid proc_id; /* Function OID */
+
+ /*
+ * is_trigger is really a bool, but declare as Oid to ensure this struct
+ * contains no padding
+ */
+ Oid is_trigger; /* is it a trigger function? */
+ Oid user_id; /* User calling the function, or 0 */
+} plperl_proc_key;
+
+typedef struct plperl_proc_ptr
+{
+ plperl_proc_key proc_key; /* Hash key (must be first!) */
+ plperl_proc_desc *proc_ptr;
+} plperl_proc_ptr;
+
+/*
+ * The information we cache for the duration of a single call to a
+ * function.
+ */
+typedef struct plperl_call_data
+{
+ plperl_proc_desc *prodesc;
+ FunctionCallInfo fcinfo;
+ Tuplestorestate *tuple_store;
+ TupleDesc ret_tdesc;
+ AttInMetadata *attinmeta;
+ MemoryContext tmp_cxt;
+} plperl_call_data;
+
+/**********************************************************************
+ * The information we cache about prepared and saved plans
+ **********************************************************************/
+typedef struct plperl_query_desc
+{
+ char qname[24];
+ void *plan;
+ int nargs;
+ Oid *argtypes;
+ FmgrInfo *arginfuncs;
+ Oid *argtypioparams;
+} plperl_query_desc;
+
+/* hash table entry for query desc */
+
+typedef struct plperl_query_entry
+{
+ char query_name[NAMEDATALEN];
+ plperl_query_desc *query_data;
+} plperl_query_entry;
+
+/**********************************************************************
+ * Information for PostgreSQL - Perl array conversion.
+ **********************************************************************/
+typedef struct plperl_array_info
+{
+ int ndims;
+ bool elem_is_rowtype; /* 't' if element type is a rowtype */
+ Datum *elements;
+ bool *nulls;
+ int *nelems;
+ FmgrInfo proc;
+} plperl_array_info;
+
+/**********************************************************************
+ * Global data
+ **********************************************************************/
+
+static HTAB *plperl_interp_hash = NULL;
+static HTAB *plperl_proc_hash = NULL;
+static plperl_interp_desc *plperl_active_interp = NULL;
+
+/* If we have an unassigned "held" interpreter, it's stored here */
+static PerlInterpreter *plperl_held_interp = NULL;
+
+/* GUC variables */
+static bool plperl_use_strict = false;
+static char *plperl_on_init = NULL;
+static char *plperl_on_plperl_init = NULL;
+static char *plperl_on_plperlu_init = NULL;
+
+static bool plperl_ending = false;
+static OP *(*pp_require_orig) (pTHX) = NULL;
+static char plperl_opmask[MAXO];
+
+/* this is saved and restored by plperl_call_handler */
+static plperl_call_data *current_call_data = NULL;
+
+/**********************************************************************
+ * Forward declarations
+ **********************************************************************/
+Datum plperl_call_handler(PG_FUNCTION_ARGS);
+Datum plperl_validator(PG_FUNCTION_ARGS);
+Datum plperlu_call_handler(PG_FUNCTION_ARGS);
+Datum plperlu_validator(PG_FUNCTION_ARGS);
+
+/* inline functions are currently Postgres only */
+#undef INLINE_FUNCTION_SUPPORT
+#ifdef INLINE_FUNCTION_SUPPORT
+Datum plperl_inline_handler(PG_FUNCTION_ARGS);
+Datum plperlu_inline_handler(PG_FUNCTION_ARGS);
+static void plperl_inline_callback(void *arg);
+#endif
+
+void _PG_init(void);
+
+static PerlInterpreter *plperl_init_interp(void);
+static void plperl_destroy_interp(PerlInterpreter **);
+static void plperl_fini(int code, Datum arg);
+static void set_interp_require(bool trusted);
+
+static Datum plperl_func_handler(PG_FUNCTION_ARGS);
+static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
+
+static plperl_proc_desc *compile_plperl_function(Oid fn_oid, bool is_trigger);
+
+static SV *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc);
+static SV *plperl_hash_from_datum(Datum attr);
+static SV *plperl_ref_from_pg_array(Datum arg, Oid typid);
+static SV *split_array(plperl_array_info *info, int first, int last, int nest);
+static SV *make_array_ref(plperl_array_info *info, int first, int last);
+static SV *get_perl_array_ref(SV *sv);
+static Datum plperl_sv_to_datum(SV *sv, FmgrInfo *func, Oid typid,
+ Oid typioparam, int32 typmod, bool *isnull);
+static void _sv_to_datum_finfo(FmgrInfo *fcinfo, Oid typid, Oid *typioparam);
+static Datum plperl_array_to_datum(SV *src, Oid typid);
+static ArrayBuildState *_array_to_datum(AV *av, int *ndims, int *dims,
+ int cur_depth, ArrayBuildState *astate, Oid typid, Oid atypid);
+static Datum plperl_hash_to_datum(SV *src, TupleDesc td);
+
+static void plperl_init_shared_libs(pTHX);
+static void plperl_trusted_init(void);
+static void plperl_untrusted_init(void);
+static HV *plperl_spi_execute_fetch_result(SPITupleTable *, int, int);
+static char *hek2cstr(HE *he);
+static SV **hv_store_string(HV *hv, const char *key, SV *val);
+static SV **hv_fetch_string(HV *hv, const char *key);
+static void plperl_create_sub(plperl_proc_desc *desc, char *s, Oid fn_oid);
+static SV *plperl_call_perl_func(plperl_proc_desc *desc,
+ FunctionCallInfo fcinfo);
+static void plperl_compile_callback(void *arg);
+static void plperl_exec_callback(void *arg);
+static char *strip_trailing_ws(const char *msg);
+static OP *pp_require_safe(pTHX);
+static void activate_interpreter(plperl_interp_desc *interp_desc);
+
+#ifdef WIN32
+static char *setlocale_perl(int category, char *locale);
+#endif
+
+/*
+ * convert a HE (hash entry) key to a cstr in the current database encoding
+ */
+static char *
+hek2cstr(HE *he)
+{
+ /*-------------------------
+ * Unfortunately, while HeUTF8 is true for most things > 256, for values
+ * 128..255 it's not, but perl will treat them as unicode code points if
+ * the utf8 flag is not set ( see The "Unicode Bug" in perldoc perlunicode
+ * for more)
+ *
+ * So if we did the expected:
+ * if (HeUTF8(he))
+ * utf_u2e(key...);
+ * else // must be ascii
+ * return HePV(he);
+ * we won't match columns with codepoints from 128..255
+ *
+ * For a more concrete example given a column with the name of the unicode
+ * codepoint U+00ae (registered sign) and a UTF8 database and the perl
+ * return_next { "\N{U+00ae}=>'text } would always fail as heUTF8 returns
+ * 0 and HePV() would give us a char * with 1 byte contains the decimal
+ * value 174
+ *
+ * Perl has the brains to know when it should utf8 encode 174 properly, so
+ * here we force it into an SV so that perl will figure it out and do the
+ * right thing
+ *-------------------------
+ */
+ SV *sv = HeSVKEY_force(he);
+
+ if (HeUTF8(he))
+ SvUTF8_on(sv);
+ return sv2cstr(sv);
+}
+
+/*
+ * This routine is a crock, and so is everyplace that calls it. The problem
+ * is that the cached form of plperl functions/queries is allocated permanently
+ * (mostly via malloc()) and never released until backend exit. Subsidiary
+ * data structures such as fmgr info records therefore must live forever
+ * as well. A better implementation would store all this stuff in a per-
+ * function memory context that could be reclaimed at need. In the meantime,
+ * fmgr_info_cxt must be called specifying TopMemoryContext so that whatever
+ * it might allocate, and whatever the eventual function might allocate using
+ * fn_mcxt, will live forever too.
+ */
+static void
+perm_fmgr_info(Oid functionId, FmgrInfo *finfo)
+{
+ fmgr_info_cxt(functionId, finfo, TopMemoryContext);
+}
+
+
+/*
+ * _PG_init() - library load-time initialization
+ *
+ * DO NOT make this static nor change its name!
+ */
+void
+_PG_init(void)
+{
+ /*
+ * Be sure we do initialization only once.
+ *
+ * If initialization fails due to, e.g., plperl_init_interp() throwing an
+ * exception, then we'll return here on the next usage and the user will
+ * get a rather cryptic: ERROR: attempt to redefine parameter
+ * "plperl.use_strict"
+ */
+ static bool inited = false;
+ HASHCTL hash_ctl;
+
+ if (inited)
+ return;
+
+ /*
+ * Support localized messages.
+ */
+ pg_bindtextdomain(TEXTDOMAIN);
+
+ /*
+ * Initialize plperl's GUCs.
+ */
+ DefineCustomBoolVariable("plperl.use_strict",
+ gettext_noop("If true, trusted and untrusted Perl code will be compiled in strict mode."),
+ NULL,
+ &plperl_use_strict,
+ PGC_USERSET,
+ NULL, NULL);
+
+ /*
+ * plperl.on_init is marked PGC_SIGHUP to support the idea that it might
+ * be executed in the postmaster (if plperl is loaded into the postmaster
+ * via shared_preload_libraries). This isn't really right either way,
+ * though.
+ */
+ DefineCustomStringVariable("plperl.on_init",
+ gettext_noop("Perl initialization code to execute when a Perl interpreter is initialized."),
+ NULL,
+ &plperl_on_init,
+ PGC_SIGHUP,
+ NULL, NULL);
+
+ /*
+ * plperl.on_plperl_init is marked PGC_SUSET to avoid issues whereby a
+ * user who might not even have USAGE privilege on the plperl language
+ * could nonetheless use SET plperl.on_plperl_init='...' to influence the
+ * behaviour of any existing plperl function that they can execute (which
+ * might be SECURITY DEFINER, leading to a privilege escalation). See
+ * http://archives.postgresql.org/pgsql-hackers/2010-02/msg00281.php and
+ * the overall thread.
+ *
+ * Note that because plperl.use_strict is USERSET, a nefarious user could
+ * set it to be applied against other people's functions. This is judged
+ * OK since the worst result would be an error. Your code oughta pass
+ * use_strict anyway ;-)
+ */
+ DefineCustomStringVariable("plperl.on_plperl_init",
+ gettext_noop("Perl initialization code to execute once when plperl is first used."),
+ NULL,
+ &plperl_on_plperl_init,
+ PGC_SUSET,
+ NULL, NULL);
+
+ DefineCustomStringVariable("plperl.on_plperlu_init",
+ gettext_noop("Perl initialization code to execute once when plperlu is first used."),
+ NULL,
+ &plperl_on_plperlu_init,
+ PGC_SUSET,
+ NULL, NULL);
+
+ EmitWarningsOnPlaceholders("plperl");
+
+ /*
+ * Create hash tables.
+ */
+ memset(&hash_ctl, 0, sizeof(hash_ctl));
+ hash_ctl.keysize = sizeof(Oid);
+ hash_ctl.entrysize = sizeof(plperl_interp_desc);
+ hash_ctl.hash = oid_hash;
+ plperl_interp_hash = hash_create("PL/Perl interpreters",
+ 8,
+ &hash_ctl,
+ HASH_ELEM | HASH_FUNCTION);
+
+ memset(&hash_ctl, 0, sizeof(hash_ctl));
+ hash_ctl.keysize = sizeof(plperl_proc_key);
+ hash_ctl.entrysize = sizeof(plperl_proc_ptr);
+ hash_ctl.hash = tag_hash;
+ plperl_proc_hash = hash_create("PL/Perl procedures",
+ 32,
+ &hash_ctl,
+ HASH_ELEM | HASH_FUNCTION);
+
+ /*
+ * Save the default opmask.
+ */
+ PLPERL_SET_OPMASK(plperl_opmask);
+
+ /*
+ * Create the first Perl interpreter, but only partially initialize it.
+ */
+ plperl_held_interp = plperl_init_interp();
+
+ inited = true;
+}
+
+
+static void
+set_interp_require(bool trusted)
+{
+ if (trusted)
+ {
+ PL_ppaddr[OP_REQUIRE] = pp_require_safe;
+ PL_ppaddr[OP_DOFILE] = pp_require_safe;
+ }
+ else
+ {
+ PL_ppaddr[OP_REQUIRE] = pp_require_orig;
+ PL_ppaddr[OP_DOFILE] = pp_require_orig;
+ }
+}
+
+/*
+ * Cleanup perl interpreters, including running END blocks.
+ * Does not fully undo the actions of _PG_init() nor make it callable again.
+ */
+static void
+plperl_fini(int code, Datum arg)
+{
+ HASH_SEQ_STATUS hash_seq;
+ plperl_interp_desc *interp_desc;
+
+ elog(DEBUG3, "plperl_fini");
+
+ /*
+ * Indicate that perl is terminating. Disables use of spi_* functions when
+ * running END/DESTROY code. See check_spi_usage_allowed(). Could be
+ * enabled in future, with care, using a transaction
+ * http://archives.postgresql.org/pgsql-hackers/2010-01/msg02743.php
+ */
+ plperl_ending = true;
+
+ /* Only perform perl cleanup if we're exiting cleanly */
+ if (code)
+ {
+ elog(DEBUG3, "plperl_fini: skipped");
+ return;
+ }
+
+ /* Zap the "held" interpreter, if we still have it */
+ plperl_destroy_interp(&plperl_held_interp);
+
+ /* Zap any fully-initialized interpreters */
+ hash_seq_init(&hash_seq, plperl_interp_hash);
+ while ((interp_desc = hash_seq_search(&hash_seq)) != NULL)
+ {
+ if (interp_desc->interp)
+ {
+ activate_interpreter(interp_desc);
+ plperl_destroy_interp(&interp_desc->interp);
+ }
+ }
+
+ elog(DEBUG3, "plperl_fini: done");
+}
+
+
+/*
+ * Select and activate an appropriate Perl interpreter.
+ */
+static void
+select_perl_context(bool trusted)
+{
+ Oid user_id;
+ plperl_interp_desc *interp_desc;
+ bool found;
+ PerlInterpreter *interp = NULL;
+
+ /* Find or create the interpreter hashtable entry for this userid */
+ if (trusted)
+ user_id = GetUserId();
+ else
+ user_id = InvalidOid;
+
+ interp_desc = hash_search(plperl_interp_hash, &user_id,
+ HASH_ENTER,
+ &found);
+ if (!found)
+ {
+ /* Initialize newly-created hashtable entry */
+ interp_desc->interp = NULL;
+ interp_desc->query_hash = NULL;
+ }
+
+ /* Make sure we have a query_hash for this interpreter */
+ if (interp_desc->query_hash == NULL)
+ {
+ HASHCTL hash_ctl;
+
+ memset(&hash_ctl, 0, sizeof(hash_ctl));
+ hash_ctl.keysize = NAMEDATALEN;
+ hash_ctl.entrysize = sizeof(plperl_query_entry);
+ interp_desc->query_hash = hash_create("PL/Perl queries",
+ 32,
+ &hash_ctl,
+ HASH_ELEM);
+ }
+
+ /*
+ * Quick exit if already have an interpreter
+ */
+ if (interp_desc->interp)
+ {
+ activate_interpreter(interp_desc);
+ return;
+ }
+
+ /*
+ * adopt held interp if free, else create new one if possible
+ */
+ if (plperl_held_interp != NULL)
+ {
+ /* first actual use of a perl interpreter */
+ interp = plperl_held_interp;
+
+ /*
+ * Reset the plperl_held_interp pointer first; if we fail during init
+ * we don't want to try again with the partially-initialized interp.
+ */
+ plperl_held_interp = NULL;
+
+ if (trusted)
+ plperl_trusted_init();
+ else
+ plperl_untrusted_init();
+
+ /* successfully initialized, so arrange for cleanup */
+ on_proc_exit(plperl_fini, 0);
+ }
+ else
+ {
+#ifdef MULTIPLICITY
+
+ /*
+ * plperl_init_interp will change Perl's idea of the active
+ * interpreter. Reset plperl_active_interp temporarily, so that if we
+ * hit an error partway through here, we'll make sure to switch back
+ * to a non-broken interpreter before running any other Perl
+ * functions.
+ */
+ plperl_active_interp = NULL;
+
+ /* Now build the new interpreter */
+ interp = plperl_init_interp();
+
+ if (trusted)
+ plperl_trusted_init();
+ else
+ plperl_untrusted_init();
+#else
+ elog(ERROR,
+ "cannot allocate multiple Perl interpreters on this platform");
+#endif
+ }
+
+ set_interp_require(trusted);
+
+ /*
+ * Since the timing of first use of PL/Perl can't be predicted, any
+ * database interaction during initialization is problematic. Including,
+ * but not limited to, security definer issues. So we only enable access
+ * to the database AFTER on_*_init code has run. See
+ * http://archives.postgresql.org/pgsql-hackers/2010-01/msg02669.php
+ */
+ newXS("PostgreSQL::InServer::SPI::bootstrap",
+ boot_PostgreSQL__InServer__SPI, __FILE__);
+
+ eval_pv("PostgreSQL::InServer::SPI::bootstrap()", FALSE);
+ if (SvTRUE(ERRSV))
+ ereport(ERROR,
+ (errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
+ errcontext("while executing PostgreSQL::InServer::SPI::bootstrap")));
+
+ /* Fully initialized, so mark the hashtable entry valid */
+ interp_desc->interp = interp;
+
+ /* And mark this as the active interpreter */
+ plperl_active_interp = interp_desc;
+}
+
+/*
+ * Make the specified interpreter the active one
+ *
+ * A call with NULL does nothing. This is so that "restoring" to a previously
+ * null state of plperl_active_interp doesn't result in useless thrashing.
+ */
+static void
+activate_interpreter(plperl_interp_desc *interp_desc)
+{
+ if (interp_desc && plperl_active_interp != interp_desc)
+ {
+ Assert(interp_desc->interp);
+ PERL_SET_CONTEXT(interp_desc->interp);
+ /* trusted iff user_id isn't InvalidOid */
+ set_interp_require(OidIsValid(interp_desc->user_id));
+ plperl_active_interp = interp_desc;
+ }
+}
+
+/*
+ * Create a new Perl interpreter.
+ *
+ * We initialize the interpreter as far as we can without knowing whether
+ * it will become a trusted or untrusted interpreter; in particular, the
+ * plperl.on_init code will get executed. Later, either plperl_trusted_init
+ * or plperl_untrusted_init must be called to complete the initialization.
+ */
+static PerlInterpreter *
+plperl_init_interp(void)
+{
+ PerlInterpreter *plperl;
+
+ static char *embedding[3 + 2] = {
+ "", "-e", PLC_PERLBOOT
+ };
+ int nargs = 3;
+
+#ifdef WIN32
+
+ /*
+ * The perl library on startup does horrible things like call
+ * setlocale(LC_ALL,""). We have protected against that on most platforms
+ * by setting the environment appropriately. However, on Windows,
+ * setlocale() does not consult the environment, so we need to save the
+ * existing locale settings before perl has a chance to mangle them and
+ * restore them after its dirty deeds are done.
+ *
+ * MSDN ref:
+ * http://msdn.microsoft.com/library/en-us/vclib/html/_crt_locale.asp
+ *
+ * It appears that we only need to do this on interpreter startup, and
+ * subsequent calls to the interpreter don't mess with the locale
+ * settings.
+ *
+ * We restore them using setlocale_perl(), defined below, so that Perl
+ * doesn't have a different idea of the locale from Postgres.
+ *
+ */
+
+ char *loc;
+ char *save_collate,
+ *save_ctype,
+ *save_monetary,
+ *save_numeric,
+ *save_time;
+
+ loc = setlocale(LC_COLLATE, NULL);
+ save_collate = loc ? pstrdup(loc) : NULL;
+ loc = setlocale(LC_CTYPE, NULL);
+ save_ctype = loc ? pstrdup(loc) : NULL;
+ loc = setlocale(LC_MONETARY, NULL);
+ save_monetary = loc ? pstrdup(loc) : NULL;
+ loc = setlocale(LC_NUMERIC, NULL);
+ save_numeric = loc ? pstrdup(loc) : NULL;
+ loc = setlocale(LC_TIME, NULL);
+ save_time = loc ? pstrdup(loc) : NULL;
+
+#define PLPERL_RESTORE_LOCALE(name, saved) \
+ STMT_START { \
+ if (saved != NULL) { setlocale_perl(name, saved); pfree(saved); } \
+ } STMT_END
+#endif /* WIN32 */
+
+ if (plperl_on_init && *plperl_on_init)
+ {
+ embedding[nargs++] = "-e";
+ embedding[nargs++] = plperl_on_init;
+ }
+
+ /*
+ * The perl API docs state that PERL_SYS_INIT3 should be called before
+ * allocating interpreters. Unfortunately, on some platforms this fails in
+ * the Perl_do_taint() routine, which is called when the platform is using
+ * the system's malloc() instead of perl's own. Other platforms, notably
+ * Windows, fail if PERL_SYS_INIT3 is not called. So we call it if it's
+ * available, unless perl is using the system malloc(), which is true when
+ * MYMALLOC is set.
+ */
+#if defined(PERL_SYS_INIT3) && !defined(MYMALLOC)
+ {
+ static int perl_sys_init_done;
+
+ /* only call this the first time through, as per perlembed man page */
+ if (!perl_sys_init_done)
+ {
+ char *dummy_env[1] = {NULL};
+
+ PERL_SYS_INIT3(&nargs, (char ***) &embedding, (char ***) &dummy_env);
+ perl_sys_init_done = 1;
+ /* quiet warning if PERL_SYS_INIT3 doesn't use the third argument */
+ dummy_env[0] = NULL;
+ }
+ }
+#endif
+
+ plperl = perl_alloc();
+ if (!plperl)
+ elog(ERROR, "could not allocate Perl interpreter");
+
+ PERL_SET_CONTEXT(plperl);
+ perl_construct(plperl);
+
+ /* run END blocks in perl_destruct instead of perl_run */
+ PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
+
+ /*
+ * Record the original function for the 'require' and 'dofile' opcodes.
+ * (They share the same implementation.) Ensure it's used for new
+ * interpreters.
+ */
+ if (!pp_require_orig)
+ pp_require_orig = PL_ppaddr[OP_REQUIRE];
+ else
+ {
+ PL_ppaddr[OP_REQUIRE] = pp_require_orig;
+ PL_ppaddr[OP_DOFILE] = pp_require_orig;
+ }
+
+#ifdef PLPERL_ENABLE_OPMASK_EARLY
+
+ /*
+ * For regression testing to prove that the PLC_PERLBOOT and PLC_TRUSTED
+ * code doesn't even compile any unsafe ops. In future there may be a
+ * valid need for them to do so, in which case this could be softened
+ * (perhaps moved to plperl_trusted_init()) or removed.
+ */
+ PL_op_mask = plperl_opmask;
+#endif
+
+ if (perl_parse(plperl, plperl_init_shared_libs,
+ nargs, embedding, NULL) != 0)
+ ereport(ERROR,
+ (errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
+ errcontext("while parsing Perl initialization")));
+
+ if (perl_run(plperl) != 0)
+ ereport(ERROR,
+ (errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
+ errcontext("while running Perl initialization")));
+
+#ifdef PLPERL_RESTORE_LOCALE
+ PLPERL_RESTORE_LOCALE(LC_COLLATE, save_collate);
+ PLPERL_RESTORE_LOCALE(LC_CTYPE, save_ctype);
+ PLPERL_RESTORE_LOCALE(LC_MONETARY, save_monetary);
+ PLPERL_RESTORE_LOCALE(LC_NUMERIC, save_numeric);
+ PLPERL_RESTORE_LOCALE(LC_TIME, save_time);
+#endif
+
+ return plperl;
+}
+
+
+/*
+ * Our safe implementation of the require opcode.
+ * This is safe because it's completely unable to load any code.
+ * If the requested file/module has already been loaded it'll return true.
+ * If not, it'll die.
+ * So now "use Foo;" will work iff Foo has already been loaded.
+ */
+static OP *
+pp_require_safe(pTHX)
+{
+ dVAR;
+ dSP;
+ SV *sv,
+ **svp;
+ char *name;
+ STRLEN len;
+
+ sv = POPs;
+ name = SvPV(sv, len);
+ if (!(name && len > 0 && *name))
+ RETPUSHNO;
+
+ svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+ if (svp && *svp != &PL_sv_undef)
+ RETPUSHYES;
+
+ DIE(aTHX_ "Unable to load %s into plperl", name);
+ return NULL; /* keep compiler quiet */
+}
+
+
+/*
+ * Destroy one Perl interpreter ... actually we just run END blocks.
+ *
+ * Caller must have ensured this interpreter is the active one.
+ */
+static void
+plperl_destroy_interp(PerlInterpreter **interp)
+{
+ if (interp && *interp)
+ {
+ /*
+ * Only a very minimal destruction is performed: - just call END
+ * blocks.
+ *
+ * We could call perl_destruct() but we'd need to audit its actions
+ * very carefully and work-around any that impact us. (Calling
+ * sv_clean_objs() isn't an option because it's not part of perl's
+ * public API so isn't portably available.) Meanwhile END blocks can
+ * be used to perform manual cleanup.
+ */
+
+ /* Run END blocks - based on perl's perl_destruct() */
+ if (PL_exit_flags & PERL_EXIT_DESTRUCT_END)
+ {
+ dJMPENV;
+ int x = 0;
+
+ JMPENV_PUSH(x);
+ PERL_UNUSED_VAR(x);
+ if (PL_endav && !PL_minus_c)
+ call_list(PL_scopestack_ix, PL_endav);
+ JMPENV_POP;
+ }
+ LEAVE;
+ FREETMPS;
+
+ *interp = NULL;
+ }
+}
+
+/*
+ * Initialize the current Perl interpreter as a trusted interp
+ */
+static void
+plperl_trusted_init(void)
+{
+ HV *stash;
+ SV *sv;
+ char *key;
+ I32 klen;
+
+ /* use original require while we set up */
+ PL_ppaddr[OP_REQUIRE] = pp_require_orig;
+ PL_ppaddr[OP_DOFILE] = pp_require_orig;
+
+ eval_pv(PLC_TRUSTED, FALSE);
+ if (SvTRUE(ERRSV))
+ ereport(ERROR,
+ (errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
+ errcontext("while executing PLC_TRUSTED")));
+
+ /*
+ * Force loading of utf8 module now to prevent errors that can arise from
+ * the regex code later trying to load utf8 modules. See
+ * http://rt.perl.org/rt3/Ticket/Display.html?id=47576
+ */
+ eval_pv("my $a=chr(0x100); return $a =~ /\\xa9/i", FALSE);
+ if (SvTRUE(ERRSV))
+ ereport(ERROR,
+ (errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
+ errcontext("while executing utf8fix")));
+
+ /*
+ * Lock down the interpreter
+ */
+
+ /* switch to the safe require/dofile opcode for future code */
+ PL_ppaddr[OP_REQUIRE] = pp_require_safe;
+ PL_ppaddr[OP_DOFILE] = pp_require_safe;
+
+ /*
+ * prevent (any more) unsafe opcodes being compiled PL_op_mask is per
+ * interpreter, so this only needs to be set once
+ */
+ PL_op_mask = plperl_opmask;
+
+ /* delete the DynaLoader:: namespace so extensions can't be loaded */
+ stash = gv_stashpv("DynaLoader", GV_ADDWARN);
+ hv_iterinit(stash);
+ while ((sv = hv_iternextsv(stash, &key, &klen)))
+ {
+ if (!isGV_with_GP(sv) || !GvCV(sv))
+ continue;
+ SvREFCNT_dec(GvCV(sv)); /* free the CV */
+ GvCV_set(sv, NULL); /* prevent call via GV */
+ }
+ hv_clear(stash);
+
+ /* invalidate assorted caches */
+ ++PL_sub_generation;
+ hv_clear(PL_stashcache);
+
+ /*
+ * Execute plperl.on_plperl_init in the locked-down interpreter
+ */
+ if (plperl_on_plperl_init && *plperl_on_plperl_init)
+ {
+ eval_pv(plperl_on_plperl_init, FALSE);
+ if (SvTRUE(ERRSV))
+ ereport(ERROR,
+ (errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
+ errcontext("while executing plperl.on_plperl_init")));
+
+ }
+}
+
+
+/*
+ * Initialize the current Perl interpreter as an untrusted interp
+ */
+static void
+plperl_untrusted_init(void)
+{
+ /*
+ * Nothing to do except execute plperl.on_plperlu_init
+ */
+ if (plperl_on_plperlu_init && *plperl_on_plperlu_init)
+ {
+ eval_pv(plperl_on_plperlu_init, FALSE);
+ if (SvTRUE(ERRSV))
+ ereport(ERROR,
+ (errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
+ errcontext("while executing plperl.on_plperlu_init")));
+ }
+}
+
+
+/*
+ * Perl likes to put a newline after its error messages; clean up such
+ */
+static char *
+strip_trailing_ws(const char *msg)
+{
+ char *res = pstrdup(msg);
+ int len = strlen(res);
+
+ while (len > 0 && isspace((unsigned char) res[len - 1]))
+ res[--len] = '\0';
+ return res;
+}
+
+
+/* Build a tuple from a hash. */
+
+static HeapTuple
+plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
+{
+ TupleDesc td = attinmeta->tupdesc;
+ Datum *values;
+ bool *nulls;
+ HE *he;
+ HeapTuple tup;
+
+ values = palloc0(sizeof(Datum) * td->natts);
+ nulls = palloc(sizeof(bool) * td->natts);
+ memset(nulls, true, sizeof(bool) * td->natts);
+
+ hv_iterinit(perlhash);
+ while ((he = hv_iternext(perlhash)))
+ {
+ SV *val = HeVAL(he);
+ char *key = hek2cstr(he);
+ int attn = SPI_fnumber(td, key);
+ bool isnull;
+
+ if (attn <= 0 || td->attrs[attn - 1]->attisdropped)
+ ereport(ERROR,
+ (errcode(ERRCODE_UNDEFINED_COLUMN),
+ errmsg("Perl hash contains nonexistent column \"%s\"",
+ key)));
+
+ values[attn - 1] = plperl_sv_to_datum(val,
+ NULL,
+ td->attrs[attn - 1]->atttypid,
+ InvalidOid,
+ td->attrs[attn - 1]->atttypmod,
+ &isnull);
+ nulls[attn - 1] = isnull;
+
+ pfree(key);
+ }
+ hv_iterinit(perlhash);
+
+ tup = heap_form_tuple(td, values, nulls);
+ pfree(values);
+ pfree(nulls);
+ return tup;
+}
+
+/* convert a hash reference to a datum */
+static Datum
+plperl_hash_to_datum(SV *src, TupleDesc td)
+{
+ AttInMetadata *attinmeta = TupleDescGetAttInMetadata(td);
+ HeapTuple tup = plperl_build_tuple_result((HV *) SvRV(src), attinmeta);
+
+ return HeapTupleGetDatum(tup);
+}
+
+/*
+ * if we are an array ref return the reference. this is special in that if we
+ * are a PostgreSQL::InServer::ARRAY object we will return the 'magic' array.
+ */
+static SV *
+get_perl_array_ref(SV *sv)
+{
+ if (SvOK(sv) && SvROK(sv))
+ {
+ if (SvTYPE(SvRV(sv)) == SVt_PVAV)
+ return sv;
+ else if (sv_isa(sv, "PostgreSQL::InServer::ARRAY"))
+ {
+ HV *hv = (HV *) SvRV(sv);
+ SV **sav = hv_fetch_string(hv, "array");
+
+ if (*sav && SvOK(*sav) && SvROK(*sav) &&
+ SvTYPE(SvRV(*sav)) == SVt_PVAV)
+ return *sav;
+
+ elog(ERROR, "could not get array reference from PostgreSQL::InServer::ARRAY object");
+ }
+ }
+ return NULL;
+}
+
+/*
+ * helper function for plperl_array_to_datum, does the main recursing
+ */
+static ArrayBuildState *
+_array_to_datum(AV *av, int *ndims, int *dims, int cur_depth,
+ ArrayBuildState *astate, Oid typid, Oid atypid)
+{
+ int i = 0;
+ int len = av_len(av) + 1;
+
+ if (len == 0)
+ astate = accumArrayResult(astate, (Datum) 0, true, atypid, NULL);
+
+ for (i = 0; i < len; i++)
+ {
+ SV **svp = av_fetch(av, i, FALSE);
+ SV *sav = svp ? get_perl_array_ref(*svp) : NULL;
+
+ if (sav)
+ {
+ AV *nav = (AV *) SvRV(sav);
+
+ if (cur_depth + 1 > MAXDIM)
+ ereport(ERROR,
+ (errcode(ERRCODE_PROGRAM_LIMIT_EXCEEDED),
+ errmsg("number of array dimensions (%d) exceeds the maximum allowed (%d)",
+ cur_depth + 1, MAXDIM)));
+
+ /* size based off the first element */
+ if (i == 0 && *ndims == cur_depth)
+ {
+ dims[*ndims] = av_len(nav) + 1;
+ (*ndims)++;
+ }
+ else
+ {
+ if (av_len(nav) + 1 != dims[cur_depth])
+ ereport(ERROR,
+ (errcode(ERRCODE_INVALID_TEXT_REPRESENTATION),
+ errmsg("multidimensional arrays must have array expressions with matching dimensions")));
+ }
+
+ astate = _array_to_datum(nav, ndims, dims, cur_depth + 1, astate,
+ typid, atypid);
+ }
+ else
+ {
+ bool isnull;
+ Datum dat = plperl_sv_to_datum(svp ? *svp : NULL, NULL,
+ atypid, 0, -1, &isnull);
+
+ astate = accumArrayResult(astate, dat, isnull, atypid, NULL);
+ }
+ }
+
+ return astate;
+}
+
+/*
+ * convert perl array ref to a datum
+ */
+static Datum
+plperl_array_to_datum(SV *src, Oid typid)
+{
+ ArrayBuildState *astate = NULL;
+ Oid atypid;
+ int dims[MAXDIM];
+ int lbs[MAXDIM];
+ int ndims = 1;
+ int i;
+
+ atypid = get_element_type(typid);
+ if (!atypid)
+ atypid = typid;
+
+ memset(dims, 0, sizeof(dims));
+ dims[0] = av_len((AV *) SvRV(src)) + 1;
+
+ astate = _array_to_datum((AV *) SvRV(src), &ndims, dims, 1, astate, typid,
+ atypid);
+
+ for (i = 0; i < ndims; i++)
+ lbs[i] = 1;
+
+ return makeMdArrayResult(astate, ndims, dims, lbs, CurrentMemoryContext, true);
+}
+
+static void
+_sv_to_datum_finfo(FmgrInfo *fcinfo, Oid typid, Oid *typioparam)
+{
+ Oid typinput;
+
+ /* XXX would be better to cache these lookups */
+ getTypeInputInfo(typid,
+ &typinput, typioparam);
+ fmgr_info(typinput, fcinfo);
+}
+
+/*
+ * convert a sv to datum
+ * fcinfo and typioparam are optional and will be looked-up if needed
+ */
+static Datum
+plperl_sv_to_datum(SV *sv, FmgrInfo *finfo, Oid typid, Oid typioparam,
+ int32 typmod, bool *isnull)
+{
+ FmgrInfo tmp;
+
+ /* we might recurse */
+ check_stack_depth();
+
+ if (isnull)
+ *isnull = false;
+
+ if (!sv || !SvOK(sv))
+ {
+ if (!finfo)
+ {
+ _sv_to_datum_finfo(&tmp, typid, &typioparam);
+ finfo = &tmp;
+ }
+ if (isnull)
+ *isnull = true;
+ return InputFunctionCall(finfo, NULL, typioparam, typmod);
+ }
+ else if (SvROK(sv))
+ {
+ SV *sav = get_perl_array_ref(sv);
+
+ if (sav)
+ {
+ return plperl_array_to_datum(sav, typid);
+ }
+ else if (SvTYPE(SvRV(sv)) == SVt_PVHV)
+ {
+ TupleDesc td = lookup_rowtype_tupdesc(typid, typmod);
+ Datum ret = plperl_hash_to_datum(sv, td);
+
+ ReleaseTupleDesc(td);
+ return ret;
+ }
+
+ ereport(ERROR,
+ (errcode(ERRCODE_DATATYPE_MISMATCH),
+ errmsg("PL/Perl function must return reference to hash or array")));
+ return (Datum) 0; /* shut up compiler */
+ }
+ else
+ {
+ Datum ret;
+ char *str = sv2cstr(sv);
+
+ if (!finfo)
+ {
+ _sv_to_datum_finfo(&tmp, typid, &typioparam);
+ finfo = &tmp;
+ }
+
+ ret = InputFunctionCall(finfo, str, typioparam, typmod);
+ pfree(str);
+
+ return ret;
+ }
+}
+
+/* Convert the perl SV to a string returned by the type output function */
+char *
+plperl_sv_to_literal(SV *sv, char *fqtypename)
+{
+ Datum str = CStringGetDatum(fqtypename);
+ Oid typid = DirectFunctionCall1(regtypein, str);
+ Oid typoutput;
+ Datum datum;
+ bool typisvarlena,
+ isnull;
+
+ if (!OidIsValid(typid))
+ elog(ERROR, "lookup failed for type %s", fqtypename);
+
+ datum = plperl_sv_to_datum(sv, NULL, typid, 0, -1, &isnull);
+
+ if (isnull)
+ return NULL;
+
+ getTypeOutputInfo(typid,
+ &typoutput, &typisvarlena);
+
+ return OidOutputFunctionCall(typoutput, datum);
+}
+
+/*
+ * Convert PostgreSQL array datum to a perl array reference.
+ *
+ * typid is arg's OID, which must be an array type.
+ */
+static SV *
+plperl_ref_from_pg_array(Datum arg, Oid typid)
+{
+ ArrayType *ar = DatumGetArrayTypeP(arg);
+ Oid elementtype = ARR_ELEMTYPE(ar);
+ int16 typlen;
+ bool typbyval;
+ char typalign,
+ typdelim;
+ Oid typioparam;
+ Oid typoutputfunc;
+ int i,
+ nitems,
+ *dims;
+ plperl_array_info *info;
+ SV *av;
+ HV *hv;
+
+ info = palloc(sizeof(plperl_array_info));
+
+ /* get element type information, including output conversion function */
+ get_type_io_data(elementtype, IOFunc_output,
+ &typlen, &typbyval, &typalign,
+ &typdelim, &typioparam, &typoutputfunc);
+
+ perm_fmgr_info(typoutputfunc, &info->proc);
+
+ info->elem_is_rowtype = type_is_rowtype(elementtype);
+
+ /* Get the number and bounds of array dimensions */
+ info->ndims = ARR_NDIM(ar);
+ dims = ARR_DIMS(ar);
+
+ deconstruct_array(ar, elementtype, typlen, typbyval,
+ typalign, &info->elements, &info->nulls,
+ &nitems);
+
+ /* Get total number of elements in each dimension */
+ info->nelems = palloc(sizeof(int) * info->ndims);
+ info->nelems[0] = nitems;
+ for (i = 1; i < info->ndims; i++)
+ info->nelems[i] = info->nelems[i - 1] / dims[i - 1];
+
+ av = split_array(info, 0, nitems, 0);
+
+ hv = newHV();
+ (void) hv_store(hv, "array", 5, av, 0);
+ (void) hv_store(hv, "typeoid", 7, newSViv(typid), 0);
+
+ return sv_bless(newRV_noinc((SV *) hv),
+ gv_stashpv("PostgreSQL::InServer::ARRAY", 0));
+}
+
+/*
+ * Recursively form array references from splices of the initial array
+ */
+static SV *
+split_array(plperl_array_info *info, int first, int last, int nest)
+{
+ int i;
+ AV *result;
+
+ /* since this function recurses, it could be driven to stack overflow */
+ check_stack_depth();
+
+ /*
+ * Base case, return a reference to a single-dimensional array
+ */
+ if (nest >= info->ndims - 1)
+ return make_array_ref(info, first, last);
+
+ result = newAV();
+ for (i = first; i < last; i += info->nelems[nest + 1])
+ {
+ /* Recursively form references to arrays of lower dimensions */
+ SV *ref = split_array(info, i, i + info->nelems[nest + 1], nest + 1);
+
+ av_push(result, ref);
+ }
+ return newRV_noinc((SV *) result);
+}
+
+/*
+ * Create a Perl reference from a one-dimensional C array, converting
+ * composite type elements to hash references.
+ */
+static SV *
+make_array_ref(plperl_array_info *info, int first, int last)
+{
+ int i;
+ AV *result = newAV();
+
+ for (i = first; i < last; i++)
+ {
+ if (info->nulls[i])
+ av_push(result, &PL_sv_undef);
+ else
+ {
+ Datum itemvalue = info->elements[i];
+
+ /* Handle composite type elements */
+ if (info->elem_is_rowtype)
+ av_push(result, plperl_hash_from_datum(itemvalue));
+ else
+ {
+ char *val = OutputFunctionCall(&info->proc, itemvalue);
+
+ av_push(result, cstr2sv(val));
+ }
+ }
+ }
+ return newRV_noinc((SV *) result);
+}
+
+/* Set up the arguments for a trigger call. */
+static SV *
+plperl_trigger_build_args(FunctionCallInfo fcinfo)
+{
+ TriggerData *tdata;
+ TupleDesc tupdesc;
+ int i;
+ char *level;
+ char *event;
+ char *relid;
+ char *when;
+ HV *hv;
+
+ hv = newHV();
+ hv_ksplit(hv, 12); /* pre-grow the hash */
+
+ tdata = (TriggerData *) fcinfo->context;
+ tupdesc = tdata->tg_relation->rd_att;
+
+ relid = DatumGetCString(
+ DirectFunctionCall1(oidout,
+ ObjectIdGetDatum(tdata->tg_relation->rd_id)
+ )
+ );
+
+ hv_store_string(hv, "name", cstr2sv(tdata->tg_trigger->tgname));
+ hv_store_string(hv, "relid", cstr2sv(relid));
+
+ if (TRIGGER_FIRED_BY_INSERT(tdata->tg_event))
+ {
+ event = "INSERT";
+ if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
+ hv_store_string(hv, "new",
+ plperl_hash_from_tuple(tdata->tg_trigtuple,
+ tupdesc));
+ }
+ else if (TRIGGER_FIRED_BY_DELETE(tdata->tg_event))
+ {
+ event = "DELETE";
+ if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
+ hv_store_string(hv, "old",
+ plperl_hash_from_tuple(tdata->tg_trigtuple,
+ tupdesc));
+ }
+ else if (TRIGGER_FIRED_BY_UPDATE(tdata->tg_event))
+ {
+ event = "UPDATE";
+ if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
+ {
+ hv_store_string(hv, "old",
+ plperl_hash_from_tuple(tdata->tg_trigtuple,
+ tupdesc));
+ hv_store_string(hv, "new",
+ plperl_hash_from_tuple(tdata->tg_newtuple,
+ tupdesc));
+ }
+ }
+ /*else if (TRIGGER_FIRED_BY_TRUNCATE(tdata->tg_event))
+ event = "TRUNCATE";*/
+ else
+ event = "UNKNOWN";
+
+ hv_store_string(hv, "event", cstr2sv(event));
+ hv_store_string(hv, "argc", newSViv(tdata->tg_trigger->tgnargs));
+
+ if (tdata->tg_trigger->tgnargs > 0)
+ {
+ AV *av = newAV();
+
+ av_extend(av, tdata->tg_trigger->tgnargs);
+ for (i = 0; i < tdata->tg_trigger->tgnargs; i++)
+ av_push(av, cstr2sv(tdata->tg_trigger->tgargs[i]));
+ hv_store_string(hv, "args", newRV_noinc((SV *) av));
+ }
+
+ hv_store_string(hv, "relname",
+ cstr2sv(SPI_getrelname(tdata->tg_relation)));
+
+ hv_store_string(hv, "table_name",
+ cstr2sv(SPI_getrelname(tdata->tg_relation)));
+
+ hv_store_string(hv, "table_schema",
+ cstr2sv(SPI_getnspname(tdata->tg_relation)));
+
+ if (TRIGGER_FIRED_BEFORE(tdata->tg_event))
+ when = "BEFORE";
+ else if (TRIGGER_FIRED_AFTER(tdata->tg_event))
+ when = "AFTER";
+ /*else if (TRIGGER_FIRED_INSTEAD(tdata->tg_event))
+ when = "INSTEAD OF";*/
+ else
+ when = "UNKNOWN";
+ hv_store_string(hv, "when", cstr2sv(when));
+
+ if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
+ level = "ROW";
+ else if (TRIGGER_FIRED_FOR_STATEMENT(tdata->tg_event))
+ level = "STATEMENT";
+ else
+ level = "UNKNOWN";
+ hv_store_string(hv, "level", cstr2sv(level));
+
+ return newRV_noinc((SV *) hv);
+}
+
+
+/* Set up the new tuple returned from a trigger. */
+
+static HeapTuple
+plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
+{
+ SV **svp;
+ HV *hvNew;
+ HE *he;
+ HeapTuple rtup;
+ int slotsused;
+ int *modattrs;
+ Datum *modvalues;
+ char *modnulls;
+
+ TupleDesc tupdesc;
+
+ tupdesc = tdata->tg_relation->rd_att;
+
+ svp = hv_fetch_string(hvTD, "new");
+ if (!svp)
+ ereport(ERROR,
+ (errcode(ERRCODE_UNDEFINED_COLUMN),
+ errmsg("$_TD->{new} does not exist")));
+ if (!SvOK(*svp) || !SvROK(*svp) || SvTYPE(SvRV(*svp)) != SVt_PVHV)
+ ereport(ERROR,
+ (errcode(ERRCODE_DATATYPE_MISMATCH),
+ errmsg("$_TD->{new} is not a hash reference")));
+ hvNew = (HV *) SvRV(*svp);
+
+ modattrs = palloc(tupdesc->natts * sizeof(int));
+ modvalues = palloc(tupdesc->natts * sizeof(Datum));
+ modnulls = palloc(tupdesc->natts * sizeof(char));
+ slotsused = 0;
+
+ hv_iterinit(hvNew);
+ while ((he = hv_iternext(hvNew)))
+ {
+ bool isnull;
+ char *key = hek2cstr(he);
+ SV *val = HeVAL(he);
+ int attn = SPI_fnumber(tupdesc, key);
+
+ if (attn <= 0 || tupdesc->attrs[attn - 1]->attisdropped)
+ ereport(ERROR,
+ (errcode(ERRCODE_UNDEFINED_COLUMN),
+ errmsg("Perl hash contains nonexistent column \"%s\"",
+ key)));
+
+ modvalues[slotsused] = plperl_sv_to_datum(val,
+ NULL,
+ tupdesc->attrs[attn - 1]->atttypid,
+ InvalidOid,
+ tupdesc->attrs[attn - 1]->atttypmod,
+ &isnull);
+
+ modnulls[slotsused] = isnull ? 'n' : ' ';
+ modattrs[slotsused] = attn;
+ slotsused++;
+
+ pfree(key);
+ }
+ hv_iterinit(hvNew);
+
+ rtup = SPI_modifytuple(tdata->tg_relation, otup, slotsused,
+ modattrs, modvalues, modnulls);
+
+ pfree(modattrs);
+ pfree(modvalues);
+ pfree(modnulls);
+
+ if (rtup == NULL)
+ elog(ERROR, "SPI_modifytuple failed: %s",
+ SPI_result_code_string(SPI_result));
+
+ return rtup;
+}
+
+
+/*
+ * There are three externally visible pieces to plperl: plperl_call_handler,
+ * plperl_inline_handler, and plperl_validator.
+ */
+
+/*
+ * The call handler is called to run normal functions (including trigger
+ * functions) that are defined in pg_proc.
+ */
+PG_FUNCTION_INFO_V1(plperl_call_handler);
+
+Datum
+plperl_call_handler(PG_FUNCTION_ARGS)
+{
+ Datum retval;
+ plperl_call_data *save_call_data = current_call_data;
+ plperl_interp_desc *oldinterp = plperl_active_interp;
+
+ PG_TRY();
+ {
+ if (CALLED_AS_TRIGGER(fcinfo))
+ retval = plperl_trigger_handler(fcinfo);
+ else
+ retval = plperl_func_handler(fcinfo);
+ }
+ PG_CATCH();
+ {
+
+ if(NULL != current_call_data->tmp_cxt)
+ MemoryContextDelete(current_call_data->tmp_cxt);
+
+ current_call_data = save_call_data;
+ activate_interpreter(oldinterp);
+ PG_RE_THROW();
+ }
+ PG_END_TRY();
+
+ if(NULL != current_call_data->tmp_cxt)
+ MemoryContextDelete(current_call_data->tmp_cxt);
+
+ current_call_data = save_call_data;
+ activate_interpreter(oldinterp);
+ return retval;
+}
+
+#ifdef INLINE_FUNCTION_SUPPORT
+/*
+ * The inline handler runs anonymous code blocks (DO blocks).
+ */
+PG_FUNCTION_INFO_V1(plperl_inline_handler);
+
+Datum
+plperl_inline_handler(PG_FUNCTION_ARGS)
+{
+ InlineCodeBlock *codeblock = (InlineCodeBlock *) PG_GETARG_POINTER(0);
+ FunctionCallInfoData fake_fcinfo;
+ FmgrInfo flinfo;
+ plperl_proc_desc desc;
+ plperl_call_data *save_call_data = current_call_data;
+ plperl_interp_desc *oldinterp = plperl_active_interp;
+ ErrorContextCallback pl_error_context;
+
+ /* Set up a callback for error reporting */
+ pl_error_context.callback = plperl_inline_callback;
+ pl_error_context.previous = error_context_stack;
+ pl_error_context.arg = (Datum) 0;
+ error_context_stack = &pl_error_context;
+
+ /*
+ * Set up a fake fcinfo and descriptor with just enough info to satisfy
+ * plperl_call_perl_func(). In particular note that this sets things up
+ * with no arguments passed, and a result type of VOID.
+ */
+ MemSet(&fake_fcinfo, 0, sizeof(fake_fcinfo));
+ MemSet(&flinfo, 0, sizeof(flinfo));
+ MemSet(&desc, 0, sizeof(desc));
+ fake_fcinfo.flinfo = &flinfo;
+ flinfo.fn_oid = InvalidOid;
+ flinfo.fn_mcxt = CurrentMemoryContext;
+
+ desc.proname = "inline_code_block";
+ desc.fn_readonly = false;
+
+ desc.lanpltrusted = codeblock->langIsTrusted;
+
+ desc.fn_retistuple = false;
+ desc.fn_retisset = false;
+ desc.fn_retisarray = false;
+ desc.result_oid = VOIDOID;
+ desc.nargs = 0;
+ desc.reference = NULL;
+
+ current_call_data = (plperl_call_data *) palloc0(sizeof(plperl_call_data));
+ current_call_data->fcinfo = &fake_fcinfo;
+ current_call_data->prodesc = &desc;
+
+ PG_TRY();
+ {
+ SV *perlret;
+
+ if (SPI_connect() != SPI_OK_CONNECT)
+ elog(ERROR, "could not connect to SPI manager");
+
+ select_perl_context(desc.lanpltrusted);
+
+ plperl_create_sub(&desc, codeblock->source_text, 0);
+
+ if (!desc.reference) /* can this happen? */
+ elog(ERROR, "could not create internal procedure for anonymous code block");
+
+ perlret = plperl_call_perl_func(&desc, &fake_fcinfo);
+
+ SvREFCNT_dec(perlret);
+
+ if (SPI_finish() != SPI_OK_FINISH)
+ elog(ERROR, "SPI_finish() failed");
+ }
+ PG_CATCH();
+ {
+ if (desc.reference)
+ SvREFCNT_dec(desc.reference);
+ current_call_data = save_call_data;
+ activate_interpreter(oldinterp);
+ PG_RE_THROW();
+ }
+ PG_END_TRY();
+
+ if (desc.reference)
+ SvREFCNT_dec(desc.reference);
+
+ current_call_data = save_call_data;
+ activate_interpreter(oldinterp);
+
+ error_context_stack = pl_error_context.previous;
+
+ PG_RETURN_VOID();
+}
+#endif
+
+/*
+ * The validator is called during CREATE FUNCTION to validate the function
+ * being created/replaced. The precise behavior of the validator may be
+ * modified by the check_function_bodies GUC.
+ */
+PG_FUNCTION_INFO_V1(plperl_validator);
+
+Datum
+plperl_validator(PG_FUNCTION_ARGS)
+{
+ Oid funcoid = PG_GETARG_OID(0);
+ HeapTuple tuple;
+ Form_pg_proc proc;
+ char functyptype;
+ int numargs;
+ Oid *argtypes;
+ char **argnames;
+ char *argmodes;
+ bool istrigger = false;
+ int i;
+
+ if (!CheckFunctionValidatorAccess(fcinfo->flinfo->fn_oid, funcoid))
+ PG_RETURN_VOID();
+
+ /* Get the new function's pg_proc entry */
+ tuple = SearchSysCache1(PROCOID, ObjectIdGetDatum(funcoid));
+ if (!HeapTupleIsValid(tuple))
+ elog(ERROR, "cache lookup failed for function %u", funcoid);
+ proc = (Form_pg_proc) GETSTRUCT(tuple);
+
+ functyptype = get_typtype(proc->prorettype);
+
+ /* Disallow pseudotype result */
+ /* except for TRIGGER, RECORD, or VOID */
+ if (functyptype == TYPTYPE_PSEUDO)
+ {
+ /* we assume OPAQUE with no arguments means a trigger */
+ if (proc->prorettype == TRIGGEROID ||
+ (proc->prorettype == OPAQUEOID && proc->pronargs == 0))
+ istrigger = true;
+ else if (proc->prorettype != RECORDOID &&
+ proc->prorettype != VOIDOID)
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("PL/Perl functions cannot return type %s",
+ format_type_be(proc->prorettype))));
+ }
+
+ /* Disallow pseudotypes in arguments (either IN or OUT) */
+ numargs = get_func_arg_info(tuple,
+ &argtypes, &argnames, &argmodes);
+ for (i = 0; i < numargs; i++)
+ {
+ if (get_typtype(argtypes[i]) == TYPTYPE_PSEUDO &&
+ argtypes[i] != RECORDOID)
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("PL/Perl functions cannot accept type %s",
+ format_type_be(argtypes[i]))));
+ }
+
+ ReleaseSysCache(tuple);
+
+ /* Postpone body checks if !check_function_bodies */
+ if (check_function_bodies)
+ {
+ (void) compile_plperl_function(funcoid, istrigger);
+ }
+
+ /* the result of a validator is ignored */
+ PG_RETURN_VOID();
+}
+
+
+/*
+ * plperlu likewise requires three externally visible functions:
+ * plperlu_call_handler, plperlu_inline_handler, and plperlu_validator.
+ * These are currently just aliases that send control to the plperl
+ * handler functions, and we decide whether a particular function is
+ * trusted or not by inspecting the actual pg_language tuple.
+ */
+
+PG_FUNCTION_INFO_V1(plperlu_call_handler);
+
+Datum
+plperlu_call_handler(PG_FUNCTION_ARGS)
+{
+ return plperl_call_handler(fcinfo);
+}
+
+#ifdef INLINE_FUNCTION_SUPPORT
+PG_FUNCTION_INFO_V1(plperlu_inline_handler);
+
+Datum
+plperlu_inline_handler(PG_FUNCTION_ARGS)
+{
+ return plperl_inline_handler(fcinfo);
+}
+#endif
+
+PG_FUNCTION_INFO_V1(plperlu_validator);
+
+Datum
+plperlu_validator(PG_FUNCTION_ARGS)
+{
+ return plperl_validator(fcinfo);
+}
+
+
+/*
+ * Uses mksafefunc/mkunsafefunc to create a subroutine whose text is
+ * supplied in s, and returns a reference to it
+ */
+static void
+plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid)
+{
+ dSP;
+ char subname[NAMEDATALEN + 40];
+ HV *pragma_hv = newHV();
+ SV *subref = NULL;
+ int count;
+
+ sprintf(subname, "%s__%u", prodesc->proname, fn_oid);
+
+ if (plperl_use_strict)
+ hv_store_string(pragma_hv, "strict", (SV *) newAV());
+
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ EXTEND(SP, 4);
+ PUSHs(sv_2mortal(cstr2sv(subname)));
+ PUSHs(sv_2mortal(newRV_noinc((SV *) pragma_hv)));
+
+ /*
+ * Use 'false' for $prolog in mkfunc, which is kept for compatibility in
+ * case a module such as PostgreSQL::PLPerl::NYTprof replaces the function
+ * compiler.
+ */
+ PUSHs(&PL_sv_no);
+ PUSHs(sv_2mortal(cstr2sv(s)));
+ PUTBACK;
+
+ /*
+ * G_KEEPERR seems to be needed here, else we don't recognize compile
+ * errors properly. Perhaps it's because there's another level of eval
+ * inside mksafefunc?
+ */
+ count = perl_call_pv("PostgreSQL::InServer::mkfunc",
+ G_SCALAR | G_EVAL | G_KEEPERR);
+ SPAGAIN;
+
+ if (count == 1)
+ {
+ SV *sub_rv = (SV *) POPs;
+
+ if (sub_rv && SvROK(sub_rv) && SvTYPE(SvRV(sub_rv)) == SVt_PVCV)
+ {
+ subref = newRV_inc(SvRV(sub_rv));
+ }
+ }
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ if (SvTRUE(ERRSV))
+ ereport(ERROR,
+ (errcode(ERRCODE_SYNTAX_ERROR),
+ errmsg("creation of Perl function failed"),
+ errdetail("%s", strip_trailing_ws(SvPV(ERRSV, PL_na))),
+ errOmitLocation(true)));
+
+ if (!subref)
+ ereport(ERROR,
+ (errmsg("didn't get a CODE reference from compiling function \"%s\"",
+ prodesc->proname)));
+
+ prodesc->reference = subref;
+
+ return;
+}
+
+
+/**********************************************************************
+ * plperl_init_shared_libs() -
+ **********************************************************************/
+
+static void
+plperl_init_shared_libs(pTHX)
+{
+ char *file = __FILE__;
+
+ newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
+ newXS("PostgreSQL::InServer::Util::bootstrap",
+ boot_PostgreSQL__InServer__Util, file);
+ /* newXS for...::SPI::bootstrap is in select_perl_context() */
+}
+
+
+static SV *
+plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
+{
+ dSP;
+ SV *retval;
+ int i;
+ int count;
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP);
+ EXTEND(sp, desc->nargs);
+
+ for (i = 0; i < desc->nargs; i++)
+ {
+ if (fcinfo->argnull[i])
+ PUSHs(&PL_sv_undef);
+ else if (desc->arg_is_rowtype[i])
+ {
+ SV *sv = plperl_hash_from_datum(fcinfo->arg[i]);
+
+ PUSHs(sv_2mortal(sv));
+ }
+ else
+ {
+ SV *sv;
+
+ if (OidIsValid(desc->arg_arraytype[i]))
+ sv = plperl_ref_from_pg_array(fcinfo->arg[i], desc->arg_arraytype[i]);
+ else
+ {
+ char *tmp;
+
+ tmp = OutputFunctionCall(&(desc->arg_out_func[i]),
+ fcinfo->arg[i]);
+ sv = cstr2sv(tmp);
+ pfree(tmp);
+ }
+
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ PUTBACK;
+
+ /* Do NOT use G_KEEPERR here */
+ count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL);
+
+ SPAGAIN;
+
+ if (count != 1)
+ {
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ elog(ERROR, "didn't get a return item from function");
+ }
+
+ if (SvTRUE(ERRSV))
+ {
+ (void) POPs;
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ /* XXX need to find a way to assign an errcode here */
+ ereport(ERROR,
+ (errmsg("Perl function \"%s\" failed", desc->proname),
+ errdetail("%s", strip_trailing_ws(SvPV(ERRSV, PL_na)))));
+ }
+
+ retval = newSVsv(POPs);
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ return retval;
+}
+
+
+static SV *
+plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
+ SV *td)
+{
+ dSP;
+ SV *retval,
+ *TDsv;
+ int i,
+ count;
+ Trigger *tg_trigger = ((TriggerData *) fcinfo->context)->tg_trigger;
+
+ ENTER;
+ SAVETMPS;
+
+ TDsv = get_sv("_TD", GV_ADD);
+ SAVESPTR(TDsv); /* local $_TD */
+ sv_setsv(TDsv, td);
+
+ PUSHMARK(sp);
+ EXTEND(sp, tg_trigger->tgnargs);
+
+ for (i = 0; i < tg_trigger->tgnargs; i++)
+ PUSHs(sv_2mortal(cstr2sv(tg_trigger->tgargs[i])));
+ PUTBACK;
+
+ /* Do NOT use G_KEEPERR here */
+ count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL);
+
+ SPAGAIN;
+
+ if (count != 1)
+ {
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ elog(ERROR, "didn't get a return item from trigger function");
+ }
+
+ if (SvTRUE(ERRSV))
+ {
+ (void) POPs;
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ /* XXX need to find a way to assign an errcode here */
+ ereport(ERROR,
+ (errmsg("Perl trigger function \"%s\" failed", desc->proname),
+ errdetail("%s", strip_trailing_ws(SvPV(ERRSV, PL_na)))));
+ }
+
+ retval = newSVsv(POPs);
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ return retval;
+}
+
+
+static Datum
+plperl_func_handler(PG_FUNCTION_ARGS)
+{
+ plperl_proc_desc *prodesc;
+ SV *perlret;
+ Datum retval = 0;
+ ReturnSetInfo *rsi;
+ ErrorContextCallback pl_error_context;
+ bool has_retval = false;
+
+ /*
+ * Create the call_data beforing connecting to SPI, so that it is not
+ * allocated in the SPI memory context
+ */
+ current_call_data = (plperl_call_data *) palloc0(sizeof(plperl_call_data));
+ current_call_data->fcinfo = fcinfo;
+
+ if (SPI_connect() != SPI_OK_CONNECT)
+ elog(ERROR, "could not connect to SPI manager");
+
+ prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
+ current_call_data->prodesc = prodesc;
+
+ /* Set a callback for error reporting */
+ pl_error_context.callback = plperl_exec_callback;
+ pl_error_context.previous = error_context_stack;
+ pl_error_context.arg = prodesc->proname;
+ error_context_stack = &pl_error_context;
+
+ rsi = (ReturnSetInfo *) fcinfo->resultinfo;
+
+ if (prodesc->fn_retisset)
+ {
+ /* Check context before allowing the call to go through */
+ if (!rsi || !IsA(rsi, ReturnSetInfo) ||
+ (rsi->allowedModes & SFRM_Materialize) == 0)
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("Unsupported Perl function \"%s\"",
+ prodesc->proname),
+ errdetail("set-valued function called in context that "
+ "cannot accept a set")));
+ if(rsi->expectedDesc == NULL)
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("Unsupported Perl function \"%s\"",
+ prodesc->proname),
+ errdetail("function returning record called in context "
+ "that cannot accept type record")));
+ }
+
+ activate_interpreter(prodesc->interp);
+
+ if (prodesc->fn_retisset)
+ {
+ if(NULL==fcinfo->flinfo->fn_extra)
+ fcinfo->flinfo->fn_extra = AllocSetContextCreate(rsi->econtext->ecxt_per_query_memory,
+ "tuplestore temporary cxt",
+ ALLOCSET_DEFAULT_MINSIZE,
+ ALLOCSET_DEFAULT_INITSIZE,
+ ALLOCSET_DEFAULT_MAXSIZE);
+ else
+ MemoryContextReset(fcinfo->flinfo->fn_extra);
+ }
+
+ perlret = plperl_call_perl_func(prodesc, fcinfo);
+
+ /************************************************************
+ * Disconnect from SPI manager and then create the return
+ * values datum (if the input function does a palloc for it
+ * this must not be allocated in the SPI memory context
+ * because SPI_finish would free it).
+ ************************************************************/
+ if (SPI_finish() != SPI_OK_FINISH)
+ elog(ERROR, "SPI_finish() failed");
+
+ if (prodesc->fn_retisset)
+ {
+ SV *sav;
+
+ /*
+ * If the Perl function returned an arrayref, we pretend that it
+ * called return_next() for each element of the array, to handle old
+ * SRFs that didn't know about return_next(). Any other sort of return
+ * value is an error, except undef which means return an empty set.
+ */
+ sav = get_perl_array_ref(perlret);
+ if (sav)
+ {
+ int i = 0;
+ SV **svp = 0;
+ AV *rav = (AV *) SvRV(sav);
+
+ while ((svp = av_fetch(rav, i, FALSE)) != NULL)
+ {
+ plperl_return_next(*svp);
+ i++;
+ }
+ }
+ else if (SvOK(perlret))
+ {
+ ereport(ERROR,
+ (errcode(ERRCODE_DATATYPE_MISMATCH),
+ errmsg("set-returning PL/Perl function must return "
+ "reference to array or use return_next")));
+ }
+
+ rsi->returnMode = SFRM_Materialize;
+ if (current_call_data->tuple_store)
+ {
+ rsi->setResult = current_call_data->tuple_store;
+ rsi->setDesc = current_call_data->ret_tdesc;
+ }
+ retval = (Datum) 0;
+ has_retval = true;
+ }
+ else if (!SvOK(perlret))
+ {
+ /* Return NULL if Perl code returned undef */
+ if (rsi && IsA(rsi, ReturnSetInfo))
+ rsi->isDone = ExprEndResult;
+ }
+ else if (prodesc->fn_retistuple)
+ {
+ /* Return a perl hash converted to a Datum */
+ TupleDesc td;
+
+ if (!SvOK(perlret) || !SvROK(perlret) ||
+ SvTYPE(SvRV(perlret)) != SVt_PVHV)
+ {
+ ereport(ERROR,
+ (errcode(ERRCODE_DATATYPE_MISMATCH),
+ errmsg("composite-returning PL/Perl function "
+ "must return reference to hash"),
+ errOmitLocation(true)));
+ }
+
+ /* XXX should cache the attinmeta data instead of recomputing */
+ if (get_call_result_type(fcinfo, NULL, &td) != TYPEFUNC_COMPOSITE)
+ {
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("function returning record called in context "
+ "that cannot accept type record"),
+ errOmitLocation(true)));
+ }
+
+ retval = plperl_hash_to_datum(perlret, td);
+ has_retval = true;
+ }
+
+ if (!has_retval)
+ {
+ bool isnull;
+
+ retval = plperl_sv_to_datum(perlret,
+ &prodesc->result_in_func,
+ prodesc->result_oid,
+ prodesc->result_typioparam, -1, &isnull);
+ fcinfo->isnull = isnull;
+ has_retval = true;
+ }
+
+ /* Restore the previous error callback */
+ error_context_stack = pl_error_context.previous;
+
+ SvREFCNT_dec(perlret);
+
+ return retval;
+}
+
+
+static Datum
+plperl_trigger_handler(PG_FUNCTION_ARGS)
+{
+ plperl_proc_desc *prodesc;
+ SV *perlret;
+ Datum retval;
+ SV *svTD;
+ HV *hvTD;
+ ErrorContextCallback pl_error_context;
+
+ /*
+ * Create the call_data beforing connecting to SPI, so that it is not
+ * allocated in the SPI memory context
+ */
+ current_call_data = (plperl_call_data *) palloc0(sizeof(plperl_call_data));
+ current_call_data->fcinfo = fcinfo;
+
+ /* Connect to SPI manager */
+ if (SPI_connect() != SPI_OK_CONNECT)
+ elog(ERROR, "could not connect to SPI manager");
+
+ /* Find or compile the function */
+ prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true);
+ current_call_data->prodesc = prodesc;
+
+ /* Set a callback for error reporting */
+ pl_error_context.callback = plperl_exec_callback;
+ pl_error_context.previous = error_context_stack;
+ pl_error_context.arg = prodesc->proname;
+ error_context_stack = &pl_error_context;
+
+ activate_interpreter(prodesc->interp);
+
+ svTD = plperl_trigger_build_args(fcinfo);
+ perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
+ hvTD = (HV *) SvRV(svTD);
+
+ /************************************************************
+ * Disconnect from SPI manager and then create the return
+ * values datum (if the input function does a palloc for it
+ * this must not be allocated in the SPI memory context
+ * because SPI_finish would free it).
+ ************************************************************/
+ if (SPI_finish() != SPI_OK_FINISH)
+ elog(ERROR, "SPI_finish() failed");
+
+ if (perlret == NULL || !SvOK(perlret))
+ {
+ /* undef result means go ahead with original tuple */
+ TriggerData *trigdata = ((TriggerData *) fcinfo->context);
+
+ if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
+ retval = PointerGetDatum(trigdata->tg_trigtuple);
+ else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
+ retval = PointerGetDatum(trigdata->tg_newtuple);
+ else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
+ retval = PointerGetDatum(trigdata->tg_trigtuple);
+ /*else if (TRIGGER_FIRED_BY_TRUNCATE(trigdata->tg_event))
+ retval = (Datum) trigdata->tg_trigtuple;*/
+ else
+ retval = (Datum) 0; /* can this happen? */
+ }
+ else
+ {
+ HeapTuple trv;
+ char *tmp;
+
+ tmp = sv2cstr(perlret);
+
+ if (pg_strcasecmp(tmp, "SKIP") == 0)
+ trv = NULL;
+ else if (pg_strcasecmp(tmp, "MODIFY") == 0)
+ {
+ TriggerData *trigdata = (TriggerData *) fcinfo->context;
+
+ if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
+ trv = plperl_modify_tuple(hvTD, trigdata,
+ trigdata->tg_trigtuple);
+ else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
+ trv = plperl_modify_tuple(hvTD, trigdata,
+ trigdata->tg_newtuple);
+ else
+ {
+ ereport(WARNING,
+ (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
+ errmsg("ignoring modified row in DELETE trigger")));
+ trv = NULL;
+ }
+ }
+ else
+ {
+ ereport(ERROR,
+ (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
+ errmsg("result of PL/Perl trigger function must be undef, "
+ "\"SKIP\", or \"MODIFY\"")));
+ trv = NULL;
+ }
+ retval = PointerGetDatum(trv);
+ pfree(tmp);
+ }
+
+ /* Restore the previous error callback */
+ error_context_stack = pl_error_context.previous;
+
+ SvREFCNT_dec(svTD);
+ if (perlret)
+ SvREFCNT_dec(perlret);
+
+ return retval;
+}
+
+
+static bool
+validate_plperl_function(plperl_proc_ptr *proc_ptr, HeapTuple procTup)
+{
+ if (proc_ptr && proc_ptr->proc_ptr)
+ {
+ plperl_proc_desc *prodesc = proc_ptr->proc_ptr;
+ bool uptodate;
+
+ /************************************************************
+ * If it's present, must check whether it's still up to date.
+ * This is needed because CREATE OR REPLACE FUNCTION can modify the
+ * function's pg_proc entry without changing its OID.
+ ************************************************************/
+ uptodate = (prodesc->fn_xmin == HeapTupleHeaderGetXmin(procTup->t_data) &&
+ prodesc->fn_cmin == HeapTupleHeaderGetCmin(procTup->t_data));
+
+ if (uptodate)
+ return true;
+
+ /* Otherwise, unlink the obsoleted entry from the hashtable ... */
+ proc_ptr->proc_ptr = NULL;
+ /* ... and throw it away */
+ if (prodesc->reference)
+ {
+ plperl_interp_desc *oldinterp = plperl_active_interp;
+
+ activate_interpreter(prodesc->interp);
+ SvREFCNT_dec(prodesc->reference);
+ activate_interpreter(oldinterp);
+ }
+ free(prodesc->proname);
+ free(prodesc);
+ }
+
+ return false;
+}
+
+
+static plperl_proc_desc *
+compile_plperl_function(Oid fn_oid, bool is_trigger)
+{
+ HeapTuple procTup;
+ Form_pg_proc procStruct;
+ plperl_proc_key proc_key;
+ plperl_proc_ptr *proc_ptr;
+ plperl_proc_desc *prodesc = NULL;
+ int i;
+ plperl_interp_desc *oldinterp = plperl_active_interp;
+ ErrorContextCallback plperl_error_context;
+
+ /* We'll need the pg_proc tuple in any case... */
+ procTup = SearchSysCache1(PROCOID, ObjectIdGetDatum(fn_oid));
+ if (!HeapTupleIsValid(procTup))
+ elog(ERROR, "cache lookup failed for function %u", fn_oid);
+ procStruct = (Form_pg_proc) GETSTRUCT(procTup);
+
+ /* Set a callback for reporting compilation errors */
+ plperl_error_context.callback = plperl_compile_callback;
+ plperl_error_context.previous = error_context_stack;
+ plperl_error_context.arg = NameStr(procStruct->proname);
+ error_context_stack = &plperl_error_context;
+
+ /* Try to find function in plperl_proc_hash */
+ proc_key.proc_id = fn_oid;
+ proc_key.is_trigger = is_trigger;
+ proc_key.user_id = GetUserId();
+
+ proc_ptr = hash_search(plperl_proc_hash, &proc_key,
+ HASH_FIND, NULL);
+
+ if (validate_plperl_function(proc_ptr, procTup))
+ prodesc = proc_ptr->proc_ptr;
+ else
+ {
+ /* If not found or obsolete, maybe it's plperlu */
+ proc_key.user_id = InvalidOid;
+ proc_ptr = hash_search(plperl_proc_hash, &proc_key,
+ HASH_FIND, NULL);
+ if (validate_plperl_function(proc_ptr, procTup))
+ prodesc = proc_ptr->proc_ptr;
+ }
+
+ /************************************************************
+ * If we haven't found it in the hashtable, we analyze
+ * the function's arguments and return type and store
+ * the in-/out-functions in the prodesc block and create
+ * a new hashtable entry for it.
+ *
+ * Then we load the procedure into the Perl interpreter.
+ ************************************************************/
+ if (prodesc == NULL)
+ {
+ HeapTuple langTup;
+ HeapTuple typeTup;
+ Form_pg_language langStruct;
+ Form_pg_type typeStruct;
+ Datum prosrcdatum;
+ bool isnull;
+ char *proc_source;
+
+ /************************************************************
+ * Allocate a new procedure description block
+ ************************************************************/
+ prodesc = (plperl_proc_desc *) malloc(sizeof(plperl_proc_desc));
+ if (prodesc == NULL)
+ ereport(ERROR,
+ (errcode(ERRCODE_OUT_OF_MEMORY),
+ errmsg("out of memory")));
+ MemSet(prodesc, 0, sizeof(plperl_proc_desc));
+ prodesc->proname = strdup(NameStr(procStruct->proname));
+ if (prodesc->proname == NULL)
+ ereport(ERROR,
+ (errcode(ERRCODE_OUT_OF_MEMORY),
+ errmsg("out of memory")));
+ prodesc->fn_xmin = HeapTupleHeaderGetXmin(procTup->t_data);
+ prodesc->fn_cmin = HeapTupleHeaderGetCmin(procTup->t_data);
+
+ /* Remember if function is STABLE/IMMUTABLE */
+ prodesc->fn_readonly =
+ (procStruct->provolatile != PROVOLATILE_VOLATILE);
+
+ /************************************************************
+ * Lookup the pg_language tuple by Oid
+ ************************************************************/
+ langTup = SearchSysCache1(LANGOID,
+ ObjectIdGetDatum(procStruct->prolang));
+ if (!HeapTupleIsValid(langTup))
+ {
+ free(prodesc->proname);
+ free(prodesc);
+ elog(ERROR, "cache lookup failed for language %u",
+ procStruct->prolang);
+ }
+ langStruct = (Form_pg_language) GETSTRUCT(langTup);
+ prodesc->lanpltrusted = langStruct->lanpltrusted;
+ ReleaseSysCache(langTup);
+
+ /************************************************************
+ * Get the required information for input conversion of the
+ * return value.
+ ************************************************************/
+ if (!is_trigger)
+ {
+ typeTup =
+ SearchSysCache1(TYPEOID,
+ ObjectIdGetDatum(procStruct->prorettype));
+ if (!HeapTupleIsValid(typeTup))
+ {
+ free(prodesc->proname);
+ free(prodesc);
+ elog(ERROR, "cache lookup failed for type %u",
+ procStruct->prorettype);
+ }
+ typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
+
+ /* Disallow pseudotype result, except VOID or RECORD */
+ if (typeStruct->typtype == TYPTYPE_PSEUDO)
+ {
+ if (procStruct->prorettype == VOIDOID ||
+ procStruct->prorettype == RECORDOID)
+ /* okay */ ;
+ else if (procStruct->prorettype == TRIGGEROID)
+ {
+ free(prodesc->proname);
+ free(prodesc);
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("trigger functions can only be called "
+ "as triggers")));
+ }
+ else
+ {
+ free(prodesc->proname);
+ free(prodesc);
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("PL/Perl functions cannot return type %s",
+ format_type_be(procStruct->prorettype))));
+ }
+ }
+
+ prodesc->result_oid = procStruct->prorettype;
+ prodesc->fn_retisset = procStruct->proretset;
+ prodesc->fn_retistuple = (procStruct->prorettype == RECORDOID ||
+ typeStruct->typtype == TYPTYPE_COMPOSITE);
+
+ prodesc->fn_retisarray =
+ (typeStruct->typlen == -1 && typeStruct->typelem);
+
+ perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
+ prodesc->result_typioparam = getTypeIOParam(typeTup);
+
+ ReleaseSysCache(typeTup);
+ }
+
+ /************************************************************
+ * Get the required information for output conversion
+ * of all procedure arguments
+ ************************************************************/
+ if (!is_trigger)
+ {
+ prodesc->nargs = procStruct->pronargs;
+ for (i = 0; i < prodesc->nargs; i++)
+ {
+ typeTup = SearchSysCache1(TYPEOID,
+ ObjectIdGetDatum(procStruct->proargtypes.values[i]));
+ if (!HeapTupleIsValid(typeTup))
+ {
+ free(prodesc->proname);
+ free(prodesc);
+ elog(ERROR, "cache lookup failed for type %u",
+ procStruct->proargtypes.values[i]);
+ }
+ typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
+
+ /* Disallow pseudotype argument */
+ if (typeStruct->typtype == TYPTYPE_PSEUDO &&
+ procStruct->proargtypes.values[i] != RECORDOID)
+ {
+ free(prodesc->proname);
+ free(prodesc);
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("PL/Perl functions cannot accept type %s",
+ format_type_be(procStruct->proargtypes.values[i]))));
+ }
+
+ if (typeStruct->typtype == TYPTYPE_COMPOSITE ||
+ procStruct->proargtypes.values[i] == RECORDOID)
+ prodesc->arg_is_rowtype[i] = true;
+ else
+ {
+ prodesc->arg_is_rowtype[i] = false;
+ perm_fmgr_info(typeStruct->typoutput,
+ &(prodesc->arg_out_func[i]));
+ }
+
+ /* Identify array attributes */
+ if (typeStruct->typelem != 0 && typeStruct->typlen == -1)
+ prodesc->arg_arraytype[i] = procStruct->proargtypes.values[i];
+ else
+ prodesc->arg_arraytype[i] = InvalidOid;
+
+ ReleaseSysCache(typeTup);
+ }
+ }
+
+ /************************************************************
+ * create the text of the anonymous subroutine.
+ * we do not use a named subroutine so that we can call directly
+ * through the reference.
+ ************************************************************/
+ prosrcdatum = SysCacheGetAttr(PROCOID, procTup,
+ Anum_pg_proc_prosrc, &isnull);
+ if (isnull)
+ elog(ERROR, "null prosrc");
+ proc_source = TextDatumGetCString(prosrcdatum);
+
+ /************************************************************
+ * Create the procedure in the appropriate interpreter
+ ************************************************************/
+
+ select_perl_context(prodesc->lanpltrusted);
+
+ prodesc->interp = plperl_active_interp;
+
+ plperl_create_sub(prodesc, proc_source, fn_oid);
+
+ activate_interpreter(oldinterp);
+
+ pfree(proc_source);
+ if (!prodesc->reference) /* can this happen? */
+ {
+ free(prodesc->proname);
+ free(prodesc);
+ elog(ERROR, "could not create PL/Perl internal procedure");
+ }
+
+ /************************************************************
+ * OK, link the procedure into the correct hashtable entry
+ ************************************************************/
+ proc_key.user_id = prodesc->lanpltrusted ? GetUserId() : InvalidOid;
+
+ proc_ptr = hash_search(plperl_proc_hash, &proc_key,
+ HASH_ENTER, NULL);
+ proc_ptr->proc_ptr = prodesc;
+ }
+
+ /* restore previous error callback */
+ error_context_stack = plperl_error_context.previous;
+
+ ReleaseSysCache(procTup);
+
+ return prodesc;
+}
+
+/* Build a hash from a given composite/row datum */
+static SV *
+plperl_hash_from_datum(Datum attr)
+{
+ HeapTupleHeader td;
+ Oid tupType;
+ int32 tupTypmod;
+ TupleDesc tupdesc;
+ HeapTupleData tmptup;
+ SV *sv;
+
+ td = DatumGetHeapTupleHeader(attr);
+
+ /* Extract rowtype info and find a tupdesc */
+ tupType = HeapTupleHeaderGetTypeId(td);
+ tupTypmod = HeapTupleHeaderGetTypMod(td);
+ tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod);
+
+ /* Build a temporary HeapTuple control structure */
+ tmptup.t_len = HeapTupleHeaderGetDatumLength(td);
+ tmptup.t_data = td;
+
+ sv = plperl_hash_from_tuple(&tmptup, tupdesc);
+ ReleaseTupleDesc(tupdesc);
+
+ return sv;
+}
+
+/* Build a hash from all attributes of a given tuple. */
+static SV *
+plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
+{
+ HV *hv;
+ int i;
+
+ /* since this function recurses, it could be driven to stack overflow */
+ check_stack_depth();
+
+ hv = newHV();
+ hv_ksplit(hv, tupdesc->natts); /* pre-grow the hash */
+
+ for (i = 0; i < tupdesc->natts; i++)
+ {
+ Datum attr;
+ bool isnull,
+ typisvarlena;
+ char *attname;
+ Oid typoutput;
+
+ if (tupdesc->attrs[i]->attisdropped)
+ continue;
+
+ attname = NameStr(tupdesc->attrs[i]->attname);
+ attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
+
+ if (isnull)
+ {
+ /* Store (attname => undef) and move on. */
+ hv_store_string(hv, attname, &PL_sv_undef);
+ continue;
+ }
+
+ if (type_is_rowtype(tupdesc->attrs[i]->atttypid))
+ {
+ SV *sv = plperl_hash_from_datum(attr);
+
+ hv_store_string(hv, attname, sv);
+ }
+ else
+ {
+ SV *sv;
+
+ if (OidIsValid(get_base_element_type(tupdesc->attrs[i]->atttypid)))
+ sv = plperl_ref_from_pg_array(attr, tupdesc->attrs[i]->atttypid);
+ else
+ {
+ char *outputstr;
+
+ /* XXX should have a way to cache these lookups */
+ getTypeOutputInfo(tupdesc->attrs[i]->atttypid,
+ &typoutput, &typisvarlena);
+
+ outputstr = OidOutputFunctionCall(typoutput, attr);
+ sv = cstr2sv(outputstr);
+ pfree(outputstr);
+ }
+
+ hv_store_string(hv, attname, sv);
+ }
+ }
+ return newRV_noinc((SV *) hv);
+}
+
+static void
+check_spi_usage_allowed()
+{
+ /* see comment in plperl_fini() */
+ if (plperl_ending)
+ {
+ /* simple croak as we don't want to involve PostgreSQL code */
+ croak("SPI functions can not be used in END blocks");
+ }
+}
+
+
+HV *
+plperl_spi_exec(char *query, int limit)
+{
+ HV *ret_hv;
+
+ /*
+ * Execute the query inside a sub-transaction, so we can cope with errors
+ * sanely
+ */
+ MemoryContext oldcontext = CurrentMemoryContext;
+ ResourceOwner oldowner = CurrentResourceOwner;
+
+ check_spi_usage_allowed();
+
+ BeginInternalSubTransaction(NULL);
+ /* Want to run inside function's memory context */
+ MemoryContextSwitchTo(oldcontext);
+
+ PG_TRY();
+ {
+ int spi_rv;
+
+ pg_verifymbstr(query, strlen(query), false);
+
+ spi_rv = SPI_execute(query, current_call_data->prodesc->fn_readonly,
+ limit);
+ ret_hv = plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed,
+ spi_rv);
+
+ /* Commit the inner transaction, return to outer xact context */
+ ReleaseCurrentSubTransaction();
+ MemoryContextSwitchTo(oldcontext);
+ CurrentResourceOwner = oldowner;
+
+ /*
+ * AtEOSubXact_SPI() should not have popped any SPI context, but just
+ * in case it did, make sure we remain connected.
+ */
+ SPI_restore_connection();
+ }
+ PG_CATCH();
+ {
+ ErrorData *edata;
+
+ /* Save error info */
+ MemoryContextSwitchTo(oldcontext);
+ edata = CopyErrorData();
+ FlushErrorState();
+
+ /* Abort the inner transaction */
+ RollbackAndReleaseCurrentSubTransaction();
+ MemoryContextSwitchTo(oldcontext);
+ CurrentResourceOwner = oldowner;
+
+ /*
+ * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
+ * have left us in a disconnected state. We need this hack to return
+ * to connected state.
+ */
+ SPI_restore_connection();
+
+ /* Punt the error to Perl */
+ croak("%s", edata->message);
+
+ /* Can't get here, but keep compiler quiet */
+ return NULL;
+ }
+ PG_END_TRY();
+
+ return ret_hv;
+}
+
+
+static HV *
+plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
+ int status)
+{
+ HV *result;
+
+ check_spi_usage_allowed();
+
+ result = newHV();
+
+ hv_store_string(result, "status",
+ cstr2sv(SPI_result_code_string(status)));
+ hv_store_string(result, "processed",
+ newSViv(processed));
+
+ if (status > 0 && tuptable)
+ {
+ AV *rows;
+ SV *row;
+ int i;
+
+ rows = newAV();
+ av_extend(rows, processed);
+ for (i = 0; i < processed; i++)
+ {
+ row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
+ av_push(rows, row);
+ }
+ hv_store_string(result, "rows",
+ newRV_noinc((SV *) rows));
+ }
+
+ SPI_freetuptable(tuptable);
+
+ return result;
+}
+
+
+/*
+ * Note: plperl_return_next is called both in Postgres and Perl contexts.
+ * We report any errors in Postgres fashion (via ereport). If called in
+ * Perl context, it is SPI.xs's responsibility to catch the error and
+ * convert to a Perl error. We assume (perhaps without adequate justification)
+ * that we need not abort the current transaction if the Perl code traps the
+ * error.
+ */
+void
+plperl_return_next(SV *sv)
+{
+ plperl_proc_desc *prodesc;
+ FunctionCallInfo fcinfo;
+ ReturnSetInfo *rsi;
+ MemoryContext old_cxt;
+
+ if (!sv)
+ return;
+
+ prodesc = current_call_data->prodesc;
+ fcinfo = current_call_data->fcinfo;
+ rsi = (ReturnSetInfo *) fcinfo->resultinfo;
+
+ if (!prodesc->fn_retisset)
+ ereport(ERROR,
+ (errcode(ERRCODE_SYNTAX_ERROR),
+ errmsg("cannot use return_next in a non-SETOF function")));
+
+ if (prodesc->fn_retistuple &&
+ !(SvOK(sv) && SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV))
+ ereport(ERROR,
+ (errcode(ERRCODE_DATATYPE_MISMATCH),
+ errmsg("SETOF-composite-returning PL/Perl function "
+ "must call return_next with reference to hash")));
+
+ if (!current_call_data->ret_tdesc)
+ {
+ TupleDesc tupdesc;
+
+ Assert(!current_call_data->tuple_store);
+ Assert(!current_call_data->attinmeta);
+
+ /*
+ * This is the first call to return_next in the current PL/Perl
+ * function call, so memoize some lookups
+ */
+ if (prodesc->fn_retistuple)
+ (void) get_call_result_type(fcinfo, NULL, &tupdesc);
+ else
+ tupdesc = rsi->expectedDesc;
+
+ /*
+ * Make sure the tuple_store and ret_tdesc are sufficiently
+ * long-lived.
+ */
+ old_cxt = MemoryContextSwitchTo(fcinfo->flinfo->fn_extra);
+
+ current_call_data->ret_tdesc = CreateTupleDescCopy(tupdesc);
+ current_call_data->tuple_store =
+ tuplestore_begin_heap(rsi->allowedModes,
+ false, work_mem);
+ if (prodesc->fn_retistuple)
+ {
+ current_call_data->attinmeta =
+ TupleDescGetAttInMetadata(current_call_data->ret_tdesc);
+ }
+
+ MemoryContextSwitchTo(old_cxt);
+ }
+
+ /*
+ * Producing the tuple we want to return requires making plenty of
+ * palloc() allocations that are not cleaned up. Since this function can
+ * be called many times before the current memory context is reset, we
+ * need to do those allocations in a temporary context.
+ */
+ if (!current_call_data->tmp_cxt)
+ {
+ current_call_data->tmp_cxt =
+ AllocSetContextCreate(rsi->econtext->ecxt_per_tuple_memory,
+ "PL/Perl return_next temporary cxt",
+ ALLOCSET_DEFAULT_MINSIZE,
+ ALLOCSET_DEFAULT_INITSIZE,
+ ALLOCSET_DEFAULT_MAXSIZE);
+ }
+
+ old_cxt = MemoryContextSwitchTo(current_call_data->tmp_cxt);
+ HeapTuple tuple;
+ if (prodesc->fn_retistuple)
+ {
+ tuple = plperl_build_tuple_result((HV *) SvRV(sv),
+ current_call_data->attinmeta);
+ MemoryContextSwitchTo(fcinfo->flinfo->fn_extra);
+ tuplestore_puttuple(current_call_data->tuple_store, tuple);
+ MemoryContextSwitchTo(current_call_data->tmp_cxt);
+ }
+ else
+ {
+ Datum ret;
+ bool isNull;
+ MemTupleBinding *pbind = NULL;
+
+ ret = plperl_sv_to_datum(sv,
+ &prodesc->result_in_func,
+ prodesc->result_oid,
+ prodesc->result_typioparam,
+ -1, &isNull);
+
+ pbind = create_memtuple_binding(current_call_data->ret_tdesc);
+ tuple = (HeapTuple)memtuple_form_to(pbind, &ret, &isNull,NULL, NULL, false);
+
+ MemoryContextSwitchTo(fcinfo->flinfo->fn_extra);
+ tuplestore_puttuple(current_call_data->tuple_store, tuple);
+ MemoryContextSwitchTo(current_call_data->tmp_cxt);
+
+ destroy_memtuple_binding(pbind);
+ }
+ MemoryContextSwitchTo(old_cxt);
+ MemoryContextReset(current_call_data->tmp_cxt);
+
+}
+
+
+SV *
+plperl_spi_query(char *query)
+{
+ SV *cursor;
+
+ /*
+ * Execute the query inside a sub-transaction, so we can cope with errors
+ * sanely
+ */
+ MemoryContext oldcontext = CurrentMemoryContext;
+ ResourceOwner oldowner = CurrentResourceOwner;
+
+ check_spi_usage_allowed();
+
+ BeginInternalSubTransaction(NULL);
+ /* Want to run inside function's memory context */
+ MemoryContextSwitchTo(oldcontext);
+
+ PG_TRY();
+ {
+ void *plan;
+ Portal portal;
+
+ /* Make sure the query is validly encoded */
+ pg_verifymbstr(query, strlen(query), false);
+
+ /* Create a cursor for the query */
+ plan = SPI_prepare(query, 0, NULL);
+ if (plan == NULL)
+ elog(ERROR, "SPI_prepare() failed:%s",
+ SPI_result_code_string(SPI_result));
+
+ portal = SPI_cursor_open(NULL, plan, NULL, NULL, false);
+ SPI_freeplan(plan);
+ if (portal == NULL)
+ elog(ERROR, "SPI_cursor_open() failed:%s",
+ SPI_result_code_string(SPI_result));
+ cursor = cstr2sv(portal->name);
+
+ /* Commit the inner transaction, return to outer xact context */
+ ReleaseCurrentSubTransaction();
+ MemoryContextSwitchTo(oldcontext);
+ CurrentResourceOwner = oldowner;
+
+ /*
+ * AtEOSubXact_SPI() should not have popped any SPI context, but just
+ * in case it did, make sure we remain connected.
+ */
+ SPI_restore_connection();
+ }
+ PG_CATCH();
+ {
+ ErrorData *edata;
+
+ /* Save error info */
+ MemoryContextSwitchTo(oldcontext);
+ edata = CopyErrorData();
+ FlushErrorState();
+
+ /* Abort the inner transaction */
+ RollbackAndReleaseCurrentSubTransaction();
+ MemoryContextSwitchTo(oldcontext);
+ CurrentResourceOwner = oldowner;
+
+ /*
+ * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
+ * have left us in a disconnected state. We need this hack to return
+ * to connected state.
+ */
+ SPI_restore_connection();
+
+ /* Punt the error to Perl */
+ croak("%s", edata->message);
+
+ /* Can't get here, but keep compiler quiet */
+ return NULL;
+ }
+ PG_END_TRY();
+
+ return cursor;
+}
+
+
+SV *
+plperl_spi_fetchrow(char *cursor)
+{
+ SV *row;
+
+ /*
+ * Execute the FETCH inside a sub-transaction, so we can cope with errors
+ * sanely
+ */
+ MemoryContext oldcontext = CurrentMemoryContext;
+ ResourceOwner oldowner = CurrentResourceOwner;
+
+ check_spi_usage_allowed();
+
+ BeginInternalSubTransaction(NULL);
+ /* Want to run inside function's memory context */
+ MemoryContextSwitchTo(oldcontext);
+
+ PG_TRY();
+ {
+ Portal p = SPI_cursor_find(cursor);
+
+ if (!p)
+ {
+ row = &PL_sv_undef;
+ }
+ else
+ {
+ SPI_cursor_fetch(p, true, 1);
+ if (SPI_processed == 0)
+ {
+ SPI_cursor_close(p);
+ row = &PL_sv_undef;
+ }
+ else
+ {
+ row = plperl_hash_from_tuple(SPI_tuptable->vals[0],
+ SPI_tuptable->tupdesc);
+ }
+ SPI_freetuptable(SPI_tuptable);
+ }
+
+ /* Commit the inner transaction, return to outer xact context */
+ ReleaseCurrentSubTransaction();
+ MemoryContextSwitchTo(oldcontext);
+ CurrentResourceOwner = oldowner;
+
+ /*
+ * AtEOSubXact_SPI() should not have popped any SPI context, but just
+ * in case it did, make sure we remain connected.
+ */
+ SPI_restore_connection();
+ }
+ PG_CATCH();
+ {
+ ErrorData *edata;
+
+ /* Save error info */
+ MemoryContextSwitchTo(oldcontext);
+ edata = CopyErrorData();
+ FlushErrorState();
+
+ /* Abort the inner transaction */
+ RollbackAndReleaseCurrentSubTransaction();
+ MemoryContextSwitchTo(oldcontext);
+ CurrentResourceOwner = oldowner;
+
+ /*
+ * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
+ * have left us in a disconnected state. We need this hack to return
+ * to connected state.
+ */
+ SPI_restore_connection();
+
+ /* Punt the error to Perl */
+ croak("%s", edata->message);
+
+ /* Can't get here, but keep compiler quiet */
+ return NULL;
+ }
+ PG_END_TRY();
+
+ return row;
+}
+
+void
+plperl_spi_cursor_close(char *cursor)
+{
+ Portal p;
+
+ check_spi_usage_allowed();
+
+ p = SPI_cursor_find(cursor);
+
+ if (p)
+ SPI_cursor_close(p);
+}
+
+SV *
+plperl_spi_prepare(char *query, int argc, SV **argv)
+{
+ plperl_query_desc *qdesc=NULL;
+ plperl_query_entry *hash_entry;
+ bool found;
+ void *plan;
+ int i;
+
+ MemoryContext oldcontext = CurrentMemoryContext;
+ ResourceOwner oldowner = CurrentResourceOwner;
+
+ check_spi_usage_allowed();
+
+ BeginInternalSubTransaction(NULL);
+ MemoryContextSwitchTo(oldcontext);
+
+ PG_TRY();
+ {
+ /************************************************************
+ * Allocate the new querydesc structure
+ ************************************************************/
+ qdesc = (plperl_query_desc *) malloc(sizeof(plperl_query_desc));
+ if (qdesc == NULL)
+ ereport(ERROR,
+ (errcode(ERRCODE_OUT_OF_MEMORY),
+ errmsg("out of memory")));
+
+ MemSet(qdesc, 0, sizeof(plperl_query_desc));
+ snprintf(qdesc->qname, sizeof(qdesc->qname), "%p", qdesc);
+ qdesc->nargs = argc;
+ qdesc->argtypes = (Oid *) malloc(argc * sizeof(Oid));
+ qdesc->arginfuncs = (FmgrInfo *) malloc(argc * sizeof(FmgrInfo));
+ qdesc->argtypioparams = (Oid *) malloc(argc * sizeof(Oid));
+
+ if (qdesc->argtypes == NULL ||
+ qdesc->arginfuncs == NULL ||
+ qdesc->argtypioparams == NULL)
+ ereport(ERROR,
+ (errcode(ERRCODE_OUT_OF_MEMORY),
+ errmsg("out of memory")));
+
+ /************************************************************
+ * Resolve argument type names
<TRUNCATED>
[5/5] incubator-hawq git commit: HAWQ-744. Add plperl code
Posted by hu...@apache.org.
HAWQ-744. Add plperl code
Project: http://git-wip-us.apache.org/repos/asf/incubator-hawq/repo
Commit: http://git-wip-us.apache.org/repos/asf/incubator-hawq/commit/120ee70b
Tree: http://git-wip-us.apache.org/repos/asf/incubator-hawq/tree/120ee70b
Diff: http://git-wip-us.apache.org/repos/asf/incubator-hawq/diff/120ee70b
Branch: refs/heads/master
Commit: 120ee70ba296872fc9c1a20d59c0303f188e2226
Parents: 970edfe
Author: Paul Guo <pa...@gmail.com>
Authored: Thu May 19 18:41:12 2016 +0800
Committer: Ruilong Huo <rh...@pivotal.io>
Committed: Fri May 20 18:20:52 2016 +0800
----------------------------------------------------------------------
src/pl/Makefile | 4 +
src/pl/plperl/.gitignore | 15 +
src/pl/plperl/.p4ignore | 6 +
src/pl/plperl/GNUmakefile | 108 +
src/pl/plperl/README | 10 +
src/pl/plperl/SPI.xs | 186 +
src/pl/plperl/Util.xs | 218 +
src/pl/plperl/expected/plperl.out | 602 ++
src/pl/plperl/expected/plperl_array.out | 166 +
src/pl/plperl/expected/plperl_elog.out | 60 +
src/pl/plperl/expected/plperl_init.out | 10 +
src/pl/plperl/expected/plperl_plperlu.out | 95 +
src/pl/plperl/expected/plperl_shared.out | 26 +
src/pl/plperl/expected/plperl_stress.out | 38 +
src/pl/plperl/expected/plperl_trigger.out | 206 +
src/pl/plperl/expected/plperl_util.out | 167 +
src/pl/plperl/expected/plperlu.out | 13 +
src/pl/plperl/nls.mk | 5 +
src/pl/plperl/plc_perlboot.pl | 105 +
src/pl/plperl/plc_trusted.pl | 27 +
src/pl/plperl/plperl--1.0.sql | 9 +
src/pl/plperl/plperl--unpackaged--1.0.sql | 7 +
src/pl/plperl/plperl.c | 3778 ++++++++++++
src/pl/plperl/plperl.control | 7 +
src/pl/plperl/plperl.h | 133 +
src/pl/plperl/plperl_helpers.h | 91 +
src/pl/plperl/plperl_opmask.pl | 58 +
src/pl/plperl/plperlu--1.0.sql | 9 +
src/pl/plperl/plperlu--unpackaged--1.0.sql | 7 +
src/pl/plperl/plperlu.control | 7 +
src/pl/plperl/po/.gitignore | 8 +
src/pl/plperl/po/.p4ignore | 8 +
src/pl/plperl/po/de.po | 105 +
src/pl/plperl/po/es.po | 115 +
src/pl/plperl/po/fr.po | 115 +
src/pl/plperl/po/it.po | 113 +
src/pl/plperl/po/ja.po | 100 +
src/pl/plperl/po/pt_BR.po | 105 +
src/pl/plperl/po/tr.po | 100 +
src/pl/plperl/ppport.h | 7064 +++++++++++++++++++++++
src/pl/plperl/sql/plperl.sql | 388 ++
src/pl/plperl/sql/plperl_array.sql | 113 +
src/pl/plperl/sql/plperl_elog.sql | 45 +
src/pl/plperl/sql/plperl_end.sql | 29 +
src/pl/plperl/sql/plperl_init.sql | 9 +
src/pl/plperl/sql/plperl_plperlu.sql | 58 +
src/pl/plperl/sql/plperl_shared.sql | 22 +
src/pl/plperl/sql/plperl_stress.sql | 54 +
src/pl/plperl/sql/plperl_trigger.sql | 133 +
src/pl/plperl/sql/plperl_util.sql | 101 +
src/pl/plperl/sql/plperlu.sql | 16 +
src/pl/plperl/text2macro.pl | 100 +
52 files changed, 15074 insertions(+)
----------------------------------------------------------------------
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/Makefile
----------------------------------------------------------------------
diff --git a/src/pl/Makefile b/src/pl/Makefile
index eda6d30..31d9bb9 100644
--- a/src/pl/Makefile
+++ b/src/pl/Makefile
@@ -26,6 +26,10 @@ ifeq ($(with_java), yes)
DIRS += pljava
endif
+ifeq ($(with_perl), yes)
+DIRS += plperl
+endif
+
all install installdirs uninstall distprep:
@for dir in $(DIRS); do $(MAKE) -C $$dir $@ || exit 1; done
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/.gitignore
----------------------------------------------------------------------
diff --git a/src/pl/plperl/.gitignore b/src/pl/plperl/.gitignore
new file mode 100644
index 0000000..503f43d
--- /dev/null
+++ b/src/pl/plperl/.gitignore
@@ -0,0 +1,15 @@
+/SPI.c
+/Util.c
+/perlchunks.h
+/plperl_opmask.h
+
+# Generated subdirectories
+/log/
+/results/
+/tmp_check/
+libplperl.so.0
+libplperl.so.0.0
+libplperl.so
+libplperl.a
+SPI.c
+plperl.so
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/.p4ignore
----------------------------------------------------------------------
diff --git a/src/pl/plperl/.p4ignore b/src/pl/plperl/.p4ignore
new file mode 100644
index 0000000..4078738
--- /dev/null
+++ b/src/pl/plperl/.p4ignore
@@ -0,0 +1,6 @@
+libplperl.so.0
+libplperl.so.0.0
+libplperl.so
+libplperl.a
+SPI.c
+plperl.so
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/GNUmakefile
----------------------------------------------------------------------
diff --git a/src/pl/plperl/GNUmakefile b/src/pl/plperl/GNUmakefile
new file mode 100644
index 0000000..d480268
--- /dev/null
+++ b/src/pl/plperl/GNUmakefile
@@ -0,0 +1,108 @@
+# Makefile for PL/Perl
+# PostgreSQL: pgsql/src/pl/plperl/GNUmakefile
+
+subdir = src/pl/plperl
+top_builddir = ../../..
+-include $(top_builddir)/src/Makefile.global
+
+ifeq ($(perl_useshrplib),true)
+shared_libperl = yes
+endif
+ifeq ($(perl_useshrplib),yes)
+shared_libperl = yes
+endif
+
+# If we don't have a shared library and the platform doesn't allow it
+# to work without, we have to skip it.
+ifneq (,$(findstring yes, $(shared_libperl)$(allow_nonpic_in_shlib)))
+
+ifeq ($(PORTNAME), win32)
+perl_archlibexp := $(subst \,/,$(perl_archlibexp))
+perl_privlibexp := $(subst \,/,$(perl_privlibexp))
+perl_lib := $(basename $(notdir $(wildcard $(perl_archlibexp)/CORE/perl[5-9]*.lib)))
+perl_embed_ldflags = -L$(perl_archlibexp)/CORE -l$(perl_lib)
+override CPPFLAGS += -DPLPERL_HAVE_UID_GID
+# Perl on win32 contains /* within comment all over the header file,
+# so disable this warning.
+override CFLAGS += -Wno-comment
+endif
+
+override CPPFLAGS := -I$(srcdir) $(CPPFLAGS) -I$(perl_archlibexp)/CORE
+
+rpathdir = $(perl_archlibexp)/CORE
+
+
+NAME = plperl
+
+OBJS = plperl.o SPI.o Util.o
+
+DATA = plperl.control plperl--1.0.sql plperl--unpackaged--1.0.sql \
+ plperlu.control plperlu--1.0.sql plperlu--unpackaged--1.0.sql
+
+PERLCHUNKS = plc_perlboot.pl plc_trusted.pl
+
+SHLIB_LINK = $(perl_embed_ldflags)
+
+REGRESS_OPTS = --dbname=$(PL_TESTDB) --load-language=plperl --load-language=plperlu
+REGRESS = plperl plperl_trigger plperl_shared plperl_elog plperl_util plperl_init plperlu plperl_array
+STRESS = plperl_stress
+# if Perl can support two interpreters in one backend,
+# test plperl-and-plperlu cases
+ifneq ($(PERL),)
+ifeq ($(shell $(PERL) -V:usemultiplicity), usemultiplicity='define';)
+ REGRESS += plperl_plperlu
+endif
+endif
+# where to find psql for running the tests
+PSQLDIR = $(bindir)
+
+include $(top_srcdir)/src/Makefile.shlib
+
+plperl.o: perlchunks.h plperl_opmask.h
+
+plperl_opmask.h: plperl_opmask.pl
+ $(PERL) $< $@
+
+perlchunks.h: $(PERLCHUNKS)
+ $(PERL) $(srcdir)/text2macro.pl --strip='^(\#.*|\s*)$$' $^ > $@
+
+all: all-lib
+
+SPI.c: SPI.xs
+ $(PERL) $(perl_privlibexp)/ExtUtils/xsubpp -typemap $(perl_privlibexp)/ExtUtils/typemap $< >$@
+
+Util.c: Util.xs
+ $(PERL) $(perl_privlibexp)/ExtUtils/xsubpp -typemap $(perl_privlibexp)/ExtUtils/typemap $< >$@
+
+install: all installdirs install-lib
+
+installdirs: installdirs-lib
+
+uninstall: uninstall-lib
+
+installcheck: submake
+ $(top_builddir)/src/test/regress/pg_regress --inputdir=$(srcdir) --psqldir=$(PSQLDIR) $(REGRESS_OPTS) $(REGRESS)
+
+installcheck-stress: submake
+ $(top_builddir)/src/test/regress/pg_regress --inputdir=$(srcdir) --psqldir=$(PSQLDIR) $(REGRESS_OPTS) $(STRESS)
+
+
+.PHONY: submake
+submake:
+ $(MAKE) -C $(top_builddir)/src/test/regress pg_regress$(X)
+
+clean distclean maintainer-clean: clean-lib
+ rm -f SPI.c Util.c $(OBJS) perlchunks.h plperl_opmask.h
+ rm -rf results
+ rm -f regression.diffs regression.out
+
+else # can't build
+
+all:
+ @echo ""; \
+ echo "*** Cannot build PL/Perl because libperl is not a shared library."; \
+ echo "*** You might have to rebuild your Perl installation. Refer to"; \
+ echo "*** the documentation for details."; \
+ echo ""
+
+endif # can't build
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/README
----------------------------------------------------------------------
diff --git a/src/pl/plperl/README b/src/pl/plperl/README
new file mode 100644
index 0000000..d3ccd14
--- /dev/null
+++ b/src/pl/plperl/README
@@ -0,0 +1,10 @@
+$PostgreSQL: pgsql/src/pl/plperl/README,v 1.4 2008/03/21 13:23:29 momjian Exp $
+
+PL/Perl allows you to write PostgreSQL functions and procedures in
+Perl. To include PL/Perl in the build use './configure --with-perl'.
+To build from this directory use 'gmake all; gmake install'. libperl
+must have been built as a shared library, which is usually not the
+case in standard installations.
+
+Consult the PostgreSQL User's Guide and the INSTALL file in the
+top-level directory of the source distribution for more information.
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/SPI.xs
----------------------------------------------------------------------
diff --git a/src/pl/plperl/SPI.xs b/src/pl/plperl/SPI.xs
new file mode 100755
index 0000000..588d77b
--- /dev/null
+++ b/src/pl/plperl/SPI.xs
@@ -0,0 +1,186 @@
+/**********************************************************************
+ * PostgreSQL::InServer::SPI
+ *
+ * SPI interface for plperl.
+ *
+ * src/pl/plperl/SPI.xs
+ *
+ **********************************************************************/
+
+/* this must be first: */
+#include "postgres.h"
+#include "mb/pg_wchar.h" /* for GetDatabaseEncoding */
+
+/* Defined by Perl */
+#undef _
+
+/* perl stuff */
+#include "plperl.h"
+#include "plperl_helpers.h"
+
+
+/*
+ * Interface routine to catch ereports and punt them to Perl
+ */
+static void
+do_plperl_return_next(SV *sv)
+{
+ MemoryContext oldcontext = CurrentMemoryContext;
+
+ PG_TRY();
+ {
+ plperl_return_next(sv);
+ }
+ PG_CATCH();
+ {
+ ErrorData *edata;
+
+ /* Must reset elog.c's state */
+ MemoryContextSwitchTo(oldcontext);
+ edata = CopyErrorData();
+ FlushErrorState();
+
+ /* Punt the error to Perl */
+ croak("%s", edata->message);
+ }
+ PG_END_TRY();
+}
+
+
+MODULE = PostgreSQL::InServer::SPI PREFIX = spi_
+
+PROTOTYPES: ENABLE
+VERSIONCHECK: DISABLE
+
+SV*
+spi_spi_exec_query(sv, ...)
+ SV* sv;
+ PREINIT:
+ HV *ret_hash;
+ int limit = 0;
+ char *query;
+ CODE:
+ if (items > 2)
+ croak("Usage: spi_exec_query(query, limit) "
+ "or spi_exec_query(query)");
+ if (items == 2)
+ limit = SvIV(ST(1));
+ query = sv2cstr(sv);
+ ret_hash = plperl_spi_exec(query, limit);
+ pfree(query);
+ RETVAL = newRV_noinc((SV*) ret_hash);
+ OUTPUT:
+ RETVAL
+
+void
+spi_return_next(rv)
+ SV *rv;
+ CODE:
+ do_plperl_return_next(rv);
+
+SV *
+spi_spi_query(sv)
+ SV *sv;
+ CODE:
+ char* query = sv2cstr(sv);
+ RETVAL = plperl_spi_query(query);
+ pfree(query);
+ OUTPUT:
+ RETVAL
+
+SV *
+spi_spi_fetchrow(sv)
+ SV* sv;
+ CODE:
+ char* cursor = sv2cstr(sv);
+ RETVAL = plperl_spi_fetchrow(cursor);
+ pfree(cursor);
+ OUTPUT:
+ RETVAL
+
+SV*
+spi_spi_prepare(sv, ...)
+ SV* sv;
+ CODE:
+ int i;
+ SV** argv;
+ char* query = sv2cstr(sv);
+ if (items < 1)
+ Perl_croak(aTHX_ "Usage: spi_prepare(query, ...)");
+ argv = ( SV**) palloc(( items - 1) * sizeof(SV*));
+ for ( i = 1; i < items; i++)
+ argv[i - 1] = ST(i);
+ RETVAL = plperl_spi_prepare(query, items - 1, argv);
+ pfree( argv);
+ pfree(query);
+ OUTPUT:
+ RETVAL
+
+SV*
+spi_spi_exec_prepared(sv, ...)
+ SV* sv;
+ PREINIT:
+ HV *ret_hash;
+ CODE:
+ HV *attr = NULL;
+ int i, offset = 1, argc;
+ SV ** argv;
+ char *query = sv2cstr(sv);
+ if ( items < 1)
+ Perl_croak(aTHX_ "Usage: spi_exec_prepared(query, [\\%%attr,] "
+ "[\\@bind_values])");
+ if ( items > 1 && SvROK( ST( 1)) && SvTYPE( SvRV( ST( 1))) == SVt_PVHV)
+ {
+ attr = ( HV*) SvRV(ST(1));
+ offset++;
+ }
+ argc = items - offset;
+ argv = ( SV**) palloc( argc * sizeof(SV*));
+ for ( i = 0; offset < items; offset++, i++)
+ argv[i] = ST(offset);
+ ret_hash = plperl_spi_exec_prepared(query, attr, argc, argv);
+ RETVAL = newRV_noinc((SV*)ret_hash);
+ pfree( argv);
+ pfree(query);
+ OUTPUT:
+ RETVAL
+
+SV*
+spi_spi_query_prepared(sv, ...)
+ SV * sv;
+ CODE:
+ int i;
+ SV ** argv;
+ char *query = sv2cstr(sv);
+ if ( items < 1)
+ Perl_croak(aTHX_ "Usage: spi_query_prepared(query, "
+ "[\\@bind_values])");
+ argv = ( SV**) palloc(( items - 1) * sizeof(SV*));
+ for ( i = 1; i < items; i++)
+ argv[i - 1] = ST(i);
+ RETVAL = plperl_spi_query_prepared(query, items - 1, argv);
+ pfree( argv);
+ pfree(query);
+ OUTPUT:
+ RETVAL
+
+void
+spi_spi_freeplan(sv)
+ SV *sv;
+ CODE:
+ char *query = sv2cstr(sv);
+ plperl_spi_freeplan(query);
+ pfree(query);
+
+void
+spi_spi_cursor_close(sv)
+ SV *sv;
+ CODE:
+ char *cursor = sv2cstr(sv);
+ plperl_spi_cursor_close(cursor);
+ pfree(cursor);
+
+
+BOOT:
+ items = 0; /* avoid 'unused variable' warning */
+
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/Util.xs
----------------------------------------------------------------------
diff --git a/src/pl/plperl/Util.xs b/src/pl/plperl/Util.xs
new file mode 100644
index 0000000..7d0102b
--- /dev/null
+++ b/src/pl/plperl/Util.xs
@@ -0,0 +1,218 @@
+/**********************************************************************
+ * PostgreSQL::InServer::Util
+ *
+ * src/pl/plperl/Util.xs
+ *
+ * Defines plperl interfaces for general-purpose utilities.
+ * This module is bootstrapped as soon as an interpreter is initialized.
+ * Currently doesn't define a PACKAGE= so all subs are in main:: to avoid
+ * the need for explicit importing.
+ *
+ **********************************************************************/
+
+/* this must be first: */
+#include "postgres.h"
+#include "fmgr.h"
+#include "utils/builtins.h"
+#include "utils/bytea.h" /* for byteain & byteaout */
+#include "mb/pg_wchar.h" /* for GetDatabaseEncoding */
+/* Defined by Perl */
+#undef _
+
+/* perl stuff */
+#include "plperl.h"
+#include "plperl_helpers.h"
+
+/*
+ * Implementation of plperl's elog() function
+ *
+ * If the error level is less than ERROR, we'll just emit the message and
+ * return. When it is ERROR, elog() will longjmp, which we catch and
+ * turn into a Perl croak(). Note we are assuming that elog() can't have
+ * any internal failures that are so bad as to require a transaction abort.
+ *
+ * This is out-of-line to suppress "might be clobbered by longjmp" warnings.
+ */
+static void
+do_util_elog(int level, SV *msg)
+{
+ MemoryContext oldcontext = CurrentMemoryContext;
+ char * volatile cmsg = NULL;
+
+ PG_TRY();
+ {
+ cmsg = sv2cstr(msg);
+ elog(level, "%s", cmsg);
+ pfree(cmsg);
+ }
+ PG_CATCH();
+ {
+ ErrorData *edata;
+
+ /* Must reset elog.c's state */
+ MemoryContextSwitchTo(oldcontext);
+ edata = CopyErrorData();
+ FlushErrorState();
+
+ if (cmsg)
+ pfree(cmsg);
+
+ /* Punt the error to Perl */
+ croak("%s", edata->message);
+ }
+ PG_END_TRY();
+}
+
+static text *
+sv2text(SV *sv)
+{
+ char *str = sv2cstr(sv);
+
+ return cstring_to_text(str);
+}
+
+MODULE = PostgreSQL::InServer::Util PREFIX = util_
+
+PROTOTYPES: ENABLE
+VERSIONCHECK: DISABLE
+
+int
+_aliased_constants()
+ PROTOTYPE:
+ ALIAS:
+ DEBUG = DEBUG2
+ LOG = LOG
+ INFO = INFO
+ NOTICE = NOTICE
+ WARNING = WARNING
+ ERROR = ERROR
+ CODE:
+ /* uses the ALIAS value as the return value */
+ RETVAL = ix;
+ OUTPUT:
+ RETVAL
+
+
+void
+util_elog(level, msg)
+ int level
+ SV *msg
+ CODE:
+ if (level > ERROR) /* no PANIC allowed thanks */
+ level = ERROR;
+ if (level < DEBUG5)
+ level = DEBUG5;
+ do_util_elog(level, msg);
+
+SV *
+util_quote_literal(sv)
+ SV *sv
+ CODE:
+ if (!sv || !SvOK(sv)) {
+ RETVAL = &PL_sv_undef;
+ }
+ else {
+ text *arg = sv2text(sv);
+ text *ret = DatumGetTextP(DirectFunctionCall1(quote_literal, PointerGetDatum(arg)));
+ char *str = text_to_cstring(ret);
+ RETVAL = cstr2sv(str);
+ pfree(str);
+ }
+ OUTPUT:
+ RETVAL
+
+SV *
+util_quote_nullable(sv)
+ SV *sv
+ CODE:
+ if (!sv || !SvOK(sv))
+ {
+ RETVAL = cstr2sv("NULL");
+ }
+ else
+ {
+ text *arg = sv2text(sv);
+ text *ret = DatumGetTextP(DirectFunctionCall1(quote_nullable, PointerGetDatum(arg)));
+ char *str = text_to_cstring(ret);
+ RETVAL = cstr2sv(str);
+ pfree(str);
+ }
+ OUTPUT:
+ RETVAL
+
+SV *
+util_quote_ident(sv)
+ SV *sv
+ PREINIT:
+ text *arg;
+ text *ret;
+ char *str;
+ CODE:
+ arg = sv2text(sv);
+ ret = DatumGetTextP(DirectFunctionCall1(quote_ident, PointerGetDatum(arg)));
+ str = text_to_cstring(ret);
+ RETVAL = cstr2sv(str);
+ pfree(str);
+ OUTPUT:
+ RETVAL
+
+SV *
+util_decode_bytea(sv)
+ SV *sv
+ PREINIT:
+ char *arg;
+ text *ret;
+ CODE:
+ arg = SvPVbyte_nolen(sv);
+ ret = DatumGetTextP(DirectFunctionCall1(byteain, PointerGetDatum(arg)));
+ /* not cstr2sv because this is raw bytes not utf8'able */
+ RETVAL = newSVpvn(VARDATA(ret), (VARSIZE(ret) - VARHDRSZ));
+ OUTPUT:
+ RETVAL
+
+SV *
+util_encode_bytea(sv)
+ SV *sv
+ PREINIT:
+ text *arg;
+ char *ret;
+ STRLEN len;
+ CODE:
+ /* not sv2text because this is raw bytes not utf8'able */
+ ret = SvPVbyte(sv, len);
+ arg = cstring_to_text_with_len(ret, len);
+ ret = DatumGetCString(DirectFunctionCall1(byteaout, PointerGetDatum(arg)));
+ RETVAL = cstr2sv(ret);
+ OUTPUT:
+ RETVAL
+
+SV *
+looks_like_number(sv)
+ SV *sv
+ CODE:
+ if (!SvOK(sv))
+ RETVAL = &PL_sv_undef;
+ else if ( looks_like_number(sv) )
+ RETVAL = &PL_sv_yes;
+ else
+ RETVAL = &PL_sv_no;
+ OUTPUT:
+ RETVAL
+
+SV *
+encode_typed_literal(sv, typname)
+ SV *sv
+ char *typname;
+ PREINIT:
+ char *outstr;
+ CODE:
+ outstr = plperl_sv_to_literal(sv, typname);
+ if (outstr == NULL)
+ RETVAL = &PL_sv_undef;
+ else
+ RETVAL = cstr2sv(outstr);
+ OUTPUT:
+ RETVAL
+
+BOOT:
+ items = 0; /* avoid 'unused variable' warning */
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/expected/plperl.out
----------------------------------------------------------------------
diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out
new file mode 100755
index 0000000..24102ba
--- /dev/null
+++ b/src/pl/plperl/expected/plperl.out
@@ -0,0 +1,602 @@
+--
+-- 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)
+
+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();
+ERROR: Unsupported Perl function "perl_record_set"
+DETAIL: function returning record called in context that cannot accept type record
+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: Unsupported Perl function "perl_record_set"
+DETAIL: 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: Unsupported Perl function "perl_record_set"
+DETAIL: 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: composite-returning PL/Perl function must return reference to hash
+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: composite-returning PL/Perl function must return reference to hash
+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"
+--
+-- 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)
+
+--
+-- 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: Perl function "perl_spi_prepared_bad" failed (SOMEFILE:SOMEFUNC)
+DETAIL: 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)
+
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/expected/plperl_array.out
----------------------------------------------------------------------
diff --git a/src/pl/plperl/expected/plperl_array.out b/src/pl/plperl/expected/plperl_array.out
new file mode 100644
index 0000000..90bfa61
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_array.out
@@ -0,0 +1,166 @@
+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 (6) exceeds the maximum allowed (6)
+LINE 1: select plperl_sum_array('{{{{{{{1,2},{3,4}},{{5,6},{7,8}}},{...
+ ^
+select plperl_sum_array('{{{1,2,3}, {4,5,6,7}}, {{7,8,9}, {10, 11, 12}}}');
+ERROR: multidimensional arrays must have array expressions with matching dimensions
+LINE 1: select plperl_sum_array('{{{1,2,3}, {4,5,6,7}}, {{7,8,9}, {1...
+ ^
+CREATE OR REPLACE FUNCTION plperl_concat(TEXT[]) RETURNS TEXT AS $$
+ my $array_arg = shift;
+ my $result = "";
+ my @arrays;
+
+ push @arrays, @$array_arg;
+ while (@arrays > 0) {
+ my $el = shift @arrays;
+ if (is_array_ref($el)) {
+ push @arrays, @$el;
+ } else {
+ $result .= $el;
+ }
+ }
+ return $result.' '.$array_arg;
+$$ LANGUAGE plperl;
+select plperl_concat('{"NULL","NULL","NULL''"}');
+ plperl_concat
+-------------------------------------
+ NULLNULLNULL' {"NULL","NULL",NULL'}
+(1 row)
+
+select plperl_concat('{{NULL,NULL,NULL}}');
+ plperl_concat
+---------------------
+ {{NULL,NULL,NULL}}
+(1 row)
+
+select plperl_concat('{"hello"," ","world!"}');
+ plperl_concat
+---------------------------------
+ hello world! {hello," ",world!}
+(1 row)
+
+-- 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)
+
+-- check arrays as out parameters
+CREATE OR REPLACE FUNCTION plperl_arrays_out(OUT INTEGER[]) AS $$
+ return [[1,2,3],[4,5,6]];
+$$ LANGUAGE plperl;
+select plperl_arrays_out();
+ plperl_arrays_out
+-------------------
+ {{1,2,3},{4,5,6}}
+(1 row)
+
+-- check that we can return the array we passed in
+CREATE OR REPLACE FUNCTION plperl_arrays_inout(INTEGER[]) returns INTEGER[] AS $$
+ return shift;
+$$ LANGUAGE plperl;
+select plperl_arrays_inout('{{1}, {2}, {3}}');
+ plperl_arrays_inout
+---------------------
+ {{1},{2},{3}}
+(1 row)
+
+-- make sure setof works
+create or replace function perl_setof_array(integer[]) returns setof integer[] language plperl as $$
+ my $arr = shift;
+ for my $r (@$arr) {
+ return_next $r;
+ }
+ return undef;
+$$;
+select perl_setof_array('{{1}, {2}, {3}}');
+ perl_setof_array
+------------------
+ {1}
+ {2}
+ {3}
+(3 rows)
+
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/expected/plperl_elog.out
----------------------------------------------------------------------
diff --git a/src/pl/plperl/expected/plperl_elog.out b/src/pl/plperl/expected/plperl_elog.out
new file mode 100755
index 0000000..471b8a0
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_elog.out
@@ -0,0 +1,60 @@
+-- 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
+CONTEXT: PL/Perl function "perl_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.
+CONTEXT: PL/Perl function "perl_warn"
+ 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: creation of Perl function failed
+DETAIL: Global symbol "$global" requires explicit package name at line 3.
+Global symbol "$other_global" requires explicit package name at line 4.
+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)
+
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/expected/plperl_init.out
----------------------------------------------------------------------
diff --git a/src/pl/plperl/expected/plperl_init.out b/src/pl/plperl/expected/plperl_init.out
new file mode 100644
index 0000000..5666b3f
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_init.out
@@ -0,0 +1,10 @@
+-- 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;
+ plperl.on_plperl_init
+-----------------------
+ system("/nonesuch")
+(1 row)
+
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/expected/plperl_plperlu.out
----------------------------------------------------------------------
diff --git a/src/pl/plperl/expected/plperl_plperlu.out b/src/pl/plperl/expected/plperl_plperlu.out
new file mode 100644
index 0000000..be96c46
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_plperlu.out
@@ -0,0 +1,95 @@
+-- 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: Perl function "bar" failed (plperl.c:1961)
+DETAIL: 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: Perl function "foo" failed (plperl.c:1961)
+DETAIL: Perl function "bar" failed 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: creation of Perl function failed
+DETAIL: 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: creation of Perl function failed
+DETAIL: 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"
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/expected/plperl_shared.out
----------------------------------------------------------------------
diff --git a/src/pl/plperl/expected/plperl_shared.out b/src/pl/plperl/expected/plperl_shared.out
new file mode 100755
index 0000000..72ae1ba
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_shared.out
@@ -0,0 +1,26 @@
+-- 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)
+
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/expected/plperl_stress.out
----------------------------------------------------------------------
diff --git a/src/pl/plperl/expected/plperl_stress.out b/src/pl/plperl/expected/plperl_stress.out
new file mode 100644
index 0000000..9a0ea81
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_stress.out
@@ -0,0 +1,38 @@
+--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\u202620000) 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\u202620000) 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/expected/plperl_trigger.out
----------------------------------------------------------------------
diff --git a/src/pl/plperl/expected/plperl_trigger.out b/src/pl/plperl/expected/plperl_trigger.out
new file mode 100755
index 0000000..3e4c25d
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_trigger.out
@@ -0,0 +1,206 @@
+-- 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)")');
+NOTICE: $_TD->{argc} = '2'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{args} = ['23', 'skidoo']
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{event} = 'INSERT'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{level} = 'ROW'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{name} = 'show_trigger_data_trig'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{new} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'insert'}
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{relid} = 'bogus:12345'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{relname} = 'trigger_test'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{table_name} = 'trigger_test'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{table_schema} = 'public'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{when} = 'BEFORE'
+CONTEXT: PL/Perl function "trigger_data"
+update trigger_test set v = 'update' where i = 1;
+NOTICE: $_TD->{argc} = '2'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{args} = ['23', 'skidoo']
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{event} = 'UPDATE'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{level} = 'ROW'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{name} = 'show_trigger_data_trig'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{new} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'update'}
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{old} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'insert'}
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{relid} = 'bogus:12345'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{relname} = 'trigger_test'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{table_name} = 'trigger_test'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{table_schema} = 'public'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{when} = 'BEFORE'
+CONTEXT: PL/Perl function "trigger_data"
+delete from trigger_test;
+NOTICE: $_TD->{argc} = '2'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{args} = ['23', 'skidoo']
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{event} = 'DELETE'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{level} = 'ROW'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{name} = 'show_trigger_data_trig'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{old} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'update'}
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{relid} = 'bogus:12345'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{relname} = 'trigger_test'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{table_name} = 'trigger_test'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{table_schema} = 'public'
+CONTEXT: PL/Perl function "trigger_data"
+NOTICE: $_TD->{when} = 'BEFORE'
+CONTEXT: PL/Perl function "trigger_data"
+DROP TRIGGER show_trigger_data_trig on trigger_test;
+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;
+ERROR: Cannot parallelize an UPDATE statement that updates the distribution columns
+UPDATE trigger_test SET i = 100 where i=1;
+ERROR: Cannot parallelize an UPDATE statement that updates the distribution columns
+SELECT * FROM trigger_test;
+ i | v | foo
+---+----------------------------------+---------
+ 2 | second line(modified by trigger) | ("(3)")
+ 4 | immortal | ("(4)")
+ 1 | first line(modified by trigger) | ("(2)")
+ 3 | third line(modified by trigger) | ("(4)")
+(4 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"
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/expected/plperl_util.out
----------------------------------------------------------------------
diff --git a/src/pl/plperl/expected/plperl_util.out b/src/pl/plperl/expected/plperl_util.out
new file mode 100644
index 0000000..0996d2f
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_util.out
@@ -0,0 +1,167 @@
+-- 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_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[]);
+ERROR: type "perl_foo[]" does not exist
+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();
+ERROR: type "perl_bar" does not exist
+CONTEXT: PL/Perl function "perl_encode_typed_literal"
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/expected/plperlu.out
----------------------------------------------------------------------
diff --git a/src/pl/plperl/expected/plperlu.out b/src/pl/plperl/expected/plperlu.out
new file mode 100644
index 0000000..6d2938a
--- /dev/null
+++ b/src/pl/plperl/expected/plperlu.out
@@ -0,0 +1,13 @@
+-- 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/nls.mk
----------------------------------------------------------------------
diff --git a/src/pl/plperl/nls.mk b/src/pl/plperl/nls.mk
new file mode 100755
index 0000000..bc6d1c3
--- /dev/null
+++ b/src/pl/plperl/nls.mk
@@ -0,0 +1,5 @@
+# $PostgreSQL: pgsql/src/pl/plperl/nls.mk,v 1.7.2.1 2009/09/03 21:01:21 petere Exp $
+CATALOG_NAME := plperl
+AVAIL_LANGUAGES := de es fr it ja pt_BR tr
+GETTEXT_FILES := plperl.c SPI.c
+GETTEXT_TRIGGERS:= errmsg errmsg_plural:1,2 errdetail errdetail_log errdetail_plural:1,2 errhint errcontext
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/plc_perlboot.pl
----------------------------------------------------------------------
diff --git a/src/pl/plperl/plc_perlboot.pl b/src/pl/plperl/plc_perlboot.pl
new file mode 100644
index 0000000..67c6560
--- /dev/null
+++ b/src/pl/plperl/plc_perlboot.pl
@@ -0,0 +1,105 @@
+# src/pl/plperl/plc_perlboot.pl
+
+use 5.008001;
+use vars qw(%_SHARED);
+
+PostgreSQL::InServer::Util::bootstrap();
+
+# globals
+
+sub ::is_array_ref {
+ return ref($_[0]) =~ m/^(?:PostgreSQL::InServer::)?ARRAY$/;
+}
+
+sub ::encode_array_literal {
+ my ($arg, $delim) = @_;
+ return $arg unless(::is_array_ref($arg));
+ $delim = ', ' unless defined $delim;
+ my $res = '';
+ foreach my $elem (@$arg) {
+ $res .= $delim if length $res;
+ if (ref $elem) {
+ $res .= ::encode_array_literal($elem, $delim);
+ }
+ elsif (defined $elem) {
+ (my $str = $elem) =~ s/(["\\])/\\$1/g;
+ $res .= qq("$str");
+ }
+ else {
+ $res .= 'NULL';
+ }
+ }
+ return qq({$res});
+}
+
+sub ::encode_array_constructor {
+ my $arg = shift;
+ return ::quote_nullable($arg) unless ::is_array_ref($arg);
+ my $res = join ", ", map {
+ (ref $_) ? ::encode_array_constructor($_)
+ : ::quote_nullable($_)
+ } @$arg;
+ return "ARRAY[$res]";
+}
+
+{
+package PostgreSQL::InServer;
+use strict;
+use warnings;
+
+sub plperl_warn {
+ (my $msg = shift) =~ s/\(eval \d+\) //g;
+ chomp $msg;
+ &::elog(&::WARNING, $msg);
+}
+$SIG{__WARN__} = \&plperl_warn;
+
+sub plperl_die {
+ (my $msg = shift) =~ s/\(eval \d+\) //g;
+ die $msg;
+}
+$SIG{__DIE__} = \&plperl_die;
+
+sub mkfuncsrc {
+ my ($name, $imports, $prolog, $src) = @_;
+
+ my $BEGIN = join "\n", map {
+ my $names = $imports->{$_} || [];
+ "$_->import(qw(@$names));"
+ } sort keys %$imports;
+ $BEGIN &&= "BEGIN { $BEGIN }";
+
+ return qq[ package main; sub { $BEGIN $prolog $src } ];
+}
+
+sub mkfunc {
+ no strict; # default to no strict for the eval
+ no warnings; # default to no warnings for the eval
+ my $ret = eval(mkfuncsrc(@_));
+ $@ =~ s/\(eval \d+\) //g if $@;
+ return $ret;
+}
+
+1;
+}
+
+{
+package PostgreSQL::InServer::ARRAY;
+use strict;
+use warnings;
+
+use overload
+ '""'=>\&to_str,
+ '@{}'=>\&to_arr;
+
+sub to_str {
+ my $self = shift;
+ return ::encode_typed_literal($self->{'array'}, $self->{'typeoid'});
+}
+
+sub to_arr {
+ return shift->{'array'};
+}
+
+1;
+}
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/plc_trusted.pl
----------------------------------------------------------------------
diff --git a/src/pl/plperl/plc_trusted.pl b/src/pl/plperl/plc_trusted.pl
new file mode 100644
index 0000000..cd61882
--- /dev/null
+++ b/src/pl/plperl/plc_trusted.pl
@@ -0,0 +1,27 @@
+# src/pl/plperl/plc_trusted.pl
+
+package PostgreSQL::InServer::safe;
+
+# Load widely useful pragmas into plperl to make them available.
+#
+# SECURITY RISKS:
+#
+# Since these modules are free to compile unsafe opcodes they must
+# be trusted to now allow any code containing unsafe opcodes to be abused.
+# That's much harder than it sounds.
+#
+# Be aware that perl provides a wide variety of ways to subvert
+# pre-compiled code. For some examples, see this presentation:
+# http://www.slideshare.net/cdman83/barely-legal-xxx-perl-presentation
+#
+# If in ANY doubt about a module, or ANY of the modules down the chain of
+# dependencies it loads, then DO NOT add it to this list.
+#
+# To check if any of these modules use "unsafe" opcodes you can compile
+# plperl with the PLPERL_ENABLE_OPMASK_EARLY macro defined. See plperl.c
+
+require strict;
+require Carp;
+require Carp::Heavy;
+require warnings;
+require feature if $] >= 5.010000;
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/plperl--1.0.sql
----------------------------------------------------------------------
diff --git a/src/pl/plperl/plperl--1.0.sql b/src/pl/plperl/plperl--1.0.sql
new file mode 100644
index 0000000..befd882
--- /dev/null
+++ b/src/pl/plperl/plperl--1.0.sql
@@ -0,0 +1,9 @@
+/* src/pl/plperl/plperl--1.0.sql */
+
+/*
+ * Currently, all the interesting stuff is done by CREATE LANGUAGE.
+ * Later we will probably "dumb down" that command and put more of the
+ * knowledge into this script.
+ */
+
+CREATE PROCEDURAL LANGUAGE plperl;
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/plperl--unpackaged--1.0.sql
----------------------------------------------------------------------
diff --git a/src/pl/plperl/plperl--unpackaged--1.0.sql b/src/pl/plperl/plperl--unpackaged--1.0.sql
new file mode 100644
index 0000000..b062bd5
--- /dev/null
+++ b/src/pl/plperl/plperl--unpackaged--1.0.sql
@@ -0,0 +1,7 @@
+/* src/pl/plperl/plperl--unpackaged--1.0.sql */
+
+ALTER EXTENSION plperl ADD PROCEDURAL LANGUAGE plperl;
+-- ALTER ADD LANGUAGE doesn't pick up the support functions, so we have to.
+ALTER EXTENSION plperl ADD FUNCTION plperl_call_handler();
+ALTER EXTENSION plperl ADD FUNCTION plperl_inline_handler(internal);
+ALTER EXTENSION plperl ADD FUNCTION plperl_validator(oid);
[3/5] incubator-hawq git commit: HAWQ-744. Add plperl code
Posted by hu...@apache.org.
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/plperl.control
----------------------------------------------------------------------
diff --git a/src/pl/plperl/plperl.control b/src/pl/plperl/plperl.control
new file mode 100644
index 0000000..6faace1
--- /dev/null
+++ b/src/pl/plperl/plperl.control
@@ -0,0 +1,7 @@
+# plperl extension
+comment = 'PL/Perl procedural language'
+default_version = '1.0'
+module_pathname = '$libdir/plperl'
+relocatable = false
+schema = pg_catalog
+superuser = false
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/plperl.h
----------------------------------------------------------------------
diff --git a/src/pl/plperl/plperl.h b/src/pl/plperl/plperl.h
new file mode 100644
index 0000000..96bc14c
--- /dev/null
+++ b/src/pl/plperl/plperl.h
@@ -0,0 +1,133 @@
+/*
+ * Licensed to the Apache Software Foundation (ASF) under one
+ * or more contributor license agreements. See the NOTICE file
+ * distributed with this work for additional information
+ * regarding copyright ownership. The ASF licenses this file
+ * to you under the Apache License, Version 2.0 (the
+ * "License"); you may not use this file except in compliance
+ * with the License. You may obtain a copy of the License at
+ *
+ * http://www.apache.org/licenses/LICENSE-2.0
+ *
+ * Unless required by applicable law or agreed to in writing,
+ * software distributed under the License is distributed on an
+ * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
+ * KIND, either express or implied. See the License for the
+ * specific language governing permissions and limitations
+ * under the License.
+ */
+
+/*-------------------------------------------------------------------------
+ *
+ * plperl.h
+ * Common include file for PL/Perl files
+ *
+ * This should be included _AFTER_ postgres.h and system include files
+ *
+ * Portions Copyright (c) 1996-2011, PostgreSQL Global Development Group
+ * Portions Copyright (c) 1995, Regents of the University of California
+ *
+ * src/pl/plperl/plperl.h
+ */
+
+#ifndef PL_PERL_H
+#define PL_PERL_H
+
+/* stop perl headers from hijacking stdio and other stuff on Windows */
+#ifdef WIN32
+#define WIN32IO_IS_STDIO
+/*
+ * isnan is defined in both the perl and mingw headers. We don't use it,
+ * so this just clears up the compile warning.
+ */
+#ifdef isnan
+#undef isnan
+#endif
+#endif
+
+/*
+ * Supply a value of PERL_UNUSED_DECL that will satisfy gcc - the one
+ * perl itself supplies doesn't seem to.
+ */
+#if defined(__GNUC__)
+#define PERL_UNUSED_DECL __attribute__ ((unused))
+#endif
+
+/*
+ * Sometimes perl carefully scribbles on our *printf macros.
+ * So we undefine them here and redefine them after it's done its dirty deed.
+ */
+
+#ifdef USE_REPL_SNPRINTF
+#undef snprintf
+#undef vsnprintf
+#endif
+
+#define list_head sys_list_head
+#define list_tail sys_list_tail
+
+/* required for perl API */
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "ppport.h"
+
+#undef list_head
+#undef list_tail
+
+
+/* put back our snprintf and vsnprintf */
+#ifdef USE_REPL_SNPRINTF
+#ifdef snprintf
+#undef snprintf
+#endif
+#ifdef vsnprintf
+#undef vsnprintf
+#endif
+#ifdef __GNUC__
+#define vsnprintf(...) pg_vsnprintf(__VA_ARGS__)
+#define snprintf(...) pg_snprintf(__VA_ARGS__)
+#else
+#define vsnprintf pg_vsnprintf
+#define snprintf pg_snprintf
+#endif /* __GNUC__ */
+#endif /* USE_REPL_SNPRINTF */
+
+/* perl version and platform portability */
+#define NEED_eval_pv
+#define NEED_newRV_noinc
+#define NEED_sv_2pv_flags
+#include "ppport.h"
+
+/* perl may have a different width of "bool", don't buy it */
+#ifdef bool
+#undef bool
+#endif
+
+/* supply HeUTF8 if it's missing - ppport.h doesn't supply it, unfortunately */
+#ifndef HeUTF8
+#define HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \
+ SvUTF8(HeKEY_sv(he)) : \
+ (U32)HeKUTF8(he))
+#endif
+
+/* supply GvCV_set if it's missing - ppport.h doesn't supply it, unfortunately */
+#ifndef GvCV_set
+#define GvCV_set(gv, cv) (GvCV(gv) = cv)
+#endif
+
+/* declare routines from plperl.c for access by .xs files */
+HV *plperl_spi_exec(char *, int);
+void plperl_return_next(SV *);
+SV *plperl_spi_query(char *);
+SV *plperl_spi_fetchrow(char *);
+SV *plperl_spi_prepare(char *, int, SV **);
+HV *plperl_spi_exec_prepared(char *, HV *, int, SV **);
+SV *plperl_spi_query_prepared(char *, int, SV **);
+void plperl_spi_freeplan(char *);
+void plperl_spi_cursor_close(char *);
+char *plperl_sv_to_literal(SV *, char *);
+
+
+
+#endif /* PL_PERL_H */
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/plperl_helpers.h
----------------------------------------------------------------------
diff --git a/src/pl/plperl/plperl_helpers.h b/src/pl/plperl/plperl_helpers.h
new file mode 100644
index 0000000..a0e2cf2
--- /dev/null
+++ b/src/pl/plperl/plperl_helpers.h
@@ -0,0 +1,91 @@
+/*
+ * Licensed to the Apache Software Foundation (ASF) under one
+ * or more contributor license agreements. See the NOTICE file
+ * distributed with this work for additional information
+ * regarding copyright ownership. The ASF licenses this file
+ * to you under the Apache License, Version 2.0 (the
+ * "License"); you may not use this file except in compliance
+ * with the License. You may obtain a copy of the License at
+ *
+ * http://www.apache.org/licenses/LICENSE-2.0
+ *
+ * Unless required by applicable law or agreed to in writing,
+ * software distributed under the License is distributed on an
+ * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
+ * KIND, either express or implied. See the License for the
+ * specific language governing permissions and limitations
+ * under the License.
+ */
+
+
+#ifndef PL_PERL_HELPERS_H
+#define PL_PERL_HELPERS_H
+
+/*
+ * convert from utf8 to database encoding
+ */
+static inline char *
+utf_u2e(const char *utf8_str, size_t len)
+{
+ char *ret = (char *) pg_do_encoding_conversion((unsigned char *) utf8_str, len, PG_UTF8, GetDatabaseEncoding());
+
+ if (ret == utf8_str)
+ ret = pstrdup(ret);
+ return ret;
+}
+
+/*
+ * convert from database encoding to utf8
+ */
+static inline char *
+utf_e2u(const char *str)
+{
+ char *ret = (char *) pg_do_encoding_conversion((unsigned char *) str, strlen(str), GetDatabaseEncoding(), PG_UTF8);
+
+ if (ret == str)
+ ret = pstrdup(ret);
+ return ret;
+}
+
+
+/*
+ * Convert an SV to a char * in the current database encoding
+ */
+static inline char *
+sv2cstr(SV *sv)
+{
+ char *val;
+ STRLEN len;
+
+ /*
+ * get a utf8 encoded char * out of perl. *note* it may not be valid utf8!
+ */
+ val = SvPVutf8(sv, len);
+
+ /*
+ * we use perls length in the event we had an embedded null byte to ensure
+ * we error out properly
+ */
+ return utf_u2e(val, len);
+}
+
+/*
+ * Create a new SV from a string assumed to be in the current database's
+ * encoding.
+ */
+
+static inline SV *
+cstr2sv(const char *str)
+{
+ SV *sv;
+ char *utf8_str = utf_e2u(str);
+
+ sv = newSVpv(utf8_str, 0);
+ SvUTF8_on(sv);
+
+ pfree(utf8_str);
+
+ return sv;
+}
+
+#endif /* PL_PERL_HELPERS_H */
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/plperl_opmask.pl
----------------------------------------------------------------------
diff --git a/src/pl/plperl/plperl_opmask.pl b/src/pl/plperl/plperl_opmask.pl
new file mode 100644
index 0000000..3e9ecaa
--- /dev/null
+++ b/src/pl/plperl/plperl_opmask.pl
@@ -0,0 +1,58 @@
+#!perl -w
+
+use strict;
+use warnings;
+
+use Opcode qw(opset opset_to_ops opdesc);
+
+my $plperl_opmask_h = shift
+ or die "Usage: $0 <output_filename.h>\n";
+
+my $plperl_opmask_tmp = $plperl_opmask_h."tmp";
+END { unlink $plperl_opmask_tmp }
+
+open my $fh, ">", "$plperl_opmask_tmp"
+ or die "Could not write to $plperl_opmask_tmp: $!";
+
+printf $fh "#define PLPERL_SET_OPMASK(opmask) \\\n";
+printf $fh " memset(opmask, 1, MAXO);\t/* disable all */ \\\n";
+printf $fh " /* then allow some... */ \\\n";
+
+my @allowed_ops = (
+ # basic set of opcodes
+ qw[:default :base_math !:base_io sort time],
+ # require is safe because we redirect the opcode
+ # entereval is safe as the opmask is now permanently set
+ # caller is safe because the entire interpreter is locked down
+ qw[require entereval caller],
+ # These are needed for utf8_heavy.pl:
+ # dofile is safe because we redirect the opcode like require above
+ # print is safe because the only writable filehandles are STDOUT & STDERR
+ # prtf (printf) is safe as it's the same as print + sprintf
+ qw[dofile print prtf],
+ # Disallow these opcodes that are in the :base_orig optag
+ # (included in :default) but aren't considered sufficiently safe
+ qw[!dbmopen !setpgrp !setpriority],
+ # custom is not deemed a likely security risk as it can't be generated from
+ # perl so would only be seen if the DBA had chosen to load a module that
+ # used it. Even then it's unlikely to be seen because it's typically
+ # generated by compiler plugins that operate after PL_op_mask checks.
+ # But we err on the side of caution and disable it
+ qw[!custom],
+);
+
+printf $fh " /* ALLOWED: @allowed_ops */ \\\n";
+
+foreach my $opname (opset_to_ops(opset(@allowed_ops))) {
+ printf $fh qq{ opmask[OP_%-12s] = 0;\t/* %s */ \\\n},
+ uc($opname), opdesc($opname);
+}
+printf $fh " /* end */ \n";
+
+close $fh
+ or die "Error closing $plperl_opmask_tmp: $!";
+
+rename $plperl_opmask_tmp, $plperl_opmask_h
+ or die "Error renaming $plperl_opmask_tmp to $plperl_opmask_h: $!";
+
+exit 0;
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/plperlu--1.0.sql
----------------------------------------------------------------------
diff --git a/src/pl/plperl/plperlu--1.0.sql b/src/pl/plperl/plperlu--1.0.sql
new file mode 100644
index 0000000..025f795
--- /dev/null
+++ b/src/pl/plperl/plperlu--1.0.sql
@@ -0,0 +1,9 @@
+/* src/pl/plperl/plperlu--1.0.sql */
+
+/*
+ * Currently, all the interesting stuff is done by CREATE LANGUAGE.
+ * Later we will probably "dumb down" that command and put more of the
+ * knowledge into this script.
+ */
+
+CREATE PROCEDURAL LANGUAGE plperlu;
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/plperlu--unpackaged--1.0.sql
----------------------------------------------------------------------
diff --git a/src/pl/plperl/plperlu--unpackaged--1.0.sql b/src/pl/plperl/plperlu--unpackaged--1.0.sql
new file mode 100644
index 0000000..bc62d36
--- /dev/null
+++ b/src/pl/plperl/plperlu--unpackaged--1.0.sql
@@ -0,0 +1,7 @@
+/* src/pl/plperl/plperlu--unpackaged--1.0.sql */
+
+ALTER EXTENSION plperlu ADD PROCEDURAL LANGUAGE plperlu;
+-- ALTER ADD LANGUAGE doesn't pick up the support functions, so we have to.
+ALTER EXTENSION plperlu ADD FUNCTION plperlu_call_handler();
+ALTER EXTENSION plperlu ADD FUNCTION plperlu_inline_handler(internal);
+ALTER EXTENSION plperlu ADD FUNCTION plperlu_validator(oid);
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/plperlu.control
----------------------------------------------------------------------
diff --git a/src/pl/plperl/plperlu.control b/src/pl/plperl/plperlu.control
new file mode 100644
index 0000000..69473ca
--- /dev/null
+++ b/src/pl/plperl/plperlu.control
@@ -0,0 +1,7 @@
+# plperlu extension
+comment = 'PL/PerlU untrusted procedural language'
+default_version = '1.0'
+module_pathname = '$libdir/plperl'
+relocatable = false
+schema = pg_catalog
+superuser = true
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/po/.gitignore
----------------------------------------------------------------------
diff --git a/src/pl/plperl/po/.gitignore b/src/pl/plperl/po/.gitignore
new file mode 100644
index 0000000..621b8ee
--- /dev/null
+++ b/src/pl/plperl/po/.gitignore
@@ -0,0 +1,8 @@
+de.mo
+es.mo
+fr.mo
+it.mo
+ja.mo
+pt_BR.mo
+tr.mo
+
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/po/.p4ignore
----------------------------------------------------------------------
diff --git a/src/pl/plperl/po/.p4ignore b/src/pl/plperl/po/.p4ignore
new file mode 100644
index 0000000..621b8ee
--- /dev/null
+++ b/src/pl/plperl/po/.p4ignore
@@ -0,0 +1,8 @@
+de.mo
+es.mo
+fr.mo
+it.mo
+ja.mo
+pt_BR.mo
+tr.mo
+
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/po/de.po
----------------------------------------------------------------------
diff --git a/src/pl/plperl/po/de.po b/src/pl/plperl/po/de.po
new file mode 100755
index 0000000..4ea354e
--- /dev/null
+++ b/src/pl/plperl/po/de.po
@@ -0,0 +1,105 @@
+# German message translation file for plperl
+# Copyright (C) 2009 PostgreSQL Global Development Group
+# This file is distributed under the same license as the PostgreSQL package.
+# Peter Eisentraut <pe...@gmx.net>, 2009.
+#
+# pgtranslation Id: plperl.po,v 1.2 2009/02/20 10:39:49 petere Exp $
+#
+# Use these quotes: �%s�
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: PostgreSQL 8.4\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n"
+"POT-Creation-Date: 2009-02-20 09:06+0000\n"
+"PO-Revision-Date: 2009-02-20 12:37+0200\n"
+"Last-Translator: Peter Eisentraut <pe...@gmx.net>\n"
+"Language-Team: German <pe...@gmx.net>\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+
+#: plperl.c:202
+msgid ""
+"If true, trusted and untrusted Perl code will be compiled in strict mode."
+msgstr "Wenn wahr, dann wird vertrauensw�rdiger und nicht vertrauensw�rdiger Perl-Code im �strict�-Modus kompiliert."
+
+#: plperl.c:606 plperl.c:799
+#, c-format
+msgid "Perl hash contains nonexistent column \"%s\""
+msgstr "Perl-Hash enth�lt nicht existierende Spalte �%s�"
+
+#: plperl.c:775
+msgid "$_TD->{new} does not exist"
+msgstr "$_TD->{new} existiert nicht"
+
+#: plperl.c:779
+msgid "$_TD->{new} is not a hash reference"
+msgstr "$_TD->{new} ist keine Hash-Referenz"
+
+#: plperl.c:916 plperl.c:1615
+#, c-format
+msgid "PL/Perl functions cannot return type %s"
+msgstr "PL/Perl-Funktionen k�nnen keinen R�ckgabetyp %s haben"
+
+#: plperl.c:928 plperl.c:1662
+#, c-format
+msgid "PL/Perl functions cannot accept type %s"
+msgstr "PL/Perl-Funktionen k�nnen Typ %s nicht annehmen"
+
+#: plperl.c:1004
+#, c-format
+msgid "creation of Perl function \"%s\" failed: %s"
+msgstr "Erzeugen der Perl-Funktion �%s� fehlgeschlagen: %s"
+
+#: plperl.c:1134 plperl.c:1192
+#, c-format
+msgid "error from Perl function \"%s\": %s"
+msgstr "Fehler aus Perl-Funktion �%s�: %s"
+
+#: plperl.c:1240
+msgid "set-valued function called in context that cannot accept a set"
+msgstr ""
+"Funktion mit Mengenergebnis in einem Zusammenhang aufgerufen, der keine "
+"Mengenergebnisse verarbeiten kann"
+
+#: plperl.c:1283
+msgid ""
+"set-returning PL/Perl function must return reference to array or use "
+"return_next"
+msgstr "PL/Perl-Funktionen mit Mengenergebnis m�ssen eine Referenz auf ein Array zur�ckgeben oder return_next verwenden"
+
+#: plperl.c:1316
+msgid "composite-returning PL/Perl function must return reference to hash"
+msgstr "PL/Perl-Funktion, die einen zusammengesetzten Typ zur�ckgibt, muss eine Referenz auf ein Hash zur�ckgeben"
+
+#: plperl.c:1325
+msgid ""
+"function returning record called in context that cannot accept type record"
+msgstr "Funktion, die einen Record zur�ckgibt, in einem Zusammenhang aufgerufen, der Typ record nicht verarbeiten kann"
+
+#: plperl.c:1441
+msgid "ignoring modified row in DELETE trigger"
+msgstr "ge�nderte Zeile im DELETE-Trigger wird ignoriert"
+
+#: plperl.c:1449
+msgid "result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\""
+msgstr "Ergebnis einer PL/Perl-Triggerfunktion muss undef, �SKIP� oder �MODIFY� sein"
+
+#: plperl.c:1549
+msgid "out of memory"
+msgstr "Speicher aufgebraucht"
+
+#: plperl.c:1606
+msgid "trigger functions can only be called as triggers"
+msgstr "Triggerfunktionen k�nnen nur als Trigger aufgerufen werden"
+
+#: plperl.c:1899
+msgid "cannot use return_next in a non-SETOF function"
+msgstr "return_next kann nur in einer Funktion mit SETOF-R�ckgabetyp verwendet werden"
+
+#: plperl.c:1905
+msgid ""
+"SETOF-composite-returning PL/Perl function must call return_next with "
+"reference to hash"
+msgstr "PL/Perl-Funktion, die SETOF eines zusammengesetzten Typs zur�ckgibt, muss return_next mit einer Referenz auf ein Hash aufrufen"
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/po/es.po
----------------------------------------------------------------------
diff --git a/src/pl/plperl/po/es.po b/src/pl/plperl/po/es.po
new file mode 100755
index 0000000..53c1af2
--- /dev/null
+++ b/src/pl/plperl/po/es.po
@@ -0,0 +1,115 @@
+# Spanish message translation file for plperl
+# This file is put in the public domain.
+# Emanuel Calvo Franco <po...@gmail.com>, 2008.
+# Alvaro Herrera <al...@alvh.no-ip.org>, 2009
+#
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: 8.4\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n"
+"POT-Creation-Date: 2009-04-09 19:21+0000\n"
+"PO-Revision-Date: 2009-04-09 17:25-0400\n"
+"Last-Translator: �lvaro Herrera <al...@alvh.no-ip.org>\n"
+"Language-Team: PgSQL-es-Ayuda <pg...@postgresql.org>\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+
+#: plperl.c:202
+msgid ""
+"If true, trusted and untrusted Perl code will be compiled in strict mode."
+msgstr ""
+"Si es verdadero, se compilar� c�digo Perl confiable y no confiable en modo "
+"�strict�."
+
+#: plperl.c:606 plperl.c:799
+#, c-format
+msgid "Perl hash contains nonexistent column \"%s\""
+msgstr "el hash de Perl contiene el columna inexistente �%s�"
+
+#: plperl.c:775
+msgid "$_TD->{new} does not exist"
+msgstr "$_TD->{new} no existe"
+
+#: plperl.c:779
+msgid "$_TD->{new} is not a hash reference"
+msgstr "$_TD->{new} no es una referencia a un hash"
+
+#: plperl.c:916 plperl.c:1615
+#, c-format
+msgid "PL/Perl functions cannot return type %s"
+msgstr "las funciones en PL/Perl no pueden retornar el tipo %s"
+
+#: plperl.c:928 plperl.c:1662
+#, c-format
+msgid "PL/Perl functions cannot accept type %s"
+msgstr "funciones de PL/Perl no pueden aceptar el tipo %s"
+
+#: plperl.c:1004
+#, c-format
+msgid "creation of Perl function \"%s\" failed: %s"
+msgstr "la creaci�n de la funci�n Perl �%s� fall�: %s"
+
+#: plperl.c:1134 plperl.c:1192
+#, c-format
+msgid "error from Perl function \"%s\": %s"
+msgstr "error en la funci�n de Perl �%s�: %s"
+
+#: plperl.c:1240
+msgid "set-valued function called in context that cannot accept a set"
+msgstr ""
+"se llam� a una funci�n que retorna un conjunto en un contexto que no puede "
+"aceptarlo"
+
+#: plperl.c:1283
+msgid ""
+"set-returning PL/Perl function must return reference to array or use "
+"return_next"
+msgstr ""
+"una funci�n PL/Perl que retorna un conjunto debe retornar una referencia a un "
+"array o usar return_next"
+
+#: plperl.c:1316
+msgid "composite-returning PL/Perl function must return reference to hash"
+msgstr ""
+"una funci�n Perl que retorna un tipo compuesto debe retornar una referencia "
+"a un hash"
+
+#: plperl.c:1325
+msgid ""
+"function returning record called in context that cannot accept type record"
+msgstr ""
+"se llam� una funci�n que retorna un registro en un contexto que no puede "
+"aceptarlo"
+
+#: plperl.c:1441
+msgid "ignoring modified row in DELETE trigger"
+msgstr "ignorando la tupla modificada en el disparador DELETE"
+
+#: plperl.c:1449
+msgid ""
+"result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\""
+msgstr ""
+"el resultado de la funci�n disparadora en PL/Perl debe ser undef, �SKIP� o "
+"�MODIFY�"
+
+#: plperl.c:1549
+msgid "out of memory"
+msgstr "memoria agotada"
+
+#: plperl.c:1606
+msgid "trigger functions can only be called as triggers"
+msgstr "las funciones disparadoras s�lo pueden ser llamadas como disparadores"
+
+#: plperl.c:1899
+msgid "cannot use return_next in a non-SETOF function"
+msgstr "no se puede utilizar return_next en una funci�n sin SETOF"
+
+#: plperl.c:1905
+msgid ""
+"SETOF-composite-returning PL/Perl function must call return_next with "
+"reference to hash"
+msgstr ""
+"una funci�n Perl que retorna SETOF de un tipo compuesto debe invocar "
+"return_next con una referencia a un hash"
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/po/fr.po
----------------------------------------------------------------------
diff --git a/src/pl/plperl/po/fr.po b/src/pl/plperl/po/fr.po
new file mode 100755
index 0000000..3654283
--- /dev/null
+++ b/src/pl/plperl/po/fr.po
@@ -0,0 +1,115 @@
+# translation of plperl.po to fr_fr
+# french message translation file for plperl
+#
+# $PostgreSQL: pgsql/src/pl/plperl/po/fr.po,v 1.1 2009/04/09 19:38:53 petere Exp $
+#
+# Use these quotes: \ufffd %s \ufffd
+# Guillaume Lelarge <gu...@lelarge.info>, 2009.
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: PostgreSQL 8.4\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n"
+"POT-Creation-Date: 2009-04-05 05:22+0000\n"
+"PO-Revision-Date: 2009-04-05 13:39+0100\n"
+"Last-Translator: Guillaume Lelarge <gu...@lelarge.info>\n"
+"Language-Team: French <gu...@lelarge.info>\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=ISO-8859-15\n"
+"Content-Transfer-Encoding: 8bit\n"
+
+#: plperl.c:202
+msgid "If true, trusted and untrusted Perl code will be compiled in strict mode."
+msgstr ""
+"Si true, le code Perl de confiance et sans confiance sera compil\ufffd en mode\n"
+"strict."
+
+#: plperl.c:606
+#: plperl.c:799
+#, c-format
+msgid "Perl hash contains nonexistent column \"%s\""
+msgstr "Le hachage Perl contient la colonne \ufffd %s \ufffd inexistante"
+
+#: plperl.c:775
+msgid "$_TD->{new} does not exist"
+msgstr "$_TD->{new} n'existe pas"
+
+#: plperl.c:779
+msgid "$_TD->{new} is not a hash reference"
+msgstr "$_TD->{new} n'est pas une r\ufffdf\ufffdrence de hachage"
+
+#: plperl.c:916
+#: plperl.c:1615
+#, c-format
+msgid "PL/Perl functions cannot return type %s"
+msgstr "Les fonctions PL/perl ne peuvent pas renvoyer le type %s"
+
+#: plperl.c:928
+#: plperl.c:1662
+#, c-format
+msgid "PL/Perl functions cannot accept type %s"
+msgstr "Les fonctions PL/perl ne peuvent pas accepter le type %s"
+
+#: plperl.c:1004
+#, c-format
+msgid "creation of Perl function \"%s\" failed: %s"
+msgstr "\ufffdchec de la cr\ufffdation de la fonction Perl \ufffd %s \ufffd : %s"
+
+#: plperl.c:1134
+#: plperl.c:1192
+#, c-format
+msgid "error from Perl function \"%s\": %s"
+msgstr "\ufffdchec dans la fonction Perl \ufffd %s \ufffd : %s"
+
+#: plperl.c:1240
+msgid "set-valued function called in context that cannot accept a set"
+msgstr ""
+"fonction renvoyant un ensemble appel\ufffde dans un contexte qui ne peut pas\n"
+"accepter un ensemble"
+
+#: plperl.c:1283
+msgid "set-returning PL/Perl function must return reference to array or use return_next"
+msgstr ""
+"la fonction PL/perl renvoyant des ensembles doit renvoyer la r\ufffdf\ufffdrence \ufffd\n"
+"un tableau ou utiliser return_next"
+
+#: plperl.c:1316
+msgid "composite-returning PL/Perl function must return reference to hash"
+msgstr ""
+"la fonction PL/perl renvoyant des valeurs composites doit renvoyer la\n"
+"r\ufffdf\ufffdrence \ufffd un hachage"
+
+#: plperl.c:1325
+msgid "function returning record called in context that cannot accept type record"
+msgstr ""
+"fonction renvoyant le type record appel\ufffde dans un contexte qui ne peut pas\n"
+"accepter le type record"
+
+#: plperl.c:1441
+msgid "ignoring modified row in DELETE trigger"
+msgstr "ignore la ligne modifi\ufffde dans le trigger DELETE"
+
+#: plperl.c:1449
+msgid "result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\""
+msgstr ""
+"le r\ufffdsultat de la fonction trigger PL/perl doit \ufffdtre undef, \ufffd SKIP \ufffd ou\n"
+"\ufffd MODIFY \ufffd"
+
+#: plperl.c:1549
+msgid "out of memory"
+msgstr "m\ufffdmoire \ufffdpuis\ufffde"
+
+#: plperl.c:1606
+msgid "trigger functions can only be called as triggers"
+msgstr "les fonctions trigger peuvent seulement \ufffdtre appel\ufffdes par des triggers"
+
+#: plperl.c:1899
+msgid "cannot use return_next in a non-SETOF function"
+msgstr "ne peut pas utiliser return_next dans une fonction non SETOF"
+
+#: plperl.c:1905
+msgid "SETOF-composite-returning PL/Perl function must call return_next with reference to hash"
+msgstr ""
+"une fonction PL/perl renvoyant des lignes composites doit appeler\n"
+"return_next avec la r\ufffdf\ufffdrence \ufffd un hachage"
+
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/po/it.po
----------------------------------------------------------------------
diff --git a/src/pl/plperl/po/it.po b/src/pl/plperl/po/it.po
new file mode 100755
index 0000000..b84bf11
--- /dev/null
+++ b/src/pl/plperl/po/it.po
@@ -0,0 +1,113 @@
+#
+# Translation of plperl to Italian
+# PostgreSQL Project
+#
+# Associazione Culturale ITPUG - Italian PostgreSQL Users Group
+# http://www.itpug.org/ - info@itpug.org
+#
+# Traduttori:
+# * Emanuele Zamprogno <em...@itpug.org>
+#
+# Revisori:
+# * Gabriele Bartolini <ga...@itpug.org>
+#
+# Copyright (c) 2009, Associazione Culturale ITPUG
+# Distributed under the same license of the PostgreSQL project
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: PostgreSQL 8.4\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n"
+"POT-Creation-Date: 2009-07-11 05:48+0000\n"
+"PO-Revision-Date: 2009-07-18 03:10:24+0200\n"
+"Last-Translator: Gabriele Bartolini <ga...@2ndquadrant.it>\n"
+"Language-Team: Gruppo traduzioni ITPUG <tr...@itpug.org>\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=utf-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+"X-Poedit-Language: Italian\n"
+"X-Poedit-Country: ITALY\n"
+"X-Poedit-SourceCharset: utf-8\n"
+
+#: plperl.c:202
+msgid "If true, trusted and untrusted Perl code will be compiled in strict mode."
+msgstr "Se vero, il codice Perl affidabile e non affidabile sar� compilato in modalit� strict"
+
+#: plperl.c:624
+#: plperl.c:817
+#, c-format
+msgid "Perl hash contains nonexistent column \"%s\""
+msgstr "La struttura hash in Perl contiene la colonna inesistente \"%s\""
+
+#: plperl.c:793
+msgid "$_TD->{new} does not exist"
+msgstr "$_TD->{new} non esiste"
+
+#: plperl.c:797
+msgid "$_TD->{new} is not a hash reference"
+msgstr "$_TD->{new} non � un riferimento ad un hash"
+
+#: plperl.c:934
+#: plperl.c:1633
+#, c-format
+msgid "PL/Perl functions cannot return type %s"
+msgstr "la funzione PL/Perl non pu� ritornare il tipo %s"
+
+#: plperl.c:946
+#: plperl.c:1680
+#, c-format
+msgid "PL/Perl functions cannot accept type %s"
+msgstr "la funzione PL/Perl non pu� accettare il tipo %s"
+
+#: plperl.c:1022
+#, c-format
+msgid "creation of Perl function \"%s\" failed: %s"
+msgstr "creazione della funzione Perl \"%s\" fallita: %s"
+
+#: plperl.c:1152
+#: plperl.c:1210
+#, c-format
+msgid "error from Perl function \"%s\": %s"
+msgstr "errore dalla funzione Perl \"%s\": %s"
+
+#: plperl.c:1258
+msgid "set-valued function called in context that cannot accept a set"
+msgstr "la funzione set-valued � stata chiamata all'interno di un contesto che non pu� accettare un set"
+
+#: plperl.c:1301
+msgid "set-returning PL/Perl function must return reference to array or use return_next"
+msgstr "la funzione PL/Perl di tipo \"set-returning\" deve ritornare un riferimento ad un array o usare return_next"
+
+#: plperl.c:1334
+msgid "composite-returning PL/Perl function must return reference to hash"
+msgstr "la funzione PL/Perl \"composite-returning\" deve ritornare un riferimento all'hash"
+
+#: plperl.c:1343
+msgid "function returning record called in context that cannot accept type record"
+msgstr "la funzione che restituisce un record � chiamata all'interno di un contesto che non pu� accettare il tipo record"
+
+#: plperl.c:1459
+msgid "ignoring modified row in DELETE trigger"
+msgstr "ignorata la riga modificata all'interno del trigger DELETE"
+
+#: plperl.c:1467
+msgid "result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\""
+msgstr "il risultato della funzione trigger PL/Perl deve essere undef, \"SKIP\" oppure \"MODIFY\""
+
+# in teoria non servirebbe tradurre
+#: plperl.c:1567
+msgid "out of memory"
+msgstr "memoria esaurita"
+
+#: plperl.c:1624
+msgid "trigger functions can only be called as triggers"
+msgstr "le funzioni trigger possono solo essere chiamate come trigger"
+
+#: plperl.c:1917
+msgid "cannot use return_next in a non-SETOF function"
+msgstr "non si pu� usare return_next in una funzione non-SETOF"
+
+#: plperl.c:1923
+msgid "SETOF-composite-returning PL/Perl function must call return_next with reference to hash"
+msgstr "la funzione PL/Perl SETOF-composite-returning deve chiamare return_next con riferimento all'hash"
+
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/po/ja.po
----------------------------------------------------------------------
diff --git a/src/pl/plperl/po/ja.po b/src/pl/plperl/po/ja.po
new file mode 100755
index 0000000..5bddc1b
--- /dev/null
+++ b/src/pl/plperl/po/ja.po
@@ -0,0 +1,100 @@
+# LANGUAGE message translation file for plperl
+# Copyright (C) 2009 PostgreSQL Global Development Group
+# This file is distributed under the same license as the PostgreSQL package.
+# FIRST AUTHOR <EM...@ADDRESS>, 2009.
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: PostgreSQL 8.4\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n"
+"POT-Creation-Date: 2009-04-13 07:10+0000\n"
+"PO-Revision-Date: 2009-04-13 22:15+0900\n"
+"Last-Translator: Shigehiro Honda <ho...@postgresql.jp>\n"
+"Language-Team: ja\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+
+#: plperl.c:202
+msgid ""
+"If true, trusted and untrusted Perl code will be compiled in strict mode."
+msgstr "\u771f\u306a\u3089\u3070\u4fe1\u983c\u3057\u3001\u4fe1\u983c\u3055\u308c\u306a\u3044Perl\u306e\u30b3\u30fc\u30c9\u306fstrict\u30e2\u30fc\u30c9\u3067\u30b3\u30f3\u30d1\u30a4\u30eb\u3055\u308c\u307e\u3059\u3002"
+
+#: plperl.c:606 plperl.c:799
+#, c-format
+msgid "Perl hash contains nonexistent column \"%s\""
+msgstr "Perl\u30cf\u30c3\u30b7\u30e5\u306b\u5b58\u5728\u3057\u306a\u3044\u5217\"%s\"\u304c\u542b\u307e\u308c\u307e\u3059"
+
+#: plperl.c:775
+msgid "$_TD->{new} does not exist"
+msgstr "$_TD->{new}\u306f\u5b58\u5728\u3057\u307e\u305b\u3093"
+
+#: plperl.c:779
+msgid "$_TD->{new} is not a hash reference"
+msgstr "$_TD->{new}\u306f\u30cf\u30c3\u30b7\u30e5\u3078\u306e\u53c2\u7167\u3067\u306f\u3042\u308a\u307e\u305b\u3093"
+
+#: plperl.c:916 plperl.c:1615
+#, c-format
+msgid "PL/Perl functions cannot return type %s"
+msgstr "PL/Perl\u95a2\u6570\u306f%s\u578b\u3092\u8fd4\u3059\u3053\u3068\u304c\u3067\u304d\u307e\u305b\u3093"
+
+#: plperl.c:928 plperl.c:1662
+#, c-format
+msgid "PL/Perl functions cannot accept type %s"
+msgstr "PL/Perl\u95a2\u6570\u306f%s\u578b\u3092\u53d7\u3051\u4ed8\u3051\u3089\u308c\u307e\u305b\u3093"
+
+#: plperl.c:1004
+#, c-format
+msgid "creation of Perl function \"%s\" failed: %s"
+msgstr "Perl\u95a2\u6570\"%s\"\u306e\u4f5c\u6210\u306b\u5931\u6557\u3057\u307e\u3057\u305f: %s"
+
+#: plperl.c:1134 plperl.c:1192
+#, c-format
+msgid "error from Perl function \"%s\": %s"
+msgstr "Perl\u95a2\u6570\"%s\"\u3067\u30a8\u30e9\u30fc\u304c\u3042\u308a\u307e\u3059: %s"
+
+#: plperl.c:1240
+msgid "set-valued function called in context that cannot accept a set"
+msgstr "\u3053\u306e\u30b3\u30f3\u30c6\u30ad\u30b9\u30c8\u3067\u96c6\u5408\u5024\u306e\u95a2\u6570\u306f\u96c6\u5408\u3092\u53d7\u3051\u4ed8\u3051\u3089\u308c\u307e\u305b\u3093"
+
+#: plperl.c:1283
+msgid ""
+"set-returning PL/Perl function must return reference to array or use "
+"return_next"
+msgstr "\u96c6\u5408\u3092\u8fd4\u3059PL/Perl\u95a2\u6570\u306f\u914d\u5217\u3078\u306e\u53c2\u7167\u3092\u8fd4\u3059\u3001\u307e\u305f\u306f\u3001return_next\u3092\u4f7f\u7528\u3059\u308b\u5fc5\u8981\u304c\u3042\u308a\u307e\u3059"
+
+#: plperl.c:1316
+msgid "composite-returning PL/Perl function must return reference to hash"
+msgstr "\u8907\u5408\u578b\u3092\u8fd4\u3059PL/Perl\u95a2\u6570\u306f\u30cf\u30c3\u30b7\u30e5\u3078\u306e\u53c2\u7167\u3092\u8fd4\u3059\u5fc5\u8981\u304c\u3042\u308a\u307e\u3059"
+
+#: plperl.c:1325
+msgid ""
+"function returning record called in context that cannot accept type record"
+msgstr "\u30ec\u30b3\u30fc\u30c9\u578b\u3092\u53d7\u3051\u4ed8\u3051\u3089\u308c\u306a\u3044\u30b3\u30f3\u30c6\u30ad\u30b9\u30c8\u3067\u30ec\u30b3\u30fc\u30c9\u3092\u8fd4\u3059\u95a2\u6570\u304c\u547c\u3073\u51fa\u3055\u308c\u307e\u3057\u305f"
+
+#: plperl.c:1441
+msgid "ignoring modified row in DELETE trigger"
+msgstr "DELETE\u30c8\u30ea\u30ac\u306b\u3066\u5909\u66f4\u3055\u308c\u305f\u884c\u3092\u7121\u8996\u3057\u307e\u3059"
+
+#: plperl.c:1449
+msgid ""
+"result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\""
+msgstr "PL/Perl\u30c8\u30ea\u30ac\u95a2\u6570\u306e\u7d50\u679c\u306f\"SKIP\"\u307e\u305f\u306f\"MODIFY\"\u3067\u306a\u3051\u308c\u3070\u306a\u308a\u307e\u305b\u3093"
+
+#: plperl.c:1549
+msgid "out of memory"
+msgstr "\u30e1\u30e2\u30ea\u4e0d\u8db3\u3067\u3059"
+
+#: plperl.c:1606
+msgid "trigger functions can only be called as triggers"
+msgstr "\u30c8\u30ea\u30ac\u30fc\u95a2\u6570\u306f\u30c8\u30ea\u30ac\u30fc\u3068\u3057\u3066\u306e\u307f\u30b3\u30fc\u30eb\u3067\u304d\u307e\u3059"
+
+#: plperl.c:1899
+msgid "cannot use return_next in a non-SETOF function"
+msgstr "SETOF\u95a2\u6570\u4ee5\u5916\u3067\u306freturn_next\u3092\u4f7f\u7528\u3059\u308b\u3053\u3068\u306f\u3067\u304d\u307e\u305b\u3093"
+
+#: plperl.c:1905
+msgid ""
+"SETOF-composite-returning PL/Perl function must call return_next with "
+"reference to hash"
+msgstr "\u8907\u5408\u578b\u306eSETOF\u3092\u8fd4\u3059PL/Perl\u95a2\u6570\u306f\u30cf\u30c3\u30b7\u30e5\u3078\u306e\u53c2\u7167\u3092\u6301\u3064return_next\u3092\u547c\u3073\u51fa\u3055\u306a\u3051\u308c\u3070\u306a\u308a\u307e\u305b\u3093"
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/po/pt_BR.po
----------------------------------------------------------------------
diff --git a/src/pl/plperl/po/pt_BR.po b/src/pl/plperl/po/pt_BR.po
new file mode 100755
index 0000000..2e6a5af
--- /dev/null
+++ b/src/pl/plperl/po/pt_BR.po
@@ -0,0 +1,105 @@
+# Brazilian Portuguese message translation file for plperl
+# Copyright (C) 2009 PostgreSQL Global Development Group
+# This file is distributed under the same license as the PostgreSQL package.
+# Euler Taveira de Oliveira <eu...@timbira.com>, 2009.
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: PostgreSQL 8.4\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n"
+"POT-Creation-Date: 2009-05-06 19:47-0300\n"
+"PO-Revision-Date: 2009-05-10 01:12-0300\n"
+"Last-Translator: Euler Taveira de Oliveira <eu...@timbira.com>\n"
+"Language-Team: Brazilian Portuguese <pg...@listas.postgresql.org.br>\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+
+#: plperl.c:202
+msgid ""
+"If true, trusted and untrusted Perl code will be compiled in strict mode."
+msgstr ""
+"Se verdadeiro, c�digo Perl confi�vel e n�o-confi�vel ser� compilado em modo estrito."
+
+#: plperl.c:606 plperl.c:799
+#, c-format
+msgid "Perl hash contains nonexistent column \"%s\""
+msgstr "hash Perl cont�m coluna inexistente \"%s\""
+
+#: plperl.c:775
+msgid "$_TD->{new} does not exist"
+msgstr "$_TD->{new} n�o existe"
+
+#: plperl.c:779
+msgid "$_TD->{new} is not a hash reference"
+msgstr "$_TD->{new} n�o � uma refer�ncia hash"
+
+#: plperl.c:916 plperl.c:1615
+#, c-format
+msgid "PL/Perl functions cannot return type %s"
+msgstr "fun��es PL/Perl n�o podem retornar tipo %s"
+
+#: plperl.c:928 plperl.c:1662
+#, c-format
+msgid "PL/Perl functions cannot accept type %s"
+msgstr "fun��es PL/Perl n�o podem aceitar tipo %s"
+
+#: plperl.c:1004
+#, c-format
+msgid "creation of Perl function \"%s\" failed: %s"
+msgstr "cria��o da fun��o Perl \"%s\" falhou: %s"
+
+#: plperl.c:1134 plperl.c:1192
+#, c-format
+msgid "error from Perl function \"%s\": %s"
+msgstr "erro da fun��o Perl \"%s\": %s"
+
+#: plperl.c:1240
+msgid "set-valued function called in context that cannot accept a set"
+msgstr ""
+
+#: plperl.c:1283
+msgid ""
+"set-returning PL/Perl function must return reference to array or use "
+"return_next"
+msgstr ""
+"fun�ao PL/Perl que retorna conjunto deve retornar refer�ncia para matriz ou usar return_next"
+
+#: plperl.c:1316
+msgid "composite-returning PL/Perl function must return reference to hash"
+msgstr "fun��o que retorna tipo composto deve retornar refer�ncia a um hash"
+
+#: plperl.c:1325
+msgid ""
+"function returning record called in context that cannot accept type record"
+msgstr ""
+"fun��o que retorna record foi chamada em um contexto que n�o pode aceitar tipo record"
+
+#: plperl.c:1441
+msgid "ignoring modified row in DELETE trigger"
+msgstr "ignorando registro modificado em gatilho DELETE"
+
+#: plperl.c:1449
+msgid ""
+"result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\""
+msgstr ""
+"resultado da fun��o de gatilho PL/Perl deve ser undef, \"SKIP\" ou \"MODIFY\""
+
+#: plperl.c:1549
+msgid "out of memory"
+msgstr "sem mem�ria"
+
+#: plperl.c:1606
+msgid "trigger functions can only be called as triggers"
+msgstr "fun��es de gatilho s� podem ser chamadas como gatilhos"
+
+#: plperl.c:1899
+msgid "cannot use return_next in a non-SETOF function"
+msgstr "n�o pode utilizar return_next em uma fun��o que n�o retorna conjunto"
+
+#: plperl.c:1905
+msgid ""
+"SETOF-composite-returning PL/Perl function must call return_next with "
+"reference to hash"
+msgstr ""
+"fun��o PL/Perl que retorna um conjunto de tipo composto deve chamar return_next com refer�ncia a um hash"
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/po/tr.po
----------------------------------------------------------------------
diff --git a/src/pl/plperl/po/tr.po b/src/pl/plperl/po/tr.po
new file mode 100755
index 0000000..3f74ef4
--- /dev/null
+++ b/src/pl/plperl/po/tr.po
@@ -0,0 +1,100 @@
+# LANGUAGE message translation file for plperl
+# Copyright (C) 2009 PostgreSQL Global Development Group
+# This file is distributed under the same license as the PostgreSQL package.
+# FIRST AUTHOR <EM...@ADDRESS>, 2009.
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: PostgreSQL 8.4\n"
+"Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n"
+"POT-Creation-Date: 2009-04-29 07:08+0000\n"
+"PO-Revision-Date: 2009-05-04 22:12+0200\n"
+"Last-Translator: Devrim G�ND�Z <de...@commandprompt.com>\n"
+"Language-Team: Turkish <de...@gunduz.org>\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+"X-Poedit-Language: Turkish\n"
+"X-Poedit-Country: Turkey\n"
+
+#: plperl.c:202
+msgid "If true, trusted and untrusted Perl code will be compiled in strict mode."
+msgstr "Do\u011fru ise, trusted ve untrusted Perl kodlar\u0131 strict modda derlenecektir"
+
+#: plperl.c:606
+#: plperl.c:799
+#, c-format
+msgid "Perl hash contains nonexistent column \"%s\""
+msgstr "Perl hashi olmayan kolonu i�eriyor: \"%s\""
+
+#: plperl.c:775
+msgid "$_TD->{new} does not exist"
+msgstr "$_TD->{new} mevcut de\u011fil"
+
+#: plperl.c:779
+msgid "$_TD->{new} is not a hash reference"
+msgstr "$_TD->{new} hash referans\u0131 de\u011fil"
+
+#: plperl.c:916
+#: plperl.c:1615
+#, c-format
+msgid "PL/Perl functions cannot return type %s"
+msgstr "PL/Perl fonksiyonlar\u0131 %s veri tipini d�nd�remezler"
+
+#: plperl.c:928
+#: plperl.c:1662
+#, c-format
+msgid "PL/Perl functions cannot accept type %s"
+msgstr "PL/Perl fonksiyonlar\u0131 %s tipini kabul etmez"
+
+#: plperl.c:1004
+#, c-format
+msgid "creation of Perl function \"%s\" failed: %s"
+msgstr " \"%s\" Perl fonksiyonunun yarat\u0131lmas\u0131 ba\u015far\u0131s\u0131z oldu: %s"
+
+#: plperl.c:1134
+#: plperl.c:1192
+#, c-format
+msgid "error from Perl function \"%s\": %s"
+msgstr "Perl fonksiyonunda hata: \"%s\": %s"
+
+#: plperl.c:1240
+msgid "set-valued function called in context that cannot accept a set"
+msgstr "set de\u011ferini kabul etmedi\u011fi ortamda set de\u011feri alan fonksiyon �a\u011f\u0131r\u0131lm\u0131\u015f"
+
+#: plperl.c:1283
+msgid "set-returning PL/Perl function must return reference to array or use return_next"
+msgstr "se d�nen PL/Perl fonksiyonu return_next kullanmal\u0131 ya da bir diziye referans d�nmelidir"
+
+#: plperl.c:1316
+msgid "composite-returning PL/Perl function must return reference to hash"
+msgstr "composite d�nd�ren PL/Perl fonksiyonu hash'e referans d�nmelidir"
+
+#: plperl.c:1325
+msgid "function returning record called in context that cannot accept type record"
+msgstr "tip kayd\u0131 i�ermeyen alanda �a\u011f\u0131r\u0131lan ve kay\u0131t d�nd�ren fonksiyon"
+
+#: plperl.c:1441
+msgid "ignoring modified row in DELETE trigger"
+msgstr "DELETE trigger\u0131ndaki de\u011fi\u015ftirilmi\u015f sat\u0131r g�zard\u0131 ediliyor"
+
+#: plperl.c:1449
+msgid "result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\""
+msgstr "PL/Perl trigger fonksiyonun sonucu undef, \"SKIP\" ya da \"MODIFY\" olmal\u0131d\u0131r"
+
+#: plperl.c:1549
+msgid "out of memory"
+msgstr "yetersiz bellek"
+
+#: plperl.c:1606
+msgid "trigger functions can only be called as triggers"
+msgstr "trigger fonksiyonlar\u0131 sadece trigger olarak �a\u011f\u0131r\u0131labilirler"
+
+#: plperl.c:1899
+msgid "cannot use return_next in a non-SETOF function"
+msgstr "SETOF olmayan bir fonksiyonda return_next kullan\u0131lamaz"
+
+#: plperl.c:1905
+msgid "SETOF-composite-returning PL/Perl function must call return_next with reference to hash"
+msgstr "SETOF-composite d�nd�ren PL/Perl fonksiyonlar\u0131 return_next'i hash'e referans olarak �a\u011f\u0131rmal\u0131d\u0131r"
+
[2/5] incubator-hawq git commit: HAWQ-744. Add plperl code
Posted by hu...@apache.org.
http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/ppport.h
----------------------------------------------------------------------
diff --git a/src/pl/plperl/ppport.h b/src/pl/plperl/ppport.h
new file mode 100644
index 0000000..efa42ea
--- /dev/null
+++ b/src/pl/plperl/ppport.h
@@ -0,0 +1,7064 @@
+#if 0
+<<'SKIP';
+#endif
+/*
+----------------------------------------------------------------------
+
+ ppport.h -- Perl/Pollution/Portability Version 3.19
+
+ Automatically created by Devel::PPPort running under perl 5.011002.
+
+ Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
+ includes in parts/inc/ instead.
+
+ Use 'perldoc ppport.h' to view the documentation below.
+
+----------------------------------------------------------------------
+
+SKIP
+
+=pod
+
+=head1 NAME
+
+ppport.h - Perl/Pollution/Portability version 3.19
+
+=head1 SYNOPSIS
+
+ perl ppport.h [options] [source files]
+
+ Searches current directory for files if no [source files] are given
+
+ --help show short help
+
+ --version show version
+
+ --patch=file write one patch file with changes
+ --copy=suffix write changed copies with suffix
+ --diff=program use diff program and options
+
+ --compat-version=version provide compatibility with Perl version
+ --cplusplus accept C++ comments
+
+ --quiet don't output anything except fatal errors
+ --nodiag don't show diagnostics
+ --nohints don't show hints
+ --nochanges don't suggest changes
+ --nofilter don't filter input files
+
+ --strip strip all script and doc functionality from
+ ppport.h
+
+ --list-provided list provided API
+ --list-unsupported list unsupported API
+ --api-info=name show Perl API portability information
+
+=head1 COMPATIBILITY
+
+This version of F<ppport.h> is designed to support operation with Perl
+installations back to 5.003, and has been tested up to 5.10.0.
+
+=head1 OPTIONS
+
+=head2 --help
+
+Display a brief usage summary.
+
+=head2 --version
+
+Display the version of F<ppport.h>.
+
+=head2 --patch=I<file>
+
+If this option is given, a single patch file will be created if
+any changes are suggested. This requires a working diff program
+to be installed on your system.
+
+=head2 --copy=I<suffix>
+
+If this option is given, a copy of each file will be saved with
+the given suffix that contains the suggested changes. This does
+not require any external programs. Note that this does not
+automagially add a dot between the original filename and the
+suffix. If you want the dot, you have to include it in the option
+argument.
+
+If neither C<--patch> or C<--copy> are given, the default is to
+simply print the diffs for each file. This requires either
+C<Text::Diff> or a C<diff> program to be installed.
+
+=head2 --diff=I<program>
+
+Manually set the diff program and options to use. The default
+is to use C<Text::Diff>, when installed, and output unified
+context diffs.
+
+=head2 --compat-version=I<version>
+
+Tell F<ppport.h> to check for compatibility with the given
+Perl version. The default is to check for compatibility with Perl
+version 5.003. You can use this option to reduce the output
+of F<ppport.h> if you intend to be backward compatible only
+down to a certain Perl version.
+
+=head2 --cplusplus
+
+Usually, F<ppport.h> will detect C++ style comments and
+replace them with C style comments for portability reasons.
+Using this option instructs F<ppport.h> to leave C++
+comments untouched.
+
+=head2 --quiet
+
+Be quiet. Don't print anything except fatal errors.
+
+=head2 --nodiag
+
+Don't output any diagnostic messages. Only portability
+alerts will be printed.
+
+=head2 --nohints
+
+Don't output any hints. Hints often contain useful portability
+notes. Warnings will still be displayed.
+
+=head2 --nochanges
+
+Don't suggest any changes. Only give diagnostic output and hints
+unless these are also deactivated.
+
+=head2 --nofilter
+
+Don't filter the list of input files. By default, files not looking
+like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped.
+
+=head2 --strip
+
+Strip all script and documentation functionality from F<ppport.h>.
+This reduces the size of F<ppport.h> dramatically and may be useful
+if you want to include F<ppport.h> in smaller modules without
+increasing their distribution size too much.
+
+The stripped F<ppport.h> will have a C<--unstrip> option that allows
+you to undo the stripping, but only if an appropriate C<Devel::PPPort>
+module is installed.
+
+=head2 --list-provided
+
+Lists the API elements for which compatibility is provided by
+F<ppport.h>. Also lists if it must be explicitly requested,
+if it has dependencies, and if there are hints or warnings for it.
+
+=head2 --list-unsupported
+
+Lists the API elements that are known not to be supported by
+F<ppport.h> and below which version of Perl they probably
+won't be available or work.
+
+=head2 --api-info=I<name>
+
+Show portability information for API elements matching I<name>.
+If I<name> is surrounded by slashes, it is interpreted as a regular
+expression.
+
+=head1 DESCRIPTION
+
+In order for a Perl extension (XS) module to be as portable as possible
+across differing versions of Perl itself, certain steps need to be taken.
+
+=over 4
+
+=item *
+
+Including this header is the first major one. This alone will give you
+access to a large part of the Perl API that hasn't been available in
+earlier Perl releases. Use
+
+ perl ppport.h --list-provided
+
+to see which API elements are provided by ppport.h.
+
+=item *
+
+You should avoid using deprecated parts of the API. For example, using
+global Perl variables without the C<PL_> prefix is deprecated. Also,
+some API functions used to have a C<perl_> prefix. Using this form is
+also deprecated. You can safely use the supported API, as F<ppport.h>
+will provide wrappers for older Perl versions.
+
+=item *
+
+If you use one of a few functions or variables that were not present in
+earlier versions of Perl, and that can't be provided using a macro, you
+have to explicitly request support for these functions by adding one or
+more C<#define>s in your source code before the inclusion of F<ppport.h>.
+
+These functions or variables will be marked C<explicit> in the list shown
+by C<--list-provided>.
+
+Depending on whether you module has a single or multiple files that
+use such functions or variables, you want either C<static> or global
+variants.
+
+For a C<static> function or variable (used only in a single source
+file), use:
+
+ #define NEED_function
+ #define NEED_variable
+
+For a global function or variable (used in multiple source files),
+use:
+
+ #define NEED_function_GLOBAL
+ #define NEED_variable_GLOBAL
+
+Note that you mustn't have more than one global request for the
+same function or variable in your project.
+
+ Function / Variable Static Request Global Request
+ -----------------------------------------------------------------------------------------
+ PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL
+ PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL
+ eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL
+ grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL
+ grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL
+ grok_number() NEED_grok_number NEED_grok_number_GLOBAL
+ grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL
+ grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL
+ load_module() NEED_load_module NEED_load_module_GLOBAL
+ my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL
+ my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL
+ my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL
+ my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL
+ newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
+ newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL
+ newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL
+ newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL
+ newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL
+ pv_display() NEED_pv_display NEED_pv_display_GLOBAL
+ pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL
+ pv_pretty() NEED_pv_pretty NEED_pv_pretty_GLOBAL
+ sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL
+ sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL
+ sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL
+ sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL
+ sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL
+ sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL
+ sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL
+ vload_module() NEED_vload_module NEED_vload_module_GLOBAL
+ vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL
+ warner() NEED_warner NEED_warner_GLOBAL
+
+To avoid namespace conflicts, you can change the namespace of the
+explicitly exported functions / variables using the C<DPPP_NAMESPACE>
+macro. Just C<#define> the macro before including C<ppport.h>:
+
+ #define DPPP_NAMESPACE MyOwnNamespace_
+ #include "ppport.h"
+
+The default namespace is C<DPPP_>.
+
+=back
+
+The good thing is that most of the above can be checked by running
+F<ppport.h> on your source code. See the next section for
+details.
+
+=head1 EXAMPLES
+
+To verify whether F<ppport.h> is needed for your module, whether you
+should make any changes to your code, and whether any special defines
+should be used, F<ppport.h> can be run as a Perl script to check your
+source code. Simply say:
+
+ perl ppport.h
+
+The result will usually be a list of patches suggesting changes
+that should at least be acceptable, if not necessarily the most
+efficient solution, or a fix for all possible problems.
+
+If you know that your XS module uses features only available in
+newer Perl releases, if you're aware that it uses C++ comments,
+and if you want all suggestions as a single patch file, you could
+use something like this:
+
+ perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff
+
+If you only want your code to be scanned without any suggestions
+for changes, use:
+
+ perl ppport.h --nochanges
+
+You can specify a different C<diff> program or options, using
+the C<--diff> option:
+
+ perl ppport.h --diff='diff -C 10'
+
+This would output context diffs with 10 lines of context.
+
+If you want to create patched copies of your files instead, use:
+
+ perl ppport.h --copy=.new
+
+To display portability information for the C<newSVpvn> function,
+use:
+
+ perl ppport.h --api-info=newSVpvn
+
+Since the argument to C<--api-info> can be a regular expression,
+you can use
+
+ perl ppport.h --api-info=/_nomg$/
+
+to display portability information for all C<_nomg> functions or
+
+ perl ppport.h --api-info=/./
+
+to display information for all known API elements.
+
+=head1 BUGS
+
+If this version of F<ppport.h> is causing failure during
+the compilation of this module, please check if newer versions
+of either this module or C<Devel::PPPort> are available on CPAN
+before sending a bug report.
+
+If F<ppport.h> was generated using the latest version of
+C<Devel::PPPort> and is causing failure of this module, please
+file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>.
+
+Please include the following information:
+
+=over 4
+
+=item 1.
+
+The complete output from running "perl -V"
+
+=item 2.
+
+This file.
+
+=item 3.
+
+The name and version of the module you were trying to build.
+
+=item 4.
+
+A full log of the build that failed.
+
+=item 5.
+
+Any other information that you think could be relevant.
+
+=back
+
+For the latest version of this code, please get the C<Devel::PPPort>
+module from CPAN.
+
+=head1 COPYRIGHT
+
+Version 3.x, Copyright (c) 2004-2009, Marcus Holland-Moritz.
+
+Version 2.x, Copyright (C) 2001, Paul Marquess.
+
+Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+See L<Devel::PPPort>.
+
+=cut
+
+use strict;
+
+# Disable broken TRIE-optimization
+BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 }
+
+my $VERSION = 3.19;
+
+my %opt = (
+ quiet => 0,
+ diag => 1,
+ hints => 1,
+ changes => 1,
+ cplusplus => 0,
+ filter => 1,
+ strip => 0,
+ version => 0,
+);
+
+my($ppport) = $0 =~ /([\w.]+)$/;
+my $LF = '(?:\r\n|[\r\n])'; # line feed
+my $HS = "[ \t]"; # horizontal whitespace
+
+# Never use C comments in this file!
+my $ccs = '/'.'*';
+my $cce = '*'.'/';
+my $rccs = quotemeta $ccs;
+my $rcce = quotemeta $cce;
+
+eval {
+ require Getopt::Long;
+ Getopt::Long::GetOptions(\%opt, qw(
+ help quiet diag! filter! hints! changes! cplusplus strip version
+ patch=s copy=s diff=s compat-version=s
+ list-provided list-unsupported api-info=s
+ )) or usage();
+};
+
+if ($@ and grep /^-/, @ARGV) {
+ usage() if "@ARGV" =~ /^--?h(?:elp)?$/;
+ die "Getopt::Long not found. Please don't use any options.\n";
+}
+
+if ($opt{version}) {
+ print "This is $0 $VERSION.\n";
+ exit 0;
+}
+
+usage() if $opt{help};
+strip() if $opt{strip};
+
+if (exists $opt{'compat-version'}) {
+ my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) };
+ if ($@) {
+ die "Invalid version number format: '$opt{'compat-version'}'\n";
+ }
+ die "Only Perl 5 is supported\n" if $r != 5;
+ die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000;
+ $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s;
+}
+else {
+ $opt{'compat-version'} = 5;
+}
+
+my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/
+ ? ( $1 => {
+ ($2 ? ( base => $2 ) : ()),
+ ($3 ? ( todo => $3 ) : ()),
+ (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()),
+ (index($4, 'p') >= 0 ? ( provided => 1 ) : ()),
+ (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()),
+ } )
+ : die "invalid spec: $_" } qw(
+AvFILLp|5.004050||p
+AvFILL|||
+CLASS|||n
+CPERLscope|5.005000||p
+CX_CURPAD_SAVE|||
+CX_CURPAD_SV|||
+CopFILEAV|5.006000||p
+CopFILEGV_set|5.006000||p
+CopFILEGV|5.006000||p
+CopFILESV|5.006000||p
+CopFILE_set|5.006000||p
+CopFILE|5.006000||p
+CopSTASHPV_set|5.006000||p
+CopSTASHPV|5.006000||p
+CopSTASH_eq|5.006000||p
+CopSTASH_set|5.006000||p
+CopSTASH|5.006000||p
+CopyD|5.009002||p
+Copy|||
+CvPADLIST|||
+CvSTASH|||
+CvWEAKOUTSIDE|||
+DEFSV_set|5.011000||p
+DEFSV|5.004050||p
+END_EXTERN_C|5.005000||p
+ENTER|||
+ERRSV|5.004050||p
+EXTEND|||
+EXTERN_C|5.005000||p
+F0convert|||n
+FREETMPS|||
+GIMME_V||5.004000|n
+GIMME|||n
+GROK_NUMERIC_RADIX|5.007002||p
+G_ARRAY|||
+G_DISCARD|||
+G_EVAL|||
+G_METHOD|5.006001||p
+G_NOARGS|||
+G_SCALAR|||
+G_VOID||5.004000|
+GetVars|||
+GvSVn|5.009003||p
+GvSV|||
+Gv_AMupdate|||
+HEf_SVKEY||5.004000|
+HeHASH||5.004000|
+HeKEY||5.004000|
+HeKLEN||5.004000|
+HePV||5.004000|
+HeSVKEY_force||5.004000|
+HeSVKEY_set||5.004000|
+HeSVKEY||5.004000|
+HeUTF8||5.011000|
+HeVAL||5.004000|
+HvNAMELEN_get|5.009003||p
+HvNAME_get|5.009003||p
+HvNAME|||
+INT2PTR|5.006000||p
+IN_LOCALE_COMPILETIME|5.007002||p
+IN_LOCALE_RUNTIME|5.007002||p
+IN_LOCALE|5.007002||p
+IN_PERL_COMPILETIME|5.008001||p
+IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p
+IS_NUMBER_INFINITY|5.007002||p
+IS_NUMBER_IN_UV|5.007002||p
+IS_NUMBER_NAN|5.007003||p
+IS_NUMBER_NEG|5.007002||p
+IS_NUMBER_NOT_INT|5.007002||p
+IVSIZE|5.006000||p
+IVTYPE|5.006000||p
+IVdf|5.006000||p
+LEAVE|||
+LVRET|||
+MARK|||
+MULTICALL||5.011000|
+MY_CXT_CLONE|5.009002||p
+MY_CXT_INIT|5.007003||p
+MY_CXT|5.007003||p
+MoveD|5.009002||p
+Move|||
+NOOP|5.005000||p
+NUM2PTR|5.006000||p
+NVTYPE|5.006000||p
+NVef|5.006001||p
+NVff|5.006001||p
+NVgf|5.006001||p
+Newxc|5.009003||p
+Newxz|5.009003||p
+Newx|5.009003||p
+Nullav|||
+Nullch|||
+Nullcv|||
+Nullhv|||
+Nullsv|||
+ORIGMARK|||
+PAD_BASE_SV|||
+PAD_CLONE_VARS|||
+PAD_COMPNAME_FLAGS|||
+PAD_COMPNAME_GEN_set|||
+PAD_COMPNAME_GEN|||
+PAD_COMPNAME_OURSTASH|||
+PAD_COMPNAME_PV|||
+PAD_COMPNAME_TYPE|||
+PAD_DUP|||
+PAD_RESTORE_LOCAL|||
+PAD_SAVE_LOCAL|||
+PAD_SAVE_SETNULLPAD|||
+PAD_SETSV|||
+PAD_SET_CUR_NOSAVE|||
+PAD_SET_CUR|||
+PAD_SVl|||
+PAD_SV|||
+PERLIO_FUNCS_CAST|5.009003||p
+PERLIO_FUNCS_DECL|5.009003||p
+PERL_ABS|5.008001||p
+PERL_BCDVERSION|5.011000||p
+PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p
+PERL_HASH|5.004000||p
+PERL_INT_MAX|5.004000||p
+PERL_INT_MIN|5.004000||p
+PERL_LONG_MAX|5.004000||p
+PERL_LONG_MIN|5.004000||p
+PERL_MAGIC_arylen|5.007002||p
+PERL_MAGIC_backref|5.007002||p
+PERL_MAGIC_bm|5.007002||p
+PERL_MAGIC_collxfrm|5.007002||p
+PERL_MAGIC_dbfile|5.007002||p
+PERL_MAGIC_dbline|5.007002||p
+PERL_MAGIC_defelem|5.007002||p
+PERL_MAGIC_envelem|5.007002||p
+PERL_MAGIC_env|5.007002||p
+PERL_MAGIC_ext|5.007002||p
+PERL_MAGIC_fm|5.007002||p
+PERL_MAGIC_glob|5.011000||p
+PERL_MAGIC_isaelem|5.007002||p
+PERL_MAGIC_isa|5.007002||p
+PERL_MAGIC_mutex|5.011000||p
+PERL_MAGIC_nkeys|5.007002||p
+PERL_MAGIC_overload_elem|5.007002||p
+PERL_MAGIC_overload_table|5.007002||p
+PERL_MAGIC_overload|5.007002||p
+PERL_MAGIC_pos|5.007002||p
+PERL_MAGIC_qr|5.007002||p
+PERL_MAGIC_regdata|5.007002||p
+PERL_MAGIC_regdatum|5.007002||p
+PERL_MAGIC_regex_global|5.007002||p
+PERL_MAGIC_shared_scalar|5.007003||p
+PERL_MAGIC_shared|5.007003||p
+PERL_MAGIC_sigelem|5.007002||p
+PERL_MAGIC_sig|5.007002||p
+PERL_MAGIC_substr|5.007002||p
+PERL_MAGIC_sv|5.007002||p
+PERL_MAGIC_taint|5.007002||p
+PERL_MAGIC_tiedelem|5.007002||p
+PERL_MAGIC_tiedscalar|5.007002||p
+PERL_MAGIC_tied|5.007002||p
+PERL_MAGIC_utf8|5.008001||p
+PERL_MAGIC_uvar_elem|5.007003||p
+PERL_MAGIC_uvar|5.007002||p
+PERL_MAGIC_vec|5.007002||p
+PERL_MAGIC_vstring|5.008001||p
+PERL_PV_ESCAPE_ALL|5.009004||p
+PERL_PV_ESCAPE_FIRSTCHAR|5.009004||p
+PERL_PV_ESCAPE_NOBACKSLASH|5.009004||p
+PERL_PV_ESCAPE_NOCLEAR|5.009004||p
+PERL_PV_ESCAPE_QUOTE|5.009004||p
+PERL_PV_ESCAPE_RE|5.009005||p
+PERL_PV_ESCAPE_UNI_DETECT|5.009004||p
+PERL_PV_ESCAPE_UNI|5.009004||p
+PERL_PV_PRETTY_DUMP|5.009004||p
+PERL_PV_PRETTY_ELLIPSES|5.010000||p
+PERL_PV_PRETTY_LTGT|5.009004||p
+PERL_PV_PRETTY_NOCLEAR|5.010000||p
+PERL_PV_PRETTY_QUOTE|5.009004||p
+PERL_PV_PRETTY_REGPROP|5.009004||p
+PERL_QUAD_MAX|5.004000||p
+PERL_QUAD_MIN|5.004000||p
+PERL_REVISION|5.006000||p
+PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p
+PERL_SCAN_DISALLOW_PREFIX|5.007003||p
+PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p
+PERL_SCAN_SILENT_ILLDIGIT|5.008001||p
+PERL_SHORT_MAX|5.004000||p
+PERL_SHORT_MIN|5.004000||p
+PERL_SIGNALS_UNSAFE_FLAG|5.008001||p
+PERL_SUBVERSION|5.006000||p
+PERL_SYS_INIT3||5.006000|
+PERL_SYS_INIT|||
+PERL_SYS_TERM||5.011000|
+PERL_UCHAR_MAX|5.004000||p
+PERL_UCHAR_MIN|5.004000||p
+PERL_UINT_MAX|5.004000||p
+PERL_UINT_MIN|5.004000||p
+PERL_ULONG_MAX|5.004000||p
+PERL_ULONG_MIN|5.004000||p
+PERL_UNUSED_ARG|5.009003||p
+PERL_UNUSED_CONTEXT|5.009004||p
+PERL_UNUSED_DECL|5.007002||p
+PERL_UNUSED_VAR|5.007002||p
+PERL_UQUAD_MAX|5.004000||p
+PERL_UQUAD_MIN|5.004000||p
+PERL_USE_GCC_BRACE_GROUPS|5.009004||p
+PERL_USHORT_MAX|5.004000||p
+PERL_USHORT_MIN|5.004000||p
+PERL_VERSION|5.006000||p
+PL_DBsignal|5.005000||p
+PL_DBsingle|||pn
+PL_DBsub|||pn
+PL_DBtrace|||pn
+PL_Sv|5.005000||p
+PL_bufend|5.011000||p
+PL_bufptr|5.011000||p
+PL_compiling|5.004050||p
+PL_copline|5.011000||p
+PL_curcop|5.004050||p
+PL_curstash|5.004050||p
+PL_debstash|5.004050||p
+PL_defgv|5.004050||p
+PL_diehook|5.004050||p
+PL_dirty|5.004050||p
+PL_dowarn|||pn
+PL_errgv|5.004050||p
+PL_error_count|5.011000||p
+PL_expect|5.011000||p
+PL_hexdigit|5.005000||p
+PL_hints|5.005000||p
+PL_in_my_stash|5.011000||p
+PL_in_my|5.011000||p
+PL_last_in_gv|||n
+PL_laststatval|5.005000||p
+PL_lex_state|5.011000||p
+PL_lex_stuff|5.011000||p
+PL_linestr|5.011000||p
+PL_modglobal||5.005000|n
+PL_na|5.004050||pn
+PL_no_modify|5.006000||p
+PL_ofsgv|||n
+PL_parser|5.009005||p
+PL_perl_destruct_level|5.004050||p
+PL_perldb|5.004050||p
+PL_ppaddr|5.006000||p
+PL_rsfp_filters|5.004050||p
+PL_rsfp|5.004050||p
+PL_rs|||n
+PL_signals|5.008001||p
+PL_stack_base|5.004050||p
+PL_stack_sp|5.004050||p
+PL_statcache|5.005000||p
+PL_stdingv|5.004050||p
+PL_sv_arenaroot|5.004050||p
+PL_sv_no|5.004050||pn
+PL_sv_undef|5.004050||pn
+PL_sv_yes|5.004050||pn
+PL_tainted|5.004050||p
+PL_tainting|5.004050||p
+PL_tokenbuf|5.011000||p
+POP_MULTICALL||5.011000|
+POPi|||n
+POPl|||n
+POPn|||n
+POPpbytex||5.007001|n
+POPpx||5.005030|n
+POPp|||n
+POPs|||n
+PTR2IV|5.006000||p
+PTR2NV|5.006000||p
+PTR2UV|5.006000||p
+PTR2nat|5.009003||p
+PTR2ul|5.007001||p
+PTRV|5.006000||p
+PUSHMARK|||
+PUSH_MULTICALL||5.011000|
+PUSHi|||
+PUSHmortal|5.009002||p
+PUSHn|||
+PUSHp|||
+PUSHs|||
+PUSHu|5.004000||p
+PUTBACK|||
+PerlIO_clearerr||5.007003|
+PerlIO_close||5.007003|
+PerlIO_context_layers||5.009004|
+PerlIO_eof||5.007003|
+PerlIO_error||5.007003|
+PerlIO_fileno||5.007003|
+PerlIO_fill||5.007003|
+PerlIO_flush||5.007003|
+PerlIO_get_base||5.007003|
+PerlIO_get_bufsiz||5.007003|
+PerlIO_get_cnt||5.007003|
+PerlIO_get_ptr||5.007003|
+PerlIO_read||5.007003|
+PerlIO_seek||5.007003|
+PerlIO_set_cnt||5.007003|
+PerlIO_set_ptrcnt||5.007003|
+PerlIO_setlinebuf||5.007003|
+PerlIO_stderr||5.007003|
+PerlIO_stdin||5.007003|
+PerlIO_stdout||5.007003|
+PerlIO_tell||5.007003|
+PerlIO_unread||5.007003|
+PerlIO_write||5.007003|
+Perl_signbit||5.009005|n
+PoisonFree|5.009004||p
+PoisonNew|5.009004||p
+PoisonWith|5.009004||p
+Poison|5.008000||p
+RETVAL|||n
+Renewc|||
+Renew|||
+SAVECLEARSV|||
+SAVECOMPPAD|||
+SAVEPADSV|||
+SAVETMPS|||
+SAVE_DEFSV|5.004050||p
+SPAGAIN|||
+SP|||
+START_EXTERN_C|5.005000||p
+START_MY_CXT|5.007003||p
+STMT_END|||p
+STMT_START|||p
+STR_WITH_LEN|5.009003||p
+ST|||
+SV_CONST_RETURN|5.009003||p
+SV_COW_DROP_PV|5.008001||p
+SV_COW_SHARED_HASH_KEYS|5.009005||p
+SV_GMAGIC|5.007002||p
+SV_HAS_TRAILING_NUL|5.009004||p
+SV_IMMEDIATE_UNREF|5.007001||p
+SV_MUTABLE_RETURN|5.009003||p
+SV_NOSTEAL|5.009002||p
+SV_SMAGIC|5.009003||p
+SV_UTF8_NO_ENCODING|5.008001||p
+SVfARG|5.009005||p
+SVf_UTF8|5.006000||p
+SVf|5.006000||p
+SVt_IV|||
+SVt_NV|||
+SVt_PVAV|||
+SVt_PVCV|||
+SVt_PVHV|||
+SVt_PVMG|||
+SVt_PV|||
+Safefree|||
+Slab_Alloc|||
+Slab_Free|||
+Slab_to_rw|||
+StructCopy|||
+SvCUR_set|||
+SvCUR|||
+SvEND|||
+SvGAMAGIC||5.006001|
+SvGETMAGIC|5.004050||p
+SvGROW|||
+SvIOK_UV||5.006000|
+SvIOK_notUV||5.006000|
+SvIOK_off|||
+SvIOK_only_UV||5.006000|
+SvIOK_only|||
+SvIOK_on|||
+SvIOKp|||
+SvIOK|||
+SvIVX|||
+SvIV_nomg|5.009001||p
+SvIV_set|||
+SvIVx|||
+SvIV|||
+SvIsCOW_shared_hash||5.008003|
+SvIsCOW||5.008003|
+SvLEN_set|||
+SvLEN|||
+SvLOCK||5.007003|
+SvMAGIC_set|5.009003||p
+SvNIOK_off|||
+SvNIOKp|||
+SvNIOK|||
+SvNOK_off|||
+SvNOK_only|||
+SvNOK_on|||
+SvNOKp|||
+SvNOK|||
+SvNVX|||
+SvNV_set|||
+SvNVx|||
+SvNV|||
+SvOK|||
+SvOOK_offset||5.011000|
+SvOOK|||
+SvPOK_off|||
+SvPOK_only_UTF8||5.006000|
+SvPOK_only|||
+SvPOK_on|||
+SvPOKp|||
+SvPOK|||
+SvPVX_const|5.009003||p
+SvPVX_mutable|5.009003||p
+SvPVX|||
+SvPV_const|5.009003||p
+SvPV_flags_const_nolen|5.009003||p
+SvPV_flags_const|5.009003||p
+SvPV_flags_mutable|5.009003||p
+SvPV_flags|5.007002||p
+SvPV_force_flags_mutable|5.009003||p
+SvPV_force_flags_nolen|5.009003||p
+SvPV_force_flags|5.007002||p
+SvPV_force_mutable|5.009003||p
+SvPV_force_nolen|5.009003||p
+SvPV_force_nomg_nolen|5.009003||p
+SvPV_force_nomg|5.007002||p
+SvPV_force|||p
+SvPV_mutable|5.009003||p
+SvPV_nolen_const|5.009003||p
+SvPV_nolen|5.006000||p
+SvPV_nomg_const_nolen|5.009003||p
+SvPV_nomg_const|5.009003||p
+SvPV_nomg|5.007002||p
+SvPV_renew|5.009003||p
+SvPV_set|||
+SvPVbyte_force||5.009002|
+SvPVbyte_nolen||5.006000|
+SvPVbytex_force||5.006000|
+SvPVbytex||5.006000|
+SvPVbyte|5.006000||p
+SvPVutf8_force||5.006000|
+SvPVutf8_nolen||5.006000|
+SvPVutf8x_force||5.006000|
+SvPVutf8x||5.006000|
+SvPVutf8||5.006000|
+SvPVx|||
+SvPV|||
+SvREFCNT_dec|||
+SvREFCNT_inc_NN|5.009004||p
+SvREFCNT_inc_simple_NN|5.009004||p
+SvREFCNT_inc_simple_void_NN|5.009004||p
+SvREFCNT_inc_simple_void|5.009004||p
+SvREFCNT_inc_simple|5.009004||p
+SvREFCNT_inc_void_NN|5.009004||p
+SvREFCNT_inc_void|5.009004||p
+SvREFCNT_inc|||p
+SvREFCNT|||
+SvROK_off|||
+SvROK_on|||
+SvROK|||
+SvRV_set|5.009003||p
+SvRV|||
+SvRXOK||5.009005|
+SvRX||5.009005|
+SvSETMAGIC|||
+SvSHARED_HASH|5.009003||p
+SvSHARE||5.007003|
+SvSTASH_set|5.009003||p
+SvSTASH|||
+SvSetMagicSV_nosteal||5.004000|
+SvSetMagicSV||5.004000|
+SvSetSV_nosteal||5.004000|
+SvSetSV|||
+SvTAINTED_off||5.004000|
+SvTAINTED_on||5.004000|
+SvTAINTED||5.004000|
+SvTAINT|||
+SvTRUE|||
+SvTYPE|||
+SvUNLOCK||5.007003|
+SvUOK|5.007001|5.006000|p
+SvUPGRADE|||
+SvUTF8_off||5.006000|
+SvUTF8_on||5.006000|
+SvUTF8||5.006000|
+SvUVXx|5.004000||p
+SvUVX|5.004000||p
+SvUV_nomg|5.009001||p
+SvUV_set|5.009003||p
+SvUVx|5.004000||p
+SvUV|5.004000||p
+SvVOK||5.008001|
+SvVSTRING_mg|5.009004||p
+THIS|||n
+UNDERBAR|5.009002||p
+UTF8_MAXBYTES|5.009002||p
+UVSIZE|5.006000||p
+UVTYPE|5.006000||p
+UVXf|5.007001||p
+UVof|5.006000||p
+UVuf|5.006000||p
+UVxf|5.006000||p
+WARN_ALL|5.006000||p
+WARN_AMBIGUOUS|5.006000||p
+WARN_ASSERTIONS|5.011000||p
+WARN_BAREWORD|5.006000||p
+WARN_CLOSED|5.006000||p
+WARN_CLOSURE|5.006000||p
+WARN_DEBUGGING|5.006000||p
+WARN_DEPRECATED|5.006000||p
+WARN_DIGIT|5.006000||p
+WARN_EXEC|5.006000||p
+WARN_EXITING|5.006000||p
+WARN_GLOB|5.006000||p
+WARN_INPLACE|5.006000||p
+WARN_INTERNAL|5.006000||p
+WARN_IO|5.006000||p
+WARN_LAYER|5.008000||p
+WARN_MALLOC|5.006000||p
+WARN_MISC|5.006000||p
+WARN_NEWLINE|5.006000||p
+WARN_NUMERIC|5.006000||p
+WARN_ONCE|5.006000||p
+WARN_OVERFLOW|5.006000||p
+WARN_PACK|5.006000||p
+WARN_PARENTHESIS|5.006000||p
+WARN_PIPE|5.006000||p
+WARN_PORTABLE|5.006000||p
+WARN_PRECEDENCE|5.006000||p
+WARN_PRINTF|5.006000||p
+WARN_PROTOTYPE|5.006000||p
+WARN_QW|5.006000||p
+WARN_RECURSION|5.006000||p
+WARN_REDEFINE|5.006000||p
+WARN_REGEXP|5.006000||p
+WARN_RESERVED|5.006000||p
+WARN_SEMICOLON|5.006000||p
+WARN_SEVERE|5.006000||p
+WARN_SIGNAL|5.006000||p
+WARN_SUBSTR|5.006000||p
+WARN_SYNTAX|5.006000||p
+WARN_TAINT|5.006000||p
+WARN_THREADS|5.008000||p
+WARN_UNINITIALIZED|5.006000||p
+WARN_UNOPENED|5.006000||p
+WARN_UNPACK|5.006000||p
+WARN_UNTIE|5.006000||p
+WARN_UTF8|5.006000||p
+WARN_VOID|5.006000||p
+XCPT_CATCH|5.009002||p
+XCPT_RETHROW|5.009002||p
+XCPT_TRY_END|5.009002||p
+XCPT_TRY_START|5.009002||p
+XPUSHi|||
+XPUSHmortal|5.009002||p
+XPUSHn|||
+XPUSHp|||
+XPUSHs|||
+XPUSHu|5.004000||p
+XSPROTO|5.010000||p
+XSRETURN_EMPTY|||
+XSRETURN_IV|||
+XSRETURN_NO|||
+XSRETURN_NV|||
+XSRETURN_PV|||
+XSRETURN_UNDEF|||
+XSRETURN_UV|5.008001||p
+XSRETURN_YES|||
+XSRETURN|||p
+XST_mIV|||
+XST_mNO|||
+XST_mNV|||
+XST_mPV|||
+XST_mUNDEF|||
+XST_mUV|5.008001||p
+XST_mYES|||
+XS_VERSION_BOOTCHECK|||
+XS_VERSION|||
+XSprePUSH|5.006000||p
+XS|||
+ZeroD|5.009002||p
+Zero|||
+_aMY_CXT|5.007003||p
+_pMY_CXT|5.007003||p
+aMY_CXT_|5.007003||p
+aMY_CXT|5.007003||p
+aTHXR_|5.011000||p
+aTHXR|5.011000||p
+aTHX_|5.006000||p
+aTHX|5.006000||p
+add_data|||n
+addmad|||
+allocmy|||
+amagic_call|||
+amagic_cmp_locale|||
+amagic_cmp|||
+amagic_i_ncmp|||
+amagic_ncmp|||
+any_dup|||
+ao|||
+append_elem|||
+append_list|||
+append_madprops|||
+apply_attrs_my|||
+apply_attrs_string||5.006001|
+apply_attrs|||
+apply|||
+atfork_lock||5.007003|n
+atfork_unlock||5.007003|n
+av_arylen_p||5.009003|
+av_clear|||
+av_create_and_push||5.009005|
+av_create_and_unshift_one||5.009005|
+av_delete||5.006000|
+av_exists||5.006000|
+av_extend|||
+av_fetch|||
+av_fill|||
+av_iter_p||5.011000|
+av_len|||
+av_make|||
+av_pop|||
+av_push|||
+av_reify|||
+av_shift|||
+av_store|||
+av_undef|||
+av_unshift|||
+ax|||n
+bad_type|||
+bind_match|||
+block_end|||
+block_gimme||5.004000|
+block_start|||
+boolSV|5.004000||p
+boot_core_PerlIO|||
+boot_core_UNIVERSAL|||
+boot_core_mro|||
+bytes_from_utf8||5.007001|
+bytes_to_uni|||n
+bytes_to_utf8||5.006001|
+call_argv|5.006000||p
+call_atexit||5.006000|
+call_list||5.004000|
+call_method|5.006000||p
+call_pv|5.006000||p
+call_sv|5.006000||p
+calloc||5.007002|n
+cando|||
+cast_i32||5.006000|
+cast_iv||5.006000|
+cast_ulong||5.006000|
+cast_uv||5.006000|
+check_type_and_open|||
+check_uni|||
+checkcomma|||
+checkposixcc|||
+ckWARN|5.006000||p
+ck_anoncode|||
+ck_bitop|||
+ck_concat|||
+ck_defined|||
+ck_delete|||
+ck_die|||
+ck_each|||
+ck_eof|||
+ck_eval|||
+ck_exec|||
+ck_exists|||
+ck_exit|||
+ck_ftst|||
+ck_fun|||
+ck_glob|||
+ck_grep|||
+ck_index|||
+ck_join|||
+ck_lfun|||
+ck_listiob|||
+ck_match|||
+ck_method|||
+ck_null|||
+ck_open|||
+ck_readline|||
+ck_repeat|||
+ck_require|||
+ck_return|||
+ck_rfun|||
+ck_rvconst|||
+ck_sassign|||
+ck_select|||
+ck_shift|||
+ck_sort|||
+ck_spair|||
+ck_split|||
+ck_subr|||
+ck_substr|||
+ck_svconst|||
+ck_trunc|||
+ck_unpack|||
+ckwarn_d||5.009003|
+ckwarn||5.009003|
+cl_and|||n
+cl_anything|||n
+cl_init_zero|||n
+cl_init|||n
+cl_is_anything|||n
+cl_or|||n
+clear_placeholders|||
+closest_cop|||
+convert|||
+cop_free|||
+cr_textfilter|||
+create_eval_scope|||
+croak_nocontext|||vn
+croak_xs_usage||5.011000|
+croak|||v
+csighandler||5.009003|n
+curmad|||
+custom_op_desc||5.007003|
+custom_op_name||5.007003|
+cv_ckproto_len|||
+cv_clone|||
+cv_const_sv||5.004000|
+cv_dump|||
+cv_undef|||
+cx_dump||5.005000|
+cx_dup|||
+cxinc|||
+dAXMARK|5.009003||p
+dAX|5.007002||p
+dITEMS|5.007002||p
+dMARK|||
+dMULTICALL||5.009003|
+dMY_CXT_SV|5.007003||p
+dMY_CXT|5.007003||p
+dNOOP|5.006000||p
+dORIGMARK|||
+dSP|||
+dTHR|5.004050||p
+dTHXR|5.011000||p
+dTHXa|5.006000||p
+dTHXoa|5.006000||p
+dTHX|5.006000||p
+dUNDERBAR|5.009002||p
+dVAR|5.009003||p
+dXCPT|5.009002||p
+dXSARGS|||
+dXSI32|||
+dXSTARG|5.006000||p
+deb_curcv|||
+deb_nocontext|||vn
+deb_stack_all|||
+deb_stack_n|||
+debop||5.005000|
+debprofdump||5.005000|
+debprof|||
+debstackptrs||5.007003|
+debstack||5.007003|
+debug_start_match|||
+deb||5.007003|v
+del_sv|||
+delete_eval_scope|||
+delimcpy||5.004000|
+deprecate_old|||
+deprecate|||
+despatch_signals||5.007001|
+destroy_matcher|||
+die_nocontext|||vn
+die_where|||
+die|||v
+dirp_dup|||
+div128|||
+djSP|||
+do_aexec5|||
+do_aexec|||
+do_aspawn|||
+do_binmode||5.004050|
+do_chomp|||
+do_chop|||
+do_close|||
+do_dump_pad|||
+do_eof|||
+do_exec3|||
+do_execfree|||
+do_exec|||
+do_gv_dump||5.006000|
+do_gvgv_dump||5.006000|
+do_hv_dump||5.006000|
+do_ipcctl|||
+do_ipcget|||
+do_join|||
+do_kv|||
+do_magic_dump||5.006000|
+do_msgrcv|||
+do_msgsnd|||
+do_oddball|||
+do_op_dump||5.006000|
+do_op_xmldump|||
+do_open9||5.006000|
+do_openn||5.007001|
+do_open||5.004000|
+do_pmop_dump||5.006000|
+do_pmop_xmldump|||
+do_print|||
+do_readline|||
+do_seek|||
+do_semop|||
+do_shmio|||
+do_smartmatch|||
+do_spawn_nowait|||
+do_spawn|||
+do_sprintf|||
+do_sv_dump||5.006000|
+do_sysseek|||
+do_tell|||
+do_trans_complex_utf8|||
+do_trans_complex|||
+do_trans_count_utf8|||
+do_trans_count|||
+do_trans_simple_utf8|||
+do_trans_simple|||
+do_trans|||
+do_vecget|||
+do_vecset|||
+do_vop|||
+docatch|||
+doeval|||
+dofile|||
+dofindlabel|||
+doform|||
+doing_taint||5.008001|n
+dooneliner|||
+doopen_pm|||
+doparseform|||
+dopoptoeval|||
+dopoptogiven|||
+dopoptolabel|||
+dopoptoloop|||
+dopoptosub_at|||
+dopoptowhen|||
+doref||5.009003|
+dounwind|||
+dowantarray|||
+dump_all||5.006000|
+dump_eval||5.006000|
+dump_exec_pos|||
+dump_fds|||
+dump_form||5.006000|
+dump_indent||5.006000|v
+dump_mstats|||
+dump_packsubs||5.006000|
+dump_sub||5.006000|
+dump_sv_child|||
+dump_trie_interim_list|||
+dump_trie_interim_table|||
+dump_trie|||
+dump_vindent||5.006000|
+dumpuntil|||
+dup_attrlist|||
+emulate_cop_io|||
+eval_pv|5.006000||p
+eval_sv|5.006000||p
+exec_failed|||
+expect_number|||
+fbm_compile||5.005000|
+fbm_instr||5.005000|
+feature_is_enabled|||
+fetch_cop_label||5.011000|
+filter_add|||
+filter_del|||
+filter_gets|||
+filter_read|||
+find_and_forget_pmops|||
+find_array_subscript|||
+find_beginning|||
+find_byclass|||
+find_hash_subscript|||
+find_in_my_stash|||
+find_runcv||5.008001|
+find_rundefsvoffset||5.009002|
+find_script|||
+find_uninit_var|||
+first_symbol|||n
+fold_constants|||
+forbid_setid|||
+force_ident|||
+force_list|||
+force_next|||
+force_version|||
+force_word|||
+forget_pmop|||
+form_nocontext|||vn
+form||5.004000|v
+fp_dup|||
+fprintf_nocontext|||vn
+free_global_struct|||
+free_tied_hv_pool|||
+free_tmps|||
+gen_constant_list|||
+get_arena|||
+get_aux_mg|||
+get_av|5.006000||p
+get_context||5.006000|n
+get_cvn_flags||5.009005|
+get_cv|5.006000||p
+get_db_sub|||
+get_debug_opts|||
+get_hash_seed|||
+get_hv|5.006000||p
+get_isa_hash|||
+get_mstats|||
+get_no_modify|||
+get_num|||
+get_op_descs||5.005000|
+get_op_names||5.005000|
+get_opargs|||
+get_ppaddr||5.006000|
+get_re_arg|||
+get_sv|5.006000||p
+get_vtbl||5.005030|
+getcwd_sv||5.007002|
+getenv_len|||
+glob_2number|||
+glob_assign_glob|||
+glob_assign_ref|||
+gp_dup|||
+gp_free|||
+gp_ref|||
+grok_bin|5.007003||p
+grok_hex|5.007003||p
+grok_number|5.007002||p
+grok_numeric_radix|5.007002||p
+grok_oct|5.007003||p
+group_end|||
+gv_AVadd|||
+gv_HVadd|||
+gv_IOadd|||
+gv_SVadd|||
+gv_autoload4||5.004000|
+gv_check|||
+gv_const_sv||5.009003|
+gv_dump||5.006000|
+gv_efullname3||5.004000|
+gv_efullname4||5.006001|
+gv_efullname|||
+gv_ename|||
+gv_fetchfile_flags||5.009005|
+gv_fetchfile|||
+gv_fetchmeth_autoload||5.007003|
+gv_fetchmethod_autoload||5.004000|
+gv_fetchmethod_flags||5.011000|
+gv_fetchmethod|||
+gv_fetchmeth|||
+gv_fetchpvn_flags|5.009002||p
+gv_fetchpvs|5.009004||p
+gv_fetchpv|||
+gv_fetchsv||5.009002|
+gv_fullname3||5.004000|
+gv_fullname4||5.006001|
+gv_fullname|||
+gv_get_super_pkg|||
+gv_handler||5.007001|
+gv_init_sv|||
+gv_init|||
+gv_name_set||5.009004|
+gv_stashpvn|5.004000||p
+gv_stashpvs|5.009003||p
+gv_stashpv|||
+gv_stashsv|||
+he_dup|||
+hek_dup|||
+hfreeentries|||
+hsplit|||
+hv_assert||5.011000|
+hv_auxinit|||n
+hv_backreferences_p|||
+hv_clear_placeholders||5.009001|
+hv_clear|||
+hv_common_key_len||5.010000|
+hv_common||5.010000|
+hv_copy_hints_hv|||
+hv_delayfree_ent||5.004000|
+hv_delete_common|||
+hv_delete_ent||5.004000|
+hv_delete|||
+hv_eiter_p||5.009003|
+hv_eiter_set||5.009003|
+hv_exists_ent||5.004000|
+hv_exists|||
+hv_fetch_ent||5.004000|
+hv_fetchs|5.009003||p
+hv_fetch|||
+hv_free_ent||5.004000|
+hv_iterinit|||
+hv_iterkeysv||5.004000|
+hv_iterkey|||
+hv_iternext_flags||5.008000|
+hv_iternextsv|||
+hv_iternext|||
+hv_iterval|||
+hv_kill_backrefs|||
+hv_ksplit||5.004000|
+hv_magic_check|||n
+hv_magic|||
+hv_name_set||5.009003|
+hv_notallowed|||
+hv_placeholders_get||5.009003|
+hv_placeholders_p||5.009003|
+hv_placeholders_set||5.009003|
+hv_riter_p||5.009003|
+hv_riter_set||5.009003|
+hv_scalar||5.009001|
+hv_store_ent||5.004000|
+hv_store_flags||5.008000|
+hv_stores|5.009004||p
+hv_store|||
+hv_undef|||
+ibcmp_locale||5.004000|
+ibcmp_utf8||5.007003|
+ibcmp|||
+incline|||
+incpush_if_exists|||
+incpush_use_sep|||
+incpush|||
+ingroup|||
+init_argv_symbols|||
+init_debugger|||
+init_global_struct|||
+init_i18nl10n||5.006000|
+init_i18nl14n||5.006000|
+init_ids|||
+init_interp|||
+init_main_stash|||
+init_perllib|||
+init_postdump_symbols|||
+init_predump_symbols|||
+init_stacks||5.005000|
+init_tm||5.007002|
+instr|||
+intro_my|||
+intuit_method|||
+intuit_more|||
+invert|||
+io_close|||
+isALNUMC|5.006000||p
+isALNUM|||
+isALPHA|||
+isASCII|5.006000||p
+isBLANK|5.006001||p
+isCNTRL|5.006000||p
+isDIGIT|||
+isGRAPH|5.006000||p
+isGV_with_GP|5.009004||p
+isLOWER|||
+isPRINT|5.004000||p
+isPSXSPC|5.006001||p
+isPUNCT|5.006000||p
+isSPACE|||
+isUPPER|||
+isXDIGIT|5.006000||p
+is_an_int|||
+is_gv_magical_sv|||
+is_handle_constructor|||n
+is_list_assignment|||
+is_lvalue_sub||5.007001|
+is_uni_alnum_lc||5.006000|
+is_uni_alnumc_lc||5.006000|
+is_uni_alnumc||5.006000|
+is_uni_alnum||5.006000|
+is_uni_alpha_lc||5.006000|
+is_uni_alpha||5.006000|
+is_uni_ascii_lc||5.006000|
+is_uni_ascii||5.006000|
+is_uni_cntrl_lc||5.006000|
+is_uni_cntrl||5.006000|
+is_uni_digit_lc||5.006000|
+is_uni_digit||5.006000|
+is_uni_graph_lc||5.006000|
+is_uni_graph||5.006000|
+is_uni_idfirst_lc||5.006000|
+is_uni_idfirst||5.006000|
+is_uni_lower_lc||5.006000|
+is_uni_lower||5.006000|
+is_uni_print_lc||5.006000|
+is_uni_print||5.006000|
+is_uni_punct_lc||5.006000|
+is_uni_punct||5.006000|
+is_uni_space_lc||5.006000|
+is_uni_space||5.006000|
+is_uni_upper_lc||5.006000|
+is_uni_upper||5.006000|
+is_uni_xdigit_lc||5.006000|
+is_uni_xdigit||5.006000|
+is_utf8_alnumc||5.006000|
+is_utf8_alnum||5.006000|
+is_utf8_alpha||5.006000|
+is_utf8_ascii||5.006000|
+is_utf8_char_slow|||n
+is_utf8_char||5.006000|
+is_utf8_cntrl||5.006000|
+is_utf8_common|||
+is_utf8_digit||5.006000|
+is_utf8_graph||5.006000|
+is_utf8_idcont||5.008000|
+is_utf8_idfirst||5.006000|
+is_utf8_lower||5.006000|
+is_utf8_mark||5.006000|
+is_utf8_print||5.006000|
+is_utf8_punct||5.006000|
+is_utf8_space||5.006000|
+is_utf8_string_loclen||5.009003|
+is_utf8_string_loc||5.008001|
+is_utf8_string||5.006001|
+is_utf8_upper||5.006000|
+is_utf8_xdigit||5.006000|
+isa_lookup|||
+items|||n
+ix|||n
+jmaybe|||
+join_exact|||
+keyword|||
+leave_scope|||
+lex_end|||
+lex_start|||
+linklist|||
+listkids|||
+list|||
+load_module_nocontext|||vn
+load_module|5.006000||pv
+localize|||
+looks_like_bool|||
+looks_like_number|||
+lop|||
+mPUSHi|5.009002||p
+mPUSHn|5.009002||p
+mPUSHp|5.009002||p
+mPUSHs|5.011000||p
+mPUSHu|5.009002||p
+mXPUSHi|5.009002||p
+mXPUSHn|5.009002||p
+mXPUSHp|5.009002||p
+mXPUSHs|5.011000||p
+mXPUSHu|5.009002||p
+mad_free|||
+madlex|||
+madparse|||
+magic_clear_all_env|||
+magic_clearenv|||
+magic_clearhint|||
+magic_clearisa|||
+magic_clearpack|||
+magic_clearsig|||
+magic_dump||5.006000|
+magic_existspack|||
+magic_freearylen_p|||
+magic_freeovrld|||
+magic_getarylen|||
+magic_getdefelem|||
+magic_getnkeys|||
+magic_getpack|||
+magic_getpos|||
+magic_getsig|||
+magic_getsubstr|||
+magic_gettaint|||
+magic_getuvar|||
+magic_getvec|||
+magic_get|||
+magic_killbackrefs|||
+magic_len|||
+magic_methcall|||
+magic_methpack|||
+magic_nextpack|||
+magic_regdata_cnt|||
+magic_regdatum_get|||
+magic_regdatum_set|||
+magic_scalarpack|||
+magic_set_all_env|||
+magic_setamagic|||
+magic_setarylen|||
+magic_setcollxfrm|||
+magic_setdbline|||
+magic_setdefelem|||
+magic_setenv|||
+magic_sethint|||
+magic_setisa|||
+magic_setmglob|||
+magic_setnkeys|||
+magic_setpack|||
+magic_setpos|||
+magic_setregexp|||
+magic_setsig|||
+magic_setsubstr|||
+magic_settaint|||
+magic_setutf8|||
+magic_setuvar|||
+magic_setvec|||
+magic_set|||
+magic_sizepack|||
+magic_wipepack|||
+make_matcher|||
+make_trie_failtable|||
+make_trie|||
+malloc_good_size|||n
+malloced_size|||n
+malloc||5.007002|n
+markstack_grow|||
+matcher_matches_sv|||
+measure_struct|||
+memEQ|5.004000||p
+memNE|5.004000||p
+mem_collxfrm|||
+mem_log_common|||n
+mess_alloc|||
+mess_nocontext|||vn
+mess||5.006000|v
+method_common|||
+mfree||5.007002|n
+mg_clear|||
+mg_copy|||
+mg_dup|||
+mg_find|||
+mg_free|||
+mg_get|||
+mg_length||5.005000|
+mg_localize|||
+mg_magical|||
+mg_set|||
+mg_size||5.005000|
+mini_mktime||5.007002|
+missingterm|||
+mode_from_discipline|||
+modkids|||
+mod|||
+more_bodies|||
+more_sv|||
+moreswitches|||
+mro_get_from_name||5.011000|
+mro_get_linear_isa_dfs|||
+mro_get_linear_isa||5.009005|
+mro_get_private_data||5.011000|
+mro_isa_changed_in|||
+mro_meta_dup|||
+mro_meta_init|||
+mro_method_changed_in||5.009005|
+mro_register||5.011000|
+mro_set_mro||5.011000|
+mro_set_private_data||5.011000|
+mul128|||
+mulexp10|||n
+my_atof2||5.007002|
+my_atof||5.006000|
+my_attrs|||
+my_bcopy|||n
+my_betoh16|||n
+my_betoh32|||n
+my_betoh64|||n
+my_betohi|||n
+my_betohl|||n
+my_betohs|||n
+my_bzero|||n
+my_chsize|||
+my_clearenv|||
+my_cxt_index|||
+my_cxt_init|||
+my_dirfd||5.009005|
+my_exit_jump|||
+my_exit|||
+my_failure_exit||5.004000|
+my_fflush_all||5.006000|
+my_fork||5.007003|n
+my_htobe16|||n
+my_htobe32|||n
+my_htobe64|||n
+my_htobei|||n
+my_htobel|||n
+my_htobes|||n
+my_htole16|||n
+my_htole32|||n
+my_htole64|||n
+my_htolei|||n
+my_htolel|||n
+my_htoles|||n
+my_htonl|||
+my_kid|||
+my_letoh16|||n
+my_letoh32|||n
+my_letoh64|||n
+my_letohi|||n
+my_letohl|||n
+my_letohs|||n
+my_lstat|||
+my_memcmp||5.004000|n
+my_memset|||n
+my_ntohl|||
+my_pclose||5.004000|
+my_popen_list||5.007001|
+my_popen||5.004000|
+my_setenv|||
+my_snprintf|5.009004||pvn
+my_socketpair||5.007003|n
+my_sprintf|5.009003||pvn
+my_stat|||
+my_strftime||5.007002|
+my_strlcat|5.009004||pn
+my_strlcpy|5.009004||pn
+my_swabn|||n
+my_swap|||
+my_unexec|||
+my_vsnprintf||5.009004|n
+need_utf8|||n
+newANONATTRSUB||5.006000|
+newANONHASH|||
+newANONLIST|||
+newANONSUB|||
+newASSIGNOP|||
+newATTRSUB||5.006000|
+newAVREF|||
+newAV|||
+newBINOP|||
+newCONDOP|||
+newCONSTSUB|5.004050||p
+newCVREF|||
+newDEFSVOP|||
+newFORM|||
+newFOROP|||
+newGIVENOP||5.009003|
+newGIVWHENOP|||
+newGP|||
+newGVOP|||
+newGVREF|||
+newGVgen|||
+newHVREF|||
+newHVhv||5.005000|
+newHV|||
+newIO|||
+newLISTOP|||
+newLOGOP|||
+newLOOPEX|||
+newLOOPOP|||
+newMADPROP|||
+newMADsv|||
+newMYSUB|||
+newNULLLIST|||
+newOP|||
+newPADOP|||
+newPMOP|||
+newPROG|||
+newPVOP|||
+newRANGE|||
+newRV_inc|5.004000||p
+newRV_noinc|5.004000||p
+newRV|||
+newSLICEOP|||
+newSTATEOP|||
+newSUB|||
+newSVOP|||
+newSVREF|||
+newSV_type|5.009005||p
+newSVhek||5.009003|
+newSViv|||
+newSVnv|||
+newSVpvf_nocontext|||vn
+newSVpvf||5.004000|v
+newSVpvn_flags|5.011000||p
+newSVpvn_share|5.007001||p
+newSVpvn_utf8|5.011000||p
+newSVpvn|5.004050||p
+newSVpvs_flags|5.011000||p
+newSVpvs_share||5.009003|
+newSVpvs|5.009003||p
+newSVpv|||
+newSVrv|||
+newSVsv|||
+newSVuv|5.006000||p
+newSV|||
+newTOKEN|||
+newUNOP|||
+newWHENOP||5.009003|
+newWHILEOP||5.009003|
+newXS_flags||5.009004|
+newXSproto||5.006000|
+newXS||5.006000|
+new_collate||5.006000|
+new_constant|||
+new_ctype||5.006000|
+new_he|||
+new_logop|||
+new_numeric||5.006000|
+new_stackinfo||5.005000|
+new_version||5.009000|
+new_warnings_bitfield|||
+next_symbol|||
+nextargv|||
+nextchar|||
+ninstr|||
+no_bareword_allowed|||
+no_fh_allowed|||
+no_op|||
+not_a_number|||
+nothreadhook||5.008000|
+nuke_stacks|||
+num_overflow|||n
+offer_nice_chunk|||
+oopsAV|||
+oopsHV|||
+op_clear|||
+op_const_sv|||
+op_dump||5.006000|
+op_free|||
+op_getmad_weak|||
+op_getmad|||
+op_null||5.007002|
+op_refcnt_dec|||
+op_refcnt_inc|||
+op_refcnt_lock||5.009002|
+op_refcnt_unlock||5.009002|
+op_xmldump|||
+open_script|||
+pMY_CXT_|5.007003||p
+pMY_CXT|5.007003||p
+pTHX_|5.006000||p
+pTHX|5.006000||p
+packWARN|5.007003||p
+pack_cat||5.007003|
+pack_rec|||
+package|||
+packlist||5.008001|
+pad_add_anon|||
+pad_add_name|||
+pad_alloc|||
+pad_block_start|||
+pad_check_dup|||
+pad_compname_type|||
+pad_findlex|||
+pad_findmy|||
+pad_fixup_inner_anons|||
+pad_free|||
+pad_leavemy|||
+pad_new|||
+pad_peg|||n
+pad_push|||
+pad_reset|||
+pad_setsv|||
+pad_sv||5.011000|
+pad_swipe|||
+pad_tidy|||
+pad_undef|||
+parse_body|||
+parse_unicode_opts|||
+parser_dup|||
+parser_free|||
+path_is_absolute|||n
+peep|||
+pending_Slabs_to_ro|||
+perl_alloc_using|||n
+perl_alloc|||n
+perl_clone_using|||n
+perl_clone|||n
+perl_construct|||n
+perl_destruct||5.007003|n
+perl_free|||n
+perl_parse||5.006000|n
+perl_run|||n
+pidgone|||
+pm_description|||
+pmflag|||
+pmop_dump||5.006000|
+pmop_xmldump|||
+pmruntime|||
+pmtrans|||
+pop_scope|||
+pregcomp||5.009005|
+pregexec|||
+pregfree2||5.011000|
+pregfree|||
+prepend_elem|||
+prepend_madprops|||
+printbuf|||
+printf_nocontext|||vn
+process_special_blocks|||
+ptr_table_clear||5.009005|
+ptr_table_fetch||5.009005|
+ptr_table_find|||n
+ptr_table_free||5.009005|
+ptr_table_new||5.009005|
+ptr_table_split||5.009005|
+ptr_table_store||5.009005|
+push_scope|||
+put_byte|||
+pv_display|5.006000||p
+pv_escape|5.009004||p
+pv_pretty|5.009004||p
+pv_uni_display||5.007003|
+qerror|||
+qsortsvu|||
+re_compile||5.009005|
+re_croak2|||
+re_dup_guts|||
+re_intuit_start||5.009005|
+re_intuit_string||5.006000|
+readpipe_override|||
+realloc||5.007002|n
+reentrant_free|||
+reentrant_init|||
+reentrant_retry|||vn
+reentrant_size|||
+ref_array_or_hash|||
+refcounted_he_chain_2hv|||
+refcounted_he_fetch|||
+refcounted_he_free|||
+refcounted_he_new_common|||
+refcounted_he_new|||
+refcounted_he_value|||
+refkids|||
+refto|||
+ref||5.011000|
+reg_check_named_buff_matched|||
+reg_named_buff_all||5.009005|
+reg_named_buff_exists||5.009005|
+reg_named_buff_fetch||5.009005|
+reg_named_buff_firstkey||5.009005|
+reg_named_buff_iter|||
+reg_named_buff_nextkey||5.009005|
+reg_named_buff_scalar||5.009005|
+reg_named_buff|||
+reg_namedseq|||
+reg_node|||
+reg_numbered_buff_fetch|||
+reg_numbered_buff_length|||
+reg_numbered_buff_store|||
+reg_qr_package|||
+reg_recode|||
+reg_scan_name|||
+reg_skipcomment|||
+reg_temp_copy|||
+reganode|||
+regatom|||
+regbranch|||
+regclass_swash||5.009004|
+regclass|||
+regcppop|||
+regcppush|||
+regcurly|||n
+regdump_extflags|||
+regdump||5.005000|
+regdupe_internal|||
+regexec_flags||5.005000|
+regfree_internal||5.009005|
+reghop3|||n
+reghop4|||n
+reghopmaybe3|||n
+reginclass|||
+reginitcolors||5.006000|
+reginsert|||
+regmatch|||
+regnext||5.005000|
+regpiece|||
+regpposixcc|||
+regprop|||
+regrepeat|||
+regtail_study|||
+regtail|||
+regtry|||
+reguni|||
+regwhite|||n
+reg|||
+repeatcpy|||
+report_evil_fh|||
+report_uninit|||
+require_pv||5.006000|
+require_tie_mod|||
+restore_magic|||
+rninstr|||
+rsignal_restore|||
+rsignal_save|||
+rsignal_state||5.004000|
+rsignal||5.004000|
+run_body|||
+run_user_filter|||
+runops_debug||5.005000|
+runops_standard||5.005000|
+rvpv_dup|||
+rxres_free|||
+rxres_restore|||
+rxres_save|||
+safesyscalloc||5.006000|n
+safesysfree||5.006000|n
+safesysmalloc||5.006000|n
+safesysrealloc||5.006000|n
+same_dirent|||
+save_I16||5.004000|
+save_I32|||
+save_I8||5.006000|
+save_adelete||5.011000|
+save_aelem||5.004050|
+save_alloc||5.006000|
+save_aptr|||
+save_ary|||
+save_bool||5.008001|
+save_clearsv|||
+save_delete|||
+save_destructor_x||5.006000|
+save_destructor||5.006000|
+save_freeop|||
+save_freepv|||
+save_freesv|||
+save_generic_pvref||5.006001|
+save_generic_svref||5.005030|
+save_gp||5.004000|
+save_hash|||
+save_hek_flags|||n
+save_helem_flags||5.011000|
+save_helem||5.004050|
+save_hints|||
+save_hptr|||
+save_int|||
+save_item|||
+save_iv||5.005000|
+save_lines|||
+save_list|||
+save_long|||
+save_magic|||
+save_mortalizesv||5.007001|
+save_nogv|||
+save_op|||
+save_padsv_and_mortalize||5.011000|
+save_pptr|||
+save_pushi32ptr|||
+save_pushptri32ptr|||
+save_pushptrptr|||
+save_pushptr||5.011000|
+save_re_context||5.006000|
+save_scalar_at|||
+save_scalar|||
+save_set_svflags||5.009000|
+save_shared_pvref||5.007003|
+save_sptr|||
+save_svref|||
+save_vptr||5.006000|
+savepvn|||
+savepvs||5.009003|
+savepv|||
+savesharedpvn||5.009005|
+savesharedpv||5.007003|
+savestack_grow_cnt||5.008001|
+savestack_grow|||
+savesvpv||5.009002|
+sawparens|||
+scalar_mod_type|||n
+scalarboolean|||
+scalarkids|||
+scalarseq|||
+scalarvoid|||
+scalar|||
+scan_bin||5.006000|
+scan_commit|||
+scan_const|||
+scan_formline|||
+scan_heredoc|||
+scan_hex|||
+scan_ident|||
+scan_inputsymbol|||
+scan_num||5.007001|
+scan_oct|||
+scan_pat|||
+scan_str|||
+scan_subst|||
+scan_trans|||
+scan_version||5.009001|
+scan_vstring||5.009005|
+scan_word|||
+scope|||
+screaminstr||5.005000|
+search_const|||
+seed||5.008001|
+sequence_num|||
+sequence_tail|||
+sequence|||
+set_context||5.006000|n
+set_numeric_local||5.006000|
+set_numeric_radix||5.006000|
+set_numeric_standard||5.006000|
+setdefout|||
+share_hek_flags|||
+share_hek||5.004000|
+si_dup|||
+sighandler|||n
+simplify_sort|||
+skipspace0|||
+skipspace1|||
+skipspace2|||
+skipspace|||
+softref2xv|||
+sortcv_stacked|||
+sortcv_xsub|||
+sortcv|||
+sortsv_flags||5.009003|
+sortsv||5.007003|
+space_join_names_mortal|||
+ss_dup|||
+stack_grow|||
+start_force|||
+start_glob|||
+start_subparse||5.004000|
+stashpv_hvname_match||5.011000|
+stdize_locale|||
+store_cop_label|||
+strEQ|||
+strGE|||
+strGT|||
+strLE|||
+strLT|||
+strNE|||
+str_to_version||5.006000|
+strip_return|||
+strnEQ|||
+strnNE|||
+study_chunk|||
+sub_crush_depth|||
+sublex_done|||
+sublex_push|||
+sublex_start|||
+sv_2bool|||
+sv_2cv|||
+sv_2io|||
+sv_2iuv_common|||
+sv_2iuv_non_preserve|||
+sv_2iv_flags||5.009001|
+sv_2iv|||
+sv_2mortal|||
+sv_2num|||
+sv_2nv|||
+sv_2pv_flags|5.007002||p
+sv_2pv_nolen|5.006000||p
+sv_2pvbyte_nolen|5.006000||p
+sv_2pvbyte|5.006000||p
+sv_2pvutf8_nolen||5.006000|
+sv_2pvutf8||5.006000|
+sv_2pv|||
+sv_2uv_flags||5.009001|
+sv_2uv|5.004000||p
+sv_add_arena|||
+sv_add_backref|||
+sv_backoff|||
+sv_bless|||
+sv_cat_decode||5.008001|
+sv_catpv_mg|5.004050||p
+sv_catpvf_mg_nocontext|||pvn
+sv_catpvf_mg|5.006000|5.004000|pv
+sv_catpvf_nocontext|||vn
+sv_catpvf||5.004000|v
+sv_catpvn_flags||5.007002|
+sv_catpvn_mg|5.004050||p
+sv_catpvn_nomg|5.007002||p
+sv_catpvn|||
+sv_catpvs|5.009003||p
+sv_catpv|||
+sv_catsv_flags||5.007002|
+sv_catsv_mg|5.004050||p
+sv_catsv_nomg|5.007002||p
+sv_catsv|||
+sv_catxmlpvn|||
+sv_catxmlsv|||
+sv_chop|||
+sv_clean_all|||
+sv_clean_objs|||
+sv_clear|||
+sv_cmp_locale||5.004000|
+sv_cmp|||
+sv_collxfrm|||
+sv_compile_2op||5.008001|
+sv_copypv||5.007003|
+sv_dec|||
+sv_del_backref|||
+sv_derived_from||5.004000|
+sv_destroyable||5.010000|
+sv_does||5.009004|
+sv_dump|||
+sv_dup_inc_multiple|||
+sv_dup|||
+sv_eq|||
+sv_exp_grow|||
+sv_force_normal_flags||5.007001|
+sv_force_normal||5.006000|
+sv_free2|||
+sv_free_arenas|||
+sv_free|||
+sv_gets||5.004000|
+sv_grow|||
+sv_i_ncmp|||
+sv_inc|||
+sv_insert_flags||5.011000|
+sv_insert|||
+sv_isa|||
+sv_isobject|||
+sv_iv||5.005000|
+sv_kill_backrefs|||
+sv_len_utf8||5.006000|
+sv_len|||
+sv_magic_portable|5.011000|5.004000|p
+sv_magicext||5.007003|
+sv_magic|||
+sv_mortalcopy|||
+sv_ncmp|||
+sv_newmortal|||
+sv_newref|||
+sv_nolocking||5.007003|
+sv_nosharing||5.007003|
+sv_nounlocking|||
+sv_nv||5.005000|
+sv_peek||5.005000|
+sv_pos_b2u_midway|||
+sv_pos_b2u||5.006000|
+sv_pos_u2b_cached|||
+sv_pos_u2b_forwards|||n
+sv_pos_u2b_midway|||n
+sv_pos_u2b||5.006000|
+sv_pvbyten_force||5.006000|
+sv_pvbyten||5.006000|
+sv_pvbyte||5.006000|
+sv_pvn_force_flags|5.007002||p
+sv_pvn_force|||
+sv_pvn_nomg|5.007003|5.005000|p
+sv_pvn||5.005000|
+sv_pvutf8n_force||5.006000|
+sv_pvutf8n||5.006000|
+sv_pvutf8||5.006000|
+sv_pv||5.006000|
+sv_recode_to_utf8||5.007003|
+sv_reftype|||
+sv_release_COW|||
+sv_replace|||
+sv_report_used|||
+sv_reset|||
+sv_rvweaken||5.006000|
+sv_setiv_mg|5.004050||p
+sv_setiv|||
+sv_setnv_mg|5.006000||p
+sv_setnv|||
+sv_setpv_mg|5.004050||p
+sv_setpvf_mg_nocontext|||pvn
+sv_setpvf_mg|5.006000|5.004000|pv
+sv_setpvf_nocontext|||vn
+sv_setpvf||5.004000|v
+sv_setpviv_mg||5.008001|
+sv_setpviv||5.008001|
+sv_setpvn_mg|5.004050||p
+sv_setpvn|||
+sv_setpvs|5.009004||p
+sv_setpv|||
+sv_setref_iv|||
+sv_setref_nv|||
+sv_setref_pvn|||
+sv_setref_pv|||
+sv_setref_uv||5.007001|
+sv_setsv_cow|||
+sv_setsv_flags||5.007002|
+sv_setsv_mg|5.004050||p
+sv_setsv_nomg|5.007002||p
+sv_setsv|||
+sv_setuv_mg|5.004050||p
+sv_setuv|5.004000||p
+sv_tainted||5.004000|
+sv_taint||5.004000|
+sv_true||5.005000|
+sv_unglob|||
+sv_uni_display||5.007003|
+sv_unmagic|||
+sv_unref_flags||5.007001|
+sv_unref|||
+sv_untaint||5.004000|
+sv_upgrade|||
+sv_usepvn_flags||5.009004|
+sv_usepvn_mg|5.004050||p
+sv_usepvn|||
+sv_utf8_decode||5.006000|
+sv_utf8_downgrade||5.006000|
+sv_utf8_encode||5.006000|
+sv_utf8_upgrade_flags_grow||5.011000|
+sv_utf8_upgrade_flags||5.007002|
+sv_utf8_upgrade_nomg||5.007002|
+sv_utf8_upgrade||5.007001|
+sv_uv|5.005000||p
+sv_vcatpvf_mg|5.006000|5.004000|p
+sv_vcatpvfn||5.004000|
+sv_vcatpvf|5.006000|5.004000|p
+sv_vsetpvf_mg|5.006000|5.004000|p
+sv_vsetpvfn||5.004000|
+sv_vsetpvf|5.006000|5.004000|p
+sv_xmlpeek|||
+svtype|||
+swallow_bom|||
+swap_match_buff|||
+swash_fetch||5.007002|
+swash_get|||
+swash_init||5.006000|
+sys_init3||5.010000|n
+sys_init||5.010000|n
+sys_intern_clear|||
+sys_intern_dup|||
+sys_intern_init|||
+sys_term||5.010000|n
+taint_env|||
+taint_proper|||
+tmps_grow||5.006000|
+toLOWER|||
+toUPPER|||
+to_byte_substr|||
+to_uni_fold||5.007003|
+to_uni_lower_lc||5.006000|
+to_uni_lower||5.007003|
+to_uni_title_lc||5.006000|
+to_uni_title||5.007003|
+to_uni_upper_lc||5.006000|
+to_uni_upper||5.007003|
+to_utf8_case||5.007003|
+to_utf8_fold||5.007003|
+to_utf8_lower||5.007003|
+to_utf8_substr|||
+to_utf8_title||5.007003|
+to_utf8_upper||5.007003|
+token_free|||
+token_getmad|||
+tokenize_use|||
+tokeq|||
+tokereport|||
+too_few_arguments|||
+too_many_arguments|||
+uiv_2buf|||n
+unlnk|||
+unpack_rec|||
+unpack_str||5.007003|
+unpackstring||5.008001|
+unshare_hek_or_pvn|||
+unshare_hek|||
+unsharepvn||5.004000|
+unwind_handler_stack|||
+update_debugger_info|||
+upg_version||5.009005|
+usage|||
+utf16_to_utf8_reversed||5.006001|
+utf16_to_utf8||5.006001|
+utf8_distance||5.006000|
+utf8_hop||5.006000|
+utf8_length||5.007001|
+utf8_mg_pos_cache_update|||
+utf8_to_bytes||5.006001|
+utf8_to_uvchr||5.007001|
+utf8_to_uvuni||5.007001|
+utf8n_to_uvchr|||
+utf8n_to_uvuni||5.007001|
+utilize|||
+uvchr_to_utf8_flags||5.007003|
+uvchr_to_utf8|||
+uvuni_to_utf8_flags||5.007003|
+uvuni_to_utf8||5.007001|
+validate_suid|||
+varname|||
+vcmp||5.009000|
+vcroak||5.006000|
+vdeb||5.007003|
+vdie_common|||
+vdie_croak_common|||
+vdie|||
+vform||5.006000|
+visit|||
+vivify_defelem|||
+vivify_ref|||
+vload_module|5.006000||p
+vmess||5.006000|
+vnewSVpvf|5.006000|5.004000|p
+vnormal||5.009002|
+vnumify||5.009000|
+vstringify||5.009000|
+vverify||5.009003|
+vwarner||5.006000|
+vwarn||5.006000|
+wait4pid|||
+warn_nocontext|||vn
+warner_nocontext|||vn
+warner|5.006000|5.004000|pv
+warn|||v
+watch|||
+whichsig|||
+write_no_mem|||
+write_to_stderr|||
+xmldump_all|||
+xmldump_attr|||
+xmldump_eval|||
+xmldump_form|||
+xmldump_indent|||v
+xmldump_packsubs|||
+xmldump_sub|||
+xmldump_vindent|||
+yyerror|||
+yylex|||
+yyparse|||
+yywarn|||
+);
+
+if (exists $opt{'list-unsupported'}) {
+ my $f;
+ for $f (sort { lc $a cmp lc $b } keys %API) {
+ next unless $API{$f}{todo};
+ print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
+ }
+ exit 0;
+}
+
+# Scan for possible replacement candidates
+
+my(%replace, %need, %hints, %warnings, %depends);
+my $replace = 0;
+my($hint, $define, $function);
+
+sub find_api
+{
+ my $code = shift;
+ $code =~ s{
+ / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
+ | "[^"\\]*(?:\\.[^"\\]*)*"
+ | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx;
+ grep { exists $API{$_} } $code =~ /(\w+)/mg;
+}
+
+while (<DATA>) {
+ if ($hint) {
+ my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings;
+ if (m{^\s*\*\s(.*?)\s*$}) {
+ for (@{$hint->[1]}) {
+ $h->{$_} ||= ''; # suppress warning with older perls
+ $h->{$_} .= "$1\n";
+ }
+ }
+ else { undef $hint }
+ }
+
+ $hint = [$1, [split /,?\s+/, $2]]
+ if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$};
+
+ if ($define) {
+ if ($define->[1] =~ /\\$/) {
+ $define->[1] .= $_;
+ }
+ else {
+ if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) {
+ my @n = find_api($define->[1]);
+ push @{$depends{$define->[0]}}, @n if @n
+ }
+ undef $define;
+ }
+ }
+
+ $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)};
+
+ if ($function) {
+ if (/^}/) {
+ if (exists $API{$function->[0]}) {
+ my @n = find_api($function->[1]);
+ push @{$depends{$function->[0]}}, @n if @n
+ }
+ undef $function;
+ }
+ else {
+ $function->[1] .= $_;
+ }
+ }
+
+ $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)};
+
+ $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$};
+ $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)};
+ $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce};
+ $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$};
+
+ if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) {
+ my @deps = map { s/\s+//g; $_ } split /,/, $3;
+ my $d;
+ for $d (map { s/\s+//g; $_ } split /,/, $1) {
+ push @{$depends{$d}}, @deps;
+ }
+ }
+
+ $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)};
+}
+
+for (values %depends) {
+ my %s;
+ $_ = [sort grep !$s{$_}++, @$_];
+}
+
+if (exists $opt{'api-info'}) {
+ my $f;
+ my $count = 0;
+ my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$";
+ for $f (sort { lc $a cmp lc $b } keys %API) {
+ next unless $f =~ /$match/;
+ print "\n=== $f ===\n\n";
+ my $info = 0;
+ if ($API{$f}{base} || $API{$f}{todo}) {
+ my $base = format_version($API{$f}{base} || $API{$f}{todo});
+ print "Supported at least starting from perl-$base.\n";
+ $info++;
+ }
+ if ($API{$f}{provided}) {
+ my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003";
+ print "Support by $ppport provided back to perl-$todo.\n";
+ print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f};
+ print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f};
+ print "\n$hints{$f}" if exists $hints{$f};
+ print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f};
+ $info++;
+ }
+ print "No portability information available.\n" unless $info;
+ $count++;
+ }
+ $count or print "Found no API matching '$opt{'api-info'}'.";
+ print "\n";
+ exit 0;
+}
+
+if (exists $opt{'list-provided'}) {
+ my $f;
+ for $f (sort { lc $a cmp lc $b } keys %API) {
+ next unless $API{$f}{provided};
+ my @flags;
+ push @flags, 'explicit' if exists $need{$f};
+ push @flags, 'depend' if exists $depends{$f};
+ push @flags, 'hint' if exists $hints{$f};
+ push @flags, 'warning' if exists $warnings{$f};
+ my $flags = @flags ? ' ['.join(', ', @flags).']' : '';
+ print "$f$flags\n";
+ }
+ exit 0;
+}
+
+my @files;
+my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc );
+my $srcext = join '|', map { quotemeta $_ } @srcext;
+
+if (@ARGV) {
+ my %seen;
+ for (@ARGV) {
+ if (-e) {
+ if (-f) {
+ push @files, $_ unless $seen{$_}++;
+ }
+ else { warn "'$_' is not a file.\n" }
+ }
+ else {
+ my @new = grep { -f } glob $_
+ or warn "'$_' does not exist.\n";
+ push @files, grep { !$seen{$_}++ } @new;
+ }
+ }
+}
+else {
+ eval {
+ require File::Find;
+ File::Find::find(sub {
+ $File$srcext)$/i
+ and push @files, $File::Find::name;
+ }, '.');
+ };
+ if ($@) {
+ @files = map { glob "*$_" } @srcext;
+ }
+}
+
+if (!@ARGV || $opt{filter}) {
+ my(@in, @out);
+ my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files;
+ for (@files) {
+ my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i;
+ push @{ $out ? \@out : \@in }, $_;
+ }
+ if (@ARGV && @out) {
+ warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out);
+ }
+ @files = @in;
+}
+
+die "No input files given!\n" unless @files;
+
+my(%files, %global, %revreplace);
+%revreplace = reverse %replace;
+my $filename;
+my $patch_opened = 0;
+
+for $filename (@files) {
+ unless (open IN, "<$filename") {
+ warn "Unable to read from $filename: $!\n";
+ next;
+ }
+
+ info("Scanning $filename ...");
+
+ my $c = do { local $/; <IN> };
+ close IN;
+
+ my %file = (orig => $c, changes => 0);
+
+ # Temporarily remove C/XS comments and strings from the code
+ my @ccom;
+
+ $c =~ s{
+ ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]*
+ | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* )
+ | ( ^$HS*\#[^\r\n]*
+ | "[^"\\]*(?:\\.[^"\\]*)*"
+ | '[^'\\]*(?:\\.[^'\\]*)*'
+ | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) )
+ }{ defined $2 and push @ccom, $2;
+ defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex;
+
+ $file{ccom} = \@ccom;
+ $file{code} = $c;
+ $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m;
+
+ my $func;
+
+ for $func (keys %API) {
+ my $match = $func;
+ $match .= "|$revreplace{$func}" if exists $revreplace{$func};
+ if ($c =~ /\b(?:Perl_)?($match)\b/) {
+ $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func};
+ $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/;
+ if (exists $API{$func}{provided}) {
+ $file{uses_provided}{$func}++;
+ if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) {
+ $file{uses}{$func}++;
+ my @deps = rec_depend($func);
+ if (@deps) {
+ $file{uses_deps}{$func} = \@deps;
+ for (@deps) {
+ $file{uses}{$_} = 0 unless exists $file{uses}{$_};
+ }
+ }
+ for ($func, @deps) {
+ $file{needs}{$_} = 'static' if exists $need{$_};
+ }
+ }
+ }
+ if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) {
+ if ($c =~ /\b$func\b/) {
+ $file{uses_todo}{$func}++;
+ }
+ }
+ }
+ }
+
+ while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) {
+ if (exists $need{$2}) {
+ $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++;
+ }
+ else { warning("Possibly wrong #define $1 in $filename") }
+ }
+
+ for (qw(uses needs uses_todo needed_global needed_static)) {
+ for $func (keys %{$file{$_}}) {
+ push @{$global{$_}{$func}}, $filename;
+ }
+ }
+
+ $files{$filename} = \%file;
+}
+
+# Globally resolve NEED_'s
+my $need;
+for $need (keys %{$global{needs}}) {
+ if (@{$global{needs}{$need}} > 1) {
+ my @targets = @{$global{needs}{$need}};
+ my @t = grep $files{$_}{needed_global}{$need}, @targets;
+ @targets = @t if @t;
+ @t = grep /\.xs$/i, @targets;
+ @targets = @t if @t;
+ my $target = shift @targets;
+ $files{$target}{needs}{$need} = 'global';
+ for (@{$global{needs}{$need}}) {
+ $files{$_}{needs}{$need} = 'extern' if $_ ne $target;
+ }
+ }
+}
+
+for $filename (@files) {
+ exists $files{$filename} or next;
+
+ info("=== Analyzing $filename ===");
+
+ my %file = %{$files{$filename}};
+ my $func;
+ my $c = $file{code};
+ my $warnings = 0;
+
+ for $func (sort keys %{$file{uses_Perl}}) {
+ if ($API{$func}{varargs}) {
+ unless ($API{$func}{nothxarg}) {
+ my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))}
+ { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge);
+ if ($changes) {
+ warning("Doesn't pass interpreter argument aTHX to Perl_$func");
+ $file{changes} += $changes;
+ }
+ }
+ }
+ else {
+ warning("Uses Perl_$func instead of $func");
+ $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*}
+ {$func$1(}g);
+ }
+ }
+
+ for $func (sort keys %{$file{uses_replace}}) {
+ warning("Uses $func instead of $replace{$func}");
+ $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
+ }
+
+ for $func (sort keys %{$file{uses_provided}}) {
+ if ($file{uses}{$func}) {
+ if (exists $file{uses_deps}{$func}) {
+ diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}}));
+ }
+ else {
+ diag("Uses $func");
+ }
+ }
+ $warnings += hint($func);
+ }
+
+ unless ($opt{quiet}) {
+ for $func (sort keys %{$file{uses_todo}}) {
+ print "*** WARNING: Uses $func, which may not be portable below perl ",
+ format_version($API{$func}{todo}), ", even with '$ppport'\n";
+ $warnings++;
+ }
+ }
+
+ for $func (sort keys %{$file{needed_static}}) {
+ my $message = '';
+ if (not exists $file{uses}{$func}) {
+ $message = "No need to define NEED_$func if $func is never used";
+ }
+ elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') {
+ $message = "No need to define NEED_$func when already needed globally";
+ }
+ if ($message) {
+ diag($message);
+ $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg);
+ }
+ }
+
+ for $func (sort keys %{$file{needed_global}}) {
+ my $message = '';
+ if (not exists $global{uses}{$func}) {
+ $message = "No need to define NEED_${func}_GLOBAL if $func is never used";
+ }
+ elsif (exists $file{needs}{$func}) {
+ if ($file{needs}{$func} eq 'extern') {
+ $message = "No need to define NEED_${func}_GLOBAL when already needed globally";
+ }
+ elsif ($file{needs}{$func} eq 'static') {
+ $message = "No need to define NEED_${func}_GLOBAL when only used in this file";
+ }
+ }
+ if ($message) {
+ diag($message);
+ $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg);
+ }
+ }
+
+ $file{needs_inc_ppport} = keys %{$file{uses}};
+
+ if ($file{needs_inc_ppport}) {
+ my $pp = '';
+
+ for $func (sort keys %{$file{needs}}) {
+ my $type = $file{needs}{$func};
+ next if $type eq 'extern';
+ my $suffix = $type eq 'global' ? '_GLOBAL' : '';
+ unless (exists $file{"needed_$type"}{$func}) {
+ if ($type eq 'global') {
+ diag("Files [@{$global{needs}{$func}}] need $func, adding global request");
+ }
+ else {
+ diag("File needs $func, adding static request");
+ }
+ $pp .= "#define NEED_$func$suffix\n";
+ }
+ }
+
+ if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) {
+ $pp = '';
+ $file{changes}++;
+ }
+
+ unless ($file{has_inc_ppport}) {
+ diag("Needs to include '$ppport'");
+ $pp .= qq(#include "$ppport"\n)
+ }
+
+ if ($pp) {
+ $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms)
+ || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m)
+ || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m)
+ || ($c =~ s/^/$pp/);
+ }
+ }
+ else {
+ if ($file{has_inc_ppport}) {
+ diag("No need to include '$ppport'");
+ $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m);
+ }
+ }
+
+ # put back in our C comments
+ my $ix;
+ my $cppc = 0;
+ my @ccom = @{$file{ccom}};
+ for $ix (0 .. $#ccom) {
+ if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) {
+ $cppc++;
+ $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/;
+ }
+ else {
+ $c =~ s/$rccs$ix$rcce/$ccom[$ix]/;
+ }
+ }
+
+ if ($cppc) {
+ my $s = $cppc != 1 ? 's' : '';
+ warning("Uses $cppc C++ style comment$s, which is not portable");
+ }
+
+ my $s = $warnings != 1 ? 's' : '';
+ my $warn = $warnings ? " ($warnings warning$s)" : '';
+ info("Analysis completed$warn");
+
+ if ($file{changes}) {
+ if (exists $opt{copy}) {
+ my $newfile = "$filename$opt{copy}";
+ if (-e $newfile) {
+ error("'$newfile' already exists, refusing to write copy of '$filename'");
+ }
+ else {
+ local *F;
+ if (open F, ">$newfile") {
+ info("Writing copy of '$filename' with changes to '$newfile'");
+ print F $c;
+ close F;
+ }
+ else {
+ error("Cannot open '$newfile' for writing: $!");
+ }
+ }
+ }
+ elsif (exists $opt{patch} || $opt{changes}) {
+ if (exists $opt{patch}) {
+ unless ($patch_opened) {
+ if (open PATCH, ">$opt{patch}") {
+ $patch_opened = 1;
+ }
+ else {
+ error("Cannot open '$opt{patch}' for writing: $!");
+ delete $opt{patch};
+ $opt{changes} = 1;
+ goto fallback;
+ }
+ }
+ mydiff(\*PATCH, $filename, $c);
+ }
+ else {
+fallback:
+ info("Suggested changes:");
+ mydiff(\*STDOUT, $filename, $c);
+ }
+ }
+ else {
+ my $s = $file{changes} == 1 ? '' : 's';
+ info("$file{changes} potentially required change$s detected");
+ }
+ }
+ else {
+ info("Looks good");
+ }
+}
+
+close PATCH if $patch_opened;
+
+exit 0;
+
+
+sub try_use { eval "use @_;"; return $@ eq '' }
+
+sub mydiff
+{
+ local *F = shift;
+ my($file, $str) = @_;
+ my $diff;
+
+ if (exists $opt{diff}) {
+ $diff = run_diff($opt{diff}, $file, $str);
+ }
+
+ if (!defined $diff and try_use('Text::Diff')) {
+ $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' });
+ $diff = <<HEADER . $diff;
+--- $file
++++ $file.patched
+HEADER
+ }
+
+ if (!defined $diff) {
+ $diff = run_diff('diff -u', $file, $str);
+ }
+
+ if (!defined $diff) {
+ $diff = run_diff('diff', $file, $str);
+ }
+
+ if (!defined $diff) {
+ error("Cannot generate a diff. Please install Text::Diff or use --copy.");
+ return;
+ }
+
+ print F $diff;
+}
+
+sub run_diff
+{
+ my($prog, $file, $str) = @_;
+ my $tmp = 'dppptemp';
+ my $suf = 'aaa';
+ my $diff = '';
+ local *F;
+
+ while (-e "$tmp.$suf") { $suf++ }
+ $tmp = "$tmp.$suf";
+
+ if (open F, ">$tmp") {
+ print F $str;
+ close F;
+
+ if (open F, "$prog $file $tmp |") {
+ while (<F>) {
+ s/\Q$tmp\E/$file.patched/;
+ $diff .= $_;
+ }
+ close F;
+ unlink $tmp;
+ return $diff;
+ }
+
+ unlink $tmp;
+ }
+ else {
+ error("Cannot open '$tmp' for writing: $!");
+ }
+
+ return undef;
+}
+
+sub rec_depend
+{
+ my($func, $seen) = @_;
+ return () unless exists $depends{$func};
+ $seen = {%{$seen||{}}};
+ return () if $seen->{$func}++;
+ my %s;
+ grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}};
+}
+
+sub parse_version
+{
+ my $ver = shift;
+
+ if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
+ return ($1, $2, $3);
+ }
+ elsif ($ver !~ /^\d+\.[\d_]+$/) {
+ die "cannot parse version '$ver'\n";
+ }
+
+ $ver =~ s/_//g;
+ $ver =~ s/$/000000/;
+
+ my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
+
+ $v = int $v;
+ $s = int $s;
+
+ if ($r < 5 || ($r == 5 && $v < 6)) {
+ if ($s % 10) {
+ die "cannot parse version '$ver'\n";
+ }
+ }
+
+ return ($r, $v, $s);
+}
+
+sub format_version
+{
+ my $ver = shift;
+
+ $ver =~ s/$/000000/;
+ my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
+
+ $v = int $v;
+ $s = int $s;
+
+ if ($r < 5 || ($r == 5 && $v < 6)) {
+ if ($s % 10) {
+ die "invalid version '$ver'\n";
+ }
+ $s /= 10;
+
+ $ver = sprintf "%d.%03d", $r, $v;
+ $s > 0 and $ver .= sprintf "_%02d", $s;
+
+ return $ver;
+ }
+
+ return sprintf "%d.%d.%d", $r, $v, $s;
+}
+
+sub info
+{
+ $opt{quiet} and return;
+ print @_, "\n";
+}
+
+sub diag
+{
+ $opt{quiet} and return;
+ $opt{diag} and print @_, "\n";
+}
+
+sub warning
+{
+ $opt{quiet} and return;
+ print "*** ", @_, "\n";
+}
+
+sub error
+{
+ print "*** ERROR: ", @_, "\n";
+}
+
+my %given_hints;
+my %given_warnings;
+sub hint
+{
+ $opt{quiet} and return;
+ my $func = shift;
+ my $rv = 0;
+ if (exists $warnings{$func} && !$given_warnings{$func}++) {
+ my $warn = $warnings{$func};
+ $warn =~ s!^!*** !mg;
+ print "*** WARNING: $func\n", $warn;
+ $rv++;
+ }
+ if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) {
+ my $hint = $hints{$func};
+ $hint =~ s/^/ /mg;
+ print " --- hint for $func ---\n", $hint;
+ }
+ $rv;
+}
+
+sub usage
+{
+ my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
+ my %M = ( 'I' => '*' );
+ $usage =~ s/^\s*perl\s+\S+/$^X $0/;
+ $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
+
+ print <<ENDUSAGE;
+
+Usage: $usage
+
+See perldoc $0 for details.
+
+ENDUSAGE
+
+ exit 2;
+}
+
+sub strip
+{
+ my $self = do { local(@ARGV,$/)=($0); <> };
+ my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms;
+ $copy =~ s/^(?=\S+)/ /gms;
+ $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms;
+ $self =~ s/^SKIP.*(?=^__DATA__)/SKIP
+if (\@ARGV && \$ARGV[0] eq '--unstrip') {
+ eval { require Devel::PPPort };
+ \$@ and die "Cannot require Devel::PPPort, please install.\\n";
+ if (eval \$Devel::PPPort::VERSION < $VERSION) {
+ die "$0 was originally generated with Devel::PPPort $VERSION.\\n"
+ . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n"
+ . "Please install a newer version, or --unstrip will not work.\\n";
+ }
+ Devel::PPPort::WriteFile(\$0);
+ exit 0;
+}
+print <<END;
+
+Sorry, but this is a stripped version of \$0.
+
+To be able to use its original script and doc functionality,
+please try to regenerate this file using:
+
+ \$^X \$0 --unstrip
+
+END
+/ms;
+ my($pl, $c) = $self =~ /(.*^__DATA__)(.*)/ms;
+ $c =~ s{
+ / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
+ | ( "[^"\\]*(?:\\.[^"\\]*)*"
+ | '[^'\\]*(?:\\.[^'\\]*)*' )
+ | ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex;
+ $c =~ s!\s+$!!mg;
+ $c =~ s!^$LF!!mg;
+ $c =~ s!^\s*#\s*!#!mg;
+ $c =~ s!^\s+!!mg;
+
+ open OUT, ">$0" or die "cannot strip $0: $!\n";
+ print OUT "$pl$c\n";
+
+ exit 0;
+}
+
+__DATA__
+*/
+
+#ifndef _P_P_PORTABILITY_H_
+#define _P_P_PORTABILITY_H_
+
+#ifndef DPPP_NAMESPACE
+# define DPPP_NAMESPACE DPPP_
+#endif
+
+#define DPPP_CAT2(x,y) CAT2(x,y)
+#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
+
+#ifndef PERL_REVISION
+# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION))
+# define PERL_PATCHLEVEL_H_IMPLICIT
+# include <patchlevel.h>
+# endif
+# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL)))
+# include <could_not_find_Perl_patchlevel.h>
+# endif
+# ifndef PERL_REVISION
+# define PERL_REVISION (5)
+ /* Replace: 1 */
+# define PERL_VERSION PATCHLEVEL
+# define PERL_SUBVERSION SUBVERSION
+ /* Replace PERL_PATCHLEVEL with PERL_VERSION */
+ /* Replace: 0 */
+# endif
+#endif
+
+#define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10))
+#define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION))
+
+/* It is very unlikely that anyone will try to use this with Perl 6
+ (or greater), but who knows.
+ */
+#if PERL_REVISION != 5
+# error ppport.h only works with Perl version 5
+#endif /* PERL_REVISION != 5 */
+#ifndef dTHR
+# define dTHR dNOOP
+#endif
+#ifndef dTHX
+# define dTHX dNOOP
+#endif
+
+#ifndef dTHXa
+# define dTHXa(x) dNOOP
+#endif
+#ifndef pTHX
+# define pTHX void
+#endif
+
+#ifndef pTHX_
+# define pTHX_
+#endif
+
+#ifndef aTHX
+# define aTHX
+#endif
+
+#ifndef aTHX_
+# define aTHX_
+#endif
+
+#if (PERL_BCDVERSION < 0x5006000)
+# ifdef USE_THREADS
+# define aTHXR thr
+# define aTHXR_ thr,
+# else
+# define aTHXR
+# define aTHXR_
+# endif
+# define dTHXR dTHR
+#else
+# define aTHXR aTHX
+# define aTHXR_ aTHX_
+# define dTHXR dTHX
+#endif
+#ifndef dTHXoa
+# define dTHXoa(x) dTHXa(x)
+#endif
+
+#ifdef I_LIMITS
+# include <limits.h>
+#endif
+
+#ifndef PERL_UCHAR_MIN
+# define PERL_UCHAR_MIN ((unsigned char)0)
+#endif
+
+#ifndef PERL_UCHAR_MAX
+# ifdef UCHAR_MAX
+# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX)
+# else
+# ifdef MAXUCHAR
+# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR)
+# else
+# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0)
+# endif
+# endif
+#endif
+
+#ifndef PERL_USHORT_MIN
+# define PERL_USHORT_MIN ((unsigned short)0)
+#endif
+
+#ifndef PERL_USHORT_MAX
+# ifdef USHORT_MAX
+# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX)
+# else
+# ifdef MAXUSHORT
+# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT)
+# else
+# ifdef USHRT_MAX
+# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX)
+# else
+# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0)
+# endif
+# endif
+# endif
+#endif
+
+#ifndef PERL_SHORT_MAX
+# ifdef SHORT_MAX
+# define PERL_SHORT_MAX ((short)SHORT_MAX)
+# else
+# ifdef MAXSHORT /* Often used in <values.h> */
+# define PERL_SHORT_MAX ((short)MAXSHORT)
+# else
+# ifdef SHRT_MAX
+# define PERL_SHORT_MAX ((short)SHRT_MAX)
+# else
+# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1))
+# endif
+# endif
+# endif
+#endif
+
+#ifndef PERL_SHORT_MIN
+# ifdef SHORT_MIN
+# define PERL_SHORT_MIN ((short)SHORT_MIN)
+# else
+# ifdef MINSHORT
+# define PERL_SHORT_MIN ((short)MINSHORT)
+# else
+# ifdef SHRT_MIN
+# define PERL_SHORT_MIN ((short)SHRT_MIN)
+# else
+# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3))
+# endif
+# endif
+# endif
+#endif
+
+#ifndef PERL_UINT_MAX
+# ifdef UINT_MAX
+# define PERL_UINT_MAX ((unsigned int)UINT_MAX)
+# else
+# ifdef MAXUINT
+# define PERL_UINT_MAX ((unsigned int)MAXUINT)
+# else
+# define PERL_UINT_MAX (~(unsigned int)0)
+# endif
+# endif
+#endif
+
+#ifndef PERL_UINT_MIN
+# define PERL_UINT_MIN ((unsigned int)0)
+#endif
+
+#ifndef PERL_INT_MAX
+# ifdef INT_MAX
+# define PERL_INT_MAX ((int)INT_MAX)
+# else
+# ifdef MAXINT /* Often used in <values.h> */
+# define PERL_INT_MAX ((int)MAXINT)
+# else
+# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1))
+# endif
+# endif
+#endif
+
+#ifndef PERL_INT_MIN
+# ifdef INT_MIN
+# define PERL_INT_MIN ((int)INT_MIN)
+# else
+# ifdef MININT
+# define PERL_INT_MIN ((int)MININT)
+# else
+# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3))
+# endif
+# endif
+#endif
+
+#ifndef PERL_ULONG_MAX
+# ifdef ULONG_MAX
+# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX)
+# else
+# ifdef MAXULONG
+# define PERL_ULONG_MAX ((unsigned long)MAXULONG)
+# else
+# define PERL_ULONG_MAX (~(unsigned long)0)
+# endif
+# endif
+#endif
+
+#ifndef PERL_ULONG_MIN
+# define PERL_ULONG_MIN ((unsigned long)0L)
+#endif
+
+#ifndef PERL_LONG_MAX
+# ifdef LONG_MAX
+# define PERL_LONG_MAX ((long)LONG_MAX)
+# else
+# ifdef MAXLONG
+# define PERL_LONG_MAX ((long)MAXLONG)
+# else
+# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1))
+# endif
+# endif
+#endif
+
+#ifndef PERL_LONG_MIN
+# ifdef LONG_MIN
+# define PERL_LONG_MIN ((long)LONG_MIN)
+# else
+# ifdef MINLONG
+# define PERL_LONG_MIN ((long)MINLONG)
+# else
+# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3))
+# endif
+# endif
+#endif
+
+#if defined(HAS_QUAD) && (defined(convex) || defined(uts))
+# ifndef PERL_UQUAD_MAX
+# ifdef ULONGLONG_MAX
+# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX)
+# else
+# ifdef MAXULONGLONG
+# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG)
+# else
+# define PERL_UQUAD_MAX (~(unsigned long long)0)
+# endif
+# endif
+# endif
+
+# ifndef PERL_UQUAD_MIN
+# define PERL_UQUAD_MIN ((unsigned long long)0L)
+# endif
+
+# ifndef PERL_QUAD_MAX
+# ifdef LONGLONG_MAX
+# define PERL_QUAD_MAX ((long long)LONGLONG_MAX)
+# else
+# ifdef MAXLONGLONG
+# define PERL_QUAD_MAX ((long long)MAXLONGLONG)
+# else
+# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1))
+# endif
+# endif
+# endif
+
+# ifndef PERL_QUAD_MIN
+# ifdef LONGLONG_MIN
+# define PERL_QUAD_MIN ((long long)LONGLONG_MIN)
+# else
+# ifdef MINLONGLONG
+# define PERL_QUAD_MIN ((long long)MINLONGLONG)
+# else
+# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3))
+# endif
+# endif
+# endif
+#endif
+
+/* This is based on code from 5.003 perl.h */
+#ifdef HAS_QUAD
+# ifdef cray
+#ifndef IVTYPE
+# define IVTYPE int
+#endif
+
+#ifndef IV_MIN
+# define IV_MIN PERL_INT_MIN
+#endif
+
+#ifndef IV_MAX
+# define IV_MAX PERL_INT_MAX
+#endif
+
+#ifndef UV_MIN
+# define UV_MIN PERL_UINT_MIN
+#endif
+
+#ifndef UV_MAX
+# define UV_MAX PERL_UINT_MAX
+#endif
+
+# ifdef INTSIZE
+#ifndef IVSIZE
+# define IVSIZE INTSIZE
+#endif
+
+# endif
+# else
+# if defined(convex) || defined(uts)
+#ifndef IVTYPE
+# define IVTYPE long long
+#endif
+
+#ifndef IV_MIN
+# define IV_MIN PERL_QUAD_MIN
+#endif
+
+#ifndef IV_MAX
+# define IV_MAX PERL_QUAD_MAX
+#endif
+
+#ifndef UV_MIN
+# define UV_MIN PERL_UQUAD_MIN
+#endif
+
+#ifndef UV_MAX
+# define UV_MAX PERL_UQUAD_MAX
+#endif
+
+# ifdef LONGLONGSIZE
+#ifndef IVSIZE
+# define IVSIZE LONGLONGSIZE
+#endif
+
+# endif
+# else
+#ifndef IVTYPE
+# define IVTYPE long
+#endif
+
+#ifndef IV_MIN
+# define IV_MIN PERL_LONG_MIN
+#endif
+
+#ifndef IV_MAX
+# define IV_MAX PERL_LONG_MAX
+#endif
+
+#ifndef UV_MIN
+# define UV_MIN PERL_ULONG_MIN
+#endif
+
+#ifndef UV_MAX
+# define UV_MAX PERL_ULONG_MAX
+#endif
+
+# ifdef LONGSIZE
+#ifndef IVSIZE
+# define IVSIZE LONGSIZE
+#endif
+
+# endif
+# endif
+# endif
+#ifndef IVSIZE
+# define IVSIZE 8
+#endif
+
+#ifndef PERL_QUAD_MIN
+# define PERL_QUAD_MIN IV_MIN
+#endif
+
+#ifndef PERL_QUAD_MAX
+# define PERL_QUAD_MAX IV_MAX
+#endif
+
+#ifndef PERL_UQUAD_MIN
+# define PERL_UQUAD_MIN UV_MIN
+#endif
+
+#ifndef PERL_UQUAD_MAX
+# define PERL_UQUAD_MAX UV_MAX
+#endif
+
+#else
+#ifndef IVTYPE
+# define IVTYPE long
+#endif
+
+#ifndef IV_MIN
+# define IV_MIN PERL_LONG_MIN
+#endif
+
+#ifndef IV_MAX
+# define IV_MAX PERL_LONG_MAX
+#endif
+
+#ifndef UV_MIN
+# define UV_MIN PERL_ULONG_MIN
+#endif
+
+#ifndef UV_MAX
+# define UV_MAX PERL_ULONG_MAX
+#endif
+
+#endif
+
+#ifndef IVSIZE
+# ifdef LONGSIZE
+# define IVSIZE LONGSIZE
+# else
+# define IVSIZE 4 /* A bold guess, but the best we can make. */
+# endif
+#endif
+#ifndef UVTYPE
+# define UVTYPE unsigned IVTYPE
+#endif
+
+#ifndef UVSIZE
+# define UVSIZE IVSIZE
+#endif
+#ifndef sv_setuv
+# define sv_setuv(sv, uv) \
+ STMT_START { \
+ UV TeMpUv = uv; \
+ if (TeMpUv <= IV_MAX) \
+ sv_setiv(sv, TeMpUv); \
+ else \
+ sv_setnv(sv, (double)TeMpUv); \
+ } STMT_END
+#endif
+#ifndef newSVuv
+# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv))
+#endif
+#ifndef sv_2uv
+# define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv)))
+#endif
+
+#ifndef SvUVX
+# define SvUVX(sv) ((UV)SvIVX(sv))
+#endif
+
+#ifndef SvUVXx
+# define SvUVXx(sv) SvUVX(sv)
+#endif
+
+#ifndef SvUV
+# define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv))
+#endif
+
+#ifndef SvUVx
+# define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv))
+#endif
+
+/* Hint: sv_uv
+ * Always use the SvUVx() macro instead of sv_uv().
+ */
+#ifndef sv_uv
+# define sv_uv(sv) SvUVx(sv)
+#endif
+
+#if !defined(SvUOK) && defined(SvIOK_UV)
+# define SvUOK(sv) SvIOK_UV(sv)
+#endif
+#ifndef XST_mUV
+# define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) )
+#endif
+
+#ifndef XSRETURN_UV
+# define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END
+#endif
+#ifndef PUSHu
+# define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END
+#endif
+
+#ifndef XPUSHu
+# define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END
+#endif
+
+#ifdef HAS_MEMCMP
+#ifndef memNE
+# define memNE(s1,s2,l) (memcmp(s1,s2,l))
+#endif
+
+#ifndef memEQ
+# define memEQ(s1,s2,l) (!memcmp(s1,s2,l))
+#endif
+
+#else
+#ifndef memNE
+# define memNE(s1,s2,l) (bcmp(s1,s2,l))
+#endif
+
+#ifndef memEQ
+# define memEQ(s1,s2,l) (!bcmp(s1,s2,l))
+#endif
+
+#endif
+#ifndef MoveD
+# define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t))
+#endif
+
+#ifndef CopyD
+# define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
+#endif
+
+#ifdef HAS_MEMSET
+#ifndef ZeroD
+# define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t))
+#endif
+
+#else
+#ifndef ZeroD
+# define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d)
+#endif
+
+#endif
+#ifndef PoisonWith
+# define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t))
+#endif
+
+#ifndef PoisonNew
+# define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB)
+#endif
+
+#ifndef PoisonFree
+# define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF)
+#endif
+
+#ifndef Poison
+# define Poison(d,n,t) PoisonFree(d,n,t)
+#endif
+#ifndef Newx
+# define Newx(v,n,t) New(0,v,n,t)
+#endif
+
+#ifndef Newxc
+# define Newxc(v,n,t,c) Newc(0,v,n,t,c)
+#endif
+
+#ifndef Newxz
+# define Newxz(v,n,t) Newz(0,v,n,t)
+#endif
+
+#ifndef PERL_UNUSED_DECL
+# ifdef HASATTRIBUTE
+# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
+# define PERL_UNUSED_DECL
+# else
+# define PERL_UNUSED_DECL __attribute__((unused))
+# endif
+# else
+# define PERL_UNUSED_DECL
+# endif
+#endif
+
+#ifndef PERL_UNUSED_ARG
+# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */
+# include <note.h>
+# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x))
+# else
+# define PERL_UNUSED_ARG(x) ((void)x)
+# endif
+#endif
+
+#ifndef PERL_UNUSED_VAR
+# define PERL_UNUSED_VAR(x) ((void)x)
+#endif
+
+#ifndef PERL_UNUSED_CONTEXT
+# ifdef USE_ITHREADS
+# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl)
+# else
+# define PERL_UNUSED_CONTEXT
+# endif
+#endif
+#ifndef NOOP
+# define NOOP /*EMPTY*/(void)0
+#endif
+
+#ifndef dNOOP
+# define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL
+#endif
+
+#ifndef NVTYPE
+# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
+# define NVTYPE long double
+# else
+# define NVTYPE double
+# endif
+typedef NVTYPE NV;
+#endif
+
+#ifndef INT2PTR
+# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
+# define PTRV UV
+# define INT2PTR(any,d) (any)(d)
+# else
+# if PTRSIZE == LONGSIZE
+# define PTRV unsigned long
+# else
+# define PTRV unsigned
+# endif
+# define INT2PTR(any,d) (any)(PTRV)(d)
+# endif
+#endif
+
+#ifndef PTR2ul
+# if PTRSIZE == LONGSIZE
+# define PTR2ul(p) (unsigned long)(p)
+# else
+# define PTR2ul(p) INT2PTR(unsigned long,p)
+# endif
+#endif
+#ifndef PTR2nat
+# define PTR2nat(p) (PTRV)(p)
+#endif
+
+#ifndef NUM2PTR
+# define NUM2PTR(any,d) (any)PTR2nat(d)
+#endif
+
+#ifndef PTR2IV
+# define PTR2IV(p) INT2PTR(IV,p)
+#endif
+
+#ifndef PTR2UV
+# define PTR2UV(p) INT2PTR(UV,p)
+#endif
+
+#ifndef PTR2NV
+# define PTR2NV(p) NUM2PTR(NV,p)
+#endif
+
+#undef START_EXTERN_C
+#undef END_EXTERN_C
+#undef EXTERN_C
+#ifdef __cplusplus
+# define START_EXTERN_C extern "C" {
+# define END_EXTERN_C }
+# define EXTERN_C extern "C"
+#else
+# define START_EXTERN_C
+# define END_EXTERN_C
+# define EXTERN_C extern
+#endif
+
+#if defined(PERL_GCC_PEDANTIC)
+# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
+# define PERL_GCC_BRACE_GROUPS_FORBIDDEN
+# endif
+#endif
+
+#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
+# ifndef PERL_USE_GCC_BRACE_GROUPS
+# define PERL_USE_GCC_BRACE_GROUPS
+# endif
+#endif
+
+#undef STMT_START
+#undef ST
<TRUNCATED>