Patch [85c8397412]: Wrapper proc for exerting timing control over pointer warping.

5 files changed, 102 insertions, 31 deletions

diff --git a/tests/bind.test b/tests/bind.test
index 47b80ed..7a075fe 100644
--- a/tests/bind.test
+++ b/tests/bind.test
@@ -48,7 +48,7 @@ proc pointerAway {} {
     # but let's wait more (it depends on computer performance).
     after 100 ; update
     event generate .top <Button-1> -warp 1
-    update
+    controlPointerWarpTiming
     destroy .top
 }
 pointerAway
@@ -6153,6 +6153,7 @@ test bind-32.1 {-warp, window was destroyed before the idle callback DoWarp} -se
     update
 } -body {
     event generate .t.f <Button-1> -warp 1
+    controlPointerWarpTiming
     event generate .t.f <ButtonRelease-1>
     destroy .t.f
     update  ;  # shall simply not crash
@@ -6745,14 +6746,12 @@ test bind-34.1 {-warp works relatively to a window} -setup {
     wm geometry .top +200+200
     after 10 ; update
     event generate .top <Motion> -x 20 -y 20 -warp 1
-    update idletasks ; # DoWarp is an idle callback
-    after 50         ; # Win specific - wait for SendInput to be executed
+    controlPointerWarpTiming
     set pointerPos1 [winfo pointerxy .top]
     wm geometry .top +600+600
     after 10 ; update
     event generate .top <Motion> -x 20 -y 20 -warp 1
-    update idletasks ; # DoWarp is an idle callback
-    after 50         ; # Win specific - wait for SendInput to be executed
+    controlPointerWarpTiming
     set pointerPos2 [winfo pointerxy .top]
     # from the first warped position to the second one, the mouse
     # pointer should have moved the same amount as the window moved
@@ -6770,12 +6769,10 @@ test bind-34.2 {-warp works relatively to the screen} -setup {
 } -body {
     # Contrary to bind-34.1, we're directly checking screen coordinates
     event generate {} <Motion> -x 20 -y 20 -warp 1
-    update idletasks ; # DoWarp is an idle callback
-    after 50         ; # Win specific - wait for SendInput to be executed
+    controlPointerWarpTiming
     set res [winfo pointerxy .]
     event generate {} <Motion> -x 200 -y 200 -warp 1
-    update idletasks ; # DoWarp is an idle callback
-    after 50         ; # Win specific - wait for SendInput to be executed
+    controlPointerWarpTiming
     lappend res {*}[winfo pointerxy .]
 } -cleanup {
 } -result {20 20 200 200}
@@ -6793,8 +6790,7 @@ test bind-34.3 {-warp works with null or negative coordinates} -setup {
     set res {}
 } -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
+    controlPointerWarpTiming
     foreach dim [winfo pointerxy .] {
         if {$dim <= $halo} {
             lappend res ok
@@ -6803,9 +6799,9 @@ test bind-34.3 {-warp works with null or negative coordinates} -setup {
         }
     }
     event generate {} <Motion> -x 100 -y 100 -warp 1
-    update idletasks ; after 50
+    controlPointerWarpTiming
     event generate {} <Motion> -x -1 -y -1 -warp 1
-    update idletasks ; after 50
+    controlPointerWarpTiming
     foreach dim [winfo pointerxy .] {
         if {$dim <= $halo} {
             lappend res ok
@@ -6967,15 +6963,15 @@ test bind-36.1 {pointer warp with grab on toplevel, bug [e3888d5820]} -setup {
     after 50
     update
     event generate .top.l <Motion> -warp 1 -x 10 -y 10
-    update idletasks ; after 50
+    controlPointerWarpTiming
     foreach {x1 y1} [winfo pointerxy .top.l] {}
     event generate {} <Motion> -warp 1 -x 50 -y 50
-    update idletasks ; after 50
+    controlPointerWarpTiming
     grab release .top  ; # this will queue events
     after 50
     update
     event generate .top.l <Motion> -warp 1 -x 10 -y 10
-    update idletasks ; after 50
+    controlPointerWarpTiming
     foreach {x2 y2} [winfo pointerxy .top.l] {}
     # success if the coords are the same with or without the grab, and if they
     # are at (10,10) inside the label widget as requested by the warping
diff --git a/tests/constraints.tcl b/tests/constraints.tcl
index ee073cf..65609d6 100644
--- a/tests/constraints.tcl
+++ b/tests/constraints.tcl
@@ -172,6 +172,67 @@ namespace eval tk {
             return $r
         }
 
+	#
+	#  CONTROL TIMING ASPECTS OF POINTER WARPING
+	#
+	# The proc [controlPointerWarpTiming] takes care of the following timing
+	# details of pointer warping:
+	#
+	# a. Allow pointer warping to happen if it was scheduled for execution at
+	#    idle time.
+	#    - In Tk releases 8.6 and older, pointer warping is scheduled for
+	#      execution at idle time
+	#    - In release 8.7 and newer this happens synchronously and no extra
+	#      control is needed.
+	#    The namespace variable idle_pointer_warping records which of these is
+	#    the case.
+	#
+	# b. Work around a race condition associated with OS notification of
+	#    mouse motion on Windows.
+	#
+	#    When calling [event generate $w $event -warp 1 ...], the following
+	#    sequence occurs:
+	#    - At some point in the processing of this command, either via a
+	#      synchronous execution path, or asynchronously at idle time, Tk calls
+	#      an OS function* to carry out the mouse cursor motion.
+	#    - Tk has previously registered a callback function** with the OS, for
+	#      the OS to call in order to notify Tk when a mouse move is completed.
+	#    - Tk doesn't wait for the callback function to receive the notification
+	#      from the OS, but continues processing. This suits most use cases
+	#      because (usually) the notification comes quickly enough
+	#      (range: a few ms?). However ...
+	#    - A problem arises if Tk performs some processing, immediately following
+	#      up on [event generate $w $event -warp 1 ...], and that processing
+	#      relies on the mouse pointer having actually moved. If such processing
+	#      happens just before the notification from the OS has been received,
+	#      Tk will be using not yet updated info (e.g. mouse coordinates).
+	#
+	#         Hickup, choke etc ... !
+	#
+	#            *  the function SendInput() of the Win32 API
+	#            ** the callback function is TkWinChildProc()
+	#
+	#    This timing issue can be addressed by putting the Tk process on hold
+	#    (do nothing at all) for a somewhat extended amount of time, while
+	#    letting the OS complete its job in the meantime. This is what is
+	#    accomplished by calling [after ms].
+	#
+	#    ----
+	#    For the history of this issue please refer to Tk ticket [69b48f427e],
+	#    specifically the comment on 2019-10-27 14:24:26.
+	#
+	variable idle_pointer_warping [expr {![package vsatisfies [package provide Tk] 8.7-]}]
+	proc controlPointerWarpTiming {{duration 50}} {
+		variable idle_pointer_warping
+		if {$idle_pointer_warping} {
+			update idletasks ;# see a. above
+		}
+		if {[tk windowingsystem] eq "win32"} {
+			after $duration ;# see b. above
+		}
+	}
+	namespace export controlPointerWarpTiming
+
     }
 }
 
diff --git a/tests/event.test b/tests/event.test
index ea190de..32641be 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -876,7 +876,7 @@ test event-9 {no <Enter> event is generated for the container window when its
     pack [frame .top.f -bg green -width 50 -height 50] -anchor se -side bottom
     tkwait visibility .top.f
     event generate .top.f <Motion> -warp 1 -x 25 -y 25  ; # <Enter> sent to .top and .top.f
-    after 50  ; # Win specific - wait for SendInput to be executed
+    controlPointerWarpTiming
     update  ; # idletasks not enough
     destroy .top.f  ; # no <Enter> event sent
     update
diff --git a/tests/menu.test b/tests/menu.test
index ec43ad3..718643e 100644
--- a/tests/menu.test
+++ b/tests/menu.test
@@ -3941,9 +3941,8 @@ test menu-38.1 {Can't dismiss ttk::menubutton menu until mouse has hovered over
     pack .top.mb
     update
     # simulate mouse click on the menubutton, which posts its menu
-    event generate .top.mb <ButtonPress-1> -warp 1
-    update
-    after 50
+    event generate .top.mb <Button-1> -warp 1
+    controlPointerWarpTiming
     event generate .top.mb <ButtonRelease-1>
     update
     # simulate mouse click on the menu again, i.e. without
diff --git a/tests/textTag.test b/tests/textTag.test
index e36cf30..9e5ccdc 100644
--- a/tests/textTag.test
+++ b/tests/textTag.test
@@ -1492,7 +1492,8 @@ set y3 [expr {[lindex $c 1] + [lindex $c 3]/2}]
 test textTag-15.1 {TkTextBindProc} -constraints haveCourier12 -setup {
     .t tag delete x y
     wm geometry . +200+200 ; update
-    event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50
+    event generate {} <Motion> -warp 1 -x 5 -y 5
+    controlPointerWarpTiming
 } -body {
     bind .t <ButtonRelease> {lappend x up}
     .t tag bind x <ButtonRelease> {lappend x x-up}
@@ -1518,7 +1519,8 @@ test textTag-15.1 {TkTextBindProc} -constraints haveCourier12 -setup {
 test textTag-15.2 {TkTextBindProc} -constraints haveCourier12 -setup {
     .t tag delete x y
     wm geometry . +200+200 ; update
-    event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50
+    event generate {} <Motion> -warp 1 -x 5 -y 5
+    controlPointerWarpTiming
 } -body {
     .t tag bind x <Enter> {lappend x x-enter}
     .t tag bind x <ButtonPress> {lappend x x-down}
@@ -1547,7 +1549,8 @@ test textTag-15.2 {TkTextBindProc} -constraints haveCourier12 -setup {
 test textTag-15.3 {TkTextBindProc} -constraints haveCourier12 -setup {
     .t tag delete x y
     wm geometry . +200+200 ; update
-    event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50
+    event generate {} <Motion> -warp 1 -x 5 -y 5
+    controlPointerWarpTiming
 } -body {
     .t tag bind x <Enter> {lappend x x-enter}
     .t tag bind x <Any-ButtonPress-1> {lappend x x-down}
@@ -1583,7 +1586,8 @@ test textTag-16.1 {TkTextPickCurrent procedure} -constraints {
 } -setup {
     .t tag delete {*}[.t tag names]
     wm geometry . +200+200 ; update
-    event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50
+    event generate {} <Motion> -warp 1 -x 5 -y 5
+    controlPointerWarpTiming
 } -body {
     event gen .t <ButtonRelease-1> -state 0x100 -x $x1 -y $y1
     set x [.t index current]
@@ -1606,7 +1610,8 @@ test textTag-16.2 {TkTextPickCurrent procedure} -constraints {
 } -setup {
     .t tag delete {*}[.t tag names]
     wm geometry . +200+200 ; update
-    event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50
+    event generate {} <Motion> -warp 1 -x 5 -y 5
+    controlPointerWarpTiming
 } -body {
     .t tag configure big -font $bigFont
     # update needed here to stabilize the test
@@ -1628,7 +1633,8 @@ test textTag-16.3 {TkTextPickCurrent procedure} -constraints {
         .t tag remove $i 1.0 end
     }
     wm geometry . +200+200 ; update
-    event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50
+    event generate {} <Motion> -warp 1 -x 5 -y 5
+    controlPointerWarpTiming
 } -body {
     foreach i {a b c d} {
         .t tag bind $i <Enter> "lappend x enter-$i"
@@ -1658,7 +1664,8 @@ test textTag-16.4 {TkTextPickCurrent procedure} -constraints {
         .t tag remove $i 1.0 end
     }
     wm geometry . +200+200 ; update
-    event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50
+    event generate {} <Motion> -warp 1 -x 5 -y 5
+    controlPointerWarpTiming
 } -body {
     foreach i {a b c d} {
         .t tag bind $i <Enter> "lappend x enter-$i"
@@ -1687,7 +1694,8 @@ test textTag-16.5 {TkTextPickCurrent procedure} -constraints {
         .t tag remove $i 1.0 end
     }
     wm geometry . +200+200 ; update
-    event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50
+    event generate {} <Motion> -warp 1 -x 5 -y 5
+    controlPointerWarpTiming
 } -body {
     .t tag configure big -font $bigFont
     event gen .t <Motion> -x $x1 -y $y1
@@ -1706,7 +1714,8 @@ test textTag-16.6 {TkTextPickCurrent procedure} -constraints {
         .t tag remove $i 1.0 end
     }
     wm geometry . +200+200 ; update
-    event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50
+    event generate {} <Motion> -warp 1 -x 5 -y 5
+    controlPointerWarpTiming
 } -body {
     .t tag configure big -font $bigFont
     event gen .t <Motion> -x $x1 -y $y1
@@ -1726,7 +1735,8 @@ test textTag-16.7 {TkTextPickCurrent procedure} -constraints {
         .t tag remove $i 1.0 end
     }
     wm geometry . +200+200 ; update
-    event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50
+    event generate {} <Motion> -warp 1 -x 5 -y 5
+    controlPointerWarpTiming
 } -body {
     .t tag configure big -font $bigFont
     .t tag bind a <Enter> {.t tag add big 3.0 3.2}
@@ -1757,7 +1767,8 @@ test textTag-17.1 {insert procedure inserts tags} -setup {
 test textTag-18.1 {TkTextPickCurrent tag bindings} -setup {
     destroy .t
     wm geometry . +200+200 ; update
-    event generate {} <Motion> -warp 1 -x 5 -y 5 ; update idletasks ; after 50
+    event generate {} <Motion> -warp 1 -x 5 -y 5
+    controlPointerWarpTiming
 } -body {
     text .t -width 30 -height 4 -relief sunken -borderwidth 10 \
       -highlightthickness 10 -pady 2
@@ -1774,6 +1785,10 @@ test textTag-18.1 {TkTextPickCurrent tag bindings} -setup {
     set res {}
     # Bindings must not trigger on the widget border, only over
     # the actual tagged characters themselves.
+    # Note that we don't need to call controlPointerWarpTiming
+    # in the following six calls because we're not checking that
+    # the mouse pointer has actually moved but rather that the
+    # tag binding mechanism of the text widget correctly triggers.
     event gen .t <Motion> -warp 1 -x 0 -y 0 ; update
     event gen .t <Motion> -warp 1 -x 10 -y 10 ; update
     event gen .t <Motion> -warp 1 -x 25 -y 25 ; update