diff options
| -rw-r--r-- | ChangeLog | 23 | ||||
| -rw-r--r-- | doc/FileSystem.3 | 6 | ||||
| -rw-r--r-- | doc/file.n | 19 | ||||
| -rw-r--r-- | generic/tclFileName.c | 12 | ||||
| -rw-r--r-- | generic/tclIOUtil.c | 76 | ||||
| -rw-r--r-- | mac/tclMacFile.c | 29 | ||||
| -rw-r--r-- | tests/fileName.test | 25 | ||||
| -rw-r--r-- | tests/fileSystem.test | 2 | ||||
| -rw-r--r-- | tests/winFile.test | 14 | ||||
| -rw-r--r-- | unix/tclUnixFile.c | 29 | ||||
| -rw-r--r-- | win/tclWinFile.c | 222 |
11 files changed, 349 insertions, 108 deletions
@@ -1,3 +1,26 @@ +2002-05-02 Vince Darley <vincentdarley@users.sourceforge.net> + + * generic/tclFileName.c: fix to freeing a bad object + (i.e. segfault) when using 'glob -types nonsense -dir dirname'. + * generic/tclWinFile.c: fix to [Bug 551306], also wrapped some + long lines. + * tests/fileName.test: added several tests for the above bugs. + * doc/FileSystem.3: clarified documentation on refCount + requirements of the object returned by the path type function. + * generic/tclIOUtil.c: + * win/tclWinFile.c: + * unix/tclUnixFile.c: + * mac/tclMacFile.c: moved TclpFilesystemPathType to the + platform specific directories, so we can add missing platform- + specific implementations. On Windows, 'file system' now returns + useful results like "native NTFS", "native FAT" for that system. + Unix and MacOS still only return "native". + * doc/file.n: clarified documentation. + * tests/winFile.test: test for 'file system' returning correct + values. + * tests/fileSystem.test: test for 'file system' returning correct + values. + 2002-04-26 Jeff Hobbs <jeffh@ActiveState.com> * unix/configure: diff --git a/doc/FileSystem.3 b/doc/FileSystem.3 index c085135..413c119 100644 --- a/doc/FileSystem.3 +++ b/doc/FileSystem.3 @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: FileSystem.3,v 1.21 2002/04/03 08:39:26 vincentdarley Exp $ +'\" RCS: @(#) $Id: FileSystem.3,v 1.22 2002/05/02 20:15:20 vincentdarley Exp $ '\" .so man.macros .TH Filesystem 3 8.4 Tcl "Tcl Library Procedures" @@ -867,7 +867,9 @@ NULL, in which case no type information will be available to users of the filesystem. The 'type' is used only for informational purposes, and should be returned as the string representation of the Tcl_Obj which is returned. A typical return value might be "networked", "zip" -or "ftp". +or "ftp". The Tcl_Obj result is owned by the filesystem and so Tcl will +increment the refCount of that object if it wishes to retain a reference +to it. .PP .CS typedef Tcl_Obj* Tcl_FSFilesystemPathTypeProc( @@ -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.14 2002/03/24 11:41:48 vincentdarley Exp $ +'\" RCS: @(#) $Id: file.n,v 1.15 2002/05/02 20:15:20 vincentdarley Exp $ '\" .so man.macros .TH file n 8.3 Tcl "Tcl Built-In Commands" @@ -350,14 +350,15 @@ empty string. Returns a list of two elements, the first of which is the name of the filesystem to use for the file, and the second an arbitrary string representing the filesystem-specific nature or type of the location -within that filesystem. If a filesystem only supports one type of -file, the second element may be null. For example the native files -have a first element 'native', and a second element which is a -platform-specific type name for the file (e.g. 'networked'), or -possibly the empty string. A generic virtual file system might return -the list 'vfs ftp' to represent a file on a remote ftp site mounted as -a virtual filesystem through an extension called 'vfs'. If the file -does not belong to any filesystem, an error is generated. +within that filesystem. If a filesystem only supports one type of file, +the second element may be null. For example the native files have a +first element 'native', and a second element which is a platform-specific +type name for the file's system (e.g. 'NTFS', 'FAT', etc), or possibly +the empty string if no further information is available or if this +is not implemented. A generic virtual file system might return the list +'vfs ftp' to represent a file on a remote ftp site mounted as a virtual +filesystem through an extension called 'vfs'. If the file does not +belong to any filesystem, an error is generated. .TP \fBfile tail \fIname\fR . diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 0e184de..b793e38 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.33 2002/03/24 11:41:50 vincentdarley Exp $ + * RCS: @(#) $Id: tclFileName.c,v 1.34 2002/05/02 20:15:20 vincentdarley Exp $ */ #include "tclInt.h" @@ -416,7 +416,7 @@ TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, driveNameRef) (*(c-1) == ':')) { /* We have an extra colon */ Tcl_SetObjLength(*driveNameRef, - c - Tcl_GetString(*driveNameRef) - 1); + c - Tcl_GetString(*driveNameRef) - 1); } } } @@ -1695,6 +1695,10 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) } } + if (pathOrDir != NULL) { + Tcl_IncrRefCount(pathOrDir); + } + if (typePtr != NULL) { /* * The rest of the possible type arguments (except 'd') are @@ -1802,10 +1806,6 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) } } - if (pathOrDir != NULL) { - Tcl_IncrRefCount(pathOrDir); - } - /* * Now we perform the actual glob below. This may involve joining * together the pattern arguments, dealing with particular file types diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index f8b395e..74baf02 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.40 2002/04/23 02:54:59 hobbs Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.41 2002/05/02 20:15:20 vincentdarley Exp $ */ #include "tclInt.h" @@ -328,7 +328,6 @@ typedef struct FilesystemRecord { * are implemented in the platform-specific directories. */ static Tcl_FSPathInFilesystemProc NativePathInFilesystem; -static Tcl_FSFilesystemPathTypeProc NativeFilesystemPathType; static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator; static Tcl_FSFreeInternalRepProc NativeFreeInternalRep; static Tcl_FSDupInternalRepProc NativeDupInternalRep; @@ -348,6 +347,7 @@ static Tcl_FSUtimeProc NativeUtime; * support into a separate code library, this could actually be * enforced). */ +Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType; Tcl_FSInternalToNormalizedProc TclpNativeToNormalized; Tcl_FSStatProc TclpObjStat; Tcl_FSAccessProc TclpObjAccess; @@ -376,7 +376,7 @@ static Tcl_Filesystem nativeFilesystem = { &TclpNativeToNormalized, &NativeCreateNativeRep, &TclpObjNormalizePath, - &NativeFilesystemPathType, + &TclpFilesystemPathType, &NativeFilesystemSeparator, &TclpObjStat, &TclpObjAccess, @@ -507,6 +507,8 @@ typedef struct FsDivertLoad { ClientData clientData; Tcl_FSUnloadFileProc *unloadProcPtr; Tcl_Obj *divertedFile; + Tcl_Filesystem *divertedFilesystem; + ClientData divertedFileNativeRep; } FsDivertLoad; /* Now move on to the basic filesystem implementation */ @@ -2452,6 +2454,18 @@ Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, tvdlPtr->unloadProcPtr = newUnloadProcPtr; /* copyToPtr is already incremented for this reference */ tvdlPtr->divertedFile = copyToPtr; + /* + * This is the filesystem we loaded it into. It is + * almost certainly the nativeFilesystem, but we don't + * want to make that assumption. Since we have a + * reference to 'copyToPtr', we already have a refCount + * on this filesystem, so we don't need to worry about it + * disappearing on us. + */ + tvdlPtr->divertedFilesystem = copyFsPtr; + /* Get the native representation of the file path */ + tvdlPtr->divertedFileNativeRep = Tcl_FSGetInternalRep(copyToPtr, + copyFsPtr); copyToPtr = NULL; (*clientDataPtr) = (ClientData) tvdlPtr; (*unloadProcPtr) = &FSUnloadTempFile; @@ -2502,9 +2516,35 @@ FSUnloadTempFile(clientData) } /* Remove the temporary file we created. */ - Tcl_FSDeleteFile(tvdlPtr->divertedFile); + if (Tcl_FSDeleteFile(tvdlPtr->divertedFile) != TCL_OK) { + /* + * The above may have failed because the filesystem, or something + * it depends upon (e.g. encodings) are being taken down because + * Tcl is exiting. + * + * Therefore we try to call the filesystem's 'delete file proc' + * directly. Note that this call may still cause problems, because + * it will ask for the native representation of the divertedFile, + * and that may need to be _recalculated_, in which case this + * call isn't very different to the above. What we could do + * instead is generate a new Tcl_Obj (pure native) by calling: + * + * Tcl_Obj *tmp = Tcl_FSNewNativePath(tvdlPtr->divertedFile, + * tvdlPtr->divertedFileNativeRep); + * Tcl_IncrRefCount(tmp); + * tvdlPtr->divertedFilesystem->deleteFileProc(tmp); + * Tcl_DecrRefCount(tmp); + * + * and then use that in this call. This approach would + */ + //tvdlPtr->divertedFilesystem->deleteFileProc(tvdlPtr->divertedFile); + } - /* And free up the allocations */ + /* + * And free up the allocations. This will also of course remove + * a refCount from the Tcl_Filesystem to which this file belongs, + * which could then free up the filesystem if we are exiting. + */ Tcl_DecrRefCount(tvdlPtr->divertedFile); ckfree((char*)tvdlPtr); } @@ -4484,32 +4524,6 @@ NativeFilesystemSeparator(pathObjPtr) /* *--------------------------------------------------------------------------- * - * NativeFilesystemPathType -- - * - * This function is part of the native filesystem support, and - * returns the path type of the given path. Right now it simply - * returns NULL. In the future it could return specific path - * types, like 'network' for a natively-networked path, etc. - * - * Results: - * NULL at present. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ -static Tcl_Obj* -NativeFilesystemPathType(pathObjPtr) - Tcl_Obj* pathObjPtr; -{ - /* All native paths are of the same type */ - return NULL; -} - -/* - *--------------------------------------------------------------------------- - * * Tcl_FSGetFileSystemForPath -- * * This function determines which filesystem to use for a diff --git a/mac/tclMacFile.c b/mac/tclMacFile.c index 01c2678..210624b 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.20 2002/04/19 14:18:50 das Exp $ + * RCS: @(#) $Id: tclMacFile.c,v 1.21 2002/05/02 20:15:20 vincentdarley Exp $ */ /* @@ -1169,3 +1169,30 @@ TclpObjLink(pathPtr, toPtr) } #endif + + +/* + *--------------------------------------------------------------------------- + * + * TclpFilesystemPathType -- + * + * This function is part of the native filesystem support, and + * returns the path type of the given path. Right now it simply + * returns NULL. In the future it could return specific path + * types, like 'HFS', 'HFS+', 'nfs', 'samba', 'FAT32', etc. + * + * Results: + * NULL at present. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +Tcl_Obj* +TclpFilesystemPathType(pathObjPtr) + Tcl_Obj* pathObjPtr; +{ + /* All native paths are of the same type */ + return NULL; +} diff --git a/tests/fileName.test b/tests/fileName.test index 18ca882..3d34e70 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -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: fileName.test,v 1.18 2002/04/22 19:57:49 hobbs Exp $ +# RCS: @(#) $Id: fileName.test,v 1.19 2002/05/02 20:15:20 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -1420,6 +1420,18 @@ test filename-11.45 {Tcl_GlobCmd on root volume} { } expr {$res1 == $res2} } {1} +test filename-11.46 {Tcl_GlobCmd} { + list [catch {glob -types abcde -dir foo *} msg] $msg +} {1 {bad argument to "-types": abcde}} +test filename-11.47 {Tcl_GlobCmd} { + list [catch {glob -types abcde -path foo *} msg] $msg +} {1 {bad argument to "-types": abcde}} +test filename-11.48 {Tcl_GlobCmd} { + list [catch {glob -types abcde -dir foo -join * *} msg] $msg +} {1 {bad argument to "-types": abcde}} +test filename-11.49 {Tcl_GlobCmd} { + list [catch {glob -types abcde -path foo -join * *} msg] $msg +} {1 {bad argument to "-types": abcde}} file rename $horribleglobname globTest set globname globTest @@ -1748,6 +1760,17 @@ test filename-16.13 {windows specific globbing} {pcOnly sharedCdrive} { cd //[info hostname]/c glob "\\\\\\\\[info hostname]\\\\c\\\\*Test" } //[info hostname]/c/globTest +test filename-16.14 {windows specific globbing} {pcOnly} { + cd [lindex [glob -types d -dir C:/ *] 0] + expr {[lsearch -exact [glob {{.,*}*}] ".."] != -1} +} {1} +test filename-16.15 {windows specific globbing} {pcOnly} { + cd [lindex [glob -types d -dir C:/ *] 0] + glob .. +} {..} +test filename-16.16 {windows specific globbing} {pcOnly} { + file tail [glob "[lindex [glob -types d -dir C:/ *] 0]/.."] +} {..} # cleanup catch {file delete -force C:/globTest} diff --git a/tests/fileSystem.test b/tests/fileSystem.test index a5bd413..5a0713a 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -119,7 +119,7 @@ test filesystem-3.4 {Tcl_FSRegister} Tcltest { test filesystem-3.5 {Tcl_FSUnregister} Tcltest { testfilesystem 0 - file system bar + lindex [file system bar] 0 } {native} test filesystem-4.0 {testfilesystem} { diff --git a/tests/winFile.test b/tests/winFile.test index 92c28a8..0cf76e2 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -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: winFile.test,v 1.6 2000/04/10 17:19:06 ericm Exp $ +# RCS: @(#) $Id: winFile.test,v 1.7 2002/05/02 20:15:20 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -62,6 +62,18 @@ test winFile-2.2 {TclpMatchFiles: case sensitivity} {pcOnly} { set result } {globlower globlower} +test winFile-3.1 {file system} {pcOnly} { + set res "volume types ok" + foreach vol [file volumes] { + if {![string equal [lindex [file system $vol] 1] [testvolumetype $vol]]} { + set res "For $vol, we found [file system $vol]\ + and [testvolumetype $vol] are different" + break + } + } + set res +} {volume types ok} + # cleanup ::tcltest::cleanupTests return diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 3e2c7c8..5eca8e7 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.19 2002/03/24 11:41:51 vincentdarley Exp $ + * RCS: @(#) $Id: tclUnixFile.c,v 1.20 2002/05/02 20:15:20 vincentdarley Exp $ */ #include "tclInt.h" @@ -760,3 +760,30 @@ TclpObjLink(pathPtr, toPtr) } #endif + + +/* + *--------------------------------------------------------------------------- + * + * TclpFilesystemPathType -- + * + * This function is part of the native filesystem support, and + * returns the path type of the given path. Right now it simply + * returns NULL. In the future it could return specific path + * types, like 'nfs', 'samba', 'FAT32', etc. + * + * Results: + * NULL at present. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +Tcl_Obj* +TclpFilesystemPathType(pathObjPtr) + Tcl_Obj* pathObjPtr; +{ + /* All native paths are of the same type */ + return NULL; +} diff --git a/win/tclWinFile.c b/win/tclWinFile.c index b0c1854..58bf2d0 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.27 2002/03/24 11:41:51 vincentdarley Exp $ + * RCS: @(#) $Id: tclWinFile.c,v 1.28 2002/05/02 20:15:20 vincentdarley Exp $ */ #include "tclWinInt.h" @@ -33,8 +33,9 @@ typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC static int NativeAccess(CONST TCHAR *path, int mode); static int NativeStat(CONST TCHAR *path, Tcl_StatBuf *statPtr); static int NativeIsExec(CONST TCHAR *path); -static int NativeMatchType(int isDrive, CONST TCHAR* nativeName, - Tcl_GlobTypeData *types); +static int WinIsDrive(CONST char *name, int nameLen); +static int NativeMatchType(CONST char *name, int nameLen, + CONST TCHAR* nativeName, Tcl_GlobTypeData *types); /* @@ -124,28 +125,16 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) CONST TCHAR *nativeName; if (pattern == NULL || (*pattern == '\0')) { - int isDrive = 0; - int len; - char *str = Tcl_GetStringFromObj(pathPtr,&len); - if (len < 4) { - if (len == 0) { - /* - * Not sure if this is possible, but we pass it on - * anyway - */ - } else if (len == 1 && (str[0] == '/' || str[0] == '\\')) { - /* Path is pointing to the root volume */ - isDrive = 1; - } else if ((str[1] == ':') && (len == 2 || (str[2] == '/' || str[2] == '\\'))) { - /* Path is of the form 'x:' or 'x:/' or 'x:\' */ - isDrive = 1; + Tcl_Obj *norm = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (norm != NULL) { + int len; + char *str = Tcl_GetStringFromObj(norm,&len); + /* Match a file directly */ + nativeName = (CONST TCHAR*) Tcl_FSGetNativePath(pathPtr); + if (NativeMatchType(str, len, nativeName, types)) { + Tcl_ListObjAppendElement(interp, resultPtr, pathPtr); } } - /* Match a file directly */ - nativeName = (CONST TCHAR*) Tcl_FSGetNativePath(pathPtr); - if (NativeMatchType(isDrive, nativeName, types)) { - Tcl_ListObjAppendElement(interp, resultPtr, pathPtr); - } return TCL_OK; } else { char drivePat[] = "?:\\"; @@ -214,10 +203,11 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) } /* - * Next check the volume information for the directory to see whether - * comparisons should be case sensitive or not. If the root is null, then - * we use the root of the current directory. If the root is just a drive - * specifier, we use the root directory of the given drive. + * Next check the volume information for the directory to see + * whether comparisons should be case sensitive or not. If the + * root is null, then we use the root of the current directory. + * If the root is just a drive specifier, we use the root + * directory of the given drive. */ switch (Tcl_GetPathType(dir)) { @@ -310,20 +300,23 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) if (!matchSpecialDots) { /* If it is exactly '.' or '..' then we ignore it */ if (name[0] == '.') { - if (name[1] == '\0' || (name[1] == '.' && name[2] == '\0')) { + if (name[1] == '\0' + || (name[1] == '.' && name[2] == '\0')) { continue; } } } /* - * Check to see if the file matches the pattern. Note that we - * are ignoring the case sensitivity flag because Windows doesn't honor - * case even if the volume is case sensitive. If the volume also - * doesn't preserve case, then we previously returned the lower case - * form of the name. This didn't seem quite right since there are - * non-case-preserving volumes that actually return mixed case. So now - * we are returning exactly what we get from the system. + * Check to see if the file matches the pattern. Note that + * we are ignoring the case sensitivity flag because Windows + * doesn't honor case even if the volume is case sensitive. + * If the volume also doesn't preserve case, then we + * previously returned the lower case form of the name. This + * didn't seem quite right since there are + * non-case-preserving volumes that actually return mixed + * case. So now we are returning exactly what we get from + * the system. */ nativeMatchResult = NULL; @@ -338,8 +331,8 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) } /* - * If the file matches, then we need to process the remainder of the - * path. + * If the file matches, then we need to process the remainder + * of the path. */ name = Tcl_WinTCharToUtf(nativeMatchResult, -1, &ds); @@ -347,9 +340,11 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) Tcl_DStringFree(&ds); fname = Tcl_DStringValue(&dsOrig); - nativeName = Tcl_WinUtfToTChar(fname, Tcl_DStringLength(&dsOrig), &ds); + nativeName = Tcl_WinUtfToTChar(fname, Tcl_DStringLength(&dsOrig), + &ds); - if (NativeMatchType(0, nativeName, types)) { + if (NativeMatchType(fname, Tcl_DStringLength(&dsOrig), + nativeName, types)) { Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(fname, Tcl_DStringLength(&dsOrig))); } @@ -381,13 +376,68 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) } /* + * Does the given path represent a root volume? We need this special + * case because for NTFS root volumes, the getFileAttributesProc returns + * a 'hidden' attribute when it should not. + */ +static int +WinIsDrive( + CONST char *name, /* Name (UTF-8) */ + int len) /* Length of name */ +{ + int remove = 0; + while (len > 4) { + if ((name[len-1] != '.' || name[len-2] != '.') + || (name[len-3] != '/' && name[len-3] != '\\')) { + /* We don't have '/..' at the end */ + if (remove == 0) { + break; + } + remove--; + while (len > 0) { + len--; + if (name[len] == '/' || name[len] == '\\') { + break; + } + } + if (len < 4) { + len++; + break; + } + } else { + /* We do have '/..' */ + len -= 3; + remove++; + } + } + if (len < 4) { + if (len == 0) { + /* + * Not sure if this is possible, but we pass it on + * anyway + */ + } else if (len == 1 && (name[0] == '/' || name[0] == '\\')) { + /* Path is pointing to the root volume */ + return 1; + } else if ((name[1] == ':') + && (len == 2 || (name[2] == '/' || name[2] == '\\'))) { + /* Path is of the form 'x:' or 'x:/' or 'x:\' */ + return 1; + } + } + return 0; +} + + +/* * This function needs a special case for a path which is a root * volume, because for NTFS root volumes, the getFileAttributesProc * returns a 'hidden' attribute when it should not. */ static int NativeMatchType( - int isDrive, /* Is this path a drive (root volume) */ + CONST char *name, /* Name */ + int nameLen, /* Length of name */ CONST TCHAR* nativeName, /* Native path to check */ Tcl_GlobTypeData *types) /* Type description to match against */ { @@ -408,11 +458,11 @@ NativeMatchType( if (types == NULL) { /* If invisible, don't return the file */ - if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) { + if (attr & FILE_ATTRIBUTE_HIDDEN && !WinIsDrive(name, nameLen)) { return 0; } } else { - if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) { + if (attr & FILE_ATTRIBUTE_HIDDEN && !WinIsDrive(name, nameLen)) { /* If invisible */ if ((types->perm == 0) || !(types->perm & TCL_GLOB_PERM_HIDDEN)) { @@ -1000,11 +1050,11 @@ NativeStat(nativePath, statPtr) (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw, NULL, NULL, NULL, 0); /* - * GetFullPathName() turns special devices like "NUL" into "\\.\NUL", - * but GetVolumeInformation() returns failure for "\\.\NUL". This - * will cause "NUL" to get a drive number of -1, which makes about - * as much sense as anything since the special devices don't live on - * any drive. + * GetFullPathName() turns special devices like "NUL" into + * "\\.\NUL", but GetVolumeInformation() returns failure for + * "\\.\NUL". This will cause "NUL" to get a drive number of + * -1, which makes about as much sense as anything since the + * special devices don't live on any drive. */ dev = dw; @@ -1031,8 +1081,8 @@ NativeStat(nativePath, statPtr) } - (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, nativeFullPath, - &nativePart); + (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, + nativeFullPath, &nativePart); fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds); @@ -1061,11 +1111,11 @@ NativeStat(nativePath, statPtr) (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw, NULL, NULL, NULL, 0); /* - * GetFullPathName() turns special devices like "NUL" into "\\.\NUL", - * but GetVolumeInformation() returns failure for "\\.\NUL". This - * will cause "NUL" to get a drive number of -1, which makes about - * as much sense as anything since the special devices don't live on - * any drive. + * GetFullPathName() turns special devices like "NUL" into + * "\\.\NUL", but GetVolumeInformation() returns failure for + * "\\.\NUL". This will cause "NUL" to get a drive number of + * -1, which makes about as much sense as anything since the + * special devices don't live on any drive. */ dev = dw; @@ -1282,7 +1332,8 @@ TclpObjLink(pathPtr, toPtr) return NULL; } else { Tcl_DString ds; - if (TclpReadlink(Tcl_FSGetTranslatedStringPath(NULL, pathPtr), &ds) != NULL) { + if (TclpReadlink(Tcl_FSGetTranslatedStringPath(NULL, pathPtr), &ds) + != NULL) { link = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); Tcl_IncrRefCount(link); Tcl_DStringFree(&ds); @@ -1292,3 +1343,64 @@ TclpObjLink(pathPtr, toPtr) } #endif + + +/* + *--------------------------------------------------------------------------- + * + * TclpFilesystemPathType -- + * + * This function is part of the native filesystem support, and + * returns the path type of the given path. Returns NTFS or FAT + * or whatever is returned by the 'volume information' proc. + * + * Results: + * NULL at present. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +Tcl_Obj* +TclpFilesystemPathType(pathObjPtr) + Tcl_Obj* pathObjPtr; +{ +#define VOL_BUF_SIZE 32 + int found; + char volType[VOL_BUF_SIZE]; + char* firstSeparator; + CONST char *path; + + Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathObjPtr); + if (normPath == NULL) return NULL; + path = Tcl_GetString(normPath); + if (path == NULL) return NULL; + + firstSeparator = strchr(path, '/'); + if (firstSeparator == NULL) { + found = tclWinProcs->getVolumeInformationProc( + Tcl_FSGetNativePath(pathObjPtr), NULL, 0, NULL, NULL, + NULL, (WCHAR *)volType, VOL_BUF_SIZE); + } else { + Tcl_Obj *driveName = Tcl_NewStringObj(path, firstSeparator - path+1); + Tcl_IncrRefCount(driveName); + found = tclWinProcs->getVolumeInformationProc( + Tcl_FSGetNativePath(driveName), NULL, 0, NULL, NULL, + NULL, (WCHAR *)volType, VOL_BUF_SIZE); + Tcl_DecrRefCount(driveName); + } + + if (found == 0) { + return NULL; + } else { + Tcl_DString ds; + Tcl_Obj *objPtr; + + Tcl_WinTCharToUtf(volType, -1, &ds); + objPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + return objPtr; + } +#undef VOL_BUF_SIZE +} |