tk/tests/menubut.test

   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
  15 package require tcltest 2.1
  16 namespace import -force tcltest::configure
  17 namespace import -force tcltest::testsDirectory
  18 configure -testdir [file join [pwd] [file dirname [info script]]]
  19 configure -loadfile [file join [testsDirectory] constraints.tcl]
  20 tcltest::loadTestedCommands
  21
  22 # Create entries in the option database to be sure that geometry options
  23 # like border width have predictable values.
  24
  25 option add *Menubutton.borderWidth 2
  26 option add *Menubutton.highlightThickness 2
  27 option add *Menubutton.font {Helvetica -12 bold}
  28 option add *Button.borderWidth 2
  29 option add *Button.highlightThickness 2
  30 option add *Button.font {Helvetica -12 bold}
  31
  32 eval image delete [image names]
  33 if {[testConstraint testImageType]} {
  34     image create test image1
  35 }
  36 menubutton .mb -text "Test"
  37 pack .mb
  38 update
  39 set i 1
  40 foreach 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
  92 test menubutton-2.1 {Tk_MenubuttonCmd procedure} {
  93     list [catch {menubutton} msg] $msg
  94 } {1 {wrong # args: should be "menubutton pathName ?options?"}}
  95 test menubutton-2.2 {Tk_MenubuttonCmd procedure} {
  96     list [catch {menubutton foo} msg] $msg
  97 } {1 {bad window path name "foo"}}
  98 test menubutton-2.3 {Tk_MenubuttonCmd procedure} {
  99     catch {destroy .mb}
 100     menubutton .mb
 101     winfo class .mb
 102 } {Menubutton}
 103 test 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
 108 catch {destroy .mb}
 109 menubutton .mb -text "Test Menu"
 110 pack .mb
 111 test menubutton-3.1 {MenuButtonWidgetCmd procedure} {
 112     list [catch {.mb} msg] $msg
 113 } {1 {wrong # args: should be ".mb option ?arg arg ...?"}}
 114 test menubutton-3.2 {ButtonWidgetCmd procedure, "cget" option} {
 115     list [catch {.mb c} msg] $msg
 116 } {1 {ambiguous option "c": must be cget or configure}}
 117 test menubutton-3.3 {ButtonWidgetCmd procedure, "cget" option} {
 118     list [catch {.mb cget} msg] $msg
 119 } {1 {wrong # args: should be ".mb cget option"}}
 120 test 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"}}
 123 test menubutton-3.5 {ButtonWidgetCmd procedure, "cget" option} {
 124     list [catch {.mb cget -gorp} msg] $msg
 125 } {1 {unknown option "-gorp"}}
 126 test menubutton-3.6 {ButtonWidgetCmd procedure, "cget" option} {
 127     .mb configure -highlightthickness 3
 128     .mb cget -highlightthickness
 129 } {3}
 130 test menubutton-3.7 {ButtonWidgetCmd procedure, "configure" option} {
 131     llength [.mb configure]
 132 } {33}
 133 test menubutton-3.8 {ButtonWidgetCmd procedure, "configure" option} {
 134     list [catch {.mb configure -gorp} msg] $msg
 135 } {1 {unknown option "-gorp"}}
 136 test menubutton-3.9 {ButtonWidgetCmd procedure, "configure" option} {
 137     list [catch {.mb co -bg #ffffff -fg} msg] $msg
 138 } {1 {value for "-fg" missing}}
 139 test 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}
 144 test 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
 151 test 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"}}
 159 test 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"}}
 167 test 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"}}
 175 test 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"}}
 185 test 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}
 193 test 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
 202 test 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
 213 test menubutton-6.1 {MenuButtonCmdDeletedProc procedure} {
 214     deleteWindows
 215     menubutton .mb1
 216     rename .mb1 {}
 217     list [info command .mb*] [winfo children .]
 218 } {{} {}}
 219
 220 test 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}
 226 test 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}
 232 test 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}
 238 test 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}
 245 test 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}
 252 test 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}
 259 test 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}
 266 test 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}
 273 test 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}
 280 test 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}
 287 test 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}
 294 test 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}
 301 test 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}
 308 test 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}
 318 test 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
 329 set l [interp hidden]
 330 deleteWindows
 331
 332 test 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
 340 eval image delete [image names]
 341 deleteWindows
 342 option clear
 343
 344 # cleanup
 345 ::tcltest::cleanupTests
 346 return
 347
 348
 349
 350
 351
 352
 353
 354
 355
 356
 357
 358
 359