blob: 8b4d8576ec3a09b454af6b876da1e080d5203edd (
plain)
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
|
source [file dirname [info script]]/testing.tcl
needs constraint jim
needs cmd array
needs cmd ref
test alias-1.1 "One word alias" {
set x 2
alias newincr incr
newincr x
} {3}
test alias-1.4 "Two word alias" {
alias infoexists info exists
infoexists x
} {1}
test alias-1.5 "Replace alias" {
alias newincr infoexists
newincr x
} {1}
test alias-1.6 "Delete alias" {
rename newincr ""
catch {newincr x}
} {1}
test alias-1.7 "Replace alias with proc" {
proc infoexists {n} {
return yes
}
infoexists any
} {yes}
test alias-1.8 "Replace proc with alias" {
alias infoexists info exists
infoexists any
} {0}
test alias-1.9 "error message from alias" -body {
alias newstring string
newstring match
} -returnCodes error -result {wrong # args: should be "newstring match ?-nocase? pattern string"}
test curry-1.1 "One word curry" {
set x 2
set one [curry incr]
$one x
} {3}
test curry-1.4 "Two word curry" {
set two [curry info exists]
list [$two x] [$two y]
} {1 0}
test curry-1.5 "Delete curry" {
unset one two
collect
} {2}
test local-1.2 "local curry in proc" {
proc a {} {
local set p [curry info exists]
set x 1
list $p [$p x] [$p y]
}
lassign [a] p exists_x exists_y
list [info procs $p] $exists_x $exists_y
} {{} 1 0}
test local-1.2 "set local curry in proc" {
proc a {} {
set p [local curry info exists]
set x 1
list $p [$p x] [$p y]
}
lassign [a] p exists_x exists_y
list [info procs $p] $exists_x $exists_y
} {{} 1 0}
test local-1.3 "local alias in proc" {
proc a {} {
local alias p info exists
set x 1
list [p x] [p y]
}
lassign [a] exists_x exists_y
list [info commands p] $exists_x $exists_y
} {{} 1 0}
test local-1.5 "local proc in proc" {
set ::x 1
proc a {} {
local proc b {} { incr ::x }
b
set ::x
}
a
list [info procs b] $::x
} {{} 2}
test local-1.6 "local lambda in lsort" {
proc a {} {
lsort -command [local lambda {a b} {string compare $a $b}] {d a f g}
}
a
} {a d f g}
test local-1.7 "check no reference procs" {
info procs "<reference*"
} {}
test local-1.8 "local on non-proc" {
list [catch {local set x blah} msg] $msg
} {1 {not a command: "blah"}}
test local-1.9 "local on existing proc" {
proc x {} {
proc a {b} {incr b}
local function a
set c [lambda b {incr b -1}]
local function $c
lappend result [a 1] [$c 2]
}
set result [x]
list [info procs a] $result
} {{} {2 1}}
test statics-1.1 "missing static variable init" {
unset -nocomplain c
catch {
proc a {b} {c} {
# No initialiser for c
}
}
} 1
test statics-1.2 "static variable with invalid name" {
catch {
proc a {b} "{c\0d 4}" {
}
}
} 1
test statics-1.3 "duplicate static variable" {
catch {
proc a {b} {{c 1} {c 2}} {
}
}
} 1
test statics-1.4 "bad static variable init" {
catch {
proc a {b} {{c 1 2}} {
}
}
} 1
test local-2.1 "proc over existing proc" {
proc a {b} {incr b}
proc t {x} {
proc a {b} {incr b -1}
a $x
}
unset -nocomplain x
lappend x [a 5]
lappend x [t 5]
lappend x [a 5]
} {6 4 4}
test local-2.2 "local proc over existing proc" {
proc a {b} {incr b}
proc t {x} {
local proc a {b} {incr b -1}
a $x
}
unset -nocomplain x
lappend x [a 5]
lappend x [t 5]
lappend x [a 5]
} {6 4 6}
test local-2.3 "local proc over existing proc" {
proc a {b} {incr b}
proc t {x} {
local proc a {b} {incr b -1}
a $x
}
unset -nocomplain x
lappend x [a 5]
lappend x [t 5]
lappend x [a 5]
} {6 4 6}
test upcall-1.1 "upcall pushed proc" {
proc a {b} {incr b}
local proc a {b} {
incr b 10
# invoke the original defn via upcall
return [upcall a $b]
}
# Should call the new defn which will call the original defn
a 3
} 14
test upcall-1.2 "upcall in proc" {
proc a {b} {incr b}
proc t {c} {
local proc a {b} {
incr b 10
return [upcall a $b]
}
a $c
}
unset -nocomplain x
lappend x [t 5]
lappend x [a 5]
set x
} {16 6}
test upcall-1.3 "double upcall" {
proc a {} {return 1}
local proc a {} {list 2 {*}[upcall a]}
local proc a {} {list 3 {*}[upcall a]}
a
} {3 2 1}
test upcall-1.4 "upcall errors" {
proc a {} {return 1}
list [catch {upcall a} msg] $msg
} {1 {no previous command: "a"}}
test upcall-1.4 "upcall errors" {
proc a {} {upcall a}
list [catch a msg] $msg
} {1 {no previous command: "a"}}
testreport
|