inherit.test

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

         [test_cd_mongrel0 cget -test_cd_mongrel::x]
} {one two three one}

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

# ----------------------------------------------------------------------
#  Test inheritance info
# ----------------------------------------------------------------------
test inherit-4.1 {define classes for inheritance info} {
    itcl::class test_cd_foo {
        method do {args} {eval $args}
    }
    itcl::class test_cd_bar {
        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
        method do {args} {eval $args}
    }
} {}

test inherit-4.2 {create an object for inheritance tests} {
    test_cd_mongrel #auto
} {test_cd_mongrel0}

test inherit-4.3 {"info class" should be virtual} {
    list [test_cd_mongrel0 info class] \
         [test_cd_mongrel0 test_cd_foo::do info class] \
         [test_cd_mongrel0 test_cd_geek::do info class]
} {::test_cd_mongrel ::test_cd_mongrel ::test_cd_mongrel}

test inherit-4.4 {"info inherit" depends on class scope} {
    list [test_cd_mongrel0 info inherit] \
         [test_cd_mongrel0 test_cd_foo::do info inherit] \
         [test_cd_mongrel0 test_cd_foobar::do info inherit]
} {{::test_cd_foobar ::test_cd_geek} {} {::test_cd_foo ::test_cd_bar}}

test inherit-4.5 {"info heritage" depends on class scope} {
    list [test_cd_mongrel0 info heritage] \
         [test_cd_mongrel0 test_cd_foo::do info heritage] \
         [test_cd_mongrel0 test_cd_foobar::do info heritage]
} {{::test_cd_mongrel ::test_cd_foobar ::test_cd_foo ::test_cd_bar ::test_cd_geek} ::test_cd_foo {::test_cd_foobar ::test_cd_foo ::test_cd_bar}}

test inherit-4.6 {built-in "isa" method works} {
    set status ""
    foreach c [test_cd_mongrel0 info heritage] {
        lappend status [test_cd_mongrel0 isa $c]
    }
    set status
} {1 1 1 1 1}

test inherit-4.7 {built-in "isa" method works within methods} {
    set status ""
    foreach c [test_cd_mongrel0 info heritage] {
        lappend status [test_cd_mongrel0 test_cd_foo::do isa $c]
    }
    set status
} {1 1 1 1 1}

test inherit-4.8 {built-in "isa" method recognizes bad classes} {
    itcl::class test_cd_other {}
    test_cd_mongrel0 isa test_cd_other
} {0}

test inherit-4.9 {built-in "isa" method recognizes bad classes} {
    list [catch {test_cd_mongrel0 isa test_cd_bogus} msg] $msg
} {1 {class "test_cd_bogus" not found in context "::test_cd_foo"}}

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

# ----------------------------------------------------------------------
#  Test "find objects"
# ----------------------------------------------------------------------
test inherit-5.1 {define classes for inheritance info} {
    itcl::class test_cd_foo {
    }
    itcl::class test_cd_bar {
    }
    itcl::class test_cd_foobar {
        inherit test_cd_foo test_cd_bar
    }
    itcl::class test_cd_geek {
    }
    itcl::class test_cd_mongrel {
        inherit test_cd_foobar test_cd_geek
    }
} {}

