#
# RCS: @(#) $Id$
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-foreach i [winfo children .] {
- catch {destroy $i}
-}
-wm geometry . {}
-raise .
+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
} {{-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} {
- list [catch {frame .f -colormap new} msg] $msg
-} {0 .f}
+ 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} {
- list [catch {frame .f -visual default} msg] $msg
-} {0 .f}
+ 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
{-highlightcolor #123456 #123456 non-existent
{unknown color name "non-existent"}}
{-highlightthickness 6 6 badValue {bad screen distance "badValue"}}
- {-relief ridge ridge badValue {bad relief type "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
+ {-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"}}
} {
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 8
+set i 11
foreach test {
{-background #ff0000 #ff0000 non-existent
{unknown color name "non-existent"}}
{-highlightcolor #123456 #123456 non-existent
{unknown color name "non-existent"}}
{-highlightthickness 3 3 badValue {bad screen distance "badValue"}}
- {-relief ridge ridge badValue {bad relief type "badValue": must be flat, groove, raised, ridge, solid, or sunken}}
+ {-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 {frame configuration options} {
+ 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 {frame configuration options} {
+ test frame-2.$i {toplevel configuration options} {
list [catch {.t configure $name [lindex $test 3]} msg] $msg
} [list 1 [lindex $test 4]]
}
test frame-5.1 {FrameWidgetCommand procedure} {
list [catch .f msg] $msg
} {1 {wrong # args: should be ".f option ?arg arg ...?"}}
-test scale-5.2 {FrameWidgetCommand procedure, cget option} {
+test frame-5.2 {FrameWidgetCommand procedure, cget option} {
list [catch {.f cget} msg] $msg
} {1 {wrong # args: should be ".f cget option"}}
-test scale-5.3 {FrameWidgetCommand procedure, 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 scale-5.4 {FrameWidgetCommand procedure, cget option} {
+test frame-5.4 {FrameWidgetCommand procedure, cget option} {
list [catch {.f cget -gorp} msg] $msg
} {1 {unknown option "-gorp"}}
-test scale-5.5 {FrameWidgetCommand procedure, cget option} {
+test frame-5.5 {FrameWidgetCommand procedure, cget option} {
.f cget -highlightcolor
} {black}
-test scale-5.6 {FrameWidgetCommand procedure, cget option} {
+test frame-5.6 {FrameWidgetCommand procedure, cget option} {
list [catch {.f cget -screen} msg] $msg
} {1 {unknown option "-screen"}}
-test scale-5.7 {FrameWidgetCommand procedure, cget option} {
+test frame-5.7 {FrameWidgetCommand procedure, cget option} {
catch {destroy .t}
toplevel .t
catch {.t cget -screen}
catch {destroy .t}
test frame-5.8 {FrameWidgetCommand procedure, configure option} {
llength [.f configure]
-} {16}
+} {18}
test frame-5.9 {FrameWidgetCommand procedure, configure option} {
list [catch {.f configure -gorp} msg] $msg
} {1 {unknown option "-gorp"}}
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}
lappend result [info commands .frame2]
} {.frame2 {}}
test frame-7.2 {FrameEventProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
frame .f1 -bg #543210
rename .f1 .f2
set x {}
} {.f1 #543210 {} {}}
test frame-8.1 {FrameCmdDeletedProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
frame .f1
rename .f1 {}
list [info command .f*] [winfo children .]
} {{} {}}
test frame-8.2 {FrameCmdDeletedProc procedure} {
- eval destroy [winfo children .]
+ deleteWindows
toplevel .f1 -menu .m
wm geometry .f1 +0+0
update
} {0}
set l [interp hidden]
-eval destroy [winfo children .]
+deleteWindows
test frame-10.1 {frame widget vs hidden commands} {
catch {destroy .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 {}
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
OSDN Git Service
