diff options
Diffstat (limited to 'tcl8.6/tests/var.test')
-rw-r--r-- | tcl8.6/tests/var.test | 1023 |
1 files changed, 0 insertions, 1023 deletions
diff --git a/tcl8.6/tests/var.test b/tcl8.6/tests/var.test deleted file mode 100644 index a9d93ac..0000000 --- a/tcl8.6/tests/var.test +++ /dev/null @@ -1,1023 +0,0 @@ -# This file contains tests for the tclVar.c source file. Tests appear in the -# same order as the C code that they test. The set of tests is currently -# incomplete since it currently includes only new tests for code changed for -# the addition of Tcl namespaces. Other variable-related tests appear in -# several other test files including namespace.test, set.test, trace.test, and -# upvar.test. -# -# Sourcing this file into Tcl runs the tests and generates output for errors. -# No output means no errors were found. -# -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# -# See the file "license.terms" for information on usage and redistribution of -# this file, and for a DISCLAIMER OF ALL WARRANTIES. - -if {"::tcltest" ni [namespace children]} { - package require tcltest 2.2 - namespace import -force ::tcltest::* -} - -::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] - -testConstraint testupvar [llength [info commands testupvar]] -testConstraint testgetvarfullname [llength [info commands testgetvarfullname]] -testConstraint testsetnoerr [llength [info commands testsetnoerr]] -testConstraint memory [llength [info commands memory]] -if {[testConstraint memory]} { - proc getbytes {} { - return [lindex [split [memory info] \n] 3 3] - } - proc leaktest {script {iterations 3}} { - set end [getbytes] - for {set i 0} {$i < $iterations} {incr i} { - uplevel 1 $script - set tmp $end - set end [getbytes] - } - return [expr {$end - $tmp}] - } -} - -catch {rename p ""} -catch {namespace delete test_ns_var} -catch {unset xx} -catch {unset x} -catch {unset y} -catch {unset i} -catch {unset a} -catch {unset arr} - -test var-1.1 {TclLookupVar, Array handling} -setup { - catch {unset a} -} -body { - set x "incr" ;# force no compilation and runtime call to Tcl_IncrCmd - set i 10 - set arr(foo) 37 - list [$x i] $i [$x arr(foo)] $arr(foo) -} -result {11 11 38 38} -set ::x "global value" -namespace eval test_ns_var { - variable x "namespace value" -} -test var-1.2 {TclLookupVar, TCL_GLOBAL_ONLY implies global namespace var} { - namespace eval test_ns_var { - proc p {} { - global x ;# specifies TCL_GLOBAL_ONLY to get global x - return $x - } - } - test_ns_var::p -} {global value} -test var-1.3 {TclLookupVar, TCL_NAMESPACE_ONLY implies namespace var} { - namespace eval test_ns_var { - proc q {} { - variable x ;# specifies TCL_NAMESPACE_ONLY to get namespace x - return $x - } - } - test_ns_var::q -} {namespace value} -test var-1.4 {TclLookupVar, no active call frame implies global namespace var} { - set x -} {global value} -test var-1.5 {TclLookupVar, active call frame pushed for namespace eval implies namespace var} { - namespace eval test_ns_var {set x} -} {namespace value} -test var-1.6 {TclLookupVar, name starts with :: implies some namespace var} { - namespace eval test_ns_var {set ::x} -} {global value} -test var-1.7 {TclLookupVar, error finding namespace var} -body { - set a:::b -} -returnCodes error -result {can't read "a:::b": no such variable} -test var-1.8 {TclLookupVar, error finding namespace var} -body { - set ::foobarfoo -} -returnCodes error -result {can't read "::foobarfoo": no such variable} -test var-1.9 {TclLookupVar, create new namespace var} { - namespace eval test_ns_var { - set v hello - } -} {hello} -test var-1.10 {TclLookupVar, create new namespace var} -setup { - catch {unset y} -} -body { - namespace eval test_ns_var { - set ::y 789 - } - set y -} -result {789} -test var-1.11 {TclLookupVar, error creating new namespace var} -body { - namespace eval test_ns_var { - set ::test_ns_var::foo::bar 314159 - } -} -returnCodes error -result {can't set "::test_ns_var::foo::bar": parent namespace doesn't exist} -test var-1.12 {TclLookupVar, error creating new namespace var} -body { - namespace eval test_ns_var { - set ::test_ns_var::foo:: 1997 - } -} -returnCodes error -result {can't set "::test_ns_var::foo::": parent namespace doesn't exist} -test var-1.13 {TclLookupVar, new namespace var is created in a particular namespace} { - catch {unset aNeWnAmEiNnS} - namespace eval test_ns_var { - namespace eval test_ns_var2::test_ns_var3 { - set aNeWnAmEiNnS 77777 - } - # namespace which builds a name by traversing nsPtr chain to :: - namespace which -variable test_ns_var2::test_ns_var3::aNeWnAmEiNnS - } -} {::test_ns_var::test_ns_var2::test_ns_var3::aNeWnAmEiNnS} -test var-1.14 {TclLookupVar, namespace code ignores ":"s in middle and end of var names} { - namespace eval test_ns_var { - set : 123 - set v: 456 - set x:y: 789 - list [set :] [set v:] [set x:y:] \ - ${:} ${v:} ${x:y:} \ - [expr {":" in [info vars]}] \ - [expr {"v:" in [info vars]}] \ - [expr {"x:y:" in [info vars]}] - } -} {123 456 789 123 456 789 1 1 1} -test var-1.15 {TclLookupVar, resurrect variable via upvar to deleted namespace: compiled code path} { - namespace eval test_ns_var { - variable foo 2 - } - proc p {} { - variable ::test_ns_var::foo - lappend result [catch {set foo} msg] $msg - namespace delete ::test_ns_var - lappend result [catch {set foo 3} msg] $msg - lappend result [catch {set foo(3) 3} msg] $msg - } - p -} {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}} -test var-1.16 {TclLookupVar, resurrect variable via upvar to deleted namespace: uncompiled code path} { - namespace eval test_ns_var { - variable result - namespace eval subns { - variable foo 2 - } - upvar 0 subns::foo foo - lappend result [catch {set foo} msg] $msg - namespace delete subns - lappend result [catch {set foo 3} msg] $msg - lappend result [catch {set foo(3) 3} msg] $msg - namespace delete [namespace current] - set result - } -} {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}} -test var-1.17 {TclLookupVar, resurrect array element via upvar to deleted array: compiled code path} { - namespace eval test_ns_var { - variable result - proc p {} { - array set x {1 2 3 4} - upvar 0 x(1) foo - lappend result [catch {set foo} msg] $msg - unset x - lappend result [catch {set foo 3} msg] $msg - } - set result [p] - namespace delete [namespace current] - set result - } -} {0 2 1 {can't set "foo": upvar refers to element in deleted array}} -test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: uncompiled code path} -setup { - unset -nocomplain test_ns_var::x -} -body { - namespace eval test_ns_var { - variable result {} - variable x - array set x {1 2 3 4} - upvar 0 x(1) foo - lappend result [catch {set foo} msg] $msg - unset x - lappend result [catch {set foo 3} msg] $msg - namespace delete [namespace current] - set result - } -} -result {0 2 1 {can't set "foo": upvar refers to element in deleted array}} -test var-1.19 {TclLookupVar, right error message when parsing variable name} -body { - [format set] thisvar(doesntexist) -} -returnCodes error -result {can't read "thisvar(doesntexist)": no such variable} - -test var-2.1 {Tcl_LappendObjCmd, create var if new} { - catch {unset x} - lappend x 1 2 -} {1 2} - -test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} -setup { - catch {unset x} -} -body { - set x 1997 - proc p {} { - global x ;# calls MakeUpvar with TCL_NAMESPACE_ONLY for other var x - return $x - } - p -} -result {1997} -test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} { - namespace eval test_ns_var { - catch {unset v} - variable v 1998 - proc p {} { - variable v ;# TCL_NAMESPACE_ONLY specified for other var x - return $v - } - p - } -} {1998} -test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} -setup { - catch {unset a} -} -constraints testupvar -body { - set a 123321 - proc p {} { - # create global xx linked to global a - testupvar 1 a {} xx global - } - list [p] $xx [set xx 789] $a -} -result {{} 123321 789 789} -test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} -setup { - catch {unset a} -} -constraints testupvar -body { - set a 456 - namespace eval test_ns_var { - catch {unset ::test_ns_var::vv} - proc p {} { - # create namespace var vv linked to global a - testupvar 1 a {} vv namespace - } - p - } - list $test_ns_var::vv [set test_ns_var::vv 123] $a -} -result {456 123 123} -test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} -setup { - catch {unset aaaaa} - catch {unset xxxxx} -} -body { - set aaaaa 77777 - upvar #0 aaaaa xxxxx - list [set xxxxx] [set aaaaa] -} -result {77777 77777} -test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} -setup { - catch {unset a} -} -body { - set a 121212 - namespace eval test_ns_var { - upvar ::a vvv - set vvv - } -} -result {121212} -test var-3.7 {MakeUpvar, my var has ::s} -setup { - catch {unset a} -} -body { - set a 789789 - upvar #0 a test_ns_var::lnk - namespace eval test_ns_var { - set lnk - } -} -result {789789} -test var-3.8 {MakeUpvar, my var already exists in global ns} -setup { - upvar #0 aaaaa xxxxx - catch {unset aaaaa} - catch {unset xxxxx} -} -body { - set aaaaa 456654 - set xxxxx hello - upvar #0 aaaaa xxxxx - set xxxxx -} -result {hello} -test var-3.9 {MakeUpvar, my var has invalid ns name} -setup { - catch {unset aaaaa} -} -returnCodes error -body { - set aaaaa 789789 - upvar #0 aaaaa test_ns_fred::lnk -} -cleanup { - unset ::aaaaa -} -result {can't create "test_ns_fred::lnk": parent namespace doesn't exist} -test var-3.10 {MakeUpvar, between namespaces} -body { - namespace eval {} { - variable bar 0 - namespace eval foo upvar bar bar - set foo::bar 1 - list $bar $foo::bar - } -} -result {1 1} -test var-3.11 {MakeUpvar, my var looks like array elem} -setup { - catch {unset aaaaa} -} -returnCodes error -body { - set aaaaa 789789 - upvar #0 aaaaa foo(bar) -} -result {bad variable name "foo(bar)": can't create a scalar variable that looks like an array element} - -test var-4.1 {Tcl_GetVariableName, global variable} testgetvarfullname { - catch {unset a} - set a 123 - testgetvarfullname a global -} ::a -test var-4.2 {Tcl_GetVariableName, namespace variable} testgetvarfullname { - namespace eval test_ns_var { - variable george - testgetvarfullname george namespace - } -} ::test_ns_var::george -test var-4.3 {Tcl_GetVariableName, variable can't be array element} -setup { - catch {unset a} -} -constraints testgetvarfullname -body { - set a(1) foo - testgetvarfullname a(1) global -} -returnCodes error -result {unknown variable "a(1)"} - -test var-5.1 {Tcl_GetVariableFullName, global variable} -setup { - catch {unset a} -} -body { - set a bar - namespace which -variable a -} -result {::a} -test var-5.2 {Tcl_GetVariableFullName, namespace variable} { - namespace eval test_ns_var { - variable martha - namespace which -variable martha - } -} {::test_ns_var::martha} -test var-5.3 {Tcl_GetVariableFullName, namespace variable} -setup { - namespace eval test_ns_var {variable martha} -} -body { - namespace which -variable test_ns_var::martha -} -result {::test_ns_var::martha} - -test var-6.1 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { - namespace eval test_ns_var { - variable boeing 777 - } - apply {{} { - global ::test_ns_var::boeing - set boeing - }} -} {777} -test var-6.2 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { - namespace eval test_ns_var { - namespace eval test_ns_nested { - variable java java - } - proc p {} { - global ::test_ns_var::test_ns_nested::java - set java - } - } - test_ns_var::p -} {java} -test var-6.3 {Tcl_GlobalObjCmd, variable named {} qualified by a namespace name} { - namespace eval ::test_ns_var::test_ns_nested {} - set ::test_ns_var::test_ns_nested:: 24 - apply {{} { - global ::test_ns_var::test_ns_nested:: - set {} - }} -} {24} -test var-6.4 {Tcl_GlobalObjCmd, variable name matching :*} { - # Test for Tcl Bug 480176 - set :v broken - proc p {} { - global :v - set :v fixed - } - p - set :v -} {fixed} -test var-6.5 {Tcl_GlobalObjCmd, no-op case (TIP 323)} { - global -} {} -test var-6.6 {Tcl_GlobalObjCmd, no-op case (TIP 323)} { - proc p {} { - global - } - p -} {} - -test var-7.1 {Tcl_VariableObjCmd, create and initialize one new ns variable} -setup { - catch {namespace delete test_ns_var} -} -body { - namespace eval test_ns_var { - variable one 1 - } - list [info vars test_ns_var::*] [set test_ns_var::one] -} -result {::test_ns_var::one 1} -test var-7.2 {Tcl_VariableObjCmd, if new and no value, leave undefined} { - set two 2222222 - namespace eval test_ns_var { - variable two - } - list [info exists test_ns_var::two] [catch {set test_ns_var::two} msg] $msg -} {0 1 {can't read "test_ns_var::two": no such variable}} -test var-7.3 {Tcl_VariableObjCmd, "define" var already created above} -setup { - catch {namespace delete test_ns_var} - namespace eval test_ns_var {variable one 1} -} -body { - namespace eval test_ns_var { - variable two 2 - } - list [lsort [info vars test_ns_var::*]] \ - [namespace eval test_ns_var {set two}] -} -result [list [lsort {::test_ns_var::two ::test_ns_var::one}] 2] -test var-7.4 {Tcl_VariableObjCmd, list of vars} -setup { - catch {namespace delete test_ns_var} - namespace eval test_ns_var {variable one 1; variable two 2} -} -body { - namespace eval test_ns_var { - variable three 3 four 4 - } - list [lsort [info vars test_ns_var::*]] \ - [namespace eval test_ns_var {expr $three+$four}] -} -result [list [lsort {::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one}] 7] -test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} -setup { - catch {unset a} - catch {unset five} - catch {unset six} -} -body { - set a "" - set five 555 - set six 666 - namespace eval test_ns_var { - variable five 5 six - lappend a $five - } - lappend a $test_ns_var::five \ - [set test_ns_var::six 6] [set test_ns_var::six] $six -} -cleanup { - catch {unset five} - catch {unset six} -} -result {5 5 6 6 666} -test var-7.6 {Tcl_VariableObjCmd, variable name can be qualified} -setup { - catch {unset newvar} -} -body { - namespace eval test_ns_var { - variable ::newvar cheers! - } - return $newvar -} -cleanup { - catch {unset newvar} -} -result {cheers!} -test var-7.7 {Tcl_VariableObjCmd, bad var name} -returnCodes error -body { - namespace eval test_ns_var { - variable sev:::en 7 - } -} -result {can't define "sev:::en": parent namespace doesn't exist} -test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, leave value unchanged} { - set a "" - namespace eval test_ns_var { - variable eight 8 - lappend a $eight - variable eight - lappend a $eight - } - set a -} {8 8} -test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} -setup { - catch {namespace delete test_ns_var2} -} -body { - set a "" - namespace eval test_ns_var2 { - variable x 123 - variable y - variable z - } - lappend a [lsort [info vars test_ns_var2::*]] - lappend a [info exists test_ns_var2::x] [info exists test_ns_var2::y] \ - [info exists test_ns_var2::z] - lappend a [list [catch {set test_ns_var2::y} msg] $msg] - lappend a [lsort [info vars test_ns_var2::*]] - lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z] - lappend a [set test_ns_var2::y hello] - lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z] - lappend a [list [catch {unset test_ns_var2::y} msg] $msg] - lappend a [lsort [info vars test_ns_var2::*]] - lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z] - lappend a [list [catch {unset test_ns_var2::z} msg] $msg] - lappend a [namespace delete test_ns_var2] -} -result [list [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 1 0 0\ - {1 {can't read "test_ns_var2::y": no such variable}}\ - [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 0 0\ - hello 1 0\ - {0 {}}\ - [lsort {::test_ns_var2::x ::test_ns_var2::z}] 0 0\ - {1 {can't unset "test_ns_var2::z": no such variable}}\ - {}] -test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} -setup { - namespace eval test_ns_var { variable eight 8 } -} -body { - namespace eval test_ns_var { - proc p {} { - variable eight - list [set eight] [info vars] - } - p - } -} -result {8 eight} -test var-7.11 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} -setup { - namespace eval test_ns_var { variable eight 8 } -} -body { - proc p {} { ;# note this proc is at global :: scope - variable test_ns_var::eight - list [set eight] [info vars] - } - p -} -result {8 eight} -test var-7.12 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} { - namespace eval test_ns_var { - variable {} {My name is empty} - } - proc p {} { ;# note this proc is at global :: scope - variable test_ns_var:: - list [set {}] [info vars] - } - p -} {{My name is empty} {{}}} -test var-7.13 {Tcl_VariableObjCmd, variable named ":"} { - namespace eval test_ns_var { - variable : {My name is ":"} - proc p {} { - variable : - list [set :] [info vars] - } - p - } -} {{My name is ":"} :} -test var-7.14 {Tcl_VariableObjCmd, array element parameter} -body { - namespace eval test_ns_var { variable arrayvar(1) } -} -returnCodes error -result "can't define \"arrayvar(1)\": name refers to an element in an array" -test var-7.15 {Tcl_VariableObjCmd, array element parameter} -body { - namespace eval test_ns_var { - variable arrayvar - set arrayvar(1) x - variable arrayvar(1) y - } -} -returnCodes error -result "can't define \"arrayvar(1)\": name refers to an element in an array" -test var-7.16 {Tcl_VariableObjCmd, no args (TIP 323)} { - variable -} {} -test var-7.17 {Tcl_VariableObjCmd, no args (TIP 323)} { - namespace eval test_ns_var { - variable - } -} {} - -test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} -setup { - catch {namespace delete test_ns_var} - catch {unset a} -} -body { - namespace eval test_ns_var { - variable v 123 - variable info "" - proc traceUnset {name1 name2 op} { - variable info - set info [concat $info [list $name1 $name2 $op]] - } - trace var v u [namespace code traceUnset] - } - list [unset test_ns_var::v] $test_ns_var::info -} -result {{} {test_ns_var::v {} u}} -test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called with fully-qualified var names} -setup { - catch {namespace delete test_ns_var} - catch {unset a} -} -body { - set info "" - namespace eval test_ns_var { - variable v 123 1 - trace var v u ::traceUnset - } - proc traceUnset {name1 name2 op} { - set ::info [concat $::info [list $name1 $name2 $op]] - } - list [namespace delete test_ns_var] $::info -} -result {{} {::test_ns_var::v {} u}} - -test var-8.3 {TclDeleteNamespaceVars, mem leak} -constraints memory -setup { - proc ::t {a i o} { - set $a 321 - } -} -body { - leaktest { - namespace eval n { - variable v 123 - trace variable v u ::t - } - namespace delete n - } -} -cleanup { - rename ::t {} -} -result 0 - -test var-9.1 {behaviour of TclGet/SetVar simple get/set} -setup { - catch {unset u} - catch {unset v} -} -constraints testsetnoerr -body { - list \ - [set u a; testsetnoerr u] \ - [testsetnoerr v b] \ - [testseterr u] \ - [unset v; testseterr v b] -} -result [list {before get a} {before set b} {before get a} {before set b}] -test var-9.2 {behaviour of TclGet/SetVar namespace get/set} -setup { - catch {namespace delete ns} -} -constraints testsetnoerr -body { - namespace eval ns {variable u a; variable v} - list \ - [testsetnoerr ns::u] \ - [testsetnoerr ns::v b] \ - [testseterr ns::u] \ - [unset ns::v; testseterr ns::v b] -} -result [list {before get a} {before set b} {before get a} {before set b}] -test var-9.3 {behaviour of TclGetVar no variable} -setup { - catch {unset u} -} -constraints testsetnoerr -body { - list \ - [catch {testsetnoerr u} res] $res \ - [catch {testseterr u} res] $res -} -result {1 {before get} 1 {can't read "u": no such variable}} -test var-9.4 {behaviour of TclGetVar no namespace variable} -setup { - catch {namespace delete ns} -} -constraints testsetnoerr -body { - namespace eval ns {} - list \ - [catch {testsetnoerr ns::w} res] $res \ - [catch {testseterr ns::w} res] $res -} -result {1 {before get} 1 {can't read "ns::w": no such variable}} -test var-9.5 {behaviour of TclGetVar no namespace} -setup { - catch {namespace delete ns} -} -constraints testsetnoerr -body { - list \ - [catch {testsetnoerr ns::u} res] $res \ - [catch {testseterr ns::v} res] $res -} -result {1 {before get} 1 {can't read "ns::v": no such variable}} -test var-9.6 {behaviour of TclSetVar no namespace} -setup { - catch {namespace delete ns} -} -constraints testsetnoerr -body { - list \ - [catch {testsetnoerr ns::v 1} res] $res \ - [catch {testseterr ns::v 1} res] $res -} -result {1 {before set} 1 {can't set "ns::v": parent namespace doesn't exist}} -test var-9.7 {behaviour of TclGetVar array variable} -setup { - catch {unset arr} -} -constraints testsetnoerr -body { - set arr(1) 1 - list \ - [catch {testsetnoerr arr} res] $res \ - [catch {testseterr arr} res] $res -} -result {1 {before get} 1 {can't read "arr": variable is array}} -test var-9.8 {behaviour of TclSetVar array variable} -setup { - catch {unset arr} -} -constraints testsetnoerr -body { - set arr(1) 1 - list \ - [catch {testsetnoerr arr 2} res] $res \ - [catch {testseterr arr 2} res] $res -} -result {1 {before set} 1 {can't set "arr": variable is array}} -test var-9.9 {behaviour of TclGetVar read trace success} -setup { - catch {unset u} - catch {unset v} -} -constraints testsetnoerr -body { - proc resetvar {val name elem op} {upvar 1 $name v; set v $val} - set u 10 - trace var u r [list resetvar 1] - trace var v r [list resetvar 2] - list \ - [testsetnoerr u] \ - [testseterr v] -} -result {{before get 1} {before get 2}} -test var-9.10 {behaviour of TclGetVar read trace error} testsetnoerr { - proc writeonly args {error "write-only"} - set v 456 - trace var v r writeonly - list \ - [catch {testsetnoerr v} msg] $msg \ - [catch {testseterr v} msg] $msg -} {1 {before get} 1 {can't read "v": write-only}} -test var-9.11 {behaviour of TclSetVar write trace success} -setup { - catch {unset u} - catch {unset v} -} -constraints testsetnoerr -body { - proc doubleval {name elem op} {upvar 1 $name v; set v [expr {2 * $v}]} - set v 1 - trace var v w doubleval - trace var u w doubleval - list \ - [testsetnoerr u 2] \ - [testseterr v 3] -} -result {{before set 4} {before set 6}} -test var-9.12 {behaviour of TclSetVar write trace error} testsetnoerr { - proc readonly args {error "read-only"} - set v 456 - trace var v w readonly - list \ - [catch {testsetnoerr v 2} msg] $msg $v \ - [catch {testseterr v 3} msg] $msg $v -} {1 {before set} 2 1 {can't set "v": read-only} 3} - -test var-10.1 {can't nest arrays with array set} -setup { - catch {unset arr} -} -returnCodes error -body { - array set arr(x) {a 1 b 2} -} -result {can't set "arr(x)": variable isn't array} -test var-10.2 {can't nest arrays with array set} -setup { - catch {unset arr} -} -returnCodes error -body { - array set arr(x) {} -} -result {can't set "arr(x)": variable isn't array} - -test var-11.1 {array unset} -setup { - catch {unset a} -} -body { - array set a { 1,1 a 1,2 b 2,1 c 2,3 d } - array unset a 1,* - lsort -dict [array names a] -} -result {2,1 2,3} -test var-11.2 {array unset} -setup { - catch {unset a} -} -body { - array set a { 1,1 a 1,2 b } - array unset a - array exists a -} -result 0 -test var-11.3 {array unset errors} -setup { - catch {unset a} -} -returnCodes error -body { - array set a { 1,1 a 1,2 b } - array unset a pattern too -} -result {wrong # args: should be "array unset arrayName ?pattern?"} - -test var-12.1 {TclFindCompiledLocals, {} array name} { - namespace eval n { - proc p {} { - variable {} - set (0) 0 - set (1) 1 - set n 2 - set ($n) 2 - set ($n,foo) 2 - } - p - lsort -dictionary [array names {}] - } -} {0 1 2 2,foo} - -test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} -setup { - catch {unset t} -} -body { - proc foo {var ind op} { - global t - set foo bar - } - namespace eval :: { - set t(1) 1 - trace variable t(1) u foo - unset t - } - set x "If you see this, it worked" -} -result "If you see this, it worked" - -test var-14.1 {array names syntax} -body { - array names foo bar baz snafu -} -returnCodes 1 -match glob -result * -test var-14.2 {array names -glob} -body { - array names tcl_platform -glob os -} -result os - -test var-15.1 {segfault in [unset], [Bug 735335]} { - proc A { name } { - upvar $name var - set var $name - } - # - # Note that the variable name has to be - # unused previously for the segfault to - # be triggered. - # - namespace eval test A useSomeUnlikelyNameHere - namespace eval test unset useSomeUnlikelyNameHere -} {} -test var-15.2 {compiled unset evaluation order, Bug 3970f54c4e} { - apply {{} {unset foo [return ok]}} -} ok - -test var-16.1 {CallVarTraces: save/restore interp error state} { - trace add variable ::errorCode write " ;#" - catch {error foo bar baz} - trace remove variable ::errorCode write " ;#" - set ::errorInfo -} bar - -test var-17.1 {TclArraySet [Bug 1669489]} -setup { - unset -nocomplain ::a -} -body { - namespace eval :: { - set elements {1 2 3 4} - trace add variable a write "string length \$elements ;#" - array set a $elements - } -} -cleanup { - unset -nocomplain ::a ::elements -} -result {} - -test var-18.1 {array unset and unset traces: Bug 2939073} -setup { - set already 0 - unset -nocomplain x -} -body { - array set x {e 1 i 1} - trace add variable x unset {apply {args { - global already x - if {!$already} { - set already 1 - unset x(i) - } - }}} - # The next command would crash reliably with memory debugging prior to the - # bug fix. - array unset x * - array size x -} -cleanup { - unset x already -} -result 0 - -test var-19.1 {crash when freeing locals hashtable: Bug 3037525} { - proc foo {} { catch {upvar 0 dummy \$index} } - foo ; # This crashes without the fix for the bug - rename foo {} -} {} - -test var-20.1 {array set compilation correctness: Bug 3603163} -setup { - unset -nocomplain x -} -body { - apply {{} { - global x - array set x {a 1} - }} - array size x -} -result 1 -test var-20.2 {array set compilation correctness: Bug 3603163} -setup { - unset -nocomplain x -} -body { - apply {{} { - global x - array set x {} - }} - array size x -} -result 0 -test var-20.3 {array set compilation correctness: Bug 3603163} -setup { - unset -nocomplain x -} -body { - apply {{} { - array set ::x {a 1} - }} - array size x -} -result 1 -test var-20.4 {array set compilation correctness: Bug 3603163} -setup { - unset -nocomplain x -} -body { - apply {{} { - array set ::x {} - }} - array size x -} -result 0 -test var-20.5 {array set compilation correctness: Bug 3603163} -setup { - unset -nocomplain x -} -body { - apply {{} { - global x - eval {array set x {a 1}} - }} - array size x -} -result 1 -test var-20.6 {array set compilation correctness: Bug 3603163} -setup { - unset -nocomplain x -} -body { - apply {{} { - global x - eval {array set x {}} - }} - array size x -} -result 0 -test var-20.7 {array set compilation correctness: Bug 3603163} -setup { - unset -nocomplain x -} -body { - apply {{} { - eval {array set ::x {a 1}} - }} - array size x -} -result 1 -test var-20.8 {array set compilation correctness: Bug 3603163} -setup { - unset -nocomplain x -} -body { - apply {{} { - eval {array set ::x {}} - }} - array size x -} -result 0 -test var-20.9 {[bc1a96407a] array set compiled w/ trace} -setup { - variable foo - variable lambda - unset -nocomplain lambda foo - array set foo {} - lappend lambda {} - lappend lambda [list array set [namespace which -variable foo] {a 1}] -} -body { - after 0 [list apply $lambda] - vwait [namespace which -variable foo] -} -cleanup { - unset -nocomplain lambda foo -} -result {} -test var-20.10 {[bc1a96407a] array set don't compile bad varname} -body { - apply {{} {set name foo(bar); array set $name {a 1}}} -} -returnCodes error -match glob -result * - -test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup { - proc linenumber {} {dict get [info frame -1] line} -} -body { - apply {n { - set foo bar - unset foo {*}{ - } [return [incr n -[linenumber]]] - }} [linenumber] -} -cleanup { - rename linenumber {} -} -result 1 - -test var-22.0 {leak in array element unset: Bug a3309d01db} -setup { - proc getbytes {} { - lindex [split [memory info] \n] 3 3 - } - proc doit k { - variable A - set A($k) {} - foreach n [array names A] { - if {$n <= $k-1} { - unset A($n) - } - } - } -} -constraints memory -body { - set end [getbytes] - for {set i 0} {$i < 5} {incr i} { - doit $i - set tmp $end - set end [getbytes] - } - set leakedBytes [expr {$end - $tmp}] -} -cleanup { - array unset A - rename getbytes {} - rename doit {} -} -result 0 -test var-22.1 {leak in localVarName intrep: Bug 80304238ac} -setup { - proc getbytes {} { - lindex [split [memory info] \n] 3 3 - } - proc doit {} { - interp create slave - slave eval { - proc doit script { - eval $script - set foo bar - } - doit {foreach foo baz {}} - } - interp delete slave - } -} -constraints memory -body { - set end [getbytes] - for {set i 0} {$i < 5} {incr i} { - doit - set tmp $end - set end [getbytes] - } - set leakedBytes [expr {$end - $tmp}] -} -cleanup { - array unset A - rename getbytes {} - rename doit {} -} -result 0 - - -catch {namespace delete ns} -catch {unset arr} -catch {unset v} - -catch {rename p ""} -catch {namespace delete test_ns_var} -catch {namespace delete test_ns_var2} -catch {unset xx} -catch {unset x} -catch {unset y} -catch {unset i} -catch {unset a} -catch {unset xxxxx} -catch {unset aaaaa} - -# cleanup -::tcltest::cleanupTests -return - -# Local Variables: -# mode: tcl -# End: |