fix to small filesystem bugs

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