diff options
Diffstat (limited to 'tests/upvar.test')
| -rw-r--r-- | tests/upvar.test | 271 |
1 files changed, 202 insertions, 69 deletions
diff --git a/tests/upvar.test b/tests/upvar.test index 1301338..457c9f8 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -1,4 +1,4 @@ -# Commands covered: upvar +# Commands covered: 'upvar', 'namespace 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 @@ -12,10 +12,12 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2 namespace import -force ::tcltest::* } +testConstraint testupvar [llength [info commands testupvar]] + 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} @@ -312,13 +314,15 @@ 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} { +test upvar-8.8 {create nested array with upvar} -body { 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}} +} -cleanup { + unset x +} -result {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 {namespace delete {*}[namespace children :: test_ns_*]} catch {rename MakeLink ""} namespace eval ::test_ns_1 {} proc MakeLink {a} { @@ -334,82 +338,211 @@ test upvar-8.10 {upvar will create element alias for new array element} { array set upvarArray {} catch {upvar 0 upvarArray(elem) upvarArrayElemAlias} } {0} +test upvar-8.11 {upvar will not create a variable that looks like an array} -body { + catch {unset upvarArray} + array set upvarArray {} + upvar 0 upvarArray(elem) upvarArrayElemAlias(elem) +} -returnCodes 1 -match glob -result * -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} -} +test upvar-9.1 {Tcl_UpVar2 procedure} testupvar { + list [catch {testupvar xyz a {} x global} msg] $msg +} {1 {bad level "xyz"}} +test upvar-9.2 {Tcl_UpVar2 procedure} testupvar { + 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} testupvar { + 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} testupvar { + 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} testupvar { + 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} testupvar { + 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} testupvar { + 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} -# cleanup -::tcltest::cleanupTests -return +# +# Tests for 'namespace upvar'. As the implementation is essentially the same as +# for 'upvar', we only test that the variables are linked correctly. Ie, we +# assume that the behaviour of variables once the link is established has +# already been tested above. +# +# + +# Clear out any namespaces called test_ns_* +catch {namespace delete {*}[namespace children :: test_ns_*]} +namespace eval test_ns_0 { + variable x test_ns_0 +} + +set x test_global +test upvar-NS-1.1 {nsupvar links to correct variable} \ + -body { + namespace eval test_ns_1 { + namespace upvar ::test_ns_0 x w + set w + } + } \ + -result {test_ns_0} \ + -cleanup {namespace delete test_ns_1} + +test upvar-NS-1.2 {nsupvar links to correct variable} \ + -body { + namespace eval test_ns_1 { + proc a {} { + namespace upvar ::test_ns_0 x w + set w + } + return [a] + } + } \ + -result {test_ns_0} \ + -cleanup {namespace delete test_ns_1} +test upvar-NS-1.3 {nsupvar links to correct variable} \ + -body { + namespace eval test_ns_1 { + namespace upvar test_ns_0 x w + set w + } + } \ + -result {namespace "test_ns_0" not found in "::test_ns_1"} \ + -returnCodes error \ + -cleanup {namespace delete test_ns_1} +test upvar-NS-1.4 {nsupvar links to correct variable} \ + -body { + namespace eval test_ns_1 { + proc a {} { + namespace upvar test_ns_0 x w + set w + } + return [a] + } + } \ + -result {namespace "test_ns_0" not found in "::test_ns_1"} \ + -returnCodes error \ + -cleanup {namespace delete test_ns_1} +test upvar-NS-1.5 {nsupvar links to correct variable} \ + -body { + namespace eval test_ns_1 { + namespace eval test_ns_0 {} + namespace upvar test_ns_0 x w + set w + } + } \ + -result {can't read "w": no such variable} \ + -returnCodes error \ + -cleanup {namespace delete test_ns_1} +test upvar-NS-1.6 {nsupvar links to correct variable} \ + -body { + namespace eval test_ns_1 { + namespace eval test_ns_0 {} + proc a {} { + namespace upvar test_ns_0 x w + set w + } + return [a] + } + } \ + -result {can't read "w": no such variable} \ + -returnCodes error \ + -cleanup {namespace delete test_ns_1} +test upvar-NS-1.7 {nsupvar links to correct variable} \ + -body { + namespace eval test_ns_1 { + namespace eval test_ns_0 { + variable x test_ns_1::test_ns_0 + } + namespace upvar test_ns_0 x w + set w + } + } \ + -result {test_ns_1::test_ns_0} \ + -cleanup {namespace delete test_ns_1} +test upvar-NS-1.8 {nsupvar links to correct variable} \ + -body { + namespace eval test_ns_1 { + namespace eval test_ns_0 { + variable x test_ns_1::test_ns_0 + } + proc a {} { + namespace upvar test_ns_0 x w + set w + } + return [a] + } + } \ + -result {test_ns_1::test_ns_0} \ + -cleanup {namespace delete test_ns_1} +test upvar-NS-1.9 {nsupvar links to correct variable} \ + -body { + namespace eval test_ns_1 { + variable x test_ns_1 + proc a {} { + namespace upvar test_ns_0 x w + set w + } + return [a] + } + } \ + -result {namespace "test_ns_0" not found in "::test_ns_1"} \ + -returnCodes error \ + -cleanup {namespace delete test_ns_1} +# cleanup +::tcltest::cleanupTests +return |