diff options
Diffstat (limited to 'tests/upvar.test')
| -rw-r--r-- | tests/upvar.test | 394 |
1 files changed, 284 insertions, 110 deletions
diff --git a/tests/upvar.test b/tests/upvar.test index 1301338..e93f58a 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -1,21 +1,26 @@ -# 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 -# generates output for errors. No output means no errors were found. +# 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. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# See the file "license.terms" for information on usage and redistribution 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::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + +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} @@ -144,7 +149,7 @@ test upvar-3.5 {unsetting array elements with upvar} { array names a } proc p2 {} {upvar a(0) x; unset x} - p1 + lsort [p1] } {1 2} test upvar-3.6 {unsetting then resetting array elements with upvar} { proc p1 {} { @@ -152,7 +157,7 @@ test upvar-3.6 {unsetting then resetting array elements with upvar} { set a(1) first set a(2) second p2 - list [array names a] [catch {set a(0)} msg] $msg + list [lsort [array names a]] [catch {set a(0)} msg] $msg } proc p2 {} {upvar a(0) x; unset x; set x 12345} p1 @@ -286,130 +291,299 @@ test upvar-7.5 {potential memory leak when deleting variable table} { 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} { +test upvar-8.1 {errors in upvar command} -returnCodes error -body { + upvar +} -result {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"} +test upvar-8.2 {errors in upvar command} -returnCodes error -body { + upvar 1 +} -result {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"} +test upvar-8.2.1 {upvar with numeric first argument} { + apply {{} {set 0 ok; apply {{} {upvar 0 x; return $x}}}} +} ok +test upvar-8.3 {errors in upvar command} -returnCodes error -body { 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} { + p1 +} -result {bad level "a"} +test upvar-8.4 {errors in upvar command} -returnCodes error -body { 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} { + p1 +} -result {can't upvar from variable to itself} +test upvar-8.5 {errors in upvar command} -returnCodes error -body { 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} { + p1 +} -result {can't upvar from variable to itself} +test upvar-8.6 {errors in upvar command} -returnCodes error -body { 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} { + p1 +} -result {variable "a" already exists} +test upvar-8.7 {errors in upvar command} -returnCodes error -body { 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} { + p1 +} -result {variable "a" has traces: can't use for 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}} -test upvar-8.9 {upvar won't create namespace variable that refers to procedure variable} { - catch {eval namespace delete [namespace children :: test_ns_*]} + p1 +} -returnCodes error -cleanup { + unset x +} -result {can't set "b(2)": variable isn't array} +test upvar-8.9 {upvar won't create namespace variable that refers to procedure variable} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename MakeLink ""} namespace eval ::test_ns_1 {} +} -returnCodes error -body { proc MakeLink {a} { - namespace eval ::test_ns_1 { + namespace eval ::test_ns_1 { upvar a a - } - unset ::test_ns_1::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}} -test upvar-8.10 {upvar will create element alias for new array element} { + MakeLink 1 +} -result {bad variable name "a": upvar won't create namespace variable that refers to procedure variable} +test upvar-8.10 {upvar will create element alias for new array element} -setup { catch {unset upvarArray} +} -body { array set upvarArray {} catch {upvar 0 upvarArray(elem) upvarArrayElemAlias} -} {0} +} -result {0} +test upvar-8.11 {upvar will not create a variable that looks like an array} -setup { + catch {unset upvarArray} +} -body { + array set upvarArray {} + upvar 0 upvarArray(elem) upvarArrayElemAlias(elem) +} -returnCodes 1 -match glob -result * + +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} + +test upvar-10.1 {CompileWord OBOE} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + upvar 1 {*}{ + } [return [incr n -[linenumber]]] x + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 + +# +# Tests for 'namespace upvar'. As the implementation is essentially the same as +# for 'upvar', we only test that the variables are linked correctly, i.e., 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 -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 +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 + } +} -returnCodes error -cleanup { + namespace delete test_ns_1 +} -result {namespace "test_ns_0" not found in "::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] + } +} -returnCodes error -cleanup { + namespace delete test_ns_1 +} -result {namespace "test_ns_0" not found in "::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 + } +} -cleanup { + namespace delete test_ns_1 +} -result {can't read "w": no such variable} -returnCodes error +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 } - 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 + return [a] + } +} -cleanup { + namespace delete test_ns_1 +} -result {can't read "w": no such variable} -returnCodes error +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 } - 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 + namespace upvar test_ns_0 x w + set w + } +} -cleanup { + namespace delete test_ns_1 +} -result {test_ns_1::test_ns_0} +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 } - 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 + proc a {} { + namespace upvar test_ns_0 x w + set w } - 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 + return [a] + } +} -cleanup { + namespace delete test_ns_1 +} -result {test_ns_1::test_ns_0} +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 } - catch {unset a} - catch {unset x} - set a(b) 1234 - foo - } {1234} -} -catch {unset a} + return [a] + } +} -returnCodes error -cleanup { + namespace delete test_ns_1 +} -result {namespace "test_ns_0" not found in "::test_ns_1"} + +test upvar-NS-2.1 {TIP 323} -returnCodes error -body { + namespace upvar +} -result {wrong # args: should be "namespace upvar ns ?otherVar myVar ...?"} +test upvar-NS-2.2 {TIP 323} -setup { + namespace eval test_ns_1 {} +} -body { + namespace upvar test_ns_1 +} -cleanup { + namespace delete test_ns_1 +} -result {} +test upvar-NS-3.1 {CompileWord OBOE} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + namespace upvar {*}{ + } [return [incr n -[linenumber]]] x y + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 +test upvar-NS-3.2 {CompileWord OBOE} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + namespace upvar :: {*}{ + } [return [incr n -[linenumber]]] x + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 +test upvar-NS-3.3 {CompileWord OBOE} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + variable x {*}{ + } [return [incr n -[linenumber]]] + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 + + # cleanup ::tcltest::cleanupTests return - - - - - - - - - - - +# Local Variables: +# mode: tcl +# End: |