Attachment "vfsGlobVol.patch" to
ticket [943995ffff]
added by
vincentdarley
2004-05-07 02:18:06.
? vfsGlobVol.patch
Index: generic/tclFileName.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclFileName.c,v
retrieving revision 1.53
diff -b -u -r1.53 tclFileName.c
--- generic/tclFileName.c 6 Apr 2004 22:25:51 -0000 1.53
+++ generic/tclFileName.c 6 May 2004 19:15:38 -0000
@@ -1696,6 +1696,20 @@
}
/*
+ * 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 @@
* 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
Index: generic/tclFileSystem.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclFileSystem.h,v
retrieving revision 1.6
diff -b -u -r1.6 tclFileSystem.h
--- generic/tclFileSystem.h 21 Jan 2004 19:59:33 -0000 1.6
+++ generic/tclFileSystem.h 6 May 2004 19:15:38 -0000
@@ -86,11 +86,15 @@
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));
Index: generic/tclIOUtil.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclIOUtil.c,v
retrieving revision 1.101
diff -b -u -r1.101 tclIOUtil.c
--- generic/tclIOUtil.c 23 Apr 2004 12:09:37 -0000 1.101
+++ generic/tclIOUtil.c 6 May 2004 19:15:50 -0000
@@ -3469,13 +3469,70 @@
* 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 @@
}
fsRecPtr = fsRecPtr->nextPtr;
}
-
- if (type != TCL_PATH_ABSOLUTE) {
- type = TclpGetNativePathType(pathPtr, driveNameLengthPtr,
- driveNameRef);
- if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) {
- *filesystemPtrPtr = &tclNativeFilesystem;
- }
- }
return type;
}
Index: tests/fileSystem.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/fileSystem.test,v
retrieving revision 1.40
diff -b -u -r1.40 fileSystem.test
--- tests/fileSystem.test 4 May 2004 22:31:10 -0000 1.40
+++ tests/fileSystem.test 6 May 2004 19:15:52 -0000
@@ -728,6 +728,57 @@
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]
