sl@0
|
1 |
# -*- tcl -*-
|
sl@0
|
2 |
# Commands covered: info
|
sl@0
|
3 |
#
|
sl@0
|
4 |
# This file contains a collection of tests for one or more of the Tcl
|
sl@0
|
5 |
# built-in commands. Sourcing this file into Tcl runs the tests and
|
sl@0
|
6 |
# generates output for errors. No output means no errors were found.
|
sl@0
|
7 |
#
|
sl@0
|
8 |
# Copyright (c) 1991-1994 The Regents of the University of California.
|
sl@0
|
9 |
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
|
sl@0
|
10 |
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
sl@0
|
11 |
# Copyright (c) 2006 ActiveState
|
sl@0
|
12 |
#
|
sl@0
|
13 |
# See the file "license.terms" for information on usage and redistribution
|
sl@0
|
14 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
sl@0
|
15 |
#
|
sl@0
|
16 |
# RCS: @(#) $Id: info.test,v 1.24.2.5 2006/11/28 22:20:02 andreas_kupries Exp $
|
sl@0
|
17 |
|
sl@0
|
18 |
if {[lsearch [namespace children] ::tcltest] == -1} {
|
sl@0
|
19 |
package require tcltest 2
|
sl@0
|
20 |
namespace import -force ::tcltest::*
|
sl@0
|
21 |
}
|
sl@0
|
22 |
|
sl@0
|
23 |
# Set up namespaces needed to test operation of "info args", "info body",
|
sl@0
|
24 |
# "info default", and "info procs" with imported procedures.
|
sl@0
|
25 |
|
sl@0
|
26 |
catch {namespace delete test_ns_info1 test_ns_info2}
|
sl@0
|
27 |
|
sl@0
|
28 |
namespace eval test_ns_info1 {
|
sl@0
|
29 |
namespace export *
|
sl@0
|
30 |
proc p {x} {return "x=$x"}
|
sl@0
|
31 |
proc q {{y 27} {z {}}} {return "y=$y"}
|
sl@0
|
32 |
}
|
sl@0
|
33 |
|
sl@0
|
34 |
testConstraint tip280 [info exists tcl_platform(tip,280)]
|
sl@0
|
35 |
testConstraint !tip280 [expr {![info exists tcl_platform(tip,280)]}]
|
sl@0
|
36 |
|
sl@0
|
37 |
|
sl@0
|
38 |
test info-1.1 {info args option} {
|
sl@0
|
39 |
proc t1 {a bbb c} {return foo}
|
sl@0
|
40 |
info args t1
|
sl@0
|
41 |
} {a bbb c}
|
sl@0
|
42 |
test info-1.2 {info args option} {
|
sl@0
|
43 |
proc t1 {{a default1} {bbb default2} {c default3} args} {return foo}
|
sl@0
|
44 |
info a t1
|
sl@0
|
45 |
} {a bbb c args}
|
sl@0
|
46 |
test info-1.3 {info args option} {
|
sl@0
|
47 |
proc t1 "" {return foo}
|
sl@0
|
48 |
info args t1
|
sl@0
|
49 |
} {}
|
sl@0
|
50 |
test info-1.4 {info args option} {
|
sl@0
|
51 |
catch {rename t1 {}}
|
sl@0
|
52 |
list [catch {info args t1} msg] $msg
|
sl@0
|
53 |
} {1 {"t1" isn't a procedure}}
|
sl@0
|
54 |
test info-1.5 {info args option} {
|
sl@0
|
55 |
list [catch {info args set} msg] $msg
|
sl@0
|
56 |
} {1 {"set" isn't a procedure}}
|
sl@0
|
57 |
test info-1.6 {info args option} {
|
sl@0
|
58 |
proc t1 {a b} {set c 123; set d $c}
|
sl@0
|
59 |
t1 1 2
|
sl@0
|
60 |
info args t1
|
sl@0
|
61 |
} {a b}
|
sl@0
|
62 |
test info-1.7 {info args option} {
|
sl@0
|
63 |
catch {namespace delete test_ns_info2}
|
sl@0
|
64 |
namespace eval test_ns_info2 {
|
sl@0
|
65 |
namespace import ::test_ns_info1::*
|
sl@0
|
66 |
list [info args p] [info args q]
|
sl@0
|
67 |
}
|
sl@0
|
68 |
} {x {y z}}
|
sl@0
|
69 |
|
sl@0
|
70 |
test info-2.1 {info body option} {
|
sl@0
|
71 |
proc t1 {} {body of t1}
|
sl@0
|
72 |
info body t1
|
sl@0
|
73 |
} {body of t1}
|
sl@0
|
74 |
test info-2.2 {info body option} {
|
sl@0
|
75 |
list [catch {info body set} msg] $msg
|
sl@0
|
76 |
} {1 {"set" isn't a procedure}}
|
sl@0
|
77 |
test info-2.3 {info body option} {
|
sl@0
|
78 |
list [catch {info args set 1} msg] $msg
|
sl@0
|
79 |
} {1 {wrong # args: should be "info args procname"}}
|
sl@0
|
80 |
test info-2.4 {info body option} {
|
sl@0
|
81 |
catch {namespace delete test_ns_info2}
|
sl@0
|
82 |
namespace eval test_ns_info2 {
|
sl@0
|
83 |
namespace import ::test_ns_info1::*
|
sl@0
|
84 |
list [info body p] [info body q]
|
sl@0
|
85 |
}
|
sl@0
|
86 |
} {{return "x=$x"} {return "y=$y"}}
|
sl@0
|
87 |
# Prior to 8.3.0 this would cause a crash because [info body]
|
sl@0
|
88 |
# would return the bytecompiled version of foo, which the catch
|
sl@0
|
89 |
# would then try and eval out of the foo context, accessing
|
sl@0
|
90 |
# compiled local indices
|
sl@0
|
91 |
test info-2.5 {info body option, returning bytecompiled bodies} {
|
sl@0
|
92 |
catch {unset args}
|
sl@0
|
93 |
proc foo {args} {
|
sl@0
|
94 |
foreach v $args {
|
sl@0
|
95 |
upvar $v var
|
sl@0
|
96 |
return "variable $v existence: [info exists var]"
|
sl@0
|
97 |
}
|
sl@0
|
98 |
}
|
sl@0
|
99 |
foo a
|
sl@0
|
100 |
list [catch [info body foo] msg] $msg
|
sl@0
|
101 |
} {1 {can't read "args": no such variable}}
|
sl@0
|
102 |
# Fix for problem tested for in info-2.5 caused problems when
|
sl@0
|
103 |
# procedure body had no string rep (i.e. was not yet bytecode)
|
sl@0
|
104 |
# causing an empty string to be returned [Bug #545644]
|
sl@0
|
105 |
test info-2.6 {info body option, returning list bodies} {
|
sl@0
|
106 |
proc foo args [list subst bar]
|
sl@0
|
107 |
list [string bytelength [info body foo]] \
|
sl@0
|
108 |
[foo; string bytelength [info body foo]]
|
sl@0
|
109 |
} {9 9}
|
sl@0
|
110 |
|
sl@0
|
111 |
# "info cmdcount" is no longer accurate for compiled commands!
|
sl@0
|
112 |
# The expected result for info-3.1 used to be "3" and is now "1"
|
sl@0
|
113 |
# since the "set"s have been compiled away. info-3.2 was corrected
|
sl@0
|
114 |
# in 8.3 because the eval'ed body won't be compiled.
|
sl@0
|
115 |
proc testinfocmdcount {} {
|
sl@0
|
116 |
set x [info cmdcount]
|
sl@0
|
117 |
set y 12345
|
sl@0
|
118 |
set z [info cm]
|
sl@0
|
119 |
expr $z-$x
|
sl@0
|
120 |
}
|
sl@0
|
121 |
test info-3.1 {info cmdcount compiled} {
|
sl@0
|
122 |
testinfocmdcount
|
sl@0
|
123 |
} 1
|
sl@0
|
124 |
test info-3.2 {info cmdcount evaled} {
|
sl@0
|
125 |
set x [info cmdcount]
|
sl@0
|
126 |
set y 12345
|
sl@0
|
127 |
set z [info cm]
|
sl@0
|
128 |
expr $z-$x
|
sl@0
|
129 |
} 3
|
sl@0
|
130 |
test info-3.3 {info cmdcount evaled} [info body testinfocmdcount] 3
|
sl@0
|
131 |
test info-3.4 {info cmdcount option} {
|
sl@0
|
132 |
list [catch {info cmdcount 1} msg] $msg
|
sl@0
|
133 |
} {1 {wrong # args: should be "info cmdcount"}}
|
sl@0
|
134 |
|
sl@0
|
135 |
test info-4.1 {info commands option} {
|
sl@0
|
136 |
proc t1 {} {}
|
sl@0
|
137 |
proc t2 {} {}
|
sl@0
|
138 |
set x " [info commands] "
|
sl@0
|
139 |
list [string match {* t1 *} $x] [string match {* t2 *} $x] \
|
sl@0
|
140 |
[string match {* set *} $x] [string match {* list *} $x]
|
sl@0
|
141 |
} {1 1 1 1}
|
sl@0
|
142 |
test info-4.2 {info commands option} {
|
sl@0
|
143 |
proc t1 {} {}
|
sl@0
|
144 |
rename t1 {}
|
sl@0
|
145 |
set x [info comm]
|
sl@0
|
146 |
string match {* t1 *} $x
|
sl@0
|
147 |
} 0
|
sl@0
|
148 |
test info-4.3 {info commands option} {
|
sl@0
|
149 |
proc _t1_ {} {}
|
sl@0
|
150 |
proc _t2_ {} {}
|
sl@0
|
151 |
info commands _t1_
|
sl@0
|
152 |
} _t1_
|
sl@0
|
153 |
test info-4.4 {info commands option} {
|
sl@0
|
154 |
proc _t1_ {} {}
|
sl@0
|
155 |
proc _t2_ {} {}
|
sl@0
|
156 |
lsort [info commands _t*]
|
sl@0
|
157 |
} {_t1_ _t2_}
|
sl@0
|
158 |
catch {rename _t1_ {}}
|
sl@0
|
159 |
catch {rename _t2_ {}}
|
sl@0
|
160 |
test info-4.5 {info commands option} {
|
sl@0
|
161 |
list [catch {info commands a b} msg] $msg
|
sl@0
|
162 |
} {1 {wrong # args: should be "info commands ?pattern?"}}
|
sl@0
|
163 |
|
sl@0
|
164 |
test info-5.1 {info complete option} {
|
sl@0
|
165 |
list [catch {info complete} msg] $msg
|
sl@0
|
166 |
} {1 {wrong # args: should be "info complete command"}}
|
sl@0
|
167 |
test info-5.2 {info complete option} {
|
sl@0
|
168 |
info complete abc
|
sl@0
|
169 |
} 1
|
sl@0
|
170 |
test info-5.3 {info complete option} {
|
sl@0
|
171 |
info complete "\{abcd "
|
sl@0
|
172 |
} 0
|
sl@0
|
173 |
test info-5.4 {info complete option} {
|
sl@0
|
174 |
info complete {# Comment should be complete command}
|
sl@0
|
175 |
} 1
|
sl@0
|
176 |
test info-5.5 {info complete option} {
|
sl@0
|
177 |
info complete {[a [b] }
|
sl@0
|
178 |
} 0
|
sl@0
|
179 |
test info-5.6 {info complete option} {
|
sl@0
|
180 |
info complete {[a [b]}
|
sl@0
|
181 |
} 0
|
sl@0
|
182 |
|
sl@0
|
183 |
test info-6.1 {info default option} {
|
sl@0
|
184 |
proc t1 {a b {c d} {e "long default value"}} {}
|
sl@0
|
185 |
info default t1 a value
|
sl@0
|
186 |
} 0
|
sl@0
|
187 |
test info-6.2 {info default option} {
|
sl@0
|
188 |
proc t1 {a b {c d} {e "long default value"}} {}
|
sl@0
|
189 |
set value 12345
|
sl@0
|
190 |
info d t1 a value
|
sl@0
|
191 |
set value
|
sl@0
|
192 |
} {}
|
sl@0
|
193 |
test info-6.3 {info default option} {
|
sl@0
|
194 |
proc t1 {a b {c d} {e "long default value"}} {}
|
sl@0
|
195 |
info default t1 c value
|
sl@0
|
196 |
} 1
|
sl@0
|
197 |
test info-6.4 {info default option} {
|
sl@0
|
198 |
proc t1 {a b {c d} {e "long default value"}} {}
|
sl@0
|
199 |
set value 12345
|
sl@0
|
200 |
info default t1 c value
|
sl@0
|
201 |
set value
|
sl@0
|
202 |
} d
|
sl@0
|
203 |
test info-6.5 {info default option} {
|
sl@0
|
204 |
proc t1 {a b {c d} {e "long default value"}} {}
|
sl@0
|
205 |
set value 12345
|
sl@0
|
206 |
set x [info default t1 e value]
|
sl@0
|
207 |
list $x $value
|
sl@0
|
208 |
} {1 {long default value}}
|
sl@0
|
209 |
test info-6.6 {info default option} {
|
sl@0
|
210 |
list [catch {info default a b} msg] $msg
|
sl@0
|
211 |
} {1 {wrong # args: should be "info default procname arg varname"}}
|
sl@0
|
212 |
test info-6.7 {info default option} {
|
sl@0
|
213 |
list [catch {info default _nonexistent_ a b} msg] $msg
|
sl@0
|
214 |
} {1 {"_nonexistent_" isn't a procedure}}
|
sl@0
|
215 |
test info-6.8 {info default option} {
|
sl@0
|
216 |
proc t1 {a b} {}
|
sl@0
|
217 |
list [catch {info default t1 x value} msg] $msg
|
sl@0
|
218 |
} {1 {procedure "t1" doesn't have an argument "x"}}
|
sl@0
|
219 |
test info-6.9 {info default option} {
|
sl@0
|
220 |
catch {unset a}
|
sl@0
|
221 |
set a(0) 88
|
sl@0
|
222 |
proc t1 {a b} {}
|
sl@0
|
223 |
list [catch {info default t1 a a} msg] $msg
|
sl@0
|
224 |
} {1 {couldn't store default value in variable "a"}}
|
sl@0
|
225 |
test info-6.10 {info default option} {
|
sl@0
|
226 |
catch {unset a}
|
sl@0
|
227 |
set a(0) 88
|
sl@0
|
228 |
proc t1 {{a 18} b} {}
|
sl@0
|
229 |
list [catch {info default t1 a a} msg] $msg
|
sl@0
|
230 |
} {1 {couldn't store default value in variable "a"}}
|
sl@0
|
231 |
test info-6.11 {info default option} {
|
sl@0
|
232 |
catch {namespace delete test_ns_info2}
|
sl@0
|
233 |
namespace eval test_ns_info2 {
|
sl@0
|
234 |
namespace import ::test_ns_info1::*
|
sl@0
|
235 |
list [info default p x foo] $foo [info default q y bar] $bar
|
sl@0
|
236 |
}
|
sl@0
|
237 |
} {0 {} 1 27}
|
sl@0
|
238 |
catch {unset a}
|
sl@0
|
239 |
|
sl@0
|
240 |
test info-7.1 {info exists option} {
|
sl@0
|
241 |
set value foo
|
sl@0
|
242 |
info exists value
|
sl@0
|
243 |
} 1
|
sl@0
|
244 |
catch {unset _nonexistent_}
|
sl@0
|
245 |
test info-7.2 {info exists option} {
|
sl@0
|
246 |
info exists _nonexistent_
|
sl@0
|
247 |
} 0
|
sl@0
|
248 |
test info-7.3 {info exists option} {
|
sl@0
|
249 |
proc t1 {x} {return [info exists x]}
|
sl@0
|
250 |
t1 2
|
sl@0
|
251 |
} 1
|
sl@0
|
252 |
test info-7.4 {info exists option} {
|
sl@0
|
253 |
proc t1 {x} {
|
sl@0
|
254 |
global _nonexistent_
|
sl@0
|
255 |
return [info exists _nonexistent_]
|
sl@0
|
256 |
}
|
sl@0
|
257 |
t1 2
|
sl@0
|
258 |
} 0
|
sl@0
|
259 |
test info-7.5 {info exists option} {
|
sl@0
|
260 |
proc t1 {x} {
|
sl@0
|
261 |
set y 47
|
sl@0
|
262 |
return [info exists y]
|
sl@0
|
263 |
}
|
sl@0
|
264 |
t1 2
|
sl@0
|
265 |
} 1
|
sl@0
|
266 |
test info-7.6 {info exists option} {
|
sl@0
|
267 |
proc t1 {x} {return [info exists value]}
|
sl@0
|
268 |
t1 2
|
sl@0
|
269 |
} 0
|
sl@0
|
270 |
test info-7.7 {info exists option} {
|
sl@0
|
271 |
catch {unset x}
|
sl@0
|
272 |
set x(2) 44
|
sl@0
|
273 |
list [info exists x] [info exists x(1)] [info exists x(2)]
|
sl@0
|
274 |
} {1 0 1}
|
sl@0
|
275 |
catch {unset x}
|
sl@0
|
276 |
test info-7.8 {info exists option} {
|
sl@0
|
277 |
list [catch {info exists} msg] $msg
|
sl@0
|
278 |
} {1 {wrong # args: should be "info exists varName"}}
|
sl@0
|
279 |
test info-7.9 {info exists option} {
|
sl@0
|
280 |
list [catch {info exists 1 2} msg] $msg
|
sl@0
|
281 |
} {1 {wrong # args: should be "info exists varName"}}
|
sl@0
|
282 |
|
sl@0
|
283 |
test info-8.1 {info globals option} {
|
sl@0
|
284 |
set x 1
|
sl@0
|
285 |
set y 2
|
sl@0
|
286 |
set value 23
|
sl@0
|
287 |
set a " [info globals] "
|
sl@0
|
288 |
list [string match {* x *} $a] [string match {* y *} $a] \
|
sl@0
|
289 |
[string match {* value *} $a] [string match {* _foobar_ *} $a]
|
sl@0
|
290 |
} {1 1 1 0}
|
sl@0
|
291 |
test info-8.2 {info globals option} {
|
sl@0
|
292 |
set _xxx1 1
|
sl@0
|
293 |
set _xxx2 2
|
sl@0
|
294 |
lsort [info g _xxx*]
|
sl@0
|
295 |
} {_xxx1 _xxx2}
|
sl@0
|
296 |
test info-8.3 {info globals option} {
|
sl@0
|
297 |
list [catch {info globals 1 2} msg] $msg
|
sl@0
|
298 |
} {1 {wrong # args: should be "info globals ?pattern?"}}
|
sl@0
|
299 |
test info-8.4 {info globals option: may have leading namespace qualifiers} {
|
sl@0
|
300 |
set x 0
|
sl@0
|
301 |
list [info globals x] [info globals :x] [info globals ::x] [info globals :::x] [info globals ::::x]
|
sl@0
|
302 |
} {x {} x x x}
|
sl@0
|
303 |
test info-8.5 {info globals option: only return existing global variables} {
|
sl@0
|
304 |
-setup {
|
sl@0
|
305 |
catch {unset ::NO_SUCH_VAR}
|
sl@0
|
306 |
proc evalInProc script {eval $script}
|
sl@0
|
307 |
}
|
sl@0
|
308 |
-body {
|
sl@0
|
309 |
evalInProc {global NO_SUCH_VAR; info globals NO_SUCH_VAR}
|
sl@0
|
310 |
}
|
sl@0
|
311 |
-cleanup {
|
sl@0
|
312 |
rename evalInProc {}
|
sl@0
|
313 |
}
|
sl@0
|
314 |
-result {}
|
sl@0
|
315 |
}
|
sl@0
|
316 |
|
sl@0
|
317 |
test info-9.1 {info level option} {
|
sl@0
|
318 |
info level
|
sl@0
|
319 |
} 0
|
sl@0
|
320 |
test info-9.2 {info level option} {
|
sl@0
|
321 |
proc t1 {a b} {
|
sl@0
|
322 |
set x [info le]
|
sl@0
|
323 |
set y [info level 1]
|
sl@0
|
324 |
list $x $y
|
sl@0
|
325 |
}
|
sl@0
|
326 |
t1 146 testString
|
sl@0
|
327 |
} {1 {t1 146 testString}}
|
sl@0
|
328 |
test info-9.3 {info level option} {
|
sl@0
|
329 |
proc t1 {a b} {
|
sl@0
|
330 |
t2 [expr $a*2] $b
|
sl@0
|
331 |
}
|
sl@0
|
332 |
proc t2 {x y} {
|
sl@0
|
333 |
list [info level] [info level 1] [info level 2] [info level -1] \
|
sl@0
|
334 |
[info level 0]
|
sl@0
|
335 |
}
|
sl@0
|
336 |
t1 146 {a {b c} {{{c}}}}
|
sl@0
|
337 |
} {2 {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}} {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}}}
|
sl@0
|
338 |
test info-9.4 {info level option} {
|
sl@0
|
339 |
proc t1 {} {
|
sl@0
|
340 |
set x [info level]
|
sl@0
|
341 |
set y [info level 1]
|
sl@0
|
342 |
list $x $y
|
sl@0
|
343 |
}
|
sl@0
|
344 |
t1
|
sl@0
|
345 |
} {1 t1}
|
sl@0
|
346 |
test info-9.5 {info level option} {
|
sl@0
|
347 |
list [catch {info level 1 2} msg] $msg
|
sl@0
|
348 |
} {1 {wrong # args: should be "info level ?number?"}}
|
sl@0
|
349 |
test info-9.6 {info level option} {
|
sl@0
|
350 |
list [catch {info level 123a} msg] $msg
|
sl@0
|
351 |
} {1 {expected integer but got "123a"}}
|
sl@0
|
352 |
test info-9.7 {info level option} {
|
sl@0
|
353 |
list [catch {info level 0} msg] $msg
|
sl@0
|
354 |
} {1 {bad level "0"}}
|
sl@0
|
355 |
test info-9.8 {info level option} {
|
sl@0
|
356 |
proc t1 {} {info level -1}
|
sl@0
|
357 |
list [catch {t1} msg] $msg
|
sl@0
|
358 |
} {1 {bad level "-1"}}
|
sl@0
|
359 |
test info-9.9 {info level option} {
|
sl@0
|
360 |
proc t1 {x} {info level $x}
|
sl@0
|
361 |
list [catch {t1 -3} msg] $msg
|
sl@0
|
362 |
} {1 {bad level "-3"}}
|
sl@0
|
363 |
test info-9.10 {info level option, namespaces} {
|
sl@0
|
364 |
set msg [namespace eval t {info level 0}]
|
sl@0
|
365 |
namespace delete t
|
sl@0
|
366 |
set msg
|
sl@0
|
367 |
} {namespace eval t {info level 0}}
|
sl@0
|
368 |
|
sl@0
|
369 |
set savedLibrary $tcl_library
|
sl@0
|
370 |
test info-10.1 {info library option} {
|
sl@0
|
371 |
list [catch {info library x} msg] $msg
|
sl@0
|
372 |
} {1 {wrong # args: should be "info library"}}
|
sl@0
|
373 |
test info-10.2 {info library option} {
|
sl@0
|
374 |
set tcl_library 12345
|
sl@0
|
375 |
info library
|
sl@0
|
376 |
} {12345}
|
sl@0
|
377 |
test info-10.3 {info library option} {
|
sl@0
|
378 |
unset tcl_library
|
sl@0
|
379 |
list [catch {info library} msg] $msg
|
sl@0
|
380 |
} {1 {no library has been specified for Tcl}}
|
sl@0
|
381 |
set tcl_library $savedLibrary
|
sl@0
|
382 |
|
sl@0
|
383 |
test info-11.1 {info loaded option} {
|
sl@0
|
384 |
list [catch {info loaded a b} msg] $msg
|
sl@0
|
385 |
} {1 {wrong # args: should be "info loaded ?interp?"}}
|
sl@0
|
386 |
test info-11.2 {info loaded option} {
|
sl@0
|
387 |
list [catch {info loaded {}}] [catch {info loaded gorp} msg] $msg
|
sl@0
|
388 |
} {0 1 {could not find interpreter "gorp"}}
|
sl@0
|
389 |
|
sl@0
|
390 |
test info-12.1 {info locals option} {
|
sl@0
|
391 |
set a 22
|
sl@0
|
392 |
proc t1 {x y} {
|
sl@0
|
393 |
set b 13
|
sl@0
|
394 |
set c testing
|
sl@0
|
395 |
global a
|
sl@0
|
396 |
global aa
|
sl@0
|
397 |
set aa 23
|
sl@0
|
398 |
return [info locals]
|
sl@0
|
399 |
}
|
sl@0
|
400 |
lsort [t1 23 24]
|
sl@0
|
401 |
} {b c x y}
|
sl@0
|
402 |
test info-12.2 {info locals option} {
|
sl@0
|
403 |
proc t1 {x y} {
|
sl@0
|
404 |
set xx1 2
|
sl@0
|
405 |
set xx2 3
|
sl@0
|
406 |
set y 4
|
sl@0
|
407 |
return [info loc x*]
|
sl@0
|
408 |
}
|
sl@0
|
409 |
lsort [t1 2 3]
|
sl@0
|
410 |
} {x xx1 xx2}
|
sl@0
|
411 |
test info-12.3 {info locals option} {
|
sl@0
|
412 |
list [catch {info locals 1 2} msg] $msg
|
sl@0
|
413 |
} {1 {wrong # args: should be "info locals ?pattern?"}}
|
sl@0
|
414 |
test info-12.4 {info locals option} {
|
sl@0
|
415 |
info locals
|
sl@0
|
416 |
} {}
|
sl@0
|
417 |
test info-12.5 {info locals option} {
|
sl@0
|
418 |
proc t1 {} {return [info locals]}
|
sl@0
|
419 |
t1
|
sl@0
|
420 |
} {}
|
sl@0
|
421 |
test info-12.6 {info locals vs unset compiled locals} {
|
sl@0
|
422 |
proc t1 {lst} {
|
sl@0
|
423 |
foreach $lst $lst {}
|
sl@0
|
424 |
unset lst
|
sl@0
|
425 |
return [info locals]
|
sl@0
|
426 |
}
|
sl@0
|
427 |
lsort [t1 {a b c c d e f}]
|
sl@0
|
428 |
} {a b c d e f}
|
sl@0
|
429 |
test info-12.7 {info locals with temporary variables} {
|
sl@0
|
430 |
proc t1 {} {
|
sl@0
|
431 |
foreach a {b c} {}
|
sl@0
|
432 |
info locals
|
sl@0
|
433 |
}
|
sl@0
|
434 |
t1
|
sl@0
|
435 |
} {a}
|
sl@0
|
436 |
|
sl@0
|
437 |
test info-13.1 {info nameofexecutable option} {
|
sl@0
|
438 |
list [catch {info nameofexecutable foo} msg] $msg
|
sl@0
|
439 |
} {1 {wrong # args: should be "info nameofexecutable"}}
|
sl@0
|
440 |
|
sl@0
|
441 |
test info-14.1 {info patchlevel option} {
|
sl@0
|
442 |
set a [info patchlevel]
|
sl@0
|
443 |
regexp {[0-9]+\.[0-9]+([p[0-9]+)?} $a
|
sl@0
|
444 |
} 1
|
sl@0
|
445 |
test info-14.2 {info patchlevel option} {
|
sl@0
|
446 |
list [catch {info patchlevel a} msg] $msg
|
sl@0
|
447 |
} {1 {wrong # args: should be "info patchlevel"}}
|
sl@0
|
448 |
test info-14.3 {info patchlevel option} {
|
sl@0
|
449 |
set t $tcl_patchLevel
|
sl@0
|
450 |
unset tcl_patchLevel
|
sl@0
|
451 |
set result [list [catch {info patchlevel} msg] $msg]
|
sl@0
|
452 |
set tcl_patchLevel $t
|
sl@0
|
453 |
set result
|
sl@0
|
454 |
} {1 {can't read "tcl_patchLevel": no such variable}}
|
sl@0
|
455 |
|
sl@0
|
456 |
test info-15.1 {info procs option} {
|
sl@0
|
457 |
proc t1 {} {}
|
sl@0
|
458 |
proc t2 {} {}
|
sl@0
|
459 |
set x " [info procs] "
|
sl@0
|
460 |
list [string match {* t1 *} $x] [string match {* t2 *} $x] \
|
sl@0
|
461 |
[string match {* _undefined_ *} $x]
|
sl@0
|
462 |
} {1 1 0}
|
sl@0
|
463 |
test info-15.2 {info procs option} {
|
sl@0
|
464 |
proc _tt1 {} {}
|
sl@0
|
465 |
proc _tt2 {} {}
|
sl@0
|
466 |
lsort [info pr _tt*]
|
sl@0
|
467 |
} {_tt1 _tt2}
|
sl@0
|
468 |
catch {rename _tt1 {}}
|
sl@0
|
469 |
catch {rename _tt2 {}}
|
sl@0
|
470 |
test info-15.3 {info procs option} {
|
sl@0
|
471 |
list [catch {info procs 2 3} msg] $msg
|
sl@0
|
472 |
} {1 {wrong # args: should be "info procs ?pattern?"}}
|
sl@0
|
473 |
test info-15.4 {info procs option} {
|
sl@0
|
474 |
catch {namespace delete test_ns_info2}
|
sl@0
|
475 |
namespace eval test_ns_info2 {
|
sl@0
|
476 |
namespace import ::test_ns_info1::*
|
sl@0
|
477 |
proc r {} {}
|
sl@0
|
478 |
list [info procs] [info procs p*]
|
sl@0
|
479 |
}
|
sl@0
|
480 |
} {{p q r} p}
|
sl@0
|
481 |
test info-15.5 {info procs option with a proc in a namespace} {
|
sl@0
|
482 |
catch {namespace delete test_ns_info2}
|
sl@0
|
483 |
namespace eval test_ns_info2 {
|
sl@0
|
484 |
proc p1 { arg } {
|
sl@0
|
485 |
puts cmd
|
sl@0
|
486 |
}
|
sl@0
|
487 |
proc p2 { arg } {
|
sl@0
|
488 |
puts cmd
|
sl@0
|
489 |
}
|
sl@0
|
490 |
}
|
sl@0
|
491 |
info procs ::test_ns_info2::p1
|
sl@0
|
492 |
} {::test_ns_info2::p1}
|
sl@0
|
493 |
test info-15.6 {info procs option with a pattern in a namespace} {
|
sl@0
|
494 |
catch {namespace delete test_ns_info2}
|
sl@0
|
495 |
namespace eval test_ns_info2 {
|
sl@0
|
496 |
proc p1 { arg } {
|
sl@0
|
497 |
puts cmd
|
sl@0
|
498 |
}
|
sl@0
|
499 |
proc p2 { arg } {
|
sl@0
|
500 |
puts cmd
|
sl@0
|
501 |
}
|
sl@0
|
502 |
}
|
sl@0
|
503 |
lsort [info procs ::test_ns_info2::p*]
|
sl@0
|
504 |
} [lsort [list ::test_ns_info2::p1 ::test_ns_info2::p2]]
|
sl@0
|
505 |
test info-15.7 {info procs option with a global shadowing proc} {
|
sl@0
|
506 |
catch {namespace delete test_ns_info2}
|
sl@0
|
507 |
proc string_cmd { arg } {
|
sl@0
|
508 |
puts cmd
|
sl@0
|
509 |
}
|
sl@0
|
510 |
namespace eval test_ns_info2 {
|
sl@0
|
511 |
proc string_cmd { arg } {
|
sl@0
|
512 |
puts cmd
|
sl@0
|
513 |
}
|
sl@0
|
514 |
}
|
sl@0
|
515 |
info procs test_ns_info2::string*
|
sl@0
|
516 |
} {::test_ns_info2::string_cmd}
|
sl@0
|
517 |
# This regression test is currently commented out because it requires
|
sl@0
|
518 |
# that the implementation of "info procs" looks into the global namespace,
|
sl@0
|
519 |
# which it does not (in contrast to "info commands")
|
sl@0
|
520 |
if {0} {
|
sl@0
|
521 |
test info-15.8 {info procs option with a global shadowing proc} {
|
sl@0
|
522 |
catch {namespace delete test_ns_info2}
|
sl@0
|
523 |
proc string_cmd { arg } {
|
sl@0
|
524 |
puts cmd
|
sl@0
|
525 |
}
|
sl@0
|
526 |
proc string_cmd2 { arg } {
|
sl@0
|
527 |
puts cmd
|
sl@0
|
528 |
}
|
sl@0
|
529 |
namespace eval test_ns_info2 {
|
sl@0
|
530 |
proc string_cmd { arg } {
|
sl@0
|
531 |
puts cmd
|
sl@0
|
532 |
}
|
sl@0
|
533 |
}
|
sl@0
|
534 |
namespace eval test_ns_info2 {
|
sl@0
|
535 |
lsort [info procs string*]
|
sl@0
|
536 |
}
|
sl@0
|
537 |
} [lsort [list string_cmd string_cmd2]]
|
sl@0
|
538 |
}
|
sl@0
|
539 |
|
sl@0
|
540 |
test info-16.1 {info script option} {
|
sl@0
|
541 |
list [catch {info script x x} msg] $msg
|
sl@0
|
542 |
} {1 {wrong # args: should be "info script ?filename?"}}
|
sl@0
|
543 |
test info-16.2 {info script option} {
|
sl@0
|
544 |
file tail [info sc]
|
sl@0
|
545 |
} "info.test"
|
sl@0
|
546 |
set gorpfile [makeFile "info script\n" gorp.info]
|
sl@0
|
547 |
test info-16.3 {info script option} {
|
sl@0
|
548 |
list [source $gorpfile] [file tail [info script]]
|
sl@0
|
549 |
} [list $gorpfile info.test]
|
sl@0
|
550 |
test info-16.4 {resetting "info script" after errors} {
|
sl@0
|
551 |
catch {source ~_nobody_/foo}
|
sl@0
|
552 |
file tail [info script]
|
sl@0
|
553 |
} "info.test"
|
sl@0
|
554 |
test info-16.5 {resetting "info script" after errors} {
|
sl@0
|
555 |
catch {source _nonexistent_}
|
sl@0
|
556 |
file tail [info script]
|
sl@0
|
557 |
} "info.test"
|
sl@0
|
558 |
test info-16.6 {info script option} {
|
sl@0
|
559 |
set script [info script]
|
sl@0
|
560 |
list [file tail [info script]] \
|
sl@0
|
561 |
[info script newname.txt] \
|
sl@0
|
562 |
[file tail [info script $script]]
|
sl@0
|
563 |
} [list info.test newname.txt info.test]
|
sl@0
|
564 |
test info-16.7 {info script option} {
|
sl@0
|
565 |
set script [info script]
|
sl@0
|
566 |
info script newname.txt
|
sl@0
|
567 |
list [source $gorpfile] [file tail [info script]] \
|
sl@0
|
568 |
[file tail [info script $script]]
|
sl@0
|
569 |
} [list $gorpfile newname.txt info.test]
|
sl@0
|
570 |
removeFile gorp.info
|
sl@0
|
571 |
set gorpfile [makeFile {list [info script] [info script foo.bar]} gorp.info]
|
sl@0
|
572 |
test info-16.8 {info script option} {
|
sl@0
|
573 |
list [source $gorpfile] [file tail [info script]]
|
sl@0
|
574 |
} [list [list $gorpfile foo.bar] info.test]
|
sl@0
|
575 |
removeFile gorp.info
|
sl@0
|
576 |
|
sl@0
|
577 |
test info-17.1 {info sharedlibextension option} {
|
sl@0
|
578 |
list [catch {info sharedlibextension foo} msg] $msg
|
sl@0
|
579 |
} {1 {wrong # args: should be "info sharedlibextension"}}
|
sl@0
|
580 |
|
sl@0
|
581 |
test info-18.1 {info tclversion option} {
|
sl@0
|
582 |
set x [info tclversion]
|
sl@0
|
583 |
scan $x "%d.%d%c" a b c
|
sl@0
|
584 |
} 2
|
sl@0
|
585 |
test info-18.2 {info tclversion option} {
|
sl@0
|
586 |
list [catch {info t 2} msg] $msg
|
sl@0
|
587 |
} {1 {wrong # args: should be "info tclversion"}}
|
sl@0
|
588 |
test info-18.3 {info tclversion option} {
|
sl@0
|
589 |
set t $tcl_version
|
sl@0
|
590 |
unset tcl_version
|
sl@0
|
591 |
set result [list [catch {info tclversion} msg] $msg]
|
sl@0
|
592 |
set tcl_version $t
|
sl@0
|
593 |
set result
|
sl@0
|
594 |
} {1 {can't read "tcl_version": no such variable}}
|
sl@0
|
595 |
|
sl@0
|
596 |
test info-19.1 {info vars option} {
|
sl@0
|
597 |
set a 1
|
sl@0
|
598 |
set b 2
|
sl@0
|
599 |
proc t1 {x y} {
|
sl@0
|
600 |
global a b
|
sl@0
|
601 |
set c 33
|
sl@0
|
602 |
return [info vars]
|
sl@0
|
603 |
}
|
sl@0
|
604 |
lsort [t1 18 19]
|
sl@0
|
605 |
} {a b c x y}
|
sl@0
|
606 |
test info-19.2 {info vars option} {
|
sl@0
|
607 |
set xxx1 1
|
sl@0
|
608 |
set xxx2 2
|
sl@0
|
609 |
proc t1 {xxa y} {
|
sl@0
|
610 |
global xxx1 xxx2
|
sl@0
|
611 |
set c 33
|
sl@0
|
612 |
return [info vars x*]
|
sl@0
|
613 |
}
|
sl@0
|
614 |
lsort [t1 18 19]
|
sl@0
|
615 |
} {xxa xxx1 xxx2}
|
sl@0
|
616 |
test info-19.3 {info vars option} {
|
sl@0
|
617 |
lsort [info vars]
|
sl@0
|
618 |
} [lsort [info globals]]
|
sl@0
|
619 |
test info-19.4 {info vars option} {
|
sl@0
|
620 |
list [catch {info vars a b} msg] $msg
|
sl@0
|
621 |
} {1 {wrong # args: should be "info vars ?pattern?"}}
|
sl@0
|
622 |
test info-19.5 {info vars with temporary variables} {
|
sl@0
|
623 |
proc t1 {} {
|
sl@0
|
624 |
foreach a {b c} {}
|
sl@0
|
625 |
info vars
|
sl@0
|
626 |
}
|
sl@0
|
627 |
t1
|
sl@0
|
628 |
} {a}
|
sl@0
|
629 |
test info-19.6 {info vars: Bug 1072654} -setup {
|
sl@0
|
630 |
namespace eval :: unset -nocomplain foo
|
sl@0
|
631 |
catch {namespace delete x}
|
sl@0
|
632 |
} -body {
|
sl@0
|
633 |
namespace eval x info vars foo
|
sl@0
|
634 |
} -cleanup {
|
sl@0
|
635 |
namespace delete x
|
sl@0
|
636 |
} -result {}
|
sl@0
|
637 |
|
sl@0
|
638 |
# Check whether the extra testing functions are defined...
|
sl@0
|
639 |
if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
|
sl@0
|
640 |
set functions {abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh wide}
|
sl@0
|
641 |
} else {
|
sl@0
|
642 |
set functions {T1 T2 T3 abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh wide}
|
sl@0
|
643 |
}
|
sl@0
|
644 |
test info-20.1 {info functions option} {info functions sin} sin
|
sl@0
|
645 |
test info-20.2 {info functions option} {lsort [info functions]} $functions
|
sl@0
|
646 |
test info-20.3 {info functions option} {
|
sl@0
|
647 |
lsort [info functions a*]
|
sl@0
|
648 |
} {abs acos asin atan atan2}
|
sl@0
|
649 |
test info-20.4 {info functions option} {
|
sl@0
|
650 |
lsort [info functions *tan*]
|
sl@0
|
651 |
} {atan atan2 tan tanh}
|
sl@0
|
652 |
test info-20.5 {info functions option} {
|
sl@0
|
653 |
list [catch {info functions raise an error} msg] $msg
|
sl@0
|
654 |
} {1 {wrong # args: should be "info functions ?pattern?"}}
|
sl@0
|
655 |
|
sl@0
|
656 |
test info-21.1 {miscellaneous error conditions} {
|
sl@0
|
657 |
list [catch {info} msg] $msg
|
sl@0
|
658 |
} {1 {wrong # args: should be "info option ?arg arg ...?"}}
|
sl@0
|
659 |
test info-21.2 {miscellaneous error conditions} !tip280 {
|
sl@0
|
660 |
list [catch {info gorp} msg] $msg
|
sl@0
|
661 |
} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
|
sl@0
|
662 |
test info-21.2-280 {miscellaneous error conditions} tip280 {
|
sl@0
|
663 |
list [catch {info gorp} msg] $msg
|
sl@0
|
664 |
} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
|
sl@0
|
665 |
test info-21.3 {miscellaneous error conditions} !tip280 {
|
sl@0
|
666 |
list [catch {info c} msg] $msg
|
sl@0
|
667 |
} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
|
sl@0
|
668 |
test info-21.3-280 {miscellaneous error conditions} tip280 {
|
sl@0
|
669 |
list [catch {info c} msg] $msg
|
sl@0
|
670 |
} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
|
sl@0
|
671 |
test info-21.4 {miscellaneous error conditions} !tip280 {
|
sl@0
|
672 |
list [catch {info l} msg] $msg
|
sl@0
|
673 |
} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
|
sl@0
|
674 |
test info-21.4-280 {miscellaneous error conditions} tip280 {
|
sl@0
|
675 |
list [catch {info l} msg] $msg
|
sl@0
|
676 |
} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
|
sl@0
|
677 |
test info-21.5 {miscellaneous error conditions} !tip280 {
|
sl@0
|
678 |
list [catch {info s} msg] $msg
|
sl@0
|
679 |
} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
|
sl@0
|
680 |
test info-21.5-280 {miscellaneous error conditions} tip280 {
|
sl@0
|
681 |
list [catch {info s} msg] $msg
|
sl@0
|
682 |
} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
|
sl@0
|
683 |
|
sl@0
|
684 |
##
|
sl@0
|
685 |
# ### ### ### ######### ######### #########
|
sl@0
|
686 |
## info frame
|
sl@0
|
687 |
|
sl@0
|
688 |
## Helper
|
sl@0
|
689 |
# For the more complex results we cut the file name down to remove
|
sl@0
|
690 |
# path dependencies, and we use only part of the first line of the
|
sl@0
|
691 |
# reported command. The latter is required because otherwise the whole
|
sl@0
|
692 |
# test case may appear in some results, but the result is part of the
|
sl@0
|
693 |
# testcase. An infinite string would be required to describe that. The
|
sl@0
|
694 |
# cutting-down breaks this.
|
sl@0
|
695 |
|
sl@0
|
696 |
proc reduce {frame} {
|
sl@0
|
697 |
set pos [lsearch -exact $frame cmd]
|
sl@0
|
698 |
incr pos
|
sl@0
|
699 |
set cmd [lindex $frame $pos]
|
sl@0
|
700 |
if {[regexp \n $cmd]} {
|
sl@0
|
701 |
set first [string range [lindex [split $cmd \n] 0] 0 end-11]
|
sl@0
|
702 |
set frame [lreplace $frame $pos $pos $first]
|
sl@0
|
703 |
}
|
sl@0
|
704 |
set pos [lsearch -exact $frame file]
|
sl@0
|
705 |
if {$pos >=0} {
|
sl@0
|
706 |
incr pos
|
sl@0
|
707 |
set tail [file tail [lindex $frame $pos]]
|
sl@0
|
708 |
set frame [lreplace $frame $pos $pos $tail]
|
sl@0
|
709 |
}
|
sl@0
|
710 |
set frame
|
sl@0
|
711 |
}
|
sl@0
|
712 |
|
sl@0
|
713 |
## Helper
|
sl@0
|
714 |
# Generate a stacktrace from the current location to top. This code
|
sl@0
|
715 |
# not only depends on the exact location of things, but also on the
|
sl@0
|
716 |
# implementation of tcltest. Any changes and these tests will have to
|
sl@0
|
717 |
# be updated.
|
sl@0
|
718 |
|
sl@0
|
719 |
proc etrace {} {
|
sl@0
|
720 |
set res {}
|
sl@0
|
721 |
set level [info frame]
|
sl@0
|
722 |
while {$level} {
|
sl@0
|
723 |
lappend res [list $level [reduce [info frame $level]]]
|
sl@0
|
724 |
incr level -1
|
sl@0
|
725 |
}
|
sl@0
|
726 |
return $res
|
sl@0
|
727 |
}
|
sl@0
|
728 |
|
sl@0
|
729 |
##
|
sl@0
|
730 |
|
sl@0
|
731 |
test info-22.0 {info frame, levels} tip280 {
|
sl@0
|
732 |
info frame
|
sl@0
|
733 |
} 7
|
sl@0
|
734 |
|
sl@0
|
735 |
test info-22.1 {info frame, bad level relative} tip280 {
|
sl@0
|
736 |
# catch is another level!, i.e. we have 8, not 7
|
sl@0
|
737 |
catch {info frame -8} msg
|
sl@0
|
738 |
set msg
|
sl@0
|
739 |
} {bad level "-8"}
|
sl@0
|
740 |
|
sl@0
|
741 |
test info-22.2 {info frame, bad level absolute} tip280 {
|
sl@0
|
742 |
# catch is another level!, i.e. we have 8, not 7
|
sl@0
|
743 |
catch {info frame 9} msg
|
sl@0
|
744 |
set msg
|
sl@0
|
745 |
} {bad level "9"}
|
sl@0
|
746 |
|
sl@0
|
747 |
test info-22.3 {info frame, current, relative} tip280 {
|
sl@0
|
748 |
info frame 0
|
sl@0
|
749 |
} {type eval line 2 cmd {info frame 0}}
|
sl@0
|
750 |
|
sl@0
|
751 |
test info-22.4 {info frame, current, relative, nested} tip280 {
|
sl@0
|
752 |
set res [info frame 0]
|
sl@0
|
753 |
} {type eval line 2 cmd {info frame 0}}
|
sl@0
|
754 |
|
sl@0
|
755 |
test info-22.5 {info frame, current, absolute} tip280 {
|
sl@0
|
756 |
reduce [info frame 7]
|
sl@0
|
757 |
} {type eval line 2 cmd {info frame 7}}
|
sl@0
|
758 |
|
sl@0
|
759 |
test info-22.6 {info frame, global, relative} tip280 {
|
sl@0
|
760 |
reduce [info frame -6]
|
sl@0
|
761 |
} {type source line 759 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relativ}
|
sl@0
|
762 |
|
sl@0
|
763 |
test info-22.7 {info frame, global, absolute} tip280 {
|
sl@0
|
764 |
reduce [info frame 1]
|
sl@0
|
765 |
} {type source line 763 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolut}
|
sl@0
|
766 |
|
sl@0
|
767 |
test info-22.8 {info frame, basic trace} tip280 {
|
sl@0
|
768 |
join [etrace] \n
|
sl@0
|
769 |
} {8 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
|
sl@0
|
770 |
7 {type eval line 2 cmd etrace}
|
sl@0
|
771 |
6 {type source line 2277 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest}
|
sl@0
|
772 |
5 {type eval line 1 cmd {::tcltest::RunTest }}
|
sl@0
|
773 |
4 {type source line 1619 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::Eval}
|
sl@0
|
774 |
3 {type eval line 1 cmd ::tcltest::Eval\ \{::tcltest::RunTest\ }
|
sl@0
|
775 |
2 {type source line 1966 file tcltest.tcl cmd {uplevel 1 [list [namespace origin Eval] $command 1]} proc ::tcltest::test}
|
sl@0
|
776 |
1 {type source line 767 file info.test cmd test\ info-22.8\ \{info\ frame,\ basic\ trac}}
|
sl@0
|
777 |
## The line 1966 is off by 5 from the true value of 1971. This is a knownBug, see testcase 30.0
|
sl@0
|
778 |
test info-23.0 {eval'd info frame} tip280 {
|
sl@0
|
779 |
eval {info frame}
|
sl@0
|
780 |
} 8
|
sl@0
|
781 |
|
sl@0
|
782 |
test info-23.1 {eval'd info frame, semi-dynamic} tip280 {
|
sl@0
|
783 |
eval info frame
|
sl@0
|
784 |
} 8
|
sl@0
|
785 |
|
sl@0
|
786 |
test info-23.2 {eval'd info frame, dynamic} tip280 {
|
sl@0
|
787 |
set script {info frame}
|
sl@0
|
788 |
eval $script
|
sl@0
|
789 |
} 8
|
sl@0
|
790 |
|
sl@0
|
791 |
test info-23.3 {eval'd info frame, literal} tip280 {
|
sl@0
|
792 |
eval {
|
sl@0
|
793 |
info frame 0
|
sl@0
|
794 |
}
|
sl@0
|
795 |
} {type eval line 2 cmd {info frame 0}}
|
sl@0
|
796 |
|
sl@0
|
797 |
test info-23.4 {eval'd info frame, semi-dynamic} tip280 {
|
sl@0
|
798 |
eval info frame 0
|
sl@0
|
799 |
} {type eval line 1 cmd {info frame 0}}
|
sl@0
|
800 |
|
sl@0
|
801 |
test info-23.5 {eval'd info frame, dynamic} tip280 {
|
sl@0
|
802 |
set script {info frame 0}
|
sl@0
|
803 |
eval $script
|
sl@0
|
804 |
} {type eval line 1 cmd {info frame 0}}
|
sl@0
|
805 |
|
sl@0
|
806 |
test info-23.6 {eval'd info frame, trace} tip280 {
|
sl@0
|
807 |
set script {etrace}
|
sl@0
|
808 |
join [eval $script] \n
|
sl@0
|
809 |
} {9 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
|
sl@0
|
810 |
8 {type eval line 1 cmd etrace}
|
sl@0
|
811 |
7 {type eval line 3 cmd {eval $script}}
|
sl@0
|
812 |
6 {type source line 2277 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest}
|
sl@0
|
813 |
5 {type eval line 1 cmd {::tcltest::RunTest }}
|
sl@0
|
814 |
4 {type source line 1619 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::Eval}
|
sl@0
|
815 |
3 {type eval line 1 cmd ::tcltest::Eval\ \{::tcltest::RunTest\ }
|
sl@0
|
816 |
2 {type source line 1966 file tcltest.tcl cmd {uplevel 1 [list [namespace origin Eval] $command 1]} proc ::tcltest::test}
|
sl@0
|
817 |
1 {type source line 806 file info.test cmd test\ info-23.6\ \{eval'd\ info\ frame,\ trac}}
|
sl@0
|
818 |
## The line 1966 is off by 5 from the true value of 1971. This is a knownBug, see testcase 30.0
|
sl@0
|
819 |
# -------------------------------------------------------------------------
|
sl@0
|
820 |
|
sl@0
|
821 |
# Procedures defined in scripts which are arguments to control
|
sl@0
|
822 |
# structures (like 'namespace eval', 'interp eval', 'if', 'while',
|
sl@0
|
823 |
# 'switch', 'catch', 'for', 'foreach', etc.) have no absolute
|
sl@0
|
824 |
# location. The command implementations execute such scripts through
|
sl@0
|
825 |
# Tcl_EvalObjEx. Flag 0 causes it to use the bytecode compiler. This
|
sl@0
|
826 |
# causes the connection to the context to be lost. Currently only
|
sl@0
|
827 |
# procedure bodies are able to remember their context.
|
sl@0
|
828 |
|
sl@0
|
829 |
# -------------------------------------------------------------------------
|
sl@0
|
830 |
|
sl@0
|
831 |
namespace eval foo {
|
sl@0
|
832 |
proc bar {} {info frame 0}
|
sl@0
|
833 |
}
|
sl@0
|
834 |
|
sl@0
|
835 |
test info-24.0 {info frame, interaction, namespace eval} tip280 {
|
sl@0
|
836 |
reduce [foo::bar]
|
sl@0
|
837 |
} {type source line 832 file info.test cmd {info frame 0} proc ::foo::bar level 0}
|
sl@0
|
838 |
|
sl@0
|
839 |
namespace delete foo
|
sl@0
|
840 |
|
sl@0
|
841 |
# -------------------------------------------------------------------------
|
sl@0
|
842 |
|
sl@0
|
843 |
set flag 1
|
sl@0
|
844 |
if {$flag} {
|
sl@0
|
845 |
namespace eval foo {}
|
sl@0
|
846 |
proc ::foo::bar {} {info frame 0}
|
sl@0
|
847 |
}
|
sl@0
|
848 |
|
sl@0
|
849 |
test info-24.1 {info frame, interaction, if} tip280 {
|
sl@0
|
850 |
reduce [foo::bar]
|
sl@0
|
851 |
} {type source line 846 file info.test cmd {info frame 0} proc ::foo::bar level 0}
|
sl@0
|
852 |
|
sl@0
|
853 |
namespace delete foo
|
sl@0
|
854 |
|
sl@0
|
855 |
# -------------------------------------------------------------------------
|
sl@0
|
856 |
|
sl@0
|
857 |
set flag 1
|
sl@0
|
858 |
while {$flag} {
|
sl@0
|
859 |
namespace eval foo {}
|
sl@0
|
860 |
proc ::foo::bar {} {info frame 0}
|
sl@0
|
861 |
set flag 0
|
sl@0
|
862 |
}
|
sl@0
|
863 |
|
sl@0
|
864 |
test info-24.2 {info frame, interaction, while} tip280 {
|
sl@0
|
865 |
reduce [foo::bar]
|
sl@0
|
866 |
} {type source line 860 file info.test cmd {info frame 0} proc ::foo::bar level 0}
|
sl@0
|
867 |
|
sl@0
|
868 |
namespace delete foo
|
sl@0
|
869 |
|
sl@0
|
870 |
# -------------------------------------------------------------------------
|
sl@0
|
871 |
|
sl@0
|
872 |
catch {
|
sl@0
|
873 |
namespace eval foo {}
|
sl@0
|
874 |
proc ::foo::bar {} {info frame 0}
|
sl@0
|
875 |
}
|
sl@0
|
876 |
|
sl@0
|
877 |
test info-24.3 {info frame, interaction, catch} tip280 {
|
sl@0
|
878 |
reduce [foo::bar]
|
sl@0
|
879 |
} {type source line 874 file info.test cmd {info frame 0} proc ::foo::bar level 0}
|
sl@0
|
880 |
|
sl@0
|
881 |
namespace delete foo
|
sl@0
|
882 |
|
sl@0
|
883 |
# -------------------------------------------------------------------------
|
sl@0
|
884 |
|
sl@0
|
885 |
foreach var val {
|
sl@0
|
886 |
namespace eval foo {}
|
sl@0
|
887 |
proc ::foo::bar {} {info frame 0}
|
sl@0
|
888 |
break
|
sl@0
|
889 |
}
|
sl@0
|
890 |
|
sl@0
|
891 |
test info-24.4 {info frame, interaction, foreach} tip280 {
|
sl@0
|
892 |
reduce [foo::bar]
|
sl@0
|
893 |
} {type source line 887 file info.test cmd {info frame 0} proc ::foo::bar level 0}
|
sl@0
|
894 |
|
sl@0
|
895 |
namespace delete foo
|
sl@0
|
896 |
|
sl@0
|
897 |
# -------------------------------------------------------------------------
|
sl@0
|
898 |
|
sl@0
|
899 |
for {} {1} {} {
|
sl@0
|
900 |
namespace eval foo {}
|
sl@0
|
901 |
proc ::foo::bar {} {info frame 0}
|
sl@0
|
902 |
break
|
sl@0
|
903 |
}
|
sl@0
|
904 |
|
sl@0
|
905 |
test info-24.5 {info frame, interaction, for} tip280 {
|
sl@0
|
906 |
reduce [foo::bar]
|
sl@0
|
907 |
} {type source line 901 file info.test cmd {info frame 0} proc ::foo::bar level 0}
|
sl@0
|
908 |
|
sl@0
|
909 |
namespace delete foo
|
sl@0
|
910 |
|
sl@0
|
911 |
# -------------------------------------------------------------------------
|
sl@0
|
912 |
|
sl@0
|
913 |
eval {
|
sl@0
|
914 |
proc bar {} {info frame 0}
|
sl@0
|
915 |
}
|
sl@0
|
916 |
|
sl@0
|
917 |
test info-25.0 {info frame, proc in eval} tip280 {
|
sl@0
|
918 |
reduce [bar]
|
sl@0
|
919 |
} {type source line 914 file info.test cmd {info frame 0} proc ::bar level 0}
|
sl@0
|
920 |
|
sl@0
|
921 |
proc bar {} {info frame 0}
|
sl@0
|
922 |
test info-25.1 {info frame, regular proc} tip280 {
|
sl@0
|
923 |
reduce [bar]
|
sl@0
|
924 |
} {type source line 921 file info.test cmd {info frame 0} proc ::bar level 0}
|
sl@0
|
925 |
rename bar {}
|
sl@0
|
926 |
|
sl@0
|
927 |
|
sl@0
|
928 |
|
sl@0
|
929 |
test info-30.0 {bs+nl in literal words} {tip280 knownBug} {
|
sl@0
|
930 |
if {1} {
|
sl@0
|
931 |
set res \
|
sl@0
|
932 |
[reduce [info frame 0]]
|
sl@0
|
933 |
}
|
sl@0
|
934 |
set res
|
sl@0
|
935 |
# This is reporting line 3 instead of the correct 4 because the
|
sl@0
|
936 |
# bs+nl combination is subst by the parser before the 'if'
|
sl@0
|
937 |
# command, and the the bcc sees the word. To fix record the
|
sl@0
|
938 |
# offsets of all bs+nl sequences in literal words, then use the
|
sl@0
|
939 |
# information in the bcc to bump line numbers when parsing over
|
sl@0
|
940 |
# the location. Also affected: testcases 22.8 and 23.6.
|
sl@0
|
941 |
} {type eval line 4 cmd {info frame 0} proc ::tcltest::RunTest}
|
sl@0
|
942 |
|
sl@0
|
943 |
|
sl@0
|
944 |
|
sl@0
|
945 |
# -------------------------------------------------------------------------
|
sl@0
|
946 |
# See 24.0 - 24.5 for similar situations, using literal scripts.
|
sl@0
|
947 |
|
sl@0
|
948 |
set body {set flag 0
|
sl@0
|
949 |
set a c
|
sl@0
|
950 |
set res [info frame 0]} ;# line 3!
|
sl@0
|
951 |
|
sl@0
|
952 |
test info-31.0 {ns eval, script in variable} tip280 {
|
sl@0
|
953 |
namespace eval foo $body
|
sl@0
|
954 |
set res
|
sl@0
|
955 |
} {type eval line 3 cmd {info frame 0} level 0}
|
sl@0
|
956 |
catch {namespace delete foo}
|
sl@0
|
957 |
|
sl@0
|
958 |
|
sl@0
|
959 |
test info-31.1 {if, script in variable} tip280 {
|
sl@0
|
960 |
if 1 $body
|
sl@0
|
961 |
set res
|
sl@0
|
962 |
} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
|
sl@0
|
963 |
|
sl@0
|
964 |
test info-31.1a {if, script in variable} tip280 {
|
sl@0
|
965 |
if 1 then $body
|
sl@0
|
966 |
set res
|
sl@0
|
967 |
} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
|
sl@0
|
968 |
|
sl@0
|
969 |
|
sl@0
|
970 |
|
sl@0
|
971 |
test info-31.2 {while, script in variable} tip280 {
|
sl@0
|
972 |
set flag 1
|
sl@0
|
973 |
while {$flag} $body
|
sl@0
|
974 |
set res
|
sl@0
|
975 |
} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
|
sl@0
|
976 |
|
sl@0
|
977 |
# .3 - proc - scoping prevent return of result ...
|
sl@0
|
978 |
|
sl@0
|
979 |
test info-31.4 {foreach, script in variable} tip280 {
|
sl@0
|
980 |
foreach var val $body
|
sl@0
|
981 |
set res
|
sl@0
|
982 |
} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
|
sl@0
|
983 |
|
sl@0
|
984 |
test info-31.5 {for, script in variable} tip280 {
|
sl@0
|
985 |
set flag 1
|
sl@0
|
986 |
for {} {$flag} {} $body
|
sl@0
|
987 |
set res
|
sl@0
|
988 |
} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
|
sl@0
|
989 |
|
sl@0
|
990 |
test info-31.6 {eval, script in variable} tip280 {
|
sl@0
|
991 |
eval $body
|
sl@0
|
992 |
set res
|
sl@0
|
993 |
} {type eval line 3 cmd {info frame 0}}
|
sl@0
|
994 |
|
sl@0
|
995 |
# -------------------------------------------------------------------------
|
sl@0
|
996 |
|
sl@0
|
997 |
namespace eval foo {}
|
sl@0
|
998 |
set x foo
|
sl@0
|
999 |
switch -exact -- $x {
|
sl@0
|
1000 |
foo {
|
sl@0
|
1001 |
proc ::foo::bar {} {info frame 0}
|
sl@0
|
1002 |
}
|
sl@0
|
1003 |
}
|
sl@0
|
1004 |
|
sl@0
|
1005 |
test info-24.6.0 {info frame, interaction, switch, list body} tip280 {
|
sl@0
|
1006 |
reduce [foo::bar]
|
sl@0
|
1007 |
} {type source line 1001 file info.test cmd {info frame 0} proc ::foo::bar level 0}
|
sl@0
|
1008 |
|
sl@0
|
1009 |
namespace delete foo
|
sl@0
|
1010 |
unset x
|
sl@0
|
1011 |
|
sl@0
|
1012 |
# -------------------------------------------------------------------------
|
sl@0
|
1013 |
|
sl@0
|
1014 |
namespace eval foo {}
|
sl@0
|
1015 |
set x foo
|
sl@0
|
1016 |
switch -exact -- $x foo {
|
sl@0
|
1017 |
proc ::foo::bar {} {info frame 0}
|
sl@0
|
1018 |
}
|
sl@0
|
1019 |
|
sl@0
|
1020 |
test info-24.6.1 {info frame, interaction, switch, multi-body} tip280 {
|
sl@0
|
1021 |
reduce [foo::bar]
|
sl@0
|
1022 |
} {type source line 1017 file info.test cmd {info frame 0} proc ::foo::bar level 0}
|
sl@0
|
1023 |
|
sl@0
|
1024 |
namespace delete foo
|
sl@0
|
1025 |
unset x
|
sl@0
|
1026 |
|
sl@0
|
1027 |
# -------------------------------------------------------------------------
|
sl@0
|
1028 |
|
sl@0
|
1029 |
namespace eval foo {}
|
sl@0
|
1030 |
set x foo
|
sl@0
|
1031 |
switch -exact -- $x [list foo {
|
sl@0
|
1032 |
proc ::foo::bar {} {info frame 0}
|
sl@0
|
1033 |
}]
|
sl@0
|
1034 |
|
sl@0
|
1035 |
test info-24.6.2 {info frame, interaction, switch, list body, dynamic} tip280 {
|
sl@0
|
1036 |
reduce [foo::bar]
|
sl@0
|
1037 |
} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
|
sl@0
|
1038 |
|
sl@0
|
1039 |
namespace delete foo
|
sl@0
|
1040 |
unset x
|
sl@0
|
1041 |
|
sl@0
|
1042 |
# -------------------------------------------------------------------------
|
sl@0
|
1043 |
|
sl@0
|
1044 |
set body {
|
sl@0
|
1045 |
foo {
|
sl@0
|
1046 |
proc ::foo::bar {} {info frame 0}
|
sl@0
|
1047 |
}
|
sl@0
|
1048 |
}
|
sl@0
|
1049 |
|
sl@0
|
1050 |
namespace eval foo {}
|
sl@0
|
1051 |
set x foo
|
sl@0
|
1052 |
switch -exact -- $x $body
|
sl@0
|
1053 |
|
sl@0
|
1054 |
test info-31.7 {info frame, interaction, switch, dynamic} tip280 {
|
sl@0
|
1055 |
reduce [foo::bar]
|
sl@0
|
1056 |
} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
|
sl@0
|
1057 |
|
sl@0
|
1058 |
namespace delete foo
|
sl@0
|
1059 |
unset x
|
sl@0
|
1060 |
|
sl@0
|
1061 |
# -------------------------------------------------------------------------
|
sl@0
|
1062 |
|
sl@0
|
1063 |
set body {
|
sl@0
|
1064 |
proc ::foo::bar {} {info frame 0}
|
sl@0
|
1065 |
}
|
sl@0
|
1066 |
|
sl@0
|
1067 |
namespace eval foo {}
|
sl@0
|
1068 |
eval $body
|
sl@0
|
1069 |
|
sl@0
|
1070 |
test info-32.0 {info frame, dynamic procedure} tip280 {
|
sl@0
|
1071 |
reduce [foo::bar]
|
sl@0
|
1072 |
} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
|
sl@0
|
1073 |
|
sl@0
|
1074 |
namespace delete foo
|
sl@0
|
1075 |
|
sl@0
|
1076 |
# -------------------------------------------------------------------------
|
sl@0
|
1077 |
|
sl@0
|
1078 |
# cleanup
|
sl@0
|
1079 |
catch {namespace delete test_ns_info1 test_ns_info2}
|
sl@0
|
1080 |
::tcltest::cleanupTests
|
sl@0
|
1081 |
return
|