diff options
Diffstat (limited to 'tests/upvar.test')
| -rw-r--r-- | tests/upvar.test | 394 |
1 files changed, 394 insertions, 0 deletions
diff --git a/tests/upvar.test b/tests/upvar.test new file mode 100644 index 0000000..d9548b0 --- /dev/null +++ b/tests/upvar.test @@ -0,0 +1,394 @@ +# Commands covered: upvar +# +# 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. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) upvar.test 1.15 97/10/29 18:25:56 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test upvar-1.1 {reading variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2} + proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a} + p1 foo bar +} {foo bar 22 33 abc} +test upvar-1.2 {reading variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2} + proc p2 {} {p3} + proc p3 {} {upvar 2 a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a} + p1 foo bar +} {foo bar 22 33 abc} +test upvar-1.3 {reading variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2} + proc p2 {} {p3} + proc p3 {} { + upvar #1 a x1 b x2 c x3 d x4 + set a abc + list $x1 $x2 $x3 $x4 $a + } + p1 foo bar +} {foo bar 22 33 abc} +test upvar-1.4 {reading variables with upvar} { + set x1 44 + set x2 55 + proc p1 {} {p2} + proc p2 {} { + upvar 2 x1 x1 x2 a + upvar #0 x1 b + set c $b + incr b 3 + list $x1 $a $b + } + p1 +} {47 55 47} +test upvar-1.5 {reading array elements with upvar} { + proc p1 {} {set a(0) zeroth; set a(1) first; p2} + proc p2 {} {upvar a(0) x; set x} + p1 +} {zeroth} + +test upvar-2.1 {writing variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d} + proc p2 {} { + upvar a x1 b x2 c x3 d x4 + set x1 14 + set x4 88 + } + p1 foo bar +} {14 bar 22 88} +test upvar-2.2 {writing variables with upvar} { + set x1 44 + set x2 55 + proc p1 {x1 x2} { + upvar #0 x1 a + upvar x2 b + set a $x1 + set b $x2 + } + p1 newbits morebits + list $x1 $x2 +} {newbits morebits} +test upvar-2.3 {writing variables with upvar} { + catch {unset x1} + catch {unset x2} + proc p1 {x1 x2} { + upvar #0 x1 a + upvar x2 b + set a $x1 + set b $x2 + } + p1 newbits morebits + list [catch {set x1} msg] $msg [catch {set x2} msg] $msg +} {0 newbits 0 morebits} +test upvar-2.4 {writing array elements with upvar} { + proc p1 {} {set a(0) zeroth; set a(1) first; list [p2] $a(0)} + proc p2 {} {upvar a(0) x; set x xyzzy} + p1 +} {xyzzy xyzzy} + +test upvar-3.1 {unsetting variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]} + proc p2 {} { + upvar 1 a x1 d x2 + unset x1 x2 + } + p1 foo bar +} {b c} +test upvar-3.2 {unsetting variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]} + proc p2 {} { + upvar 1 a x1 d x2 + unset x1 x2 + set x2 28 + } + p1 foo bar +} {b c d} +test upvar-3.3 {unsetting variables with upvar} { + set x1 44 + set x2 55 + proc p1 {} {p2} + proc p2 {} { + upvar 2 x1 a + upvar #0 x2 b + unset a b + } + p1 + list [info exists x1] [info exists x2] +} {0 0} +test upvar-3.4 {unsetting variables with upvar} { + set x1 44 + set x2 55 + proc p1 {} { + upvar x1 a x2 b + unset a b + set b 118 + } + p1 + list [info exists x1] [catch {set x2} msg] $msg +} {0 0 118} +test upvar-3.5 {unsetting array elements with upvar} { + proc p1 {} { + set a(0) zeroth + set a(1) first + set a(2) second + p2 + array names a + } + proc p2 {} {upvar a(0) x; unset x} + p1 +} {1 2} +test upvar-3.6 {unsetting then resetting array elements with upvar} { + proc p1 {} { + set a(0) zeroth + set a(1) first + set a(2) second + p2 + list [array names a] [catch {set a(0)} msg] $msg + } + proc p2 {} {upvar a(0) x; unset x; set x 12345} + p1 +} {{0 1 2} 0 12345} + +test upvar-4.1 {nested upvars} { + set x1 88 + proc p1 {a b} {set c 22; set d 33; p2} + proc p2 {} {global x1; upvar c x2; p3} + proc p3 {} { + upvar x1 a x2 b + list $a $b + } + p1 14 15 +} {88 22} +test upvar-4.2 {nested upvars} { + set x1 88 + proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d} + proc p2 {} {global x1; upvar c x2; p3} + proc p3 {} { + upvar x1 a x2 b + set a foo + set b bar + } + list [p1 14 15] $x1 +} {{14 15 bar 33} foo} + +proc tproc {args} {global x; set x [list $args [uplevel info vars]]} +test upvar-5.1 {traces involving upvars} { + proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2} + proc p2 {} {upvar c x1; set x1 22} + set x --- + p1 foo bar + set x +} {{x1 {} w} x1} +test upvar-5.2 {traces involving upvars} { + proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2} + proc p2 {} {upvar c x1; set x1} + set x --- + p1 foo bar + set x +} {{x1 {} r} x1} +test upvar-5.3 {traces involving upvars} { + proc p1 {a b} {set c 22; set d 33; trace var c rwu tproc; p2} + proc p2 {} {upvar c x1; unset x1} + set x --- + p1 foo bar + set x +} {{x1 {} u} x1} + +test upvar-6.1 {retargeting an upvar} { + proc p1 {} { + set a(0) zeroth + set a(1) first + set a(2) second + p2 + } + proc p2 {} { + upvar a x + set result {} + foreach i [array names x] { + upvar a($i) x + lappend result $x + } + lsort $result + } + p1 +} {first second zeroth} +test upvar-6.2 {retargeting an upvar} { + set x 44 + set y abcde + proc p1 {} { + global x + set result $x + upvar y x + lappend result $x + } + p1 +} {44 abcde} +test upvar-6.3 {retargeting an upvar} { + set x 44 + set y abcde + proc p1 {} { + upvar y x + lappend result $x + global x + lappend result $x + } + p1 +} {abcde 44} + +test upvar-7.1 {upvar to same level} { + set x 44 + set y 55 + catch {unset uv} + upvar #0 x uv + set uv abc + upvar 0 y uv + set uv xyzzy + list $x $y +} {abc xyzzy} +test upvar-7.2 {upvar to same level} { + set x 1234 + set y 4567 + proc p1 {x y} { + upvar 0 x uv + set uv $y + return "$x $y" + } + p1 44 89 +} {89 89} +test upvar-7.3 {upvar to same level} { + set x 1234 + set y 4567 + proc p1 {x y} { + upvar #1 x uv + set uv $y + return "$x $y" + } + p1 xyz abc +} {abc abc} +test upvar-7.4 {upvar to same level: tricky problems when deleting variable table} { + proc tt {} {upvar #1 toto loc; return $loc} + list [catch tt msg] $msg +} {1 {can't read "loc": no such variable}} +test upvar-7.5 {potential memory leak when deleting variable table} { + proc leak {} { + array set foo {1 2 3 4} + upvar 0 foo(1) bar + } + leak +} {} + +test upvar-8.1 {errors in upvar command} { + list [catch upvar msg] $msg +} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}} +test upvar-8.2 {errors in upvar command} { + list [catch {upvar 1} msg] $msg +} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}} +test upvar-8.3 {errors in upvar command} { + proc p1 {} {upvar a b c} + list [catch p1 msg] $msg +} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}} +test upvar-8.4 {errors in upvar command} { + proc p1 {} {upvar 0 b b} + list [catch p1 msg] $msg +} {1 {can't upvar from variable to itself}} +test upvar-8.5 {errors in upvar command} { + proc p1 {} {upvar 0 a b; upvar 0 b a} + list [catch p1 msg] $msg +} {1 {can't upvar from variable to itself}} +test upvar-8.6 {errors in upvar command} { + proc p1 {} {set a 33; upvar b a} + list [catch p1 msg] $msg +} {1 {variable "a" already exists}} +test upvar-8.7 {errors in upvar command} { + proc p1 {} {trace variable a w foo; upvar b a} + list [catch p1 msg] $msg +} {1 {variable "a" has traces: can't use for upvar}} +test upvar-8.8 {create nested array with upvar} { + proc p1 {} {upvar x(a) b; set b(2) 44} + catch {unset x} + list [catch p1 msg] $msg +} {1 {can't set "b(2)": variable isn't array}} +test upvar-8.9 {upvar won't create namespace variable that refers to procedure variable} { + catch {eval namespace delete [namespace children :: test_ns_*]} + catch {rename MakeLink ""} + namespace eval ::test_ns_1 {} + proc MakeLink {a} { + namespace eval ::test_ns_1 { + upvar a a + } + unset ::test_ns_1::a + } + list [catch {MakeLink 1} msg] $msg +} {1 {bad variable name "a": upvar won't create namespace variable that refers to procedure variable}} + +if {[info commands testupvar] != {}} { + test upvar-9.1 {Tcl_UpVar2 procedure} { + list [catch {testupvar xyz a {} x global} msg] $msg + } {1 {bad level "xyz"}} + test upvar-9.2 {Tcl_UpVar2 procedure} { + catch {unset a} + catch {unset x} + set a 44 + list [catch {testupvar #0 a 1 x global} msg] $msg + } {1 {can't access "a(1)": variable isn't array}} + test upvar-9.3 {Tcl_UpVar2 procedure} { + proc foo {} { + testupvar 1 a {} x local + set x + } + catch {unset a} + catch {unset x} + set a 44 + foo + } {44} + test upvar-9.4 {Tcl_UpVar2 procedure} { + proc foo {} { + testupvar 1 a {} _up_ global + list [catch {set x} msg] $msg + } + catch {unset a} + catch {unset _up_} + set a 44 + concat [foo] $_up_ + } {1 {can't read "x": no such variable} 44} + test upvar-9.5 {Tcl_UpVar2 procedure} { + proc foo {} { + testupvar 1 a b x local + set x + } + catch {unset a} + catch {unset x} + set a(b) 1234 + foo + } {1234} + test upvar-9.6 {Tcl_UpVar procedure} { + proc foo {} { + testupvar 1 a x local + set x + } + catch {unset a} + catch {unset x} + set a xyzzy + foo + } {xyzzy} + test upvar-9.7 {Tcl_UpVar procedure} { + proc foo {} { + testupvar #0 a(b) x local + set x + } + catch {unset a} + catch {unset x} + set a(b) 1234 + foo + } {1234} +} +catch {unset a} + +concat |