diff options
| -rw-r--r-- | ChangeLog | 12 | ||||
| -rw-r--r-- | generic/tclFileName.c | 8 | ||||
| -rw-r--r-- | generic/tclFileSystem.h | 3 | ||||
| -rw-r--r-- | generic/tclIOUtil.c | 179 | ||||
| -rw-r--r-- | generic/tclPathObj.c | 23 | ||||
| -rw-r--r-- | tests/cmdAH.test | 26 | ||||
| -rw-r--r-- | tests/fileSystem.test | 2 | ||||
| -rw-r--r-- | tests/winFCmd.test | 22 |
8 files changed, 176 insertions, 99 deletions
@@ -1,3 +1,15 @@ +2004-09-27 Vince Darley <vincentdarley@users.sourceforge.net> + + * generic/tclFileName.c: + * generic/tclFileSystem.h: + * generic/tclIOUtil.c: + * generic/tclPathObj.c: + * tests/cmdAH.test: + * tests/fileSystem.test: + * tests/winFCmd.test: fix to bad error message with 'cd' on + windows, when permissions are inadequate [Bug 1035462] and + to treatment of a volume-relative pwd on Windows [Bug 1018980]. + 2004-09-27 Kevin Kenny <kennykb@acm.org> * compat/strftime.c (Removed): diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 0307ee1..9736096 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFileName.c,v 1.55 2004/05/08 15:51:41 vincentdarley Exp $ + * RCS: @(#) $Id: tclFileName.c,v 1.56 2004/09/27 15:00:26 vincentdarley Exp $ */ #include "tclInt.h" @@ -240,6 +240,12 @@ Tcl_GetPathType(path) * tclIOUtil.c (but needs to be here due to its dependence on * static variables/functions in this file). The exported * function Tcl_FSGetPathType should be used by extensions. + * + * Note that '~' paths are always considered TCL_PATH_ABSOLUTE, + * even though expanding the '~' could lead to any possible + * path type. This function should therefore be considered a + * low-level, string-manipulation function only -- it doesn't + * actually do any expansion in making its determination. * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or diff --git a/generic/tclFileSystem.h b/generic/tclFileSystem.h index d63f7d5..2fe4bd6 100644 --- a/generic/tclFileSystem.h +++ b/generic/tclFileSystem.h @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFileSystem.h,v 1.7 2004/05/07 07:44:37 vincentdarley Exp $ + * RCS: @(#) $Id: tclFileSystem.h,v 1.8 2004/09/27 15:00:39 vincentdarley Exp $ */ /* @@ -98,4 +98,5 @@ Tcl_PathType TclFSNonnativePathType _ANSI_ARGS_((CONST char *pathPtr, Tcl_PathType TclGetPathType _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_Filesystem **filesystemPtrPtr, int *driveNameLengthPtr, Tcl_Obj **driveNameRef)); +int TclFSEpochOk _ANSI_ARGS_((int filesystemEpoch)); Tcl_FSPathInFilesystemProc TclNativePathInFilesystem; diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 18dfc58..1e30134 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -17,7 +17,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOUtil.c,v 1.108 2004/08/31 09:20:09 vincentdarley Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.109 2004/09/27 15:00:39 vincentdarley Exp $ */ #include "tclInt.h" @@ -621,6 +621,25 @@ FsGetFirstFilesystem(void) { return fsRecPtr; } +/* + * The epoch can be changed both by filesystems being added or + * removed and by env(HOME) changing. + */ +int +TclFSEpochOk (filesystemEpoch) + int filesystemEpoch; +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); +#ifndef TCL_THREADS + tsdPtr->filesystemEpoch = theFilesystemEpoch; +#else + Tcl_MutexLock(&filesystemMutex); + tsdPtr->filesystemEpoch = theFilesystemEpoch; + Tcl_MutexUnlock(&filesystemMutex); +#endif + return (filesystemEpoch == tsdPtr->filesystemEpoch); +} + /* * If non-NULL, clientData is owned by us and must be freed later. */ @@ -2635,12 +2654,20 @@ Tcl_FSChdir(pathPtr) if (fsPtr != NULL) { Tcl_FSChdirProc *proc = fsPtr->chdirProc; if (proc != NULL) { + /* + * If this fails, an appropriate errno will have + * been stored using 'Tcl_SetErrno()'. + */ retVal = (*proc)(pathPtr); } else { /* Fallback on stat-based implementation */ Tcl_StatBuf buf; - /* If the file can be stat'ed and is a directory and - * is readable, then we can chdir. */ + /* + * If the file can be stat'ed and is a directory and is + * readable, then we can chdir. If any of these actions + * fail, then 'Tcl_SetErrno()' should automatically have + * been called to set an appropriate error code + */ if ((Tcl_FSStat(pathPtr, &buf) == 0) && (S_ISDIR(buf.st_mode)) && (Tcl_FSAccess(pathPtr, R_OK) == 0)) { @@ -2648,88 +2675,86 @@ Tcl_FSChdir(pathPtr) retVal = 0; } } + } else { + Tcl_SetErrno(ENOENT); } + + /* + * The cwd changed, or an error was thrown. If an error was + * thrown, we can just continue (and that will report the error + * to the user). If there was no error we must assume that the + * cwd was actually changed to the normalized value we + * calculated above, and we must therefore cache that + * information. + */ - if (retVal != -1) { - /* - * The cwd changed, or an error was thrown. If an error was - * thrown, we can just continue (and that will report the error - * to the user). If there was no error we must assume that the - * cwd was actually changed to the normalized value we - * calculated above, and we must therefore cache that - * information. - */ + /* + * If the filesystem in question has a getCwdProc, then the + * correct logic which performs the part below is already part + * of the Tcl_FSGetCwd() call, so no need to replicate it again. + * This will have a side effect though. The private + * authoritative representation of the current working directory + * stored in cwdPathPtr in static memory will be out-of-sync + * with the real OS-maintained value. The first call to + * Tcl_FSGetCwd will however recalculate the private copy to + * match the OS-value so everything will work right. + * + * However, if there is no getCwdProc, then we _must_ update + * our private storage of the cwd, since this is the only + * opportunity to do that! + * + * Note: We currently call this block of code irrespective of + * whether there was a getCwdProc or not, but the code should + * all in principle work if we only call this block if + * fsPtr->getCwdProc == NULL. + */ - /* - * If the filesystem in question has a getCwdProc, then the - * correct logic which performs the part below is already part - * of the Tcl_FSGetCwd() call, so no need to replicate it again. - * This will have a side effect though. The private - * authoritative representation of the current working directory - * stored in cwdPathPtr in static memory will be out-of-sync - * with the real OS-maintained value. The first call to - * Tcl_FSGetCwd will however recalculate the private copy to - * match the OS-value so everything will work right. - * - * However, if there is no getCwdProc, then we _must_ update - * our private storage of the cwd, since this is the only - * opportunity to do that! - * - * Note: We currently call this block of code irrespective of - * whether there was a getCwdProc or not, but the code should - * all in principle work if we only call this block if - * fsPtr->getCwdProc == NULL. + if (retVal == 0) { + /* + * Note that this normalized path may be different to what + * we found above (or at least a different object), if the + * filesystem epoch changed recently. This can actually + * happen with scripted documents very easily. Therefore + * we ask for the normalized path again (the correct value + * will have been cached as a result of the + * Tcl_FSGetFileSystemForPath call above anyway). */ - - if (retVal == 0) { + Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (normDirName == NULL) { + /* Not really true, but what else to do? */ + Tcl_SetErrno(ENOENT); + return -1; + } + if (fsPtr == &tclNativeFilesystem) { /* - * Note that this normalized path may be different to what - * we found above (or at least a different object), if the - * filesystem epoch changed recently. This can actually - * happen with scripted documents very easily. Therefore - * we ask for the normalized path again (the correct value - * will have been cached as a result of the - * Tcl_FSGetFileSystemForPath call above anyway). + * For the native filesystem, we keep a cache of the + * native representation of the cwd. But, we want to do + * that for the exact format that is returned by + * 'getcwd' (so that we can later compare the two + * representations for equality), which might not be + * exactly the same char-string as the native + * representation of the fully normalized path (e.g. on + * Windows there's a forward-slash vs backslash + * difference). Hence we ask for this again here. On + * Unix it might actually be true that we always have + * the correct form in the native rep in which case we + * could simply use: + * + * cd = Tcl_FSGetNativePath(pathPtr); + * + * instead. This should be examined by someone on + * Unix. */ - Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr); - if (normDirName == NULL) { - /* Not really true, but what else to do? */ - Tcl_SetErrno(ENOENT); - return -1; - } - if (fsPtr == &tclNativeFilesystem) { - /* - * For the native filesystem, we keep a cache of the - * native representation of the cwd. But, we want to do - * that for the exact format that is returned by - * 'getcwd' (so that we can later compare the two - * representations for equality), which might not be - * exactly the same char-string as the native - * representation of the fully normalized path (e.g. on - * Windows there's a forward-slash vs backslash - * difference). Hence we ask for this again here. On - * Unix it might actually be true that we always have - * the correct form in the native rep in which case we - * could simply use: - * - * cd = Tcl_FSGetNativePath(pathPtr); - * - * instead. This should be examined by someone on - * Unix. - */ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - ClientData cd; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); + ClientData cd; - /* Assumption we are using a filesystem version 2 */ - TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)fsPtr->getCwdProc; - cd = (*proc2)(tsdPtr->cwdClientData); - FsUpdateCwd(normDirName, TclNativeDupInternalRep(cd)); - } else { - FsUpdateCwd(normDirName, NULL); - } + /* Assumption we are using a filesystem version 2 */ + TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)fsPtr->getCwdProc; + cd = (*proc2)(tsdPtr->cwdClientData); + FsUpdateCwd(normDirName, TclNativeDupInternalRep(cd)); + } else { + FsUpdateCwd(normDirName, NULL); } - } else { - Tcl_SetErrno(ENOENT); } return (retVal); diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index b27b6b5..9ce22e5 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPathObj.c,v 1.33 2004/06/10 16:55:39 dgp Exp $ + * RCS: @(#) $Id: tclPathObj.c,v 1.34 2004/09/27 15:00:40 vincentdarley Exp $ */ #include "tclInt.h" @@ -491,7 +491,8 @@ TclPathPart(interp, pathPtr, portion) { if (pathPtr->typePtr == &tclFsPathType) { FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathPtr); - if (PATHFLAGS(pathPtr) != 0) { + if (TclFSEpochOk(fsPathPtr->filesystemEpoch) + && (PATHFLAGS(pathPtr) != 0)) { switch (portion) { case TCL_PATH_DIRNAME: { /* @@ -999,8 +1000,6 @@ Tcl_FSConvertToPathType(interp, pathPtr) Tcl_Obj *pathPtr; /* Object to convert to a valid, current * path type. */ { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - /* * While it is bad practice to examine an object's type directly, * this is actually the best thing to do here. The reason is that @@ -1012,7 +1011,7 @@ Tcl_FSConvertToPathType(interp, pathPtr) */ if (pathPtr->typePtr == &tclFsPathType) { FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathPtr); - if (fsPathPtr->filesystemEpoch != tsdPtr->filesystemEpoch) { + if (!TclFSEpochOk(fsPathPtr->filesystemEpoch)) { if (pathPtr->bytes == NULL) { UpdateStringOfFsPath(pathPtr); } @@ -1691,7 +1690,16 @@ Tcl_FSGetNormalizedPath(interp, pathPtr) * action, which might loop back through here. */ if (path[0] != '\0') { - Tcl_PathType type = Tcl_FSGetPathType(pathPtr); + Tcl_PathType type; + /* + * We don't ask for the type of 'pathPtr' here, because + * that is not correct for our purposes when we have a + * path like '~'. Tcl has a bit of a contradiction in + * that '~' paths are defined as 'absolute', but in + * reality can be just about anything, depending on + * how env(HOME) is set. + */ + type = Tcl_FSGetPathType(absolutePath); if (type == TCL_PATH_RELATIVE) { useThisCwd = Tcl_FSGetCwd(interp); @@ -1941,7 +1949,6 @@ TclFSEnsureEpochOk(pathPtr, fsPtrPtr) Tcl_Filesystem **fsPtrPtr; { FsPath* srcFsPathPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); if (pathPtr->typePtr != &tclFsPathType) { return TCL_OK; @@ -1953,7 +1960,7 @@ TclFSEnsureEpochOk(pathPtr, fsPtrPtr) * Check if the filesystem has changed in some way since * this object's internal representation was calculated. */ - if (srcFsPathPtr->filesystemEpoch != tsdPtr->filesystemEpoch) { + if (!TclFSEpochOk(srcFsPathPtr->filesystemEpoch)) { /* * We have to discard the stale representation and * recalculate it diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 06ad91a..2ecb291 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdAH.test,v 1.43 2004/06/23 15:46:45 dkf Exp $ +# RCS: @(#) $Id: cmdAH.test,v 1.44 2004/09/27 15:00:40 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -358,15 +358,21 @@ test cmdAH-8.44 {Tcl_FileObjCmd: dirname} testsetplatform { set env(HOME) $temp set result } {0 ~} -test cmdAH-8.45 {Tcl_FileObjCmd: dirname} testsetplatform { - global env - set temp $env(HOME) - set env(HOME) "/homewontexist/test" - testsetplatform windows - set result [list [catch {file dirname ~} msg] $msg] - set env(HOME) $temp - set result -} {0 /homewontexist} +test cmdAH-8.45 {Tcl_FileObjCmd: dirname} { + -constraints {Tcltest testsetplatform} + -match regexp + -body { + global env + set temp $env(HOME) + set env(HOME) "/homewontexist/test" + testsetplatform windows + set result [list [catch {file dirname ~} msg] $msg] + set env(HOME) $temp + set result + } + -result {{0 ([a-zA-Z]:?)/homewontexist}} +} + test cmdAH-8.46 {Tcl_FileObjCmd: dirname} { set f [file normalize [info nameof]] file exists $f diff --git a/tests/fileSystem.test b/tests/fileSystem.test index fd4918a..a56e56d 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -539,7 +539,7 @@ test filesystem-5.1 {cache and ~} { set ::env(HOME) $orig list $res1 $res2 } - -result {{Parent of ~ \(/foo/bar/blah\) is (/foo/bar|foo:bar)} {Parent of ~ \(/a/b/c\) is (/a/b|a:b)}} + -result {{Parent of ~ \(/foo/bar/blah\) is ([a-zA-Z]:)?(/foo/bar|foo:bar)} {Parent of ~ \(/a/b/c\) is ([a-zA-Z]:)?(/a/b|a:b)}} } test filesystem-6.1 {empty file name} { diff --git a/tests/winFCmd.test b/tests/winFCmd.test index dc0edd9..891925e 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winFCmd.test,v 1.33 2004/06/23 21:32:03 patthoyts Exp $ +# RCS: @(#) $Id: winFCmd.test,v 1.34 2004/09/27 15:00:42 vincentdarley Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -1044,6 +1044,26 @@ test winFCmd-16.12 {Windows file normalization} -constraints win -setup { cd $oldwd } -result ok +test winFCmd-16.13 {Windows bad permissions cd} -constraints win -setup { + set oldwd [pwd] +} -body { + set d {} + foreach dd {c:/ d:/ e:/} { + eval lappend d [glob -nocomplain \ + -types hidden -dir $dd "System Volume Information"] + } + # Old versions of Tcl gave a misleading error that the + # directory in question didn't exist. + if {[llength $d] && [catch {cd [lindex $d 0]} err]} { + regsub ".*: " $err "" err + set err + } else { + set err "permission denied" + } +} -cleanup { + cd $oldwd +} -result "permission denied" + cd $pwd unset d dd pwd |