merge core-8-6-branch, and add (currently failing) test bind-34.3 demonstrating that warping does not work with null or negative coordinates. Also add a bit of debug printf in TkSetCursorPos() for Windows

7 files changed, 165 insertions, 30 deletions

diff --git a/tests/bind.test b/tests/bind.test
index 557d38e..20582df 100644
--- a/tests/bind.test
+++ b/tests/bind.test
@@ -5918,6 +5918,34 @@ test bind-28.8 {keysym names} -setup {
 } -cleanup {
     destroy .t.f
 } -result {X x {keysym X}}
+test bind-28.9 {keysym names, Eth -> ETH} -body {
+    frame .t.f -class Test -width 150 -height 100
+    bind .t.f <Eth> foo
+    bind .t.f
+} -cleanup {
+    destroy .t.f
+} -result {<Key-ETH>}
+test bind-28.10 {keysym names, Ooblique -> Oslash} -body {
+    frame .t.f -class Test -width 150 -height 100
+    bind .t.f <Ooblique> foo
+    bind .t.f
+} -cleanup {
+    destroy .t.f
+} -result {<Key-Oslash>}
+test bind-28.11 {keysym names, gcedilla} -body {
+    frame .t.f -class Test -width 150 -height 100
+    bind .t.f <gcedilla> foo
+    bind .t.f
+} -cleanup {
+    destroy .t.f
+} -result {<Key-gcedilla>}
+test bind-28.12 {keysym names, Greek_IOTAdiaeresis -> Greek_IOTAdieresis} -body {
+    frame .t.f -class Test -width 150 -height 100
+    bind .t.f <Greek_IOTAdiaeresis> foo
+    bind .t.f
+} -cleanup {
+    destroy .t.f
+} -result {<Key-Greek_IOTAdieresis>}
 
 
 test bind-29.1 {Tcl_BackgroundError procedure} -setup {
@@ -6641,6 +6669,25 @@ test bind-34.2 {-warp works relatively to the screen} -setup {
     lappend res {*}[winfo pointerxy .]
 } -cleanup {
 } -result {20 20 200 200}
+test bind-34.3 {-warp works with null or negative coordinates} -setup {
+} -body {
+    event generate {} <Motion> -x 0 -y 0 -warp 1
+    update idletasks ; # DoWarp is an idle callback
+    after 50         ; # Win specific - wait for SendInput to be executed
+    set res [winfo pointerxy .]
+    event generate {} <Motion> -x -1 -y -1 -warp 1
+    update idletasks ; # DoWarp is an idle callback
+    after 50         ; # Win specific - wait for SendInput to be executed
+    foreach dim [winfo pointerxy .] {
+        if {$dim <= 0} {
+            lappend res ok
+        } else {
+            lappend res $dim
+        }
+    }
+    set res
+} -cleanup {
+} -result {0 0 ok ok}
 
 # cleanup
 cleanupTests
diff --git a/tests/canvImg.test b/tests/canvImg.test
index aa6781d..a5e8e10 100644
--- a/tests/canvImg.test
+++ b/tests/canvImg.test
@@ -166,20 +166,20 @@ test canvImg-4.2 {ConfigureImage procedure} -constraints testImageType -setup {
     update
     set x {}
     set y {}
-    set timer [after 300 {lappend y "timeout"}]
+    set timer [after 300 {lappend y "timed out"}]
     .c itemconfigure i1 -image foo2
     update idletasks
     update
     # On MacOS we need to wait for the test image display procedure to run.
-    while {"timeout" ni $y && [lindex $y end 1] ne "display"} {
+    while {"timed out" ni $y && [lindex $y end 1] ne "display"} {
         vwait y
     }
     after cancel timer
     list $x $y [.c bbox i1]
 } -cleanup {
-	.c delete all
-	image delete foo
-	image delete foo2
+    .c delete all
+    image delete foo
+    image delete foo2
 } -result {{{foo free}} {{foo2 get} {foo2 display 0 0 80 60}} {50 100 130 160}}
 test canvImg-4.3 {ConfiugreImage procedure} -constraints testImageType -setup {
     .c delete all
@@ -741,14 +741,15 @@ test canvImg-10.1 {TranslateImage procedure} -constraints testImageType -setup {
     .c create image 50 100 -image foo -tags image -anchor nw
     update
     set x {}
+    set timer [after 500 {lappend x "timed out"}]
     foo changed 2 4 6 8 30 15
-    # macOS Catalina needs a delay here.
-    after 20
+    vwait x
+    after cancel $timer
     update
     return $x
 } -cleanup {
-	.c delete all
-	image delete foo
+    .c delete all
+    image delete foo
 } -result $result_10_1
 
 test canvImg-11.1 {TranslateImage procedure} -constraints testImageType -setup {
@@ -759,14 +760,15 @@ test canvImg-11.1 {TranslateImage procedure} -constraints testImageType -setup {
     .c create image 50 100 -image foo -tags image -anchor nw
     update
     set x {}
+    set timer [after 500 {lappend x "timed out"}]
     foo changed 2 4 6 8 40 50
-    # macOS Catalina needs a delay here.
-    after 20
+        vwait x
+    after cancel $timer
     update
     return $x
 } -cleanup {
-	.c delete all
-	image delete foo
+    .c delete all
+    image delete foo
 } -result {{foo display 0 0 40 50}}
 test canvImg-11.2 {ImageChangedProc procedure} -constraints {
 	testImageType 
@@ -796,22 +798,21 @@ test canvImg-11.3 {ImageChangedProc procedure} -constraints {
     update
 } -body {
     image create test foo -variable x
-    image create test foo2 -variable y
+    image create test foo2 -variable z
     foo changed 0 0 0 0 40 50
     foo2 changed 0 0 0 0 80 60
-
     .c create image 50 100 -image foo -tags image -anchor nw
     .c create image 70 110 -image foo2 -anchor nw
     update
-    set y {}
+    set z {}
+    set timer [after 500 {lappend z "timed out"}]
     image create test foo -variable x
-    # macOS Catalina needs a delay here.
-    after 20
-    update
-    return $y
+    vwait x
+    after cancel $timer
+    return $z
 } -cleanup {
-	.c delete all
-	image delete foo foo2
+    .c delete all
+    image delete foo foo2
 } -result $result_11_3
 
 # cleanup
diff --git a/tests/grab.test b/tests/grab.test
index 33399cb..653d756 100644
--- a/tests/grab.test
+++ b/tests/grab.test
@@ -12,10 +12,14 @@ eval tcltest::configure $argv
 tcltest::loadTestedCommands
 namespace import -force tcltest::test
 
-# There's currently no way to test the actual grab effect, per se,
-# in an automated test.  Therefore, this test suite only covers the
-# interface to the grab command (ie, error messages, etc.)
+# The macOS test module includes the pressbutton command to simulate a
+# mouse button press event by injecting events into the NSApplication
+# event queue.  On other platforms there is currently no way to test
+# the actual grab effect, per se, in an automated test.  Therefore,
+# this test suite only covers the interface to the grab command (ie,
+# error messages, etc.) on platforms other than macOS.
 
+testConstraint pressbutton [llength [info commands pressbutton]]
 
 test grab-1.1 {Tk_GrabObjCmd} -body {
     grab
@@ -182,6 +186,32 @@ test grab-5.2 {Tk_GrabObjCmd, grab set} -body {
     grab release .
 } -result {. global}
 
+test grab-6.1 {local grab on child window} -constraints {
+    pressbutton
+} -body {
+    wm geometry . 100x200+200+100
+    set result {}
+    frame .f -background red -padx 10 -pady 10 -height 100 -width 80
+    bind . <Button-1> {lappend result "outside"}
+    bind .f <Button-1> {lappend result "inside"}
+    pack .f
+    update idletasks
+    pressbutton 250 150
+    update
+    lappend result ":"
+    pressbutton 250 250
+    update
+    lappend result ":"
+    grab set .f
+    pressbutton 250 150
+    update
+    lappend result ":"
+    pressbutton 250 250
+    update
+    return $result
+} -cleanup {
+    grab release .f
+} -result {inside outside : outside : inside outside :}
 
 cleanupTests
 return
diff --git a/tests/ttk/entry.test b/tests/ttk/entry.test
index a920042..34795fe 100644
--- a/tests/ttk/entry.test
+++ b/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.
diff --git a/tests/ttk/notebook.test b/tests/ttk/notebook.test
index 3a2a6ff..ac63088 100644
--- a/tests/ttk/notebook.test
+++ b/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
diff --git a/tests/ttk/treeview.test b/tests/ttk/treeview.test
index 43a6527..c9dcf52 100644
--- a/tests/ttk/treeview.test
+++ b/tests/ttk/treeview.test
@@ -692,7 +692,7 @@ test treeview-368fa4561e "indicators cannot be clicked on leafs" -setup {
     destroy .tv
 } -result {0 0 0}
 
-test treeview-ce470f20fd-1 "dragging further than the right edge of the treeview is forbidden" -setup {
+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
@@ -702,7 +702,7 @@ test treeview-ce470f20fd-1 "dragging further than the right edge of the treeview
     lappend res [expr {[.tv column #0 -width] > $res}]
 } -cleanup {
     destroy .tv
-} -result {200 0}
+} -result {200 1}
 
 proc nostretch {tv} {
     foreach col [$tv cget -columns] {
diff --git a/tests/unixEmbed.test b/tests/unixEmbed.test
index 7d26fbf..2ebf9c2 100644
--- a/tests/unixEmbed.test
+++ b/tests/unixEmbed.test
@@ -85,6 +85,8 @@ proc colorsFree {w {red 31} {green 245} {blue 192}} {
 	    && ([lindex $vals 2]/256 == $blue)
 }
 
+testConstraint pressbutton [llength [info commands pressbutton]]
+
 test unixEmbed-1.1 {TkpUseWindow procedure, bad window identifier} -constraints {
 	unix
 } -setup {
@@ -1263,6 +1265,56 @@ test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} -con
 	deleteWindows
 } -result {70x300+0+0}
 
+test unixEmbed-11.1 {focus -force works for embedded toplevels} -constraints {
+	unix
+} -setup {
+	deleteWindows
+} -body {
+    toplevel .t
+    pack [frame .t.f -container 1 -width 200 -height 200] -fill both
+    update idletasks
+    toplevel .embed -use [winfo id .t.f] -bg green
+    update idletasks
+    focus -force .t
+    focus -force .embed
+    focus
+} -cleanup {
+    deleteWindows
+} -result .embed
+test unixEmbed-11.2 {mouse coordinates in embedded toplevels} -constraints {
+	unix pressbutton
+} -setup {
+	deleteWindows
+} -body {
+    toplevel .main
+    set result {}
+    pack [button .main.b -text "Main Button" \
+	      -command {lappend result ".main.b"}] -padx 30 -pady 30
+    pack [frame .main.f -container 1 -width 200 -height 200] -fill both
+    update idletasks
+    toplevel .embed -use [winfo id .main.f] -bg green
+    pack [button .embed.b -text "Emb Button" \
+	      -command {lappend result ".embed.b"}] -padx 30 -pady 30
+    wm geometry .main 200x400+100+100
+    update idletasks
+    focus -force .main
+    set x [expr {[winfo x .main ] + [winfo x .main.b] + 40}]
+    set y [expr {[winfo y .main ] + [winfo y .main.b] + 38}]
+    lappend result [winfo containing $x $y]
+    after 200
+    pressbutton $x $y
+    update
+    set y [expr {$y + 80}]
+    lappend result [winfo containing $x $y]
+    after 200
+    pressbutton $x $y
+    update
+    set result
+} -cleanup {
+    deleteWindows
+} -result {.main.b .main.b .embed.b .embed.b}
+
+
 # cleanup
 deleteWindows
 cleanupbg