Added labelframe widget. TIP#18.

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