inherit.test

这是一个Linux下的集成开发环境

#
# Tests for inheritance and scope handling
# ----------------------------------------------------------------------
#   AUTHOR:  Michael J. McLennan
#            Bell Labs Innovations for Lucent Technologies
#            [e-mail]
#            http://www.tcltk.com/itcl
#
#      RCS:  $Id: inherit.test,v 1.1 2003/02/05 10:53:55 mdejong Exp $
# ----------------------------------------------------------------------
#            Copyright (c) 1993-1998  Lucent Technologies, Inc.
# ======================================================================
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require tcltest
namespace import -force ::tcltest::*

if {[string compare test [info procs test]] == 1} then {source defs}

package require Itcl

# ----------------------------------------------------------------------
#  Test construction/destruction with inheritance
# ----------------------------------------------------------------------
test inherit-1.1 {define classes with constructors/destructors} {
    variable ::test_cd_watch ""
    itcl::class test_cd_foo {
        constructor {x y} {
            global ::test_cd_watch
            lappend test_cd_watch "foo: $x $y"
        }
        destructor {
            global ::test_cd_watch
            lappend test_cd_watch "foo destruct"
        }
    }
    itcl::class test_cd_bar {
        constructor {args} {
            global ::test_cd_watch
            lappend test_cd_watch "bar: $args"
        }
        destructor {
            global ::test_cd_watch
            lappend test_cd_watch "bar destruct"
        }
    }
    itcl::class test_cd_foobar {
        inherit test_cd_foo test_cd_bar
        constructor {x y args} {
            test_cd_foo::constructor $x $y
        } {
            global ::test_cd_watch
            lappend test_cd_watch "foobar: $x $y ($args)"
        }
        destructor {
            global ::test_cd_watch
            lappend test_cd_watch "foobar destruct"
        }
    }
    itcl::class test_cd_geek {
        constructor {} {
            global ::test_cd_watch
            lappend test_cd_watch "geek"
        }
        destructor {
            global ::test_cd_watch
            lappend test_cd_watch "geek destruct"
        }
    }
    itcl::class test_cd_mongrel {
        inherit test_cd_foobar test_cd_geek
        constructor {x} {
            eval test_cd_foobar::constructor 1 2 fred $x
        } {
            global ::test_cd_watch
            lappend test_cd_watch "mongrel: $x"
        }
        destructor {
            global ::test_cd_watch
            lappend test_cd_watch "mongrel destruct"
        }
    }
    itcl::class test_cd_none {
        inherit test_cd_bar test_cd_geek
    }
    itcl::class test_cd_skip {
        inherit test_cd_none
        constructor {} {
            global ::test_cd_watch
            lappend test_cd_watch "skip"
        }
        destructor {
            global ::test_cd_watch
            lappend test_cd_watch "skip destruct"
        }
    }
} {}

