var.test

来自「tcl是工具命令语言」· TEST 代码 · 共 691 行 · 第 1/2 页

} {::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} {
    namespace eval test_ns_var {
        variable two 2
    }
    list [lsort [info vars test_ns_var::*]] \
         [namespace eval test_ns_var {set two}]
} [list [lsort {::test_ns_var::two ::test_ns_var::one}] 2]
test var-7.4 {Tcl_VariableObjCmd, list of vars} {
    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}]
} [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} {
    catch {unset a}
    catch {unset five}
    catch {unset six}
    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
    catch {unset five}
    catch {unset six}
    set a
} {5 5 6 6 666}
catch {unset newvar}
test var-7.6 {Tcl_VariableObjCmd, variable name can be qualified} {
    namespace eval test_ns_var {
        variable ::newvar cheers!
    }
    set newvar
} {cheers!}
catch {unset newvar}
test var-7.7 {Tcl_VariableObjCmd, bad var name} {
    namespace eval test_ns_var {
        list [catch {variable sev:::en 7} msg] $msg
    }
} {1 {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} {
    catch {namespace delete test_ns_var2}
    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]
    set a
} [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} {
    namespace eval test_ns_var {
        proc p {} {
            variable eight
            list [set eight] [info vars]
        }
        p
    }
} {8 eight}
test var-7.11 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
    proc p {} {   ;# note this proc is at global :: scope
        variable test_ns_var::eight
        list [set eight] [info vars]
    }
    p
} {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} {
    catch {namespace eval test_ns_var { variable arrayvar(1) }} res
    set res
} "can't define \"arrayvar(1)\": name refers to an element in an array"
test var-7.15 {Tcl_VariableObjCmd, array element parameter} {
    catch {
	namespace eval test_ns_var { 
	    variable arrayvar
	    set arrayvar(1) x
	    variable arrayvar(1) y
	}   
    } res
    set res
} "can't define \"arrayvar(1)\": name refers to an element in an array"
test var-7.16 {Tcl_VariableObjCmd, no args} {
    list [catch {variable} msg] $msg
} {1 {wrong # args: should be "variable ?name value...? name ?value?"}}
test var-7.17 {Tcl_VariableObjCmd, no args} {
    namespace eval test_ns_var {
	list [catch {variable} msg] $msg
    }
} {1 {wrong # args: should be "variable ?name value...? name ?value?"}}

test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} {
    catch {namespace delete test_ns_var}
    catch {unset a}
    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
} {{} {test_ns_var::v {} u}}

if {[info commands testsetnoerr] == {}} {
    puts "This application hasn't been compiled with the \"testsetnoerr\""
    puts "command, so I can't test TclSetVar etc."
} else {
test var-9.1 {behaviour of TclGet/SetVar simple get/set} {
    catch {unset u}; catch {unset v}
    list \
       [set u a; testsetnoerr u] \
       [testsetnoerr v b] \
       [testseterr u] \
       [unset v; testseterr v b]
} [list {before get a} {before set b} {before get a} {before set b}]
test var-9.2 {behaviour of TclGet/SetVar namespace get/set} {
    catch {namespace delete ns}
    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]
} [list {before get a} {before set b} {before get a} {before set b}]
test var-9.3 {behaviour of TclGetVar no variable} {
    catch {unset u}
    list \
       [catch {testsetnoerr u} res] $res \
       [catch {testseterr u} res] $res
} {1 {before get} 1 {can't read "u": no such variable}}
test var-9.4 {behaviour of TclGetVar no namespace variable} {
    catch {namespace delete ns}
    namespace eval ns {}
    list \
       [catch {testsetnoerr ns::w} res] $res \
       [catch {testseterr ns::w} res] $res
} {1 {before get} 1 {can't read "ns::w": no such variable}}
test var-9.5 {behaviour of TclGetVar no namespace} {
    catch {namespace delete ns}
    list \
       [catch {testsetnoerr ns::u} res] $res \
       [catch {testseterr ns::v} res] $res
} {1 {before get} 1 {can't read "ns::v": no such variable}}
test var-9.6 {behaviour of TclSetVar no namespace} {
    catch {namespace delete ns}
    list \
       [catch {testsetnoerr ns::v 1} res] $res \
       [catch {testseterr ns::v 1} res] $res
} {1 {before set} 1 {can't set "ns::v": parent namespace doesn't exist}}
test var-9.7 {behaviour of TclGetVar array variable} {
    catch {unset arr}
    set arr(1) 1;
    list \
       [catch {testsetnoerr arr} res] $res \
       [catch {testseterr arr} res] $res
} {1 {before get} 1 {can't read "arr": variable is array}}
test var-9.8 {behaviour of TclSetVar array variable} {
    catch {unset arr}
    set arr(1) 1
    list \
       [catch {testsetnoerr arr 2} res] $res \
       [catch {testseterr arr 2} res] $res
} {1 {before set} 1 {can't set "arr": variable is array}}
test var-9.9 {behaviour of TclGetVar read trace success} {
    proc resetvar {val name elem op} {upvar 1 $name v; set v $val}
    catch {unset u}; catch {unset v}
    set u 10
    trace var u r [list resetvar 1]
    trace var v r [list resetvar 2]
    list \
       [testsetnoerr u] \
       [testseterr v]
} {{before get 1} {before get 2}}
test var-9.10 {behaviour of TclGetVar read trace error} {
    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} {
    proc doubleval {name elem op} {upvar 1 $name v; set v [expr {2 * $v}]}
    catch {unset u}; catch {unset v}
    set v 1
    trace var v w doubleval
    trace var u w doubleval
    list \
       [testsetnoerr u 2] \
       [testseterr v 3]
} {{before set 4} {before set 6}}
test var-9.12 {behaviour of TclSetVar write trace error} {
    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} {
   catch {unset arr}
   list [catch {array set arr(x) {a 1 b 2}} res] $res
} {1 {can't set "arr(x)": variable isn't array}}

test var-10.2 {can't nest arrays with array set} {
   catch {unset arr}
   list [catch {array set arr(x) {}} res] $res
} {1 {can't set "arr(x)": variable isn't array}}

test var-11.1 {array unset} {
    catch {unset a}
    array set a { 1,1 a 1,2 b 2,1 c 2,3 d }
    array unset a 1,*
    lsort -dict [array names a]
} {2,1 2,3}
test var-11.2 {array unset} {
    catch {unset a}
    array set a { 1,1 a 1,2 b }
    array unset a
    array exists a
} 0
test var-11.3 {array unset errors} {
    catch {unset a}
    array set a { 1,1 a 1,2 b }
    list [catch {array unset a pattern too} msg] $msg
} {1 {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} {
    catch {unset t}
    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"
} "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 *

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