Initial revision

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}
+