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.
4
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
6
# See the file "license.terms" for information on usage and redistribution
7
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
9
# RCS: @(#) $Id: menuDraw.test,v 1.2 1998/09/14 18:23:48 stanton Exp $
11
if {[lsearch [image types] test] < 0} {
12
puts "This application hasn't been compiled with the \"test\" image"
13
puts "type, so I can't run this test. Are you sure you're using"
14
puts "tktest instead of wish?"
18
if {[info procs test] != "test"} {
22
proc deleteWindows {} {
23
foreach i [winfo children .] {
32
if {$tcl_platform(platform) == "windows" && ![info exists INTERACTIVE]} {
33
puts " Some tests were skipped because they could not be performed"
34
puts " automatically on this platform. If you wish to execute them"
35
puts " interactively, set the TCL variable INTERACTIVE and re-run"
37
set testConfig(menuInteractive) 0
39
set testConfig(menuInteractive) 1
42
test menuDraw-1.1 {TkMenuInitializeDrawingFields} {
44
list [menu .m1] [destroy .m1]
47
test menuDraw-2.1 {TkIntializeMenuEntryDrawingFields} {
50
list [.m1 add command] [destroy .m1]
53
test menuDraw-3.1 {TkMenuFreeDrawOptions} {
59
test menuDraw-4.1 {TkMenuEntryFreeDrawOptions} {
62
.m1 add command -label "This is a test"
65
test menuDraw-4.2 {TkMenuEntryFreeDrawOptions} {
68
.m1 add checkbutton -label "This is a test." -font "Courier 12" -activeforeground red -background green -selectcolor purple
72
test menuDraw-5.1 {TkMenuConfigureDrawOptions - new menu} {
74
list [menu .m1] [destroy .m1]
76
test menuDraw-5.2 {TkMenuConfigureDrawOptions - old menu} {
79
list [.m1 configure -fg red] [destroy .m1]
81
test menuDraw-5.3 {TkMenuConfigureDrawOptions - no disabledFg} {
83
list [menu .m1 -disabledforeground ""] [destroy .m1]
86
test menuDraw-6.1 {TkMenuConfigureEntryDrawOptions - no tkfont specified} {
89
list [.m1 add command -label "foo"] [destroy .m1]
91
test menuDraw-6.2 {TkMenuConfigureEntryDrawOptions - tkfont specified} {
94
list [.m1 add command -label "foo" -font "Courier 12"] [destroy .m1]
96
test menuDraw-6.3 {TkMenuConfigureEntryDrawOptions - active state - wrong entry} {
99
.m1 add command -label "foo"
100
list [.m1 entryconfigure 1 -state active] [destroy .m1]
102
test menuDraw-6.4 {TkMenuConfigureEntryDrawOptions - active state - correct entry} {
105
.m1 add command -label "foo"
107
list [.m1 entryconfigure 1 -state active] [destroy .m1]
109
test menuDraw-6.5 {TkMenuConfigureEntryDrawOptions - deactivate entry} {
112
.m1 add command -label "foo"
114
list [.m1 entryconfigure 1 -state normal] [destroy .m1]
116
test menuDraw-6.6 {TkMenuConfigureEntryDrawOptions - bad state} {
119
.m1 add command -label "foo"
120
list [catch {.m1 entryconfigure 1 -state foo} msg] $msg [destroy .m1]
121
} {1 {bad state value "foo": must be normal, active, or disabled} {}}
122
test menuDraw-6.7 {TkMenuConfigureEntryDrawOptions - tkfont specified} {
125
list [.m1 add command -label "foo" -font "Courier 12"] [destroy .m1]
127
test menuDraw-6.8 {TkMenuConfigureEntryDrawOptions - border specified} {
130
list [.m1 add command -label "foo" -background "red"] [destroy .m1]
132
test menuDraw-6.9 {TkMenuConfigureEntryDrawOptions - foreground specified} {
135
list [.m1 add command -label "foo" -foreground "red"] [destroy .m1]
137
test menuDraw-6.10 {TkMenuConfigureEntryDrawOptions - activeBorder specified} {
140
list [.m1 add command -label "foo" -activebackground "red"] [destroy .m1]
142
test menuDraw-6.11 {TkMenuConfigureEntryDrawOptions - activeforeground specified} {
145
list [.m1 add command -label "foo" -activeforeground "red"] [destroy .m1]
147
test menuDraw-6.12 {TkMenuConfigureEntryDrawOptions - selectcolor specified} {
150
list [.m1 add radiobutton -label "foo" -selectcolor "red"] [destroy .m1]
152
test menuDraw-6.13 {TkMenuConfigureEntryDrawOptions - textGC disposal} {
155
.m1 add command -label "foo" -font "Helvetica 12"
156
list [.m1 entryconfigure 1 -font "Courier 12"] [destroy .m1]
158
test menuDraw-6.14 {TkMenuConfigureEntryDrawOptions - activeGC disposal} {
161
.m1 add command -label "foo" -activeforeground "red"
162
list [.m1 entryconfigure 1 -activeforeground "green"] [destroy .m1]
164
test menuDraw-6.15 {TkMenuConfigureEntryDrawOptions - disabledGC disposal} {
166
menu .m1 -disabledforeground "red"
167
.m1 add command -label "foo"
168
list [.m1 configure -disabledforeground "green"] [destroy .m1]
170
test menuDraw-6.16 {TkMenuConfigureEntryDrawOptions - indicatorGC disposal} {
173
.m1 add radiobutton -label "foo" -selectcolor "red"
174
list [.m1 entryconfigure 1 -selectcolor "green"] [destroy .m1]
177
test menuDraw-7.1 {TkEventuallyRecomputeMenu} {
180
.m1 add command -label "This is a long label"
181
set tearoff [tkTearOffMenu .m1]
183
list [.m1 entryconfigure 1 -label "foo"] [destroy .m1]
185
test menuDraw-7.2 {TkEventuallyRecomputeMenu - update pending} {
188
.m1 add command -label "This is a long label"
189
set tearoff [tkTearOffMenu .m1]
190
list [.m1 entryconfigure 1 -label "foo"] [destroy .m1]
194
test menuDraw-8.1 {TkRecomputeMenu} {menuInteractive} {
197
.m1 configure -postcommand [.m1 add command -label foo]
198
.m1 add command -label "Hit ESCAPE to make this menu go away."
199
list [.m1 post 0 0] [destroy .m1]
203
test menuDraw-9.1 {TkEventuallyRedrawMenu - entry test} {
208
.m1 add radiobutton -variable foo -label test
211
list [set foo test] [destroy .m1] [unset foo]
213
test menuDraw-9.2 {TkEventuallyRedrawMenu - whole menu} {
216
list [catch {tkTearOffMenu .m1}] [destroy .m1]
219
# Don't know how to test when window has been deleted and ComputeMenuGeometry
221
test menuDraw-10.1 {ComputeMenuGeometry - menubar} {
224
.m1 add command -label test
225
. configure -menu .m1
226
list [update idletasks] [. configure -menu ""] [destroy .m1]
228
test menuDraw-10.2 {ComputeMenuGeometry - non-menubar} {
231
.m1 add command -label test
232
list [update idletasks] [destroy .m1]
234
test menuDraw-10.3 {ComputeMenuGeometry - Resize necessary} {
237
.m1 add command -label test
238
list [update idletasks] [destroy .m1]
240
test menuDraw-10.4 {ComputeMenuGeometry - resize not necessary} {
243
.m1 add command -label test
245
.m1 entryconfigure 1 -label test
246
list [update idletasks] [destroy .m1]
249
test menuDraw-11.1 {TkMenuSelectImageProc - entry selected; redraw not pending} {
251
catch {eval image delete [image names]}
252
image create test image1
253
image create test image2
255
.m1 add checkbutton -image image1 -selectimage image2
257
set tearoff [tkTearOffMenu .m1 40 40]
259
list [image delete image2] [destroy .m1] [eval image delete [image names]]
261
test menuDraw-11.2 {TkMenuSelectImageProc - entry selected; redraw pending} {
263
catch {eval image delete [image names]}
264
image create test image1
265
image create test image2
267
.m1 add checkbutton -image image1 -selectimage image2
269
set tearoff [tkTearOffMenu .m1 40 40]
270
list [image delete image2] [destroy .m1] [eval image delete [image names]]
272
test menuDraw-11.3 {TkMenuSelectImageProc - entry not selected} {
274
catch {eval image delete [image names]}
275
image create test image1
276
image create test image2
278
.m1 add checkbutton -image image1 -selectimage image2
279
set tearoff [tkTearOffMenu .m1 40 40]
281
list [image delete image2] [destroy .m1] [eval image delete [image names]]
284
#Don't know how to test missing tkwin in DisplayMenu
285
test menuDraw-12.1 {DisplayMenu - menubar background} {unixOnly} {
288
.m1 add cascade -label foo -menu .m2
289
. configure -menu .m1
290
list [update] [. configure -menu ""] [destroy .m1]
292
test menuDraw-12.2 {Display menu - no entries} {
295
set tearoff [tkTearOffMenu .m1 40 40]
296
list [update] [destroy .m1]
298
test menuDraw-12.3 {DisplayMenu - one entry} {
301
.m1 add command -label foo
302
set tearoff [tkTearOffMenu .m1 40 40]
303
list [update] [destroy .m1]
305
test menuDraw-12.4 {DisplayMenu - two entries} {
308
.m1 add command -label "one"
309
.m1 add command -label "two"
310
set tearoff [tkTearOffMenu .m1 40 40]
311
list [update] [destroy .m1]
313
test menuDraw.12.5 {DisplayMenu - two columns - first bigger} {
316
.m1 add command -label "one"
317
.m1 add command -label "two"
318
.m1 add command -label "three" -columnbreak 1
319
set tearoff [tkTearOffMenu .m1 40 40]
320
list [update] [destroy .m1]
322
test menuDraw-12.5 {DisplayMenu - two column - second bigger} {
325
.m1 add command -label "one"
326
.m1 add command -label "two" -columnbreak 1
327
.m1 add command -label "three"
328
set tearoff [tkTearOffMenu .m1 40 40]
329
list [update] [destroy .m1]
331
test menuDraw.12.7 {DisplayMenu - three columns} {
334
.m1 add command -label "one"
335
.m1 add command -label "two" -columnbreak 1
336
.m1 add command -label "three"
337
.m1 add command -label "four"
338
.m1 add command -label "five"
339
.m1 add command -label "six"
340
set tearoff [tkTearOffMenu .m1 40 40]
341
list [update] [destroy .m1]
343
test menuDraw-12.6 {Display menu - testing for extra space and menubars} {unixOnly} {
346
.m1 add cascade -label foo
347
. configure -menu .m1
348
list [update] [. configure -menu ""] [destroy .m1]
350
test menuDraw-12.7 {Display menu - extra space at end of menu} {
353
.m1 add cascade -label foo
354
set tearoff [tkTearOffMenu .m1 40 40]
355
wm geometry $tearoff 200x100
356
list [update] [destroy .m1]
359
test menuDraw-13.1 {TkMenuEventProc - Expose} {
363
.m1 add command -label "one"
365
.m2 add command -label "two"
366
set tearoff1 [tkTearOffMenu .m1 40 40]
367
set tearoff2 [tkTearOffMenu .m2 40 40]
368
list [raise $tearoff2] [update] [destroy .m1] [destroy .m2]
370
test menuDraw-13.2 {TkMenuEventProc - ConfigureNotify} {
373
.m1 add command -label "foo"
374
set tearoff [tkTearOffMenu .m1 40 40]
375
list [wm geometry $tearoff 200x100] [update] [destroy .m1]
377
test menuDraw-13.3 {TkMenuEventProc - ActivateNotify} {macOnly} {
379
toplevel .t2 -menu .t2.m1
381
.t2.m1 add command -label foo
382
tkTearOffMenu .t2.m1 40 40
383
list [catch {update} msg] $msg [destroy .t2]
385
# Testing deletes is hard, and I am going to do my best. Don't know how
386
# to test the case where we have already cleared the tkwin field in the
388
test menuDraw-13.4 {TkMenuEventProc - simple delete} {
393
test menuDraw-13.5 {TkMenuEventProc - nothing pending} {
396
.m1 add command -label foo
401
test menuDraw-14.1 {TkMenuImageProc} {
403
catch {image delete image1}
405
image create test image1
406
.m1 add command -image image1
408
list [image delete image1] [destroy .m1]
410
test menuDraw-14.2 {TkMenuImageProc} {
412
catch {image delete image1}
414
image create test image1
415
.m1 add command -image image1
416
list [image delete image1] [destroy .m1]
419
test menuDraw-15.1 {TkPostTearoffMenu - Basic posting} {
422
.m1 add command -label "foo"
423
list [catch {tkTearOffMenu .m1 40 40}] [destroy .m1]
425
test menuDraw-15.2 {TkPostTearoffMenu - Deactivation} {
428
.m1 add command -label "foo" -state active
429
set tearoff [tkTearOffMenu .m1 40 40]
430
list [$tearoff index active] [destroy .m1]
432
test menuDraw-15.3 {TkPostTearoffMenu - post command} {
435
menu .m1 -postcommand "set foo .m1"
436
.m1 add command -label "foo"
437
list [catch {tkTearOffMenu .m1 40 40}] [set foo] [unset foo] [destroy .m1]
439
test menuDraw-15.4 {TkPostTearoffMenu - post command deleting the menu} {
441
menu .m1 -postcommand "destroy .m1"
442
.m1 add command -label "foo"
443
list [catch {tkTearOffMenu .m1 40 40} msg] $msg [winfo exists .m1]
445
test menuDraw-15.5 {TkPostTearoffMenu - tearoff at edge of screen} {
448
.m1 add command -label "foo"
449
set height [winfo screenheight .m1]
450
list [catch {tkTearOffMenu .m1 40 $height}] [destroy .m1]
452
test menuDraw-15.6 {TkPostTearoffMenu - tearoff off right} {
455
.m1 add command -label "foo"
456
set width [winfo screenwidth .m1]
457
list [catch {tkTearOffMenu .m1 $width 40}] [destroy .m1]
461
test menuDraw-16.1 {TkPostSubmenu} {unixOnly} {
465
.m1 add cascade -label test -menu .m2
467
.m2 add command -label "Hit ESCAPE to make this menu go away."
468
set tearoff [tkTearOffMenu .m1 40 40]
469
$tearoff postcascade 0
470
list [$tearoff postcascade 0] [destroy .m1] [destroy .m2]
472
test menuDraw-16.2 {TkPostSubMenu} {unixOnly} {
477
.m1 add cascade -label "two" -menu .m2
478
.m1 add cascade -label "three" -menu .m3
480
.m2 add command -label "two"
482
.m3 add command -label "three"
483
set tearoff [tkTearOffMenu .m1 40 40]
484
$tearoff postcascade 0
485
list [$tearoff postcascade 1] [destroy .m1] [destroy .m2] [destroy .m3]
487
test menuDraw-16.3 {TkPostSubMenu} {
490
.m1 add cascade -label test -menu .m2
491
list [.m1 postcascade 1] [destroy .m1]
493
test menuDraw-16.4 {TkPostSubMenu} {
496
.m1 add cascade -label test
497
set tearoff [tkTearOffMenu .m1 40 40]
498
list [$tearoff postcascade 0] [destroy .m1]
500
test menuDraw-16.5 {TkPostSubMenu} {unixOnly} {
504
.m1 add cascade -label test -menu .m2
505
menu .m2 -postcommand "glorp"
506
set tearoff [tkTearOffMenu .m1 40 40]
507
list [catch {$tearoff postcascade test} msg] $msg [destroy .m1] [destroy .m2]
508
} {1 {invalid command name "glorp"} {} {}}
509
test menuDraw-16.6 {TkPostSubMenu} {menuInteractive} {
513
.m1 add cascade -label test -menu .m2
515
.m2 add command -label "Hit ESCAPE to get rid of this menu"
516
set tearoff [tkTearOffMenu .m1 40 40]
517
list [$tearoff postcascade 0] [destroy .m1] [destroy .m2]
520
test menuDraw-17.1 {AdjustMenuCoords - menubar} {unixOnly} {
524
.m1 add cascade -label test -menu .m2
526
.m2 add command -label foo
527
. configure -menu .m1
528
foreach w [winfo children .] {
529
if {[$w cget -type] == "menubar"} {
533
list [$w postcascade 0] [. configure -menu ""] [destroy .m1] [destroy .m2]
535
test menuDraw-17.2 {AdjustMenuCoords - menu} {menuInteractive} {
539
.m1 add cascade -label test -menu .m2
541
.m2 add command -label "Hit ESCAPE to make this menu go away"
542
set tearoff [tkTearOffMenu .m1 40 40]
543
list [$tearoff postcascade 0] [destroy .m1] [destroy .m2]
added
removed
tests/menuDraw.test
