1-- 2-- Test result value processing 3-- 4 5CREATE OR REPLACE FUNCTION perl_int(int) RETURNS INTEGER AS $$ 6return undef; 7$$ LANGUAGE plperl; 8 9SELECT perl_int(11); 10SELECT * FROM perl_int(42); 11 12CREATE OR REPLACE FUNCTION perl_int(int) RETURNS INTEGER AS $$ 13return $_[0] + 1; 14$$ LANGUAGE plperl; 15 16SELECT perl_int(11); 17SELECT * FROM perl_int(42); 18 19 20CREATE OR REPLACE FUNCTION perl_set_int(int) RETURNS SETOF INTEGER AS $$ 21return undef; 22$$ LANGUAGE plperl; 23 24SELECT perl_set_int(5); 25SELECT * FROM perl_set_int(5); 26 27CREATE OR REPLACE FUNCTION perl_set_int(int) RETURNS SETOF INTEGER AS $$ 28return [0..$_[0]]; 29$$ LANGUAGE plperl; 30 31SELECT perl_set_int(5); 32SELECT * FROM perl_set_int(5); 33 34 35CREATE TYPE testnestperl AS (f5 integer[]); 36CREATE TYPE testrowperl AS (f1 integer, f2 text, f3 text, f4 testnestperl); 37 38CREATE OR REPLACE FUNCTION perl_row() RETURNS testrowperl AS $$ 39 return undef; 40$$ LANGUAGE plperl; 41 42SELECT perl_row(); 43SELECT * FROM perl_row(); 44 45 46CREATE OR REPLACE FUNCTION perl_row() RETURNS testrowperl AS $$ 47 return {f2 => 'hello', f1 => 1, f3 => 'world', 'f4' => { 'f5' => [[1]] } }; 48$$ LANGUAGE plperl; 49 50SELECT perl_row(); 51SELECT * FROM perl_row(); 52 53-- test returning a composite literal 54CREATE OR REPLACE FUNCTION perl_row_lit() RETURNS testrowperl AS $$ 55 return '(1,hello,world,"({{1}})")'; 56$$ LANGUAGE plperl; 57 58SELECT perl_row_lit(); 59 60 61CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$ 62 return undef; 63$$ LANGUAGE plperl; 64 65SELECT perl_set(); 66SELECT * FROM perl_set(); 67 68CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$ 69 return [ 70 { f1 => 1, f2 => 'Hello', f3 => 'World' }, 71 undef, 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] }}, 76 ]; 77$$ LANGUAGE plperl; 78 79SELECT perl_set(); 80SELECT * FROM perl_set(); 81 82CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$ 83 return [ 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})' }, 91 ]; 92$$ LANGUAGE plperl; 93 94SELECT perl_set(); 95SELECT * FROM perl_set(); 96 97CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$ 98 return undef; 99$$ LANGUAGE plperl; 100 101SELECT perl_record(); 102SELECT * FROM perl_record(); 103SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text, f4 testnestperl); 104 105CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$ 106 return {f2 => 'hello', f1 => 1, f3 => 'world', 'f4' => { 'f5' => [1] } }; 107$$ LANGUAGE plperl; 108 109SELECT perl_record(); 110SELECT * FROM perl_record(); 111SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text, f4 testnestperl); 112 113 114CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$ 115 return undef; 116$$ LANGUAGE plperl; 117 118SELECT perl_record_set(); 119SELECT * FROM perl_record_set(); 120SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text); 121 122CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$ 123 return [ 124 { f1 => 1, f2 => 'Hello', f3 => 'World' }, 125 undef, 126 { f1 => 3, f2 => 'Hello', f3 => 'PL/Perl' } 127 ]; 128$$ LANGUAGE plperl; 129 130SELECT perl_record_set(); 131SELECT * FROM perl_record_set(); 132SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text); 133 134CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$ 135 return [ 136 { f1 => 1, f2 => 'Hello', f3 => 'World' }, 137 { f1 => 2, f2 => 'Hello', f3 => 'PostgreSQL' }, 138 { f1 => 3, f2 => 'Hello', f3 => 'PL/Perl' } 139 ]; 140$$ LANGUAGE plperl; 141 142SELECT perl_record_set(); 143SELECT * FROM perl_record_set(); 144SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text); 145 146CREATE OR REPLACE FUNCTION 147perl_out_params(f1 out integer, f2 out text, f3 out text) AS $$ 148 return {f2 => 'hello', f1 => 1, f3 => 'world'}; 149$$ LANGUAGE plperl; 150 151SELECT perl_out_params(); 152SELECT * FROM perl_out_params(); 153SELECT (perl_out_params()).f2; 154 155CREATE OR REPLACE FUNCTION 156perl_out_params_set(out f1 integer, out f2 text, out f3 text) 157RETURNS SETOF record AS $$ 158 return [ 159 { f1 => 1, f2 => 'Hello', f3 => 'World' }, 160 { f1 => 2, f2 => 'Hello', f3 => 'PostgreSQL' }, 161 { f1 => 3, f2 => 'Hello', f3 => 'PL/Perl' } 162 ]; 163$$ LANGUAGE plperl; 164 165SELECT perl_out_params_set(); 166SELECT * FROM perl_out_params_set(); 167SELECT (perl_out_params_set()).f3; 168 169-- 170-- Check behavior with erroneous return values 171-- 172 173CREATE TYPE footype AS (x INTEGER, y INTEGER); 174 175CREATE OR REPLACE FUNCTION foo_good() RETURNS SETOF footype AS $$ 176return [ 177 {x => 1, y => 2}, 178 {x => 3, y => 4} 179]; 180$$ LANGUAGE plperl; 181 182SELECT * FROM foo_good(); 183 184CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$ 185 return {y => 3, z => 4}; 186$$ LANGUAGE plperl; 187 188SELECT * FROM foo_bad(); 189 190CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$ 191return 42; 192$$ LANGUAGE plperl; 193 194SELECT * FROM foo_bad(); 195 196CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$ 197return [ 198 [1, 2], 199 [3, 4] 200]; 201$$ LANGUAGE plperl; 202 203SELECT * FROM foo_bad(); 204 205CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ 206 return 42; 207$$ LANGUAGE plperl; 208 209SELECT * FROM foo_set_bad(); 210 211CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ 212 return {y => 3, z => 4}; 213$$ LANGUAGE plperl; 214 215SELECT * FROM foo_set_bad(); 216 217CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ 218return [ 219 [1, 2], 220 [3, 4] 221]; 222$$ LANGUAGE plperl; 223 224SELECT * FROM foo_set_bad(); 225 226CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ 227return [ 228 {y => 3, z => 4} 229]; 230$$ LANGUAGE plperl; 231 232SELECT * FROM foo_set_bad(); 233 234CREATE DOMAIN orderedfootype AS footype CHECK ((VALUE).x <= (VALUE).y); 235 236CREATE OR REPLACE FUNCTION foo_ordered() RETURNS orderedfootype AS $$ 237 return {x => 3, y => 4}; 238$$ LANGUAGE plperl; 239 240SELECT * FROM foo_ordered(); 241 242CREATE OR REPLACE FUNCTION foo_ordered() RETURNS orderedfootype AS $$ 243 return {x => 5, y => 4}; 244$$ LANGUAGE plperl; 245 246SELECT * FROM foo_ordered(); -- fail 247 248CREATE OR REPLACE FUNCTION foo_ordered_set() RETURNS SETOF orderedfootype AS $$ 249return [ 250 {x => 3, y => 4}, 251 {x => 4, y => 7} 252]; 253$$ LANGUAGE plperl; 254 255SELECT * FROM foo_ordered_set(); 256 257CREATE OR REPLACE FUNCTION foo_ordered_set() RETURNS SETOF orderedfootype AS $$ 258return [ 259 {x => 3, y => 4}, 260 {x => 9, y => 7} 261]; 262$$ LANGUAGE plperl; 263 264SELECT * FROM foo_ordered_set(); -- fail 265 266-- 267-- Check passing a tuple argument 268-- 269 270CREATE OR REPLACE FUNCTION perl_get_field(footype, text) RETURNS integer AS $$ 271 return $_[0]->{$_[1]}; 272$$ LANGUAGE plperl; 273 274SELECT perl_get_field((11,12), 'x'); 275SELECT perl_get_field((11,12), 'y'); 276SELECT perl_get_field((11,12), 'z'); 277 278CREATE OR REPLACE FUNCTION perl_get_cfield(orderedfootype, text) RETURNS integer AS $$ 279 return $_[0]->{$_[1]}; 280$$ LANGUAGE plperl; 281 282SELECT perl_get_cfield((11,12), 'x'); 283SELECT perl_get_cfield((11,12), 'y'); 284SELECT perl_get_cfield((12,11), 'x'); -- fail 285 286CREATE OR REPLACE FUNCTION perl_get_rfield(record, text) RETURNS integer AS $$ 287 return $_[0]->{$_[1]}; 288$$ LANGUAGE plperl; 289 290SELECT perl_get_rfield((11,12), 'f1'); 291SELECT perl_get_rfield((11,12)::footype, 'y'); 292SELECT perl_get_rfield((11,12)::orderedfootype, 'x'); 293SELECT perl_get_rfield((12,11)::orderedfootype, 'x'); -- fail 294 295-- 296-- Test return_next 297-- 298 299CREATE OR REPLACE FUNCTION perl_srf_rn() RETURNS SETOF RECORD AS $$ 300my $i = 0; 301for ("World", "PostgreSQL", "PL/Perl") { 302 return_next({f1=>++$i, f2=>'Hello', f3=>$_}); 303} 304return; 305$$ language plperl; 306SELECT * from perl_srf_rn() AS (f1 INTEGER, f2 TEXT, f3 TEXT); 307 308-- 309-- Test spi_query/spi_fetchrow 310-- 311 312CREATE OR REPLACE FUNCTION perl_spi_func() RETURNS SETOF INTEGER AS $$ 313my $x = spi_query("select 1 as a union select 2 as a"); 314while (defined (my $y = spi_fetchrow($x))) { 315 return_next($y->{a}); 316} 317return; 318$$ LANGUAGE plperl; 319SELECT * from perl_spi_func(); 320 321-- 322-- Test spi_fetchrow abort 323-- 324CREATE OR REPLACE FUNCTION perl_spi_func2() RETURNS INTEGER AS $$ 325my $x = spi_query("select 1 as a union select 2 as a"); 326spi_cursor_close( $x); 327return 0; 328$$ LANGUAGE plperl; 329SELECT * from perl_spi_func2(); 330 331 332--- 333--- Test recursion via SPI 334--- 335 336 337CREATE OR REPLACE FUNCTION recurse(i int) RETURNS SETOF TEXT LANGUAGE plperl 338AS $$ 339 340 my $i = shift; 341 foreach my $x (1..$i) 342 { 343 return_next "hello $x"; 344 } 345 if ($i > 2) 346 { 347 my $z = $i-1; 348 my $cursor = spi_query("select * from recurse($z)"); 349 while (defined(my $row = spi_fetchrow($cursor))) 350 { 351 return_next "recurse $i: $row->{recurse}"; 352 } 353 } 354 return undef; 355 356$$; 357 358SELECT * FROM recurse(2); 359SELECT * FROM recurse(3); 360 361 362--- 363--- Test array return 364--- 365CREATE OR REPLACE FUNCTION array_of_text() RETURNS TEXT[][] 366LANGUAGE plperl as $$ 367 return [['a"b',undef,'c,d'],['e\\f',undef,'g']]; 368$$; 369 370SELECT array_of_text(); 371 372-- 373-- Test spi_prepare/spi_exec_prepared/spi_freeplan 374-- 375CREATE OR REPLACE FUNCTION perl_spi_prepared(INTEGER) RETURNS INTEGER AS $$ 376 my $x = spi_prepare('select $1 AS a', 'INTEGER'); 377 my $q = spi_exec_prepared( $x, $_[0] + 1); 378 spi_freeplan($x); 379return $q->{rows}->[0]->{a}; 380$$ LANGUAGE plperl; 381SELECT * from perl_spi_prepared(42); 382 383-- 384-- Test spi_prepare/spi_query_prepared/spi_freeplan 385-- 386CREATE OR REPLACE FUNCTION perl_spi_prepared_set(INTEGER, INTEGER) RETURNS SETOF INTEGER AS $$ 387 my $x = spi_prepare('SELECT $1 AS a union select $2 as a', 'INT4', 'INT4'); 388 my $q = spi_query_prepared( $x, 1+$_[0], 2+$_[1]); 389 while (defined (my $y = spi_fetchrow($q))) { 390 return_next $y->{a}; 391 } 392 spi_freeplan($x); 393 return; 394$$ LANGUAGE plperl; 395SELECT * from perl_spi_prepared_set(1,2); 396 397-- 398-- Test prepare with a type with spaces 399-- 400CREATE OR REPLACE FUNCTION perl_spi_prepared_double(double precision) RETURNS double precision AS $$ 401 my $x = spi_prepare('SELECT 10.0 * $1 AS a', 'DOUBLE PRECISION'); 402 my $q = spi_query_prepared($x,$_[0]); 403 my $result; 404 while (defined (my $y = spi_fetchrow($q))) { 405 $result = $y->{a}; 406 } 407 spi_freeplan($x); 408 return $result; 409$$ LANGUAGE plperl; 410SELECT perl_spi_prepared_double(4.35) as "double precision"; 411 412-- 413-- Test with a bad type 414-- 415CREATE OR REPLACE FUNCTION perl_spi_prepared_bad(double precision) RETURNS double precision AS $$ 416 my $x = spi_prepare('SELECT 10.0 * $1 AS a', 'does_not_exist'); 417 my $q = spi_query_prepared($x,$_[0]); 418 my $result; 419 while (defined (my $y = spi_fetchrow($q))) { 420 $result = $y->{a}; 421 } 422 spi_freeplan($x); 423 return $result; 424$$ LANGUAGE plperl; 425SELECT perl_spi_prepared_bad(4.35) as "double precision"; 426 427-- Test with a row type 428CREATE OR REPLACE FUNCTION perl_spi_prepared() RETURNS INTEGER AS $$ 429 my $x = spi_prepare('select $1::footype AS a', 'footype'); 430 my $q = spi_exec_prepared( $x, '(1, 2)'); 431 spi_freeplan($x); 432return $q->{rows}->[0]->{a}->{x}; 433$$ LANGUAGE plperl; 434SELECT * from perl_spi_prepared(); 435 436CREATE OR REPLACE FUNCTION perl_spi_prepared_row(footype) RETURNS footype AS $$ 437 my $footype = shift; 438 my $x = spi_prepare('select $1 AS a', 'footype'); 439 my $q = spi_exec_prepared( $x, {}, $footype ); 440 spi_freeplan($x); 441return $q->{rows}->[0]->{a}; 442$$ LANGUAGE plperl; 443SELECT * from perl_spi_prepared_row('(1, 2)'); 444 445-- simple test of a DO block 446DO $$ 447 $a = 'This is a test'; 448 elog(NOTICE, $a); 449$$ LANGUAGE plperl; 450 451-- check that restricted operations are rejected in a plperl DO block 452DO $$ system("/nonesuch"); $$ LANGUAGE plperl; 453DO $$ qx("/nonesuch"); $$ LANGUAGE plperl; 454DO $$ open my $fh, "</nonesuch"; $$ LANGUAGE plperl; 455 456-- check that eval is allowed and eval'd restricted ops are caught 457DO $$ eval q{chdir '.';}; warn "Caught: $@"; $$ LANGUAGE plperl; 458 459-- check that compiling do (dofile opcode) is allowed 460-- but that executing it for a file not already loaded (via require) dies 461DO $$ warn do "/dev/null"; $$ LANGUAGE plperl; 462 463-- check that we can't "use" a module that's not been loaded already 464-- compile-time error: "Unable to load blib.pm into plperl" 465DO $$ use blib; $$ LANGUAGE plperl; 466 467-- check that we can "use" a module that has already been loaded 468-- runtime error: "Can't use string ("foo") as a SCALAR ref while "strict refs" in use 469DO $do$ use strict; my $name = "foo"; my $ref = $$name; $do$ LANGUAGE plperl; 470 471-- check that we can "use warnings" (in this case to turn a warn into an error) 472-- yields "ERROR: Useless use of sort in scalar context." 473DO $do$ use warnings FATAL => qw(void) ; my @y; my $x = sort @y; 1; $do$ LANGUAGE plperl; 474 475-- make sure functions marked as VOID without an explicit return work 476CREATE OR REPLACE FUNCTION myfuncs() RETURNS void AS $$ 477 $_SHARED{myquote} = sub { 478 my $arg = shift; 479 $arg =~ s/(['\\])/\\$1/g; 480 return "'$arg'"; 481 }; 482$$ LANGUAGE plperl; 483 484SELECT myfuncs(); 485 486-- make sure we can't return an array as a scalar 487CREATE OR REPLACE FUNCTION text_arrayref() RETURNS text AS $$ 488 return ['array']; 489$$ LANGUAGE plperl; 490 491SELECT text_arrayref(); 492 493--- make sure we can't return a hash as a scalar 494CREATE OR REPLACE FUNCTION text_hashref() RETURNS text AS $$ 495 return {'hash'=>1}; 496$$ LANGUAGE plperl; 497 498SELECT text_hashref(); 499 500---- make sure we can't return a blessed object as a scalar 501CREATE OR REPLACE FUNCTION text_obj() RETURNS text AS $$ 502 return bless({}, 'Fake::Object'); 503$$ LANGUAGE plperl; 504 505SELECT text_obj(); 506 507-- test looking through a scalar ref 508CREATE OR REPLACE FUNCTION text_scalarref() RETURNS text AS $$ 509 my $str = 'str'; 510 return \$str; 511$$ LANGUAGE plperl; 512 513SELECT text_scalarref(); 514 515-- check safe behavior when a function body is replaced during execution 516CREATE OR REPLACE FUNCTION self_modify(INTEGER) RETURNS INTEGER AS $$ 517 spi_exec_query('CREATE OR REPLACE FUNCTION self_modify(INTEGER) RETURNS INTEGER AS \'return $_[0] * 3;\' LANGUAGE plperl;'); 518 spi_exec_query('select self_modify(42) AS a'); 519 return $_[0] * 2; 520$$ LANGUAGE plperl; 521 522SELECT self_modify(42); 523SELECT self_modify(42); 524