diff options
| -rw-r--r-- | ChangeLog | 24 | ||||
| -rw-r--r-- | doc/file.n | 8 | ||||
| -rw-r--r-- | generic/tclFCmd.c | 18 | ||||
| -rw-r--r-- | generic/tclIOUtil.c | 22 | ||||
| -rw-r--r-- | generic/tclPathObj.c | 8 | ||||
| -rw-r--r-- | generic/tclTest.c | 158 | ||||
| -rw-r--r-- | library/init.tcl | 17 | ||||
| -rw-r--r-- | mac/tclMacFile.c | 7 | ||||
| -rw-r--r-- | tests/fileSystem.test | 142 | ||||
| -rw-r--r-- | unix/tclUnixFCmd.c | 6 | ||||
| -rw-r--r-- | unix/tclUnixFile.c | 7 | ||||
| -rw-r--r-- | win/tclWinFile.c | 7 |
12 files changed, 322 insertions, 102 deletions
@@ -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 @@ -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) { |