1# 2# Tests for inheritance and scope handling 3# ---------------------------------------------------------------------- 4# AUTHOR: Michael J. McLennan 5# Bell Labs Innovations for Lucent Technologies 6# mmclennan@lucent.com 7# http://www.tcltk.com/itcl 8# 9# RCS: $Id: inherit.test,v 1.5 2004/02/12 18:09:50 davygrvy Exp $ 10# ---------------------------------------------------------------------- 11# Copyright (c) 1993-1998 Lucent Technologies, Inc. 12# ====================================================================== 13# See the file "license.terms" for information on usage and 14# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 15 16if {[lsearch [namespace children] ::tcltest] == -1} { 17 package require tcltest 2.1 18 namespace import -force ::tcltest::test 19} 20 21::tcltest::loadTestedCommands 22 23# ---------------------------------------------------------------------- 24# Test construction/destruction with inheritance 25# ---------------------------------------------------------------------- 26test inherit-1.1 {define classes with constructors/destructors} { 27 variable ::test_cd_watch "" 28 itcl::class test_cd_foo { 29 constructor {x y} { 30 global ::test_cd_watch 31 lappend test_cd_watch "foo: $x $y" 32 } 33 destructor { 34 global ::test_cd_watch 35 lappend test_cd_watch "foo destruct" 36 } 37 } 38 itcl::class test_cd_bar { 39 constructor {args} { 40 global ::test_cd_watch 41 lappend test_cd_watch "bar: $args" 42 } 43 destructor { 44 global ::test_cd_watch 45 lappend test_cd_watch "bar destruct" 46 } 47 } 48 itcl::class test_cd_foobar { 49 inherit test_cd_foo test_cd_bar 50 constructor {x y args} { 51 test_cd_foo::constructor $x $y 52 } { 53 global ::test_cd_watch 54 lappend test_cd_watch "foobar: $x $y ($args)" 55 } 56 destructor { 57 global ::test_cd_watch 58 lappend test_cd_watch "foobar destruct" 59 } 60 } 61 itcl::class test_cd_geek { 62 constructor {} { 63 global ::test_cd_watch 64 lappend test_cd_watch "geek" 65 } 66 destructor { 67 global ::test_cd_watch 68 lappend test_cd_watch "geek destruct" 69 } 70 } 71 itcl::class test_cd_mongrel { 72 inherit test_cd_foobar test_cd_geek 73 constructor {x} { 74 eval test_cd_foobar::constructor 1 2 fred $x 75 } { 76 global ::test_cd_watch 77 lappend test_cd_watch "mongrel: $x" 78 } 79 destructor { 80 global ::test_cd_watch 81 lappend test_cd_watch "mongrel destruct" 82 } 83 } 84 itcl::class test_cd_none { 85 inherit test_cd_bar test_cd_geek 86 } 87 itcl::class test_cd_skip { 88 inherit test_cd_none 89 constructor {} { 90 global ::test_cd_watch 91 lappend test_cd_watch "skip" 92 } 93 destructor { 94 global ::test_cd_watch 95 lappend test_cd_watch "skip destruct" 96 } 97 } 98} {} 99 100test inherit-1.2 {constructors should be invoked in the proper order} { 101 set ::test_cd_watch "" 102 list [test_cd_mongrel #auto bob] [set ::test_cd_watch] 103} {test_cd_mongrel0 {{foo: 1 2} {bar: } {foobar: 1 2 (fred bob)} geek {mongrel: bob}}} 104 105test inherit-1.3 {destructors should be invoked in the proper order} { 106 set ::test_cd_watch "" 107 list [itcl::delete object test_cd_mongrel0] [set ::test_cd_watch] 108} {{} {{mongrel destruct} {foobar destruct} {foo destruct} {bar destruct} {geek destruct}}} 109 110test inherit-1.4 {constructors are optional} { 111 set ::test_cd_watch "" 112 list [test_cd_none #auto] [set ::test_cd_watch] 113} {test_cd_none0 {geek {bar: }}} 114 115test inherit-1.5 {destructors are optional} { 116 set ::test_cd_watch "" 117 list [itcl::delete object test_cd_none0] [set ::test_cd_watch] 118} {{} {{bar destruct} {geek destruct}}} 119 120test inherit-1.6 {construction ok if constructors are missing} { 121 set ::test_cd_watch "" 122 list [test_cd_skip #auto] [set ::test_cd_watch] 123} {test_cd_skip0 {geek {bar: } skip}} 124 125test inherit-1.7 {destruction ok if destructors are missing} { 126 set ::test_cd_watch "" 127 list [itcl::delete object test_cd_skip0] [set ::test_cd_watch] 128} {{} {{skip destruct} {bar destruct} {geek destruct}}} 129 130test inherit-1.8 {errors during construction are cleaned up and reported} { 131 global errorInfo test_cd_watch 132 set test_cd_watch "" 133 itcl::body test_cd_bar::constructor {args} {error "bar: failed"} 134 list [catch {test_cd_mongrel #auto bob} msg] $msg \ 135 $errorInfo $test_cd_watch 136} {1 {bar: failed} {bar: failed 137 while executing 138"error "bar: failed"" 139 while constructing object "::test_cd_mongrel1" in ::test_cd_bar::constructor (body line 1) 140 while constructing object "::test_cd_mongrel1" in ::test_cd_foobar::constructor (body line 1) 141 invoked from within 142"test_cd_foobar::constructor 1 2 fred bob" 143 ("eval" body line 1) 144 invoked from within 145"eval test_cd_foobar::constructor 1 2 fred $x" 146 while constructing object "::test_cd_mongrel1" in ::test_cd_mongrel::constructor (body line 2) 147 invoked from within 148"test_cd_mongrel #auto bob"} {{foo: 1 2} {mongrel destruct} {foobar destruct} {foo destruct} {bar destruct} {geek destruct}}} 149 150test inherit-1.9 {errors during destruction prevent object delete} { 151 global errorInfo test_cd_watch 152 itcl::body test_cd_bar::constructor {args} {return "bar: $args"} 153 itcl::body test_cd_bar::destructor {} {error "bar: failed"} 154 test_cd_mongrel mongrel1 ted 155 set test_cd_watch "" 156 list [catch {itcl::delete object mongrel1} msg] $msg \ 157 $errorInfo $test_cd_watch [itcl::find objects mongrel*] 158} {1 {bar: failed} {bar: failed 159 while executing 160"error "bar: failed"" 161 while deleting object "::mongrel1" in ::test_cd_bar::destructor (body line 1) 162 invoked from within 163"itcl::delete object mongrel1"} {{mongrel destruct} {foobar destruct} {foo destruct}} mongrel1} 164 165test inherit-1.10 {errors during destruction prevent class delete} { 166 list [catch {itcl::delete class test_cd_foo} msg] $msg 167} {1 {bar: failed}} 168 169eval namespace delete [itcl::find classes test_cd_*] 170 171# ---------------------------------------------------------------------- 172# Test data member access and scoping 173# ---------------------------------------------------------------------- 174test inherit-2.1 {define classes with data members} { 175 itcl::class test_cd_foo { 176 protected variable x "foo-x" 177 method do {args} {eval $args} 178 } 179 itcl::class test_cd_bar { 180 protected variable x "bar-x" 181 method do {args} {eval $args} 182 } 183 itcl::class test_cd_foobar { 184 inherit test_cd_foo test_cd_bar 185 method do {args} {eval $args} 186 } 187 itcl::class test_cd_geek { 188 method do {args} {eval $args} 189 } 190 itcl::class test_cd_mongrel { 191 inherit test_cd_foobar test_cd_geek 192 protected variable x "mongrel-x" 193 method do {args} {eval $args} 194 } 195} {} 196 197test inherit-2.2 {"info" provides access to shadowed data members} { 198 test_cd_mongrel #auto 199 list [lsort [test_cd_mongrel0 info variable]] \ 200 [test_cd_mongrel0 info variable test_cd_foo::x] \ 201 [test_cd_mongrel0 info variable test_cd_bar::x] \ 202 [test_cd_mongrel0 info variable test_cd_mongrel::x] \ 203 [test_cd_mongrel0 info variable x] 204} {{::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}} 205 206test inherit-2.3 {variable resolution works properly in methods} { 207 list [test_cd_mongrel0 test_cd_foo::do set x] \ 208 [test_cd_mongrel0 test_cd_bar::do set x] \ 209 [test_cd_mongrel0 test_cd_foobar::do set x] \ 210 [test_cd_mongrel0 test_cd_mongrel::do set x] 211} {foo-x bar-x foo-x mongrel-x} 212 213test inherit-2.4 {methods have access to shadowed data members} { 214 list [test_cd_mongrel0 test_cd_foobar::do set x] \ 215 [test_cd_mongrel0 test_cd_foobar::do set test_cd_foo::x] \ 216 [test_cd_mongrel0 test_cd_foobar::do set test_cd_bar::x] \ 217 [test_cd_mongrel0 test_cd_mongrel::do set test_cd_foo::x] \ 218 [test_cd_mongrel0 test_cd_mongrel::do set test_cd_bar::x] 219} {foo-x foo-x bar-x foo-x bar-x} 220 221eval namespace delete [itcl::find classes test_cd_*] 222 223# ---------------------------------------------------------------------- 224# Test public variables and "configure" method 225# ---------------------------------------------------------------------- 226test inherit-3.1 {define classes with public variables} { 227 variable ::test_cd_watch "" 228 itcl::class test_cd_foo { 229 public variable x "foo-x" { 230 global test_cd_watch 231 lappend test_cd_watch "foo: $x in scope [namespace current]" 232 } 233 method do {args} {eval $args} 234 } 235 itcl::class test_cd_bar { 236 public variable x "bar-x" { 237 global test_cd_watch 238 lappend test_cd_watch "bar: $x in scope [namespace current]" 239 } 240 method do {args} {eval $args} 241 } 242 itcl::class test_cd_foobar { 243 inherit test_cd_foo test_cd_bar 244 method do {args} {eval $args} 245 } 246 itcl::class test_cd_geek { 247 method do {args} {eval $args} 248 } 249 itcl::class test_cd_mongrel { 250 inherit test_cd_foobar test_cd_geek 251 public variable x "mongrel-x" { 252 global test_cd_watch 253 lappend test_cd_watch "mongrel: $x in scope [namespace current]" 254 } 255 method do {args} {eval $args} 256 } 257} {} 258 259test inherit-3.2 {create an object with public variables} { 260 test_cd_mongrel #auto 261} {test_cd_mongrel0} 262 263test inherit-3.3 {"configure" lists all public variables} { 264 lsort [test_cd_mongrel0 configure] 265} {{-test_cd_bar::x bar-x bar-x} {-test_cd_foo::x foo-x foo-x} {-x mongrel-x mongrel-x}} 266 267test inherit-3.4 {"configure" treats simple names as "most specific"} { 268 lsort [test_cd_mongrel0 configure -x] 269} {-x mongrel-x mongrel-x} 270 271test inherit-3.5 {"configure" treats simple names as "most specific"} { 272 set ::test_cd_watch "" 273 list [test_cd_mongrel0 configure -x hello] \ 274 [set ::test_cd_watch] 275} {{} {{mongrel: hello in scope ::test_cd_mongrel}}} 276 277test inherit-3.6 {"configure" allows access to shadowed options} { 278 set ::test_cd_watch "" 279 list [test_cd_mongrel0 configure -test_cd_foo::x hello] \ 280 [test_cd_mongrel0 configure -test_cd_bar::x there] \ 281 [set ::test_cd_watch] 282} {{} {} {{foo: hello in scope ::test_cd_foo} {bar: there in scope ::test_cd_bar}}} 283 284test inherit-3.7 {"configure" will change several variables at once} { 285 set ::test_cd_watch "" 286 list [test_cd_mongrel0 configure -x one \ 287 -test_cd_foo::x two \ 288 -test_cd_bar::x three] \ 289 [set ::test_cd_watch] 290} {{} {{mongrel: one in scope ::test_cd_mongrel} {foo: two in scope ::test_cd_foo} {bar: three in scope ::test_cd_bar}}} 291 292test inherit-3.8 {"cget" does proper name resolution} { 293 list [test_cd_mongrel0 cget -x] \ 294 [test_cd_mongrel0 cget -test_cd_foo::x] \ 295 [test_cd_mongrel0 cget -test_cd_bar::x] \ 296 [test_cd_mongrel0 cget -test_cd_mongrel::x] 297} {one two three one} 298 299eval namespace delete [itcl::find classes test_cd_*] 300 301# ---------------------------------------------------------------------- 302# Test inheritance info 303# ---------------------------------------------------------------------- 304test inherit-4.1 {define classes for inheritance info} { 305 itcl::class test_cd_foo { 306 method do {args} {eval $args} 307 } 308 itcl::class test_cd_bar { 309 method do {args} {eval $args} 310 } 311 itcl::class test_cd_foobar { 312 inherit test_cd_foo test_cd_bar 313 method do {args} {eval $args} 314 } 315 itcl::class test_cd_geek { 316 method do {args} {eval $args} 317 } 318 itcl::class test_cd_mongrel { 319 inherit test_cd_foobar test_cd_geek 320 method do {args} {eval $args} 321 } 322} {} 323 324test inherit-4.2 {create an object for inheritance tests} { 325 test_cd_mongrel #auto 326} {test_cd_mongrel0} 327 328test inherit-4.3 {"info class" should be virtual} { 329 list [test_cd_mongrel0 info class] \ 330 [test_cd_mongrel0 test_cd_foo::do info class] \ 331 [test_cd_mongrel0 test_cd_geek::do info class] 332} {::test_cd_mongrel ::test_cd_mongrel ::test_cd_mongrel} 333 334test inherit-4.4 {"info inherit" depends on class scope} { 335 list [test_cd_mongrel0 info inherit] \ 336 [test_cd_mongrel0 test_cd_foo::do info inherit] \ 337 [test_cd_mongrel0 test_cd_foobar::do info inherit] 338} {{::test_cd_foobar ::test_cd_geek} {} {::test_cd_foo ::test_cd_bar}} 339 340test inherit-4.5 {"info heritage" depends on class scope} { 341 list [test_cd_mongrel0 info heritage] \ 342 [test_cd_mongrel0 test_cd_foo::do info heritage] \ 343 [test_cd_mongrel0 test_cd_foobar::do info heritage] 344} {{::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}} 345 346test inherit-4.6 {built-in "isa" method works} { 347 set status "" 348 foreach c [test_cd_mongrel0 info heritage] { 349 lappend status [test_cd_mongrel0 isa $c] 350 } 351 set status 352} {1 1 1 1 1} 353 354test inherit-4.7 {built-in "isa" method works within methods} { 355 set status "" 356 foreach c [test_cd_mongrel0 info heritage] { 357 lappend status [test_cd_mongrel0 test_cd_foo::do isa $c] 358 } 359 set status 360} {1 1 1 1 1} 361 362test inherit-4.8 {built-in "isa" method recognizes bad classes} { 363 itcl::class test_cd_other {} 364 test_cd_mongrel0 isa test_cd_other 365} {0} 366 367test inherit-4.9 {built-in "isa" method recognizes bad classes} { 368 list [catch {test_cd_mongrel0 isa test_cd_bogus} msg] $msg 369} {1 {class "test_cd_bogus" not found in context "::test_cd_foo"}} 370 371eval namespace delete [itcl::find classes test_cd_*] 372 373# ---------------------------------------------------------------------- 374# Test "find objects" 375# ---------------------------------------------------------------------- 376test inherit-5.1 {define classes for inheritance info} { 377 itcl::class test_cd_foo { 378 } 379 itcl::class test_cd_bar { 380 } 381 itcl::class test_cd_foobar { 382 inherit test_cd_foo test_cd_bar 383 } 384 itcl::class test_cd_geek { 385 } 386 itcl::class test_cd_mongrel { 387 inherit test_cd_foobar test_cd_geek 388 } 389} {} 390 391test inherit-5.2 {create objects for info tests} { 392 list [test_cd_foo #auto] [test_cd_foo #auto] \ 393 [test_cd_foobar #auto] \ 394 [test_cd_geek #auto] \ 395 [test_cd_mongrel #auto] 396} {test_cd_foo0 test_cd_foo1 test_cd_foobar0 test_cd_geek0 test_cd_mongrel0} 397 398test inherit-5.3 {find objects: -class qualifier} { 399 lsort [itcl::find objects -class test_cd_foo] 400} {test_cd_foo0 test_cd_foo1} 401 402test inherit-5.4 {find objects: -class qualifier} { 403 lsort [itcl::find objects -class test_cd_mongrel] 404} {test_cd_mongrel0} 405 406test inherit-5.5 {find objects: -isa qualifier} { 407 lsort [itcl::find objects -isa test_cd_foo] 408} {test_cd_foo0 test_cd_foo1 test_cd_foobar0 test_cd_mongrel0} 409 410test inherit-5.6 {find objects: -isa qualifier} { 411 lsort [itcl::find objects -isa test_cd_mongrel] 412} {test_cd_mongrel0} 413 414test inherit-5.7 {find objects: name qualifier} { 415 lsort [itcl::find objects test_cd_foo*] 416} {test_cd_foo0 test_cd_foo1 test_cd_foobar0} 417 418test inherit-5.8 {find objects: -class and -isa qualifiers} { 419 lsort [itcl::find objects -isa test_cd_foo -class test_cd_foobar] 420} {test_cd_foobar0} 421 422test inherit-5.9 {find objects: -isa and name qualifiers} { 423 lsort [itcl::find objects -isa test_cd_foo *0] 424} {test_cd_foo0 test_cd_foobar0 test_cd_mongrel0} 425 426test inherit-5.10 {find objects: usage errors} { 427 list [catch {itcl::find objects -xyzzy value} msg] $msg 428} {1 {wrong # args: should be "itcl::find objects ?-class className? ?-isa className? ?pattern?"}} 429 430eval namespace delete [itcl::find classes test_cd_*] 431 432# ---------------------------------------------------------------------- 433# Test method scoping and execution 434# ---------------------------------------------------------------------- 435test inherit-6.1 {define classes for scope tests} { 436 itcl::class test_cd_foo { 437 method check {} {return "foo"} 438 method do {args} {return "foo says: [eval $args]"} 439 } 440 itcl::class test_cd_bar { 441 method check {} {return "bar"} 442 method do {args} {return "bar says: [eval $args]"} 443 } 444 itcl::class test_cd_foobar { 445 inherit test_cd_foo test_cd_bar 446 method check {} {return "foobar"} 447 method do {args} {return "foobar says: [eval $args]"} 448 } 449 itcl::class test_cd_geek { 450 method check {} {return "geek"} 451 method do {args} {return "geek says: [eval $args]"} 452 } 453 itcl::class test_cd_mongrel { 454 inherit test_cd_foobar test_cd_geek 455 method check {} {return "mongrel"} 456 method do {args} {return "mongrel says: [eval $args]"} 457 } 458} {} 459 460test inherit-6.2 {create objects for scoping tests} { 461 list [test_cd_mongrel #auto] [test_cd_foobar #auto] 462} {test_cd_mongrel0 test_cd_foobar0} 463 464test inherit-6.3 {methods are "virtual" outside of the class} { 465 test_cd_mongrel0 check 466} {mongrel} 467 468test inherit-6.4 {specific methods can be accessed by name} { 469 test_cd_mongrel0 test_cd_foo::check 470} {foo} 471 472test inherit-6.5 {methods are "virtual" within a class too} { 473 test_cd_mongrel0 test_cd_foobar::do check 474} {foobar says: mongrel} 475 476test inherit-6.6 {methods are executed where they were defined} { 477 list [test_cd_mongrel0 test_cd_foo::do namespace current] \ 478 [test_cd_mongrel0 test_cd_foobar::do namespace current] \ 479 [test_cd_mongrel0 do namespace current] \ 480} {{foo says: ::test_cd_foo} {foobar says: ::test_cd_foobar} {mongrel says: ::test_cd_mongrel}} 481 482test inherit-6.7 {"virtual" command no longer exists} { 483 list [catch { 484 test_cd_mongrel0 test_cd_foobar::do virtual namespace current 485 } msg] $msg 486} {1 {invalid command name "virtual"}} 487 488test inherit-6.8 {"previous" command no longer exists} { 489 list [catch { 490 test_cd_mongrel0 test_cd_foobar::do previous check 491 } msg] $msg 492} {1 {invalid command name "previous"}} 493 494test inherit-6.9 {errors are detected and reported across class boundaries} { 495 # 496 # NOTE: For tcl8.2.3 and earlier the stack trace will have 497 # 'invoked from within "eval $args"' for the first eval 498 # statement. For later versions, it does not. Use 499 # string match to reduce the sensitivity to that. 500 # 501 list [catch { 502 test_cd_mongrel0 do test_cd_foobar0 do error "test" "some error" 503 } msg] $msg [string match {some error 504 ("eval" body line 1)* 505 (object "::test_cd_foobar0" method "::test_cd_foobar::do" body line 1) 506 invoked from within 507"test_cd_foobar0 do error test {some error}" 508 ("eval" body line 1) 509 invoked from within 510"eval $args" 511 (object "::test_cd_mongrel0" method "::test_cd_mongrel::do" body line 1) 512 invoked from within 513"test_cd_mongrel0 do test_cd_foobar0 do error "test" "some error""} [set ::errorInfo]] 514} {1 test 1} 515 516test inherit-6.10 {errors codes are preserved across class boundaries} { 517 list [catch { 518 test_cd_mongrel0 do test_cd_foobar0 do error "test" "problem" CODE-BLUE 519 } msg] $msg [set ::errorCode] 520} {1 test CODE-BLUE} 521 522test inherit-6.11 {multi-value error codes are preserved across class boundaries} { 523 list [catch { 524 test_cd_mongrel0 do test_cd_foobar0 do error "test" "problem" "CODE BLUE 123" 525 } msg] $msg [set ::errorCode] 526} {1 test {CODE BLUE 123}} 527 528eval namespace delete [itcl::find classes test_cd_*] 529 530# ---------------------------------------------------------------------- 531# Test inheritance errors 532# ---------------------------------------------------------------------- 533test inherit-7.1 {cannot inherit from non-existant class} { 534 list [catch { 535 itcl::class bogus { 536 inherit non_existant_class_xyzzy 537 } 538 } msg] $msg 539} {1 {cannot inherit from "non_existant_class_xyzzy" (class "non_existant_class_xyzzy" not found in context "::")}} 540 541test inherit-7.2 {cannot inherit from procs} { 542 proc inherit_test_proc {x y} { 543 error "never call this" 544 } 545 list [catch { 546 itcl::class bogus { 547 inherit inherit_test_proc 548 } 549 } msg] $msg 550} {1 {cannot inherit from "inherit_test_proc" (class "inherit_test_proc" not found in context "::")}} 551 552test inherit-7.3 {cannot inherit from yourself} { 553 list [catch { 554 itcl::class bogus { 555 inherit bogus 556 } 557 } msg] $msg 558} {1 {class "bogus" cannot inherit from itself}} 559 560test inherit-7.4 {cannot have more than one inherit statement} { 561 list [catch { 562 itcl::class test_inherit_base1 { } 563 itcl::class test_inherit_base2 { } 564 itcl::class bogus { 565 inherit test_inherit_base1 566 inherit test_inherit_base2 567 } 568 } msg] $msg 569} {1 {inheritance "test_inherit_base1 " already defined for class "::bogus"}} 570 571# ---------------------------------------------------------------------- 572# Multiple base class error detection 573# ---------------------------------------------------------------------- 574test inherit-8.1 {cannot inherit from the same base class more than once} { 575 itcl::class test_mi_base {} 576 itcl::class test_mi_foo {inherit test_mi_base} 577 itcl::class test_mi_bar {inherit test_mi_base} 578 list [catch { 579 itcl::class test_mi_foobar {inherit test_mi_foo test_mi_bar} 580 } msg] $msg 581} {1 {class "::test_mi_foobar" inherits base class "::test_mi_base" more than once: 582 test_mi_foobar->test_mi_foo->test_mi_base 583 test_mi_foobar->test_mi_bar->test_mi_base}} 584 585itcl::delete class test_mi_base 586 587::tcltest::cleanupTests 588return 589