src/pl/plperl/sql/plperl_util.sql

   1 -- test plperl utility functions (defined in Util.xs)
   2
   3 -- test quote_literal
   4
   5 create or replace function perl_quote_literal() returns setof text language plperl as $$
   6         return_next "undef: ".quote_literal(undef);
   7         return_next sprintf"$_: ".quote_literal($_)
   8                 for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{};
   9         return undef;
  10 $$;
  11
  12 select perl_quote_literal();
  13
  14 -- test quote_nullable
  15
  16 create or replace function perl_quote_nullable() returns setof text language plperl as $$
  17         return_next "undef: ".quote_nullable(undef);
  18         return_next sprintf"$_: ".quote_nullable($_)
  19                 for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{};
  20         return undef;
  21 $$;
  22
  23 select perl_quote_nullable();
  24
  25 -- test quote_ident
  26
  27 create or replace function perl_quote_ident() returns setof text language plperl as $$
  28         return_next "undef: ".quote_ident(undef); # generates undef warning if warnings enabled
  29         return_next "$_: ".quote_ident($_)
  30                 for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{g.h}, q{};
  31         return undef;
  32 $$;
  33
  34 select perl_quote_ident();
  35
  36 -- test decode_bytea
  37
  38 create or replace function perl_decode_bytea() returns setof text language plperl as $$
  39         return_next "undef: ".decode_bytea(undef); # generates undef warning if warnings enabled
  40         return_next "$_: ".decode_bytea($_)
  41                 for q{foo}, q{a\047b}, q{};
  42         return undef;
  43 $$;
  44
  45 select perl_decode_bytea();
  46
  47 -- test encode_bytea
  48
  49 create or replace function perl_encode_bytea() returns setof text language plperl as $$
  50         return_next encode_bytea(undef); # generates undef warning if warnings enabled
  51         return_next encode_bytea($_)
  52                 for q{@}, qq{@\x01@}, qq{@\x00@}, q{};
  53         return undef;
  54 $$;
  55
  56 select perl_encode_bytea();
  57
  58 -- test encode_array_literal
  59
  60 create or replace function perl_encode_array_literal() returns setof text language plperl as $$
  61         return_next encode_array_literal(undef);
  62         return_next encode_array_literal(0);
  63         return_next encode_array_literal(42);
  64         return_next encode_array_literal($_)
  65                 for [], [0], [1..5], [[]], [[1,2,[3]],4];
  66         return_next encode_array_literal($_,'|')
  67                 for [], [0], [1..5], [[]], [[1,2,[3]],4];
  68         return undef;
  69 $$;
  70
  71 select perl_encode_array_literal();
  72
  73 -- test encode_array_constructor
  74
  75 create or replace function perl_encode_array_constructor() returns setof text language plperl as $$
  76         return_next encode_array_constructor(undef);
  77         return_next encode_array_constructor(0);
  78         return_next encode_array_constructor(42);
  79         return_next encode_array_constructor($_)
  80                 for [], [0], [1..5], [[]], [[1,2,[3]],4];
  81         return undef;
  82 $$;
  83
  84 select perl_encode_array_constructor();
  85
  86 -- test looks_like_number
  87
  88 create or replace function perl_looks_like_number() returns setof text language plperl as $$
  89         return_next "undef is undef" if not defined looks_like_number(undef);
  90         return_next quote_nullable($_).": ". (looks_like_number($_) ? "number" : "not number")
  91                 for 'foo', 0, 1, 1.3, '+3.e-4',
  92                         '42 x', # trailing garbage
  93                         '99  ', # trailing space
  94                         '  99', # leading space
  95                         '    ', # only space
  96                         '';     # empty string
  97         return undef;
  98 $$;
  99
 100 select perl_looks_like_number();
 101
 102 -- test encode_typed_literal
 103 create type perl_foo as (a integer, b text[]);
 104 create type perl_bar as (c perl_foo[]);
 105 create domain perl_foo_pos as perl_foo check((value).a > 0);
 106
 107 create or replace function perl_encode_typed_literal() returns setof text language plperl as $$
 108         return_next encode_typed_literal(undef, 'text');
 109         return_next encode_typed_literal([[1,2,3],[3,2,1],[1,3,2]], 'integer[]');
 110         return_next encode_typed_literal({a => 1, b => ['PL','/','Perl']}, 'perl_foo');
 111         return_next encode_typed_literal({c => [{a => 9, b => ['PostgreSQL']}, {b => ['Postgres'], a => 1}]}, 'perl_bar');
 112         return_next encode_typed_literal({a => 1, b => ['PL','/','Perl']}, 'perl_foo_pos');
 113 $$;
 114
 115 select perl_encode_typed_literal();
 116
 117 create or replace function perl_encode_typed_literal() returns setof text language plperl as $$
 118         return_next encode_typed_literal({a => 0, b => ['PL','/','Perl']}, 'perl_foo_pos');
 119 $$;
 120
 121 select perl_encode_typed_literal();  -- fail