1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
|
-- 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"
|
