1# This file is a Tcl script to test labels, buttons, checkbuttons, and 2# radiobuttons in Tk (i.e., all the widgets defined in tkButton.c). It is 3# organized in the standard fashion for Tcl tests. 4# 5# Copyright (c) 1994 The Regents of the University of California. 6# Copyright (c) 1994-1996 Sun Microsystems, Inc. 7# Copyright (c) 1998-1999 by Scriptics Corporation. 8# All rights reserved. 9# 10# RCS: @(#) $Id: button.test,v 1.13 2002/09/02 23:32:35 hobbs Exp $ 11 12package require tcltest 2.1 13namespace import -force tcltest::configure 14namespace import -force tcltest::testsDirectory 15configure -testdir [file join [pwd] [file dirname [info script]]] 16configure -loadfile [file join [testsDirectory] constraints.tcl] 17tcltest::loadTestedCommands 18 19proc bogusTrace args { 20 error "trace aborted" 21} 22catch {unset value} 23catch {unset value2} 24 25# Create entries in the option database to be sure that geometry options 26# like border width have predictable values. 27 28option add *Button.borderWidth 2 29option add *Button.highlightThickness 2 30option add *Button.font {Helvetica -12 bold} 31 32eval image delete [image names] 33if {[testConstraint testImageType]} { 34 image create test image1 35} 36label .l -text Label 37button .b -text Button 38checkbutton .c -text Checkbutton 39radiobutton .r -text Radiobutton 40pack .l .b .c .r 41update 42set i 1 43foreach test { 44 {-activebackground #012345 #012345 non-existent 45 {unknown color name "non-existent"} {1 1 1 1}} 46 {-activeforeground #ff0000 #ff0000 non-existent 47 {unknown color name "non-existent"} {1 1 1 1}} 48 {-anchor nw nw bogus {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center} {1 1 1 1}} 49 {-background #ff0000 #ff0000 non-existent 50 {unknown color name "non-existent"} {1 1 1 1}} 51 {-bd 4 4 badValue {bad screen distance "badValue"} {1 1 1 1}} 52 {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"} 53 {1 1 1 1}} 54 {-bitmap questhead questhead badValue {bitmap "badValue" not defined} 55 {1 1 1 1}} 56 {-borderwidth 1.3 1.3 badValue {bad screen distance "badValue"} {1 1 1 1}} 57 {-command "set x" {set x} {} {} {0 1 1 1}} 58 {-compound left left bogus {bad compound "bogus": must be bottom, center, left, none, right, or top} {1 1 1 1}} 59 {-cursor arrow arrow badValue {bad cursor spec "badValue"} {1 1 1 1}} 60 {-default active active huh? 61 {bad default "huh?": must be active, disabled, or normal} 62 {0 1 0 0}} 63 {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"} 64 {1 1 1 1}} 65 {-fg #110022 #110022 bogus {unknown color name "bogus"} {1 1 1 1}} 66 {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist} {1 1 1 1}} 67 {-foreground #110022 #110022 bogus {unknown color name "bogus"} {1 1 1 1}} 68 {-height 18 18 20.0 {expected integer but got "20.0"} {1 1 1 1}} 69 {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"} 70 {1 1 1 1}} 71 {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"} 72 {1 1 1 1}} 73 {-highlightthickness 6m 6m badValue {bad screen distance "badValue"} 74 {1 1 1 1}} 75 {-image image1 image1 bogus {image "bogus" doesn't exist} {1 1 1 1}} 76 {-indicatoron yes 1 no_way {expected boolean value but got "no_way"} 77 {0 0 1 1}} 78 {-justify right right bogus {bad justification "bogus": must be left, right, or center} {1 1 1 1}} 79 {-offrelief flat flat 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} {0 0 1 1}} 80 {-offvalue lousy lousy {} {} {0 0 1 0}} 81 {-offvalue fantastic fantastic {} {} {0 0 1 0}} 82 {-overrelief "" "" 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} {0 1 1 1}} 83 {-padx 12m 12m 420x {bad screen distance "420x"} {1 1 1 1}} 84 {-pady 12m 12m 420x {bad screen distance "420x"} {1 1 1 1}} 85 {-repeatdelay 100 100 foo {expected integer but got "foo"} {0 1 0 0}} 86 {-repeatinterval 100 100 foo {expected integer but got "foo"} {0 1 0 0}} 87 {-relief flat flat 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} {1 1 1 1}} 88 {-selectcolor #110022 #110022 bogus {unknown color name "bogus"} {0 0 1 1}} 89 {-selectimage image1 image1 bogus {image "bogus" doesn't exist} {0 0 1 1}} 90 {-state normal normal bogus {bad state "bogus": must be active, disabled, or normal} {1 1 1 1}} 91 {-takefocus "any string" "any string" {} {} {1 1 1 1}} 92 {-text "Sample text" {Sample text} {} {} {1 1 1 1}} 93 {-textvariable i i {} {} {1 1 1 1}} 94 {-underline 5 5 3p {expected integer but got "3p"} {1 1 1 1}} 95 {-value anyString anyString {} {} {0 0 0 1}} 96 {-width 402 402 3p {expected integer but got "3p"} {1 1 1 1}} 97 {-wraplength 100 100 6x {bad screen distance "6x"} {1 1 1 1}} 98} { 99 set name [lindex $test 0] 100 set classes [lindex $test 5] 101 foreach w {.l .b .c .r} hasOption [lindex $test 5] { 102 if $hasOption { 103 test button-1.$i {configuration options} testImageType { 104 $w configure $name [lindex $test 1] 105 lindex [$w configure $name] 4 106 } [lindex $test 2] 107 incr i 108 if {[lindex $test 3] != ""} { 109 test button-1.$i {configuration options} testImageType { 110 list [catch {$w configure $name [lindex $test 3]} msg] $msg 111 } [list 1 [lindex $test 4]] 112 } 113 $w configure $name [lindex [$w configure $name] 3] 114 } else { 115 test button-1.$i {configuration options} testImageType { 116 list [catch {$w configure $name [lindex $test 1]} msg] $msg 117 } "1 {unknown option \"$name\"}" 118 } 119 } 120 incr i 121} 122test button-1.$i {configuration options} { 123 .c configure -selectcolor {} 124} {} 125 126test button-3.1 {ButtonCreate - not enough cd ../unix 127} { 128 list [catch {button} msg] $msg 129} {1 {wrong # args: should be "button pathName ?options?"}} 130test button-3.2 {ButtonCreate procedure - setting label class} { 131 catch {destroy .x} 132 label .x 133 winfo class .x 134} {Label} 135test button-3.3 {ButtonCreate - setting button class} { 136 catch {destroy .x} 137 button .x 138 winfo class .x 139} {Button} 140test button-3.4 {ButtonCreate - setting checkbutton class} { 141 catch {destroy .x} 142 checkbutton .x 143 winfo class .x 144} {Checkbutton} 145test button-3.5 {ButtonCreate - setting radiobutton class} { 146 catch {destroy .x} 147 radiobutton .x 148 winfo class .x 149} {Radiobutton} 150rename button gorp 151test button-3.6 {ButtonCreate - setting class} { 152 catch {destroy .x} 153 gorp .x 154 winfo class .x 155} {Button} 156rename gorp button 157test button-3.7 {ButtonCreate - bad window name} { 158 list [catch {button foo} msg] $msg 159} {1 {bad window path name "foo"}} 160test button-3.8 {ButtonCreate procedure - error in default option value} { 161 catch {destroy .funny} 162 option add *funny.background bogus 163 list [catch {button .funny} msg] $msg $errorInfo 164} {1 {unknown color name "bogus"} {unknown color name "bogus" 165 (database entry for "-background" in widget ".funny") 166 invoked from within 167"button .funny"}} 168test button-3.9 {ButtonCreate procedure - option error} { 169 catch {destroy .x} 170 list [catch {button .x -gorp foo} msg] $msg [winfo exists .x] 171} {1 {unknown option "-gorp"} 0} 172test button-3.10 {ButtonCreate procedure - return value} { 173 catch {destroy .abcd} 174 set x [button .abcd] 175 destroy .abc 176 set x 177} {.abcd} 178 179test button-4.1 {ButtonWidgetCmd - too few arguments} { 180 list [catch {.b} msg] $msg 181} {1 {wrong # args: should be ".b option ?arg arg ...?"}} 182test button-4.2 {ButtonWidgetCmd - bad option name} { 183 list [catch {.b c} msg] $msg 184} {1 {ambiguous option "c": must be cget, configure, flash, or invoke}} 185test button-4.3 {ButtonWidgetCmd - bad option name} { 186 list [catch {.b bogus} msg] $msg 187} {1 {bad option "bogus": must be cget, configure, flash, or invoke}} 188test button-4.4 {ButtonWidgetCmd procedure, "cget" option} { 189 list [catch {.b cget a b} msg] $msg 190} {1 {wrong # args: should be ".b cget option"}} 191test button-4.5 {ButtonWidgetCmd procedure, "cget" option} { 192 list [catch {.b cget -gorp} msg] $msg 193} {1 {unknown option "-gorp"}} 194test button-4.6 {ButtonWidgetCmd procedure, "cget" option} { 195 .b configure -highlightthickness 3 196 .b cget -highlightthickness 197} {3} 198test button-4.7 {ButtonWidgetCmd procedure, "cget" option} { 199 catch {.l cget -disabledforeground} 200} {0} 201test button-4.8 {ButtonWidgetCmd procedure, "cget" option} { 202 catch {.b cget -disabledforeground} 203} {0} 204test button-4.9 {ButtonWidgetCmd procedure, "cget" option} { 205 list [catch {.b cget -variable} msg] $msg 206} {1 {unknown option "-variable"}} 207test button-4.10 {ButtonWidgetCmd procedure, "cget" option} { 208 catch {.c cget -variable} 209} {0} 210test button-4.11 {ButtonWidgetCmd procedure, "cget" option} { 211 list [catch {.c cget -value} msg] $msg 212} {1 {unknown option "-value"}} 213test button-4.12 {ButtonWidgetCmd procedure, "cget" option} { 214 catch {.r cget -value} 215} {0} 216test button-4.13 {ButtonWidgetCmd procedure, "cget" option} { 217 list [catch {.r cget -onvalue} msg] $msg 218} {1 {unknown option "-onvalue"}} 219test button-4.14 {ButtonWidgetCmd procedure, "configure" option} { 220 llength [.c configure] 221} {39} 222test button-4.15 {ButtonWidgetCmd procedure, "configure" option} { 223 list [catch {.b configure -gorp} msg] $msg 224} {1 {unknown option "-gorp"}} 225test button-4.16 {ButtonWidgetCmd procedure, "configure" option} { 226 list [catch {.b co -bg #ffffff -fg} msg] $msg 227} {1 {value for "-fg" missing}} 228test button-4.17 {ButtonWidgetCmd procedure, "configure" option} { 229 .b configure -fg #123456 230 .b configure -bg #654321 231 lindex [.b configure -fg] 4 232} {#123456} 233.c configure -variable value -onvalue 1 -offvalue 0 234.r configure -variable value2 -value red 235test button-4.18 {ButtonWidgetCmd procedure, "deselect" option} { 236 list [catch {.c deselect foo} msg] $msg 237} {1 {wrong # args: should be ".c deselect"}} 238test button-4.19 {ButtonWidgetCmd procedure, "deselect" option} { 239 list [catch {.l deselect} msg] $msg 240} {1 {bad option "deselect": must be cget or configure}} 241test button-4.20 {ButtonWidgetCmd procedure, "deselect" option} { 242 list [catch {.b deselect} msg] $msg 243} {1 {bad option "deselect": must be cget, configure, flash, or invoke}} 244test button-4.21 {ButtonWidgetCmd procedure, "deselect" option} { 245 set value 1 246 .c d 247 set value 248} {0} 249test button-4.22 {ButtonWidgetCmd procedure, "deselect" option} { 250 set value2 green 251 .r deselect 252 set value2 253} {green} 254test button-4.23 {ButtonWidgetCmd procedure, "deselect" option} { 255 set value2 red 256 .r deselect 257 set value2 258} {} 259test button-4.24 {ButtonWidgetCmd procedure, "deselect" option} { 260 set value 1 261 trace variable value w bogusTrace 262 set result [list [catch {.c deselect} msg] $msg $errorInfo $value] 263 trace vdelete value w bogusTrace 264 set result 265} {1 {can't set "value": trace aborted} {can't set "value": trace aborted 266 while executing 267".c deselect"} 0} 268test button-4.25 {ButtonWidgetCmd procedure, "deselect" option} { 269 set value2 red 270 trace variable value2 w bogusTrace 271 set result [list [catch {.r deselect} msg] $msg $errorInfo $value2] 272 trace vdelete value2 w bogusTrace 273 set result 274} {1 {can't set "value2": trace aborted} {can't set "value2": trace aborted 275 while executing 276".r deselect"} {}} 277test button-4.26 {ButtonWidgetCmd procedure, "flash" option} { 278 list [catch {.b flash foo} msg] $msg 279} {1 {wrong # args: should be ".b flash"}} 280test button-4.27 {ButtonWidgetCmd procedure, "flash" option} { 281 list [catch {.l flash} msg] $msg 282} {1 {bad option "flash": must be cget or configure}} 283test button-4.28 {ButtonWidgetCmd procedure, "flash" option} { 284 list [catch {.b flash} msg] $msg 285} {0 {}} 286test button-4.29 {ButtonWidgetCmd procedure, "flash" option} { 287 list [catch {.c flash} msg] $msg 288} {0 {}} 289test button-4.30 {ButtonWidgetCmd procedure, "flash" option} { 290 list [catch {.r f} msg] $msg 291} {0 {}} 292test button-4.31 {ButtonWidgetCmd procedure, "invoke" option} { 293 list [catch {.b invoke foo} msg] $msg 294} {1 {wrong # args: should be ".b invoke"}} 295test button-4.32 {ButtonWidgetCmd procedure, "invoke" option} { 296 list [catch {.l invoke} msg] $msg 297} {1 {bad option "invoke": must be cget or configure}} 298test button-4.33 {ButtonWidgetCmd procedure, "invoke" option} { 299 .b configure -command {set x invoked} 300 set x "not invoked" 301 .b invoke 302 set x 303} {invoked} 304test button-4.34 {ButtonWidgetCmd procedure, "invoke" option} { 305 .b configure -command {set x invoked} -state disabled 306 set x "not invoked" 307 .b invoke 308 set x 309} {not invoked} 310test button-4.35 {ButtonWidgetCmd procedure, "invoke" option} { 311 set value bogus 312 .c configure -command {set x invoked} -variable value -onvalue 1 \ 313 -offvalue 0 314 set x "not invoked" 315 .c invoke 316 list $x $value 317} {invoked 1} 318test button-4.36 {ButtonWidgetCmd procedure, "invoke" option} { 319 set value2 green 320 .r configure -command {set x invoked} -variable value2 -value red 321 set x "not invoked" 322 .r i 323 list $x $value2 324} {invoked red} 325test button-4.37 {ButtonWidgetCmd procedure, "select" option} { 326 list [catch {.l select} msg] $msg 327} {1 {bad option "select": must be cget or configure}} 328test button-4.38 {ButtonWidgetCmd procedure, "select" option} { 329 list [catch {.b select} msg] $msg 330} {1 {bad option "select": must be cget, configure, flash, or invoke}} 331test button-4.39 {ButtonWidgetCmd procedure, "select" option} { 332 list [catch {.c select foo} msg] $msg 333} {1 {wrong # args: should be ".c select"}} 334test button-4.40 {ButtonWidgetCmd procedure, "select" option} { 335 set value bogus 336 .c configure -command {} -variable value -onvalue lovely -offvalue 0 337 .c s 338 set value 339} {lovely} 340test button-4.41 {ButtonWidgetCmd procedure, "select" option} { 341 set value2 green 342 .r configure -command {} -variable value2 -value red 343 .r select 344 set value2 345} {red} 346test button-4.42 {ButtonWidgetCmd procedure, "select" option} { 347 set value2 yellow 348 trace variable value2 w bogusTrace 349 set result [list [catch {.r select} msg] $msg $errorInfo $value2] 350 trace vdelete value2 w bogusTrace 351 set result 352} {1 {can't set "value2": trace aborted} {can't set "value2": trace aborted 353 while executing 354".r select"} red} 355test button-4.43 {ButtonWidgetCmd procedure, "toggle" option} { 356 list [catch {.l toggle} msg] $msg 357} {1 {bad option "toggle": must be cget or configure}} 358test button-4.44 {ButtonWidgetCmd procedure, "toggle" option} { 359 list [catch {.b toggle} msg] $msg 360} {1 {bad option "toggle": must be cget, configure, flash, or invoke}} 361test button-4.45 {ButtonWidgetCmd procedure, "toggle" option} { 362 list [catch {.r toggle} msg] $msg 363} {1 {bad option "toggle": must be cget, configure, deselect, flash, invoke, or select}} 364test button-4.46 {ButtonWidgetCmd procedure, "toggle" option} { 365 list [catch {.c toggle foo} msg] $msg 366} {1 {wrong # args: should be ".c toggle"}} 367test button-4.47 {ButtonWidgetCmd procedure, "toggle" option} { 368 set value bogus 369 .c configure -command {} -variable value -onvalue sunshine -offvalue rain 370 .c toggle 371 set result $value 372 .c toggle 373 lappend result $value 374 .c toggle 375 lappend result $value 376} {sunshine rain sunshine} 377test button-4.48 {ButtonWidgetCmd procedure, "toggle" option} { 378 .c configure -onvalue xyz -offvalue abc 379 set value xyz 380 trace variable value w bogusTrace 381 set result [list [catch {.c toggle} msg] $msg $errorInfo $value] 382 trace vdelete value w bogusTrace 383 set result 384} {1 {can't set "value": trace aborted} {can't set "value": trace aborted 385 while executing 386".c toggle"} abc} 387test button-4.49 {ButtonWidgetCmd procedure, "toggle" option} { 388 .c configure -onvalue xyz -offvalue abc 389 set value abc 390 trace variable value w bogusTrace 391 set result [list [catch {.c toggle} msg] $msg $errorInfo $value] 392 trace vdelete value w bogusTrace 393 set result 394} {1 {can't set "value": trace aborted} {can't set "value": trace aborted 395 while executing 396".c toggle"} xyz} 397test button-4.50 {ButtonWidgetCmd procedure, "toggle" option} { 398 catch {unset value}; set value(1) 1; 399 set result [list [catch {.c toggle} msg] $msg $errorInfo] 400 unset value; 401 set result 402} {1 {can't set "value": variable is array} {can't set "value": variable is array 403 while executing 404".c toggle"}} 405 406test button-5.1 {DestroyButton procedure} testImageType { 407 image create test image1 408 button .b1 -image image1 409 button .b2 -fg #ff0000 -text "Button 2" 410 button .b3 -state active -text "Button 3" 411 button .b4 -disabledforeground #0000ff -state disabled -text "Button 4" 412 checkbutton .b5 -variable x -text "Checkbutton 5" 413 set x 1 414 pack .b1 .b2 .b3 .b4 .b5 415 update 416 deleteWindows 417} {} 418 419test button-6.1 {ConfigureButton - textvariable trace} { 420 catch {destroy .b1} 421 button .b1 -bd 4 -bg green 422 catch {.b1 configure -bd 7 -bg green -fg bogus} 423 list [catch {.b1 configure -bd 7 -bg red -fg bogus} msg] \ 424 $msg [.b1 cget -bd] [.b1 cget -bg] 425} {1 {unknown color name "bogus"} 4 green} 426test button-6.2 {ConfigureButton - textvariable trace} { 427 catch {destroy .b1} 428 set x From-x 429 set y From-y 430 button .b1 -textvariable x 431 .b1 configure -textvariable y 432 set x New 433 lindex [.b1 configure -text] 4 434} {From-y} 435test button-6.2 {ConfigureButton - variable traces} { 436 catch {destroy .b1} 437 catch {unset x} 438 checkbutton .b1 -variable x 439 set x 1 440 set y 1 441 .b1 configure -textvariable y 442 set x 0 443 .b1 toggle 444 set y 445} {1} 446test button-6.3 {ConfigureButton - image handling} testImageType { 447 catch {destroy .b1} 448 eval image delete [image names] 449 image create test image1 450 image create test image2 451 button .b1 -image image1 452 image delete image1 453 .b1 configure -image image2 454 image names 455} {image2} 456test button-6.5 {ConfigureButton - default value for variable} { 457 catch {destroy .b1} 458 checkbutton .b1 459 .b1 cget -variable 460} {b1} 461test button-6.6 {ConfigureButton - setting selected state from variable} { 462 catch {destroy .b1} 463 set x 0 464 set y Shiny 465 checkbutton .b1 -variable x 466 .b1 configure -variable y -onvalue Shiny 467 .b1 toggle 468 set y 469} 0 470test button-6.7 {ConfigureButton - setting selected state from variable} { 471 catch {destroy .b1} 472 catch {unset x} 473 checkbutton .b1 -variable x -offvalue Bogus 474 set x 475} Bogus 476test button-6.8 {ConfigureButton - setting selected state from variable} { 477 catch {destroy .b1} 478 catch {unset x} 479 radiobutton .b1 -variable x 480 set x 481} {} 482test button-6.9 {ConfigureButton - error in setting variable} { 483 catch {destroy .b1} 484 catch {unset x} 485 trace variable x w bogusTrace 486 set result [list [catch {radiobutton .b1 -variable x} msg] $msg] 487 trace vdelete x w bogusTrace 488 set result 489} {1 {can't set "x": trace aborted}} 490test button-6.10 {ConfigureButton - bad image name} { 491 catch {destroy .b1} 492 list [catch {button .b1 -image bogus} msg] $msg 493} {1 {image "bogus" doesn't exist}} 494test button-6.11 {ConfigureButton - setting variable from current text value} { 495 catch {destroy .b1} 496 catch {unset x} 497 button .b1 -textvariable x -text "Button 1" 498 set x 499} {Button 1} 500test button-6.12 {ConfigureButton - using current value of variable} { 501 catch {destroy .b1} 502 set x Override 503 button .b1 -textvariable x -text "Button 1" 504 set x 505} {Override} 506test button-6.13 {ConfigureButton - variable handling} { 507 catch {destroy .b1} 508 catch {unset x} 509 trace variable x w bogusTrace 510 set result [list [catch {radiobutton .b1 -text foo -textvariable x} msg] \ 511 $msg $x] 512 trace vdelete x w bogusTrace 513 set result 514} {1 {can't set "x": trace aborted} foo} 515test button-6.14 {ConfigureButton - -width option} { 516 catch {destroy .b1} 517 button .b1 -text "Button 1" 518 list [catch {.b1 configure -width 1i} msg] $msg $errorInfo 519} {1 {expected integer but got "1i"} {expected integer but got "1i" 520 (processing -width option) 521 invoked from within 522".b1 configure -width 1i"}} 523test button-6.15 {ConfigureButton - -height option} { 524 catch {destroy .b1} 525 button .b1 -text "Button 1" 526 list [catch {.b1 configure -height 0.5c} msg] $msg $errorInfo 527} {1 {expected integer but got "0.5c"} {expected integer but got "0.5c" 528 (processing -height option) 529 invoked from within 530".b1 configure -height 0.5c"}} 531test button-6.16 {ConfigureButton - -width option} { 532 catch {destroy .b1} 533 button .b1 -bitmap questhead 534 list [catch {.b1 configure -width abc} msg] $msg $errorInfo 535} {1 {bad screen distance "abc"} {bad screen distance "abc" 536 (processing -width option) 537 invoked from within 538".b1 configure -width abc"}} 539test button-6.17 {ConfigureButton - -height option} testImageType { 540 catch {destroy .b1} 541 eval image delete [image names] 542 image create test image1 543 button .b1 -image image1 544 list [catch {.b1 configure -height 0.5x} msg] $msg $errorInfo 545} {1 {bad screen distance "0.5x"} {bad screen distance "0.5x" 546 (processing -height option) 547 invoked from within 548".b1 configure -height 0.5x"}} 549test button-6.18 {ConfigureButton - computing geometry} {nonPortable fonts} { 550 catch {destroy .b1} 551 button .b1 -text "Sample text" -width 10 -height 2 552 pack .b1 553 set result "[winfo reqwidth .b1] [winfo reqheight .b1]" 554 .b1 configure -bitmap questhead 555 lappend result [winfo reqwidth .b1] [winfo reqheight .b1] 556} {102 46 20 12} 557test button-6.19 {ConfigureButton - computing geometry} { 558 catch {destroy .b1} 559 button .b1 -text "Button 1" 560 set old [winfo reqwidth .b1] 561 .b1 configure -text "Much longer text" 562 set new [winfo reqwidth .b1] 563 expr $old == $new 564} {0} 565 566test button-7.1 {ButtonEventProc procedure} { 567 catch {destroy .b1} 568 button .b1 -text "Test Button" -command { 569 destroy .b1 570 set x [list [winfo exists .b1] [info commands .b1]] 571 } 572 .b1 invoke 573 set x 574} {0 {}} 575test button-7.2 {ButtonEventProc procedure} { 576 deleteWindows 577 button .b1 -bg #543210 578 rename .b1 .b2 579 set x {} 580 lappend x [winfo children .] 581 lappend x [.b2 cget -bg] 582 destroy .b1 583 lappend x [info command .b*] [winfo children .] 584} {.b1 #543210 {} {}} 585 586test button-8.1 {ButtonCmdDeletedProc procedure} { 587 deleteWindows 588 button .b1 589 rename .b1 {} 590 list [info command .b*] [winfo children .] 591} {{} {}} 592 593test button-9.1 {TkInvokeButton procedure} { 594 catch {destroy .b1} 595 set x 0 596 checkbutton .b1 -variable x 597 set result $x 598 .b1 invoke 599 lappend result $x 600 .b1 invoke 601 lappend result $x 602} {0 1 0} 603test button-9.2 {TkInvokeButton procedure} { 604 catch {destroy .b1} 605 set x 0 606 checkbutton .b1 -variable x 607 trace variable x w bogusTrace 608 set result [list [catch {.b1 invoke} msg] $msg $x] 609 trace vdelete x w bogusTrace 610 set result 611} {1 {can't set "x": trace aborted} 1} 612test button-9.3 {TkInvokeButton procedure} { 613 catch {destroy .b1} 614 set x 1 615 checkbutton .b1 -variable x 616 trace variable x w bogusTrace 617 set result [list [catch {.b1 invoke} msg] $msg $x] 618 trace vdelete x w bogusTrace 619 set result 620} {1 {can't set "x": trace aborted} 0} 621test button-9.4 {TkInvokeButton procedure} { 622 catch {destroy .b1} 623 set x 0 624 radiobutton .b1 -variable x -value red 625 set result $x 626 .b1 invoke 627 lappend result $x 628 .b1 invoke 629 lappend result $x 630} {0 red red} 631test button-9.5 {TkInvokeButton procedure} { 632 catch {destroy .b1} 633 radiobutton .b1 -variable x -value red 634 set x green 635 trace variable x w bogusTrace 636 set result [list [catch {.b1 invoke} msg] $msg $errorInfo $x] 637 trace vdelete x w bogusTrace 638 set result 639} {1 {can't set "x": trace aborted} {can't set "x": trace aborted 640 while executing 641".b1 invoke"} red} 642test button-9.6 {TkInvokeButton procedure} { 643 deleteWindows 644 set result untouched 645 button .b1 -command {set result invoked} 646 list [catch {.b1 invoke} msg] $msg $result 647} {0 invoked invoked} 648test button-9.7 {TkInvokeButton procedure} { 649 deleteWindows 650 set result untouched 651 set x 0 652 checkbutton .b1 -variable x -command {set result "invoked $x"} 653 list [catch {.b1 invoke} msg] $msg $result 654} {0 {invoked 1} {invoked 1}} 655test button-9.8 {TkInvokeButton procedure} { 656 deleteWindows 657 set result untouched 658 set x 0 659 radiobutton .b1 -variable x -value red -command {set result "invoked $x"} 660 list [catch {.b1 invoke} msg] $msg $result 661} {0 {invoked red} {invoked red}} 662 663test button-10.1 {ButtonVarProc procedure} { 664 deleteWindows 665 set x 1 666 checkbutton .b1 -variable x 667 unset x 668 set result [info exists x] 669 .b1 toggle 670 lappend result $x 671 set x 0 672 .b1 toggle 673 lappend result $x 674} {0 1 1} 675test button-10.2 {ButtonVarProc procedure} { 676 deleteWindows 677 set x 0 678 checkbutton .b1 -variable x 679 set x 44 680 .b1 toggle 681 set x 682} {1} 683test button-10.3 {ButtonVarProc procedure} { 684 deleteWindows 685 set x 1 686 checkbutton .b1 -variable x 687 set x 44 688 .b1 toggle 689 set x 690} {1} 691test button-10.4 {ButtonVarProc procedure} { 692 deleteWindows 693 set x 0 694 checkbutton .b1 -variable x 695 set x 1 696 .b1 toggle 697 set x 698} {0} 699test button-10.5 {ButtonVarProc procedure} { 700 deleteWindows 701 set x 1 702 checkbutton .b1 -variable x 703 set x 1 704 .b1 toggle 705 set x 706} {0} 707test button-10.6 {ButtonVarProc procedure} { 708 deleteWindows 709 set x 0 710 checkbutton .b1 -variable x 711 set x 0 712 .b1 toggle 713 set x 714} {1} 715test button-10.7 {ButtonVarProc procedure} { 716 deleteWindows 717 set x 1 718 checkbutton .b1 -variable x 719 set x 0 720 .b1 toggle 721 set x 722} {1} 723test button-10.8 {ButtonVarProc procedure, can't read variable} { 724 # This test does nothing but produce a core dump if there's a prbblem. 725 deleteWindows 726 catch {unset a} 727 checkbutton .b1 -variable a 728 unset a 729 set a(32) 0 730 unset a 731} {} 732 733test button-11.1 {ButtonTextVarProc procedure} { 734 deleteWindows 735 set x Label 736 button .b1 -textvariable x 737 unset x 738 set result [list $x [lindex [.b1 configure -text] 4]] 739 set x New 740 lappend result [lindex [.b1 configure -text] 4] 741} {Label Label New} 742test button-11.2 {ButtonTextVarProc procedure} { 743 deleteWindows 744 # Windows buttons have a default min width, so we have to 745 # set this to be longer to force the wider button. 746 set x ExtraLongLabel 747 button .b1 -textvariable x 748 set old [winfo reqwidth .b1] 749 set x New 750 set new [winfo reqwidth .b1] 751 list [lindex [.b1 configure -text] 4] [expr $old == $new] 752} {New 0} 753 754test button-12.1 {ButtonImageProc procedure} testImageType { 755 deleteWindows 756 eval image delete [image names] 757 image create test image1 758 label .b1 -image image1 -padx 0 -pady 0 -bd 0 759 pack .b1 760 set result "[winfo reqwidth .b1] [winfo reqheight .b1]" 761 image1 changed 0 0 0 0 80 100 762 lappend result [winfo reqwidth .b1] [winfo reqheight .b1] 763} {30 15 80 100} 764 765deleteWindows 766set l [interp hidden] 767 768test button-13.1 {button widget vs hidden commands} { 769 catch {destroy .b} 770 button .b -text hello 771 interp hide {} .b 772 destroy .b 773 list [winfo children .] [interp hidden] 774} [list {} $l] 775 776deleteWindows 777 778test button-14.1 {size behaviouor} { 779 set res {} 780 foreach class {label button radiobutton checkbutton} { 781 eval destroy [winfo children .] 782 783 $class .a -text Hej 784 $class .b -text Hej -width 10 -height 1 785 $class .c -text "" -width 10 -height 1 786 787 for {set t 0} {$t < 2} {incr t} { 788 set res2 {} 789 # With -width, width should not be affected by text change 790 lappend res2 [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}] 791 # With -height, height should not be affected by text change 792 lappend res2 [expr {[winfo reqheight .b] == [winfo reqheight .c]}] 793 # A one line text should be as high as -height 1 794 lappend res2 [expr {[winfo reqheight .a] == [winfo reqheight .b]}] 795 lappend res $res2 796 797 # Do the second round with another font 798 .a configure -font "Arial 20" 799 .b configure -font "Arial 20" 800 .c configure -font "Arial 20" 801 } 802 } 803 set res 804} {{1 1 1} {1 1 1} {1 1 1} {1 1 1} {1 1 1} {1 1 1} {1 1 1} {1 1 1}} 805 806deleteWindows 807 808option clear 809 810# cleanup 811::tcltest::cleanupTests 812return 813