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