From f5c319ed1e839e9256fcad85b69c4fde1d5d7c97 Mon Sep 17 00:00:00 2001
From: vincentdarley <vincentdarley>
Date: Thu, 29 Jan 2004 10:28:18 +0000
Subject: filesystem fixes for '-force' consistency and picky compilers
---
ChangeLog | 24 ++++++++
doc/file.n | 8 ++-
generic/tclFCmd.c | 18 +++++-
generic/tclIOUtil.c | 22 +++++--
generic/tclPathObj.c | 8 ++-
generic/tclTest.c | 158 ++++++++++++++++++++++++++------------------------
library/init.tcl | 17 ++++--
mac/tclMacFile.c | 7 ++-
tests/fileSystem.test | 142 +++++++++++++++++++++++++++++++++++++++++++--
unix/tclUnixFCmd.c | 6 +-
unix/tclUnixFile.c | 7 ++-
win/tclWinFile.c | 7 ++-
12 files changed, 322 insertions(+), 102 deletions(-)
diff --git a/ChangeLog b/ChangeLog
index b487027..7d3e573 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,27 @@
+2004-01-29 Vince Darley <vincentdarley@users.sourceforge.net>
+
+ * doc/file.n:
+ * generic/tclFCmd.c
+ * generic/tclTest.c
+ * library/init.tcl
+ * mac/tclMacFile.c
+ * tests/fileSystem.test: fix to [Bug 886352] where 'file copy
+ -force' had inconsistent behaviour wrt target files with
+ insufficient permissions, particular from vfs->native fs.
+ Behaviour of '-force' is now always consistent (and now
+ consistent with behaviour of 'file delete -force'). Added new
+ tests and documentation and cleaned up the 'simplefs' test
+ filesystem.
+
+ * generic/tclIOUtil.c
+ * unix/tclUnixFCmd.c
+ * unix/tclUnixFile.c
+ * win/tclWinFile.c: made native filesystems more robust to C code
+ which asks for mount lists.
+
+ * generic/tclPathObj.c: fix to [Bug 886607] removing warning/error
+ with some compilers.
+
2004-01-28 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclObj.c (SetBooleanFromAny): Rewrite to do more
diff --git a/doc/file.n b/doc/file.n
index c6ac014..80294b2 100644
--- a/doc/file.n
+++ b/doc/file.n
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: file.n,v 1.28 2004/01/26 13:33:59 vincentdarley Exp $
+'\" RCS: @(#) $Id: file.n,v 1.29 2004/01/29 10:28:20 vincentdarley Exp $
'\"
.so man.macros
.TH file n 8.3 Tcl "Tcl Built-In Commands"
@@ -103,11 +103,13 @@ then the second form is used. The second form makes a copy inside
\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
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index 3d78f4c..8cfcdf7 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -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: tclFCmd.c,v 1.23 2004/01/21 19:59:33 vincentdarley Exp $
+ * RCS: @(#) $Id: tclFCmd.c,v 1.24 2004/01/29 10:28:20 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -525,6 +525,22 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
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) {
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index b06885c..6e15ab7 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.94 2004/01/23 11:03:33 vincentdarley Exp $
+ * RCS: @(#) $Id: tclIOUtil.c,v 1.95 2004/01/29 10:28:20 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -999,6 +999,17 @@ Tcl_FSMatchInDirectory(interp, result, pathPtr, pattern, types)
* 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 @@ FsListMounts(pathPtr, pattern)
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();
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index 42dfaa3..5be3447 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.21 2004/01/23 11:04:11 vincentdarley Exp $
+ * RCS: @(#) $Id: tclPathObj.c,v 1.22 2004/01/29 10:28:20 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -513,6 +513,12 @@ TclPathPart(interp, pathPtr, portion)
return root;
}
}
+ default: {
+ /* We should never get here */
+ Tcl_Panic("Bad portion to TclPathPart");
+ /* For less clever compilers */
+ return NULL;
+ }
}
} else if (fsPathPtr->cwdPtr != NULL) {
/* Relative path */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 7c9361d..7709bb9 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTest.c,v 1.75 2004/01/21 19:59:33 vincentdarley Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.76 2004/01/29 10:28:20 vincentdarley Exp $
*/
#define TCL_TEST
@@ -422,7 +422,11 @@ static Tcl_Channel SimpleOpenFileChannel _ANSI_ARGS_ ((
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 @@ static Tcl_Filesystem simpleFilesystem = {
&SimpleStat,
&SimpleAccess,
&SimpleOpenFileChannel,
- NULL,
+ &SimpleMatchInDirectory,
NULL,
/* We choose not to support symbolic links inside our vfs's */
NULL,
@@ -6320,34 +6324,22 @@ SimplePathInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr) {
}
/*
- * 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 @@ TestSimpleFilesystemObjCmd(dummy, interp, objc, objv)
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 @@ SimpleOpenFileChannel(interp, pathPtr, mode, permissions)
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 @@ SimpleAccess(pathPtr, mode)
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 @@ SimpleStat(pathPtr, bufPtr)
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*
diff --git a/library/init.tcl b/library/init.tcl
index 5f69a88..ff3a245 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -3,7 +3,7 @@
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
-# RCS: @(#) $Id: init.tcl,v 1.58 2003/10/14 15:44:53 dgp Exp $
+# RCS: @(#) $Id: init.tcl,v 1.59 2004/01/29 10:28:21 vincentdarley Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -668,6 +668,7 @@ proc auto_execok name {
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 @@ proc tcl::CopyDirectory {action src dest} {
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 @@ proc tcl::CopyDirectory {action src dest} {
# 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
diff --git a/mac/tclMacFile.c b/mac/tclMacFile.c
index 1c1279d..de5f422 100644
--- a/mac/tclMacFile.c
+++ b/mac/tclMacFile.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: tclMacFile.c,v 1.29 2004/01/21 19:59:33 vincentdarley Exp $
+ * RCS: @(#) $Id: tclMacFile.c,v 1.30 2004/01/29 10:28:22 vincentdarley Exp $
*/
/*
@@ -156,6 +156,11 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
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;
diff --git a/tests/fileSystem.test b/tests/fileSystem.test
index 112e665..a311c90 100644
--- a/tests/fileSystem.test
+++ b/tests/fileSystem.test
@@ -613,15 +613,145 @@ test filesystem-7.2 {cross-filesystem copy from vfs maintains mtime} \
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 file copy with -force} \
+ {testsimplefilesystem unixOnly} {
+ 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
+ file attributes file2 -permissions 0000
+ # 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.6 {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}
+
+test filesystem-7.7 {cross-filesystem dir copy with -force} \
+ {testsimplefilesystem unixOnly} {
+ 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
+ file attributes file2 -permissions 0000
+ # 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
diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c
index dfbc9d3..fede131 100644
--- a/unix/tclUnixFCmd.c
+++ b/unix/tclUnixFCmd.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: tclUnixFCmd.c,v 1.33 2003/11/18 23:13:34 davygrvy Exp $
+ * RCS: @(#) $Id: tclUnixFCmd.c,v 1.34 2004/01/29 10:28:23 vincentdarley Exp $
*
* Portions of this code were derived from NetBSD source code which has
* the following copyright notice:
@@ -110,6 +110,10 @@ typedef int (TraversalProc) _ANSI_ARGS_((Tcl_DString *srcPtr,
/*
* 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 {
diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c
index 23837a0..76ffc32 100644
--- a/unix/tclUnixFile.c
+++ b/unix/tclUnixFile.c
@@ -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: tclUnixFile.c,v 1.37 2004/01/21 19:59:34 vincentdarley Exp $
+ * RCS: @(#) $Id: tclUnixFile.c,v 1.38 2004/01/29 10:28:23 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -210,6 +210,11 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
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;
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index 6a4ddff..30d08fa 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclWinFile.c,v 1.60 2004/01/23 11:06:00 vincentdarley Exp $
+ * RCS: @(#) $Id: tclWinFile.c,v 1.61 2004/01/29 10:28:23 vincentdarley Exp $
*/
//#define _WIN32_WINNT 0x0500
@@ -743,6 +743,11 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
{
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) {
--
cgit v0.12