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 234-- 235-- Check passing a tuple argument 236-- 237 238CREATE OR REPLACE FUNCTION perl_get_field(footype, text) RETURNS integer AS $$ 239 return $_[0]->{$_[1]}; 240$$ LANGUAGE plperl; 241 242SELECT perl_get_field((11,12), 'x'); 243SELECT perl_get_field((11,12), 'y'); 244SELECT perl_get_field((11,12), 'z'); 245 246-- 247-- Test return_next 248-- 249 250CREATE OR REPLACE FUNCTION perl_srf_rn() RETURNS SETOF RECORD AS $$ 251my $i = 0; 252for ("World", "PostgreSQL", "PL/Perl") { 253 return_next({f1=>++$i, f2=>'Hello', f3=>$_}); 254} 255return; 256$$ language plperl; 257SELECT * from perl_srf_rn() AS (f1 INTEGER, f2 TEXT, f3 TEXT); 258 259-- 260-- Test spi_query/spi_fetchrow 261-- 262 263CREATE OR REPLACE FUNCTION perl_spi_func() RETURNS SETOF INTEGER AS $$ 264my $x = spi_query("select 1 as a union select 2 as a"); 265while (defined (my $y = spi_fetchrow($x))) { 266 return_next($y->{a}); 267} 268return; 269$$ LANGUAGE plperl; 270SELECT * from perl_spi_func(); 271 272-- 273-- Test spi_fetchrow abort 274-- 275CREATE OR REPLACE FUNCTION perl_spi_func2() RETURNS INTEGER AS $$ 276my $x = spi_query("select 1 as a union select 2 as a"); 277spi_cursor_close( $x); 278return 0; 279$$ LANGUAGE plperl; 280SELECT * from perl_spi_func2(); 281 282 283--- 284--- Test recursion via SPI 285--- 286 287 288CREATE OR REPLACE FUNCTION recurse(i int) RETURNS SETOF TEXT LANGUAGE plperl 289AS $$ 290 291 my $i = shift; 292 foreach my $x (1..$i) 293 { 294 return_next "hello $x"; 295 } 296 if ($i > 2) 297 { 298 my $z = $i-1; 299 my $cursor = spi_query("select * from recurse($z)"); 300 while (defined(my $row = spi_fetchrow($cursor))) 301 { 302 return_next "recurse $i: $row->{recurse}"; 303 } 304 } 305 return undef; 306 307$$; 308 309SELECT * FROM recurse(2); 310SELECT * FROM recurse(3); 311 312 313--- 314--- Test array return 315--- 316CREATE OR REPLACE FUNCTION array_of_text() RETURNS TEXT[][] 317LANGUAGE plperl as $$ 318 return [['a"b',undef,'c,d'],['e\\f',undef,'g']]; 319$$; 320 321SELECT array_of_text(); 322 323-- 324-- Test spi_prepare/spi_exec_prepared/spi_freeplan 325-- 326CREATE 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); 329 spi_freeplan($x); 330return $q->{rows}->[0]->{a}; 331$$ LANGUAGE plperl; 332SELECT * from perl_spi_prepared(42); 333 334-- 335-- Test spi_prepare/spi_query_prepared/spi_freeplan 336-- 337CREATE 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))) { 341 return_next $y->{a}; 342 } 343 spi_freeplan($x); 344 return; 345$$ LANGUAGE plperl; 346SELECT * from perl_spi_prepared_set(1,2); 347 348-- 349-- Test prepare with a type with spaces 350-- 351CREATE 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]); 354 my $result; 355 while (defined (my $y = spi_fetchrow($q))) { 356 $result = $y->{a}; 357 } 358 spi_freeplan($x); 359 return $result; 360$$ LANGUAGE plperl; 361SELECT perl_spi_prepared_double(4.35) as "double precision"; 362 363-- 364-- Test with a bad type 365-- 366CREATE 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]); 369 my $result; 370 while (defined (my $y = spi_fetchrow($q))) { 371 $result = $y->{a}; 372 } 373 spi_freeplan($x); 374 return $result; 375$$ LANGUAGE plperl; 376SELECT perl_spi_prepared_bad(4.35) as "double precision"; 377 378-- Test with a row type 379CREATE 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)'); 382 spi_freeplan($x); 383return $q->{rows}->[0]->{a}->{x}; 384$$ LANGUAGE plperl; 385SELECT * from perl_spi_prepared(); 386 387CREATE OR REPLACE FUNCTION perl_spi_prepared_row(footype) RETURNS footype AS $$ 388 my $footype = shift; 389 my $x = spi_prepare('select $1 AS a', 'footype'); 390 my $q = spi_exec_prepared( $x, {}, $footype ); 391 spi_freeplan($x); 392return $q->{rows}->[0]->{a}; 393$$ LANGUAGE plperl; 394SELECT * from perl_spi_prepared_row('(1, 2)'); 395 396-- simple test of a DO block 397DO $$ 398 $a = 'This is a test'; 399 elog(NOTICE, $a); 400$$ LANGUAGE plperl; 401 402-- check that restricted operations are rejected in a plperl DO block 403DO $$ system("/nonesuch"); $$ LANGUAGE plperl; 404DO $$ qx("/nonesuch"); $$ LANGUAGE plperl; 405DO $$ open my $fh, "</nonesuch"; $$ LANGUAGE plperl; 406 407-- check that eval is allowed and eval'd restricted ops are caught 408DO $$ eval q{chdir '.';}; warn "Caught: $@"; $$ LANGUAGE plperl; 409 410-- check that compiling do (dofile opcode) is allowed 411-- but that executing it for a file not already loaded (via require) dies 412DO $$ warn do "/dev/null"; $$ LANGUAGE plperl; 413 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" 416DO $$ use blib; $$ LANGUAGE plperl; 417 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 420DO $do$ use strict; my $name = "foo"; my $ref = $$name; $do$ LANGUAGE plperl; 421 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." 424DO $do$ use warnings FATAL => qw(void) ; my @y; my $x = sort @y; 1; $do$ LANGUAGE plperl; 425 426-- make sure functions marked as VOID without an explicit return work 427CREATE OR REPLACE FUNCTION myfuncs() RETURNS void AS $$ 428 $_SHARED{myquote} = sub { 429 my $arg = shift; 430 $arg =~ s/(['\\])/\\$1/g; 431 return "'$arg'"; 432 }; 433$$ LANGUAGE plperl; 434 435SELECT myfuncs(); 436 437-- make sure we can't return an array as a scalar 438CREATE OR REPLACE FUNCTION text_arrayref() RETURNS text AS $$ 439 return ['array']; 440$$ LANGUAGE plperl; 441 442SELECT text_arrayref(); 443 444--- make sure we can't return a hash as a scalar 445CREATE OR REPLACE FUNCTION text_hashref() RETURNS text AS $$ 446 return {'hash'=>1}; 447$$ LANGUAGE plperl; 448 449SELECT text_hashref(); 450 451---- make sure we can't return a blessed object as a scalar 452CREATE OR REPLACE FUNCTION text_obj() RETURNS text AS $$ 453 return bless({}, 'Fake::Object'); 454$$ LANGUAGE plperl; 455 456SELECT text_obj(); 457 458----- make sure we can't return a scalar ref 459CREATE OR REPLACE FUNCTION text_scalarref() RETURNS text AS $$ 460 my $str = 'str'; 461 return \$str; 462$$ LANGUAGE plperl; 463 464SELECT text_scalarref(); 465 466-- check safe behavior when a function body is replaced during execution 467CREATE 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'); 470 return $_[0] * 2; 471$$ LANGUAGE plperl; 472 473SELECT self_modify(42); 474SELECT self_modify(42); 475