tk/tests/menuDraw.test

   1 # This file is a Tcl script to test drawing of menus in Tk.  It is
   2 # organized in the standard fashion for Tcl tests.
   3 #
   4 # Copyright (c) 1996-1997 Sun Microsystems, Inc.
   5 # Copyright (c) 1998-1999 by Scriptics Corporation.
   6 # All rights reserved.
   7 #
   8 # RCS: @(#) $Id$
   9
  10 if {[lsearch [namespace children] ::tcltest] == -1} {
  11     source [file join [pwd] [file dirname [info script]] defs.tcl]
  12 }
  13
  14 if {[lsearch [image types] test] < 0} {
  15     puts "This application hasn't been compiled with the \"test\" image"
  16     puts "type, so I can't run this test.  Are you sure you're using"
  17     puts "tktest instead of wish?"
  18     ::tcltest::cleanupTests
  19     return
  20 }
  21
  22 proc deleteWindows {} {
  23     foreach i [winfo children .] {
  24         catch [destroy $i]
  25     }
  26 }
  27
  28 deleteWindows
  29 wm geometry . {}
  30 raise .
  31
  32 test menuDraw-1.1 {TkMenuInitializeDrawingFields} {
  33     catch {destroy .m1}
  34     list [menu .m1] [destroy .m1]
  35 } {.m1 {}}
  36
  37 test menuDraw-2.1 {TkIntializeMenuEntryDrawingFields} {
  38     catch {destroy .m1}
  39     menu .m1
  40     list [.m1 add command] [destroy .m1]
  41 } {{} {}}
  42
  43 test menuDraw-3.1 {TkMenuFreeDrawOptions} {
  44     catch {destroy .m1}
  45     menu .m1
  46     list [destroy .m1]
  47 } {{}}
  48
  49 test menuDraw-4.1 {TkMenuEntryFreeDrawOptions} {
  50     catch {destroy .m1}
  51     menu .m1
  52     .m1 add command -label "This is a test"
  53     list [destroy .m1]
  54 } {{}}
  55 test menuDraw-4.2 {TkMenuEntryFreeDrawOptions} {
  56         catch {destroy .m1}
  57         menu .m1
  58         .m1 add checkbutton -label "This is a test." -font "Courier 12" -activeforeground red -background green -selectcolor purple
  59         list [destroy .m1]
  60 } {{}}
  61
  62 test menuDraw-5.1 {TkMenuConfigureDrawOptions - new menu} {
  63     catch {destroy .m1}
  64     list [menu .m1] [destroy .m1]
  65 } {.m1 {}}
  66 test menuDraw-5.2 {TkMenuConfigureDrawOptions - old menu} {
  67     catch {destroy .m1}
  68     menu .m1
  69     list [.m1 configure -fg red] [destroy .m1]
  70 } {{} {}}
  71 test menuDraw-5.3 {TkMenuConfigureDrawOptions - no disabledFg} {
  72         catch {destroy .m1}
  73         list [menu .m1 -disabledforeground ""] [destroy .m1]
  74 } {.m1 {}}
  75
  76 test menuDraw-6.1 {TkMenuConfigureEntryDrawOptions - no tkfont specified} {
  77     catch {destroy .m1}
  78     menu .m1
  79     list [.m1 add command -label "foo"] [destroy .m1]
  80 } {{} {}}
  81 test menuDraw-6.2 {TkMenuConfigureEntryDrawOptions - tkfont specified} {
  82     catch {destroy .m1}
  83     menu .m1
  84     list [.m1 add command -label "foo" -font "Courier 12"] [destroy .m1]
  85 } {{} {}}
  86 test menuDraw-6.3 {TkMenuConfigureEntryDrawOptions - active state - wrong entry} {
  87     catch {destroy .m1}
  88     menu .m1
  89     .m1 add command -label "foo"
  90     list [.m1 entryconfigure 1 -state active] [destroy .m1]
  91 } {{} {}}
  92 test menuDraw-6.4 {TkMenuConfigureEntryDrawOptions - active state - correct entry} {
  93     catch {destroy .m1}
  94     menu .m1
  95     .m1 add command -label "foo"
  96     .m1 activate 1
  97     list [.m1 entryconfigure 1 -state active] [destroy .m1]
  98 } {{} {}}
  99 test menuDraw-6.5 {TkMenuConfigureEntryDrawOptions - deactivate entry} {
 100     catch {destroy .m1}
 101     menu .m1
 102     .m1 add command -label "foo"
 103     .m1 activate 1
 104     list [.m1 entryconfigure 1 -state normal] [destroy .m1]
 105 } {{} {}}
 106 test menuDraw-6.6 {TkMenuConfigureEntryDrawOptions - bad state} {
 107     catch {destroy .m1}
 108     menu .m1
 109     .m1 add command -label "foo"
 110     list [catch {.m1 entryconfigure 1 -state foo} msg] $msg [destroy .m1]
 111 } {1 {bad state "foo": must be active, normal, or disabled} {}}
 112 test menuDraw-6.7 {TkMenuConfigureEntryDrawOptions - tkfont specified} {
 113     catch {destroy .m1}
 114     menu .m1
 115     list [.m1 add command -label "foo" -font "Courier 12"] [destroy .m1]
 116 } {{} {}}
 117 test menuDraw-6.8 {TkMenuConfigureEntryDrawOptions - border specified} {
 118     catch {destroy .m1}
 119     menu .m1
 120     list [.m1 add command -label "foo" -background "red"] [destroy .m1]
 121 } {{} {}}
 122 test menuDraw-6.9 {TkMenuConfigureEntryDrawOptions - foreground specified} {
 123     catch {destroy .m1}
 124     menu .m1
 125     list [.m1 add command -label "foo" -foreground "red"] [destroy .m1]
 126 } {{} {}}
 127 test menuDraw-6.10 {TkMenuConfigureEntryDrawOptions - activeBorder specified} {
 128     catch {destroy .m1}
 129     menu .m1
 130     list [.m1 add command -label "foo" -activebackground "red"] [destroy .m1]
 131 } {{} {}}
 132 test menuDraw-6.11 {TkMenuConfigureEntryDrawOptions - activeforeground specified} {
 133     catch {destroy .m1}
 134     menu .m1
 135     list [.m1 add command -label "foo" -activeforeground "red"] [destroy .m1]
 136 } {{} {}}
 137 test menuDraw-6.12 {TkMenuConfigureEntryDrawOptions - selectcolor specified} {
 138     catch {destroy .m1}
 139     menu .m1
 140     list [.m1 add radiobutton -label "foo" -selectcolor "red"] [destroy .m1]
 141 } {{} {}}
 142 test menuDraw-6.13 {TkMenuConfigureEntryDrawOptions - textGC disposal} {
 143     catch {destroy .m1}
 144     menu .m1
 145     .m1 add command -label "foo" -font "Helvetica 12"
 146     list [.m1 entryconfigure 1 -font "Courier 12"] [destroy .m1]
 147 } {{} {}}
 148 test menuDraw-6.14 {TkMenuConfigureEntryDrawOptions - activeGC disposal} {
 149     catch {destroy .m1}
 150     menu .m1
 151     .m1 add command -label "foo" -activeforeground "red"
 152     list [.m1 entryconfigure 1 -activeforeground "green"] [destroy .m1]
 153 } {{} {}}
 154 test menuDraw-6.15 {TkMenuConfigureEntryDrawOptions - disabledGC disposal} {
 155     catch {destroy .m1}
 156     menu .m1 -disabledforeground "red"
 157     .m1 add command -label "foo"
 158     list [.m1 configure -disabledforeground "green"] [destroy .m1]
 159 } {{} {}}
 160 test menuDraw-6.16 {TkMenuConfigureEntryDrawOptions - indicatorGC disposal} {
 161     catch {destroy .m1}
 162     menu .m1
 163     .m1 add radiobutton -label "foo" -selectcolor "red"
 164     list [.m1 entryconfigure 1 -selectcolor "green"] [destroy .m1]
 165 } {{} {}}
 166
 167 test menuDraw-7.1 {TkEventuallyRecomputeMenu} {
 168     catch {destroy .m1}
 169     menu .m1
 170     .m1 add command -label "This is a long label"
 171     set tearoff [tkTearOffMenu .m1]
 172     update idletasks
 173     list [.m1 entryconfigure 1 -label "foo"] [destroy .m1]
 174 } {{} {}}
 175 test menuDraw-7.2 {TkEventuallyRecomputeMenu - update pending} {
 176     catch {destroy .m1}
 177     menu .m1
 178     .m1 add command -label "This is a long label"
 179     set tearoff [tkTearOffMenu .m1]
 180     list [.m1 entryconfigure 1 -label "foo"] [destroy .m1]
 181 } {{} {}}
 182
 183
 184 test menuDraw-8.1 {TkRecomputeMenu} {pcOnly userInteraction} {
 185     catch {destroy .m1}
 186     menu .m1
 187     .m1 configure -postcommand [.m1 add command -label foo]
 188     .m1 add command -label "Hit ESCAPE to make this menu go away."
 189     list [.m1 post 0 0] [destroy .m1]
 190 } {{} {}}
 191
 192
 193 test menuDraw-9.1 {TkEventuallyRedrawMenu - entry test} {
 194     catch {destroy .m1}
 195     catch {unset foo}
 196     menu .m1
 197     set foo 0
 198     .m1 add radiobutton -variable foo -label test
 199     tkTearOffMenu .m1
 200     update idletasks
 201     list [set foo test] [destroy .m1] [unset foo]
 202 } {test {} {}}
 203 test menuDraw-9.2 {TkEventuallyRedrawMenu - whole menu} {
 204     catch {destroy .m1}
 205     menu .m1
 206     list [catch {tkTearOffMenu .m1}] [destroy .m1]
 207 } {0 {}}
 208
 209 # Don't know how to test when window has been deleted and ComputeMenuGeometry
 210 # gets called.
 211 test menuDraw-10.1 {ComputeMenuGeometry - menubar} {
 212     catch {destroy .m1}
 213     menu .m1
 214     .m1 add command -label test
 215     . configure -menu .m1
 216     list [update idletasks] [. configure -menu ""] [destroy .m1]
 217 } {{} {} {}}
 218 test menuDraw-10.2 {ComputeMenuGeometry - non-menubar} {
 219     catch {destroy .m1}
 220     menu .m1
 221     .m1 add command -label test
 222     list [update idletasks] [destroy .m1]
 223 } {{} {}}
 224 test menuDraw-10.3 {ComputeMenuGeometry - Resize necessary} {
 225     catch {destroy .m1}
 226     menu .m1
 227     .m1 add command -label test
 228     list [update idletasks] [destroy .m1]
 229 } {{} {}}
 230 test menuDraw-10.4 {ComputeMenuGeometry - resize not necessary} {
 231     catch {destroy .m1}
 232     menu .m1
 233     .m1 add command -label test
 234     update idletasks
 235     .m1 entryconfigure 1 -label test
 236     list [update idletasks] [destroy .m1]
 237 } {{} {}}
 238
 239 test menuDraw-11.1 {TkMenuSelectImageProc - entry selected; redraw not pending} {
 240     catch {destroy .m1}
 241     catch {eval image delete [image names]}
 242     image create test image1
 243     image create test image2
 244     menu .m1
 245     .m1 add checkbutton -image image1 -selectimage image2
 246     .m1 invoke 1
 247     set tearoff [tkTearOffMenu .m1 40 40]
 248     update idletasks
 249     list [image delete image2] [destroy .m1] [eval image delete [image names]]
 250 } {{} {} {}}
 251 test menuDraw-11.2 {TkMenuSelectImageProc - entry selected; redraw pending} {
 252     catch {destroy .m1}
 253     catch {eval image delete [image names]}
 254     image create test image1
 255     image create test image2
 256     menu .m1
 257     .m1 add checkbutton -image image1 -selectimage image2
 258     .m1 invoke 1
 259     set tearoff [tkTearOffMenu .m1 40 40]
 260     list [image delete image2] [destroy .m1] [eval image delete [image names]]
 261 } {{} {} {}}
 262 test menuDraw-11.3 {TkMenuSelectImageProc - entry not selected} {
 263     catch {destroy .m1}
 264     catch {eval image delete [image names]}
 265     image create test image1
 266     image create test image2
 267     menu .m1
 268     .m1 add checkbutton -image image1 -selectimage image2
 269     set tearoff [tkTearOffMenu .m1 40 40]
 270     update idletasks
 271     list [image delete image2] [destroy .m1] [eval image delete [image names]]
 272 } {{} {} {}}
 273
 274 #Don't know how to test missing tkwin in DisplayMenu
 275 test menuDraw-12.1 {DisplayMenu - menubar background} {unixOnly} {
 276     catch {destroy .m1}
 277     menu .m1
 278     .m1 add cascade -label foo -menu .m2
 279     . configure -menu .m1
 280     list [update] [. configure -menu ""] [destroy .m1]
 281 } {{} {} {}}
 282 test menuDraw-12.2 {Display menu - no entries} {
 283     catch {destroy .m1}
 284     menu .m1
 285     set tearoff [tkTearOffMenu .m1 40 40]
 286     list [update] [destroy .m1]
 287 } {{} {}}
 288 test menuDraw-12.3 {DisplayMenu - one entry} {
 289     catch {destroy .m1}
 290     menu .m1
 291     .m1 add command -label foo
 292     set tearoff [tkTearOffMenu .m1 40 40]
 293     list [update] [destroy .m1]
 294 } {{} {}}
 295 test menuDraw-12.4 {DisplayMenu - two entries} {
 296     catch {destroy .m1}
 297     menu .m1
 298     .m1 add command -label "one"
 299     .m1 add command -label "two"
 300     set tearoff [tkTearOffMenu .m1 40 40]
 301     list [update] [destroy .m1]
 302 } {{} {}}
 303 test menuDraw.12.5 {DisplayMenu - two columns - first bigger} {
 304     catch {destroy .m1}
 305     menu .m1
 306     .m1 add command -label "one"
 307     .m1 add command -label "two"
 308     .m1 add command -label "three" -columnbreak 1
 309     set tearoff [tkTearOffMenu .m1 40 40]
 310     list [update] [destroy .m1]
 311 } {{} {}}
 312 test menuDraw-12.5 {DisplayMenu - two column - second  bigger} {
 313     catch {destroy .m1}
 314     menu .m1
 315     .m1 add command -label "one"
 316     .m1 add command -label "two" -columnbreak 1
 317     .m1 add command -label "three"
 318     set tearoff [tkTearOffMenu .m1 40 40]
 319     list [update] [destroy .m1]
 320 } {{} {}}
 321 test menuDraw.12.7 {DisplayMenu - three columns} {
 322     catch {destroy .m1}
 323     menu .m1
 324     .m1 add command -label "one"
 325     .m1 add command -label "two" -columnbreak 1
 326     .m1 add command -label "three"
 327     .m1 add command -label "four"
 328     .m1 add command -label "five"
 329     .m1 add command -label "six"
 330     set tearoff [tkTearOffMenu .m1 40 40]
 331     list [update] [destroy .m1]
 332 } {{} {}}
 333 test menuDraw-12.6 {Display menu - testing for extra space and menubars} {unixOnly} {
 334     catch {destroy .m1}
 335     menu .m1
 336     .m1 add cascade -label foo
 337     . configure -menu .m1
 338     list [update] [. configure -menu ""] [destroy .m1]
 339 } {{} {} {}}
 340 test menuDraw-12.7 {Display menu - extra space at end of menu} {
 341     catch {destroy .m1}
 342     menu .m1
 343     .m1 add cascade -label foo
 344     set tearoff [tkTearOffMenu .m1 40 40]
 345     wm geometry $tearoff 200x100
 346     list [update] [destroy .m1]
 347 } {{} {}}
 348
 349 test menuDraw-13.1 {TkMenuEventProc - Expose} {
 350     catch {destroy .m1}
 351     catch {destroy .m2}
 352     menu .m1
 353     .m1 add command -label "one"
 354     menu .m2
 355     .m2 add command -label "two"
 356     set tearoff1 [tkTearOffMenu .m1 40 40]
 357     set tearoff2 [tkTearOffMenu .m2 40 40]
 358     list [raise $tearoff2] [update] [destroy .m1] [destroy .m2]
 359 } {{} {} {} {}}
 360 test menuDraw-13.2 {TkMenuEventProc - ConfigureNotify} {
 361     catch {destroy .m1}
 362     menu .m1
 363     .m1 add command -label "foo"
 364     set tearoff [tkTearOffMenu .m1 40 40]
 365     list [wm geometry $tearoff 200x100] [update] [destroy .m1]
 366 } {{} {} {}}
 367 test menuDraw-13.3 {TkMenuEventProc - ActivateNotify} {macOnly} {
 368     catch {destroy .t2}
 369     toplevel .t2 -menu .t2.m1
 370     menu .t2.m1
 371     .t2.m1 add command -label foo
 372     tkTearOffMenu .t2.m1 40 40
 373     list [catch {update} msg] $msg [destroy .t2]
 374 } {0 {} {}}
 375 # Testing deletes is hard, and I am going to do my best. Don't know how
 376 # to test the case where we have already cleared the tkwin field in the
 377 # menuPtr.
 378 test menuDraw-13.4 {TkMenuEventProc - simple delete} {
 379     catch {destroy .m1}
 380     menu .m1
 381     list [destroy .m1]
 382 } {{}}
 383 test menuDraw-13.5 {TkMenuEventProc - nothing pending} {
 384     catch {destroy .m1}
 385     menu .m1
 386     .m1 add command -label foo
 387     update idletasks
 388     list [destroy .m1]
 389 } {{}}
 390
 391 test menuDraw-14.1 {TkMenuImageProc} {
 392     catch {destroy .m1}
 393     catch {image delete image1}
 394     menu .m1
 395     image create test image1
 396     .m1 add command -image image1
 397     update idletasks
 398     list [image delete image1] [destroy .m1]
 399 } {{} {}}
 400 test menuDraw-14.2 {TkMenuImageProc} {
 401     catch {destroy .m1}
 402     catch {image delete image1}
 403     menu .m1
 404     image create test image1
 405     .m1 add command -image image1
 406     list [image delete image1] [destroy .m1]
 407 } {{} {}}
 408
 409 test menuDraw-15.1 {TkPostTearoffMenu - Basic posting} {
 410     catch {destroy .m1}
 411     menu .m1
 412     .m1 add command -label "foo"
 413     list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1]
 414 } {0 {}}
 415 test menuDraw-15.2 {TkPostTearoffMenu - Deactivation} {
 416     catch {destroy .m1}
 417     menu .m1
 418     .m1 add command -label "foo" -state active
 419     set tearoff [tkTearOffMenu .m1 40 40]
 420     list [$tearoff index active] [destroy .m1]
 421 } {none {}}
 422 test menuDraw-15.3 {TkPostTearoffMenu - post command} {
 423     catch {destroy .m1}
 424     catch {unset foo}
 425     menu .m1 -postcommand "set foo .m1"
 426     .m1 add command -label "foo"
 427     list [catch {tkTearOffMenu .m1 40 40}] [set foo] [unset foo] [destroy .m1]
 428 } {0 .m1 {} {}}
 429 test menuDraw-15.4 {TkPostTearoffMenu - post command deleting the menu} {
 430     catch {destroy .m1}
 431     menu .m1 -postcommand "destroy .m1"
 432     .m1 add command -label "foo"
 433     list [catch {tkTearOffMenu .m1 40 40} msg] $msg [winfo exists .m1]
 434 } {0 {} 0}
 435 test menuDraw-15.5 {TkPostTearoffMenu - tearoff at edge of screen} {
 436     catch {destroy .m1}
 437     menu .m1
 438     .m1 add command -label "foo"
 439     set height [winfo screenheight .m1]
 440     list [catch {tkTearOffMenu .m1 40 $height}] [destroy .m1]
 441 } {0 {}}
 442 test menuDraw-15.6 {TkPostTearoffMenu - tearoff off right} {
 443     catch {destroy .m1}
 444     menu .m1
 445     .m1 add command -label "foo"
 446     set width [winfo screenwidth .m1]
 447     list [catch {tkTearOffMenu .m1 $width 40}] [destroy .m1]
 448 } {0 {}}
 449
 450
 451 test menuDraw-16.1 {TkPostSubmenu} {unixOnly} {
 452     catch {destroy .m1}
 453     catch {destroy .m2}
 454     menu .m1
 455     .m1 add cascade -label test -menu .m2
 456     menu .m2
 457     .m2 add command -label "Hit ESCAPE to make this menu go away."
 458     set tearoff [tkTearOffMenu .m1 40 40]
 459     $tearoff postcascade 0
 460     list [$tearoff postcascade 0] [destroy .m1] [destroy .m2]
 461 } {{} {} {}}
 462 test menuDraw-16.2 {TkPostSubMenu} {unixOnly} {
 463     catch {destroy .m1}
 464     catch {destroy .m2}
 465     catch {destroy .m3}
 466     menu .m1
 467     .m1 add cascade -label "two" -menu .m2
 468     .m1 add cascade -label "three" -menu .m3
 469     menu .m2
 470     .m2 add command -label "two"
 471     menu .m3
 472     .m3 add command -label "three"
 473     set tearoff [tkTearOffMenu .m1 40 40]
 474     $tearoff postcascade 0
 475     list [$tearoff postcascade 1] [destroy .m1] [destroy .m2] [destroy .m3]
 476 } {{} {} {} {}}
 477 test menuDraw-16.3 {TkPostSubMenu} {
 478     catch {destroy .m1}
 479     menu .m1
 480     .m1 add cascade -label test -menu .m2
 481     list [.m1 postcascade 1] [destroy .m1]
 482 } {{} {}}
 483 test menuDraw-16.4 {TkPostSubMenu} {
 484     catch {destroy .m1}
 485     menu .m1
 486     .m1 add cascade -label test
 487     set tearoff [tkTearOffMenu .m1 40 40]
 488     list [$tearoff postcascade 0] [destroy .m1]
 489 } {{} {}}
 490 test menuDraw-16.5 {TkPostSubMenu} {unixOnly} {
 491     catch {destroy .m1}
 492     catch {destroy .m2}
 493     menu .m1
 494     .m1 add cascade -label test -menu .m2
 495     menu .m2 -postcommand "glorp"
 496     set tearoff [tkTearOffMenu .m1 40 40]
 497     list [catch {$tearoff postcascade test} msg] $msg [destroy .m1] [destroy .m2]
 498 } {1 {invalid command name "glorp"} {} {}}
 499 test menuDraw-16.6 {TkPostSubMenu} {pcOnly userInteraction} {
 500     catch {destroy .m1}
 501     catch {destroy .m2}
 502     menu .m1
 503     .m1 add cascade -label test -menu .m2
 504     menu .m2
 505     .m2 add command -label "Hit ESCAPE to get rid of this menu"
 506     set tearoff [tkTearOffMenu .m1 40 40]
 507     list [$tearoff postcascade 0] [destroy .m1] [destroy .m2]
 508 } {{} {} {}}
 509
 510 test menuDraw-17.1 {AdjustMenuCoords - menubar} {unixOnly} {
 511     catch {destroy .m1}
 512     catch {destroy .m2}
 513     menu .m1 -tearoff 0
 514     .m1 add cascade -label test -menu .m2
 515     menu .m2 -tearoff 0
 516     .m2 add command -label foo
 517     . configure -menu .m1
 518     foreach w [winfo children .] {
 519         if {[$w cget -type] == "menubar"} {
 520                 break
 521         }
 522     }
 523     list [$w postcascade 0] [. configure -menu ""] [destroy .m1] [destroy .m2]
 524 } {{} {} {} {}}
 525 test menuDraw-17.2 {AdjustMenuCoords - menu} {pcOnly userInteraction} {
 526     catch {destroy .m1}
 527     catch {destroy .m2}
 528     menu .m1
 529     .m1 add cascade -label test -menu .m2
 530     menu .m2
 531     .m2 add command -label "Hit ESCAPE to make this menu go away"
 532     set tearoff [tkTearOffMenu .m1 40 40]
 533     list [$tearoff postcascade 0] [destroy .m1] [destroy .m2]
 534 } {{} {} {}}
 535
 536 # cleanup
 537 deleteWindows
 538 ::tcltest::cleanupTests
 539 return
 540
 541
 542
 543
 544
 545
 546
 547
 548
 549
 550
 551
 552