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