-- test plperl utility functions (defined in Util.xs)
-- test quote_literal
create or replace function perl_quote_literal() returns setof text language plperl as $$
 return_next "undef: ".quote_literal(undef);
 return_next sprintf"$_: ".quote_literal($_)
  for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{};
 return undef;
$$;
select perl_quote_literal();
 perl_quote_literal 
--------------------
 undef: 
 foo: 'foo'
 a'b: 'a''b'
 a"b: 'a"b'
 c''d: 'c''''d'
 e\f: E'e\\f'
 : ''
(7 rows)

-- test quote_nullable
create or replace function perl_quote_nullable() returns setof text language plperl as $$
 return_next "undef: ".quote_nullable(undef);
 return_next sprintf"$_: ".quote_nullable($_)
  for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{};
 return undef;
$$;
select perl_quote_nullable();
 perl_quote_nullable 
---------------------
 undef: NULL
 foo: 'foo'
 a'b: 'a''b'
 a"b: 'a"b'
 c''d: 'c''''d'
 e\f: E'e\\f'
 : ''
(7 rows)

-- test quote_ident
create or replace function perl_quote_ident() returns setof text language plperl as $$
 return_next "undef: ".quote_ident(undef); # generates undef warning if warnings enabled
 return_next "$_: ".quote_ident($_)
  for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{g.h}, q{};
 return undef;
$$;
select perl_quote_ident();
 perl_quote_ident 
------------------
 undef: ""
 foo: foo
 a'b: "a'b"
 a"b: "a""b"
 c''d: "c''d"
 e\f: "e\f"
 g.h: "g.h"
 : ""
(8 rows)

-- test decode_bytea
create or replace function perl_decode_bytea() returns setof text language plperl as $$
 return_next "undef: ".decode_bytea(undef); # generates undef warning if warnings enabled
 return_next "$_: ".decode_bytea($_)
  for q{foo}, q{a\047b}, q{};
 return undef;
$$;
select perl_decode_bytea();
 perl_decode_bytea 
-------------------
 undef: 
 foo: foo
 a\047b: a'b
 : 
(4 rows)

-- test encode_bytea
create or replace function perl_encode_bytea() returns setof text language plperl as $$
 return_next encode_bytea(undef); # generates undef warning if warnings enabled
 return_next encode_bytea($_)
  for q{@}, qq{@\x01@}, qq{@\x00@}, q{};
 return undef;
$$;
select perl_encode_bytea();
 perl_encode_bytea 
-------------------
 \x
 \x40
 \x400140
 \x400040
 \x
(5 rows)

-- test encode_array_literal
create or replace function perl_encode_array_literal() returns setof text language plperl as $$
 return_next encode_array_literal(undef);
 return_next encode_array_literal(0);
 return_next encode_array_literal(42);
 return_next encode_array_literal($_)
  for [], [0], [1..5], [[]], [[1,2,[3]],4];
 return_next encode_array_literal($_,'|')
  for [], [0], [1..5], [[]], [[1,2,[3]],4];
 return undef;
$$;
select perl_encode_array_literal();
 perl_encode_array_literal 
---------------------------
 
 0
 42
 {}
 {"0"}
 {"1", "2", "3", "4", "5"}
 {{}}
 {{"1", "2", {"3"}}, "4"}
 {}
 {"0"}
 {"1"|"2"|"3"|"4"|"5"}
 {{}}
 {{"1"|"2"|{"3"}}|"4"}
(13 rows)

-- test encode_array_constructor
create or replace function perl_encode_array_constructor() returns setof text language plperl as $$
 return_next encode_array_constructor(undef);
 return_next encode_array_constructor(0);
 return_next encode_array_constructor(42);
 return_next encode_array_constructor($_)
  for [], [0], [1..5], [[]], [[1,2,[3]],4];
 return undef;
$$;
select perl_encode_array_constructor();
      perl_encode_array_constructor      
-----------------------------------------
 NULL
 '0'
 '42'
 ARRAY[]
 ARRAY['0']
 ARRAY['1', '2', '3', '4', '5']
 ARRAY[ARRAY[]]
 ARRAY[ARRAY['1', '2', ARRAY['3']], '4']
(8 rows)

-- test looks_like_number
create or replace function perl_looks_like_number() returns setof text language plperl as $$
 return_next "undef is undef" if not defined looks_like_number(undef);
 return_next quote_nullable($_).": ". (looks_like_number($_) ? "number" : "not number")
  for 'foo', 0, 1, 1.3, '+3.e-4',
   '42 x', # trailing garbage
   '99  ', # trailing space
   '  99', # leading space
   '    ', # only space
   '';     # empty string
 return undef;
$$;
select perl_looks_like_number();
 perl_looks_like_number 
------------------------
 undef is undef
 'foo': not number
 '0': number
 '1': number
 '1.3': number
 '+3.e-4': number
 '42 x': not number
 '99  ': number
 '  99': number
 '    ': not number
 '': not number
(11 rows)

-- test encode_typed_literal
create type perl_foo as (a integer, b text[]);
create type perl_bar as (c perl_foo[]);
create domain perl_foo_pos as perl_foo check((value).a > 0);
create or replace function perl_encode_typed_literal() returns setof text language plperl as $$
 return_next encode_typed_literal(undef, 'text');
 return_next encode_typed_literal([[1,2,3],[3,2,1],[1,3,2]], 'integer[]');
 return_next encode_typed_literal({a => 1, b => ['PL','/','Perl']}, 'perl_foo');
 return_next encode_typed_literal({c => [{a => 9, b => ['PostgreSQL']}, {b => ['Postgres'], a => 1}]}, 'perl_bar');
 return_next encode_typed_literal({a => 1, b => ['PL','/','Perl']}, 'perl_foo_pos');
$$;
select perl_encode_typed_literal();
           perl_encode_typed_literal           
-----------------------------------------------
 
 {{1,2,3},{3,2,1},{1,3,2}}
 (1,"{PL,/,Perl}")
 ("{""(9,{PostgreSQL})"",""(1,{Postgres})""}")
 (1,"{PL,/,Perl}")
(5 rows)

create or replace function perl_encode_typed_literal() returns setof text language plperl as $$
 return_next encode_typed_literal({a => 0, b => ['PL','/','Perl']}, 'perl_foo_pos');
$$;
select perl_encode_typed_literal();  -- fail
ERROR:  value for domain perl_foo_pos violates check constraint "perl_foo_pos_check"
CONTEXT:  PL/Perl function "perl_encode_typed_literal"