1# This file is a Tcl script to test menubuttons in Tk. It is 2# organized in the standard fashion for Tcl tests. 3# 4# Copyright (c) 1994 The Regents of the University of California. 5# Copyright (c) 1994-1996 Sun Microsystems, Inc. 6# Copyright (c) 1998-1999 by Scriptics Corporation. 7# All rights reserved. 8# 9# RCS: @(#) $Id$ 10 11# XXX This test file is woefully incomplete right now. If any part 12# XXX of a procedure has tests then the whole procedure has tests, 13# XXX but many procedures have no tests. 14 15package require tcltest 2.1 16eval tcltest::configure $argv 17tcltest::loadTestedCommands 18 19# Create entries in the option database to be sure that geometry options 20# like border width have predictable values. 21 22option add *Menubutton.borderWidth 2 23option add *Menubutton.highlightThickness 2 24option add *Menubutton.font {Helvetica -12 bold} 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} 33menubutton .mb -text "Test" 34pack .mb 35update 36set i 1 37foreach test { 38 {-activebackground #012345 #012345 non-existent 39 {unknown color name "non-existent"}} 40 {-activeforeground #ff0000 #ff0000 non-existent 41 {unknown color name "non-existent"}} 42 {-anchor nw nw bogus {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}} 43 {-background #ff0000 #ff0000 non-existent 44 {unknown color name "non-existent"}} 45 {-bd 4 4 badValue {bad screen distance "badValue"}} 46 {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} 47 {-bitmap questhead questhead badValue {bitmap "badValue" not defined}} 48 {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} 49 {-cursor arrow arrow badValue {bad cursor spec "badValue"}} 50 {-direction below below badValue {bad direction "badValue": must be above, below, flush, left, or right}} 51 {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}} 52 {-fg #110022 #110022 bogus {unknown color name "bogus"}} 53 {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist}} 54 {-foreground #110022 #110022 bogus {unknown color name "bogus"}} 55 {-height 18 18 20.0 {expected integer but got "20.0"}} 56 {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} 57 {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}} 58 {-highlightthickness 18 18 badValue {bad screen distance "badValue"}} 59 {-image image1 image1 bogus {image "bogus" doesn't exist}} 60 {-indicatoron yes 1 no_way {expected boolean value but got "no_way"}} 61 {-justify right right bogus {bad justification "bogus": must be left, right, or center}} 62 {-menu "any old string" "any old string" {} {}} 63 {-padx 12 12 420x {bad screen distance "420x"}} 64 {-pady 12 12 420x {bad screen distance "420x"}} 65 {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}} 66 {-state normal normal bogus {bad state "bogus": must be active, disabled, or normal}} 67 {-takefocus "any string" "any string" {} {}} 68 {-text "Sample text" {Sample text} {} {}} 69 {-textvariable i i {} {}} 70 {-underline 5 5 3p {expected integer but got "3p"}} 71 {-width 402 402 3p {expected integer but got "3p"}} 72 {-wraplength 100 100 6x {bad screen distance "6x"}} 73} { 74 set name [lindex $test 0] 75 test menubutton-1.$i {configuration options} testImageType { 76 .mb configure $name [lindex $test 1] 77 lindex [.mb configure $name] 4 78 } [lindex $test 2] 79 incr i 80 if {[lindex $test 3] != ""} { 81 test menubutton-1.$i {configuration options} { 82 list [catch {.mb configure $name [lindex $test 3]} msg] $msg 83 } [list 1 [lindex $test 4]] 84 } 85 .mb configure $name [lindex [.mb configure $name] 3] 86 incr i 87} 88 89test menubutton-2.1 {Tk_MenubuttonCmd procedure} { 90 list [catch {menubutton} msg] $msg 91} {1 {wrong # args: should be "menubutton pathName ?options?"}} 92test menubutton-2.2 {Tk_MenubuttonCmd procedure} { 93 list [catch {menubutton foo} msg] $msg 94} {1 {bad window path name "foo"}} 95test menubutton-2.3 {Tk_MenubuttonCmd procedure} { 96 catch {destroy .mb} 97 menubutton .mb 98 winfo class .mb 99} {Menubutton} 100test menubutton-2.4 {Tk_ButtonCmd procedure} { 101 catch {destroy .mb} 102 list [catch {menubutton .mb -gorp foo} msg] $msg [winfo exists .mb] 103} {1 {unknown option "-gorp"} 0} 104 105catch {destroy .mb} 106menubutton .mb -text "Test Menu" 107pack .mb 108test menubutton-3.1 {MenuButtonWidgetCmd procedure} { 109 list [catch {.mb} msg] $msg 110} {1 {wrong # args: should be ".mb option ?arg arg ...?"}} 111test menubutton-3.2 {ButtonWidgetCmd procedure, "cget" option} { 112 list [catch {.mb c} msg] $msg 113} {1 {ambiguous option "c": must be cget or configure}} 114test menubutton-3.3 {ButtonWidgetCmd procedure, "cget" option} { 115 list [catch {.mb cget} msg] $msg 116} {1 {wrong # args: should be ".mb cget option"}} 117test menubutton-3.4 {ButtonWidgetCmd procedure, "cget" option} { 118 list [catch {.mb cget a b} msg] $msg 119} {1 {wrong # args: should be ".mb cget option"}} 120test menubutton-3.5 {ButtonWidgetCmd procedure, "cget" option} { 121 list [catch {.mb cget -gorp} msg] $msg 122} {1 {unknown option "-gorp"}} 123test menubutton-3.6 {ButtonWidgetCmd procedure, "cget" option} { 124 .mb configure -highlightthickness 3 125 .mb cget -highlightthickness 126} {3} 127test menubutton-3.7 {ButtonWidgetCmd procedure, "configure" option} { 128 llength [.mb configure] 129} {33} 130test menubutton-3.8 {ButtonWidgetCmd procedure, "configure" option} { 131 list [catch {.mb configure -gorp} msg] $msg 132} {1 {unknown option "-gorp"}} 133test menubutton-3.9 {ButtonWidgetCmd procedure, "configure" option} { 134 list [catch {.mb co -bg #ffffff -fg} msg] $msg 135} {1 {value for "-fg" missing}} 136test menubutton-3.10 {ButtonWidgetCmd procedure, "configure" option} { 137 .mb configure -fg #123456 138 .mb configure -bg #654321 139 lindex [.mb configure -fg] 4 140} {#123456} 141test menubutton-3.11 {ButtonWidgetCmd procedure, "configure" option} { 142 list [catch {.mb foobar} msg] $msg 143} {1 {bad option "foobar": must be cget or configure}} 144 145# XXX Need to add tests for several procedures here. The tests for XXX 146# XXX ConfigureMenuButton aren't complete either. XXX 147 148test menubutton-4.1 {ConfigureMenuButton procedure} { 149 catch {destroy .mb1} 150 button .mb1 -text "Menubutton 1" 151 list [catch {.mb1 configure -width 1i} msg] $msg $errorInfo 152} {1 {expected integer but got "1i"} {expected integer but got "1i" 153 (processing -width option) 154 invoked from within 155".mb1 configure -width 1i"}} 156test menubutton-4.2 {ConfigureMenuButton procedure} { 157 catch {destroy .mb1} 158 button .mb1 -text "Menubutton 1" 159 list [catch {.mb1 configure -height 0.5c} msg] $msg $errorInfo 160} {1 {expected integer but got "0.5c"} {expected integer but got "0.5c" 161 (processing -height option) 162 invoked from within 163".mb1 configure -height 0.5c"}} 164test menubutton-4.3 {ConfigureMenuButton procedure} { 165 catch {destroy .mb1} 166 button .mb1 -bitmap questhead 167 list [catch {.mb1 configure -width abc} msg] $msg $errorInfo 168} {1 {bad screen distance "abc"} {bad screen distance "abc" 169 (processing -width option) 170 invoked from within 171".mb1 configure -width abc"}} 172test menubutton-4.4 {ConfigureMenuButton procedure} testImageType { 173 catch {destroy .mb1} 174 eval image delete [image names] 175 image create test image1 176 button .mb1 -image image1 177 list [catch {.mb1 configure -height 0.5x} msg] $msg $errorInfo 178} {1 {bad screen distance "0.5x"} {bad screen distance "0.5x" 179 (processing -height option) 180 invoked from within 181".mb1 configure -height 0.5x"}} 182test menubutton-4.5 {ConfigureMenuButton procedure} {nonPortable fonts} { 183 catch {destroy .mb1} 184 button .mb1 -text "Sample text" -width 10 -height 2 185 pack .mb1 186 set result "[winfo reqwidth .mb1] [winfo reqheight .mb1]" 187 .mb1 configure -bitmap questhead 188 lappend result [winfo reqwidth .mb1] [winfo reqheight .mb1] 189} {102 46 20 12} 190test menubutton-4.6 {ConfigureMenuButton procedure - bad direction} { 191 catch {destroy .mb} 192 menubutton .mb -text "Test" 193 list [catch {.mb configure -direction badValue} msg] $msg \ 194 [.mb cget -direction] [destroy .mb] 195} {1 {bad direction "badValue": must be above, below, flush, left, or right} below {}} 196 197# XXX Need to add tests for several procedures here. XXX 198 199test menubutton-5.1 {MenuButtonEventProc procedure} { 200 deleteWindows 201 menubutton .mb1 -bg #543210 202 rename .mb1 .mb2 203 set x {} 204 lappend x [winfo children .] 205 lappend x [.mb2 cget -bg] 206 destroy .mb1 207 lappend x [info command .mb*] [winfo children .] 208} {.mb1 #543210 {} {}} 209 210test menubutton-6.1 {MenuButtonCmdDeletedProc procedure} { 211 deleteWindows 212 menubutton .mb1 213 rename .mb1 {} 214 list [info command .mb*] [winfo children .] 215} {{} {}} 216 217test menubutton-7.1 {ComputeMenuButtonGeometry procedure} testImageType { 218 catch {destroy .mb} 219 menubutton .mb -image image1 -bd 4 -highlightthickness 0 220 pack .mb 221 list [winfo reqwidth .mb] [winfo reqheight .mb] 222} {38 23} 223test menubutton-7.2 {ComputeMenuButtonGeometry procedure} testImageType { 224 catch {destroy .mb} 225 menubutton .mb -image image1 -bd 1 -highlightthickness 2 226 pack .mb 227 list [winfo reqwidth .mb] [winfo reqheight .mb] 228} {36 21} 229test menubutton-7.3 {ComputeMenuButtonGeometry procedure} testImageType { 230 catch {destroy .mb} 231 menubutton .mb -image image1 -bd 0 -highlightthickness 2 -padx 5 -pady 5 232 pack .mb 233 list [winfo reqwidth .mb] [winfo reqheight .mb] 234} {34 19} 235test menubutton-7.4 {ComputeMenuButtonGeometry procedure} testImageType { 236 catch {destroy .mb} 237 menubutton .mb -image image1 -bd 2 -relief raised -width 40 \ 238 -highlightthickness 2 239 pack .mb 240 list [winfo reqwidth .mb] [winfo reqheight .mb] 241} {48 23} 242test menubutton-7.5 {ComputeMenuButtonGeometry procedure} testImageType { 243 catch {destroy .mb} 244 menubutton .mb -image image1 -bd 2 -relief raised -height 30 \ 245 -highlightthickness 2 246 pack .mb 247 list [winfo reqwidth .mb] [winfo reqheight .mb] 248} {38 38} 249test menubutton-7.6 {ComputeMenuButtonGeometry procedure} { 250 catch {destroy .mb} 251 menubutton .mb -bitmap question -bd 2 -relief raised \ 252 -highlightthickness 2 253 pack .mb 254 list [winfo reqwidth .mb] [winfo reqheight .mb] 255} {25 35} 256test menubutton-7.7 {ComputeMenuButtonGeometry procedure} { 257 catch {destroy .mb} 258 menubutton .mb -bitmap question -bd 2 -relief raised -width 40 \ 259 -highlightthickness 1 260 pack .mb 261 list [winfo reqwidth .mb] [winfo reqheight .mb] 262} {46 33} 263test menubutton-7.8 {ComputeMenuButtonGeometry procedure} { 264 catch {destroy .mb} 265 menubutton .mb -bitmap question -bd 2 -relief raised -height 50 \ 266 -highlightthickness 1 267 pack .mb 268 list [winfo reqwidth .mb] [winfo reqheight .mb] 269} {23 56} 270test menubutton-7.9 {ComputeMenuButtonGeometry procedure} {fonts} { 271 catch {destroy .mb} 272 menubutton .mb -text String -bd 2 -relief raised -padx 0 -pady 0 \ 273 -highlightthickness 1 274 pack .mb 275 list [winfo reqwidth .mb] [winfo reqheight .mb] 276} {42 20} 277test menubutton-7.10 {ComputeMenuButtonGeometry procedure} {fonts} { 278 catch {destroy .mb} 279 menubutton .mb -text String -bd 2 -relief raised -width 20 \ 280 -padx 0 -pady 0 -highlightthickness 1 281 pack .mb 282 list [winfo reqwidth .mb] [winfo reqheight .mb] 283} {146 20} 284test menubutton-7.11 {ComputeMenuButtonGeometry procedure} {fonts} { 285 catch {destroy .mb} 286 menubutton .mb -text String -bd 2 -relief raised -height 2 \ 287 -padx 0 -pady 0 -highlightthickness 1 288 pack .mb 289 list [winfo reqwidth .mb] [winfo reqheight .mb] 290} {42 34} 291test menubutton-7.12 {ComputeMenuButtonGeometry procedure} {fonts} { 292 catch {destroy .mb} 293 menubutton .mb -text String -bd 2 -relief raised -padx 10 -pady 5 \ 294 -highlightthickness 1 295 pack .mb 296 list [winfo reqwidth .mb] [winfo reqheight .mb] 297} {62 30} 298test menubutton-7.13 {ComputeMenuButtonGeometry procedure} {nonPortable fonts} { 299 catch {destroy .mb} 300 menubutton .mb -text String -bd 2 -relief raised \ 301 -highlightthickness 1 -indicatoron 1 302 pack .mb 303 list [winfo reqwidth .mb] [winfo reqheight .mb] 304} {78 28} 305test menubutton-7.14 {ComputeMenuButtonGeometry procedure} {testImageType unix nonPortable} { 306 # The following test is non-portable because the indicator's pixel 307 # size varies to maintain constant absolute size. 308 309 catch {destroy .mb} 310 menubutton .mb -image image1 -bd 2 -relief raised \ 311 -highlightthickness 2 -indicatoron 1 312 pack .mb 313 list [winfo reqwidth .mb] [winfo reqheight .mb] 314} {64 23} 315test menubutton-7.15 {ComputeMenuButtonGeometry procedure} {testImageType win nonPortable} { 316 # The following test is non-portable because the indicator's pixel 317 # size varies to maintain constant absolute size. 318 319 catch {destroy .mb} 320 menubutton .mb -image image1 -bd 2 -relief raised \ 321 -highlightthickness 2 -indicatoron 1 322 pack .mb 323 list [winfo reqwidth .mb] [winfo reqheight .mb] 324} {65 23} 325 326set l [interp hidden] 327deleteWindows 328 329test menubutton-8.1 {menubutton vs hidden commands} { 330 catch {destroy .mb} 331 menubutton .mb 332 interp hide {} .mb 333 destroy .mb 334 list [winfo children .] [interp hidden] 335} [list {} $l] 336 337eval image delete [image names] 338deleteWindows 339option clear 340 341# cleanup 342cleanupTests 343return 344