util/src/TclTk/tcl8.6.12/tests/var.test

   1 # This file contains tests for the tclVar.c source file. Tests appear in the
   2 # same order as the C code that they test. The set of tests is currently
   3 # incomplete since it currently includes only new tests for code changed for
   4 # the addition of Tcl namespaces. Other variable-related tests appear in
   5 # several other test files including namespace.test, set.test, trace.test, and
   6 # upvar.test.
   7 #
   8 # Sourcing this file into Tcl runs the tests and generates output for errors.
   9 # 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 of
  15 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
  16
  17 if {"::tcltest" ni [namespace children]} {
  18     package require tcltest 2.5
  19     namespace import -force ::tcltest::*
  20 }
  21
  22 ::tcltest::loadTestedCommands
  23 catch [list package require -exact Tcltest [info patchlevel]]
  24
  25 testConstraint testupvar [llength [info commands testupvar]]
  26 testConstraint testgetvarfullname [llength [info commands testgetvarfullname]]
  27 testConstraint testsetnoerr [llength [info commands testsetnoerr]]
  28 testConstraint memory [llength [info commands memory]]
  29 if {[testConstraint memory]} {
  30     proc getbytes {} {
  31         return [lindex [split [memory info] \n] 3 3]
  32     }
  33     proc leaktest {script {iterations 3}} {
  34         set end [getbytes]
  35         for {set i 0} {$i < $iterations} {incr i} {
  36             uplevel 1 $script
  37             set tmp $end
  38             set end [getbytes]
  39         }
  40         return [expr {$end - $tmp}]
  41     }
  42 }
  43
  44 catch {rename p ""}
  45 catch {namespace delete test_ns_var}
  46 catch {unset xx}
  47 catch {unset x}
  48 catch {unset y}
  49 catch {unset i}
  50 catch {unset a}
  51 catch {unset arr}
  52 \f
  53 test var-1.1 {TclLookupVar, Array handling} -setup {
  54     catch {unset a}
  55 } -body {
  56     set x "incr"  ;# force no compilation and runtime call to Tcl_IncrCmd
  57     set i 10
  58     set arr(foo) 37
  59     list [$x i] $i [$x arr(foo)] $arr(foo)
  60 } -result {11 11 38 38}
  61 set ::x "global value"
  62 namespace eval test_ns_var {
  63     variable x "namespace value"
  64 }
  65 test var-1.2 {TclLookupVar, TCL_GLOBAL_ONLY implies global namespace var} {
  66     namespace eval test_ns_var {
  67         proc p {} {
  68             global x  ;# specifies TCL_GLOBAL_ONLY to get global x
  69             return $x
  70         }
  71     }
  72     test_ns_var::p
  73 } {global value}
  74 test var-1.3 {TclLookupVar, TCL_NAMESPACE_ONLY implies namespace var} {
  75     namespace eval test_ns_var {
  76         proc q {} {
  77             variable x  ;# specifies TCL_NAMESPACE_ONLY to get namespace x
  78             return $x
  79         }
  80     }
  81     test_ns_var::q
  82 } {namespace value}
  83 test var-1.4 {TclLookupVar, no active call frame implies global namespace var} {
  84     set x
  85 } {global value}
  86 test var-1.5 {TclLookupVar, active call frame pushed for namespace eval implies namespace var} {
  87     namespace eval test_ns_var {set x}
  88 } {namespace value}
  89 test var-1.6 {TclLookupVar, name starts with :: implies some namespace var} {
  90     namespace eval test_ns_var {set ::x}
  91 } {global value}
  92 test var-1.7 {TclLookupVar, error finding namespace var} -body {
  93     set a:::b
  94 } -returnCodes error -result {can't read "a:::b": no such variable}
  95 test var-1.8 {TclLookupVar, error finding namespace var} -body {
  96     set ::foobarfoo
  97 } -returnCodes error -result {can't read "::foobarfoo": no such variable}
  98 test var-1.9 {TclLookupVar, create new namespace var} {
  99     namespace eval test_ns_var {
 100         set v hello
 101     }
 102 } {hello}
 103 test var-1.10 {TclLookupVar, create new namespace var} -setup {
 104     catch {unset y}
 105 } -body {
 106     namespace eval test_ns_var {
 107         set ::y 789
 108     }
 109     set y
 110 } -result {789}
 111 test var-1.11 {TclLookupVar, error creating new namespace var} -body {
 112     namespace eval test_ns_var {
 113         set ::test_ns_var::foo::bar 314159
 114     }
 115 } -returnCodes error -result {can't set "::test_ns_var::foo::bar": parent namespace doesn't exist}
 116 test var-1.12 {TclLookupVar, error creating new namespace var} -body {
 117     namespace eval test_ns_var {
 118         set ::test_ns_var::foo:: 1997
 119     }
 120 } -returnCodes error -result {can't set "::test_ns_var::foo::": parent namespace doesn't exist}
 121 test var-1.13 {TclLookupVar, new namespace var is created in a particular namespace} {
 122     catch {unset aNeWnAmEiNnS}
 123     namespace eval test_ns_var {
 124         namespace eval test_ns_var2::test_ns_var3 {
 125             set aNeWnAmEiNnS 77777
 126         }
 127         # namespace which builds a name by traversing nsPtr chain to ::
 128         namespace which -variable test_ns_var2::test_ns_var3::aNeWnAmEiNnS
 129     }
 130 } {::test_ns_var::test_ns_var2::test_ns_var3::aNeWnAmEiNnS}
 131 test var-1.14 {TclLookupVar, namespace code ignores ":"s in middle and end of var names} {
 132     namespace eval test_ns_var {
 133         set : 123
 134         set v: 456
 135         set x:y: 789
 136         list [set :] [set v:] [set x:y:] \
 137              ${:} ${v:} ${x:y:} \
 138              [expr {":" in [info vars]}] \
 139              [expr {"v:" in [info vars]}] \
 140              [expr {"x:y:" in [info vars]}]
 141     }
 142 } {123 456 789 123 456 789 1 1 1}
 143 test var-1.15 {TclLookupVar, resurrect variable via upvar to deleted namespace: compiled code path} {
 144     namespace eval test_ns_var {
 145         variable foo 2
 146     }
 147     proc p {} {
 148         variable ::test_ns_var::foo
 149         lappend result [catch {set foo} msg] $msg
 150         namespace delete ::test_ns_var
 151         lappend result [catch {set foo 3} msg] $msg
 152         lappend result [catch {set foo(3) 3} msg] $msg
 153     }
 154     p
 155 } {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}}
 156 test var-1.16 {TclLookupVar, resurrect variable via upvar to deleted namespace: uncompiled code path} {
 157     namespace eval test_ns_var {
 158         variable result
 159         namespace eval subns {
 160             variable foo 2
 161         }
 162         upvar 0 subns::foo foo
 163         lappend result [catch {set foo} msg] $msg
 164         namespace delete subns
 165         lappend result [catch {set foo 3} msg] $msg
 166         lappend result [catch {set foo(3) 3} msg] $msg
 167         namespace delete [namespace current]
 168         set result
 169     }
 170 } {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}}
 171 test var-1.17 {TclLookupVar, resurrect array element via upvar to deleted array: compiled code path} {
 172     namespace eval test_ns_var {
 173         variable result
 174         proc p {} {
 175             array set x {1 2 3 4}
 176             upvar 0 x(1) foo
 177             lappend result [catch {set foo} msg] $msg
 178             unset x
 179             lappend result [catch {set foo 3} msg] $msg
 180         }
 181         set result [p]
 182         namespace delete [namespace current]
 183         set result
 184     }
 185 } {0 2 1 {can't set "foo": upvar refers to element in deleted array}}
 186 test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: uncompiled code path} -setup {
 187     unset -nocomplain test_ns_var::x
 188 } -body {
 189     namespace eval test_ns_var {
 190         variable result {}
 191         variable x
 192         array set x {1 2 3 4}
 193         upvar 0 x(1) foo
 194         lappend result [catch {set foo} msg] $msg
 195         unset x
 196         lappend result [catch {set foo 3} msg] $msg
 197         namespace delete [namespace current]
 198         set result
 199     }
 200 } -result {0 2 1 {can't set "foo": upvar refers to element in deleted array}}
 201 test var-1.19 {TclLookupVar, right error message when parsing variable name} -body {
 202     [format set] thisvar(doesntexist)
 203 } -returnCodes error -result {can't read "thisvar(doesntexist)": no such variable}
 204 test var-1.20 {TclLookupVar, regression on utf-8 variable names} -setup {
 205     proc p [list \u20ac \xe4] {info vars}
 206 } -body {
 207     # test variable with non-ascii name is available (euro and a-uml chars here):
 208     list \
 209         [p 1 2] \
 210         [apply [list [list \u20ac \xe4] {info vars}] 1 2] \
 211         [apply [list [list [list \u20ac \u20ac] [list \xe4 \xe4]] {info vars}]] \
 212 } -cleanup {
 213     rename p {}
 214 } -result [lrepeat 3 [list \u20ac \xe4]]
 215 test var-1.21 {TclLookupVar, regression on utf-8 variable names} -setup {
 216     proc p [list [list \u20ac v\u20ac] [list \xe4 v\xe4]] {list [set \u20ac] [set \xe4]}
 217 } -body {
 218     # test variable with non-ascii name (and default) is resolvable (euro and a-uml chars here):
 219     list \
 220         [p] \
 221         [apply [list [list \u20ac \xe4] {list [set \u20ac] [set \xe4]}] v\u20ac v\xe4] \
 222         [apply [list [list [list \u20ac v\u20ac] [list \xe4 v\xe4]] {list [set \u20ac] [set \xe4]}]] \
 223 } -cleanup {
 224     rename p {}
 225 } -result [lrepeat 3 [list v\u20ac v\xe4]]
 226
 227 test var-2.1 {Tcl_LappendObjCmd, create var if new} {
 228     catch {unset x}
 229     lappend x 1 2
 230 } {1 2}
 231
 232 test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} -setup {
 233     catch {unset x}
 234 } -body {
 235     set x 1997
 236     proc p {} {
 237         global x  ;# calls MakeUpvar with TCL_NAMESPACE_ONLY for other var x
 238         return $x
 239     }
 240     p
 241 } -result {1997}
 242 test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} {
 243     namespace eval test_ns_var {
 244         catch {unset v}
 245         variable v 1998
 246         proc p {} {
 247             variable v  ;# TCL_NAMESPACE_ONLY specified for other var x
 248             return $v
 249         }
 250         p
 251     }
 252 } {1998}
 253 test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} -setup {
 254     catch {unset a}
 255 } -constraints testupvar -body {
 256     set a 123321
 257     proc p {} {
 258         # create global xx linked to global a
 259         testupvar 1 a {} xx global
 260     }
 261     list [p] $xx [set xx 789] $a
 262 } -result {{} 123321 789 789}
 263 test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} -setup {
 264     catch {unset a}
 265 } -constraints testupvar -body {
 266     set a 456
 267     namespace eval test_ns_var {
 268         catch {unset ::test_ns_var::vv}
 269         proc p {} {
 270             # create namespace var vv linked to global a
 271             testupvar 1 a {} vv namespace
 272         }
 273         p
 274     }
 275     list $test_ns_var::vv [set test_ns_var::vv 123] $a
 276 } -result {456 123 123}
 277 test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} -setup {
 278     catch {unset aaaaa}
 279     catch {unset xxxxx}
 280 } -body {
 281     set aaaaa 77777
 282     upvar #0 aaaaa xxxxx
 283     list [set xxxxx] [set aaaaa]
 284 } -result {77777 77777}
 285 test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} -setup {
 286     catch {unset a}
 287 } -body {
 288     set a 121212
 289     namespace eval test_ns_var {
 290         upvar ::a vvv
 291         set vvv
 292     }
 293 } -result {121212}
 294 test var-3.7 {MakeUpvar, my var has ::s} -setup {
 295     catch {unset a}
 296 } -body {
 297     set a 789789
 298     upvar #0 a test_ns_var::lnk
 299     namespace eval test_ns_var {
 300         set lnk
 301     }
 302 } -result {789789}
 303 test var-3.8 {MakeUpvar, my var already exists in global ns} -setup {
 304     upvar #0 aaaaa xxxxx
 305     catch {unset aaaaa}
 306     catch {unset xxxxx}
 307 } -body {
 308     set aaaaa 456654
 309     set xxxxx hello
 310     upvar #0 aaaaa xxxxx
 311     set xxxxx
 312 } -result {hello}
 313 test var-3.9 {MakeUpvar, my var has invalid ns name} -setup {
 314     catch {unset aaaaa}
 315 } -returnCodes error -body {
 316     set aaaaa 789789
 317     upvar #0 aaaaa test_ns_fred::lnk
 318 } -cleanup {
 319     unset ::aaaaa
 320 } -result {can't create "test_ns_fred::lnk": parent namespace doesn't exist}
 321 test var-3.10 {MakeUpvar, between namespaces} -body {
 322     namespace eval {} {
 323         variable bar 0
 324         namespace eval foo upvar bar bar
 325         set foo::bar 1
 326         list $bar $foo::bar
 327     }
 328 } -result {1 1}
 329 test var-3.11 {MakeUpvar, my var looks like array elem} -setup {
 330     catch {unset aaaaa}
 331 } -returnCodes error -body {
 332     set aaaaa 789789
 333     upvar #0 aaaaa foo(bar)
 334 } -result {bad variable name "foo(bar)": can't create a scalar variable that looks like an array element}
 335
 336 test var-4.1 {Tcl_GetVariableName, global variable} testgetvarfullname {
 337     catch {unset a}
 338     set a 123
 339     testgetvarfullname a global
 340 } ::a
 341 test var-4.2 {Tcl_GetVariableName, namespace variable} testgetvarfullname {
 342     namespace eval test_ns_var {
 343         variable george
 344         testgetvarfullname george namespace
 345     }
 346 } ::test_ns_var::george
 347 test var-4.3 {Tcl_GetVariableName, variable can't be array element} -setup {
 348     catch {unset a}
 349 } -constraints testgetvarfullname -body {
 350     set a(1) foo
 351     testgetvarfullname a(1) global
 352 } -returnCodes error -result {unknown variable "a(1)"}
 353
 354 test var-5.1 {Tcl_GetVariableFullName, global variable} -setup {
 355     catch {unset a}
 356 } -body {
 357     set a bar
 358     namespace which -variable a
 359 } -result {::a}
 360 test var-5.2 {Tcl_GetVariableFullName, namespace variable} {
 361     namespace eval test_ns_var {
 362         variable martha
 363         namespace which -variable martha
 364     }
 365 } {::test_ns_var::martha}
 366 test var-5.3 {Tcl_GetVariableFullName, namespace variable} -setup {
 367     namespace eval test_ns_var {variable martha}
 368 } -body {
 369     namespace which -variable test_ns_var::martha
 370 } -result {::test_ns_var::martha}
 371
 372 test var-6.1 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} {
 373     namespace eval test_ns_var {
 374         variable boeing 777
 375     }
 376     apply {{} {
 377         global ::test_ns_var::boeing
 378         set boeing
 379     }}
 380 } {777}
 381 test var-6.2 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} {
 382     namespace eval test_ns_var {
 383         namespace eval test_ns_nested {
 384             variable java java
 385         }
 386         proc p {} {
 387             global ::test_ns_var::test_ns_nested::java
 388             set java
 389         }
 390     }
 391     test_ns_var::p
 392 } {java}
 393 test var-6.3 {Tcl_GlobalObjCmd, variable named {} qualified by a namespace name} {
 394     namespace eval ::test_ns_var::test_ns_nested {}
 395     set ::test_ns_var::test_ns_nested:: 24
 396     apply {{} {
 397         global ::test_ns_var::test_ns_nested::
 398         set {}
 399     }}
 400 } {24}
 401 test var-6.4 {Tcl_GlobalObjCmd, variable name matching :*} {
 402     # Test for Tcl Bug 480176
 403     set :v broken
 404     proc p {} {
 405         global :v
 406         set :v fixed
 407     }
 408     p
 409     set :v
 410 } {fixed}
 411 test var-6.5 {Tcl_GlobalObjCmd, no-op case (TIP 323)} {
 412     global
 413 } {}
 414 test var-6.6 {Tcl_GlobalObjCmd, no-op case (TIP 323)} {
 415     proc p {} {
 416         global
 417     }
 418     p
 419 } {}
 420
 421 test var-7.1 {Tcl_VariableObjCmd, create and initialize one new ns variable} -setup {
 422     catch {namespace delete test_ns_var}
 423 } -body {
 424     namespace eval test_ns_var {
 425         variable one 1
 426     }
 427     list [info vars test_ns_var::*] [set test_ns_var::one]
 428 } -result {::test_ns_var::one 1}
 429 test var-7.2 {Tcl_VariableObjCmd, if new and no value, leave undefined} {
 430     set two 2222222
 431     namespace eval test_ns_var {
 432         variable two
 433     }
 434     list [info exists test_ns_var::two] [catch {set test_ns_var::two} msg] $msg
 435 } {0 1 {can't read "test_ns_var::two": no such variable}}
 436 test var-7.3 {Tcl_VariableObjCmd, "define" var already created above} -setup {
 437     catch {namespace delete test_ns_var}
 438     namespace eval test_ns_var {variable one 1}
 439 } -body {
 440     namespace eval test_ns_var {
 441         variable two 2
 442     }
 443     list [lsort [info vars test_ns_var::*]] \
 444          [namespace eval test_ns_var {set two}]
 445 } -result [list [lsort {::test_ns_var::two ::test_ns_var::one}] 2]
 446 test var-7.4 {Tcl_VariableObjCmd, list of vars} -setup {
 447     catch {namespace delete test_ns_var}
 448     namespace eval test_ns_var {variable one 1; variable two 2}
 449 } -body {
 450     namespace eval test_ns_var {
 451         variable three 3 four 4
 452     }
 453     list [lsort [info vars test_ns_var::*]] \
 454          [namespace eval test_ns_var {expr {$three+$four}}]
 455 } -result [list [lsort {::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one}] 7]
 456 test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} -setup {
 457     catch {unset a}
 458     catch {unset five}
 459     catch {unset six}
 460 } -body {
 461     set a ""
 462     set five 555
 463     set six  666
 464     namespace eval test_ns_var {
 465         variable five 5 six
 466         lappend a $five
 467     }
 468     lappend a $test_ns_var::five \
 469         [set test_ns_var::six 6] [set test_ns_var::six] $six
 470 } -cleanup {
 471     catch {unset five}
 472     catch {unset six}
 473 } -result {5 5 6 6 666}
 474 test var-7.6 {Tcl_VariableObjCmd, variable name can be qualified} -setup {
 475     catch {unset newvar}
 476 } -body {
 477     namespace eval test_ns_var {
 478         variable ::newvar cheers!
 479     }
 480     return $newvar
 481 } -cleanup {
 482     catch {unset newvar}
 483 } -result {cheers!}
 484 test var-7.7 {Tcl_VariableObjCmd, bad var name} -returnCodes error -body {
 485     namespace eval test_ns_var {
 486         variable sev:::en 7
 487     }
 488 } -result {can't define "sev:::en": parent namespace doesn't exist}
 489 test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, leave value unchanged} {
 490     set a ""
 491     namespace eval test_ns_var {
 492         variable eight 8
 493         lappend a $eight
 494         variable eight
 495         lappend a $eight
 496     }
 497     set a
 498 } {8 8}
 499 test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} -setup {
 500     catch {namespace delete test_ns_var2}
 501 } -body {
 502     set a ""
 503     namespace eval test_ns_var2 {
 504         variable x 123
 505         variable y
 506         variable z
 507     }
 508     lappend a [lsort [info vars test_ns_var2::*]]
 509     lappend a [info exists test_ns_var2::x] [info exists test_ns_var2::y] \
 510         [info exists test_ns_var2::z]
 511     lappend a [list [catch {set test_ns_var2::y} msg] $msg]
 512     lappend a [lsort [info vars test_ns_var2::*]]
 513     lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
 514     lappend a [set test_ns_var2::y hello]
 515     lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
 516     lappend a [list [catch {unset test_ns_var2::y} msg] $msg]
 517     lappend a [lsort [info vars test_ns_var2::*]]
 518     lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
 519     lappend a [list [catch {unset test_ns_var2::z} msg] $msg]
 520     lappend a [namespace delete test_ns_var2]
 521 } -result [list [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 1 0 0\
 522         {1 {can't read "test_ns_var2::y": no such variable}}\
 523         [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 0 0\
 524         hello 1 0\
 525         {0 {}}\
 526         [lsort {::test_ns_var2::x ::test_ns_var2::z}] 0 0\
 527         {1 {can't unset "test_ns_var2::z": no such variable}}\
 528         {}]
 529 test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} -setup {
 530     namespace eval test_ns_var { variable eight 8 }
 531 } -body {
 532     namespace eval test_ns_var {
 533         proc p {} {
 534             variable eight
 535             list [set eight] [info vars]
 536         }
 537         p
 538     }
 539 } -result {8 eight}
 540 test var-7.11 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} -setup {
 541     namespace eval test_ns_var { variable eight 8 }
 542 } -body {
 543     proc p {} {   ;# note this proc is at global :: scope
 544         variable test_ns_var::eight
 545         list [set eight] [info vars]
 546     }
 547     p
 548 } -result {8 eight}
 549 test var-7.12 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
 550     namespace eval test_ns_var {
 551         variable {} {My name is empty}
 552     }
 553     proc p {} {   ;# note this proc is at global :: scope
 554         variable test_ns_var::
 555         list [set {}] [info vars]
 556     }
 557     p
 558 } {{My name is empty} {{}}}
 559 test var-7.13 {Tcl_VariableObjCmd, variable named ":"} {
 560     namespace eval test_ns_var {
 561         variable : {My name is ":"}
 562         proc p {} {
 563             variable :
 564             list [set :] [info vars]
 565         }
 566         p
 567     }
 568 } {{My name is ":"} :}
 569 test var-7.14 {Tcl_VariableObjCmd, array element parameter} -body {
 570     namespace eval test_ns_var { variable arrayvar(1) }
 571 } -returnCodes error -result "can't define \"arrayvar(1)\": name refers to an element in an array"
 572 test var-7.15 {Tcl_VariableObjCmd, array element parameter} -body {
 573     namespace eval test_ns_var {
 574         variable arrayvar
 575         set arrayvar(1) x
 576         variable arrayvar(1) y
 577     }
 578 } -returnCodes error -result "can't define \"arrayvar(1)\": name refers to an element in an array"
 579 test var-7.16 {Tcl_VariableObjCmd, no args (TIP 323)} {
 580     variable
 581 } {}
 582 test var-7.17 {Tcl_VariableObjCmd, no args (TIP 323)} {
 583     namespace eval test_ns_var {
 584         variable
 585     }
 586 } {}
 587
 588 test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} -setup {
 589     catch {namespace delete test_ns_var}
 590     catch {unset a}
 591 } -body {
 592     namespace eval test_ns_var {
 593         variable v 123
 594         variable info ""
 595         proc traceUnset {name1 name2 op} {
 596             variable info
 597             set info [concat $info [list $name1 $name2 $op]]
 598         }
 599         trace var v u [namespace code traceUnset]
 600     }
 601     list [unset test_ns_var::v] $test_ns_var::info
 602 } -result {{} {test_ns_var::v {} u}}
 603 test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called with fully-qualified var names} -setup {
 604     catch {namespace delete test_ns_var}
 605     catch {unset a}
 606 } -body {
 607     set info ""
 608     namespace eval test_ns_var {
 609         variable v 123 1
 610         trace var v u ::traceUnset
 611     }
 612     proc traceUnset {name1 name2 op} {
 613         set ::info [concat $::info [list $name1 $name2 $op]]
 614     }
 615     list [namespace delete test_ns_var] $::info
 616 } -result {{} {::test_ns_var::v {} u}}
 617
 618 test var-8.3 {TclDeleteNamespaceVars, mem leak} -constraints memory -setup {
 619     proc ::t {a i o} {
 620         set $a 321
 621     }
 622 } -body {
 623     leaktest {
 624         namespace eval n {
 625             variable v 123
 626             trace variable v u ::t
 627         }
 628         namespace delete n
 629     }
 630 } -cleanup {
 631     rename ::t {}
 632 } -result 0
 633
 634 test var-9.1 {behaviour of TclGet/SetVar simple get/set} -setup {
 635     catch {unset u}
 636     catch {unset v}
 637 } -constraints testsetnoerr -body {
 638     list \
 639         [set u a; testsetnoerr u] \
 640         [testsetnoerr v b] \
 641         [testseterr u] \
 642         [unset v; testseterr v b]
 643 } -result [list {before get a} {before set b} {before get a} {before set b}]
 644 test var-9.2 {behaviour of TclGet/SetVar namespace get/set} -setup {
 645     catch {namespace delete ns}
 646 } -constraints testsetnoerr -body {
 647     namespace eval ns {variable u a; variable v}
 648     list \
 649         [testsetnoerr ns::u] \
 650         [testsetnoerr ns::v b] \
 651         [testseterr ns::u] \
 652         [unset ns::v; testseterr ns::v b]
 653 } -result [list {before get a} {before set b} {before get a} {before set b}]
 654 test var-9.3 {behaviour of TclGetVar no variable} -setup {
 655     catch {unset u}
 656 } -constraints testsetnoerr -body {
 657     list \
 658         [catch {testsetnoerr u} res] $res \
 659         [catch {testseterr u} res] $res
 660 } -result {1 {before get} 1 {can't read "u": no such variable}}
 661 test var-9.4 {behaviour of TclGetVar no namespace variable} -setup {
 662     catch {namespace delete ns}
 663 } -constraints testsetnoerr -body {
 664     namespace eval ns {}
 665     list \
 666         [catch {testsetnoerr ns::w} res] $res \
 667         [catch {testseterr ns::w} res] $res
 668 } -result {1 {before get} 1 {can't read "ns::w": no such variable}}
 669 test var-9.5 {behaviour of TclGetVar no namespace} -setup {
 670     catch {namespace delete ns}
 671 } -constraints testsetnoerr -body {
 672     list \
 673         [catch {testsetnoerr ns::u} res] $res \
 674         [catch {testseterr ns::v} res] $res
 675 } -result {1 {before get} 1 {can't read "ns::v": no such variable}}
 676 test var-9.6 {behaviour of TclSetVar no namespace} -setup {
 677     catch {namespace delete ns}
 678 } -constraints testsetnoerr -body {
 679     list \
 680         [catch {testsetnoerr ns::v 1} res] $res \
 681         [catch {testseterr ns::v 1} res] $res
 682 } -result {1 {before set} 1 {can't set "ns::v": parent namespace doesn't exist}}
 683 test var-9.7 {behaviour of TclGetVar array variable} -setup {
 684     catch {unset arr}
 685 } -constraints testsetnoerr -body {
 686     set arr(1) 1
 687     list \
 688         [catch {testsetnoerr arr} res] $res \
 689         [catch {testseterr arr} res] $res
 690 } -result {1 {before get} 1 {can't read "arr": variable is array}}
 691 test var-9.8 {behaviour of TclSetVar array variable} -setup {
 692     catch {unset arr}
 693 } -constraints testsetnoerr -body {
 694     set arr(1) 1
 695     list \
 696         [catch {testsetnoerr arr 2} res] $res \
 697         [catch {testseterr arr 2} res] $res
 698 } -result {1 {before set} 1 {can't set "arr": variable is array}}
 699 test var-9.9 {behaviour of TclGetVar read trace success} -setup {
 700     catch {unset u}
 701     catch {unset v}
 702 } -constraints testsetnoerr -body {
 703     proc resetvar {val name elem op} {upvar 1 $name v; set v $val}
 704     set u 10
 705     trace var u r [list resetvar 1]
 706     trace var v r [list resetvar 2]
 707     list \
 708         [testsetnoerr u] \
 709         [testseterr v]
 710 } -result {{before get 1} {before get 2}}
 711 test var-9.10 {behaviour of TclGetVar read trace error} testsetnoerr {
 712     proc writeonly args {error "write-only"}
 713     set v 456
 714     trace var v r writeonly
 715     list \
 716         [catch {testsetnoerr v} msg] $msg \
 717         [catch {testseterr v} msg] $msg
 718 } {1 {before get} 1 {can't read "v": write-only}}
 719 test var-9.11 {behaviour of TclSetVar write trace success} -setup {
 720     catch {unset u}
 721     catch {unset v}
 722 } -constraints testsetnoerr -body {
 723     proc doubleval {name elem op} {upvar 1 $name v; set v [expr {2 * $v}]}
 724     set v 1
 725     trace var v w doubleval
 726     trace var u w doubleval
 727     list \
 728         [testsetnoerr u 2] \
 729         [testseterr v 3]
 730 } -result {{before set 4} {before set 6}}
 731 test var-9.12 {behaviour of TclSetVar write trace error} testsetnoerr {
 732     proc readonly args {error "read-only"}
 733     set v 456
 734     trace var v w readonly
 735     list \
 736         [catch {testsetnoerr v 2} msg] $msg $v \
 737         [catch {testseterr v 3} msg] $msg $v
 738 } {1 {before set} 2 1 {can't set "v": read-only} 3}
 739
 740 test var-10.1 {can't nest arrays with array set} -setup {
 741    catch {unset arr}
 742 } -returnCodes error -body {
 743    array set arr(x) {a 1 b 2}
 744 } -result {can't set "arr(x)": variable isn't array}
 745 test var-10.2 {can't nest arrays with array set} -setup {
 746    catch {unset arr}
 747 } -returnCodes error -body {
 748    array set arr(x) {}
 749 } -result {can't set "arr(x)": variable isn't array}
 750
 751 test var-11.1 {array unset} -setup {
 752     catch {unset a}
 753 } -body {
 754     array set a { 1,1 a 1,2 b 2,1 c 2,3 d }
 755     array unset a 1,*
 756     lsort -dict [array names a]
 757 } -result {2,1 2,3}
 758 test var-11.2 {array unset} -setup {
 759     catch {unset a}
 760 } -body {
 761     array set a { 1,1 a 1,2 b }
 762     array unset a
 763     array exists a
 764 } -result 0
 765 test var-11.3 {array unset errors} -setup {
 766     catch {unset a}
 767 } -returnCodes error -body {
 768     array set a { 1,1 a 1,2 b }
 769     array unset a pattern too
 770 } -result {wrong # args: should be "array unset arrayName ?pattern?"}
 771
 772 test var-12.1 {TclFindCompiledLocals, {} array name} {
 773     namespace eval n {
 774         proc p {} {
 775             variable {}
 776             set (0) 0
 777             set (1) 1
 778             set n 2
 779             set ($n) 2
 780             set ($n,foo) 2
 781         }
 782         p
 783         lsort -dictionary [array names {}]
 784     }
 785 } {0 1 2 2,foo}
 786
 787 test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} -setup {
 788     catch {unset t}
 789 } -body {
 790     proc foo {var ind op} {
 791         global t
 792         set foo bar
 793     }
 794     namespace eval :: {
 795         set t(1) 1
 796         trace variable t(1) u foo
 797         unset t
 798     }
 799     set x "If you see this, it worked"
 800 } -result "If you see this, it worked"
 801 test var-13.2 {unset array with search, bug 46a2410650} -body {
 802     apply {{} {
 803         array set a {aa 11 bb 22 cc 33 dd 44 ee 55 ff 66}
 804         set s [array startsearch a]
 805         unset a([array nextelement a $s])
 806         array nextelement a $s
 807     }}
 808 } -returnCodes error -result {couldn't find search "s-1-a"}
 809 test var-13.3 {unset array with search, SIGSEGV, bug 46a2410650} -body {
 810     apply {{} {
 811         array set a {aa 11 bb 22 cc 33 dd 44 ee 55 ff 66}
 812         set s [array startsearch a]
 813         unset a(ff)
 814         array nextelement a $s
 815     }}
 816 } -returnCodes error -result {couldn't find search "s-1-a"}
 817
 818 test var-14.1 {array names syntax} -body {
 819     array names foo bar baz snafu
 820 } -returnCodes 1 -match glob -result *
 821 test var-14.2 {array names -glob} -body {
 822     array names tcl_platform -glob os
 823 } -result os
 824
 825 test var-15.1 {segfault in [unset], [Bug 735335]} {
 826     proc A { name } {
 827         upvar $name var
 828         set var $name
 829     }
 830     #
 831     # Note that the variable name has to be
 832     # unused previously for the segfault to
 833     # be triggered.
 834     #
 835     namespace eval test A useSomeUnlikelyNameHere
 836     namespace eval test unset useSomeUnlikelyNameHere
 837 } {}
 838 test var-15.2 {compiled unset evaluation order, Bug 3970f54c4e} {
 839     apply {{} {unset foo [return ok]}}
 840 } ok
 841
 842 test var-16.1 {CallVarTraces: save/restore interp error state} {
 843     trace add variable ::errorCode write " ;#"
 844     catch {error foo bar baz}
 845     trace remove variable ::errorCode write " ;#"
 846     set ::errorInfo
 847 } bar
 848
 849 test var-17.1 {TclArraySet [Bug 1669489]} -setup {
 850     unset -nocomplain ::a
 851 } -body {
 852     namespace eval :: {
 853         set elements {1 2 3 4}
 854         trace add variable a write "string length \$elements ;#"
 855         array set a $elements
 856     }
 857 } -cleanup {
 858     unset -nocomplain ::a ::elements
 859 } -result {}
 860 test var-17.2 {TclArraySet Dict shortcut only on pure value} -setup {
 861     unset -nocomplain a d
 862     set d {p 1 p 2}
 863     dict get $d p
 864     set foo 0
 865 } -body {
 866     trace add variable a write "[list incr [namespace which -variable foo]];#"
 867     array set a $d
 868     set foo
 869 } -cleanup {
 870     unset -nocomplain a d foo
 871 } -result 2
 872
 873 test var-18.1 {array unset and unset traces: Bug 2939073} -setup {
 874     set already 0
 875     unset -nocomplain x
 876 } -body {
 877     array set x {e 1 i 1}
 878     trace add variable x unset {apply {args {
 879         global already x
 880         if {!$already} {
 881             set already 1
 882             unset x(i)
 883         }
 884     }}}
 885     # The next command would crash reliably with memory debugging prior to the
 886     # bug fix.
 887     array unset x *
 888     array size x
 889 } -cleanup {
 890     unset x already
 891 } -result 0
 892
 893 test var-19.1 {crash when freeing locals hashtable: Bug 3037525} {
 894     proc foo {} { catch {upvar 0 dummy \$index} }
 895     foo ; # This crashes without the fix for the bug
 896     rename foo {}
 897 } {}
 898
 899 test var-20.1 {array set compilation correctness: Bug 3603163} -setup {
 900     unset -nocomplain x
 901 } -body {
 902     apply {{} {
 903         global x
 904         array set x {a 1}
 905     }}
 906     array size x
 907 } -result 1
 908 test var-20.2 {array set compilation correctness: Bug 3603163} -setup {
 909     unset -nocomplain x
 910 } -body {
 911     apply {{} {
 912         global x
 913         array set x {}
 914     }}
 915     array size x
 916 } -result 0
 917 test var-20.3 {array set compilation correctness: Bug 3603163} -setup {
 918     unset -nocomplain x
 919 } -body {
 920     apply {{} {
 921         array set ::x {a 1}
 922     }}
 923     array size x
 924 } -result 1
 925 test var-20.4 {array set compilation correctness: Bug 3603163} -setup {
 926     unset -nocomplain x
 927 } -body {
 928     apply {{} {
 929         array set ::x {}
 930     }}
 931     array size x
 932 } -result 0
 933 test var-20.5 {array set compilation correctness: Bug 3603163} -setup {
 934     unset -nocomplain x
 935 } -body {
 936     apply {{} {
 937         global x
 938         eval {array set x {a 1}}
 939     }}
 940     array size x
 941 } -result 1
 942 test var-20.6 {array set compilation correctness: Bug 3603163} -setup {
 943     unset -nocomplain x
 944 } -body {
 945     apply {{} {
 946         global x
 947         eval {array set x {}}
 948     }}
 949     array size x
 950 } -result 0
 951 test var-20.7 {array set compilation correctness: Bug 3603163} -setup {
 952     unset -nocomplain x
 953 } -body {
 954     apply {{} {
 955         eval {array set ::x {a 1}}
 956     }}
 957     array size x
 958 } -result 1
 959 test var-20.8 {array set compilation correctness: Bug 3603163} -setup {
 960     unset -nocomplain x
 961 } -body {
 962     apply {{} {
 963         eval {array set ::x {}}
 964     }}
 965     array size x
 966 } -result 0
 967 test var-20.9 {[bc1a96407a] array set compiled w/ trace} -setup {
 968     variable foo
 969     variable lambda
 970     unset -nocomplain lambda foo
 971     array set foo {}
 972     lappend lambda {}
 973     lappend lambda [list array set [namespace which -variable foo] {a 1}]
 974 } -body {
 975     after 0 [list apply $lambda]
 976     vwait [namespace which -variable foo]
 977 } -cleanup {
 978     unset -nocomplain lambda foo
 979 } -result {}
 980 test var-20.10 {[bc1a96407a] array set don't compile bad varname} -body {
 981     apply {{} {set name foo(bar); array set $name {a 1}}}
 982 } -returnCodes error -match glob -result *
 983 test var-20.11 {array set don't compile bad initializer} -setup {
 984     unset -nocomplain foo
 985     trace add variable foo array {set foo(bar) baz;#}
 986 } -body {
 987     catch {array set foo bad}
 988     set foo(bar)
 989 } -cleanup {
 990     unset -nocomplain foo
 991 } -result baz
 992 test var-20.12 {array set don't compile bad initializer} -setup {
 993     unset -nocomplain ::foo
 994     trace add variable ::foo array {set ::foo(bar) baz;#}
 995 } -body {
 996     catch {apply {{} {
 997         set value bad
 998         array set ::foo $value
 999
1000     }}}
1001     set ::foo(bar)
1002 } -cleanup {
1003     unset -nocomplain ::foo
1004 } -result baz
1005
1006 test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup {
1007     proc linenumber {} {dict get [info frame -1] line}
1008 } -body {
1009     apply {n {
1010         set foo bar
1011         unset foo {*}{
1012         } [return [incr n -[linenumber]]]
1013     }} [linenumber]
1014 } -cleanup {
1015     rename linenumber {}
1016 } -result 1
1017
1018 test var-22.0 {leak in array element unset: Bug a3309d01db} -setup {
1019     proc getbytes {} {
1020         lindex [split [memory info] \n] 3 3
1021     }
1022     proc doit k {
1023         variable A
1024         set A($k) {}
1025         foreach n [array names A] {
1026             if {$n <= $k-1} {
1027                 unset A($n)
1028             }
1029         }
1030     }
1031 } -constraints memory -body {
1032     set end [getbytes]
1033     for {set i 0} {$i < 5} {incr i} {
1034         doit $i
1035         set tmp $end
1036         set end [getbytes]
1037     }
1038     set leakedBytes [expr {$end - $tmp}]
1039 } -cleanup {
1040     array unset A
1041     rename getbytes {}
1042     rename doit {}
1043 } -result 0
1044 test var-22.1 {leak in localVarName internalrep: Bug 80304238ac} -setup {
1045     proc getbytes {} {
1046         lindex [split [memory info] \n] 3 3
1047     }
1048     proc doit {} {
1049         interp create child
1050         child eval {
1051             proc doit script {
1052                 eval $script
1053                 set foo bar
1054             }
1055             doit {foreach foo baz {}}
1056         }
1057         interp delete child
1058     }
1059 } -constraints memory -body {
1060     set end [getbytes]
1061     for {set i 0} {$i < 5} {incr i} {
1062         doit
1063         set tmp $end
1064         set end [getbytes]
1065     }
1066     set leakedBytes [expr {$end - $tmp}]
1067 } -cleanup {
1068     array unset A
1069     rename getbytes {}
1070     rename doit {}
1071 } -result 0
1072
1073 \f
1074 catch {namespace delete ns}
1075 catch {unset arr}
1076 catch {unset v}
1077
1078 catch {rename p ""}
1079 catch {namespace delete test_ns_var}
1080 catch {namespace delete test_ns_var2}
1081 catch {unset xx}
1082 catch {unset x}
1083 catch {unset y}
1084 catch {unset i}
1085 catch {unset a}
1086 catch {unset xxxxx}
1087 catch {unset aaaaa}
1088
1089 # cleanup
1090 ::tcltest::cleanupTests
1091 return
1092
1093 # Local Variables:
1094 # mode: tcl
1095 # End: