# -*- tcl -*- # Commands covered: info # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2006 ActiveState # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: info.test,v 1.24.2.12 2009/07/14 16:31:49 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } # Set up namespaces needed to test operation of "info args", "info body", # "info default", and "info procs" with imported procedures. catch {namespace delete test_ns_info1 test_ns_info2} namespace eval test_ns_info1 { namespace export * proc p {x} {return "x=$x"} proc q {{y 27} {z {}}} {return "y=$y"} } testConstraint tip280 [info exists tcl_platform(tip,280)] testConstraint !tip280 [expr {![info exists tcl_platform(tip,280)]}] test info-1.1 {info args option} { proc t1 {a bbb c} {return foo} info args t1 } {a bbb c} test info-1.2 {info args option} { proc t1 {{a default1} {bbb default2} {c default3} args} {return foo} info a t1 } {a bbb c args} test info-1.3 {info args option} { proc t1 "" {return foo} info args t1 } {} test info-1.4 {info args option} { catch {rename t1 {}} list [catch {info args t1} msg] $msg } {1 {"t1" isn't a procedure}} test info-1.5 {info args option} { list [catch {info args set} msg] $msg } {1 {"set" isn't a procedure}} test info-1.6 {info args option} { proc t1 {a b} {set c 123; set d $c} t1 1 2 info args t1 } {a b} test info-1.7 {info args option} { catch {namespace delete test_ns_info2} namespace eval test_ns_info2 { namespace import ::test_ns_info1::* list [info args p] [info args q] } } {x {y z}} test info-2.1 {info body option} { proc t1 {} {body of t1} info body t1 } {body of t1} test info-2.2 {info body option} { list [catch {info body set} msg] $msg } {1 {"set" isn't a procedure}} test info-2.3 {info body option} { list [catch {info args set 1} msg] $msg } {1 {wrong # args: should be "info args procname"}} test info-2.4 {info body option} { catch {namespace delete test_ns_info2} namespace eval test_ns_info2 { namespace import ::test_ns_info1::* list [info body p] [info body q] } } {{return "x=$x"} {return "y=$y"}} # Prior to 8.3.0 this would cause a crash because [info body] # would return the bytecompiled version of foo, which the catch # would then try and eval out of the foo context, accessing # compiled local indices test info-2.5 {info body option, returning bytecompiled bodies} { catch {unset args} proc foo {args} { foreach v $args { upvar $v var return "variable $v existence: [info exists var]" } } foo a list [catch [info body foo] msg] $msg } {1 {can't read "args": no such variable}} # Fix for problem tested for in info-2.5 caused problems when # procedure body had no string rep (i.e. was not yet bytecode) # causing an empty string to be returned [Bug #545644] test info-2.6 {info body option, returning list bodies} { proc foo args [list subst bar] list [string bytelength [info body foo]] \ [foo; string bytelength [info body foo]] } {9 9} # "info cmdcount" is no longer accurate for compiled commands! # The expected result for info-3.1 used to be "3" and is now "1" # since the "set"s have been compiled away. info-3.2 was corrected # in 8.3 because the eval'ed body won't be compiled. proc testinfocmdcount {} { set x [info cmdcount] set y 12345 set z [info cm] expr $z-$x } test info-3.1 {info cmdcount compiled} { testinfocmdcount } 1 test info-3.2 {info cmdcount evaled} { set x [info cmdcount] set y 12345 set z [info cm] expr $z-$x } 3 test info-3.3 {info cmdcount evaled} [info body testinfocmdcount] 3 test info-3.4 {info cmdcount option} { list [catch {info cmdcount 1} msg] $msg } {1 {wrong # args: should be "info cmdcount"}} test info-4.1 {info commands option} { proc t1 {} {} proc t2 {} {} set x " [info commands] " list [string match {* t1 *} $x] [string match {* t2 *} $x] \ [string match {* set *} $x] [string match {* list *} $x] } {1 1 1 1} test info-4.2 {info commands option} { proc t1 {} {} rename t1 {} set x [info comm] string match {* t1 *} $x } 0 test info-4.3 {info commands option} { proc _t1_ {} {} proc _t2_ {} {} info commands _t1_ } _t1_ test info-4.4 {info commands option} { proc _t1_ {} {} proc _t2_ {} {} lsort [info commands _t*] } {_t1_ _t2_} catch {rename _t1_ {}} catch {rename _t2_ {}} test info-4.5 {info commands option} { list [catch {info commands a b} msg] $msg } {1 {wrong # args: should be "info commands ?pattern?"}} test info-5.1 {info complete option} { list [catch {info complete} msg] $msg } {1 {wrong # args: should be "info complete command"}} test info-5.2 {info complete option} { info complete abc } 1 test info-5.3 {info complete option} { info complete "\{abcd " } 0 test info-5.4 {info complete option} { info complete {# Comment should be complete command} } 1 test info-5.5 {info complete option} { info complete {[a [b] } } 0 test info-5.6 {info complete option} { info complete {[a [b]} } 0 test info-6.1 {info default option} { proc t1 {a b {c d} {e "long default value"}} {} info default t1 a value } 0 test info-6.2 {info default option} { proc t1 {a b {c d} {e "long default value"}} {} set value 12345 info d t1 a value set value } {} test info-6.3 {info default option} { proc t1 {a b {c d} {e "long default value"}} {} info default t1 c value } 1 test info-6.4 {info default option} { proc t1 {a b {c d} {e "long default value"}} {} set value 12345 info default t1 c value set value } d test info-6.5 {info default option} { proc t1 {a b {c d} {e "long default value"}} {} set value 12345 set x [info default t1 e value] list $x $value } {1 {long default value}} test info-6.6 {info default option} { list [catch {info default a b} msg] $msg } {1 {wrong # args: should be "info default procname arg varname"}} test info-6.7 {info default option} { list [catch {info default _nonexistent_ a b} msg] $msg } {1 {"_nonexistent_" isn't a procedure}} test info-6.8 {info default option} { proc t1 {a b} {} list [catch {info default t1 x value} msg] $msg } {1 {procedure "t1" doesn't have an argument "x"}} test info-6.9 {info default option} { catch {unset a} set a(0) 88 proc t1 {a b} {} list [catch {info default t1 a a} msg] $msg } {1 {couldn't store default value in variable "a"}} test info-6.10 {info default option} { catch {unset a} set a(0) 88 proc t1 {{a 18} b} {} list [catch {info default t1 a a} msg] $msg } {1 {couldn't store default value in variable "a"}} test info-6.11 {info default option} { catch {namespace delete test_ns_info2} namespace eval test_ns_info2 { namespace import ::test_ns_info1::* list [info default p x foo] $foo [info default q y bar] $bar } } {0 {} 1 27} catch {unset a} test info-7.1 {info exists option} { set value foo info exists value } 1 catch {unset _nonexistent_} test info-7.2 {info exists option} { info exists _nonexistent_ } 0 test info-7.3 {info exists option} { proc t1 {x} {return [info exists x]} t1 2 } 1 test info-7.4 {info exists option} { proc t1 {x} { global _nonexistent_ return [info exists _nonexistent_] } t1 2 } 0 test info-7.5 {info exists option} { proc t1 {x} { set y 47 return [info exists y] } t1 2 } 1 test info-7.6 {info exists option} { proc t1 {x} {return [info exists value]} t1 2 } 0 test info-7.7 {info exists option} { catch {unset x} set x(2) 44 list [info exists x] [info exists x(1)] [info exists x(2)] } {1 0 1} catch {unset x} test info-7.8 {info exists option} { list [catch {info exists} msg] $msg } {1 {wrong # args: should be "info exists varName"}} test info-7.9 {info exists option} { list [catch {info exists 1 2} msg] $msg } {1 {wrong # args: should be "info exists varName"}} test info-8.1 {info globals option} { set x 1 set y 2 set value 23 set a " [info globals] " list [string match {* x *} $a] [string match {* y *} $a] \ [string match {* value *} $a] [string match {* _foobar_ *} $a] } {1 1 1 0} test info-8.2 {info globals option} { set _xxx1 1 set _xxx2 2 lsort [info g _xxx*] } {_xxx1 _xxx2} test info-8.3 {info globals option} { list [catch {info globals 1 2} msg] $msg } {1 {wrong # args: should be "info globals ?pattern?"}} test info-8.4 {info globals option: may have leading namespace qualifiers} { set x 0 list [info globals x] [info globals :x] [info globals ::x] [info globals :::x] [info globals ::::x] } {x {} x x x} test info-8.5 {info globals option: only return existing global variables} { -setup { catch {unset ::NO_SUCH_VAR} proc evalInProc script {eval $script} } -body { evalInProc {global NO_SUCH_VAR; info globals NO_SUCH_VAR} } -cleanup { rename evalInProc {} } -result {} } test info-9.1 {info level option} { info level } 0 test info-9.2 {info level option} { proc t1 {a b} { set x [info le] set y [info level 1] list $x $y } t1 146 testString } {1 {t1 146 testString}} test info-9.3 {info level option} { proc t1 {a b} { t2 [expr $a*2] $b } proc t2 {x y} { list [info level] [info level 1] [info level 2] [info level -1] \ [info level 0] } t1 146 {a {b c} {{{c}}}} } {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}}}}}} test info-9.4 {info level option} { proc t1 {} { set x [info level] set y [info level 1] list $x $y } t1 } {1 t1} test info-9.5 {info level option} { list [catch {info level 1 2} msg] $msg } {1 {wrong # args: should be "info level ?number?"}} test info-9.6 {info level option} { list [catch {info level 123a} msg] $msg } {1 {expected integer but got "123a"}} test info-9.7 {info level option} { list [catch {info level 0} msg] $msg } {1 {bad level "0"}} test info-9.8 {info level option} { proc t1 {} {info level -1} list [catch {t1} msg] $msg } {1 {bad level "-1"}} test info-9.9 {info level option} { proc t1 {x} {info level $x} list [catch {t1 -3} msg] $msg } {1 {bad level "-3"}} test info-9.10 {info level option, namespaces} { set msg [namespace eval t {info level 0}] namespace delete t set msg } {namespace eval t {info level 0}} set savedLibrary $tcl_library test info-10.1 {info library option} { list [catch {info library x} msg] $msg } {1 {wrong # args: should be "info library"}} test info-10.2 {info library option} { set tcl_library 12345 info library } {12345} test info-10.3 {info library option} { unset tcl_library list [catch {info library} msg] $msg } {1 {no library has been specified for Tcl}} set tcl_library $savedLibrary test info-11.1 {info loaded option} { list [catch {info loaded a b} msg] $msg } {1 {wrong # args: should be "info loaded ?interp?"}} test info-11.2 {info loaded option} { list [catch {info loaded {}}] [catch {info loaded gorp} msg] $msg } {0 1 {could not find interpreter "gorp"}} test info-12.1 {info locals option} { set a 22 proc t1 {x y} { set b 13 set c testing global a global aa set aa 23 return [info locals] } lsort [t1 23 24] } {b c x y} test info-12.2 {info locals option} { proc t1 {x y} { set xx1 2 set xx2 3 set y 4 return [info loc x*] } lsort [t1 2 3] } {x xx1 xx2} test info-12.3 {info locals option} { list [catch {info locals 1 2} msg] $msg } {1 {wrong # args: should be "info locals ?pattern?"}} test info-12.4 {info locals option} { info locals } {} test info-12.5 {info locals option} { proc t1 {} {return [info locals]} t1 } {} test info-12.6 {info locals vs unset compiled locals} { proc t1 {lst} { foreach $lst $lst {} unset lst return [info locals] } lsort [t1 {a b c c d e f}] } {a b c d e f} test info-12.7 {info locals with temporary variables} { proc t1 {} { foreach a {b c} {} info locals } t1 } {a} test info-13.1 {info nameofexecutable option} { list [catch {info nameofexecutable foo} msg] $msg } {1 {wrong # args: should be "info nameofexecutable"}} test info-14.1 {info patchlevel option} { set a [info patchlevel] regexp {[0-9]+\.[0-9]+([p[0-9]+)?} $a } 1 test info-14.2 {info patchlevel option} { list [catch {info patchlevel a} msg] $msg } {1 {wrong # args: should be "info patchlevel"}} test info-14.3 {info patchlevel option} { set t $tcl_patchLevel unset tcl_patchLevel set result [list [catch {info patchlevel} msg] $msg] set tcl_patchLevel $t set result } {1 {can't read "tcl_patchLevel": no such variable}} test info-15.1 {info procs option} { proc t1 {} {} proc t2 {} {} set x " [info procs] " list [string match {* t1 *} $x] [string match {* t2 *} $x] \ [string match {* _undefined_ *} $x] } {1 1 0} test info-15.2 {info procs option} { proc _tt1 {} {} proc _tt2 {} {} lsort [info pr _tt*] } {_tt1 _tt2} catch {rename _tt1 {}} catch {rename _tt2 {}} test info-15.3 {info procs option} { list [catch {info procs 2 3} msg] $msg } {1 {wrong # args: should be "info procs ?pattern?"}} test info-15.4 {info procs option} { catch {namespace delete test_ns_info2} namespace eval test_ns_info2 { namespace import ::test_ns_info1::* proc r {} {} list [info procs] [info procs p*] } } {{p q r} p} test info-15.5 {info procs option with a proc in a namespace} { catch {namespace delete test_ns_info2} namespace eval test_ns_info2 { proc p1 { arg } { puts cmd } proc p2 { arg } { puts cmd } } info procs ::test_ns_info2::p1 } {::test_ns_info2::p1} test info-15.6 {info procs option with a pattern in a namespace} { catch {namespace delete test_ns_info2} namespace eval test_ns_info2 { proc p1 { arg } { puts cmd } proc p2 { arg } { puts cmd } } lsort [info procs ::test_ns_info2::p*] } [lsort [list ::test_ns_info2::p1 ::test_ns_info2::p2]] test info-15.7 {info procs option with a global shadowing proc} { catch {namespace delete test_ns_info2} proc string_cmd { arg } { puts cmd } namespace eval test_ns_info2 { proc string_cmd { arg } { puts cmd } } info procs test_ns_info2::string* } {::test_ns_info2::string_cmd} # This regression test is currently commented out because it requires # that the implementation of "info procs" looks into the global namespace, # which it does not (in contrast to "info commands") if {0} { test info-15.8 {info procs option with a global shadowing proc} { catch {namespace delete test_ns_info2} proc string_cmd { arg } { puts cmd } proc string_cmd2 { arg } { puts cmd } namespace eval test_ns_info2 { proc string_cmd { arg } { puts cmd } } namespace eval test_ns_info2 { lsort [info procs string*] } } [lsort [list string_cmd string_cmd2]] } test info-16.1 {info script option} { list [catch {info script x x} msg] $msg } {1 {wrong # args: should be "info script ?filename?"}} test info-16.2 {info script option} { file tail [info sc] } "info.test" set gorpfile [makeFile "info script\n" gorp.info] test info-16.3 {info script option} { list [source $gorpfile] [file tail [info script]] } [list $gorpfile info.test] test info-16.4 {resetting "info script" after errors} { catch {source ~_nobody_/foo} file tail [info script] } "info.test" test info-16.5 {resetting "info script" after errors} { catch {source _nonexistent_} file tail [info script] } "info.test" test info-16.6 {info script option} { set script [info script] list [file tail [info script]] \ [info script newname.txt] \ [file tail [info script $script]] } [list info.test newname.txt info.test] test info-16.7 {info script option} { set script [info script] info script newname.txt list [source $gorpfile] [file tail [info script]] \ [file tail [info script $script]] } [list $gorpfile newname.txt info.test] removeFile gorp.info set gorpfile [makeFile {list [info script] [info script foo.bar]} gorp.info] test info-16.8 {info script option} { list [source $gorpfile] [file tail [info script]] } [list [list $gorpfile foo.bar] info.test] removeFile gorp.info test info-17.1 {info sharedlibextension option} { list [catch {info sharedlibextension foo} msg] $msg } {1 {wrong # args: should be "info sharedlibextension"}} test info-18.1 {info tclversion option} { set x [info tclversion] scan $x "%d.%d%c" a b c } 2 test info-18.2 {info tclversion option} { list [catch {info t 2} msg] $msg } {1 {wrong # args: should be "info tclversion"}} test info-18.3 {info tclversion option} { set t $tcl_version unset tcl_version set result [list [catch {info tclversion} msg] $msg] set tcl_version $t set result } {1 {can't read "tcl_version": no such variable}} test info-19.1 {info vars option} { set a 1 set b 2 proc t1 {x y} { global a b set c 33 return [info vars] } lsort [t1 18 19] } {a b c x y} test info-19.2 {info vars option} { set xxx1 1 set xxx2 2 proc t1 {xxa y} { global xxx1 xxx2 set c 33 return [info vars x*] } lsort [t1 18 19] } {xxa xxx1 xxx2} test info-19.3 {info vars option} { lsort [info vars] } [lsort [info globals]] test info-19.4 {info vars option} { list [catch {info vars a b} msg] $msg } {1 {wrong # args: should be "info vars ?pattern?"}} test info-19.5 {info vars with temporary variables} { proc t1 {} { foreach a {b c} {} info vars } t1 } {a} test info-19.6 {info vars: Bug 1072654} -setup { namespace eval :: unset -nocomplain foo catch {namespace delete x} } -body { namespace eval x info vars foo } -cleanup { namespace delete x } -result {} # Check whether the extra testing functions are defined... if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { 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} } else { 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} } test info-20.1 {info functions option} {info functions sin} sin test info-20.2 {info functions option} {lsort [info functions]} $functions test info-20.3 {info functions option} { lsort [info functions a*] } {abs acos asin atan atan2} test info-20.4 {info functions option} { lsort [info functions *tan*] } {atan atan2 tan tanh} test info-20.5 {info functions option} { list [catch {info functions raise an error} msg] $msg } {1 {wrong # args: should be "info functions ?pattern?"}} test info-21.1 {miscellaneous error conditions} { list [catch {info} msg] $msg } {1 {wrong # args: should be "info option ?arg arg ...?"}} test info-21.2 {miscellaneous error conditions} !tip280 { list [catch {info gorp} msg] $msg } {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}} test info-21.2-280 {miscellaneous error conditions} tip280 { list [catch {info gorp} msg] $msg } {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}} test info-21.3 {miscellaneous error conditions} !tip280 { list [catch {info c} msg] $msg } {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}} test info-21.3-280 {miscellaneous error conditions} tip280 { list [catch {info c} msg] $msg } {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}} test info-21.4 {miscellaneous error conditions} !tip280 { list [catch {info l} msg] $msg } {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}} test info-21.4-280 {miscellaneous error conditions} tip280 { list [catch {info l} msg] $msg } {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}} test info-21.5 {miscellaneous error conditions} !tip280 { list [catch {info s} msg] $msg } {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}} test info-21.5-280 {miscellaneous error conditions} tip280 { list [catch {info s} msg] $msg } {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}} ## # ### ### ### ######### ######### ######### ## info frame ## Helper # For the more complex results we cut the file name down to remove # path dependencies, and we use only part of the first line of the # reported command. The latter is required because otherwise the whole # test case may appear in some results, but the result is part of the # testcase. An infinite string would be required to describe that. The # cutting-down breaks this. proc reduce {frame} { set pos [lsearch -exact $frame cmd] incr pos set cmd [lindex $frame $pos] if {[regexp \n $cmd]} { set first [lindex [split $cmd \n] 0] ; set first [expr {[string length $first] > 11 ? [string range $first 0 end-11] : [string range $first 0 end-4]}] set frame [lreplace $frame $pos $pos $first] } set pos [lsearch -exact $frame file] if {$pos >=0} { incr pos set tail [file tail [lindex $frame $pos]] set frame [lreplace $frame $pos $pos $tail] } set frame } ## Helper # Generate a stacktrace from the current location to top. This code # not only depends on the exact location of things, but also on the # implementation of tcltest. Any changes and these tests will have to # be updated. proc etrace {} { set res {} set level [info frame] while {$level} { lappend res [list $level [reduce [info frame $level]]] incr level -1 } return $res } ## test info-22.0.0 {info frame, levels} {tip280 && !singleTestInterp} { info frame } 7 test info-22.0.1 {info frame, levels} {tip280 && singleTestInterp} { info frame } 10 test info-22.1.0 {info frame, bad level relative} {tip280 && !singleTestInterp} { # catch is another level!, i.e. we have 8, not 7 catch {info frame -8} msg set msg } {bad level "-8"} test info-22.1.1 {info frame, bad level relative} {tip280 && singleTestInterp} { # catch is another level!, i.e. we have 11, not 10 catch {info frame -11} msg set msg } {bad level "-11"} test info-22.2.0 {info frame, bad level absolute} {tip280 && !singleTestInterp} { # catch is another level!, i.e. we have 8, not 7 catch {info frame 9} msg set msg } {bad level "9"} test info-22.2.1 {info frame, bad level absolute} {tip280 && singleTestInterp} { # catch is another level!, i.e. we have 12, not 10 catch {info frame 12} msg set msg } {bad level "12"} test info-22.3 {info frame, current, relative} -constraints tip280 -match glob -body { info frame 0 } -result {type source line 761 file * cmd {info frame 0} proc ::tcltest::RunTest} test info-22.4 {info frame, current, relative, nested} -constraints tip280 -match glob -body { set res [info frame 0] } -result {type source line 765 file * cmd {info frame 0} proc ::tcltest::RunTest} test info-22.5.0 {info frame, current, absolute} -constraints {tip280 && !singleTestInterp} -match glob -body { reduce [info frame 7] } -result {type source line 769 file * cmd {info frame 7} proc ::tcltest::RunTest} test info-22.5.1 {info frame, current, absolute} -constraints {tip280 && singleTestInterp} -match glob -body { reduce [info frame 10] } -result {type source line 772 file * cmd {info frame 10} proc ::tcltest::RunTest} test info-22.6.0 {info frame, global, relative} {tip280 && !singleTestInterp} { reduce [info frame -6] } {type source line 775 file info.test cmd test\ info-22.6.0\ \{info\ frame,\ global,\ relative\}\ \{tip280\ &&\ !singleTe} test info-22.6.1 {info frame, global, relative} {tip280 && singleTestInterp} { reduce [info frame -6] } {type source line 778 file info.test cmd test\ info-22.6.1\ \{info\ frame,\ global,\ relative\}\ \{tip280\ &&\ singleTe proc ::tcltest::runAllTests} test info-22.7.0 {info frame, global, absolute} {tip280 && !singleTestInterp} { reduce [info frame 1] } {type source line 782 file info.test cmd test\ info-22.7.0\ \{info\ frame,\ global,\ absolute\}\ \{tip280\ &&\ !singleTe} test info-22.7.1 {info frame, global, absolute} {tip280 && singleTestInterp} { reduce [info frame 4] } {type source line 785 file info.test cmd test\ info-22.7.1\ \{info\ frame,\ global,\ absolute\}\ \{tip280\ &&\ singleTe proc ::tcltest::runAllTests} test info-22.8 {info frame, basic trace} -constraints {tip280} -match glob -body { join [lrange [etrace] 0 1] \n } -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} * {type source line 790 file info.test cmd etrace proc ::tcltest::RunTest}} ## The line 1966 is off by 5 from the true value of 1971. This is a knownBug, see testcase 30.0 test info-23.0.0 {eval'd info frame} {tip280 && !singleTestInterp} { eval {info frame} } 8 test info-23.0.1 {eval'd info frame} {tip280 && singleTestInterp} { eval {info frame} } 11 test info-23.1.0 {eval'd info frame, semi-dynamic} {tip280 && !singleTestInterp} { eval info frame } 8 test info-23.1.1 {eval'd info frame, semi-dynamic} {tip280 && singleTestInterp} { eval info frame } 11 test info-23.2.0 {eval'd info frame, dynamic} {tip280 && !singleTestInterp} { set script {info frame} eval $script } 8 test info-23.2.1 {eval'd info frame, dynamic} {tip280 && singleTestInterp} { set script {info frame} eval $script } 11 test info-23.3 {eval'd info frame, literal} -constraints tip280 -match glob -body { eval { info frame 0 } } -result {type source line 819 file *info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-23.4 {eval'd info frame, semi-dynamic} tip280 { eval info frame 0 } {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest} test info-23.5 {eval'd info frame, dynamic} tip280 { set script {info frame 0} eval $script } {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest} test info-23.6 {eval'd info frame, trace} -constraints {tip280} -match glob -body { set script {etrace} join [lrange [eval $script] 0 2] \n } -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 1 cmd etrace proc ::tcltest::RunTest} * {type source line 834 file info.test cmd {eval $script} proc ::tcltest::RunTest}} ## The line 1966 is off by 5 from the true value of 1971. This is a knownBug, see testcase 30.0 # ------------------------------------------------------------------------- # Procedures defined in scripts which are arguments to control # structures (like 'namespace eval', 'interp eval', 'if', 'while', # 'switch', 'catch', 'for', 'foreach', etc.) have no absolute # location. The command implementations execute such scripts through # Tcl_EvalObjEx. Flag 0 causes it to use the bytecode compiler. This # causes the connection to the context to be lost. Currently only # procedure bodies are able to remember their context. # ------------------------------------------------------------------------- namespace eval foo { proc bar {} {info frame 0} } test info-24.0 {info frame, interaction, namespace eval} tip280 { reduce [foo::bar] } {type source line 852 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo # ------------------------------------------------------------------------- set flag 1 if {$flag} { namespace eval foo {} proc ::foo::bar {} {info frame 0} } test info-24.1 {info frame, interaction, if} tip280 { reduce [foo::bar] } {type source line 866 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo # ------------------------------------------------------------------------- set flag 1 while {$flag} { namespace eval foo {} proc ::foo::bar {} {info frame 0} set flag 0 } test info-24.2 {info frame, interaction, while} tip280 { reduce [foo::bar] } {type source line 880 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo # ------------------------------------------------------------------------- catch { namespace eval foo {} proc ::foo::bar {} {info frame 0} } test info-24.3 {info frame, interaction, catch} tip280 { reduce [foo::bar] } {type source line 894 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo # ------------------------------------------------------------------------- foreach var val { namespace eval foo {} proc ::foo::bar {} {info frame 0} break } test info-24.4 {info frame, interaction, foreach} tip280 { reduce [foo::bar] } {type source line 907 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo # ------------------------------------------------------------------------- for {} {1} {} { namespace eval foo {} proc ::foo::bar {} {info frame 0} break } test info-24.5 {info frame, interaction, for} tip280 { reduce [foo::bar] } {type source line 921 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo # ------------------------------------------------------------------------- eval { proc bar {} {info frame 0} } test info-25.0 {info frame, proc in eval} tip280 { reduce [bar] } {type source line 934 file info.test cmd {info frame 0} proc ::bar level 0} proc bar {} {info frame 0} test info-25.1 {info frame, regular proc} tip280 { reduce [bar] } {type source line 941 file info.test cmd {info frame 0} proc ::bar level 0} rename bar {} test info-30.0 {bs+nl in literal words} {tip280 knownBug} { if {1} { set res \ [reduce [info frame 0]] } set res # This is reporting line 3 instead of the correct 4 because the # bs+nl combination is subst by the parser before the 'if' # command, and the the bcc sees the word. To fix record the # offsets of all bs+nl sequences in literal words, then use the # information in the bcc to bump line numbers when parsing over # the location. Also affected: testcases 22.8 and 23.6. } {type eval line 4 cmd {info frame 0} proc ::tcltest::RunTest} # ------------------------------------------------------------------------- # See 24.0 - 24.5 for similar situations, using literal scripts. set body {set flag 0 set a c set res [info frame 0]} ;# line 3! test info-31.0 {ns eval, script in variable} tip280 { namespace eval foo $body set res } {type eval line 3 cmd {info frame 0} level 0} catch {namespace delete foo} test info-31.1 {if, script in variable} tip280 { if 1 $body set res } {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest} test info-31.1a {if, script in variable} tip280 { if 1 then $body set res } {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest} test info-31.2 {while, script in variable} tip280 { set flag 1 while {$flag} $body set res } {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest} # .3 - proc - scoping prevent return of result ... test info-31.4 {foreach, script in variable} tip280 { foreach var val $body set res } {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest} test info-31.5 {for, script in variable} tip280 { set flag 1 for {} {$flag} {} $body set res } {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest} test info-31.6 {eval, script in variable} tip280 { eval $body set res } {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest} # ------------------------------------------------------------------------- namespace eval foo {} set x foo switch -exact -- $x { foo { proc ::foo::bar {} {info frame 0} } } test info-24.6.0 {info frame, interaction, switch, list body} tip280 { reduce [foo::bar] } {type source line 1021 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo unset x # ------------------------------------------------------------------------- namespace eval foo {} set x foo switch -exact -- $x foo { proc ::foo::bar {} {info frame 0} } test info-24.6.1 {info frame, interaction, switch, multi-body} tip280 { reduce [foo::bar] } {type source line 1037 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo unset x # ------------------------------------------------------------------------- namespace eval foo {} set x foo switch -exact -- $x [list foo { proc ::foo::bar {} {info frame 0} }] test info-24.6.2 {info frame, interaction, switch, list body, dynamic} tip280 { reduce [foo::bar] } {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo unset x # ------------------------------------------------------------------------- set body { foo { proc ::foo::bar {} {info frame 0} } } namespace eval foo {} set x foo switch -exact -- $x $body test info-31.7 {info frame, interaction, switch, dynamic} tip280 { reduce [foo::bar] } {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo unset x # ------------------------------------------------------------------------- set body { proc ::foo::bar {} {info frame 0} } namespace eval foo {} eval $body test info-32.0 {info frame, dynamic procedure} tip280 { reduce [foo::bar] } {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo # ------------------------------------------------------------------------- test info-34.0 {eval pure list, single line} -constraints {tip280} -match glob -body { # Basically, counting the newline in the word seen through $foo # doesn't really make sense. It makes a bit of sense if the word # would have been a string literal in the command list. # # Problem: At the point where we see the list elements we cannot # distinguish the two cases, thus we cannot switch between # count/not-count, it is has to be one or the other for all # cases. Of the two possibilities miguel convinced me that 'not # counting' is the more proper. set foo {b c} set cmd [list foreach $foo {x y} { set res [join [lrange [etrace] 0 2] \n] break }] eval $cmd set res } -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 2 cmd etrace proc ::tcltest::RunTest} * {type eval line 1 cmd foreac proc ::tcltest::RunTest}} # ------------------------------------------------------------------------- # 6 cases. ## DV. direct-var - unchanged ## DPV direct-proc-var - ditto ## PPV proc-proc-var - ditto ## DL. direct-literal - now tracking absolute location ## DPL direct-proc-literal - ditto ## PPL proc-proc-literal - ditto ## ### ### ### ######### ######### #########" proc control {vv script} { upvar 1 $vv var return [uplevel 1 $script] } proc datal {} { control y { set y PPL etrace } } proc datav {} { set script { set y PPV etrace } control y $script } test info-38.1 {location information for uplevel, dv, direct-var} -constraints tip280 -match glob -body { set script { set y DV. etrace } join [lrange [uplevel \#0 $script] 0 2] \n } -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 3 cmd etrace proc ::tcltest::RunTest} * {type source line 1156 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} test info-38.2 {location information for uplevel, dl, direct-literal} -constraints tip280 -match glob -body { join [lrange [uplevel \#0 { set y DL. etrace }] 0 2] \n } -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} * {type source line 1164 file info.test cmd etrace proc ::tcltest::RunTest} * {type source line 1162 file info.test cmd up proc ::tcltest::RunTest}} test info-38.3 {location information for uplevel, dpv, direct-proc-var} -constraints tip280 -match glob -body { set script { set y DPV etrace } join [lrange [control y $script] 0 3] \n } -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 3 cmd etrace proc ::control} * {type source line 1133 file info.test cmd {uplevel 1 $script} proc ::control} * {type source line 1175 file info.test cmd {control y $script} proc ::tcltest::RunTest}} test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -constraints tip280 -match glob -body { join [lrange [control y { set y DPL etrace }] 0 3] \n } -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} * {type source line 1184 file info.test cmd etrace proc ::control} * {type source line 1133 file info.test cmd {uplevel 1 $script} proc ::control} * {type source line 1182 file info.test cmd control proc ::tcltest::RunTest}} test info-38.5 {location information for uplevel, ppv, proc-proc-var} -constraints tip280 -match glob -body { join [lrange [datav] 0 4] \n } -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 3 cmd etrace proc ::control} * {type source line 1133 file info.test cmd {uplevel 1 $script} proc ::control} * {type source line 1148 file info.test cmd {control y $script} proc ::datav level 1} * {type source line 1192 file info.test cmd datav proc ::tcltest::RunTest}} test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -constraints tip280 -match glob -body { join [lrange [datal] 0 4] \n } -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} * {type source line 1139 file info.test cmd etrace proc ::control} * {type source line 1133 file info.test cmd {uplevel 1 $script} proc ::control} * {type source line 1137 file info.test cmd control proc ::datal level 1} * {type source line 1200 file info.test cmd datal proc ::tcltest::RunTest}} # ------------------------------------------------------------------------- # literal sharing test info-39.0 {location information not confused by literal sharing} -constraints tip280 -body { namespace eval ::foo {} proc ::foo::bar {} { lappend res {} lappend res [reduce [eval {info frame 0}]] lappend res [reduce [eval {info frame 0}]] return $res } set res [::foo::bar] namespace delete ::foo join $res \n } -result { type source line 1214 file info.test cmd {info frame 0} proc ::foo::bar level 0 type source line 1215 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- # cleanup catch {namespace delete test_ns_info1 test_ns_info2} ::tcltest::cleanupTests return