summaryrefslogtreecommitdiffstats
path: root/tests/menubut.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/menubut.test')
-rw-r--r--tests/menubut.test352
1 files changed, 352 insertions, 0 deletions
diff --git a/tests/menubut.test b/tests/menubut.test
new file mode 100644
index 0000000..8a5c14a
--- /dev/null
+++ b/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.
+#
+# SCCS: @(#) menubut.test 1.26 97/07/31 10:08:50
+
+# 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
+