summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authorpspjuth <peter.spjuth@gmail.com>2001-09-26 21:36:19 (GMT)
committerpspjuth <peter.spjuth@gmail.com>2001-09-26 21:36:19 (GMT)
commit071818f331706f06d0498f1f9d5f4e9121395daf (patch)
tree20c06e6412fd77d17f1141ae292692607300a6da /tests
parent05383a493ead1b30256c79a19782ecdbfa74522a (diff)
downloadtk-071818f331706f06d0498f1f9d5f4e9121395daf.zip
tk-071818f331706f06d0498f1f9d5f4e9121395daf.tar.gz
tk-071818f331706f06d0498f1f9d5f4e9121395daf.tar.bz2
Added labelframe widget. TIP#18.
Diffstat (limited to 'tests')
-rw-r--r--tests/frame.test284
-rw-r--r--tests/grid.test37
-rw-r--r--tests/pack.test38
-rw-r--r--tests/place.test19
4 files changed, 350 insertions, 28 deletions
diff --git a/tests/frame.test b/tests/frame.test
index 8f5644b..7e7746c 100644
--- a/tests/frame.test
+++ b/tests/frame.test
@@ -7,7 +7,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: frame.test,v 1.5 2001/05/28 16:56:02 pspjuth Exp $
+# RCS: @(#) $Id: frame.test,v 1.6 2001/09/26 21:36:19 pspjuth Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -65,12 +65,14 @@ test frame-1.1 {frame configuration options} {
} {{-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
@@ -105,6 +107,8 @@ foreach test {
{-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"}}
@@ -206,6 +210,8 @@ foreach test {
{-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"}}
} {
@@ -458,22 +464,22 @@ 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 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}
@@ -481,7 +487,7 @@ test scale-5.7 {FrameWidgetCommand procedure, cget option} {
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"}}
@@ -494,6 +500,9 @@ test frame-5.11 {FrameWidgetCommand procedure, configure option} {
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}
@@ -624,6 +633,244 @@ test frame-11.2 {TkInstallFrameMenu - frame renamed} {
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 {}
@@ -632,16 +879,3 @@ rename colorsFree {}
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/grid.test b/tests/grid.test
index b7711a0..9342d9f 100644
--- a/tests/grid.test
+++ b/tests/grid.test
@@ -5,7 +5,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: grid.test,v 1.13 2001/09/23 11:30:44 pspjuth Exp $
+# RCS: @(#) $Id: grid.test,v 1.14 2001/09/26 21:36:19 pspjuth Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -1360,6 +1360,41 @@ test grid-17.1 {forget and pending idle handlers} {
set result ok
} ok
+test grid-18.1 {test respect for internalborder} {
+ toplevel .pack
+ wm geometry .pack 200x200
+ frame .pack.l -width 15 -height 10
+ labelframe .pack.lf -labelwidget .pack.l
+ pack .pack.lf -fill both -expand 1
+ frame .pack.lf.f
+ grid .pack.lf.f -sticky news
+ grid columnconfigure .pack.lf 0 -weight 1
+ grid rowconfigure .pack.lf 0 -weight 1
+ update
+ set res [list [winfo geometry .pack.lf.f]]
+ .pack.lf configure -labelanchor e -padx 3 -pady 5
+ update
+ lappend res [winfo geometry .pack.lf.f]
+ destroy .pack
+ set res
+} {196x188+2+10 177x186+5+7}
+test grid-18.2 {test support for minreqsize} {
+ toplevel .pack
+ wm geometry .pack {}
+ frame .pack.l -width 150 -height 100
+ labelframe .pack.lf -labelwidget .pack.l
+ pack .pack.lf -fill both -expand 1
+ frame .pack.lf.f -width 20 -height 25
+ grid .pack.lf.f
+ update
+ set res [list [winfo geometry .pack.lf]]
+ .pack.lf configure -labelanchor ws
+ update
+ lappend res [winfo geometry .pack.lf]
+ destroy .pack
+ set res
+} {162x127+0+0 172x112+0+0}
+
# cleanup
::tcltest::cleanupTests
return
diff --git a/tests/pack.test b/tests/pack.test
index d05854f..395b3f2 100644
--- a/tests/pack.test
+++ b/tests/pack.test
@@ -6,7 +6,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: pack.test,v 1.8 2001/09/23 11:30:44 pspjuth Exp $
+# RCS: @(#) $Id: pack.test,v 1.9 2001/09/26 21:36:19 pspjuth Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -1060,6 +1060,42 @@ test pack-18.2 {unmap slaves when master unmapped} {
update
lappend result [winfo ismapped .pack.b]
} {1 0 100 30 0 1}
+
+test pack-19.1 {test respect for internalborder} {
+ catch {eval pack forget [pack slaves .pack]}
+ destroy .pack.l .pack.lf
+ wm geometry .pack 200x200
+ frame .pack.l -width 15 -height 10
+ labelframe .pack.lf -labelwidget .pack.l
+ pack .pack.lf -fill both -expand 1
+ frame .pack.lf.f
+ pack .pack.lf.f -fill both -expand 1
+ update
+ set res [list [winfo geometry .pack.lf.f]]
+ .pack.lf configure -labelanchor e -padx 3 -pady 5
+ update
+ lappend res [winfo geometry .pack.lf.f]
+ destroy .pack.l .pack.lf
+ set res
+} {196x188+2+10 177x186+5+7}
+test pack-19.2 {test support for minreqsize} {
+ catch {eval pack forget [pack slaves .pack]}
+ destroy .pack.l .pack.lf
+ wm geometry .pack {}
+ frame .pack.l -width 150 -height 100
+ labelframe .pack.lf -labelwidget .pack.l
+ pack .pack.lf -fill both -expand 1
+ frame .pack.lf.f -width 20 -height 25
+ pack .pack.lf.f
+ update
+ set res [list [winfo geometry .pack.lf]]
+ .pack.lf configure -labelanchor ws
+ update
+ lappend res [winfo geometry .pack.lf]
+ destroy .pack.l .pack.lf
+ set res
+} {162x127+0+0 172x112+0+0}
+
destroy .pack
foreach i {pack1 pack2 pack3 pack4} {
rename $i {}
diff --git a/tests/place.test b/tests/place.test
index 1dc2dfa..2d25e3c 100644
--- a/tests/place.test
+++ b/tests/place.test
@@ -5,7 +5,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: place.test,v 1.5 2000/08/10 00:21:08 ericm Exp $
+# RCS: @(#) $Id: place.test,v 1.6 2001/09/26 21:36:19 pspjuth Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -353,6 +353,23 @@ test place-12.1 {PlaceObjCmd, forget command} {
set res
} [list 1 0]
+test place-13.1 {test respect for internalborder} {
+ toplevel .pack
+ wm geometry .pack 200x200
+ frame .pack.l -width 15 -height 10
+ labelframe .pack.lf -labelwidget .pack.l
+ pack .pack.lf -fill both -expand 1
+ frame .pack.lf.f
+ place .pack.lf.f -x 0 -y 0 -relwidth 1.0 -relheight 1.0
+ update
+ set res [list [winfo geometry .pack.lf.f]]
+ .pack.lf configure -labelanchor e -padx 3 -pady 5
+ update
+ lappend res [winfo geometry .pack.lf.f]
+ destroy .pack
+ set res
+} {196x188+2+10 177x186+5+7}
+
catch {destroy .t}
# cleanup