Subversion Repositories or1k

# 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.1.1.1 2002-01-16 10:25:36 markom 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}