1# 2# Tests for SF bugs 3# ---------------------------------------------------------------------- 4# AUTHOR: Arnulf Wiedemann 5# arnulf@wiedemann-pri.de 6# ---------------------------------------------------------------------- 7# Copyright (c) Arnulf Wiedemann 8# ====================================================================== 9# See the file "license.terms" for information on usage and 10# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 11 12package require tcltest 2.1 13namespace import ::tcltest::test 14::tcltest::loadTestedCommands 15package require itcl 16 17global ::test_status 18 19# ---------------------------------------------------------------------- 20# Test bugs of the SourceForge bug tracker for incrtcl 21# ---------------------------------------------------------------------- 22 23test sfbug-163 {upvar has to resolve instance variables in caller} -setup { 24 itcl::class o1 { 25 public method getValue {name} { 26 upvar $name val 27 set val 22 28 } 29 } 30 itcl::class o2 { 31 public variable command 32 constructor {cls2} { 33 $cls2 getValue command 34 } 35 public method b {cls2} { 36 return $command 37 } 38 } 39 o1 test1 40 o2 test2 test1 41} -body { 42 test2 b test1 43} -cleanup { 44 itcl::delete class o2 45 itcl::delete class o1 46} -result 22 47 48test sfbug-187 {upvar with this variable SF bug #187 49} -body { 50 ::itcl::class foo { 51 method test {} { 52 PopID 53 } 54 55 proc PopID {} { 56 upvar 1 this me 57 set me 58 } 59 } 60 foo bar 61 bar test 62} -result {::bar} \ 63 -cleanup {::itcl::delete class foo} 64 65test sfbug-234 {chain with no argument SF bug #234 66} -body { 67 set ::test_status "" 68 itcl::class One { 69 public method t1 {x} { 70 lappend ::test_status "$this One.t1($x)" 71 } 72 public method t2 {} { 73 lappend ::test_status "$this One.t2" 74 } 75 } 76 77 itcl::class Two { 78 inherit One 79 80 public method t1 {x} { 81 lappend ::test_status "$this Two.t1($x)" 82 chain $x 83 } 84 85 public method t2 {} { 86 lappend ::test_status "$this Two.t2" 87 chain 88 } 89 } 90 set y [Two #auto] 91 $y t1 a 92 $y t2 93} -result {{::two0 Two.t1(a)} {::two0 One.t1(a)} {::two0 Two.t2} {::two0 One.t2}} \ 94 -cleanup {::itcl::delete class Two} 95 96test sfbug-236 {problem with inheritance of methods SF bug #236 97} -body { 98 set ::test_status "" 99 100 ::itcl::class c_mem { 101 private method get_ports {} 102 public method get_mem {} 103 } 104 105 ::itcl::class c_rom { 106 inherit c_mem 107 private method get_ports {} 108 } 109 110 ::itcl::body c_rom::get_ports {} { 111 return "toto" 112 } 113 114 ::itcl::body c_mem::get_ports {} { 115 return "tata" 116 } 117 118 ::itcl::body c_mem::get_mem {} { 119 return [concat "titi" [get_ports]] 120 } 121 122 set ptr [c_rom #auto] 123 lappend ::test_status [$ptr get_mem] 124 125# expected output: 126# titi toto 127} -result {{titi toto}} \ 128 -cleanup {::itcl::delete class c_rom} 129 130test sfbug-237 { problem with chain command SF bug #237 131} -body { 132 set ::test_status "" 133 134 itcl::class main { 135 constructor {} { 136 lappend ::test_status "OK ITCL constructor" 137 } 138 139 public method init_OK1 { parm } { 140 lappend ::test_status "OK1 MAIN $parm" 141 } 142 public method init_OK2 {} { 143 lappend ::test_status "OK2 MAIN" 144 } 145 public method init_ERR1 {} { 146 lappend ::test_status "ERR1 MAIN" 147 } 148 } 149 150 itcl::class child { 151 inherit main 152 153 constructor {} {} 154 155 public method init_OK1 {} { 156 lappend ::test_status "OK1 CHILD" 157 chain TEST 158 } 159 160 public method init_OK2 {} { 161 lappend ::test_status "OK2 CHILD" 162 next 163 } 164 165 public method init_ERR1 {} { 166 lappend ::test_status "ERR1 CHILD" 167 chain 168 } 169 } 170 171 set obj [child #auto] 172 $obj init_OK1 173 $obj init_OK2 174 $obj init_ERR1 175} -result {{OK ITCL constructor} {OK1 CHILD} {OK1 MAIN TEST} {OK2 CHILD} {OK2 MAIN} {ERR1 CHILD} {ERR1 MAIN}} \ 176 -cleanup {::itcl::delete class child} 177 178test sfbug-243 {faulty namespace behaviour SF bug #243 179} -body { 180 set ::test_status "" 181 182 namespace eval ns {} 183 184 itcl::class ns::A { 185 method do {} {nsdo} 186 187 method nsdo {} { 188 lappend ::test_status "body do: [info function do -body]" 189 } 190 } 191 192 [ns::A #auto] do 193 194 itcl::body ns::A::do {} {A::nsdo} 195 [ns::A #auto] do 196 197 itcl::body ns::A::do {} {::ns::A::nsdo} 198 [ns::A #auto] do 199 200 itcl::body ns::A::do {} {ns::A::nsdo} 201 [ns::A #auto] do 202} -result {{body do: nsdo} {body do: A::nsdo} {body do: ::ns::A::nsdo} {body do: ns::A::nsdo}} \ 203 -cleanup {::itcl::delete class ns::A} 204 205test sfbug-244 { SF bug 244 206} -body { 207 set ::test_status "" 208 209 proc foo {body} { 210 uplevel $body 211 } 212 213 itcl::class A { 214 method do {body} {foo $body} 215 method do2 {} {lappend ::test_status done} 216 } 217 218 set y [A #auto] 219 $y do { 220 lappend ::test_status "I'm $this" 221 do2 222 } 223} -result {{I'm ::a0} done} \ 224 -cleanup {::itcl::delete class A; rename foo {}} 225 226test sfbug-250 { SF bug #250 227} -body { 228 set ::test_status "" 229 230 ::itcl::class A { 231 variable b 232 233 constructor {} { 234 set b [B #auto] 235 } 236 237 public method m1 {} { 238 $b m3 239 } 240 241 public method m2 {} { 242 lappend ::test_status m2 243 } 244 } 245 246 ::itcl::class B { 247 public method m3 {} { 248 uplevel m2 249 } 250 } 251 252 set a [A #auto] 253 $a m1 254 255} -result {m2} \ 256 -cleanup {::itcl::delete class A B} 257 258test sfbug-Schelte {bug with onfo reported from Schelte SF bug xxx 259} -body { 260 set ::test_status "" 261 262 itcl::class foo { 263 method kerplunk {args} { 264 lappend ::test_status [info level 0] 265 lappend ::test_status [::info level 0] 266 lappend ::test_status [[namespace which info] level 0] 267 } 268 } 269 270 [foo #auto] kerplunk hello world 271} -result {{foo0 kerplunk hello world} {foo0 kerplunk hello world} {foo0 kerplunk hello world}} \ 272 -cleanup {::itcl::delete class foo} 273 274test sfbug-254.1 { SF bug #254 + bug [1dc2d851eb] 275} -body { 276 set interp [interp create] 277 set ::test_status "" 278 $interp eval { 279 oo::class destroy 280 } 281 lappend ::test_status "::oo::class destroy worked" 282 if {[catch { 283 $interp eval [::tcltest::loadScript] 284 $interp eval { 285 package require itcl 286 } 287 } msg]} { 288 lappend ::test_status $msg 289 } 290} -result {{::oo::class destroy worked} {::oo::class does not refer to an object}} \ 291 -cleanup {interp delete $interp} 292 293test sfbug-254.2 { SF bug #254 + bug [1dc2d851eb] 294} -body { 295 set interp [interp create] 296 set ::test_status "" 297 $interp eval {set ::tcl::inl_mem_test 0} 298 $interp eval [::tcltest::loadScript] 299 $interp eval { 300 package require itcl 301 302 oo::class destroy 303 } 304 lappend ::test_status "::oo::class destroy worked" 305 if {[catch { 306 $interp eval { 307 ::itcl::class ::test {} 308 } 309 } msg]} { 310 lappend ::test_status $msg 311 } 312} -result {{::oo::class destroy worked} {oo-subsystem is deleted}} \ 313 -cleanup {interp delete $interp} 314 315test sfbug-254.3 { delete oo-subsystem should remove all classes + summary of bug [1dc2d851eb] 316} -body { 317 set interp [interp create] 318 set ::test_status "" 319 $interp eval {set ::tcl::inl_mem_test 0} 320 $interp eval [::tcltest::loadScript] 321 $interp eval { 322 package require itcl 323 324 ::itcl::class ::test {} 325 } 326 lappend ::test_status "::test class created" 327 $interp eval { 328 oo::class destroy 329 } 330 lappend ::test_status "::oo::class destroy worked" 331 if {[catch { 332 $interp eval { 333 ::test x 334 } 335 } msg]} { 336 lappend ::test_status $msg 337 } 338 if {[catch { 339 $interp eval { 340 ::itcl::class ::test2 {inherit ::test} 341 } 342 } msg]} { 343 lappend ::test_status $msg 344 } 345} -result {{::test class created} {::oo::class destroy worked} {invalid command name "::test"} {oo-subsystem is deleted}} \ 346 -cleanup {interp delete $interp} 347 348test sfbug-255 { SF bug #255 349} -body { 350 set ::test_status "" 351 352 proc ::sfbug_255_do_uplevel { body } { 353 uplevel 1 $body 354 } 355 356 proc ::sfbug_255_testclass { pathName args } { 357 uplevel TestClass $pathName $args 358 } 359 360 ::itcl::class TestClass { 361 public variable property "value" 362 constructor {} { 363 } 364 365 private method internal-helper {} { 366 return "TestClass::internal-helper" 367 } 368 369 public method api-call {} { 370 lappend ::test_status "TestClass::api-call" 371 lappend ::test_status [internal-helper] 372 lappend ::test_status [sfbug_255_do_uplevel { internal-helper }] 373 lappend ::test_status [cget -property] 374 sfbug_255_do_uplevel { lappend ::test_status [cget -property] } 375 } 376 } 377 378 [::sfbug_255_testclass tc] api-call 379} -result {TestClass::api-call TestClass::internal-helper TestClass::internal-helper value value} \ 380 -cleanup {::itcl::delete class TestClass} 381 382test fossilbug-8 { fossil bug 2cd667f270b68ef66d668338e09d144e20405e23 383} -body { 384 ::itcl::class ::Naughty { 385 private method die {} { 386 } 387 } 388 ::Naughty die 389} -cleanup { 390 ::itcl::delete class ::Naughty 391} -result {die} 392 393test sfbug-256 { SF bug #256 394} -body { 395 set ::test_status "" 396 397 proc ::sfbug_256_do_uplevel { body } { 398 uplevel 1 $body 399 } 400 401 proc ::sfbug_256_testclass { pathName args } { 402 uplevel TestClass256 $pathName $args 403 } 404 405 ::itcl::class TestClass256 { 406 public variable property "value" 407 constructor {} { 408 } 409 410 private method internal-helper {} { 411 lappend ::test_status "TestClass::internal-helper" 412 sfbug_256_do_uplevel { lappend ::test_status [cget -property] } 413 } 414 415 public method api-call {} { 416 lappend ::test_status "TestClass::api-call" 417 lappend ::test_status [internal-helper] 418 lappend ::test_status [sfbug_256_do_uplevel { internal-helper }] 419 lappend ::test_status [cget -property] 420 sfbug_256_do_uplevel { lappend ::test_status [cget -property] } 421 } 422 } 423 424 [::sfbug_256_testclass tc] api-call 425} -result {TestClass::api-call TestClass::internal-helper value {TestClass::api-call TestClass::internal-helper value} TestClass::internal-helper value {TestClass::api-call TestClass::internal-helper value {TestClass::api-call TestClass::internal-helper value} TestClass::internal-helper value} value value} \ 426 -cleanup {::itcl::delete class TestClass256} 427 428test sfbug-257 { SF bug #257 429} -body { 430 set interp [interp create] 431 $interp eval {set ::tcl::inl_mem_test 0} 432 $interp eval [::tcltest::loadScript] 433 $interp eval { 434 package require itcl 435 set ::test_status "" 436 ::itcl::class ::cl1 { 437 method m1 {} { 438 ::oo::class destroy 439 lappend ::test_status "method Hello World" 440 } 441 proc p1 {} { 442 lappend ::test_status "proc Hello World" 443 } 444 } 445 set obj1 [::cl1 #auto] 446 ::cl1::p1 447 $obj1 p1 448 $obj1 m1 449 450 catch { 451 $obj1 m1 452 ::cl1::p1 453 } msg 454 lappend ::test_status $msg 455 } 456} -result {{proc Hello World} {proc Hello World} {method Hello World} {invalid command name "cl10"}} \ 457 -cleanup {interp delete $interp} 458 459test sfbug-259 { SF bug #257 } -setup { 460 interp create child 461 load {} Itcl child 462} -cleanup { 463 interp delete child 464} -body { 465 child eval { 466proc do_uplevel { body } { 467 uplevel 1 $body 468} 469proc ::testclass { pathName args } { 470 uplevel TestClass $pathName $args 471} 472itcl::class TestClass { 473 constructor {} {} 474 public variable property "value" 475 public method api-call {} 476 protected method internal-helper {} 477} 478itcl::body TestClass::internal-helper {} { 479} 480itcl::configbody TestClass::property { 481 internal-helper 482} 483itcl::body TestClass::api-call {} { 484 do_uplevel {configure -property blah} 485} 486set tc [::testclass .] 487$tc api-call 488 } 489} 490 491test sfbug-261 { SF bug #261 } -setup { 492 itcl::class A { 493 public method a1 {} {a2} 494 public method a2 {} {uplevel a3 hello} 495 public method a3 {s} {return $s} 496 } 497 A x 498} -body { 499 x a1 500} -cleanup { 501 itcl::delete class A 502} -result hello 503 504test sfbug-265.1 { SF bug #265 } -setup { 505 itcl::class C {} 506} -body { 507 namespace eval A {C c} 508 namespace eval B {C c} 509} -cleanup { 510 itcl::delete class C 511 namespace delete A B 512} -result c 513test sfbug-265.2 { SF bug #265 } -setup { 514 itcl::class C {} 515 itcl::class B::C {} 516} -body { 517 C ::A::B 518 B::C ::A 519} -cleanup { 520 itcl::delete class B::C 521 itcl::delete class C 522 namespace delete A B 523} -result ::A 524 525test sfbug-268 { SF bug #268 } -setup { 526 itcl::class C { 527 private variable v 528 destructor {error foo} 529 public method demo {} {set v 0} 530 } 531 C c 532} -body { 533 catch {itcl::delete object c} 534 c demo 535} -cleanup { 536 rename c {} 537 itcl::delete class C 538} -result 0 539 540test sfbug-273 { SF bug #273 } -setup { 541 itcl::class C { 542 public proc call {m} {$m} 543 public proc crash {} { 544 call null 545 info frame 2 546 return ok 547 } 548 public proc null {} {} 549 } 550} -body { 551 C::call crash 552} -cleanup { 553 itcl::delete class C 554} -result ok 555 556 557test sfbug-276.0 { SF bug #276 } -setup { 558 set ::answer {} 559 itcl::class A { 560 constructor {} { 561 lappend ::answer [uplevel namespace current] 562 } 563 } 564 itcl::class B { 565 inherit A 566 constructor {} {} 567 } 568} -body { 569 B b 570 set ::answer 571} -cleanup { 572 itcl::delete class A B 573 unset -nocomplain ::answer 574} -result ::B 575 576test sfbug-276.1 { SF bug #276 } -setup { 577 set ::answer {} 578 itcl::class A { 579 constructor {} { 580 lappend ::answer [uplevel namespace current] 581 } 582 } 583 itcl::class E { 584 constructor {} { 585 lappend ::answer [uplevel namespace current] 586 } 587 } 588 itcl::class B { 589 inherit A E 590 constructor {} {} 591 } 592} -body { 593 B b 594 set ::answer 595} -cleanup { 596 itcl::delete class A B E 597 unset -nocomplain ::answer 598} -result {::B ::B} 599 600test fossil-9.0 {d0126511d9} -setup { 601 itcl::class N::B {} 602} -body { 603 itcl::class N {} 604} -cleanup { 605 itcl::delete class N::B N 606} -result {} 607 608test fossil-9.1 {d0126511d9} -setup { 609 itcl::class N::B {} 610 itcl::delete class N::B 611 namespace delete N 612} -body { 613 itcl::class N {} 614} -cleanup { 615 itcl::delete class N 616 catch {namespace delete N} 617} -result {} 618 619test fossil-9.2 {ec215db901} -setup { 620 set ::answer {} 621 itcl::class Object { 622 constructor {} {set n 1} {set ::answer $n} 623 } 624} -body { 625 Object foo 626 set ::answer 627} -cleanup { 628 itcl::delete class Object 629 unset -nocomplain ::answer 630} -result 1 631 632test fossil-9.3 {c45384364c} -setup { 633 itcl::class A { 634 method demo script {uplevel 1 $script} 635 } 636 A a 637 itcl::class B { 638 method demo script {eval $script; a demo $script} 639 } 640 B b 641} -body { 642 b demo {lappend result $this} 643} -cleanup { 644 itcl::delete class A B 645} -result {::b ::b} 646 647test fossil-9.4 {9eea4912b9} -setup { 648 itcl::class A { 649 public method foo WRONG 650 } 651} -body { 652 itcl::body A::foo {RIGHT} {} 653 A a 654 a info args foo 655} -cleanup { 656 itcl::delete class A 657} -result RIGHT 658 659test sfbugs-281 {Resolve inherited common} -setup { 660 itcl::class Parent {protected common x 0} 661} -cleanup { 662 itcl::delete class Parent 663} -body { 664 itcl::class Child { 665 inherit Parent 666 set Parent::x 667 } 668} -result {} 669 670 671 672#test sfbug-xxx { SF bug xxx 673#} -body { 674# set ::test_status "" 675# 676#} -result {::bar} \ 677# -cleanup {::itcl::delete class yyy} 678 679::tcltest::cleanupTests 680return 681