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