Index: generic/tclPathObj.c ================================================================== --- generic/tclPathObj.c +++ generic/tclPathObj.c @@ -27,10 +27,13 @@ static int FindSplitPos(const char *path, int separator); static int IsSeparatorOrNull(int ch); static Tcl_Obj * GetExtension(Tcl_Obj *pathPtr); static int MakePathFromNormalized(Tcl_Interp *interp, Tcl_Obj *pathPtr); +static Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[], + int forceRelative); + /* * Define the 'path' object type, which Tcl uses to represent file paths * internally. */ @@ -819,38 +822,36 @@ * None. * *--------------------------------------------------------------------------- */ -Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[]); - Tcl_Obj * Tcl_FSJoinPath( Tcl_Obj *listObj, /* Path elements to join, may have a zero * reference count. */ int elements) /* Number of elements to use (-1 = all) */ { - Tcl_Obj *copy, *res; + Tcl_Obj *res; int objc; Tcl_Obj **objv; if (Tcl_ListObjLength(NULL, listObj, &objc) != TCL_OK) { return NULL; } 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 * +static 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; /* Resulting path object (container of join) */ Tcl_Obj *elt; /* Path part (result if returns part of path) */ int i; Tcl_Filesystem *fsPtr = NULL; @@ -873,17 +874,18 @@ * * Bugfix [a47641a0]. TclNewFSPathObj requires first argument * to be an absolute path. Added a check for that elt is absolute. */ - if ((i == (elements-2)) && (i == 0) + if ((i == 0) && (elements == 2) && (elt->typePtr == &tclFsPathType) && !((elt->bytes != NULL) && (elt->bytes[0] == '\0')) && TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) { Tcl_Obj *tailObj = objv[i+1]; - - type = TclGetPathType(tailObj, NULL, NULL, NULL); + /* 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; str = Tcl_GetStringFromObj(tailObj, &len); @@ -951,11 +953,13 @@ } } } 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. */ @@ -2411,41 +2415,34 @@ /* * Handle tilde substitutions, if needed. */ - if (name[0] == '~') { + if (len && name[0] == '~') { char *expandedUser; 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) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't find HOME environment " @@ -2459,26 +2456,28 @@ } else { /* * We have a user name '~user' */ + 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_ResetResult(interp); - Tcl_AppendResult(interp, "user \"", name+1, + Tcl_AppendResult(interp, "user \"", expandedUser, "\" doesn't exist", 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); } expandedUser = Tcl_DStringValue(&temp); transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp)); @@ -2512,18 +2511,22 @@ } else { Tcl_Obj *pair[2]; pair[0] = transPtr; pair[1] = Tcl_NewStringObj(name+split+1, -1); - transPtr = TclJoinPath(2, pair); - TclDecrRefCount(pair[0]); - TclDecrRefCount(pair[1]); + transPtr = TclJoinPath(2, pair, 1); + if (transPtr != pair[0]) { + TclDecrRefCount(pair[0]); + } + if (transPtr != pair[1]) { + TclDecrRefCount(pair[1]); + } } } Tcl_DStringFree(&temp); } else { - transPtr = TclJoinPath(1, &pathPtr); + transPtr = TclJoinPath(1, &pathPtr, 1); } /* * Now we have a translated filename in 'transPtr'. This will have forward * slashes on Windows, and will not contain any ~user sequences. Index: tests/cmdAH.test ================================================================== --- tests/cmdAH.test +++ tests/cmdAH.test @@ -539,10 +539,17 @@ } bar 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} testsetplatform { testsetplatform unix Index: tests/winFile.test ================================================================== --- tests/winFile.test +++ tests/winFile.test @@ -58,17 +58,19 @@ catch {glob ~stanton@workgroup} } {0} test winFile-2.1 {TclpMatchFiles: case sensitivity} {win} { makeFile {} GlobCapS - set result [list [glob -nocomplain GlobC*] [glob -nocomplain globc*]] + set args [list -nocomplain -tails -directory [temporaryDirectory]] + set result [list [glob {*}$args GlobC*] [glob {*}$args globc*]] removeFile GlobCapS set result } {GlobCapS GlobCapS} test winFile-2.2 {TclpMatchFiles: case sensitivity} {win} { makeFile {} globlower - set result [list [glob -nocomplain globl*] [glob -nocomplain gLOBl*]] + set args [list -nocomplain -tails -directory [temporaryDirectory]] + set result [list [glob {*}$args globl*] [glob {*}$args gLOBl*]] removeFile globlower set result } {globlower globlower} test winFile-3.1 {file system} {win testvolumetype} { Index: tests/winPipe.test ================================================================== --- tests/winPipe.test +++ tests/winPipe.test @@ -15,12 +15,16 @@ package require tcltest namespace import -force ::tcltest::* unset -nocomplain path -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 testexcept [llength [info commands testexcept]] testConstraint cat32 [file exists $cat32] testConstraint AllocConsole [catch {puts console1 ""}] @@ -598,6 +602,8 @@ # cleanup file delete big little stdout stderr nothing echoArgs.tcl echoArgs.bat file delete -force [file join [temporaryDirectory] test(Dir)Check] ::tcltest::cleanupTests +# back to original directory: +cd $org_pwd; unset org_pwd return Index: win/tclWinTest.c ================================================================== --- win/tclWinTest.c +++ win/tclWinTest.c @@ -418,13 +418,15 @@ typedef BOOL (WINAPI *getFileSecurityADef)(LPCSTR, SECURITY_INFORMATION, PSECURITY_DESCRIPTOR, DWORD, LPDWORD); 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). */ @@ -464,11 +466,14 @@ if (!initialized) { TCL_DECLARE_MUTEX(initializeMutex) Tcl_MutexLock(&initializeMutex); if (!initialized) { - HMODULE handle = GetModuleHandle(TEXT("ADVAPI")); + HMODULE handle = GetModuleHandle(TEXT("ADVAPI32")); + if (handle == NULL) { + handle = GetModuleHandle(TEXT("ADVAPI")); + } if (handle != NULL) { setNamedSecurityInfoProc = (setNamedSecurityInfoADef) GetProcAddress(handle, "SetNamedSecurityInfoA"); getFileSecurityProc = (getFileSecurityADef) @@ -659,15 +664,17 @@ goto done; } } /* - * 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 || setNamedSecurityInfoProc( - (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; } done: