diff options
Diffstat (limited to 'itcl/itcl/tests/inherit.test')
| -rw-r--r-- | itcl/itcl/tests/inherit.test | 86 |
1 files changed, 49 insertions, 37 deletions
diff --git a/itcl/itcl/tests/inherit.test b/itcl/itcl/tests/inherit.test index d391573dee4..e20d5065e78 100644 --- a/itcl/itcl/tests/inherit.test +++ b/itcl/itcl/tests/inherit.test @@ -13,8 +13,13 @@ # 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 # ---------------------------------------------------------------------- @@ -99,7 +104,7 @@ test inherit-1.2 {constructors should be invoked in the proper order} { 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] + 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} { @@ -109,7 +114,7 @@ test inherit-1.4 {constructors are optional} { test inherit-1.5 {destructors are optional} { set ::test_cd_watch "" - list [delete object test_cd_none0] [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} { @@ -119,13 +124,13 @@ test inherit-1.6 {construction ok if constructors are missing} { test inherit-1.7 {destruction ok if destructors are missing} { set ::test_cd_watch "" - list [delete object test_cd_skip0] [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 "" - body test_cd_bar::constructor {args} {error "bar: failed"} + 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 @@ -144,24 +149,24 @@ test inherit-1.8 {errors during construction are cleaned up and reported} { 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"} + 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 {delete object mongrel1} msg] $msg \ - $errorInfo $test_cd_watch [find objects mongrel*] + 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 -"delete object mongrel1"} {{mongrel destruct} {foobar destruct} {foo destruct}} mongrel1} +"itcl::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 + list [catch {itcl::delete class test_cd_foo} msg] $msg } {1 {bar: failed}} -eval namespace delete [find classes test_cd_*] +eval namespace delete [itcl::find classes test_cd_*] # ---------------------------------------------------------------------- # Test data member access and scoping @@ -213,7 +218,7 @@ test inherit-2.4 {methods have access to shadowed data members} { [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_*] +eval namespace delete [itcl::find classes test_cd_*] # ---------------------------------------------------------------------- # Test public variables and "configure" method @@ -291,7 +296,7 @@ test inherit-3.8 {"cget" does proper name resolution} { [test_cd_mongrel0 cget -test_cd_mongrel::x] } {one two three one} -eval namespace delete [find classes test_cd_*] +eval namespace delete [itcl::find classes test_cd_*] # ---------------------------------------------------------------------- # Test inheritance info @@ -355,7 +360,7 @@ test inherit-4.7 {built-in "isa" method works within methods} { } {1 1 1 1 1} test inherit-4.8 {built-in "isa" method recognizes bad classes} { - class test_cd_other {} + itcl::class test_cd_other {} test_cd_mongrel0 isa test_cd_other } {0} @@ -363,7 +368,7 @@ 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_*] +eval namespace delete [itcl::find classes test_cd_*] # ---------------------------------------------------------------------- # Test "find objects" @@ -391,38 +396,38 @@ test inherit-5.2 {create objects for info tests} { } {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] + lsort [itcl::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] + lsort [itcl::find objects -class test_cd_mongrel] } {test_cd_mongrel0} test inherit-5.5 {find objects: -isa qualifier} { - lsort [find objects -isa test_cd_foo] + 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 [find objects -isa test_cd_mongrel] + lsort [itcl::find objects -isa test_cd_mongrel] } {test_cd_mongrel0} test inherit-5.7 {find objects: name qualifier} { - lsort [find objects test_cd_foo*] + 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 [find objects -isa test_cd_foo -class test_cd_foobar] + 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 [find objects -isa test_cd_foo *0] + 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 {find objects -xyzzy} msg] $msg -} {1 {wrong # args: should be "find objects ?-class className? ?-isa className? ?pattern?"}} + 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 [find classes test_cd_*] +eval namespace delete [itcl::find classes test_cd_*] # ---------------------------------------------------------------------- # Test method scoping and execution @@ -487,13 +492,16 @@ test inherit-6.8 {"previous" command no longer exists} { } {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 [set ::errorInfo] -} {1 test {some error - ("eval" body line 1) - invoked from within -"eval $args" + } 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}" @@ -502,7 +510,8 @@ test inherit-6.9 {errors are detected and reported across class boundaries} { "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_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 { @@ -516,7 +525,7 @@ test inherit-6.11 {multi-value error codes are preserved across class boundaries } msg] $msg [set ::errorCode] } {1 test {CODE BLUE 123}} -eval namespace delete [find classes test_cd_*] +eval namespace delete [itcl::find classes test_cd_*] # ---------------------------------------------------------------------- # Test inheritance errors @@ -563,14 +572,17 @@ test inherit-7.4 {cannot have more than one inherit statement} { # 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} + 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 { - class test_mi_foobar {inherit test_mi_foo test_mi_bar} + 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}} -delete class test_mi_base +itcl::delete class test_mi_base + +::tcltest::cleanupTests +return |