test inherit-5.2 {create objects for info tests} {
    list [test_cd_foo #auto] [test_cd_foo #auto] \
         [test_cd_foobar #auto] \
         [test_cd_geek #auto] \
         [test_cd_mongrel #auto]
} {test_cd_foo0 test_cd_foo1 test_cd_foobar0 test_cd_geek0 test_cd_mongrel0}

test inherit-5.3 {find objects: -class qualifier} {
    lsort [itcl::find objects -class test_cd_foo]
} {test_cd_foo0 test_cd_foo1}

test inherit-5.4 {find objects: -class qualifier} {
    lsort [itcl::find objects -class test_cd_mongrel]
} {test_cd_mongrel0}

test inherit-5.5 {find objects: -isa qualifier} {
    lsort [itcl::find objects -isa test_cd_foo]
} {test_cd_foo0 test_cd_foo1 test_cd_foobar0 test_cd_mongrel0}

test inherit-5.6 {find objects: -isa qualifier} {
    lsort [itcl::find objects -isa test_cd_mongrel]
} {test_cd_mongrel0}

test inherit-5.7 {find objects: name qualifier} {
    lsort [itcl::find objects test_cd_foo*]
} {test_cd_foo0 test_cd_foo1 test_cd_foobar0}

test inherit-5.8 {find objects: -class and -isa qualifiers} {
    lsort [itcl::find objects -isa test_cd_foo -class test_cd_foobar]
} {test_cd_foobar0}

test inherit-5.9 {find objects: -isa and name qualifiers} {
    lsort [itcl::find objects -isa test_cd_foo *0]
} {test_cd_foo0 test_cd_foobar0 test_cd_mongrel0}

test inherit-5.10 {find objects: usage errors} {
    list [catch {itcl::find objects -xyzzy value} msg] $msg
} {1 {wrong # args: should be "itcl::find objects ?-class className? ?-isa className? ?pattern?"}}

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

# ----------------------------------------------------------------------
#  Test method scoping and execution
# ----------------------------------------------------------------------
test inherit-6.1 {define classes for scope tests} {
    itcl::class test_cd_foo {
        method check {} {return "foo"}
        method do {args} {return "foo says: [eval $args]"}
    }
    itcl::class test_cd_bar {
        method check {} {return "bar"}
        method do {args} {return "bar says: [eval $args]"}
    }
    itcl::class test_cd_foobar {
        inherit test_cd_foo test_cd_bar
        method check {} {return "foobar"}
        method do {args} {return "foobar says: [eval $args]"}
    }
    itcl::class test_cd_geek {
        method check {} {return "geek"}
        method do {args} {return "geek says: [eval $args]"}
    }
    itcl::class test_cd_mongrel {
        inherit test_cd_foobar test_cd_geek
        method check {} {return "mongrel"}
        method do {args} {return "mongrel says: [eval $args]"}
    }
} {}

test inherit-6.2 {create objects for scoping tests} {
    list [test_cd_mongrel #auto] [test_cd_foobar #auto]
} {test_cd_mongrel0 test_cd_foobar0}

test inherit-6.3 {methods are "virtual" outside of the class} {
    test_cd_mongrel0 check
} {mongrel}

test inherit-6.4 {specific methods can be accessed by name} {
    test_cd_mongrel0 test_cd_foo::check
} {foo}

test inherit-6.5 {methods are "virtual" within a class too} {
    test_cd_mongrel0 test_cd_foobar::do check
} {foobar says: mongrel}

test inherit-6.6 {methods are executed where they were defined} {
    list [test_cd_mongrel0 test_cd_foo::do namespace current] \
         [test_cd_mongrel0 test_cd_foobar::do namespace current] \
         [test_cd_mongrel0 do namespace current] \
} {{foo says: ::test_cd_foo} {foobar says: ::test_cd_foobar} {mongrel says: ::test_cd_mongrel}}

test inherit-6.7 {"virtual" command no longer exists} {
    list [catch {
        test_cd_mongrel0 test_cd_foobar::do virtual namespace current
    } msg] $msg
} {1 {invalid command name "virtual"}}

test inherit-6.8 {"previous" command no longer exists} {
    list [catch {
        test_cd_mongrel0 test_cd_foobar::do previous check
    } msg] $msg
} {1 {invalid command name "previous"}}

test inherit-6.9 {errors are detected and reported across class boundaries} {
    #
    # NOTE: For tcl8.2.3 and earlier the stack trace will have
    #       'invoked from within "eval $args"' for the first eval
    #       statement.  For later versions, it does not.  Use
    #       string match to reduce the sensitivity to that.
    #
    list [catch {
        test_cd_mongrel0 do test_cd_foobar0 do error "test" "some error"
    } msg] $msg [string match {some error
    ("eval" body line 1)*
    (object "::test_cd_foobar0" method "::test_cd_foobar::do" body line 1)
    invoked from within
"test_cd_foobar0 do error test {some error}"
    ("eval" body line 1)
    invoked from within
"eval $args"
    (object "::test_cd_mongrel0" method "::test_cd_mongrel::do" body line 1)
    invoked from within
"test_cd_mongrel0 do test_cd_foobar0 do error "test" "some error""} [set ::errorInfo]]
} {1 test 1}

test inherit-6.10 {errors codes are preserved across class boundaries} {
    list [catch {
        test_cd_mongrel0 do test_cd_foobar0 do error "test" "problem" CODE-BLUE
    } msg] $msg [set ::errorCode]
} {1 test CODE-BLUE}

test inherit-6.11 {multi-value error codes are preserved across class boundaries} {
    list [catch {
        test_cd_mongrel0 do test_cd_foobar0 do error "test" "problem" "CODE BLUE 123"
    } msg] $msg [set ::errorCode]
} {1 test {CODE BLUE 123}}

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

# ----------------------------------------------------------------------
#  Test inheritance errors
# ----------------------------------------------------------------------
test inherit-7.1 {cannot inherit from non-existant class} {
    list [catch {
        itcl::class bogus {
            inherit non_existant_class_xyzzy
        }
    } msg] $msg
} {1 {cannot inherit from "non_existant_class_xyzzy" (class "non_existant_class_xyzzy" not found in context "::")}}

test inherit-7.2 {cannot inherit from procs} {
    proc inherit_test_proc {x y} {
        error "never call this"
    }
    list [catch {
        itcl::class bogus {
            inherit inherit_test_proc
        }
    } msg] $msg
} {1 {cannot inherit from "inherit_test_proc" (class "inherit_test_proc" not found in context "::")}}

test inherit-7.3 {cannot inherit from yourself} {
    list [catch {
        itcl::class bogus {
            inherit bogus
        }
    } msg] $msg
} {1 {class "bogus" cannot inherit from itself}}

test inherit-7.4 {cannot have more than one inherit statement} {
    list [catch {
        itcl::class test_inherit_base1 { }
        itcl::class test_inherit_base2 { }
        itcl::class bogus {
            inherit test_inherit_base1
            inherit test_inherit_base2
        }
    } msg] $msg
} {1 {inheritance "test_inherit_base1 " already defined for class "::bogus"}}

# ----------------------------------------------------------------------
#  Multiple base class error detection
# ----------------------------------------------------------------------
test inherit-8.1 {cannot inherit from the same base class more than once} {
    itcl::class test_mi_base {}
    itcl::class test_mi_foo {inherit test_mi_base}
    itcl::class test_mi_bar {inherit test_mi_base}
    list [catch {
        itcl::class test_mi_foobar {inherit test_mi_foo test_mi_bar}
    } msg] $msg
} {1 {class "::test_mi_foobar" inherits base class "::test_mi_base" more than once:
  test_mi_foobar->test_mi_foo->test_mi_base
  test_mi_foobar->test_mi_bar->test_mi_base}}

itcl::delete class test_mi_base

::tcltest::cleanupTests
return