Merge trunk

14 files changed, 189 insertions, 61 deletions

diff --git a/doc/zipfs.n b/doc/zipfs.n
index f4e2949..2cf00aa 100644
--- a/doc/zipfs.n
+++ b/doc/zipfs.n
@@ -131,7 +131,7 @@ The command returns the normalized mount point path.
 If not under the zipfs file system root, \fImountpoint\fR is normalized with
 respect to it. For example, a mount point passed as either \fBmt\fR or \fB/mt\fR
 would be normalized to \fB//zipfs:/mt\fR (given that \fBzipfs root\fR
-returns 
+returns
 .QW //zipfs:/ ).
 An error is raised if the mount point includes a drive or UNC volume.
 .PP
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 1878d27..a979ab9 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -463,7 +463,7 @@ static const UnsafeEnsembleInfo unsafeEnsembleCommands[] = {
     {"process", "status"},
     {"process", "purge"},
     {"process", "autopurge"},
-    /* 
+    /*
      * [zipfs] perhaps has some safe commands. But like file make it inaccessible
      * until they are analyzed to be safe.
      */
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 64fb1b6..ae73c77 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -2424,7 +2424,11 @@ UtfToUtfProc(
     const char *src,		/* Source string in UTF-8. */
     int srcLen,			/* Source string length in bytes. */
     int flags,			/* TCL_ENCODING_* conversion control flags. */
-    TCL_UNUSED(Tcl_EncodingState *),
+    Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
+				 * information used during a piecewise
+				 * conversion. Contents of statePtr are
+				 * initialized and/or reset by conversion
+				 * routine under control of flags argument. */
     char *dst,			/* Output buffer in which converted string is
 				 * stored. */
     int dstLen,			/* The maximum length of output buffer in
@@ -2447,6 +2451,10 @@ UtfToUtfProc(
     int ch;
     int profile;
 
+    if (flags & TCL_ENCODING_START) {
+        /* *statePtr will hold high surrogate in a split surrogate pair */
+    	*statePtr = 0;
+    }
     result = TCL_OK;
 
     srcStart = src;
@@ -2463,6 +2471,42 @@ UtfToUtfProc(
     flags |= PTR2INT(clientData);
     dstEnd = dst + dstLen - ((flags & ENCODING_UTF) ? TCL_UTF_MAX : 6);
 
+    /*
+     * Macro to output an isolated high surrogate when it is not followed
+     * by a low surrogate. NOT to be called for strict profile since
+     * that should raise an error.
+     */
+#define OUTPUT_ISOLATEDSURROGATE                                \
+    do {                                                        \
+        Tcl_UniChar high;                                       \
+        if (PROFILE_REPLACE(profile)) {                         \
+            high = UNICODE_REPLACE_CHAR;                        \
+        } else {                                                \
+            high = (Tcl_UniChar)(ptrdiff_t) *statePtr;          \
+        }                                                       \
+        assert(!(flags & ENCODING_UTF)); /* Must be CESU-8 */   \
+        assert(HIGH_SURROGATE(high));                           \
+        assert(!PROFILE_STRICT(profile));                       \
+        dst += Tcl_UniCharToUtf(high, dst);                     \
+        *statePtr = 0; /* Reset state */                        \
+    } while (0) 
+
+    /*
+     * Macro to check for isolated surrogate and either break with
+     * an error if profile is strict, or output an appropriate
+     * character for replace and tcl8 profiles and continue.
+     */
+#define CHECK_ISOLATEDSURROGATE                                         \
+    if (*statePtr) {                                                    \
+        if (PROFILE_STRICT(profile)) {                                  \
+            result = TCL_CONVERT_SYNTAX;                                \
+            break;                                                      \
+        }                                                               \
+        OUTPUT_ISOLATEDSURROGATE;                                       \
+        continue; /* Rerun loop so length checks etc. repeated */       \
+    } else                                                              \
+        (void) 0
+
     profile = ENCODING_PROFILE_GET(flags);
     for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
 
@@ -2481,6 +2525,8 @@ UtfToUtfProc(
 	}
 	if (UCHAR(*src) < 0x80
 		&& !((UCHAR(*src) == 0) && (flags & ENCODING_INPUT))) {
+
+            CHECK_ISOLATEDSURROGATE;
 	    /*
 	     * Copy 7bit characters, but skip null-bytes when we are in input
 	     * mode, so that they get converted to \xC0\x80.
@@ -2490,6 +2536,8 @@ UtfToUtfProc(
 		 (UCHAR(src[1]) == 0x80) &&
 		 (!(flags & ENCODING_INPUT) || !PROFILE_TCL8(profile))) {
 	    /* Special sequence \xC0\x80 */
+
+            CHECK_ISOLATEDSURROGATE;
 	    if (!PROFILE_TCL8(profile) && (flags & ENCODING_INPUT)) {
 		if (PROFILE_REPLACE(profile)) {
 		    dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst);
@@ -2510,12 +2558,12 @@ UtfToUtfProc(
 
 	} else if (!Tcl_UtfCharComplete(src, srcEnd - src)) {
 	    /*
-	     * Incomplete byte sequence.
-	     * Always check before using Tcl_UtfToUniChar. Not doing so can cause
-	     * it to run beyond the end of the buffer! If we happen on such an
-	     * incomplete char its bytes are made to represent themselves unless
-	     * the user has explicitly asked to be told.
-	     */
+             * Incomplete byte sequence not because there are insufficient
+             * bytes in source buffer (have already checked that above) but
+             * because the UTF-8 sequence is truncated.
+             */
+
+            CHECK_ISOLATEDSURROGATE;
 
 	    if (flags & ENCODING_INPUT) {
 		/* Incomplete bytes for modified UTF-8 target */
@@ -2537,7 +2585,12 @@ UtfToUtfProc(
 	    }
 	    dst += Tcl_UniCharToUtf(ch, dst);
 	} else {
+            /* Have a complete character */
 	    size_t len = TclUtfToUniChar(src, &ch);
+
+            Tcl_UniChar savedSurrogate = (Tcl_UniChar) (ptrdiff_t)*statePtr;
+            *statePtr = 0; /* Reset surrogate */
+
 	    if (flags & ENCODING_INPUT) {
 		if (((len < 2) && (ch != 0))
 			|| ((ch > 0xFFFF) && !(flags & ENCODING_UTF))) {
@@ -2554,6 +2607,8 @@ UtfToUtfProc(
 	    src += len;
 	    if (!(flags & ENCODING_UTF) && !(flags & ENCODING_INPUT)
 		    && (ch > 0x3FF)) {
+                assert(savedSurrogate == 0); /* Since this flag combo
+                                                will never set *statePtr */
 		if (ch > 0xFFFF) {
 		    /* CESU-8 6-byte sequence for chars > U+FFFF */
 		    ch -= 0x10000;
@@ -2567,19 +2622,98 @@ UtfToUtfProc(
 		*dst++ = (char)((ch | 0x80) & 0xBF);
 		continue;
 	    } else if (SURROGATE(ch)) {
-		if (PROFILE_STRICT(profile)) {
-		    result = (flags & ENCODING_INPUT)
+                if ((flags & ENCODING_UTF)) {
+                    /* UTF-8, not CESU-8, so surrogates should not appear */
+                    if (PROFILE_STRICT(profile)) {
+                        result = (flags & ENCODING_INPUT)
 			    ? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN;
-		    src = saveSrc;
-		    break;
-		} else if (PROFILE_REPLACE(profile)) {
-		    ch = UNICODE_REPLACE_CHAR;
-		}
-	    }
+                        src = saveSrc;
+                        break;
+                    } else if (PROFILE_REPLACE(profile)) {
+                        ch = UNICODE_REPLACE_CHAR;
+                    } else {
+                        /* PROFILE_TCL8 - output as is */
+                    }
+                } else {
+                    /* CESU-8 */
+                    if (LOW_SURROGATE(ch)) {
+                        if (savedSurrogate) {
+                            assert(HIGH_SURROGATE(savedSurrogate));
+                            ch = 0x10000 + ((savedSurrogate - 0xd800) << 10) + (ch - 0xdc00);
+                        } else {
+                            /* Isolated low surrogate */
+                            if (PROFILE_STRICT(profile)) {
+                                result = (flags & ENCODING_INPUT)
+                                    ? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN;
+                                src = saveSrc;
+                                break;
+                            } else if (PROFILE_REPLACE(profile)) {
+                                ch = UNICODE_REPLACE_CHAR;
+                            } else {
+                                /* Tcl8 profile. Output low surrogate as is */
+                            }
+                        }
+                    } else {
+                        assert(HIGH_SURROGATE(ch));
+                        /* Save the high surrogate */
+                        *statePtr = (Tcl_EncodingState) (ptrdiff_t) ch;
+                        if (savedSurrogate) {
+                            assert(HIGH_SURROGATE(savedSurrogate));
+                            if (PROFILE_STRICT(profile)) {
+                                result = (flags & ENCODING_INPUT)
+                                    ? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN;
+                                src = saveSrc;
+                                break;
+                            } else if (PROFILE_REPLACE(profile)) {
+                                ch = UNICODE_REPLACE_CHAR;
+                            } else {
+                                /* Output the isolated high surrogate */
+                                ch = savedSurrogate;
+                            }
+                        } else {
+                            /* High surrogate saved in *statePtr. Do not output anything just yet. */
+                            --numChars; /* Cancel the increment at end of loop */
+                            continue;
+                        }
+                    }
+                }
+	    } else {
+                /* Normal character */
+                CHECK_ISOLATEDSURROGATE;
+            }
+
 	    dst += Tcl_UniCharToUtf(ch, dst);
 	}
     }
 
+    /* Check if an high surrogate left over */
+    if (*statePtr) {
+        assert(!(flags & ENCODING_UTF)); /* CESU-8, Not UTF-8 */
+        if (!(flags & TCL_ENCODING_END)) {
+            /* More data coming */
+        } else {
+            /* No more data coming */
+            if (PROFILE_STRICT(profile)) {
+                result = (flags & ENCODING_INPUT)
+                    ? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN;
+            } else {
+                if (PROFILE_REPLACE(profile)) {
+                    ch = UNICODE_REPLACE_CHAR;
+                } else {
+                    ch = (Tcl_UniChar) (ptrdiff_t) *statePtr;
+                }
+                if (dst < dstEnd) {
+                    dst += Tcl_UniCharToUtf(ch, dst);
+                    ++numChars;
+                } else {
+                    /* No room in destination */
+                    result = TCL_CONVERT_NOSPACE;
+                }
+            }
+        }
+
+    }
+
     *srcReadPtr = src - srcStart;
     *dstWrotePtr = dst - dstStart;
     *dstCharsPtr = numChars;
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index c8449aa..859366f 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -522,9 +522,10 @@ TclChanCreateObjCmd(
      * Actually: rCreate MODE CMDPREFIX
      *           [0]     [1]  [2]
      */
-
-#define MODE	(1)
-#define CMD	(2)
+    enum ArgIndices {
+	MODE = 1,
+	CMD = 2
+    };
 
     /*
      * Number of arguments...
@@ -739,9 +740,6 @@ TclChanCreateObjCmd(
     Tcl_DecrRefCount(rcPtr->cmd);
     Tcl_Free(rcPtr);
     return TCL_ERROR;
-
-#undef MODE
-#undef CMD
 }
 
 /*
@@ -826,9 +824,10 @@ TclChanPostEventObjCmd(
      *
      * where EVENTSPEC = {read write ...} (Abbreviations allowed as well).
      */
-
-#define CHAN	(1)
-#define EVENT	(2)
+    enum ArgIndices {
+	CHAN = 1,
+	EVENT = 2
+    };
 
     const char *chanId;		/* Tcl level channel handle */
     Tcl_Channel chan;		/* Channel associated to the handle */
@@ -980,9 +979,6 @@ TclChanPostEventObjCmd(
 
     Tcl_ResetResult(interp);
     return TCL_OK;
-
-#undef CHAN
-#undef EVENT
 }
 
 /*
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
index dce1a1c..d2853e2 100644
--- a/generic/tclIORTrans.c
+++ b/generic/tclIORTrans.c
@@ -529,9 +529,10 @@ TclChanPushObjCmd(
      * Actually: rPush CHANNEL CMDPREFIX
      *           [0]   [1]     [2]
      */
-
-#define CHAN	(1)
-#define CMD	(2)
+    enum ArgIndices {
+	CHAN = 1,
+	CMD = 2
+    };
 
     /*
      * Number of arguments...
@@ -714,9 +715,6 @@ TclChanPushObjCmd(
 
     Tcl_EventuallyFree(rtPtr, FreeReflectedTransform);
     return TCL_ERROR;
-
-#undef CHAN
-#undef CMD
 }
 
 /*
@@ -751,8 +749,9 @@ TclChanPopObjCmd(
      * Actually: rPop CHANNEL
      *           [0]  [1]
      */
-
-#define CHAN	(1)
+    enum ArgIndices {
+	CHAN = 1
+    };
 
     const char *chanId;		/* Tcl level channel handle */
     Tcl_Channel chan;		/* Channel associated to the handle */
@@ -786,8 +785,6 @@ TclChanPopObjCmd(
 
     Tcl_UnstackChannel(interp, chan);
     return TCL_OK;
-
-#undef CHAN
 }
 
 /*
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 461fc54..250e43e 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -455,8 +455,8 @@ InitFoundation(
      * Make the configurable class and install its standard defined method.
      */
 
-    Tcl_Object cfgCls = Tcl_NewObjectInstance(interp, 
-	    (Tcl_Class) fPtr->classCls, 
+    Tcl_Object cfgCls = Tcl_NewObjectInstance(interp,
+	    (Tcl_Class) fPtr->classCls,
 	    "::oo::configuresupport::configurable", NULL, -1, NULL, 0);
     for (i = 0 ; cfgMethods[i].name ; i++) {
 	TclOONewBasicMethod(((Object *) cfgCls)->classPtr, &cfgMethods[i]);
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 0e5513a..8f5988d 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -3394,7 +3394,7 @@ Configurable_ObjectWritableProps_Set(
  *	instance.
  *
  * BuildPropertyList --
- * 
+ *
  *	Helper for the helpers. Scans a property list and does the filtering
  *	or adding of the property to add or remove
  *
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 3ef395c..02ab2e2 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -409,7 +409,7 @@ struct Foundation {
 
 /*
  * The number of MInvoke records in the CallChain before we allocate
- * separately. 
+ * separately.
  */
 #define CALL_CHAIN_STATIC_SIZE 4
 
diff --git a/generic/tclOOProp.c b/generic/tclOOProp.c
index 4cff300..a8b2002 100644
--- a/generic/tclOOProp.c
+++ b/generic/tclOOProp.c
@@ -25,7 +25,7 @@ enum GPNFlags {
 };
 
 /*
- * Shared bits for [property] declarations. 
+ * Shared bits for [property] declarations.
  */
 enum PropOpt {
     PROP_ALL, PROP_READABLE, PROP_WRITABLE
@@ -212,7 +212,7 @@ GetPropertyName(
 	 */
 
 	Tcl_InterpState foo = Tcl_SaveInterpState(interp, result);
-	Tcl_Obj *otherName = GetPropertyName(interp, oPtr, 
+	Tcl_Obj *otherName = GetPropertyName(interp, oPtr,
 		flags ^ (GPN_WRITABLE | GPN_FALLING_BACK), namePtr, NULL);
 	result = Tcl_RestoreInterpState(interp, foo);
 	if (otherName != NULL) {
@@ -334,7 +334,7 @@ TclOO_Configurable_Configure(
 
 	code = TCL_OK;
 	for (i = 0; i < objc; i += 2) {
-	    namePtr = GetPropertyName(interp, oPtr, GPN_WRITABLE, objv[i], 
+	    namePtr = GetPropertyName(interp, oPtr, GPN_WRITABLE, objv[i],
 		    &cache);
 	    if (namePtr == NULL) {
 		code = TCL_ERROR;
@@ -381,7 +381,7 @@ Configurable_Getter(
     Tcl_Obj *valuePtr;
 
     if ((int) Tcl_ObjectContextSkippedArgs(context) != objc) {
-	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), 
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context),
 		objv, NULL);
 	return TCL_ERROR;
     }
@@ -416,7 +416,7 @@ Configurable_Setter(
     Tcl_Var varPtr, aryVar;
 
     if ((int) Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
-	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), 
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context),
 		objv, "value");
 	return TCL_ERROR;
     }
@@ -465,7 +465,7 @@ DetailsCloner(
  *	Installs a basic property implementation for a property, either on
  *	an instance or on a class. It's up to the code that calls these
  *	to ensure that the property name is syntactically valid.
- * 
+ *
  * ----------------------------------------------------------------------
  */
 
@@ -1318,7 +1318,7 @@ ReleasePropertyList(
 {
     Tcl_Obj *propertyObj;
     Tcl_Size i;
-    
+
     FOREACH(propertyObj, *propList) {
 	Tcl_DecrRefCount(propertyObj);
     }
diff --git a/win/Makefile.in b/win/Makefile.in
index bd6d693..35de31d 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -1151,7 +1151,7 @@ $(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \
 
 $(GENERIC_DIR)/tclOOScript.h: $(TOOL_DIR)/tclOOScript.tcl
 	@echo "Warning: tclOOScript.h may be out of date."
-	@echo "Developers may want to run \"make genscript\" to regenerate." 
+	@echo "Developers may want to run \"make genscript\" to regenerate."
 	@echo "This warning can be safely ignored, do not report as a bug!"
 
 genstubs:
diff --git a/win/configure b/win/configure
index 37b0d71..ae1bf30 100755
--- a/win/configure
+++ b/win/configure
@@ -4435,7 +4435,7 @@ fi
 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_enable_auto_image_base" >&5
 printf "%s\n" "$ac_cv_enable_auto_image_base" >&6; }
     CFLAGS=$hold_cflags
-    if test "$ac_cv_enable_auto_image_base" == "yes" ; then
+    if test "$ac_cv_enable_auto_image_base" = "yes" ; then
 	extra_ldflags="$extra_ldflags -Wl,--enable-auto-image-base"
     fi
 
@@ -4960,7 +4960,7 @@ printf "%s\n" "#define MP_64BIT 1" >>confdefs.h
     if test "$do64bit" = "arm64"
 then :
 
-      if test "$GCC" == "yes"
+      if test "$GCC" = "yes"
 then :
 
         ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64-arm/libz.dll.a
@@ -4982,7 +4982,7 @@ fi
 
 else case e in #(
   e)
-      if test "$GCC" == "yes"
+      if test "$GCC" = "yes"
 then :
 
         ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/libz.dll.a
diff --git a/win/configure.ac b/win/configure.ac
index 9a5de1d..0bd254d 100644
--- a/win/configure.ac
+++ b/win/configure.ac
@@ -130,7 +130,7 @@ AS_IF([test "$tcl_ok" = "yes"], [
   AS_IF([test "$do64bit" != "no"], [
     AC_DEFINE(MP_64BIT, 1, [Using libtommath.dll in 64-bit mode])
     AS_IF([test "$do64bit" = "arm64"], [
-      AS_IF([test "$GCC" == "yes"],[
+      AS_IF([test "$GCC" = "yes"],[
         AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64-arm/libz.dll.a])
         AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64-arm/libtommath.dll.a])
         zlib_lib_name=libz.dll.a
@@ -140,7 +140,7 @@ AS_IF([test "$tcl_ok" = "yes"], [
         AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64-arm/tommath.lib])
       ])
     ], [
-      AS_IF([test "$GCC" == "yes"],[
+      AS_IF([test "$GCC" = "yes"],[
         AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/libz.dll.a])
         AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64/libtommath.dll.a])
         zlib_lib_name=libz.dll.a
diff --git a/win/tcl.m4 b/win/tcl.m4
index 23e916c..3b7e582 100644
--- a/win/tcl.m4
+++ b/win/tcl.m4
@@ -644,7 +644,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
 	[ac_cv_enable_auto_image_base=no])
     )
     CFLAGS=$hold_cflags
-    if test "$ac_cv_enable_auto_image_base" == "yes" ; then
+    if test "$ac_cv_enable_auto_image_base" = "yes" ; then
 	extra_ldflags="$extra_ldflags -Wl,--enable-auto-image-base"
     fi
 
diff --git a/win/tclWinReg.c b/win/tclWinReg.c
index 68e22cb..1034392 100644
--- a/win/tclWinReg.c
+++ b/win/tclWinReg.c
@@ -52,8 +52,9 @@
  * The following flag is used in OpenKeys to indicate that the specified key
  * should be created if it doesn't currently exist.
  */
-
-#define REG_CREATE 1
+enum OpenKeysFlags {
+    REG_CREATE = 1
+};
 
 /*
  * The following tables contain the mapping from registry root names to the
@@ -386,7 +387,7 @@ RegistryObjCmd(
 	     */
 
 	    mode |= KEY_ALL_ACCESS;
-	    if (OpenKey(interp, objv[n], mode, 1, &key) != TCL_OK) {
+	    if (OpenKey(interp, objv[n], mode, REG_CREATE, &key) != TCL_OK) {
 		return TCL_ERROR;
 	    }
 	    RegCloseKey(key);
@@ -1310,7 +1311,7 @@ SetValue(
 	Tcl_ResetResult(interp);
     }
     mode |= KEY_ALL_ACCESS;
-    if (OpenKey(interp, keyNameObj, mode, 1, &key) != TCL_OK) {
+    if (OpenKey(interp, keyNameObj, mode, REG_CREATE, &key) != TCL_OK) {
 	return TCL_ERROR;
     }