test inherit-1.2 {constructors should be invoked in the proper order} {
    set ::test_cd_watch ""
    list [test_cd_mongrel #auto bob] [set ::test_cd_watch]
} {test_cd_mongrel0 {{foo: 1 2} {bar: } {foobar: 1 2 (fred bob)} geek {mongrel: bob}}}

test inherit-1.3 {destructors should be invoked in the proper order} {
    set ::test_cd_watch ""
    list [itcl::delete object test_cd_mongrel0] [set ::test_cd_watch]
} {{} {{mongrel destruct} {foobar destruct} {foo destruct} {bar destruct} {geek destruct}}}

test inherit-1.4 {constructors are optional} {
    set ::test_cd_watch ""
    list [test_cd_none #auto] [set ::test_cd_watch]
} {test_cd_none0 {geek {bar: }}}

test inherit-1.5 {destructors are optional} {
    set ::test_cd_watch ""
    list [itcl::delete object test_cd_none0] [set ::test_cd_watch]
} {{} {{bar destruct} {geek destruct}}}

test inherit-1.6 {construction ok if constructors are missing} {
    set ::test_cd_watch ""
    list [test_cd_skip #auto] [set ::test_cd_watch]
} {test_cd_skip0 {geek {bar: } skip}}

test inherit-1.7 {destruction ok if destructors are missing} {
    set ::test_cd_watch ""
    list [itcl::delete object test_cd_skip0] [set ::test_cd_watch]
} {{} {{skip destruct} {bar destruct} {geek destruct}}}

test inherit-1.8 {errors during construction are cleaned up and reported} {
    global errorInfo test_cd_watch
    set test_cd_watch ""
    itcl::body test_cd_bar::constructor {args} {error "bar: failed"}
    list [catch {test_cd_mongrel #auto bob} msg] $msg \
        $errorInfo $test_cd_watch
} {1 {bar: failed} {bar: failed
    while executing
"error "bar: failed""
    while constructing object "::test_cd_mongrel1" in ::test_cd_bar::constructor (body line 1)
    while constructing object "::test_cd_mongrel1" in ::test_cd_foobar::constructor (body line 1)
    invoked from within
"test_cd_foobar::constructor 1 2 fred bob"
    ("eval" body line 1)
    invoked from within
"eval test_cd_foobar::constructor 1 2 fred $x"
    while constructing object "::test_cd_mongrel1" in ::test_cd_mongrel::constructor (body line 2)
    invoked from within
"test_cd_mongrel #auto bob"} {{foo: 1 2} {mongrel destruct} {foobar destruct} {foo destruct} {bar destruct} {geek destruct}}}

test inherit-1.9 {errors during destruction prevent object delete} {
    global errorInfo test_cd_watch
    itcl::body test_cd_bar::constructor {args} {return "bar: $args"}
    itcl::body test_cd_bar::destructor {} {error "bar: failed"}
    test_cd_mongrel mongrel1 ted
    set test_cd_watch ""
    list [catch {itcl::delete object mongrel1} msg] $msg \
        $errorInfo $test_cd_watch [itcl::find objects mongrel*]
} {1 {bar: failed} {bar: failed
    while executing
"error "bar: failed""
    while deleting object "::mongrel1" in ::test_cd_bar::destructor (body line 1)
    invoked from within
"itcl::delete object mongrel1"} {{mongrel destruct} {foobar destruct} {foo destruct}} mongrel1}

test inherit-1.10 {errors during destruction prevent class delete} {
    list [catch {itcl::delete class test_cd_foo} msg] $msg
} {1 {bar: failed}}

eval namespace delete [itcl::find classes test_cd_*]

# ----------------------------------------------------------------------
#  Test data member access and scoping
# ----------------------------------------------------------------------
test inherit-2.1 {define classes with data members} {
    itcl::class test_cd_foo {
        protected variable x "foo-x"
        method do {args} {eval $args}
    }
    itcl::class test_cd_bar {
        protected variable x "bar-x"
        method do {args} {eval $args}
    }
    itcl::class test_cd_foobar {
        inherit test_cd_foo test_cd_bar
        method do {args} {eval $args}
    }
    itcl::class test_cd_geek {
        method do {args} {eval $args}
    }
    itcl::class test_cd_mongrel {
        inherit test_cd_foobar test_cd_geek
        protected variable x "mongrel-x"
        method do {args} {eval $args}
    }
} {}

test inherit-2.2 {"info" provides access to shadowed data members} {
    test_cd_mongrel #auto
    list [lsort [test_cd_mongrel0 info variable]] \
         [test_cd_mongrel0 info variable test_cd_foo::x] \
         [test_cd_mongrel0 info variable test_cd_bar::x] \
         [test_cd_mongrel0 info variable test_cd_mongrel::x] \
         [test_cd_mongrel0 info variable x]
} {{::test_cd_bar::x ::test_cd_foo::x ::test_cd_mongrel::this ::test_cd_mongrel::x} {protected variable ::test_cd_foo::x foo-x foo-x} {protected variable ::test_cd_bar::x bar-x bar-x} {protected variable ::test_cd_mongrel::x mongrel-x mongrel-x} {protected variable ::test_cd_mongrel::x mongrel-x mongrel-x}}

test inherit-2.3 {variable resolution works properly in methods} {
    list [test_cd_mongrel0 test_cd_foo::do set x] \
         [test_cd_mongrel0 test_cd_bar::do set x] \
         [test_cd_mongrel0 test_cd_foobar::do set x] \
         [test_cd_mongrel0 test_cd_mongrel::do set x]
} {foo-x bar-x foo-x mongrel-x}

test inherit-2.4 {methods have access to shadowed data members} {
    list [test_cd_mongrel0 test_cd_foobar::do set x] \
         [test_cd_mongrel0 test_cd_foobar::do set test_cd_foo::x] \
         [test_cd_mongrel0 test_cd_foobar::do set test_cd_bar::x] \
         [test_cd_mongrel0 test_cd_mongrel::do set test_cd_foo::x] \
         [test_cd_mongrel0 test_cd_mongrel::do set test_cd_bar::x]
} {foo-x foo-x bar-x foo-x bar-x}

eval namespace delete [itcl::find classes test_cd_*]

# ----------------------------------------------------------------------
#  Test public variables and "configure" method
# ----------------------------------------------------------------------
test inherit-3.1 {define classes with public variables} {
    variable ::test_cd_watch ""
    itcl::class test_cd_foo {
        public variable x "foo-x" {
            global test_cd_watch
            lappend test_cd_watch "foo: $x in scope [namespace current]"
        }
        method do {args} {eval $args}
    }
    itcl::class test_cd_bar {
        public variable x "bar-x" {
            global test_cd_watch
            lappend test_cd_watch "bar: $x in scope [namespace current]"
        }
        method do {args} {eval $args}
    }
    itcl::class test_cd_foobar {
        inherit test_cd_foo test_cd_bar
        method do {args} {eval $args}
    }
    itcl::class test_cd_geek {
        method do {args} {eval $args}
    }
    itcl::class test_cd_mongrel {
        inherit test_cd_foobar test_cd_geek
        public variable x "mongrel-x" {
            global test_cd_watch
            lappend test_cd_watch "mongrel: $x in scope [namespace current]"
        }
        method do {args} {eval $args}
    }
} {}

test inherit-3.2 {create an object with public variables} {
    test_cd_mongrel #auto
} {test_cd_mongrel0}

test inherit-3.3 {"configure" lists all public variables} {
    lsort [test_cd_mongrel0 configure]
} {{-test_cd_bar::x bar-x bar-x} {-test_cd_foo::x foo-x foo-x} {-x mongrel-x mongrel-x}}

test inherit-3.4 {"configure" treats simple names as "most specific"} {
    lsort [test_cd_mongrel0 configure -x]
} {-x mongrel-x mongrel-x}

test inherit-3.5 {"configure" treats simple names as "most specific"} {
    set ::test_cd_watch ""
    list [test_cd_mongrel0 configure -x hello] \
         [set ::test_cd_watch]
} {{} {{mongrel: hello in scope ::test_cd_mongrel}}}

test inherit-3.6 {"configure" allows access to shadowed options} {
    set ::test_cd_watch ""
    list [test_cd_mongrel0 configure -test_cd_foo::x hello] \
         [test_cd_mongrel0 configure -test_cd_bar::x there] \
         [set ::test_cd_watch]
} {{} {} {{foo: hello in scope ::test_cd_foo} {bar: there in scope ::test_cd_bar}}}

test inherit-3.7 {"configure" will change several variables at once} {
    set ::test_cd_watch ""
    list [test_cd_mongrel0 configure -x one \
                                     -test_cd_foo::x two \
                                     -test_cd_bar::x three] \
         [set ::test_cd_watch]
} {{} {{mongrel: one in scope ::test_cd_mongrel} {foo: two in scope ::test_cd_foo} {bar: three in scope ::test_cd_bar}}}

test inherit-3.8 {"cget" does proper name resolution} {
    list [test_cd_mongrel0 cget -x] \
         [test_cd_mongrel0 cget -test_cd_foo::x] \
         [test_cd_mongrel0 cget -test_cd_bar::x] \