diff options
Diffstat (limited to 'tests/var.test')
| -rw-r--r-- | tests/var.test | 467 |
1 files changed, 467 insertions, 0 deletions
diff --git a/tests/var.test b/tests/var.test new file mode 100644 index 0000000..6452577 --- /dev/null +++ b/tests/var.test @@ -0,0 +1,467 @@ +# 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. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) var.test 1.10 97/07/28 18:31:47 +# + +if {[string compare test [info procs test]] == 1} then {source defs} + +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, TCL_PARSE_PART1 flag set} { + catch {unset a} + 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) +} {11 11 38 38} +test var-1.2 {TclLookupVar, TCL_GLOBAL_ONLY implies global namespace var} { + set x "global value" + namespace eval test_ns_var { + variable x "namespace value" + 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} { + list [catch {set a:::b} msg] $msg +} {1 {can't read "a:::b": no such variable}} +test var-1.8 {TclLookupVar, error finding namespace var} { + list [catch {set ::foobarfoo} msg] $msg +} {1 {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} { + catch {unset y} + namespace eval test_ns_var { + set ::y 789 + } + set y +} {789} +test var-1.11 {TclLookupVar, error creating new namespace var} { + namespace eval test_ns_var { + list [catch {set ::test_ns_var::foo::bar 314159} msg] $msg + } +} {1 {can't set "::test_ns_var::foo::bar": parent namespace doesn't exist}} +test var-1.12 {TclLookupVar, error creating new namespace var} { + namespace eval test_ns_var { + list [catch {set ::test_ns_var::foo:: 1997} msg] $msg + } +} {1 {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 {[lsearch [info vars] :] != -1}] \ + [expr {[lsearch [info vars] v:] != -1}] \ + [expr {[lsearch [info vars] x:y:] != -1}] + } +} {123 456 789 123 456 789 1 1 1} + +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} { + catch {unset x} + set x 1997 + proc p {} { + global x ;# calls MakeUpvar with TCL_NAMESPACE_ONLY for other var x + return $x + } + p +} {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} +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 + } + 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} +} +test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} { + catch {unset aaaaa} + catch {unset xxxxx} + set aaaaa 77777 + upvar #0 aaaaa xxxxx + list [set xxxxx] [set aaaaa] +} {77777 77777} +test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} { + catch {unset a} + set a 121212 + namespace eval test_ns_var { + upvar ::a vvv + set vvv + } +} {121212} +test var-3.7 {MakeUpvar, my var has ::s} { + catch {unset a} + set a 789789 + upvar #0 a test_ns_var::lnk + namespace eval test_ns_var { + set lnk + } +} {789789} +test var-3.8 {MakeUpvar, my var already exists in global ns} { + catch {unset aaaaa} + catch {unset xxxxx} + set aaaaa 456654 + set xxxxx hello + upvar #0 aaaaa xxxxx + set xxxxx +} {hello} +test var-3.9 {MakeUpvar, my var has invalid ns name} { + catch {unset aaaaa} + set aaaaa 789789 + list [catch {upvar #0 aaaaa test_ns_fred::lnk} msg] $msg +} {1 {bad variable name "test_ns_fred::lnk": unknown namespace}} + +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-5.1 {Tcl_GetVariableFullName, global variable} { + catch {unset a} + set a bar + namespace which -variable a +} {::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} { + namespace which -variable test_ns_var::martha +} {::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 + } + proc p {} { + global ::test_ns_var::boeing + set boeing + } + p +} {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} { + set ::test_ns_var::test_ns_nested:: 24 + proc p {} { + global ::test_ns_var::test_ns_nested:: + set {} + } + p +} {24} + +test var-7.1 {Tcl_VariableObjCmd, create and initialize one new ns variable} { + catch {namespace delete test_ns_var} + namespace eval test_ns_var { + variable one 1 + } + list [info vars test_ns_var::*] [set test_ns_var::one] +} {::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 [info vars test_ns_var::*] \ + [namespace eval test_ns_var {set two}] +} {{::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 [info vars test_ns_var::*] \ + [namespace eval test_ns_var {expr $three+$four}] +} {{::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 [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 [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 [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 +} {{::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}}\ +{::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z} 0 0\ +hello 1 0\ +{0 {}}\ +{::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-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}} + +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) + 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} { + proc readonly args {error "read-only"} + set v 456 + trace var v w readonly + list [catch {testsetnoerr v 2} msg] $msg +} {1 {before set}} + +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} + |