diff options
Diffstat (limited to 'tcl/tests/button.test')
| -rw-r--r-- | tcl/tests/button.test | 812 |
1 files changed, 0 insertions, 812 deletions
diff --git a/tcl/tests/button.test b/tcl/tests/button.test deleted file mode 100644 index 27c46316be1..00000000000 --- a/tcl/tests/button.test +++ /dev/null @@ -1,812 +0,0 @@ -# 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. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# All rights reserved. -# -# RCS: @(#) $Id$ - -package require tcltest 2.1 -namespace import -force tcltest::configure -namespace import -force tcltest::testsDirectory -configure -testdir [file join [pwd] [file dirname [info script]]] -configure -loadfile [file join [testsDirectory] constraints.tcl] -tcltest::loadTestedCommands - -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] -if {[testConstraint testImageType]} { - 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"} {1 1 1 1}} - {-activeforeground #ff0000 #ff0000 non-existent - {unknown color name "non-existent"} {1 1 1 1}} - {-anchor nw nw bogus {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center} {1 1 1 1}} - {-background #ff0000 #ff0000 non-existent - {unknown color name "non-existent"} {1 1 1 1}} - {-bd 4 4 badValue {bad screen distance "badValue"} {1 1 1 1}} - {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"} - {1 1 1 1}} - {-bitmap questhead questhead badValue {bitmap "badValue" not defined} - {1 1 1 1}} - {-borderwidth 1.3 1.3 badValue {bad screen distance "badValue"} {1 1 1 1}} - {-command "set x" {set x} {} {} {0 1 1 1}} - {-compound left left bogus {bad compound "bogus": must be bottom, center, left, none, right, or top} {1 1 1 1}} - {-cursor arrow arrow badValue {bad cursor spec "badValue"} {1 1 1 1}} - {-default active active huh? - {bad default "huh?": must be active, disabled, or normal} - {0 1 0 0}} - {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"} - {1 1 1 1}} - {-fg #110022 #110022 bogus {unknown color name "bogus"} {1 1 1 1}} - {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist} {1 1 1 1}} - {-foreground #110022 #110022 bogus {unknown color name "bogus"} {1 1 1 1}} - {-height 18 18 20.0 {expected integer but got "20.0"} {1 1 1 1}} - {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"} - {1 1 1 1}} - {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"} - {1 1 1 1}} - {-highlightthickness 6m 6m badValue {bad screen distance "badValue"} - {1 1 1 1}} - {-image image1 image1 bogus {image "bogus" doesn't exist} {1 1 1 1}} - {-indicatoron yes 1 no_way {expected boolean value but got "no_way"} - {0 0 1 1}} - {-justify right right bogus {bad justification "bogus": must be left, right, or center} {1 1 1 1}} - {-offrelief flat flat 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} {0 0 1 1}} - {-offvalue lousy lousy {} {} {0 0 1 0}} - {-offvalue fantastic fantastic {} {} {0 0 1 0}} - {-overrelief "" "" 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} {0 1 1 1}} - {-padx 12m 12m 420x {bad screen distance "420x"} {1 1 1 1}} - {-pady 12m 12m 420x {bad screen distance "420x"} {1 1 1 1}} - {-repeatdelay 100 100 foo {expected integer but got "foo"} {0 1 0 0}} - {-repeatinterval 100 100 foo {expected integer but got "foo"} {0 1 0 0}} - {-relief flat flat 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} {1 1 1 1}} - {-selectcolor #110022 #110022 bogus {unknown color name "bogus"} {0 0 1 1}} - {-selectimage image1 image1 bogus {image "bogus" doesn't exist} {0 0 1 1}} - {-state normal normal bogus {bad state "bogus": must be active, disabled, or normal} {1 1 1 1}} - {-takefocus "any string" "any string" {} {} {1 1 1 1}} - {-text "Sample text" {Sample text} {} {} {1 1 1 1}} - {-textvariable i i {} {} {1 1 1 1}} - {-underline 5 5 3p {expected integer but got "3p"} {1 1 1 1}} - {-value anyString anyString {} {} {0 0 0 1}} - {-width 402 402 3p {expected integer but got "3p"} {1 1 1 1}} - {-wraplength 100 100 6x {bad screen distance "6x"} {1 1 1 1}} -} { - set name [lindex $test 0] - set classes [lindex $test 5] - foreach w {.l .b .c .r} hasOption [lindex $test 5] { - if $hasOption { - test button-1.$i {configuration options} testImageType { - $w configure $name [lindex $test 1] - lindex [$w configure $name] 4 - } [lindex $test 2] - incr i - if {[lindex $test 3] != ""} { - test button-1.$i {configuration options} testImageType { - list [catch {$w configure $name [lindex $test 3]} msg] $msg - } [list 1 [lindex $test 4]] - } - $w configure $name [lindex [$w configure $name] 3] - } else { - test button-1.$i {configuration options} testImageType { - list [catch {$w configure $name [lindex $test 1]} msg] $msg - } "1 {unknown option \"$name\"}" - } - } - incr i -} -test button-1.$i {configuration options} { - .c configure -selectcolor {} -} {} - -test button-3.1 {ButtonCreate - not enough cd ../unix -} { - list [catch {button} msg] $msg -} {1 {wrong # args: should be "button pathName ?options?"}} -test button-3.2 {ButtonCreate procedure - setting label class} { - catch {destroy .x} - label .x - winfo class .x -} {Label} -test button-3.3 {ButtonCreate - setting button class} { - catch {destroy .x} - button .x - winfo class .x -} {Button} -test button-3.4 {ButtonCreate - setting checkbutton class} { - catch {destroy .x} - checkbutton .x - winfo class .x -} {Checkbutton} -test button-3.5 {ButtonCreate - setting radiobutton class} { - catch {destroy .x} - radiobutton .x - winfo class .x -} {Radiobutton} -rename button gorp -test button-3.6 {ButtonCreate - setting class} { - catch {destroy .x} - gorp .x - winfo class .x -} {Button} -rename gorp button -test button-3.7 {ButtonCreate - bad window name} { - list [catch {button foo} msg] $msg -} {1 {bad window path name "foo"}} -test button-3.8 {ButtonCreate procedure - error in default option value} { - catch {destroy .funny} - option add *funny.background bogus - list [catch {button .funny} msg] $msg $errorInfo -} {1 {unknown color name "bogus"} {unknown color name "bogus" - (database entry for "-background" in widget ".funny") - invoked from within -"button .funny"}} -test button-3.9 {ButtonCreate procedure - option error} { - catch {destroy .x} - list [catch {button .x -gorp foo} msg] $msg [winfo exists .x] -} {1 {unknown option "-gorp"} 0} -test button-3.10 {ButtonCreate procedure - return value} { - catch {destroy .abcd} - set x [button .abcd] - destroy .abc - set x -} {.abcd} - -test button-4.1 {ButtonWidgetCmd - too few arguments} { - list [catch {.b} msg] $msg -} {1 {wrong # args: should be ".b option ?arg arg ...?"}} -test button-4.2 {ButtonWidgetCmd - bad option name} { - list [catch {.b c} msg] $msg -} {1 {ambiguous option "c": must be cget, configure, flash, or invoke}} -test button-4.3 {ButtonWidgetCmd - bad option name} { - list [catch {.b bogus} msg] $msg -} {1 {bad option "bogus": must be cget, configure, flash, or invoke}} -test button-4.4 {ButtonWidgetCmd procedure, "cget" option} { - list [catch {.b cget a b} msg] $msg -} {1 {wrong # args: should be ".b cget option"}} -test button-4.5 {ButtonWidgetCmd procedure, "cget" option} { - list [catch {.b cget -gorp} msg] $msg -} {1 {unknown option "-gorp"}} -test button-4.6 {ButtonWidgetCmd procedure, "cget" option} { - .b configure -highlightthickness 3 - .b cget -highlightthickness -} {3} -test button-4.7 {ButtonWidgetCmd procedure, "cget" option} { - catch {.l cget -disabledforeground} -} {0} -test button-4.8 {ButtonWidgetCmd procedure, "cget" option} { - catch {.b cget -disabledforeground} -} {0} -test button-4.9 {ButtonWidgetCmd procedure, "cget" option} { - list [catch {.b cget -variable} msg] $msg -} {1 {unknown option "-variable"}} -test button-4.10 {ButtonWidgetCmd procedure, "cget" option} { - catch {.c cget -variable} -} {0} -test button-4.11 {ButtonWidgetCmd procedure, "cget" option} { - list [catch {.c cget -value} msg] $msg -} {1 {unknown option "-value"}} -test button-4.12 {ButtonWidgetCmd procedure, "cget" option} { - catch {.r cget -value} -} {0} -test button-4.13 {ButtonWidgetCmd procedure, "cget" option} { - list [catch {.r cget -onvalue} msg] $msg -} {1 {unknown option "-onvalue"}} -test button-4.14 {ButtonWidgetCmd procedure, "configure" option} { - llength [.c configure] -} {39} -test button-4.15 {ButtonWidgetCmd procedure, "configure" option} { - list [catch {.b configure -gorp} msg] $msg -} {1 {unknown option "-gorp"}} -test button-4.16 {ButtonWidgetCmd procedure, "configure" option} { - list [catch {.b co -bg #ffffff -fg} msg] $msg -} {1 {value for "-fg" missing}} -test button-4.17 {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.18 {ButtonWidgetCmd procedure, "deselect" option} { - list [catch {.c deselect foo} msg] $msg -} {1 {wrong # args: should be ".c deselect"}} -test button-4.19 {ButtonWidgetCmd procedure, "deselect" option} { - list [catch {.l deselect} msg] $msg -} {1 {bad option "deselect": must be cget or configure}} -test button-4.20 {ButtonWidgetCmd procedure, "deselect" option} { - list [catch {.b deselect} msg] $msg -} {1 {bad option "deselect": must be cget, configure, flash, or invoke}} -test button-4.21 {ButtonWidgetCmd procedure, "deselect" option} { - set value 1 - .c d - set value -} {0} -test button-4.22 {ButtonWidgetCmd procedure, "deselect" option} { - set value2 green - .r deselect - set value2 -} {green} -test button-4.23 {ButtonWidgetCmd procedure, "deselect" option} { - set value2 red - .r deselect - set value2 -} {} -test button-4.24 {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.25 {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.26 {ButtonWidgetCmd procedure, "flash" option} { - list [catch {.b flash foo} msg] $msg -} {1 {wrong # args: should be ".b flash"}} -test button-4.27 {ButtonWidgetCmd procedure, "flash" option} { - list [catch {.l flash} msg] $msg -} {1 {bad option "flash": must be cget or configure}} -test button-4.28 {ButtonWidgetCmd procedure, "flash" option} { - list [catch {.b flash} msg] $msg -} {0 {}} -test button-4.29 {ButtonWidgetCmd procedure, "flash" option} { - list [catch {.c flash} msg] $msg -} {0 {}} -test button-4.30 {ButtonWidgetCmd procedure, "flash" option} { - list [catch {.r f} msg] $msg -} {0 {}} -test button-4.31 {ButtonWidgetCmd procedure, "invoke" option} { - list [catch {.b invoke foo} msg] $msg -} {1 {wrong # args: should be ".b invoke"}} -test button-4.32 {ButtonWidgetCmd procedure, "invoke" option} { - list [catch {.l invoke} msg] $msg -} {1 {bad option "invoke": must be cget or configure}} -test button-4.33 {ButtonWidgetCmd procedure, "invoke" option} { - .b configure -command {set x invoked} - set x "not invoked" - .b invoke - set x -} {invoked} -test button-4.34 {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.35 {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.36 {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.37 {ButtonWidgetCmd procedure, "select" option} { - list [catch {.l select} msg] $msg -} {1 {bad option "select": must be cget or configure}} -test button-4.38 {ButtonWidgetCmd procedure, "select" option} { - list [catch {.b select} msg] $msg -} {1 {bad option "select": must be cget, configure, flash, or invoke}} -test button-4.39 {ButtonWidgetCmd procedure, "select" option} { - list [catch {.c select foo} msg] $msg -} {1 {wrong # args: should be ".c select"}} -test button-4.40 {ButtonWidgetCmd procedure, "select" option} { - set value bogus - .c configure -command {} -variable value -onvalue lovely -offvalue 0 - .c s - set value -} {lovely} -test button-4.41 {ButtonWidgetCmd procedure, "select" option} { - set value2 green - .r configure -command {} -variable value2 -value red - .r select - set value2 -} {red} -test button-4.42 {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.43 {ButtonWidgetCmd procedure, "toggle" option} { - list [catch {.l toggle} msg] $msg -} {1 {bad option "toggle": must be cget or configure}} -test button-4.44 {ButtonWidgetCmd procedure, "toggle" option} { - list [catch {.b toggle} msg] $msg -} {1 {bad option "toggle": must be cget, configure, flash, or invoke}} -test button-4.45 {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.46 {ButtonWidgetCmd procedure, "toggle" option} { - list [catch {.c toggle foo} msg] $msg -} {1 {wrong # args: should be ".c toggle"}} -test button-4.47 {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.48 {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.49 {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.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} testImageType { - 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 - deleteWindows -} {} - -test button-6.1 {ConfigureButton - textvariable trace} { - catch {destroy .b1} - button .b1 -bd 4 -bg green - catch {.b1 configure -bd 7 -bg green -fg bogus} - list [catch {.b1 configure -bd 7 -bg red -fg bogus} msg] \ - $msg [.b1 cget -bd] [.b1 cget -bg] -} {1 {unknown color name "bogus"} 4 green} -test button-6.2 {ConfigureButton - textvariable trace} { - 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 - variable traces} { - 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 - image handling} testImageType { - 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.5 {ConfigureButton - default value for variable} { - catch {destroy .b1} - checkbutton .b1 - .b1 cget -variable -} {b1} -test button-6.6 {ConfigureButton - setting selected state from variable} { - 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 - setting selected state from variable} { - catch {destroy .b1} - catch {unset x} - checkbutton .b1 -variable x -offvalue Bogus - set x -} Bogus -test button-6.8 {ConfigureButton - setting selected state from variable} { - catch {destroy .b1} - catch {unset x} - radiobutton .b1 -variable x - set x -} {} -test button-6.9 {ConfigureButton - error in setting variable} { - 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 - bad image name} { - catch {destroy .b1} - list [catch {button .b1 -image bogus} msg] $msg -} {1 {image "bogus" doesn't exist}} -test button-6.11 {ConfigureButton - setting variable from current text value} { - catch {destroy .b1} - catch {unset x} - button .b1 -textvariable x -text "Button 1" - set x -} {Button 1} -test button-6.12 {ConfigureButton - using current value of variable} { - catch {destroy .b1} - set x Override - button .b1 -textvariable x -text "Button 1" - set x -} {Override} -test button-6.13 {ConfigureButton - variable handling} { - 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 - -width option} { - 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 - -height option} { - 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 - -width option} { - 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 - -height option} testImageType { - 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 - computing geometry} {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 - computing geometry} { - 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} { - deleteWindows - 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} { - deleteWindows - 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} { - deleteWindows - 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} { - deleteWindows - 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} { - deleteWindows - 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} { - deleteWindows - 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} { - deleteWindows - set x 0 - checkbutton .b1 -variable x - set x 44 - .b1 toggle - set x -} {1} -test button-10.3 {ButtonVarProc procedure} { - deleteWindows - set x 1 - checkbutton .b1 -variable x - set x 44 - .b1 toggle - set x -} {1} -test button-10.4 {ButtonVarProc procedure} { - deleteWindows - set x 0 - checkbutton .b1 -variable x - set x 1 - .b1 toggle - set x -} {0} -test button-10.5 {ButtonVarProc procedure} { - deleteWindows - set x 1 - checkbutton .b1 -variable x - set x 1 - .b1 toggle - set x -} {0} -test button-10.6 {ButtonVarProc procedure} { - deleteWindows - set x 0 - checkbutton .b1 -variable x - set x 0 - .b1 toggle - set x -} {1} -test button-10.7 {ButtonVarProc procedure} { - deleteWindows - 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. - deleteWindows - catch {unset a} - checkbutton .b1 -variable a - unset a - set a(32) 0 - unset a -} {} - -test button-11.1 {ButtonTextVarProc procedure} { - deleteWindows - 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} { - deleteWindows - # Windows buttons have a default min width, so we have to - # set this to be longer to force the wider button. - set x ExtraLongLabel - 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} testImageType { - deleteWindows - 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} - -deleteWindows -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] - -deleteWindows - -test button-14.1 {size behaviouor} { - set res {} - foreach class {label button radiobutton checkbutton} { - eval destroy [winfo children .] - - $class .a -text Hej - $class .b -text Hej -width 10 -height 1 - $class .c -text "" -width 10 -height 1 - - for {set t 0} {$t < 2} {incr t} { - set res2 {} - # With -width, width should not be affected by text change - lappend res2 [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}] - # With -height, height should not be affected by text change - lappend res2 [expr {[winfo reqheight .b] == [winfo reqheight .c]}] - # A one line text should be as high as -height 1 - lappend res2 [expr {[winfo reqheight .a] == [winfo reqheight .b]}] - lappend res $res2 - - # Do the second round with another font - .a configure -font "Arial 20" - .b configure -font "Arial 20" - .c configure -font "Arial 20" - } - } - set res -} {{1 1 1} {1 1 1} {1 1 1} {1 1 1} {1 1 1} {1 1 1} {1 1 1} {1 1 1}} - -deleteWindows - -option clear - -# cleanup -::tcltest::cleanupTests -return |