diff options
Diffstat (limited to 'tests/info.test')
| -rw-r--r-- | tests/info.test | 1221 |
1 files changed, 788 insertions, 433 deletions
diff --git a/tests/info.test b/tests/info.test index 5816da3..937da8c 100644 --- a/tests/info.test +++ b/tests/info.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# DO NOT DELETE THIS LINE. Keep line numbers correct for testing 'info frame'. +# DO NOT DELETE THIS LINE if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -31,10 +31,6 @@ namespace eval test_ns_info1 { 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 @@ -47,13 +43,13 @@ test info-1.3 {info args option} { proc t1 "" {return foo} info args t1 } {} -test info-1.4 {info args option} { +test info-1.4 {info args option} -body { 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}} + info args t1 +} -returnCodes error -result {"t1" isn't a procedure} +test info-1.5 {info args option} -body { + info args set +} -returnCodes error -result {"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 @@ -71,12 +67,12 @@ 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.2 {info body option} -body { + info body set +} -returnCodes error -result {"set" isn't a procedure} +test info-2.3 {info body option} -body { + info args set 1 +} -returnCodes error -result {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 { @@ -108,10 +104,6 @@ test info-2.6 {info body option, returning list bodies} { [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 @@ -120,17 +112,17 @@ proc testinfocmdcount {} { } test info-3.1 {info cmdcount compiled} { testinfocmdcount -} 1 +} 4 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"}} +} 4 +test info-3.3 {info cmdcount evaled} [info body testinfocmdcount] 4 +test info-3.4 {info cmdcount option} -body { + info cmdcount 1 +} -returnCodes error -result {wrong # args: should be "info cmdcount"} test info-4.1 {info commands option} { proc t1 {} {} @@ -157,13 +149,14 @@ test info-4.4 {info commands option} { } {_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-4.5 {info commands option} -returnCodes error -body { + info commands a b +} -result {wrong # args: should be "info commands ?pattern?"} +# Also some tests in namespace.test + +test info-5.1 {info complete option} -body { + info complete +} -returnCodes error -result {wrong # args: should be "info complete command"} test info-5.2 {info complete option} { info complete abc } 1 @@ -206,28 +199,30 @@ test info-6.5 {info default option} { 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} { +test info-6.6 {info default option} -returnCodes error -body { + info default a b +} -result {wrong # args: should be "info default procname arg varname"} +test info-6.7 {info default option} -returnCodes error -body { + info default _nonexistent_ a b +} -result {"_nonexistent_" isn't a procedure} +test info-6.8 {info default option} -returnCodes error -body { 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} { + info default t1 x value +} -result {procedure "t1" doesn't have an argument "x"} +test info-6.9 {info default option} -returnCodes error -setup { catch {unset a} +} -body { 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} { + info default t1 a a +} -returnCodes error -result {couldn't store default value in variable "a"} +test info-6.10 {info default option} -setup { catch {unset a} +} -body { 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"}} + info default t1 a a +} -returnCodes error -result {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 { @@ -267,18 +262,19 @@ test info-7.6 {info exists option} { proc t1 {x} {return [info exists value]} t1 2 } 0 -test info-7.7 {info exists option} { +test info-7.7 {info exists option} -setup { catch {unset x} +} -body { set x(2) 44 list [info exists x] [info exists x(1)] [info exists x(2)] -} {1 0 1} +} -result {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-7.8 {info exists option} -body { + info exists +} -returnCodes error -result {wrong # args: should be "info exists varName"} +test info-7.9 {info exists option} -body { + info exists 1 2 +} -returnCodes error -result {wrong # args: should be "info exists varName"} test info-8.1 {info globals option} { set x 1 @@ -293,9 +289,9 @@ test info-8.2 {info globals option} { 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.3 {info globals option} -returnCodes error -body { + info globals 1 2 +} -result {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] @@ -343,46 +339,64 @@ test info-9.4 {info level option} { } 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} { +test info-9.5 {info level option} -body { + info level 1 2 +} -returnCodes error -result {wrong # args: should be "info level ?number?"} +test info-9.6 {info level option} -body { + info level 123a +} -returnCodes error -result {expected integer but got "123a"} +test info-9.7 {info level option} -body { + info level 0 +} -returnCodes error -result {bad level "0"} +test info-9.8 {info level option} -body { proc t1 {} {info level -1} - list [catch {t1} msg] $msg -} {1 {bad level "-1"}} -test info-9.9 {info level option} { + t1 +} -returnCodes error -result {bad level "-1"} +test info-9.9 {info level option} -body { proc t1 {x} {info level $x} - list [catch {t1 -3} msg] $msg -} {1 {bad level "-3"}} + t1 -3 +} -returnCodes error -result {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}} +test info-9.11 {info level option, aliases} -constraints knownBug -setup { + proc w {x y z} {info level 0} + interp alias {} a {} w a b +} -body { + a c +} -cleanup { + rename a {} + rename w {} +} -result {a c} +test info-9.12 {info level option, ensembles} -constraints knownBug -setup { + proc w {x y z} {info level 0} + namespace ensemble create -command a -map {foo ::w} +} -body { + a foo 1 2 3 +} -cleanup { + rename a {} + rename w {} +} -result {a foo 1 2 3} 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.1 {info library option} -body { + info library x +} -returnCodes error -result {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} { +test info-10.3 {info library option} -body { unset tcl_library - list [catch {info library} msg] $msg -} {1 {no library has been specified for Tcl}} + info library +} -returnCodes error -result {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.1 {info loaded option} -body { + info loaded a b +} -returnCodes error -result {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"}} @@ -408,9 +422,9 @@ test info-12.2 {info locals option} { } 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.3 {info locals option} -body { + info locals 1 2 +} -returnCodes error -result {wrong # args: should be "info locals ?pattern?"} test info-12.4 {info locals option} { info locals } {} @@ -434,24 +448,25 @@ test info-12.7 {info locals with temporary variables} { 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-13.1 {info nameofexecutable option} -returnCodes error -body { + info nameofexecutable foo +} -result {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} { +test info-14.2 {info patchlevel option} -returnCodes error -body { + info patchlevel a +} -result {wrong # args: should be "info patchlevel"} +test info-14.3 {info patchlevel option} -setup { set t $tcl_patchLevel +} -body { unset tcl_patchLevel - set result [list [catch {info patchlevel} msg] $msg] + info patchlevel +} -cleanup { set tcl_patchLevel $t - set result -} {1 {can't read "tcl_patchLevel": no such variable}} +} -returnCodes error -result {can't read "tcl_patchLevel": no such variable} test info-15.1 {info procs option} { proc t1 {} {} @@ -467,19 +482,21 @@ test info-15.2 {info procs option} { } {_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} { +test info-15.3 {info procs option} -body { + info procs 2 3 +} -returnCodes error -result {wrong # args: should be "info procs ?pattern?"} +test info-15.4 {info procs option} -setup { catch {namespace delete test_ns_info2} +} -body { 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} { +} -result {{p q r} p} +test info-15.5 {info procs option with a proc in a namespace} -setup { catch {namespace delete test_ns_info2} +} -body { namespace eval test_ns_info2 { proc p1 { arg } { puts cmd @@ -489,9 +506,10 @@ test info-15.5 {info procs option with a proc in a namespace} { } } info procs ::test_ns_info2::p1 -} {::test_ns_info2::p1} -test info-15.6 {info procs option with a pattern in a namespace} { +} -result {::test_ns_info2::p1} +test info-15.6 {info procs option with a pattern in a namespace} -setup { catch {namespace delete test_ns_info2} +} -body { namespace eval test_ns_info2 { proc p1 { arg } { puts cmd @@ -501,9 +519,10 @@ test info-15.6 {info procs option with a pattern in a namespace} { } } 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} { +} -result [lsort [list ::test_ns_info2::p1 ::test_ns_info2::p2]] +test info-15.7 {info procs option with a global shadowing proc} -setup { catch {namespace delete test_ns_info2} +} -body { proc string_cmd { arg } { puts cmd } @@ -513,13 +532,13 @@ test info-15.7 {info procs option with a global shadowing proc} { } } info procs test_ns_info2::string* -} {::test_ns_info2::string_cmd} +} -result {::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} { +test info-15.8 {info procs option with a global shadowing proc} -setup { catch {namespace delete test_ns_info2} +} -constraints knownBug -body { proc string_cmd { arg } { puts cmd } @@ -534,12 +553,11 @@ test info-15.8 {info procs option with a global shadowing proc} { namespace eval test_ns_info2 { lsort [info procs string*] } -} [lsort [list string_cmd string_cmd2]] -} +} -result [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.1 {info script option} -returnCodes error -body { + info script x x +} -result {wrong # args: should be "info script ?filename?"} test info-16.2 {info script option} { file tail [info sc] } "info.test" @@ -574,24 +592,24 @@ test info-16.8 {info script option} { } [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-17.1 {info sharedlibextension option} -returnCodes error -body { + info sharedlibextension foo +} -result {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 + scan [info tclversion] "%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 +test info-18.2 {info tclversion option} -body { + info t 2 +} -returnCodes error -result {wrong # args: should be "info tclversion"} +test info-18.3 {info tclversion option} -body { unset tcl_version - set result [list [catch {info tclversion} msg] $msg] + info tclversion +} -returnCodes error -setup { + set t $tcl_version +} -cleanup { set tcl_version $t - set result -} {1 {can't read "tcl_version": no such variable}} +} -result {can't read "tcl_version": no such variable} test info-19.1 {info vars option} { set a 1 @@ -616,9 +634,9 @@ test info-19.2 {info vars option} { 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.4 {info vars option} -returnCodes error -body { + info vars a b +} -result {wrong # args: should be "info vars ?pattern?"} test info-19.5 {info vars with temporary variables} { proc t1 {} { foreach a {b c} {} @@ -635,11 +653,10 @@ test info-19.6 {info vars: Bug 1072654} -setup { namespace delete x } -result {} +set functions {abs acos asin atan atan2 bool ceil cos cosh double entier exp floor fmod hypot int isqrt log log10 max min pow rand round sin sinh sqrt srand tan tanh wide} # 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} +if {!([catch {expr T1()} msg] && ($msg eq {invalid command name "tcl::mathfunc::T1"}))} { + set functions "T1 T2 T3 $functions" ;# A lazy way of prepending! } test info-20.1 {info functions option} {info functions sin} sin test info-20.2 {info functions option} {lsort [info functions]} $functions @@ -649,42 +666,29 @@ test info-20.3 {info functions option} { 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}} +test info-20.5 {info functions option} -returnCodes error -body { + info functions raise an error +} -result {wrong # args: should be "info functions ?pattern?"} + +test info-21.1 {miscellaneous error conditions} -returnCodes error -body { + info +} -result {wrong # args: should be "info subcommand ?argument ...?"} +test info-21.2 {miscellaneous error conditions} -returnCodes error -body { + info gorp +} -result {unknown or ambiguous subcommand "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} -returnCodes error -body { + info c +} -result {unknown or ambiguous subcommand "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} -returnCodes error -body { + info l +} -result {unknown or ambiguous subcommand "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} -returnCodes error -body { + info s +} -result {unknown or ambiguous subcommand "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 @@ -692,13 +696,12 @@ test info-21.5-280 {miscellaneous error conditions} tip280 { # 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] + set pos [lsearch -exact $frame cmd] incr pos - set cmd [lindex $frame $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 first [string range [lindex [split $cmd \n] 0] 0 end-4] set frame [lreplace $frame $pos $pos $first] } set pos [lsearch -exact $frame file] @@ -709,7 +712,9 @@ proc reduce {frame} { } set frame } - +proc subinterp {} { interp create sub ; interp debug sub -frame 1; + interp eval sub [list proc reduce [info args reduce] [info body reduce]] +} ## 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 @@ -728,114 +733,81 @@ proc etrace {} { ## -test info-22.0.0 {info frame, levels} {tip280 && !singleTestInterp} { +test info-22.0 {info frame, levels} {!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} { +test info-22.1 {info frame, bad level relative} {!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} { +test info-22.2 {info frame, bad level absolute} {!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 { +test info-22.3 {info frame, current, relative} -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 { +} -result {type source line 750 file * cmd {info frame 0} proc ::tcltest::RunTest} +test info-22.4 {info frame, current, relative, nested} -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 { +} -result {type source line 753 file * cmd {info frame 0} proc ::tcltest::RunTest} +test info-22.5 {info frame, current, absolute} -constraints {!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} { +} -result {type source line 756 file * cmd {info frame 7} proc ::tcltest::RunTest} +test info-22.6 {info frame, global, relative} {!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} { +} {type source line 758 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relative\}\ \{!singleTestInter level 0} +test info-22.7 {info frame, global, absolute} {!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} +} {type source line 761 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{!singleTestInter level 0} +test info-22.8 {info frame, basic trace} -constraints {!singleTestInterp} -match glob -body { + join [lrange [etrace] 0 2] \n +} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 765 file info.test cmd etrace proc ::tcltest::RunTest} +* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}} + + + + -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}} -test info-23.0.0 {eval'd info frame} {tip280 && !singleTestInterp} { +## The line 1967 is off by 5 from the true value of 1972. This is a knownBug, see testcase 30.0 +test info-23.0 {eval'd info frame} {!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} { +test info-23.1 {eval'd info frame, semi-dynamic} {!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} { +test info-23.2 {eval'd info frame, dynamic} {!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 { +test info-23.3 {eval'd info frame, literal} -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 { +} -result {type source line 788 file * cmd {info frame 0} proc ::tcltest::RunTest} +test info-23.4 {eval'd info frame, semi-dynamic} { 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 { +test info-23.5 {eval'd info frame, dynamic} { 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 { +test info-23.6 {eval'd info frame, trace} -constraints {!singleTestInterp} -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} +} -result {* {type source line 728 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}} +* {type source line 800 file info.test cmd {eval $script} proc ::tcltest::RunTest}} + + + + + +## The line 1967 is off by 5 from the true value of 1972. This is a knownBug, see testcase 30.0 # ------------------------------------------------------------------------- # Procedures defined in scripts which are arguments to control @@ -846,17 +818,19 @@ test info-23.6 {eval'd info frame, trace} -constraints {tip280} -match glob -bod # causes the connection to the context to be lost. Currently only # procedure bodies are able to remember their context. +# NOTE THAT THESE DO NOT USE THE -setup OPTION TO [test] + # ------------------------------------------------------------------------- namespace eval foo { proc bar {} {info frame 0} } -test info-24.0 {info frame, interaction, namespace eval} tip280 { +test info-24.0 {info frame, interaction, namespace eval} -body { reduce [foo::bar] -} {type source line 852 file info.test cmd {info frame 0} proc ::foo::bar level 0} - -namespace delete foo +} -cleanup { + namespace delete foo +} -result {type source line 826 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -866,11 +840,11 @@ if {$flag} { proc ::foo::bar {} {info frame 0} } -test info-24.1 {info frame, interaction, if} tip280 { +test info-24.1 {info frame, interaction, if} -body { reduce [foo::bar] -} {type source line 866 file info.test cmd {info frame 0} proc ::foo::bar level 0} - -namespace delete foo +} -cleanup { + namespace delete foo +} -result {type source line 840 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -881,11 +855,11 @@ while {$flag} { set flag 0 } -test info-24.2 {info frame, interaction, while} tip280 { +test info-24.2 {info frame, interaction, while} -body { reduce [foo::bar] -} {type source line 880 file info.test cmd {info frame 0} proc ::foo::bar level 0} - -namespace delete foo +} -cleanup { + namespace delete foo +} -result {type source line 854 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -894,11 +868,11 @@ catch { proc ::foo::bar {} {info frame 0} } -test info-24.3 {info frame, interaction, catch} tip280 { +test info-24.3 {info frame, interaction, catch} -body { reduce [foo::bar] -} {type source line 894 file info.test cmd {info frame 0} proc ::foo::bar level 0} - -namespace delete foo +} -cleanup { + namespace delete foo +} -result {type source line 868 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -908,11 +882,11 @@ foreach var val { break } -test info-24.4 {info frame, interaction, foreach} tip280 { +test info-24.4 {info frame, interaction, foreach} -body { reduce [foo::bar] -} {type source line 907 file info.test cmd {info frame 0} proc ::foo::bar level 0} - -namespace delete foo +} -cleanup { + namespace delete foo +} -result {type source line 881 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -922,11 +896,101 @@ for {} {1} {} { break } -test info-24.5 {info frame, interaction, for} tip280 { +test info-24.5 {info frame, interaction, for} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 895 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- + +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} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo + unset x +} -result {type source line 911 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- + +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} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo + unset x +} -result {type source line 927 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- + +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} -body { reduce [foo::bar] -} {type source line 921 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -cleanup { + namespace delete foo + unset x +} -result {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- + +namespace eval foo {} +dict for {k v} {foo bar} { + proc ::foo::bar {} {info frame 0} +} + +test info-24.7 {info frame, interaction, dict for} { + reduce [foo::bar] +} {type source line 956 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo + +# ------------------------------------------------------------------------- + +namespace eval foo {} +set thedict {foo bar} +dict with thedict { + proc ::foo::bar {} {info frame 0} +} + +test info-24.8 {info frame, interaction, dict with} { + reduce [foo::bar] +} {type source line 970 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo +unset thedict + +# ------------------------------------------------------------------------- + +namespace eval foo {} +dict filter {foo bar} script {k v} { + proc ::foo::bar {} {info frame 0} + set x 1 +} + +test info-24.9 {info frame, interaction, dict filter} { + reduce [foo::bar] +} {type source line 984 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo +unset x # ------------------------------------------------------------------------- @@ -934,22 +998,25 @@ eval { proc bar {} {info frame 0} } -test info-25.0 {info frame, proc in eval} tip280 { +test info-25.0 {info frame, proc in eval} { reduce [bar] -} {type source line 934 file info.test cmd {info frame 0} proc ::bar level 0} +} {type source line 998 file info.test cmd {info frame 0} proc ::bar level 0} +# Don't need to clean up yet... proc bar {} {info frame 0} -test info-25.1 {info frame, regular proc} tip280 { + +test info-25.1 {info frame, regular proc} { reduce [bar] -} {type source line 941 file info.test cmd {info frame 0} proc ::bar level 0} -rename bar {} +} {type source line 1006 file info.test cmd {info frame 0} proc ::bar level 0} +rename bar {} +# ------------------------------------------------------------------------- # More info-30.x test cases at the end of the file. -test info-30.0 {bs+nl in literal words} {tip280} { +test info-30.0 {bs+nl in literal words} { if {1} { set res \ - [reduce [info frame 0]];# line 952 + [reduce [info frame 0]];# 1019 } set res # This was reporting line 3 instead of the correct 4 because the @@ -958,9 +1025,7 @@ test info-30.0 {bs+nl in literal words} {tip280} { # offsets of all bs+nl sequences in literal words, then using the # information in the bcc and other places to bump line numbers when # parsing over the location. Also affected: testcases 22.8 and 23.6. -} {type source line 952 file info.test cmd {info frame 0} proc ::tcltest::RunTest} - - +} {type source line 1019 file info.test cmd {info frame 0} proc ::tcltest::RunTest} # ------------------------------------------------------------------------- # See 24.0 - 24.5 for similar situations, using literal scripts. @@ -969,26 +1034,23 @@ 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 {set res {} +test info-31.0 {ns eval, script in variable} {set res {} 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 { +test info-31.1 {if, script in variable} { 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 { +test info-31.1a {if, script in variable} { 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 { +test info-31.2 {while, script in variable} { set flag 1 while {$flag} $body set res @@ -996,106 +1058,250 @@ test info-31.2 {while, script in variable} tip280 { # .3 - proc - scoping prevent return of result ... -test info-31.4 {foreach, script in variable} tip280 { +test info-31.4 {foreach, script in variable} { 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 { +test info-31.5 {for, script in variable} { 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 { +test info-31.6 {eval, script in variable} { eval $body set res } {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest} # ------------------------------------------------------------------------- -namespace eval foo {} -set x foo -switch -exact -- $x { +set body { foo { proc ::foo::bar {} {info frame 0} } } -test info-24.6.0 {info frame, interaction, switch, list body} tip280 { +namespace eval foo {} +set x foo +switch -exact -- $x $body + +test info-31.7 {info frame, interaction, switch, dynamic} -body { reduce [foo::bar] -} {type source line 1021 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -cleanup { + namespace delete foo + unset x +} -result {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} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- + +namespace {*}{ + eval + foo + {proc bar {} {info frame 0}} +} +test info-33.0 {{*}, literal, direct} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 1116 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- namespace eval foo {} -set x foo -switch -exact -- $x foo { - proc ::foo::bar {} {info frame 0} +proc foo::bar {} { + set flag 1 + if {*}{ + {$flag} + {info frame 0} + } } +test info-33.1 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 1131 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- -test info-24.6.1 {info frame, interaction, switch, multi-body} tip280 { +namespace {*}" + eval + foo + {proc bar {} {info frame 0}} +" +test info-33.2 {{*}, literal, direct} { reduce [foo::bar] -} {type source line 1037 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 1145 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} -}] +namespace {*}"eval\nfoo\n{proc bar {} {info frame 0}}\n" -test info-24.6.2 {info frame, interaction, switch, list body, dynamic} tip280 { +test info-33.2a {{*}, literal, not simple, direct} { 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 {} +proc foo::bar {} { + set flag 1 + if {*}" + {1} + {info frame 0} + " } +test info-33.3 {{*}, literal, simple, bytecompiled} { + reduce [foo::bar] +} {type source line 1170 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo + +# ------------------------------------------------------------------------- namespace eval foo {} -set x foo -switch -exact -- $x $body +proc foo::bar {} { + set flag 1 + if {*}"\n{1}\n{info frame 0}" +} +test info-33.3a {{*}, literal, not simple, bytecompiled} { + reduce [foo::bar] +} {type eval line 1 cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo -test info-31.7 {info frame, interaction, switch, dynamic} tip280 { +# ------------------------------------------------------------------------- + +set body { + eval + foo + {proc bar {} { + info frame 0 + }} +} +namespace {*}$body +test info-34.0 {{*}, dynamic, direct} { reduce [foo::bar] -} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0} +} {type proc line 2 cmd {info frame 0} proc ::foo::bar level 0} +unset body namespace delete foo -unset x # ------------------------------------------------------------------------- +namespace eval foo {} set body { - proc ::foo::bar {} {info frame 0} + {$flag} + {info frame 0} +} +proc foo::bar {} { + global body ; set flag 1 + if {*}$body } +test info-34.1 {{*}, literal, bytecompiled} { + reduce [foo::bar] +} {type eval line 1 cmd {info frame 0} proc ::foo::bar level 0} + +unset body +namespace delete foo + +# ------------------------------------------------------------------------- + +proc foo {} { + apply { + {x y} + {info frame 0} + } 0 0 +} +test info-35.0 {apply, literal} { + reduce [foo] +} {type source line 1232 file info.test cmd {info frame 0} lambda { + {x y} + {info frame 0} + } level 0} +rename foo {} + +set lambda { + {x y} + {info frame 0} +} +test info-35.1 {apply, dynamic} { + reduce [apply $lambda 0 0] +} {type proc line 1 cmd {info frame 0} lambda { + {x y} + {info frame 0} +} level 0} +unset lambda + +# ------------------------------------------------------------------------- namespace eval foo {} -eval $body +proc foo::bar {} { + dict for {k v} {foo bar} { + set x [info frame 0] + } + set x +} +test info-36.0 {info frame, dict for, bcc} { + reduce [foo::bar] +} {type source line 1260 file info.test cmd {info frame 0} proc ::foo::bar level 0} -test info-32.0 {info frame, dynamic procedure} tip280 { +namespace delete foo + +# ------------------------------------------------------------------------- + +namespace eval foo {} +proc foo::bar {} { + set x foo + switch -exact -- $x { + foo {set y [info frame 0]} + } + set y +} + +test info-36.1.0 {switch, list literal, bcc} { reduce [foo::bar] -} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 1276 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo + +# ------------------------------------------------------------------------- + +namespace eval foo {} +proc foo::bar {} { + set x foo + switch -exact -- $x foo {set y [info frame 0]} + set y +} + +test info-36.1.1 {switch, multi-body literals, bcc} { + reduce [foo::bar] +} {type source line 1292 file info.test 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 { +test info-37.0 {eval pure list, single line} -constraints {!singleTestInterp} -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. @@ -1113,7 +1319,7 @@ test info-34.0 {eval pure list, single line} -constraints {tip280} -match glob - }] eval $cmd set res -} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 728 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}} @@ -1148,66 +1354,66 @@ proc datav {} { control y $script } -test info-38.1 {location information for uplevel, dv, direct-var} -constraints tip280 -match glob -body { +test info-38.1 {location information for uplevel, dv, direct-var} -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} +} -result {* {type source line 728 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}} +* {type source line 1362 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} + +# 38.2 moved to bottom to not disturb other tests with the necessary changes to this one. -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 { + + + + + + +test info-38.3 {location information for uplevel, dpv, direct-proc-var} -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} +} -result {* {type source line 728 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}} +* {type source line 1339 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1381 file info.test cmd {control y $script} proc ::tcltest::RunTest}} + +# 38.4 moved to bottom to not disturb other tests with the necessary changes to this one. + + -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 { + + + + + +test info-38.5 {location information for uplevel, ppv, proc-proc-var} -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} +} -result {* {type source line 728 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}} +* {type source line 1339 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1354 file info.test cmd {control y $script} proc ::datav level 1} +* {type source line 1398 file info.test cmd datav proc ::tcltest::RunTest}} + +# 38.6 moved to bottom to not disturb other tests with the necessary changes to this one. + + + + + + # ------------------------------------------------------------------------- # literal sharing -test info-39.0 {location information not confused by literal sharing} -constraints tip280 -body { +test info-39.0 {location information not confused by literal sharing} -body { namespace eval ::foo {} proc ::foo::bar {} { lappend res {} @@ -1219,146 +1425,146 @@ test info-39.0 {location information not confused by literal sharing} -constrain 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} +type source line 1420 file info.test cmd {info frame 0} proc ::foo::bar level 0 +type source line 1421 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- # Additional tests for info-30.*, handling of continuation lines (bs+nl sequences). -test info-30.1 {bs+nl in literal words, procedure body, compiled} {tip280} { +test info-30.1 {bs+nl in literal words, procedure body, compiled} { proc abra {} { if {1} \ { return \ - [reduce [info frame 0]];# line 1233 + [reduce [info frame 0]];# line 1439 } } set res [abra] rename abra {} set res -} {type source line 1233 file info.test cmd {info frame 0} proc ::abra level 0} +} {type source line 1439 file info.test cmd {info frame 0} proc ::abra level 0} -test info-30.2 {bs+nl in literal words, namespace script} {tip280} { +test info-30.2 {bs+nl in literal words, namespace script} { namespace eval xxx { set res \ - [reduce [info frame 0]];# line 1244 + [reduce [info frame 0]];# line 1450 } set res -} {type source line 1244 file info.test cmd {info frame 0} level 0} +} {type source line 1450 file info.test cmd {info frame 0} level 0} -test info-30.3 {bs+nl in literal words, namespace multi-word script} {tip280} { +test info-30.3 {bs+nl in literal words, namespace multi-word script} { namespace eval xxx set res \ - [list [reduce [info frame 0]]];# line 1251 + [list [reduce [info frame 0]]];# line 1457 set res -} {type source line 1251 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} {type source line 1457 file info.test cmd {info frame 0} proc ::tcltest::RunTest} -test info-30.4 {bs+nl in literal words, eval script} {tip280} { +test info-30.4 {bs+nl in literal words, eval script} { eval { set ::res \ - [reduce [info frame 0]];# line 1258 + [reduce [info frame 0]];# line 1464 } set res -} {type source line 1258 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} {type source line 1464 file info.test cmd {info frame 0} proc ::tcltest::RunTest} -test info-30.5 {bs+nl in literal words, eval script, with nested words} {tip280} { +test info-30.5 {bs+nl in literal words, eval script, with nested words} { eval { if {1} \ { set ::res \ - [reduce [info frame 0]];# line 1268 + [reduce [info frame 0]];# line 1474 } } set res -} {type source line 1268 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} {type source line 1474 file info.test cmd {info frame 0} proc ::tcltest::RunTest} -test info-30.6 {bs+nl in computed word} {tip280} { +test info-30.6 {bs+nl in computed word} { set res "\ -[reduce [info frame 0]]";# line 1276 -} { type source line 1276 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +[reduce [info frame 0]]";# line 1482 +} { type source line 1482 file info.test cmd {info frame 0} proc ::tcltest::RunTest} -test info-30.7 {bs+nl in computed word, in proc} {tip280} { +test info-30.7 {bs+nl in computed word, in proc} { proc abra {} { return "\ -[reduce [info frame 0]]";# line 1282 +[reduce [info frame 0]]";# line 1488 } set res [abra] rename abra {} set res -} { type source line 1282 file info.test cmd {info frame 0} proc ::abra level 0} +} { type source line 1488 file info.test cmd {info frame 0} proc ::abra level 0} -test info-30.8 {bs+nl in computed word, nested eval} {tip280} { +test info-30.8 {bs+nl in computed word, nested eval} { eval { set \ res "\ -[reduce [info frame 0]]";# line 1293 +[reduce [info frame 0]]";# line 1499 } -} { type source line 1293 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} { type source line 1499 file info.test cmd {info frame 0} proc ::tcltest::RunTest} -test info-30.9 {bs+nl in computed word, nested eval} {tip280} { +test info-30.9 {bs+nl in computed word, nested eval} { eval { set \ res "\ [reduce \ - [info frame 0]]";# line 1302 + [info frame 0]]";# line 1508 } -} { type source line 1302 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} { type source line 1508 file info.test cmd {info frame 0} proc ::tcltest::RunTest} -test info-30.10 {bs+nl in computed word, key to array} {tip280} { +test info-30.10 {bs+nl in computed word, key to array} { set tmp([set \ res "\ [reduce \ - [info frame 0]]"]) x ; #1310 + [info frame 0]]"]) x ; #1516 unset tmp set res -} { type source line 1310 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} { type source line 1516 file info.test cmd {info frame 0} proc ::tcltest::RunTest} -test info-30.11 {bs+nl in subst arguments, no true counting} {tip280} { +test info-30.11 {bs+nl in subst arguments, no true counting} { subst {[set \ res "\ [reduce \ [info frame 0]]"]} -} { type eval line 2 cmd {info frame 0} proc ::tcltest::RunTest} +} { type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest} -test info-30.12 {bs+nl in computed word, nested eval} {tip280} { +test info-30.12 {bs+nl in computed word, nested eval} { eval { set \ res "\ [set x {}] \ [reduce \ - [info frame 0]]";# line 1328 + [info frame 0]]";# line 1534 } -} { type source line 1328 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} { type source line 1534 file info.test cmd {info frame 0} proc ::tcltest::RunTest} -test info-30.13 {bs+nl in literal words, uplevel script, with nested words} {tip280} { - uplevel #0 { +test info-30.13 {bs+nl in literal words, uplevel script, with nested words} { + subinterp ; set res [interp eval sub { uplevel #0 { if {1} \ { set ::res \ - [reduce [info frame 0]];# line 1337 + [reduce [info frame 0]];# line 1543 } } - set res -} {type source line 1337 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + set res }] ; interp delete sub ; set res +} {type source line 1543 file info.test cmd {info frame 0} level 0} -test info-30.14 {bs+nl, literal word, uplevel through proc} {tip280} { - proc abra {script} { +test info-30.14 {bs+nl, literal word, uplevel through proc} { + subinterp ; set res [interp eval sub { proc abra {script} { uplevel 1 $script } set res [abra { return "\ -[reduce [info frame 0]]";# line 1349 + [reduce [info frame 0]]";# line 1555 }] rename abra {} - set res -} { type source line 1349 file info.test cmd {info frame 0} proc ::abra} + set res }] ; interp delete sub ; set res +} { type source line 1555 file info.test cmd {info frame 0} proc ::abra} -test info-30.15 {bs+nl in literal words, nested proc body, compiled} {tip280} { +test info-30.15 {bs+nl in literal words, nested proc body, compiled} { proc a {} { proc b {} { if {1} \ { return \ - [reduce [info frame 0]];# line 1361 + [reduce [info frame 0]];# line 1567 } } } @@ -1366,45 +1572,45 @@ test info-30.15 {bs+nl in literal words, nested proc body, compiled} {tip280} { rename a {} rename b {} set res -} {type source line 1361 file info.test cmd {info frame 0} proc ::b level 0} +} {type source line 1567 file info.test cmd {info frame 0} proc ::b level 0} -test info-30.16 {bs+nl in multi-body switch, compiled} {tip280} { +test info-30.16 {bs+nl in multi-body switch, compiled} { proc a {value} { switch -regexp -- $value \ - ^key { info frame 0; # 1374 } \ - \t { info frame 0; # 1375 } \ - {[0-9]*} { info frame 0; # 1376 } + ^key { info frame 0; # 1580 } \ + \t### { info frame 0; # 1581 } \ + {[0-9]*} { info frame 0; # 1582 } } set res {} lappend res [reduce [a {key }]] lappend res [reduce [a {1alpha}]] set res "\n[join $res \n]" } { -type source line 1374 file info.test cmd {info frame 0} proc ::a level 0 -type source line 1376 file info.test cmd {info frame 0} proc ::a level 0} +type source line 1580 file info.test cmd {info frame 0} proc ::a level 0 +type source line 1582 file info.test cmd {info frame 0} proc ::a level 0} -test info-30.17 {bs+nl in multi-body switch, direct} {tip280} { +test info-30.17 {bs+nl in multi-body switch, direct} { switch -regexp -- {key } \ - ^key { reduce [info frame 0] ;# 1388 } \ + ^key { reduce [info frame 0] ;# 1594 } \ \t### { } \ {[0-9]*} { } -} {type source line 1388 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} {type source line 1594 file info.test cmd {info frame 0} proc ::tcltest::RunTest} -test info-30.18 {bs+nl, literal word, uplevel through proc, appended, loss of primary tracking data} {tip280} { +test info-30.18 {bs+nl, literal word, uplevel through proc, appended, loss of primary tracking data} { proc abra {script} { append script "\n# end of script" uplevel 1 $script } set res [abra { return "\ -[reduce [info frame 0]]";# line 1400, still line of 3 appended script +[reduce [info frame 0]]";# line 1606, still line of 3 appended script }] rename abra {} set res } { type eval line 3 cmd {info frame 0} proc ::abra} -# { type source line 1400 file info.test cmd {info frame 0} proc ::abra} +# { type source line 1606 file info.test cmd {info frame 0} proc ::abra} -test info-30.19 {bs+nl in single-body switch, compiled} {tip280} { +test info-30.19 {bs+nl in single-body switch, compiled} { proc a {value} { switch -regexp -- $value { ^key { reduce \ @@ -1420,20 +1626,20 @@ test info-30.19 {bs+nl in single-body switch, compiled} {tip280} { lappend res [a {1alpha}] set res "\n[join $res \n]" } { -type source line 1411 file info.test cmd {info frame 0} proc ::a level 0 -type source line 1415 file info.test cmd {info frame 0} proc ::a level 0} +type source line 1617 file info.test cmd {info frame 0} proc ::a level 0 +type source line 1621 file info.test cmd {info frame 0} proc ::a level 0} -test info-30.20 {bs+nl in single-body switch, direct} {tip280} { +test info-30.20 {bs+nl in single-body switch, direct} { switch -regexp -- {key } { \ ^key { reduce \ [info frame 0] } - \t { } + \t### { } {[0-9]*} { } } -} {type source line 1430 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} {type source line 1636 file info.test cmd {info frame 0} proc ::tcltest::RunTest} -test info-30.21 {bs+nl in if, full compiled} {tip280} { +test info-30.21 {bs+nl in if, full compiled} { proc a {value} { if {$value} \ {info frame 0} \ @@ -1444,24 +1650,173 @@ test info-30.21 {bs+nl in if, full compiled} {tip280} { lappend res [reduce [a 0]] set res "\n[join $res \n]" } { -type source line 1439 file info.test cmd {info frame 0} proc ::a level 0 -type source line 1440 file info.test cmd {info frame 0} proc ::a level 0} +type source line 1645 file info.test cmd {info frame 0} proc ::a level 0 +type source line 1646 file info.test cmd {info frame 0} proc ::a level 0} -test info-30.22 {bs+nl in computed word, key to array, compiled} {tip280} { +test info-30.22 {bs+nl in computed word, key to array, compiled} { proc a {} { set tmp([set \ res "\ [reduce \ - [info frame 0]]"]) x ; #1454 + [info frame 0]]"]) x ; #1661 unset tmp set res } set res [a] rename a {} set res -} { type source line 1455 file info.test cmd {info frame 0} proc ::a level 0} +} { type source line 1661 file info.test cmd {info frame 0} proc ::a level 0} + +test info-30.23 {bs+nl in multi-body switch, full compiled} { + proc a {value} { + switch -exact -- $value \ + key { info frame 0; # 1673 } \ + xxx { info frame 0; # 1674 } \ + 000 { info frame 0; # 1675 } + } + set res {} + lappend res [reduce [a key]] + lappend res [reduce [a 000]] + set res "\n[join $res \n]" +} { +type source line 1673 file info.test cmd {info frame 0} proc ::a level 0 +type source line 1675 file info.test cmd {info frame 0} proc ::a level 0} + +test info-30.24 {bs+nl in single-body switch, full compiled} { + proc a {value} { + switch -exact -- $value { + key { reduce \ + [info frame 0] } + xxx { reduce \ + [info frame 0] } + 000 { reduce \ + [info frame 0] } + } + } + set res {} + lappend res [a key] + lappend res [a 000] + set res "\n[join $res \n]" +} { +type source line 1689 file info.test cmd {info frame 0} proc ::a level 0 +type source line 1693 file info.test cmd {info frame 0} proc ::a level 0} # ------------------------------------------------------------------------- +# literal sharing 2, bug 2933089 + +test info-39.1 {location information not confused by literal sharing, bug 2933089} -setup { + set result {} + + proc print_one {} {} + proc test_info_frame {} { + set x 1 + set y x + + if "$x != 1" { + } else { + print_one + } ;#line 1717^ + + if "$$y != 1" { + } else { + print_one + } ;#line 1722^ + # Do not put the comments listing the line numbers into the + # branches. We need shared literals, and the comments would + # make them different, thus unshared. + } + + proc get_frame_info { cmd_str op } { + lappend ::result [reduce [eval {info frame -3}]] + } + trace add execution print_one enter get_frame_info +} -body { + test_info_frame; + join $result \n +} -cleanup { + trace remove execution print_one enter get_frame_info + rename get_frame_info {} + rename test_info_frame {} + rename print_one {} +} -result {type source line 1717 file info.test cmd print_one proc ::test_info_frame level 1 +type source line 1722 file info.test cmd print_one proc ::test_info_frame level 1} + +# ------------------------------------------------------------------------- +# Tests moved to the end to not disturb other tests and their locations. + +test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -match glob -setup {subinterp} -body { + interp eval sub { + proc etrace {} { + set res {} + set level [info frame] + while {$level} { + lappend res [list $level [reduce [info frame $level]]] + incr level -1 + } + return $res + } + proc control {vv script} { + upvar 1 $vv var + return [uplevel 1 $script] + } + proc datal {} { + control y { + set y PPL + etrace + } + } + join [lrange [datal] 0 4] \n + } +} -result {* {type source line 1753 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 1765 file info.test cmd etrace proc ::control} +* {type source line 1760 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1763 file info.test cmd control proc ::datal level 1} +* {type source line 1768 file info.test cmd datal level 2}} -cleanup {interp delete sub} + +test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -match glob -setup {subinterp} -body { + interp eval sub { + proc etrace {} { + set res {} + set level [info frame] + while {$level} { + lappend res [list $level [reduce [info frame $level]]] + incr level -1 + } + return $res + } + proc control {vv script} { + upvar 1 $vv var + return [uplevel 1 $script] + } + join [lrange [control y { + set y DPL + etrace + }] 0 3] \n + } +} -result {* {type source line 1782 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 1793 file info.test cmd etrace proc ::control} +* {type source line 1789 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1791 file info.test cmd control level 1}} -cleanup {interp delete sub} + +test info-38.2 {location information for uplevel, dl, direct-literal} -match glob -setup {subinterp} -body { + interp eval sub { + proc etrace {} { + set res {} + set level [info frame] + while {$level} { + lappend res [list $level [reduce [info frame $level]]] + incr level -1 + } + return $res + } + join [lrange [uplevel \#0 { + set y DL. + etrace + }] 0 2] \n + } +} -result {* {type source line 1807 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 1814 file info.test cmd etrace level 1} +* {type source line 1812 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub} # cleanup catch {namespace delete test_ns_info1 test_ns_info2} |