summaryrefslogtreecommitdiffstats
path: root/tests/var.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/var.test')
-rw-r--r--tests/var.test194
1 files changed, 155 insertions, 39 deletions
diff --git a/tests/var.test b/tests/var.test
index 735b0ee..981c649 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -13,7 +13,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: var.test,v 1.3 1998/09/14 18:40:15 stanton Exp $
+# RCS: @(#) $Id: var.test,v 1.4 1999/02/03 00:55:07 stanton Exp $
#
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -113,6 +113,62 @@ test var-1.14 {TclLookupVar, namespace code ignores ":"s in middle and end of va
[expr {[lsearch [info vars] x:y:] != -1}]
}
} {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} {
+ 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
+ }
+} {0 2 1 {can't set "foo": upvar refers to element in deleted array}}
test var-2.1 {Tcl_LappendObjCmd, create var if new} {
catch {unset x}
@@ -389,6 +445,16 @@ test var-7.12 {Tcl_VariableObjCmd, variable cmd inside proc creates local link v
}
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-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} {
catch {namespace delete test_ns_var}
@@ -411,48 +477,98 @@ 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 TclSetVar without TCL_LEAVE_ERR_MSG flag} {
- testsetnoerr v 1
-} 1
-test var-9.2 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} {
- catch {unset v}
- list [catch {testsetnoerr v} res] $res;
-} {1 {before get}}
-test var-9.3 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} {
- catch {unset arr}
- set arr(1) 1;
- list [catch {testsetnoerr arr} res] $res;
-} {1 {before get}}
-test var-9.4 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} {
- namespace eval ns {variable v nsv}
- testsetnoerr ns::v;
-} nsv;
-test var-9.5 {behaviour of TclGetVar without TCL_LEAVE_ERR_MSG flag} {
- catch {namespace delete ns}
- list [catch {testsetnoerr ns::v} res] $res;
-} {1 {before get}}
-test var-9.6 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} {
- catch {unset arr}
- set arr(1) 1;
- list [catch {testsetnoerr arr 2} res] $res;
-} {1 {before set}}
-test var-9.7 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} {
- catch {unset arr}
- set arr(1) 1;
- list [catch {testsetnoerr arr 2} res] $res;
-} {1 {before set}}
-test var-9.8 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} {
- # this test currently fails, should not...
- # (some namespace function resets the interp while it should not)
+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::v 1} res] $res;
-} {1 {before set}}
-test var-9.9 {behaviour of TclSetVar without TCL_LEAVE_ERR_MSG flag} {
+ 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
-} {1 {before set}}
+ 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}
}
catch {namespace delete ns}