1
0
mirror of https://github.com/postgres/postgres.git synced 2025-06-11 20:28:21 +03:00
Files
postgres/src/pl/plperl/sql/plperl.sql
Alvaro Herrera fc661f78c6 plperl: Skip setting UTF8 flag when in SQL_ASCII encoding
When in SQL_ASCII encoding, strings passed around are not necessarily
UTF8-safe.  We had already fixed this in some places, but it looks like
we missed some.

I had to backpatch Peter Eisentraut's a8b92b60 to 9.1 in order for this
patch to cherry-pick more cleanly.

Patch from Alex Hunsaker, tweaked by Kyotaro HORIGUCHI and myself.

Some desultory cleanup and comment addition by me, during patch review.

Per bug report from Christoph Berg in
20120209102116.GA14429@msgid.df7cb.de
2012-07-10 15:50:58 -04:00

465 lines
12 KiB
PL/PgSQL

--
-- 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();