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