# Commands covered:  uplevel

 #

 # 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-1993 The Regents of the University of California.

 # Copyright (c) 1994 Sun Microsystems, Inc.

 # Copyright (c) 1998-1999 by Scriptics Corporation.

 #

 # See the file "license.terms" for information on usage and redistribution

 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.

 #

 # RCS: @(#) $Id: uplevel.test,v 1.7 2002/08/08 18:19:37 msofer Exp $

 if {[lsearch [namespace children] ::tcltest] == -1} {

     package require tcltest

     namespace import -force ::tcltest::*

 }

 proc a {x y} {

     newset z [expr $x+$y]

     return $z

 }

 proc newset {name value} {

     uplevel set $name $value

     uplevel 1 {uplevel 1 {set xyz 22}}

 }

 test uplevel-1.1 {simple operation} {

     set xyz 0

     a 22 33

 } 55

 test uplevel-1.2 {command is another uplevel command} {

     set xyz 0

     a 22 33

     set xyz

 } 22

 proc a1 {} {

     b1

     global a a1

     set a $x

     set a1 $y

 }

 proc b1 {} {

     c1

     global b b1

     set b $x

     set b1 $y

 }

 proc c1 {} {

     uplevel 1 set x 111

     uplevel #2 set y 222

     uplevel 2 set x 333

     uplevel #1 set y 444

     uplevel 3 set x 555

     uplevel #0 set y 666

 }

 a1

 test uplevel-2.1 {relative and absolute uplevel} {set a} 333

 test uplevel-2.2 {relative and absolute uplevel} {set a1} 444

 test uplevel-2.3 {relative and absolute uplevel} {set b} 111

 test uplevel-2.4 {relative and absolute uplevel} {set b1} 222

 test uplevel-2.5 {relative and absolute uplevel} {set x} 555

 test uplevel-2.6 {relative and absolute uplevel} {set y} 666

 test uplevel-3.1 {uplevel to same level} {

     set x 33

     uplevel #0 set x 44

     set x

 } 44

 test uplevel-3.2 {uplevel to same level} {

     set x 33

     uplevel 0 set x

 } 33

 test uplevel-3.3 {uplevel to same level} {

     set y xxx

     proc a1 {} {set y 55; uplevel 0 set y 66; return $y}

     a1

 } 66

 test uplevel-3.4 {uplevel to same level} {

     set y zzz

     proc a1 {} {set y 55; uplevel #1 set y}

     a1

 } 55

 test uplevel-4.1 {error: non-existent level} {

     list [catch c1 msg] $msg

 } {1 {bad level "#2"}}

 test uplevel-4.2 {error: non-existent level} {

     proc c2 {} {uplevel 3 {set a b}}

     list [catch c2 msg] $msg

 } {1 {bad level "3"}}

 test uplevel-4.3 {error: not enough args} {

     list [catch uplevel msg] $msg

 } {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}}

 test uplevel-4.4 {error: not enough args} {

     proc upBug {} {uplevel 1}

     list [catch upBug msg] $msg

 } {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}}

 proc a2 {} {

     uplevel a3

 }

 proc a3 {} {

     global x y

     set x [info level]

     set y [info level 1]

 }

 a2

 test uplevel-5.1 {info level} {set x} 1

 test uplevel-5.2 {info level} {set y} a3

 namespace eval ns1 {

     proc set args {return ::ns1}

 }

 proc a2 {} {

     uplevel {set x ::}

 }

 test uplevel-6.1 {uplevel and shadowed cmds} {

     set res [namespace eval ns1 a2]

     lappend res [namespace eval ns2 a2]

     lappend res [namespace eval ns1 a2]

     namespace eval ns1 {rename set {}}

     lappend res [namespace eval ns1 a2]

 } {::ns1 :: ::ns1 ::}

 # cleanup

 ::tcltest::cleanupTests

 return