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
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
|
create table T_comp1 (
tkey char(10),
ref1 int4,
ref2 char(20)
);
create function tcl_composite_arg_ref1(T_comp1) returns int as '
return $1(ref1)
' language pltcl;
create function tcl_composite_arg_ref2(T_comp1) returns text as '
return $1(ref2)
' language pltcl;
create function tcl_argisnull(text) returns bool as '
argisnull 1
' language pltcl;
create function tcl_int4add(int4,int4) returns int4 as '
return [expr $1 + $2]
' language pltcl;
-- We use split(n) as a quick-and-dirty way of parsing the input array
-- value, which comes in as a string like '{1,2}'. There are better ways...
create function tcl_int4_accum(int4[], int4) returns int4[] as '
set state [split $1 "{,}"]
set newsum [expr {[lindex $state 1] + $2}]
set newcnt [expr {[lindex $state 2] + 1}]
return "{$newsum,$newcnt}"
' language pltcl;
create function tcl_int4_avg(int4[]) returns int4 as '
set state [split $1 "{,}"]
if {[lindex $state 2] == 0} { return_null }
return [expr {[lindex $state 1] / [lindex $state 2]}]
' language pltcl;
create aggregate tcl_avg (
sfunc = tcl_int4_accum,
basetype = int4,
stype = int4[],
finalfunc = tcl_int4_avg,
initcond = '{0,0}'
);
create aggregate tcl_sum (
sfunc = tcl_int4add,
basetype = int4,
stype = int4,
initcond1 = 0
);
create function tcl_int4lt(int4,int4) returns bool as '
if {$1 < $2} {
return t
}
return f
' language pltcl;
create function tcl_int4le(int4,int4) returns bool as '
if {$1 <= $2} {
return t
}
return f
' language pltcl;
create function tcl_int4eq(int4,int4) returns bool as '
if {$1 == $2} {
return t
}
return f
' language pltcl;
create function tcl_int4ge(int4,int4) returns bool as '
if {$1 >= $2} {
return t
}
return f
' language pltcl;
create function tcl_int4gt(int4,int4) returns bool as '
if {$1 > $2} {
return t
}
return f
' language pltcl;
create operator @< (
leftarg = int4,
rightarg = int4,
procedure = tcl_int4lt
);
create operator @<= (
leftarg = int4,
rightarg = int4,
procedure = tcl_int4le
);
create operator @= (
leftarg = int4,
rightarg = int4,
procedure = tcl_int4eq
);
create operator @>= (
leftarg = int4,
rightarg = int4,
procedure = tcl_int4ge
);
create operator @> (
leftarg = int4,
rightarg = int4,
procedure = tcl_int4gt
);
create function tcl_int4cmp(int4,int4) returns int4 as '
if {$1 < $2} {
return -1
}
if {$1 > $2} {
return 1
}
return 0
' language pltcl;
CREATE OPERATOR CLASS tcl_int4_ops
FOR TYPE int4 USING btree AS
OPERATOR 1 @<,
OPERATOR 2 @<=,
OPERATOR 3 @=,
OPERATOR 4 @>=,
OPERATOR 5 @>,
FUNCTION 1 tcl_int4cmp(int4,int4) ;
--
-- Test usage of Tcl's "clock" command. In recent Tcl versions this
-- command fails without working "unknown" support, so it's a good canary
-- for initialization problems.
--
create function tcl_date_week(int4,int4,int4) returns text as $$
return [clock format [clock scan "$2/$3/$1"] -format "%U"]
$$ language pltcl immutable;
select tcl_date_week(2010,1,26);
tcl_date_week
---------------
04
(1 row)
select tcl_date_week(2001,10,24);
tcl_date_week
---------------
42
(1 row)
-- test pltcl event triggers
create function tclsnitch() returns event_trigger language pltcl as $$
elog NOTICE "tclsnitch: $TG_event $TG_tag"
$$;
create event trigger tcl_a_snitch on ddl_command_start execute procedure tclsnitch();
create event trigger tcl_b_snitch on ddl_command_end execute procedure tclsnitch();
create function foobar() returns int language sql as $$select 1;$$;
NOTICE: tclsnitch: ddl_command_start CREATE FUNCTION
NOTICE: tclsnitch: ddl_command_end CREATE FUNCTION
alter function foobar() cost 77;
NOTICE: tclsnitch: ddl_command_start ALTER FUNCTION
NOTICE: tclsnitch: ddl_command_end ALTER FUNCTION
drop function foobar();
NOTICE: tclsnitch: ddl_command_start DROP FUNCTION
NOTICE: tclsnitch: ddl_command_end DROP FUNCTION
create table foo();
NOTICE: tclsnitch: ddl_command_start CREATE TABLE
NOTICE: tclsnitch: ddl_command_end CREATE TABLE
drop table foo;
NOTICE: tclsnitch: ddl_command_start DROP TABLE
NOTICE: tclsnitch: ddl_command_end DROP TABLE
drop event trigger tcl_a_snitch;
drop event trigger tcl_b_snitch;
create function tcl_test_cube_squared(in int, out squared int, out cubed int) as $$
return [list squared [expr {$1 * $1}] cubed [expr {$1 * $1 * $1}]]
$$ language pltcl;
create function tcl_test_squared_rows(int,int) returns table (x int, y int) as $$
for {set i $1} {$i < $2} {incr i} {
return_next [list y [expr {$i * $i}] x $i]
}
$$ language pltcl;
create function tcl_test_sequence(int,int) returns setof int as $$
for {set i $1} {$i < $2} {incr i} {
return_next $i
}
$$ language pltcl;
create function tcl_eval(string text) returns text as $$
eval $1
$$ language pltcl;
-- test use of errorCode in error handling
create function tcl_error_handling_test(text) returns text
language pltcl
as $function$
if {[catch $1 err]} {
# If not a Postgres error, just return the basic error message
if {[lindex $::errorCode 0] != "POSTGRES"} {
return $err
}
# Get rid of keys that can't be expected to remain constant
array set myArray $::errorCode
unset myArray(POSTGRES)
unset -nocomplain myArray(funcname)
unset -nocomplain myArray(filename)
unset -nocomplain myArray(lineno)
# Format into something nicer
set vals []
foreach {key} [lsort [array names myArray]] {
set value [string map {"\n" "\n\t"} $myArray($key)]
lappend vals "$key: $value"
}
return [join $vals "\n"]
} else {
return "no error"
}
$function$;
-- test spi_exec and spi_execp with -array
create function tcl_spi_exec(
prepare boolean,
action text
)
returns void language pltcl AS $function$
set query "select * from (values (1,'foo'),(2,'bar'),(3,'baz')) v(col1,col2)"
if {$1 == "t"} {
set prep [spi_prepare $query {}]
spi_execp -array A $prep {
elog NOTICE "col1 $A(col1), col2 $A(col2)"
switch $A(col1) {
2 {
elog NOTICE "action: $2"
switch $2 {
break {
break
}
continue {
continue
}
return {
return
}
error {
error "error message"
}
}
error "should not get here"
}
}
}
} else {
spi_exec -array A $query {
elog NOTICE "col1 $A(col1), col2 $A(col2)"
switch $A(col1) {
2 {
elog NOTICE "action: $2"
switch $2 {
break {
break
}
continue {
continue
}
return {
return
}
error {
error "error message"
}
}
error "should not get here"
}
}
}
}
elog NOTICE "end of function"
$function$;
|
