diff options
Diffstat (limited to 'itcl/itcl/tests/inherit.test')
| -rw-r--r-- | itcl/itcl/tests/inherit.test | 576 |
1 files changed, 576 insertions, 0 deletions
diff --git a/itcl/itcl/tests/inherit.test b/itcl/itcl/tests/inherit.test new file mode 100644 index 00000000000..d391573dee4 --- /dev/null +++ b/itcl/itcl/tests/inherit.test @@ -0,0 +1,576 @@ +# +# Tests for inheritance and scope handling +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# 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. + +if {[string compare test [info procs test]] == 1} then {source defs} + +# ---------------------------------------------------------------------- +# 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 [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 [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 [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 "" + 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 + body test_cd_bar::constructor {args} {return "bar: $args"} + body test_cd_bar::destructor {} {error "bar: failed"} + test_cd_mongrel mongrel1 ted + set test_cd_watch "" + list [catch {delete object mongrel1} msg] $msg \ + $errorInfo $test_cd_watch [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 +"delete object mongrel1"} {{mongrel destruct} {foobar destruct} {foo destruct}} mongrel1} + +test inherit-1.10 {errors during destruction prevent class delete} { + list [catch {delete class test_cd_foo} msg] $msg +} {1 {bar: failed}} + +eval namespace delete [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 [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] \ + [test_cd_mongrel0 cget -test_cd_mongrel::x] +} {one two three one} + +eval namespace delete [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} { + 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 [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 [find objects -class test_cd_foo] +} {test_cd_foo0 test_cd_foo1} + +test inherit-5.4 {find objects: -class qualifier} { + lsort [find objects -class test_cd_mongrel] +} {test_cd_mongrel0} + +test inherit-5.5 {find objects: -isa qualifier} { + lsort [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 [find objects -isa test_cd_mongrel] +} {test_cd_mongrel0} + +test inherit-5.7 {find objects: name qualifier} { + lsort [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 [find objects -isa test_cd_foo -class test_cd_foobar] +} {test_cd_foobar0} + +test inherit-5.9 {find objects: -isa and name qualifiers} { + lsort [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 {find objects -xyzzy} msg] $msg +} {1 {wrong # args: should be "find objects ?-class className? ?-isa className? ?pattern?"}} + +eval namespace delete [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} { + list [catch { + test_cd_mongrel0 do test_cd_foobar0 do error "test" "some error" + } msg] $msg [set ::errorInfo] +} {1 test {some error + ("eval" body line 1) + invoked from within +"eval $args" + (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""}} + +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 [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} { + class test_mi_base {} + class test_mi_foo {inherit test_mi_base} + class test_mi_bar {inherit test_mi_base} + list [catch { + 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}} + +delete class test_mi_base |