diff options
| -rw-r--r-- | tests/bind.test | 26 | ||||
| -rw-r--r-- | tests/constraints.tcl | 61 | ||||
| -rw-r--r-- | tests/event.test | 2 | ||||
| -rw-r--r-- | tests/menu.test | 3 | ||||
| -rw-r--r-- | tests/textTag.test | 37 |
5 files changed, 102 insertions, 27 deletions
diff --git a/tests/bind.test b/tests/bind.test index c27412d..cd07b09 100644 --- a/tests/bind.test +++ b/tests/bind.test @@ -45,7 +45,7 @@ toplevel .top wm geometry .top 50x50-50-50 update event generate .top <Button-1> -warp 1 -update +controlPointerWarpTiming destroy .top test bind-1.1 {bind command} -body { @@ -6248,7 +6248,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 - after 50 ; # Win specific - wait for SendInput to be executed + controlPointerWarpTiming event generate .t.f <ButtonRelease-1> destroy .t.f update ; # shall simply not crash @@ -6829,12 +6829,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 - 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 - 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 @@ -6852,10 +6852,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 - after 50 ; # Win specific - wait for SendInput to be executed + controlPointerWarpTiming set res [winfo pointerxy .] event generate {} <Motion> -x 200 -y 200 -warp 1 - after 50 ; # Win specific - wait for SendInput to be executed + controlPointerWarpTiming lappend res {*}[winfo pointerxy .] } -cleanup { } -result {20 20 200 200} @@ -6873,7 +6873,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 - after 50 ; # Win specific - wait for SendInput to be executed + controlPointerWarpTiming foreach dim [winfo pointerxy .] { if {$dim <= $halo} { lappend res ok @@ -6882,9 +6882,9 @@ test bind-34.3 {-warp works with null or negative coordinates} -setup { } } event generate {} <Motion> -x 100 -y 100 -warp 1 - after 50 ; # Win specific - wait for SendInput to be executed + controlPointerWarpTiming event generate {} <Motion> -x -1 -y -1 -warp 1 - after 50 ; # Win specific - wait for SendInput to be executed + controlPointerWarpTiming foreach dim [winfo pointerxy .] { if {$dim <= $halo} { lappend res ok @@ -7029,7 +7029,7 @@ test bind-35.3 {Events agree for modifier keys} -constraints {aqua} -setup { test bind-36.1 {pointer warp with grab on toplevel, bug [e3888d5820]} -setup { event generate {} <Motion> -warp 1 -x 50 -y 50 - after 50 ; # Win specific - wait for SendInput to be executed + controlPointerWarpTiming toplevel .top grab release .top wm geometry .top 200x200+300+300 @@ -7045,13 +7045,13 @@ test bind-36.1 {pointer warp with grab on toplevel, bug [e3888d5820]} -setup { } -body { grab .top event generate .top.l <Motion> -warp 1 -x 10 -y 10 - after 50 ; # Win specific - wait for SendInput to be executed + controlPointerWarpTiming foreach {x1 y1} [winfo pointerxy .top.l] {} event generate {} <Motion> -warp 1 -x 50 -y 50 - after 50 ; # Win specific - wait for SendInput to be executed + controlPointerWarpTiming grab release .top event generate .top.l <Motion> -warp 1 -x 10 -y 10 - after 50 ; # Win specific - wait for SendInput to be executed + 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 a89605a..66ac1eb 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 c649303..fe23743 100644 --- a/tests/event.test +++ b/tests/event.test @@ -833,7 +833,7 @@ test event-9 {no <Enter> event is generated for the container window when its update focus -force .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 fdd5969..f830156 100644 --- a/tests/menu.test +++ b/tests/menu.test @@ -3958,8 +3958,7 @@ test menu-38.1 {Can't dismiss ttk::menubutton menu until mouse has hovered over update # simulate mouse click on the menubutton, which posts its menu event generate .top.mb <Button-1> -warp 1 - update - after 50 + 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 b703a81..2d25f4c 100644 --- a/tests/textTag.test +++ b/tests/textTag.test @@ -1237,7 +1237,8 @@ set y5 [expr [lindex $c 1] + [lindex $c 3]/2] test textTag-15.1 {TkTextBindProc} -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} @@ -1263,7 +1264,8 @@ test textTag-15.1 {TkTextBindProc} -setup { test textTag-15.2 {TkTextBindProc} -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 <Button> {lappend x x-down} @@ -1292,7 +1294,8 @@ test textTag-15.2 {TkTextBindProc} -setup { test textTag-15.3 {TkTextBindProc} -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 <Button-1> {lappend x x-down} @@ -1326,7 +1329,8 @@ test textTag-15.3 {TkTextBindProc} -setup { test textTag-16.1 {TkTextPickCurrent procedure} -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] @@ -1349,7 +1353,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 .t configure -font $textWidgetFont -wrap none } -body { .t tag configure big -font $bigFont @@ -1371,7 +1376,8 @@ test textTag-16.3 {TkTextPickCurrent procedure} -setup { .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" @@ -1399,7 +1405,8 @@ test textTag-16.4 {TkTextPickCurrent procedure} -setup { .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" @@ -1428,7 +1435,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 .t configure -font $textWidgetFont -wrap none } -body { .t tag configure big -font $bigFont @@ -1449,7 +1457,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 .t configure -font $textWidgetFont -wrap none } -body { .t tag configure big -font $bigFont @@ -1471,7 +1480,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 .t configure -font $textWidgetFont -wrap none } -body { .t tag configure big -font $bigFont @@ -1504,7 +1514,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 @@ -1521,6 +1532,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 |