? permfix.patch
? win/dir.file
? win/gorp.file
? win/touch.me
Index: doc/file.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/file.n,v
retrieving revision 1.28
diff -u -r1.28 file.n
--- doc/file.n	26 Jan 2004 13:33:59 -0000	1.28
+++ doc/file.n	28 Jan 2004 18:11:50 -0000
@@ -103,11 +103,13 @@
 \fItargetDir\fR of each \fIsource\fR file listed.  If a directory is
 specified as a \fIsource\fR, then the contents of the directory will be
 recursively copied into \fItargetDir\fR. Existing files will not be
-overwritten unless the \fB\-force\fR option is specified.  When copying
+overwritten unless the \fB\-force\fR option is specified (when Tcl will
+also attempt to adjust permissions on the destination file or directory
+if that is necessary to allow the copy to proceed).  When copying
 within a single filesystem, \fIfile copy\fR will copy soft links (i.e.
 the links themselves are copied, not the things they point to).  Trying
 to overwrite a non-empty directory, overwrite a directory with a file,
-or a file with a directory will all result in errors even if
+or overwrite a file with a directory will all result in errors even if
 \fI\-force\fR was specified.  Arguments are processed in the order
 specified, halting at the first error, if any.  A \fB\-\|\-\fR marks
 the end of switches; the argument following the \fB\-\|\-\fR will be
Index: generic/tclFCmd.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclFCmd.c,v
retrieving revision 1.23
diff -u -r1.23 tclFCmd.c
--- generic/tclFCmd.c	21 Jan 2004 19:59:33 -0000	1.23
+++ generic/tclFCmd.c	28 Jan 2004 18:11:50 -0000
@@ -525,6 +525,22 @@
 		    Tcl_GetString(source), "\"", (char *) NULL);
 	    goto done;
 	}
