1# This file is a Tcl script to test out the "frame" and "toplevel"
2# commands of Tk.  It is organized in the standard fashion for Tcl
3# tests.
4#
5# Copyright (c) 1994 The Regents of the University of California.
6# Copyright (c) 1994-1996 Sun Microsystems, Inc.
7# Copyright (c) 1998-1999 by Scriptics Corporation.
8# All rights reserved.
9#
10# RCS: @(#) $Id: frame.test,v 1.7.2.1 2003/07/16 23:17:39 pspjuth Exp $
11
12package require tcltest 2.1
13namespace import -force tcltest::configure
14namespace import -force tcltest::testsDirectory
15configure -testdir [file join [pwd] [file dirname [info script]]]
16configure -loadfile [file join [testsDirectory] constraints.tcl]
17tcltest::loadTestedCommands
18
19# eatColors --
20# Creates a toplevel window and allocates enough colors in it to
21# use up all the slots in the colormap.
22#
23# Arguments:
24# w -		Name of toplevel window to create.
25
26proc eatColors {w} {
27    catch {destroy $w}
28    toplevel $w
29    wm geom $w +0+0
30    canvas $w.c -width 400 -height 200 -bd 0
31    pack $w.c
32    for {set y 0} {$y < 8} {incr y} {
33	for {set x 0} {$x < 40} {incr x} {
34	    set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0]
35	    $w.c create rectangle [expr 10*$x] [expr 20*$y] \
36		    [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
37		    -fill $color
38	}
39    }
40    update
41}
42
43# colorsFree --
44#
45# Returns 1 if there appear to be free colormap entries in a window,
46# 0 otherwise.
47#
48# Arguments:
49# w -			Name of window in which to check.
50# red, green, blue -	Intensities to use in a trial color allocation
51#			to see if there are colormap entries free.
52
53proc colorsFree {w {red 31} {green 245} {blue 192}} {
54    set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]]
55    expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \
56	    && ([lindex $vals 2]/256 == $blue)
57}
58
59test frame-1.1 {frame configuration options} {
60    frame .f -class NewFrame
61    list [.f configure -class] [catch {.f configure -class Different} msg] $msg
62} {{-class class Class Frame NewFrame} 1 {can't modify -class option after widget is created}}
63catch {destroy .f}
64test frame-1.2 {frame configuration options} {
65    frame .f -colormap new
66    list [.f configure -colormap] [catch {.f configure -colormap .} msg] $msg
67} {{-colormap colormap Colormap {} new} 1 {can't modify -colormap option after widget is created}}
68catch {destroy .f}
69test frame-1.3 {frame configuration options} {
70    frame .f -visual default
71    list [.f configure -visual] [catch {.f configure -visual best} msg] $msg
72} {{-visual visual Visual {} default} 1 {can't modify -visual option after widget is created}}
73catch {destroy .f}
74test frame-1.4 {frame configuration options} {
75    list [catch {frame .f -screen bogus} msg] $msg
76} {1 {unknown option "-screen"}}
77test frame-1.5 {frame configuration options} {
78    set result [list [catch {frame .f -container true} msg] $msg \
79	    [.f configure -container]]
80    destroy .f
81    set result
82} {0 .f {-container container Container 0 1}}
83test frame-1.6 {frame configuration options} {
84    list [catch {frame .f -container bogus} msg] $msg
85} {1 {expected boolean value but got "bogus"}}
86test frame-1.7 {frame configuration options} {
87    frame .f
88    set result [list [catch {.f configure -container 1} msg] $msg]
89    destroy .f
90    set result
91} {1 {can't modify -container option after widget is created}}
92test frame-1.8 {frame configuration options} {
93    # Make sure all options can be set to the default value
94    frame .f
95    set opts {}
96    foreach opt [.f configure] {
97        if {[llength $opt] == 5} {
98            lappend opts [lindex $opt 0] [lindex $opt 4]
99        }
100    }
101    eval frame .g $opts
102    destroy .f .g
103} {}
104
105frame .f
106set i 9
107foreach test {
108    {-background #ff0000 #ff0000 non-existent
109	    {unknown color name "non-existent"}}
110    {-bd 4 4 badValue {bad screen distance "badValue"}}
111    {-bg #00ff00 #00ff00 non-existent
112	    {unknown color name "non-existent"}}
113    {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
114    {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
115    {-height 100 100 not_a_number {bad screen distance "not_a_number"}}
116    {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
117    {-highlightcolor #123456 #123456 non-existent
118	    {unknown color name "non-existent"}}
119    {-highlightthickness 6 6 badValue {bad screen distance "badValue"}}
120    {-padx 3 3 badValue {bad screen distance "badValue"}}
121    {-pady 4 4 badValue {bad screen distance "badValue"}}
122    {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
123    {-takefocus "any string" "any string" {} {}}
124    {-width 32 32 badValue {bad screen distance "badValue"}}
125} {
126    set name [lindex $test 0]
127    test frame-1.$i {frame configuration options} {
128	.f configure $name [lindex $test 1]
129	lindex [.f configure $name] 4
130    } [lindex $test 2]
131    incr i
132    if {[lindex $test 3] != ""} {
133	test frame-1.$i {frame configuration options} {
134	    list [catch {.f configure $name [lindex $test 3]} msg] $msg
135	} [list 1 [lindex $test 4]]
136    }
137    .f configure $name [lindex [.f configure $name] 3]
138    incr i
139}
140destroy .f
141
142set i 1
143test frame-2.1 {toplevel configuration options} {
144    catch {destroy .t}
145    toplevel .t -width 200 -height 100 -class NewClass
146    wm geometry .t +0+0
147    list [.t configure -class] [catch {.t configure -class Another} msg] $msg
148} {{-class class Class Toplevel NewClass} 1 {can't modify -class option after widget is created}}
149test frame-2.2 {toplevel configuration options} {
150    catch {destroy .t}
151    toplevel .t -width 200 -height 100 -colormap new
152    wm geometry .t +0+0
153    list [.t configure -colormap] [catch {.t configure -colormap .} msg] $msg
154} {{-colormap colormap Colormap {} new} 1 {can't modify -colormap option after widget is created}}
155test frame-2.3 {toplevel configuration options} {
156    catch {destroy .t}
157    toplevel .t -width 200 -height 100 -colormap {} -use {}
158    wm geometry .t +0+0
159    list [catch {.t configure -container 1} msg] $msg [.t configure -container]
160} {1 {can't modify -container option after widget is created} {-container container Container 0 0}}
161test frame-2.4 {toplevel configuration options} {
162    catch {destroy .t}
163    list [catch {toplevel .t -width 200 -height 100 -colormap bogus} msg] $msg
164} {1 {bad window path name "bogus"}}
165set default "[winfo visual .] [winfo depth .]"
166test frame-2.5 {toplevel configuration options} {
167    catch {destroy .t}
168    toplevel .t -width 200 -height 100
169    wm geometry .t +0+0
170    list [catch {.t configure -use 0x44022} msg] $msg [.t configure -use]
171} {1 {can't modify -use option after widget is created} {-use use Use {} {}}}
172test frame-2.6 {toplevel configuration options} {
173    catch {destroy .t}
174    toplevel .t -width 200 -height 100 -visual default
175    wm geometry .t +0+0
176    list [.t configure -visual] [catch {.t configure -visual best} msg] $msg
177} {{-visual visual Visual {} default} 1 {can't modify -visual option after widget is created}}
178test frame-2.7 {toplevel configuration options} {
179    catch {destroy .t}
180    list [catch {toplevel .t -width 200 -height 100 -visual who_knows?} msg] $msg
181} {1 {unknown or ambiguous visual name "who_knows?": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}}
182if [info exists env(DISPLAY)] {
183    test frame-2.8 {toplevel configuration options} {
184	catch {destroy .t}
185	toplevel .t -width 200 -height 100 -screen $env(DISPLAY)
186	wm geometry .t +0+0
187	list [.t configure -screen] \
188		[catch {.t configure -screen another} msg] $msg
189    } [list [list -screen screen Screen {} $env(DISPLAY)] 1 {can't modify -screen option after widget is created}]
190}
191test frame-2.9 {toplevel configuration options} {
192    catch {destroy .t}
193    list [catch {toplevel .t -width 200 -height 100 -screen bogus} msg] $msg
194} {1 {couldn't connect to display "bogus"}}
195test frame-2.10 {toplevel configuration options} {
196    catch {destroy .t}
197    catch {destroy .x}
198    toplevel .t -container 1 -width 300 -height 120
199    wm geometry .t +0+0
200    set result [list \
201            [catch {toplevel .x -container 1 -use [winfo id .t]} msg] $msg]
202    destroy .t .x
203    set result
204} {1 {A window cannot have both the -use and the -container option set.}}
205test frame-2.11 {toplevel configuration options} {
206    # Make sure all options can be set to the default value
207    toplevel .f
208    set opts {}
209    foreach opt [.f configure] {
210        if {[llength $opt] == 5} {
211            lappend opts [lindex $opt 0] [lindex $opt 4]
212        }
213    }
214    eval toplevel .g $opts
215    destroy .f .g
216} {}
217
218catch {destroy .t}
219toplevel .t -width 300 -height 150
220wm geometry .t +0+0
221update
222set i 12
223foreach test {
224    {-background #ff0000 #ff0000 non-existent
225	    {unknown color name "non-existent"}}
226    {-bd 4 4 badValue {bad screen distance "badValue"}}
227    {-bg #00ff00 #00ff00 non-existent
228	    {unknown color name "non-existent"}}
229    {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
230    {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
231    {-height 100 100 not_a_number {bad screen distance "not_a_number"}}
232    {-highlightcolor #123456 #123456 non-existent
233	    {unknown color name "non-existent"}}
234    {-highlightthickness 3 3 badValue {bad screen distance "badValue"}}
235    {-padx 3 3 badValue {bad screen distance "badValue"}}
236    {-pady 4 4 badValue {bad screen distance "badValue"}}
237    {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
238    {-width 32 32 badValue {bad screen distance "badValue"}}
239} {
240    set name [lindex $test 0]
241    test frame-2.$i {toplevel configuration options} {
242	.t configure $name [lindex $test 1]
243	lindex [.t configure $name] 4
244    } [lindex $test 2]
245    incr i
246    if {[lindex $test 3] != ""} {
247	test frame-2.$i {toplevel configuration options} {
248	    list [catch {.t configure $name [lindex $test 3]} msg] $msg
249	} [list 1 [lindex $test 4]]
250    }
251    .t configure $name [lindex [.t configure $name] 3]
252    incr i
253}
254
255test frame-3.1 {TkCreateFrame procedure} {
256    list [catch frame msg] $msg
257} {1 {wrong # args: should be "frame pathName ?options?"}}
258test frame-3.2 {TkCreateFrame procedure} {
259    catch {destroy .f}
260    frame .f
261    set result [.f configure -class]
262    destroy .f
263    set result
264} {-class class Class Frame Frame}
265test frame-3.3 {TkCreateFrame procedure} {
266    catch {destroy .t}
267    toplevel .t
268    wm geometry .t +0+0
269    set result [.t configure -class]
270    destroy .t
271    set result
272} {-class class Class Toplevel Toplevel}
273test frame-3.4 {TkCreateFrame procedure} {
274    catch {destroy .t}
275    toplevel .t -width 350 -class NewClass -bg black -visual default -height 90
276    wm geometry .t +0+0
277    update
278    list [lindex [.t configure -width] 4] \
279	    [lindex [.t configure -background] 4] \
280	    [lindex [.t configure -height] 4]
281} {350 black 90}
282
283# Be sure that the -class, -colormap, and -visual options are processed
284# before configuring the widget.
285
286test frame-3.5 {TkCreateFrame procedure} {
287    catch {destroy .f}
288    option add *NewFrame.background #123456
289    frame .f -class NewFrame
290    option clear
291    lindex [.f configure -background] 4
292} {#123456}
293test frame-3.6 {TkCreateFrame procedure} {
294    catch {destroy .f}
295    option add *NewFrame.background #123456
296    frame .f -class NewFrame
297    option clear
298    lindex [.f configure -background] 4
299} {#123456}
300test frame-3.7 {TkCreateFrame procedure} {
301    catch {destroy .f}
302    option add *NewFrame.background #332211
303    option add *f.class NewFrame
304    frame .f
305    option clear
306    list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4]
307} {NewFrame #332211}
308test frame-3.8 {TkCreateFrame procedure} {
309    catch {destroy .f}
310    option add *Silly.background #122334
311    option add *f.Class Silly
312    frame .f
313    option clear
314    list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4]
315} {Silly #122334}
316test frame-3.9 {TkCreateFrame procedure, -use option} unixOnly {
317    catch {destroy .t}
318    catch {destroy .x}
319    toplevel .t -container 1 -width 300 -height 120
320    wm geometry .t +0+0
321    toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green
322    tkwait visibility .x
323    set result "[expr [winfo rootx .x] - [winfo rootx .t]] [expr [winfo rooty .x] - [winfo rooty .t]] [winfo width .t] [winfo height .t]"
324    destroy .t
325    set result
326} {0 0 140 300}
327test frame-3.10 {TkCreateFrame procedure, -use option} unixOnly {
328    catch {destroy .t}
329    catch {destroy .x}
330    toplevel .t -container 1 -width 300 -height 120
331    wm geometry .t +0+0
332    option add *x.use [winfo id .t]
333    toplevel .x -width 140 -height 300 -bg green
334    tkwait visibility .x
335    set result "[expr [winfo rootx .x] - [winfo rootx .t]] [expr [winfo rooty .x] - [winfo rooty .t]] [winfo width .t] [winfo height .t]"
336     destroy .t
337    option clear
338    set result
339} {0 0 140 300}
340
341# The tests below require specific display characteristics.  Even so,
342# they are non-portable:  some machines don't seem to ever run out of
343# colors.
344
345if {([winfo visual .] == "pseudocolor") && ([winfo depth .] == 8)} {
346    eatColors .t1
347    test frame-3.11 {TkCreateFrame procedure} {nonPortable} {
348	catch {destroy .t}
349	toplevel .t -width 300 -height 200 -bg #475601
350	wm geometry .t +0+0
351	update
352	colorsFree .t
353    } {0}
354    test frame-3.12 {TkCreateFrame procedure} {nonPortable} {
355	catch {destroy .t}
356	toplevel .t -width 300 -height 200 -bg #475601 -colormap new
357	wm geometry .t +0+0
358	update
359	colorsFree .t
360    } {1}
361    test frame-3.13 {TkCreateFrame procedure} {nonPortable} {
362	catch {destroy .t}
363	option add *t.class Toplevel2
364	option add *Toplevel2.colormap new
365	toplevel .t -width 300 -height 200 -bg #475601
366	wm geometry .t +0+0
367	update
368	option clear
369	colorsFree .t
370    } {1}
371    test frame-3.14 {TkCreateFrame procedure} {nonPortable} {
372	catch {destroy .t}
373	option add *t.class Toplevel3
374	option add *Toplevel3.Colormap new
375	toplevel .t -width 300 -height 200 -bg #475601 -colormap new
376	wm geometry .t +0+0
377	update
378	option clear
379	colorsFree .t
380    } {1}
381    test frame-3.15 {TkCreateFrame procedure, -use and -colormap} {unixOnly nonPortable} {
382	catch {destroy .t}
383	catch {destroy .x}
384	toplevel .t -container 1 -width 300 -height 120
385	wm geometry .t +0+0
386	toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green -colormap new
387	tkwait visibility .x
388	set result "[colorsFree .t] [colorsFree .x]"
389	destroy .t
390	set result
391    } {0 1}
392    test frame-3.16 {TkCreateFrame procedure} {nonPortable} {
393	catch {destroy .t}
394	toplevel .t -width 300 -height 200 -bg #475601 -visual default
395	wm geometry .t +0+0
396	update
397	colorsFree .t
398    } {0}
399    test frame-3.17 {TkCreateFrame procedure} {nonPortable} {
400	catch {destroy .t}
401	toplevel .t -width 300 -height 200 -bg #475601 -visual default \
402		-colormap new
403	wm geometry .t +0+0
404	update
405	colorsFree .t
406    } {1}
407    if {[lsearch -exact [winfo visualsavailable .] {grayscale 8}] >= 0} {
408        test frame-3.18 {TkCreateFrame procedure} {nonPortable} {
409	    catch {destroy .t}
410	    toplevel .t -visual {grayscale 8} -width 300 -height 200 \
411		    -bg #434343 
412	    wm geometry .t +0+0
413	    update
414	    colorsFree .t 131 131 131
415	} {1}
416        test frame-3.19 {TkCreateFrame procedure} {nonPortable} {
417	    catch {destroy .t}
418	    option add *t.class T4
419	    option add *T4.visual {grayscale 8}
420	    toplevel .t -width 300 -height 200 -bg #434343
421	    wm geometry .t +0+0
422	    update
423	    option clear
424	    list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4]
425	} {1 {grayscale 8}}
426        test frame-3.20 {TkCreateFrame procedure} {nonPortable} {
427	    catch {destroy .t}
428	    set x ok
429	    option add *t.class T5
430	    option add *T5.Visual {grayscale 8}
431	    toplevel .t -width 300 -height 200 -bg #434343
432	    wm geometry .t +0+0
433	    update
434	    option clear
435	    list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4]
436	} {1 {grayscale 8}}
437        test frame-3.21 {TkCreateFrame procedure} {nonPortable} {
438	    catch {destroy .t}
439	    set x ok
440	    toplevel .t -visual {grayscale 8} -width 300 -height 200 \
441		    -bg #434343 
442	    wm geometry .t +0+0
443	    update
444	    colorsFree .t 131 131 131
445	} {1}
446    }
447    destroy .t1
448}
449test frame-3.22 {TkCreateFrame procedure, default dimensions} {
450    catch {destroy .t}
451    toplevel .t
452    wm geometry .t +0+0
453    update
454    set result "[winfo reqwidth .t] [winfo reqheight .t]"
455    frame .t.f -bg red
456    pack .t.f
457    update
458    lappend result [winfo reqwidth .t.f] [winfo reqheight .t.f]
459    destroy .t
460    set result
461} {200 200 1 1}
462test frame-3.23 {TkCreateFrame procedure} {
463    catch {destroy .f}
464    list [catch {frame .f -gorp glob} msg] $msg
465} {1 {unknown option "-gorp"}}
466test frame-3.24 {TkCreateFrame procedure} {
467    catch {destroy .t}
468    list [catch {
469	toplevel .t -width 300 -height 200 -colormap new -bogus option
470	wm geometry .t +0+0
471    } msg] $msg
472} {1 {unknown option "-bogus"}}
473
474test frame-4.1 {TkCreateFrame procedure} {
475    catch {destroy .f}
476    catch {frame .f -gorp glob}
477    winfo exists .f
478} 0
479test frame-4.2 {TkCreateFrame procedure} {
480    catch {destroy .f}
481    list [frame .f -width 200 -height 100] [winfo exists .f]
482} {.f 1}
483
484catch {destroy .f}
485frame .f -highlightcolor black
486test frame-5.1 {FrameWidgetCommand procedure} {
487    list [catch .f msg] $msg
488} {1 {wrong # args: should be ".f option ?arg arg ...?"}}
489test frame-5.2 {FrameWidgetCommand procedure, cget option} {
490    list [catch {.f cget} msg] $msg
491} {1 {wrong # args: should be ".f cget option"}}
492test frame-5.3 {FrameWidgetCommand procedure, cget option} {
493    list [catch {.f cget a b} msg] $msg
494} {1 {wrong # args: should be ".f cget option"}}
495test frame-5.4 {FrameWidgetCommand procedure, cget option} {
496    list [catch {.f cget -gorp} msg] $msg
497} {1 {unknown option "-gorp"}}
498test frame-5.5 {FrameWidgetCommand procedure, cget option} {
499    .f cget -highlightcolor
500} {black}
501test frame-5.6 {FrameWidgetCommand procedure, cget option} {
502    list [catch {.f cget -screen} msg] $msg
503} {1 {unknown option "-screen"}}
504test frame-5.7 {FrameWidgetCommand procedure, cget option} {
505    catch {destroy .t}
506    toplevel .t
507    catch {.t cget -screen}
508} {0}
509catch {destroy .t}
510test frame-5.8 {FrameWidgetCommand procedure, configure option} {
511    llength [.f configure]
512} {18}
513test frame-5.9 {FrameWidgetCommand procedure, configure option} {
514    list [catch {.f configure -gorp} msg] $msg
515} {1 {unknown option "-gorp"}}
516test frame-5.10 {FrameWidgetCommand procedure, configure option} {
517    list [catch {.f configure -gorp bogus} msg] $msg
518} {1 {unknown option "-gorp"}}
519test frame-5.11 {FrameWidgetCommand procedure, configure option} {
520    list [catch {.f configure -width 200 -height} msg] $msg
521} {1 {value for "-height" missing}}
522test frame-5.12 {FrameWidgetCommand procedure} {
523    list [catch {.f swizzle} msg] $msg
524} {1 {bad option "swizzle": must be cget or configure}}
525test frame-5.13 {FrameWidgetCommand procedure, configure option} {
526    llength [. configure]
527} {21}
528
529test frame-6.1 {ConfigureFrame procedure} {
530    catch {destroy .f}
531    frame .f -width 150
532    list [winfo reqwidth .f] [winfo reqheight .f]
533} {150 1}
534test frame-6.2 {ConfigureFrame procedure} {
535    catch {destroy .f}
536    frame .f -height 97
537    list [winfo reqwidth .f] [winfo reqheight .f]
538} {1 97}
539test frame-6.3 {ConfigureFrame procedure} {
540    catch {destroy .f}
541    frame .f
542    set result {}
543    lappend result [winfo reqwidth .f] [winfo reqheight .f]
544    .f configure -width 100 -height 180
545    lappend result [winfo reqwidth .f] [winfo reqheight .f]
546    .f configure -width 0 -height 0
547    lappend result [winfo reqwidth .f] [winfo reqheight .f]
548} {1 1 100 180 100 180}
549
550test frame-7.1 {FrameEventProc procedure} {
551    frame .frame2
552    set result [info commands .frame2]
553    destroy .frame2
554    lappend result [info commands .frame2]
555} {.frame2 {}}
556test frame-7.2 {FrameEventProc procedure} {
557    deleteWindows
558    frame .f1 -bg #543210
559    rename .f1 .f2
560    set x {}
561    lappend x [winfo children .]
562    lappend x [.f2 cget -bg]
563    destroy .f1
564    lappend x [info command .f*] [winfo children .]
565} {.f1 #543210 {} {}}
566
567test frame-8.1 {FrameCmdDeletedProc procedure} {
568    deleteWindows
569    frame .f1
570    rename .f1 {}
571    list [info command .f*] [winfo children .]
572} {{} {}}
573test frame-8.2 {FrameCmdDeletedProc procedure} {
574    deleteWindows
575    toplevel .f1 -menu .m
576    wm geometry .f1 +0+0
577    update
578    rename .f1 {}
579    update
580    list [info command .f*] [winfo children .]
581} {{} {}}
582#
583# This one fails with the dash-patch!!!! Still don't know why  :-(
584#
585#test frame-8.3 {FrameCmdDeletedProc procedure} {
586#    eval destroy [winfo children .]
587#    toplevel .f1 -menu .m
588#    wm geometry .f1 +0+0
589#    menu .m
590#    update
591#    rename .f1 {}
592#    update
593#    set result [list [info command .f*] [winfo children .]]
594#    eval destroy [winfo children .]
595#    set result
596#} {{} .m}
597
598test frame-9.1 {MapFrame procedure} {
599    catch {destroy .t}
600    toplevel .t -width 100 -height 400
601    wm geometry .t +0+0
602    set result [winfo ismapped .t]
603    update idletasks
604    lappend result [winfo ismapped .t]
605} {0 1}
606test frame-9.2 {MapFrame procedure} {
607    catch {destroy .t}
608    toplevel .t -width 100 -height 400
609    wm geometry .t +0+0
610    destroy .t
611    update
612    winfo exists .t
613} {0}
614test frame-9.3 {MapFrame procedure, window deleted while mapping} {
615    toplevel .t2 -width 200 -height 200
616    wm geometry .t2 +0+0
617    tkwait visibility .t2
618    catch {destroy .t}
619    toplevel .t -width 100 -height 400
620    wm geometry .t +0+0
621    frame .t2.f -width 50 -height 50
622    bind .t2.f <Configure> {destroy .t}
623    pack .t2.f -side top
624    update idletasks
625    winfo exists .t
626} {0}
627
628set l [interp hidden]
629deleteWindows
630
631test frame-10.1 {frame widget vs hidden commands} {
632    catch {destroy .t}
633    frame .t
634    interp hide {} .t
635    destroy .t
636    list [winfo children .] [interp hidden]
637} [list {} $l]
638
639test frame-11.1 {TkInstallFrameMenu} {
640    catch {destroy .t}
641    menu .m1
642    .m1 add cascade -menu .m1.system
643    menu .m1.system -tearoff 0
644    .m1.system add command -label foo
645    list [toplevel .t -menu .m1] [destroy .m1] [destroy .t]
646} {.t {} {}}
647test frame-11.2 {TkInstallFrameMenu - frame renamed} {
648    catch {destroy .t}
649    catch {rename foo {}}
650    menu .m1
651    .m1 add cascade -menu .m1.system
652    menu .m1.system -tearoff 0
653    .m1.system add command -label foo
654    toplevel .t
655    list [rename .t foo] [destroy .t] [destroy foo] [destroy .m1]
656} {{} {} {} {}}
657
658test frame-12.1 {FrameWorldChanged procedure} {
659    # Test -bd -padx and -pady
660    destroy .f
661    frame .f -borderwidth 2 -padx 3 -pady 4
662    place .f -x 0 -y 0 -width 40 -height 40
663    pack [frame .f.f] -fill both -expand 1
664    update
665    set result [list [winfo x .f.f] [winfo y .f.f] \
666            [winfo width .f.f] [winfo height .f.f]]
667    destroy .f
668    set result
669} {5 6 30 28}
670test frame-12.2 {FrameWorldChanged procedure} {
671    # Test all -labelanchor positions
672    destroy .f
673    set font {helvetica 12}
674    labelframe .f -highlightthickness 1 -bd 3 -padx 1 -pady 2 -font $font \
675            -text "Mupp"
676    set fh [expr {[font metrics $font -linespace] + 2 - 3}]
677    set fw [expr {[font measure $font "Mupp"] + 2 - 3}]
678    if {$fw < 0} {set fw 0}
679    if {$fh < 0} {set fh 0}
680    place .f -x 0 -y 0 -width 100 -height 100
681    pack [frame .f.f] -fill both -expand 1
682
683    set result {} 
684    foreach lp {nw n ne en e es se s sw ws w wn} {
685        .f configure -labelanchor $lp
686        update
687        set expx 5
688        set expy 6
689        set expw 90
690        set exph 88
691        switch -glob $lp {
692            n* {incr expy $fh ; incr exph -$fh}
693            s* {incr exph -$fh}
694            w* {incr expx $fw ; incr expw -$fw}
695            e* {incr expw -$fw}
696        }
697        lappend result [expr {\
698                [winfo x .f.f] == $expx && [winfo y .f.f] == $expy &&\
699                [winfo width .f.f] == $expw && [winfo height .f.f] == $exph}]
700    }
701    destroy .f
702    set result
703} {1 1 1 1 1 1 1 1 1 1 1 1}
704test frame-12.3 {FrameWorldChanged procedure} {
705    # Check reaction on font change
706    destroy .f
707    font create myfont -family courier -size 10
708    labelframe .f -font myfont -text Mupp
709    place .f -x 0 -y 0 -width 40 -height 40
710    pack [frame .f.f] -fill both -expand 1
711    update
712    set h1 [font metrics myfont -linespace]
713    set y1 [winfo y .f.f]
714    font configure myfont -size 20
715    update
716    set h2 [font metrics myfont -linespace]
717    set y2 [winfo y .f.f]
718    destroy .f
719    font delete myfont
720    expr {($h2 - $h1) - ($y2 - $y1)}
721} {0}
722
723test frame-13.1 {labelframe configuration options} {
724    labelframe .f -class NewFrame
725    list [.f configure -class] [catch {.f configure -class Different} msg] $msg
726} {{-class class Class Labelframe NewFrame} 1 {can't modify -class option after widget is created}}
727catch {destroy .f}
728test frame-13.2 {labelframe configuration options} {
729    list [catch {labelframe .f -colormap new} msg] $msg
730} {0 .f}
731catch {destroy .f}
732test frame-13.3 {labelframe configuration options} {
733    list [catch {labelframe .f -visual default} msg] $msg
734} {0 .f}
735catch {destroy .f}
736test frame-13.4 {labelframe configuration options} {
737    list [catch {labelframe .f -screen bogus} msg] $msg
738} {1 {unknown option "-screen"}}
739test frame-13.5 {labelframe configuration options} {
740    set result [list [catch {labelframe .f -container true} msg] $msg \
741	    [.f configure -container]]
742    destroy .f
743    set result
744} {0 .f {-container container Container 0 1}}
745test frame-13.6 {labelframe configuration options} {
746    list [catch {labelframe .f -container bogus} msg] $msg
747} {1 {expected boolean value but got "bogus"}}
748test frame-13.7 {labelframe configuration options} {
749    labelframe .f
750    set result [list [catch {.f configure -container 1} msg] $msg]
751    destroy .f
752    set result
753} {1 {can't modify -container option after widget is created}}
754labelframe .f
755set i 8
756foreach test {
757    {-background #ff0000 #ff0000 non-existent
758	    {unknown color name "non-existent"}}
759    {-bd 4 4 badValue {bad screen distance "badValue"}}
760    {-bg #00ff00 #00ff00 non-existent
761	    {unknown color name "non-existent"}}
762    {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
763    {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
764    {-fg #0000ff #0000ff non-existent
765	    {unknown color name "non-existent"}}
766    {-font {courier 8} {courier 8} {} {}}
767    {-foreground #ff0000 #ff0000 non-existent
768	    {unknown color name "non-existent"}}
769    {-height 100 100 not_a_number {bad screen distance "not_a_number"}}
770    {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
771    {-highlightcolor #123456 #123456 non-existent
772	    {unknown color name "non-existent"}}
773    {-highlightthickness 6 6 badValue {bad screen distance "badValue"}}
774    {-labelanchor se se badValue {bad labelanchor "badValue": must be e, en, es, n, ne, nw, s, se, sw, w, wn, or ws}}
775    {-padx 3 3 badValue {bad screen distance "badValue"}}
776    {-pady 4 4 badValue {bad screen distance "badValue"}}
777    {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
778    {-takefocus "any string" "any string" {} {}}
779    {-text "any string" "any string" {} {}}
780    {-width 32 32 badValue {bad screen distance "badValue"}}
781} {
782    set name [lindex $test 0]
783    test frame-13.$i {labelframe configuration options} {
784	.f configure $name [lindex $test 1]
785	lindex [.f configure $name] 4
786    } [lindex $test 2]
787    incr i
788    if {[lindex $test 3] != ""} {
789	test frame-13.$i {labelframe configuration options} {
790	    list [catch {.f configure $name [lindex $test 3]} msg] $msg
791	} [list 1 [lindex $test 4]]
792    }
793    .f configure $name [lindex [.f configure $name] 3]
794    incr i
795}
796destroy .f
797
798test frame-14.1 {labelframe labelwidget option} {
799    # Test that label is moved in stacking order
800    destroy .f .l
801    label .l -text Mupp
802    labelframe .f -labelwidget .l
803    pack .f
804    frame .f.f -width 50 -height 50
805    pack .f.f
806    update
807    set res [list [winfo children .] [winfo width .f] \
808            [expr {[winfo height .f] - [winfo height .l]}]]
809    destroy .f .l
810    set res
811} {{.f .l} 54 52}
812test frame-14.2 {labelframe labelwidget option} {
813    # Test the labelframe's reaction if the label is destroyed
814    destroy .f .l
815    label .l -text Aratherlonglabel
816    labelframe .f -labelwidget .l
817    pack .f
818    label .f.l -text Mupp
819    pack .f.l
820    update
821    set res [list [.f cget -labelwidget]]
822    lappend res [expr {[winfo width .f] - [winfo width .l]}]
823    destroy .l
824    lappend res [.f cget -labelwidget]
825    update
826    lappend res [expr {[winfo width .f] - [winfo width .f.l]}]
827    destroy .f
828    set res
829} {.l 12 {} 4}
830test frame-14.3 {labelframe labelwidget option} {
831    # Test the labelframe's reaction if the label is stolen
832    destroy .f .l
833    label .l -text Aratherlonglabel
834    labelframe .f -labelwidget .l
835    pack .f
836    label .f.l -text Mupp
837    pack .f.l
838    update
839    set res [list [.f cget -labelwidget]]
840    lappend res [expr {[winfo width .f] - [winfo width .l]}]
841    pack .l
842    lappend res [.f cget -labelwidget]
843    update
844    lappend res [expr {[winfo width .f] - [winfo width .f.l]}]
845    destroy .f .l
846    set res
847} {.l 12 {} 4}
848test frame-14.4 {labelframe labelwidget option} {
849    # Test the label's reaction if the labelframe is destroyed
850    destroy .f .l
851    label .l -text Mupp
852    labelframe .f -labelwidget .l
853    pack .f
854    update
855    set res [list [winfo manager .l]]
856    destroy .f
857    lappend res [winfo manager .l]
858    destroy .l
859    set res
860} {labelframe {}}
861test frame-14.5 {labelframe labelwidget option} {
862    # Test that the labelframe reacts on changes in label
863    destroy .f .l
864    label .l -text Aratherlonglabel
865    labelframe .f -labelwidget .l
866    pack .f
867    label .f.l -text Mupp
868    pack .f.l
869    update
870    set first [winfo width .f]
871    set res [expr {[winfo width .f] - [winfo width .l]}]
872    .l configure -text Shorter
873    update
874    lappend res [expr {[winfo width .f] - [winfo width .l]}]
875    lappend res [expr {[winfo width .f] < $first}]
876    .l configure -text Alotlongerthananytimebefore
877    update
878    lappend res [expr {[winfo width .f] - [winfo width .l]}]
879    lappend res [expr {[winfo width .f] > $first}]
880    destroy .f .l
881    set res
882} {12 12 1 12 1}
883test frame-14.6 {labelframe labelwidget option} {
884    # Destroying a labelframe with a child label caused a crash
885    # when not handling mapping of the label correctly.
886    # This test does not test anything directly, it's just ment
887    # to catch if the same mistake is made again.
888    destroy .f
889    labelframe .f
890    pack .f
891    label .f.l -text Mupp
892    .f configure -labelwidget .f.l
893    update
894    destroy .f
895} {}
896
897catch {destroy .f}
898rename eatColors {}
899rename colorsFree {}
900
901# cleanup
902::tcltest::cleanupTests
903return
904