Merge 8.7

8 files changed, 116 insertions, 29 deletions

diff --git a/generic/tkInt.h b/generic/tkInt.h
index 8a6e3f7..efc65b6 100644
--- a/generic/tkInt.h
+++ b/generic/tkInt.h
@@ -123,6 +123,17 @@
 #   endif
 #endif
 
+/*
+ * Fallback in case Tk is linked against a Tcl version not having TIP #585
+ * (TCL_INDEX_TEMP_TABLE flag). This allows to use the internal
+ * INDEX_TEMP_TABLE flag of Tcl. However this is rather ugly and not robust
+ * since nothing prevents Tcl from changing the value of its internal flags!
+ */
+
+#if !defined(TCL_INDEX_TEMP_TABLE)
+#   define TCL_INDEX_TEMP_TABLE 2
+#endif
+
 #ifndef TCL_Z_MODIFIER
 #   if defined(_WIN64)
 #	define TCL_Z_MODIFIER	"I"
diff --git a/macosx/tkMacOSXDefault.h b/macosx/tkMacOSXDefault.h
index 39535ef..d258118 100644
--- a/macosx/tkMacOSXDefault.h
+++ b/macosx/tkMacOSXDefault.h
@@ -74,7 +74,7 @@
 #define DEF_BUTTON_HEIGHT		"0"
 #define DEF_BUTTON_HIGHLIGHT_BG_COLOR	DEF_BUTTON_BG_COLOR
 #define DEF_BUTTON_HIGHLIGHT_BG_MONO	DEF_BUTTON_BG_MONO
-#define DEF_BUTTON_HIGHLIGHT		"systemButtonFrame"
+#define DEF_BUTTON_HIGHLIGHT		NORMAL_FG
 #define DEF_LABEL_HIGHLIGHT_WIDTH	"0"
 //#if TK_MAC_BUTTON_USE_COMPATIBILITY_METRICS
 //#define DEF_BUTTON_HIGHLIGHT_WIDTH	"4"
diff --git a/macosx/tkMacOSXFont.c b/macosx/tkMacOSXFont.c
index 00a0b9e..ab13fd0 100644
--- a/macosx/tkMacOSXFont.c
+++ b/macosx/tkMacOSXFont.c
@@ -1209,11 +1209,13 @@ TkpDrawAngledCharsInContext(
     TkSetMacColor(gc->foreground, &fg);
     attributes = [fontPtr->nsAttributes mutableCopy];
     [attributes setObject:(id)fg forKey:(id)kCTForegroundColorAttributeName];
+    CFRelease(fg);
     nsFont = [attributes objectForKey:NSFontAttributeName];
     [nsFont setInContext:GET_NSCONTEXT(context, NO)];
     CGContextSetTextMatrix(context, CGAffineTransformIdentity);
     attributedString = [[NSAttributedString alloc] initWithString:string
 	    attributes:attributes];
+    [string release];
     typesetter = CTTypesetterCreateWithAttributedString(
 	    (CFAttributedStringRef)attributedString);
     textX += (CGFloat) macWin->xOff;
@@ -1250,7 +1252,6 @@ TkpDrawAngledCharsInContext(
     CFRelease(line);
     CFRelease(typesetter);
     [attributedString release];
-    [string release];
     [attributes release];
     TkMacOSXRestoreDrawingContext(&drawingContext);
 }
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 e7e4286..780fc44 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