|
sl@0
|
1 |
# Commands covered: proc, return, global
|
|
sl@0
|
2 |
#
|
|
sl@0
|
3 |
# This file, proc-old.test, includes the original set of tests for Tcl's
|
|
sl@0
|
4 |
# proc, return, and global commands. There is now a new file proc.test
|
|
sl@0
|
5 |
# that contains tests for the tclProc.c source file.
|
|
sl@0
|
6 |
#
|
|
sl@0
|
7 |
# Sourcing this file into Tcl runs the tests and generates output for
|
|
sl@0
|
8 |
# errors. No output means no errors were found.
|
|
sl@0
|
9 |
#
|
|
sl@0
|
10 |
# Copyright (c) 1991-1993 The Regents of the University of California.
|
|
sl@0
|
11 |
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
|
|
sl@0
|
12 |
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
|
sl@0
|
13 |
#
|
|
sl@0
|
14 |
# See the file "license.terms" for information on usage and redistribution
|
|
sl@0
|
15 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
|
sl@0
|
16 |
#
|
|
sl@0
|
17 |
# RCS: @(#) $Id: proc-old.test,v 1.9.2.1 2003/03/27 21:46:32 msofer Exp $
|
|
sl@0
|
18 |
|
|
sl@0
|
19 |
if {[lsearch [namespace children] ::tcltest] == -1} {
|
|
sl@0
|
20 |
package require tcltest
|
|
sl@0
|
21 |
namespace import -force ::tcltest::*
|
|
sl@0
|
22 |
}
|
|
sl@0
|
23 |
|
|
sl@0
|
24 |
catch {rename t1 ""}
|
|
sl@0
|
25 |
catch {rename foo ""}
|
|
sl@0
|
26 |
|
|
sl@0
|
27 |
proc tproc {} {return a; return b}
|
|
sl@0
|
28 |
test proc-old-1.1 {simple procedure call and return} {tproc} a
|
|
sl@0
|
29 |
proc tproc x {
|
|
sl@0
|
30 |
set x [expr $x+1]
|
|
sl@0
|
31 |
return $x
|
|
sl@0
|
32 |
}
|
|
sl@0
|
33 |
test proc-old-1.2 {simple procedure call and return} {tproc 2} 3
|
|
sl@0
|
34 |
test proc-old-1.3 {simple procedure call and return} {
|
|
sl@0
|
35 |
proc tproc {} {return foo}
|
|
sl@0
|
36 |
} {}
|
|
sl@0
|
37 |
test proc-old-1.4 {simple procedure call and return} {
|
|
sl@0
|
38 |
proc tproc {} {return}
|
|
sl@0
|
39 |
tproc
|
|
sl@0
|
40 |
} {}
|
|
sl@0
|
41 |
proc tproc1 {a} {incr a; return $a}
|
|
sl@0
|
42 |
proc tproc2 {a b} {incr a; return $a}
|
|
sl@0
|
43 |
test proc-old-1.5 {simple procedure call and return (2 procs with same body but different parameters)} {
|
|
sl@0
|
44 |
list [tproc1 123] [tproc2 456 789]
|
|
sl@0
|
45 |
} {124 457}
|
|
sl@0
|
46 |
test proc-old-1.6 {simple procedure call and return (shared proc body string)} {
|
|
sl@0
|
47 |
set x {}
|
|
sl@0
|
48 |
proc tproc {} {} ;# body is shared with x
|
|
sl@0
|
49 |
list [tproc] [append x foo]
|
|
sl@0
|
50 |
} {{} foo}
|
|
sl@0
|
51 |
|
|
sl@0
|
52 |
test proc-old-2.1 {local and global variables} {
|
|
sl@0
|
53 |
proc tproc x {
|
|
sl@0
|
54 |
set x [expr $x+1]
|
|
sl@0
|
55 |
return $x
|
|
sl@0
|
56 |
}
|
|
sl@0
|
57 |
set x 42
|
|
sl@0
|
58 |
list [tproc 6] $x
|
|
sl@0
|
59 |
} {7 42}
|
|
sl@0
|
60 |
test proc-old-2.2 {local and global variables} {
|
|
sl@0
|
61 |
proc tproc x {
|
|
sl@0
|
62 |
set y [expr $x+1]
|
|
sl@0
|
63 |
return $y
|
|
sl@0
|
64 |
}
|
|
sl@0
|
65 |
set y 18
|
|
sl@0
|
66 |
list [tproc 6] $y
|
|
sl@0
|
67 |
} {7 18}
|
|
sl@0
|
68 |
test proc-old-2.3 {local and global variables} {
|
|
sl@0
|
69 |
proc tproc x {
|
|
sl@0
|
70 |
global y
|
|
sl@0
|
71 |
set y [expr $x+1]
|
|
sl@0
|
72 |
return $y
|
|
sl@0
|
73 |
}
|
|
sl@0
|
74 |
set y 189
|
|
sl@0
|
75 |
list [tproc 6] $y
|
|
sl@0
|
76 |
} {7 7}
|
|
sl@0
|
77 |
test proc-old-2.4 {local and global variables} {
|
|
sl@0
|
78 |
proc tproc x {
|
|
sl@0
|
79 |
global y
|
|
sl@0
|
80 |
return [expr $x+$y]
|
|
sl@0
|
81 |
}
|
|
sl@0
|
82 |
set y 189
|
|
sl@0
|
83 |
list [tproc 6] $y
|
|
sl@0
|
84 |
} {195 189}
|
|
sl@0
|
85 |
catch {unset _undefined_}
|
|
sl@0
|
86 |
test proc-old-2.5 {local and global variables} {
|
|
sl@0
|
87 |
proc tproc x {
|
|
sl@0
|
88 |
global _undefined_
|
|
sl@0
|
89 |
return $_undefined_
|
|
sl@0
|
90 |
}
|
|
sl@0
|
91 |
list [catch {tproc xxx} msg] $msg
|
|
sl@0
|
92 |
} {1 {can't read "_undefined_": no such variable}}
|
|
sl@0
|
93 |
test proc-old-2.6 {local and global variables} {
|
|
sl@0
|
94 |
set a 114
|
|
sl@0
|
95 |
set b 115
|
|
sl@0
|
96 |
global a b
|
|
sl@0
|
97 |
list $a $b
|
|
sl@0
|
98 |
} {114 115}
|
|
sl@0
|
99 |
|
|
sl@0
|
100 |
proc do {cmd} {eval $cmd}
|
|
sl@0
|
101 |
test proc-old-3.1 {local and global arrays} {
|
|
sl@0
|
102 |
catch {unset a}
|
|
sl@0
|
103 |
set a(0) 22
|
|
sl@0
|
104 |
list [catch {do {global a; set a(0)}} msg] $msg
|
|
sl@0
|
105 |
} {0 22}
|
|
sl@0
|
106 |
test proc-old-3.2 {local and global arrays} {
|
|
sl@0
|
107 |
catch {unset a}
|
|
sl@0
|
108 |
set a(x) 22
|
|
sl@0
|
109 |
list [catch {do {global a; set a(x) newValue}} msg] $msg $a(x)
|
|
sl@0
|
110 |
} {0 newValue newValue}
|
|
sl@0
|
111 |
test proc-old-3.3 {local and global arrays} {
|
|
sl@0
|
112 |
catch {unset a}
|
|
sl@0
|
113 |
set a(x) 22
|
|
sl@0
|
114 |
set a(y) 33
|
|
sl@0
|
115 |
list [catch {do {global a; unset a(y)}; array names a} msg] $msg
|
|
sl@0
|
116 |
} {0 x}
|
|
sl@0
|
117 |
test proc-old-3.4 {local and global arrays} {
|
|
sl@0
|
118 |
catch {unset a}
|
|
sl@0
|
119 |
set a(x) 22
|
|
sl@0
|
120 |
set a(y) 33
|
|
sl@0
|
121 |
list [catch {do {global a; unset a; info exists a}} msg] $msg \
|
|
sl@0
|
122 |
[info exists a]
|
|
sl@0
|
123 |
} {0 0 0}
|
|
sl@0
|
124 |
test proc-old-3.5 {local and global arrays} {
|
|
sl@0
|
125 |
catch {unset a}
|
|
sl@0
|
126 |
set a(x) 22
|
|
sl@0
|
127 |
set a(y) 33
|
|
sl@0
|
128 |
list [catch {do {global a; unset a(y); array names a}} msg] $msg
|
|
sl@0
|
129 |
} {0 x}
|
|
sl@0
|
130 |
catch {unset a}
|
|
sl@0
|
131 |
test proc-old-3.6 {local and global arrays} {
|
|
sl@0
|
132 |
catch {unset a}
|
|
sl@0
|
133 |
set a(x) 22
|
|
sl@0
|
134 |
set a(y) 33
|
|
sl@0
|
135 |
do {global a; do {global a; unset a}; set a(z) 22}
|
|
sl@0
|
136 |
list [catch {array names a} msg] $msg
|
|
sl@0
|
137 |
} {0 z}
|
|
sl@0
|
138 |
test proc-old-3.7 {local and global arrays} {
|
|
sl@0
|
139 |
proc t1 {args} {global info; set info 1}
|
|
sl@0
|
140 |
catch {unset a}
|
|
sl@0
|
141 |
set info {}
|
|
sl@0
|
142 |
do {global a; trace var a(1) w t1}
|
|
sl@0
|
143 |
set a(1) 44
|
|
sl@0
|
144 |
set info
|
|
sl@0
|
145 |
} 1
|
|
sl@0
|
146 |
test proc-old-3.8 {local and global arrays} {
|
|
sl@0
|
147 |
proc t1 {args} {global info; set info 1}
|
|
sl@0
|
148 |
catch {unset a}
|
|
sl@0
|
149 |
trace var a(1) w t1
|
|
sl@0
|
150 |
set info {}
|
|
sl@0
|
151 |
do {global a; trace vdelete a(1) w t1}
|
|
sl@0
|
152 |
set a(1) 44
|
|
sl@0
|
153 |
set info
|
|
sl@0
|
154 |
} {}
|
|
sl@0
|
155 |
test proc-old-3.9 {local and global arrays} {
|
|
sl@0
|
156 |
proc t1 {args} {global info; set info 1}
|
|
sl@0
|
157 |
catch {unset a}
|
|
sl@0
|
158 |
trace var a(1) w t1
|
|
sl@0
|
159 |
do {global a; trace vinfo a(1)}
|
|
sl@0
|
160 |
} {{w t1}}
|
|
sl@0
|
161 |
catch {unset a}
|
|
sl@0
|
162 |
|
|
sl@0
|
163 |
test proc-old-30.1 {arguments and defaults} {
|
|
sl@0
|
164 |
proc tproc {x y z} {
|
|
sl@0
|
165 |
return [list $x $y $z]
|
|
sl@0
|
166 |
}
|
|
sl@0
|
167 |
tproc 11 12 13
|
|
sl@0
|
168 |
} {11 12 13}
|
|
sl@0
|
169 |
test proc-old-30.2 {arguments and defaults} {
|
|
sl@0
|
170 |
proc tproc {x y z} {
|
|
sl@0
|
171 |
return [list $x $y $z]
|
|
sl@0
|
172 |
}
|
|
sl@0
|
173 |
list [catch {tproc 11 12} msg] $msg
|
|
sl@0
|
174 |
} {1 {wrong # args: should be "tproc x y z"}}
|
|
sl@0
|
175 |
test proc-old-30.3 {arguments and defaults} {
|
|
sl@0
|
176 |
proc tproc {x y z} {
|
|
sl@0
|
177 |
return [list $x $y $z]
|
|
sl@0
|
178 |
}
|
|
sl@0
|
179 |
list [catch {tproc 11 12 13 14} msg] $msg
|
|
sl@0
|
180 |
} {1 {wrong # args: should be "tproc x y z"}}
|
|
sl@0
|
181 |
test proc-old-30.4 {arguments and defaults} {
|
|
sl@0
|
182 |
proc tproc {x {y y-default} {z z-default}} {
|
|
sl@0
|
183 |
return [list $x $y $z]
|
|
sl@0
|
184 |
}
|
|
sl@0
|
185 |
tproc 11 12 13
|
|
sl@0
|
186 |
} {11 12 13}
|
|
sl@0
|
187 |
test proc-old-30.5 {arguments and defaults} {
|
|
sl@0
|
188 |
proc tproc {x {y y-default} {z z-default}} {
|
|
sl@0
|
189 |
return [list $x $y $z]
|
|
sl@0
|
190 |
}
|
|
sl@0
|
191 |
tproc 11 12
|
|
sl@0
|
192 |
} {11 12 z-default}
|
|
sl@0
|
193 |
test proc-old-30.6 {arguments and defaults} {
|
|
sl@0
|
194 |
proc tproc {x {y y-default} {z z-default}} {
|
|
sl@0
|
195 |
return [list $x $y $z]
|
|
sl@0
|
196 |
}
|
|
sl@0
|
197 |
tproc 11
|
|
sl@0
|
198 |
} {11 y-default z-default}
|
|
sl@0
|
199 |
test proc-old-30.7 {arguments and defaults} {
|
|
sl@0
|
200 |
proc tproc {x {y y-default} {z z-default}} {
|
|
sl@0
|
201 |
return [list $x $y $z]
|
|
sl@0
|
202 |
}
|
|
sl@0
|
203 |
list [catch {tproc} msg] $msg
|
|
sl@0
|
204 |
} {1 {wrong # args: should be "tproc x ?y? ?z?"}}
|
|
sl@0
|
205 |
test proc-old-30.8 {arguments and defaults} {
|
|
sl@0
|
206 |
list [catch {
|
|
sl@0
|
207 |
proc tproc {x {y y-default} z} {
|
|
sl@0
|
208 |
return [list $x $y $z]
|
|
sl@0
|
209 |
}
|
|
sl@0
|
210 |
tproc 2 3
|
|
sl@0
|
211 |
} msg] $msg
|
|
sl@0
|
212 |
} {1 {wrong # args: should be "tproc x ?y? z"}}
|
|
sl@0
|
213 |
test proc-old-30.9 {arguments and defaults} {
|
|
sl@0
|
214 |
proc tproc {x {y y-default} args} {
|
|
sl@0
|
215 |
return [list $x $y $args]
|
|
sl@0
|
216 |
}
|
|
sl@0
|
217 |
tproc 2 3 4 5
|
|
sl@0
|
218 |
} {2 3 {4 5}}
|
|
sl@0
|
219 |
test proc-old-30.10 {arguments and defaults} {
|
|
sl@0
|
220 |
proc tproc {x {y y-default} args} {
|
|
sl@0
|
221 |
return [list $x $y $args]
|
|
sl@0
|
222 |
}
|
|
sl@0
|
223 |
tproc 2 3
|
|
sl@0
|
224 |
} {2 3 {}}
|
|
sl@0
|
225 |
test proc-old-30.11 {arguments and defaults} {
|
|
sl@0
|
226 |
proc tproc {x {y y-default} args} {
|
|
sl@0
|
227 |
return [list $x $y $args]
|
|
sl@0
|
228 |
}
|
|
sl@0
|
229 |
tproc 2
|
|
sl@0
|
230 |
} {2 y-default {}}
|
|
sl@0
|
231 |
test proc-old-30.12 {arguments and defaults} {
|
|
sl@0
|
232 |
proc tproc {x {y y-default} args} {
|
|
sl@0
|
233 |
return [list $x $y $args]
|
|
sl@0
|
234 |
}
|
|
sl@0
|
235 |
list [catch {tproc} msg] $msg
|
|
sl@0
|
236 |
} {1 {wrong # args: should be "tproc x ?y? args"}}
|
|
sl@0
|
237 |
|
|
sl@0
|
238 |
test proc-old-4.1 {variable numbers of arguments} {
|
|
sl@0
|
239 |
proc tproc args {return $args}
|
|
sl@0
|
240 |
tproc
|
|
sl@0
|
241 |
} {}
|
|
sl@0
|
242 |
test proc-old-4.2 {variable numbers of arguments} {
|
|
sl@0
|
243 |
proc tproc args {return $args}
|
|
sl@0
|
244 |
tproc 1 2 3 4 5 6 7 8
|
|
sl@0
|
245 |
} {1 2 3 4 5 6 7 8}
|
|
sl@0
|
246 |
test proc-old-4.3 {variable numbers of arguments} {
|
|
sl@0
|
247 |
proc tproc args {return $args}
|
|
sl@0
|
248 |
tproc 1 {2 3} {4 {5 6} {{{7}}}} 8
|
|
sl@0
|
249 |
} {1 {2 3} {4 {5 6} {{{7}}}} 8}
|
|
sl@0
|
250 |
test proc-old-4.4 {variable numbers of arguments} {
|
|
sl@0
|
251 |
proc tproc {x y args} {return $args}
|
|
sl@0
|
252 |
tproc 1 2 3 4 5 6 7
|
|
sl@0
|
253 |
} {3 4 5 6 7}
|
|
sl@0
|
254 |
test proc-old-4.5 {variable numbers of arguments} {
|
|
sl@0
|
255 |
proc tproc {x y args} {return $args}
|
|
sl@0
|
256 |
tproc 1 2
|
|
sl@0
|
257 |
} {}
|
|
sl@0
|
258 |
test proc-old-4.6 {variable numbers of arguments} {
|
|
sl@0
|
259 |
proc tproc {x missing args} {return $args}
|
|
sl@0
|
260 |
list [catch {tproc 1} msg] $msg
|
|
sl@0
|
261 |
} {1 {wrong # args: should be "tproc x missing args"}}
|
|
sl@0
|
262 |
|
|
sl@0
|
263 |
test proc-old-5.1 {error conditions} {
|
|
sl@0
|
264 |
list [catch {proc} msg] $msg
|
|
sl@0
|
265 |
} {1 {wrong # args: should be "proc name args body"}}
|
|
sl@0
|
266 |
test proc-old-5.2 {error conditions} {
|
|
sl@0
|
267 |
list [catch {proc tproc b} msg] $msg
|
|
sl@0
|
268 |
} {1 {wrong # args: should be "proc name args body"}}
|
|
sl@0
|
269 |
test proc-old-5.3 {error conditions} {
|
|
sl@0
|
270 |
list [catch {proc tproc b c d e} msg] $msg
|
|
sl@0
|
271 |
} {1 {wrong # args: should be "proc name args body"}}
|
|
sl@0
|
272 |
test proc-old-5.4 {error conditions} {
|
|
sl@0
|
273 |
list [catch {proc tproc \{xyz {return foo}} msg] $msg
|
|
sl@0
|
274 |
} {1 {unmatched open brace in list}}
|
|
sl@0
|
275 |
test proc-old-5.5 {error conditions} {
|
|
sl@0
|
276 |
list [catch {proc tproc {{} y} {return foo}} msg] $msg
|
|
sl@0
|
277 |
} {1 {procedure "tproc" has argument with no name}}
|
|
sl@0
|
278 |
test proc-old-5.6 {error conditions} {
|
|
sl@0
|
279 |
list [catch {proc tproc {{} y} {return foo}} msg] $msg
|
|
sl@0
|
280 |
} {1 {procedure "tproc" has argument with no name}}
|
|
sl@0
|
281 |
test proc-old-5.7 {error conditions} {
|
|
sl@0
|
282 |
list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg
|
|
sl@0
|
283 |
} {1 {too many fields in argument specifier "x 1 2"}}
|
|
sl@0
|
284 |
test proc-old-5.8 {error conditions} {
|
|
sl@0
|
285 |
catch {return}
|
|
sl@0
|
286 |
} 2
|
|
sl@0
|
287 |
test proc-old-5.9 {error conditions} {
|
|
sl@0
|
288 |
list [catch {global} msg] $msg
|
|
sl@0
|
289 |
} {1 {wrong # args: should be "global varName ?varName ...?"}}
|
|
sl@0
|
290 |
proc tproc {} {
|
|
sl@0
|
291 |
set a 22
|
|
sl@0
|
292 |
global a
|
|
sl@0
|
293 |
}
|
|
sl@0
|
294 |
test proc-old-5.10 {error conditions} {
|
|
sl@0
|
295 |
list [catch {tproc} msg] $msg
|
|
sl@0
|
296 |
} {1 {variable "a" already exists}}
|
|
sl@0
|
297 |
test proc-old-5.11 {error conditions} {
|
|
sl@0
|
298 |
catch {rename tproc {}}
|
|
sl@0
|
299 |
catch {
|
|
sl@0
|
300 |
proc tproc {x {} z} {return foo}
|
|
sl@0
|
301 |
}
|
|
sl@0
|
302 |
list [catch {tproc 1} msg] $msg
|
|
sl@0
|
303 |
} {1 {invalid command name "tproc"}}
|
|
sl@0
|
304 |
test proc-old-5.12 {error conditions} {
|
|
sl@0
|
305 |
proc tproc {} {
|
|
sl@0
|
306 |
set a 22
|
|
sl@0
|
307 |
error "error in procedure"
|
|
sl@0
|
308 |
return
|
|
sl@0
|
309 |
}
|
|
sl@0
|
310 |
list [catch tproc msg] $msg
|
|
sl@0
|
311 |
} {1 {error in procedure}}
|
|
sl@0
|
312 |
test proc-old-5.13 {error conditions} {
|
|
sl@0
|
313 |
proc tproc {} {
|
|
sl@0
|
314 |
set a 22
|
|
sl@0
|
315 |
error "error in procedure"
|
|
sl@0
|
316 |
return
|
|
sl@0
|
317 |
}
|
|
sl@0
|
318 |
catch tproc msg
|
|
sl@0
|
319 |
set errorInfo
|
|
sl@0
|
320 |
} {error in procedure
|
|
sl@0
|
321 |
while executing
|
|
sl@0
|
322 |
"error "error in procedure""
|
|
sl@0
|
323 |
(procedure "tproc" line 3)
|
|
sl@0
|
324 |
invoked from within
|
|
sl@0
|
325 |
"tproc"}
|
|
sl@0
|
326 |
test proc-old-5.14 {error conditions} {
|
|
sl@0
|
327 |
proc tproc {} {
|
|
sl@0
|
328 |
set a 22
|
|
sl@0
|
329 |
break
|
|
sl@0
|
330 |
return
|
|
sl@0
|
331 |
}
|
|
sl@0
|
332 |
catch tproc msg
|
|
sl@0
|
333 |
set errorInfo
|
|
sl@0
|
334 |
} {invoked "break" outside of a loop
|
|
sl@0
|
335 |
(procedure "tproc" line 1)
|
|
sl@0
|
336 |
invoked from within
|
|
sl@0
|
337 |
"tproc"}
|
|
sl@0
|
338 |
test proc-old-5.15 {error conditions} {
|
|
sl@0
|
339 |
proc tproc {} {
|
|
sl@0
|
340 |
set a 22
|
|
sl@0
|
341 |
continue
|
|
sl@0
|
342 |
return
|
|
sl@0
|
343 |
}
|
|
sl@0
|
344 |
catch tproc msg
|
|
sl@0
|
345 |
set errorInfo
|
|
sl@0
|
346 |
} {invoked "continue" outside of a loop
|
|
sl@0
|
347 |
(procedure "tproc" line 1)
|
|
sl@0
|
348 |
invoked from within
|
|
sl@0
|
349 |
"tproc"}
|
|
sl@0
|
350 |
test proc-old-5.16 {error conditions} {
|
|
sl@0
|
351 |
proc foo args {
|
|
sl@0
|
352 |
global fooMsg
|
|
sl@0
|
353 |
set fooMsg "foo was called: $args"
|
|
sl@0
|
354 |
}
|
|
sl@0
|
355 |
proc tproc {} {
|
|
sl@0
|
356 |
set x 44
|
|
sl@0
|
357 |
trace var x u foo
|
|
sl@0
|
358 |
while {$x < 100} {
|
|
sl@0
|
359 |
error "Nested error"
|
|
sl@0
|
360 |
}
|
|
sl@0
|
361 |
}
|
|
sl@0
|
362 |
set fooMsg "foo not called"
|
|
sl@0
|
363 |
list [catch tproc msg] $msg $errorInfo $fooMsg
|
|
sl@0
|
364 |
} {1 {Nested error} {Nested error
|
|
sl@0
|
365 |
while executing
|
|
sl@0
|
366 |
"error "Nested error""
|
|
sl@0
|
367 |
(procedure "tproc" line 5)
|
|
sl@0
|
368 |
invoked from within
|
|
sl@0
|
369 |
"tproc"} {foo was called: x {} u}}
|
|
sl@0
|
370 |
|
|
sl@0
|
371 |
# The tests below will really only be useful when run under Purify or
|
|
sl@0
|
372 |
# some other system that can detect accesses to freed memory...
|
|
sl@0
|
373 |
|
|
sl@0
|
374 |
test proc-old-6.1 {procedure that redefines itself} {
|
|
sl@0
|
375 |
proc tproc {} {
|
|
sl@0
|
376 |
proc tproc {} {
|
|
sl@0
|
377 |
return 44
|
|
sl@0
|
378 |
}
|
|
sl@0
|
379 |
return 45
|
|
sl@0
|
380 |
}
|
|
sl@0
|
381 |
tproc
|
|
sl@0
|
382 |
} 45
|
|
sl@0
|
383 |
test proc-old-6.2 {procedure that deletes itself} {
|
|
sl@0
|
384 |
proc tproc {} {
|
|
sl@0
|
385 |
rename tproc {}
|
|
sl@0
|
386 |
return 45
|
|
sl@0
|
387 |
}
|
|
sl@0
|
388 |
tproc
|
|
sl@0
|
389 |
} 45
|
|
sl@0
|
390 |
|
|
sl@0
|
391 |
proc tproc code {
|
|
sl@0
|
392 |
return -code $code abc
|
|
sl@0
|
393 |
}
|
|
sl@0
|
394 |
test proc-old-7.1 {return with special completion code} {
|
|
sl@0
|
395 |
list [catch {tproc ok} msg] $msg
|
|
sl@0
|
396 |
} {0 abc}
|
|
sl@0
|
397 |
test proc-old-7.2 {return with special completion code} {
|
|
sl@0
|
398 |
list [catch {tproc error} msg] $msg $errorInfo $errorCode
|
|
sl@0
|
399 |
} {1 abc {abc
|
|
sl@0
|
400 |
while executing
|
|
sl@0
|
401 |
"tproc error"} NONE}
|
|
sl@0
|
402 |
test proc-old-7.3 {return with special completion code} {
|
|
sl@0
|
403 |
list [catch {tproc return} msg] $msg
|
|
sl@0
|
404 |
} {2 abc}
|
|
sl@0
|
405 |
test proc-old-7.4 {return with special completion code} {
|
|
sl@0
|
406 |
list [catch {tproc break} msg] $msg
|
|
sl@0
|
407 |
} {3 abc}
|
|
sl@0
|
408 |
test proc-old-7.5 {return with special completion code} {
|
|
sl@0
|
409 |
list [catch {tproc continue} msg] $msg
|
|
sl@0
|
410 |
} {4 abc}
|
|
sl@0
|
411 |
test proc-old-7.6 {return with special completion code} {
|
|
sl@0
|
412 |
list [catch {tproc -14} msg] $msg
|
|
sl@0
|
413 |
} {-14 abc}
|
|
sl@0
|
414 |
test proc-old-7.7 {return with special completion code} {
|
|
sl@0
|
415 |
list [catch {tproc gorp} msg] $msg
|
|
sl@0
|
416 |
} {1 {bad completion code "gorp": must be ok, error, return, break, continue, or an integer}}
|
|
sl@0
|
417 |
test proc-old-7.8 {return with special completion code} {
|
|
sl@0
|
418 |
list [catch {tproc 10b} msg] $msg
|
|
sl@0
|
419 |
} {1 {bad completion code "10b": must be ok, error, return, break, continue, or an integer}}
|
|
sl@0
|
420 |
test proc-old-7.9 {return with special completion code} {
|
|
sl@0
|
421 |
proc tproc2 {} {
|
|
sl@0
|
422 |
tproc return
|
|
sl@0
|
423 |
}
|
|
sl@0
|
424 |
list [catch tproc2 msg] $msg
|
|
sl@0
|
425 |
} {0 abc}
|
|
sl@0
|
426 |
test proc-old-7.10 {return with special completion code} {
|
|
sl@0
|
427 |
proc tproc2 {} {
|
|
sl@0
|
428 |
return -code error
|
|
sl@0
|
429 |
}
|
|
sl@0
|
430 |
list [catch tproc2 msg] $msg
|
|
sl@0
|
431 |
} {1 {}}
|
|
sl@0
|
432 |
test proc-old-7.11 {return with special completion code} {
|
|
sl@0
|
433 |
proc tproc2 {} {
|
|
sl@0
|
434 |
global errorCode errorInfo
|
|
sl@0
|
435 |
catch {open _bad_file_name r} msg
|
|
sl@0
|
436 |
return -code error -errorinfo $errorInfo -errorcode $errorCode $msg
|
|
sl@0
|
437 |
}
|
|
sl@0
|
438 |
set msg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
|
|
sl@0
|
439 |
regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg
|
|
sl@0
|
440 |
normalizeMsg $msg
|
|
sl@0
|
441 |
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
|
|
sl@0
|
442 |
while executing
|
|
sl@0
|
443 |
"open _bad_file_name r"
|
|
sl@0
|
444 |
invoked from within
|
|
sl@0
|
445 |
"tproc2"} {posix enoent {no such file or directory}}}
|
|
sl@0
|
446 |
test proc-old-7.12 {return with special completion code} {
|
|
sl@0
|
447 |
proc tproc2 {} {
|
|
sl@0
|
448 |
global errorCode errorInfo
|
|
sl@0
|
449 |
catch {open _bad_file_name r} msg
|
|
sl@0
|
450 |
return -code error -errorcode $errorCode $msg
|
|
sl@0
|
451 |
}
|
|
sl@0
|
452 |
set msg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
|
|
sl@0
|
453 |
regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg
|
|
sl@0
|
454 |
normalizeMsg $msg
|
|
sl@0
|
455 |
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
|
|
sl@0
|
456 |
while executing
|
|
sl@0
|
457 |
"tproc2"} {posix enoent {no such file or directory}}}
|
|
sl@0
|
458 |
test proc-old-7.13 {return with special completion code} {
|
|
sl@0
|
459 |
proc tproc2 {} {
|
|
sl@0
|
460 |
global errorCode errorInfo
|
|
sl@0
|
461 |
catch {open _bad_file_name r} msg
|
|
sl@0
|
462 |
return -code error -errorinfo $errorInfo $msg
|
|
sl@0
|
463 |
}
|
|
sl@0
|
464 |
set msg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
|
|
sl@0
|
465 |
regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg
|
|
sl@0
|
466 |
normalizeMsg $msg
|
|
sl@0
|
467 |
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
|
|
sl@0
|
468 |
while executing
|
|
sl@0
|
469 |
"open _bad_file_name r"
|
|
sl@0
|
470 |
invoked from within
|
|
sl@0
|
471 |
"tproc2"} none}
|
|
sl@0
|
472 |
test proc-old-7.14 {return with special completion code} {
|
|
sl@0
|
473 |
proc tproc2 {} {
|
|
sl@0
|
474 |
global errorCode errorInfo
|
|
sl@0
|
475 |
catch {open _bad_file_name r} msg
|
|
sl@0
|
476 |
return -code error $msg
|
|
sl@0
|
477 |
}
|
|
sl@0
|
478 |
set msg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
|
|
sl@0
|
479 |
regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg
|
|
sl@0
|
480 |
normalizeMsg $msg
|
|
sl@0
|
481 |
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
|
|
sl@0
|
482 |
while executing
|
|
sl@0
|
483 |
"tproc2"} none}
|
|
sl@0
|
484 |
test proc-old-7.15 {return with special completion code} {
|
|
sl@0
|
485 |
list [catch {return -badOption foo message} msg] $msg
|
|
sl@0
|
486 |
} {1 {bad option "-badOption": must be -code, -errorcode, or -errorinfo}}
|
|
sl@0
|
487 |
|
|
sl@0
|
488 |
test proc-old-8.1 {unset and undefined local arrays} {
|
|
sl@0
|
489 |
proc t1 {} {
|
|
sl@0
|
490 |
foreach v {xxx, yyy} {
|
|
sl@0
|
491 |
catch {unset $v}
|
|
sl@0
|
492 |
}
|
|
sl@0
|
493 |
set yyy(foo) bar
|
|
sl@0
|
494 |
}
|
|
sl@0
|
495 |
t1
|
|
sl@0
|
496 |
} bar
|
|
sl@0
|
497 |
|
|
sl@0
|
498 |
test proc-old-9.1 {empty command name} {
|
|
sl@0
|
499 |
catch {rename {} ""}
|
|
sl@0
|
500 |
proc t1 {args} {
|
|
sl@0
|
501 |
return
|
|
sl@0
|
502 |
}
|
|
sl@0
|
503 |
set v [t1]
|
|
sl@0
|
504 |
catch {$v}
|
|
sl@0
|
505 |
} 1
|
|
sl@0
|
506 |
|
|
sl@0
|
507 |
test proc-old-10.1 {ByteCode epoch change during recursive proc execution} {
|
|
sl@0
|
508 |
proc t1 x {
|
|
sl@0
|
509 |
set y 20
|
|
sl@0
|
510 |
rename expr expr.old
|
|
sl@0
|
511 |
rename expr.old expr
|
|
sl@0
|
512 |
if $x then {t1 0} ;# recursive call after foo's code is invalidated
|
|
sl@0
|
513 |
return 20
|
|
sl@0
|
514 |
}
|
|
sl@0
|
515 |
t1 1
|
|
sl@0
|
516 |
} 20
|
|
sl@0
|
517 |
|
|
sl@0
|
518 |
# cleanup
|
|
sl@0
|
519 |
catch {rename t1 ""}
|
|
sl@0
|
520 |
catch {rename foo ""}
|
|
sl@0
|
521 |
::tcltest::cleanupTests
|
|
sl@0
|
522 |
return
|
|
sl@0
|
523 |
|
|
sl@0
|
524 |
|
|
sl@0
|
525 |
|
|
sl@0
|
526 |
|
|
sl@0
|
527 |
|
|
sl@0
|
528 |
|
|
sl@0
|
529 |
|
|
sl@0
|
530 |
|
|
sl@0
|
531 |
|
|
sl@0
|
532 |
|
|
sl@0
|
533 |
|
|
sl@0
|
534 |
|