# 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.47.2.13 2010/11/15 21:32:32 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",

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
# 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-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
}
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
# implementation of tcltest. Any changes and these tests will have to
# be updated.

proc etrace {} {

	etrace
    }
    join [lrange [uplevel \#0 $script] 0 2] \n
} -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 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.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 728 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::control}
* {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.5 {location information for uplevel, ppv, proc-proc-var} -match glob -body {
    join [lrange [datav] 0 4] \n
} -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 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} -body {
    namespace eval ::foo {}
    proc ::foo::bar {} {

[set x {}] \
[reduce \
     [info frame 0]]";# line 1534
}
} {   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} {
    subinterp ; set res [interp eval sub { uplevel #0 {
	if {1} \
	    {
		set ::res \
		    [reduce [info frame 0]];# line 1543
	    }
    }
    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} {
    subinterp ; set res [interp eval sub { proc abra {script} {
	uplevel 1 $script
    }
    set res [abra {
	return "\
 [reduce [info frame 0]]";# line 1555
    }]
    rename 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} {
    proc a {} {
	proc b {} {
	    if {1} \
		{

    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}
::tcltest::cleanupTests
return