Fix testchmod and associated tests that always failed on Windows

generic/tclDecls.h

@@ -4035,7 +4035,7 @@ extern const TclStubs *tclStubsPtr;
 /* Handle Win64 tk.dll being loaded in Cygwin64. */
 #	define Tcl_GetTime(t) \
 		do { \
-		    union { \
+		    struct { \
 			Tcl_Time now; \
 			__int64 reserved; \
 		    } _t; \

generic/tclEncoding.c

@@ -2244,9 +2244,9 @@ UtfExtToUtfIntProc(
  *
  * UtfToUtfProc --
  *
- *	Convert from UTF-8 to UTF-8. Note that the UTF-8 to UTF-8 translation
- *	is not a no-op, because it will turn a stream of improperly formed
- *	UTF-8 into a properly formed stream.
+ *	Converts from UTF-8 to UTF-8. Note that the UTF-8 to UTF-8 translation
+ *	is not a no-op, because it turns a stream of improperly formed
+ *	UTF-8 into a properly-formed stream.
  *
  * Results:
  *	Returns TCL_OK if conversion was successful.
@@ -2457,21 +2457,27 @@ UnicodeToUtfProc(
     }
     result = TCL_OK;
 
-    /* check alignment with utf-16 (2 == sizeof(UTF-16)) */
+    /*
+     * Check alignment with utf-16 (2 == sizeof(UTF-16))
+     */
+
     if ((srcLen % 2) != 0) {
 	result = TCL_CONVERT_MULTIBYTE;
 	srcLen--;
     }
 
+#if TCL_UTF_MAX > 3
     /*
-     * If last code point is a high surrogate, we cannot handle that yet.
+     * If last code point is a high surrogate, we cannot handle that yet,
+     * unless we are at the end.
      */
 
-    if ((srcLen >= 2) &&
+    if (!(flags & TCL_ENCODING_END) && (srcLen >= 2) &&
 	    ((src[srcLen - (clientData?1:2)] & 0xFC) == 0xD8)) {
 	result = TCL_CONVERT_MULTIBYTE;
 	srcLen-= 2;
     }
+#endif
 
     srcStart = src;
     srcEnd = src + srcLen;
@@ -2504,6 +2510,18 @@ UnicodeToUtfProc(
 	src += sizeof(unsigned short);
     }
 
+    if ((flags & TCL_ENCODING_END) && (result == TCL_CONVERT_MULTIBYTE)) {
+	/* We have a single byte left-over at the end */
+	if (dst > dstEnd) {
+	    result = TCL_CONVERT_NOSPACE;
+	} else {
+	    /* destination is not full, so we really are at the end now */
+	    result = TCL_OK;
+	    dst += Tcl_UniCharToUtf(0xFFFD, dst);
+	    numChars++;
+	    src++;
+	}
+    }
     *srcReadPtr = src - srcStart;
     *dstWrotePtr = dst - dstStart;
     *dstCharsPtr = numChars;

generic/tclIORChan.c

@@ -1128,8 +1128,8 @@ ReflectClose(
 	/*
 	 * This call comes from TclFinalizeIOSystem. There are no
 	 * interpreters, and therefore we cannot call upon the handler command
-	 * anymore. Threading is irrelevant as well. We simply clean up all
-	 * our C level data structures and leave the Tcl level to the other
+	 * anymore. Threading is irrelevant as well. Simply clean up all
+	 * the C level data structures and leave the Tcl level to the other
 	 * finalization functions.
 	 */
 
@@ -2697,6 +2697,7 @@ DeleteThreadReflectedChannelMap(
     Tcl_ThreadId self = Tcl_GetCurrentThread();
     ReflectedChannelMap *rcmPtr; /* The map */
     ForwardingResult *resultPtr;
+    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
     (void)dummy;
 
     /*
@@ -2777,6 +2778,7 @@ DeleteThreadReflectedChannelMap(
      */
 
     rcmPtr = GetThreadReflectedChannelMap();
+    tsdPtr->rcmPtr = NULL;
     for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
 	    hPtr != NULL;
 	    hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) {
@@ -3083,10 +3085,10 @@ ForwardProc(
                 (paramPtr->seek.seekMode==SEEK_SET) ? "start" :
                 (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1);
 
-        Tcl_IncrRefCount(offObj);
-        Tcl_IncrRefCount(baseObj);
+	Tcl_IncrRefCount(offObj);
+	Tcl_IncrRefCount(baseObj);
 
-        Tcl_Preserve(rcPtr);
+	Tcl_Preserve(rcPtr);
 	if (InvokeTclMethod(rcPtr, METH_SEEK, offObj, baseObj, &resObj)!=TCL_OK){
 	    ForwardSetObjError(paramPtr, resObj);
 	    paramPtr->seek.offset = -1;

generic/tclObj.c

@@ -3040,19 +3040,13 @@ Tcl_SetWideIntObj(
 	Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj");
     }
 
-    if ((wideValue >= (Tcl_WideInt) LONG_MIN)
-	    && (wideValue <= (Tcl_WideInt) LONG_MAX)) {
-	TclSetLongObj(objPtr, (long) wideValue);
-    } else {
 #ifndef TCL_WIDE_INT_IS_LONG
+    if ((wideValue < (Tcl_WideInt) LONG_MIN)
+	    || (wideValue > (Tcl_WideInt) LONG_MAX)) {
 	TclSetWideIntObj(objPtr, wideValue);
-#else
-	mp_int big;
-
-	TclBNInitBignumFromWideInt(&big, wideValue);
-	Tcl_SetBignumObj(objPtr, &big);
+    } else
 #endif
-    }
+    TclSetLongObj(objPtr, (long) wideValue);
 }
 
 /*

generic/tclUtf.c

@@ -206,12 +206,11 @@ Invalid(
  *
  * Tcl_UniCharToUtf --
  *
- *	Store the given Tcl_UniChar as a sequence of UTF-8 bytes in the
+ *	Stores the given Tcl_UniChar as a sequence of UTF-8 bytes in the
  *	provided buffer. Equivalent to Plan 9 runetochar().
  *
  * Results:
- *	The return values is the number of bytes in the buffer that were
- *	consumed.
+ *	Returns the number of bytes stored into the buffer.
  *
  * Side effects:
  *	None.
@@ -234,8 +233,8 @@ Tcl_UniCharToUtf(
     }
     if (ch >= 0) {
 	if (ch <= 0x7FF) {
-	    buf[1] = (char) ((ch | 0x80) & 0xBF);
-	    buf[0] = (char) ((ch >> 6) | 0xC0);
+	    buf[1] = (char) (0x80 | (0x3F & ch));
+	    buf[0] = (char) (0xC0 | (ch >> 6));
 	    return 2;
 	}
 	if (ch <= 0xFFFF) {
@@ -243,10 +242,11 @@ Tcl_UniCharToUtf(
 	    if ((ch & 0xF800) == 0xD800) {
 		if (ch & 0x0400) {
 		    /* Low surrogate */
-		    if (((buf[0] & 0xC0) == 0x80) && ((buf[1] & 0xCF) == 0)) {
+		    if (   (0x80 == (0xC0 & buf[0]))
+			&& (0    == (0xCF & buf[1]))) {
 			/* Previous Tcl_UniChar was a high surrogate, so combine */
-			buf[2] = (char) ((ch & 0x3F) | 0x80);
-			buf[1] |= (char) (((ch >> 6) & 0x0F) | 0x80);
+			buf[2]  = (char) (0x80 | (0x3F & ch));
+			buf[1] |= (char) (0x80 | (0x0F & (ch >> 6)));
 			return 3;
 		    }
 		    /* Previous Tcl_UniChar was not a high surrogate, so just output */
@@ -256,8 +256,8 @@ Tcl_UniCharToUtf(
 		    /* Fill buffer with specific 3-byte (invalid) byte combination,
 		       so following low surrogate can recognize it and combine */
 		    buf[2] = (char) ((ch << 4) & 0x30);
-		    buf[1] = (char) (((ch >> 2) & 0x3F) | 0x80);
-		    buf[0] = (char) (((ch >> 8) & 0x07) | 0xF0);
+		    buf[1] = (char) (0x80 | (0x3F & (ch >> 2)));
+		    buf[0] = (char) (0xF0 | (0x07 & (ch >> 8)));
 		    return 1;
 		}
 	    }
@@ -267,20 +267,23 @@ Tcl_UniCharToUtf(
 
 #if TCL_UTF_MAX > 3
 	if (ch <= 0x10FFFF) {
-	    buf[3] = (char) ((ch | 0x80) & 0xBF);
-	    buf[2] = (char) (((ch >> 6) | 0x80) & 0xBF);
-	    buf[1] = (char) (((ch >> 12) | 0x80) & 0xBF);
-	    buf[0] = (char) ((ch >> 18) | 0xF0);
+	    buf[3] = (char) (0x80 | (0x3F & ch));
+	    buf[2] = (char) (0x80 | (0x3F & (ch >> 6)));
+	    buf[1] = (char) (0x80 | (0x3F & (ch >> 12)));
+	    buf[0] = (char) (0xF0 |         (ch >> 18));
 	    return 4;
 	}
     } else if (ch == -1) {
-	if (((buf[0] & 0xC0) == 0x80) && ((buf[1] & 0xCF) == 0)
-		&& ((buf[-1] & 0xF8) == 0xF0)) {
-	    ch = 0xD7C0 + ((buf[-1] & 0x07) << 8) + ((buf[0] & 0x3F) << 2)
-		    + ((buf[1] & 0x30) >> 4);
-	    buf[1] = (char) ((ch | 0x80) & 0xBF);
-	    buf[0] = (char) (((ch >> 6) | 0x80) & 0xBF);
-	    buf[-1] = (char) ((ch >> 12) | 0xE0);
+	if (   (0x80 == (0xC0 & buf[0]))
+	    && (0    == (0xCF & buf[1]))
+	    && (0xF0 == (0xF8 & buf[-1]))) {
+	    ch = 0xD7C0
+		+ ((0x07 & buf[-1]) << 8)
+		+ ((0x3F & buf[0])  << 2)
+		+ ((0x30 & buf[1])  >> 4);
+	    buf[1]  = (char) (0x80 | (0x3F & ch));
+	    buf[0]  = (char) (0x80 | (0x3F & (ch >> 6)));
+	    buf[-1] = (char) (0xE0 | (ch >> 12));
 	    return 2;
 	}
 #endif
@@ -288,9 +291,9 @@ Tcl_UniCharToUtf(
 
     ch = 0xFFFD;
 three:
-    buf[2] = (char) ((ch | 0x80) & 0xBF);
-    buf[1] = (char) (((ch >> 6) | 0x80) & 0xBF);
-    buf[0] = (char) ((ch >> 12) | 0xE0);
+    buf[2] = (char) (0x80 | (0x3F & ch));
+    buf[1] = (char) (0x80 | (0x3F & (ch >> 6)));
+    buf[0] = (char) (0xE0 |         (ch >> 12));
     return 3;
 }
 
@@ -2386,7 +2389,7 @@ TclUniCharMatch(
  *
  * TclUtfToUCS4 --
  *
- *	Extract the 4-byte codepoint from the leading bytes of the
+ *	Extracts the 4-byte codepoint from the leading bytes of the
  *	Modified UTF-8 string "src".  This is a utility routine to
  *	contain the surrogate gymnastics in one place.
  *
@@ -2398,8 +2401,8 @@ TclUniCharMatch(
  *	enough bytes remain in the string.
  *
  * Results:
- *	*usc4Ptr is filled with the UCS4 code point, and the return value is
- *	the number of bytes from the UTF-8 string that were consumed.
+ *	Fills *usc4Ptr with the UCS4 code point and returns the number of bytes
+ *	consumed from the source string.
  *
  * Side effects:
  *	None.

generic/tclZlib.c

@@ -441,10 +441,21 @@ GenerateHeader(
     if (GetValue(interp, dictObj, "comment", &value) != TCL_OK) {
 	goto error;
     } else if (value != NULL) {
+	Tcl_EncodingState state;
 	valueStr = Tcl_GetStringFromObj(value, &len);
-	Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL,
+	result = Tcl_UtfToExternal(NULL, latin1enc, valueStr, len,
+		TCL_ENCODING_START|TCL_ENCODING_END|TCL_ENCODING_STOPONERROR, &state,
 		headerPtr->nativeCommentBuf, MAX_COMMENT_LEN-1, NULL, &len,
 		NULL);
+	if (result != TCL_OK) {
+	    if (result == TCL_CONVERT_UNKNOWN) {
+		Tcl_AppendResult(interp, "Comment contains characters > 0xFF", NULL);
+	    } else {
+		Tcl_AppendResult(interp, "Comment too large for zip", NULL);
+	    }
+	    result = TCL_ERROR;
+	    goto error;
+	}
 	headerPtr->nativeCommentBuf[len] = '\0';
 	headerPtr->header.comment = (Bytef *) headerPtr->nativeCommentBuf;
 	if (extraSizePtr != NULL) {
@@ -462,9 +473,21 @@ GenerateHeader(
     if (GetValue(interp, dictObj, "filename", &value) != TCL_OK) {
 	goto error;
     } else if (value != NULL) {
+	Tcl_EncodingState state;
 	valueStr = Tcl_GetStringFromObj(value, &len);
-	Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL,
-		headerPtr->nativeFilenameBuf, MAXPATHLEN-1, NULL, &len, NULL);
+	result = Tcl_UtfToExternal(NULL, latin1enc, valueStr, len,
+		TCL_ENCODING_START|TCL_ENCODING_END|TCL_ENCODING_STOPONERROR, &state,
+		headerPtr->nativeFilenameBuf, MAXPATHLEN-1, NULL, &len,
+		NULL);
+	if (result != TCL_OK) {
+	    if (result == TCL_CONVERT_UNKNOWN) {
+		Tcl_AppendResult(interp, "Filename contains characters > 0xFF", NULL);
+	    } else {
+		Tcl_AppendResult(interp, "Filename too large for zip", NULL);
+	    }
+	    result = TCL_ERROR;
+	    goto error;
+	}
 	headerPtr->nativeFilenameBuf[len] = '\0';
 	headerPtr->header.name = (Bytef *) headerPtr->nativeFilenameBuf;
 	if (extraSizePtr != NULL) {
@@ -1189,7 +1212,8 @@ Tcl_ZlibStreamPut(
 {
     ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
     char *dataTmp = NULL;
-    int e, size, outSize, toStore;
+    int e;
+    int size, outSize, toStore;
 
     if (zshPtr->streamEnd) {
 	if (zshPtr->interp) {
@@ -1312,7 +1336,8 @@ Tcl_ZlibStreamGet(
 				 * may get less! */
 {
     ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
-    int e, i, listLen, itemLen, dataPos = 0;
+    int e;
+    int i, listLen, itemLen, dataPos = 0;
     Tcl_Obj *itemObj;
     unsigned char *dataPtr, *itemPtr;
     int existing;
@@ -1561,7 +1586,8 @@ Tcl_ZlibDeflate(
     int level,
     Tcl_Obj *gzipHeaderDictObj)
 {
-    int wbits = 0, inLen = 0, e = 0, extraSize = 0;
+    int wbits = 0, e = 0, extraSize = 0;
+    int inLen = 0;
     Byte *inData = NULL;
     z_stream stream;
     GzipHeader header;
@@ -1711,7 +1737,8 @@ Tcl_ZlibInflate(
     int bufferSize,
     Tcl_Obj *gzipHeaderDictObj)
 {
-    int wbits = 0, inLen = 0, e = 0, newBufferSize;
+    int wbits = 0, e = 0;
+    int inLen = 0, newBufferSize;
     Byte *inData = NULL, *outData = NULL, *newOutData = NULL;
     z_stream stream;
     gz_header header, *headerPtr = NULL;
@@ -2365,7 +2392,8 @@ ZlibPushSubcmd(
     const char *const *pushOptions = pushDecompressOptions;
     enum pushOptions {poDictionary, poHeader, poLevel, poLimit};
     Tcl_Obj *headerObj = NULL, *compDictObj = NULL;
-    int limit = DEFAULT_BUFFER_SIZE, dummy;
+    int limit = DEFAULT_BUFFER_SIZE;
+    int dummy;
 
     if (objc < 4) {
 	Tcl_WrongNumArgs(interp, 2, objv, "mode channel ?options...?");
@@ -2897,7 +2925,8 @@ ZlibTransformClose(
     Tcl_Interp *interp)
 {
     ZlibChannelData *cd = (ZlibChannelData *)instanceData;
-    int e, written, result = TCL_OK;
+    int e, result = TCL_OK;
+    int written;
 
     /*
      * Delete the support timer.

tests/dstring.test

@@ -211,6 +211,38 @@ test dstring-2.15 {appending list elements} -constraints testdstring -setup {
 } -cleanup {
     testdstring free
 } -result {x  #}
+test dstring-2.16 {appending list elements - bug [46dda6fc29] segfault} -constraints testdstring -setup {
+    testdstring free
+} -body {
+    testdstring element "\\\n"; # Will setfault
+    testdstring get
+} -cleanup {
+    testdstring free
+} -result \\\\\\n
+test dstring-2.17 {appending list elements - bug [46dda6fc29] segfault} -constraints testdstring -setup {
+    testdstring free
+} -body {
+    testdstring element "\\\{"; # Will setfault
+    testdstring get
+} -cleanup {
+    testdstring free
+} -result [list [list \{]]
+test dstring-2.18 {appending list elements - bug [46dda6fc29] segfault} -constraints testdstring -setup {
+    testdstring free
+} -body {
+    testdstring element "\\\}"; # Will setfault
+    testdstring get
+} -cleanup {
+    testdstring free
+} -result [list [list \}]]
+test dstring-2.19 {appending list elements - bug [46dda6fc29] segfault} -constraints testdstring -setup {
+    testdstring free
+} -body {
+    testdstring element "\\\\"; # Will setfault
+    testdstring get
+} -cleanup {
+    testdstring free
+} -result [list [list \\]]
 
 test dstring-3.1 {nested sublists} -constraints testdstring -setup {
     testdstring free

tests/encoding.test

@@ -3,7 +3,7 @@
 # No output means no errors were found.
 #
 # Copyright (c) 1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 1998-1999 Scriptics Corporation.
 #
 # See the file "license.terms" for information on usage and redistribution of
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -65,12 +65,12 @@ test encoding-1.2 {Tcl_GetEncoding: existing encoding} {testencoding} {
     return $x
 } {{fromutf }}
 test encoding-1.3 {Tcl_GetEncoding: load encoding} {
-    list [encoding convertto jis0208 \u4e4e] \
+    list [encoding convertto jis0208 \u4E4E] \
 	[encoding convertfrom jis0208 8C]
-} "8C \u4e4e"
+} "8C \u4E4E"
 
 test encoding-2.1 {Tcl_FreeEncoding: refcount == 0} {
-    encoding convertto jis0208 \u4e4e
+    encoding convertto jis0208 \u4E4E
 } {8C}
 test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup {
     set system [encoding system]
@@ -78,15 +78,15 @@ test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup {
 } -constraints {testencoding} -body {
     encoding system shiftjis		;# incr ref count
     encoding dirs [list [pwd]]
-    set x [encoding convertto shiftjis \u4e4e]	;# old one found
+    set x [encoding convertto shiftjis \u4E4E]	;# old one found
     encoding system iso8859-1
     llength shiftjis		;# Shimmer away any cache of Tcl_Encoding
-    lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg
+    lappend x [catch {encoding convertto shiftjis \u4E4E} msg] $msg
 } -cleanup {
     encoding system iso8859-1
     encoding dirs $path
     encoding system $system
-} -result "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}"
+} -result "\x8C\xC1 1 {unknown encoding \"shiftjis\"}"
 
 test encoding-3.1 {Tcl_GetEncodingName, NULL} -setup {
     set old [encoding system]
@@ -138,7 +138,7 @@ test encoding-5.1 {Tcl_SetSystemEncoding} -setup {
     set old [encoding system]
 } -body {
     encoding system jis0208
-    encoding convertto \u4e4e
+    encoding convertto \u4E4E
 } -cleanup {
     encoding system iso8859-1
     encoding system $old
@@ -170,7 +170,7 @@ test encoding-6.2 {Tcl_CreateEncoding: replace encoding} {testencoding} {
 
 test encoding-7.1 {Tcl_ExternalToUtfDString: small buffer} {
     encoding convertfrom jis0208 8c8c8c8c
-} "\u543e\u543e\u543e\u543e"
+} "\u543E\u543E\u543E\u543E"
 test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} {
     set a 8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C
     append a $a
@@ -179,12 +179,12 @@ test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} {
     append a $a
     set x [encoding convertfrom jis0208 $a]
     list [string length $x] [string index $x 0]
-} "512 \u4e4e"
+} "512 \u4E4E"
 
 test encoding-8.1 {Tcl_ExternalToUtf} {
     set f [open [file join [temporaryDirectory] dummy] w]
     fconfigure $f -translation binary -encoding iso8859-1
-    puts -nonewline $f "ab\x8c\xc1g"
+    puts -nonewline $f "ab\x8C\xC1g"
     close $f
     set f [open [file join [temporaryDirectory] dummy] r]
     fconfigure $f -translation binary -encoding shiftjis
@@ -192,13 +192,13 @@ test encoding-8.1 {Tcl_ExternalToUtf} {
     close $f
     file delete [file join [temporaryDirectory] dummy]
     return $x
-} "ab\u4e4eg"
+} "ab\u4E4Eg"
 
 test encoding-9.1 {Tcl_UtfToExternalDString: small buffer} {
-    encoding convertto jis0208 "\u543e\u543e\u543e\u543e"
+    encoding convertto jis0208 "\u543E\u543E\u543E\u543E"
 } {8c8c8c8c}
 test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} {
-    set a \u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e
+    set a \u4E4E\u4E4E\u4E4E\u4E4E\u4E4E\u4E4E\u4E4E\u4E4E
     append a $a
     append a $a
     append a $a
@@ -212,7 +212,7 @@ test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} {
 test encoding-10.1 {Tcl_UtfToExternal} {
     set f [open [file join [temporaryDirectory] dummy] w]
     fconfigure $f -translation binary -encoding shiftjis
-    puts -nonewline $f "ab\u4e4eg"
+    puts -nonewline $f "ab\u4E4Eg"
     close $f
     set f [open [file join [temporaryDirectory] dummy] r]
     fconfigure $f -translation binary -encoding iso8859-1
@@ -220,7 +220,7 @@ test encoding-10.1 {Tcl_UtfToExternal} {
     close $f
     file delete [file join [temporaryDirectory] dummy]
     return $x
-} "ab\x8c\xc1g"
+} "ab\x8C\xC1g"
 
 proc viewable {str} {
     set res ""
@@ -228,7 +228,7 @@ proc viewable {str} {
 	if {[string is print $c] && [string is ascii $c]} {
 	    append res $c
 	} else {
-	    append res "\\u[format %4.4x [scan $c %c]]"
+	    append res "\\u[format %4.4X [scan $c %c]]"
 	}
     }
     return "$str ($res)"
@@ -240,26 +240,26 @@ test encoding-11.1 {LoadEncodingFile: unknown encoding} {testencoding} {
     encoding system iso8859-1
     encoding dirs {}
     llength jis0208	;# Shimmer any cached Tcl_Encoding in shared literal
-    set x [list [catch {encoding convertto jis0208 \u4e4e} msg] $msg]
+    set x [list [catch {encoding convertto jis0208 \u4E4E} msg] $msg]
     encoding dirs $path
     encoding system $system
-    lappend x [encoding convertto jis0208 \u4e4e]
+    lappend x [encoding convertto jis0208 \u4E4E]
 } {1 {unknown encoding "jis0208"} 8C}
 test encoding-11.2 {LoadEncodingFile: single-byte} {
-    encoding convertfrom jis0201 \xa1
-} "\uff61"
+    encoding convertfrom jis0201 \xA1
+} \uFF61
 test encoding-11.3 {LoadEncodingFile: double-byte} {
     encoding convertfrom jis0208 8C
-} "\u4e4e"
+} \u4E4E
 test encoding-11.4 {LoadEncodingFile: multi-byte} {
-    encoding convertfrom shiftjis \x8c\xc1
-} "\u4e4e"
+    encoding convertfrom shiftjis \x8C\xC1
+} \u4E4E
 test encoding-11.5 {LoadEncodingFile: escape file} {
-    viewable [encoding convertto iso2022 \u4e4e]
-} [viewable "\x1b\$B8C\x1b(B"]
+    viewable [encoding convertto iso2022 \u4E4E]
+} [viewable "\x1B\$B8C\x1B(B"]
 test encoding-11.5.1 {LoadEncodingFile: escape file} {
-    viewable [encoding convertto iso2022-jp \u4e4e]
-} [viewable "\x1b\$B8C\x1b(B"]
+    viewable [encoding convertto iso2022-jp \u4E4E]
+} [viewable "\x1B\$B8C\x1B(B"]
 test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} -setup {
     set system [encoding system]
     set path [encoding dirs]
@@ -273,7 +273,7 @@ test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding}
     fconfigure $f -translation binary
     puts $f "abcdefghijklmnop"
     close $f
-    encoding convertto splat \u4e4e
+    encoding convertto splat \u4E4E
 } -returnCodes error -cleanup {
     file delete [file join [temporaryDirectory] tmp encoding splat.enc]
     removeDirectory [file join tmp encoding]
@@ -289,45 +289,45 @@ test encoding-12.1 {LoadTableEncoding: normal encoding} {
     set x [encoding convertto iso8859-3 \u0120]
     append x [encoding convertto iso8859-3 \xD5]
     append x [encoding convertfrom iso8859-3 \xD5]
-} "\xd5?\u120"
+} \xD5?\u0120
 test encoding-12.2 {LoadTableEncoding: single-byte encoding} {
     set x [encoding convertto iso8859-3 ab\u0120g]
     append x [encoding convertfrom iso8859-3 ab\xD5g]
-} "ab\xd5gab\u120g"
+} ab\xD5gab\u0120g
 test encoding-12.3 {LoadTableEncoding: multi-byte encoding} {
     set x [encoding convertto shiftjis ab\u4E4Eg]
-    append x [encoding convertfrom shiftjis ab\x8c\xc1g]
-} "ab\x8c\xc1gab\u4e4eg"
+    append x [encoding convertfrom shiftjis ab\x8C\xC1g]
+} ab\x8C\xC1gab\u4E4Eg
 test encoding-12.4 {LoadTableEncoding: double-byte encoding} {
-    set x [encoding convertto jis0208 \u4e4e\u3b1]
+    set x [encoding convertto jis0208 \u4E4E\u03B1]
     append x [encoding convertfrom jis0208 8C&A]
-} "8C&A\u4e4e\u3b1"
+} 8C&A\u4E4E\u03B1
 test encoding-12.5 {LoadTableEncoding: symbol encoding} {
-    set x [encoding convertto symbol \u3b3]
-    append x [encoding convertto symbol \u67]
-    append x [encoding convertfrom symbol \x67]
-} "\x67\x67\u3b3"
+    set x [encoding convertto symbol \u03B3]
+    append x [encoding convertto symbol g]
+    append x [encoding convertfrom symbol g]
+} gg\u03B3
 test encoding-12.6 {LoadTableEncoding: overflow in char value} ucs2 {
     encoding convertto iso8859-3 \U010000
-} "?"
+} ?
 
 test encoding-13.1 {LoadEscapeTable} {
-    viewable [set x [encoding convertto iso2022 ab\u4e4e\u68d9g]]
-} [viewable "ab\x1b\$B8C\x1b\$\(DD%\x1b(Bg"]
+    viewable [set x [encoding convertto iso2022 ab\u4E4E\u68D9g]]
+} [viewable "ab\x1B\$B8C\x1B\$\(DD%\x1B(Bg"]
 
 test encoding-14.1 {BinaryProc} {
     encoding convertto identity \x12\x34\x56\xff\x69
 } "\x12\x34\x56\xc3\xbf\x69"
 
 test encoding-15.1 {UtfToUtfProc} {
-    encoding convertto utf-8 \xa3
-} "\xc2\xa3"
+    encoding convertto utf-8 \xA3
+} "\xC2\xA3"
 test encoding-15.2 {UtfToUtfProc null character output} testbytestring {
-    binary scan [testbytestring [encoding convertto utf-8 \u0000]] H* z
+    binary scan [testbytestring [encoding convertto utf-8 \x00]] H* z
     set z
 } 00
 test encoding-15.3 {UtfToUtfProc null character input} teststringbytes {
-    set y [encoding convertfrom utf-8 [encoding convertto utf-8 \u0000]]
+    set y [encoding convertfrom utf-8 [encoding convertto utf-8 \x00]]
     binary scan [teststringbytes $y] H* z
     set z
 } c080
@@ -407,18 +407,24 @@ test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} {
     list [string length $x] $y
 } "4 \xF0\xA0\xA1\xC2"
 
-test encoding-16.1 {UnicodeToUtfProc} {
+test encoding-16.1 {UnicodeToUtfProc} -body {
     set val [encoding convertfrom unicode NN]
-    list $val [format %x [scan $val %c]]
-} "\u4e4e 4e4e"
+    list $val [format %X [scan $val %c]]
+} -result "\u4E4E 4E4E"
 test encoding-16.2 {UnicodeToUtfProc} -constraints fullutf -body {
     set val [encoding convertfrom unicode "\xD8\xD8\xDC\xDC"]
     list $val [format %x [scan $val %c]]
 } -result "\U460DC 460dc"
 test encoding-16.3 {UnicodeToUtfProc} -body {
     set val [encoding convertfrom unicode "\xDC\xDC"]
-    list $val [format %x [scan $val %c]]
-} -result "\uDCDC dcdc"
+    list $val [format %X [scan $val %c]]
+} -result "\uDCDC DCDC"
+test encoding-16.4 {UnicodeToUtfProc, bug [d19fe0a5b]} -body {
+    encoding convertfrom unicode "\x41\x41\x41"
+} -result \u4141\uFFFD
+test encoding-16.5 {UnicodeToUtfProc, bug [d19fe0a5b]} -constraints ucs2 -body {
+    encoding convertfrom unicode "\xD8\xD8"
+} -result \uD8D8
 
 test encoding-17.1 {UtfToUnicodeProc} -constraints fullutf -body {
     encoding convertto unicode "\U460DC"
@@ -430,8 +436,9 @@ test encoding-17.3 {UtfToUnicodeProc} -body {
     encoding convertto unicode "\uD8D8"
 } -result "\xD8\xD8"
 
-test encoding-18.1 {TableToUtfProc} {
-} {}
+test encoding-18.1 {TableToUtfProc on invalid input} -body {
+	list [catch {encoding convertto jis0208 \\} res] $res
+} -result {0 !)}
 
 test encoding-19.1 {TableFromUtfProc} {
 } {}
@@ -445,11 +452,11 @@ test encoding-21.1 {EscapeToUtfProc} {
 test encoding-22.1 {EscapeFromUtfProc} {
 } {}
 
-set iso2022encData "\u001b\$B;d\$I\$b\$G\$O!\"%A%C%W\$49XF~;~\$K\$4EPO?\$\$\$?\$@\$\$\$?\$4=;=j\$r%-%c%C%7%e%\"%&%H\$N:]\$N\u001b(B
-\u001b\$B>.@Z<jAwIU@h\$H\$7\$F;HMQ\$7\$F\$*\$j\$^\$9!#62\$lF~\$j\$^\$9\$,!\"@5\$7\$\$=;=j\$r\$4EPO?\$7\$J\$*\u001b(B
-\u001b\$B\$*4j\$\$\$\$\$?\$7\$^\$9!#\$^\$?!\"BgJQ62=L\$G\$9\$,!\"=;=jJQ99\$N\$\"\$H!\"F|K\\8l%5!<%S%9It!J\u001b(B
-casino_japanese@___.com \u001b\$B!K\$^\$G\$4=;=jJQ99:Q\$NO\"Mm\$r\$\$\$?\$@\$1\$J\$\$\$G\u001b(B
-\u001b\$B\$7\$g\$&\$+!)\u001b(B"
+set iso2022encData "\x1B\$B;d\$I\$b\$G\$O!\"%A%C%W\$49XF~;~\$K\$4EPO?\$\$\$?\$@\$\$\$?\$4=;=j\$r%-%c%C%7%e%\"%&%H\$N:]\$N\x1B(B
+\x1B\$B>.@Z<jAwIU@h\$H\$7\$F;HMQ\$7\$F\$*\$j\$^\$9!#62\$lF~\$j\$^\$9\$,!\"@5\$7\$\$=;=j\$r\$4EPO?\$7\$J\$*\x1B(B
+\x1B\$B\$*4j\$\$\$\$\$?\$7\$^\$9!#\$^\$?!\"BgJQ62=L\$G\$9\$,!\"=;=jJQ99\$N\$\"\$H!\"F|K\\8l%5!<%S%9It!J\x1B(B
+casino_japanese@___.com \x1B\$B!K\$^\$G\$4=;=jJQ99:Q\$NO\"Mm\$r\$\$\$?\$@\$1\$J\$\$\$G\x1B(B
+\x1B\$B\$7\$g\$&\$+!)\x1B(B"
 
 set iso2022uniData [encoding convertfrom iso2022-jp $iso2022encData]
 set iso2022uniData2 "\u79c1\u3069\u3082\u3067\u306f\u3001\u30c1\u30c3\u30d7\u3054\u8cfc\u5165\u6642\u306b\u3054\u767b\u9332\u3044\u305f\u3060\u3044\u305f\u3054\u4f4f\u6240\u3092\u30ad\u30e3\u30c3\u30b7\u30e5\u30a2\u30a6\u30c8\u306e\u969b\u306e
@@ -521,17 +528,17 @@ test encoding-24.2 {EscapeFreeProc on open channels} {exec} {
     viewable [runInSubprocess {
 	encoding system cp1252;	# Bug #2891556 crash revelator
 	fconfigure stdout -encoding iso2022-jp
-	puts ab\u4e4e\u68d9g
+	puts ab\u4E4E\u68D9g
 	set env(TCL_FINALIZE_ON_EXIT) 1
 	exit
     }]
-} "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)"
+} "ab\x1B\$B8C\x1B\$(DD%\x1B(Bg (ab\\u001B\$B8C\\u001B\$(DD%\\u001B(Bg)"
 test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
     # Bug #219314 - if we don't free escape encodings correctly on channel
     # closure, we go boom
     set file [makeFile {
 	encoding system iso2022-jp
-	set a "\u4e4e\u4e5e\u4e5f"; # 3 Japanese Kanji letters
+	set a \u4E4E\u4E5E\u4E5F; # 3 Japanese Kanji letters
 	puts $a
     } iso2022.tcl]
     set f [open "|[list [interpreter] $file]"]
@@ -540,31 +547,31 @@ test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
     close $f
     removeFile iso2022.tcl
     list $count [viewable $line]
-} [list 3 "\u4e4e\u4e5e\u4e5f (\\u4e4e\\u4e5e\\u4e5f)"]
+} [list 3 "\u4E4E\u4E5E\u4E5F (\\u4E4E\\u4E5E\\u4E5F)"]
 
 test encoding-24.4 {Parse valid or invalid utf-8} {
-    string length [encoding convertfrom utf-8 "\xc0\x80"]
+    string length [encoding convertfrom utf-8 "\xC0\x80"]
 } 1
 test encoding-24.5 {Parse valid or invalid utf-8} {
-    string length [encoding convertfrom utf-8 "\xc0\x81"]
+    string length [encoding convertfrom utf-8 "\xC0\x81"]
 } 2
 test encoding-24.6 {Parse valid or invalid utf-8} {
-    string length [encoding convertfrom utf-8 "\xc1\xbf"]
+    string length [encoding convertfrom utf-8 "\xC1\xBF"]
 } 2
 test encoding-24.7 {Parse valid or invalid utf-8} {
-    string length [encoding convertfrom utf-8 "\xc2\x80"]
+    string length [encoding convertfrom utf-8 "\xC2\x80"]
 } 1
 test encoding-24.8 {Parse valid or invalid utf-8} {
-    string length [encoding convertfrom utf-8 "\xe0\x80\x80"]
+    string length [encoding convertfrom utf-8 "\xE0\x80\x80"]
 } 3
 test encoding-24.9 {Parse valid or invalid utf-8} {
-    string length [encoding convertfrom utf-8 "\xe0\x9f\xbf"]
+    string length [encoding convertfrom utf-8 "\xE0\x9F\xBF"]
 } 3
 test encoding-24.10 {Parse valid or invalid utf-8} {
-    string length [encoding convertfrom utf-8 "\xe0\xa0\x80"]
+    string length [encoding convertfrom utf-8 "\xE0\xA0\x80"]
 } 1
 test encoding-24.11 {Parse valid or invalid utf-8} {
-    string length [encoding convertfrom utf-8 "\xef\xbf\xbf"]
+    string length [encoding convertfrom utf-8 "\xEF\xBF\xBF"]
 } 1
 
 file delete [file join [temporaryDirectory] iso2022.txt]
@@ -618,20 +625,20 @@ proc foreach-jisx0208 {varName command} {
 }
 proc gen-jisx0208-euc-jp {code} {
     binary format cc \
-	[expr {($code >> 8) | 0x80}] [expr {($code & 0xff) | 0x80}]
+	[expr {($code >> 8) | 0x80}] [expr {($code & 0xFF) | 0x80}]
 }
 proc gen-jisx0208-iso2022-jp {code} {
     binary format a3cca3 \
-	"\x1b\$B" [expr {$code >> 8}] [expr {$code & 0xff}] "\x1b(B"
+	"\x1B\$B" [expr {$code >> 8}] [expr {$code & 0xFF}] "\x1B(B"
 }
 proc gen-jisx0208-cp932 {code} {
     set c1 [expr {($code >> 8) | 0x80}]
     set c2 [expr {($code & 0xff)| 0x80}]
     if {$c1 % 2} {
-	set c1 [expr {($c1 >> 1) + ($c1 < 0xdf ? 0x31 : 0x71)}]
-	incr c2 [expr {- (0x60 + ($c2 < 0xe0))}]
+	set c1 [expr {($c1 >> 1) + ($c1 < 0xDF ? 0x31 : 0x71)}]
+	incr c2 [expr {- (0x60 + ($c2 < 0xE0))}]
     } else {
-	set c1 [expr {($c1 >> 1) + ($c1 < 0xdf ? 0x30 : 0x70)}]
+	set c1 [expr {($c1 >> 1) + ($c1 < 0xDF ? 0x30 : 0x70)}]
 	incr c2 -2
     }
     binary format cc $c1 $c2

tests/fCmd.test

@@ -1065,6 +1065,7 @@ test fCmd-10.3.1 {file copy: comprehensive: dir to new name} -setup {
     file mkdir [file join td1 tdx]
     file mkdir [file join td2 tdy]
     testchmod 0o555 td2
+    testchmod 0o555 td2/tdy; # Above line removes inherited perms. So restore.
     file copy td1 td3
     file copy td2 td4
     list [lsort [glob td*]] [glob -directory td3 t*] \
@@ -1086,10 +1087,19 @@ test fCmd-10.4 {file copy: comprehensive: file to existing file} -setup {
     createfile tfd2
     createfile tfd3
     createfile tfd4
-    testchmod 0o444 tfs3
-    testchmod 0o444 tfs4
-    testchmod 0o444 tfd2
-    testchmod 0o444 tfd4
+    if {$::tcl_platform(platform) eq "windows"} {
+        # On Windows testchmode will attach an ACL which file copy cannot handle
+        # so use good old attributes which file copy does understand
+        file attribute tfs3 -readonly 1
+        file attribute tfs4 -readonly 1
+        file attribute tfd2 -readonly 1
+        file attribute tfd4 -readonly 1
+    } else {
+        testchmod 0o444 tfs3
+        testchmod 0o444 tfs4
+        testchmod 0o444 tfd2
+        testchmod 0o444 tfd4
+    }
     set msg [list [catch {file copy tf1 tf2} msg] $msg]
     file copy -force tfs1 tfd1
     file copy -force tfs2 tfd2

tests/fileSystem.test

@@ -277,6 +277,16 @@ test filesystem-1.30.1 {normalisation of existing user} -body {
 test filesystem-1.30.2 {normalisation of nonexistent user specified as user@domain} -body {
     file normalize ~nonexistentuser@nonexistentdomain
 } -returnCodes error -result {user "nonexistentuser@nonexistentdomain" doesn't exist}
+test filesystem-1.30.3 {file normalization should distinguish between ~ and ~user} -setup {
+    set oldhome $::env(HOME)
+    set olduserhome [file normalize ~$::tcl_platform(user)]
+    set ::env(HOME) [file join $oldhome temp]
+} -cleanup {
+    set env(HOME) $oldhome
+} -body {
+    list [string equal [file normalize ~] $::env(HOME)] \
+        [string equal $olduserhome [file normalize ~$::tcl_platform(user)]]
+} -result {1 1}
 test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} {
     testsetplatform unix
     file normalize /foo/../bar

tests/tcltest.test

@@ -552,7 +552,7 @@ switch -- $::tcl_platform(platform) {
     default {
 	# note in FAT/NTFS we won't be able to protect directory with read-only attribute...
 	catch {file attributes $notWriteableDir -readonly 1}
-	catch {testchmod 0 $notWriteableDir}
+	catch {testchmod 0o444 $notWriteableDir}
     }
 }
 test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {

tests/winFCmd.test

@@ -47,15 +47,20 @@ proc contents {file} {
     set r
 }
 
+proc cleanupRecurse {args} {
+    # Assumes no loops via links!
+    # Need to change permissions BEFORE deletion
+    testchmod 0o777 {*}$args
+    foreach victim $args {
+        if {[file isdirectory $victim]} {
+            cleanupRecurse {*}[glob -nocomplain -directory $victim td* tf* Test*]
+        }
+        file delete -force $victim
+    }
+}
 proc cleanup {args} {
-    foreach p ". $args" {
-	set x ""
-	catch {
-	    set x [glob -directory $p tf* td*]
-	}
-	if {$x != ""} {
-	    catch {file delete -force -- {*}$x}
-	}
+    foreach p [list [pwd] {*}$args] {
+        cleanupRecurse {*}[glob -nocomplain -directory $p tf* td*]
     }
 }
 
@@ -415,12 +420,12 @@ test winFCmd-1.38 {TclpRenameFile: check rename of conflicting inodes} -setup {
     cleanup
 } -constraints {win winNonZeroInodes notInCIenv} -body {
     file mkdir td1
-    foreach {a b} [MakeFiles td1] break
+    lassign [MakeFiles td1] a b
     file rename -force $a $b
     file exists $a
 } -cleanup {
     cleanup
-} -result {0}
+} -result 0
 
 
 test winFCmd-2.1 {TclpCopyFile: errno: EACCES} -setup {
@@ -496,11 +501,11 @@ test winFCmd-2.12 {TclpCopyFile: CopyFile succeeds} -setup {
     cleanup
 } -constraints {win testfile} -body {
     createfile tf1 tf1
-    testchmod 0 tf1
+    file attribute tf1 -readonly 1
     testfile cp tf1 tf2
     list [contents tf2] [file writable tf2]
 } -cleanup {
-    catch {testchmod 0o666 tf1}
+    testchmod 0o660 tf1
     cleanup
 } -result {tf1 0}
 test winFCmd-2.13 {TclpCopyFile: CopyFile fails} -setup {
@@ -542,11 +547,10 @@ test winFCmd-2.17 {TclpCopyFile: dst is readonly} -setup {
 } -constraints {win testfile testchmod} -body {
     createfile tf1 tf1
     createfile tf2 tf2
-    testchmod 0 tf2
+    file attribute tf2 -readonly 1
     testfile cp tf1 tf2
     list [file writable tf2] [contents tf2]
 } -cleanup {
-    catch {testchmod 0o666 tf2}
     cleanup
 } -result {1 tf1}
 
@@ -624,7 +628,6 @@ test winFCmd-3.11 {TclpDeleteFile: still can't remove path} -setup {
     testfile rm tf1
 } -cleanup {
     close $fd
-    catch {testchmod 0o666 tf1}
     cleanup
 } -returnCodes error -result EACCES
 
@@ -664,14 +667,17 @@ test winFCmd-5.1 {TclpCopyDirectory: calls TraverseWinTree} -setup {
 test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} -setup {
     cleanup
 } -constraints {winVista testfile testchmod notInCIenv} -body {
-    file mkdir td1
-    testchmod 0 td1
-    testfile rmdir td1
-    file exists td1
+    # Parent's FILE_DELETE_CHILD setting permits deletion of subdir
+    # even when subdir DELETE mask is clear. So we need an intermediate
+    # parent td0 with FILE_DELETE_CHILD turned off while allowing R/W.
+    file mkdir td0/td1
+    testchmod 0o777 td0
+    testchmod 0 td0/td1
+    testfile rmdir td0/td1
+    file exists td0/td1
 } -returnCodes error -cleanup {
-    catch {testchmod 0o666 td1}
     cleanup
-} -result {td1 EACCES}
+} -result {td0/td1 EACCES}
 # This next test has a very hokey way of matching...
 test winFCmd-6.2 {TclpRemoveDirectory: errno: EEXIST} -setup {
     cleanup
@@ -679,7 +685,7 @@ test winFCmd-6.2 {TclpRemoveDirectory: errno: EEXIST} -setup {
     file mkdir td1/td2
     list [catch {testfile rmdir td1} msg] [file tail $msg]
 } -result {1 {td1 EEXIST}}
-test winFCmd-6.3 {TclpRemoveDirectory: errno: EACCES} {win emptyTest} {
+test winFCmd-6.3 {TclpRemoveDirectory: errno: EACCES} {win emptyTest trashSystem} {
     # can't test this w/o removing everything on your hard disk first!
     # testfile rmdir /
 } {}
@@ -715,17 +721,7 @@ test winFCmd-6.8 {TclpRemoveDirectory: RemoveDirectory fails} -setup {
     createfile tf1
     list [catch {testfile rmdir tf1} msg] [file tail $msg]
 } -result {1 {tf1 ENOTDIR}}
-test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} -setup {
-    cleanup
-} -constraints {winVista testfile testchmod notInCIenv} -body {
-    file mkdir td1
-    testchmod 0 td1
-    testfile rmdir td1
-    file exists td1
-} -returnCodes error -cleanup {
-    catch {testchmod 0o666 td1}
-    cleanup
-} -result {td1 EACCES}
+# winFCmd-6.9 removed - was exact dup of winFCmd-6.1
 test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup {
     cleanup
 } -constraints {win nt testfile} -body {
@@ -736,14 +732,18 @@ test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup {
 test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup {
     cleanup
 } -constraints {winVista testfile testchmod notInCIenv} -body {
-    file mkdir td1
-    testchmod 0 td1
-    testfile rmdir td1
-    file exists td1
+    # Parent's FILE_DELETE_CHILD setting permits deletion of subdir
+    # even when subdir DELETE mask is clear. So we need an intermediate
+    # parent td0 with FILE_DELETE_CHILD turned off while allowing R/W.
+    file mkdir td0/td1
+    testchmod 0o770 td0
+    testchmod 0o444 td0/td1
+    testfile rmdir td0/td1
+    file exists td0/td1
 } -cleanup {
-    catch {testchmod 0o666 td1}
+    testchmod 0o770 td0/td1
     cleanup
-} -returnCodes error -result {td1 EACCES}
+} -returnCodes error -result {td0/td1 EACCES}
 # This next test has a very hokey way of matching...
 test winFCmd-6.15 {TclpRemoveDirectory: !recursive} -setup {
     cleanup
@@ -837,11 +837,12 @@ test winFCmd-7.11 {TraverseWinTree: call TraversalCopy: DOTREE_PRED} -setup {
 } -constraints {win testfile testchmod} -body {
     file mkdir td1
     createfile td1/tf1 tf1
-    testchmod 0 td1
+    testchmod 0o770 td1/tf1; # Else tf2 will have no ACL after td1 testchmod
+    testchmod 0o400 td1
     testfile cpdir td1 td2
     list [file exists td2] [file writable td2]
 } -cleanup {
-    catch {testchmod 0o666 td1}
+    testchmod 0o660 td1
     cleanup
 } -result {1 1}
 test winFCmd-7.12 {TraverseWinTree: call TraversalDelete: DOTREE_PRED} -setup {
@@ -908,11 +909,12 @@ test winFCmd-7.19 {TraverseWinTree: call TraversalCopy: DOTREE_POSTD} -setup {
 } -constraints {win testfile testchmod} -body {
     file mkdir td1
     createfile td1/tf1 tf1
-    testchmod 0 td1
+    testchmod 0o770 td1/tf1; # Else tf2 will have no ACL after td1 testchmod
+    testchmod 0o400 td1
     testfile cpdir td1 td2
     list [file exists td2] [file writable td2]
 } -cleanup {
-    catch {testchmod 0o666 td1}
+    testchmod 0o660 td1
     cleanup
 } -result {1 1}
 test winFCmd-7.20 {TraverseWinTree: call TraversalDelete: DOTREE_POSTD} -setup {
@@ -939,11 +941,12 @@ test winFCmd-8.2 {TraversalCopy: DOTREE_PRED} -setup {
     cleanup
 } -constraints {win testfile testchmod} -body {
     file mkdir td1/td2
-    testchmod 0 td1
+    testchmod 0o770 td1/td2; # Else td2 will have no ACL after td1 testchmod
+    testchmod 0o400 td1
     testfile cpdir td1 td2
     list [file writable td1] [file writable td1/td2]
 } -cleanup {
-    catch {testchmod 0o666 td1}
+    testchmod 0o660 td1
     cleanup
 } -result {0 1}
 test winFCmd-8.3 {TraversalCopy: DOTREE_POSTD} -setup {
@@ -965,14 +968,18 @@ test winFCmd-9.1 {TraversalDelete: DOTREE_F} -setup {
 test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} -setup {
     cleanup
 } -constraints {winVista testfile testchmod notInCIenv} -body {
-    file mkdir td1/td2
-    testchmod 0 td1
-    testfile rmdir -force td1
+    # Parent's FILE_DELETE_CHILD setting permits deletion of subdir
+    # even when subdir DELETE mask is clear. So we need an intermediate
+    # parent td0 with FILE_DELETE_CHILD turned off while allowing R/W.
+    file mkdir td0/td1/td2
+    testchmod 0o770 td0
+    testchmod 0o400 td0/td1
+    testfile rmdir -force td0/td1
     file exists td1
 } -cleanup {
-    catch {testchmod 0o666 td1}
+    testchmod 0o770 td0/td1
     cleanup
-} -returnCodes error -result {td1 EACCES}
+} -returnCodes error -result {td0/td1 EACCES}
 test winFCmd-9.4 {TraversalDelete: DOTREE_POSTD} -setup {
     cleanup
 } -constraints {win testfile} -body {
@@ -1471,7 +1478,6 @@ test winFCmd-19.9 {Windows devices path names} -constraints {win nt} -body {
 #    }
 #}
 
-# cleanup
 cleanup
 ::tcltest::cleanupTests
 return

tests/winTime.test

@@ -19,9 +19,6 @@ if {"::tcltest" ni [namespace children]} {
 catch [list package require -exact Tcltest [info patchlevel]]
 
 testConstraint testwinclock [llength [info commands testwinclock]]
-# Some things fail under all Continuous Integration systems for subtle reasons
-# such as CI often running with elevated privileges in a container.
-testConstraint notInCIenv   [expr {![info exists ::env(CI)]}]
 
 # The next two tests will crash on Windows if the check for negative
 # clock values is not done properly.
@@ -43,7 +40,7 @@ test winTime-1.2 {TclpGetDate} {win} {
 # with the Windows clock.  30 sec really isn't enough,
 # but how much time does a tester have patience for?
 
-test winTime-2.1 {Synchronization of Tcl and Windows clocks} {testwinclock notInCIenv} {
+test winTime-2.1 {Synchronization of Tcl and Windows clocks} testwinclock {
     # May fail due to OS/hardware discrepancies.  See:
     # http://support.microsoft.com/default.aspx?scid=kb;en-us;274323
     set failed {}

tests/zlib.test

@@ -486,6 +486,38 @@ test zlib-8.18 {Bug dd260aaf: fconfigure} -setup {
     catch {close $inSide}
     catch {close $outSide}
 } -result {{one two} {one two}}
+test zlib-8.19 {zlib transformation, bug f9eafc3886} -constraints zlib -setup {
+    set file [makeFile {} test.gz]
+} -body {
+    set f [zlib push gzip [open $file w] -header [list comment [string repeat A 500]]]
+} -cleanup {
+    catch {close $f}
+    removeFile $file
+} -returnCodes 1 -result {Comment too large for zip}
+test zlib-8.20 {zlib transformation, bug f9eafc3886} -constraints zlib -setup {
+    set file [makeFile {} test.gz]
+} -body {
+    set f [zlib push gzip [open $file w] -header [list filename [string repeat A 5000]]]
+} -cleanup {
+    catch {close $f}
+    removeFile $file
+} -returnCodes 1 -result {Filename too large for zip}
+test zlib-8.21 {zlib transformation, bug f9eafc3886} -constraints zlib -setup {
+    set file [makeFile {} test.gz]
+} -body {
+    set f [zlib push gzip [open $file w] -header [list comment \u100]]
+} -cleanup {
+    catch {close $f}
+    removeFile $file
+} -returnCodes 1 -result {Comment contains characters > 0xFF}
+test zlib-8.22 {zlib transformation, bug f9eafc3886} -constraints zlib -setup {
+    set file [makeFile {} test.gz]
+} -body {
+    set f [zlib push gzip [open $file w] -header [list filename \u100]]
+} -cleanup {
+    catch {close $f}
+    removeFile $file
+} -returnCodes 1 -result {Filename contains characters > 0xFF}
 
 test zlib-9.1 "check fcopy with push" -constraints zlib -setup {
     set sfile [makeFile {} testsrc.gz]

tools/valgrind_suppress

@@ -1,3 +1,17 @@
+#{
+#    Tcl_GetChannelOption/TcpGetOptionProc/TcphostPortList/getnameinfo/gethostbyaddr_r
+#    Memcheck:Leak
+#    match-leak-kinds: reachable
+#    fun:malloc
+#    fun:strdup
+#    ...
+#    fun:module_load
+#    ...
+#    fun:getnameinfo
+#    ...
+#    fun:Tcl_GetChannelOption
+#}
+
 {
    TclCreatesocketAddress/getaddrinfo/calloc
    Memcheck:Leak
@@ -8,6 +22,16 @@
    fun:TclCreateSocketAddress
 }
 
+{
+   TclCreatesocketAddress/getaddrinfo/malloc
+   Memcheck:Leak
+   match-leak-kinds: definite
+   fun:malloc
+   ...
+   fun:getaddrinfo
+   fun:TclCreateSocketAddress
+}
+
 {
    TclCreatesocketAddress/getaddrinfo/malloc
    Memcheck:Leak
@@ -18,6 +42,18 @@
    fun:TclCreateSocketAddress
 }
 
+{
+   TclpDlopen/decompose_rpath
+   Memcheck:Leak
+   match-leak-kinds: reachable
+   fun:malloc
+   fun:decompose_rpath
+   ...
+   fun:dlopen_doit
+   ...
+   fun:TclpDlopen
+}
+
 {
    TclpDlopen/load
    Memcheck:Leak
@@ -71,6 +107,46 @@
    fun:TclpGetGrNam
 }
 
+{
+    TclpGeHostByName/gethostbyname_r/strdup/malloc
+    Memcheck:Leak
+    match-leak-kinds: reachable
+    fun:malloc
+    fun:strdup
+    ...
+    fun:dl_open_worker
+    ...
+    fun:do_dlopen
+    ...
+    fun:TclpGetHostByName
+}
+
+{
+    TclpGeHostByName/gethostbyname_r/calloc
+    Memcheck:Leak
+    match-leak-kinds: reachable
+    fun:calloc
+    ...
+    fun:dl_open_worker
+    ...
+    fun:do_dlopen
+    ...
+    fun:TclpGetHostByName
+}
+
+{
+    TclpGeHostByName/gethostbyname_r/malloc
+    Memcheck:Leak
+    match-leak-kinds: reachable
+    fun:malloc
+    ...
+    fun:dl_open_worker
+    ...
+    fun:do_dlopen
+    ...
+    fun:TclpGetHostByName
+}
+
 {
    TclpGetPwNam/getpwname_r/__nss_next2/calloc
    Memcheck:Leak
@@ -104,6 +180,57 @@
    fun:TclpGetPwNam
 }
 
+{
+    TclpGetGrGid/getgrgid_r/module_load
+    Memcheck:Leak
+    match-leak-kinds: reachable
+    fun:calloc
+    ...
+    fun:module_load
+    ...
+    fun:TclpGetGrGid
+}
+
+{
+    TclpGetGrGid/getgrgid_r/module_load
+    Memcheck:Leak
+    match-leak-kinds: reachable
+    fun:malloc
+    ...
+    fun:module_load
+    ...
+    fun:TclpGetGrGid
+}
+
+{
+    TcphostPortList/getnameinfo/module_load/calloc
+    Memcheck:Leak
+    match-leak-kinds: definite,reachable
+    fun:calloc
+    ...
+    fun:dl_open_worker_begin
+    ...
+    fun:module_load
+    ...
+    fun:getnameinfo
+    fun:TcpHostPortList
+}
+
+{
+    # see sourceware glibc Bug 14984 - getnameinfo() might be leaking memory
+    TcphostPortList/getnameinfo/module_load/mallco
+    Memcheck:Leak
+    match-leak-kinds: definite,reachable
+    fun:malloc
+    ...
+    fun:dl_open_worker_begin
+    ...
+    fun:module_load
+    ...
+    fun:getnameinfo
+    fun:TcpHostPortList
+}
+
 {
 	TclpThreadExit/pthread_exit/calloc
     Memcheck:Leak
@@ -124,3 +251,13 @@
 	fun:TclpThreadExit
 }
 
+{
+	TclpThreadExit/pthread_exit/malloc
+    Memcheck:Leak
+    match-leak-kinds: definite
+	fun:malloc
+	...
+	fun:pthread_exit
+	fun:TclpThreadExit
+}
+

win/tclWinFile.c

@@ -1458,22 +1458,43 @@ TclpGetUserHome(
     if (domain == NULL) {
 	const char *ptr;
 
-	/*
-	 * No domain. Firstly check it's the current user
-	 */
-
+        /*
+         * Treat the current user as a special case because the general case
+         * below does not properly retrieve the path. The NetUserGetInfo
+         * call returns an empty path and the code defaults to the user's
+         * name in the profiles directory. On modern Windows systems, this
+         * is generally wrong as when the account is a Microsoft account,
+         * for example abcdefghi@outlook.com, the directory name is
+         * abcde and not abcdefghi.
+         *
+         * Note we could have just used env(USERPROFILE) here but
+         * the intent is to retrieve (as on Unix) the system's view
+         * of the home irrespective of environment settings of HOME
+         * and USERPROFILE.
+         *
+         * Fixing this for the general user needs more investigating but
+         * at least for the current user we can use a direct call.
+         */
 	ptr = TclpGetUserName(&ds);
 	if (ptr != NULL && strcasecmp(name, ptr) == 0) {
-	    /*
-	     * Try safest and fastest way to get current user home
-	     */
-
-	    ptr = TclGetEnv("HOME", &ds);
-	    if (ptr != NULL) {
-		Tcl_JoinPath(1, &ptr, bufferPtr);
-		rc = 1;
-		result = Tcl_DStringValue(bufferPtr);
-	    }
+            HANDLE hProcess;
+            WCHAR buf[MAX_PATH];
+            DWORD nChars = sizeof(buf) / sizeof(buf[0]);
+            /* Sadly GetCurrentProcessToken not in Win 7 so slightly longer */
+            hProcess = GetCurrentProcess(); /* Need not be closed */
+            if (hProcess) {
+                HANDLE hToken;
+                if (OpenProcessToken(hProcess, TOKEN_QUERY, &hToken)) {
+                    if (GetUserProfileDirectoryW(hToken, buf, &nChars)) {
+                        Tcl_WinTCharToUtf((TCHAR *)buf,
+                                          (nChars-1)*sizeof(WCHAR),
+                                          bufferPtr);
+                        result = Tcl_DStringValue(bufferPtr);
+                        rc = 1;
+                    }
+                    CloseHandle(hToken);
+                }
+            }
 	}
 	Tcl_DStringFree(&ds);
     } else {
@@ -1542,30 +1563,6 @@ TclpGetUserHome(
     if (wDomain != NULL) {
 	NetApiBufferFree((void *) wDomain);
     }
-    if (result == NULL) {
-	/*
-	 * Look in the "Password Lists" section of system.ini for the local
-	 * user. There are also entries in that section that begin with a "*"
-	 * character that are used by Windows for other purposes; ignore user
-	 * names beginning with a "*".
-	 */
-
-	char buf[MAX_PATH];
-
-	if (name[0] != '*') {
-	    if (GetPrivateProfileStringA("Password Lists", name, "", buf,
-		    MAX_PATH, "system.ini") > 0) {
-		/*
-		 * User exists, but there is no such thing as a home directory
-		 * in system.ini. Return "{Windows drive}:/".
-		 */
-
-		GetWindowsDirectoryA(buf, MAX_PATH);
-		Tcl_DStringAppend(bufferPtr, buf, 3);
-		result = Tcl_DStringValue(bufferPtr);
-	    }
-	}
-    }
 
     return result;
 }

win/tclWinTest.c

@@ -17,9 +17,8 @@
 /*
  * For TestplatformChmod on Windows
  */
-#ifdef _WIN32
 #include <aclapi.h>
-#endif
+#include <sddl.h>
 
 /*
  * MinGW 3.4.2 does not define this.
@@ -416,176 +415,190 @@ TestExceptionCmd(
     return TCL_OK;
 }
 
+/*
+ * This "chmod" works sufficiently for test script purposes. Do not expect
+ * it to be exact emulation of Unix chmod (not sure if that's even possible)
+ */
 static int
 TestplatformChmod(
     const char *nativePath,
     int pmode)
 {
-    static const SECURITY_INFORMATION infoBits = OWNER_SECURITY_INFORMATION
-	    | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION;
-    /* don't reset change permissions mask (WRITE_DAC, allow test-cases restore it to cleanup) */
-    static const DWORD readOnlyMask = FILE_DELETE_CHILD | FILE_ADD_FILE
-	    | FILE_ADD_SUBDIRECTORY | FILE_WRITE_EA | FILE_APPEND_DATA
-	    | FILE_WRITE_DATA
-	    | DELETE;
-
-    /*
-     * References to security functions (only available on NT and later).
+    /* 
+     * Note FILE_DELETE_CHILD missing from dirWriteMask because we do
+     * not want overriding of child's delete setting when testing
      */
+    static const DWORD dirWriteMask =
+	FILE_WRITE_ATTRIBUTES | FILE_WRITE_EA |
+	FILE_ADD_FILE | FILE_ADD_SUBDIRECTORY | STANDARD_RIGHTS_WRITE | DELETE |
+	SYNCHRONIZE;
+    static const DWORD dirReadMask = 
+	FILE_READ_ATTRIBUTES | FILE_READ_EA | FILE_LIST_DIRECTORY |
+	STANDARD_RIGHTS_READ | SYNCHRONIZE;
+    /* Note - default user privileges allow ignoring TRAVERSE setting */
+    static const DWORD dirExecuteMask =
+	FILE_TRAVERSE | STANDARD_RIGHTS_READ | SYNCHRONIZE;
 
-    const BOOL set_readOnly = !(pmode & 0222);
-    BOOL acl_readOnly_found = FALSE, curAclPresent, curAclDefaulted;
-    SID_IDENTIFIER_AUTHORITY userSidAuthority = {
-	SECURITY_WORLD_SID_AUTHORITY
-    };
-    BYTE *secDesc = 0;
-    DWORD secDescLen, attr, newAclSize;
-    ACL_SIZE_INFORMATION ACLSize;
-    PACL curAcl, newAcl = 0;
-    WORD j;
-    SID *userSid = 0;
-    char *userDomain = 0;
+    static const DWORD fileWriteMask =
+	FILE_WRITE_ATTRIBUTES | FILE_WRITE_EA | FILE_WRITE_DATA |
+	FILE_APPEND_DATA | STANDARD_RIGHTS_WRITE | DELETE | SYNCHRONIZE;
+    static const DWORD fileReadMask = 
+	FILE_READ_ATTRIBUTES | FILE_READ_EA | FILE_READ_DATA |
+	STANDARD_RIGHTS_READ | SYNCHRONIZE;
+    static const DWORD fileExecuteMask =
+	FILE_EXECUTE | STANDARD_RIGHTS_READ | SYNCHRONIZE;
+
+    DWORD attr, newAclSize;
+    PACL newAcl = NULL;
     int res = 0;
+    SID_IDENTIFIER_AUTHORITY worldAuthority = SECURITY_WORLD_SID_AUTHORITY;
 
-    /*
-     * Process the chmod request.
-     */
+    HANDLE hToken = NULL;
+    int i;
+    int nSids = 0;
+    struct {
+	PSID pSid;
+	DWORD mask;
+	DWORD sidLen;
+    } aceEntry[3];
+    DWORD dw;
+    int isDir;
+    TOKEN_USER *pTokenUser = NULL;
+
+    res = -1; /* Assume failure */
 
     attr = GetFileAttributesA(nativePath);
-
-    /*
-     * nativePath not found
-     */
-
     if (attr == 0xFFFFFFFF) {
-	res = -1;
-	goto done;
+	goto done; /* Not found */
     }
 
-    /*
-     * If nativePath is not a directory, there is no special handling.
-     */
+    isDir = (attr & FILE_ATTRIBUTE_DIRECTORY) != 0;
 
-    if (!(attr & FILE_ATTRIBUTE_DIRECTORY)) {
+    if (!OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &hToken)) {
 	goto done;
     }
-
-    /*
-     * Set the result to error, if the ACL change is successful it will be
-     * reset to 0.
+    
+    /* Get process SID */
+    if (!GetTokenInformation(hToken, TokenUser, NULL, 0, &dw) &&
+	GetLastError() != ERROR_INSUFFICIENT_BUFFER) {
+	goto done;
+    }
+    pTokenUser = ckalloc(dw);
+    if (!GetTokenInformation(hToken, TokenUser, pTokenUser, dw, &dw)) {
+	goto done;
+    }
+    aceEntry[nSids].sidLen = GetLengthSid(pTokenUser->User.Sid);
+    aceEntry[nSids].pSid = ckalloc(aceEntry[nSids].sidLen);
+    if (!CopySid(aceEntry[nSids].sidLen,
+		 aceEntry[nSids].pSid,
+		 pTokenUser->User.Sid)) {
+	ckfree(aceEntry[nSids].pSid); /* Since we have not ++'ed nSids */
+	goto done;
+    }
+    /* 
+     * Always include DACL modify rights so we don't get locked out
      */
-
-    res = -1;
-
-    /*
-     * Read the security descriptor for the directory. Note the first call
-     * obtains the size of the security descriptor.
-     */
-
-    if (!GetFileSecurityA(nativePath, infoBits, NULL, 0, &secDescLen)) {
-	DWORD secDescLen2 = 0;
-
-	if (GetLastError() != ERROR_INSUFFICIENT_BUFFER) {
-	    goto done;
+    aceEntry[nSids].mask = READ_CONTROL | WRITE_DAC | WRITE_OWNER | SYNCHRONIZE |
+			   FILE_READ_ATTRIBUTES | FILE_WRITE_ATTRIBUTES;
+    if (pmode & 0700) {
+	/* Owner permissions. Assumes current process is owner */
+	if (pmode & 0400) {
+	    aceEntry[nSids].mask |= isDir ? dirReadMask : fileReadMask;
 	}
-
-	secDesc = ckalloc(secDescLen);
-	if (!GetFileSecurityA(nativePath, infoBits,
-		(PSECURITY_DESCRIPTOR) secDesc, secDescLen, &secDescLen2)
-		|| (secDescLen < secDescLen2)) {
-	    goto done;
+	if (pmode & 0200) {
+	    aceEntry[nSids].mask |= isDir ? dirWriteMask : fileWriteMask;
+	}
+	if (pmode & 0100) {
+	    aceEntry[nSids].mask |= isDir ? dirExecuteMask : fileExecuteMask;
 	}
     }
+    ++nSids;
 
-    /*
-     * Get the World SID.
-     */
+    if (pmode & 0070) {
+	/* Group permissions. */
 
-    userSid = ckalloc(GetSidLengthRequired((UCHAR) 1));
-    InitializeSid(userSid, &userSidAuthority, (BYTE) 1);
-    *(GetSidSubAuthority(userSid, 0)) = SECURITY_WORLD_RID;
+	TOKEN_PRIMARY_GROUP *pTokenGroup;
 
-    /*
-     * If curAclPresent == false then curAcl and curAclDefaulted not valid.
-     */
+	/* Get primary group SID */
+	if (!GetTokenInformation(
+		hToken, TokenPrimaryGroup, NULL, 0, &dw) &&
+		GetLastError() != ERROR_INSUFFICIENT_BUFFER) {
+	    goto done;
+	}
+	pTokenGroup = ckalloc(dw);
+	if (!GetTokenInformation(hToken, TokenPrimaryGroup, pTokenGroup, dw, &dw)) {
+	    ckfree(pTokenGroup);
+	    goto done;
+	}
+	aceEntry[nSids].sidLen = GetLengthSid(pTokenGroup->PrimaryGroup);
+	aceEntry[nSids].pSid = ckalloc(aceEntry[nSids].sidLen);
+	if (!CopySid(aceEntry[nSids].sidLen, aceEntry[nSids].pSid, pTokenGroup->PrimaryGroup)) {
+	    ckfree(pTokenGroup);
+	    ckfree(aceEntry[nSids].pSid); /* Since we have not ++'ed nSids */
+	    goto done;
+	}
+	ckfree(pTokenGroup);
 
-    if (!GetSecurityDescriptorDacl((PSECURITY_DESCRIPTOR) secDesc,
-	    &curAclPresent, &curAcl, &curAclDefaulted)) {
-	goto done;
-    }
-    if (!curAclPresent || !curAcl) {
-	ACLSize.AclBytesInUse = 0;
-	ACLSize.AceCount = 0;
-    } else if (!GetAclInformation(curAcl, &ACLSize, sizeof(ACLSize),
-	    AclSizeInformation)) {
-	goto done;
+	/* Generate mask for group ACL */
+
+	aceEntry[nSids].mask = 0;
+	if (pmode & 0040) {
+	    aceEntry[nSids].mask |= isDir ? dirReadMask : fileReadMask;
+	}
+	if (pmode & 0020) {
+	    aceEntry[nSids].mask |= isDir ? dirWriteMask : fileWriteMask;
+	}
+	if (pmode & 0010) {
+	    aceEntry[nSids].mask |= isDir ? dirExecuteMask : fileExecuteMask;
+	}
+	++nSids;
     }
 
-    /*
-     * Allocate memory for the new ACL.
-     */
+    if (pmode & 0007) {
+	/* World permissions */
+	PSID pWorldSid;
+	if (!ConvertStringSidToSidA("S-1-1-0", &pWorldSid)) {
+	    goto done;
+	}
+	aceEntry[nSids].sidLen = GetLengthSid(pWorldSid);
+	aceEntry[nSids].pSid = ckalloc(aceEntry[nSids].sidLen);
+	if (!CopySid(aceEntry[nSids].sidLen, aceEntry[nSids].pSid, pWorldSid)) {
+	    LocalFree(pWorldSid);
+	    ckfree(aceEntry[nSids].pSid); /* Since we have not ++'ed nSids */
+	    goto done;
+	}
+	LocalFree(pWorldSid);
 
-    newAclSize = ACLSize.AclBytesInUse + sizeof(ACCESS_DENIED_ACE)
-	    + GetLengthSid(userSid) - sizeof(DWORD);
+	/* Generate mask for world ACL */
+
+	aceEntry[nSids].mask = 0;
+	if (pmode & 0004) {
+	    aceEntry[nSids].mask |= isDir ? dirReadMask : fileReadMask;
+	}
+	if (pmode & 0002) {
+	    aceEntry[nSids].mask |= isDir ? dirWriteMask : fileWriteMask;
+	}
+	if (pmode & 0001) {
+	    aceEntry[nSids].mask |= isDir ? dirExecuteMask : fileExecuteMask;
+	}
+	++nSids;
+    }
+
+    /* Allocate memory and initialize the new ACL. */
+
+    newAclSize = sizeof(ACL);
+    /* Add in size required for each ACE entry in the ACL */
+    for (i = 0; i < nSids; ++i) {
+	newAclSize +=
+	    offsetof(ACCESS_ALLOWED_ACE, SidStart) + aceEntry[i].sidLen;
+    }
     newAcl = ckalloc(newAclSize);
-
-    /*
-     * Initialize the new ACL.
-     */
-
     if (!InitializeAcl(newAcl, newAclSize, ACL_REVISION)) {
 	goto done;
     }
 
-    /*
-     * Add denied to make readonly, this will be known as a "read-only tag".
-     */
-
-    if (set_readOnly && !AddAccessDeniedAce(newAcl, ACL_REVISION,
-	    readOnlyMask, userSid)) {
-	goto done;
-    }
-
-    acl_readOnly_found = FALSE;
-    for (j = 0; j < ACLSize.AceCount; j++) {
-	LPVOID pACE2;
-	ACE_HEADER *phACE2;
-
-	if (!GetAce(curAcl, j, &pACE2)) {
-	    goto done;
-	}
-
-	phACE2 = (ACE_HEADER *) pACE2;
-
-	/*
-	 * Do NOT propagate inherited ACEs.
-	 */
-
-	if (phACE2->AceFlags & INHERITED_ACE) {
-	    continue;
-	}
-
-	/*
-	 * Skip the "read-only tag" restriction (either added above, or it is
-	 * being removed).
-	 */
-
-	if (phACE2->AceType == ACCESS_DENIED_ACE_TYPE) {
-	    ACCESS_DENIED_ACE *pACEd = (ACCESS_DENIED_ACE *) phACE2;
-
-	    if (pACEd->Mask == readOnlyMask
-		    && EqualSid(userSid, (PSID) &pACEd->SidStart)) {
-		acl_readOnly_found = TRUE;
-		continue;
-	    }
-	}
-
-	/*
-	 * Copy the current ACE from the old to the new ACL.
-	 */
-
-	if (!AddAce(newAcl, ACL_REVISION, MAXDWORD, (PACL *) pACE2,
-		((PACE_HEADER) pACE2)->AceSize)) {
+    for (i = 0; i < nSids; ++i) {
+	if (!AddAccessAllowedAce(newAcl, ACL_REVISION, aceEntry[i].mask, aceEntry[i].pSid)) {
 	    goto done;
 	}
     }
@@ -595,35 +608,36 @@ TestplatformChmod(
      * to remove inherited ACL (we need to overwrite the default ACL's in this case)
      */
 
-    if (set_readOnly == acl_readOnly_found || SetNamedSecurityInfoA(
-	    (LPSTR) nativePath, SE_FILE_OBJECT,
-	    DACL_SECURITY_INFORMATION /*| PROTECTED_DACL_SECURITY_INFORMATION*/,
-	    NULL, NULL, newAcl, NULL) == ERROR_SUCCESS) {
+    if (SetNamedSecurityInfoA((LPSTR)nativePath,
+			      SE_FILE_OBJECT,
+			      DACL_SECURITY_INFORMATION |
+				  PROTECTED_DACL_SECURITY_INFORMATION,
+			      NULL,
+			      NULL,
+			      newAcl,
+			      NULL) == ERROR_SUCCESS) {
 	res = 0;
     }
 
   done:
-    if (secDesc) {
-	ckfree(secDesc);
+    if (pTokenUser) {
+	ckfree(pTokenUser);
+    }
+    if (hToken) {
+	CloseHandle(hToken);
     }
     if (newAcl) {
 	ckfree(newAcl);
     }
-    if (userSid) {
-	ckfree(userSid);
-    }
-    if (userDomain) {
-	ckfree(userDomain);
+    for (i = 0; i < nSids; ++i) {
+	ckfree(aceEntry[i].pSid);
     }
 
     if (res != 0) {
 	return res;
     }
 
-    /*
-     * Run normal chmod command.
-     */
-
+    /* Run normal chmod command */
     return chmod(nativePath, pmode);
 }