1# Commands covered: 'upvar', 'namespace upvar' 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 19::tcltest::loadTestedCommands 20catch [list package require -exact tcl::test [info patchlevel]] 21 22testConstraint testupvar [llength [info commands testupvar]] 23 24test upvar-1.1 {reading variables with upvar} { 25 proc p1 {a b} {set c 22; set d 33; p2} 26 proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a} 27 p1 foo bar 28} {foo bar 22 33 abc} 29test upvar-1.2 {reading variables with upvar} { 30 proc p1 {a b} {set c 22; set d 33; p2} 31 proc p2 {} {p3} 32 proc p3 {} {upvar 2 a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a} 33 p1 foo bar 34} {foo bar 22 33 abc} 35test upvar-1.3 {reading variables with upvar} { 36 proc p1 {a b} {set c 22; set d 33; p2} 37 proc p2 {} {p3} 38 proc p3 {} { 39 upvar #1 a x1 b x2 c x3 d x4 40 set a abc 41 list $x1 $x2 $x3 $x4 $a 42 } 43 p1 foo bar 44} {foo bar 22 33 abc} 45test upvar-1.4 {reading variables with upvar} { 46 set x1 44 47 set x2 55 48 proc p1 {} {p2} 49 proc p2 {} { 50 upvar 2 x1 x1 x2 a 51 upvar #0 x1 b 52 set c $b 53 incr b 3 54 list $x1 $a $b 55 } 56 p1 57} {47 55 47} 58test upvar-1.5 {reading array elements with upvar} { 59 proc p1 {} {set a(0) zeroth; set a(1) first; p2} 60 proc p2 {} {upvar a(0) x; set x} 61 p1 62} {zeroth} 63 64test upvar-2.1 {writing variables with upvar} { 65 proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d} 66 proc p2 {} { 67 upvar a x1 b x2 c x3 d x4 68 set x1 14 69 set x4 88 70 } 71 p1 foo bar 72} {14 bar 22 88} 73test upvar-2.2 {writing variables with upvar} { 74 set x1 44 75 set x2 55 76 proc p1 {x1 x2} { 77 upvar #0 x1 a 78 upvar x2 b 79 set a $x1 80 set b $x2 81 } 82 p1 newbits morebits 83 list $x1 $x2 84} {newbits morebits} 85test upvar-2.3 {writing variables with upvar} { 86 catch {unset x1} 87 catch {unset x2} 88 proc p1 {x1 x2} { 89 upvar #0 x1 a 90 upvar x2 b 91 set a $x1 92 set b $x2 93 } 94 p1 newbits morebits 95 list [catch {set x1} msg] $msg [catch {set x2} msg] $msg 96} {0 newbits 0 morebits} 97test upvar-2.4 {writing array elements with upvar} { 98 proc p1 {} {set a(0) zeroth; set a(1) first; list [p2] $a(0)} 99 proc p2 {} {upvar a(0) x; set x xyzzy} 100 p1 101} {xyzzy xyzzy} 102 103test upvar-3.1 {unsetting variables with upvar} { 104 proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]} 105 proc p2 {} { 106 upvar 1 a x1 d x2 107 unset x1 x2 108 } 109 p1 foo bar 110} {b c} 111test upvar-3.2 {unsetting variables with upvar} { 112 proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]} 113 proc p2 {} { 114 upvar 1 a x1 d x2 115 unset x1 x2 116 set x2 28 117 } 118 p1 foo bar 119} {b c d} 120test upvar-3.3 {unsetting variables with upvar} { 121 set x1 44 122 set x2 55 123 proc p1 {} {p2} 124 proc p2 {} { 125 upvar 2 x1 a 126 upvar #0 x2 b 127 unset a b 128 } 129 p1 130 list [info exists x1] [info exists x2] 131} {0 0} 132test upvar-3.4 {unsetting variables with upvar} { 133 set x1 44 134 set x2 55 135 proc p1 {} { 136 upvar x1 a x2 b 137 unset a b 138 set b 118 139 } 140 p1 141 list [info exists x1] [catch {set x2} msg] $msg 142} {0 0 118} 143test upvar-3.5 {unsetting array elements with upvar} { 144 proc p1 {} { 145 set a(0) zeroth 146 set a(1) first 147 set a(2) second 148 p2 149 array names a 150 } 151 proc p2 {} {upvar a(0) x; unset x} 152 lsort [p1] 153} {1 2} 154test upvar-3.6 {unsetting then resetting array elements with upvar} { 155 proc p1 {} { 156 set a(0) zeroth 157 set a(1) first 158 set a(2) second 159 p2 160 list [lsort [array names a]] [catch {set a(0)} msg] $msg 161 } 162 proc p2 {} {upvar a(0) x; unset x; set x 12345} 163 p1 164} {{0 1 2} 0 12345} 165 166test upvar-4.1 {nested upvars} { 167 set x1 88 168 proc p1 {a b} {set c 22; set d 33; p2} 169 proc p2 {} {global x1; upvar c x2; p3} 170 proc p3 {} { 171 upvar x1 a x2 b 172 list $a $b 173 } 174 p1 14 15 175} {88 22} 176test upvar-4.2 {nested upvars} { 177 set x1 88 178 proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d} 179 proc p2 {} {global x1; upvar c x2; p3} 180 proc p3 {} { 181 upvar x1 a x2 b 182 set a foo 183 set b bar 184 } 185 list [p1 14 15] $x1 186} {{14 15 bar 33} foo} 187 188proc tproc {args} {global x; set x [list $args [uplevel info vars]]} 189test upvar-5.1 {traces involving upvars} { 190 proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2} 191 proc p2 {} {upvar c x1; set x1 22} 192 set x --- 193 p1 foo bar 194 set x 195} {{x1 {} w} x1} 196test upvar-5.2 {traces involving upvars} { 197 proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2} 198 proc p2 {} {upvar c x1; set x1} 199 set x --- 200 p1 foo bar 201 set x 202} {{x1 {} r} x1} 203test upvar-5.3 {traces involving upvars} { 204 proc p1 {a b} {set c 22; set d 33; trace var c rwu tproc; p2} 205 proc p2 {} {upvar c x1; unset x1} 206 set x --- 207 p1 foo bar 208 set x 209} {{x1 {} u} x1} 210 211test upvar-6.1 {retargeting an upvar} { 212 proc p1 {} { 213 set a(0) zeroth 214 set a(1) first 215 set a(2) second 216 p2 217 } 218 proc p2 {} { 219 upvar a x 220 set result {} 221 foreach i [array names x] { 222 upvar a($i) x 223 lappend result $x 224 } 225 lsort $result 226 } 227 p1 228} {first second zeroth} 229test upvar-6.2 {retargeting an upvar} { 230 set x 44 231 set y abcde 232 proc p1 {} { 233 global x 234 set result $x 235 upvar y x 236 lappend result $x 237 } 238 p1 239} {44 abcde} 240test upvar-6.3 {retargeting an upvar} { 241 set x 44 242 set y abcde 243 proc p1 {} { 244 upvar y x 245 lappend result $x 246 global x 247 lappend result $x 248 } 249 p1 250} {abcde 44} 251 252 253 254test upvar-6.4 { 255 retargeting a variable created by upvar to itself is allowed 256} -body { 257 catch { 258 unset x 259 } 260 catch { 261 unset y 262 } 263 set res {} 264 set x abcde 265 set res [catch { 266 upvar 0 x x 267 } cres copts] 268 lappend res [dict get $copts -errorcode] 269 upvar 0 x y 270 lappend res $y 271 upvar 0 y y 272 lappend res $y 273 return $res 274} -cleanup { 275 upvar 0 {} y 276} -result {1 {TCL UPVAR SELF} abcde abcde} 277 278 279test upvar-7.1 {upvar to same level} { 280 set x 44 281 set y 55 282 catch {unset uv} 283 upvar #0 x uv 284 set uv abc 285 upvar 0 y uv 286 set uv xyzzy 287 list $x $y 288} {abc xyzzy} 289test upvar-7.2 {upvar to same level} { 290 set x 1234 291 set y 4567 292 proc p1 {x y} { 293 upvar 0 x uv 294 set uv $y 295 return "$x $y" 296 } 297 p1 44 89 298} {89 89} 299test upvar-7.3 {upvar to same level} { 300 set x 1234 301 set y 4567 302 proc p1 {x y} { 303 upvar #1 x uv 304 set uv $y 305 return "$x $y" 306 } 307 p1 xyz abc 308} {abc abc} 309test upvar-7.4 {upvar to same level: tricky problems when deleting variable table} { 310 proc tt {} {upvar #1 toto loc; return $loc} 311 list [catch tt msg] $msg 312} {1 {can't read "loc": no such variable}} 313test upvar-7.5 {potential memory leak when deleting variable table} { 314 proc leak {} { 315 array set foo {1 2 3 4} 316 upvar 0 foo(1) bar 317 } 318 leak 319} {} 320 321test upvar-8.1 {errors in upvar command} -returnCodes error -body { 322 upvar 323} -result {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"} 324test upvar-8.2 {errors in upvar command} -returnCodes error -body { 325 upvar 1 326} -result {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"} 327test upvar-8.2.1 {upvar with numeric first argument} { 328 apply {{} {set 0 ok; apply {{} {upvar 0 x; return $x}}}} 329} ok 330test upvar-8.3 {errors in upvar command} -returnCodes error -body { 331 proc p1 {} {upvar a b c} 332 p1 333} -result {bad level "a"} 334test upvar-8.3.1 {bad level for upvar (upvar at top-level, bug [775ee88560])} -body { 335 proc p1 {} { uplevel { upvar b b; lappend b UNEXPECTED } } 336 uplevel #0 { p1 } 337} -returnCodes error -result {bad level "1"} 338test upvar-8.3.2 {bad level for upvar (upvar at top-level, bug [775ee88560])} -setup { 339 interp create i 340} -body { 341 i eval { upvar b b; lappend b UNEXPECTED } 342} -returnCodes error -result {bad level "1"} -cleanup { 343 interp delete i 344} 345test upvar-8.4 {errors in upvar command} -returnCodes error -body { 346 proc p1 {} {upvar 0 b b} 347 p1 348} -result {can't upvar from variable to itself} 349test upvar-8.5 {errors in upvar command} -returnCodes error -body { 350 proc p1 {} {upvar 0 a b; upvar 0 b a} 351 p1 352} -result {can't upvar from variable to itself} 353test upvar-8.6 {errors in upvar command} -returnCodes error -body { 354 proc p1 {} {set a 33; upvar b a} 355 p1 356} -result {variable "a" already exists} 357test upvar-8.7 {errors in upvar command} -returnCodes error -body { 358 proc p1 {} {trace variable a w foo; upvar b a} 359 p1 360} -result {variable "a" has traces: can't use for upvar} 361test upvar-8.8 {create nested array with upvar} -body { 362 proc p1 {} {upvar x(a) b; set b(2) 44} 363 catch {unset x} 364 p1 365} -returnCodes error -cleanup { 366 unset x 367} -result {can't set "b(2)": variable isn't array} 368test upvar-8.9 {upvar won't create namespace variable that refers to procedure variable} -setup { 369 catch {namespace delete {*}[namespace children :: test_ns_*]} 370 catch {rename MakeLink ""} 371 namespace eval ::test_ns_1 {} 372} -returnCodes error -body { 373 proc MakeLink {a} { 374 namespace eval ::test_ns_1 { 375 upvar a a 376 } 377 unset ::test_ns_1::a 378 } 379 MakeLink 1 380} -result {bad variable name "a": can't create namespace variable that refers to procedure variable} 381test upvar-8.10 {upvar will create element alias for new array element} -setup { 382 catch {unset upvarArray} 383} -body { 384 array set upvarArray {} 385 catch {upvar 0 upvarArray(elem) upvarArrayElemAlias} 386} -result {0} 387test upvar-8.11 {upvar will not create a variable that looks like an array} -setup { 388 catch {unset upvarArray} 389} -body { 390 array set upvarArray {} 391 upvar 0 upvarArray(elem) upvarArrayElemAlias(elem) 392} -returnCodes 1 -match glob -result * 393 394test upvar-9.1 {Tcl_UpVar2 procedure} testupvar { 395 list [catch {testupvar xyz a {} x global} msg] $msg 396} {1 {bad level "1"}} 397test upvar-9.1.1 {TclGetFrame, via Tcl_UpVar2} testupvar { 398 apply {{} {testupvar xyz a {} x local; set x foo}} 399 set a 400} foo 401test upvar-9.2 {Tcl_UpVar2 procedure} testupvar { 402 catch {unset a} 403 catch {unset x} 404 set a 44 405 list [catch "testupvar #0 a 1 x global" msg] $msg 406} {1 {can't access "a(1)": variable isn't array}} 407test upvar-9.3 {Tcl_UpVar2 procedure} testupvar { 408 proc foo {} { 409 testupvar 1 a {} x local 410 set x 411 } 412 catch {unset a} 413 catch {unset x} 414 set a 44 415 foo 416} {44} 417test upvar-9.4 {Tcl_UpVar2 procedure} testupvar { 418 proc foo {} { 419 testupvar 1 a {} _up_ global 420 list [catch {set x} msg] $msg 421 } 422 catch {unset a} 423 catch {unset _up_} 424 set a 44 425 concat [foo] $_up_ 426} {1 {can't read "x": no such variable} 44} 427test upvar-9.5 {Tcl_UpVar2 procedure} testupvar { 428 proc foo {} { 429 testupvar 1 a b x local 430 set x 431 } 432 catch {unset a} 433 catch {unset x} 434 set a(b) 1234 435 foo 436} {1234} 437test upvar-9.6 {Tcl_UpVar procedure} testupvar { 438 proc foo {} { 439 testupvar 1 a x local 440 set x 441 } 442 catch {unset a} 443 catch {unset x} 444 set a xyzzy 445 foo 446} {xyzzy} 447test upvar-9.7 {Tcl_UpVar procedure} testupvar { 448 proc foo {} { 449 testupvar #0 a(b) x local 450 set x 451 } 452 catch {unset a} 453 catch {unset x} 454 set a(b) 1234 455 foo 456} {1234} 457catch {unset a} 458 459test upvar-10.1 {CompileWord OBOE} -setup { 460 proc linenumber {} {dict get [info frame -1] line} 461} -body { 462 apply {n { 463 upvar 1 {*}{ 464 } [return [incr n -[linenumber]]] x 465 }} [linenumber] 466} -cleanup { 467 rename linenumber {} 468} -result 1 469 470# 471# Tests for 'namespace upvar'. As the implementation is essentially the same as 472# for 'upvar', we only test that the variables are linked correctly, i.e., we 473# assume that the behaviour of variables once the link is established has 474# already been tested above. 475# 476 477# Clear out any namespaces called test_ns_* 478catch {namespace delete {*}[namespace children :: test_ns_*]} 479namespace eval test_ns_0 { 480 variable x test_ns_0 481} 482set ::x test_global 483 484test upvar-NS-1.1 {nsupvar links to correct variable} -body { 485 namespace eval test_ns_1 { 486 namespace upvar ::test_ns_0 x w 487 set w 488 } 489} -result {test_ns_0} -cleanup { 490 namespace delete test_ns_1 491} 492test upvar-NS-1.2 {nsupvar links to correct variable} -body { 493 namespace eval test_ns_1 { 494 proc a {} { 495 namespace upvar ::test_ns_0 x w 496 set w 497 } 498 return [a] 499 } 500} -result {test_ns_0} -cleanup { 501 namespace delete test_ns_1 502} 503test upvar-NS-1.3 {nsupvar links to correct variable} -body { 504 namespace eval test_ns_1 { 505 namespace upvar test_ns_0 x w 506 set w 507 } 508} -returnCodes error -cleanup { 509 namespace delete test_ns_1 510} -result {namespace "test_ns_0" not found in "::test_ns_1"} 511test upvar-NS-1.4 {nsupvar links to correct variable} -body { 512 namespace eval test_ns_1 { 513 proc a {} { 514 namespace upvar test_ns_0 x w 515 set w 516 } 517 return [a] 518 } 519} -returnCodes error -cleanup { 520 namespace delete test_ns_1 521} -result {namespace "test_ns_0" not found in "::test_ns_1"} 522 523test upvar-NS-1.5 {nsupvar links to correct variable} -body { 524 namespace eval test_ns_1 { 525 namespace eval test_ns_0 {} 526 namespace upvar test_ns_0 x w 527 set w 528 } 529} -cleanup { 530 namespace delete test_ns_1 531} -result {can't read "w": no such variable} -returnCodes error 532test upvar-NS-1.6 {nsupvar links to correct variable} -body { 533 namespace eval test_ns_1 { 534 namespace eval test_ns_0 {} 535 proc a {} { 536 namespace upvar test_ns_0 x w 537 set w 538 } 539 return [a] 540 } 541} -cleanup { 542 namespace delete test_ns_1 543} -result {can't read "w": no such variable} -returnCodes error 544test upvar-NS-1.7 {nsupvar links to correct variable} -body { 545 namespace eval test_ns_1 { 546 namespace eval test_ns_0 { 547 variable x test_ns_1::test_ns_0 548 } 549 namespace upvar test_ns_0 x w 550 set w 551 } 552} -cleanup { 553 namespace delete test_ns_1 554} -result {test_ns_1::test_ns_0} 555test upvar-NS-1.8 {nsupvar links to correct variable} -body { 556 namespace eval test_ns_1 { 557 namespace eval test_ns_0 { 558 variable x test_ns_1::test_ns_0 559 } 560 proc a {} { 561 namespace upvar test_ns_0 x w 562 set w 563 } 564 return [a] 565 } 566} -cleanup { 567 namespace delete test_ns_1 568} -result {test_ns_1::test_ns_0} 569test upvar-NS-1.9 {nsupvar links to correct variable} -body { 570 namespace eval test_ns_1 { 571 variable x test_ns_1 572 proc a {} { 573 namespace upvar test_ns_0 x w 574 set w 575 } 576 return [a] 577 } 578} -returnCodes error -cleanup { 579 namespace delete test_ns_1 580} -result {namespace "test_ns_0" not found in "::test_ns_1"} 581 582test upvar-NS-2.1 {TIP 323} -returnCodes error -body { 583 namespace upvar 584} -result {wrong # args: should be "namespace upvar ns ?otherVar myVar ...?"} 585test upvar-NS-2.2 {TIP 323} -setup { 586 namespace eval test_ns_1 {} 587} -body { 588 namespace upvar test_ns_1 589} -cleanup { 590 namespace delete test_ns_1 591} -result {} 592 593test upvar-NS-3.1 {CompileWord OBOE} -setup { 594 proc linenumber {} {dict get [info frame -1] line} 595} -body { 596 apply {n { 597 namespace upvar {*}{ 598 } [return [incr n -[linenumber]]] x y 599 }} [linenumber] 600} -cleanup { 601 rename linenumber {} 602} -result 1 603test upvar-NS-3.2 {CompileWord OBOE} -setup { 604 proc linenumber {} {dict get [info frame -1] line} 605} -body { 606 apply {n { 607 namespace upvar :: {*}{ 608 } [return [incr n -[linenumber]]] x 609 }} [linenumber] 610} -cleanup { 611 rename linenumber {} 612} -result 1 613test upvar-NS-3.3 {CompileWord OBOE} -setup { 614 proc linenumber {} {dict get [info frame -1] line} 615} -body { 616 apply {n { 617 variable x {*}{ 618 } [return [incr n -[linenumber]]] 619 }} [linenumber] 620} -cleanup { 621 rename linenumber {} 622} -result 1 623 624# cleanup 625::tcltest::cleanupTests 626return 627 628# Local Variables: 629# mode: tcl 630# End: 631