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 © 1997 Sun Microsystems, Inc. 12# Copyright © 1998-1999 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 17if {"::tcltest" ni [namespace children]} { 18 package require tcltest 2.5 19 namespace import -force ::tcltest::* 20} 21 22::tcltest::loadTestedCommands 23catch [list package require -exact tcl::test [info patchlevel]] 24 25testConstraint testupvar [llength [info commands testupvar]] 26testConstraint testgetvarfullname [llength [info commands testgetvarfullname]] 27testConstraint testsetnoerr [llength [info commands testsetnoerr]] 28testConstraint memory [llength [info commands memory]] 29if {[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 45catch {rename p ""} 46catch {namespace delete test_ns_var} 47catch {unset xx} 48catch {unset x} 49catch {unset y} 50catch {unset i} 51catch {unset a} 52catch {unset arr} 53 54test var-1.1 {TclLookupVar, Array handling} -setup { 55 catch {unset a} 56} -body { 57 set x "incr" ;# force no compilation and runtime call to Tcl_IncrCmd 58 set i 10 59 set arr(foo) 37 60 list [$x i] $i [$x arr(foo)] $arr(foo) 61} -result {11 11 38 38} 62set ::x "global value" 63namespace eval test_ns_var { 64 variable x "namespace value" 65} 66test var-1.2 {TclLookupVar, TCL_GLOBAL_ONLY implies global namespace var} { 67 namespace eval test_ns_var { 68 proc p {} { 69 global x ;# specifies TCL_GLOBAL_ONLY to get global x 70 return $x 71 } 72 } 73 test_ns_var::p 74} {global value} 75test var-1.3 {TclLookupVar, TCL_NAMESPACE_ONLY implies namespace var} { 76 namespace eval test_ns_var { 77 proc q {} { 78 variable x ;# specifies TCL_NAMESPACE_ONLY to get namespace x 79 return $x 80 } 81 } 82 test_ns_var::q 83} {namespace value} 84test var-1.4 {TclLookupVar, no active call frame implies global namespace var} { 85 set x 86} {global value} 87test var-1.5 {TclLookupVar, active call frame pushed for namespace eval implies namespace var} { 88 namespace eval test_ns_var {set x} 89} {namespace value} 90test var-1.6 {TclLookupVar, name starts with :: implies some namespace var} { 91 namespace eval test_ns_var {set ::x} 92} {global value} 93test var-1.7 {TclLookupVar, error finding namespace var} -body { 94 set a:::b 95} -returnCodes error -result {can't read "a:::b": no such variable} 96test var-1.8 {TclLookupVar, error finding namespace var} -body { 97 set ::foobarfoo 98} -returnCodes error -result {can't read "::foobarfoo": no such variable} 99test var-1.9 {TclLookupVar, create new namespace var} { 100 namespace eval test_ns_var { 101 set v hello 102 } 103} {hello} 104test var-1.10 {TclLookupVar, create new namespace var} -setup { 105 catch {unset y} 106} -body { 107 namespace eval test_ns_var { 108 set ::y 789 109 } 110 set y 111} -result {789} 112test var-1.11 {TclLookupVar, error creating new namespace var} -body { 113 namespace eval test_ns_var { 114 set ::test_ns_var::foo::bar 314159 115 } 116} -returnCodes error -result {can't set "::test_ns_var::foo::bar": parent namespace doesn't exist} 117test var-1.12 {TclLookupVar, error creating new namespace var} -body { 118 namespace eval test_ns_var { 119 set ::test_ns_var::foo:: 1997 120 } 121} -returnCodes error -result {can't set "::test_ns_var::foo::": parent namespace doesn't exist} 122test var-1.13 {TclLookupVar, new namespace var is created in a particular namespace} { 123 catch {unset aNeWnAmEiNnS} 124 namespace eval test_ns_var { 125 namespace eval test_ns_var2::test_ns_var3 { 126 set aNeWnAmEiNnS 77777 127 } 128 # namespace which builds a name by traversing nsPtr chain to :: 129 namespace which -variable test_ns_var2::test_ns_var3::aNeWnAmEiNnS 130 } 131} {::test_ns_var::test_ns_var2::test_ns_var3::aNeWnAmEiNnS} 132test var-1.14 {TclLookupVar, namespace code ignores ":"s in middle and end of var names} { 133 namespace eval test_ns_var { 134 set : 123 135 set v: 456 136 set x:y: 789 137 list [set :] [set v:] [set x:y:] \ 138 ${:} ${v:} ${x:y:} \ 139 [expr {":" in [info vars]}] \ 140 [expr {"v:" in [info vars]}] \ 141 [expr {"x:y:" in [info vars]}] 142 } 143} {123 456 789 123 456 789 1 1 1} 144test var-1.15 {TclLookupVar, resurrect variable via upvar to deleted namespace: compiled code path} { 145 namespace eval test_ns_var { 146 variable foo 2 147 } 148 proc p {} { 149 variable ::test_ns_var::foo 150 lappend result [catch {set foo} msg] $msg 151 namespace delete ::test_ns_var 152 lappend result [catch {set foo 3} msg] $msg 153 lappend result [catch {set foo(3) 3} msg] $msg 154 } 155 p 156} {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}} 157test var-1.16 {TclLookupVar, resurrect variable via upvar to deleted namespace: uncompiled code path} { 158 namespace eval test_ns_var { 159 variable result 160 namespace eval subns { 161 variable foo 2 162 } 163 upvar 0 subns::foo foo 164 lappend result [catch {set foo} msg] $msg 165 namespace delete subns 166 lappend result [catch {set foo 3} msg] $msg 167 lappend result [catch {set foo(3) 3} msg] $msg 168 namespace delete [namespace current] 169 set result 170 } 171} {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}} 172test var-1.17 {TclLookupVar, resurrect array element via upvar to deleted array: compiled code path} { 173 namespace eval test_ns_var { 174 variable result 175 proc p {} { 176 array set x {1 2 3 4} 177 upvar 0 x(1) foo 178 lappend result [catch {set foo} msg] $msg 179 unset x 180 lappend result [catch {set foo 3} msg] $msg 181 } 182 set result [p] 183 namespace delete [namespace current] 184 set result 185 } 186} {0 2 1 {can't set "foo": upvar refers to element in deleted array}} 187test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: uncompiled code path} -setup { 188 unset -nocomplain test_ns_var::x 189} -body { 190 namespace eval test_ns_var { 191 variable result {} 192 variable x 193 array set x {1 2 3 4} 194 upvar 0 x(1) foo 195 lappend result [catch {set foo} msg] $msg 196 unset x 197 lappend result [catch {set foo 3} msg] $msg 198 namespace delete [namespace current] 199 set result 200 } 201} -result {0 2 1 {can't set "foo": upvar refers to element in deleted array}} 202test var-1.19 {TclLookupVar, right error message when parsing variable name} -body { 203 [format set] thisvar(doesntexist) 204} -returnCodes error -result {can't read "thisvar(doesntexist)": no such variable} 205test var-1.20 {TclLookupVar, regression on utf-8 variable names} -setup { 206 proc p [list € ä] {info vars} 207} -body { 208 # test variable with non-ascii name is available (euro and a-uml chars here): 209 list \ 210 [p 1 2] \ 211 [apply [list [list € ä] {info vars}] 1 2] \ 212 [apply [list [list [list € €] [list ä ä]] {info vars}]] \ 213} -cleanup { 214 rename p {} 215} -result [lrepeat 3 [list € ä]] 216test var-1.21 {TclLookupVar, regression on utf-8 variable names} -setup { 217 proc p [list [list € v€] [list ä vä]] {list [set €] [set ä]} 218} -body { 219 # test variable with non-ascii name (and default) is resolvable (euro and a-uml chars here): 220 list \ 221 [p] \ 222 [apply [list [list € ä] {list [set €] [set ä]}] v€ vä] \ 223 [apply [list [list [list € v€] [list ä vä]] {list [set €] [set ä]}]] \ 224} -cleanup { 225 rename p {} 226} -result [lrepeat 3 [list v€ vä]] 227 228test var-2.1 {Tcl_LappendObjCmd, create var if new} { 229 catch {unset x} 230 lappend x 1 2 231} {1 2} 232 233test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} -setup { 234 catch {unset x} 235} -body { 236 set x 1997 237 proc p {} { 238 global x ;# calls MakeUpvar with TCL_NAMESPACE_ONLY for other var x 239 return $x 240 } 241 p 242} -result {1997} 243test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} { 244 namespace eval test_ns_var { 245 catch {unset v} 246 variable v 1998 247 proc p {} { 248 variable v ;# TCL_NAMESPACE_ONLY specified for other var x 249 return $v 250 } 251 p 252 } 253} {1998} 254test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} -setup { 255 catch {unset a} 256} -constraints testupvar -body { 257 set a 123321 258 proc p {} { 259 # create global xx linked to global a 260 testupvar 1 a {} xx global 261 } 262 list [p] $xx [set xx 789] $a 263} -result {{} 123321 789 789} 264test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} -setup { 265 catch {unset a} 266} -constraints testupvar -body { 267 set a 456 268 namespace eval test_ns_var { 269 catch {unset ::test_ns_var::vv} 270 proc p {} { 271 # create namespace var vv linked to global a 272 testupvar 1 a {} vv namespace 273 } 274 p 275 } 276 list $test_ns_var::vv [set test_ns_var::vv 123] $a 277} -result {456 123 123} 278test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} -setup { 279 catch {unset aaaaa} 280 catch {unset xxxxx} 281} -body { 282 set aaaaa 77777 283 upvar #0 aaaaa xxxxx 284 list [set xxxxx] [set aaaaa] 285} -result {77777 77777} 286test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} -setup { 287 catch {unset a} 288} -body { 289 set a 121212 290 namespace eval test_ns_var { 291 upvar ::a vvv 292 set vvv 293 } 294} -result {121212} 295test var-3.7 {MakeUpvar, my var has ::s} -setup { 296 catch {unset a} 297} -body { 298 set a 789789 299 upvar #0 a test_ns_var::lnk 300 namespace eval test_ns_var { 301 set lnk 302 } 303} -result {789789} 304test var-3.8 {MakeUpvar, my var already exists in global ns} -setup { 305 upvar #0 aaaaa xxxxx 306 catch {unset aaaaa} 307 catch {unset xxxxx} 308} -body { 309 set aaaaa 456654 310 set xxxxx hello 311 upvar #0 aaaaa xxxxx 312 set xxxxx 313} -result {hello} 314test var-3.9 {MakeUpvar, my var has invalid ns name} -setup { 315 catch {unset aaaaa} 316} -returnCodes error -body { 317 set aaaaa 789789 318 upvar #0 aaaaa test_ns_fred::lnk 319} -cleanup { 320 unset ::aaaaa 321} -result {can't create "test_ns_fred::lnk": parent namespace doesn't exist} 322test var-3.10 {MakeUpvar, between namespaces} -body { 323 namespace eval {} { 324 variable bar 0 325 namespace eval foo upvar bar bar 326 set foo::bar 1 327 list $bar $foo::bar 328 } 329} -result {1 1} 330test var-3.11 {MakeUpvar, my var looks like array elem} -setup { 331 catch {unset aaaaa} 332} -returnCodes error -body { 333 set aaaaa 789789 334 upvar #0 aaaaa foo(bar) 335} -result {bad variable name "foo(bar)": can't create a scalar variable that looks like an array element} 336 337test var-4.1 {Tcl_GetVariableName, global variable} testgetvarfullname { 338 catch {unset a} 339 set a 123 340 testgetvarfullname a global 341} ::a 342test var-4.2 {Tcl_GetVariableName, namespace variable} testgetvarfullname { 343 namespace eval test_ns_var { 344 variable george 345 testgetvarfullname george namespace 346 } 347} ::test_ns_var::george 348test var-4.3 {Tcl_GetVariableName, variable can't be array element} -setup { 349 catch {unset a} 350} -constraints testgetvarfullname -body { 351 set a(1) foo 352 testgetvarfullname a(1) global 353} -returnCodes error -result {unknown variable "a(1)"} 354 355test var-5.1 {Tcl_GetVariableFullName, global variable} -setup { 356 catch {unset a} 357} -body { 358 set a bar 359 namespace which -variable a 360} -result {::a} 361test var-5.2 {Tcl_GetVariableFullName, namespace variable} { 362 namespace eval test_ns_var { 363 variable martha 364 namespace which -variable martha 365 } 366} {::test_ns_var::martha} 367test var-5.3 {Tcl_GetVariableFullName, namespace variable} -setup { 368 namespace eval test_ns_var {variable martha} 369} -body { 370 namespace which -variable test_ns_var::martha 371} -result {::test_ns_var::martha} 372 373test var-6.1 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { 374 namespace eval test_ns_var { 375 variable boeing 777 376 } 377 apply {{} { 378 global ::test_ns_var::boeing 379 set boeing 380 }} 381} {777} 382test var-6.2 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { 383 namespace eval test_ns_var { 384 namespace eval test_ns_nested { 385 variable java java 386 } 387 proc p {} { 388 global ::test_ns_var::test_ns_nested::java 389 set java 390 } 391 } 392 test_ns_var::p 393} {java} 394test var-6.3 {Tcl_GlobalObjCmd, variable named {} qualified by a namespace name} { 395 namespace eval ::test_ns_var::test_ns_nested {} 396 set ::test_ns_var::test_ns_nested:: 24 397 apply {{} { 398 global ::test_ns_var::test_ns_nested:: 399 set {} 400 }} 401} {24} 402test var-6.4 {Tcl_GlobalObjCmd, variable name matching :*} { 403 # Test for Tcl Bug 480176 404 set :v broken 405 proc p {} { 406 global :v 407 set :v fixed 408 } 409 p 410 set :v 411} {fixed} 412test var-6.5 {Tcl_GlobalObjCmd, no-op case (TIP 323)} { 413 global 414} {} 415test var-6.6 {Tcl_GlobalObjCmd, no-op case (TIP 323)} { 416 proc p {} { 417 global 418 } 419 p 420} {} 421 422test var-7.1 {Tcl_VariableObjCmd, create and initialize one new ns variable} -setup { 423 catch {namespace delete test_ns_var} 424} -body { 425 namespace eval test_ns_var { 426 variable one 1 427 } 428 list [info vars test_ns_var::*] [set test_ns_var::one] 429} -result {::test_ns_var::one 1} 430test var-7.2 {Tcl_VariableObjCmd, if new and no value, leave undefined} { 431 set two 2222222 432 namespace eval test_ns_var { 433 variable two 434 } 435 list [info exists test_ns_var::two] [catch {set test_ns_var::two} msg] $msg 436} {0 1 {can't read "test_ns_var::two": no such variable}} 437test var-7.3 {Tcl_VariableObjCmd, "define" var already created above} -setup { 438 catch {namespace delete test_ns_var} 439 namespace eval test_ns_var {variable one 1} 440} -body { 441 namespace eval test_ns_var { 442 variable two 2 443 } 444 list [lsort [info vars test_ns_var::*]] \ 445 [namespace eval test_ns_var {set two}] 446} -result [list [lsort {::test_ns_var::two ::test_ns_var::one}] 2] 447test var-7.4 {Tcl_VariableObjCmd, list of vars} -setup { 448 catch {namespace delete test_ns_var} 449 namespace eval test_ns_var {variable one 1; variable two 2} 450} -body { 451 namespace eval test_ns_var { 452 variable three 3 four 4 453 } 454 list [lsort [info vars test_ns_var::*]] \ 455 [namespace eval test_ns_var {expr {$three+$four}}] 456} -result [list [lsort {::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one}] 7] 457test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} -setup { 458 catch {unset a} 459 catch {unset five} 460 catch {unset six} 461} -body { 462 set a "" 463 set five 555 464 set six 666 465 namespace eval test_ns_var { 466 variable five 5 six 467 lappend a $five 468 } 469 lappend a $test_ns_var::five \ 470 [set test_ns_var::six 6] [set test_ns_var::six] $six 471} -cleanup { 472 catch {unset five} 473 catch {unset six} 474} -result {5 5 6 6 666} 475test var-7.6 {Tcl_VariableObjCmd, variable name can be qualified} -setup { 476 catch {unset newvar} 477} -body { 478 namespace eval test_ns_var { 479 variable ::newvar cheers! 480 } 481 return $newvar 482} -cleanup { 483 catch {unset newvar} 484} -result {cheers!} 485test var-7.7 {Tcl_VariableObjCmd, bad var name} -returnCodes error -body { 486 namespace eval test_ns_var { 487 variable sev:::en 7 488 } 489} -result {can't define "sev:::en": parent namespace doesn't exist} 490test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, leave value unchanged} { 491 set a "" 492 namespace eval test_ns_var { 493 variable eight 8 494 lappend a $eight 495 variable eight 496 lappend a $eight 497 } 498 set a 499} {8 8} 500test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} -setup { 501 catch {namespace delete test_ns_var2} 502} -body { 503 set a "" 504 namespace eval test_ns_var2 { 505 variable x 123 506 variable y 507 variable z 508 } 509 lappend a [lsort [info vars test_ns_var2::*]] 510 lappend a [info exists test_ns_var2::x] [info exists test_ns_var2::y] \ 511 [info exists test_ns_var2::z] 512 lappend a [list [catch {set test_ns_var2::y} msg] $msg] 513 lappend a [lsort [info vars test_ns_var2::*]] 514 lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z] 515 lappend a [set test_ns_var2::y hello] 516 lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z] 517 lappend a [list [catch {unset test_ns_var2::y} msg] $msg] 518 lappend a [lsort [info vars test_ns_var2::*]] 519 lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z] 520 lappend a [list [catch {unset test_ns_var2::z} msg] $msg] 521 lappend a [namespace delete test_ns_var2] 522} -result [list [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 1 0 0\ 523 {1 {can't read "test_ns_var2::y": no such variable}}\ 524 [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 0 0\ 525 hello 1 0\ 526 {0 {}}\ 527 [lsort {::test_ns_var2::x ::test_ns_var2::z}] 0 0\ 528 {1 {can't unset "test_ns_var2::z": no such variable}}\ 529 {}] 530test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} -setup { 531 namespace eval test_ns_var { variable eight 8 } 532} -body { 533 namespace eval test_ns_var { 534 proc p {} { 535 variable eight 536 list [set eight] [info vars] 537 } 538 p 539 } 540} -result {8 eight} 541test var-7.11 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} -setup { 542 namespace eval test_ns_var { variable eight 8 } 543} -body { 544 proc p {} { ;# note this proc is at global :: scope 545 variable test_ns_var::eight 546 list [set eight] [info vars] 547 } 548 p 549} -result {8 eight} 550test var-7.12 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} { 551 namespace eval test_ns_var { 552 variable {} {My name is empty} 553 } 554 proc p {} { ;# note this proc is at global :: scope 555 variable test_ns_var:: 556 list [set {}] [info vars] 557 } 558 p 559} {{My name is empty} {{}}} 560test var-7.13 {Tcl_VariableObjCmd, variable named ":"} { 561 namespace eval test_ns_var { 562 variable : {My name is ":"} 563 proc p {} { 564 variable : 565 list [set :] [info vars] 566 } 567 p 568 } 569} {{My name is ":"} :} 570test var-7.14 {Tcl_VariableObjCmd, array element parameter} -body { 571 namespace eval test_ns_var { variable arrayvar(1) } 572} -returnCodes error -result "can't define \"arrayvar(1)\": name refers to an element in an array" 573test var-7.15 {Tcl_VariableObjCmd, array element parameter} -body { 574 namespace eval test_ns_var { 575 variable arrayvar 576 set arrayvar(1) x 577 variable arrayvar(1) y 578 } 579} -returnCodes error -result "can't define \"arrayvar(1)\": name refers to an element in an array" 580test var-7.16 {Tcl_VariableObjCmd, no args (TIP 323)} { 581 variable 582} {} 583test var-7.17 {Tcl_VariableObjCmd, no args (TIP 323)} { 584 namespace eval test_ns_var { 585 variable 586 } 587} {} 588 589test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} -setup { 590 catch {namespace delete test_ns_var} 591 catch {unset a} 592} -body { 593 namespace eval test_ns_var { 594 variable v 123 595 variable info "" 596 proc traceUnset {name1 name2 op} { 597 variable info 598 set info [concat $info [list $name1 $name2 $op]] 599 } 600 trace var v u [namespace code traceUnset] 601 } 602 list [unset test_ns_var::v] $test_ns_var::info 603} -result {{} {test_ns_var::v {} u}} 604test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called with fully-qualified var names} -setup { 605 catch {namespace delete test_ns_var} 606 catch {unset a} 607} -body { 608 set info "" 609 namespace eval test_ns_var { 610 variable v 123 1 611 trace var v u ::traceUnset 612 } 613 proc traceUnset {name1 name2 op} { 614 set ::info [concat $::info [list $name1 $name2 $op]] 615 } 616 list [namespace delete test_ns_var] $::info 617} -result {{} {::test_ns_var::v {} u}} 618 619test var-8.3 {TclDeleteNamespaceVars, mem leak} -constraints memory -setup { 620 proc ::t {a i o} { 621 set $a 321 622 } 623} -body { 624 leaktest { 625 namespace eval n { 626 variable v 123 627 trace variable v u ::t 628 } 629 namespace delete n 630 } 631} -cleanup { 632 rename ::t {} 633} -result 0 634 635test var-9.1 {behaviour of TclGet/SetVar simple get/set} -setup { 636 catch {unset u} 637 catch {unset v} 638} -constraints testsetnoerr -body { 639 list \ 640 [set u a; testsetnoerr u] \ 641 [testsetnoerr v b] \ 642 [testseterr u] \ 643 [unset v; testseterr v b] 644} -result [list {before get a} {before set b} {before get a} {before set b}] 645test var-9.2 {behaviour of TclGet/SetVar namespace get/set} -setup { 646 catch {namespace delete ns} 647} -constraints testsetnoerr -body { 648 namespace eval ns {variable u a; variable v} 649 list \ 650 [testsetnoerr ns::u] \ 651 [testsetnoerr ns::v b] \ 652 [testseterr ns::u] \ 653 [unset ns::v; testseterr ns::v b] 654} -result [list {before get a} {before set b} {before get a} {before set b}] 655test var-9.3 {behaviour of TclGetVar no variable} -setup { 656 catch {unset u} 657} -constraints testsetnoerr -body { 658 list \ 659 [catch {testsetnoerr u} res] $res \ 660 [catch {testseterr u} res] $res 661} -result {1 {before get} 1 {can't read "u": no such variable}} 662test var-9.4 {behaviour of TclGetVar no namespace variable} -setup { 663 catch {namespace delete ns} 664} -constraints testsetnoerr -body { 665 namespace eval ns {} 666 list \ 667 [catch {testsetnoerr ns::w} res] $res \ 668 [catch {testseterr ns::w} res] $res 669} -result {1 {before get} 1 {can't read "ns::w": no such variable}} 670test var-9.5 {behaviour of TclGetVar no namespace} -setup { 671 catch {namespace delete ns} 672} -constraints testsetnoerr -body { 673 list \ 674 [catch {testsetnoerr ns::u} res] $res \ 675 [catch {testseterr ns::v} res] $res 676} -result {1 {before get} 1 {can't read "ns::v": no such variable}} 677test var-9.6 {behaviour of TclSetVar no namespace} -setup { 678 catch {namespace delete ns} 679} -constraints testsetnoerr -body { 680 list \ 681 [catch {testsetnoerr ns::v 1} res] $res \ 682 [catch {testseterr ns::v 1} res] $res 683} -result {1 {before set} 1 {can't set "ns::v": parent namespace doesn't exist}} 684test var-9.7 {behaviour of TclGetVar array variable} -setup { 685 catch {unset arr} 686} -constraints testsetnoerr -body { 687 set arr(1) 1 688 list \ 689 [catch {testsetnoerr arr} res] $res \ 690 [catch {testseterr arr} res] $res 691} -result {1 {before get} 1 {can't read "arr": variable is array}} 692test var-9.8 {behaviour of TclSetVar array variable} -setup { 693 catch {unset arr} 694} -constraints testsetnoerr -body { 695 set arr(1) 1 696 list \ 697 [catch {testsetnoerr arr 2} res] $res \ 698 [catch {testseterr arr 2} res] $res 699} -result {1 {before set} 1 {can't set "arr": variable is array}} 700test var-9.9 {behaviour of TclGetVar read trace success} -setup { 701 catch {unset u} 702 catch {unset v} 703} -constraints testsetnoerr -body { 704 proc resetvar {val name elem op} {upvar 1 $name v; set v $val} 705 set u 10 706 trace var u r [list resetvar 1] 707 trace var v r [list resetvar 2] 708 list \ 709 [testsetnoerr u] \ 710 [testseterr v] 711} -result {{before get 1} {before get 2}} 712test var-9.10 {behaviour of TclGetVar read trace error} testsetnoerr { 713 proc writeonly args {error "write-only"} 714 set v 456 715 trace var v r writeonly 716 list \ 717 [catch {testsetnoerr v} msg] $msg \ 718 [catch {testseterr v} msg] $msg 719} {1 {before get} 1 {can't read "v": write-only}} 720test var-9.11 {behaviour of TclSetVar write trace success} -setup { 721 catch {unset u} 722 catch {unset v} 723} -constraints testsetnoerr -body { 724 proc doubleval {name elem op} {upvar 1 $name v; set v [expr {2 * $v}]} 725 set v 1 726 trace var v w doubleval 727 trace var u w doubleval 728 list \ 729 [testsetnoerr u 2] \ 730 [testseterr v 3] 731} -result {{before set 4} {before set 6}} 732test var-9.12 {behaviour of TclSetVar write trace error} testsetnoerr { 733 proc readonly args {error "read-only"} 734 set v 456 735 trace var v w readonly 736 list \ 737 [catch {testsetnoerr v 2} msg] $msg $v \ 738 [catch {testseterr v 3} msg] $msg $v 739} {1 {before set} 2 1 {can't set "v": read-only} 3} 740 741test var-10.1 {can't nest arrays with array set} -setup { 742 catch {unset arr} 743} -returnCodes error -body { 744 array set arr(x) {a 1 b 2} 745} -result {can't set "arr(x)": variable isn't array} 746test var-10.2 {can't nest arrays with array set} -setup { 747 catch {unset arr} 748} -returnCodes error -body { 749 array set arr(x) {} 750} -result {can't set "arr(x)": variable isn't array} 751 752test var-11.1 {array unset} -setup { 753 catch {unset a} 754} -body { 755 array set a { 1,1 a 1,2 b 2,1 c 2,3 d } 756 array unset a 1,* 757 lsort -dict [array names a] 758} -result {2,1 2,3} 759test var-11.2 {array unset} -setup { 760 catch {unset a} 761} -body { 762 array set a { 1,1 a 1,2 b } 763 array unset a 764 array exists a 765} -result 0 766test var-11.3 {array unset errors} -setup { 767 catch {unset a} 768} -returnCodes error -body { 769 array set a { 1,1 a 1,2 b } 770 array unset a pattern too 771} -result {wrong # args: should be "array unset arrayName ?pattern?"} 772 773test var-12.1 {TclFindCompiledLocals, {} array name} { 774 namespace eval n { 775 proc p {} { 776 variable {} 777 set (0) 0 778 set (1) 1 779 set n 2 780 set ($n) 2 781 set ($n,foo) 2 782 } 783 p 784 lsort -dictionary [array names {}] 785 } 786} {0 1 2 2,foo} 787 788test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} -setup { 789 catch {unset t} 790} -body { 791 proc foo {var ind op} { 792 global t 793 set foo bar 794 } 795 namespace eval :: { 796 set t(1) 1 797 trace variable t(1) u foo 798 unset t 799 } 800 set x "If you see this, it worked" 801} -result "If you see this, it worked" 802test var-13.2 {unset array with search, bug 46a2410650} -body { 803 apply {{} { 804 array set a {aa 11 bb 22 cc 33 dd 44 ee 55 ff 66} 805 set s [array startsearch a] 806 unset a([array nextelement a $s]) 807 array nextelement a $s 808 }} 809} -returnCodes error -result {couldn't find search "s-1-a"} 810test var-13.3 {unset array with search, SIGSEGV, bug 46a2410650} -body { 811 apply {{} { 812 array set a {aa 11 bb 22 cc 33 dd 44 ee 55 ff 66} 813 set s [array startsearch a] 814 unset a(ff) 815 array nextelement a $s 816 }} 817} -returnCodes error -result {couldn't find search "s-1-a"} 818 819test var-14.1 {array names syntax} -body { 820 array names foo bar baz snafu 821} -returnCodes 1 -match glob -result * 822test var-14.2 {array names -glob} -body { 823 array names tcl_platform -glob os 824} -result os 825 826test var-15.1 {segfault in [unset], [Bug 735335]} { 827 proc A { name } { 828 upvar $name var 829 set var $name 830 } 831 # 832 # Note that the variable name has to be 833 # unused previously for the segfault to 834 # be triggered. 835 # 836 namespace eval test A useSomeUnlikelyNameHere 837 namespace eval test unset useSomeUnlikelyNameHere 838} {} 839test var-15.2 {compiled unset evaluation order, Bug 3970f54c4e} { 840 apply {{} {unset foo [return ok]}} 841} ok 842 843test var-16.1 {CallVarTraces: save/restore interp error state} { 844 trace add variable ::errorCode write " ;#" 845 catch {error foo bar baz} 846 trace remove variable ::errorCode write " ;#" 847 set ::errorInfo 848} bar 849 850test var-17.1 {TclArraySet [Bug 1669489]} -setup { 851 unset -nocomplain ::a 852} -body { 853 namespace eval :: { 854 set elements {1 2 3 4} 855 trace add variable a write "string length \$elements ;#" 856 array set a $elements 857 } 858} -cleanup { 859 unset -nocomplain ::a ::elements 860} -result {} 861test var-17.2 {TclArraySet Dict shortcut only on pure value} -setup { 862 unset -nocomplain a d 863 set d {p 1 p 2} 864 dict get $d p 865 set foo 0 866} -body { 867 trace add variable a write "[list incr [namespace which -variable foo]];#" 868 array set a $d 869 set foo 870} -cleanup { 871 unset -nocomplain a d foo 872} -result 2 873 874test var-18.1 {array unset and unset traces: Bug 2939073} -setup { 875 set already 0 876 unset -nocomplain x 877} -body { 878 array set x {e 1 i 1} 879 trace add variable x unset {apply {args { 880 global already x 881 if {!$already} { 882 set already 1 883 unset x(i) 884 } 885 }}} 886 # The next command would crash reliably with memory debugging prior to the 887 # bug fix. 888 array unset x * 889 array size x 890} -cleanup { 891 unset x already 892} -result 0 893 894test var-19.1 {crash when freeing locals hashtable: Bug 3037525} { 895 proc foo {} { catch {upvar 0 dummy \$index} } 896 foo ; # This crashes without the fix for the bug 897 rename foo {} 898} {} 899 900test var-20.1 {array set compilation correctness: Bug 3603163} -setup { 901 unset -nocomplain x 902} -body { 903 apply {{} { 904 global x 905 array set x {a 1} 906 }} 907 array size x 908} -result 1 909test var-20.2 {array set compilation correctness: Bug 3603163} -setup { 910 unset -nocomplain x 911} -body { 912 apply {{} { 913 global x 914 array set x {} 915 }} 916 array size x 917} -result 0 918test var-20.3 {array set compilation correctness: Bug 3603163} -setup { 919 unset -nocomplain x 920} -body { 921 apply {{} { 922 array set ::x {a 1} 923 }} 924 array size x 925} -result 1 926test var-20.4 {array set compilation correctness: Bug 3603163} -setup { 927 unset -nocomplain x 928} -body { 929 apply {{} { 930 array set ::x {} 931 }} 932 array size x 933} -result 0 934test var-20.5 {array set compilation correctness: Bug 3603163} -setup { 935 unset -nocomplain x 936} -body { 937 apply {{} { 938 global x 939 eval {array set x {a 1}} 940 }} 941 array size x 942} -result 1 943test var-20.6 {array set compilation correctness: Bug 3603163} -setup { 944 unset -nocomplain x 945} -body { 946 apply {{} { 947 global x 948 eval {array set x {}} 949 }} 950 array size x 951} -result 0 952test var-20.7 {array set compilation correctness: Bug 3603163} -setup { 953 unset -nocomplain x 954} -body { 955 apply {{} { 956 eval {array set ::x {a 1}} 957 }} 958 array size x 959} -result 1 960test var-20.8 {array set compilation correctness: Bug 3603163} -setup { 961 unset -nocomplain x 962} -body { 963 apply {{} { 964 eval {array set ::x {}} 965 }} 966 array size x 967} -result 0 968test var-20.9 {[bc1a96407a] array set compiled w/ trace} -setup { 969 variable foo 970 variable lambda 971 unset -nocomplain lambda foo 972 array set foo {} 973 lappend lambda {} 974 lappend lambda [list array set [namespace which -variable foo] {a 1}] 975} -body { 976 after 0 [list apply $lambda] 977 vwait [namespace which -variable foo] 978} -cleanup { 979 unset -nocomplain lambda foo 980} -result {} 981test var-20.10 {[bc1a96407a] array set don't compile bad varname} -body { 982 apply {{} {set name foo(bar); array set $name {a 1}}} 983} -returnCodes error -match glob -result * 984test var-20.11 {array set don't compile bad initializer} -setup { 985 unset -nocomplain foo 986 trace add variable foo array {set foo(bar) baz;#} 987} -body { 988 catch {array set foo bad} 989 set foo(bar) 990} -cleanup { 991 unset -nocomplain foo 992} -result baz 993test var-20.12 {array set don't compile bad initializer} -setup { 994 unset -nocomplain ::foo 995 trace add variable ::foo array {set ::foo(bar) baz;#} 996} -body { 997 catch {apply {{} { 998 set value bad 999 array set ::foo $value 1000 1001 }}} 1002 set ::foo(bar) 1003} -cleanup { 1004 unset -nocomplain ::foo 1005} -result baz 1006 1007test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup { 1008 proc linenumber {} {dict get [info frame -1] line} 1009} -body { 1010 apply {n { 1011 set foo bar 1012 unset foo {*}{ 1013 } [return [incr n -[linenumber]]] 1014 }} [linenumber] 1015} -cleanup { 1016 rename linenumber {} 1017} -result 1 1018 1019test var-22.0 {leak in array element unset: Bug a3309d01db} -setup { 1020 proc doit k { 1021 variable A 1022 set A($k) {} 1023 foreach n [array names A] { 1024 if {$n <= $k-1} { 1025 unset A($n) 1026 } 1027 } 1028 } 1029} -constraints memory -body { 1030 set end [getbytes] 1031 for {set i 0} {$i < 5} {incr i} { 1032 doit $i 1033 set tmp $end 1034 set end [getbytes] 1035 } 1036 set leakedBytes [expr {$end - $tmp}] 1037} -cleanup { 1038 array unset A 1039 rename doit {} 1040} -result 0 1041test var-22.1 {leak in localVarName intrep: Bug 80304238ac} -setup { 1042 proc doit {} { 1043 interp create child 1044 child eval { 1045 proc doit script { 1046 eval $script 1047 set foo bar 1048 } 1049 doit {foreach foo baz {}} 1050 } 1051 interp delete child 1052 } 1053} -constraints memory -body { 1054 set end [getbytes] 1055 for {set i 0} {$i < 5} {incr i} { 1056 doit 1057 set tmp $end 1058 set end [getbytes] 1059 } 1060 set leakedBytes [expr {$end - $tmp}] 1061} -cleanup { 1062 array unset A 1063 rename doit {} 1064} -result 0 1065test var-22.2 {leak in parsedVarName} -constraints memory -body { 1066 set i 0 1067 leaktest {lappend x($i)} 1068} -cleanup { 1069 unset -nocomplain i x 1070} -result 0 1071 1072unset -nocomplain a k v 1073test var-23.1 {array command, for loop, too many args} -returnCodes error -body { 1074 array for {k v} c d e {} 1075} -result {wrong # args: should be "array for {key value} arrayName script"} 1076test var-23.2 {array command, for loop, not enough args} -returnCodes error -body { 1077 array for {k v} {} 1078} -result {wrong # args: should be "array for {key value} arrayName script"} 1079test var-23.3 {array command, for loop, too many list args} -setup { 1080 unset -nocomplain a 1081} -returnCodes error -body { 1082 array for {k v w} a {} 1083} -result {must have two variable names} 1084test var-23.4 {array command, for loop, not enough list args} -setup { 1085 unset -nocomplain a 1086} -returnCodes error -body { 1087 array for {k} a {} 1088} -result {must have two variable names} 1089test var-23.5 {array command, for loop, no array} -setup { 1090 unset -nocomplain a 1091} -returnCodes error -body { 1092 array for {k v} a {} 1093} -result {"a" isn't an array} 1094test var-23.6 {array command, for loop, array doesn't exist yet but has compiler-allocated procedure slot} -setup { 1095 catch {rename p ""} 1096} -returnCodes error -body { 1097 apply {{x} { 1098 if {$x==1} { 1099 return [array for {k v} a {}] 1100 } 1101 set a(x) 123 1102 }} 1 1103} -result {"a" isn't an array} 1104test var-23.7 {array enumeration} -setup { 1105 unset -nocomplain a 1106 set reslist [list] 1107} -body { 1108 array set a {a 1 b 2 c 3} 1109 array for {k v} a { 1110 lappend reslist $k $v 1111 } 1112 lsort -stride 2 -index 0 $reslist 1113} -cleanup { 1114 unset -nocomplain a 1115 unset -nocomplain reslist 1116} -result {a 1 b 2 c 3} 1117test var-23.9 {array enumeration, nested} -setup { 1118 unset -nocomplain a 1119 set reslist [list] 1120} -body { 1121 array set a {a 1 b 2 c 3} 1122 array for {k1 v1} a { 1123 lappend reslist $k1 $v1 1124 set r2 {} 1125 array for {k2 v2} a { 1126 lappend r2 $k2 $v2 1127 } 1128 lappend reslist [lsort -stride 2 -index 0 $r2] 1129 } 1130 # there is no guarantee in which order the array contents will be 1131 # returned. 1132 lsort -stride 3 -index 0 $reslist 1133} -cleanup { 1134 unset -nocomplain a 1135 unset -nocomplain reslist 1136} -result {a 1 {a 1 b 2 c 3} b 2 {a 1 b 2 c 3} c 3 {a 1 b 2 c 3}} 1137test var-23.10 {array enumeration, delete key} -match glob -setup { 1138 unset -nocomplain a 1139 set reslist [list] 1140} -body { 1141 set retval {} 1142 try { 1143 array set a {a 1 b 2 c 3 d 4} 1144 array for {k v} a { 1145 lappend reslist $k $v 1146 if { $k eq "a" } { 1147 unset a(c) 1148 } 1149 } 1150 lsort -stride 2 -index 0 $reslist 1151 } on error {err res} { 1152 set retval [dict get $res -errorinfo] 1153 } 1154 set retval 1155} -cleanup { 1156 unset -nocomplain a 1157 unset -nocomplain reslist 1158 unset -nocomplain retval 1159} -result {array changed during iteration*} 1160test var-23.11 {array enumeration, insert key} -match glob -setup { 1161 unset -nocomplain a 1162 set reslist [list] 1163} -body { 1164 set retval {} 1165 try { 1166 array set a {a 1 b 2 c 3 d 4} 1167 array for {k v} a { 1168 lappend reslist $k $v 1169 if { $k eq "a" } { 1170 set a(e) 5 1171 } 1172 } 1173 lsort -stride 2 -index 0 $reslist 1174 } on error {err res} { 1175 set retval [dict get $res -errorinfo] 1176 } 1177} -cleanup { 1178 unset -nocomplain a 1179 unset -nocomplain reslist 1180} -result {array changed during iteration*} 1181test var-23.12 {array enumeration, change value} -setup { 1182 unset -nocomplain a 1183 set reslist [list] 1184} -body { 1185 array set a {a 1 b 2 c 3} 1186 array for {k v} a { 1187 lappend reslist $k $v 1188 if { $k eq "a" } { 1189 set a(c) 9 1190 } 1191 } 1192 lsort -stride 2 -index 0 $reslist 1193} -cleanup { 1194 unset -nocomplain a 1195 unset -nocomplain reslist 1196} -result {a 1 b 2 c 9} 1197test var-23.13 {array enumeration, number of traces} -setup { 1198 set ::countarrayfor 0 1199 proc ::tracearrayfor { args } { 1200 incr ::countarrayfor 1201 } 1202 unset -nocomplain ::a 1203 set reslist [list] 1204} -body { 1205 array set ::a {a 1 b 2 c 3} 1206 foreach {k} [array names a] { 1207 trace add variable ::a($k) read ::tracearrayfor 1208 } 1209 array for {k v} ::a { 1210 lappend reslist $k $v 1211 } 1212 set ::countarrayfor 1213} -cleanup { 1214 unset -nocomplain ::countarrayfor 1215 unset -nocomplain ::a 1216 unset -nocomplain reslist 1217} -result 3 1218test var-23.14 {array for, shared arguments} -setup { 1219 set vn {k v} 1220 unset -nocomplain $vn 1221} -body { 1222 array set $vn {a 1 b 2 c 3} 1223 array for $vn $vn {} 1224} -cleanup { 1225 unset -nocomplain $vn vn 1226} -result {} 1227 1228test var-24.1 {array default set and get: interpreted} -setup { 1229 unset -nocomplain ary 1230} -body { 1231 array set ary {a 3} 1232 array default set ary 7 1233 list $ary(a) $ary(b) [info exist ary(a)] [info exist ary(b)] \ 1234 [array default get ary] 1235} -cleanup { 1236 unset -nocomplain ary 1237} -result {3 7 1 0 7} 1238test var-24.2 {array default set and get: compiled} { 1239 apply {{} { 1240 array set ary {a 3} 1241 array default set ary 7 1242 list $ary(a) $ary(b) [info exist ary(a)] [info exist ary(b)] \ 1243 [array default get ary] 1244 }} 1245} {3 7 1 0 7} 1246test var-24.3 {array default unset: interpreted} -setup { 1247 unset -nocomplain ary 1248} -body { 1249 array set ary {a 3} 1250 array default set ary 7 1251 list $ary(a) $ary(b) [array default unset ary] $ary(a) [catch {set ary(b)}] 1252} -cleanup { 1253 unset -nocomplain ary 1254} -result {3 7 {} 3 1} 1255test var-24.4 {array default unset: compiled} { 1256 apply {{} { 1257 array set ary {a 3} 1258 array default set ary 7 1259 list $ary(a) $ary(b) [array default unset ary] $ary(a) \ 1260 [catch {set ary(b)}] 1261 }} 1262} {3 7 {} 3 1} 1263test var-24.5 {array default exists: interpreted} -setup { 1264 unset -nocomplain ary result 1265 set result {} 1266} -body { 1267 array set ary {a 3} 1268 lappend result [info exists ary],[array exists ary],[array default exists ary] 1269 array default set ary 7 1270 lappend result [info exists ary],[array exists ary],[array default exists ary] 1271 array default unset ary 1272 lappend result [info exists ary],[array exists ary],[array default exists ary] 1273 unset ary 1274 lappend result [info exists ary],[array exists ary],[array default exists ary] 1275 array default set ary 11 1276 lappend result [info exists ary],[array exists ary],[array default exists ary] 1277} -cleanup { 1278 unset -nocomplain ary result 1279} -result {1,1,0 1,1,1 1,1,0 0,0,0 1,1,1} 1280test var-24.6 {array default exists: compiled} { 1281 apply {{} { 1282 array set ary {a 3} 1283 lappend result [info exists ary],[array exists ary],[array default exists ary] 1284 array default set ary 7 1285 lappend result [info exists ary],[array exists ary],[array default exists ary] 1286 array default unset ary 1287 lappend result [info exists ary],[array exists ary],[array default exists ary] 1288 unset ary 1289 lappend result [info exists ary],[array exists ary],[array default exists ary] 1290 array default set ary 11 1291 lappend result [info exists ary],[array exists ary],[array default exists ary] 1292 }} 1293} {1,1,0 1,1,1 1,1,0 0,0,0 1,1,1} 1294test var-24.7 {array default and append: interpreted} -setup { 1295 unset -nocomplain ary result 1296 set result {} 1297} -body { 1298 array default set ary grill 1299 lappend result [array size ary] [info exist ary(x)] 1300 append ary(x) abc 1301 lappend result [array size ary] $ary(x) 1302 array default unset ary 1303 append ary(x) def 1304 append ary(y) ghi 1305 lappend result [array size ary] $ary(x) $ary(y) 1306} -cleanup { 1307 unset -nocomplain ary result 1308} -result {0 0 1 grillabc 2 grillabcdef ghi} 1309test var-24.8 {array default and append: compiled} { 1310 apply {{} { 1311 array default set ary grill 1312 lappend result [array size ary] [info exist ary(x)] 1313 append ary(x) abc 1314 lappend result [array size ary] $ary(x) 1315 array default unset ary 1316 append ary(x) def 1317 append ary(y) ghi 1318 lappend result [array size ary] $ary(x) $ary(y) 1319 }} 1320} {0 0 1 grillabc 2 grillabcdef ghi} 1321test var-24.9 {array default and lappend: interpreted} -setup { 1322 unset -nocomplain ary result 1323 set result {} 1324} -body { 1325 array default set ary grill 1326 lappend result [array size ary] [info exist ary(x)] 1327 lappend ary(x) abc 1328 lappend result [array size ary] $ary(x) 1329 array default unset ary 1330 lappend ary(x) def 1331 lappend ary(y) ghi 1332 lappend result [array size ary] $ary(x) $ary(y) 1333} -cleanup { 1334 unset -nocomplain ary result 1335} -result {0 0 1 {grill abc} 2 {grill abc def} ghi} 1336test var-24.10 {array default and lappend: compiled} { 1337 apply {{} { 1338 array default set ary grill 1339 lappend result [array size ary] [info exist ary(x)] 1340 lappend ary(x) abc 1341 lappend result [array size ary] $ary(x) 1342 array default unset ary 1343 lappend ary(x) def 1344 lappend ary(y) ghi 1345 lappend result [array size ary] $ary(x) $ary(y) 1346 }} 1347} {0 0 1 {grill abc} 2 {grill abc def} ghi} 1348test var-24.11 {array default and incr: interpreted} -setup { 1349 unset -nocomplain ary result 1350 set result {} 1351} -body { 1352 array default set ary 7 1353 lappend result [array size ary] [info exist ary(x)] 1354 incr ary(x) 11 1355 lappend result [array size ary] $ary(x) 1356 array default unset ary 1357 incr ary(x) 1358 incr ary(y) 1359 lappend result [array size ary] $ary(x) $ary(y) 1360} -cleanup { 1361 unset -nocomplain ary result 1362} -result {0 0 1 18 2 19 1} 1363test var-24.12 {array default and incr: compiled} { 1364 apply {{} { 1365 array default set ary 7 1366 lappend result [array size ary] [info exist ary(x)] 1367 incr ary(x) 11 1368 lappend result [array size ary] $ary(x) 1369 array default unset ary 1370 incr ary(x) 1371 incr ary(y) 1372 lappend result [array size ary] $ary(x) $ary(y) 1373 }} 1374} {0 0 1 18 2 19 1} 1375test var-24.13 {array default and dict: interpreted} -setup { 1376 unset -nocomplain ary x y z 1377} -body { 1378 array default set ary {x y} 1379 dict lappend ary(p) x z 1380 dict update ary(q) x y { 1381 set y z 1382 } 1383 dict with ary(r) { 1384 set x 123 1385 } 1386 lsort -stride 2 -index 0 [array get ary] 1387} -cleanup { 1388 unset -nocomplain ary x y z 1389} -result {p {x {y z}} q {x z} r {x 123}} 1390test var-24.14 {array default and dict: compiled} { 1391 lsort -stride 2 -index 0 [apply {{} { 1392 array default set ary {x y} 1393 dict lappend ary(p) x z 1394 dict update ary(q) x y { 1395 set y z 1396 } 1397 dict with ary(r) { 1398 set x 123 1399 } 1400 array get ary 1401 }}] 1402} {p {x {y z}} q {x z} r {x 123}} 1403test var-24.15 {array default set and get: two-level} { 1404 apply {{} { 1405 array set ary {a 3} 1406 array default set ary 7 1407 apply {{} { 1408 upvar 1 ary ary ary(c) c 1409 lappend result $ary(a) $ary(b) $c 1410 lappend result [info exist ary(a)] [info exist ary(b)] [info exist c] 1411 lappend result [array default get ary] 1412 }} 1413 }} 1414} {3 7 7 1 0 0 7} 1415test var-24.16 {array default set: errors} -setup { 1416 unset -nocomplain ary 1417} -body { 1418 set ary not-an-array 1419 array default set ary 7 1420} -returnCodes error -cleanup { 1421 unset -nocomplain ary 1422} -result {can't array default set "ary": variable isn't array} 1423test var-24.17 {array default set: errors} -setup { 1424 unset -nocomplain ary 1425} -body { 1426 array default set ary 1427} -returnCodes error -cleanup { 1428 unset -nocomplain ary 1429} -result * -match glob 1430test var-24.18 {array default set: errors} -setup { 1431 unset -nocomplain ary 1432} -body { 1433 array default set ary x y 1434} -returnCodes error -cleanup { 1435 unset -nocomplain ary 1436} -result * -match glob 1437test var-24.19 {array default get: errors} -setup { 1438 unset -nocomplain ary 1439} -body { 1440 set ary not-an-array 1441 array default get ary 1442} -returnCodes error -cleanup { 1443 unset -nocomplain ary 1444} -result {"ary" isn't an array} 1445test var-24.20 {array default get: errors} -setup { 1446 unset -nocomplain ary 1447} -body { 1448 array default get ary x y 1449} -returnCodes error -cleanup { 1450 unset -nocomplain ary 1451} -result * -match glob 1452test var-24.21 {array default exists: errors} -setup { 1453 unset -nocomplain ary 1454} -body { 1455 set ary not-an-array 1456 array default exists ary 1457} -returnCodes error -cleanup { 1458 unset -nocomplain ary 1459} -result {"ary" isn't an array} 1460test var-24.22 {array default exists: errors} -setup { 1461 unset -nocomplain ary 1462} -body { 1463 array default exists ary x 1464} -returnCodes error -cleanup { 1465 unset -nocomplain ary 1466} -result * -match glob 1467test var-24.23 {array default unset: errors} -setup { 1468 unset -nocomplain ary 1469} -body { 1470 set ary not-an-array 1471 array default unset ary 1472} -returnCodes error -cleanup { 1473 unset -nocomplain ary 1474} -result {"ary" isn't an array} 1475test var-24.24 {array default unset: errors} -setup { 1476 unset -nocomplain ary 1477} -body { 1478 array default unset ary x 1479} -returnCodes error -cleanup { 1480 unset -nocomplain ary 1481} -result * -match glob 1482 1483catch {namespace delete ns} 1484catch {unset arr} 1485catch {unset v} 1486 1487catch {rename getbytes ""} 1488catch {rename p ""} 1489catch {namespace delete test_ns_var} 1490catch {namespace delete test_ns_var2} 1491catch {unset xx} 1492catch {unset x} 1493catch {unset y} 1494catch {unset i} 1495catch {unset a} 1496catch {unset xxxxx} 1497catch {unset aaaaa} 1498 1499# cleanup 1500::tcltest::cleanupTests 1501return 1502 1503# Local Variables: 1504# mode: tcl 1505# End: 1506