summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorvincentdarley <vincentdarley>2004-09-27 15:00:25 (GMT)
committervincentdarley <vincentdarley>2004-09-27 15:00:25 (GMT)
commit6fcff1d789f4f9d4fb6336668edfaba407b4dddb (patch)
tree4703373dd878abf4d2fcb6ee0fed5febf8af8046
parentb2ddd5afb45d64091bc8d01b2b113523ffd74d45 (diff)
downloadtcl-6fcff1d789f4f9d4fb6336668edfaba407b4dddb.zip
tcl-6fcff1d789f4f9d4fb6336668edfaba407b4dddb.tar.gz
tcl-6fcff1d789f4f9d4fb6336668edfaba407b4dddb.tar.bz2
fix to small filesystem bugs
-rw-r--r--ChangeLog12
-rw-r--r--generic/tclFileName.c8
-rw-r--r--generic/tclFileSystem.h3
-rw-r--r--generic/tclIOUtil.c179
-rw-r--r--generic/tclPathObj.c23
-rw-r--r--tests/cmdAH.test26
-rw-r--r--tests/fileSystem.test2
-rw-r--r--tests/winFCmd.test22
8 files changed, 176 insertions, 99 deletions
diff --git a/ChangeLog b/ChangeLog
index 4debeae..9c1ce3b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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