merge trunk

12 files changed, 138 insertions, 76 deletions

diff --git a/.github/workflows/mac-build.yml b/.github/workflows/mac-build.yml
index a9a0c39..72a13d0 100644
--- a/.github/workflows/mac-build.yml
+++ b/.github/workflows/mac-build.yml
@@ -137,8 +137,6 @@ jobs:
             echo "::error::Failure during Test"
             exit 1
           }
-        env:
-          MAC_CI: 1
       - name: Carry out trial installation
         run: |
           make install || {
diff --git a/generic/tkEvent.c b/generic/tkEvent.c
index bb9b12d..698e9e1 100644
--- a/generic/tkEvent.c
+++ b/generic/tkEvent.c
@@ -1151,7 +1151,7 @@ Tk_HandleEvent(
 	    eventPtr->xany.send_event = -1;
 	    eventPtr->xkey.keycode = (but & 1) ? -120 : 120;
 	    if (but > Button5) {
-		eventPtr->xkey.state ^= ShiftMask;
+		eventPtr->xkey.state |= ShiftMask;
 	    }
 	}
     }
diff --git a/generic/tkInt.h b/generic/tkInt.h
index ee453ea..c171bf0 100644
--- a/generic/tkInt.h
+++ b/generic/tkInt.h
@@ -701,6 +701,10 @@ typedef struct TkMainInfo {
     struct TkMainInfo *nextPtr;	/* Next in list of all main windows managed by
 				 * this process. */
     Tcl_HashTable busyTable;	/* Information used by [tk busy] command. */
+    Tcl_ObjCmdProc *tclUpdateObjProc;
+				/* Saved Tcl [update] command, used to restore
+				 * Tcl's version of [update] after Tk is shut
+				 * down */
 } TkMainInfo;
 
 /*
@@ -1259,9 +1263,6 @@ MODULE_SCOPE int	Tk_SelectionObjCmd(ClientData clientData,
 MODULE_SCOPE int	Tk_SendObjCmd(ClientData clientData,
 			    Tcl_Interp *interp,int objc,
 			    Tcl_Obj *const objv[]);
-MODULE_SCOPE int	Tk_SendObjCmd(ClientData clientData,
-			    Tcl_Interp *interp, int objc,
-			    Tcl_Obj *const objv[]);
 MODULE_SCOPE int	Tk_SpinboxObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
@@ -1417,14 +1418,13 @@ MODULE_SCOPE void	TkUnixSetXftClipRegion(Region clipRegion);
 # define c_class class
 #endif
 
-#if TCL_UTF_MAX > 4
+/* Tcl 8.6 has a different definition of Tcl_UniChar than other Tcl versions for TCL_UTF_MAX > 3 */
+#if TCL_UTF_MAX > (3 + (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 6))
 #   define TkUtfToUniChar(src, ch) (size_t)(((int (*)(const char *, int *))Tcl_UtfToUniChar)(src, ch))
 #   define TkUniCharToUtf(ch, src) (size_t)(((int (*)(int, char *))Tcl_UniCharToUtf)(ch, src))
-#   define TkUtfPrev Tcl_UtfPrev
 #else
     MODULE_SCOPE size_t TkUtfToUniChar(const char *, int *);
     MODULE_SCOPE size_t TkUniCharToUtf(int, char *);
-    MODULE_SCOPE const char *TkUtfPrev(const char *, const char *);
 #endif
 
 #if defined(_WIN32) && !defined(STATIC_BUILD) && TCL_MAJOR_VERSION < 9
diff --git a/generic/tkTextIndex.c b/generic/tkTextIndex.c
index eea8f50..7d55331 100644
--- a/generic/tkTextIndex.c
+++ b/generic/tkTextIndex.c
@@ -436,7 +436,7 @@ TkTextMakeByteIndex(
 		 */
 
 		start = segPtr->body.chars + (byteIndex - index);
-		p = TkUtfPrev(start, segPtr->body.chars);
+		p = Tcl_UtfPrev(start, segPtr->body.chars);
 		p += TkUtfToUniChar(p, &ch);
 		indexPtr->byteIndex += p - start;
 	    }
