summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorvincentdarley <vincentdarley>2004-05-07 07:44:35 (GMT)
committervincentdarley <vincentdarley>2004-05-07 07:44:35 (GMT)
commit8c5df5fda90a29c593793d69237f1f8cceb0e4c0 (patch)
tree15cbaaef673cb04fd761bfd3522c629aa2dc347b
parentfcc10d4dd68b2d659c7554f1d07781320a75a74b (diff)
downloadtcl-8c5df5fda90a29c593793d69237f1f8cceb0e4c0.zip
tcl-8c5df5fda90a29c593793d69237f1f8cceb0e4c0.tar.gz
tcl-8c5df5fda90a29c593793d69237f1f8cceb0e4c0.tar.bz2
vfs glob root volume fix
-rw-r--r--ChangeLog9
-rw-r--r--generic/tclFileName.c21
-rw-r--r--generic/tclFileSystem.h8
-rw-r--r--generic/tclIOUtil.c71
-rw-r--r--tests/fileSystem.test51
5 files changed, 145 insertions, 15 deletions
diff --git a/ChangeLog b/ChangeLog
index 137651f..d51d6de 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2004-05-07 Vince Darley <vincentdarley@users.sourceforge.net>
+
+ * generic/tclFileName.c:
+ * generic/tclIOUtil.c:
+ * generic/tclFileSystem.h:
+ * tests/fileSystem.test: fix for [Bug 943995], in which vfs-
+ registered root volumes were not handled correctly as glob
+ patterns in all circumstances.
+
2004-05-06 Miguel Sofer <msofer@users.sf.net>
* generic/tclInt.h:
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index 33f6f52..adbae7a 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.53 2004/04/06 22:25:51 dgp Exp $
+ * RCS: @(#) $Id: tclFileName.c,v 1.54 2004/05/07 07:44:37 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -1695,6 +1695,20 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types)
}
}
+ /*
+ * Finally if we still haven't managed to generate a path
+ * prefix, check if the path starts with a current volume.
+ */
+ if (pathPrefix == NULL) {
+ int driveNameLen;
+ Tcl_Obj *driveName;
+ if (TclFSNonnativePathType(tail, strlen(tail), NULL, &driveNameLen,
+ &driveName) == TCL_PATH_ABSOLUTE) {
+ pathPrefix = driveName;
+ tail += driveNameLen;
+ }
+ }
+
/*
* We need to get the old result, in case it is over-written
* below when we still need it.
@@ -1852,7 +1866,10 @@ SkipToChar(stringPtr, match)
* path name to be globbed and the pattern. The directory and
* remainder are assumed to be native format paths. The prefix
* contained in 'pathPtr' is either a directory or path from which
- * to start the search (or NULL).
+ * to start the search (or NULL). If pathPtr is NULL, then the
+ * pattern must not start with an absolute path specification
+ * (that case should be handled by moving the absolute path
+ * prefix into pathPtr before calling DoGlob).
*
* Results:
* The return value is a standard Tcl result indicating whether
diff --git a/generic/tclFileSystem.h b/generic/tclFileSystem.h
index 8d0ab34..d63f7d5 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.6 2004/01/21 19:59:33 vincentdarley Exp $
+ * RCS: @(#) $Id: tclFileSystem.h,v 1.7 2004/05/07 07:44:37 vincentdarley Exp $
*/
/*
@@ -86,11 +86,15 @@ extern Tcl_Filesystem tclNativeFilesystem;
extern Tcl_ThreadDataKey tclFsDataKey;
/*
- * Private shared functions for use by tclIOUtil.c and tclPathObj.c
+ * Private shared functions for use by tclIOUtil.c, tclPathObj.c
+ * and tclFileName.c
*/
Tcl_PathType TclFSGetPathType _ANSI_ARGS_((Tcl_Obj *pathPtr,
Tcl_Filesystem **filesystemPtrPtr,
int *driveNameLengthPtr));
+Tcl_PathType TclFSNonnativePathType _ANSI_ARGS_((CONST char *pathPtr,
+ int pathLen, Tcl_Filesystem **filesystemPtrPtr,
+ int *driveNameLengthPtr, Tcl_Obj **driveNameRef));
Tcl_PathType TclGetPathType _ANSI_ARGS_((Tcl_Obj *pathPtr,
Tcl_Filesystem **filesystemPtrPtr,
int *driveNameLengthPtr, Tcl_Obj **driveNameRef));
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index f526d40..48621d8 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.101 2004/04/23 12:09:37 vincentdarley Exp $
+ * RCS: @(#) $Id: tclIOUtil.c,v 1.102 2004/05/07 07:44:37 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -3469,13 +3469,70 @@ TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef)
* the path, already with a
* refCount for the caller. */
{
- FilesystemRecord *fsRecPtr;
int pathLen;
char *path;
- Tcl_PathType type = TCL_PATH_RELATIVE;
+ Tcl_PathType type;
path = Tcl_GetStringFromObj(pathPtr, &pathLen);
+ type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr,
+ driveNameLengthPtr, driveNameRef);
+
+ if (type != TCL_PATH_ABSOLUTE) {
+ type = TclpGetNativePathType(pathPtr, driveNameLengthPtr,
+ driveNameRef);
+ if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) {
+ *filesystemPtrPtr = &tclNativeFilesystem;
+ }
+ }
+ return type;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFSNonnativePathType --
+ *
+ * Helper function used by TclGetPathType. Its purpose is to
+ * check whether the given path starts with a string which
+ * corresponds to a file volume in any registered filesystem
+ * except the native one. For speed and historical reasons the
+ * native filesystem has special hard-coded checks dotted here
+ * and there in the filesystem code.
+ *
+ * Results:
+ * Returns one of TCL_PATH_ABSOLUTE or TCL_PATH_RELATIVE.
+ * The filesystem reference will be set if and only if it is
+ * non-NULL and the function's return value is TCL_PATH_ABSOLUTE.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_PathType
+TclFSNonnativePathType(path, pathLen, filesystemPtrPtr,
+ driveNameLengthPtr, driveNameRef)
+ CONST char *path; /* Path to determine type for */
+ int pathLen; /* Length of the path */
+ Tcl_Filesystem **filesystemPtrPtr; /* If absolute path and this is
+ * non-NULL, then set to the
+ * filesystem which claims this
+ * path */
+ int *driveNameLengthPtr; /* If the path is absolute, and
+ * this is non-NULL, then set to
+ * the length of the driveName */
+ Tcl_Obj **driveNameRef; /* If the path is absolute, and
+ * this is non-NULL, then set to
+ * the name of the drive,
+ * network-volume which contains
+ * the path, already with a
+ * refCount for the caller. */
+{
+ FilesystemRecord *fsRecPtr;
+ Tcl_PathType type = TCL_PATH_RELATIVE;
+
/*
* Call each of the "listVolumes" function in succession, checking
* whether the given path is an absolute path on any of the volumes
@@ -3557,14 +3614,6 @@ TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef)
}
fsRecPtr = fsRecPtr->nextPtr;
}
-
- if (type != TCL_PATH_ABSOLUTE) {
- type = TclpGetNativePathType(pathPtr, driveNameLengthPtr,
- driveNameRef);
- if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) {
- *filesystemPtrPtr = &tclNativeFilesystem;
- }
- }
return type;
}
diff --git a/tests/fileSystem.test b/tests/fileSystem.test
index e9c4ee6..a45751f 100644
--- a/tests/fileSystem.test
+++ b/tests/fileSystem.test
@@ -728,6 +728,57 @@ test filesystem-7.3 {glob in simplefs} \
set res
} {simplefs:/simpledir/simplefile}
+test filesystem-7.3.1 {glob in simplefs: no path/dir} \
+ {testsimplefilesystem} {
+ set dir [pwd]
+ cd [tcltest::temporaryDirectory]
+ file mkdir simpledir
+ close [open [file join simpledir simplefile] w]
+ testsimplefilesystem 1
+ set res [glob -nocomplain simplefs:/simpledir/*]
+ eval lappend res [glob -nocomplain simplefs:/simpledir]
+ testsimplefilesystem 0
+ file delete -force simpledir
+ cd $dir
+ set res
+} {simplefs:/simpledir/simplefile simplefs:/simpledir}
+
+test filesystem-7.3.2 {glob in simplefs: no path/dir, no subdirectory} \
+ {testsimplefilesystem} {
+ set dir [pwd]
+ cd [tcltest::temporaryDirectory]
+ file mkdir simpledir
+ close [open [file join simpledir simplefile] w]
+ testsimplefilesystem 1
+ set res [glob -nocomplain simplefs:/s*]
+ testsimplefilesystem 0
+ file delete -force simpledir
+ cd $dir
+ if {[llength $res] > 0} {
+ set res "ok"
+ } else {
+ set res "no files found with 'glob -nocomplain simplefs:/s*'"
+ }
+} {ok}
+
+test filesystem-7.3.3 {glob in simplefs: pattern is a volume} \
+ {testsimplefilesystem} {
+ set dir [pwd]
+ cd [tcltest::temporaryDirectory]
+ file mkdir simpledir
+ close [open [file join simpledir simplefile] w]
+ testsimplefilesystem 1
+ set res [glob -nocomplain simplefs:/*]
+ testsimplefilesystem 0
+ file delete -force simpledir
+ cd $dir
+ if {[llength $res] > 0} {
+ set res "ok"
+ } else {
+ set res "no files found with 'glob -nocomplain simplefs:/*'"
+ }
+} {ok}
+
test filesystem-7.4 {cross-filesystem file copy with -force} \
{testsimplefilesystem} {
set dir [pwd]