# 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.7 2002/07/14 05:48:46 dgp Exp $ package require tcltest 2.1 namespace import -force tcltest::configure namespace import -force tcltest::testsDirectory configure -testdir [file join [pwd] [file dirname [info script]]] configure -loadfile [file join [testsDirectory] constraints.tcl] tcltest::loadTestedCommands # 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}} frame .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"}} {-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"}} } { set name [lindex $test 0] test frame-1.$i {frame configuration options} { .f configure $name [lindex $test 1] lindex [.f configure $name] 4 } [lindex $test 2] incr i if {[lindex $test 3] != ""} { test frame-1.$i {frame configuration options} { list [catch {.f configure $name [lindex $test 3]} msg] $msg } [list 1 [lindex $test 4]] } .f configure $name [lindex [.f configure $name] 3] incr i } destroy .f set i 1 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}} if [info exists env(DISPLAY)] { test frame-2.8 {toplevel configuration options} { 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.}} catch {destroy .t} toplevel .t -width 300 -height 150 wm geometry .t +0+0 update set i 11 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"}} } { set name [lindex $test 0] test frame-2.$i {toplevel configuration options} { .t configure $name [lindex $test 1] lindex [.t configure $name] 4 } [lindex $test 2] incr i if {[lindex $test 3] != ""} { test frame-2.$i {toplevel configuration options} { list [catch {.t configure $name [lindex $test 3]} msg] $msg } [list 1 [lindex $test 4]] } .t configure $name [lindex [.t configure $name] 3] incr i } test frame-3.1 {TkCreateFrame procedure} { list [catch frame msg] $msg } {1 {wrong # args: should be "frame pathName ?options?"}} test frame-3.2 {TkCreateFrame procedure} { catch {destroy .f} frame .f set result [.f configure -class] destroy .f set result } {-class class Class Frame Frame} test frame-3.3 {TkCreateFrame procedure} { catch {destroy .t} toplevel .t wm geometry .t +0+0 set result [.t configure -class] destroy .t set result } {-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} unixOnly { catch {destroy .t} catch {destroy .x} 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 set result "[expr [winfo rootx .x] - [winfo rootx .t]] [expr [winfo rooty .x] - [winfo rooty .t]] [winfo width .t] [winfo height .t]" destroy .t set result } {0 0 140 300} test frame-3.10 {TkCreateFrame procedure, -use option} unixOnly { catch {destroy .t} catch {destroy .x} 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 set result "[expr [winfo rootx .x] - [winfo rootx .t]] [expr [winfo rooty .x] - [winfo rooty .t]] [winfo width .t] [winfo height .t]" destroy .t option clear set 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 {([winfo visual .] == "pseudocolor") && ([winfo depth .] == 8)} { eatColors .t1 test frame-3.11 {TkCreateFrame procedure} {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} {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} {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} {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} {unixOnly nonPortable} { catch {destroy .t} catch {destroy .x} 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 set result "[colorsFree .t] [colorsFree .x]" destroy .t set result } {0 1} test frame-3.16 {TkCreateFrame procedure} {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} {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} if {[lsearch -exact [winfo visualsavailable .] {grayscale 8}] >= 0} { test frame-3.18 {TkCreateFrame procedure} {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} {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} {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} {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} } destroy .t1 } test frame-3.22 {TkCreateFrame procedure, default dimensions} { catch {destroy .t} 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] destroy .t set result } {200 200 1 1} test frame-3.23 {TkCreateFrame procedure} { catch {destroy .f} list [catch {frame .f -gorp glob} msg] $msg } {1 {unknown option "-gorp"}} test frame-3.24 {TkCreateFrame procedure} { catch {destroy .t} list [catch { toplevel .t -width 300 -height 200 -colormap new -bogus option wm geometry .t +0+0 } msg] $msg } {1 {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 {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"}} } { set name [lindex $test 0] test frame-13.$i {labelframe configuration options} { .f configure $name [lindex $test 1] lindex [.f configure $name] 4 } [lindex $test 2] incr i if {[lindex $test 3] != ""} { test frame-13.$i {labelframe configuration options} { list [catch {.f configure $name [lindex $test 3]} msg] $msg } [list 1 [lindex $test 4]] } .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 ::tcltest::cleanupTests return