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