1# Commands covered: uplevel 2# 3# This file contains a collection of tests for one or more of the Tcl built-in 4# commands. Sourcing this file into Tcl runs the tests and generates output 5# for errors. No output means no errors were found. 6# 7# Copyright © 1991-1993 The Regents of the University of California. 8# Copyright © 1994 Sun Microsystems, Inc. 9# Copyright © 1998-1999 Scriptics Corporation. 10# 11# See the file "license.terms" for information on usage and redistribution of 12# this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 14if {"::tcltest" ni [namespace children]} { 15 package require tcltest 2.5 16 namespace import -force ::tcltest::* 17} 18 19proc a {x y} { 20 newset z [expr {$x + $y}] 21 return $z 22} 23proc newset {name value} { 24 uplevel set $name $value 25 uplevel 1 {uplevel 1 {set xyz 22}} 26} 27 28test uplevel-1.1 {simple operation} { 29 set xyz 0 30 a 22 33 31} 55 32test uplevel-1.2 {command is another uplevel command} { 33 set xyz 0 34 a 22 33 35 set xyz 36} 22 37 38proc a1 {} { 39 b1 40 global a a1 41 set a $x 42 set a1 $y 43} 44proc b1 {} { 45 c1 46 global b b1 47 set b $x 48 set b1 $y 49} 50proc c1 {} { 51 uplevel 1 set x 111 52 uplevel #2 set y 222 53 uplevel 2 set x 333 54 uplevel #1 set y 444 55 uplevel 3 set x 555 56 uplevel #0 set y 666 57} 58a1 59test uplevel-2.1 {relative and absolute uplevel} {set a} 333 60test uplevel-2.2 {relative and absolute uplevel} {set a1} 444 61test uplevel-2.3 {relative and absolute uplevel} {set b} 111 62test uplevel-2.4 {relative and absolute uplevel} {set b1} 222 63test uplevel-2.5 {relative and absolute uplevel} {set x} 555 64test uplevel-2.6 {relative and absolute uplevel} {set y} 666 65 66test uplevel-3.1 {uplevel to same level} { 67 set x 33 68 uplevel #0 set x 44 69 set x 70} 44 71test uplevel-3.2 {uplevel to same level} { 72 set x 33 73 uplevel 0 set x 74} 33 75test uplevel-3.3 {uplevel to same level} { 76 set y xxx 77 proc a1 {} {set y 55; uplevel 0 set y 66; return $y} 78 a1 79} 66 80test uplevel-3.4 {uplevel to same level} { 81 set y zzz 82 proc a1 {} {set y 55; uplevel #1 set y} 83 a1 84} 55 85 86test uplevel-4.0.1 {error: non-existent level} -body { 87 uplevel #0 { uplevel { set y 222 } } 88} -returnCodes error -result {bad level "1"} 89test uplevel-4.0.2 {error: non-existent level} -setup { 90 interp create i 91} -body { 92 i eval { uplevel { set y 222 } } 93} -returnCodes error -result {bad level "1"} -cleanup { 94 interp delete i 95} 96test uplevel-4.1 {error: non-existent level} -returnCodes error -body { 97 apply {{} { 98 uplevel #2 {set y 222} 99 }} 100} -result {bad level "#2"} 101test uplevel-4.2 {error: non-existent level} -returnCodes error -body { 102 apply {{} { 103 uplevel 3 {set a b} 104 }} 105} -result {bad level "3"} 106test uplevel-4.3 {error: not enough args} -returnCodes error -body { 107 uplevel 108} -result {wrong # args: should be "uplevel ?level? command ?arg ...?"} 109test uplevel-4.4 {error: not enough args} -returnCodes error -body { 110 apply {{} { 111 uplevel 1 112 }} 113} -result {wrong # args: should be "uplevel ?level? command ?arg ...?"} 114test uplevel-4.5 {level parsing} { 115 apply {{} {uplevel 0 {}}} 116} {} 117test uplevel-4.6 {level parsing} { 118 apply {{} {uplevel #0 {}}} 119} {} 120test uplevel-4.7 {level parsing} { 121 apply {{} {uplevel [expr 0] {}}} 122} {} 123test uplevel-4.8 {level parsing} { 124 apply {{} {uplevel #[expr 0] {}}} 125} {} 126test uplevel-4.9 {level parsing} { 127 apply {{} {uplevel -0 {}}} 128} {} 129test uplevel-4.10 {level parsing} { 130 apply {{} {uplevel #-0 {}}} 131} {} 132test uplevel-4.11 {level parsing} { 133 apply {{} {uplevel [expr -0] {}}} 134} {} 135test uplevel-4.12 {level parsing} { 136 apply {{} {uplevel #[expr -0] {}}} 137} {} 138test uplevel-4.13 {level parsing} { 139 apply {{} {uplevel 1 {}}} 140} {} 141test uplevel-4.14 {level parsing} { 142 apply {{} {uplevel #1 {}}} 143} {} 144test uplevel-4.15 {level parsing} { 145 apply {{} {uplevel [expr 1] {}}} 146} {} 147test uplevel-4.16 {level parsing} { 148 apply {{} {uplevel #[expr 1] {}}} 149} {} 150test uplevel-4.17 {level parsing} -returnCodes error -body { 151 apply {{} {uplevel -0xffffffff {}}} 152} -result {bad level "-0xffffffff"} 153test uplevel-4.18 {level parsing} -returnCodes error -body { 154 apply {{} {uplevel #-0xffffffff {}}} 155} -result {bad level "#-0xffffffff"} 156test uplevel-4.19 {level parsing} -returnCodes error -body { 157 apply {{} {uplevel [expr -0xffffffff] {}}} 158} -result {bad level "-4294967295"} 159test uplevel-4.20 {level parsing} -returnCodes error -body { 160 apply {{} {uplevel #[expr -0xffffffff] {}}} 161} -result {bad level "#-4294967295"} 162test uplevel-4.21 {level parsing} -body { 163 apply {{} {uplevel -1 {}}} 164} -returnCodes error -result {bad level "-1"} 165test uplevel-4.22 {level parsing} -body { 166 apply {{} {uplevel #-1 {}}} 167} -returnCodes error -result {bad level "#-1"} 168test uplevel-4.23 {level parsing} -body { 169 apply {{} {uplevel [expr -1] {}}} 170} -returnCodes error -result {bad level "-1"} 171test uplevel-4.24 {level parsing} -body { 172 apply {{} {uplevel #[expr -1] {}}} 173} -returnCodes error -result {bad level "#-1"} 174test uplevel-4.25 {level parsing} -body { 175 apply {{} {uplevel 0xffffffff {}}} 176} -returnCodes error -result {bad level "0xffffffff"} 177test uplevel-4.26 {level parsing} -body { 178 apply {{} {uplevel #0xffffffff {}}} 179} -returnCodes error -result {bad level "#0xffffffff"} 180test uplevel-4.27 {level parsing} -body { 181 apply {{} {uplevel [expr 0xffffffff] {}}} 182} -returnCodes error -result {bad level "4294967295"} 183test uplevel-4.28 {level parsing} -body { 184 apply {{} {uplevel #[expr 0xffffffff] {}}} 185} -returnCodes error -result {bad level "#4294967295"} 186test uplevel-4.29 {level parsing} -body { 187 apply {{} {uplevel 0.2 {}}} 188} -returnCodes error -result {invalid command name "0.2"} 189test uplevel-4.30 {level parsing} -body { 190 apply {{} {uplevel #0.2 {}}} 191} -returnCodes error -result {bad level "#0.2"} 192test uplevel-4.31 {level parsing} -body { 193 apply {{} {uplevel [expr 0.2] {}}} 194} -returnCodes error -result {invalid command name "0.2"} 195test uplevel-4.32 {level parsing} -body { 196 apply {{} {uplevel #[expr 0.2] {}}} 197} -returnCodes error -result {bad level "#0.2"} 198test uplevel-4.33 {level parsing} -body { 199 apply {{} {uplevel .2 {}}} 200} -returnCodes error -result {invalid command name ".2"} 201test uplevel-4.34 {level parsing} -body { 202 apply {{} {uplevel #.2 {}}} 203} -returnCodes error -result {bad level "#.2"} 204test uplevel-4.35 {level parsing} -body { 205 apply {{} {uplevel [expr .2] {}}} 206} -returnCodes error -result {invalid command name "0.2"} 207test uplevel-4.36 {level parsing} -body { 208 apply {{} {uplevel #[expr .2] {}}} 209} -returnCodes error -result {bad level "#0.2"} 210 211 212 213 214proc a2 {} { 215 uplevel a3 216} 217proc a3 {} { 218 global x y 219 set x [info level] 220 set y [info level 1] 221} 222a2 223test uplevel-5.1 {info level} {set x} 1 224test uplevel-5.2 {info level} {set y} a3 225 226namespace eval ns1 { 227 proc set args {return ::ns1} 228} 229proc a2 {} { 230 uplevel {set x ::} 231} 232test uplevel-6.1 {uplevel and shadowed cmds} { 233 set res [namespace eval ns1 a2] 234 lappend res [namespace eval ns2 a2] 235 lappend res [namespace eval ns1 a2] 236 namespace eval ns1 {rename set {}} 237 lappend res [namespace eval ns1 a2] 238} {::ns1 :: ::ns1 ::} 239 240# 241# These tests verify that upleveled scripts run in the correct level and access 242# the proper variables. 243# 244 245test uplevel-7.1 {var access, no LVT in either level} -setup { 246 set x 1 247 unset -nocomplain y z 248} -body { 249 namespace eval foo { 250 set x 2 251 set y 2 252 uplevel 1 { 253 set x 3 254 set y 3 255 set z 3 256 } 257 } 258 list $x $y $z 259} -cleanup { 260 namespace delete foo 261 unset -nocomplain x y z 262} -result {3 3 3} 263 264test uplevel-7.2 {var access, no LVT in upper level} -setup { 265 set x 1 266 unset -nocomplain y z 267} -body { 268 proc foo {} { 269 set x 2 270 set y 2 271 uplevel 1 { 272 set x 3 273 set y 3 274 set z 3 275 } 276 } 277 foo 278 list $x $y $z 279} -cleanup { 280 rename foo {} 281 unset -nocomplain x y z 282} -result {3 3 3} 283 284test uplevel-7.3 {var access, LVT in upper level} -setup { 285 proc moo {} { 286 set x 1; #var in LVT 287 unset -nocomplain y z 288 foo 289 list $x $y $z 290 } 291} -body { 292 proc foo {} { 293 set x 2 294 set y 2 295 uplevel 1 { 296 set x 3 297 set y 3 298 set z 3 299 } 300 } 301 foo 302 moo 303} -cleanup { 304 rename foo {} 305 rename moo {} 306} -result {3 3 3} 307 308 309test uplevel-8.0 { 310 string representation isn't generated when there is only one argument 311} -body { 312 set res {} 313 set script [list lindex 5] 314 lappend res [apply {script { 315 uplevel $script 316 }} $script] 317 lappend res [string match {value is a list *no string representation*} [ 318 ::tcl::unsupported::representation $script]] 319} -cleanup { 320 unset script 321 unset res 322} -result {5 1} 323 324 325# cleanup 326::tcltest::cleanupTests 327return 328 329# Local Variables: 330# mode: tcl 331# fill-column: 78 332# End: 333