@@ -2126,7 +2126,7 @@ TkTextIndexBackChars(
 	    if (segPtr->typePtr == &tkTextCharType) {
 		start = segPtr->body.chars;
 		end = segPtr->body.chars + segSize;
-		for (p = end; ; p = TkUtfPrev(p, start)) {
+		for (p = end; ; p = Tcl_UtfPrev(p, start)) {
 		    if (charCount == 0) {
 			dstPtr->byteIndex -= (end - p);
 			goto backwardCharDone;
@@ -2367,7 +2367,7 @@ StartEnd(
 		}
 		if (offset + 1 > 1) {
 		    chSize = (segPtr->body.chars + offset
-			    - TkUtfPrev(segPtr->body.chars + offset,
+			    - Tcl_UtfPrev(segPtr->body.chars + offset,
 			    segPtr->body.chars));
 		}
 		firstChar = 0;
diff --git a/generic/tkUtil.c b/generic/tkUtil.c
index 1e9c334..da2ce95 100644
--- a/generic/tkUtil.c
+++ b/generic/tkUtil.c
@@ -1196,7 +1196,8 @@ Tk_SendVirtualEvent(
     Tk_QueueWindowEvent(&event.general, TCL_QUEUE_TAIL);
 }
 
-#if TCL_UTF_MAX <= 4
+/* Tcl 8.6 has a different definition of Tcl_UniChar than other Tcl versions for TCL_UTF_MAX > 3 */
+#if TCL_UTF_MAX <= (3 + (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 6))
 /*
  *---------------------------------------------------------------------------
  *
@@ -1225,15 +1226,10 @@ TkUtfToUniChar(
     Tcl_UniChar uniChar = 0;
 
     size_t len = Tcl_UtfToUniChar(src, &uniChar);
-    if ((sizeof(Tcl_UniChar) == 2)
-	    && ((uniChar & 0xFC00) == 0xD800)
-#if TCL_MAJOR_VERSION > 8
-	    && (len == 1)
-#endif
-	) {
+    if ((uniChar & 0xFC00) == 0xD800) {
 	Tcl_UniChar low = uniChar;
-	/* This can only happen if Tcl is compiled with TCL_UTF_MAX=4,
-	 * or when a high surrogate character is detected in UTF-8 form */
+	/* This can only happen if sizeof(Tcl_UniChar)== 2 and src points
+	 * to a character > U+FFFF  */
 	size_t len2 = Tcl_UtfToUniChar(src+len, &low);
 	if ((low & 0xFC00) == 0xDC00) {
 	    *chPtr = (((uniChar & 0x3FF) << 10) | (low & 0x3FF)) + 0x10000;
@@ -1265,7 +1261,7 @@ TkUtfToUniChar(
 
 size_t TkUniCharToUtf(int ch, char *buf)
 {
-    if ((sizeof(Tcl_UniChar) == 2) && (((unsigned)(ch - 0x10000) <= 0xFFFFF))) {
+    if ((unsigned)(ch - 0x10000) <= 0xFFFFF) {
 	/* Spit out a 4-byte UTF-8 character or 2 x 3-byte UTF-8 characters, depending on Tcl
 	 * version and/or TCL_UTF_MAX build value */
 	int len = Tcl_UniCharToUtf(0xD800 | ((ch - 0x10000) >> 10), buf);
@@ -1273,44 +1269,6 @@ size_t TkUniCharToUtf(int ch, char *buf)
     }
     return Tcl_UniCharToUtf(ch, buf);
 }
-/*
- *---------------------------------------------------------------------------
- *
- * TkUtfPrev --
- *
- *	Almost the same as Tcl_UtfPrev.
- *	This function is capable of jumping over a upper/lower surrogate pair.
- *	So, might jump back up to 6 bytes.
- *
- * Results:
- *	pointer to the first byte of the current UTF-8 character. A surrogate
- *	pair is also handled as being a single entity.
- *
- * Side effects:
- *	None.
- *
- *---------------------------------------------------------------------------
- */
-
-const char *
-TkUtfPrev(
-    const char *src,	/* The UTF-8 string. */
-    const char *start)		/* Start position of string */
-{
-    const char *p = Tcl_UtfPrev(src, start);
-    const char *first = Tcl_UtfPrev(p, start);
-    int ch;
-
-#if TCL_UTF_MAX == 3
-    if ((src - start > 3) && ((src[-1] & 0xC0) == 0x80) && ((src[-2] & 0xC0) == 0x80)
-	    && ((src[-3] & 0xC0) == 0x80) && (UCHAR(src[-4]) >= 0xF0)) {
-	return src - 4;
-    }
-#endif
-
-    return (first + TkUtfToUniChar(first, &ch) >= src) ? first : p ;
-}
-
 #endif
 /*
  * Local Variables:
diff --git a/generic/tkWindow.c b/generic/tkWindow.c
index 2a98876..d3a6052 100644
--- a/generic/tkWindow.c
+++ b/generic/tkWindow.c
@@ -93,6 +93,7 @@ static const XSetWindowAttributes defAtts= {
 #define PASSMAINWINDOW 2
 #define WINMACONLY 4
 #define USEINITPROC 8
+#define SAVEUPDATECMD 16 /* better only be one of these! */
 
 typedef int (TkInitProc)(Tcl_Interp *interp, ClientData clientData);
 typedef struct {
@@ -126,7 +127,7 @@ static const TkCmd commands[] = {
     {"selection",	Tk_SelectionObjCmd,	PASSMAINWINDOW},
     {"tk",		(Tcl_ObjCmdProc *)(void *)TkInitTkCmd,  USEINITPROC|PASSMAINWINDOW|ISSAFE},
     {"tkwait",		Tk_TkwaitObjCmd,	PASSMAINWINDOW|ISSAFE},
-    {"update",		Tk_UpdateObjCmd,	PASSMAINWINDOW|ISSAFE},
+    {"update",		Tk_UpdateObjCmd,	PASSMAINWINDOW|ISSAFE|SAVEUPDATECMD},
     {"winfo",		Tk_WinfoObjCmd,		PASSMAINWINDOW|ISSAFE},
     {"wm",		Tk_WmObjCmd,		PASSMAINWINDOW},
 
@@ -876,6 +877,7 @@ TkCreateMainWindow(
     Tcl_InitHashTable(&mainPtr->imageTable, TCL_STRING_KEYS);
     mainPtr->strictMotif = 0;
     mainPtr->alwaysShowSelection = 0;
+    mainPtr->tclUpdateObjProc = NULL;
     if (Tcl_LinkVar(interp, "tk_strictMotif", (char *) &mainPtr->strictMotif,
 	    TCL_LINK_BOOLEAN) != TCL_OK) {
 	Tcl_ResetResult(interp);
@@ -915,6 +917,8 @@ TkCreateMainWindow(
 
     isSafe = Tcl_IsSafe(interp);
     for (cmdPtr = commands; cmdPtr->name != NULL; cmdPtr++) {
+	Tcl_CmdInfo cmdInfo;
+	
 	if (cmdPtr->objProc == NULL) {
 	    Tcl_Panic("TkCreateMainWindow: builtin command with NULL string and object procs");
 	}
@@ -934,6 +938,11 @@ TkCreateMainWindow(
 	} else {
 	    clientData = NULL;
 	}
+	if ((cmdPtr->flags & SAVEUPDATECMD) &&
+	    Tcl_GetCommandInfo(interp, cmdPtr->name, &cmdInfo) &&
+	    cmdInfo.isNativeObjectProc) {
+	    mainPtr->tclUpdateObjProc = cmdInfo.objProc;
+	}
 	if (cmdPtr->flags & USEINITPROC) {
 	    ((TkInitProc *)(void *)cmdPtr->objProc)(interp, clientData);
 	} else {
@@ -1496,10 +1505,20 @@ Tk_DestroyWindow(
 	     */
 
 	    if ((winPtr->mainPtr->interp != NULL) &&
-		    !Tcl_InterpDeleted(winPtr->mainPtr->interp)) {
+		!Tcl_InterpDeleted(winPtr->mainPtr->interp)) {
 		for (cmdPtr = commands; cmdPtr->name != NULL; cmdPtr++) {
-		    Tcl_CreateObjCommand(winPtr->mainPtr->interp, cmdPtr->name,
-			    TkDeadAppObjCmd, NULL, NULL);
+		    if ((cmdPtr->flags & SAVEUPDATECMD) &&
+			winPtr->mainPtr->tclUpdateObjProc != NULL) {
+			/* Restore Tcl's version of [update] */
+			Tcl_CreateObjCommand(winPtr->mainPtr->interp,
+					     cmdPtr->name,
+					     winPtr->mainPtr->tclUpdateObjProc,
+					     NULL, NULL);
+		    } else {
+			Tcl_CreateObjCommand(winPtr->mainPtr->interp,
+					     cmdPtr->name, TkDeadAppObjCmd,
+					     NULL, NULL);
+		    }
 		}
 		Tcl_CreateObjCommand(winPtr->mainPtr->interp, "send",
 			TkDeadAppObjCmd, NULL, NULL);
diff --git a/macosx/tkMacOSXMouseEvent.c b/macosx/tkMacOSXMouseEvent.c
index 46f20bc..7241e13 100644
--- a/macosx/tkMacOSXMouseEvent.c
+++ b/macosx/tkMacOSXMouseEvent.c
@@ -25,6 +25,13 @@ typedef struct {
     Point local;
 } MouseEventData;
 
+typedef struct {
+    uint64_t wheelTickPrev;	/* For high resolution wheels. */
+    double vWheelAcc;		/* For high resolution wheels (vertical). */
+    double hWheelAcc;		/* For high resolution wheels (horizontal). */
+} ThreadSpecificData;
+static Tcl_ThreadDataKey dataKey;
+
 static Tk_Window captureWinPtr = NULL;	/* Current capture window; may be
 					 * NULL. */
 
@@ -309,6 +316,8 @@ enum {
     } else {
 	CGFloat delta;
 	XEvent xEvent;
+	ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
+		Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
 
 	/*
 	 * For scroll wheel events we need to send the XEvent here.
@@ -323,19 +332,43 @@ enum {
 	xEvent.xany.display = Tk_Display(target);
 	xEvent.xany.window = Tk_WindowId(target);
 
-	delta = [theEvent deltaY] * 120;
+#define WHEEL_DELTA 120
+#define WHEEL_DELAY 300000000
+	uint64_t wheelTick = clock_gettime_nsec_np(CLOCK_MONOTONIC_RAW);
+	Bool timeout = (wheelTick - tsdPtr->wheelTickPrev) >= WHEEL_DELAY;
+	if (timeout) {
+	    tsdPtr->vWheelAcc = tsdPtr->hWheelAcc = 0;
+	}
+	tsdPtr->wheelTickPrev = wheelTick;
+	delta = [theEvent deltaY];
 	if (delta != 0.0) {
-	    xEvent.xbutton.state = state;
-	    xEvent.xkey.keycode = (delta > 0) ? ceil(delta) : floor(delta);
-	    xEvent.xany.serial = LastKnownRequestProcessed(Tk_Display(tkwin));
-	    Tk_QueueWindowEvent(&xEvent, TCL_QUEUE_TAIL);
+	    delta = (tsdPtr->vWheelAcc += delta);
+	    if (timeout && fabs(delta) < 1.0) {
+		delta = ((delta < 0.0) ? -1.0 : 1.0);
+	    }
+	    if (fabs(delta) >= 0.6) {
+		int intDelta = round(delta);
+		xEvent.xbutton.state = state;
+		xEvent.xkey.keycode = WHEEL_DELTA * intDelta;
+		tsdPtr->vWheelAcc -= intDelta;
+		xEvent.xany.serial = LastKnownRequestProcessed(Tk_Display(tkwin));
+		Tk_QueueWindowEvent(&xEvent, TCL_QUEUE_TAIL);
+	    }
 	}
-	delta = [theEvent deltaX] * 120;
+	delta = [theEvent deltaX];
 	if (delta != 0.0) {
-	    xEvent.xbutton.state = state | ShiftMask;
-	    xEvent.xkey.keycode = (delta > 0) ? ceil(delta) : floor(delta);
-	    xEvent.xany.serial = LastKnownRequestProcessed(Tk_Display(tkwin));
-	    Tk_QueueWindowEvent(&xEvent, TCL_QUEUE_TAIL);
+	    delta = (tsdPtr->hWheelAcc += delta);
+	    if (timeout && fabs(delta) < 1.0) {
+		delta = ((delta < 0.0) ? -1.0 : 1.0);
+	    }
+	    if (fabs(delta) >= 0.6) {
+	    int intDelta = round(delta);
+		xEvent.xbutton.state = state | ShiftMask;
+		xEvent.xkey.keycode = WHEEL_DELTA * intDelta;
+		tsdPtr->hWheelAcc -= intDelta;
+		xEvent.xany.serial = LastKnownRequestProcessed(Tk_Display(tkwin));
+		Tk_QueueWindowEvent(&xEvent, TCL_QUEUE_TAIL);
+	    }
 	}
     }
     return theEvent;
diff --git a/tests/event.test b/tests/event.test
index 4fc0cc4..48ffaed 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -828,6 +828,9 @@ test event-9 {no <Enter> event is generated for the container window when its
     pack propagate .top 0
     bind .top <Enter> {lappend res %W}
     pack [frame .top.f -bg green -width 50 -height 50] -anchor se -side bottom
+    # stabilize the test by giving some time to the OS before the upcoming update,
+    # so that -warp below finds the frame
+    after 50
     update
     event generate .top.f <Motion> -warp 1 -x 25 -y 25  ; # <Enter> sent to .top and .top.f
     controlPointerWarpTiming
diff --git a/tests/textTag.test b/tests/textTag.test
index 709a3cb..2d25f4c 100644
--- a/tests/textTag.test
+++ b/tests/textTag.test
@@ -1358,6 +1358,8 @@ test textTag-16.2 {TkTextPickCurrent procedure} -constraints {
     .t configure -font $textWidgetFont -wrap none
 } -body {
     .t tag configure big -font $bigFont
+    # update needed here to stabilize the test
+    update
     event gen .t <ButtonRelease-1> -state 0x100 -x $x4 -y $y4
     event gen .t <Motion> -x $x5 -y $y5
     set x [.t index current]
diff --git a/tests/tk.test b/tests/tk.test
index de738ef..f424c77 100644
--- a/tests/tk.test
+++ b/tests/tk.test
@@ -11,7 +11,7 @@ tcltest::loadTestedCommands
 namespace import -force tcltest::test
 
 testConstraint testprintf [llength [info command testprintf]]
-testConstraint failsOnQuarz [expr {![info exists ::env(MAC_CI)]}]
+testConstraint failsOnXQuarz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }]
 
 test tk-1.1 {tk command: general} -body {
     tk
@@ -155,7 +155,7 @@ test tk-6.3 {tk inactive wrong argument} -body {
 test tk-6.4 {tk inactive too many arguments} -body {
     tk inactive reset foo
 } -returnCodes 1 -result {wrong # args: should be "tk inactive ?-displayof window? ?reset?"}
-test tk-6.5 {tk inactive} -constraints failsOnQuarz -body {
+test tk-6.5 {tk inactive} -constraints failsOnXQuarz -body {
     tk inactive reset
     update
     after 100
diff --git a/tests/window.test b/tests/window.test
index dec2cc4..8a56d5a 100644
--- a/tests/window.test
+++ b/tests/window.test
@@ -263,6 +263,38 @@ test window-2.11 {Tk_DestroyWindow, don't reanimate a half-dead window} -constra
     list $error $msg
 } -result {0 YES}
 
+test window-2.12 {Test for ticket [9b6065d1fd] - restore Tcl [update] command} -constraints {
+    unixOrWin
+} -body {
+    set code [loadTkCommand]
+    append code {
+	after 1000 {set forever 1}
+	after 100 {destroy .}
+	after 200 {catch bell msg; puts "ringing the bell -> $msg"}
+	after 250 {update idletasks}
+	after 300 {update}
+	puts "waiting"
+	vwait forever
+	puts "done waiting"
+	catch {bell} msg
+	puts "bell -> $msg"
+	catch update msg
+	puts "update -> $msg"
+    }
+    set script [makeFile $code script]
+    if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} {
+        set error 1
+    } else {
+        set error 0
+    }
+    removeFile script
+    list $error $msg
+} -result {0 {waiting
+ringing the bell -> can't invoke "bell" command: application has been destroyed
+done waiting
+bell -> can't invoke "bell" command: application has been destroyed
+update -> }}
+
 
 test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} -constraints {
     unix testmenubar
@@ -342,6 +374,7 @@ test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} -con
 } -result {}
 
 
+
 # cleanup
 cleanupTests
 return
diff --git a/unix/tkUnixFont.c b/unix/tkUnixFont.c
index e30c07a..ccb9b30 100644
--- a/unix/tkUnixFont.c
+++ b/unix/tkUnixFont.c
@@ -238,6 +238,7 @@ static unsigned		RankAttributes(FontAttributes *wantPtr,
 static void		ReleaseFont(UnixFont *fontPtr);
 static void		ReleaseSubFont(Display *display, SubFont *subFontPtr);
 static int		SeenName(const char *name, Tcl_DString *dsPtr);
+#if TCL_MAJOR_VERSION < 9
 static int		Ucs2beToUtfProc(void *clientData, const char*src,
 			    int srcLen, int flags, Tcl_EncodingState*statePtr,
 			    char *dst, int dstLen, int *srcReadPtr,
@@ -246,6 +247,7 @@ static int		UtfToUcs2beProc(void *clientData, const char*src,
 			    int srcLen, int flags, Tcl_EncodingState*statePtr,
 			    char *dst, int dstLen, int *srcReadPtr,
 			    int *dstWrotePtr, int *dstCharsPtr);
+#endif
 
 /*
  *-------------------------------------------------------------------------
@@ -312,7 +314,9 @@ TkpFontPkgInit(
 	    Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
     SubFont dummy;
     int i;
+#if TCL_MAJOR_VERSION < 9
     Tcl_Encoding ucs2;
+#endif
 
     if (tsdPtr->controlFamily.encoding == NULL) {
 
@@ -333,6 +337,7 @@ TkpFontPkgInit(
 	 * if it doesn't exist yet. It is used in iso10646 fonts.
 	 */
 
+#if TCL_MAJOR_VERSION < 9
 	ucs2 = Tcl_GetEncoding(NULL, "ucs-2be");
 	if (ucs2 == NULL) {
 	    Tcl_EncodingType ucs2type = {"ucs-2be", Ucs2beToUtfProc, UtfToUcs2beProc, NULL, NULL, 2};
@@ -340,6 +345,7 @@ TkpFontPkgInit(
 	} else {
 	    Tcl_FreeEncoding(ucs2);
 	}
+#endif
 	Tcl_CreateThreadExitHandler(FontPkgCleanup, NULL);
     }
 }
@@ -458,6 +464,7 @@ ControlUtfProc(
  *-------------------------------------------------------------------------
  */
 
+#if TCL_MAJOR_VERSION < 9
 static int
 Ucs2beToUtfProc(
     TCL_UNUSED(void *),		/* Not used. */
@@ -554,6 +561,14 @@ Ucs2beToUtfProc(
  *-------------------------------------------------------------------------
  */
 
+#if defined(USE_TCL_STUBS)
+/* Since the UCS-2BE encoding is only used when Tk 8.7 is dynamically loaded in Tcl 8.6,
+ * make sure that Tcl_UtfCharComplete is ALWAYS the pre-TIP #575 version,
+ * even though Tk 8.7 is being compiled with -DTCL_NO_DEPRECATED! */
+#   undef Tcl_UtfCharComplete
+#   define Tcl_UtfCharComplete ((int (*)(const char *, int))(void *)((&tclStubsPtr->tcl_PkgProvideEx)[326]))
+#endif
+
 static int
 UtfToUcs2beProc(
     TCL_UNUSED(void *),	/* TableEncodingData that specifies
@@ -627,6 +642,7 @@ UtfToUcs2beProc(
     *dstCharsPtr = numChars;
     return result;
 }
+#endif
 
 /*
  *---------------------------------------------------------------------------