1# Commands covered: upvar 2# 3# This file contains a collection of tests for one or more of the Tcl 4# built-in commands. Sourcing this file into Tcl runs the tests and 5# generates output for errors. No output means no errors were found. 6# 7# Copyright (c) 1991-1993 The Regents of the University of California. 8# Copyright (c) 1994 Sun Microsystems, Inc. 9# Copyright (c) 1998-1999 by Scriptics Corporation. 10# 11# See the file "license.terms" for information on usage and redistribution 12# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13# 14# RCS: @(#) $Id: upvar.test,v 1.7 2000/04/10 17:19:05 ericm Exp $ 15 16source [file dirname [info script]]/testing.tcl 17 18needs cmd array 19 20test upvar-1.1 {reading variables with upvar} { 21 proc p1 {a b} {set c 22; set d 33; p2} 22 proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a} 23 p1 foo bar 24} {foo bar 22 33 abc} 25test upvar-1.2 {reading variables with upvar} { 26 proc p1 {a b} {set c 22; set d 33; p2} 27 proc p2 {} {p3} 28 proc p3 {} {upvar 2 a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a} 29 p1 foo bar 30} {foo bar 22 33 abc} 31test upvar-1.3 {reading variables with upvar} { 32 proc p1 {a b} {set c 22; set d 33; p2} 33 proc p2 {} {p3} 34 proc p3 {} { 35 upvar #1 a x1 b x2 c x3 d x4 36 set a abc 37 list $x1 $x2 $x3 $x4 $a 38 } 39 p1 foo bar 40} {foo bar 22 33 abc} 41test upvar-1.4 {reading variables with upvar} { 42 set x1 44 43 set x2 55 44 proc p1 {} {p2} 45 proc p2 {} { 46 upvar 2 x1 x1 x2 a 47 upvar #0 x1 b 48 set c $b 49 incr b 3 50 list $x1 $a $b 51 } 52 p1 53} {47 55 47} 54test upvar-1.5 {reading array elements with upvar} { 55 proc p1 {} {set a(0) zeroth; set a(1) first; p2} 56 proc p2 {} {upvar a(0) x; set x} 57 p1 58} {zeroth} 59 60test upvar-2.1 {writing variables with upvar} { 61 proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d} 62 proc p2 {} { 63 upvar a x1 b x2 c x3 d x4 64 set x1 14 65 set x4 88 66 } 67 p1 foo bar 68} {14 bar 22 88} 69test upvar-2.2 {writing variables with upvar} { 70 set x1 44 71 set x2 55 72 proc p1 {x1 x2} { 73 upvar #0 x1 a 74 upvar x2 b 75 set a $x1 76 set b $x2 77 } 78 p1 newbits morebits 79 list $x1 $x2 80} {newbits morebits} 81test upvar-2.3 {writing variables with upvar} { 82 catch {unset x1} 83 catch {unset x2} 84 proc p1 {x1 x2} { 85 upvar #0 x1 a 86 upvar x2 b 87 set a $x1 88 set b $x2 89 } 90 p1 newbits morebits 91 list [catch {set x1} msg] $msg [catch {set x2} msg] $msg 92} {0 newbits 0 morebits} 93test upvar-2.4 {writing array elements with upvar} { 94 proc p1 {} {set a(0) zeroth; set a(1) first; list [p2] $a(0)} 95 proc p2 {} {upvar a(0) x; set x xyzzy} 96 p1 97} {xyzzy xyzzy} 98 99test upvar-3.1 {unsetting variables with upvar} { 100 proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]} 101 proc p2 {} { 102 upvar 1 a x1 d x2 103 unset x1 x2 104 } 105 p1 foo bar 106} {b c} 107test upvar-3.2 {unsetting variables with upvar} { 108 proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]} 109 proc p2 {} { 110 upvar 1 a x1 d x2 111 unset x1 x2 112 set x2 28 113 } 114 p1 foo bar 115} {b c d} 116test upvar-3.3 {unsetting variables with upvar} { 117 set x1 44 118 set x2 55 119 proc p1 {} {p2} 120 proc p2 {} { 121 upvar 2 x1 a 122 upvar #0 x2 b 123 unset a b 124 } 125 p1 126 list [info exists x1] [info exists x2] 127} {0 0} 128test upvar-3.4 {unsetting variables with upvar} { 129 set x1 44 130 set x2 55 131 proc p1 {} { 132 upvar x1 a x2 b 133 unset a b 134 set b 118 135 } 136 p1 137 list [info exists x1] [catch {set x2} msg] $msg 138} {0 0 118} 139test upvar-3.5 {unsetting array elements with upvar} { 140 proc p1 {} { 141 set a(0) zeroth 142 set a(1) first 143 set a(2) second 144 p2 145 lsort [array names a] 146 } 147 proc p2 {} {upvar a(0) x; unset x} 148 p1 149} {1 2} 150test upvar-3.6 {unsetting then resetting array elements with upvar} { 151 proc p1 {} { 152 set a(0) zeroth 153 set a(1) first 154 set a(2) second 155 p2 156 list [lsort [array names a]] [catch {set a(0)} msg] $msg 157 } 158 proc p2 {} {upvar a(0) x; unset x; set x 12345} 159 p1 160} {{0 1 2} 0 12345} 161 162test upvar-4.1 {nested upvars} { 163 set x1 88 164 proc p1 {a b} {set c 22; set d 33; p2} 165 proc p2 {} {global x1; upvar c x2; p3} 166 proc p3 {} { 167 upvar x1 a x2 b 168 list $a $b 169 } 170 p1 14 15 171} {88 22} 172test upvar-4.2 {nested upvars} { 173 set x1 88 174 proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d} 175 proc p2 {} {global x1; upvar c x2; p3} 176 proc p3 {} { 177 upvar x1 a x2 b 178 set a foo 179 set b bar 180 } 181 list [p1 14 15] $x1 182} {{14 15 bar 33} foo} 183 184proc tproc {args} {global x; set x [list $args [uplevel info vars]]} 185 186test upvar-6.1 {retargeting an upvar} { 187 proc p1 {} { 188 set a(0) zeroth 189 set a(1) first 190 set a(2) second 191 p2 192 } 193 proc p2 {} { 194 upvar a x 195 set result {} 196 foreach i [array names x] { 197 upvar a($i) x 198 lappend result $x 199 } 200 lsort $result 201 } 202 p1 203} {first second zeroth} 204test upvar-6.2 {retargeting an upvar} { 205 set x 44 206 set y abcde 207 proc p1 {} { 208 global x 209 set result $x 210 upvar y x 211 lappend result $x 212 } 213 p1 214} {44 abcde} 215test upvar-6.3 {retargeting an upvar} { 216 set x 44 217 set y abcde 218 proc p1 {} { 219 upvar y x 220 lappend result $x 221 global x 222 lappend result $x 223 } 224 p1 225} {abcde 44} 226 227test upvar-7.1 {upvar to same level} { 228 set x 44 229 set y 55 230 catch {unset uv} 231 upvar #0 x uv 232 set uv abc 233 upvar 0 y uv 234 set uv xyzzy 235 list $x $y 236} {abc xyzzy} 237test upvar-7.2 {upvar to same level} { 238 set x 1234 239 set y 4567 240 proc p1 {x y} { 241 upvar 0 x uv 242 set uv $y 243 return "$x $y" 244 } 245 p1 44 89 246} {89 89} 247test upvar-7.3 {upvar to same level} { 248 set x 1234 249 set y 4567 250 proc p1 {x y} { 251 upvar #1 x uv 252 set uv $y 253 return "$x $y" 254 } 255 p1 xyz abc 256} {abc abc} 257test upvar-7.4 {upvar to same level: tricky problems when deleting variable table} { 258 proc tt {} {upvar #1 toto loc; return $loc} 259 list [catch tt msg] $msg 260} {1 {can't read "loc": no such variable}} 261test upvar-7.5 {potential memory leak when deleting variable table} { 262 proc leak {} { 263 array set foo {1 2 3 4} 264 upvar 0 foo(1) bar 265 } 266 leak 267} {} 268 269test upvar-8.1 {errors in upvar command} { 270 catch upvar msg 271} 1 272test upvar-8.2 {errors in upvar command} { 273 catch {upvar 1} 274} 1 275test upvar-8.3 {errors in upvar command} { 276 proc p1 {} {upvar a b c} 277 catch p1 278} 1 279test upvar-8.4 {errors in upvar command} { 280 proc p1 {} {upvar 0 b b} 281 list [catch p1 msg] $msg 282} {1 {can't upvar from variable to itself}} 283test upvar-8.5 {errors in upvar command} { 284 proc p1 {} {upvar 0 a b; upvar 0 b a} 285 list [catch p1 msg] $msg 286} {1 {can't upvar from variable to itself}} 287test upvar-8.6 {errors in upvar command} { 288 proc p1 {} {set a 33; upvar b a} 289 list [catch p1 msg] $msg 290} {1 {variable "a" already exists}} 291# Jim allows dicts within dicts. Tcl can't do this. 292test upvar-8.8 {create nested array with upvar} jim { 293 proc p1 {} {upvar x(a) b; set b(2) 44} 294 catch {unset x} 295 p1 296 set x 297} {a {2 44}} 298test upvar-8.10 {upvar will create element alias for new array element} { 299 catch {unset upvarArray} 300 array set upvarArray {} 301 catch {upvar 0 upvarArray(elem) upvarArrayElemAlias} 302} {0} 303test upvar-8.11 {error upvar array element} { 304 proc a {} { upvar a b(1) } 305 list [catch {a} msg] $msg 306} {1 {bad variable name "b(1)": upvar won't create a scalar variable that looks like an array element}} 307test upvar-9.1 {global redefine} { 308 proc p1 {} { global x; global x } 309 p1 310} {} 311test upvar-9.2 {upvar redefine} { 312 set a 1 313 set b 2 314 proc p1 {} { upvar a x; upvar b x; return $x } 315 p1 316} 2 317test upvar-9.3 {upvar redefine static} jim { 318 proc p1 {} {{a 3}} { upvar b a; return $b } 319 list [catch p1 msg] $msg 320} {1 {variable "a" already exists}} 321test upvar-9.4 {upvar links to static} jim { 322 proc p1 {} {} { upvar a x; incr x; return $x } 323 proc p2 {} {{a 3}} { list [p1] $a } 324 p2 325} {4 4} 326test upvar-9.5 {upvar via global namespace} { 327 set x 2 328 unset -nocomplain y 329 # Links ::y to ::x 330 proc p1 {} { upvar x ::y; incr ::y -1 } 331 p1 332 list $x $y 333} {1 1} 334 335test upvar-9.6 {upvar via global namespace} { 336 set x 2 337 unset -nocomplain x 338 # Links ::x to ::x 339 proc p1 {} { upvar x ::x; incr ::x } 340 list [catch p1 msg] $msg 341} {1 {can't upvar from variable to itself}} 342 343test upvar-9.7 {upvar to higher level} { 344 proc p1 {} { upvar 0 x ::globx } 345 list [catch p1 msg] $msg 346} {1 {bad variable name "::globx": upvar won't create namespace variable that refers to procedure variable}} 347 348catch {unset a} 349 350testreport 351