tests/upvar.test

   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
  16 source [file dirname [info script]]/testing.tcl
  17
  18 needs cmd array
  19
  20 test 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}
  25 test 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}
  31 test 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}
  41 test 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}
  54 test 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
  60 test 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}
  69 test 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}
  81 test 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}
  93 test 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
  99 test 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}
 107 test 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}
 116 test 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}
 128 test 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}
 139 test 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}
 150 test 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
 162 test 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}
 172 test 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
 184 proc tproc {args} {global x; set x [list $args [uplevel info vars]]}
 185
 186 test 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}
 204 test 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}
 215 test 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
 227 test 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}
 237 test 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}
 247 test 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}
 257 test 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}}
 261 test 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
 269 test upvar-8.1 {errors in upvar command} {
 270     catch upvar msg
 271 } 1
 272 test upvar-8.2 {errors in upvar command} {
 273     catch {upvar 1}
 274 } 1
 275 test upvar-8.3 {errors in upvar command} {
 276     proc p1 {} {upvar a b c}
 277     catch p1
 278 } 1
 279 test 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}}
 283 test 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}}
 287 test 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.
 292 test 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}}
 298 test 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}
 303 test 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}}
 307 test upvar-9.1 {global redefine} {
 308     proc p1 {} { global x; global x }
 309     p1
 310 } {}
 311 test 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
 317 test 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}}
 321 test 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}
 326 test 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
 335 test 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
 343 test 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
 348 catch {unset a}
 349
 350 testreport