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