merge 8.5: fixes segfault [7a9dc52b29] and wrong normalization (inside TclJoinPath) for pure relative path-segments; test-cases extended and several windows-related are fixed.

9 files changed, 74 insertions, 50 deletions

diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 7e117af..e6f1cd5 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -2127,7 +2127,7 @@ PathJoinCmd(
 	Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
 	return TCL_ERROR;
     }
-    Tcl_SetObjResult(interp, TclJoinPath(objc - 1, objv + 1));
+    Tcl_SetObjResult(interp, TclJoinPath(objc - 1, objv + 1, 0));
     return TCL_OK;
 }
 
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index fda2940..99372c5 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -180,7 +180,7 @@ FileCopyRename(
 	}
 	jargv[0] = objv[objc - 1];
 	jargv[1] = source;
-	newFileName = TclJoinPath(2, jargv);
+	newFileName = TclJoinPath(2, jargv, 1);
 	Tcl_IncrRefCount(newFileName);
 	result = CopyRenameOneFile(interp, objv[i], newFileName, copyFlag,
 		force);
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index b566d7f..7afcdaf 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -808,24 +808,24 @@ Tcl_FSJoinToPath(
     Tcl_Obj *const objv[])	/* Path elements to join. */
 {
     if (pathPtr == NULL) {
-	return TclJoinPath(objc, objv);
+	return TclJoinPath(objc, objv, 0);
     }
     if (objc == 0) {
-	return TclJoinPath(1, &pathPtr);
+	return TclJoinPath(1, &pathPtr, 0);
     }
     if (objc == 1) {
 	Tcl_Obj *pair[2];
 
 	pair[0] = pathPtr;
 	pair[1] = objv[0];
-	return TclJoinPath(2, pair);
+	return TclJoinPath(2, pair, 0);
     } else {
 	int elemc = objc + 1;
 	Tcl_Obj *ret, **elemv = ckalloc(elemc*sizeof(Tcl_Obj *));
 
 	elemv[0] = pathPtr;
 	memcpy(elemv+1, objv, objc*sizeof(Tcl_Obj *));
-	ret = TclJoinPath(elemc, elemv);
+	ret = TclJoinPath(elemc, elemv, 0);
 	ckfree(elemv);
 	return ret;
     }
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 432be7a..03cb5ae 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3027,7 +3027,8 @@ MODULE_SCOPE void	TclInitSubsystems(void);
 MODULE_SCOPE int	TclInterpReady(Tcl_Interp *interp);
 MODULE_SCOPE int	TclIsSpaceProc(char byte);
 MODULE_SCOPE int	TclIsBareword(char byte);
-MODULE_SCOPE Tcl_Obj *	TclJoinPath(int elements, Tcl_Obj * const objv[]);
+MODULE_SCOPE Tcl_Obj *	TclJoinPath(int elements, Tcl_Obj * const objv[],
+			    int forceRelative);
 MODULE_SCOPE int	TclJoinThread(Tcl_ThreadId id, int *result);
 MODULE_SCOPE void	TclLimitRemoveAllHandlers(Tcl_Interp *interp);
 MODULE_SCOPE Tcl_Obj *	TclLindexList(Tcl_Interp *interp,
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index e214d1f..a2a41e4 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -829,7 +829,7 @@ Tcl_FSJoinPath(
 				 * reference count. */
     int elements)		/* Number of elements to use (-1 = all) */
 {
-    Tcl_Obj *copy, *res;
+    Tcl_Obj *res;
     int objc;
     Tcl_Obj **objv;
 
@@ -838,17 +838,17 @@ Tcl_FSJoinPath(
     }
 
     elements = ((elements >= 0) && (elements <= objc)) ? elements : objc;
-    copy = TclListObjCopy(NULL, listObj);
     Tcl_ListObjGetElements(NULL, listObj, &objc, &objv);
-    res = TclJoinPath(elements, objv);
-    Tcl_DecrRefCount(copy);
+    res = TclJoinPath(elements, objv, 0);
     return res;
 }
 
 Tcl_Obj *
 TclJoinPath(
-    int elements,
-    Tcl_Obj * const objv[])
+    int elements,		/* Number of elements to use (-1 = all) */
+    Tcl_Obj * const objv[],	/* Path elements to join */
+    int forceRelative)		/* If non-zero, assume all more paths are
+				 * relative (e. g. simple normalization) */
 {
     Tcl_Obj *res = NULL;
     int i;
@@ -879,10 +879,13 @@ TclJoinPath(
 
 	if ((elt->typePtr == &tclFsPathType)
 		&& !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))
-                && TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) {
-            Tcl_Obj *tailObj = objv[1];
-	    Tcl_PathType type = TclGetPathType(tailObj, NULL, NULL, NULL);
+		&& TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) {
+	    Tcl_Obj *tailObj = objv[1];
+	    Tcl_PathType type;
 
+	    /* if forceRelative - second path is relative */
+	    type = forceRelative ? TCL_PATH_RELATIVE :
+		    TclGetPathType(tailObj, NULL, NULL, NULL);
 	    if (type == TCL_PATH_RELATIVE) {
 		const char *str;
 		int len;
@@ -960,7 +963,9 @@ TclJoinPath(
 
 	strElt = Tcl_GetStringFromObj(elt, &strEltLen);
 	driveNameLength = 0;
-	type = TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName);
+	/* if forceRelative - all paths excepting first one are relative */
+	type = (forceRelative && (i > 0)) ? TCL_PATH_RELATIVE :
+		TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName);
 	if (type != TCL_PATH_RELATIVE) {
 	    /*
 	     * Zero out the current result.
@@ -2360,36 +2365,29 @@ SetFsPathFromAny(
      * Handle tilde substitutions, if needed.
      */
 
-    if (name[0] == '~') {
+    if (len && name[0] == '~') {
 	Tcl_DString temp;
 	int split;
 	char separator = '/';
 
+	/*
+	 * We have multiple cases '~/foo/bar...', '~user/foo/bar...', etc.
+	 * split becomes value 1 for '~/...' as well as for '~'.
+	 */
 	split = FindSplitPos(name, separator);
-	if (split != len) {
-	    /*
-	     * We have multiple pieces '~user/foo/bar...'
-	     */
-
-	    name[split] = '\0';
-	}
 
 	/*
 	 * Do some tilde substitution.
 	 */
 
-	if (name[1] == '\0') {
+	if (split == 1) {
 	    /*
-	     * We have just '~'
+	     * We have just '~' (or '~/...')
 	     */
 
 	    const char *dir;
 	    Tcl_DString dirString;
 
-	    if (split != len) {
-		name[split] = separator;
-	    }
-
 	    dir = TclGetEnv("HOME", &dirString);
 	    if (dir == NULL) {
 		if (interp) {
@@ -2409,23 +2407,26 @@ SetFsPathFromAny(
 	     * We have a user name '~user'
 	     */
 
+	    const char *expandedUser;
+	    Tcl_DString userName;
+
+	    Tcl_DStringInit(&userName);
+	    Tcl_DStringAppend(&userName, name+1, split-1);
+	    expandedUser = Tcl_DStringValue(&userName);
+
 	    Tcl_DStringInit(&temp);
-	    if (TclpGetUserHome(name+1, &temp) == NULL) {
+	    if (TclpGetUserHome(expandedUser, &temp) == NULL) {
 		if (interp != NULL) {
 		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-			    "user \"%s\" doesn't exist", name+1));
+			    "user \"%s\" doesn't exist", expandedUser));
 		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER",
 			    NULL);
 		}
+		Tcl_DStringFree(&userName);
 		Tcl_DStringFree(&temp);
-		if (split != len) {
-		    name[split] = separator;
-		}
 		return TCL_ERROR;
 	    }
-	    if (split != len) {
-		name[split] = separator;
-	    }
+	    Tcl_DStringFree(&userName);
 	}
 
 	transPtr = TclDStringToObj(&temp);
@@ -2462,13 +2463,17 @@ SetFsPathFromAny(
 
 		pair[0] = transPtr;
 		pair[1] = Tcl_NewStringObj(name+split+1, -1);
-		transPtr = TclJoinPath(2, pair);
-		Tcl_DecrRefCount(pair[0]);
-		Tcl_DecrRefCount(pair[1]);
+		transPtr = TclJoinPath(2, pair, 1);
+		if (transPtr != pair[0]) {
+		    Tcl_DecrRefCount(pair[0]);
+		}
+		if (transPtr != pair[1]) {
+		    Tcl_DecrRefCount(pair[1]);
+		}
 	    }
 	}
     } else {
-	transPtr = TclJoinPath(1, &pathPtr);
+	transPtr = TclJoinPath(1, &pathPtr, 1);
     }
 
     /*
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index e8933d6..88c0367 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -566,6 +566,13 @@ test cmdAH-9.51 {Tcl_FileObjCmd: tail} testsetplatform {
     testsetplatform windows
     file tail {foo\bar}
 } bar
+test cmdAH-9.52 {Tcl_FileObjCmd: tail / normalize, bug 7a9dc52b29} {
+    list \
+	[file tail {~/~foo}] \
+	[file tail {~/test/~foo}] \
+	[file tail [file normalize {~/~foo}]] \
+	[file tail [file normalize {~/test/~foo}]]
+} [lrepeat 4 ./~foo]
 
 # rootname
 test cmdAH-10.1 {Tcl_FileObjCmd: rootname} -returnCodes error -body {
diff --git a/tests/winFile.test b/tests/winFile.test
index 2c47f5f..eb6addd 100644
--- a/tests/winFile.test
+++ b/tests/winFile.test
@@ -43,13 +43,14 @@ test winFile-1.4 {TclpGetUserHome} {win nt nonPortable} {
 
 test winFile-2.1 {TclpMatchFiles: case sensitivity} -constraints {win} -body {
     makeFile {} GlobCapS
-    list [glob -nocomplain GlobC*] [glob -nocomplain globc*]
-} -cleanup {
+    set args [list -nocomplain -tails -directory [temporaryDirectory]]
+    list [glob {*}$args GlobC*] [glob {*}$args globc*]} -cleanup {
     removeFile GlobCapS
 } -result {GlobCapS GlobCapS}
 test winFile-2.2 {TclpMatchFiles: case sensitivity} -constraints {win} -body {
     makeFile {} globlower
-    list [glob -nocomplain globl*] [glob -nocomplain gLOBl*]
+    set args [list -nocomplain -tails -directory [temporaryDirectory]]
+    list [glob {*}$args globl*] [glob {*}$args gLOBl*]
 } -cleanup {
     removeFile globlower
 } -result {globlower globlower}
diff --git a/tests/winPipe.test b/tests/winPipe.test
index b3624c2..06bd67e 100644
--- a/tests/winPipe.test
+++ b/tests/winPipe.test
@@ -22,9 +22,13 @@ catch {
     set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
 }
 
-set bindir [file join [pwd] [file dirname [info nameofexecutable]]]
+set org_pwd [pwd]
+set bindir [file join $org_pwd [file dirname [info nameofexecutable]]]
 set cat32 [file join $bindir cat32.exe]
 
+# several test-cases here expect current directory == [temporaryDirectory]:
+cd [temporaryDirectory]
+
 testConstraint exec         [llength [info commands exec]]
 testConstraint cat32        [file exists $cat32]
 testConstraint AllocConsole [catch {puts console1 ""}]
@@ -608,6 +612,8 @@ if {[info exists path(echoArgs.tcl)]} { removeFile echoArgs.tcl }
 if {[info exists path(echoArgs.bat)]} { removeFile echoArgs.bat }
 if {[info exists path(echoArgs2.bat)]} { removeDirectory test(Dir)Check }
 ::tcltest::cleanupTests
+# back to original directory:
+cd $org_pwd; unset org_pwd
 return
 
 # Local Variables:
diff --git a/win/tclWinTest.c b/win/tclWinTest.c
index b3ad626..b2fe6c0 100644
--- a/win/tclWinTest.c
+++ b/win/tclWinTest.c
@@ -399,9 +399,11 @@ TestplatformChmod(
 {
     static const SECURITY_INFORMATION infoBits = OWNER_SECURITY_INFORMATION
 	    | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION;
+    /* don't deny DELETE mask (reset writable only, allow test-cases cleanup) */
     static const DWORD readOnlyMask = FILE_DELETE_CHILD | FILE_ADD_FILE
 	    | FILE_ADD_SUBDIRECTORY | FILE_WRITE_EA | FILE_APPEND_DATA
-	    | FILE_WRITE_DATA | DELETE;
+	    | FILE_WRITE_DATA
+	    /* | DELETE */;
 
     /*
      * References to security functions (only available on NT and later).
@@ -565,11 +567,13 @@ TestplatformChmod(
     }
 
     /*
-     * Apply the new ACL.
+     * Apply the new ACL. Note PROTECTED_DACL_SECURITY_INFORMATION can be used
+     * 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,
+	    (LPSTR) nativePath, SE_FILE_OBJECT, 
+	    DACL_SECURITY_INFORMATION /*| PROTECTED_DACL_SECURITY_INFORMATION*/,
 	    NULL, NULL, newAcl, NULL) == ERROR_SUCCESS) {
 	res = 0;
     }