[25] | 1 | # This file contains tests for the tclVar.c source file. Tests appear in |
---|
| 2 | # the same order as the C code that they test. The set of tests is |
---|
| 3 | # currently incomplete since it currently includes only new tests for |
---|
| 4 | # code changed for the addition of Tcl namespaces. Other variable- |
---|
| 5 | # related tests appear in several other test files including |
---|
| 6 | # namespace.test, set.test, trace.test, and upvar.test. |
---|
| 7 | # |
---|
| 8 | # Sourcing this file into Tcl runs the tests and generates output for |
---|
| 9 | # errors. No output means no errors were found. |
---|
| 10 | # |
---|
| 11 | # Copyright (c) 1997 Sun Microsystems, Inc. |
---|
| 12 | # Copyright (c) 1998-1999 by Scriptics Corporation. |
---|
| 13 | # |
---|
| 14 | # See the file "license.terms" for information on usage and redistribution |
---|
| 15 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
| 16 | # |
---|
| 17 | # RCS: @(#) $Id: var.test,v 1.31 2008/03/11 17:23:56 msofer Exp $ |
---|
| 18 | # |
---|
| 19 | |
---|
| 20 | if {[lsearch [namespace children] ::tcltest] == -1} { |
---|
| 21 | package require tcltest 2.2 |
---|
| 22 | namespace import -force ::tcltest::* |
---|
| 23 | } |
---|
| 24 | |
---|
| 25 | testConstraint testupvar [llength [info commands testupvar]] |
---|
| 26 | testConstraint testgetvarfullname [llength [info commands testgetvarfullname]] |
---|
| 27 | testConstraint testsetnoerr [llength [info commands testsetnoerr]] |
---|
| 28 | |
---|
| 29 | catch {rename p ""} |
---|
| 30 | catch {namespace delete test_ns_var} |
---|
| 31 | catch {unset xx} |
---|
| 32 | catch {unset x} |
---|
| 33 | catch {unset y} |
---|
| 34 | catch {unset i} |
---|
| 35 | catch {unset a} |
---|
| 36 | catch {unset arr} |
---|
| 37 | |
---|
| 38 | test var-1.1 {TclLookupVar, Array handling} { |
---|
| 39 | catch {unset a} |
---|
| 40 | set x "incr" ;# force no compilation and runtime call to Tcl_IncrCmd |
---|
| 41 | set i 10 |
---|
| 42 | set arr(foo) 37 |
---|
| 43 | list [$x i] $i [$x arr(foo)] $arr(foo) |
---|
| 44 | } {11 11 38 38} |
---|
| 45 | test var-1.2 {TclLookupVar, TCL_GLOBAL_ONLY implies global namespace var} { |
---|
| 46 | set x "global value" |
---|
| 47 | namespace eval test_ns_var { |
---|
| 48 | variable x "namespace value" |
---|
| 49 | proc p {} { |
---|
| 50 | global x ;# specifies TCL_GLOBAL_ONLY to get global x |
---|
| 51 | return $x |
---|
| 52 | } |
---|
| 53 | } |
---|
| 54 | test_ns_var::p |
---|
| 55 | } {global value} |
---|
| 56 | test var-1.3 {TclLookupVar, TCL_NAMESPACE_ONLY implies namespace var} { |
---|
| 57 | namespace eval test_ns_var { |
---|
| 58 | proc q {} { |
---|
| 59 | variable x ;# specifies TCL_NAMESPACE_ONLY to get namespace x |
---|
| 60 | return $x |
---|
| 61 | } |
---|
| 62 | } |
---|
| 63 | test_ns_var::q |
---|
| 64 | } {namespace value} |
---|
| 65 | test var-1.4 {TclLookupVar, no active call frame implies global namespace var} { |
---|
| 66 | set x |
---|
| 67 | } {global value} |
---|
| 68 | test var-1.5 {TclLookupVar, active call frame pushed for namespace eval implies namespace var} { |
---|
| 69 | namespace eval test_ns_var {set x} |
---|
| 70 | } {namespace value} |
---|
| 71 | test var-1.6 {TclLookupVar, name starts with :: implies some namespace var} { |
---|
| 72 | namespace eval test_ns_var {set ::x} |
---|
| 73 | } {global value} |
---|
| 74 | test var-1.7 {TclLookupVar, error finding namespace var} { |
---|
| 75 | list [catch {set a:::b} msg] $msg |
---|
| 76 | } {1 {can't read "a:::b": no such variable}} |
---|
| 77 | test var-1.8 {TclLookupVar, error finding namespace var} { |
---|
| 78 | list [catch {set ::foobarfoo} msg] $msg |
---|
| 79 | } {1 {can't read "::foobarfoo": no such variable}} |
---|
| 80 | test var-1.9 {TclLookupVar, create new namespace var} { |
---|
| 81 | namespace eval test_ns_var { |
---|
| 82 | set v hello |
---|
| 83 | } |
---|
| 84 | } {hello} |
---|
| 85 | test var-1.10 {TclLookupVar, create new namespace var} { |
---|
| 86 | catch {unset y} |
---|
| 87 | namespace eval test_ns_var { |
---|
| 88 | set ::y 789 |
---|
| 89 | } |
---|
| 90 | set y |
---|
| 91 | } {789} |
---|
| 92 | test var-1.11 {TclLookupVar, error creating new namespace var} { |
---|
| 93 | namespace eval test_ns_var { |
---|
| 94 | list [catch {set ::test_ns_var::foo::bar 314159} msg] $msg |
---|
| 95 | } |
---|
| 96 | } {1 {can't set "::test_ns_var::foo::bar": parent namespace doesn't exist}} |
---|
| 97 | test var-1.12 {TclLookupVar, error creating new namespace var} { |
---|
| 98 | namespace eval test_ns_var { |
---|
| 99 | list [catch {set ::test_ns_var::foo:: 1997} msg] $msg |
---|
| 100 | } |
---|
| 101 | } {1 {can't set "::test_ns_var::foo::": parent namespace doesn't exist}} |
---|
| 102 | test var-1.13 {TclLookupVar, new namespace var is created in a particular namespace} { |
---|
| 103 | catch {unset aNeWnAmEiNnS} |
---|
| 104 | namespace eval test_ns_var { |
---|
| 105 | namespace eval test_ns_var2::test_ns_var3 { |
---|
| 106 | set aNeWnAmEiNnS 77777 |
---|
| 107 | } |
---|
| 108 | # namespace which builds a name by traversing nsPtr chain to :: |
---|
| 109 | namespace which -variable test_ns_var2::test_ns_var3::aNeWnAmEiNnS |
---|
| 110 | } |
---|
| 111 | } {::test_ns_var::test_ns_var2::test_ns_var3::aNeWnAmEiNnS} |
---|
| 112 | test var-1.14 {TclLookupVar, namespace code ignores ":"s in middle and end of var names} { |
---|
| 113 | namespace eval test_ns_var { |
---|
| 114 | set : 123 |
---|
| 115 | set v: 456 |
---|
| 116 | set x:y: 789 |
---|
| 117 | list [set :] [set v:] [set x:y:] \ |
---|
| 118 | ${:} ${v:} ${x:y:} \ |
---|
| 119 | [expr {[lsearch [info vars] :] != -1}] \ |
---|
| 120 | [expr {[lsearch [info vars] v:] != -1}] \ |
---|
| 121 | [expr {[lsearch [info vars] x:y:] != -1}] |
---|
| 122 | } |
---|
| 123 | } {123 456 789 123 456 789 1 1 1} |
---|
| 124 | test var-1.15 {TclLookupVar, resurrect variable via upvar to deleted namespace: compiled code path} { |
---|
| 125 | namespace eval test_ns_var { |
---|
| 126 | variable foo 2 |
---|
| 127 | } |
---|
| 128 | proc p {} { |
---|
| 129 | variable ::test_ns_var::foo |
---|
| 130 | lappend result [catch {set foo} msg] $msg |
---|
| 131 | namespace delete ::test_ns_var |
---|
| 132 | lappend result [catch {set foo 3} msg] $msg |
---|
| 133 | lappend result [catch {set foo(3) 3} msg] $msg |
---|
| 134 | } |
---|
| 135 | p |
---|
| 136 | } {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}} |
---|
| 137 | test var-1.16 {TclLookupVar, resurrect variable via upvar to deleted namespace: uncompiled code path} { |
---|
| 138 | namespace eval test_ns_var { |
---|
| 139 | variable result |
---|
| 140 | namespace eval subns { |
---|
| 141 | variable foo 2 |
---|
| 142 | } |
---|
| 143 | upvar 0 subns::foo foo |
---|
| 144 | lappend result [catch {set foo} msg] $msg |
---|
| 145 | namespace delete subns |
---|
| 146 | lappend result [catch {set foo 3} msg] $msg |
---|
| 147 | lappend result [catch {set foo(3) 3} msg] $msg |
---|
| 148 | namespace delete [namespace current] |
---|
| 149 | set result |
---|
| 150 | } |
---|
| 151 | } {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}} |
---|
| 152 | test var-1.17 {TclLookupVar, resurrect array element via upvar to deleted array: compiled code path} { |
---|
| 153 | namespace eval test_ns_var { |
---|
| 154 | variable result |
---|
| 155 | proc p {} { |
---|
| 156 | array set x {1 2 3 4} |
---|
| 157 | upvar 0 x(1) foo |
---|
| 158 | lappend result [catch {set foo} msg] $msg |
---|
| 159 | unset x |
---|
| 160 | lappend result [catch {set foo 3} msg] $msg |
---|
| 161 | } |
---|
| 162 | set result [p] |
---|
| 163 | namespace delete [namespace current] |
---|
| 164 | set result |
---|
| 165 | } |
---|
| 166 | } {0 2 1 {can't set "foo": upvar refers to element in deleted array}} |
---|
| 167 | test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: uncompiled code path} { |
---|
| 168 | namespace eval test_ns_var { |
---|
| 169 | variable result {} |
---|
| 170 | variable x |
---|
| 171 | array set x {1 2 3 4} |
---|
| 172 | upvar 0 x(1) foo |
---|
| 173 | lappend result [catch {set foo} msg] $msg |
---|
| 174 | unset x |
---|
| 175 | lappend result [catch {set foo 3} msg] $msg |
---|
| 176 | namespace delete [namespace current] |
---|
| 177 | set result |
---|
| 178 | } |
---|
| 179 | } {0 2 1 {can't set "foo": upvar refers to element in deleted array}} |
---|
| 180 | test var-1.19 {TclLookupVar, right error message when parsing variable name} { |
---|
| 181 | list [catch {[format set] thisvar(doesntexist)} msg] $msg |
---|
| 182 | } {1 {can't read "thisvar(doesntexist)": no such variable}} |
---|
| 183 | |
---|
| 184 | test var-2.1 {Tcl_LappendObjCmd, create var if new} { |
---|
| 185 | catch {unset x} |
---|
| 186 | lappend x 1 2 |
---|
| 187 | } {1 2} |
---|
| 188 | |
---|
| 189 | test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} { |
---|
| 190 | catch {unset x} |
---|
| 191 | set x 1997 |
---|
| 192 | proc p {} { |
---|
| 193 | global x ;# calls MakeUpvar with TCL_NAMESPACE_ONLY for other var x |
---|
| 194 | return $x |
---|
| 195 | } |
---|
| 196 | p |
---|
| 197 | } {1997} |
---|
| 198 | test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} { |
---|
| 199 | namespace eval test_ns_var { |
---|
| 200 | catch {unset v} |
---|
| 201 | variable v 1998 |
---|
| 202 | proc p {} { |
---|
| 203 | variable v ;# TCL_NAMESPACE_ONLY specified for other var x |
---|
| 204 | return $v |
---|
| 205 | } |
---|
| 206 | p |
---|
| 207 | } |
---|
| 208 | } {1998} |
---|
| 209 | test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} testupvar { |
---|
| 210 | catch {unset a} |
---|
| 211 | set a 123321 |
---|
| 212 | proc p {} { |
---|
| 213 | # create global xx linked to global a |
---|
| 214 | testupvar 1 a {} xx global |
---|
| 215 | } |
---|
| 216 | list [p] $xx [set xx 789] $a |
---|
| 217 | } {{} 123321 789 789} |
---|
| 218 | test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} testupvar { |
---|
| 219 | catch {unset a} |
---|
| 220 | set a 456 |
---|
| 221 | namespace eval test_ns_var { |
---|
| 222 | catch {unset ::test_ns_var::vv} |
---|
| 223 | proc p {} { |
---|
| 224 | # create namespace var vv linked to global a |
---|
| 225 | testupvar 1 a {} vv namespace |
---|
| 226 | } |
---|
| 227 | p |
---|
| 228 | } |
---|
| 229 | list $test_ns_var::vv [set test_ns_var::vv 123] $a |
---|
| 230 | } {456 123 123} |
---|
| 231 | test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} { |
---|
| 232 | catch {unset aaaaa} |
---|
| 233 | catch {unset xxxxx} |
---|
| 234 | set aaaaa 77777 |
---|
| 235 | upvar #0 aaaaa xxxxx |
---|
| 236 | list [set xxxxx] [set aaaaa] |
---|
| 237 | } {77777 77777} |
---|
| 238 | test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} { |
---|
| 239 | catch {unset a} |
---|
| 240 | set a 121212 |
---|
| 241 | namespace eval test_ns_var { |
---|
| 242 | upvar ::a vvv |
---|
| 243 | set vvv |
---|
| 244 | } |
---|
| 245 | } {121212} |
---|
| 246 | test var-3.7 {MakeUpvar, my var has ::s} { |
---|
| 247 | catch {unset a} |
---|
| 248 | set a 789789 |
---|
| 249 | upvar #0 a test_ns_var::lnk |
---|
| 250 | namespace eval test_ns_var { |
---|
| 251 | set lnk |
---|
| 252 | } |
---|
| 253 | } {789789} |
---|
| 254 | test var-3.8 {MakeUpvar, my var already exists in global ns} { |
---|
| 255 | catch {unset aaaaa} |
---|
| 256 | catch {unset xxxxx} |
---|
| 257 | set aaaaa 456654 |
---|
| 258 | set xxxxx hello |
---|
| 259 | upvar #0 aaaaa xxxxx |
---|
| 260 | set xxxxx |
---|
| 261 | } {hello} |
---|
| 262 | test var-3.9 {MakeUpvar, my var has invalid ns name} { |
---|
| 263 | catch {unset aaaaa} |
---|
| 264 | set aaaaa 789789 |
---|
| 265 | list [catch {upvar #0 aaaaa test_ns_fred::lnk} msg] $msg |
---|
| 266 | } {1 {can't create "test_ns_fred::lnk": parent namespace doesn't exist}} |
---|
| 267 | test var-3.10 {MakeUpvar, } { |
---|
| 268 | namespace eval {} { |
---|
| 269 | set bar 0 |
---|
| 270 | namespace eval foo upvar bar bar |
---|
| 271 | set foo::bar 1 |
---|
| 272 | catch {list $bar $foo::bar} msg |
---|
| 273 | unset ::aaaaa |
---|
| 274 | set msg |
---|
| 275 | } |
---|
| 276 | } {1 1} |
---|
| 277 | test var-3.11 {MakeUpvar, my var looks like array elem} -body { |
---|
| 278 | catch {unset aaaaa} |
---|
| 279 | set aaaaa 789789 |
---|
| 280 | upvar #0 aaaaa foo(bar) |
---|
| 281 | } -returnCodes 1 -result {bad variable name "foo(bar)": upvar won't create a scalar variable that looks like an array element} |
---|
| 282 | |
---|
| 283 | test var-4.1 {Tcl_GetVariableName, global variable} testgetvarfullname { |
---|
| 284 | catch {unset a} |
---|
| 285 | set a 123 |
---|
| 286 | testgetvarfullname a global |
---|
| 287 | } ::a |
---|
| 288 | test var-4.2 {Tcl_GetVariableName, namespace variable} testgetvarfullname { |
---|
| 289 | namespace eval test_ns_var { |
---|
| 290 | variable george |
---|
| 291 | testgetvarfullname george namespace |
---|
| 292 | } |
---|
| 293 | } ::test_ns_var::george |
---|
| 294 | test var-4.3 {Tcl_GetVariableName, variable can't be array element} testgetvarfullname { |
---|
| 295 | catch {unset a} |
---|
| 296 | set a(1) foo |
---|
| 297 | list [catch {testgetvarfullname a(1) global} msg] $msg |
---|
| 298 | } {1 {unknown variable "a(1)"}} |
---|
| 299 | |
---|
| 300 | test var-5.1 {Tcl_GetVariableFullName, global variable} { |
---|
| 301 | catch {unset a} |
---|
| 302 | set a bar |
---|
| 303 | namespace which -variable a |
---|
| 304 | } {::a} |
---|
| 305 | test var-5.2 {Tcl_GetVariableFullName, namespace variable} { |
---|
| 306 | namespace eval test_ns_var { |
---|
| 307 | variable martha |
---|
| 308 | namespace which -variable martha |
---|
| 309 | } |
---|
| 310 | } {::test_ns_var::martha} |
---|
| 311 | test var-5.3 {Tcl_GetVariableFullName, namespace variable} { |
---|
| 312 | namespace which -variable test_ns_var::martha |
---|
| 313 | } {::test_ns_var::martha} |
---|
| 314 | |
---|
| 315 | test var-6.1 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { |
---|
| 316 | namespace eval test_ns_var { |
---|
| 317 | variable boeing 777 |
---|
| 318 | } |
---|
| 319 | proc p {} { |
---|
| 320 | global ::test_ns_var::boeing |
---|
| 321 | set boeing |
---|
| 322 | } |
---|
| 323 | p |
---|
| 324 | } {777} |
---|
| 325 | test var-6.2 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { |
---|
| 326 | namespace eval test_ns_var { |
---|
| 327 | namespace eval test_ns_nested { |
---|
| 328 | variable java java |
---|
| 329 | } |
---|
| 330 | proc p {} { |
---|
| 331 | global ::test_ns_var::test_ns_nested::java |
---|
| 332 | set java |
---|
| 333 | } |
---|
| 334 | } |
---|
| 335 | test_ns_var::p |
---|
| 336 | } {java} |
---|
| 337 | test var-6.3 {Tcl_GlobalObjCmd, variable named {} qualified by a namespace name} { |
---|
| 338 | set ::test_ns_var::test_ns_nested:: 24 |
---|
| 339 | proc p {} { |
---|
| 340 | global ::test_ns_var::test_ns_nested:: |
---|
| 341 | set {} |
---|
| 342 | } |
---|
| 343 | p |
---|
| 344 | } {24} |
---|
| 345 | test var-6.4 {Tcl_GlobalObjCmd, variable name matching :*} { |
---|
| 346 | # Test for Tcl Bug 480176 |
---|
| 347 | set :v broken |
---|
| 348 | proc p {} { |
---|
| 349 | global :v |
---|
| 350 | set :v fixed |
---|
| 351 | } |
---|
| 352 | p |
---|
| 353 | set :v |
---|
| 354 | } {fixed} |
---|
| 355 | |
---|
| 356 | test var-7.1 {Tcl_VariableObjCmd, create and initialize one new ns variable} { |
---|
| 357 | catch {namespace delete test_ns_var} |
---|
| 358 | namespace eval test_ns_var { |
---|
| 359 | variable one 1 |
---|
| 360 | } |
---|
| 361 | list [info vars test_ns_var::*] [set test_ns_var::one] |
---|
| 362 | } {::test_ns_var::one 1} |
---|
| 363 | test var-7.2 {Tcl_VariableObjCmd, if new and no value, leave undefined} { |
---|
| 364 | set two 2222222 |
---|
| 365 | namespace eval test_ns_var { |
---|
| 366 | variable two |
---|
| 367 | } |
---|
| 368 | list [info exists test_ns_var::two] [catch {set test_ns_var::two} msg] $msg |
---|
| 369 | } {0 1 {can't read "test_ns_var::two": no such variable}} |
---|
| 370 | test var-7.3 {Tcl_VariableObjCmd, "define" var already created above} { |
---|
| 371 | namespace eval test_ns_var { |
---|
| 372 | variable two 2 |
---|
| 373 | } |
---|
| 374 | list [lsort [info vars test_ns_var::*]] \ |
---|
| 375 | [namespace eval test_ns_var {set two}] |
---|
| 376 | } [list [lsort {::test_ns_var::two ::test_ns_var::one}] 2] |
---|
| 377 | test var-7.4 {Tcl_VariableObjCmd, list of vars} { |
---|
| 378 | namespace eval test_ns_var { |
---|
| 379 | variable three 3 four 4 |
---|
| 380 | } |
---|
| 381 | list [lsort [info vars test_ns_var::*]] \ |
---|
| 382 | [namespace eval test_ns_var {expr $three+$four}] |
---|
| 383 | } [list [lsort {::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one}] 7] |
---|
| 384 | test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} { |
---|
| 385 | catch {unset a} |
---|
| 386 | catch {unset five} |
---|
| 387 | catch {unset six} |
---|
| 388 | set a "" |
---|
| 389 | set five 555 |
---|
| 390 | set six 666 |
---|
| 391 | namespace eval test_ns_var { |
---|
| 392 | variable five 5 six |
---|
| 393 | lappend a $five |
---|
| 394 | } |
---|
| 395 | lappend a $test_ns_var::five \ |
---|
| 396 | [set test_ns_var::six 6] [set test_ns_var::six] $six |
---|
| 397 | catch {unset five} |
---|
| 398 | catch {unset six} |
---|
| 399 | set a |
---|
| 400 | } {5 5 6 6 666} |
---|
| 401 | catch {unset newvar} |
---|
| 402 | test var-7.6 {Tcl_VariableObjCmd, variable name can be qualified} { |
---|
| 403 | namespace eval test_ns_var { |
---|
| 404 | variable ::newvar cheers! |
---|
| 405 | } |
---|
| 406 | set newvar |
---|
| 407 | } {cheers!} |
---|
| 408 | catch {unset newvar} |
---|
| 409 | test var-7.7 {Tcl_VariableObjCmd, bad var name} { |
---|
| 410 | namespace eval test_ns_var { |
---|
| 411 | list [catch {variable sev:::en 7} msg] $msg |
---|
| 412 | } |
---|
| 413 | } {1 {can't define "sev:::en": parent namespace doesn't exist}} |
---|
| 414 | test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, leave value unchanged} { |
---|
| 415 | set a "" |
---|
| 416 | namespace eval test_ns_var { |
---|
| 417 | variable eight 8 |
---|
| 418 | lappend a $eight |
---|
| 419 | variable eight |
---|
| 420 | lappend a $eight |
---|
| 421 | } |
---|
| 422 | set a |
---|
| 423 | } {8 8} |
---|
| 424 | test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} { |
---|
| 425 | catch {namespace delete test_ns_var2} |
---|
| 426 | set a "" |
---|
| 427 | namespace eval test_ns_var2 { |
---|
| 428 | variable x 123 |
---|
| 429 | variable y |
---|
| 430 | variable z |
---|
| 431 | } |
---|
| 432 | lappend a [lsort [info vars test_ns_var2::*]] |
---|
| 433 | lappend a [info exists test_ns_var2::x] [info exists test_ns_var2::y] \ |
---|
| 434 | [info exists test_ns_var2::z] |
---|
| 435 | lappend a [list [catch {set test_ns_var2::y} msg] $msg] |
---|
| 436 | lappend a [lsort [info vars test_ns_var2::*]] |
---|
| 437 | lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z] |
---|
| 438 | lappend a [set test_ns_var2::y hello] |
---|
| 439 | lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z] |
---|
| 440 | lappend a [list [catch {unset test_ns_var2::y} msg] $msg] |
---|
| 441 | lappend a [lsort [info vars test_ns_var2::*]] |
---|
| 442 | lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z] |
---|
| 443 | lappend a [list [catch {unset test_ns_var2::z} msg] $msg] |
---|
| 444 | lappend a [namespace delete test_ns_var2] |
---|
| 445 | set a |
---|
| 446 | } [list [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 1 0 0\ |
---|
| 447 | {1 {can't read "test_ns_var2::y": no such variable}}\ |
---|
| 448 | [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 0 0\ |
---|
| 449 | hello 1 0\ |
---|
| 450 | {0 {}}\ |
---|
| 451 | [lsort {::test_ns_var2::x ::test_ns_var2::z}] 0 0\ |
---|
| 452 | {1 {can't unset "test_ns_var2::z": no such variable}}\ |
---|
| 453 | {}] |
---|
| 454 | test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} { |
---|
| 455 | namespace eval test_ns_var { |
---|
| 456 | proc p {} { |
---|
| 457 | variable eight |
---|
| 458 | list [set eight] [info vars] |
---|
| 459 | } |
---|
| 460 | p |
---|
| 461 | } |
---|
| 462 | } {8 eight} |
---|
| 463 | test var-7.11 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} { |
---|
| 464 | proc p {} { ;# note this proc is at global :: scope |
---|
| 465 | variable test_ns_var::eight |
---|
| 466 | list [set eight] [info vars] |
---|
| 467 | } |
---|
| 468 | p |
---|
| 469 | } {8 eight} |
---|
| 470 | test var-7.12 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} { |
---|
| 471 | namespace eval test_ns_var { |
---|
| 472 | variable {} {My name is empty} |
---|
| 473 | } |
---|
| 474 | proc p {} { ;# note this proc is at global :: scope |
---|
| 475 | variable test_ns_var:: |
---|
| 476 | list [set {}] [info vars] |
---|
| 477 | } |
---|
| 478 | p |
---|
| 479 | } {{My name is empty} {{}}} |
---|
| 480 | test var-7.13 {Tcl_VariableObjCmd, variable named ":"} { |
---|
| 481 | namespace eval test_ns_var { |
---|
| 482 | variable : {My name is ":"} |
---|
| 483 | proc p {} { |
---|
| 484 | variable : |
---|
| 485 | list [set :] [info vars] |
---|
| 486 | } |
---|
| 487 | p |
---|
| 488 | } |
---|
| 489 | } {{My name is ":"} :} |
---|
| 490 | test var-7.14 {Tcl_VariableObjCmd, array element parameter} { |
---|
| 491 | catch {namespace eval test_ns_var { variable arrayvar(1) }} res |
---|
| 492 | set res |
---|
| 493 | } "can't define \"arrayvar(1)\": name refers to an element in an array" |
---|
| 494 | test var-7.15 {Tcl_VariableObjCmd, array element parameter} { |
---|
| 495 | catch { |
---|
| 496 | namespace eval test_ns_var { |
---|
| 497 | variable arrayvar |
---|
| 498 | set arrayvar(1) x |
---|
| 499 | variable arrayvar(1) y |
---|
| 500 | } |
---|
| 501 | } res |
---|
| 502 | set res |
---|
| 503 | } "can't define \"arrayvar(1)\": name refers to an element in an array" |
---|
| 504 | test var-7.16 {Tcl_VariableObjCmd, no args} { |
---|
| 505 | list [catch {variable} msg] $msg |
---|
| 506 | } {1 {wrong # args: should be "variable ?name value...? name ?value?"}} |
---|
| 507 | test var-7.17 {Tcl_VariableObjCmd, no args} { |
---|
| 508 | namespace eval test_ns_var { |
---|
| 509 | list [catch {variable} msg] $msg |
---|
| 510 | } |
---|
| 511 | } {1 {wrong # args: should be "variable ?name value...? name ?value?"}} |
---|
| 512 | |
---|
| 513 | test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} { |
---|
| 514 | catch {namespace delete test_ns_var} |
---|
| 515 | catch {unset a} |
---|
| 516 | namespace eval test_ns_var { |
---|
| 517 | variable v 123 |
---|
| 518 | variable info "" |
---|
| 519 | |
---|
| 520 | proc traceUnset {name1 name2 op} { |
---|
| 521 | variable info |
---|
| 522 | set info [concat $info [list $name1 $name2 $op]] |
---|
| 523 | } |
---|
| 524 | |
---|
| 525 | trace var v u [namespace code traceUnset] |
---|
| 526 | } |
---|
| 527 | list [unset test_ns_var::v] $test_ns_var::info |
---|
| 528 | } {{} {test_ns_var::v {} u}} |
---|
| 529 | |
---|
| 530 | test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called with fully-qualified var names} { |
---|
| 531 | catch {namespace delete test_ns_var} |
---|
| 532 | catch {unset a} |
---|
| 533 | set info "" |
---|
| 534 | namespace eval test_ns_var { |
---|
| 535 | variable v 123 1 |
---|
| 536 | trace var v u ::traceUnset |
---|
| 537 | } |
---|
| 538 | |
---|
| 539 | proc traceUnset {name1 name2 op} { |
---|
| 540 | set ::info [concat $::info [list $name1 $name2 $op]] |
---|
| 541 | } |
---|
| 542 | |
---|
| 543 | list [namespace delete test_ns_var] $::info |
---|
| 544 | } {{} {::test_ns_var::v {} u}} |
---|
| 545 | |
---|
| 546 | test var-9.1 {behaviour of TclGet/SetVar simple get/set} testsetnoerr { |
---|
| 547 | catch {unset u}; catch {unset v} |
---|
| 548 | list \ |
---|
| 549 | [set u a; testsetnoerr u] \ |
---|
| 550 | [testsetnoerr v b] \ |
---|
| 551 | [testseterr u] \ |
---|
| 552 | [unset v; testseterr v b] |
---|
| 553 | } [list {before get a} {before set b} {before get a} {before set b}] |
---|
| 554 | test var-9.2 {behaviour of TclGet/SetVar namespace get/set} testsetnoerr { |
---|
| 555 | catch {namespace delete ns} |
---|
| 556 | namespace eval ns {variable u a; variable v} |
---|
| 557 | list \ |
---|
| 558 | [testsetnoerr ns::u] \ |
---|
| 559 | [testsetnoerr ns::v b] \ |
---|
| 560 | [testseterr ns::u] \ |
---|
| 561 | [unset ns::v; testseterr ns::v b] |
---|
| 562 | } [list {before get a} {before set b} {before get a} {before set b}] |
---|
| 563 | test var-9.3 {behaviour of TclGetVar no variable} testsetnoerr { |
---|
| 564 | catch {unset u} |
---|
| 565 | list \ |
---|
| 566 | [catch {testsetnoerr u} res] $res \ |
---|
| 567 | [catch {testseterr u} res] $res |
---|
| 568 | } {1 {before get} 1 {can't read "u": no such variable}} |
---|
| 569 | test var-9.4 {behaviour of TclGetVar no namespace variable} testsetnoerr { |
---|
| 570 | catch {namespace delete ns} |
---|
| 571 | namespace eval ns {} |
---|
| 572 | list \ |
---|
| 573 | [catch {testsetnoerr ns::w} res] $res \ |
---|
| 574 | [catch {testseterr ns::w} res] $res |
---|
| 575 | } {1 {before get} 1 {can't read "ns::w": no such variable}} |
---|
| 576 | test var-9.5 {behaviour of TclGetVar no namespace} testsetnoerr { |
---|
| 577 | catch {namespace delete ns} |
---|
| 578 | list \ |
---|
| 579 | [catch {testsetnoerr ns::u} res] $res \ |
---|
| 580 | [catch {testseterr ns::v} res] $res |
---|
| 581 | } {1 {before get} 1 {can't read "ns::v": no such variable}} |
---|
| 582 | test var-9.6 {behaviour of TclSetVar no namespace} testsetnoerr { |
---|
| 583 | catch {namespace delete ns} |
---|
| 584 | list \ |
---|
| 585 | [catch {testsetnoerr ns::v 1} res] $res \ |
---|
| 586 | [catch {testseterr ns::v 1} res] $res |
---|
| 587 | } {1 {before set} 1 {can't set "ns::v": parent namespace doesn't exist}} |
---|
| 588 | test var-9.7 {behaviour of TclGetVar array variable} testsetnoerr { |
---|
| 589 | catch {unset arr} |
---|
| 590 | set arr(1) 1; |
---|
| 591 | list \ |
---|
| 592 | [catch {testsetnoerr arr} res] $res \ |
---|
| 593 | [catch {testseterr arr} res] $res |
---|
| 594 | } {1 {before get} 1 {can't read "arr": variable is array}} |
---|
| 595 | test var-9.8 {behaviour of TclSetVar array variable} testsetnoerr { |
---|
| 596 | catch {unset arr} |
---|
| 597 | set arr(1) 1 |
---|
| 598 | list \ |
---|
| 599 | [catch {testsetnoerr arr 2} res] $res \ |
---|
| 600 | [catch {testseterr arr 2} res] $res |
---|
| 601 | } {1 {before set} 1 {can't set "arr": variable is array}} |
---|
| 602 | test var-9.9 {behaviour of TclGetVar read trace success} testsetnoerr { |
---|
| 603 | proc resetvar {val name elem op} {upvar 1 $name v; set v $val} |
---|
| 604 | catch {unset u}; catch {unset v} |
---|
| 605 | set u 10 |
---|
| 606 | trace var u r [list resetvar 1] |
---|
| 607 | trace var v r [list resetvar 2] |
---|
| 608 | list \ |
---|
| 609 | [testsetnoerr u] \ |
---|
| 610 | [testseterr v] |
---|
| 611 | } {{before get 1} {before get 2}} |
---|
| 612 | test var-9.10 {behaviour of TclGetVar read trace error} testsetnoerr { |
---|
| 613 | proc writeonly args {error "write-only"} |
---|
| 614 | set v 456 |
---|
| 615 | trace var v r writeonly |
---|
| 616 | list \ |
---|
| 617 | [catch {testsetnoerr v} msg] $msg \ |
---|
| 618 | [catch {testseterr v} msg] $msg |
---|
| 619 | } {1 {before get} 1 {can't read "v": write-only}} |
---|
| 620 | test var-9.11 {behaviour of TclSetVar write trace success} testsetnoerr { |
---|
| 621 | proc doubleval {name elem op} {upvar 1 $name v; set v [expr {2 * $v}]} |
---|
| 622 | catch {unset u}; catch {unset v} |
---|
| 623 | set v 1 |
---|
| 624 | trace var v w doubleval |
---|
| 625 | trace var u w doubleval |
---|
| 626 | list \ |
---|
| 627 | [testsetnoerr u 2] \ |
---|
| 628 | [testseterr v 3] |
---|
| 629 | } {{before set 4} {before set 6}} |
---|
| 630 | test var-9.12 {behaviour of TclSetVar write trace error} testsetnoerr { |
---|
| 631 | proc readonly args {error "read-only"} |
---|
| 632 | set v 456 |
---|
| 633 | trace var v w readonly |
---|
| 634 | list \ |
---|
| 635 | [catch {testsetnoerr v 2} msg] $msg $v \ |
---|
| 636 | [catch {testseterr v 3} msg] $msg $v |
---|
| 637 | } {1 {before set} 2 1 {can't set "v": read-only} 3} |
---|
| 638 | |
---|
| 639 | test var-10.1 {can't nest arrays with array set} { |
---|
| 640 | catch {unset arr} |
---|
| 641 | list [catch {array set arr(x) {a 1 b 2}} res] $res |
---|
| 642 | } {1 {can't set "arr(x)": variable isn't array}} |
---|
| 643 | test var-10.2 {can't nest arrays with array set} { |
---|
| 644 | catch {unset arr} |
---|
| 645 | list [catch {array set arr(x) {}} res] $res |
---|
| 646 | } {1 {can't set "arr(x)": variable isn't array}} |
---|
| 647 | |
---|
| 648 | test var-11.1 {array unset} { |
---|
| 649 | catch {unset a} |
---|
| 650 | array set a { 1,1 a 1,2 b 2,1 c 2,3 d } |
---|
| 651 | array unset a 1,* |
---|
| 652 | lsort -dict [array names a] |
---|
| 653 | } {2,1 2,3} |
---|
| 654 | test var-11.2 {array unset} { |
---|
| 655 | catch {unset a} |
---|
| 656 | array set a { 1,1 a 1,2 b } |
---|
| 657 | array unset a |
---|
| 658 | array exists a |
---|
| 659 | } 0 |
---|
| 660 | test var-11.3 {array unset errors} { |
---|
| 661 | catch {unset a} |
---|
| 662 | array set a { 1,1 a 1,2 b } |
---|
| 663 | list [catch {array unset a pattern too} msg] $msg |
---|
| 664 | } {1 {wrong # args: should be "array unset arrayName ?pattern?"}} |
---|
| 665 | |
---|
| 666 | test var-12.1 {TclFindCompiledLocals, {} array name} { |
---|
| 667 | namespace eval n { |
---|
| 668 | proc p {} { |
---|
| 669 | variable {} |
---|
| 670 | set (0) 0 |
---|
| 671 | set (1) 1 |
---|
| 672 | set n 2 |
---|
| 673 | set ($n) 2 |
---|
| 674 | set ($n,foo) 2 |
---|
| 675 | } |
---|
| 676 | p |
---|
| 677 | lsort -dictionary [array names {}] |
---|
| 678 | } |
---|
| 679 | } {0 1 2 2,foo} |
---|
| 680 | |
---|
| 681 | test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} { |
---|
| 682 | catch {unset t} |
---|
| 683 | proc foo {var ind op} { |
---|
| 684 | global t |
---|
| 685 | set foo bar |
---|
| 686 | } |
---|
| 687 | namespace eval :: { |
---|
| 688 | set t(1) 1 |
---|
| 689 | trace variable t(1) u foo |
---|
| 690 | unset t |
---|
| 691 | } |
---|
| 692 | set x "If you see this, it worked" |
---|
| 693 | } "If you see this, it worked" |
---|
| 694 | |
---|
| 695 | test var-14.1 {array names syntax} -body { |
---|
| 696 | array names foo bar baz snafu |
---|
| 697 | } -returnCodes 1 -match glob -result * |
---|
| 698 | |
---|
| 699 | test var-14.2 {array names -glob} -body { |
---|
| 700 | array names tcl_platform -glob os |
---|
| 701 | } -returnCodes 0 -match exact -result os |
---|
| 702 | |
---|
| 703 | test var-15.1 {segfault in [unset], [Bug 735335]} { |
---|
| 704 | proc A { name } { |
---|
| 705 | upvar $name var |
---|
| 706 | set var $name |
---|
| 707 | } |
---|
| 708 | # |
---|
| 709 | # Note that the variable name has to be |
---|
| 710 | # unused previously for the segfault to |
---|
| 711 | # be triggered. |
---|
| 712 | # |
---|
| 713 | namespace eval test A useSomeUnlikelyNameHere |
---|
| 714 | namespace eval test unset useSomeUnlikelyNameHere |
---|
| 715 | } {} |
---|
| 716 | |
---|
| 717 | |
---|
| 718 | test var-16.1 {CallVarTraces: save/restore interp error state} { |
---|
| 719 | trace add variable ::errorCode write { ;#} |
---|
| 720 | catch {error foo bar baz} |
---|
| 721 | trace remove variable ::errorCode write { ;#} |
---|
| 722 | set ::errorInfo |
---|
| 723 | } bar |
---|
| 724 | |
---|
| 725 | test var-17.1 {TclArraySet [Bug 1669489]} -setup { |
---|
| 726 | unset -nocomplain ::a |
---|
| 727 | } -body { |
---|
| 728 | namespace eval :: { |
---|
| 729 | set elements {1 2 3 4} |
---|
| 730 | trace add variable a write {string length $elements ;#} |
---|
| 731 | array set a $elements |
---|
| 732 | } |
---|
| 733 | } -cleanup { |
---|
| 734 | unset -nocomplain ::a ::elements |
---|
| 735 | } -result {} |
---|
| 736 | |
---|
| 737 | catch {namespace delete ns} |
---|
| 738 | catch {unset arr} |
---|
| 739 | catch {unset v} |
---|
| 740 | |
---|
| 741 | catch {rename p ""} |
---|
| 742 | catch {namespace delete test_ns_var} |
---|
| 743 | catch {namespace delete test_ns_var2} |
---|
| 744 | catch {unset xx} |
---|
| 745 | catch {unset x} |
---|
| 746 | catch {unset y} |
---|
| 747 | catch {unset i} |
---|
| 748 | catch {unset a} |
---|
| 749 | catch {unset xxxxx} |
---|
| 750 | catch {unset aaaaa} |
---|
| 751 | |
---|
| 752 | # cleanup |
---|
| 753 | ::tcltest::cleanupTests |
---|
| 754 | return |
---|