diff -r 000000000000 -r bde4ae8d615e os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/info.test --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/info.test Fri Jun 15 03:10:57 2012 +0200 @@ -0,0 +1,1081 @@ +# -*- 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.5 2006/11/28 22:20:02 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 [string range [lindex [split $cmd \n] 0] 0 end-11] + 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 {info frame, levels} tip280 { + info frame +} 7 + +test info-22.1 {info frame, bad level relative} tip280 { + # catch is another level!, i.e. we have 8, not 7 + catch {info frame -8} msg + set msg +} {bad level "-8"} + +test info-22.2 {info frame, bad level absolute} tip280 { + # catch is another level!, i.e. we have 8, not 7 + catch {info frame 9} msg + set msg +} {bad level "9"} + +test info-22.3 {info frame, current, relative} tip280 { + info frame 0 +} {type eval line 2 cmd {info frame 0}} + +test info-22.4 {info frame, current, relative, nested} tip280 { + set res [info frame 0] +} {type eval line 2 cmd {info frame 0}} + +test info-22.5 {info frame, current, absolute} tip280 { + reduce [info frame 7] +} {type eval line 2 cmd {info frame 7}} + +test info-22.6 {info frame, global, relative} tip280 { + reduce [info frame -6] +} {type source line 759 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relativ} + +test info-22.7 {info frame, global, absolute} tip280 { + reduce [info frame 1] +} {type source line 763 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolut} + +test info-22.8 {info frame, basic trace} tip280 { + join [etrace] \n +} {8 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} +7 {type eval line 2 cmd etrace} +6 {type source line 2277 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest} +5 {type eval line 1 cmd {::tcltest::RunTest }} +4 {type source line 1619 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::Eval} +3 {type eval line 1 cmd ::tcltest::Eval\ \{::tcltest::RunTest\ } +2 {type source line 1966 file tcltest.tcl cmd {uplevel 1 [list [namespace origin Eval] $command 1]} proc ::tcltest::test} +1 {type source line 767 file info.test cmd test\ info-22.8\ \{info\ frame,\ basic\ trac}} +## 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 {eval'd info frame} tip280 { + eval {info frame} +} 8 + +test info-23.1 {eval'd info frame, semi-dynamic} tip280 { + eval info frame +} 8 + +test info-23.2 {eval'd info frame, dynamic} tip280 { + set script {info frame} + eval $script +} 8 + +test info-23.3 {eval'd info frame, literal} tip280 { + eval { + info frame 0 + } +} {type eval line 2 cmd {info frame 0}} + +test info-23.4 {eval'd info frame, semi-dynamic} tip280 { + eval info frame 0 +} {type eval line 1 cmd {info frame 0}} + +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}} + +test info-23.6 {eval'd info frame, trace} tip280 { + set script {etrace} + join [eval $script] \n +} {9 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} +8 {type eval line 1 cmd etrace} +7 {type eval line 3 cmd {eval $script}} +6 {type source line 2277 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest} +5 {type eval line 1 cmd {::tcltest::RunTest }} +4 {type source line 1619 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::Eval} +3 {type eval line 1 cmd ::tcltest::Eval\ \{::tcltest::RunTest\ } +2 {type source line 1966 file tcltest.tcl cmd {uplevel 1 [list [namespace origin Eval] $command 1]} proc ::tcltest::test} +1 {type source line 806 file info.test cmd test\ info-23.6\ \{eval'd\ info\ frame,\ trac}} +## 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 832 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 846 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 860 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 874 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 887 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 901 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 914 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 921 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}} + +# ------------------------------------------------------------------------- + +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 1001 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 1017 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 + +# ------------------------------------------------------------------------- + +# cleanup +catch {namespace delete test_ns_info1 test_ns_info2} +::tcltest::cleanupTests +return