# 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.78.2.1 2010/12/01 16:42:37 kennykb Exp $

if {{::tcltest} ni [namespace children]} {
    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, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, 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 1361 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} -cleanup {unset script y}

# 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 1338 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1380 file info.test cmd {control y $script} proc ::tcltest::RunTest}} -cleanup {unset script y}

# 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 1338 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1353 file info.test cmd {control y $script} proc ::datav level 1}
* {type source line 1397 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.







testConstraint testevalex [llength [info commands testevalex]]
test info-38.7 {location information for arg substitution} -constraints testevalex -match glob -body {
    join [lrange [testevalex {return -level 0 [etrace]}] 0 3] \n
} -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 1414 file info.test cmd {testevalex {return -level 0 \[etrace]}} proc ::tcltest::RunTest}

[set x {}] \
[reduce \
     [info frame 0]]";# line 1541
}
} -cleanup {unset res x} -result {   type source line 1541 file info.test cmd {info frame 0} proc ::tcltest::RunTest}

test info-30.13 {bs+nl in literal words, uplevel script, with nested words} -body {
    subinterp ; set res [interp eval sub { uplevel #0 {
	if {1} \
	    {
		set ::res \
		    [reduce [info frame 0]];# line 1550
	    }
    }
    set res }] ; interp delete sub ; set res
} -cleanup {unset res} -result {type source line 1550 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 1562
    }]
    rename abra {}
    set res }] ; interp delete sub ; set res
} { type source line 1562 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} \
		{

    trace remove execution print_one enter get_frame_info
    rename get_frame_info {}
    rename test_info_frame {}
    rename print_one {}
} -result {type source line 1854 file info.test cmd print_one proc ::test_info_frame level 1
type source line 1859 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 1890 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1902 file info.test cmd etrace proc ::control}
* {type source line 1897 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1900 file info.test cmd control proc ::datal level 1}
* {type source line 1905 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 1919 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1930 file info.test cmd etrace proc ::control}
* {type source line 1926 file info.test cmd {uplevel 1 $script} proc ::control}
* {type source line 1928 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 1944 file info.test cmd {info frame $level} proc ::etrace level 0}
* {type source line 1951 file info.test cmd etrace level 1}
* {type source line 1949 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub}

# -------------------------------------------------------------------------
unset -nocomplain res

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