+	
+	/* 
+	 * The destination exists, but appears to be ok to over-write,
+	 * and -force is given.  We now try to adjust permissions to
+	 * ensure the operation succeeds.  If we can't adjust
+	 * permissions, we'll let the actual copy/rename return
+	 * an error later.
+	 */
+#if !defined(__WIN32__) && !defined(MAC_TCL)
+	{
+	Tcl_Obj* perm = Tcl_NewStringObj("u+w",-1);
+	Tcl_IncrRefCount(perm);
+	Tcl_FSFileAttrsSet(NULL, 2, target, perm);
+	Tcl_DecrRefCount(perm);
+	}
+#endif
     }
 
     if (copyFlag == 0) {
Index: generic/tclIOUtil.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclIOUtil.c,v
retrieving revision 1.94
diff -u -r1.94 tclIOUtil.c
--- generic/tclIOUtil.c	23 Jan 2004 11:03:33 -0000	1.94
+++ generic/tclIOUtil.c	28 Jan 2004 18:11:50 -0000
@@ -999,6 +999,17 @@
 				 * flag is very important. */
 {
     Tcl_Filesystem *fsPtr;
+    
+    if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) {
+	/* 
+	 * We don't currently allow querying of mounts by external code
+	 * (a valuable future step), so since we're the only function
+	 * that actually knows about mounts, this means we're being
+	 * called recursively by ourself.  Return no matches.
+	 */
+	return TCL_OK;
+    }
+    
     if (pathPtr != NULL) {
         fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
     } else {
@@ -3261,10 +3272,11 @@
     Tcl_Obj *resultPtr = NULL;
     
     /*
-     * Call each of the "listMounts" functions in succession.
-     * A non-NULL return value indicates the particular function has
-     * succeeded.  We call all the functions registered, since we want
-     * a list from each filesystems.
+     * Call each of the "matchInDirectory" functions in succession, with
+     * the specific type information 'mountsOnly'.  A non-NULL return
+     * value indicates the particular function has succeeded.  We call
+     * all the functions registered, since we want a list from each
+     * filesystems.
      */
 
     fsRecPtr = FsGetFirstFilesystem();
Index: generic/tclTest.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclTest.c,v
retrieving revision 1.75
diff -u -r1.75 tclTest.c
--- generic/tclTest.c	21 Jan 2004 19:59:33 -0000	1.75
+++ generic/tclTest.c	28 Jan 2004 18:11:51 -0000
@@ -422,7 +422,11 @@
 static Tcl_Obj*         SimpleListVolumes _ANSI_ARGS_ ((void));
 static int              SimplePathInFilesystem _ANSI_ARGS_ ((
 			    Tcl_Obj *pathPtr, ClientData *clientDataPtr));
-static Tcl_Obj*         SimpleCopy _ANSI_ARGS_ ((Tcl_Obj *pathPtr));
+static Tcl_Obj*         SimpleRedirect _ANSI_ARGS_ ((Tcl_Obj *pathPtr));
+static int		SimpleMatchInDirectory _ANSI_ARGS_ ((
+			    Tcl_Interp *interp, Tcl_Obj *resultPtr,
+			    Tcl_Obj *dirPtr, CONST char *pattern,
+			    Tcl_GlobTypeData *types));
 static int              TestNumUtfCharsCmd _ANSI_ARGS_((ClientData clientData,
                             Tcl_Interp *interp, int objc,
 			    Tcl_Obj *CONST objv[]));
@@ -485,7 +489,7 @@
     &SimpleStat,
     &SimpleAccess,
     &SimpleOpenFileChannel,
-    NULL,
+    &SimpleMatchInDirectory,
     NULL,
     /* We choose not to support symbolic links inside our vfs's */
     NULL,
@@ -6320,34 +6324,22 @@
 }
 
 /* 
- * Since TclCopyChannel insists on an interpreter, we use this
- * to simplify our test scripts.  Would be better if it could
- * copy without an interp
- */
-static Tcl_Interp *simpleInterpPtr = NULL;
-/* We use this to ensure we clean up after ourselves */
-static Tcl_Obj *tempFile = NULL;
-
-/* 
- * This is a very 'hacky' filesystem which is used just to 
- * test two important features of the vfs code: (1) that
- * you can load a shared library from a vfs, (2) that when
- * copying files from one fs to another, the 'mtime' is
- * preserved.
+ * This is a slightly 'hacky' filesystem which is used just to test a
+ * few important features of the vfs code: (1) that you can load a
+ * shared library from a vfs, (2) that when copying files from one fs to
+ * another, the 'mtime' is preserved.  (3) that recursive
+ * cross-filesystem directory copies have the correct behaviour
+ * with/without -force.
  * 
- * It treats any file in 'simplefs:/' as a file, and
- * artificially creates a real file on the fly which it uses
- * to extract information from.  The real file it uses is
+ * It treats any file in 'simplefs:/' as a file, which it
+ * routes to the current directory.  The real file it uses is
  * whatever follows the trailing '/' (e.g. 'foo' in 'simplefs:/foo'),
- * and that file is assumed to exist in the native pwd, and is
- * copied over to the native temporary directory where it is
- * accessed.
+ * and that file exists or not according to what is in the native
+ * pwd.
  * 
  * Please do not consider this filesystem a model of how
  * things are to be done.  It is quite the opposite!  But, it
- * does allow us to test two important features.
- * 
- * Finally: this fs can only be used from one interpreter.
+ * does allow us to test some important features.
  */
 static int
 TestSimpleFilesystemObjCmd(dummy, interp, objc, objv)
@@ -6369,54 +6361,81 @@
     if (boolVal) {
 	res = Tcl_FSRegister((ClientData)interp, &simpleFilesystem);
 	msg = (res == TCL_OK) ? "registered" : "failed";
-	simpleInterpPtr = interp;
     } else {
-	if (tempFile != NULL) {
-	    Tcl_FSDeleteFile(tempFile);
-	    Tcl_DecrRefCount(tempFile);
-	    tempFile = NULL;
-	}
 	res = Tcl_FSUnregister(&simpleFilesystem);
 	msg = (res == TCL_OK) ? "unregistered" : "failed";
-	simpleInterpPtr = NULL;
     }
     Tcl_SetResult(interp, msg, TCL_VOLATILE);
     return res;
 }
 
 /* 
- * Treats a file name 'simplefs:/foo' by copying the file 'foo'
- * in the current (native) directory to a temporary native file,
- * and then returns that native file.
+ * Treats a file name 'simplefs:/foo' by using the file 'foo'
+ * in the current (native) directory.
  */
 static Tcl_Obj*
