sl@0: # Commands covered:  uplevel
sl@0: #
sl@0: # This file contains a collection of tests for one or more of the Tcl
sl@0: # built-in commands.  Sourcing this file into Tcl runs the tests and
sl@0: # generates output for errors.  No output means no errors were found.
sl@0: #
sl@0: # Copyright (c) 1991-1993 The Regents of the University of California.
sl@0: # Copyright (c) 1994 Sun Microsystems, Inc.
sl@0: # Copyright (c) 1998-1999 by Scriptics Corporation.
sl@0: #
sl@0: # See the file "license.terms" for information on usage and redistribution
sl@0: # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0: #
sl@0: # RCS: @(#) $Id: uplevel.test,v 1.7 2002/08/08 18:19:37 msofer Exp $
sl@0: 
sl@0: if {[lsearch [namespace children] ::tcltest] == -1} {
sl@0:     package require tcltest
sl@0:     namespace import -force ::tcltest::*
sl@0: }
sl@0: 
sl@0: proc a {x y} {
sl@0:     newset z [expr $x+$y]
sl@0:     return $z
sl@0: }
sl@0: proc newset {name value} {
sl@0:     uplevel set $name $value
sl@0:     uplevel 1 {uplevel 1 {set xyz 22}}
sl@0: }
sl@0: 
sl@0: test uplevel-1.1 {simple operation} {
sl@0:     set xyz 0
sl@0:     a 22 33
sl@0: } 55
sl@0: test uplevel-1.2 {command is another uplevel command} {
sl@0:     set xyz 0
sl@0:     a 22 33
sl@0:     set xyz
sl@0: } 22
sl@0: 
sl@0: proc a1 {} {
sl@0:     b1
sl@0:     global a a1
sl@0:     set a $x
sl@0:     set a1 $y
sl@0: }
sl@0: proc b1 {} {
sl@0:     c1
sl@0:     global b b1
sl@0:     set b $x
sl@0:     set b1 $y
sl@0: }
sl@0: proc c1 {} {
sl@0:     uplevel 1 set x 111
sl@0:     uplevel #2 set y 222
sl@0:     uplevel 2 set x 333
sl@0:     uplevel #1 set y 444
sl@0:     uplevel 3 set x 555
sl@0:     uplevel #0 set y 666
sl@0: }
sl@0: a1
sl@0: test uplevel-2.1 {relative and absolute uplevel} {set a} 333
sl@0: test uplevel-2.2 {relative and absolute uplevel} {set a1} 444
sl@0: test uplevel-2.3 {relative and absolute uplevel} {set b} 111
sl@0: test uplevel-2.4 {relative and absolute uplevel} {set b1} 222
sl@0: test uplevel-2.5 {relative and absolute uplevel} {set x} 555
sl@0: test uplevel-2.6 {relative and absolute uplevel} {set y} 666
sl@0: 
sl@0: test uplevel-3.1 {uplevel to same level} {
sl@0:     set x 33
sl@0:     uplevel #0 set x 44
sl@0:     set x
sl@0: } 44
sl@0: test uplevel-3.2 {uplevel to same level} {
sl@0:     set x 33
sl@0:     uplevel 0 set x
sl@0: } 33
sl@0: test uplevel-3.3 {uplevel to same level} {
sl@0:     set y xxx
sl@0:     proc a1 {} {set y 55; uplevel 0 set y 66; return $y}
sl@0:     a1
sl@0: } 66
sl@0: test uplevel-3.4 {uplevel to same level} {
sl@0:     set y zzz
sl@0:     proc a1 {} {set y 55; uplevel #1 set y}
sl@0:     a1
sl@0: } 55
sl@0: 
sl@0: test uplevel-4.1 {error: non-existent level} {
sl@0:     list [catch c1 msg] $msg
sl@0: } {1 {bad level "#2"}}
sl@0: test uplevel-4.2 {error: non-existent level} {
sl@0:     proc c2 {} {uplevel 3 {set a b}}
sl@0:     list [catch c2 msg] $msg
sl@0: } {1 {bad level "3"}}
sl@0: test uplevel-4.3 {error: not enough args} {
sl@0:     list [catch uplevel msg] $msg
sl@0: } {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}}
sl@0: test uplevel-4.4 {error: not enough args} {
sl@0:     proc upBug {} {uplevel 1}
sl@0:     list [catch upBug msg] $msg
sl@0: } {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}}
sl@0: 
sl@0: proc a2 {} {
sl@0:     uplevel a3
sl@0: }
sl@0: proc a3 {} {
sl@0:     global x y
sl@0:     set x [info level]
sl@0:     set y [info level 1]
sl@0: }
sl@0: a2
sl@0: test uplevel-5.1 {info level} {set x} 1
sl@0: test uplevel-5.2 {info level} {set y} a3
sl@0: 
sl@0: namespace eval ns1 {
sl@0:     proc set args {return ::ns1}
sl@0: }
sl@0: proc a2 {} {
sl@0:     uplevel {set x ::}
sl@0: }
sl@0: test uplevel-6.1 {uplevel and shadowed cmds} {
sl@0:     set res [namespace eval ns1 a2]
sl@0:     lappend res [namespace eval ns2 a2]
sl@0:     lappend res [namespace eval ns1 a2]
sl@0:     namespace eval ns1 {rename set {}}
sl@0:     lappend res [namespace eval ns1 a2]
sl@0: } {::ns1 :: ::ns1 ::}
sl@0: 
sl@0: 
sl@0: # cleanup
sl@0: ::tcltest::cleanupTests
sl@0: return
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: