diff options
Diffstat (limited to 'tests/var.test')
| -rw-r--r-- | tests/var.test | 186 |
1 files changed, 119 insertions, 67 deletions
diff --git a/tests/var.test b/tests/var.test index af3d22c..45b7207 100644 --- a/tests/var.test +++ b/tests/var.test @@ -19,6 +19,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +testConstraint testupvar [llength [info commands testupvar]] +testConstraint testgetvarfullname [llength [info commands testgetvarfullname]] +testConstraint testsetnoerr [llength [info commands testsetnoerr]] + catch {rename p ""} catch {namespace delete test_ns_var} catch {unset xx} @@ -27,7 +31,7 @@ catch {unset y} catch {unset i} catch {unset a} catch {unset arr} - + test var-1.1 {TclLookupVar, Array handling} { catch {unset a} set x "incr" ;# force no compilation and runtime call to Tcl_IncrCmd @@ -199,30 +203,28 @@ test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} { p } } {1998} -if {[info commands testupvar] != {}} { - test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} { - catch {unset a} - set a 123321 - proc p {} { - # create global xx linked to global a - testupvar 1 a {} xx global +test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} testupvar { + catch {unset a} + set a 123321 + proc p {} { + # create global xx linked to global a + testupvar 1 a {} xx global + } + list [p] $xx [set xx 789] $a +} {{} 123321 789 789} +test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} testupvar { + catch {unset a} + 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 } - list [p] $xx [set xx 789] $a - } {{} 123321 789 789} - test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} { - catch {unset a} - 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 - } {456 123 123} -} + p + } + list $test_ns_var::vv [set test_ns_var::vv 123] $a +} {456 123 123} test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} { catch {unset aaaaa} catch {unset xxxxx} @@ -269,25 +271,28 @@ test var-3.10 {MakeUpvar, } { set msg } } {1 1} +test var-3.11 {MakeUpvar, my var looks like array elem} -body { + catch {unset aaaaa} + set aaaaa 789789 + upvar #0 aaaaa foo(bar) +} -returnCodes 1 -result {bad variable name "foo(bar)": upvar won't create a scalar variable that looks like an array element} -if {[info commands testgetvarfullname] != {}} { - test var-4.1 {Tcl_GetVariableName, global variable} { - catch {unset a} - set a 123 - testgetvarfullname a global - } ::a - test var-4.2 {Tcl_GetVariableName, namespace variable} { - 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} { - catch {unset a} - set a(1) foo - list [catch {testgetvarfullname a(1) global} msg] $msg - } {1 {unknown variable "a(1)"}} -} +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} testgetvarfullname { + catch {unset a} + set a(1) foo + list [catch {testgetvarfullname a(1) global} msg] $msg +} {1 {unknown variable "a(1)"}} test var-5.1 {Tcl_GetVariableFullName, global variable} { catch {unset a} @@ -519,11 +524,23 @@ test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var 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} { +test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called with fully-qualified var names} { + catch {namespace delete test_ns_var} + catch {unset a} + 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 +} {{} {::test_ns_var::v {} u}} + +test var-9.1 {behaviour of TclGet/SetVar simple get/set} testsetnoerr { catch {unset u}; catch {unset v} list \ [set u a; testsetnoerr u] \ @@ -531,7 +548,7 @@ test var-9.1 {behaviour of TclGet/SetVar simple get/set} { [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} { +test var-9.2 {behaviour of TclGet/SetVar namespace get/set} testsetnoerr { catch {namespace delete ns} namespace eval ns {variable u a; variable v} list \ @@ -540,46 +557,46 @@ test var-9.2 {behaviour of TclGet/SetVar namespace get/set} { [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} { +test var-9.3 {behaviour of TclGetVar no variable} testsetnoerr { 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} { +test var-9.4 {behaviour of TclGetVar no namespace variable} testsetnoerr { 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} { +test var-9.5 {behaviour of TclGetVar no namespace} testsetnoerr { 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} { +test var-9.6 {behaviour of TclSetVar no namespace} testsetnoerr { 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} { +test var-9.7 {behaviour of TclGetVar array variable} testsetnoerr { 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} { +test var-9.8 {behaviour of TclSetVar array variable} testsetnoerr { 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} { +test var-9.9 {behaviour of TclGetVar read trace success} testsetnoerr { proc resetvar {val name elem op} {upvar 1 $name v; set v $val} catch {unset u}; catch {unset v} set u 10 @@ -589,7 +606,7 @@ test var-9.9 {behaviour of TclGetVar read trace success} { [testsetnoerr u] \ [testseterr v] } {{before get 1} {before get 2}} -test var-9.10 {behaviour of TclGetVar read trace error} { +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 @@ -597,7 +614,7 @@ test var-9.10 {behaviour of TclGetVar read trace error} { [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} { +test var-9.11 {behaviour of TclSetVar write trace success} testsetnoerr { proc doubleval {name elem op} {upvar 1 $name v; set v [expr {2 * $v}]} catch {unset u}; catch {unset v} set v 1 @@ -607,7 +624,7 @@ test var-9.11 {behaviour of TclSetVar write trace success} { [testsetnoerr u 2] \ [testseterr v 3] } {{before set 4} {before set 6}} -test var-9.12 {behaviour of TclSetVar write trace error} { +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 @@ -615,12 +632,11 @@ test var-9.12 {behaviour of TclSetVar write trace error} { [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 @@ -677,6 +693,10 @@ 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 +} -returnCodes 0 -match exact -result os + test var-15.1 {segfault in [unset], [Bug 735335]} { proc A { name } { upvar $name var @@ -691,25 +711,53 @@ test var-15.1 {segfault in [unset], [Bug 735335]} { namespace eval test unset useSomeUnlikelyNameHere } {} -test var-16.1 {CallVarTraces: save/restore interp error state: 1038021} { - trace add variable errorCode write { ;#} + +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 + 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 + 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 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 {} +} {} + catch {namespace delete ns} catch {unset arr} catch {unset v} @@ -728,3 +776,7 @@ catch {unset aaaaa} # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: |