-SimpleCopy(pathPtr)
+SimpleRedirect(pathPtr)
     Tcl_Obj *pathPtr;                   /* Name of file to copy. */
 {
-    int res;
+    int len;
     CONST char *str;
     Tcl_Obj *origPtr;
-    Tcl_Obj *tempPtr;
-
-    tempPtr = TclpTempFileName();
-    Tcl_IncrRefCount(tempPtr);
 
     /* 
      * We assume the same name in the current directory is ok.
      */
-    str = Tcl_GetString(pathPtr);
+    str = Tcl_GetStringFromObj(pathPtr, &len);
+    if (len < 10 || strncmp(str, "simplefs:/", 10)) {
+	/* Probably shouldn't ever reach here */
+	Tcl_IncrRefCount(pathPtr);
+	return pathPtr;
+    } 
     origPtr = Tcl_NewStringObj(str+10,-1);
     Tcl_IncrRefCount(origPtr);
+    return origPtr;
+}
 
-    res = TclCrossFilesystemCopy(simpleInterpPtr, origPtr, tempPtr);
-    Tcl_DecrRefCount(origPtr);
+static int
+SimpleMatchInDirectory(interp, resultPtr, dirPtr, pattern, types)
+    Tcl_Interp *interp;		/* Interpreter for error
+				 * messages. */
+    Tcl_Obj *resultPtr;		/* Object to lappend results. */
+    Tcl_Obj *dirPtr;	        /* Contains path to directory to search. */
+    CONST char *pattern;	/* Pattern to match against. */
+    Tcl_GlobTypeData *types;	/* Object containing list of acceptable types.
+				 * May be NULL. */
+{
+    int res;
+    Tcl_Obj *origPtr;
+    Tcl_Obj *resPtr;
 
-    if (res != TCL_OK) {
-	Tcl_FSDeleteFile(tempPtr);
-	Tcl_DecrRefCount(tempPtr);
-	return NULL;
+    /* We only provide a new volume, therefore no mounts at all */
+    if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) {
+	return TCL_OK;
     }
-    return tempPtr;
+    
+    /* 
+     * We assume the same name in the current directory is ok.
+     */
+    resPtr = Tcl_NewObj();
+    Tcl_IncrRefCount(resPtr);
+    origPtr = SimpleRedirect(dirPtr);
+    Tcl_IncrRefCount(origPtr);
+    res = Tcl_FSMatchInDirectory(interp, resPtr, origPtr, pattern, types);
+    if (res == TCL_OK) {
+	int gLength, j;
+	Tcl_ListObjLength(NULL, resPtr, &gLength);
+	for (j = 0; j < gLength; j++) {
+	    Tcl_Obj *gElt, *nElt;
+	    Tcl_ListObjIndex(NULL, resPtr, j, &gElt);
+	    nElt = Tcl_NewStringObj("simplefs:/",10);
+	    Tcl_AppendObjToObj(nElt, gElt);
+	    Tcl_ListObjAppendElement(NULL, resultPtr, nElt);
+	}
+    }
+    Tcl_DecrRefCount(origPtr);
+    Tcl_DecrRefCount(resPtr);
+    return res;
 }
 
 static Tcl_Channel
@@ -6438,24 +6457,11 @@
 	return NULL;
     }
     
-    tempPtr = SimpleCopy(pathPtr);
-    
-    if (tempPtr == NULL) {
-	return NULL;
-    }
+    tempPtr = SimpleRedirect(pathPtr);
     
     chan = Tcl_FSOpenFileChannel(interp, tempPtr, "r", permissions);
 
-    if (tempFile != NULL) {
-        Tcl_FSDeleteFile(tempFile);
-	Tcl_DecrRefCount(tempFile);
-	tempFile = NULL;
-    }
-    /* 
-     * Store file pointer in this global variable so we can delete
-     * it later 
-     */
-    tempFile = tempPtr;
+    Tcl_DecrRefCount(tempPtr);
     return chan;
 }
 
@@ -6464,8 +6470,11 @@
     Tcl_Obj *pathPtr;		/* Path of file to access (in current CP). */
     int mode;                   /* Permission setting. */
 {
-    /* All files exist */
-    return TCL_OK;
+    int res;
+    Tcl_Obj *tempPtr = SimpleRedirect(pathPtr);
+    res = Tcl_FSAccess(tempPtr, mode);
+    Tcl_DecrRefCount(tempPtr);
+    return res;
 }
 
 static int
