/src/pl/plperl/sql/plperl.sql
SQL | 474 lines | 321 code | 99 blank | 54 comment | 7 complexity | 0afa80a2d7120e15a717e5ade97c25cc MD5 | raw file
- --
- -- Test result value processing
- --
- CREATE OR REPLACE FUNCTION perl_int(int) RETURNS INTEGER AS $$
- return undef;
- $$ LANGUAGE plperl;
- SELECT perl_int(11);
- SELECT * FROM perl_int(42);
- CREATE OR REPLACE FUNCTION perl_int(int) RETURNS INTEGER AS $$
- return $_[0] + 1;
- $$ LANGUAGE plperl;
- SELECT perl_int(11);
- SELECT * FROM perl_int(42);
- CREATE OR REPLACE FUNCTION perl_set_int(int) RETURNS SETOF INTEGER AS $$
- return undef;
- $$ LANGUAGE plperl;
- SELECT perl_set_int(5);
- SELECT * FROM perl_set_int(5);
- CREATE OR REPLACE FUNCTION perl_set_int(int) RETURNS SETOF INTEGER AS $$
- return [0..$_[0]];
- $$ LANGUAGE plperl;
- SELECT perl_set_int(5);
- SELECT * FROM perl_set_int(5);
- CREATE TYPE testnestperl AS (f5 integer[]);
- CREATE TYPE testrowperl AS (f1 integer, f2 text, f3 text, f4 testnestperl);
- CREATE OR REPLACE FUNCTION perl_row() RETURNS testrowperl AS $$
- return undef;
- $$ LANGUAGE plperl;
- SELECT perl_row();
- SELECT * FROM perl_row();
- CREATE OR REPLACE FUNCTION perl_row() RETURNS testrowperl AS $$
- return {f2 => 'hello', f1 => 1, f3 => 'world', 'f4' => { 'f5' => [[1]] } };
- $$ LANGUAGE plperl;
- SELECT perl_row();
- SELECT * FROM perl_row();
- -- test returning a composite literal
- CREATE OR REPLACE FUNCTION perl_row_lit() RETURNS testrowperl AS $$
- return '(1,hello,world,"({{1}})")';
- $$ LANGUAGE plperl;
- SELECT perl_row_lit();
- CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
- return undef;
- $$ LANGUAGE plperl;
- SELECT perl_set();
- SELECT * FROM perl_set();
- CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
- return [
- { f1 => 1, f2 => 'Hello', f3 => 'World' },
- undef,
- { f1 => 3, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => {} },
- { f1 => 4, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => undef }},
- { f1 => 5, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => '{1}' }},
- { f1 => 6, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => [1] }},
- ];
- $$ LANGUAGE plperl;
- SELECT perl_set();
- SELECT * FROM perl_set();
- CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
- return [
- { f1 => 1, f2 => 'Hello', f3 => 'World' },
- { f1 => 2, f2 => 'Hello', f3 => 'PostgreSQL', 'f4' => undef },
- { f1 => 3, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => {} },
- { f1 => 4, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => undef }},
- { f1 => 5, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => '{1}' }},
- { f1 => 6, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => [1] }},
- { f1 => 7, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => '({1})' },
- ];
- $$ LANGUAGE plperl;
- SELECT perl_set();
- SELECT * FROM perl_set();
- CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$
- return undef;
- $$ LANGUAGE plperl;
- SELECT perl_record();
- SELECT * FROM perl_record();
- SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text, f4 testnestperl);
- CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$
- return {f2 => 'hello', f1 => 1, f3 => 'world', 'f4' => { 'f5' => [1] } };
- $$ LANGUAGE plperl;
- SELECT perl_record();
- SELECT * FROM perl_record();
- SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text, f4 testnestperl);
- CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
- return undef;
- $$ LANGUAGE plperl;
- SELECT perl_record_set();
- SELECT * FROM perl_record_set();
- SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text);
- CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
- return [
- { f1 => 1, f2 => 'Hello', f3 => 'World' },
- undef,
- { f1 => 3, f2 => 'Hello', f3 => 'PL/Perl' }
- ];
- $$ LANGUAGE plperl;
- SELECT perl_record_set();
- SELECT * FROM perl_record_set();
- SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text);
- CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
- return [
- { f1 => 1, f2 => 'Hello', f3 => 'World' },
- { f1 => 2, f2 => 'Hello', f3 => 'PostgreSQL' },
- { f1 => 3, f2 => 'Hello', f3 => 'PL/Perl' }
- ];
- $$ LANGUAGE plperl;
- SELECT perl_record_set();
- SELECT * FROM perl_record_set();
- SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text);
- CREATE OR REPLACE FUNCTION
- perl_out_params(f1 out integer, f2 out text, f3 out text) AS $$
- return {f2 => 'hello', f1 => 1, f3 => 'world'};
- $$ LANGUAGE plperl;
- SELECT perl_out_params();
- SELECT * FROM perl_out_params();
- SELECT (perl_out_params()).f2;
- CREATE OR REPLACE FUNCTION
- perl_out_params_set(out f1 integer, out f2 text, out f3 text)
- RETURNS SETOF record AS $$
- return [
- { f1 => 1, f2 => 'Hello', f3 => 'World' },
- { f1 => 2, f2 => 'Hello', f3 => 'PostgreSQL' },
- { f1 => 3, f2 => 'Hello', f3 => 'PL/Perl' }
- ];
- $$ LANGUAGE plperl;
- SELECT perl_out_params_set();
- SELECT * FROM perl_out_params_set();
- SELECT (perl_out_params_set()).f3;
- --
- -- Check behavior with erroneous return values
- --
- CREATE TYPE footype AS (x INTEGER, y INTEGER);
- CREATE OR REPLACE FUNCTION foo_good() RETURNS SETOF footype AS $$
- return [
- {x => 1, y => 2},
- {x => 3, y => 4}
- ];
- $$ LANGUAGE plperl;
- SELECT * FROM foo_good();
- CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
- return {y => 3, z => 4};
- $$ LANGUAGE plperl;
- SELECT * FROM foo_bad();
- CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
- return 42;
- $$ LANGUAGE plperl;
- SELECT * FROM foo_bad();
- CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
- return [
- [1, 2],
- [3, 4]
- ];
- $$ LANGUAGE plperl;
- SELECT * FROM foo_bad();
- CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
- return 42;
- $$ LANGUAGE plperl;
- SELECT * FROM foo_set_bad();
- CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
- return {y => 3, z => 4};
- $$ LANGUAGE plperl;
- SELECT * FROM foo_set_bad();
- CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
- return [
- [1, 2],
- [3, 4]
- ];
- $$ LANGUAGE plperl;
- SELECT * FROM foo_set_bad();
- CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
- return [
- {y => 3, z => 4}
- ];
- $$ LANGUAGE plperl;
- SELECT * FROM foo_set_bad();
- --
- -- 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)');
- -- simple test of a DO block
- DO $$
- $a = 'This is a test';
- elog(NOTICE, $a);
- $$ LANGUAGE plperl;
- -- check that restricted operations are rejected in a plperl DO block
- DO $$ system("/nonesuch"); $$ LANGUAGE plperl;
- DO $$ qx("/nonesuch"); $$ LANGUAGE plperl;
- DO $$ open my $fh, "</nonesuch"; $$ LANGUAGE plperl;
- -- check that eval is allowed and eval'd restricted ops are caught
- DO $$ eval q{chdir '.';}; warn "Caught: $@"; $$ LANGUAGE plperl;
- -- check that compiling do (dofile opcode) is allowed
- -- but that executing it for a file not already loaded (via require) dies
- DO $$ warn do "/dev/null"; $$ LANGUAGE plperl;
- -- check that we can't "use" a module that's not been loaded already
- -- compile-time error: "Unable to load blib.pm into plperl"
- DO $$ use blib; $$ LANGUAGE plperl;
- -- check that we can "use" a module that has already been loaded
- -- runtime error: "Can't use string ("foo") as a SCALAR ref while "strict refs" in use
- DO $do$ use strict; my $name = "foo"; my $ref = $$name; $do$ LANGUAGE plperl;
- -- check that we can "use warnings" (in this case to turn a warn into an error)
- -- yields "ERROR: Useless use of sort in scalar context."
- DO $do$ use warnings FATAL => qw(void) ; my @y; my $x = sort @y; 1; $do$ LANGUAGE plperl;
- -- make sure functions marked as VOID without an explicit return work
- CREATE OR REPLACE FUNCTION myfuncs() RETURNS void AS $$
- $_SHARED{myquote} = sub {
- my $arg = shift;
- $arg =~ s/(['\\])/\\$1/g;
- return "'$arg'";
- };
- $$ LANGUAGE plperl;
- SELECT myfuncs();
- -- make sure we can't return an array as a scalar
- CREATE OR REPLACE FUNCTION text_arrayref() RETURNS text AS $$
- return ['array'];
- $$ LANGUAGE plperl;
- SELECT text_arrayref();
- --- make sure we can't return a hash as a scalar
- CREATE OR REPLACE FUNCTION text_hashref() RETURNS text AS $$
- return {'hash'=>1};
- $$ LANGUAGE plperl;
- SELECT text_hashref();
- ---- make sure we can't return a blessed object as a scalar
- CREATE OR REPLACE FUNCTION text_obj() RETURNS text AS $$
- return bless({}, 'Fake::Object');
- $$ LANGUAGE plperl;
- SELECT text_obj();
- ----- make sure we can't return a scalar ref
- CREATE OR REPLACE FUNCTION text_scalarref() RETURNS text AS $$
- my $str = 'str';
- return \$str;
- $$ LANGUAGE plperl;
- SELECT text_scalarref();
- -- check safe behavior when a function body is replaced during execution
- CREATE OR REPLACE FUNCTION self_modify(INTEGER) RETURNS INTEGER AS $$
- spi_exec_query('CREATE OR REPLACE FUNCTION self_modify(INTEGER) RETURNS INTEGER AS \'return $_[0] * 3;\' LANGUAGE plperl;');
- spi_exec_query('select self_modify(42) AS a');
- return $_[0] * 2;
- $$ LANGUAGE plperl;
- SELECT self_modify(42);
- SELECT self_modify(42);