summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorjan.nijtmans <nijtmans@users.sourceforge.net>2021-04-27 13:47:32 (GMT)
committerjan.nijtmans <nijtmans@users.sourceforge.net>2021-04-27 13:47:32 (GMT)
commit668bf78c9bc16a0ba316241f1e2262b9ce4a9a30 (patch)
treeedc7c099a79b4905416343b26f1cce23ce5bd797
parent1df699cb6d8b09689e447d9a18fd9549e11206ff (diff)
parent3518f5614a393f2761dc58f4baa386115cbda33d (diff)
downloadtk-668bf78c9bc16a0ba316241f1e2262b9ce4a9a30.zip
tk-668bf78c9bc16a0ba316241f1e2262b9ce4a9a30.tar.gz
tk-668bf78c9bc16a0ba316241f1e2262b9ce4a9a30.tar.bz2
Merge 8.7
-rw-r--r--generic/tkInt.h11
-rw-r--r--macosx/tkMacOSXDefault.h2
-rw-r--r--macosx/tkMacOSXFont.c3
-rw-r--r--tests/bind.test26
-rw-r--r--tests/constraints.tcl61
-rw-r--r--tests/event.test2
-rw-r--r--tests/menu.test3
-rw-r--r--tests/textTag.test37
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