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