1 2package require Tk 8.5 3package require tcltest ; namespace import -force tcltest::* 4loadTestedCommands 5 6proc skip args {} 7proc ok {} { return } 8 9variable widgetClasses { 10 button checkbutton radiobutton menubutton label entry 11 frame labelframe scrollbar 12 notebook progressbar combobox separator 13 panedwindow treeview sizegrip 14 scale 15} 16 17proc bgerror {error} { 18 variable bgerror $error 19 variable bgerrorInfo $::errorInfo 20 variable bgerrorCode $::errorCode 21} 22 23# Self-destruct tests. 24# Do these early, so any memory corruption has a longer time to cause a crash. 25# 26proc selfdestruct {w args} { 27 destroy $w 28} 29test ttk-6.1 "Self-destructing checkbutton" -body { 30 pack [ttk::checkbutton .sd -text "Self-destruction" -variable ::sd] 31 trace variable sd w [list selfdestruct .sd] 32 update 33 .sd invoke 34} -returnCodes 1 35test ttk-6.2 "Checkbutton self-destructed" -body { 36 winfo exists .sd 37} -result 0 38 39# test ttk-6.3 not applicable [see #2175411] 40 41test ttk-6.4 "Destroy widget in configure" -setup { 42 set OUCH ouch 43 trace variable OUCH r { kill.b } 44 proc kill.b {args} { destroy .b } 45} -cleanup { 46 unset OUCH 47} -body { 48 pack [ttk::checkbutton .b] 49 set rc [catch { .b configure -variable OUCH } msg] 50 list $rc $msg [winfo exists .b] [info commands .b] 51} -result [list 1 "Widget has been destroyed" 0 {}] 52 53test ttk-6.5 "Clean up -textvariable traces" -body { 54 foreach class {ttk::button ttk::checkbutton ttk::radiobutton} { 55 $class .b1 -textvariable V 56 set V "asdf" 57 destroy .b1 58 set V "" 59 } 60} 61 62test ttk-6.6 "Bad color spec in styles" -body { 63 pack [ttk::button .b1 -text Hi!] 64 ttk::style configure TButton -foreground badColor 65 event generate .b1 <Expose> 66 update 67 ttk::style configure TButton -foreground black 68 destroy .b1 69 set ::bgerror 70} -result {unknown color name "badColor"} 71 72test ttk-6.7 "Basic destruction test" -body { 73 foreach widget $widgetClasses { 74 ttk::$widget .w 75 pack .w 76 destroy .w 77 } 78} 79 80test ttk-6.8 "Button command removes itself" -body { 81 ttk::button .b -command ".b configure -command {}; set ::A {it worked}" 82 .b invoke 83 destroy .b 84 set ::A 85} -result {it worked} 86 87test ttk-6.9 "Bad font spec in styles" -setup { 88 ttk::style theme create badfont -settings { 89 ttk::style configure . -font {Helvetica 12 Bogus} 90 } 91 ttk::style theme use badfont 92} -cleanup { 93 ttk::style theme use default 94} -body { 95 pack [ttk::label .l -text Hi! -font {}] 96 event generate .l <Expose> 97 update 98 destroy .l 99 set ::bgerror 100} -result {unknown font style "Bogus"} 101 102test ttk-construction-failure-1 "Excercise construction failure path" -setup { 103 option add *TLabel.cursor badCursor 1 104} -cleanup { 105 option add *TLabel.cursor {} 1 106} -body { 107 catch {ttk::label .l} errmsg 108 list $errmsg [info commands .l] [winfo exists .l] 109} -result [list {bad cursor spec "badCursor"} {} 0] 110 111test ttk-construction-failure-2 "Destroy widget in constructor" -setup { 112 set OUCH ouch 113 trace variable OUCH r { kill.b } 114 proc kill.b {args} { destroy .b } 115} -cleanup { 116 unset OUCH 117} -body { 118 list \ 119 [catch { ttk::checkbutton .b -variable OUCH } msg] \ 120 $msg \ 121 [winfo exists .b] \ 122 [info commands .b] \ 123 ; 124} -result [list 1 "Widget has been destroyed" 0 {}] 125 126test ttk-selfdestruct-ok-1 "Intentional self-destruction" -body { 127 # see #2298720 128 toplevel .t 129 ttk::button .t.b -command [list destroy .t] 130 .t.b invoke 131 list [winfo exists .t] [winfo exists .t.b] 132} -result [list 0 0] 133 134# 135# Basic tests. 136# 137test ttk-1.1 "Create button" -body { 138 pack [ttk::button .t] -expand true -fill both 139 update 140} 141 142test ttk-1.2 "Check style" -body { 143 .t cget -style 144} -result {} 145 146test ttk-1.3 "Set bad style" -body { 147 .t configure -style "nosuchstyle" 148} -returnCodes 1 -result {Layout nosuchstyle not found} 149 150test ttk-1.4 "Original style preserved" -body { 151 .t cget -style 152} -result "" 153 154proc checkstate {w} { 155 foreach statespec { 156 {!active !disabled} 157 {!active disabled} 158 {active !disabled} 159 {active disabled} 160 active 161 disabled 162 } { 163 lappend result [$w instate $statespec] 164 } 165 set result 166} 167 168# NB: this will fail if the top-level window pops up underneath the cursor 169test ttk-2.0 "Check state" -body { 170 checkstate .t 171} -result [list 1 0 0 0 0 0] 172 173test ttk-2.1 "Change state" -body { 174 .t state active 175} -result !active 176 177test ttk-2.2 "Check state again" -body { 178 checkstate .t 179} -result [list 0 0 1 0 1 0] 180 181test ttk-2.3 "Change state again" -body { 182 .t state {!active disabled} 183} -result {active !disabled} 184 185test ttk-2.4 "Check state again" -body { 186 checkstate .t 187} -result [list 0 1 0 0 0 1] 188 189test ttk-2.5 "Change state again" -body { 190 .t state !disabled 191} -result {disabled} 192 193test ttk-2.6 "instate scripts, false" -body { 194 set x 0 195 .t instate disabled { set x 1 } 196 set x 197} -result 0 198 199test ttk-2.7 "instate scripts, true" -body { 200 set x 0 201 .t instate !disabled { set x 1 } 202 set x 203} -result 1 204 205test ttk-2.8 "bug 3223850: button state disabled during click" -setup { 206 destroy .b 207 set ttk28 {} 208 pack [ttk::button .b -command {set ::ttk28 failed}] 209} -body { 210 bind .b <ButtonPress-1> {after 0 {.b configure -state disabled}} 211 after 1 {event generate .b <ButtonPress-1>} 212 after 20 {event generate .b <ButtonRelease-1>} 213 set aid [after 100 {set ::ttk28 [.b instate {disabled !pressed}]}] 214 vwait ::ttk28 215 after cancel $aid 216 set ttk28 217} -cleanup { 218 destroy .b 219 unset -nocomplain ttk28 aid 220} -result 1 221 222foreach wc $widgetClasses { 223 test ttk-coreoptions-$wc "$wc has all core options" -body { 224 ttk::$wc .w 225 foreach option { 226 -class 227 -style 228 -cursor 229 -takefocus 230 } { 231 .w cget $option 232 } 233 destroy .w 234 } 235} 236 237# misc. error detection 238test ttk-3.0 "Bad option" -body { 239 ttk::button .bad -badoption foo 240} -returnCodes 1 -result {unknown option "-badoption"} -match glob 241 242test ttk-3.1 "Make sure widget command not created" -body { 243 .bad state disabled 244} -returnCodes 1 -result {invalid command name ".bad"} -match glob 245 246test ttk-3.2 "Propagate errors from variable traces" -body { 247 set A 0 248 trace add variable A write {error "failure" ;# } 249 ttk::checkbutton .cb -variable A 250 .cb invoke 251} -cleanup { 252 unset ::A ; destroy .cb 253} -returnCodes error -result {can't set "A": failure} 254 255test ttk-3.3 "Constructor failure with cursor" -body { 256 ttk::button .b -cursor bottom_right_corner -style BadStyle 257} -returnCodes 1 -result "Layout BadStyle not found" 258 259test ttk-3.4 "SF#2009213" -body { 260 ttk::style configure TScale -sliderrelief {} 261 pack [ttk::scale .s] 262 update 263} -cleanup { 264 ttk::style configure TScale -sliderrelief raised 265 destroy .s 266} 267 268# Test resource allocation 269# (@@@ "-font" is a compatibility option now, so tests 4.1-4.3 270# don't really test anything useful at the moment.) 271# 272 273test ttk-4.0 "Setup" -body { 274 catch { destroy .t } 275 pack [ttk::label .t -text "Button 1"] 276 testConstraint fontOption [expr ![catch { set prevFont [.t cget -font] }]] 277 ok 278} 279 280test ttk-4.1 "Change font" -constraints fontOption -body { 281 .t configure -font "Helvetica 18 bold" 282} 283test ttk-4.2 "Check font" -constraints fontOption -body { 284 .t cget -font 285} -result "Helvetica 18 bold" 286 287test ttk-4.3 "Restore font" -constraints fontOption -body { 288 .t configure -font $prevFont 289} 290 291test ttk-4.4 "Bad resource specifications" -body { 292 ttk::style theme settings alt { 293 ttk::style configure TButton -font {Bad font} 294 # @@@ it would be best to raise an error at this point, 295 # @@@ but that's not really feasible in the current framework. 296 } 297 pack [ttk::button .tb1 -text "Ouch"] 298 ttk::style theme use alt 299 update; 300 # As long as we haven't crashed, everything's OK 301 ttk::style theme settings alt { 302 ttk::style configure TButton -font TkDefaultFont 303 } 304 ttk::style theme use default 305 destroy .tb1 306} 307 308# 309# -compound tests: 310# 311variable iconData \ 312{R0lGODlhIAAgAKIAANnZ2YQAAP8AAISEhP///////////////yH5BAEAAAAALAAAAAAgACAA 313AAP/CLoMGLqKoMvtGIqiqxEYCLrcioGiyxwIusyBgaLLLRiBoMsQKLrcjYGgu4Giy+2CAkFX 314A0WX2wXFIOgGii7trkCEohsDCACBoktEKLpKhISiGwAIECiqSKooukiqKKoxgACBooukKiIo 315SKooujGDECi6iqQqsopEV2MQAkV3kXQZRXdjEAJFl5F0FUWXY3ACRZcFSRdFlyVwJlB0WZB0 316UXRZAmcCRZeRdBVFl2NwAkV3kXQZRXdjcAJFV5FURVaR6GoMDgSKLpKqiKAgqaLoxgwOBIoq 317kiqKLpIqimrM4ECg6BIRiq4SIaHoxgyCBoou7a5AhKIbMzgAAIGiy+2CTWJmBhAAAkWX2wXF 318zCDoBooud2PMDIKuRqDocgtGzMwg6O4Eii5z4Kgi6DIMhqLoagQGjiqCLvPgYOgqji6CLrfi 3196DIj6HI7jq4i6DIkADs=} 320 321variable compoundStrings {text image center top bottom left right none} 322 323if {0} { 324 proc now {} { set ::now [clock clicks -milliseconds] } 325 proc tick {} { puts -nonewline stderr "+" ; flush stderr } 326 proc tock {} { 327 set then $::now; set ::now [clock clicks -milliseconds] 328 puts stderr " [expr {$::now - $then}] ms" 329 } 330} else { 331 proc now {} {} ; proc tick {} {} ; proc tock {} {} 332} 333 334now ; tick 335test ttk-8.0 "Setup for 8.X" -body { 336 ttk::button .ctb 337 image create photo icon -data $::iconData; 338 pack .ctb 339} 340tock 341 342now 343test ttk-8.1 "Test -compound options" -body { 344 # Exhaustively test each combination. 345 # Main goal is to make sure no code paths crash. 346 foreach image {icon ""} { 347 foreach text {"Hi!" ""} { 348 foreach compound $::compoundStrings { 349 .ctb configure -image $image -text $text -compound $compound 350 update; tick 351 } 352 } 353 } 354} 355tock 356 357test ttk-8.2 "Test -compound options with regular button" -body { 358 button .rtb 359 pack .rtb 360 361 foreach image {"" icon} { 362 foreach text {"Hi!" ""} { 363 foreach compound [lrange $::compoundStrings 2 end] { 364 .rtb configure -image $image -text $text -compound $compound 365 update; tick 366 } 367 } 368 } 369} 370tock 371 372test ttk-8.3 "Rerun test 8.1" -body { 373 foreach image {icon ""} { 374 foreach text {"Hi!" ""} { 375 foreach compound $::compoundStrings { 376 .ctb configure -image $image -text $text -compound $compound 377 update; tick 378 } 379 } 380 } 381} 382tock 383 384test ttk-8.4 "ImageChanged" -body { 385 ttk::button .b -image icon 386 icon blank 387} -cleanup { destroy .b } 388 389#------------------------------------------------------------------------ 390 391test ttk-9.1 "Traces on nonexistant namespaces" -body { 392 ttk::checkbutton .tcb -variable foo::bar 393} -returnCodes 1 -result "*parent namespace doesn't exist*" -match glob 394 395test ttk-9.2 "Traces on nonexistant namespaces II" -body { 396 ttk::checkbutton .tcb -variable X 397 .tcb configure -variable foo::bar 398} -returnCodes 1 -result "*parent namespace doesn't exist*" -match glob 399 400test ttk-9.3 "Restore saved options on configure error" -body { 401 .tcb cget -variable 402} -result X 403 404test ttk-9.4 "Textvariable tests" -body { 405 set tcbLabel "Testing..." 406 .tcb configure -textvariable tcbLabel 407 .tcb cget -text 408} -result "Testing..." 409 410# Changing -text has no effect if there is a linked -textvariable. 411# Compatible with core widget. 412test ttk-9.5 "Change -text" -body { 413 .tcb configure -text "Changed -text" 414 .tcb cget -text 415} -result "Testing..." 416 417# Unset -textvariable clears the text. 418# NOTE: this is different from core widgets, which automagically reinitalize 419# the -textvariable to the last value of -text. 420# 421test ttk-9.6 "Unset -textvariable" -body { 422 unset tcbLabel 423 list [info exists tcbLabel] [.tcb cget -text] 424} -result [list 0 ""] 425 426test ttk-9.7 "Unset textvariable, comparison" -body { 427# 428# NB: ttk::label behaves differently from the standard label here; 429# NB: this is on purpose: I believe the standard behaviour is the Wrong Thing 430# 431 unset -nocomplain V1 V2 432 label .l -text Foo ; ttk::label .tl -text Foo 433 434 .l configure -textvariable V1 ; .tl configure -textvariable V2 435 list [set V1] [info exists V2] 436} -cleanup { destroy .l .tl } -result [list Foo 0] 437 438test ttk-9.8 "-textvariable overrides -text" -body { 439 ttk::label .tl -textvariable TV 440 set TV Foo 441 .tl configure -text Bar 442 .tl cget -text 443} -cleanup { destroy .tl } -result "Foo" 444 445# 446# Frame widget tests: 447# 448 449test ttk-10.1 "ttk::frame -class resource" -body { 450 ttk::frame .f -class Foo 451} -result .f 452 453test ttk-10.2 "Check widget class" -body { 454 winfo class .f 455} -result Foo 456 457test ttk-10.3 "Check class resource" -body { 458 .f cget -class 459} -result Foo 460 461test ttk-10.4 "Try to modify class resource" -body { 462 .f configure -class Bar 463} -returnCodes 1 -match glob -result "*read-only option*" 464 465test ttk-10.5 "Check class resource again" -body { 466 .f cget -class 467} -result Foo 468 469test ttk-11.1 "-state test, setup" -body { 470 ttk::button .b 471 .b instate disabled 472} -result 0 473 474test ttk-11.2 "-state test, disable" -body { 475 .b configure -state disabled 476 .b instate disabled 477} -result 1 478 479test ttk-11.3 "-state test, reenable" -body { 480 .b configure -state normal 481 .b instate disabled 482} -result 0 483 484test ttk-11.4 "-state test, unrecognized -state value" -body { 485 .b configure -state bogus 486 .b state 487} -result [list] 488 489test ttk-11.5 "-state test, 'active'" -body { 490 .b configure -state active 491 .b state 492} -result [list active] -cleanup { .b state !active } 493 494test ttk-11.6 "-state test, 'readonly'" -body { 495 .b configure -state readonly 496 .b state 497} -result [list readonly] -cleanup { .b state !readonly } 498 499test ttk-11.7 "-state test, cleanup" -body { 500 destroy .b 501} 502 503test ttk-12.1 "-cursor option" -body { 504 ttk::button .b 505 .b cget -cursor 506} -result {} 507 508test ttk-12.2 "-cursor option" -body { 509 .b configure -cursor arrow 510 .b cget -cursor 511} -result arrow 512 513test ttk-12.3 "-borderwidth frame option" -body { 514 destroy .t 515 toplevel .t 516 raise .t 517 pack [set t [ttk::frame .t.f]] -expand true -fill x ; 518 pack [ttk::label $t.l -text "ASDF QWERTY"] -expand true -fill both 519 foreach theme {default alt} { 520 ttk::style theme use $theme 521 foreach relief {flat raised sunken ridge groove solid} { 522 $t configure -relief $relief 523 for {set i 5} {$i >= 0} {incr i -1} { 524 $t configure -borderwidth $i 525 update 526 } 527 } 528 } 529} 530 531test ttk-12.4 "-borderwidth frame option" -body { 532 .t.f configure -relief raised 533 .t.f configure -borderwidth 1 534 ttk::style theme use alt 535 update 536} 537 538test ttk-13.1 "Custom styles -- bad -style option" -body { 539 ttk::button .tb1 -style badstyle 540} -returnCodes 1 -result "*badstyle not found*" -match glob 541 542test ttk-13.4 "Custom styles -- bad -style option" -body { 543 ttk::button .tb1 544 .tb1 configure -style badstyle 545} -cleanup { 546 destroy .tb1 547} -returnCodes 1 -result "*badstyle not found*" -match glob 548 549test ttk-13.5 "Custom layouts -- missing element definition" -body { 550 ttk::style layout badstyle { 551 NoSuchElement 552 } 553 ttk::button .tb1 -style badstyle 554} -cleanup { 555 destroy .tb1 556} -result .tb1 557# @@@ Should: signal an error, possibly a background error. 558 559# 560# See #793909 561# 562 563test ttk-14.1 "-variable in nonexistant namespace" -body { 564 ttk::checkbutton .tw -variable ::nsn::foo 565} -returnCodes 1 -result {can't trace *: parent namespace doesn't exist} \ 566 -match glob -cleanup { destroy .tw } 567 568test ttk-14.2 "-textvariable in nonexistant namespace" -body { 569 ttk::label .tw -textvariable ::nsn::foo 570} -returnCodes 1 -result {can't trace *: parent namespace doesn't exist} \ 571 -match glob -cleanup { destroy .tw } 572 573test ttk-14.3 "-textvariable in nonexistant namespace" -body { 574 ttk::entry .tw -textvariable ::nsn::foo 575} -returnCodes 1 -result {can't trace *: parent namespace doesn't exist} \ 576 -match glob -cleanup { destroy .tw } 577 578test ttk-15.1 {Bug 3062331} -setup { 579 destroy .b 580} -body { 581 set Y {} 582 ttk::button .b -textvariable Y 583 trace variable Y u "destroy .b; #" 584 unset Y 585} -cleanup { 586 destroy .b 587} -result {} 588 589test ttk-15.2 {Bug 3341056} -setup { 590 proc foo {} { 591 destroy .lf 592 ttk::labelframe .lf 593 ttk::checkbutton .lf.cb -text xxx 594 } 595} -body { 596 ttk::button .b -text xxx -command foo 597 .b invoke 598 .b invoke 599 .lf.cb invoke 600 destroy .b 601} -cleanup { 602 rename foo {} 603 destroy .lf 604} -result {} 605 606## Test ensemble processing: 607# 608# (See also: SF#2021443) 609# 610proc wrong#args {args} { 611 return "wrong # args: should be \"$args\"" 612} 613proc wrong#varargs {varpart args} { 614 set usage $args 615 append usage " ?$varpart ...?" 616 return "wrong # args: should be \"$usage\"" 617} 618 619test ttk-ensemble-0 "style element create: insufficient args" -body { 620 ttk::style 621} -returnCodes 1 -result \ 622 [wrong#varargs arg ttk::style option] 623 624test ttk-ensemble-1 "style element create: insufficient args" -body { 625 ttk::style element 626} -returnCodes 1 -result \ 627 [wrong#varargs arg ttk::style element option] 628 629test ttk-ensemble-2 "style element create: insufficient args" -body { 630 ttk::style element create 631} -returnCodes 1 -result \ 632 [wrong#varargs {-option value} ttk::style element create name type] 633 634test ttk-ensemble-3 "style element create: insufficient args" -body { 635 ttk::style element create plain.background 636} -returnCodes 1 -result \ 637 [wrong#varargs {-option value} ttk::style element create name type] 638 639test ttk-ensemble-4 "style element create: insufficient args" -body { 640 ttk::style element create plain.background from 641} -returnCodes 1 -result [wrong#args theme ?element?] 642 643test ttk-ensemble-5 "style element create: valid" -body { 644 ttk::style element create plain.background from default 645} -returnCodes 0 -result "" 646 647eval destroy [winfo children .] 648 649tcltest::cleanupTests 650 651#*EOF* 652