os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/var.test
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/var.test Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,733 @@
1.4 +# This file contains tests for the tclVar.c source file. Tests appear in
1.5 +# the same order as the C code that they test. The set of tests is
1.6 +# currently incomplete since it currently includes only new tests for
1.7 +# code changed for the addition of Tcl namespaces. Other variable-
1.8 +# related tests appear in several other test files including
1.9 +# namespace.test, set.test, trace.test, and upvar.test.
1.10 +#
1.11 +# Sourcing this file into Tcl runs the tests and generates output for
1.12 +# errors. No output means no errors were found.
1.13 +#
1.14 +# Copyright (c) 1997 Sun Microsystems, Inc.
1.15 +# Copyright (c) 1998-1999 by Scriptics Corporation.
1.16 +#
1.17 +# See the file "license.terms" for information on usage and redistribution
1.18 +# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.19 +#
1.20 +# RCS: @(#) $Id: var.test,v 1.20.2.4 2007/03/13 15:59:53 dgp Exp $
1.21 +#
1.22 +
1.23 +if {[lsearch [namespace children] ::tcltest] == -1} {
1.24 + package require tcltest 2.2
1.25 + namespace import -force ::tcltest::*
1.26 +}
1.27 +
1.28 +catch {rename p ""}
1.29 +catch {namespace delete test_ns_var}
1.30 +catch {unset xx}
1.31 +catch {unset x}
1.32 +catch {unset y}
1.33 +catch {unset i}
1.34 +catch {unset a}
1.35 +catch {unset arr}
1.36 +
1.37 +test var-1.1 {TclLookupVar, Array handling} {
1.38 + catch {unset a}
1.39 + set x "incr" ;# force no compilation and runtime call to Tcl_IncrCmd
1.40 + set i 10
1.41 + set arr(foo) 37
1.42 + list [$x i] $i [$x arr(foo)] $arr(foo)
1.43 +} {11 11 38 38}
1.44 +test var-1.2 {TclLookupVar, TCL_GLOBAL_ONLY implies global namespace var} {
1.45 + set x "global value"
1.46 + namespace eval test_ns_var {
1.47 + variable x "namespace value"
1.48 + proc p {} {
1.49 + global x ;# specifies TCL_GLOBAL_ONLY to get global x
1.50 + return $x
1.51 + }
1.52 + }
1.53 + test_ns_var::p
1.54 +} {global value}
1.55 +test var-1.3 {TclLookupVar, TCL_NAMESPACE_ONLY implies namespace var} {
1.56 + namespace eval test_ns_var {
1.57 + proc q {} {
1.58 + variable x ;# specifies TCL_NAMESPACE_ONLY to get namespace x
1.59 + return $x
1.60 + }
1.61 + }
1.62 + test_ns_var::q
1.63 +} {namespace value}
1.64 +test var-1.4 {TclLookupVar, no active call frame implies global namespace var} {
1.65 + set x
1.66 +} {global value}
1.67 +test var-1.5 {TclLookupVar, active call frame pushed for namespace eval implies namespace var} {
1.68 + namespace eval test_ns_var {set x}
1.69 +} {namespace value}
1.70 +test var-1.6 {TclLookupVar, name starts with :: implies some namespace var} {
1.71 + namespace eval test_ns_var {set ::x}
1.72 +} {global value}
1.73 +test var-1.7 {TclLookupVar, error finding namespace var} {
1.74 + list [catch {set a:::b} msg] $msg
1.75 +} {1 {can't read "a:::b": no such variable}}
1.76 +test var-1.8 {TclLookupVar, error finding namespace var} {
1.77 + list [catch {set ::foobarfoo} msg] $msg
1.78 +} {1 {can't read "::foobarfoo": no such variable}}
1.79 +test var-1.9 {TclLookupVar, create new namespace var} {
1.80 + namespace eval test_ns_var {
1.81 + set v hello
1.82 + }
1.83 +} {hello}
1.84 +test var-1.10 {TclLookupVar, create new namespace var} {
1.85 + catch {unset y}
1.86 + namespace eval test_ns_var {
1.87 + set ::y 789
1.88 + }
1.89 + set y
1.90 +} {789}
1.91 +test var-1.11 {TclLookupVar, error creating new namespace var} {
1.92 + namespace eval test_ns_var {
1.93 + list [catch {set ::test_ns_var::foo::bar 314159} msg] $msg
1.94 + }
1.95 +} {1 {can't set "::test_ns_var::foo::bar": parent namespace doesn't exist}}
1.96 +test var-1.12 {TclLookupVar, error creating new namespace var} {
1.97 + namespace eval test_ns_var {
1.98 + list [catch {set ::test_ns_var::foo:: 1997} msg] $msg
1.99 + }
1.100 +} {1 {can't set "::test_ns_var::foo::": parent namespace doesn't exist}}
1.101 +test var-1.13 {TclLookupVar, new namespace var is created in a particular namespace} {
1.102 + catch {unset aNeWnAmEiNnS}
1.103 + namespace eval test_ns_var {
1.104 + namespace eval test_ns_var2::test_ns_var3 {
1.105 + set aNeWnAmEiNnS 77777
1.106 + }
1.107 + # namespace which builds a name by traversing nsPtr chain to ::
1.108 + namespace which -variable test_ns_var2::test_ns_var3::aNeWnAmEiNnS
1.109 + }
1.110 +} {::test_ns_var::test_ns_var2::test_ns_var3::aNeWnAmEiNnS}
1.111 +test var-1.14 {TclLookupVar, namespace code ignores ":"s in middle and end of var names} {
1.112 + namespace eval test_ns_var {
1.113 + set : 123
1.114 + set v: 456
1.115 + set x:y: 789
1.116 + list [set :] [set v:] [set x:y:] \
1.117 + ${:} ${v:} ${x:y:} \
1.118 + [expr {[lsearch [info vars] :] != -1}] \
1.119 + [expr {[lsearch [info vars] v:] != -1}] \
1.120 + [expr {[lsearch [info vars] x:y:] != -1}]
1.121 + }
1.122 +} {123 456 789 123 456 789 1 1 1}
1.123 +test var-1.15 {TclLookupVar, resurrect variable via upvar to deleted namespace: compiled code path} {
1.124 + namespace eval test_ns_var {
1.125 + variable foo 2
1.126 + }
1.127 + proc p {} {
1.128 + variable ::test_ns_var::foo
1.129 + lappend result [catch {set foo} msg] $msg
1.130 + namespace delete ::test_ns_var
1.131 + lappend result [catch {set foo 3} msg] $msg
1.132 + lappend result [catch {set foo(3) 3} msg] $msg
1.133 + }
1.134 + p
1.135 +} {0 2 1 {can't set "foo": upvar refers to variable in deleted namespace} 1 {can't set "foo(3)": upvar refers to variable in deleted namespace}}
1.136 +test var-1.16 {TclLookupVar, resurrect variable via upvar to deleted namespace: uncompiled code path} {
1.137 + namespace eval test_ns_var {
1.138 + variable result
1.139 + namespace eval subns {
1.140 + variable foo 2
1.141 + }
1.142 + upvar 0 subns::foo foo
1.143 + lappend result [catch {set foo} msg] $msg
1.144 + namespace delete subns
1.145 + lappend result [catch {set foo 3} msg] $msg
1.146 + lappend result [catch {set foo(3) 3} msg] $msg
1.147 + namespace delete [namespace current]
1.148 + set result
1.149 + }
1.150 +} {0 2 1 {can't set "foo": upvar refers to variable in deleted namespace} 1 {can't set "foo(3)": upvar refers to variable in deleted namespace}}
1.151 +test var-1.17 {TclLookupVar, resurrect array element via upvar to deleted array: compiled code path} {
1.152 + namespace eval test_ns_var {
1.153 + variable result
1.154 + proc p {} {
1.155 + array set x {1 2 3 4}
1.156 + upvar 0 x(1) foo
1.157 + lappend result [catch {set foo} msg] $msg
1.158 + unset x
1.159 + lappend result [catch {set foo 3} msg] $msg
1.160 + }
1.161 + set result [p]
1.162 + namespace delete [namespace current]
1.163 + set result
1.164 + }
1.165 +} {0 2 1 {can't set "foo": upvar refers to element in deleted array}}
1.166 +test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: uncompiled code path} {
1.167 + namespace eval test_ns_var {
1.168 + variable result {}
1.169 + variable x
1.170 + array set x {1 2 3 4}
1.171 + upvar 0 x(1) foo
1.172 + lappend result [catch {set foo} msg] $msg
1.173 + unset x
1.174 + lappend result [catch {set foo 3} msg] $msg
1.175 + namespace delete [namespace current]
1.176 + set result
1.177 + }
1.178 +} {0 2 1 {can't set "foo": upvar refers to element in deleted array}}
1.179 +test var-1.19 {TclLookupVar, right error message when parsing variable name} {
1.180 + list [catch {[format set] thisvar(doesntexist)} msg] $msg
1.181 +} {1 {can't read "thisvar(doesntexist)": no such variable}}
1.182 +
1.183 +test var-2.1 {Tcl_LappendObjCmd, create var if new} {
1.184 + catch {unset x}
1.185 + lappend x 1 2
1.186 +} {1 2}
1.187 +
1.188 +test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} {
1.189 + catch {unset x}
1.190 + set x 1997
1.191 + proc p {} {
1.192 + global x ;# calls MakeUpvar with TCL_NAMESPACE_ONLY for other var x
1.193 + return $x
1.194 + }
1.195 + p
1.196 +} {1997}
1.197 +test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} {
1.198 + namespace eval test_ns_var {
1.199 + catch {unset v}
1.200 + variable v 1998
1.201 + proc p {} {
1.202 + variable v ;# TCL_NAMESPACE_ONLY specified for other var x
1.203 + return $v
1.204 + }
1.205 + p
1.206 + }
1.207 +} {1998}
1.208 +if {[info commands testupvar] != {}} {
1.209 + test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} {
1.210 + catch {unset a}
1.211 + set a 123321
1.212 + proc p {} {
1.213 + # create global xx linked to global a
1.214 + testupvar 1 a {} xx global
1.215 + }
1.216 + list [p] $xx [set xx 789] $a
1.217 + } {{} 123321 789 789}
1.218 + test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} {
1.219 + catch {unset a}
1.220 + set a 456
1.221 + namespace eval test_ns_var {
1.222 + catch {unset ::test_ns_var::vv}
1.223 + proc p {} {
1.224 + # create namespace var vv linked to global a
1.225 + testupvar 1 a {} vv namespace
1.226 + }
1.227 + p
1.228 + }
1.229 + list $test_ns_var::vv [set test_ns_var::vv 123] $a
1.230 + } {456 123 123}
1.231 +}
1.232 +test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} {
1.233 + catch {unset aaaaa}
1.234 + catch {unset xxxxx}
1.235 + set aaaaa 77777
1.236 + upvar #0 aaaaa xxxxx
1.237 + list [set xxxxx] [set aaaaa]
1.238 +} {77777 77777}
1.239 +test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} {
1.240 + catch {unset a}
1.241 + set a 121212
1.242 + namespace eval test_ns_var {
1.243 + upvar ::a vvv
1.244 + set vvv
1.245 + }
1.246 +} {121212}
1.247 +test var-3.7 {MakeUpvar, my var has ::s} {
1.248 + catch {unset a}
1.249 + set a 789789
1.250 + upvar #0 a test_ns_var::lnk
1.251 + namespace eval test_ns_var {
1.252 + set lnk
1.253 + }
1.254 +} {789789}
1.255 +test var-3.8 {MakeUpvar, my var already exists in global ns} {
1.256 + catch {unset aaaaa}
1.257 + catch {unset xxxxx}
1.258 + set aaaaa 456654
1.259 + set xxxxx hello
1.260 + upvar #0 aaaaa xxxxx
1.261 + set xxxxx
1.262 +} {hello}
1.263 +test var-3.9 {MakeUpvar, my var has invalid ns name} {
1.264 + catch {unset aaaaa}
1.265 + set aaaaa 789789
1.266 + list [catch {upvar #0 aaaaa test_ns_fred::lnk} msg] $msg
1.267 +} {1 {can't create "test_ns_fred::lnk": parent namespace doesn't exist}}
1.268 +test var-3.10 {MakeUpvar, } {
1.269 + namespace eval {} {
1.270 + set bar 0
1.271 + namespace eval foo upvar bar bar
1.272 + set foo::bar 1
1.273 + catch {list $bar $foo::bar} msg
1.274 + unset ::aaaaa
1.275 + set msg
1.276 + }
1.277 +} {1 1}
1.278 +
1.279 +if {[info commands testgetvarfullname] != {}} {
1.280 + test var-4.1 {Tcl_GetVariableName, global variable} {
1.281 + catch {unset a}
1.282 + set a 123
1.283 + testgetvarfullname a global
1.284 + } ::a
1.285 + test var-4.2 {Tcl_GetVariableName, namespace variable} {
1.286 + namespace eval test_ns_var {
1.287 + variable george
1.288 + testgetvarfullname george namespace
1.289 + }
1.290 + } ::test_ns_var::george
1.291 + test var-4.3 {Tcl_GetVariableName, variable can't be array element} {
1.292 + catch {unset a}
1.293 + set a(1) foo
1.294 + list [catch {testgetvarfullname a(1) global} msg] $msg
1.295 + } {1 {unknown variable "a(1)"}}
1.296 +}
1.297 +
1.298 +test var-5.1 {Tcl_GetVariableFullName, global variable} {
1.299 + catch {unset a}
1.300 + set a bar
1.301 + namespace which -variable a
1.302 +} {::a}
1.303 +test var-5.2 {Tcl_GetVariableFullName, namespace variable} {
1.304 + namespace eval test_ns_var {
1.305 + variable martha
1.306 + namespace which -variable martha
1.307 + }
1.308 +} {::test_ns_var::martha}
1.309 +test var-5.3 {Tcl_GetVariableFullName, namespace variable} {
1.310 + namespace which -variable test_ns_var::martha
1.311 +} {::test_ns_var::martha}
1.312 +
1.313 +test var-6.1 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} {
1.314 + namespace eval test_ns_var {
1.315 + variable boeing 777
1.316 + }
1.317 + proc p {} {
1.318 + global ::test_ns_var::boeing
1.319 + set boeing
1.320 + }
1.321 + p
1.322 +} {777}
1.323 +test var-6.2 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} {
1.324 + namespace eval test_ns_var {
1.325 + namespace eval test_ns_nested {
1.326 + variable java java
1.327 + }
1.328 + proc p {} {
1.329 + global ::test_ns_var::test_ns_nested::java
1.330 + set java
1.331 + }
1.332 + }
1.333 + test_ns_var::p
1.334 +} {java}
1.335 +test var-6.3 {Tcl_GlobalObjCmd, variable named {} qualified by a namespace name} {
1.336 + set ::test_ns_var::test_ns_nested:: 24
1.337 + proc p {} {
1.338 + global ::test_ns_var::test_ns_nested::
1.339 + set {}
1.340 + }
1.341 + p
1.342 +} {24}
1.343 +test var-6.4 {Tcl_GlobalObjCmd, variable name matching :*} {
1.344 + # Test for Tcl Bug 480176
1.345 + set :v broken
1.346 + proc p {} {
1.347 + global :v
1.348 + set :v fixed
1.349 + }
1.350 + p
1.351 + set :v
1.352 +} {fixed}
1.353 +
1.354 +test var-7.1 {Tcl_VariableObjCmd, create and initialize one new ns variable} {
1.355 + catch {namespace delete test_ns_var}
1.356 + namespace eval test_ns_var {
1.357 + variable one 1
1.358 + }
1.359 + list [info vars test_ns_var::*] [set test_ns_var::one]
1.360 +} {::test_ns_var::one 1}
1.361 +test var-7.2 {Tcl_VariableObjCmd, if new and no value, leave undefined} {
1.362 + set two 2222222
1.363 + namespace eval test_ns_var {
1.364 + variable two
1.365 + }
1.366 + list [info exists test_ns_var::two] [catch {set test_ns_var::two} msg] $msg
1.367 +} {0 1 {can't read "test_ns_var::two": no such variable}}
1.368 +test var-7.3 {Tcl_VariableObjCmd, "define" var already created above} {
1.369 + namespace eval test_ns_var {
1.370 + variable two 2
1.371 + }
1.372 + list [lsort [info vars test_ns_var::*]] \
1.373 + [namespace eval test_ns_var {set two}]
1.374 +} [list [lsort {::test_ns_var::two ::test_ns_var::one}] 2]
1.375 +test var-7.4 {Tcl_VariableObjCmd, list of vars} {
1.376 + namespace eval test_ns_var {
1.377 + variable three 3 four 4
1.378 + }
1.379 + list [lsort [info vars test_ns_var::*]] \
1.380 + [namespace eval test_ns_var {expr $three+$four}]
1.381 +} [list [lsort {::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one}] 7]
1.382 +test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} {
1.383 + catch {unset a}
1.384 + catch {unset five}
1.385 + catch {unset six}
1.386 + set a ""
1.387 + set five 555
1.388 + set six 666
1.389 + namespace eval test_ns_var {
1.390 + variable five 5 six
1.391 + lappend a $five
1.392 + }
1.393 + lappend a $test_ns_var::five \
1.394 + [set test_ns_var::six 6] [set test_ns_var::six] $six
1.395 + catch {unset five}
1.396 + catch {unset six}
1.397 + set a
1.398 +} {5 5 6 6 666}
1.399 +catch {unset newvar}
1.400 +test var-7.6 {Tcl_VariableObjCmd, variable name can be qualified} {
1.401 + namespace eval test_ns_var {
1.402 + variable ::newvar cheers!
1.403 + }
1.404 + set newvar
1.405 +} {cheers!}
1.406 +catch {unset newvar}
1.407 +test var-7.7 {Tcl_VariableObjCmd, bad var name} {
1.408 + namespace eval test_ns_var {
1.409 + list [catch {variable sev:::en 7} msg] $msg
1.410 + }
1.411 +} {1 {can't define "sev:::en": parent namespace doesn't exist}}
1.412 +test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, leave value unchanged} {
1.413 + set a ""
1.414 + namespace eval test_ns_var {
1.415 + variable eight 8
1.416 + lappend a $eight
1.417 + variable eight
1.418 + lappend a $eight
1.419 + }
1.420 + set a
1.421 +} {8 8}
1.422 +test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} {
1.423 + catch {namespace delete test_ns_var2}
1.424 + set a ""
1.425 + namespace eval test_ns_var2 {
1.426 + variable x 123
1.427 + variable y
1.428 + variable z
1.429 + }
1.430 + lappend a [lsort [info vars test_ns_var2::*]]
1.431 + lappend a [info exists test_ns_var2::x] [info exists test_ns_var2::y] \
1.432 + [info exists test_ns_var2::z]
1.433 + lappend a [list [catch {set test_ns_var2::y} msg] $msg]
1.434 + lappend a [lsort [info vars test_ns_var2::*]]
1.435 + lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
1.436 + lappend a [set test_ns_var2::y hello]
1.437 + lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
1.438 + lappend a [list [catch {unset test_ns_var2::y} msg] $msg]
1.439 + lappend a [lsort [info vars test_ns_var2::*]]
1.440 + lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
1.441 + lappend a [list [catch {unset test_ns_var2::z} msg] $msg]
1.442 + lappend a [namespace delete test_ns_var2]
1.443 + set a
1.444 +} [list [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 1 0 0\
1.445 + {1 {can't read "test_ns_var2::y": no such variable}}\
1.446 + [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 0 0\
1.447 + hello 1 0\
1.448 + {0 {}}\
1.449 + [lsort {::test_ns_var2::x ::test_ns_var2::z}] 0 0\
1.450 + {1 {can't unset "test_ns_var2::z": no such variable}}\
1.451 + {}]
1.452 +test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
1.453 + namespace eval test_ns_var {
1.454 + proc p {} {
1.455 + variable eight
1.456 + list [set eight] [info vars]
1.457 + }
1.458 + p
1.459 + }
1.460 +} {8 eight}
1.461 +test var-7.11 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
1.462 + proc p {} { ;# note this proc is at global :: scope
1.463 + variable test_ns_var::eight
1.464 + list [set eight] [info vars]
1.465 + }
1.466 + p
1.467 +} {8 eight}
1.468 +test var-7.12 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
1.469 + namespace eval test_ns_var {
1.470 + variable {} {My name is empty}
1.471 + }
1.472 + proc p {} { ;# note this proc is at global :: scope
1.473 + variable test_ns_var::
1.474 + list [set {}] [info vars]
1.475 + }
1.476 + p
1.477 +} {{My name is empty} {{}}}
1.478 +test var-7.13 {Tcl_VariableObjCmd, variable named ":"} {
1.479 + namespace eval test_ns_var {
1.480 + variable : {My name is ":"}
1.481 + proc p {} {
1.482 + variable :
1.483 + list [set :] [info vars]
1.484 + }
1.485 + p
1.486 + }
1.487 +} {{My name is ":"} :}
1.488 +test var-7.14 {Tcl_VariableObjCmd, array element parameter} {
1.489 + catch {namespace eval test_ns_var { variable arrayvar(1) }} res
1.490 + set res
1.491 +} "can't define \"arrayvar(1)\": name refers to an element in an array"
1.492 +test var-7.15 {Tcl_VariableObjCmd, array element parameter} {
1.493 + catch {
1.494 + namespace eval test_ns_var {
1.495 + variable arrayvar
1.496 + set arrayvar(1) x
1.497 + variable arrayvar(1) y
1.498 + }
1.499 + } res
1.500 + set res
1.501 +} "can't define \"arrayvar(1)\": name refers to an element in an array"
1.502 +test var-7.16 {Tcl_VariableObjCmd, no args} {
1.503 + list [catch {variable} msg] $msg
1.504 +} {1 {wrong # args: should be "variable ?name value...? name ?value?"}}
1.505 +test var-7.17 {Tcl_VariableObjCmd, no args} {
1.506 + namespace eval test_ns_var {
1.507 + list [catch {variable} msg] $msg
1.508 + }
1.509 +} {1 {wrong # args: should be "variable ?name value...? name ?value?"}}
1.510 +
1.511 +test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} {
1.512 + catch {namespace delete test_ns_var}
1.513 + catch {unset a}
1.514 + namespace eval test_ns_var {
1.515 + variable v 123
1.516 + variable info ""
1.517 +
1.518 + proc traceUnset {name1 name2 op} {
1.519 + variable info
1.520 + set info [concat $info [list $name1 $name2 $op]]
1.521 + }
1.522 +
1.523 + trace var v u [namespace code traceUnset]
1.524 + }
1.525 + list [unset test_ns_var::v] $test_ns_var::info
1.526 +} {{} {test_ns_var::v {} u}}
1.527 +
1.528 +if {[info commands testsetnoerr] == {}} {
1.529 + puts "This application hasn't been compiled with the \"testsetnoerr\""
1.530 + puts "command, so I can't test TclSetVar etc."
1.531 +} else {
1.532 +test var-9.1 {behaviour of TclGet/SetVar simple get/set} {
1.533 + catch {unset u}; catch {unset v}
1.534 + list \
1.535 + [set u a; testsetnoerr u] \
1.536 + [testsetnoerr v b] \
1.537 + [testseterr u] \
1.538 + [unset v; testseterr v b]
1.539 +} [list {before get a} {before set b} {before get a} {before set b}]
1.540 +test var-9.2 {behaviour of TclGet/SetVar namespace get/set} {
1.541 + catch {namespace delete ns}
1.542 + namespace eval ns {variable u a; variable v}
1.543 + list \
1.544 + [testsetnoerr ns::u] \
1.545 + [testsetnoerr ns::v b] \
1.546 + [testseterr ns::u] \
1.547 + [unset ns::v; testseterr ns::v b]
1.548 +} [list {before get a} {before set b} {before get a} {before set b}]
1.549 +test var-9.3 {behaviour of TclGetVar no variable} {
1.550 + catch {unset u}
1.551 + list \
1.552 + [catch {testsetnoerr u} res] $res \
1.553 + [catch {testseterr u} res] $res
1.554 +} {1 {before get} 1 {can't read "u": no such variable}}
1.555 +test var-9.4 {behaviour of TclGetVar no namespace variable} {
1.556 + catch {namespace delete ns}
1.557 + namespace eval ns {}
1.558 + list \
1.559 + [catch {testsetnoerr ns::w} res] $res \
1.560 + [catch {testseterr ns::w} res] $res
1.561 +} {1 {before get} 1 {can't read "ns::w": no such variable}}
1.562 +test var-9.5 {behaviour of TclGetVar no namespace} {
1.563 + catch {namespace delete ns}
1.564 + list \
1.565 + [catch {testsetnoerr ns::u} res] $res \
1.566 + [catch {testseterr ns::v} res] $res
1.567 +} {1 {before get} 1 {can't read "ns::v": no such variable}}
1.568 +test var-9.6 {behaviour of TclSetVar no namespace} {
1.569 + catch {namespace delete ns}
1.570 + list \
1.571 + [catch {testsetnoerr ns::v 1} res] $res \
1.572 + [catch {testseterr ns::v 1} res] $res
1.573 +} {1 {before set} 1 {can't set "ns::v": parent namespace doesn't exist}}
1.574 +test var-9.7 {behaviour of TclGetVar array variable} {
1.575 + catch {unset arr}
1.576 + set arr(1) 1;
1.577 + list \
1.578 + [catch {testsetnoerr arr} res] $res \
1.579 + [catch {testseterr arr} res] $res
1.580 +} {1 {before get} 1 {can't read "arr": variable is array}}
1.581 +test var-9.8 {behaviour of TclSetVar array variable} {
1.582 + catch {unset arr}
1.583 + set arr(1) 1
1.584 + list \
1.585 + [catch {testsetnoerr arr 2} res] $res \
1.586 + [catch {testseterr arr 2} res] $res
1.587 +} {1 {before set} 1 {can't set "arr": variable is array}}
1.588 +test var-9.9 {behaviour of TclGetVar read trace success} {
1.589 + proc resetvar {val name elem op} {upvar 1 $name v; set v $val}
1.590 + catch {unset u}; catch {unset v}
1.591 + set u 10
1.592 + trace var u r [list resetvar 1]
1.593 + trace var v r [list resetvar 2]
1.594 + list \
1.595 + [testsetnoerr u] \
1.596 + [testseterr v]
1.597 +} {{before get 1} {before get 2}}
1.598 +test var-9.10 {behaviour of TclGetVar read trace error} {
1.599 + proc writeonly args {error "write-only"}
1.600 + set v 456
1.601 + trace var v r writeonly
1.602 + list \
1.603 + [catch {testsetnoerr v} msg] $msg \
1.604 + [catch {testseterr v} msg] $msg
1.605 +} {1 {before get} 1 {can't read "v": write-only}}
1.606 +test var-9.11 {behaviour of TclSetVar write trace success} {
1.607 + proc doubleval {name elem op} {upvar 1 $name v; set v [expr {2 * $v}]}
1.608 + catch {unset u}; catch {unset v}
1.609 + set v 1
1.610 + trace var v w doubleval
1.611 + trace var u w doubleval
1.612 + list \
1.613 + [testsetnoerr u 2] \
1.614 + [testseterr v 3]
1.615 +} {{before set 4} {before set 6}}
1.616 +test var-9.12 {behaviour of TclSetVar write trace error} {
1.617 + proc readonly args {error "read-only"}
1.618 + set v 456
1.619 + trace var v w readonly
1.620 + list \
1.621 + [catch {testsetnoerr v 2} msg] $msg $v \
1.622 + [catch {testseterr v 3} msg] $msg $v
1.623 +} {1 {before set} 2 1 {can't set "v": read-only} 3}
1.624 +}
1.625 +test var-10.1 {can't nest arrays with array set} {
1.626 + catch {unset arr}
1.627 + list [catch {array set arr(x) {a 1 b 2}} res] $res
1.628 +} {1 {can't set "arr(x)": variable isn't array}}
1.629 +
1.630 +test var-10.2 {can't nest arrays with array set} {
1.631 + catch {unset arr}
1.632 + list [catch {array set arr(x) {}} res] $res
1.633 +} {1 {can't set "arr(x)": variable isn't array}}
1.634 +
1.635 +test var-11.1 {array unset} {
1.636 + catch {unset a}
1.637 + array set a { 1,1 a 1,2 b 2,1 c 2,3 d }
1.638 + array unset a 1,*
1.639 + lsort -dict [array names a]
1.640 +} {2,1 2,3}
1.641 +test var-11.2 {array unset} {
1.642 + catch {unset a}
1.643 + array set a { 1,1 a 1,2 b }
1.644 + array unset a
1.645 + array exists a
1.646 +} 0
1.647 +test var-11.3 {array unset errors} {
1.648 + catch {unset a}
1.649 + array set a { 1,1 a 1,2 b }
1.650 + list [catch {array unset a pattern too} msg] $msg
1.651 +} {1 {wrong # args: should be "array unset arrayName ?pattern?"}}
1.652 +
1.653 +test var-12.1 {TclFindCompiledLocals, {} array name} {
1.654 + namespace eval n {
1.655 + proc p {} {
1.656 + variable {}
1.657 + set (0) 0
1.658 + set (1) 1
1.659 + set n 2
1.660 + set ($n) 2
1.661 + set ($n,foo) 2
1.662 + }
1.663 + p
1.664 + lsort -dictionary [array names {}]
1.665 + }
1.666 +} {0 1 2 2,foo}
1.667 +
1.668 +test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} {
1.669 + catch {unset t}
1.670 + proc foo {var ind op} {
1.671 + global t
1.672 + set foo bar
1.673 + }
1.674 + namespace eval :: {
1.675 + set t(1) 1
1.676 + trace variable t(1) u foo
1.677 + unset t
1.678 + }
1.679 + set x "If you see this, it worked"
1.680 +} "If you see this, it worked"
1.681 +
1.682 +test var-14.1 {array names syntax} -body {
1.683 + array names foo bar baz snafu
1.684 +} -returnCodes 1 -match glob -result *
1.685 +
1.686 +test var-15.1 {segfault in [unset], [Bug 735335]} {
1.687 + proc A { name } {
1.688 + upvar $name var
1.689 + set var $name
1.690 + }
1.691 + #
1.692 + # Note that the variable name has to be
1.693 + # unused previously for the segfault to
1.694 + # be triggered.
1.695 + #
1.696 + namespace eval test A useSomeUnlikelyNameHere
1.697 + namespace eval test unset useSomeUnlikelyNameHere
1.698 +} {}
1.699 +
1.700 +test var-16.1 {CallVarTraces: save/restore interp error state: 1038021} {
1.701 + trace add variable errorCode write { ;#}
1.702 + catch {error foo bar baz}
1.703 + trace remove variable errorCode write { ;#}
1.704 + set errorInfo
1.705 +} bar
1.706 +
1.707 +test var-17.1 {TclArraySet [Bug 1669489]} -setup {
1.708 + unset -nocomplain ::a
1.709 +} -body {
1.710 + namespace eval :: {
1.711 + set elements {1 2 3 4}
1.712 + trace add variable a write {string length $elements ;#}
1.713 + array set a $elements
1.714 + }
1.715 +} -cleanup {
1.716 + unset -nocomplain ::a ::elements
1.717 +} -result {}
1.718 +
1.719 +catch {namespace delete ns}
1.720 +catch {unset arr}
1.721 +catch {unset v}
1.722 +
1.723 +catch {rename p ""}
1.724 +catch {namespace delete test_ns_var}
1.725 +catch {namespace delete test_ns_var2}
1.726 +catch {unset xx}
1.727 +catch {unset x}
1.728 +catch {unset y}
1.729 +catch {unset i}
1.730 +catch {unset a}
1.731 +catch {unset xxxxx}
1.732 +catch {unset aaaaa}
1.733 +
1.734 +# cleanup
1.735 +::tcltest::cleanupTests
1.736 +return