diff options
Diffstat (limited to 'tk/tests/menubut.test')
| -rw-r--r-- | tk/tests/menubut.test | 352 |
1 files changed, 352 insertions, 0 deletions
diff --git a/tk/tests/menubut.test b/tk/tests/menubut.test new file mode 100644 index 00000000000..eb510cfe823 --- /dev/null +++ b/tk/tests/menubut.test @@ -0,0 +1,352 @@ +# This file is a Tcl script to test menubuttons in Tk. 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. +# +# RCS: @(#) $Id$ + +# XXX This test file is woefully incomplete right now. If any part +# XXX of a procedure has tests then the whole procedure has tests, +# XXX but many procedures have no tests. + +if {[lsearch [image types] test] < 0} { + puts "This application hasn't been compiled with the \"test\" image" + puts "type, 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 . + +# Create entries in the option database to be sure that geometry options +# like border width have predictable values. + +option add *Menubutton.borderWidth 2 +option add *Menubutton.highlightThickness 2 +option add *Menubutton.font {Helvetica -12 bold} +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 +menubutton .mb -text "Test" +pack .mb +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"}} + {-bd 4 4 badValue {bad screen distance "badValue"}} + {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} + {-bitmap questhead questhead badValue {bitmap "badValue" not defined}} + {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} + {-cursor arrow arrow badValue {bad cursor spec "badValue"}} + {-direction below below badValue {bad direction value "badValue": must be above, below, left, right, or flush}} + {-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}} + {-menu "any old string" "any old string" {} {}} + {-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}} + {-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 menubutton-1.$i {configuration options} { + .mb configure $name [lindex $test 1] + lindex [.mb configure $name] 4 + } [lindex $test 2] + incr i + if {[lindex $test 3] != ""} { + test menubutton-1.$i {configuration options} { + list [catch {.mb configure $name [lindex $test 3]} msg] $msg + } [list 1 [lindex $test 4]] + } + .mb configure $name [lindex [.mb configure $name] 3] + incr i +} + +test menubutton-2.1 {Tk_MenubuttonCmd procedure} { + list [catch {menubutton} msg] $msg +} {1 {wrong # args: should be "menubutton pathName ?options?"}} +test menubutton-2.2 {Tk_MenubuttonCmd procedure} { + list [catch {menubutton foo} msg] $msg +} {1 {bad window path name "foo"}} +test menubutton-2.3 {Tk_MenubuttonCmd procedure} { + catch {destroy .mb} + menubutton .mb + winfo class .mb +} {Menubutton} +test menubutton-2.4 {Tk_ButtonCmd procedure} { + catch {destroy .mb} + list [catch {menubutton .mb -gorp foo} msg] $msg [winfo exists .mb] +} {1 {unknown option "-gorp"} 0} + +catch {destroy .mb} +menubutton .mb -text "Test Menu" +pack .mb +test menubutton-3.1 {MenuButtonWidgetCmd procedure} { + list [catch {.mb} msg] $msg +} {1 {wrong # args: should be ".mb option ?arg arg ...?"}} +test menubutton-3.2 {ButtonWidgetCmd procedure, "cget" option} { + list [catch {.mb c} msg] $msg +} {1 {bad option "c": must be cget or configure}} +test menubutton-3.3 {ButtonWidgetCmd procedure, "cget" option} { + list [catch {.mb cget} msg] $msg +} {1 {wrong # args: should be ".mb cget option"}} +test menubutton-3.4 {ButtonWidgetCmd procedure, "cget" option} { + list [catch {.mb cget a b} msg] $msg +} {1 {wrong # args: should be ".mb cget option"}} +test menubutton-3.5 {ButtonWidgetCmd procedure, "cget" option} { + list [catch {.mb cget -gorp} msg] $msg +} {1 {unknown option "-gorp"}} +test menubutton-3.6 {ButtonWidgetCmd procedure, "cget" option} { + .mb configure -highlightthickness 3 + .mb cget -highlightthickness +} {3} +test menubutton-3.7 {ButtonWidgetCmd procedure, "configure" option} { + llength [.mb configure] +} {32} +test menubutton-3.8 {ButtonWidgetCmd procedure, "configure" option} { + list [catch {.mb configure -gorp} msg] $msg +} {1 {unknown option "-gorp"}} +test menubutton-3.9 {ButtonWidgetCmd procedure, "configure" option} { + list [catch {.mb co -bg #ffffff -fg} msg] $msg +} {1 {value for "-fg" missing}} +test menubutton-3.10 {ButtonWidgetCmd procedure, "configure" option} { + .mb configure -fg #123456 + .mb configure -bg #654321 + lindex [.mb configure -fg] 4 +} {#123456} +test menubutton-3.11 {ButtonWidgetCmd procedure, "configure" option} { + list [catch {.mb foobar} msg] $msg +} {1 {bad option "foobar": must be cget or configure}} + +# XXX Need to add tests for several procedures here. The tests for XXX +# XXX ConfigureMenuButton aren't complete either. XXX + +test menubutton-4.1 {ConfigureMenuButton procedure} { + catch {destroy .mb1} + button .mb1 -text "Menubutton 1" + list [catch {.mb1 configure -width 1i} msg] $msg $errorInfo +} {1 {expected integer but got "1i"} {expected integer but got "1i" + (processing -width option) + invoked from within +".mb1 configure -width 1i"}} +test menubutton-4.2 {ConfigureMenuButton procedure} { + catch {destroy .mb1} + button .mb1 -text "Menubutton 1" + list [catch {.mb1 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 +".mb1 configure -height 0.5c"}} +test menubutton-4.3 {ConfigureMenuButton procedure} { + catch {destroy .mb1} + button .mb1 -bitmap questhead + list [catch {.mb1 configure -width abc} msg] $msg $errorInfo +} {1 {bad screen distance "abc"} {bad screen distance "abc" + (processing -width option) + invoked from within +".mb1 configure -width abc"}} +test menubutton-4.4 {ConfigureMenuButton procedure} { + catch {destroy .mb1} + eval image delete [image names] + image create test image1 + button .mb1 -image image1 + list [catch {.mb1 configure -height 0.5x} msg] $msg $errorInfo +} {1 {bad screen distance "0.5x"} {bad screen distance "0.5x" + (processing -height option) + invoked from within +".mb1 configure -height 0.5x"}} +test menubutton-4.5 {ConfigureMenuButton procedure} {fonts} { + catch {destroy .mb1} + button .mb1 -text "Sample text" -width 10 -height 2 + pack .mb1 + set result "[winfo reqwidth .mb1] [winfo reqheight .mb1]" + .mb1 configure -bitmap questhead + lappend result [winfo reqwidth .mb1] [winfo reqheight .mb1] +} {102 46 20 12} +test menubutton-4.6 {ConfigureMenuButton procedure - bad direction} { + catch {destroy .mb} + menubutton .mb -text "Test" + list [catch {.mb configure -direction badValue} msg] $msg \ + [.mb cget -direction] [destroy .mb] +} {1 {bad direction value "badValue": must be above, below, left, right, or flush} below {}} + +# XXX Need to add tests for several procedures here. XXX + +test menubutton-5.1 {MenuButtonEventProc procedure} { + eval destroy [winfo children .] + menubutton .mb1 -bg #543210 + rename .mb1 .mb2 + set x {} + lappend x [winfo children .] + lappend x [.mb2 cget -bg] + destroy .mb1 + lappend x [info command .mb*] [winfo children .] +} {.mb1 #543210 {} {}} + +test menubutton-6.1 {MenuButtonCmdDeletedProc procedure} { + eval destroy [winfo children .] + menubutton .mb1 + rename .mb1 {} + list [info command .mb*] [winfo children .] +} {{} {}} + +test menubutton-7.1 {ComputeMenuButtonGeometry procedure} { + catch {destroy .mb} + menubutton .mb -image image1 -bd 4 -highlightthickness 0 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {38 23} +test menubutton-7.2 {ComputeMenuButtonGeometry procedure} { + catch {destroy .mb} + menubutton .mb -image image1 -bd 1 -highlightthickness 2 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {36 21} +test menubutton-7.3 {ComputeMenuButtonGeometry procedure} { + catch {destroy .mb} + menubutton .mb -image image1 -bd 0 -highlightthickness 2 -padx 5 -pady 5 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {34 19} +test menubutton-7.4 {ComputeMenuButtonGeometry procedure} { + catch {destroy .mb} + menubutton .mb -image image1 -bd 2 -relief raised -width 40 \ + -highlightthickness 2 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {48 23} +test menubutton-7.5 {ComputeMenuButtonGeometry procedure} { + catch {destroy .mb} + menubutton .mb -image image1 -bd 2 -relief raised -height 30 \ + -highlightthickness 2 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {38 38} +test menubutton-7.6 {ComputeMenuButtonGeometry procedure} { + catch {destroy .mb} + menubutton .mb -bitmap question -bd 2 -relief raised \ + -highlightthickness 2 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {25 35} +test menubutton-7.7 {ComputeMenuButtonGeometry procedure} { + catch {destroy .mb} + menubutton .mb -bitmap question -bd 2 -relief raised -width 40 \ + -highlightthickness 1 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {46 33} +test menubutton-7.8 {ComputeMenuButtonGeometry procedure} { + catch {destroy .mb} + menubutton .mb -bitmap question -bd 2 -relief raised -height 50 \ + -highlightthickness 1 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {23 56} +test menubutton-7.9 {ComputeMenuButtonGeometry procedure} {fonts} { + catch {destroy .mb} + menubutton .mb -text String -bd 2 -relief raised -padx 0 -pady 0 \ + -highlightthickness 1 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {42 20} +test menubutton-7.10 {ComputeMenuButtonGeometry procedure} {fonts} { + catch {destroy .mb} + menubutton .mb -text String -bd 2 -relief raised -width 20 \ + -padx 0 -pady 0 -highlightthickness 1 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {146 20} +test menubutton-7.11 {ComputeMenuButtonGeometry procedure} {fonts} { + catch {destroy .mb} + menubutton .mb -text String -bd 2 -relief raised -height 2 \ + -padx 0 -pady 0 -highlightthickness 1 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {42 34} +test menubutton-7.12 {ComputeMenuButtonGeometry procedure} {fonts} { + catch {destroy .mb} + menubutton .mb -text String -bd 2 -relief raised -padx 10 -pady 5 \ + -highlightthickness 1 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {62 30} +test menubutton-7.13 {ComputeMenuButtonGeometry procedure} {fonts} { + catch {destroy .mb} + menubutton .mb -text String -bd 2 -relief raised \ + -highlightthickness 1 -indicatoron 1 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {78 28} +test menubutton-7.14 {ComputeMenuButtonGeometry procedure} {unix nonPortable} { + # The following test is non-portable because the indicator's pixel + # size varies to maintain constant absolute size. + + catch {destroy .mb} + menubutton .mb -image image1 -bd 2 -relief raised \ + -highlightthickness 2 -indicatoron 1 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {64 23} +test menubutton-7.15 {ComputeMenuButtonGeometry procedure} {pc nonPortable} { + # The following test is non-portable because the indicator's pixel + # size varies to maintain constant absolute size. + + catch {destroy .mb} + menubutton .mb -image image1 -bd 2 -relief raised \ + -highlightthickness 2 -indicatoron 1 + pack .mb + list [winfo reqwidth .mb] [winfo reqheight .mb] +} {65 23} + +set l [interp hidden] +eval destroy [winfo children .] + +test menubutton-8.1 {menubutton vs hidden commands} { + catch {destroy .mb} + menubutton .mb + interp hide {} .mb + destroy .mb + list [winfo children .] [interp hidden] +} [list {} $l] + +eval image delete [image names] +eval destroy [winfo children .] +option clear + |