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