path: root/tests/info.test

# -*- 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.11 2008/07/28 20:01:12 andreas_kupries Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Set up namespaces needed to test operation of "info args", "info body",
# "info default", and "info procs" with imported procedures.

catch {namespace delete test_ns_info1 test_ns_info2}

namespace eval test_ns_info1 {
    namespace export *
    proc p {x} {return "x=$x"}
    proc q {{y 27} {z {}}} {return "y=$y"}
}

testConstraint tip280  [info exists tcl_platform(tip,280)]
testConstraint !tip280 [expr {![info exists tcl_platform(tip,280)]}]


test info-1.1 {info args option} {
    proc t1 {a bbb c} {return foo}
    info args t1
} {a bbb c}
test info-1.2 {info args option} {
    proc t1 {{a default1} {bbb default2} {c default3} args} {return foo}
    info a t1
} {a bbb c args}
test info-1.3 {info args option} {
    proc t1 "" {return foo}
    info args t1
} {}
test info-1.4 {info args option} {
    catch {rename t1 {}}
    list [catch {info args t1} msg] $msg
} {1 {"t1" isn't a procedure}}
test info-1.5 {info args option} {
    list [catch {info args set} msg] $msg
} {1 {"set" isn't a procedure}}
test info-1.6 {info args option} {
    proc t1 {a b} {set c 123; set d $c}
    t1 1 2
    info args t1
} {a b}
test info-1.7 {info args option} {
    catch {namespace delete test_ns_info2}
    namespace eval test_ns_info2 {
        namespace import ::test_ns_info1::*
        list [info args p] [info args q]
    }
} {x {y z}}

test info-2.1 {info body option} {
    proc t1 {} {body of t1}
    info body t1
} {body of t1}
test info-2.2 {info body option} {
    list [catch {info body set} msg] $msg
} {1 {"set" isn't a procedure}}
test info-2.3 {info body option} {
    list [catch {info args set 1} msg] $msg
} {1 {wrong # args: should be "info args procname"}}
test info-2.4 {info body option} {
    catch {namespace delete test_ns_info2}
    namespace eval test_ns_info2 {
        namespace import ::test_ns_info1::*
        list [info body p] [info body q]
    }
} {{return "x=$x"} {return "y=$y"}}
# Prior to 8.3.0 this would cause a crash because [info body]
# would return the bytecompiled version of foo, which the catch
# would then try and eval out of the foo context, accessing
# compiled local indices
test info-2.5 {info body option, returning bytecompiled bodies} {
    catch {unset args}
    proc foo {args} {
	foreach v $args {
	    upvar $v var
	    return "variable $v existence: [info exists var]"
	}
    }
    foo a
    list [catch [info body foo] msg] $msg
} {1 {can't read "args": no such variable}}
# Fix for problem tested for in info-2.5 caused problems when
# procedure body had no string rep (i.e. was not yet bytecode)
# causing an empty string to be returned [Bug #545644]
test info-2.6 {info body option, returning list bodies} {
    proc foo args [list subst bar]
    list [string bytelength [info body foo]] \
	    [foo; string bytelength [info body foo]]
} {9 9}

# "info cmdcount" is no longer accurate for compiled commands!
# The expected result for info-3.1 used to be "3" and is now "1"
# since the "set"s have been compiled away.  info-3.2 was corrected
# in 8.3 because the eval'ed body won't be compiled.
proc testinfocmdcount {} {
    set x [info cmdcount]
    set y 12345
    set z [info cm]
    expr $z-$x
}
test info-3.1 {info cmdcount compiled} {
    testinfocmdcount
} 1
test info-3.2 {info cmdcount evaled} {
    set x [info cmdcount]
    set y 12345
    set z [info cm]
    expr $z-$x
} 3
test info-3.3 {info cmdcount evaled} [info body testinfocmdcount] 3
test info-3.4 {info cmdcount option} {
    list [catch {info cmdcount 1} msg] $msg
} {1 {wrong # args: should be "info cmdcount"}}

test info-4.1 {info commands option} {
    proc t1 {} {}
    proc t2 {} {}
    set x " [info commands] "
    list [string match {* t1 *} $x] [string match {* t2 *} $x] \
            [string match {* set *} $x] [string match {* list *} $x]
} {1 1 1 1}
test info-4.2 {info commands option} {
    proc t1 {} {}
    rename t1 {}
    set x [info comm]
    string match {* t1 *} $x
} 0
test info-4.3 {info commands option} {
    proc _t1_ {} {}
    proc _t2_ {} {}
    info commands _t1_
} _t1_
test info-4.4 {info commands option} {
    proc _t1_ {} {}
    proc _t2_ {} {}
    lsort [info commands _t*]
} {_t1_ _t2_}
catch {rename _t1_ {}}
catch {rename _t2_ {}}
test info-4.5 {info commands option} {
    list [catch {info commands a b} msg] $msg
} {1 {wrong # args: should be "info commands ?pattern?"}}

test info-5.1 {info complete option} {
    list [catch {info complete} msg] $msg
} {1 {wrong # args: should be "info complete command"}}
test info-5.2 {info complete option} {
    info complete abc
} 1
test info-5.3 {info complete option} {
    info complete "\{abcd "
} 0
test info-5.4 {info complete option} {
    info complete {# Comment should be complete command}
} 1
test info-5.5 {info complete option} {
    info complete {[a [b] }
} 0
test info-5.6 {info complete option} {
    info complete {[a [b]}
} 0

test info-6.1 {info default option} {
    proc t1 {a b {c d} {e "long default value"}} {}
    info default t1 a value
} 0
test info-6.2 {info default option} {
    proc t1 {a b {c d} {e "long default value"}} {}
    set value 12345
    info d t1 a value
    set value
} {}
test info-6.3 {info default option} {
    proc t1 {a b {c d} {e "long default value"}} {}
    info default t1 c value
} 1
test info-6.4 {info default option} {
    proc t1 {a b {c d} {e "long default value"}} {}
    set value 12345
    info default t1 c value
    set value
} d
test info-6.5 {info default option} {
    proc t1 {a b {c d} {e "long default value"}} {}
    set value 12345
    set x [info default t1 e value]
    list $x $value
} {1 {long default value}}
test info-6.6 {info default option} {
    list [catch {info default a b} msg] $msg
} {1 {wrong # args: should be "info default procname arg varname"}}
test info-6.7 {info default option} {
    list [catch {info default _nonexistent_ a b} msg] $msg
} {1 {"_nonexistent_" isn't a procedure}}
test info-6.8 {info default option} {
    proc t1 {a b} {}
    list [catch {info default t1 x value} msg] $msg
} {1 {procedure "t1" doesn't have an argument "x"}}
test info-6.9 {info default option} {
    catch {unset a}
    set a(0) 88
    proc t1 {a b} {}
    list [catch {info default t1 a a} msg] $msg
} {1 {couldn't store default value in variable "a"}}
test info-6.10 {info default option} {
    catch {unset a}
    set a(0) 88
    proc t1 {{a 18} b} {}
    list [catch {info default t1 a a} msg] $msg
} {1 {couldn't store default value in variable "a"}}
test info-6.11 {info default option} {
    catch {namespace delete test_ns_info2}
    namespace eval test_ns_info2 {
        namespace import ::test_ns_info1::*
        list [info default p x foo] $foo [info default q y bar] $bar
    }
} {0 {} 1 27}
catch {unset a}

test info-7.1 {info exists option} {
    set value foo
    info exists value
} 1
catch {unset _nonexistent_}
test info-7.2 {info exists option} {
    info exists _nonexistent_
} 0
test info-7.3 {info exists option} {
    proc t1 {x} {return [info exists x]}
    t1 2
} 1
test info-7.4 {info exists option} {
    proc t1 {x} {
        global _nonexistent_
        return [info exists _nonexistent_]
    }
    t1 2
} 0
test info-7.5 {info exists option} {
    proc t1 {x} {
        set y 47
        return [info exists y]
    }
    t1 2
} 1
test info-7.6 {info exists option} {
    proc t1 {x} {return [info exists value]}
    t1 2
} 0
test info-7.7 {info exists option} {
    catch {unset x}
    set x(2) 44
    list [info exists x] [info exists x(1)] [info exists x(2)]
} {1 0 1}
catch {unset x}
test info-7.8 {info exists option} {
    list [catch {info exists} msg] $msg
} {1 {wrong # args: should be "info exists varName"}}
test info-7.9 {info exists option} {
    list [catch {info exists 1 2} msg] $msg
} {1 {wrong # args: should be "info exists varName"}}

test info-8.1 {info globals option} {
    set x 1
    set y 2
    set value 23
    set a " [info globals] "
    list [string match {* x *} $a] [string match {* y *} $a] \
            [string match {* value *} $a] [string match {* _foobar_ *} $a]
} {1 1 1 0}
test info-8.2 {info globals option} {
    set _xxx1 1
    set _xxx2 2
    lsort [info g _xxx*]
} {_xxx1 _xxx2}
test info-8.3 {info globals option} {
    list [catch {info globals 1 2} msg] $msg
} {1 {wrong # args: should be "info globals ?pattern?"}}
test info-8.4 {info globals option: may have leading namespace qualifiers} {
    set x 0
    list [info globals x] [info globals :x] [info globals ::x] [info globals :::x] [info globals ::::x]
} {x {} x x x}
test info-8.5 {info globals option: only return existing global variables} {
    -setup {
	catch {unset ::NO_SUCH_VAR}
	proc evalInProc script {eval $script}
    }
    -body {
	evalInProc {global NO_SUCH_VAR; info globals NO_SUCH_VAR}
    }
    -cleanup {
	rename evalInProc {}
    }
    -result {}
}

test info-9.1 {info level option} {
    info level
} 0
test info-9.2 {info level option} {
    proc t1 {a b} {
        set x [info le]
        set y [info level 1]
        list $x $y
    }
    t1 146 testString
} {1 {t1 146 testString}}
test info-9.3 {info level option} {
    proc t1 {a b} {
        t2 [expr $a*2] $b
    }
    proc t2 {x y} {
        list [info level] [info level 1] [info level 2] [info level -1] \
                [info level 0]
    }
    t1 146 {a {b c} {{{c}}}}
} {2 {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}} {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}}}
test info-9.4 {info level option} {
    proc t1 {} {
        set x [info level]
        set y [info level 1]
        list $x $y
    }
    t1
} {1 t1}
test info-9.5 {info level option} {
    list [catch {info level 1 2} msg] $msg
} {1 {wrong # args: should be "info level ?number?"}}
test info-9.6 {info level option} {
    list [catch {info level 123a} msg] $msg
} {1 {expected integer but got "123a"}}
test info-9.7 {info level option} {
    list [catch {info level 0} msg] $msg
} {1 {bad level "0"}}
test info-9.8 {info level option} {
    proc t1 {} {info level -1}
    list [catch {t1} msg] $msg
} {1 {bad level "-1"}}
test info-9.9 {info level option} {
    proc t1 {x} {info level $x}
    list [catch {t1 -3} msg] $msg
} {1 {bad level "-3"}}
test info-9.10 {info level option, namespaces} {
    set msg [namespace eval t {info level 0}]
    namespace delete t
    set msg
} {namespace eval t {info level 0}}

set savedLibrary $tcl_library
test info-10.1 {info library option} {
    list [catch {info library x} msg] $msg
} {1 {wrong # args: should be "info library"}}
test info-10.2 {info library option} {
    set tcl_library 12345
    info library
} {12345}
test info-10.3 {info library option} {
    unset tcl_library
    list [catch {info library} msg] $msg
} {1 {no library has been specified for Tcl}}
set tcl_library $savedLibrary

test info-11.1 {info loaded option} {
    list [catch {info loaded a b} msg] $msg
} {1 {wrong # args: should be "info loaded ?interp?"}}
test info-11.2 {info loaded option} {
    list [catch {info loaded {}}] [catch {info loaded gorp} msg] $msg
} {0 1 {could not find interpreter "gorp"}}

test info-12.1 {info locals option} {
    set a 22
    proc t1 {x y} {
        set b 13
        set c testing
        global a
	global aa
	set aa 23
        return [info locals]
    }
    lsort [t1 23 24]
} {b c x y}
test info-12.2 {info locals option} {
    proc t1 {x y} {
        set xx1 2
        set xx2 3
        set y 4
        return [info loc x*]
    }
    lsort [t1 2 3]
} {x xx1 xx2}
test info-12.3 {info locals option} {
    list [catch {info locals 1 2} msg] $msg
} {1 {wrong # args: should be "info locals ?pattern?"}}
test info-12.4 {info locals option} {
    info locals
} {}
test info-12.5 {info locals option} {
    proc t1 {} {return [info locals]}
    t1
} {}
test info-12.6 {info locals vs unset compiled locals} {
    proc t1 {lst} {
        foreach $lst $lst {}
        unset lst
        return [info locals]
    }
    lsort [t1 {a b c c d e f}]
} {a b c d e f}
test info-12.7 {info locals with temporary variables} {
    proc t1 {} {
        foreach a {b c} {}
        info locals
    }
    t1
} {a}

test info-13.1 {info nameofexecutable option} {
    list [catch {info nameofexecutable foo} msg] $msg
} {1 {wrong # args: should be "info nameofexecutable"}}

test info-14.1 {info patchlevel option} {
    set a [info patchlevel]
    regexp {[0-9]+\.[0-9]+([p[0-9]+)?} $a
} 1
test info-14.2 {info patchlevel option} {
    list [catch {info patchlevel a} msg] $msg
} {1 {wrong # args: should be "info patchlevel"}}
test info-14.3 {info patchlevel option} {
    set t $tcl_patchLevel
    unset tcl_patchLevel
    set result [list [catch {info patchlevel} msg] $msg]
    set tcl_patchLevel $t
    set result
} {1 {can't read "tcl_patchLevel": no such variable}}

test info-15.1 {info procs option} {
    proc t1 {} {}
    proc t2 {} {}
    set x " [info procs] "
    list [string match {* t1 *} $x] [string match {* t2 *} $x] \
            [string match {* _undefined_ *} $x]
} {1 1 0}
test info-15.2 {info procs option} {
    proc _tt1 {} {}
    proc _tt2 {} {}
    lsort [info pr _tt*]
} {_tt1 _tt2}
catch {rename _tt1 {}}
catch {rename _tt2 {}}
test info-15.3 {info procs option} {
    list [catch {info procs 2 3} msg] $msg
} {1 {wrong # args: should be "info procs ?pattern?"}}
test info-15.4 {info procs option} {
    catch {namespace delete test_ns_info2}
    namespace eval test_ns_info2 {
        namespace import ::test_ns_info1::*
        proc r {} {}
        list [info procs] [info procs p*]
    }
} {{p q r} p}
test info-15.5 {info procs option with a proc in a namespace} {
    catch {namespace delete test_ns_info2}
    namespace eval test_ns_info2 {
	proc p1 { arg } {
	    puts cmd
	}
        proc p2 { arg } {
	    puts cmd
	}
    }
    info procs ::test_ns_info2::p1
} {::test_ns_info2::p1}
test info-15.6 {info procs option with a pattern in a namespace} {
    catch {namespace delete test_ns_info2}
    namespace eval test_ns_info2 {
	proc p1 { arg } {
	    puts cmd
	}
        proc p2 { arg } {
	    puts cmd
	}
    }
    lsort [info procs ::test_ns_info2::p*]
} [lsort [list ::test_ns_info2::p1 ::test_ns_info2::p2]]
test info-15.7 {info procs option with a global shadowing proc} {
    catch {namespace delete test_ns_info2}
    proc string_cmd { arg } {
        puts cmd
    }
    namespace eval test_ns_info2 {
	proc string_cmd { arg } {
	    puts cmd
	}
    }
    info procs test_ns_info2::string*
} {::test_ns_info2::string_cmd}
# This regression test is currently commented out because it requires
# that the implementation of "info procs" looks into the global namespace,
# which it does not (in contrast to "info commands")
if {0} {
test info-15.8 {info procs option with a global shadowing proc} {
    catch {namespace delete test_ns_info2}
    proc string_cmd { arg } {
        puts cmd
    }
    proc string_cmd2 { arg } {
        puts cmd
    }
    namespace eval test_ns_info2 {
	proc string_cmd { arg } {
	    puts cmd
	}
    }
    namespace eval test_ns_info2 {
        lsort [info procs string*]
    }
} [lsort [list string_cmd string_cmd2]]
}

test info-16.1 {info script option} {
    list [catch {info script x x} msg] $msg
} {1 {wrong # args: should be "info script ?filename?"}}
test info-16.2 {info script option} {
    file tail [info sc]
} "info.test"
set gorpfile [makeFile "info script\n" gorp.info]
test info-16.3 {info script option} {
    list [source $gorpfile] [file tail [info script]]
} [list $gorpfile info.test]
test info-16.4 {resetting "info script" after errors} {
    catch {source ~_nobody_/foo}
    file tail [info script]
} "info.test"
test info-16.5 {resetting "info script" after errors} {
    catch {source _nonexistent_}
    file tail [info script]
} "info.test"
test info-16.6 {info script option} {
    set script [info script]
    list [file tail [info script]] \
	    [info script newname.txt] \
	    [file tail [info script $script]]
} [list info.test newname.txt info.test]
test info-16.7 {info script option} {
    set script [info script]
    info script newname.txt
    list [source $gorpfile] [file tail [info script]] \
	    [file tail [info script $script]]
} [list $gorpfile newname.txt info.test]
removeFile gorp.info
set gorpfile [makeFile {list [info script] [info script foo.bar]} gorp.info]
test info-16.8 {info script option} {
    list [source $gorpfile] [file tail [info script]]
} [list [list $gorpfile foo.bar] info.test]
removeFile gorp.info

test info-17.1 {info sharedlibextension option} {
    list [catch {info sharedlibextension foo} msg] $msg
} {1 {wrong # args: should be "info sharedlibextension"}}

test info-18.1 {info tclversion option} {
    set x [info tclversion]
    scan $x "%d.%d%c" a b c
} 2
test info-18.2 {info tclversion option} {
    list [catch {info t 2} msg] $msg
} {1 {wrong # args: should be "info tclversion"}}
test info-18.3 {info tclversion option} {
    set t $tcl_version
    unset tcl_version
    set result [list [catch {info tclversion} msg] $msg]
    set tcl_version $t
    set result
} {1 {can't read "tcl_version": no such variable}}

test info-19.1 {info vars option} {
    set a 1
    set b 2
    proc t1 {x y} {
        global a b
        set c 33
        return [info vars]
    }
    lsort [t1 18 19]
} {a b c x y}
test info-19.2 {info vars option} {
    set xxx1 1
    set xxx2 2
    proc t1 {xxa y} {
        global xxx1 xxx2
        set c 33
        return [info vars x*]
    }
    lsort [t1 18 19]
} {xxa xxx1 xxx2}
test info-19.3 {info vars option} {
    lsort [info vars]
} [lsort [info globals]]
test info-19.4 {info vars option} {
    list [catch {info vars a b} msg] $msg
} {1 {wrong # args: should be "info vars ?pattern?"}}
test info-19.5 {info vars with temporary variables} {
    proc t1 {} {
        foreach a {b c} {}
        info vars
    }
    t1
} {a}
test info-19.6 {info vars: Bug 1072654} -setup {
    namespace eval :: unset -nocomplain foo
    catch {namespace delete x}
} -body {
    namespace eval x info vars foo
} -cleanup {
    namespace delete x
} -result {}

# Check whether the extra testing functions are defined...
if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    set functions {abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh wide}
} else {
    set functions {T1 T2 T3 abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh wide}
}
test info-20.1 {info functions option} {info functions sin} sin
test info-20.2 {info functions option} {lsort [info functions]} $functions
test info-20.3 {info functions option} {
    lsort [info functions a*]
} {abs acos asin atan atan2}
test info-20.4 {info functions option} {
    lsort [info functions *tan*]
} {atan atan2 tan tanh}
test info-20.5 {info functions option} {
    list [catch {info functions raise an error} msg] $msg
} {1 {wrong # args: should be "info functions ?pattern?"}}

test info-21.1 {miscellaneous error conditions} {
    list [catch {info} msg] $msg
} {1 {wrong # args: should be "info option ?arg arg ...?"}}
test info-21.2 {miscellaneous error conditions} !tip280 {
    list [catch {info gorp} msg] $msg
} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.2-280 {miscellaneous error conditions} tip280 {
    list [catch {info gorp} msg] $msg
} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.3 {miscellaneous error conditions} !tip280 {
    list [catch {info c} msg] $msg
} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.3-280 {miscellaneous error conditions} tip280 {
    list [catch {info c} msg] $msg
} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.4 {miscellaneous error conditions} !tip280 {
    list [catch {info l} msg] $msg
} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.4-280 {miscellaneous error conditions} tip280 {
    list [catch {info l} msg] $msg
} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.5 {miscellaneous error conditions} !tip280 {
    list [catch {info s} msg] $msg
} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.5-280 {miscellaneous error conditions} tip280 {
    list [catch {info s} msg] $msg
} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}

##
# ### ### ### ######### ######### #########
## info frame

## Helper
# For the more complex results we cut the file name down to remove
# path dependencies, and we use only part of the first line of the
# reported command. The latter is required because otherwise the whole
# test case may appear in some results, but the result is part of the
# testcase. An infinite string would be required to describe that. The
# cutting-down breaks this.

proc reduce {frame} {
    set pos [lsearch -exact $frame cmd]
    incr pos
    set cmd   [lindex $frame $pos]
    if {[regexp \n $cmd]} {
	set first [lindex [split $cmd \n] 0] ; set first [expr {[string length $first] > 11 ? [string range $first 0 end-11] : [string range $first 0 end-4]}]
	set frame [lreplace $frame $pos $pos $first]
    }
    set pos [lsearch -exact $frame file]
    if {$pos >=0} {
	incr pos
	set tail  [file tail [lindex $frame $pos]]
	set frame [lreplace $frame $pos $pos $tail]
    }
    set frame
}

## Helper
# Generate a stacktrace from the current location to top.  This code
# not only depends on the exact location of things, but also on the
# implementation of tcltest. Any changes and these tests will have to
# be updated.

proc etrace {} {
    set res {}
    set level [info frame]
    while {$level} {
	lappend res [list $level [reduce [info frame $level]]]
	incr level -1
    }
    return $res
}

##

test info-22.0.0 {info frame, levels} {tip280 && !singleTestInterp} {
    info frame
} 7
test info-22.0.1 {info frame, levels} {tip280 && singleTestInterp} {
    info frame
} 10

test info-22.1.0 {info frame, bad level relative} {tip280 && !singleTestInterp} {
    # catch is another level!, i.e. we have 8, not 7
    catch {info frame -8} msg
    set msg
} {bad level "-8"}
test info-22.1.1 {info frame, bad level relative} {tip280 && singleTestInterp} {
    # catch is another level!, i.e. we have 11, not 10
    catch {info frame -11} msg
    set msg
} {bad level "-11"}

test info-22.2.0 {info frame, bad level absolute} {tip280 && !singleTestInterp} {
    # catch is another level!, i.e. we have 8, not 7
    catch {info frame 9} msg
    set msg
} {bad level "9"}
test info-22.2.1 {info frame, bad level absolute} {tip280 && singleTestInterp} {
    # catch is another level!, i.e. we have 12, not 10
    catch {info frame 12} msg
    set msg
} {bad level "12"}

test info-22.3 {info frame, current, relative} -constraints tip280 -match glob -body {
    info frame 0
} -result {type source line 761 file * cmd {info frame 0} proc ::tcltest::RunTest}

test info-22.4 {info frame, current, relative, nested} -constraints tip280 -match glob -body {
    set res [info frame 0]
} -result {type source line 765 file * cmd {info frame 0} proc ::tcltest::RunTest}

test info-22.5.0 {info frame, current, absolute} -constraints {tip280 && !singleTestInterp} -match glob -body {
    reduce [info frame 7]
} -result {type source line 769 file * cmd {info frame 7} proc ::tcltest::RunTest}
test info-22.5.1 {info frame, current, absolute} -constraints {tip280 && singleTestInterp} -match glob -body {
    reduce [info frame 10]
} -result {type source line 772 file * cmd {info frame 10} proc ::tcltest::RunTest}

test info-22.6.0 {info frame, global, relative} {tip280 && !singleTestInterp} {
    reduce [info frame -6]
} {type source line 775 file info.test cmd test\ info-22.6.0\ \{info\ frame,\ global,\ relative\}\ \{tip280\ &&\ !singleTe}
test info-22.6.1 {info frame, global, relative} {tip280 && singleTestInterp} {
    reduce [info frame -6]
} {type source line 778 file info.test cmd test\ info-22.6.1\ \{info\ frame,\ global,\ relative\}\ \{tip280\ &&\ singleTe proc ::tcltest::runAllTests}

test info-22.7.0 {info frame, global, absolute} {tip280 && !singleTestInterp} {
    reduce [info frame 1]
} {type source line 782 file info.test cmd test\ info-22.7.0\ \{info\ frame,\ global,\ absolute\}\ \{tip280\ &&\ !singleTe}
test info-22.7.1 {info frame, global, absolute} {tip280 && singleTestInterp} {
    reduce [info frame 4]
} {type source line 785 file info.test cmd test\ info-22.7.1\ \{info\ frame,\ global,\ absolute\}\ \{tip280\ &&\ singleTe proc ::tcltest::runAllTests}

test info-22.8 {info frame, basic trace} -constraints {tip280} -match glob -body {
    join [lrange [etrace] 0 1] \n
} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 790 file info.test cmd etrace proc ::tcltest::RunTest}}
## The line 1966 is off by 5 from the true value of 1971. This is a knownBug, see testcase 30.0
test info-23.0.0 {eval'd info frame} {tip280 && !singleTestInterp} {
    eval {info frame}
} 8
test info-23.0.1 {eval'd info frame} {tip280 && singleTestInterp} {
    eval {info frame}
} 11

test info-23.1.0 {eval'd info frame, semi-dynamic} {tip280 && !singleTestInterp} {
    eval info frame
} 8
test info-23.1.1 {eval'd info frame, semi-dynamic} {tip280 && singleTestInterp} {
    eval info frame
} 11

test info-23.2.0 {eval'd info frame, dynamic} {tip280 && !singleTestInterp} {
    set script {info frame}
    eval $script
} 8
test info-23.2.1 {eval'd info frame, dynamic} {tip280 && singleTestInterp} {
    set script {info frame}
    eval $script
} 11

test info-23.3 {eval'd info frame, literal} -constraints tip280 -match glob -body {
    eval {
	info frame 0
    }
} -result {type source line 819 file *info.test cmd {info frame 0} proc ::tcltest::RunTest}

test info-23.4 {eval'd info frame, semi-dynamic} tip280 {
    eval info frame 0
} {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest}

test info-23.5 {eval'd info frame, dynamic} tip280 {
    set script {info frame 0}
    eval $script
} {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest}

test info-23.6 {eval'd info frame, trace} -constraints {tip280} -match glob -body {
    set script {etrace}
    join [lrange [eval $script] 0 2] \n
} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 1 cmd etrace proc ::tcltest::RunTest}
* {type source line 834 file info.test cmd {eval $script} proc ::tcltest::RunTest}}
## The line 1966 is off by 5 from the true value of 1971. This is a knownBug, see testcase 30.0
# -------------------------------------------------------------------------

# Procedures defined in scripts which are arguments to control
# structures (like 'namespace eval', 'interp eval', 'if', 'while',
# 'switch', 'catch', 'for', 'foreach', etc.) have no absolute
# location. The command implementations execute such scripts through
# Tcl_EvalObjEx. Flag 0 causes it to use the bytecode compiler. This
# causes the connection to the context to be lost. Currently only
# procedure bodies are able to remember their context.

# -------------------------------------------------------------------------

namespace eval foo {
    proc bar {} {info frame 0}
}

test info-24.0 {info frame, interaction, namespace eval} tip280 {
    reduce [foo::bar]
} {type source line 852 file info.test cmd {info frame 0} proc ::foo::bar level 0}

namespace delete foo

# -------------------------------------------------------------------------

set flag 1
if {$flag} {
    namespace eval foo {}
    proc ::foo::bar {} {info frame 0}
}

test info-24.1 {info frame, interaction, if} tip280 {
    reduce [foo::bar]
} {type source line 866 file info.test cmd {info frame 0} proc ::foo::bar level 0}

namespace delete foo

# -------------------------------------------------------------------------

set flag 1
while {$flag} {
    namespace eval foo {}
    proc ::foo::bar {} {info frame 0}
    set flag 0
}

test info-24.2 {info frame, interaction, while} tip280 {
    reduce [foo::bar]
} {type source line 880 file info.test cmd {info frame 0} proc ::foo::bar level 0}

namespace delete foo

# -------------------------------------------------------------------------

catch {
    namespace eval foo {}
    proc ::foo::bar {} {info frame 0}
}

test info-24.3 {info frame, interaction, catch} tip280 {
    reduce [foo::bar]
} {type source line 894 file info.test cmd {info frame 0} proc ::foo::bar level 0}

namespace delete foo

# -------------------------------------------------------------------------

foreach var val {
    namespace eval foo {}
    proc ::foo::bar {} {info frame 0}
    break
}

test info-24.4 {info frame, interaction, foreach} tip280 {
    reduce [foo::bar]
} {type source line 907 file info.test cmd {info frame 0} proc ::foo::bar level 0}

namespace delete foo

# -------------------------------------------------------------------------

for {} {1} {} {
    namespace eval foo {}
    proc ::foo::bar {} {info frame 0}
    break
}

test info-24.5 {info frame, interaction, for} tip280 {
    reduce [foo::bar]
} {type source line 921 file info.test cmd {info frame 0} proc ::foo::bar level 0}

namespace delete foo

# -------------------------------------------------------------------------

eval {
    proc bar {} {info frame 0}
}

test info-25.0 {info frame, proc in eval} tip280 {
    reduce [bar]
} {type source line 934 file info.test cmd {info frame 0} proc ::bar level 0}

proc bar {} {info frame 0}
test info-25.1 {info frame, regular proc} tip280 {
    reduce [bar]
} {type source line 941 file info.test cmd {info frame 0} proc ::bar level 0}
rename bar {}



test info-30.0 {bs+nl in literal words} {tip280 knownBug} {
    if {1} {
	set res \
	    [reduce [info frame 0]]
    }
    set res
    # This is reporting line 3 instead of the correct 4 because the
    # bs+nl combination is subst by the parser before the 'if'
    # command, and the the bcc sees the word. To fix record the
    # offsets of all bs+nl sequences in literal words, then use the
    # information in the bcc to bump line numbers when parsing over
    # the location. Also affected: testcases 22.8 and 23.6.
} {type eval line 4 cmd {info frame 0} proc ::tcltest::RunTest}



# -------------------------------------------------------------------------
# See 24.0 - 24.5 for similar situations, using literal scripts.

set body {set flag 0
    set a c
    set res [info frame 0]} ;# line 3!

test info-31.0 {ns eval, script in variable} tip280 {
    namespace eval foo $body
    set res
} {type eval line 3 cmd {info frame 0} level 0}
catch {namespace delete foo}


test info-31.1 {if, script in variable} tip280 {
    if 1 $body
    set res
} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}

test info-31.1a {if, script in variable} tip280 {
    if 1 then $body
    set res
} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}



test info-31.2 {while, script in variable} tip280 {
    set flag 1
    while {$flag} $body
    set res
} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}

# .3 - proc - scoping prevent return of result ...

test info-31.4 {foreach, script in variable} tip280 {
    foreach var val $body
    set res
} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}

test info-31.5 {for, script in variable} tip280 {
    set flag 1
    for {} {$flag} {} $body
    set res
} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}

test info-31.6 {eval, script in variable} tip280 {
    eval $body
    set res
} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}

# -------------------------------------------------------------------------

namespace eval foo {}
set x foo
switch -exact -- $x {
    foo {
	proc ::foo::bar {} {info frame 0}
    }
}

test info-24.6.0 {info frame, interaction, switch, list body} tip280 {
    reduce [foo::bar]
} {type source line 1021 file info.test cmd {info frame 0} proc ::foo::bar level 0}

namespace delete foo
unset x

# -------------------------------------------------------------------------

namespace eval foo {}
set x foo
switch -exact -- $x foo {
    proc ::foo::bar {} {info frame 0}
}

test info-24.6.1 {info frame, interaction, switch, multi-body} tip280 {
    reduce [foo::bar]
} {type source line 1037 file info.test cmd {info frame 0} proc ::foo::bar level 0}

namespace delete foo
unset x

# -------------------------------------------------------------------------

namespace eval foo {}
set x foo
switch -exact -- $x [list foo {
    proc ::foo::bar {} {info frame 0}
}]

test info-24.6.2 {info frame, interaction, switch, list body, dynamic} tip280 {
    reduce [foo::bar]
} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}

namespace delete foo
unset x

# -------------------------------------------------------------------------

set body {
    foo {
	proc ::foo::bar {} {info frame 0}
    }
}

namespace eval foo {}
set x foo
switch -exact -- $x $body

test info-31.7 {info frame, interaction, switch, dynamic} tip280 {
    reduce [foo::bar]
} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}

namespace delete foo
unset x

# -------------------------------------------------------------------------

set body {
    proc ::foo::bar {} {info frame 0}
}

namespace eval foo {}
eval $body

test info-32.0 {info frame, dynamic procedure} tip280 {
    reduce [foo::bar]
} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}

namespace delete foo

# -------------------------------------------------------------------------

test info-34.0 {eval pure list, single line} -constraints {tip280} -match glob -body {
    # Basically, counting the newline in the word seen through $foo
    # doesn't really make sense. It makes a bit of sense if the word
    # would have been a string literal in the command list.
    #
    # Problem: At the point where we see the list elements we cannot
    # distinguish the two cases, thus we cannot switch between
    # count/not-count, it is has to be one or the other for all
    # cases. Of the two possibilities miguel convinced me that 'not
    # counting' is the more proper.
    set foo {b
	c}
    set cmd [list foreach $foo {x y} {
	set res [join [lrange [etrace] 0 2] \n]
	break
    }]
    eval $cmd
    set res
} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 2 cmd etrace proc ::tcltest::RunTest}
* {type eval line 1 cmd foreac proc ::tcltest::RunTest}}

# -------------------------------------------------------------------------

# 6 cases.
## DV. direct-var          - unchanged
## DPV direct-proc-var     - ditto
## PPV proc-proc-var       - ditto
## DL. direct-literal      - now tracking absolute location
## DPL direct-proc-literal - ditto
## PPL proc-proc-literal   - ditto
## ### ### ### ######### ######### #########"

proc control {vv script} {
    upvar 1 $vv var
    return [uplevel 1 $script]
}

proc datal {} {
    control y {
	set y PPL
	etrace
    }
}

proc datav {} {
    set script {
	set y PPV
	etrace
    }
    control y $script
}

test info-38.1 {location information for uplevel, dv, direct-var} -constraints tip280 -match glob -body {
    set script {
	set y DV.
	etrace
    }
    join [lrange [uplevel \#0 $script] 0 2] \n
} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::tcltest::RunTest}
* {type source line 1156 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}}

test info-38.2 {location information for uplevel, dl, direct-literal} -constraints tip280 -match glob -body {
    join [lrange [uplevel \#0 {
	set y DL.
	etrace
    }] 0 2] \n
} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1164 file info.test cmd etrace proc ::tcltest::RunTest}
* {type source line 1162 file info.test cmd up proc ::tcltest::RunTest}}

test info-38.3 {location information for uplevel, dpv, direct-proc-var} -constraints tip280 -match glob -body {
    set script {
	set y DPV
	etrace
    }
    join [lrange [control y $script] 0 3] \n
} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::control}
* {type source line 1133 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1175 file info.test cmd {control y $script} proc ::tcltest::RunTest}}

test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -constraints tip280 -match glob -body {
    join [lrange [control y {
	set y DPL
	etrace
    }] 0 3] \n
} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1184 file info.test cmd etrace proc ::control}
* {type source line 1133 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1182 file info.test cmd control proc ::tcltest::RunTest}}

test info-38.5 {location information for uplevel, ppv, proc-proc-var} -constraints tip280 -match glob -body {
    join [lrange [datav] 0 4] \n
} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::control}
* {type source line 1133 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1148 file info.test cmd {control y $script} proc ::datav level 1}
* {type source line 1192 file info.test cmd datav proc ::tcltest::RunTest}}

test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -constraints tip280 -match glob -body {
    join [lrange [datal] 0 4] \n
} -result {* {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1139 file info.test cmd etrace proc ::control}
* {type source line 1133 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1137 file info.test cmd control proc ::datal level 1}
* {type source line 1200 file info.test cmd datal proc ::tcltest::RunTest}}

# -------------------------------------------------------------------------

# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::tcltest::cleanupTests
return