Import Tk 8.6.10

tests/ttk/combobox.test

@@ -43,6 +43,17 @@ test combobox-2.4 "current -- value not in list" -body {
     .cb current
 } -result -1
 
+test combobox-2.5 "current -- set to end index" -body { 
+    .cb configure -values [list a b c d e thelastone]
+    .cb current end
+    .cb get
+} -result thelastone
+
+test combobox-2.6 "current -- set to unknown index" -body { 
+    .cb configure -values [list a b c d e]
+    .cb current notanindex
+} -returnCodes error -result {Incorrect index notanindex}
+
 test combobox-2.end "Cleanup" -body { destroy .cb }
 
 test combobox-3 "Read postoffset value dynamically from current style" -body {

tests/ttk/entry.test

@@ -77,9 +77,14 @@ test entry-2.1 "Create entry before scrollbar" -body {
 test entry-2.2 "Initial scroll position" -body {
     ttk::entry .e -font fixed -width 5 -xscrollcommand scroll
     .e insert end "0123456789"
-    pack .e; update
+    pack .e;
+    set timeout [after 500 {set $scrollInfo "timeout"}]
+    vwait scrollInfo
     set scrollInfo
-} -result {0.0 0.5} -cleanup { destroy .e }
+} -cleanup {
+    destroy .e
+    after cancel $timeout
+} -result {0.0 0.5}
 # NOTE: result can vary depending on font.
 
 # Bounding box / scrolling tests.
@@ -103,10 +108,37 @@ test entry-3.1 "bbox widget command" -body {
 test entry-3.2 "xview" -body {
     .e delete 0 end;
     .e insert end [string repeat "0" 40]
-    update idletasks
     set result [.e xview]
 } -result {0.0 0.5}
 
+test entry-3.3 "xview" -body {
+    .e delete 0 end;
+    .e insert end abcdefghijklmnopqrstuvwxyz
+    .e xview end
+    set result [.e index @0]
+} -result {7}
+
+test entry-3.4 "xview" -body {
+    .e delete 0 end;
+    .e insert end abcdefghijklmnopqrstuvwxyz
+    .e xview moveto 1.0
+    set result [.e index @0]
+} -result {7}
+
+test entry-3.5 "xview" -body {
+    .e delete 0 end;
+    .e insert end abcdefghijklmnopqrstuvwxyz
+    .e xview scroll 5 units
+    set result [.e index @0]
+} -result {5}
+
+test entry-3.6 "xview" -body {
+    .e delete 0 end;
+    .e insert end [string repeat abcdefghijklmnopqrstuvwxyz 5]
+    .e xview scroll 2 pages
+    set result [.e index @0]
+} -result {40}
+
 test entry-3.last "Series 3 cleanup" -body {
     destroy .e
 }

tests/ttk/notebook.test

@@ -69,7 +69,7 @@ test notebook-2.5 "tab - get all options" -body {
     .nb tab .nb.foo
 } -result [list \
     -padding 0 -sticky nsew \
-    -state normal -text "Changed Foo" -image "" -compound none -underline -1]
+    -state normal -text "Changed Foo" -image "" -compound {} -underline -1]
 
 test notebook-4.1 "Test .nb index end" -body {
     .nb index end

tests/ttk/scrollbar.test

@@ -4,16 +4,26 @@ loadTestedCommands
 
 testConstraint coreScrollbar [expr {[tk windowingsystem] eq "aqua"}]
 
-test scrollbar-swapout-1 "Use core scrollbars on OSX..." -constraints {
-    coreScrollbar
+# Before 2019 the code in library/ttk/scrollbar.tcl would replace the
+# constructor of ttk::scrollbar with the constructor of tk::scrollbar
+# unless the -class or -style options were specified..
+# Now there is an implementation of ttk::scrollbar for macOS.  The
+# tests are left in place, though, except that scrollbar-swapout-1
+# test was changed to expect the class to be TScrollbar instead of
+# Scrollbar.
+
+test scrollbar-swapout-1 "Don't use core scrollbars on OSX..." \
+ -constraints {
+     coreScrollbar
 } -body {
     ttk::scrollbar .sb -command "yadda"
     list [winfo class .sb] [.sb cget -command]
-} -result [list Scrollbar yadda] -cleanup { 
+} -result [list TScrollbar yadda] -cleanup { 
     destroy .sb 
 }
 
-test scrollbar-swapout-2 "... unless -style is specified ..." -constraints {
+test scrollbar-swapout-2 "... regardless of whether -style ..." \
+-constraints {
     coreScrollbar
 } -body {
     ttk::style layout Vertical.Custom.TScrollbar \
@@ -24,7 +34,7 @@ test scrollbar-swapout-2 "... unless -style is specified ..." -constraints {
     destroy .sb
 }
 
-test scrollbar-swapout-3 "... or -class." -constraints {
+test scrollbar-swapout-3 "... or -class is specified." -constraints {
     coreScrollbar
 } -body {
     ttk::scrollbar .sb -command "yadda" -class Custom.TScrollbar 
@@ -44,13 +54,19 @@ test scrollbar-1.1 "Set method" -body {
 
 test scrollbar-1.2 "Set orientation" -body {
     .tsb configure -orient vertical
-    set w [winfo reqwidth .tsb] ; set h [winfo reqheight .tsb]
+    pack .tsb -side right -anchor e -expand 1 -fill y
+    wm geometry . 200x200
+    update
+    set w [winfo width .tsb] ; set h [winfo height .tsb]
     expr {$h > $w}
 } -result 1
 
 test scrollbar-1.3 "Change orientation" -body {
     .tsb configure -orient horizontal
-    set w [winfo reqwidth .tsb] ; set h [winfo reqheight .tsb]
+    pack .tsb -side bottom -anchor s -expand 1 -fill x
+    wm geometry . 200x200
+    update
+    set w [winfo width .tsb] ; set h [winfo height .tsb]
     expr {$h < $w}
 } -result 1
 

tests/ttk/treeview.test

@@ -459,6 +459,31 @@ test treeview-8.5 "Selection - bad operation" -body {
     .tv selection badop foo
 } -returnCodes 1 -match glob -result {bad selection operation "badop": must be *}
 
+test treeview-8.6 "Selection - <<TreeviewSelect>> on selection add" -body {
+    .tv selection set {}
+    bind .tv <<TreeviewSelect>> {set res 1}
+    set res 0
+    .tv selection add newnode.n1
+    update
+    set res
+} -result {1}
+
+test treeview-8.7 "<<TreeviewSelect>> on selected item deletion" -body {
+    .tv selection set {}
+    .tv insert "" end -id selectedDoomed -text DeadItem
+    .tv insert "" end -id doomed -text AlsoDead
+    .tv selection add selectedDoomed
+    update
+    bind .tv <<TreeviewSelect>> {lappend res 1}
+    set res 0
+    .tv delete doomed
+    update
+    set res [expr {$res == 0}]
+    .tv delete selectedDoomed
+    update
+    set res
+} -result {1 1}
+
 ### NEED: more tests for see/yview/scrolling
 
 proc scrollcallback {args} {
@@ -471,6 +496,18 @@ test treeview-9.0 "scroll callback - empty tree" -body {
     set ::scrolldata
 } -result [list 0.0 1.0]
 
+test treeview-9.1 "scrolling" -setup {
+    pack [ttk::treeview .tree -show tree] -fill y
+    for {set i 1} {$i < 100} {incr i} {
+        .tree insert {} end -text $i
+    }
+} -body {
+    .tree yview scroll 5 units
+    .tree identify item 2 2
+} -cleanup {
+    destroy .tree
+} -result {I006}
+
 ### identify tests:
 #
 proc identify* {tv comps args} {
@@ -636,4 +673,111 @@ test treeview-3085489-2 "tag remove, no -tags" -setup {
     destroy .tv
 } -result [list]
 
+test treeview-368fa4561e "indicators cannot be clicked on leafs" -setup {
+    pack [ttk::treeview .tv]
+    .tv insert {} end -id foo -text "<-- (1) Click the blank space to my left" 
+    update
+} -body {
+    foreach {x y w h} [.tv bbox foo #0] {}
+    set res [.tv item foo -open]
+    # using $h even for x computation is intentional here in order to simulate
+    # a mouse click on the (invisible since we're on a leaf) indicator
+    event generate .tv <ButtonPress-1> \
+            -x [expr {$x + $h / 2}] \
+            -y [expr {$y + $h / 2}]
+    lappend res [.tv item foo -open]
+    .tv insert foo end -text "sub"
+    lappend res [.tv item foo -open]
+} -cleanup {
+    destroy .tv
+} -result {0 0 0}
+
+test treeview-ce470f20fd-1 "dragging further than the right edge of the treeview is allowed" -setup {
+    pack [ttk::treeview .tv]
+    .tv heading #0 -text "Drag my right edge -->" 
+    update
+} -body {
+    set res [.tv column #0 -width]
+    .tv drag #0 400
+    lappend res [expr {[.tv column #0 -width] > $res}]
+} -cleanup {
+    destroy .tv
+} -result {200 1}
+
+proc nostretch {tv} {
+    foreach col [$tv cget -columns] {
+        $tv column $col -stretch 0
+    }
+    $tv column #0 -stretch 0
+    update idletasks ; # redisplay $tv
+}
+
+test treeview-ce470f20fd-2 "changing -stretch resizes columns" -setup {
+    pack [ttk::treeview .tv -columns {bar colA colB colC foo}]
+    foreach col [.tv cget -columns] {
+        .tv heading $col -text $col
+    }
+    nostretch .tv
+    .tv column colA -width 50 ; .tv column colB -width 50 ; # slack created
+    update idletasks ; # redisplay treeview
+} -body {
+    # when no column is stretchable and one of them becomes stretchable
+    # the stretchable column takes the slack and the widget is redisplayed
+    # automatically at idle time
+    set res [.tv column colA -width]
+    .tv column colA -stretch 1
+    update idletasks ; # no slack anymore, widget redisplayed
+    lappend res [expr {[.tv column colA -width] > $res}]
+} -cleanup {
+    destroy .tv
+} -result {50 1}
+
+test treeview-ce470f20fd-3 "changing -stretch resizes columns" -setup {
+    pack [ttk::treeview .tv -columns {bar colA colB colC foo}]
+    foreach col [.tv cget -columns] {
+        .tv heading $col -text $col
+    }
+    .tv configure -displaycolumns {colB colA colC}
+    nostretch .tv
+    .tv column colA -width 50 ; .tv column colB -width 50 ; # slack created
+    update idletasks ; # redisplay treeview
+} -body {
+    # only some columns are displayed (and in a different order than declared
+    # in -columns), a displayed column becomes stretchable  --> the stretchable
+    # column expands
+    set res [.tv column colA -width]
+    .tv column colA -stretch 1
+    update idletasks ; # no slack anymore, widget redisplayed
+    lappend res [expr {[.tv column colA -width] > $res}]
+} -cleanup {
+    destroy .tv
+} -result {50 1}
+
+test treeview-ce470f20fd-4 "changing -stretch resizes columns" -setup {
+    pack [ttk::treeview .tv -columns {bar colA colB colC foo}]
+    foreach col [.tv cget -columns] {
+        .tv heading $col -text $col
+    }
+    .tv configure -displaycolumns {colB colA colC}
+    nostretch .tv
+    .tv column colA -width 50 ; .tv column bar -width 60 ; # slack created
+    update idletasks ; # redisplay treeview
+} -body {
+    # only some columns are displayed (and in a different order than declared
+    # in -columns), a non-displayed column becomes stretchable  --> nothing 
+    # happens
+    set origTreeWidth [winfo width .tv]
+    set res [list [.tv column bar -width] [.tv column colA -width]]
+    .tv column bar -stretch 1
+    update idletasks ; # no change, widget redisplayed
+    lappend res [.tv column bar -width] [.tv column colA -width]
+    # this column becomes visible  --> widget resizes
+    .tv configure -displaycolumns {bar colC colA colB}
+    update idletasks ; # no slack anymore because the widget resizes (shrinks)
+    lappend res [.tv column bar -width] [.tv column colA -width] \
+                [expr {[winfo width .tv] < $origTreeWidth}]
+} -cleanup {
+    destroy .tv
+} -result {60 50 60 50 60 50 1}
+
 tcltest::cleanupTests

tests/ttk/ttk.test

@@ -206,6 +206,7 @@ test ttk-2.8 "bug 3223850: button state disabled during click" -setup {
     destroy .b
     set ttk28 {}
     pack [ttk::button .b -command {set ::ttk28 failed}]
+    update
 } -body { 
     bind .b <ButtonPress-1> {after 0 {.b configure -state disabled}}
     after 1 {event generate .b <ButtonPress-1>}
@@ -269,7 +270,7 @@ test ttk-3.4 "SF#2009213" -body {
 test ttk-4.0 "Setup" -body {
     catch { destroy .t }
     pack [ttk::label .t -text "Button 1"]
-    testConstraint fontOption [expr ![catch { set prevFont [.t cget -font] }]]
+    testConstraint fontOption [expr {![catch { set prevFont [.t cget -font] }]}]
     ok
 }