diff options
Diffstat (limited to 'tests/button.test')
| -rw-r--r-- | tests/button.test | 822 |
1 files changed, 822 insertions, 0 deletions
diff --git a/tests/button.test b/tests/button.test new file mode 100644 index 0000000..2c6d082 --- /dev/null +++ b/tests/button.test @@ -0,0 +1,822 @@ +# This file is a Tcl script to test labels, buttons, checkbuttons, and +# radiobuttons in Tk (i.e., all the widgets defined in tkButton.c). It is +# organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) button.test 1.39 97/07/31 10:19:02 + +if {[lsearch [image types] test] < 0} { + puts "This application hasn't been compiled with the \"test\"" + puts "image, so I can't run this test. Are you sure you're using" + puts "tktest instead of wish?" + return +} + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +proc bogusTrace args { + error "trace aborted" +} +catch {unset value} +catch {unset value2} + +# Create entries in the option database to be sure that geometry options +# like border width have predictable values. + +option add *Button.borderWidth 2 +option add *Button.highlightThickness 2 +option add *Button.font {Helvetica -12 bold} + +eval image delete [image names] +image create test image1 +label .l -text Label +button .b -text Button +checkbutton .c -text Checkbutton +radiobutton .r -text Radiobutton +pack .l .b .c .r +update +set i 1 +foreach test { + {-activebackground #012345 #012345 non-existent + {unknown color name "non-existent"}} + {-activeforeground #ff0000 #ff0000 non-existent + {unknown color name "non-existent"}} + {-anchor nw nw bogus {bad anchor position "bogus": must be n, ne, e, se, s, sw, w, nw, or center}} + {-background #ff0000 #ff0000 non-existent + {unknown color name "non-existent"}} + {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} + {-bd 4 4 badValue {bad screen distance "badValue"}} + {-bitmap questhead questhead badValue {bitmap "badValue" not defined}} + {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} + {-command "set x" {set x} {} {}} + {-cursor arrow arrow badValue {bad cursor spec "badValue"}} + {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}} + {-fg #110022 #110022 bogus {unknown color name "bogus"}} + {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist}} + {-foreground #110022 #110022 bogus {unknown color name "bogus"}} + {-height 18 18 20.0 {expected integer but got "20.0"}} + {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} + {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}} + {-highlightthickness 18 18 badValue {bad screen distance "badValue"}} + {-image image1 image1 bogus {image "bogus" doesn't exist}} + {-indicatoron yes 1 no_way {expected boolean value but got "no_way"}} + {-justify right right bogus {bad justification "bogus": must be left, right, or center}} + {-offvalue lousy lousy {} {}} + {-offvalue fantastic fantastic {} {}} + {-padx 12 12 420x {bad screen distance "420x"}} + {-pady 12 12 420x {bad screen distance "420x"}} + {-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}} + {-selectcolor #110022 #110022 bogus {unknown color name "bogus"}} + {-selectimage image1 image1 bogus {image "bogus" doesn't exist}} + {-state normal normal bogus {bad state value "bogus": must be normal, active, or disabled}} + {-takefocus "any string" "any string" {} {}} + {-text "Sample text" {Sample text} {} {}} + {-textvariable i i {} {}} + {-underline 5 5 3p {expected integer but got "3p"}} + {-width 402 402 3p {expected integer but got "3p"}} + {-wraplength 100 100 6x {bad screen distance "6x"}} +} { + set name [lindex $test 0] + test button-1.$i {configuration options} { + .c configure $name [lindex $test 1] + lindex [.c configure $name] 4 + } [lindex $test 2] + incr i + if {[lindex $test 3] != ""} { + test button-1.$i {configuration options} { + list [catch {.c configure $name [lindex $test 3]} msg] $msg + } [list 1 [lindex $test 4]] + } + .c configure $name [lindex [.c configure $name] 3] + incr i +} +test button-1.$i {configuration options} { + .c configure -selectcolor {} +} {} +incr i +# the following tests only work on buttons, not checkbuttons +test button-1.$i {configuration options} { + .b configure -default active + lindex [.b configure -default] 4 +} active +incr i +test button-1.$i {configuration options} { + .b configure -default normal + lindex [.b configure -default] 4 +} normal +incr i +test button-1.$i {configuration options} { + .b configure -default disabled + lindex [.b configure -default] 4 +} disabled +incr i +test button-1.$i {configuration options} { + .b configure -default active + lindex [.b configure -default] 3 +} disabled +incr i +test button-1.$i {configuration options} { + list [catch {.b configure -default no_way} msg] $msg +} {1 {bad -default value "no_way": must be normal, active, or disabled}} + +set i 1 +foreach check { + {-activebackground 1 0 0 0} + {-activeforeground 1 0 0 0} + {-anchor 0 0 0 0} + {-background 0 0 0 0} + {-bd 0 0 0 0} + {-bg 0 0 0 0} + {-bitmap 0 0 0 0} + {-borderwidth 0 0 0 0} + {-command 1 0 0 0} + {-cursor 0 0 0 0} + {-default 1 0 1 1} + {-disabledforeground 1 0 0 0} + {-fg 0 0 0 0} + {-font 0 0 0 0} + {-foreground 0 0 0 0} + {-height 0 0 0 0} + {-image 0 0 0 0} + {-indicatoron 1 1 0 0} + {-offvalue 1 1 0 1} + {-onvalue 1 1 0 1} + {-padx 0 0 0 0} + {-pady 0 0 0 0} + {-relief 0 0 0 0} + {-selectcolor 1 1 0 0} + {-selectimage 1 1 0 0} + {-state 1 0 0 0} + {-text 0 0 0 0} + {-textvariable 0 0 0 0} + {-value 1 1 1 0} + {-variable 1 1 0 0} + {-width 0 0 0 0} +} { + test button-2.$i {label-specific options} " + catch {.l configure [lindex $check 0]} + " [lindex $check 1] + incr i + test button-2.$i {button-specific options} " + catch {.b configure [lindex $check 0]} + " [lindex $check 2] + incr i + test button-2.$i {checkbutton-specific options} " + catch {.c configure [lindex $check 0]} + " [lindex $check 3] + incr i + test button-2.$i {radiobutton-specific options} " + catch {.r configure [lindex $check 0]} + " [lindex $check 4] + incr i +} + +test button-3.1 {ButtonCreate procedure} { + list [catch {button} msg] $msg +} {1 {wrong # args: should be "button pathName ?options?"}} +test button-3.2 {ButtonCreate procedure} { + catch {destroy .x} + label .x + winfo class .x +} {Label} +test button-3.3 {ButtonCreate procedure} { + catch {destroy .x} + button .x + winfo class .x +} {Button} +test button-3.4 {ButtonCreate procedure} { + catch {destroy .x} + checkbutton .x + winfo class .x +} {Checkbutton} +test button-3.5 {ButtonCreate procedure} { + catch {destroy .x} + radiobutton .x + winfo class .x +} {Radiobutton} +rename button gorp +test button-3.6 {ButtonCreate procedure} { + catch {destroy .x} + gorp .x + winfo class .x +} {Button} +rename gorp button +test button-3.7 {ButtonCreate procedure} { + list [catch {button foo} msg] $msg +} {1 {bad window path name "foo"}} +test button-3.8 {ButtonCreate procedure} { + catch {destroy .x} + list [catch {button .x -gorp foo} msg] $msg [winfo exists .x] +} {1 {unknown option "-gorp"} 0} + +test button-4.1 {ButtonWidgetCmd procedure} { + list [catch {.b} msg] $msg +} {1 {wrong # args: should be ".b option ?arg arg ...?"}} +test button-4.2 {ButtonWidgetCmd procedure, "cget" option} { + list [catch {.b c} msg] $msg +} {1 {bad option "c": must be cget, configure, flash, or invoke}} +test button-4.3 {ButtonWidgetCmd procedure, "cget" option} { + list [catch {.b cget a b} msg] $msg +} {1 {wrong # args: should be ".b cget option"}} +test button-4.4 {ButtonWidgetCmd procedure, "cget" option} { + list [catch {.b cget -gorp} msg] $msg +} {1 {unknown option "-gorp"}} +test button-4.5 {ButtonWidgetCmd procedure, "cget" option} { + .b configure -highlightthickness 3 + .b cget -highlightthickness +} {3} +test button-4.6 {ButtonWidgetCmd procedure, "cget" option} { + list [catch {.l cget -disabledforeground} msg] $msg +} {1 {unknown option "-disabledforeground"}} +test button-4.7 {ButtonWidgetCmd procedure, "cget" option} { + catch {.b cget -disabledforeground} +} {0} +test button-4.8 {ButtonWidgetCmd procedure, "cget" option} { + list [catch {.b cget -variable} msg] $msg +} {1 {unknown option "-variable"}} +test button-4.9 {ButtonWidgetCmd procedure, "cget" option} { + catch {.c cget -variable} +} {0} +test button-4.10 {ButtonWidgetCmd procedure, "cget" option} { + list [catch {.c cget -value} msg] $msg +} {1 {unknown option "-value"}} +test button-4.11 {ButtonWidgetCmd procedure, "cget" option} { + catch {.r cget -value} +} {0} +test button-4.12 {ButtonWidgetCmd procedure, "cget" option} { + list [catch {.r cget -onvalue} msg] $msg +} {1 {unknown option "-onvalue"}} +test button-4.13 {ButtonWidgetCmd procedure, "configure" option} { + llength [.c configure] +} {36} +test button-4.14 {ButtonWidgetCmd procedure, "configure" option} { + list [catch {.b configure -gorp} msg] $msg +} {1 {unknown option "-gorp"}} +test button-4.15 {ButtonWidgetCmd procedure, "configure" option} { + list [catch {.b co -bg #ffffff -fg} msg] $msg +} {1 {value for "-fg" missing}} +test button-4.16 {ButtonWidgetCmd procedure, "configure" option} { + .b configure -fg #123456 + .b configure -bg #654321 + lindex [.b configure -fg] 4 +} {#123456} +.c configure -variable value -onvalue 1 -offvalue 0 +.r configure -variable value2 -value red +test button-4.17 {ButtonWidgetCmd procedure, "deselect" option} { + list [catch {.c deselect foo} msg] $msg +} {1 {wrong # args: should be ".c deselect"}} +test button-4.18 {ButtonWidgetCmd procedure, "deselect" option} { + list [catch {.l deselect} msg] $msg +} {1 {bad option "deselect": must be cget or configure}} +test button-4.19 {ButtonWidgetCmd procedure, "deselect" option} { + list [catch {.b deselect} msg] $msg +} {1 {bad option "deselect": must be cget, configure, flash, or invoke}} +test button-4.20 {ButtonWidgetCmd procedure, "deselect" option} { + set value 1 + .c d + set value +} {0} +test button-4.21 {ButtonWidgetCmd procedure, "deselect" option} { + set value2 green + .r deselect + set value2 +} {green} +test button-4.22 {ButtonWidgetCmd procedure, "deselect" option} { + set value2 red + .r deselect + set value2 +} {} +test button-4.23 {ButtonWidgetCmd procedure, "deselect" option} { + set value 1 + trace variable value w bogusTrace + set result [list [catch {.c deselect} msg] $msg $errorInfo $value] + trace vdelete value w bogusTrace + set result +} {1 {can't set "value": trace aborted} {can't set "value": trace aborted + while executing +".c deselect"} 0} +test button-4.24 {ButtonWidgetCmd procedure, "deselect" option} { + set value2 red + trace variable value2 w bogusTrace + set result [list [catch {.r deselect} msg] $msg $errorInfo $value2] + trace vdelete value2 w bogusTrace + set result +} {1 {can't set "value2": trace aborted} {can't set "value2": trace aborted + while executing +".r deselect"} {}} +test button-4.25 {ButtonWidgetCmd procedure, "flash" option} { + list [catch {.b flash foo} msg] $msg +} {1 {wrong # args: should be ".b flash"}} +test button-4.26 {ButtonWidgetCmd procedure, "flash" option} { + list [catch {.l flash} msg] $msg +} {1 {bad option "flash": must be cget or configure}} +test button-4.27 {ButtonWidgetCmd procedure, "flash" option} { + list [catch {.b flash} msg] $msg +} {0 {}} +test button-4.28 {ButtonWidgetCmd procedure, "flash" option} { + list [catch {.c flash} msg] $msg +} {0 {}} +test button-4.29 {ButtonWidgetCmd procedure, "flash" option} { + list [catch {.r f} msg] $msg +} {0 {}} +test button-4.30 {ButtonWidgetCmd procedure, "invoke" option} { + list [catch {.b invoke foo} msg] $msg +} {1 {wrong # args: should be ".b invoke"}} +test button-4.31 {ButtonWidgetCmd procedure, "invoke" option} { + list [catch {.l invoke} msg] $msg +} {1 {bad option "invoke": must be cget or configure}} +test button-4.32 {ButtonWidgetCmd procedure, "invoke" option} { + .b configure -command {set x invoked} + set x "not invoked" + .b invoke + set x +} {invoked} +test button-4.33 {ButtonWidgetCmd procedure, "invoke" option} { + .b configure -command {set x invoked} -state disabled + set x "not invoked" + .b invoke + set x +} {not invoked} +test button-4.34 {ButtonWidgetCmd procedure, "invoke" option} { + set value bogus + .c configure -command {set x invoked} -variable value -onvalue 1 \ + -offvalue 0 + set x "not invoked" + .c invoke + list $x $value +} {invoked 1} +test button-4.35 {ButtonWidgetCmd procedure, "invoke" option} { + set value2 green + .r configure -command {set x invoked} -variable value2 -value red + set x "not invoked" + .r i + list $x $value2 +} {invoked red} +test button-4.36 {ButtonWidgetCmd procedure, "select" option} { + list [catch {.l select} msg] $msg +} {1 {bad option "select": must be cget or configure}} +test button-4.37 {ButtonWidgetCmd procedure, "select" option} { + list [catch {.b select} msg] $msg +} {1 {bad option "select": must be cget, configure, flash, or invoke}} +test button-4.38 {ButtonWidgetCmd procedure, "select" option} { + list [catch {.c select foo} msg] $msg +} {1 {wrong # args: should be ".c select"}} +test button-4.39 {ButtonWidgetCmd procedure, "select" option} { + set value bogus + .c configure -command {} -variable value -onvalue lovely -offvalue 0 + .c s + set value +} {lovely} +test button-4.40 {ButtonWidgetCmd procedure, "select" option} { + set value2 green + .r configure -command {} -variable value2 -value red + .r select + set value2 +} {red} +test button-4.41 {ButtonWidgetCmd procedure, "select" option} { + set value2 yellow + trace variable value2 w bogusTrace + set result [list [catch {.r select} msg] $msg $errorInfo $value2] + trace vdelete value2 w bogusTrace + set result +} {1 {can't set "value2": trace aborted} {can't set "value2": trace aborted + while executing +".r select"} red} +test button-4.42 {ButtonWidgetCmd procedure, "toggle" option} { + list [catch {.l toggle} msg] $msg +} {1 {bad option "toggle": must be cget or configure}} +test button-4.43 {ButtonWidgetCmd procedure, "toggle" option} { + list [catch {.b toggle} msg] $msg +} {1 {bad option "toggle": must be cget, configure, flash, or invoke}} +test button-4.44 {ButtonWidgetCmd procedure, "toggle" option} { + list [catch {.r toggle} msg] $msg +} {1 {bad option "toggle": must be cget, configure, deselect, flash, invoke, or select}} +test button-4.45 {ButtonWidgetCmd procedure, "toggle" option} { + list [catch {.c toggle foo} msg] $msg +} {1 {wrong # args: should be ".c toggle"}} +test button-4.46 {ButtonWidgetCmd procedure, "toggle" option} { + set value bogus + .c configure -command {} -variable value -onvalue sunshine -offvalue rain + .c toggle + set result $value + .c toggle + lappend result $value + .c toggle + lappend result $value +} {sunshine rain sunshine} +test button-4.47 {ButtonWidgetCmd procedure, "toggle" option} { + .c configure -onvalue xyz -offvalue abc + set value xyz + trace variable value w bogusTrace + set result [list [catch {.c toggle} msg] $msg $errorInfo $value] + trace vdelete value w bogusTrace + set result +} {1 {can't set "value": trace aborted} {can't set "value": trace aborted + while executing +".c toggle"} abc} +test button-4.48 {ButtonWidgetCmd procedure, "toggle" option} { + .c configure -onvalue xyz -offvalue abc + set value abc + trace variable value w bogusTrace + set result [list [catch {.c toggle} msg] $msg $errorInfo $value] + trace vdelete value w bogusTrace + set result +} {1 {can't set "value": trace aborted} {can't set "value": trace aborted + while executing +".c toggle"} xyz} +test button-4.49 {ButtonWidgetCmd procedure} { + list [catch {.c bad_option} msg] $msg +} {1 {bad option "bad_option": must be cget, configure, deselect, flash, invoke, select, or toggle}} +test button-4.50 {ButtonWidgetCmd procedure, "toggle" option} { + catch {unset value}; set value(1) 1; + set result [list [catch {.c toggle} msg] $msg $errorInfo] + unset value; + set result +} {1 {can't set "value": variable is array} {can't set "value": variable is array + while executing +".c toggle"}} + +test button-5.1 {DestroyButton procedure} { + image create test image1 + button .b1 -image image1 + button .b2 -fg #ff0000 -text "Button 2" + button .b3 -state active -text "Button 3" + button .b4 -disabledforeground #0000ff -state disabled -text "Button 4" + checkbutton .b5 -variable x -text "Checkbutton 5" + set x 1 + pack .b1 .b2 .b3 .b4 .b5 + update + eval destroy [winfo children .] +} {} + +test button-6.1 {ConfigureButton procedure} { + catch {destroy .b1} + set x From-x + set y From-y + button .b1 -textvariable x + .b1 configure -textvariable y + set x New + lindex [.b1 configure -text] 4 +} {From-y} +test button-6.2 {ConfigureButton procedure} { + catch {destroy .b1} + catch {unset x} + checkbutton .b1 -variable x + set x 1 + set y 1 + .b1 configure -textvariable y + set x 0 + .b1 toggle + set y +} {1} +test button-6.3 {ConfigureButton procedure} { + catch {destroy .b1} + eval image delete [image names] + image create test image1 + image create test image2 + button .b1 -image image1 + image delete image1 + .b1 configure -image image2 + image names +} {image2} +test button-6.4 {ConfigureButton procedure} { + catch {destroy .b1} + button .b1 -text "Test" -state disabled + list [catch {.b1 configure -state bogus} msg] $msg \ + [lindex [.b1 configure -state] 4] +} {1 {bad state value "bogus": must be normal, active, or disabled} normal} +test button-6.5 {ConfigureButton procedure} { + catch {destroy .b1} + checkbutton .b1 + .b1 cget -variable +} {b1} +test button-6.6 {ConfigureButton procedure} { + catch {destroy .b1} + set x 0 + set y Shiny + checkbutton .b1 -variable x + .b1 configure -variable y -onvalue Shiny + .b1 toggle + set y +} 0 +test button-6.7 {ConfigureButton procedure} { + catch {destroy .b1} + catch {unset x} + checkbutton .b1 -variable x -offvalue Bogus + set x +} Bogus +test button-6.8 {ConfigureButton procedure} { + catch {destroy .b1} + catch {unset x} + radiobutton .b1 -variable x + set x +} {} +test button-6.9 {ConfigureButton procedure} { + catch {destroy .b1} + catch {unset x} + trace variable x w bogusTrace + set result [list [catch {radiobutton .b1 -variable x} msg] $msg] + trace vdelete x w bogusTrace + set result +} {1 {can't set "x": trace aborted}} +test button-6.10 {ConfigureButton procedure} { + catch {destroy .b1} + list [catch {button .b1 -image bogus} msg] $msg +} {1 {image "bogus" doesn't exist}} +test button-6.11 {ConfigureButton procedure} { + catch {destroy .b1} + catch {unset x} + button .b1 -textvariable x -text "Button 1" + set x +} {Button 1} +test button-6.12 {ConfigureButton procedure} { + catch {destroy .b1} + set x Override + button .b1 -textvariable x -text "Button 1" + set x +} {Override} +test button-6.13 {ConfigureButton procedure} { + catch {destroy .b1} + catch {unset x} + trace variable x w bogusTrace + set result [list [catch {radiobutton .b1 -text foo -textvariable x} msg] \ + $msg $x] + trace vdelete x w bogusTrace + set result +} {1 {can't set "x": trace aborted} foo} +test button-6.14 {ConfigureButton procedure} { + catch {destroy .b1} + button .b1 -text "Button 1" + list [catch {.b1 configure -width 1i} msg] $msg $errorInfo +} {1 {expected integer but got "1i"} {expected integer but got "1i" + (processing -width option) + invoked from within +".b1 configure -width 1i"}} +test button-6.15 {ConfigureButton procedure} { + catch {destroy .b1} + button .b1 -text "Button 1" + list [catch {.b1 configure -height 0.5c} msg] $msg $errorInfo +} {1 {expected integer but got "0.5c"} {expected integer but got "0.5c" + (processing -height option) + invoked from within +".b1 configure -height 0.5c"}} +test button-6.16 {ConfigureButton procedure} { + catch {destroy .b1} + button .b1 -bitmap questhead + list [catch {.b1 configure -width abc} msg] $msg $errorInfo +} {1 {bad screen distance "abc"} {bad screen distance "abc" + (processing -width option) + invoked from within +".b1 configure -width abc"}} +test button-6.17 {ConfigureButton procedure} { + catch {destroy .b1} + eval image delete [image names] + image create test image1 + button .b1 -image image1 + list [catch {.b1 configure -height 0.5x} msg] $msg $errorInfo +} {1 {bad screen distance "0.5x"} {bad screen distance "0.5x" + (processing -height option) + invoked from within +".b1 configure -height 0.5x"}} +test button-6.18 {ConfigureButton procedure} {nonPortable fonts} { + catch {destroy .b1} + button .b1 -text "Sample text" -width 10 -height 2 + pack .b1 + set result "[winfo reqwidth .b1] [winfo reqheight .b1]" + .b1 configure -bitmap questhead + lappend result [winfo reqwidth .b1] [winfo reqheight .b1] +} {102 46 20 12} +test button-6.19 {ConfigureButton procedure} { + catch {destroy .b1} + button .b1 -text "Button 1" + set old [winfo reqwidth .b1] + .b1 configure -text "Much longer text" + set new [winfo reqwidth .b1] + expr $old == $new +} {0} + +test button-7.1 {ButtonEventProc procedure} { + catch {destroy .b1} + button .b1 -text "Test Button" -command { + destroy .b1 + set x [list [winfo exists .b1] [info commands .b1]] + } + .b1 invoke + set x +} {0 {}} +test button-7.2 {ButtonEventProc procedure} { + eval destroy [winfo children .] + button .b1 -bg #543210 + rename .b1 .b2 + set x {} + lappend x [winfo children .] + lappend x [.b2 cget -bg] + destroy .b1 + lappend x [info command .b*] [winfo children .] +} {.b1 #543210 {} {}} + +test button-8.1 {ButtonCmdDeletedProc procedure} { + eval destroy [winfo children .] + button .b1 + rename .b1 {} + list [info command .b*] [winfo children .] +} {{} {}} + +test button-9.1 {TkInvokeButton procedure} { + catch {destroy .b1} + set x 0 + checkbutton .b1 -variable x + set result $x + .b1 invoke + lappend result $x + .b1 invoke + lappend result $x +} {0 1 0} +test button-9.2 {TkInvokeButton procedure} { + catch {destroy .b1} + set x 0 + checkbutton .b1 -variable x + trace variable x w bogusTrace + set result [list [catch {.b1 invoke} msg] $msg $x] + trace vdelete x w bogusTrace + set result +} {1 {can't set "x": trace aborted} 1} +test button-9.3 {TkInvokeButton procedure} { + catch {destroy .b1} + set x 1 + checkbutton .b1 -variable x + trace variable x w bogusTrace + set result [list [catch {.b1 invoke} msg] $msg $x] + trace vdelete x w bogusTrace + set result +} {1 {can't set "x": trace aborted} 0} +test button-9.4 {TkInvokeButton procedure} { + catch {destroy .b1} + set x 0 + radiobutton .b1 -variable x -value red + set result $x + .b1 invoke + lappend result $x + .b1 invoke + lappend result $x +} {0 red red} +test button-9.5 {TkInvokeButton procedure} { + catch {destroy .b1} + radiobutton .b1 -variable x -value red + set x green + trace variable x w bogusTrace + set result [list [catch {.b1 invoke} msg] $msg $errorInfo $x] + trace vdelete x w bogusTrace + set result +} {1 {can't set "x": trace aborted} {can't set "x": trace aborted + while executing +".b1 invoke"} red} +test button-9.6 {TkInvokeButton procedure} { + eval destroy [winfo children .] + set result untouched + button .b1 -command {set result invoked} + list [catch {.b1 invoke} msg] $msg $result +} {0 invoked invoked} +test button-9.7 {TkInvokeButton procedure} { + eval destroy [winfo children .] + set result untouched + set x 0 + checkbutton .b1 -variable x -command {set result "invoked $x"} + list [catch {.b1 invoke} msg] $msg $result +} {0 {invoked 1} {invoked 1}} +test button-9.8 {TkInvokeButton procedure} { + eval destroy [winfo children .] + set result untouched + set x 0 + radiobutton .b1 -variable x -value red -command {set result "invoked $x"} + list [catch {.b1 invoke} msg] $msg $result +} {0 {invoked red} {invoked red}} + +test button-10.1 {ButtonVarProc procedure} { + eval destroy [winfo children .] + set x 1 + checkbutton .b1 -variable x + unset x + set result [info exists x] + .b1 toggle + lappend result $x + set x 0 + .b1 toggle + lappend result $x +} {0 1 1} +test button-10.2 {ButtonVarProc procedure} { + eval destroy [winfo children .] + set x 0 + checkbutton .b1 -variable x + set x 44 + .b1 toggle + set x +} {1} +test button-10.3 {ButtonVarProc procedure} { + eval destroy [winfo children .] + set x 1 + checkbutton .b1 -variable x + set x 44 + .b1 toggle + set x +} {1} +test button-10.4 {ButtonVarProc procedure} { + eval destroy [winfo children .] + set x 0 + checkbutton .b1 -variable x + set x 1 + .b1 toggle + set x +} {0} +test button-10.5 {ButtonVarProc procedure} { + eval destroy [winfo children .] + set x 1 + checkbutton .b1 -variable x + set x 1 + .b1 toggle + set x +} {0} +test button-10.6 {ButtonVarProc procedure} { + eval destroy [winfo children .] + set x 0 + checkbutton .b1 -variable x + set x 0 + .b1 toggle + set x +} {1} +test button-10.7 {ButtonVarProc procedure} { + eval destroy [winfo children .] + set x 1 + checkbutton .b1 -variable x + set x 0 + .b1 toggle + set x +} {1} +test button-10.8 {ButtonVarProc procedure, can't read variable} { + # This test does nothing but produce a core dump if there's a prbblem. + eval destroy [winfo children .] + catch {unset a} + checkbutton .b1 -variable a + unset a + set a(32) 0 + unset a +} {} + +test button-11.1 {ButtonTextVarProc procedure} { + eval destroy [winfo children .] + set x Label + button .b1 -textvariable x + unset x + set result [list $x [lindex [.b1 configure -text] 4]] + set x New + lappend result [lindex [.b1 configure -text] 4] +} {Label Label New} +test button-11.2 {ButtonTextVarProc procedure} { + eval destroy [winfo children .] + set x Label + button .b1 -textvariable x + set old [winfo reqwidth .b1] + set x New + set new [winfo reqwidth .b1] + list [lindex [.b1 configure -text] 4] [expr $old == $new] +} {New 0} + +test button-12.1 {ButtonImageProc procedure} { + eval destroy [winfo children .] + eval image delete [image names] + image create test image1 + label .b1 -image image1 -padx 0 -pady 0 -bd 0 + pack .b1 + set result "[winfo reqwidth .b1] [winfo reqheight .b1]" + image1 changed 0 0 0 0 80 100 + lappend result [winfo reqwidth .b1] [winfo reqheight .b1] +} {30 15 80 100} + +eval destroy [winfo children .] +set l [interp hidden] + +test button-13.1 {button widget vs hidden commands} { + catch {destroy .b} + button .b -text hello + interp hide {} .b + destroy .b + list [winfo children .] [interp hidden] +} [list {} $l] + +eval destroy [winfo children .] + +option clear + |