src/pl/plperl/sql/plperl.sql

   1 --
   2 -- Test result value processing
   3 --
   4
   5 CREATE OR REPLACE FUNCTION perl_int(int) RETURNS INTEGER AS $$
   6 return undef;
   7 $$ LANGUAGE plperl;
   8
   9 SELECT perl_int(11);
  10 SELECT * FROM perl_int(42);
  11
  12 CREATE OR REPLACE FUNCTION perl_int(int) RETURNS INTEGER AS $$
  13 return $_[0] + 1;
  14 $$ LANGUAGE plperl;
  15
  16 SELECT perl_int(11);
  17 SELECT * FROM perl_int(42);
  18
  19
  20 CREATE OR REPLACE FUNCTION perl_set_int(int) RETURNS SETOF INTEGER AS $$
  21 return undef;
  22 $$ LANGUAGE plperl;
  23
  24 SELECT perl_set_int(5);
  25 SELECT * FROM perl_set_int(5);
  26
  27 CREATE OR REPLACE FUNCTION perl_set_int(int) RETURNS SETOF INTEGER AS $$
  28 return [0..$_[0]];
  29 $$ LANGUAGE plperl;
  30
  31 SELECT perl_set_int(5);
  32 SELECT * FROM perl_set_int(5);
  33
  34
  35 CREATE TYPE testnestperl AS (f5 integer[]);
  36 CREATE TYPE testrowperl AS (f1 integer, f2 text, f3 text, f4 testnestperl);
  37
  38 CREATE OR REPLACE FUNCTION perl_row() RETURNS testrowperl AS $$
  39     return undef;
  40 $$ LANGUAGE plperl;
  41
  42 SELECT perl_row();
  43 SELECT * FROM perl_row();
  44
  45
  46 CREATE OR REPLACE FUNCTION perl_row() RETURNS testrowperl AS $$
  47     return {f2 => 'hello', f1 => 1, f3 => 'world', 'f4' => { 'f5' => [[1]] } };
  48 $$ LANGUAGE plperl;
  49
  50 SELECT perl_row();
  51 SELECT * FROM perl_row();
  52
  53 -- test returning a composite literal
  54 CREATE OR REPLACE FUNCTION perl_row_lit() RETURNS testrowperl AS $$
  55     return '(1,hello,world,"({{1}})")';
  56 $$ LANGUAGE plperl;
  57
  58 SELECT perl_row_lit();
  59
  60
  61 CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
  62     return undef;
  63 $$  LANGUAGE plperl;
  64
  65 SELECT perl_set();
  66 SELECT * FROM perl_set();
  67
  68 CREATE 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
  79 SELECT perl_set();
  80 SELECT * FROM perl_set();
  81
  82 CREATE 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
  94 SELECT perl_set();
  95 SELECT * FROM perl_set();
  96
  97 CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$
  98     return undef;
  99 $$ LANGUAGE plperl;
 100
 101 SELECT perl_record();
 102 SELECT * FROM perl_record();
 103 SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text, f4 testnestperl);
 104
 105 CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$
 106     return {f2 => 'hello', f1 => 1, f3 => 'world', 'f4' => { 'f5' => [1] } };
 107 $$ LANGUAGE plperl;
 108
 109 SELECT perl_record();
 110 SELECT * FROM perl_record();
 111 SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text, f4 testnestperl);
 112
 113
 114 CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
 115     return undef;
 116 $$  LANGUAGE plperl;
 117
 118 SELECT perl_record_set();
 119 SELECT * FROM perl_record_set();
 120 SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text);
 121
 122 CREATE 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
 130 SELECT perl_record_set();
 131 SELECT * FROM perl_record_set();
 132 SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text);
 133
 134 CREATE 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
 142 SELECT perl_record_set();
 143 SELECT * FROM perl_record_set();
 144 SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text);
 145
 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'};
 149 $$ LANGUAGE plperl;
 150
 151 SELECT perl_out_params();
 152 SELECT * FROM perl_out_params();
 153 SELECT (perl_out_params()).f2;
 154
 155 CREATE OR REPLACE FUNCTION
 156 perl_out_params_set(out f1 integer, out f2 text, out f3 text)
 157 RETURNS 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
 165 SELECT perl_out_params_set();
 166 SELECT * FROM perl_out_params_set();
 167 SELECT (perl_out_params_set()).f3;
 168
 169 --
 170 -- Check behavior with erroneous return values
 171 --
 172
 173 CREATE TYPE footype AS (x INTEGER, y INTEGER);
 174
 175 CREATE OR REPLACE FUNCTION foo_good() RETURNS SETOF footype AS $$
 176 return [
 177     {x => 1, y => 2},
 178     {x => 3, y => 4}
 179 ];
 180 $$ LANGUAGE plperl;
 181
 182 SELECT * FROM foo_good();
 183
 184 CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
 185     return {y => 3, z => 4};
 186 $$ LANGUAGE plperl;
 187
 188 SELECT * FROM foo_bad();
 189
 190 CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
 191 return 42;
 192 $$ LANGUAGE plperl;
 193
 194 SELECT * FROM foo_bad();
 195
 196 CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$
 197 return [
 198     [1, 2],
 199     [3, 4]
 200 ];
 201 $$ LANGUAGE plperl;
 202
 203 SELECT * FROM foo_bad();
 204
 205 CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
 206     return 42;
 207 $$ LANGUAGE plperl;
 208
 209 SELECT * FROM foo_set_bad();
 210
 211 CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
 212     return {y => 3, z => 4};
 213 $$ LANGUAGE plperl;
 214
 215 SELECT * FROM foo_set_bad();
 216
 217 CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
 218 return [
 219     [1, 2],
 220     [3, 4]
 221 ];
 222 $$ LANGUAGE plperl;
 223
 224 SELECT * FROM foo_set_bad();
 225
 226 CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$
 227 return [
 228     {y => 3, z => 4}
 229 ];
 230 $$ LANGUAGE plperl;
 231
 232 SELECT * FROM foo_set_bad();
 233
 234 CREATE DOMAIN orderedfootype AS footype CHECK ((VALUE).x <= (VALUE).y);
 235
 236 CREATE OR REPLACE FUNCTION foo_ordered() RETURNS orderedfootype AS $$
 237     return {x => 3, y => 4};
 238 $$ LANGUAGE plperl;
 239
 240 SELECT * FROM foo_ordered();
 241
 242 CREATE OR REPLACE FUNCTION foo_ordered() RETURNS orderedfootype AS $$
 243     return {x => 5, y => 4};
 244 $$ LANGUAGE plperl;
 245
 246 SELECT * FROM foo_ordered();  -- fail
 247
 248 CREATE OR REPLACE FUNCTION foo_ordered_set() RETURNS SETOF orderedfootype AS $$
 249 return [
 250     {x => 3, y => 4},
 251     {x => 4, y => 7}
 252 ];
 253 $$ LANGUAGE plperl;
 254
 255 SELECT * FROM foo_ordered_set();
 256
 257 CREATE OR REPLACE FUNCTION foo_ordered_set() RETURNS SETOF orderedfootype AS $$
 258 return [
 259     {x => 3, y => 4},
 260     {x => 9, y => 7}
 261 ];
 262 $$ LANGUAGE plperl;
 263
 264 SELECT * FROM foo_ordered_set();  -- fail
 265
 266 --
 267 -- Check passing a tuple argument
 268 --
 269
 270 CREATE OR REPLACE FUNCTION perl_get_field(footype, text) RETURNS integer AS $$
 271     return $_[0]->{$_[1]};
 272 $$ LANGUAGE plperl;
 273
 274 SELECT perl_get_field((11,12), 'x');
 275 SELECT perl_get_field((11,12), 'y');
 276 SELECT perl_get_field((11,12), 'z');
 277
 278 CREATE OR REPLACE FUNCTION perl_get_cfield(orderedfootype, text) RETURNS integer AS $$
 279     return $_[0]->{$_[1]};
 280 $$ LANGUAGE plperl;
 281
 282 SELECT perl_get_cfield((11,12), 'x');
 283 SELECT perl_get_cfield((11,12), 'y');
 284 SELECT perl_get_cfield((12,11), 'x');  -- fail
 285
 286 CREATE OR REPLACE FUNCTION perl_get_rfield(record, text) RETURNS integer AS $$
 287     return $_[0]->{$_[1]};
 288 $$ LANGUAGE plperl;
 289
 290 SELECT perl_get_rfield((11,12), 'f1');
 291 SELECT perl_get_rfield((11,12)::footype, 'y');
 292 SELECT perl_get_rfield((11,12)::orderedfootype, 'x');
 293 SELECT perl_get_rfield((12,11)::orderedfootype, 'x');  -- fail
 294
 295 --
 296 -- Test return_next
 297 --
 298
 299 CREATE OR REPLACE FUNCTION perl_srf_rn() RETURNS SETOF RECORD AS $$
 300 my $i = 0;
 301 for ("World", "PostgreSQL", "PL/Perl") {
 302     return_next({f1=>++$i, f2=>'Hello', f3=>$_});
 303 }
 304 return;
 305 $$ language plperl;
 306 SELECT * from perl_srf_rn() AS (f1 INTEGER, f2 TEXT, f3 TEXT);
 307
 308 --
 309 -- Test spi_query/spi_fetchrow
 310 --
 311
 312 CREATE OR REPLACE FUNCTION perl_spi_func() RETURNS SETOF INTEGER AS $$
 313 my $x = spi_query("select 1 as a union select 2 as a");
 314 while (defined (my $y = spi_fetchrow($x))) {
 315     return_next($y->{a});
 316 }
 317 return;
 318 $$ LANGUAGE plperl;
 319 SELECT * from perl_spi_func();
 320
 321 --
 322 -- Test spi_fetchrow abort
 323 --
 324 CREATE OR REPLACE FUNCTION perl_spi_func2() RETURNS INTEGER AS $$
 325 my $x = spi_query("select 1 as a union select 2 as a");
 326 spi_cursor_close( $x);
 327 return 0;
 328 $$ LANGUAGE plperl;
 329 SELECT * from perl_spi_func2();
 330
 331
 332 ---
 333 --- Test recursion via SPI
 334 ---
 335
 336
 337 CREATE OR REPLACE FUNCTION recurse(i int) RETURNS SETOF TEXT LANGUAGE plperl
 338 AS $$
 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
 358 SELECT * FROM recurse(2);
 359 SELECT * FROM recurse(3);
 360
 361
 362 ---
 363 --- Test array return
 364 ---
 365 CREATE OR REPLACE FUNCTION  array_of_text() RETURNS TEXT[][]
 366 LANGUAGE plperl as $$
 367     return [['a"b',undef,'c,d'],['e\\f',undef,'g']];
 368 $$;
 369
 370 SELECT array_of_text();
 371
 372 --
 373 -- Test spi_prepare/spi_exec_prepared/spi_freeplan
 374 --
 375 CREATE 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);
 379 return $q->{rows}->[0]->{a};
 380 $$ LANGUAGE plperl;
 381 SELECT * from perl_spi_prepared(42);
 382
 383 --
 384 -- Test spi_prepare/spi_query_prepared/spi_freeplan
 385 --
 386 CREATE 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;
 395 SELECT * from perl_spi_prepared_set(1,2);
 396
 397 --
 398 -- Test prepare with a type with spaces
 399 --
 400 CREATE 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;
 410 SELECT perl_spi_prepared_double(4.35) as "double precision";
 411
 412 --
 413 -- Test with a bad type
 414 --
 415 CREATE 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;
 425 SELECT perl_spi_prepared_bad(4.35) as "double precision";
 426
 427 -- Test with a row type
 428 CREATE 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);
 432 return $q->{rows}->[0]->{a}->{x};
 433 $$ LANGUAGE plperl;
 434 SELECT * from perl_spi_prepared();
 435
 436 CREATE 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);
 441 return $q->{rows}->[0]->{a};
 442 $$ LANGUAGE plperl;
 443 SELECT * from perl_spi_prepared_row('(1, 2)');
 444
 445 -- simple test of a DO block
 446 DO $$
 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
 452 DO $$ system("/nonesuch"); $$ LANGUAGE plperl;
 453 DO $$ qx("/nonesuch"); $$ LANGUAGE plperl;
 454 DO $$ open my $fh, "</nonesuch"; $$ LANGUAGE plperl;
 455
 456 -- check that eval is allowed and eval'd restricted ops are caught
 457 DO $$ 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
 461 DO $$ 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"
 465 DO $$ 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
 469 DO $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 void context."
 473 DO $do$ use warnings FATAL => qw(void) ; my @y; sort @y; 1; $do$ LANGUAGE plperl;
 474
 475 -- make sure functions marked as VOID without an explicit return work
 476 CREATE 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
 484 SELECT myfuncs();
 485
 486 -- make sure we can't return an array as a scalar
 487 CREATE OR REPLACE FUNCTION text_arrayref() RETURNS text AS $$
 488         return ['array'];
 489 $$ LANGUAGE plperl;
 490
 491 SELECT text_arrayref();
 492
 493 --- make sure we can't return a hash as a scalar
 494 CREATE OR REPLACE FUNCTION text_hashref() RETURNS text AS $$
 495         return {'hash'=>1};
 496 $$ LANGUAGE plperl;
 497
 498 SELECT text_hashref();
 499
 500 ---- make sure we can't return a blessed object as a scalar
 501 CREATE OR REPLACE FUNCTION text_obj() RETURNS text AS $$
 502         return bless({}, 'Fake::Object');
 503 $$ LANGUAGE plperl;
 504
 505 SELECT text_obj();
 506
 507 -- test looking through a scalar ref
 508 CREATE OR REPLACE FUNCTION text_scalarref() RETURNS text AS $$
 509         my $str = 'str';
 510         return \$str;
 511 $$ LANGUAGE plperl;
 512
 513 SELECT text_scalarref();
 514
 515 -- check safe behavior when a function body is replaced during execution
 516 CREATE 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
 522 SELECT self_modify(42);
 523 SELECT self_modify(42);