2
-- Test result value processing
5
CREATE OR REPLACE FUNCTION perl_int(int) RETURNS INTEGER AS $$
10
SELECT * FROM perl_int(42);
12
CREATE OR REPLACE FUNCTION perl_int(int) RETURNS INTEGER AS $$
17
SELECT * FROM perl_int(42);
20
CREATE OR REPLACE FUNCTION perl_set_int(int) RETURNS SETOF INTEGER AS $$
24
SELECT perl_set_int(5);
25
SELECT * FROM perl_set_int(5);
27
CREATE OR REPLACE FUNCTION perl_set_int(int) RETURNS SETOF INTEGER AS $$
31
SELECT perl_set_int(5);
32
SELECT * FROM perl_set_int(5);
35
CREATE TYPE testnestperl AS (f5 integer[]);
36
CREATE TYPE testrowperl AS (f1 integer, f2 text, f3 text, f4 testnestperl);
38
CREATE OR REPLACE FUNCTION perl_row() RETURNS testrowperl AS $$
43
SELECT * FROM perl_row();
46
CREATE OR REPLACE FUNCTION perl_row() RETURNS testrowperl AS $$
47
return {f2 => 'hello', f1 => 1, f3 => 'world', 'f4' => { 'f5' => [[1]] } };
51
SELECT * FROM perl_row();
53
-- test returning a composite literal
54
CREATE OR REPLACE FUNCTION perl_row_lit() RETURNS testrowperl AS $$
55
return '(1,hello,world,"({{1}})")';
58
SELECT perl_row_lit();
61
CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
66
SELECT * FROM perl_set();
68
CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
70
{ f1 => 1, f2 => 'Hello', f3 => 'World' },
72
{ f1 => 3, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => {} },
73
{ f1 => 4, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => undef }},
74
{ f1 => 5, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => '{1}' }},
75
{ f1 => 6, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => [1] }},
80
SELECT * FROM perl_set();
82
CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
84
{ f1 => 1, f2 => 'Hello', f3 => 'World' },
85
{ f1 => 2, f2 => 'Hello', f3 => 'PostgreSQL', 'f4' => undef },
86
{ f1 => 3, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => {} },
87
{ f1 => 4, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => undef }},
88
{ f1 => 5, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => '{1}' }},
89
{ f1 => 6, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => [1] }},
90
{ f1 => 7, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => '({1})' },
95
SELECT * FROM perl_set();
97
CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$
101
SELECT perl_record();
102
SELECT * FROM perl_record();
103
SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text, f4 testnestperl);
105
CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$
106
return {f2 => 'hello', f1 => 1, f3 => 'world', 'f4' => { 'f5' => [1] } };
109
SELECT perl_record();
110
SELECT * FROM perl_record();
111
SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text, f4 testnestperl);
114
CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
118
SELECT perl_record_set();
119
SELECT * FROM perl_record_set();
120
SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text);
122
CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
124
{ f1 => 1, f2 => 'Hello', f3 => 'World' },
126
{ f1 => 3, f2 => 'Hello', f3 => 'PL/Perl' }
130
SELECT perl_record_set();
131
SELECT * FROM perl_record_set();
132
SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text);
134
CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
136
{ f1 => 1, f2 => 'Hello', f3 => 'World' },
137
{ f1 => 2, f2 => 'Hello', f3 => 'PostgreSQL' },
138
{ f1 => 3, f2 => 'Hello', f3 => 'PL/Perl' }
142
SELECT perl_record_set();
143
SELECT * FROM perl_record_set();
144
SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text);
146
CREATE OR REPLACE FUNCTION
147
perl_out_params(f1 out integer, f2 out text, f3 out text) AS $$
148
return {f2 => 'hello', f1 => 1, f3 => 'world'};
151
SELECT perl_out_params();
152
SELECT * FROM perl_out_params();
153
SELECT (perl_out_params()).f2;
155
CREATE OR REPLACE FUNCTION
156
perl_out_params_set(out f1 integer, out f2 text, out f3 text)
157
RETURNS SETOF record AS $$
159
{ f1 => 1, f2 => 'Hello', f3 => 'World' },
160
{ f1 => 2, f2 => 'Hello', f3 => 'PostgreSQL' },
161
{ f1 => 3, f2 => 'Hello', f3 => 'PL/Perl' }
165
SELECT perl_out_params_set();
166
SELECT * FROM perl_out_params_set();
167
SELECT (perl_out_params_set()).f3;
170
-- Check behavior with erroneous return values
173
CREATE TYPE footype AS (x INTEGER, y INTEGER);
175
CREATE OR REPLACE FUNCTION foo_good() RETURNS SETOF footype AS $$
182
SELECT * FROM foo_good();
184
CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
185
return {y => 3, z => 4};
188
SELECT * FROM foo_bad();
190
CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
194
SELECT * FROM foo_bad();
196
CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
203
SELECT * FROM foo_bad();
205
CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
209
SELECT * FROM foo_set_bad();
211
CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
212
return {y => 3, z => 4};
215
SELECT * FROM foo_set_bad();
217
CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
224
SELECT * FROM foo_set_bad();
226
CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
232
SELECT * FROM foo_set_bad();
235
-- Check passing a tuple argument
238
CREATE OR REPLACE FUNCTION perl_get_field(footype, text) RETURNS integer AS $$
239
return $_[0]->{$_[1]};
242
SELECT perl_get_field((11,12), 'x');
243
SELECT perl_get_field((11,12), 'y');
244
SELECT perl_get_field((11,12), 'z');
250
CREATE OR REPLACE FUNCTION perl_srf_rn() RETURNS SETOF RECORD AS $$
252
for ("World", "PostgreSQL", "PL/Perl") {
253
return_next({f1=>++$i, f2=>'Hello', f3=>$_});
257
SELECT * from perl_srf_rn() AS (f1 INTEGER, f2 TEXT, f3 TEXT);
260
-- Test spi_query/spi_fetchrow
263
CREATE OR REPLACE FUNCTION perl_spi_func() RETURNS SETOF INTEGER AS $$
264
my $x = spi_query("select 1 as a union select 2 as a");
265
while (defined (my $y = spi_fetchrow($x))) {
266
return_next($y->{a});
270
SELECT * from perl_spi_func();
273
-- Test spi_fetchrow abort
275
CREATE OR REPLACE FUNCTION perl_spi_func2() RETURNS INTEGER AS $$
276
my $x = spi_query("select 1 as a union select 2 as a");
277
spi_cursor_close( $x);
280
SELECT * from perl_spi_func2();
284
--- Test recursion via SPI
288
CREATE OR REPLACE FUNCTION recurse(i int) RETURNS SETOF TEXT LANGUAGE plperl
292
foreach my $x (1..$i)
294
return_next "hello $x";
299
my $cursor = spi_query("select * from recurse($z)");
300
while (defined(my $row = spi_fetchrow($cursor)))
302
return_next "recurse $i: $row->{recurse}";
309
SELECT * FROM recurse(2);
310
SELECT * FROM recurse(3);
314
--- Test array return
316
CREATE OR REPLACE FUNCTION array_of_text() RETURNS TEXT[][]
317
LANGUAGE plperl as $$
318
return [['a"b',undef,'c,d'],['e\\f',undef,'g']];
321
SELECT array_of_text();
324
-- Test spi_prepare/spi_exec_prepared/spi_freeplan
326
CREATE OR REPLACE FUNCTION perl_spi_prepared(INTEGER) RETURNS INTEGER AS $$
327
my $x = spi_prepare('select $1 AS a', 'INTEGER');
328
my $q = spi_exec_prepared( $x, $_[0] + 1);
330
return $q->{rows}->[0]->{a};
332
SELECT * from perl_spi_prepared(42);
335
-- Test spi_prepare/spi_query_prepared/spi_freeplan
337
CREATE OR REPLACE FUNCTION perl_spi_prepared_set(INTEGER, INTEGER) RETURNS SETOF INTEGER AS $$
338
my $x = spi_prepare('SELECT $1 AS a union select $2 as a', 'INT4', 'INT4');
339
my $q = spi_query_prepared( $x, 1+$_[0], 2+$_[1]);
340
while (defined (my $y = spi_fetchrow($q))) {
346
SELECT * from perl_spi_prepared_set(1,2);
349
-- Test prepare with a type with spaces
351
CREATE OR REPLACE FUNCTION perl_spi_prepared_double(double precision) RETURNS double precision AS $$
352
my $x = spi_prepare('SELECT 10.0 * $1 AS a', 'DOUBLE PRECISION');
353
my $q = spi_query_prepared($x,$_[0]);
355
while (defined (my $y = spi_fetchrow($q))) {
361
SELECT perl_spi_prepared_double(4.35) as "double precision";
364
-- Test with a bad type
366
CREATE OR REPLACE FUNCTION perl_spi_prepared_bad(double precision) RETURNS double precision AS $$
367
my $x = spi_prepare('SELECT 10.0 * $1 AS a', 'does_not_exist');
368
my $q = spi_query_prepared($x,$_[0]);
370
while (defined (my $y = spi_fetchrow($q))) {
376
SELECT perl_spi_prepared_bad(4.35) as "double precision";
378
-- Test with a row type
379
CREATE OR REPLACE FUNCTION perl_spi_prepared() RETURNS INTEGER AS $$
380
my $x = spi_prepare('select $1::footype AS a', 'footype');
381
my $q = spi_exec_prepared( $x, '(1, 2)');
383
return $q->{rows}->[0]->{a}->{x};
385
SELECT * from perl_spi_prepared();
387
CREATE OR REPLACE FUNCTION perl_spi_prepared_row(footype) RETURNS footype AS $$
389
my $x = spi_prepare('select $1 AS a', 'footype');
390
my $q = spi_exec_prepared( $x, {}, $footype );
392
return $q->{rows}->[0]->{a};
394
SELECT * from perl_spi_prepared_row('(1, 2)');
396
-- simple test of a DO block
398
$a = 'This is a test';
402
-- check that restricted operations are rejected in a plperl DO block
403
DO $$ system("/nonesuch"); $$ LANGUAGE plperl;
404
DO $$ qx("/nonesuch"); $$ LANGUAGE plperl;
405
DO $$ open my $fh, "</nonesuch"; $$ LANGUAGE plperl;
407
-- check that eval is allowed and eval'd restricted ops are caught
408
DO $$ eval q{chdir '.'}; warn "Caught: $@"; $$ LANGUAGE plperl;
410
-- check that compiling do (dofile opcode) is allowed
411
-- but that executing it for a file not already loaded (via require) dies
412
DO $$ warn do "/dev/null"; $$ LANGUAGE plperl;
414
-- check that we can't "use" a module that's not been loaded already
415
-- compile-time error: "Unable to load blib.pm into plperl"
416
DO $$ use blib; $$ LANGUAGE plperl;
418
-- check that we can "use" a module that has already been loaded
419
-- runtime error: "Can't use string ("foo") as a SCALAR ref while "strict refs" in use
420
DO $do$ use strict; my $name = "foo"; my $ref = $$name; $do$ LANGUAGE plperl;
422
-- check that we can "use warnings" (in this case to turn a warn into an error)
423
-- yields "ERROR: Useless use of sort in scalar context."
424
DO $do$ use warnings FATAL => qw(void) ; my @y; my $x = sort @y; 1; $do$ LANGUAGE plperl;
426
-- make sure functions marked as VOID without an explicit return work
427
CREATE OR REPLACE FUNCTION myfuncs() RETURNS void AS $$
428
$_SHARED{myquote} = sub {
430
$arg =~ s/(['\\])/\\$1/g;
437
-- make sure we can't return an array as a scalar
438
CREATE OR REPLACE FUNCTION text_arrayref() RETURNS text AS $$
442
SELECT text_arrayref();
444
--- make sure we can't return a hash as a scalar
445
CREATE OR REPLACE FUNCTION text_hashref() RETURNS text AS $$
449
SELECT text_hashref();
451
---- make sure we can't return a blessed object as a scalar
452
CREATE OR REPLACE FUNCTION text_obj() RETURNS text AS $$
453
return bless({}, 'Fake::Object');
458
----- make sure we can't return a scalar ref
459
CREATE OR REPLACE FUNCTION text_scalarref() RETURNS text AS $$
464
SELECT text_scalarref();
466
-- check safe behavior when a function body is replaced during execution
467
CREATE OR REPLACE FUNCTION self_modify(INTEGER) RETURNS INTEGER AS $$
468
spi_exec_query('CREATE OR REPLACE FUNCTION self_modify(INTEGER) RETURNS INTEGER AS \'return $_[0] * 3;\' LANGUAGE plperl;');
469
spi_exec_query('select self_modify(42) AS a');
473
SELECT self_modify(42);
474
SELECT self_modify(42);
added
removed
.pc/00git-perl5.18.patch/src/pl/plperl/sql/plperl.sql
