summaryrefslogtreecommitdiffstats
path: root/tests/frame.test
blob: 41307fe30b88cdbb8408f0829d6acbee1dbcba23 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
# This file is a Tcl script to test out the "frame" and "toplevel"
# commands of Tk.  It is organized in the standard fashion for Tcl
# tests.
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: frame.test,v 1.10 2004/05/23 17:34:48 dkf Exp $

package require tcltest 2.1
eval tcltest::configure $argv
tcltest::loadTestedCommands

testConstraint haveDISPLAY [info exists env(DISPLAY)]
testConstraint edibleColors [expr {
    ([winfo visual .] == "pseudocolor") && ([winfo depth .] == 8)
}]
testConstraint haveGrayscale8 [expr {
    [lsearch -exact [winfo visualsavailable .] {grayscale 8}] >= 0
}]

# eatColors --
# Creates a toplevel window and allocates enough colors in it to
# use up all the slots in the colormap.
#
# Arguments:
# w -		Name of toplevel window to create.

proc eatColors {w} {
    catch {destroy $w}
    toplevel $w
    wm geom $w +0+0
    canvas $w.c -width 400 -height 200 -bd 0
    pack $w.c
    for {set y 0} {$y < 8} {incr y} {
	for {set x 0} {$x < 40} {incr x} {
	    set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0]
	    $w.c create rectangle [expr 10*$x] [expr 20*$y] \
		    [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
		    -fill $color
	}
    }
    update
}

# colorsFree --
#
# Returns 1 if there appear to be free colormap entries in a window,
# 0 otherwise.
#
# Arguments:
# w -			Name of window in which to check.
# red, green, blue -	Intensities to use in a trial color allocation
#			to see if there are colormap entries free.

proc colorsFree {w {red 31} {green 245} {blue 192}} {
    set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]]
    expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \
	    && ([lindex $vals 2]/256 == $blue)
}

