src/pl/plperl/expected/plperl.out

   1 --
   2 -- Test result value processing
   3 --
   4 CREATE OR REPLACE FUNCTION perl_int(int) RETURNS INTEGER AS $$
   5 return undef;
   6 $$ LANGUAGE plperl;
   7 SELECT perl_int(11);
   8  perl_int
   9 ----------
  10
  11 (1 row)
  12
  13 SELECT * FROM perl_int(42);
  14  perl_int
  15 ----------
  16
  17 (1 row)
  18
  19 CREATE OR REPLACE FUNCTION perl_int(int) RETURNS INTEGER AS $$
  20 return $_[0] + 1;
  21 $$ LANGUAGE plperl;
  22 SELECT perl_int(11);
  23  perl_int
  24 ----------
  25        12
  26 (1 row)
  27
  28 SELECT * FROM perl_int(42);
  29  perl_int
  30 ----------
  31        43
  32 (1 row)
  33
  34 CREATE OR REPLACE FUNCTION perl_set_int(int) RETURNS SETOF INTEGER AS $$
  35 return undef;
  36 $$ LANGUAGE plperl;
  37 SELECT perl_set_int(5);
  38  perl_set_int
  39 --------------
  40 (0 rows)
  41
  42 SELECT * FROM perl_set_int(5);
  43  perl_set_int
  44 --------------
  45 (0 rows)
  46
  47 CREATE OR REPLACE FUNCTION perl_set_int(int) RETURNS SETOF INTEGER AS $$
  48 return [0..$_[0]];
  49 $$ LANGUAGE plperl;
  50 SELECT perl_set_int(5);
  51  perl_set_int
  52 --------------
  53             0
  54             1
  55             2
  56             3
  57             4
  58             5
  59 (6 rows)
  60
  61 SELECT * FROM perl_set_int(5);
  62  perl_set_int
  63 --------------
  64             0
  65             1
  66             2
  67             3
  68             4
  69             5
  70 (6 rows)
  71
  72 CREATE TYPE testnestperl AS (f5 integer[]);
  73 CREATE TYPE testrowperl AS (f1 integer, f2 text, f3 text, f4 testnestperl);
  74 CREATE OR REPLACE FUNCTION perl_row() RETURNS testrowperl AS $$
  75     return undef;
  76 $$ LANGUAGE plperl;
  77 SELECT perl_row();
  78  perl_row
  79 ----------
  80
  81 (1 row)
  82
  83 SELECT * FROM perl_row();
  84  f1 | f2 | f3 | f4
  85 ----+----+----+----
  86     |    |    |
  87 (1 row)
  88
  89 CREATE OR REPLACE FUNCTION perl_row() RETURNS testrowperl AS $$
  90     return {f2 => 'hello', f1 => 1, f3 => 'world', 'f4' => { 'f5' => [[1]] } };
  91 $$ LANGUAGE plperl;
  92 SELECT perl_row();
  93          perl_row
  94 ---------------------------
  95  (1,hello,world,"({{1}})")
  96 (1 row)
  97
  98 SELECT * FROM perl_row();
  99  f1 |  f2   |  f3   |   f4
 100 ----+-------+-------+---------
 101   1 | hello | world | ({{1}})
 102 (1 row)
 103
 104 -- test returning a composite literal
 105 CREATE OR REPLACE FUNCTION perl_row_lit() RETURNS testrowperl AS $$
 106     return '(1,hello,world,"({{1}})")';
 107 $$ LANGUAGE plperl;
 108 SELECT perl_row_lit();
 109        perl_row_lit
 110 ---------------------------
 111  (1,hello,world,"({{1}})")
 112 (1 row)
 113
 114 CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
 115     return undef;
 116 $$  LANGUAGE plperl;
 117 SELECT perl_set();
 118  perl_set
 119 ----------
 120 (0 rows)
 121
 122 SELECT * FROM perl_set();
 123  f1 | f2 | f3 | f4
 124 ----+----+----+----
 125 (0 rows)
 126
 127 CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
 128     return [
 129         { f1 => 1, f2 => 'Hello', f3 =>  'World' },
 130         undef,
 131         { f1 => 3, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => {} },
 132         { f1 => 4, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => { 'f5' => undef }},
 133         { f1 => 5, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => { 'f5' => '{1}' }},
 134         { f1 => 6, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => { 'f5' => [1] }},
 135     ];
 136 $$  LANGUAGE plperl;
 137 SELECT perl_set();
 138 ERROR:  SETOF-composite-returning PL/Perl function must call return_next with reference to hash
 139 CONTEXT:  PL/Perl function "perl_set"
 140 SELECT * FROM perl_set();
 141 ERROR:  SETOF-composite-returning PL/Perl function must call return_next with reference to hash
 142 CONTEXT:  PL/Perl function "perl_set"
 143 CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
 144     return [
 145         { f1 => 1, f2 => 'Hello', f3 =>  'World' },
 146         { f1 => 2, f2 => 'Hello', f3 =>  'PostgreSQL', 'f4' => undef },
 147         { f1 => 3, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => {} },
 148         { f1 => 4, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => { 'f5' => undef }},
 149         { f1 => 5, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => { 'f5' => '{1}' }},
 150         { f1 => 6, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => { 'f5' => [1] }},
 151         { f1 => 7, f2 => 'Hello', f3 =>  'PL/Perl', 'f4' => '({1})' },
 152     ];
 153 $$  LANGUAGE plperl;
 154 SELECT perl_set();
 155          perl_set
 156 ---------------------------
 157  (1,Hello,World,)
 158  (2,Hello,PostgreSQL,)
 159  (3,Hello,PL/Perl,"()")
 160  (4,Hello,PL/Perl,"()")
 161  (5,Hello,PL/Perl,"({1})")
 162  (6,Hello,PL/Perl,"({1})")
 163  (7,Hello,PL/Perl,"({1})")
 164 (7 rows)
 165
 166 SELECT * FROM perl_set();
 167  f1 |  f2   |     f3     |  f4
 168 ----+-------+------------+-------
 169   1 | Hello | World      |
 170   2 | Hello | PostgreSQL |
 171   3 | Hello | PL/Perl    | ()
 172   4 | Hello | PL/Perl    | ()
 173   5 | Hello | PL/Perl    | ({1})
 174   6 | Hello | PL/Perl    | ({1})
 175   7 | Hello | PL/Perl    | ({1})
 176 (7 rows)
 177
 178 CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$
 179     return undef;
 180 $$ LANGUAGE plperl;
 181 SELECT perl_record();
 182  perl_record
 183 -------------
 184
 185 (1 row)
 186
 187 SELECT * FROM perl_record();
 188 ERROR:  a column definition list is required for functions returning "record"
 189 LINE 1: SELECT * FROM perl_record();
 190                       ^
 191 SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text, f4 testnestperl);
 192  f1 | f2 | f3 | f4
 193 ----+----+----+----
 194     |    |    |
 195 (1 row)
 196
 197 CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$
 198     return {f2 => 'hello', f1 => 1, f3 => 'world', 'f4' => { 'f5' => [1] } };
 199 $$ LANGUAGE plperl;
 200 SELECT perl_record();
 201 ERROR:  function returning record called in context that cannot accept type record
 202 CONTEXT:  PL/Perl function "perl_record"
 203 SELECT * FROM perl_record();
 204 ERROR:  a column definition list is required for functions returning "record"
 205 LINE 1: SELECT * FROM perl_record();
 206                       ^
 207 SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text, f4 testnestperl);
 208  f1 |  f2   |  f3   |  f4
 209 ----+-------+-------+-------
 210   1 | hello | world | ({1})
 211 (1 row)
 212
 213 CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
 214     return undef;
 215 $$  LANGUAGE plperl;
 216 SELECT perl_record_set();
 217  perl_record_set
 218 -----------------
 219 (0 rows)
 220
 221 SELECT * FROM perl_record_set();
 222 ERROR:  a column definition list is required for functions returning "record"
 223 LINE 1: SELECT * FROM perl_record_set();
 224                       ^
 225 SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text);
 226  f1 | f2 | f3
 227 ----+----+----
 228 (0 rows)
 229
 230 CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
 231     return [
 232         { f1 => 1, f2 => 'Hello', f3 =>  'World' },
 233         undef,
 234         { f1 => 3, f2 => 'Hello', f3 =>  'PL/Perl' }
 235     ];
 236 $$  LANGUAGE plperl;
 237 SELECT perl_record_set();
 238 ERROR:  function returning record called in context that cannot accept type record
 239 CONTEXT:  PL/Perl function "perl_record_set"
 240 SELECT * FROM perl_record_set();
 241 ERROR:  a column definition list is required for functions returning "record"
 242 LINE 1: SELECT * FROM perl_record_set();
 243                       ^
 244 SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text);
 245 ERROR:  SETOF-composite-returning PL/Perl function must call return_next with reference to hash
 246 CONTEXT:  PL/Perl function "perl_record_set"
 247 CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
 248     return [
 249         { f1 => 1, f2 => 'Hello', f3 =>  'World' },
 250         { f1 => 2, f2 => 'Hello', f3 =>  'PostgreSQL' },
 251         { f1 => 3, f2 => 'Hello', f3 =>  'PL/Perl' }
 252     ];
 253 $$  LANGUAGE plperl;
 254 SELECT perl_record_set();
 255 ERROR:  function returning record called in context that cannot accept type record
 256 CONTEXT:  PL/Perl function "perl_record_set"
 257 SELECT * FROM perl_record_set();
 258 ERROR:  a column definition list is required for functions returning "record"
 259 LINE 1: SELECT * FROM perl_record_set();
 260                       ^
 261 SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text);
 262  f1 |  f2   |     f3
 263 ----+-------+------------
 264   1 | Hello | World
 265   2 | Hello | PostgreSQL
 266   3 | Hello | PL/Perl
 267 (3 rows)
 268
 269 CREATE OR REPLACE FUNCTION
 270 perl_out_params(f1 out integer, f2 out text, f3 out text) AS $$
 271     return {f2 => 'hello', f1 => 1, f3 => 'world'};
 272 $$ LANGUAGE plperl;
 273 SELECT perl_out_params();
 274  perl_out_params
 275 -----------------
 276  (1,hello,world)
 277 (1 row)
 278
 279 SELECT * FROM perl_out_params();
 280  f1 |  f2   |  f3
 281 ----+-------+-------
 282   1 | hello | world
 283 (1 row)
 284
 285 SELECT (perl_out_params()).f2;
 286   f2
 287 -------
 288  hello
 289 (1 row)
 290
 291 CREATE OR REPLACE FUNCTION
 292 perl_out_params_set(out f1 integer, out f2 text, out f3 text)
 293 RETURNS SETOF record AS $$
 294     return [
 295         { f1 => 1, f2 => 'Hello', f3 =>  'World' },
 296         { f1 => 2, f2 => 'Hello', f3 =>  'PostgreSQL' },
 297         { f1 => 3, f2 => 'Hello', f3 =>  'PL/Perl' }
 298     ];
 299 $$  LANGUAGE plperl;
 300 SELECT perl_out_params_set();
 301  perl_out_params_set
 302 ----------------------
 303  (1,Hello,World)
 304  (2,Hello,PostgreSQL)
 305  (3,Hello,PL/Perl)
 306 (3 rows)
 307
 308 SELECT * FROM perl_out_params_set();
 309  f1 |  f2   |     f3
 310 ----+-------+------------
 311   1 | Hello | World
 312   2 | Hello | PostgreSQL
 313   3 | Hello | PL/Perl
 314 (3 rows)
 315
 316 SELECT (perl_out_params_set()).f3;
 317      f3
 318 ------------
 319  World
 320  PostgreSQL
 321  PL/Perl
 322 (3 rows)
 323
 324 --
 325 -- Check behavior with erroneous return values
 326 --
 327 CREATE TYPE footype AS (x INTEGER, y INTEGER);
 328 CREATE OR REPLACE FUNCTION foo_good() RETURNS SETOF footype AS $$
 329 return [
 330     {x => 1, y => 2},
 331     {x => 3, y => 4}
 332 ];
 333 $$ LANGUAGE plperl;
 334 SELECT * FROM foo_good();
 335  x | y
 336 ---+---
 337  1 | 2
 338  3 | 4
 339 (2 rows)
 340
 341 CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
 342     return {y => 3, z => 4};
 343 $$ LANGUAGE plperl;
 344 SELECT * FROM foo_bad();
 345 ERROR:  Perl hash contains nonexistent column "z"
 346 CONTEXT:  PL/Perl function "foo_bad"
 347 CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
 348 return 42;
 349 $$ LANGUAGE plperl;
 350 SELECT * FROM foo_bad();
 351 ERROR:  malformed record literal: "42"
 352 DETAIL:  Missing left parenthesis.
 353 CONTEXT:  PL/Perl function "foo_bad"
 354 CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
 355 return [
 356     [1, 2],
 357     [3, 4]
 358 ];
 359 $$ LANGUAGE plperl;
 360 SELECT * FROM foo_bad();
 361 ERROR:  cannot convert Perl array to non-array type footype
 362 CONTEXT:  PL/Perl function "foo_bad"
 363 CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
 364     return 42;
 365 $$ LANGUAGE plperl;
 366 SELECT * FROM foo_set_bad();
 367 ERROR:  set-returning PL/Perl function must return reference to array or use return_next
 368 CONTEXT:  PL/Perl function "foo_set_bad"
 369 CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
 370     return {y => 3, z => 4};
 371 $$ LANGUAGE plperl;
 372 SELECT * FROM foo_set_bad();
 373 ERROR:  set-returning PL/Perl function must return reference to array or use return_next
 374 CONTEXT:  PL/Perl function "foo_set_bad"
 375 CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
 376 return [
 377     [1, 2],
 378     [3, 4]
 379 ];
 380 $$ LANGUAGE plperl;
 381 SELECT * FROM foo_set_bad();
 382 ERROR:  SETOF-composite-returning PL/Perl function must call return_next with reference to hash
 383 CONTEXT:  PL/Perl function "foo_set_bad"
 384 CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
 385 return [
 386     {y => 3, z => 4}
 387 ];
 388 $$ LANGUAGE plperl;
 389 SELECT * FROM foo_set_bad();
 390 ERROR:  Perl hash contains nonexistent column "z"
 391 CONTEXT:  PL/Perl function "foo_set_bad"
 392 CREATE DOMAIN orderedfootype AS footype CHECK ((VALUE).x <= (VALUE).y);
 393 CREATE OR REPLACE FUNCTION foo_ordered() RETURNS orderedfootype AS $$
 394     return {x => 3, y => 4};
 395 $$ LANGUAGE plperl;
 396 SELECT * FROM foo_ordered();
 397  x | y
 398 ---+---
 399  3 | 4
 400 (1 row)
 401
 402 CREATE OR REPLACE FUNCTION foo_ordered() RETURNS orderedfootype AS $$
 403     return {x => 5, y => 4};
 404 $$ LANGUAGE plperl;
 405 SELECT * FROM foo_ordered();  -- fail
 406 ERROR:  value for domain orderedfootype violates check constraint "orderedfootype_check"
 407 CONTEXT:  PL/Perl function "foo_ordered"
 408 CREATE OR REPLACE FUNCTION foo_ordered_set() RETURNS SETOF orderedfootype AS $$
 409 return [
 410     {x => 3, y => 4},
 411     {x => 4, y => 7}
 412 ];
 413 $$ LANGUAGE plperl;
 414 SELECT * FROM foo_ordered_set();
 415  x | y
 416 ---+---
 417  3 | 4
 418  4 | 7
 419 (2 rows)
 420
 421 CREATE OR REPLACE FUNCTION foo_ordered_set() RETURNS SETOF orderedfootype AS $$
 422 return [
 423     {x => 3, y => 4},
 424     {x => 9, y => 7}
 425 ];
 426 $$ LANGUAGE plperl;
 427 SELECT * FROM foo_ordered_set();  -- fail
 428 ERROR:  value for domain orderedfootype violates check constraint "orderedfootype_check"
 429 CONTEXT:  PL/Perl function "foo_ordered_set"
 430 --
 431 -- Check passing a tuple argument
 432 --
 433 CREATE OR REPLACE FUNCTION perl_get_field(footype, text) RETURNS integer AS $$
 434     return $_[0]->{$_[1]};
 435 $$ LANGUAGE plperl;
 436 SELECT perl_get_field((11,12), 'x');
 437  perl_get_field
 438 ----------------
 439              11
 440 (1 row)
 441
 442 SELECT perl_get_field((11,12), 'y');
 443  perl_get_field
 444 ----------------
 445              12
 446 (1 row)
 447
 448 SELECT perl_get_field((11,12), 'z');
 449  perl_get_field
 450 ----------------
 451
 452 (1 row)
 453
 454 CREATE OR REPLACE FUNCTION perl_get_cfield(orderedfootype, text) RETURNS integer AS $$
 455     return $_[0]->{$_[1]};
 456 $$ LANGUAGE plperl;
 457 SELECT perl_get_cfield((11,12), 'x');
 458  perl_get_cfield
 459 -----------------
 460               11
 461 (1 row)
 462
 463 SELECT perl_get_cfield((11,12), 'y');
 464  perl_get_cfield
 465 -----------------
 466               12
 467 (1 row)
 468
 469 SELECT perl_get_cfield((12,11), 'x');  -- fail
 470 ERROR:  value for domain orderedfootype violates check constraint "orderedfootype_check"
 471 CREATE OR REPLACE FUNCTION perl_get_rfield(record, text) RETURNS integer AS $$
 472     return $_[0]->{$_[1]};
 473 $$ LANGUAGE plperl;
 474 SELECT perl_get_rfield((11,12), 'f1');
 475  perl_get_rfield
 476 -----------------
 477               11
 478 (1 row)
 479
 480 SELECT perl_get_rfield((11,12)::footype, 'y');
 481  perl_get_rfield
 482 -----------------
 483               12
 484 (1 row)
 485
 486 SELECT perl_get_rfield((11,12)::orderedfootype, 'x');
 487  perl_get_rfield
 488 -----------------
 489               11
 490 (1 row)
 491
 492 SELECT perl_get_rfield((12,11)::orderedfootype, 'x');  -- fail
 493 ERROR:  value for domain orderedfootype violates check constraint "orderedfootype_check"
 494 --
 495 -- Test return_next
 496 --
 497 CREATE OR REPLACE FUNCTION perl_srf_rn() RETURNS SETOF RECORD AS $$
 498 my $i = 0;
 499 for ("World", "PostgreSQL", "PL/Perl") {
 500     return_next({f1=>++$i, f2=>'Hello', f3=>$_});
 501 }
 502 return;
 503 $$ language plperl;
 504 SELECT * from perl_srf_rn() AS (f1 INTEGER, f2 TEXT, f3 TEXT);
 505  f1 |  f2   |     f3
 506 ----+-------+------------
 507   1 | Hello | World
 508   2 | Hello | PostgreSQL
 509   3 | Hello | PL/Perl
 510 (3 rows)
 511
 512 --
 513 -- Test spi_query/spi_fetchrow
 514 --
 515 CREATE OR REPLACE FUNCTION perl_spi_func() RETURNS SETOF INTEGER AS $$
 516 my $x = spi_query("select 1 as a union select 2 as a");
 517 while (defined (my $y = spi_fetchrow($x))) {
 518     return_next($y->{a});
 519 }
 520 return;
 521 $$ LANGUAGE plperl;
 522 SELECT * from perl_spi_func();
 523  perl_spi_func
 524 ---------------
 525              1
 526              2
 527 (2 rows)
 528
 529 --
 530 -- Test spi_fetchrow abort
 531 --
 532 CREATE OR REPLACE FUNCTION perl_spi_func2() RETURNS INTEGER AS $$
 533 my $x = spi_query("select 1 as a union select 2 as a");
 534 spi_cursor_close( $x);
 535 return 0;
 536 $$ LANGUAGE plperl;
 537 SELECT * from perl_spi_func2();
 538  perl_spi_func2
 539 ----------------
 540               0
 541 (1 row)
 542
 543 ---
 544 --- Test recursion via SPI
 545 ---
 546 CREATE OR REPLACE FUNCTION recurse(i int) RETURNS SETOF TEXT LANGUAGE plperl
 547 AS $$
 548
 549   my $i = shift;
 550   foreach my $x (1..$i)
 551   {
 552     return_next "hello $x";
 553   }
 554   if ($i > 2)
 555   {
 556     my $z = $i-1;
 557     my $cursor = spi_query("select * from recurse($z)");
 558     while (defined(my $row = spi_fetchrow($cursor)))
 559     {
 560       return_next "recurse $i: $row->{recurse}";
 561     }
 562   }
 563   return undef;
 564
 565 $$;
 566 SELECT * FROM recurse(2);
 567  recurse
 568 ---------
 569  hello 1
 570  hello 2
 571 (2 rows)
 572
 573 SELECT * FROM recurse(3);
 574       recurse
 575 --------------------
 576  hello 1
 577  hello 2
 578  hello 3
 579  recurse 3: hello 1
 580  recurse 3: hello 2
 581 (5 rows)
 582
 583 ---
 584 --- Test array return
 585 ---
 586 CREATE OR REPLACE FUNCTION  array_of_text() RETURNS TEXT[][]
 587 LANGUAGE plperl as $$
 588     return [['a"b',undef,'c,d'],['e\\f',undef,'g']];
 589 $$;
 590 SELECT array_of_text();
 591              array_of_text
 592 ---------------------------------------
 593  {{"a\"b",NULL,"c,d"},{"e\\f",NULL,g}}
 594 (1 row)
 595
 596 --
 597 -- Test spi_prepare/spi_exec_prepared/spi_freeplan
 598 --
 599 CREATE OR REPLACE FUNCTION perl_spi_prepared(INTEGER) RETURNS INTEGER AS $$
 600    my $x = spi_prepare('select $1 AS a', 'INTEGER');
 601    my $q = spi_exec_prepared( $x, $_[0] + 1);
 602    spi_freeplan($x);
 603 return $q->{rows}->[0]->{a};
 604 $$ LANGUAGE plperl;
 605 SELECT * from perl_spi_prepared(42);
 606  perl_spi_prepared
 607 -------------------
 608                 43
 609 (1 row)
 610
 611 --
 612 -- Test spi_prepare/spi_query_prepared/spi_freeplan
 613 --
 614 CREATE OR REPLACE FUNCTION perl_spi_prepared_set(INTEGER, INTEGER) RETURNS SETOF INTEGER AS $$
 615   my $x = spi_prepare('SELECT $1 AS a union select $2 as a', 'INT4', 'INT4');
 616   my $q = spi_query_prepared( $x, 1+$_[0], 2+$_[1]);
 617   while (defined (my $y = spi_fetchrow($q))) {
 618       return_next $y->{a};
 619   }
 620   spi_freeplan($x);
 621   return;
 622 $$ LANGUAGE plperl;
 623 SELECT * from perl_spi_prepared_set(1,2);
 624  perl_spi_prepared_set
 625 -----------------------
 626                      2
 627                      4
 628 (2 rows)
 629
 630 --
 631 -- Test prepare with a type with spaces
 632 --
 633 CREATE OR REPLACE FUNCTION perl_spi_prepared_double(double precision) RETURNS double precision AS $$
 634   my $x = spi_prepare('SELECT 10.0 * $1 AS a', 'DOUBLE PRECISION');
 635   my $q = spi_query_prepared($x,$_[0]);
 636   my $result;
 637   while (defined (my $y = spi_fetchrow($q))) {
 638       $result = $y->{a};
 639   }
 640   spi_freeplan($x);
 641   return $result;
 642 $$ LANGUAGE plperl;
 643 SELECT perl_spi_prepared_double(4.35) as "double precision";
 644  double precision
 645 ------------------
 646              43.5
 647 (1 row)
 648
 649 --
 650 -- Test with a bad type
 651 --
 652 CREATE OR REPLACE FUNCTION perl_spi_prepared_bad(double precision) RETURNS double precision AS $$
 653   my $x = spi_prepare('SELECT 10.0 * $1 AS a', 'does_not_exist');
 654   my $q = spi_query_prepared($x,$_[0]);
 655   my $result;
 656   while (defined (my $y = spi_fetchrow($q))) {
 657       $result = $y->{a};
 658   }
 659   spi_freeplan($x);
 660   return $result;
 661 $$ LANGUAGE plperl;
 662 SELECT perl_spi_prepared_bad(4.35) as "double precision";
 663 ERROR:  type "does_not_exist" does not exist at line 2.
 664 CONTEXT:  PL/Perl function "perl_spi_prepared_bad"
 665 -- Test with a row type
 666 CREATE OR REPLACE FUNCTION perl_spi_prepared() RETURNS INTEGER AS $$
 667    my $x = spi_prepare('select $1::footype AS a', 'footype');
 668    my $q = spi_exec_prepared( $x, '(1, 2)');
 669    spi_freeplan($x);
 670 return $q->{rows}->[0]->{a}->{x};
 671 $$ LANGUAGE plperl;
 672 SELECT * from perl_spi_prepared();
 673  perl_spi_prepared
 674 -------------------
 675                  1
 676 (1 row)
 677
 678 CREATE OR REPLACE FUNCTION perl_spi_prepared_row(footype) RETURNS footype AS $$
 679    my $footype = shift;
 680    my $x = spi_prepare('select $1 AS a', 'footype');
 681    my $q = spi_exec_prepared( $x, {}, $footype );
 682    spi_freeplan($x);
 683 return $q->{rows}->[0]->{a};
 684 $$ LANGUAGE plperl;
 685 SELECT * from perl_spi_prepared_row('(1, 2)');
 686  x | y
 687 ---+---
 688  1 | 2
 689 (1 row)
 690
 691 -- simple test of a DO block
 692 DO $$
 693   $a = 'This is a test';
 694   elog(NOTICE, $a);
 695 $$ LANGUAGE plperl;
 696 NOTICE:  This is a test
 697 -- check that restricted operations are rejected in a plperl DO block
 698 DO $$ system("/nonesuch"); $$ LANGUAGE plperl;
 699 ERROR:  'system' trapped by operation mask at line 1.
 700 CONTEXT:  PL/Perl anonymous code block
 701 DO $$ qx("/nonesuch"); $$ LANGUAGE plperl;
 702 ERROR:  'quoted execution (``, qx)' trapped by operation mask at line 1.
 703 CONTEXT:  PL/Perl anonymous code block
 704 DO $$ open my $fh, "</nonesuch"; $$ LANGUAGE plperl;
 705 ERROR:  'open' trapped by operation mask at line 1.
 706 CONTEXT:  PL/Perl anonymous code block
 707 -- check that eval is allowed and eval'd restricted ops are caught
 708 DO $$ eval q{chdir '.';}; warn "Caught: $@"; $$ LANGUAGE plperl;
 709 WARNING:  Caught: 'chdir' trapped by operation mask at line 1.
 710 -- check that compiling do (dofile opcode) is allowed
 711 -- but that executing it for a file not already loaded (via require) dies
 712 DO $$ warn do "/dev/null"; $$ LANGUAGE plperl;
 713 ERROR:  Unable to load /dev/null into plperl at line 1.
 714 CONTEXT:  PL/Perl anonymous code block
 715 -- check that we can't "use" a module that's not been loaded already
 716 -- compile-time error: "Unable to load blib.pm into plperl"
 717 DO $$ use blib; $$ LANGUAGE plperl;
 718 ERROR:  Unable to load blib.pm into plperl at line 1.
 719 BEGIN failed--compilation aborted at line 1.
 720 CONTEXT:  PL/Perl anonymous code block
 721 -- check that we can "use" a module that has already been loaded
 722 -- runtime error: "Can't use string ("foo") as a SCALAR ref while "strict refs" in use
 723 DO $do$ use strict; my $name = "foo"; my $ref = $$name; $do$ LANGUAGE plperl;
 724 ERROR:  Can't use string ("foo") as a SCALAR ref while "strict refs" in use at line 1.
 725 CONTEXT:  PL/Perl anonymous code block
 726 -- check that we can "use warnings" (in this case to turn a warn into an error)
 727 -- yields "ERROR:  Useless use of sort in void context."
 728 DO $do$ use warnings FATAL => qw(void) ; my @y; sort @y; 1; $do$ LANGUAGE plperl;
 729 ERROR:  Useless use of sort in void context at line 1.
 730 CONTEXT:  PL/Perl anonymous code block
 731 -- make sure functions marked as VOID without an explicit return work
 732 CREATE OR REPLACE FUNCTION myfuncs() RETURNS void AS $$
 733    $_SHARED{myquote} = sub {
 734        my $arg = shift;
 735        $arg =~ s/(['\\])/\\$1/g;
 736        return "'$arg'";
 737    };
 738 $$ LANGUAGE plperl;
 739 SELECT myfuncs();
 740  myfuncs
 741 ---------
 742
 743 (1 row)
 744
 745 -- make sure we can't return an array as a scalar
 746 CREATE OR REPLACE FUNCTION text_arrayref() RETURNS text AS $$
 747         return ['array'];
 748 $$ LANGUAGE plperl;
 749 SELECT text_arrayref();
 750 ERROR:  cannot convert Perl array to non-array type text
 751 CONTEXT:  PL/Perl function "text_arrayref"
 752 --- make sure we can't return a hash as a scalar
 753 CREATE OR REPLACE FUNCTION text_hashref() RETURNS text AS $$
 754         return {'hash'=>1};
 755 $$ LANGUAGE plperl;
 756 SELECT text_hashref();
 757 ERROR:  cannot convert Perl hash to non-composite type text
 758 CONTEXT:  PL/Perl function "text_hashref"
 759 ---- make sure we can't return a blessed object as a scalar
 760 CREATE OR REPLACE FUNCTION text_obj() RETURNS text AS $$
 761         return bless({}, 'Fake::Object');
 762 $$ LANGUAGE plperl;
 763 SELECT text_obj();
 764 ERROR:  cannot convert Perl hash to non-composite type text
 765 CONTEXT:  PL/Perl function "text_obj"
 766 -- test looking through a scalar ref
 767 CREATE OR REPLACE FUNCTION text_scalarref() RETURNS text AS $$
 768         my $str = 'str';
 769         return \$str;
 770 $$ LANGUAGE plperl;
 771 SELECT text_scalarref();
 772  text_scalarref
 773 ----------------
 774  str
 775 (1 row)
 776
 777 -- check safe behavior when a function body is replaced during execution
 778 CREATE OR REPLACE FUNCTION self_modify(INTEGER) RETURNS INTEGER AS $$
 779    spi_exec_query('CREATE OR REPLACE FUNCTION self_modify(INTEGER) RETURNS INTEGER AS \'return $_[0] * 3;\' LANGUAGE plperl;');
 780    spi_exec_query('select self_modify(42) AS a');
 781    return $_[0] * 2;
 782 $$ LANGUAGE plperl;
 783 SELECT self_modify(42);
 784  self_modify
 785 -------------
 786           84
 787 (1 row)
 788
 789 SELECT self_modify(42);
 790  self_modify
 791 -------------
 792          126
 793 (1 row)
 794