@@ -6473,16 +6482,11 @@
     Tcl_Obj *pathPtr;		/* Path of file to stat (in current CP). */
     Tcl_StatBuf *bufPtr;	/* Filled with results of stat call. */
 {
-    Tcl_Obj *tempPtr = SimpleCopy(pathPtr);
-    if (tempPtr == NULL) {
-	/* We just pretend the file exists anyway */
-	return TCL_OK;
-    } else {
-	int res = Tcl_FSStat(tempPtr, bufPtr);
-	Tcl_FSDeleteFile(tempPtr);
-	Tcl_DecrRefCount(tempPtr);
-	return res;
-    }
+    int res;
+    Tcl_Obj *tempPtr = SimpleRedirect(pathPtr);
+    res = Tcl_FSStat(tempPtr, bufPtr);
+    Tcl_DecrRefCount(tempPtr);
+    return res;
 }
 
 static Tcl_Obj*
Index: library/init.tcl
===================================================================
RCS file: /cvsroot/tcl/tcl/library/init.tcl,v
retrieving revision 1.58
diff -u -r1.58 init.tcl
--- library/init.tcl	14 Oct 2003 15:44:53 -0000	1.58
+++ library/init.tcl	28 Jan 2004 18:11:51 -0000
@@ -668,6 +668,7 @@
 proc tcl::CopyDirectory {action src dest} {
     set nsrc [file normalize $src]
     set ndest [file normalize $dest]
+
     if {[string equal $action "renaming"]} {
 	# Can't rename volumes.  We could give a more precise
 	# error message here, but that would break the test suite.
@@ -684,8 +685,14 @@
 	      into itself"
 	}
 	if {[string equal $action "copying"]} {
-	    return -code error "error $action \"$src\" to\
-	      \"$dest\": file already exists"
+	    # We used to throw an error here, but, looking more closely
+	    # at the core copy code in tclFCmd.c, if the destination
+	    # exists, then we should only call this function if -force
+	    # is true, which means we just want to over-write.  So,
+	    # the following code is now commented out.
+	    # 
+	    # return -code error "error $action \"$src\" to\
+	    # \"$dest\": file already exists"
 	} else {
 	    # Depending on the platform, and on the current
 	    # working directory, the directories '.', '..'
@@ -721,10 +728,10 @@
     # or filesystems hidden files may have other interpretations.
     set filelist [concat [glob -nocomplain -directory $src *] \
       [glob -nocomplain -directory $src -types hidden *]]
-    
+
     foreach s [lsort -unique $filelist] {
 	if {([file tail $s] != ".") && ([file tail $s] != "..")} {
-	    file copy $s [file join $dest [file tail $s]]
+	    file copy -force $s [file join $dest [file tail $s]]
 	}
     }
     return
Index: mac/tclMacFile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/mac/tclMacFile.c,v
retrieving revision 1.29
diff -u -r1.29 tclMacFile.c
--- mac/tclMacFile.c	21 Jan 2004 19:59:33 -0000	1.29
+++ mac/tclMacFile.c	28 Jan 2004 18:11:51 -0000
@@ -156,6 +156,11 @@
     OSType okCreator = 0;
     Tcl_Obj *fileNamePtr;
 
+    if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) {
+	/* The native filesystem never adds mounts */
+	return TCL_OK;
+    }
+
     fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
     if (fileNamePtr == NULL) {
 	return TCL_ERROR;
Index: tests/fileSystem.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/fileSystem.test,v
retrieving revision 1.31
diff -u -r1.31 fileSystem.test
--- tests/fileSystem.test	23 Jan 2004 11:05:38 -0000	1.31
+++ tests/fileSystem.test	28 Jan 2004 18:11:52 -0000
@@ -613,15 +613,89 @@
     cd [tcltest::temporaryDirectory]
     # We created this file several tests ago.
     set origtime [file mtime gorp.file]
+    set res [file exists gorp.file]
+    if {[catch {
+	testsimplefilesystem 1
+	file delete -force theCopy
+	file copy simplefs:/gorp.file theCopy
+	testsimplefilesystem 0
+	set newtime [file mtime theCopy]
+	file delete theCopy
+    } err]} {
+	lappend res $err
+	set newtime ""
+    }
+    cd $dir
+    lappend res [expr {$origtime == $newtime}]
+} {1 1}
+
+test filesystem-7.3 {glob in simplefs} \
+  {testsimplefilesystem} {
+    set dir [pwd]
+    cd [tcltest::temporaryDirectory]
+    file mkdir simpledir
+    close [open [file join simpledir simplefile] w]
     testsimplefilesystem 1
-    file delete -force theCopy
-    file copy simplefs:/gorp.file theCopy
+    set res [glob -nocomplain -dir simplefs:/simpledir *]
     testsimplefilesystem 0
-    set newtime [file mtime theCopy]
-    file delete theCopy
+    file delete -force simpledir
     cd $dir
-    expr {$origtime == $newtime}
-} {1}
+    set res
+} {simplefs:/simpledir/simplefile}
+
+test filesystem-7.4 {cross-filesystem file copy with -force} \
+  {testsimplefilesystem} {
+    set dir [pwd]
+    cd [tcltest::temporaryDirectory]
+    set fout [open [file join simplefile] w]
+    puts -nonewline $fout "1234567890"
+    close $fout
+    testsimplefilesystem 1
+    # First copy should succeed
+    set res [catch {file copy simplefs:/simplefile file2} err]
+    lappend res $err
+    # Second copy should fail (no -force)
+    lappend res [catch {file copy simplefs:/simplefile file2} err]
+    lappend res $err
+    # Third copy should succeed (-force)
+    lappend res [catch {file copy -force simplefs:/simplefile file2} err]
+    lappend res $err
+    lappend res [file exists file2]
+    testsimplefilesystem 0
+    file delete -force simplefile
+    file delete -force file2
+    cd $dir
+    set res
+} {0 10 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 10 1}
+
+test filesystem-7.5 {cross-filesystem dir copy with -force} \
+  {testsimplefilesystem} {
+    set dir [pwd]
+    cd [tcltest::temporaryDirectory]
+    file delete -force simpledir
+    file mkdir simpledir
+    file mkdir dir2
+    set fout [open [file join simpledir simplefile] w]
+    puts -nonewline $fout "1234567890"
+    close $fout
+    testsimplefilesystem 1
+    # First copy should succeed
+    set res [catch {file copy simplefs:/simpledir dir2} err]
+    lappend res $err
+    # Second copy should fail (no -force)
+    lappend res [catch {file copy simplefs:/simpledir dir2} err]
+    lappend res $err
+    # Third copy should succeed (-force)
+    lappend res [catch {file copy -force simplefs:/simpledir dir2} err]
+    lappend res $err
+    lappend res [file exists [file join dir2 simpledir]] \
+      [file exists [file join dir2 simpledir simplefile]]
+    testsimplefilesystem 0
+    file delete -force simpledir
+    file delete -force dir2
+    cd $dir
+    set res
+} {0 {} 1 {error copying "simplefs:/simpledir" to "dir2/simpledir": file already exists} 0 {} 1 1}
 
 removeFile gorp.file
 
