# 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. # # RCS: @(#) $Id: var.test,v 1.2 2001/09/14 01:43:51 zlaski Exp $ # 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}} 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) 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}