test frame-1.1 {frame configuration options} {
    frame .f -class NewFrame
    list [.f configure -class] [catch {.f configure -class Different} msg] $msg
} {{-class class Class Frame NewFrame} 1 {can't modify -class option after widget is created}}
catch {destroy .f}
test frame-1.2 {frame configuration options} {
    frame .f -colormap new
    list [.f configure -colormap] [catch {.f configure -colormap .} msg] $msg
} {{-colormap colormap Colormap {} new} 1 {can't modify -colormap option after widget is created}}
catch {destroy .f}
test frame-1.3 {frame configuration options} {
    frame .f -visual default
    list [.f configure -visual] [catch {.f configure -visual best} msg] $msg
} {{-visual visual Visual {} default} 1 {can't modify -visual option after widget is created}}
catch {destroy .f}
test frame-1.4 {frame configuration options} {
    list [catch {frame .f -screen bogus} msg] $msg
} {1 {unknown option "-screen"}}
test frame-1.5 {frame configuration options} {
    set result [list [catch {frame .f -container true} msg] $msg \
	    [.f configure -container]]
    destroy .f
    set result
} {0 .f {-container container Container 0 1}}
test frame-1.6 {frame configuration options} {
    list [catch {frame .f -container bogus} msg] $msg
} {1 {expected boolean value but got "bogus"}}
test frame-1.7 {frame configuration options} {
    frame .f
    set result [list [catch {.f configure -container 1} msg] $msg]
    destroy .f
    set result
} {1 {can't modify -container option after widget is created}}
test frame-1.8 {frame configuration options} {
    # Make sure all options can be set to the default value
    frame .f
    set opts {}
    foreach opt [.f configure] {
        if {[llength $opt] == 5} {
            lappend opts [lindex $opt 0] [lindex $opt 4]
        }
    }
    eval frame .g $opts
    destroy .f .g
} {}

frame .f
set i 9
foreach test {
    {-background #ff0000 #ff0000 non-existent
	    {unknown color name "non-existent"}}
    {-bd 4 4 badValue {bad screen distance "badValue"}}
    {-bg #00ff00 #00ff00 non-existent
	    {unknown color name "non-existent"}}
    {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
    {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
    {-height 100 100 not_a_number {bad screen distance "not_a_number"}}
    {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
    {-highlightcolor #123456 #123456 non-existent
	    {unknown color name "non-existent"}}
    {-highlightthickness 6 6 badValue {bad screen distance "badValue"}}
    {-padx 3 3 badValue {bad screen distance "badValue"}}
    {-pady 4 4 badValue {bad screen distance "badValue"}}
    {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
    {-takefocus "any string" "any string" {} {}}
    {-width 32 32 badValue {bad screen distance "badValue"}}
} {
    lassign $test opt goodValue goodResult badValue badResult
    test frame-1.$i {frame configuration options} {
	.f configure $opt $goodValue
	lindex [.f configure $opt] 4
    } $goodResult
    incr i
    if {$badValue ne ""} {
	test frame-1.$i {frame configuration options} -body {
	    .f configure $opt $badValue
	} -returnCodes error -result $badResult
    }
    .f configure $opt [lindex [.f configure $opt] 3]
    incr i
}
destroy .f

test frame-2.1 {toplevel configuration options} {
    catch {destroy .t}
    toplevel .t -width 200 -height 100 -class NewClass
    wm geometry .t +0+0
    list [.t configure -class] [catch {.t configure -class Another} msg] $msg
} {{-class class Class Toplevel NewClass} 1 {can't modify -class option after widget is created}}
test frame-2.2 {toplevel configuration options} {
    catch {destroy .t}
    toplevel .t -width 200 -height 100 -colormap new
    wm geometry .t +0+0
    list [.t configure -colormap] [catch {.t configure -colormap .} msg] $msg
} {{-colormap colormap Colormap {} new} 1 {can't modify -colormap option after widget is created}}
test frame-2.3 {toplevel configuration options} {
    catch {destroy .t}
    toplevel .t -width 200 -height 100
    wm geometry .t +0+0
    list [catch {.t configure -container 1} msg] $msg [.t configure -container]
} {1 {can't modify -container option after widget is created} {-container container Container 0 0}}
test frame-2.4 {toplevel configuration options} {
    catch {destroy .t}
    list [catch {toplevel .t -width 200 -height 100 -colormap bogus} msg] $msg
} {1 {bad window path name "bogus"}}
set default "[winfo visual .] [winfo depth .]"
test frame-2.5 {toplevel configuration options} {
    catch {destroy .t}
    toplevel .t -width 200 -height 100
    wm geometry .t +0+0
    list [catch {.t configure -use 0x44022} msg] $msg [.t configure -use]
} {1 {can't modify -use option after widget is created} {-use use Use {} {}}}
test frame-2.6 {toplevel configuration options} {
    catch {destroy .t}
    toplevel .t -width 200 -height 100 -visual default
    wm geometry .t +0+0
    list [.t configure -visual] [catch {.t configure -visual best} msg] $msg
} {{-visual visual Visual {} default} 1 {can't modify -visual option after widget is created}}
test frame-2.7 {toplevel configuration options} {
    catch {destroy .t}
    list [catch {toplevel .t -width 200 -height 100 -visual who_knows?} msg] $msg
} {1 {unknown or ambiguous visual name "who_knows?": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}}
test frame-2.8 {toplevel configuration options} haveDISPLAY {
    catch {destroy .t}
    toplevel .t -width 200 -height 100 -screen $env(DISPLAY)
    wm geometry .t +0+0
    list [.t configure -screen] \
	    [catch {.t configure -screen another} msg] $msg
} [list [list -screen screen Screen {} $env(DISPLAY)] 1 {can't modify -screen option after widget is created}]
test frame-2.9 {toplevel configuration options} {
    catch {destroy .t}
    list [catch {toplevel .t -width 200 -height 100 -screen bogus} msg] $msg
} {1 {couldn't connect to display "bogus"}}
test frame-2.10 {toplevel configuration options} {
    catch {destroy .t}
    catch {destroy .x}
    toplevel .t -container 1 -width 300 -height 120
    wm geometry .t +0+0
    set result [list \
            [catch {toplevel .x -container 1 -use [winfo id .t]} msg] $msg]
    destroy .t .x
    set result
} {1 {A window cannot have both the -use and the -container option set.}}
test frame-2.11 {toplevel configuration options} {
    # Make sure all options can be set to the default value
    toplevel .f
    set opts {}
    foreach opt [.f configure] {
        if {[llength $opt] == 5} {
            lappend opts [lindex $opt 0] [lindex $opt 4]
        }
    }
    eval toplevel .g $opts
    destroy .f .g
} {}

catch {destroy .t}
toplevel .t -width 300 -height 150
wm geometry .t +0+0
update
set i 12
foreach test {
    {-background #ff0000 #ff0000 non-existent
	    {unknown color name "non-existent"}}
    {-bd 4 4 badValue {bad screen distance "badValue"}}
    {-bg #00ff00 #00ff00 non-existent
	    {unknown color name "non-existent"}}
    {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
    {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
    {-height 100 100 not_a_number {bad screen distance "not_a_number"}}
    {-highlightcolor #123456 #123456 non-existent
	    {unknown color name "non-existent"}}
    {-highlightthickness 3 3 badValue {bad screen distance "badValue"}}
    {-padx 3 3 badValue {bad screen distance "badValue"}}
    {-pady 4 4 badValue {bad screen distance "badValue"}}
    {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
    {-width 32 32 badValue {bad screen distance "badValue"}}
} {
    lassign $test opt goodValue goodResult badValue badResult
    test frame-2.$i {toplevel configuration options} {
	.t configure $opt $goodValue
	lindex [.t configure $opt] 4
    } $goodResult
    incr i
    if {$badValue ne ""} {
	test frame-2.$i {toplevel configuration options} -body {
	    .t configure $opt $badValue
	} -returnCodes error -result $badResult
    }
    .t configure $opt [lindex [.t configure $opt] 3]
    incr i
}

test frame-3.1 {TkCreateFrame procedure} -body {
    frame
} -returnCodes error -result {wrong # args: should be "frame pathName ?options?"}
test frame-3.2 {TkCreateFrame procedure} -setup {
    catch {destroy .f}
    frame .f
} -body {
    .f configure -class
} -cleanup {
    destroy .f
} -result {-class class Class Frame Frame}
test frame-3.3 {TkCreateFrame procedure} -setup {
    catch {destroy .t}
    toplevel .t
    wm geometry .t +0+0
} -body {
    .t configure -class
} -cleanup {
    destroy .t
} {-class class Class Toplevel Toplevel}
test frame-3.4 {TkCreateFrame procedure} {
    catch {destroy .t}
    toplevel .t -width 350 -class NewClass -bg black -visual default -height 90
    wm geometry .t +0+0
    update
    list [lindex [.t configure -width] 4] \
	    [lindex [.t configure -background] 4] \
	    [lindex [.t configure -height] 4]
} {350 black 90}

# Be sure that the -class, -colormap, and -visual options are processed
# before configuring the widget.

test frame-3.5 {TkCreateFrame procedure} {
    catch {destroy .f}
    option add *NewFrame.background #123456
    frame .f -class NewFrame
    option clear
    lindex [.f configure -background] 4
} {#123456}
test frame-3.6 {TkCreateFrame procedure} {
    catch {destroy .f}
    option add *NewFrame.background #123456
    frame .f -class NewFrame
    option clear
    lindex [.f configure -background] 4
} {#123456}
test frame-3.7 {TkCreateFrame procedure} {
    catch {destroy .f}
    option add *NewFrame.background #332211
    option add *f.class NewFrame
    frame .f
    option clear
    list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4]
} {NewFrame #332211}
test frame-3.8 {TkCreateFrame procedure} {
    catch {destroy .f}
    option add *Silly.background #122334
    option add *f.Class Silly
    frame .f
    option clear
    list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4]
} {Silly #122334}
test frame-3.9 {TkCreateFrame procedure, -use option} -setup {
    catch {destroy .t}
    catch {destroy .x}
} -constraints unixOnly -body {
    toplevel .t -container 1 -width 300 -height 120
    wm geometry .t +0+0
    toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green
    tkwait visibility .x
    list [expr {[winfo rootx .x] - [winfo rootx .t]}] \
	    [expr {[winfo rooty .x] - [winfo rooty .t]}] \
	    [winfo width .t] [winfo height .t]
} -cleanup {
    destroy .t
} -result {0 0 140 300}
test frame-3.10 {TkCreateFrame procedure, -use option} -setup {
    catch {destroy .t}
    catch {destroy .x}
} -constraints unixOnly -body {
    toplevel .t -container 1 -width 300 -height 120
    wm geometry .t +0+0
    option add *x.use [winfo id .t]
    toplevel .x -width 140 -height 300 -bg green
    tkwait visibility .x
    list [expr {[winfo rootx .x] - [winfo rootx .t]}] \
	    [expr {[winfo rooty .x] - [winfo rooty .t]}] \
	    [winfo width .t] [winfo height .t]
} -cleanup {
    destroy .t
    option clear
} -result {0 0 140 300}

# The tests below require specific display characteristics.  Even so,
# they are non-portable:  some machines don't seem to ever run out of
# colors.

if {[testConstraint edibleColors]} {
    eatColors .t1
}
test frame-3.11 {TkCreateFrame procedure} {edibleColors nonPortable} {
    catch {destroy .t}
    toplevel .t -width 300 -height 200 -bg #475601
    wm geometry .t +0+0
    update
    colorsFree .t
} {0}
test frame-3.12 {TkCreateFrame procedure} {edibleColors nonPortable} {
    catch {destroy .t}
    toplevel .t -width 300 -height 200 -bg #475601 -colormap new
    wm geometry .t +0+0
    update
    colorsFree .t
} {1}
test frame-3.13 {TkCreateFrame procedure} {edibleColors nonPortable} {
    catch {destroy .t}
    option add *t.class Toplevel2
    option add *Toplevel2.colormap new
    toplevel .t -width 300 -height 200 -bg #475601
    wm geometry .t +0+0
    update
    option clear
    colorsFree .t
} {1}
test frame-3.14 {TkCreateFrame procedure} {edibleColors nonPortable} {
    catch {destroy .t}
    option add *t.class Toplevel3
    option add *Toplevel3.Colormap new
    toplevel .t -width 300 -height 200 -bg #475601 -colormap new
    wm geometry .t +0+0
    update
    option clear
    colorsFree .t
} {1}
test frame-3.15 {TkCreateFrame procedure, -use and -colormap} -setup {
    catch {destroy .t}
    catch {destroy .x}
} -constraints {edibleColors unixOnly nonPortable} -body {
    toplevel .t -container 1 -width 300 -height 120
    wm geometry .t +0+0
    toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green -colormap new
    tkwait visibility .x
    list [colorsFree .t] [colorsFree .x]
} -cleanup {
    destroy .t
} -result {0 1}
test frame-3.16 {TkCreateFrame procedure} {edibleColors nonPortable} {
    catch {destroy .t}
    toplevel .t -width 300 -height 200 -bg #475601 -visual default
    wm geometry .t +0+0
    update
    colorsFree .t
} {0}
test frame-3.17 {TkCreateFrame procedure} {edibleColors nonPortable} {
    catch {destroy .t}
    toplevel .t -width 300 -height 200 -bg #475601 -visual default \
	    -colormap new
    wm geometry .t +0+0
    update
    colorsFree .t
} {1}
test frame-3.18 {TkCreateFrame procedure} {edibleColors haveGrayscale8 nonPortable} {
    catch {destroy .t}
    toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343 
    wm geometry .t +0+0
    update
    colorsFree .t 131 131 131
} {1}
test frame-3.19 {TkCreateFrame procedure} {edibleColors haveGrayscale8 nonPortable} {
    catch {destroy .t}
    option add *t.class T4
    option add *T4.visual {grayscale 8}
    toplevel .t -width 300 -height 200 -bg #434343
    wm geometry .t +0+0
    update
    option clear
    list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4]
} {1 {grayscale 8}}
test frame-3.20 {TkCreateFrame procedure} {edibleColors haveGrayscale8 nonPortable} {
    catch {destroy .t}
    set x ok
    option add *t.class T5
    option add *T5.Visual {grayscale 8}
    toplevel .t -width 300 -height 200 -bg #434343
    wm geometry .t +0+0
    update
    option clear
    list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4]
} {1 {grayscale 8}}
test frame-3.21 {TkCreateFrame procedure} {edibleColors haveGrayscale8 nonPortable} {
    catch {destroy .t}
    set x ok
    toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343 
    wm geometry .t +0+0
    update
    colorsFree .t 131 131 131
} {1}
if {[testConstraint edibleColors]} {
    destroy .t1
}
test frame-3.22 {TkCreateFrame procedure, default dimensions} -setup {
    catch {destroy .t}
} -body {
    toplevel .t
    wm geometry .t +0+0
    update
    set result "[winfo reqwidth .t] [winfo reqheight .t]"
    frame .t.f -bg red
    pack .t.f
    update
    lappend result [winfo reqwidth .t.f] [winfo reqheight .t.f]
} -cleanup {
    destroy .t
} -result {200 200 1 1}
test frame-3.23 {TkCreateFrame procedure} -setup {
    catch {destroy .f}
} -body {
    frame .f -gorp glob
} -returnCodes error -result {unknown option "-gorp"}
test frame-3.24 {TkCreateFrame procedure} -setup {
    catch {destroy .t}
} -body {
    toplevel .t -width 300 -height 200 -colormap new -bogus option
    wm geometry .t +0+0
} -returnCodes error -result {unknown option "-bogus"}

test frame-4.1 {TkCreateFrame procedure} {
    catch {destroy .f}
    catch {frame .f -gorp glob}
    winfo exists .f
} 0
test frame-4.2 {TkCreateFrame procedure} {
    catch {destroy .f}
    list [frame .f -width 200 -height 100] [winfo exists .f]
} {.f 1}

catch {destroy .f}
frame .f -highlightcolor black
test frame-5.1 {FrameWidgetCommand procedure} {
    list [catch .f msg] $msg
} {1 {wrong # args: should be ".f option ?arg arg ...?"}}
test frame-5.2 {FrameWidgetCommand procedure, cget option} {
    list [catch {.f cget} msg] $msg
} {1 {wrong # args: should be ".f cget option"}}
test frame-5.3 {FrameWidgetCommand procedure, cget option} {
    list [catch {.f cget a b} msg] $msg
} {1 {wrong # args: should be ".f cget option"}}
test frame-5.4 {FrameWidgetCommand procedure, cget option} {
    list [catch {.f cget -gorp} msg] $msg
} {1 {unknown option "-gorp"}}
test frame-5.5 {FrameWidgetCommand procedure, cget option} {
    .f cget -highlightcolor
} {black}
test frame-5.6 {FrameWidgetCommand procedure, cget option} {
    list [catch {.f cget -screen} msg] $msg
} {1 {unknown option "-screen"}}
test frame-5.7 {FrameWidgetCommand procedure, cget option} {
    catch {destroy .t}
    toplevel .t
    catch {.t cget -screen}
} {0}
catch {destroy .t}
test frame-5.8 {FrameWidgetCommand procedure, configure option} {
    llength [.f configure]
} {18}
test frame-5.9 {FrameWidgetCommand procedure, configure option} {
    list [catch {.f configure -gorp} msg] $msg
} {1 {unknown option "-gorp"}}
test frame-5.10 {FrameWidgetCommand procedure, configure option} {
    list [catch {.f configure -gorp bogus} msg] $msg
} {1 {unknown option "-gorp"}}
test frame-5.11 {FrameWidgetCommand procedure, configure option} {
    list [catch {.f configure -width 200 -height} msg] $msg
} {1 {value for "-height" missing}}
test frame-5.12 {FrameWidgetCommand procedure} {
    list [catch {.f swizzle} msg] $msg
} {1 {bad option "swizzle": must be cget or configure}}
test frame-5.13 {FrameWidgetCommand procedure, configure option} {
    llength [. configure]
} {21}

test frame-6.1 {ConfigureFrame procedure} {
    catch {destroy .f}
    frame .f -width 150
    list [winfo reqwidth .f] [winfo reqheight .f]
} {150 1}
test frame-6.2 {ConfigureFrame procedure} {
    catch {destroy .f}
    frame .f -height 97
    list [winfo reqwidth .f] [winfo reqheight .f]
} {1 97}
test frame-6.3 {ConfigureFrame procedure} {
    catch {destroy .f}
    frame .f
    set result {}
    lappend result [winfo reqwidth .f] [winfo reqheight .f]
    .f configure -width 100 -height 180
    lappend result [winfo reqwidth .f] [winfo reqheight .f]
    .f configure -width 0 -height 0
    lappend result [winfo reqwidth .f] [winfo reqheight .f]
} {1 1 100 180 100 180}

test frame-7.1 {FrameEventProc procedure} {
    frame .frame2
    set result [info commands .frame2]
    destroy .frame2
    lappend result [info commands .frame2]
} {.frame2 {}}
test frame-7.2 {FrameEventProc procedure} {
    deleteWindows
    frame .f1 -bg #543210
    rename .f1 .f2
    set x {}
    lappend x [winfo children .]
    lappend x [.f2 cget -bg]
    destroy .f1
    lappend x [info command .f*] [winfo children .]
} {.f1 #543210 {} {}}

test frame-8.1 {FrameCmdDeletedProc procedure} {
    deleteWindows
    frame .f1
    rename .f1 {}
    list [info command .f*] [winfo children .]
} {{} {}}
test frame-8.2 {FrameCmdDeletedProc procedure} {
    deleteWindows
    toplevel .f1 -menu .m
    wm geometry .f1 +0+0
    update
    rename .f1 {}
    update
    list [info command .f*] [winfo children .]
} {{} {}}
#
# This one fails with the dash-patch!!!! Still don't know why  :-(
#
#test frame-8.3 {FrameCmdDeletedProc procedure} {
#    eval destroy [winfo children .]
#    toplevel .f1 -menu .m
#    wm geometry .f1 +0+0
#    menu .m
#    update
#    rename .f1 {}
#    update
#    set result [list [info command .f*] [winfo children .]]
#    eval destroy [winfo children .]
#    set result
#} {{} .m}

test frame-9.1 {MapFrame procedure} {
    catch {destroy .t}
    toplevel .t -width 100 -height 400
    wm geometry .t +0+0
    set result [winfo ismapped .t]
    update idletasks
    lappend result [winfo ismapped .t]
} {0 1}
test frame-9.2 {MapFrame procedure} {
    catch {destroy .t}
    toplevel .t -width 100 -height 400
    wm geometry .t +0+0
    destroy .t
    update
    winfo exists .t
} {0}
test frame-9.3 {MapFrame procedure, window deleted while mapping} {
    toplevel .t2 -width 200 -height 200
    wm geometry .t2 +0+0
    tkwait visibility .t2
    catch {destroy .t}
    toplevel .t -width 100 -height 400
    wm geometry .t +0+0
    frame .t2.f -width 50 -height 50
    bind .t2.f <Configure> {destroy .t}
    pack .t2.f -side top
    update idletasks
    winfo exists .t
} {0}

set l [interp hidden]
deleteWindows

test frame-10.1 {frame widget vs hidden commands} {
    catch {destroy .t}
    frame .t
    interp hide {} .t
    destroy .t
    list [winfo children .] [interp hidden]
} [list {} $l]

test frame-11.1 {TkInstallFrameMenu} {
    catch {destroy .t}
    menu .m1
    .m1 add cascade -menu .m1.system
    menu .m1.system -tearoff 0
    .m1.system add command -label foo
    list [toplevel .t -menu .m1] [destroy .m1] [destroy .t]
} {.t {} {}}
test frame-11.2 {TkInstallFrameMenu - frame renamed} {
    catch {destroy .t}
    catch {rename foo {}}
    menu .m1
    .m1 add cascade -menu .m1.system
    menu .m1.system -tearoff 0
    .m1.system add command -label foo
    toplevel .t
    list [rename .t foo] [destroy .t] [destroy foo] [destroy .m1]
} {{} {} {} {}}

test frame-12.1 {FrameWorldChanged procedure} {
    # Test -bd -padx and -pady
    destroy .f
    frame .f -borderwidth 2 -padx 3 -pady 4
    place .f -x 0 -y 0 -width 40 -height 40
    pack [frame .f.f] -fill both -expand 1
    update
    set result [list [winfo x .f.f] [winfo y .f.f] \
            [winfo width .f.f] [winfo height .f.f]]
    destroy .f
    set result
} {5 6 30 28}
test frame-12.2 {FrameWorldChanged procedure} {
    # Test all -labelanchor positions
    destroy .f
    set font {helvetica 12}
    labelframe .f -highlightthickness 1 -bd 3 -padx 1 -pady 2 -font $font \
            -text "Mupp"
    set fh [expr {[font metrics $font -linespace] + 2 - 3}]
    set fw [expr {[font measure $font "Mupp"] + 2 - 3}]
    if {$fw < 0} {set fw 0}
    if {$fh < 0} {set fh 0}
    place .f -x 0 -y 0 -width 100 -height 100
    pack [frame .f.f] -fill both -expand 1

    set result {} 
    foreach lp {nw n ne en e es se s sw ws w wn} {
        .f configure -labelanchor $lp
        update
        set expx 5
        set expy 6
        set expw 90
        set exph 88
        switch -glob $lp {
            n* {incr expy $fh ; incr exph -$fh}
            s* {incr exph -$fh}
            w* {incr expx $fw ; incr expw -$fw}
            e* {incr expw -$fw}
        }
        lappend result [expr {\
                [winfo x .f.f] == $expx && [winfo y .f.f] == $expy &&\
                [winfo width .f.f] == $expw && [winfo height .f.f] == $exph}]
    }
    destroy .f
    set result
} {1 1 1 1 1 1 1 1 1 1 1 1}
test frame-12.3 {FrameWorldChanged procedure} {
    # Check reaction on font change
    destroy .f
    font create myfont -family courier -size 10
    labelframe .f -font myfont -text Mupp
    place .f -x 0 -y 0 -width 40 -height 40
    pack [frame .f.f] -fill both -expand 1
    update
    set h1 [font metrics myfont -linespace]
    set y1 [winfo y .f.f]
    font configure myfont -size 20
    update
    set h2 [font metrics myfont -linespace]
    set y2 [winfo y .f.f]
    destroy .f
    font delete myfont
    expr {($h2 - $h1) - ($y2 - $y1)}
} {0}

test frame-13.1 {labelframe configuration options} {
    labelframe .f -class NewFrame
    list [.f configure -class] [catch {.f configure -class Different} msg] $msg
} {{-class class Class Labelframe NewFrame} 1 {can't modify -class option after widget is created}}
catch {destroy .f}
test frame-13.2 {labelframe configuration options} {
    list [catch {labelframe .f -colormap new} msg] $msg
} {0 .f}
catch {destroy .f}
test frame-13.3 {labelframe configuration options} {
    list [catch {labelframe .f -visual default} msg] $msg
} {0 .f}
catch {destroy .f}
test frame-13.4 {labelframe configuration options} {
    list [catch {labelframe .f -screen bogus} msg] $msg
} {1 {unknown option "-screen"}}
test frame-13.5 {labelframe configuration options} {
    set result [list [catch {labelframe .f -container true} msg] $msg \
	    [.f configure -container]]
    destroy .f
    set result
} {0 .f {-container container Container 0 1}}
test frame-13.6 {labelframe configuration options} {
    list [catch {labelframe .f -container bogus} msg] $msg
} {1 {expected boolean value but got "bogus"}}
test frame-13.7 {labelframe configuration options} {
    labelframe .f
    set result [list [catch {.f configure -container 1} msg] $msg]
    destroy .f
    set result
} {1 {can't modify -container option after widget is created}}
labelframe .f
set i 8
foreach test {
    {-background #ff0000 #ff0000 non-existent
	    {unknown color name "non-existent"}}
    {-bd 4 4 badValue {bad screen distance "badValue"}}
    {-bg #00ff00 #00ff00 non-existent
	    {unknown color name "non-existent"}}
    {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}}
    {-cursor arrow arrow badValue {bad cursor spec "badValue"}}
    {-fg #0000ff #0000ff non-existent
	    {unknown color name "non-existent"}}
    {-font {courier 8} {courier 8} {} {}}
    {-foreground #ff0000 #ff0000 non-existent
	    {unknown color name "non-existent"}}
    {-height 100 100 not_a_number {bad screen distance "not_a_number"}}
    {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}}
    {-highlightcolor #123456 #123456 non-existent
	    {unknown color name "non-existent"}}
    {-highlightthickness 6 6 badValue {bad screen distance "badValue"}}
    {-labelanchor se se badValue {bad labelanchor "badValue": must be e, en, es, n, ne, nw, s, se, sw, w, wn, or ws}}
    {-padx 3 3 badValue {bad screen distance "badValue"}}
    {-pady 4 4 badValue {bad screen distance "badValue"}}
    {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
    {-takefocus "any string" "any string" {} {}}
    {-text "any string" "any string" {} {}}
    {-width 32 32 badValue {bad screen distance "badValue"}}
} {
    lassign $test name goodValue goodResult badValue badResult
    test frame-13.$i {labelframe configuration options} {
	.f configure $name $goodValue
	lindex [.f configure $name] 4
    } $goodResult
    incr i
    if {$badValue ne ""} {
	test frame-13.$i {labelframe configuration options} -body {
	    .f configure $name $badValue
	} -returnCodes error -result $badResult
    }
    .f configure $name [lindex [.f configure $name] 3]
    incr i
}
destroy .f

test frame-14.1 {labelframe labelwidget option} {
    # Test that label is moved in stacking order
    destroy .f .l
    label .l -text Mupp
    labelframe .f -labelwidget .l
    pack .f
    frame .f.f -width 50 -height 50
    pack .f.f
    update
    set res [list [winfo children .] [winfo width .f] \
            [expr {[winfo height .f] - [winfo height .l]}]]
    destroy .f .l
    set res
} {{.f .l} 54 52}
test frame-14.2 {labelframe labelwidget option} {
    # Test the labelframe's reaction if the label is destroyed
    destroy .f .l
    label .l -text Aratherlonglabel
    labelframe .f -labelwidget .l
    pack .f
    label .f.l -text Mupp
    pack .f.l
    update
    set res [list [.f cget -labelwidget]]
    lappend res [expr {[winfo width .f] - [winfo width .l]}]
    destroy .l
    lappend res [.f cget -labelwidget]
    update
    lappend res [expr {[winfo width .f] - [winfo width .f.l]}]
    destroy .f
    set res
} {.l 12 {} 4}
test frame-14.3 {labelframe labelwidget option} {
    # Test the labelframe's reaction if the label is stolen
    destroy .f .l
    label .l -text Aratherlonglabel
    labelframe .f -labelwidget .l
    pack .f
    label .f.l -text Mupp
    pack .f.l
    update
    set res [list [.f cget -labelwidget]]
    lappend res [expr {[winfo width .f] - [winfo width .l]}]
    pack .l
    lappend res [.f cget -labelwidget]
    update
    lappend res [expr {[winfo width .f] - [winfo width .f.l]}]
    destroy .f .l
    set res
} {.l 12 {} 4}
test frame-14.4 {labelframe labelwidget option} {
    # Test the label's reaction if the labelframe is destroyed
    destroy .f .l
    label .l -text Mupp
    labelframe .f -labelwidget .l
    pack .f
    update
    set res [list [winfo manager .l]]
    destroy .f
    lappend res [winfo manager .l]
    destroy .l
    set res
} {labelframe {}}
test frame-14.5 {labelframe labelwidget option} {
    # Test that the labelframe reacts on changes in label
    destroy .f .l
    label .l -text Aratherlonglabel
    labelframe .f -labelwidget .l
    pack .f
    label .f.l -text Mupp
    pack .f.l
    update
    set first [winfo width .f]
    set res [expr {[winfo width .f] - [winfo width .l]}]
    .l configure -text Shorter
    update
    lappend res [expr {[winfo width .f] - [winfo width .l]}]
    lappend res [expr {[winfo width .f] < $first}]
    .l configure -text Alotlongerthananytimebefore
    update
    lappend res [expr {[winfo width .f] - [winfo width .l]}]
    lappend res [expr {[winfo width .f] > $first}]
    destroy .f .l
    set res
} {12 12 1 12 1}
test frame-14.6 {labelframe labelwidget option} {
    # Destroying a labelframe with a child label caused a crash
    # when not handling mapping of the label correctly.
    # This test does not test anything directly, it's just ment
    # to catch if the same mistake is made again.
    destroy .f
    labelframe .f
    pack .f
    label .f.l -text Mupp
    .f configure -labelwidget .f.l
    update
    destroy .f
} {}

catch {destroy .f}
rename eatColors {}
rename colorsFree {}

# cleanup
cleanupTests
return