Index: unix/tclUnixFCmd.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclUnixFCmd.c,v
retrieving revision 1.33
diff -u -r1.33 tclUnixFCmd.c
--- unix/tclUnixFCmd.c	18 Nov 2003 23:13:34 -0000	1.33
+++ unix/tclUnixFCmd.c	28 Jan 2004 18:11:52 -0000
@@ -110,6 +110,10 @@
 
 /*
  * Constants and variables necessary for file attributes subcommand.
+ * 
+ * IMPORTANT: The permissions attribute is assumed to be the third
+ * item (i.e. to be indexed with '2' in arrays) in code in tclIOUtil.c
+ * and possibly elsewhere in Tcl's core.
  */
 
 enum {
Index: unix/tclUnixFile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclUnixFile.c,v
retrieving revision 1.37
diff -u -r1.37 tclUnixFile.c
--- unix/tclUnixFile.c	21 Jan 2004 19:59:34 -0000	1.37
+++ unix/tclUnixFile.c	28 Jan 2004 18:11:52 -0000
@@ -210,6 +210,11 @@
     CONST char *native;
     Tcl_Obj *fileNamePtr;
 
+    if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) {
+	/* The native filesystem never adds mounts */
+	return TCL_OK;
+    }
+
     fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
     if (fileNamePtr == NULL) {
 	return TCL_ERROR;
Index: win/tclWinFile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/win/tclWinFile.c,v
retrieving revision 1.60
diff -u -r1.60 tclWinFile.c
--- win/tclWinFile.c	23 Jan 2004 11:06:00 -0000	1.60
+++ win/tclWinFile.c	28 Jan 2004 18:11:53 -0000
@@ -743,6 +743,11 @@
 {
     CONST TCHAR *native;
 
+    if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) {
+	/* The native filesystem never adds mounts */
+	return TCL_OK;
+    }
+
     if (pattern == NULL || (*pattern == '\0')) {
 	Tcl_Obj *norm = Tcl_FSGetNormalizedPath(NULL, pathPtr);
 	if (norm != NULL) {
