1# -*- tcl -*-
2# Commands covered:  info
3#
4# This file contains a collection of tests for one or more of the Tcl
5# built-in commands.  Sourcing this file into Tcl runs the tests and
6# generates output for errors.  No output means no errors were found.
7#
8# Copyright © 1991-1994 The Regents of the University of California.
9# Copyright © 1994-1997 Sun Microsystems, Inc.
10# Copyright © 1998-1999 Scriptics Corporation.
11# Copyright © 2006 ActiveState
12#
13# See the file "license.terms" for information on usage and redistribution
14# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15#
16# DO NOT DELETE THIS LINE
17
18if {{::tcltest} ni [namespace children]} {
19    package require tcltest 2.5
20    namespace import -force ::tcltest::*
21}
22::tcltest::loadTestedCommands
23catch [list package require -exact tcl::test [info patchlevel]]
24testConstraint zlib [llength [info commands zlib]]
25testConstraint nodep [info exists tcl_precision]
26# Set up namespaces needed to test operation of "info args", "info body",
27# "info default", and "info procs" with imported procedures.
28
29catch {namespace delete test_ns_info1 test_ns_info2}
30
31namespace eval test_ns_info1 {
32    namespace export *
33    proc p {x} {return "x=$x"}
34    proc q {{y 27} {z {}}} {return "y=$y"}
35}
36
37test info-1.1 {info args option} {
38    proc t1 {a bbb c} {return foo}
39    info args t1
40} {a bbb c}
41test info-1.2 {info args option} {
42    proc t1 {{a default1} {bbb default2} {c default3} args} {return foo}
43    info a t1
44} {a bbb c args}
45test info-1.3 {info args option} {
46    proc t1 "" {return foo}
47    info args t1
48} {}
49test info-1.4 {info args option} -body {
50    catch {rename t1 {}}
51    info args t1
52} -returnCodes error -result {"t1" isn't a procedure}
53test info-1.5 {info args option} -body {
54    info args set
55} -returnCodes error -result {"set" isn't a procedure}
56test info-1.6 {info args option} {
57    proc t1 {a b} {set c 123; set d $c}
58    t1 1 2
59    info args t1
60} {a b}
61test info-1.7 {info args option} {
62    catch {namespace delete test_ns_info2}
63    namespace eval test_ns_info2 {
64        namespace import ::test_ns_info1::*
65        list [info args p] [info args q]
66    }
67} {x {y z}}
68
69test info-2.1 {info body option} {
70    proc t1 {} {body of t1}
71    info body t1
72} {body of t1}
73test info-2.2 {info body option} -body {
74    info body set
75} -returnCodes error -result {"set" isn't a procedure}
76test info-2.3 {info body option} -body {
77    info args set 1
78} -returnCodes error -result {wrong # args: should be "info args procname"}
79test info-2.4 {info body option} {
80    catch {namespace delete test_ns_info2}
81    namespace eval test_ns_info2 {
82        namespace import ::test_ns_info1::*
83        list [info body p] [info body q]
84    }
85} {{return "x=$x"} {return "y=$y"}}
86# Prior to 8.3.0 this would cause a crash because [info body]
87# would return the bytecompiled version of foo, which the catch
88# would then try and eval out of the foo context, accessing
89# compiled local indices
90test info-2.5 {info body option, returning bytecompiled bodies} -body {
91    catch {unset args}
92    proc foo {args} {
93	foreach v $args {
94	    upvar $v var
95	    return "variable $v existence: [info exists var]"
96	}
97    }
98    foo a
99    eval [info body foo]
100} -returnCodes error -result {can't read "args": no such variable}
101# Fix for problem tested for in info-2.5 caused problems when
102# procedure body had no string rep (i.e. was not yet bytecode)
103# causing an empty string to be returned [Bug #545644]
104test info-2.6 {info body option, returning list bodies} nodep {
105    proc foo args [list subst bar]
106    list [string bytelength [info body foo]] \
107	    [foo; string bytelength [info body foo]]
108} {9 9}
109
110proc testinfocmdcount {} {
111    set x [info cmdcount]
112    set y 12345
113    set z [info cmdc]
114    expr {$z-$x}
115}
116test info-3.1 {info cmdcount compiled} {
117    testinfocmdcount
118} 4
119test info-3.2 {info cmdcount evaled} -body {
120    set x [info cmdcount]
121    set y 12345
122    set z [info cmdc]
123    expr {$z-$x}
124} -cleanup {unset x y z} -result 4
125test info-3.3 {info cmdcount evaled} -body [info body testinfocmdcount] -cleanup {unset x y z} -result 4
126test info-3.4 {info cmdcount option} -body {
127    info cmdcount 1
128} -returnCodes error -result {wrong # args: should be "info cmdcount"}
129
130test info-4.1 {info commands option} -body {
131    proc t1 {} {}
132    proc t2 {} {}
133    set x " [info commands] "
134    list [string match {* t1 *} $x] [string match {* t2 *} $x] \
135            [string match {* set *} $x] [string match {* list *} $x]
136} -cleanup {unset x} -result {1 1 1 1}
137test info-4.2 {info commands option} -body {
138    proc t1 {} {}
139    rename t1 {}
140    string match {* t1 *} \
141	[info comm]
142} -result 0
143test info-4.3 {info commands option} {
144    proc _t1_ {} {}
145    proc _t2_ {} {}
146    info commands _t1_
147} _t1_
148test info-4.4 {info commands option} {
149    proc _t1_ {} {}
150    proc _t2_ {} {}
151    lsort [info commands _t*]
152} {_t1_ _t2_}
153catch {rename _t1_ {}}
154catch {rename _t2_ {}}
155test info-4.5 {info commands option} -returnCodes error -body {
156    info commands a b
157} -result {wrong # args: should be "info commands ?pattern?"}
158# Also some tests in namespace.test
159
160test info-5.1 {info complete option} -body {
161    info complete
162} -returnCodes error -result {wrong # args: should be "info complete command"}
163test info-5.2 {info complete option} {
164    info complete abc
165} 1
166test info-5.3 {info complete option} {
167    info complete "\{abcd "
168} 0
169test info-5.4 {info complete option} {
170    info complete {# Comment should be complete command}
171} 1
172test info-5.5 {info complete option} {
173    info complete {[a [b] }
174} 0
175test info-5.6 {info complete option} {
176    info complete {[a [b]}
177} 0
178
179test info-6.1 {info default option} {
180    proc t1 {a b {c d} {e "long default value"}} {}
181    info default t1 a value
182} 0
183test info-6.2 {info default option} -body {
184    proc t1 {a b {c d} {e "long default value"}} {}
185    set value 12345
186    info d t1 a value
187    return $value
188} -cleanup {unset value} -result {}
189test info-6.3 {info default option} -body {
190    proc t1 {a b {c d} {e "long default value"}} {}
191    info default t1 c value
192} -cleanup {unset value} -result 1
193test info-6.4 {info default option} -body {
194    proc t1 {a b {c d} {e "long default value"}} {}
195    set value 12345
196    info default t1 c value
197    return $value
198} -cleanup {unset value} -result d
199test info-6.5 {info default option} -body {
200    proc t1 {a b {c d} {e "long default value"}} {}
201    set value 12345
202    set x [info default t1 e value]
203    list $x $value
204} -cleanup {unset x value} -result {1 {long default value}}
205test info-6.6 {info default option} -returnCodes error -body {
206    info default a b
207} -result {wrong # args: should be "info default procname arg varname"}
208test info-6.7 {info default option} -returnCodes error -body {
209    info default _nonexistent_ a b
210} -result {"_nonexistent_" isn't a procedure}
211test info-6.8 {info default option} -returnCodes error -body {
212    proc t1 {a b} {}
213    info default t1 x value
214} -result {procedure "t1" doesn't have an argument "x"}
215test info-6.9 {info default option} -returnCodes error -setup {
216    catch {unset a}
217} -cleanup {unset a} -body {
218    set a(0) 88
219    proc t1 {a b} {}
220    info default t1 a a
221} -returnCodes error -result {can't set "a": variable is array}
222test info-6.10 {info default option} -setup {
223    catch {unset a}
224} -cleanup {unset a} -body {
225    set a(0) 88
226    proc t1 {{a 18} b} {}
227    info default t1 a a
228} -returnCodes error -result {can't set "a": variable is array}
229test info-6.11 {info default option} {
230    catch {namespace delete test_ns_info2}
231    namespace eval test_ns_info2 {
232        namespace import ::test_ns_info1::*
233        list [info default p x foo] $foo [info default q y bar] $bar
234    }
235} {0 {} 1 27}
236
237test info-7.1 {info exists option} -body {
238    set value foo
239    info exists value
240} -cleanup {unset value} -result 1
241
242test info-7.2 {info exists option} -setup {catch {unset _nonexistent_}} -body {
243    info exists _nonexistent_
244} -result 0
245test info-7.3 {info exists option} {
246    proc t1 {x} {return [info exists x]}
247    t1 2
248} 1
249test info-7.4 {info exists option} -body {
250    proc t1 {x} {
251        global _nonexistent_
252        return [info exists _nonexistent_]
253    }
254    t1 2
255} -setup {unset -nocomplain _nonexistent_} -result 0
256test info-7.5 {info exists option} {
257    proc t1 {x} {
258        set y 47
259        return [info exists y]
260    }
261    t1 2
262} 1
263test info-7.6 {info exists option} {
264    proc t1 {x} {return [info exists value]}
265    t1 2
266} 0
267test info-7.7 {info exists option} -setup {
268    catch {unset x}
269} -body {
270    set x(2) 44
271    list [info exists x] [info exists x(1)] [info exists x(2)]
272} -result {1 0 1}
273catch {unset x}
274test info-7.8 {info exists option} -body {
275    info exists
276} -returnCodes error -result {wrong # args: should be "info exists varName"}
277test info-7.9 {info exists option} -body {
278    info exists 1 2
279} -returnCodes error -result {wrong # args: should be "info exists varName"}
280
281test info-8.1 {info globals option} -body {
282    set x 1
283    set y 2
284    set value 23
285    set a " [info globals] "
286    list [string match {* x *} $a] [string match {* y *} $a] \
287            [string match {* value *} $a] [string match {* _foobar_ *} $a]
288} -cleanup {unset x y value a} -result {1 1 1 0}
289test info-8.2 {info globals option} -body {
290    set _xxx1 1
291    set _xxx2 2
292    lsort [info g _xxx*]
293} -cleanup {unset _xxx1 _xxx2} -result {_xxx1 _xxx2}
294test info-8.3 {info globals option} -returnCodes error -body {
295    info globals 1 2
296} -result {wrong # args: should be "info globals ?pattern?"}
297test info-8.4 {info globals option: may have leading namespace qualifiers} -body {
298    set x 0
299    list [info globals x] [info globals :x] [info globals ::x] [info globals :::x] [info globals ::::x]
300} -cleanup {unset x} -result {x {} x x x}
301test info-8.5 {info globals option: only return existing global variables} {
302    -setup {
303	unset -nocomplain ::NO_SUCH_VAR
304	proc evalInProc script {eval $script}
305    }
306    -body {
307	evalInProc {global NO_SUCH_VAR; info globals NO_SUCH_VAR}
308    }
309    -cleanup {
310	rename evalInProc {}
311    }
312    -result {}
313}
314
315test info-9.1 {info level option} {
316    info level
317} 0
318test info-9.2 {info level option} {
319    proc t1 {a b} {
320        set x [info le]
321        set y [info level 1]
322        list $x $y
323    }
324    t1 146 testString
325} {1 {t1 146 testString}}
326test info-9.3 {info level option} {
327    proc t1 {a b} {
328        t2 [expr {$a*2}] $b
329    }
330    proc t2 {x y} {
331        list [info level] [info level 1] [info level 2] [info level -1] \
332                [info level 0]
333    }
334    t1 146 {a {b c} {{{c}}}}
335} {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}}}}}}
336test info-9.4 {info level option} {
337    proc t1 {} {
338        set x [info level]
339        set y [info level 1]
340        list $x $y
341    }
342    t1
343} {1 t1}
344test info-9.5 {info level option} -body {
345    info level 1 2
346} -returnCodes error -result {wrong # args: should be "info level ?number?"}
347test info-9.6 {info level option} -body {
348    info level 123a
349} -returnCodes error -result {expected integer but got "123a"}
350test info-9.7 {info level option} -body {
351    info level 0
352} -returnCodes error -result {bad level "0"}
353test info-9.8 {info level option} -body {
354    proc t1 {} {info level -1}
355    t1
356} -returnCodes error -result {bad level "-1"}
357test info-9.9 {info level option} -body {
358    proc t1 {x} {info level $x}
359    t1 -3
360} -returnCodes error -result {bad level "-3"}
361test info-9.10 {info level option, namespaces} -body {
362    namespace eval t {info level 0}
363} -cleanup {
364    namespace delete t
365} -result {namespace eval t {info level 0}}
366test info-9.11 {info level option, aliases} -constraints knownBug -setup {
367    proc w {x y z} {info level 0}
368    interp alias {} a {} w a b
369} -body {
370    a c
371} -cleanup {
372    rename a {}
373    rename w {}
374} -result {a c}
375test info-9.12 {info level option, ensembles} -constraints knownBug -setup {
376    proc w {x y z} {info level 0}
377    namespace ensemble create -command a -map {foo ::w}
378} -body {
379    a foo 1 2 3
380} -cleanup {
381    rename a {}
382    rename w {}
383} -result {a foo 1 2 3}
384
385set savedLibrary $tcl_library
386test info-10.1 {info library option} -body {
387    info library x
388} -returnCodes error -result {wrong # args: should be "info library"}
389test info-10.2 {info library option} {
390    set tcl_library 12345
391    info library
392} {12345}
393test info-10.3 {info library option} -body {
394    unset tcl_library
395    info library
396} -returnCodes error -result {no library has been specified for Tcl}
397set tcl_library $savedLibrary; unset savedLibrary
398
399test info-11.1 {info loaded option} -body {
400    info loaded a b c
401} -returnCodes error -result {wrong # args: should be "info loaded ?interp? ?packageName?"}
402test info-11.2 {info loaded option} -body {
403    info loaded {}; info loaded gorp
404} -returnCodes error -result {could not find interpreter "gorp"}
405
406test info-12.1 {info locals option} -body {
407    set a 22
408    proc t1 {x y} {
409        set b 13
410        set c testing
411        global a
412	global aa
413	set aa 23
414        return [info locals]
415    }
416    lsort [t1 23 24]
417} -cleanup {unset a aa} -result {b c x y}
418test info-12.2 {info locals option} {
419    proc t1 {x y} {
420        set xx1 2
421        set xx2 3
422        set y 4
423        return [info loc x*]
424    }
425    lsort [t1 2 3]
426} {x xx1 xx2}
427test info-12.3 {info locals option} -body {
428    info locals 1 2
429} -returnCodes error -result {wrong # args: should be "info locals ?pattern?"}
430test info-12.4 {info locals option} {
431    info locals
432} {}
433test info-12.5 {info locals option} {
434    proc t1 {} {return [info locals]}
435    t1
436} {}
437test info-12.6 {info locals vs unset compiled locals} {
438    proc t1 {lst} {
439        foreach $lst $lst {}
440        unset lst
441        return [info locals]
442    }
443    lsort [t1 {a b c c d e f}]
444} {a b c d e f}
445test info-12.7 {info locals with temporary variables} {
446    proc t1 {} {
447        foreach a {b c} {}
448        info locals
449    }
450    t1
451} {a}
452
453test info-13.1 {info nameofexecutable option} -returnCodes error -body {
454    info nameofexecutable foo
455} -result {wrong # args: should be "info nameofexecutable"}
456
457test info-14.1 {info patchlevel option} -body {
458    set a [info patchlevel]
459    regexp {[0-9]+\.[0-9]+([p[0-9]+)?} $a
460} -cleanup {unset a} -result 1
461test info-14.2 {info patchlevel option} -returnCodes error -body {
462    info patchlevel a
463} -result {wrong # args: should be "info patchlevel"}
464test info-14.3 {info patchlevel option} -setup {
465    set t $tcl_patchLevel
466} -body {
467    unset tcl_patchLevel
468    info patchlevel
469} -cleanup {
470    set tcl_patchLevel $t; unset t
471} -returnCodes error -result {can't read "tcl_patchLevel": no such variable}
472
473test info-15.1 {info procs option} -body {
474    proc t1 {} {}
475    proc t2 {} {}
476    set x " [info procs] "
477    list [string match {* t1 *} $x] [string match {* t2 *} $x] \
478            [string match {* _undefined_ *} $x]
479} -cleanup {unset x} -result {1 1 0}
480test info-15.2 {info procs option} {
481    proc _tt1 {} {}
482    proc _tt2 {} {}
483    lsort [info pr _tt*]
484} {_tt1 _tt2}
485catch {rename _tt1 {}}
486catch {rename _tt2 {}}
487test info-15.3 {info procs option} -body {
488    info procs 2 3
489} -returnCodes error -result {wrong # args: should be "info procs ?pattern?"}
490test info-15.4 {info procs option} -setup {
491    catch {namespace delete test_ns_info2}
492} -body {
493    namespace eval test_ns_info2 {
494        namespace import ::test_ns_info1::*
495        proc r {} {}
496        list [lsort [info procs]] [info procs p*]
497    }
498} -result {{p q r} p}
499test info-15.5 {info procs option with a proc in a namespace} -setup {
500    catch {namespace delete test_ns_info2}
501} -body {
502    namespace eval test_ns_info2 {
503	proc p1 { arg } {
504	    puts cmd
505	}
506        proc p2 { arg } {
507	    puts cmd
508	}
509    }
510    info procs ::test_ns_info2::p1
511} -result {::test_ns_info2::p1}
512test info-15.6 {info procs option with a pattern in a namespace} -setup {
513    catch {namespace delete test_ns_info2}
514} -body {
515    namespace eval test_ns_info2 {
516	proc p1 { arg } {
517	    puts cmd
518	}
519        proc p2 { arg } {
520	    puts cmd
521	}
522    }
523    lsort [info procs ::test_ns_info2::p*]
524} -result [lsort [list ::test_ns_info2::p1 ::test_ns_info2::p2]]
525test info-15.7 {info procs option with a global shadowing proc} -setup {
526    catch {namespace delete test_ns_info2}
527} -body {
528    proc string_cmd { arg } {
529        puts cmd
530    }
531    namespace eval test_ns_info2 {
532	proc string_cmd { arg } {
533	    puts cmd
534	}
535    }
536    info procs test_ns_info2::string*
537} -result {::test_ns_info2::string_cmd}
538# This regression test is currently commented out because it requires
539# that the implementation of "info procs" looks into the global namespace,
540# which it does not (in contrast to "info commands")
541test info-15.8 {info procs option with a global shadowing proc} -setup {
542    catch {namespace delete test_ns_info2}
543} -constraints knownBug -body {
544    proc string_cmd { arg } {
545        puts cmd
546    }
547    proc string_cmd2 { arg } {
548        puts cmd
549    }
550    namespace eval test_ns_info2 {
551	proc string_cmd { arg } {
552	    puts cmd
553	}
554    }
555    namespace eval test_ns_info2 {
556        lsort [info procs string*]
557    }
558} -result [lsort [list string_cmd string_cmd2]]
559
560test info-16.1 {info script option} -returnCodes error -body {
561    info script x x
562} -result {wrong # args: should be "info script ?filename?"}
563test info-16.2 {info script option} {
564    file tail [info sc]
565} "info.test"
566set gorpfile [makeFile "info script\n" gorp.info]
567test info-16.3 {info script option} {
568    list [source $gorpfile] [file tail [info script]]
569} [list $gorpfile info.test]
570test info-16.4 {resetting "info script" after errors} {
571    catch {source ~_nobody_/foo}
572    file tail [info script]
573} "info.test"
574test info-16.5 {resetting "info script" after errors} {
575    catch {source _nonexistent_}
576    file tail [info script]
577} "info.test"
578test info-16.6 {info script option} -body {
579    set script [info script]
580    list [file tail [info script]] \
581	    [info script newname.txt] \
582	    [file tail [info script $script]]
583} -result [list info.test newname.txt info.test] -cleanup {unset script}
584test info-16.7 {info script option} -body {
585    set script [info script]
586    info script newname.txt
587    list [source $gorpfile] [file tail [info script]] \
588	    [file tail [info script $script]]
589} -result [list $gorpfile newname.txt info.test] -cleanup {unset script}
590removeFile gorp.info
591set gorpfile [makeFile {list [info script] [info script foo.bar]} gorp.info]
592test info-16.8 {info script option} {
593    list [source $gorpfile] [file tail [info script]]
594} [list [list $gorpfile foo.bar] info.test]
595removeFile gorp.info; unset gorpfile
596
597test info-17.1 {info sharedlibextension option} -returnCodes error -body {
598    info sharedlibextension foo
599} -result {wrong # args: should be "info sharedlibextension"}
600
601test info-18.1 {info tclversion option} -body {
602    scan [info tclversion] "%d.%d%c" a b c
603} -cleanup {unset -nocomplain a b c} -result 2
604test info-18.2 {info tclversion option} -body {
605    info t 2
606} -returnCodes error -result {wrong # args: should be "info tclversion"}
607test info-18.3 {info tclversion option} -body {
608    unset tcl_version
609    info tclversion
610} -returnCodes error -setup {
611    set t $tcl_version
612} -cleanup {
613    set tcl_version $t; unset t
614} -result {can't read "tcl_version": no such variable}
615
616test info-19.1 {info vars option} -body {
617    set a 1
618    set b 2
619    proc t1 {x y} {
620        global a b
621        set c 33
622        return [info vars]
623    }
624    lsort [t1 18 19]
625} -cleanup {unset a b} -result {a b c x y}
626test info-19.2 {info vars option} -body {
627    set xxx1 1
628    set xxx2 2
629    proc t1 {xxa y} {
630        global xxx1 xxx2
631        set c 33
632        return [info vars x*]
633    }
634    lsort [t1 18 19]
635} -cleanup {unset xxx1 xxx2} -result {xxa xxx1 xxx2}
636test info-19.3 {info vars option} {
637    lsort [info vars]
638} [lsort [info globals]]
639test info-19.4 {info vars option} -returnCodes error -body {
640    info vars a b
641} -result {wrong # args: should be "info vars ?pattern?"}
642test info-19.5 {info vars with temporary variables} {
643    proc t1 {} {
644        foreach a {b c} {}
645        info vars
646    }
647    t1
648} {a}
649test info-19.6 {info vars: Bug 1072654} -setup {
650    namespace eval :: unset -nocomplain foo
651    catch {namespace delete x}
652} -body {
653    namespace eval x info vars foo
654} -cleanup {
655    namespace delete x
656} -result {}
657
658set functions {abs acos asin atan atan2 bool ceil cos cosh double entier exp floor fmod hypot int isfinite isinf isnan isnormal isqrt issubnormal isunordered log log10 max min pow rand round sin sinh sqrt srand tan tanh wide}
659# Check whether the extra testing functions are defined...
660if {!([catch {expr {T1()}} msg] && ($msg eq {invalid command name "tcl::mathfunc::T1"}))} {
661    set functions "T1 T2 T3 $functions"  ;# A lazy way of prepending!
662}
663test info-20.1 {info functions option} {info functions sin} sin
664test info-20.2 {info functions option} {lsort [info functions]} $functions
665test info-20.3 {info functions option} {
666    lsort [info functions a*]
667} {abs acos asin atan atan2}
668test info-20.4 {info functions option} {
669    lsort [info functions *tan*]
670} {atan atan2 tan tanh}
671test info-20.5 {info functions option} -returnCodes error -body {
672    info functions raise an error
673} -result {wrong # args: should be "info functions ?pattern?"}
674unset functions msg
675
676test info-21.1 {miscellaneous error conditions} -returnCodes error -body {
677    info
678} -result {wrong # args: should be "info subcommand ?arg ...?"}
679test info-21.2 {miscellaneous error conditions} -returnCodes error -body {
680    info gorp
681} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
682test info-21.3 {miscellaneous error conditions} -returnCodes error -body {
683    info c
684} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
685test info-21.4 {miscellaneous error conditions} -returnCodes error -body {
686    info l
687} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
688test info-21.5 {miscellaneous error conditions} -returnCodes error -body {
689    info s
690} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
691
692##
693# ### ### ### ######### ######### #########
694## info frame
695
696## Helper
697# For the more complex results we cut the file name down to remove path
698# dependencies, and we use only part of the first line of the reported
699# command. The latter is required because otherwise the whole test case may
700# appear in some results, but the result is part of the testcase. An infinite
701# string would be required to describe that. The cutting-down breaks this.
702
703proc reduce {frame} {
704    set cmd [dict get $frame cmd]
705    if {[regexp \n $cmd]} {
706	dict set frame cmd \
707	    [string range [lindex [split $cmd \n] 0] 0 end-4]
708    }
709    if {[dict exists $frame file]} {
710	dict set frame file \
711	    [file tail [dict get $frame file]]
712    }
713    return $frame
714}
715
716proc subinterp {} { interp create sub ; interp debug sub -frame 1;
717    interp eval sub [list proc reduce [info args reduce] [info body reduce]]
718}
719
720## Helper
721# Generate a stacktrace from the current location to top.  This code
722# not only depends on the exact location of things, but also on the
723# implementation of tcltest. Any changes and these tests will have to
724# be updated.
725
726proc etrace {} {
727    set res {}
728    set level [info frame]
729    while {$level} {
730	lappend res [list $level [reduce [info frame $level]]]
731	incr level -1
732    }
733    return $res
734}
735
736test info-22.0 {info frame, levels} {!singleTestInterp} {
737    info frame
738} 7
739test info-22.1 {info frame, bad level relative} {!singleTestInterp} {
740    # catch is another level!, i.e. we have 8, not 7
741    catch {info frame -8} msg
742    set msg
743} {bad level "-8"}
744test info-22.2 {info frame, bad level absolute} {!singleTestInterp} {
745    # catch is another level!, i.e. we have 8, not 7
746    catch {info frame 9} msg
747    set msg
748} {bad level "9"}
749test info-22.3 {info frame, current, relative} -match glob -body {
750    info frame 0
751} -result {type source line 750 file */info.test cmd {info frame 0} proc ::tcltest::RunTest}
752test info-22.4 {info frame, current, relative, nested} -match glob -body {
753    set res [info frame 0]
754} -result {type source line 753 file */info.test cmd {info frame 0} proc ::tcltest::RunTest} -cleanup {unset res}
755test info-22.5 {info frame, current, absolute} -constraints {!singleTestInterp} -match glob -body {
756    reduce [info frame 7]
757} -result {type source line 756 file info.test cmd {info frame 7} proc ::tcltest::RunTest}
758test info-22.6 {info frame, global, relative} {!singleTestInterp} {
759    reduce [info frame -6]
760} {type source line 758 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relative\}\ \{!singleTestInter level 0}
761test info-22.7 {info frame, global, absolute} {!singleTestInterp} {
762    reduce [info frame 1]
763} {type source line 761 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{!singleTestInter level 0}
764test info-22.8 {info frame, basic trace} -match glob -body {
765    join [lrange [etrace] 0 2] \n
766} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
767* {type source line 765 file info.test cmd etrace proc ::tcltest::RunTest}
768* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}}
769unset -nocomplain msg
770
771
772
773
774
775
776
777
778
779
780## The line 1967 is off by 5 from the true value of 1972. This is a knownBug, see testcase 30.0
781test info-23.0 {eval'd info frame} -constraints {!singleTestInterp} -body {
782    list [i eval {info frame}] [i eval {eval {info frame}}]
783} -setup {interp create i} -cleanup {interp delete i} -result {1 2}
784test info-23.1 {eval'd info frame, semi-dynamic} -constraints {!singleTestInterp} -body {
785    i eval {eval info frame}
786} -setup {interp create i} -cleanup {interp delete i} -result 2
787test info-23.2 {eval'd info frame, dynamic} -constraints {!singleTestInterp} -body {
788    i eval {	set script {info frame}
789		eval $script}
790} -setup {interp create i} -cleanup {interp delete i} -result 2
791test info-23.3 {eval'd info frame, literal} -match glob -body {
792    eval {
793	info frame 0
794    }
795} -result {type source line 793 file * cmd {info frame 0} proc ::tcltest::RunTest}
796test info-23.4 {eval'd info frame, semi-dynamic} {
797    eval info frame 0
798} {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest}
799test info-23.5 {eval'd info frame, dynamic} -cleanup {unset script} -body {
800    set script {info frame 0}
801    eval $script
802} -result {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest}
803test info-23.6 {eval'd info frame, trace} -match glob -cleanup {unset script} -body {
804    set script {etrace}
805    join [lrange [eval $script] 0 2] \n
806} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
807* {type eval line 1 cmd etrace proc ::tcltest::RunTest}
808* {type source line 805 file info.test cmd {eval $script} proc ::tcltest::RunTest}}
809
810# -------------------------------------------------------------------------
811
812# Procedures defined in scripts which are arguments to control
813# structures (like 'namespace eval', 'interp eval', 'if', 'while',
814# 'switch', 'catch', 'for', 'foreach', etc.) have no absolute
815# location. The command implementations execute such scripts through
816# Tcl_EvalObjEx. Flag 0 causes it to use the bytecode compiler. This
817# causes the connection to the context to be lost. Currently only
818# procedure bodies are able to remember their context.
819
820# NOTE THAT THESE DO NOT USE THE -setup OPTION TO [test]
821
822# -------------------------------------------------------------------------
823
824namespace eval foo {
825    proc bar {} {info frame 0}
826}
827
828test info-24.0 {info frame, interaction, namespace eval} -body {
829    reduce [foo::bar]
830} -cleanup {
831    namespace delete foo
832} -result {type source line 825 file info.test cmd {info frame 0} proc ::foo::bar level 0}
833
834# -------------------------------------------------------------------------
835
836set flag 1
837if {$flag} {
838    namespace eval foo {}
839    proc ::foo::bar {} {info frame 0}
840}
841
842test info-24.1 {info frame, interaction, if} -body {
843    reduce [foo::bar]
844} -cleanup {
845    namespace delete foo
846} -result {type source line 839 file info.test cmd {info frame 0} proc ::foo::bar level 0}
847
848# -------------------------------------------------------------------------
849
850set flag 1
851while {$flag} {
852    namespace eval foo {}
853    proc ::foo::bar {} {info frame 0}
854    set flag 0
855};unset flag
856
857test info-24.2 {info frame, interaction, while} -body {
858    reduce [foo::bar]
859} -cleanup {
860    namespace delete foo
861} -result {type source line 853 file info.test cmd {info frame 0} proc ::foo::bar level 0}
862
863# -------------------------------------------------------------------------
864
865catch {
866    namespace eval foo {}
867    proc ::foo::bar {} {info frame 0}
868}
869
870test info-24.3 {info frame, interaction, catch} -body {
871    reduce [foo::bar]
872} -cleanup {
873    namespace delete foo
874} -result {type source line 867 file info.test cmd {info frame 0} proc ::foo::bar level 0}
875
876# -------------------------------------------------------------------------
877
878foreach var val {
879    namespace eval foo {}
880    proc ::foo::bar {} {info frame 0}
881    break
882}; unset var
883
884test info-24.4 {info frame, interaction, foreach} -body {
885    reduce [foo::bar]
886} -cleanup {
887    namespace delete foo
888} -result {type source line 880 file info.test cmd {info frame 0} proc ::foo::bar level 0}
889
890# -------------------------------------------------------------------------
891
892for {} {1} {} {
893    namespace eval foo {}
894    proc ::foo::bar {} {info frame 0}
895    break
896}
897
898test info-24.5 {info frame, interaction, for} -body {
899    reduce [foo::bar]
900} -cleanup {
901    namespace delete foo
902} -result {type source line 894 file info.test cmd {info frame 0} proc ::foo::bar level 0}
903
904# -------------------------------------------------------------------------
905
906namespace eval foo {}
907set x foo
908switch -exact -- $x {
909    foo {
910	proc ::foo::bar {} {info frame 0}
911    }
912}
913
914test info-24.6.0 {info frame, interaction, switch, list body} -body {
915    reduce [foo::bar]
916} -cleanup {
917    namespace delete foo
918    unset x
919} -result {type source line 910 file info.test cmd {info frame 0} proc ::foo::bar level 0}
920
921# -------------------------------------------------------------------------
922
923namespace eval foo {}
924set x foo
925switch -exact -- $x foo {
926    proc ::foo::bar {} {info frame 0}
927}
928
929test info-24.6.1 {info frame, interaction, switch, multi-body} -body {
930    reduce [foo::bar]
931} -cleanup {
932    namespace delete foo
933    unset x
934} -result {type source line 926 file info.test cmd {info frame 0} proc ::foo::bar level 0}
935
936# -------------------------------------------------------------------------
937
938namespace eval foo {}
939set x foo
940switch -exact -- $x [list foo {
941    proc ::foo::bar {} {info frame 0}
942}]
943
944test info-24.6.2 {info frame, interaction, switch, list body, dynamic} -body {
945    reduce [foo::bar]
946} -cleanup {
947    namespace delete foo
948    unset x
949} -result {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
950
951# -------------------------------------------------------------------------
952
953namespace eval foo {}
954dict for {k v} {foo bar} {
955    proc ::foo::bar {} {info frame 0}
956}
957
958test info-24.7 {info frame, interaction, dict for} {
959    reduce [foo::bar]
960} {type source line 955 file info.test cmd {info frame 0} proc ::foo::bar level 0}
961
962namespace delete foo; unset k v
963
964# -------------------------------------------------------------------------
965
966namespace eval foo {}
967set thedict {foo bar}
968dict with thedict {
969    proc ::foo::bar {} {info frame 0}
970}
971
972test info-24.8 {info frame, interaction, dict with} {
973    reduce [foo::bar]
974} {type source line 969 file info.test cmd {info frame 0} proc ::foo::bar level 0}
975
976namespace delete foo
977unset thedict foo
978
979# -------------------------------------------------------------------------
980
981namespace eval foo {}
982dict filter {foo bar} script {k v} {
983    proc ::foo::bar {} {info frame 0}
984    set x 1
985}; unset k v x
986
987test info-24.9 {info frame, interaction, dict filter} {
988    reduce [foo::bar]
989} {type source line 983 file info.test cmd {info frame 0} proc ::foo::bar level 0}
990
991namespace delete foo
992#unset x
993
994# -------------------------------------------------------------------------
995
996eval {
997    proc bar {} {info frame 0}
998}
999
1000test info-25.0 {info frame, proc in eval} {
1001    reduce [bar]
1002} {type source line 997 file info.test cmd {info frame 0} proc ::bar level 0}
1003# Don't need to clean up yet...
1004
1005proc bar {} {info frame 0}
1006
1007test info-25.1 {info frame, regular proc} {
1008    reduce [bar]
1009} {type source line 1005 file info.test cmd {info frame 0} proc ::bar level 0}
1010
1011rename bar {}
1012
1013# -------------------------------------------------------------------------
1014# More info-30.x test cases at the end of the file.
1015test info-30.0 {bs+nl in literal words} -cleanup {unset res} -body {
1016    if {1} {
1017	set res \
1018	    [reduce [info frame 0]];#1018
1019    }
1020    return $res
1021    # This was reporting line 3 instead of the correct 4 because the
1022    # bs+nl combination is subst by the parser before the 'if'
1023    # command, and the bcc, see the word. Fixed by recording the
1024    # offsets of all bs+nl sequences in literal words, then using the
1025    # information in the bcc and other places to bump line numbers when
1026    # parsing over the location. Also affected: testcases 22.8 and 23.6.
1027} -result {type source line 1018 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1028
1029# -------------------------------------------------------------------------
1030# See 24.0 - 24.5 for similar situations, using literal scripts.
1031
1032set body {set flag 0
1033    set a c
1034    set res [info frame 0]} ;# line 3!
1035
1036test info-31.0 {ns eval, script in variable} -body {namespace eval foo {variable res {}}
1037    namespace eval foo $body
1038    return $foo::res
1039} -result {type eval line 3 cmd {info frame 0} level 0} -cleanup {
1040    catch {namespace delete foo}
1041}
1042test info-31.1 {if, script in variable} -cleanup {unset res a flag} -body {
1043    if 1 $body
1044    return $res
1045} -result {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
1046
1047test info-31.1a {if, script in variable} -cleanup {unset res a flag} -body {
1048    if 1 then $body
1049    return $res
1050} -result {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
1051
1052test info-31.2 {while, script in variable} -cleanup {unset flag res a} -body {
1053    set flag 1
1054    while {$flag} $body
1055    return $res
1056} -result {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
1057
1058# .3 - proc - scoping prevent return of result ...
1059
1060test info-31.4 {foreach, script in variable} -cleanup {unset var res a flag} -body {
1061    foreach var val $body
1062    set res
1063} -result {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
1064
1065test info-31.5 {for, script in variable} -cleanup {unset flag res a} -body {
1066    set flag 1
1067    for {} {$flag} {} $body
1068    return $res
1069} -result {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
1070
1071test info-31.6 {eval, script in variable} -cleanup {unset res a flag} -body {
1072    eval $body
1073    return $res
1074} -result {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
1075
1076# -------------------------------------------------------------------------
1077
1078set body {
1079    foo {
1080	proc ::foo::bar {} {info frame 0}
1081    }
1082}
1083
1084namespace eval foo {}
1085set x foo
1086switch -exact -- $x $body; unset body
1087
1088test info-31.7 {info frame, interaction, switch, dynamic} -body {
1089    reduce [foo::bar]
1090} -cleanup {
1091    namespace delete foo
1092    unset x
1093} -result {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
1094
1095# -------------------------------------------------------------------------
1096
1097set body {
1098    proc ::foo::bar {} {info frame 0}
1099}
1100
1101namespace eval foo {}
1102eval $body
1103
1104test info-32.0 {info frame, dynamic procedure} -body {
1105    reduce [foo::bar]
1106} -cleanup {
1107    namespace delete foo
1108} -result {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
1109
1110# -------------------------------------------------------------------------
1111
1112namespace {*}{
1113    eval
1114    foo
1115    {proc bar {} {info frame 0}}
1116}
1117test info-33.0 {{*}, literal, direct} -body {
1118    reduce [foo::bar]
1119} -cleanup {
1120    namespace delete foo
1121} -result {type source line 1115 file info.test cmd {info frame 0} proc ::foo::bar level 0}
1122
1123# -------------------------------------------------------------------------
1124
1125namespace eval foo {}
1126proc foo::bar {} {
1127    set flag 1
1128    if {*}{
1129	{$flag}
1130	{info frame 0}
1131    }
1132}
1133test info-33.1 {{*}, literal, simple, bytecompiled} -body {
1134    reduce [foo::bar]
1135} -cleanup {
1136    namespace delete foo
1137} -result {type source line 1130 file info.test cmd {info frame 0} proc ::foo::bar level 0}
1138
1139# -------------------------------------------------------------------------
1140
1141namespace {*}"
1142    eval
1143    foo
1144    {proc bar {} {info frame 0}}
1145"
1146test info-33.2 {{*}, literal, direct} {
1147    reduce [foo::bar]
1148} {type source line 1144 file info.test cmd {info frame 0} proc ::foo::bar level 0}
1149
1150namespace delete foo
1151
1152# -------------------------------------------------------------------------
1153
1154namespace {*}"eval\nfoo\n{proc bar {} {info frame 0}}\n"
1155
1156test info-33.2a {{*}, literal, not simple, direct} {
1157    reduce [foo::bar]
1158} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
1159
1160namespace delete foo
1161
1162# -------------------------------------------------------------------------
1163
1164namespace eval foo {}
1165proc foo::bar {} {
1166    set flag 1
1167    if {*}"
1168	{1}
1169	{info frame 0}
1170    "
1171}
1172test info-33.3 {{*}, literal, simple, bytecompiled} {
1173    reduce [foo::bar]
1174} {type source line 1169 file info.test cmd {info frame 0} proc ::foo::bar level 0}
1175
1176namespace delete foo
1177
1178# -------------------------------------------------------------------------
1179
1180namespace eval foo {}
1181proc foo::bar {} {
1182    set flag 1
1183    if {*}"\n{1}\n{info frame 0}"
1184}
1185test info-33.3a {{*}, literal, not simple, bytecompiled} {
1186    reduce [foo::bar]
1187} {type eval line 1 cmd {info frame 0} proc ::foo::bar level 0}
1188
1189namespace delete foo
1190
1191# -------------------------------------------------------------------------
1192
1193set body {
1194    eval
1195    foo
1196    {proc bar {} {
1197	info frame 0
1198    }}
1199}
1200namespace {*}$body
1201test info-34.0 {{*}, dynamic, direct} {
1202    reduce [foo::bar]
1203} {type proc line 2 cmd {info frame 0} proc ::foo::bar level 0}
1204
1205unset body
1206namespace delete foo
1207
1208# -------------------------------------------------------------------------
1209
1210namespace eval foo {}
1211set body {
1212    {$flag}
1213    {info frame 0}
1214}
1215proc foo::bar {} {
1216    global body ; set flag 1
1217    if {*}$body
1218}
1219test info-34.1 {{*}, literal, bytecompiled} {
1220    reduce [foo::bar]
1221} {type eval line 1 cmd {info frame 0} proc ::foo::bar level 0}
1222
1223unset body
1224namespace delete foo
1225
1226# -------------------------------------------------------------------------
1227
1228proc foo {} {
1229    apply {
1230	{x y}
1231	{info frame 0}
1232    } 0 0
1233}
1234test info-35.0 {apply, literal} {
1235    reduce [foo]
1236} {type source line 1231 file info.test cmd {info frame 0} lambda {
1237	{x y}
1238	{info frame 0}
1239    } level 0}
1240rename foo {}
1241
1242set lambda {
1243    {x y}
1244    {info frame 0}
1245}
1246test info-35.1 {apply, dynamic} {
1247    reduce [apply $lambda 0 0]
1248} {type proc line 1 cmd {info frame 0} lambda {
1249    {x y}
1250    {info frame 0}
1251} level 0}
1252unset lambda
1253
1254# -------------------------------------------------------------------------
1255
1256namespace eval foo {}
1257proc foo::bar {} {
1258    dict for {k v} {foo bar} {
1259	set x [info frame 0]
1260    }
1261    set x
1262}
1263test info-36.0 {info frame, dict for, bcc} -body {
1264    reduce [foo::bar]
1265} -result {type source line 1259 file info.test cmd {info frame 0} proc ::foo::bar level 0}
1266
1267namespace delete foo
1268
1269# -------------------------------------------------------------------------
1270
1271namespace eval foo {}
1272proc foo::bar {} {
1273    set x foo
1274    switch -exact -- $x {
1275	foo {set y [info frame 0]}
1276    }
1277    set y
1278}
1279
1280test info-36.1.0 {switch, list literal, bcc} -body {
1281    reduce [foo::bar]
1282} -result {type source line 1275 file info.test cmd {info frame 0} proc ::foo::bar level 0}
1283
1284namespace delete foo
1285
1286# -------------------------------------------------------------------------
1287
1288namespace eval foo {}
1289proc foo::bar {} {
1290    set x foo
1291    switch -exact -- $x foo {set y [info frame 0]}
1292    set y
1293}
1294
1295test info-36.1.1 {switch, multi-body literals, bcc} -body {
1296    reduce [foo::bar]
1297} -result {type source line 1291 file info.test cmd {info frame 0} proc ::foo::bar level 0}
1298
1299namespace delete foo
1300
1301# -------------------------------------------------------------------------
1302
1303test info-37.0 {eval pure list, single line} -match glob -body {
1304    # Basically, counting the newline in the word seen through $foo
1305    # doesn't really make sense. It makes a bit of sense if the word
1306    # would have been a string literal in the command list.
1307    #
1308    # Problem: At the point where we see the list elements we cannot
1309    # distinguish the two cases, thus we cannot switch between
1310    # count/not-count, it is has to be one or the other for all
1311    # cases. Of the two possibilities miguel convinced me that 'not
1312    # counting' is the more proper.
1313    set foo {b
1314	c}
1315    set cmd [list foreach $foo {x y} {
1316	set res [join [lrange [etrace] 0 2] \n]
1317	break
1318    }]
1319    eval $cmd
1320    return $res
1321} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
1322* {type eval line 2 cmd etrace proc ::tcltest::RunTest}
1323* {type eval line 1 cmd foreac proc ::tcltest::RunTest}} -cleanup {unset foo cmd res b c}
1324
1325# -------------------------------------------------------------------------
1326
1327# 6 cases.
1328## DV. direct-var          - unchanged
1329## DPV direct-proc-var     - ditto
1330## PPV proc-proc-var       - ditto
1331## DL. direct-literal      - now tracking absolute location
1332## DPL direct-proc-literal - ditto
1333## PPL proc-proc-literal   - ditto
1334## ### ### ### ######### ######### #########"
1335
1336proc control {vv script} {
1337    upvar 1 $vv var
1338    return [uplevel 1 $script]
1339}
1340
1341proc datal {} {
1342    control y {
1343	set y PPL
1344	etrace
1345    }
1346}
1347
1348proc datav {} {
1349    set script {
1350	set y PPV
1351	etrace
1352    }
1353    control y $script
1354}
1355
1356test info-38.1 {location information for uplevel, dv, direct-var} -match glob -body {
1357    set script {
1358	set y DV.
1359	etrace
1360    }
1361    join [lrange [uplevel \#0 $script] 0 2] \n
1362} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
1363* {type eval line 3 cmd etrace proc ::tcltest::RunTest}
1364* {type source line 1361 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} -cleanup {unset script y}
1365
1366# 38.2 moved to bottom to not disturb other tests with the necessary changes to this one.
1367
1368
1369
1370
1371
1372
1373
1374
1375test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match glob -body {
1376    set script {
1377	set y DPV
1378	etrace
1379    }
1380    join [lrange [control y $script] 0 3] \n
1381} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
1382* {type eval line 3 cmd etrace proc ::control}
1383* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control}
1384* {type source line 1380 file info.test cmd {control y $script} proc ::tcltest::RunTest}} -cleanup {unset script y}
1385
1386# 38.4 moved to bottom to not disturb other tests with the necessary changes to this one.
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glob -body {
1397    join [lrange [datav] 0 4] \n
1398} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
1399* {type eval line 3 cmd etrace proc ::control}
1400* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control}
1401* {type source line 1353 file info.test cmd {control y $script} proc ::datav level 1}
1402* {type source line 1397 file info.test cmd datav proc ::tcltest::RunTest}}
1403
1404# 38.6 moved to bottom to not disturb other tests with the necessary changes to this one.
1405
1406
1407
1408
1409
1410
1411
1412testConstraint testevalex [llength [info commands testevalex]]
1413test info-38.7 {location information for arg substitution} -constraints testevalex -match glob -body {
1414    join [lrange [testevalex {return -level 0 [etrace]}] 0 3] \n
1415} -result {* {type source line 730 file info.test cmd {info frame \$level} proc ::etrace level 0}
1416* {type eval line 1 cmd etrace proc ::tcltest::RunTest}
1417* {type source line 1414 file info.test cmd {testevalex {return -level 0 \[etrace]}} proc ::tcltest::RunTest}
1418* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}}
1419
1420# -------------------------------------------------------------------------
1421# literal sharing
1422
1423test info-39.0 {location information not confused by literal sharing} -body {
1424    namespace eval ::foo {}
1425    proc ::foo::bar {} {
1426	lappend res {}
1427	lappend res [reduce [eval {info frame 0}]]
1428	lappend res [reduce [eval {info frame 0}]]
1429	return $res
1430    }
1431    set res [::foo::bar]
1432    namespace delete ::foo
1433    join $res \n
1434} -cleanup {unset res} -result {
1435type source line 1427 file info.test cmd {info frame 0} proc ::foo::bar level 0
1436type source line 1428 file info.test cmd {info frame 0} proc ::foo::bar level 0}
1437
1438# -------------------------------------------------------------------------
1439# Additional tests for info-30.*, handling of continuation lines (bs+nl sequences).
1440
1441test info-30.1 {bs+nl in literal words, procedure body, compiled} -body {
1442    proc abra {} {
1443	if {1} \
1444	    {
1445		return \
1446		    [reduce [info frame 0]];# line 1446
1447	    }
1448    }
1449    abra
1450} -cleanup {
1451    rename abra {}
1452} -result {type source line 1446 file info.test cmd {info frame 0} proc ::abra level 0}
1453
1454test info-30.2 {bs+nl in literal words, namespace script} {
1455    namespace eval xxx {
1456	variable res \
1457	    [info frame 0];# line 1457
1458    }
1459    return [reduce $xxx::res]
1460} {type source line 1457 file info.test cmd {info frame 0} level 0}
1461
1462test info-30.3 {bs+nl in literal words, namespace multi-word script} {
1463    namespace eval xxx variable res \
1464	[list [reduce [info frame 0]]];# line 1464
1465    return $xxx::res
1466} {type source line 1464 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1467
1468test info-30.4 {bs+nl in literal words, eval script} -cleanup {unset res} -body {
1469    eval {
1470	set ::res \
1471	    [reduce [info frame 0]];# line 1471
1472    }
1473    return $res
1474} -result {type source line 1471 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1475
1476test info-30.5 {bs+nl in literal words, eval script, with nested words} -body {
1477    eval {
1478	if {1} \
1479	    {
1480		set ::res \
1481		    [reduce [info frame 0]];# line 1481
1482	    }
1483    }
1484    return $res
1485} -cleanup {unset res} -result {type source line 1481 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1486
1487test info-30.6 {bs+nl in computed word} -cleanup {unset res} -body {
1488    set res "\
1489[reduce [info frame 0]]";# line 1489
1490} -result { type source line 1489 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1491
1492test info-30.7 {bs+nl in computed word, in proc} -body {
1493    proc abra {} {
1494	return "\
1495[reduce [info frame 0]]";# line 1495
1496    }
1497    abra
1498} -cleanup {
1499    rename abra {}
1500} -result { type source line 1495 file info.test cmd {info frame 0} proc ::abra level 0}
1501
1502test info-30.8 {bs+nl in computed word, nested eval} -body {
1503    eval {
1504	set \
1505	    res "\
1506[reduce [info frame 0]]";# line 1506
1507}
1508} -cleanup {unset res} -result { type source line 1506 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1509
1510test info-30.9 {bs+nl in computed word, nested eval} -body {
1511    eval {
1512	set \
1513	    res "\
1514[reduce \
1515     [info frame 0]]";# line 1515
1516}
1517} -cleanup {unset res} -result { type source line 1515 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1518
1519test info-30.10 {bs+nl in computed word, key to array} -body {
1520    set tmp([set \
1521	    res "\
1522[reduce \
1523     [info frame 0]]"]) x ; #1523
1524    unset tmp
1525    set res
1526} -cleanup {unset res} -result { type source line 1523 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1527
1528test info-30.11 {bs+nl in subst arguments} -body {
1529    subst {[set \
1530	    res "\
1531[reduce \
1532     [info frame 0]]"]} ; #1532
1533} -cleanup {unset res} -result { type source line 1532 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1534
1535test info-30.12 {bs+nl in computed word, nested eval} -body {
1536    eval {
1537	set \
1538	    res "\
1539[set x {}] \
1540[reduce \
1541     [info frame 0]]";# line 1541
1542}
1543} -cleanup {unset res x} -result {   type source line 1541 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1544
1545test info-30.13 {bs+nl in literal words, uplevel script, with nested words} -body {
1546    subinterp ; set res [interp eval sub { uplevel #0 {
1547	if {1} \
1548	    {
1549		set ::res \
1550		    [reduce [info frame 0]];# line 1550
1551	    }
1552    }
1553    set res }] ; interp delete sub ; set res
1554} -cleanup {unset res} -result {type source line 1550 file info.test cmd {info frame 0} level 0}
1555
1556test info-30.14 {bs+nl, literal word, uplevel through proc} {
1557    subinterp ; set res [interp eval sub { proc abra {script} {
1558	uplevel 1 $script
1559    }
1560    set res [abra {
1561	return "\
1562[reduce [info frame 0]]";# line 1562
1563    }]
1564    rename abra {}
1565    set res }] ; interp delete sub ; set res
1566} { type source line 1562 file info.test cmd {info frame 0} proc ::abra}
1567
1568test info-30.15 {bs+nl in literal words, nested proc body, compiled} {
1569    proc a {} {
1570	proc b {} {
1571	    if {1} \
1572		{
1573		    return \
1574			[reduce [info frame 0]];# line 1574
1575		}
1576	}
1577    }
1578    a ; set res [b]
1579    rename a {}
1580    rename b {}
1581    set res
1582} {type source line 1574 file info.test cmd {info frame 0} proc ::b level 0}
1583
1584test info-30.16 {bs+nl in multi-body switch, compiled} {
1585    proc a {value} {
1586	switch -regexp -- $value \
1587	    ^key     { info frame 0; # 1587 } \
1588	    \t###    { info frame 0; # 1588 } \
1589	    {[0-9]*} { info frame 0; # 1589 }
1590    }
1591    set res {}
1592    lappend res [reduce [a {key   }]]
1593    lappend res [reduce [a {1alpha}]]
1594    set res "\n[join $res \n]"
1595} {
1596type source line 1587 file info.test cmd {info frame 0} proc ::a level 0
1597type source line 1589 file info.test cmd {info frame 0} proc ::a level 0}
1598
1599test info-30.17 {bs+nl in multi-body switch, direct} {
1600    switch -regexp -- {key    } \
1601	^key     { reduce [info frame 0] ;# 1601 } \
1602        \t###    { } \
1603        {[0-9]*} { }
1604} {type source line 1601 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1605
1606test info-30.18 {bs+nl, literal word, uplevel through proc, appended, loss of primary tracking data} {
1607    proc abra {script} {
1608	append script "\n# end of script"
1609	uplevel 1 $script
1610    }
1611    set res [abra {
1612	return "\
1613[reduce [info frame 0]]";# line 1613, still line of 3 appended script
1614    }]
1615    rename abra {}
1616    set res
1617} { type eval line 3 cmd {info frame 0} proc ::abra}
1618# { type source line 1606 file info.test cmd {info frame 0} proc ::abra}
1619
1620test info-30.19 {bs+nl in single-body switch, compiled} {
1621    proc a {value} {
1622	switch -regexp -- $value {
1623	    ^key     { reduce \
1624			   [info frame 0] }
1625	    \t       { reduce \
1626			   [info frame 0] }
1627	    {[0-9]*} { reduce \
1628			   [info frame 0] }
1629	}
1630    }
1631    set res {}
1632    lappend res [a {key   }]
1633    lappend res [a {1alpha}]
1634    set res "\n[join $res \n]"
1635} {
1636type source line 1624 file info.test cmd {info frame 0} proc ::a level 0
1637type source line 1628 file info.test cmd {info frame 0} proc ::a level 0}
1638
1639test info-30.20 {bs+nl in single-body switch, direct} {
1640    switch -regexp -- {key    } { \
1641
1642	^key     { reduce \
1643		       [info frame 0] }
1644	\t###    { }
1645        {[0-9]*} { }
1646    }
1647} {type source line 1643 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1648
1649test info-30.21 {bs+nl in if, full compiled} {
1650    proc a {value} {
1651	if {$value} \
1652	    {info frame 0} \
1653	    {info frame 0} ; # 1653
1654    }
1655    set res {}
1656    lappend res [reduce [a 1]]
1657    lappend res [reduce [a 0]]
1658    set res "\n[join $res \n]"
1659} {
1660type source line 1652 file info.test cmd {info frame 0} proc ::a level 0
1661type source line 1653 file info.test cmd {info frame 0} proc ::a level 0}
1662
1663test info-30.22 {bs+nl in computed word, key to array, compiled} {
1664    proc a {} {
1665	set tmp([set \
1666		     res "\
1667[reduce \
1668     [info frame 0]]"]) x ; #1668
1669    unset tmp
1670    set res
1671    }
1672    set res [a]
1673    rename a {}
1674    set res
1675} { type source line 1668 file info.test cmd {info frame 0} proc ::a level 0}
1676
1677test info-30.23 {bs+nl in multi-body switch, full compiled} {
1678    proc a {value} {
1679	switch -exact -- $value \
1680	    key     { info frame 0; # 1680 } \
1681	    xxx     { info frame 0; # 1681 } \
1682	    000     { info frame 0; # 1682 }
1683    }
1684    set res {}
1685    lappend res [reduce [a key]]
1686    lappend res [reduce [a 000]]
1687    set res "\n[join $res \n]"
1688} {
1689type source line 1680 file info.test cmd {info frame 0} proc ::a level 0
1690type source line 1682 file info.test cmd {info frame 0} proc ::a level 0}
1691
1692test info-30.24 {bs+nl in single-body switch, full compiled} {
1693    proc a {value} {
1694	switch -exact -- $value {
1695	    key { reduce \
1696		      [info frame 0] }
1697	    xxx { reduce \
1698		      [info frame 0] }
1699	    000 { reduce \
1700		      [info frame 0] }
1701	}
1702    }
1703    set res {}
1704    lappend res [a key]
1705    lappend res [a 000]
1706    set res "\n[join $res \n]"
1707} {
1708type source line 1696 file info.test cmd {info frame 0} proc ::a level 0
1709type source line 1700 file info.test cmd {info frame 0} proc ::a level 0}
1710
1711test info-30.25 {TIP 280 for compiled [subst]} {
1712    subst {[reduce [info frame 0]]} ; # 1712
1713} {type source line 1712 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1714test info-30.26 {TIP 280 for compiled [subst]} {
1715    subst \
1716	    {[reduce [info frame 0]]} ; # 1716
1717} {type source line 1716 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1718test info-30.27 {TIP 280 for compiled [subst]} {
1719    subst {
1720[reduce [info frame 0]]} ; # 1720
1721} {
1722type source line 1720 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1723test info-30.28 {TIP 280 for compiled [subst]} {
1724    subst {\
1725[reduce [info frame 0]]} ; # 1725
1726} { type source line 1725 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1727test info-30.29 {TIP 280 for compiled [subst]} {
1728    subst {foo\
1729[reduce [info frame 0]]} ; # 1729
1730} {foo type source line 1729 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1731test info-30.30 {TIP 280 for compiled [subst]} {
1732    subst {foo
1733[reduce [info frame 0]]} ; # 1733
1734} {foo
1735type source line 1733 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1736test info-30.31 {TIP 280 for compiled [subst]} {
1737    subst {[][reduce [info frame 0]]} ; # 1737
1738} {type source line 1737 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1739test info-30.32 {TIP 280 for compiled [subst]} {
1740    subst {[\
1741][reduce [info frame 0]]} ; # 1741
1742} {type source line 1741 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1743test info-30.33 {TIP 280 for compiled [subst]} {
1744    subst {[
1745][reduce [info frame 0]]} ; # 1745
1746} {type source line 1745 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1747test info-30.34 {TIP 280 for compiled [subst]} {
1748    subst {[format %s {}
1749][reduce [info frame 0]]} ; # 1749
1750} {type source line 1749 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1751test info-30.35 {TIP 280 for compiled [subst]} {
1752    subst {[format %s {}
1753]
1754[reduce [info frame 0]]} ; # 1754
1755} {
1756type source line 1754 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1757test info-30.36 {TIP 280 for compiled [subst]} {
1758    subst {
1759[format %s {}][reduce [info frame 0]]} ; # 1759
1760} {
1761type source line 1759 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1762test info-30.37 {TIP 280 for compiled [subst]} {
1763    subst {
1764[format %s {}]
1765[reduce [info frame 0]]} ; # 1765
1766} {
1767
1768type source line 1765 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1769test info-30.38 {TIP 280 for compiled [subst]} {
1770    subst {\
1771[format %s {}][reduce [info frame 0]]} ; # 1771
1772} { type source line 1771 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1773test info-30.39 {TIP 280 for compiled [subst]} {
1774    subst {\
1775[format %s {}]\
1776[reduce [info frame 0]]} ; # 1776
1777} {  type source line 1776 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1778test info-30.40 {TIP 280 for compiled [subst]} -setup {
1779    unset -nocomplain empty
1780} -body {
1781    set empty {}
1782    subst {$empty[reduce [info frame 0]]} ; # 1782
1783} -cleanup {
1784    unset empty
1785} -result {type source line 1782 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1786test info-30.41 {TIP 280 for compiled [subst]} -setup {
1787    unset -nocomplain empty
1788} -body {
1789    set empty {}
1790    subst {$empty
1791[reduce [info frame 0]]} ; # 1791
1792} -cleanup {
1793    unset empty
1794} -result {
1795type source line 1791 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1796test info-30.42 {TIP 280 for compiled [subst]} -setup {
1797    unset -nocomplain empty
1798} -body {
1799    set empty {}; subst {$empty\
1800[reduce [info frame 0]]} ; # 1800
1801} -cleanup {
1802    unset empty
1803} -result { type source line 1800 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1804test info-30.43 {TIP 280 for compiled [subst]} -body {
1805    unset -nocomplain a\nb
1806    set a\nb {}
1807    subst {${a
1808b}[reduce [info frame 0]]} ; # 1808
1809} -cleanup {unset a\nb} -result {type source line 1808 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1810test info-30.44 {TIP 280 for compiled [subst]} {
1811    unset -nocomplain a
1812    set a(\n) {}
1813    subst {$a(
1814)[reduce [info frame 0]]} ; # 1814
1815} {type source line 1814 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1816test info-30.45 {TIP 280 for compiled [subst]} {
1817    unset -nocomplain a
1818    set a() {}
1819    subst {$a([
1820return -level 0])[reduce [info frame 0]]} ; # 1820
1821} {type source line 1820 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
1822test info-30.46 {TIP 280 for compiled [subst]} {
1823    unset -nocomplain a
1824    set a(1825) YES;  set a(1824) 1824; set a(1826) 1826
1825    subst {$a([dict get [info frame 0] line])} ; # 1825
1826} YES
1827test info-30.47 {TIP 280 for compiled [subst]} {
1828    unset -nocomplain a
1829    set a(\n1831) YES;  set a(\n1830) 1830; set a(\n1832) 1832
1830    subst {$a(
1831[dict get [info frame 0] line])} ; # 1831
1832} YES
1833unset -nocomplain a
1834
1835test info-30.48 {Bug 2850901} testevalex {
1836    testevalex {return -level 0 [format %s {}
1837][reduce [info frame 0]]} ; # line 2 of the eval
1838} {type eval line 2 cmd {info frame 0} proc ::tcltest::RunTest}
1839
1840
1841# -------------------------------------------------------------------------
1842# literal sharing 2, bug 2933089
1843
1844test info-39.1 {location information not confused by literal sharing, bug 2933089} -setup {
1845    set result {}
1846
1847    proc print_one {} {}
1848    proc test_info_frame {} {
1849	set x 1
1850	set y x
1851
1852	if "$x != 1" {
1853	} else {
1854	    print_one
1855	} ;#line 1854^
1856
1857	if "$$y != 1" {
1858	} else {
1859	    print_one
1860	} ;#line 1859^
1861	# Do not put the comments listing the line numbers into the
1862	# branches. We need shared literals, and the comments would
1863	# make them different, thus unshared.
1864    }
1865
1866    proc get_frame_info { cmd_str op } {
1867	lappend ::result [reduce [eval {info frame -3}]]
1868    }
1869    trace add execution print_one enter get_frame_info
1870} -body {
1871    test_info_frame;
1872    join $result \n
1873} -cleanup {
1874    trace remove execution print_one enter get_frame_info
1875    rename get_frame_info {}
1876    rename test_info_frame {}
1877    rename print_one {}
1878} -result {type source line 1854 file info.test cmd print_one proc ::test_info_frame level 1
1879type source line 1859 file info.test cmd print_one proc ::test_info_frame level 1}
1880
1881# -------------------------------------------------------------------------
1882# Tests moved to the end to not disturb other tests and their locations.
1883
1884test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -match glob -setup {subinterp} -body {
1885    interp eval sub {
1886	proc etrace {} {
1887	    set res {}
1888	    set level [info frame]
1889	    while {$level} {
1890		lappend res [list $level [reduce [info frame $level]]]
1891		incr level -1
1892	    }
1893	    return $res
1894	}
1895	proc control {vv script} {
1896	    upvar 1 $vv var
1897	    return [uplevel 1 $script]
1898	}
1899	proc datal {} {
1900	    control y {
1901		set y PPL
1902		etrace
1903	    }
1904	}
1905	join [lrange [datal] 0 4] \n
1906    }
1907} -result {* {type source line 1890 file info.test cmd {info frame $level} proc ::etrace level 0}
1908* {type source line 1902 file info.test cmd etrace proc ::control}
1909* {type source line 1897 file info.test cmd {uplevel 1 $script} proc ::control}
1910* {type source line 1900 file info.test cmd control proc ::datal level 1}
1911* {type source line 1905 file info.test cmd datal level 2}} -cleanup {interp delete sub}
1912
1913test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -match glob -setup {subinterp} -body {
1914    interp eval sub {
1915	proc etrace {} {
1916	    set res {}
1917	    set level [info frame]
1918	    while {$level} {
1919		lappend res [list $level [reduce [info frame $level]]]
1920		incr level -1
1921	    }
1922	    return $res
1923	}
1924	proc control {vv script} {
1925	    upvar 1 $vv var
1926	    return [uplevel 1 $script]
1927	}
1928	join [lrange [control y {
1929	    set y DPL
1930	    etrace
1931	}] 0 3] \n
1932    }
1933} -result {* {type source line 1919 file info.test cmd {info frame $level} proc ::etrace level 0}
1934* {type source line 1930 file info.test cmd etrace proc ::control}
1935* {type source line 1926 file info.test cmd {uplevel 1 $script} proc ::control}
1936* {type source line 1928 file info.test cmd control level 1}} -cleanup {interp delete sub}
1937
1938test info-38.2 {location information for uplevel, dl, direct-literal} -match glob -setup {subinterp} -body {
1939    interp eval sub {
1940	proc etrace {} {
1941	    set res {}
1942	    set level [info frame]
1943	    while {$level} {
1944		lappend res [list $level [reduce [info frame $level]]]
1945		incr level -1
1946	    }
1947	    return $res
1948	}
1949	join [lrange [uplevel \#0 {
1950	    set y DL.
1951	    etrace
1952	}] 0 2] \n
1953    }
1954} -result {* {type source line 1944 file info.test cmd {info frame $level} proc ::etrace level 0}
1955* {type source line 1951 file info.test cmd etrace level 1}
1956* {type source line 1949 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub}
1957
1958# This test at the end of this file _only_ to avoid disturbing above line
1959# numbers. It _belongs_ after info-9.12
1960test info-9.13 {info level option, value in global context} -body {
1961    uplevel #0 {info level 2}
1962} -returnCodes error -result {bad level "2"}
1963
1964# -------------------------------------------------------------------------
1965namespace eval foo {}
1966proc foo::bar {} {
1967    catch {*}{
1968	{info frame 0}
1969	res
1970    }
1971    return $res
1972}
1973test info-33.4 {{*}, literal, simple, bytecompiled} -body {
1974    reduce [foo::bar]
1975} -cleanup {
1976    namespace delete foo
1977} -result {type source line 1968 file info.test cmd {info frame 0} proc ::foo::bar level 0}
1978
1979# -------------------------------------------------------------------------
1980namespace eval foo {}
1981proc foo::bar {} {
1982    dict for {a b} {c d} {*}{
1983	{set res [info frame 0]}
1984    }
1985    return $res
1986}
1987test info-33.5 {{*}, literal, simple, bytecompiled} -body {
1988    reduce [foo::bar]
1989} -cleanup {
1990    namespace delete foo
1991} -result {type source line 1983 file info.test cmd {info frame 0} proc ::foo::bar level 0}
1992
1993# -------------------------------------------------------------------------
1994namespace eval foo {}
1995proc foo::bar {} {
1996    set d {a b}
1997    dict update d x y {*}{
1998	{set res [info frame 0]}
1999    }
2000    return $res
2001}
2002test info-33.6 {{*}, literal, simple, bytecompiled} -body {
2003    reduce [foo::bar]
2004} -cleanup {
2005    namespace delete foo
2006} -result {type source line 1998 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2007
2008# -------------------------------------------------------------------------
2009namespace eval foo {}
2010proc foo::bar {} {
2011    set d {}
2012    dict with d {*}{
2013	{set res [info frame 0]}
2014    }
2015    return $res
2016}
2017test info-33.7 {{*}, literal, simple, bytecompiled} -body {
2018    reduce [foo::bar]
2019} -cleanup {
2020    namespace delete foo
2021} -result {type source line 2013 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2022
2023# -------------------------------------------------------------------------
2024namespace eval foo {}
2025proc foo::bar {} {
2026    for {*}{
2027	{set res [info frame 0]}
2028	{1} {} {break}
2029    }
2030    return $res
2031}
2032test info-33.8 {{*}, literal, simple, bytecompiled} -body {
2033    reduce [foo::bar]
2034} -cleanup {
2035    namespace delete foo
2036} -result {type source line 2027 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2037
2038# -------------------------------------------------------------------------
2039namespace eval foo {}
2040proc foo::bar {} {
2041    for {*}{
2042	{} {1} {}
2043	{set res [info frame 0]; break}
2044    }
2045    return $res
2046}
2047test info-33.9 {{*}, literal, simple, bytecompiled} -body {
2048    reduce [foo::bar]
2049} -cleanup {
2050    namespace delete foo
2051} -result {type source line 2043 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2052
2053# -------------------------------------------------------------------------
2054namespace eval foo {}
2055proc foo::bar {} {
2056    for {*}{
2057	{} {1}
2058	{return [info frame 0]}
2059	{}
2060    }
2061}
2062test info-33.10 {{*}, literal, simple, bytecompiled} -body {
2063    reduce [foo::bar]
2064} -cleanup {
2065    namespace delete foo
2066} -result {type source line 2058 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2067
2068# -------------------------------------------------------------------------
2069namespace eval foo {}
2070proc foo::bar {} {
2071    for {*}{
2072	{}
2073	{[return [info frame 0]]}
2074	{} {}
2075    }
2076}
2077test info-33.11 {{*}, literal, simple, bytecompiled} -body {
2078    reduce [foo::bar]
2079} -cleanup {
2080    namespace delete foo
2081} -result {type source line 2073 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2082
2083# -------------------------------------------------------------------------
2084namespace eval foo {}
2085proc foo::bar {} {
2086    foreach {*}{
2087	x
2088    } [return [info frame 0]] {}
2089}
2090test info-33.12 {{*}, literal, simple, bytecompiled} -body {
2091    reduce [foo::bar]
2092} -cleanup {
2093    namespace delete foo
2094} -result {type source line 2088 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2095
2096# -------------------------------------------------------------------------
2097namespace eval foo {}
2098proc foo::bar {} {
2099    foreach {*}{
2100	x y
2101	{set res [info frame 0]}
2102    }
2103    return $res
2104}
2105test info-33.13 {{*}, literal, simple, bytecompiled} -body {
2106    reduce [foo::bar]
2107} -cleanup {
2108    namespace delete foo
2109} -result {type source line 2101 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2110
2111# -------------------------------------------------------------------------
2112namespace eval foo {}
2113proc foo::bar {} {
2114    if {*}{
2115	{[return [info frame 0]]}
2116	{}
2117    }
2118}
2119test info-33.14 {{*}, literal, simple, bytecompiled} -body {
2120    reduce [foo::bar]
2121} -cleanup {
2122    namespace delete foo
2123} -result {type source line 2115 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2124
2125# -------------------------------------------------------------------------
2126namespace eval foo {}
2127proc foo::bar {} {
2128    if 0 {*}{
2129	{} else
2130	{return [info frame 0]}
2131    }
2132}
2133test info-33.15 {{*}, literal, simple, bytecompiled} -body {
2134    reduce [foo::bar]
2135} -cleanup {
2136    namespace delete foo
2137} -result {type source line 2130 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2138
2139# -------------------------------------------------------------------------
2140namespace eval foo {}
2141proc foo::bar {} {
2142    incr {*}{
2143	x
2144    } [return [info frame 0]]
2145}
2146test info-33.16 {{*}, literal, simple, bytecompiled} -body {
2147    reduce [foo::bar]
2148} -cleanup {
2149    namespace delete foo
2150} -result {type source line 2144 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2151
2152# -------------------------------------------------------------------------
2153namespace eval foo {}
2154proc foo::bar {} {
2155    info level {*}{
2156    } [return [info frame 0]]
2157}
2158test info-33.17 {{*}, literal, simple, bytecompiled} -body {
2159    reduce [foo::bar]
2160} -cleanup {
2161    namespace delete foo
2162} -result {type source line 2156 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2163
2164# -------------------------------------------------------------------------
2165namespace eval foo {}
2166proc foo::bar {} {
2167    string match {*}{
2168    } [return [info frame 0]] {}
2169}
2170test info-33.18 {{*}, literal, simple, bytecompiled} -body {
2171    reduce [foo::bar]
2172} -cleanup {
2173    namespace delete foo
2174} -result {type source line 2168 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2175
2176# -------------------------------------------------------------------------
2177namespace eval foo {}
2178proc foo::bar {} {
2179    string match {*}{
2180	{}
2181    } [return [info frame 0]]
2182}
2183test info-33.19 {{*}, literal, simple, bytecompiled} -body {
2184    reduce [foo::bar]
2185} -cleanup {
2186    namespace delete foo
2187} -result {type source line 2181 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2188
2189# -------------------------------------------------------------------------
2190namespace eval foo {}
2191proc foo::bar {} {
2192    string length {*}{
2193    } [return [info frame 0]]
2194}
2195test info-33.20 {{*}, literal, simple, bytecompiled} -body {
2196    reduce [foo::bar]
2197} -cleanup {
2198    namespace delete foo
2199} -result {type source line 2193 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2200
2201# -------------------------------------------------------------------------
2202namespace eval foo {}
2203proc foo::bar {} {
2204    while {*}{
2205	{[return [info frame 0]]}
2206    } {}
2207}
2208test info-33.21 {{*}, literal, simple, bytecompiled} -body {
2209    reduce [foo::bar]
2210} -cleanup {
2211    namespace delete foo
2212} -result {type source line 2205 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2213
2214# -------------------------------------------------------------------------
2215namespace eval foo {}
2216proc foo::bar {} {
2217    switch -- {*}{
2218    } [return [info frame 0]] {*}{
2219    } x y
2220}
2221test info-33.22 {{*}, literal, simple, bytecompiled} -body {
2222    reduce [foo::bar]
2223} -cleanup {
2224    namespace delete foo
2225} -result {type source line 2218 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2226
2227# -------------------------------------------------------------------------
2228namespace eval foo {}
2229proc foo::bar {} {
2230    try {*}{
2231	{set res [info frame 0]}
2232    }
2233    return $res
2234}
2235test info-33.23 {{*}, literal, simple, bytecompiled} -body {
2236    reduce [foo::bar]
2237} -cleanup {
2238    namespace delete foo
2239} -result {type source line 2231 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2240
2241# -------------------------------------------------------------------------
2242namespace eval foo {}
2243proc foo::bar {} {
2244    try {*}{
2245	{set res [info frame 0]}
2246    } finally {}
2247    return $res
2248}
2249test info-33.24 {{*}, literal, simple, bytecompiled} -body {
2250    reduce [foo::bar]
2251} -cleanup {
2252    namespace delete foo
2253} -result {type source line 2245 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2254
2255# -------------------------------------------------------------------------
2256namespace eval foo {}
2257proc foo::bar {} {
2258    try {*}{
2259	{set res [info frame 0]}
2260    } on ok {} {}
2261    return $res
2262}
2263test info-33.25 {{*}, literal, simple, bytecompiled} -body {
2264    reduce [foo::bar]
2265} -cleanup {
2266    namespace delete foo
2267} -result {type source line 2259 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2268
2269# -------------------------------------------------------------------------
2270namespace eval foo {}
2271proc foo::bar {} {
2272    try {*}{
2273	{set res [info frame 0]}
2274    } on ok {} {} finally {}
2275    return $res
2276}
2277test info-33.26 {{*}, literal, simple, bytecompiled} -body {
2278    reduce [foo::bar]
2279} -cleanup {
2280    namespace delete foo
2281} -result {type source line 2273 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2282
2283# -------------------------------------------------------------------------
2284namespace eval foo {}
2285proc foo::bar {} {
2286    while 1 {*}{
2287	{return [info frame 0]}
2288    }
2289}
2290test info-33.27 {{*}, literal, simple, bytecompiled} -body {
2291    reduce [foo::bar]
2292} -cleanup {
2293    namespace delete foo
2294} -result {type source line 2287 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2295
2296# -------------------------------------------------------------------------
2297namespace eval foo {}
2298proc foo::bar {} {
2299    try {} finally {*}{
2300	{return [info frame 0]}
2301    }
2302}
2303test info-33.28 {{*}, literal, simple, bytecompiled} -body {
2304    reduce [foo::bar]
2305} -cleanup {
2306    namespace delete foo
2307} -result {type source line 2300 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2308
2309# -------------------------------------------------------------------------
2310namespace eval foo {}
2311proc foo::bar {} {
2312    try {} on ok {} {} finally {*}{
2313	{return [info frame 0]}
2314    }
2315}
2316test info-33.29 {{*}, literal, simple, bytecompiled} -body {
2317    reduce [foo::bar]
2318} -cleanup {
2319    namespace delete foo
2320} -result {type source line 2313 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2321
2322# -------------------------------------------------------------------------
2323namespace eval foo {}
2324proc foo::bar {} {
2325    try {} on ok {} {*}{
2326	{return [info frame 0]}
2327    }
2328}
2329test info-33.30 {{*}, literal, simple, bytecompiled} -body {
2330    reduce [foo::bar]
2331} -cleanup {
2332    namespace delete foo
2333} -result {type source line 2326 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2334
2335# -------------------------------------------------------------------------
2336namespace eval foo {}
2337proc foo::bar {} {
2338    try {} on ok {} {*}{
2339	{return [info frame 0]}
2340    } finally {}
2341}
2342test info-33.31 {{*}, literal, simple, bytecompiled} -body {
2343    reduce [foo::bar]
2344} -cleanup {
2345    namespace delete foo
2346} -result {type source line 2339 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2347
2348# -------------------------------------------------------------------------
2349namespace eval foo {}
2350proc foo::bar {} {
2351    binary format {*}{
2352    } [return [info frame 0]]
2353}
2354test info-33.32 {{*}, literal, simple, bytecompiled} -body {
2355    reduce [foo::bar]
2356} -cleanup {
2357    namespace delete foo
2358} -result {type source line 2352 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2359
2360# -------------------------------------------------------------------------
2361namespace eval foo {}
2362proc foo::bar {} {
2363    set format format
2364    binary $format {*}{
2365    } [return [info frame 0]]
2366}
2367test info-33.33 {{*}, literal, simple, bytecompiled} -body {
2368    reduce [foo::bar]
2369} -cleanup {
2370    namespace delete foo
2371} -result {type source line 2365 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2372
2373# -------------------------------------------------------------------------
2374namespace eval foo {}
2375proc foo::bar {} {
2376    append x {*}{
2377    } [return [info frame 0]]
2378}
2379test info-33.34 {{*}, literal, simple, bytecompiled} -body {
2380    reduce [foo::bar]
2381} -cleanup {
2382    namespace delete foo
2383} -result {type source line 2377 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2384
2385# -------------------------------------------------------------------------
2386namespace eval foo {}
2387proc foo::bar {} {
2388    append {*}{
2389    } x([return [info frame 0]]) {*}{
2390    } a
2391}
2392test info-33.35 {{*}, literal, simple, bytecompiled} -body {
2393    reduce [foo::bar]
2394} -cleanup {
2395    namespace delete foo
2396} -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0}
2397
2398# -------------------------------------------------------------------------
2399namespace eval ::testinfocmdtype {
2400    apply {cmds {
2401	foreach c $cmds {rename $c {}}
2402    } ::testinfocmdtype} [info commands ::testinfocmdtype::*]
2403}
2404test info-40.1 {info cmdtype: syntax} -body {
2405    info cmdtype
2406} -returnCodes error -result {wrong # args: should be "info cmdtype commandName"}
2407test info-40.2 {info cmdtype: syntax} -body {
2408    info cmdtype foo bar
2409} -returnCodes error -result {wrong # args: should be "info cmdtype commandName"}
2410test info-40.3 {info cmdtype: no such command} -body {
2411    info cmdtype ::testinfocmdtype::foo
2412} -returnCodes error -result {unknown command "::testinfocmdtype::foo"}
2413test info-40.4 {info cmdtype: native commands} -body {
2414    info cmdtype ::if
2415} -result native
2416test info-40.5 {info cmdtype: native commands} -body {
2417    info cmdtype ::puts
2418} -result native
2419test info-40.6 {info cmdtype: native commands} -body {
2420    info cmdtype ::yield
2421} -result native
2422test info-40.7 {info cmdtype: procedures} -setup {
2423    proc ::testinfocmdtype::someproc {} {}
2424} -body {
2425    info cmdtype ::testinfocmdtype::someproc
2426} -cleanup {
2427    rename ::testinfocmdtype::someproc {}
2428} -result proc
2429test info-40.8 {info cmdtype: aliases} -setup {
2430    interp alias {} ::testinfocmdtype::somealias {} ::puts
2431} -body {
2432    info cmdtype ::testinfocmdtype::somealias
2433} -cleanup {
2434    rename ::testinfocmdtype::somealias {}
2435} -result alias
2436test info-40.9 {info cmdtype: imports} -setup {
2437    namespace eval ::testinfocmdtype {
2438	namespace eval foo {
2439	    proc bar {} {}
2440	    namespace export bar
2441	}
2442	namespace import foo::bar
2443    }
2444} -body {
2445    info cmdtype ::testinfocmdtype::bar
2446} -cleanup {
2447    rename ::testinfocmdtype::bar {}
2448    namespace delete ::testinfocmdtype::foo
2449} -result import
2450test info-40.10 {info cmdtype: interps} -setup {
2451    apply {i {
2452	rename $i ::testinfocmdtype::child
2453	variable ::testinfocmdtype::child $i
2454    }} [interp create]
2455} -body {
2456    info cmdtype ::testinfocmdtype::child
2457} -cleanup {
2458    interp delete $::testinfocmdtype::child
2459} -result interp
2460test info-40.11 {info cmdtype: objects} -setup {
2461    apply {{} {
2462	oo::object create obj
2463    } ::testinfocmdtype}
2464} -body {
2465    info cmdtype ::testinfocmdtype::obj
2466} -cleanup {
2467    ::testinfocmdtype::obj destroy
2468} -result object
2469test info-40.12 {info cmdtype: objects} -setup {
2470    apply {{} {
2471	oo::object create obj
2472    } ::testinfocmdtype}
2473} -body {
2474    info cmdtype [info object namespace ::testinfocmdtype::obj]::my
2475} -cleanup {
2476    ::testinfocmdtype::obj destroy
2477} -result privateObject
2478test info-40.13 {info cmdtype: ensembles} -setup {
2479    namespace eval ::testinfocmdtype {
2480	namespace eval ensmbl {
2481	    proc bar {} {}
2482	    namespace export *
2483	    namespace ensemble create
2484	}
2485    }
2486} -body {
2487    info cmdtype ::testinfocmdtype::ensmbl
2488} -cleanup {
2489    namespace delete ::testinfocmdtype::ensmbl
2490} -result ensemble
2491test info-40.14 {info cmdtype: zlib streams} -constraints zlib -setup {
2492    namespace eval ::testinfocmdtype {
2493	rename [zlib stream gzip] zstream
2494    }
2495} -body {
2496    info cmdtype ::testinfocmdtype::zstream
2497} -cleanup {
2498    ::testinfocmdtype::zstream close
2499} -result zlibStream
2500test info-40.15 {info cmdtype: coroutines} -setup {
2501    coroutine ::testinfocmdtype::coro eval yield
2502} -body {
2503    info cmdtype ::testinfocmdtype::coro
2504} -cleanup {
2505    ::testinfocmdtype::coro
2506} -result coroutine
2507test info-40.16 {info cmdtype: dynamic behavior} -setup {
2508    proc ::testinfocmdtype::foo {} {}
2509} -body {
2510    namespace eval ::testinfocmdtype {
2511	list [catch {info cmdtype foo}] [catch {info cmdtype bar}] \
2512	    [namespace which foo] [rename foo bar] [namespace which bar] \
2513	    [catch {info cmdtype foo}] [catch {info cmdtype bar}]
2514    }
2515} -cleanup {
2516    namespace eval ::testinfocmdtype {
2517	catch {rename foo {}}
2518	catch {rename bar {}}
2519    }
2520} -result {0 1 ::testinfocmdtype::foo {} ::testinfocmdtype::bar 1 0}
2521test info-40.17 {info cmdtype: aliases in child interpreters} -setup {
2522    set i [interp create]
2523} -body {
2524    $i alias foo gorp
2525    $i eval {
2526	info cmdtype foo
2527    }
2528} -cleanup {
2529    interp delete $i
2530} -result alias
2531test info-40.18 {info cmdtype: aliases in child interpreters} -setup {
2532    set safe [interp create -safe]
2533} -body {
2534    $safe alias foo gorp
2535    $safe eval {
2536	info cmdtype foo
2537    }
2538} -returnCodes error -cleanup {
2539    interp delete $safe
2540} -result {not allowed to invoke subcommand cmdtype of info}
2541test info-40.19 {info cmdtype: aliases in child interpreters} -setup {
2542    set safe [interp create -safe]
2543} -body {
2544    set inner [interp create [list $safe bar]]
2545    interp alias $inner foo $safe gorp
2546    $safe eval {
2547	bar eval {
2548	    info cmdtype foo
2549	}
2550    }
2551} -returnCodes error -cleanup {
2552    interp delete $safe
2553} -result {not allowed to invoke subcommand cmdtype of info}
2554test info-40.20 {info cmdtype: aliases in child interpreters} -setup {
2555    set safe [interp create -safe]
2556} -body {
2557    $safe eval {
2558	interp alias {} foo {} gorp
2559	info cmdtype foo
2560    }
2561} -returnCodes error -cleanup {
2562    interp delete $safe
2563} -result {not allowed to invoke subcommand cmdtype of info}
2564namespace delete ::testinfocmdtype
2565
2566# -------------------------------------------------------------------------
2567unset -nocomplain res
2568
2569test info-39.2 {Bug 4b61afd660} -setup {
2570    proc probe {} {
2571	return [dict get [info frame -1] line]
2572    }
2573    set body {
2574	set cmd probe
2575	$cmd
2576    }
2577    proc demo {} $body
2578} -body {
2579    demo
2580} -cleanup {
2581    unset -nocomplain body
2582    rename demo {}
2583    rename probe {}
2584} -result 3
2585
2586# cleanup
2587catch {namespace delete test_ns_info1 test_ns_info2}
2588::tcltest::cleanupTests
2589return
2590