Attachment "globLinkFix.patch" to
ticket [511666ffff]
added by
vincentdarley
2002-03-17 00:32:24.
? tests/fileSystem.test
? win/efile
? win/outdata
Index: ChangeLog
===================================================================
RCS file: /cvsroot/tcl/tcl/ChangeLog,v
retrieving revision 1.907
diff -b -u -r1.907 ChangeLog
--- ChangeLog 15 Mar 2002 15:39:06 -0000 1.907
+++ ChangeLog 16 Mar 2002 17:22:25 -0000
@@ -4,6 +4,38 @@
* generic/tclCompile.c (TclCompileTokens): Fixed buffer overrun
reported in bug 530320.
+2002-03-15 Vince Darley <[email protected]>
+
+ * generic/tclFilename.c
+ * generic/tclFCmd.c
+ * generic/tclTest.c
+ * generic/tcl.h
+ * generic/tclIOUtil.c
+ * win/tclWinFile.c:
+ * win/tclWinFCmd.c:
+ * unix/tclUnixFile.c:
+ * unix/tclUnixFCmd.c:
+ * mac/tclMacFile.c:
+ * doc/FileSystem.3:
+ * doc/file.n:
+ * tests/cmdAH.test:
+ * tests/fileName.test:
+ * tests/winFCmd.test:
+ * tests/fileSystem.test: fix [Bug 511666] and [Bug 511658],
+ and improved documentation of some aspects of the filesystem,
+ particularly 'Tcl_FSMatchInDirectory' which now might match
+ a single file/directory only. Removed inconsistency betweens
+ docs and the Tcl_Filesystem structure. Also fixed [Bug] and
+ corrected file normalization on Unix so that it expands
+ symbolic links. Added some new tests of the filesystem code,
+ and some extra tests for correct handling of symbolic links.
+
+ ***POTENTIAL INCOMPATIBILITY***: But only between alpha
+ releases (users of the new Tcl_Filesystem lookup table in
+ Tcl 8.4a4 will need to update their code, and 'file
+ normalize' on unix now behaves correctly). Only known
+ impact is with the 'tclvfs' extension.
+
2002-03-14 Mo DeJong <[email protected]>
* win/configure: Regen.
Index: doc/FileSystem.3
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/FileSystem.3,v
retrieving revision 1.19
diff -b -u -r1.19 FileSystem.3
--- doc/FileSystem.3 15 Feb 2002 14:28:47 -0000 1.19
+++ doc/FileSystem.3 16 Mar 2002 17:22:30 -0000
@@ -495,7 +495,11 @@
.PP
It returns the normalized path object, with refCount of zero, or NULL
if the path was invalid or could otherwise not be successfully
-converted.
+converted. Extraction of absolute, normalized paths is very
+efficient (because the filesystem operates on these representations
+internally), although the result when the filesystem contains
+numerous symbolic links may not be the most user-friendly
+version of a path.
.PP
\fBTcl_FSJoinToPath\fR takes the given object, which should usually be a
valid path or NULL, and joins onto it the array of paths segments
@@ -529,12 +533,14 @@
.PP
If the translation succeeds (i.e. the object is a valid path), then it
is returned. Otherwise NULL will be returned, and an error message may
-be left in the interpreter.
+be left in the interpreter. A "translated" path is one which
+contains no "~" or "~user" sequences (these have been expanded to
+their current representation in the filesystem).
.PP
\fBTcl_FSGetTranslatedStringPath\fR does the same as
\fBTcl_FSGetTranslatedPath\fR, but returns a character string or NULL.
.PP
-\fBTcl_FSNewNativePath\fR performs the something like that reverse of the
+\fBTcl_FSNewNativePath\fR performs something like that reverse of the
usual obj->path->nativerep conversions. If some code retrieves a path
in native form (from, e.g. readlink or a native dialog), and that path
is to be used at the Tcl level, then calling this function is an
@@ -666,10 +672,62 @@
\fITcl_FSDeleteFileProc\fR, and if \fITcl_FSCopyFileProc\fR is not
implemented there is a further fallback). However, if a
\fITcl_FSRenameFile\fR command is issued at the C level, no such
-fallbacks occur. This is true except for the last five entries in the
-filesystem table (lstat, load, unload, getcwd and chdir)
+fallbacks occur. This is true except for the last four entries in the
+filesystem table (lstat, load, getcwd and chdir)
for which fallbacks do in fact occur at the C level.
.PP
+As an example, here is the filesystem lookup table used by the
+"vfs" extension which allows filesystem actions to be implemented
+in Tcl.
+.CS
+static Tcl_Filesystem vfsFilesystem = {
+ "tclvfs",
+ sizeof(Tcl_Filesystem),
+ TCL_FILESYSTEM_VERSION_1,
+ &VfsPathInFilesystem,
+ &VfsDupInternalRep,
+ &VfsFreeInternalRep,
+ /* No internal to normalized, since we don't create any
+ * pure 'internal' Tcl_Obj path representations */
+ NULL,
+ /* No create native rep function, since we don't use it
+ * and don't choose to support uses of 'Tcl_FSNewNativePath' */
+ NULL,
+ /* Normalize path isn't needed - we assume paths only have
+ * one representation */
+ NULL,
+ &VfsFilesystemPathType,
+ &VfsFilesystemSeparator,
+ &VfsStat,
+ &VfsAccess,
+ &VfsOpenFileChannel,
+ &VfsMatchInDirectory,
+ &VfsUtime,
+ /* We choose not to support symbolic links inside our vfs's */
+ NULL,
+ &VfsListVolumes,
+ &VfsFileAttrStrings,
+ &VfsFileAttrsGet,
+ &VfsFileAttrsSet,
+ &VfsCreateDirectory,
+ &VfsRemoveDirectory,
+ &VfsDeleteFile,
+ /* No copy file - fallback will occur at Tcl level */
+ NULL,
+ /* No rename file - fallback will occur at Tcl level */
+ NULL,
+ /* No copy directory - fallback will occur at Tcl level */
+ NULL,
+ /* Core will use stat for lstat */
+ NULL,
+ /* No load - fallback on core implementation */
+ NULL,
+ /* We don't need a getcwd or chdir - fallback on Tcl's versions */
+ NULL,
+ NULL
+};
+.CE
+.PP
Any functions which take path names in Tcl_Obj form take
those names in UTF\-8 form. The filesystem infrastructure API is
designed to support efficient, cached conversion of these UTF\-8 paths
@@ -768,7 +826,13 @@
there may be more than one unnormalized string representation which
refers to that path (e.g. a relative path, a path with different
character case if the filesystem is case insensitive, a path contain a
-reference to a home directory such as '~', etc).
+reference to a home directory such as '~', a path containing symbolic
+links, etc). If the very last component in the path is a symbolic
+link, it should not be converted into the object it points to (but
+its case or other aspects should be made unique). All other path
+components should be converted from symbolic links. This one
+exception is required to agree with Tcl's semantics with 'file
+delete', 'file rename', 'file copy' operating on symbolic links.
.PP
.CS
typedef int Tcl_FSNormalizePathProc(
@@ -909,9 +973,13 @@
.PP
The function should return all files or directories (or other
filesystem objects) which match the given pattern and accord with the
-\fItypes\fR specification given. The directory \fIpathPtr\fR, in which
-the function should search, can be assumed to be both non-NULL and
-non-empty.
+\fItypes\fR specification given. There are two ways in which this
+function may be called. If \fIpattern\fR is NULL, then \fIpathPtr\fR
+is a full path specification of a single file or directory which
+should be checked for existence and correct type. Otherwise, \fIpathPtr\fR
+is a directory, the contents of which the function should search for
+files or directories which have the correct type. In either case,
+\fIpathPtr\fR can be assumed to be both non-NULL and non-empty.
.PP
The return value is a standard Tcl result indicating whether an error
occurred in the matching process. Error messages are placed in interp,
@@ -920,6 +988,9 @@
(which can be assumed to be a valid Tcl list). The matches added
to \fIresult\fR should include any path prefix given in \fIpathPtr\fR
(this usually means they will be absolute path specifications).
+Note that if no matches are found, that simply leads to an empty
+result --- errors are only signalled for actual file or filesystem
+problems which may occur during the matching process.
.SH UTIMEPROC
.PP
Function to process a \fBTcl_FSUtime()\fR call. Required to allow setting
@@ -1164,7 +1235,8 @@
Function to process a \fBTcl_FSLoadFile()\fR call. If not implemented, Tcl
will fall back on a copy to native-temp followed by a Tcl_FSLoadFile on
that temporary copy. Therefore it need only be implemented if the
-filesystem can load code directly, or to disable load functionality
+filesystem can load code directly, or it can be implemented simply to
+return TCL_ERROR to disable load functionality in this filesystem
entirely.
.PP
.CS
Index: doc/file.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/file.n,v
retrieving revision 1.13
diff -b -u -r1.13 file.n
--- doc/file.n 10 Dec 2001 15:50:47 -0000 1.13
+++ doc/file.n 16 Mar 2002 17:22:32 -0000
@@ -110,17 +110,20 @@
.TP
\fBfile delete \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIpathname\fR ?\fIpathname\fR ... ?
.
-Removes the file or directory specified by each \fIpathname\fR argument.
-Non-empty directories will be removed only if the \fB\-force\fR option is
-specified. Trying to delete a non-existent file is not considered an
-error. Trying to delete a read-only file will cause the file to be deleted,
+Removes the file or directory specified by each \fIpathname\fR
+argument. Non-empty directories will be removed only if the
+\fB\-force\fR option is specified. When operating on symbolic links,
+the links themselves will be deleted, not the objects they point to.
+Trying to delete a non-existent file is not considered an error.
+Trying to delete a read-only file will cause the file to be deleted,
even if the \fB\-force\fR flags is not specified. If the \fB\-force\fR
option is specified on a directory, Tcl will attempt both to change
permissions and move the current directory 'pwd' out of the given path
-if that is necessary to allow the deletion to proceed. 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
-treated as a \fIpathname\fR even if it starts with a \fB\-\fR.
+if that is necessary to allow the deletion to proceed. 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 treated as a \fIpathname\fR even if it starts with
+a \fB\-\fR.
.TP
\fBfile dirname \fIname\fR
Returns a name comprised of all of the path components in \fIname\fR
@@ -227,11 +230,16 @@
string value can be used as a unique identifier for the it. A
normalized path is one which has all '../', './' removed. Also it is
one which is in the ``standard'' format for the native platform. On
-MacOS, Unix, this means the path must be free of symbolic
-links/aliases, and on Windows it also means means we want the long form
-(when running Win NT/2000/XP) or the short form (when running Win
+MacOS, Unix, this means the segments leading up to the path must be
+free of symbolic links/aliases (but the very last path component may be
+a symbolic link), and on Windows it also means means we want the long
+form (when running Win NT/2000/XP) or the short form (when running Win
95/98) with that form's case-dependence (which gives us a unique,
-case-dependent path).
+case-dependent path). The one exception concerning the last link in
+the path is necessary, because Tcl or the user may wish to operate on
+the actual symbolic link itself (for example 'file delete', 'file
+rename', 'file copy' are defined to operate on symbolic links, not on
+the things that they point to).
.TP
\fBfile owned \fIname\fR
.
@@ -267,12 +275,14 @@
The first form takes the file or directory specified by pathname
\fIsource\fR and renames it to \fItarget\fR, moving the file if the
pathname \fItarget\fR specifies a name in a different directory. If
-\fItarget\fR is an existing directory, then the second form is used. The
-second form moves each \fIsource\fR file or directory into the directory
-\fItargetDir\fR. Existing files will not be overwritten unless the
-\fB\-force\fR option is specified. Trying to overwrite a non-empty
-directory, overwrite a directory with a file, or a file with a directory
-will all result in errors. Arguments are processed in the order specified,
+\fItarget\fR is an existing directory, then the second form is used.
+The second form moves each \fIsource\fR file or directory into the
+directory \fItargetDir\fR. Existing files will not be overwritten
+unless the \fB\-force\fR option is specified. When operating inside a
+single filesystem, Tcl will rename symbolic links rather than the
+things that 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. 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 treated as a
\fIsource\fR even if it starts with a \fB\-\fR.
Index: generic/tcl.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.h,v
retrieving revision 1.120
diff -b -u -r1.120 tcl.h
--- generic/tcl.h 6 Mar 2002 15:20:23 -0000 1.120
+++ generic/tcl.h 16 Mar 2002 17:22:40 -0000
@@ -1788,28 +1788,31 @@
* 'Tcl_FSDeleteFile()' call. Should
* be implemented unless the FS is
* read-only. */
- Tcl_FSLstatProc *lstatProc;
- /* Function to process a
- * 'Tcl_FSLstat()' call. If not implemented,
- * Tcl will attempt to use the 'statProc'
- * defined above instead. */
Tcl_FSCopyFileProc *copyFileProc;
/* Function to process a
* 'Tcl_FSCopyFile()' call. If not
* implemented Tcl will fall back
* on open-r, open-w and fcopy as
- * a copying mechanism. */
+ * a copying mechanism, for copying
+ * actions initiated in Tcl (not C). */
Tcl_FSRenameFileProc *renameFileProc;
/* Function to process a
* 'Tcl_FSRenameFile()' call. If not
* implemented, Tcl will fall back on
- * a copy and delete mechanism. */
+ * a copy and delete mechanism, for
+ * rename actions initiated in Tcl (not C). */
Tcl_FSCopyDirectoryProc *copyDirectoryProc;
/* Function to process a
* 'Tcl_FSCopyDirectory()' call. If
* not implemented, Tcl will fall back
* on a recursive create-dir, file copy
- * mechanism. */
+ * mechanism, for copying actions
+ * initiated in Tcl (not C). */
+ Tcl_FSLstatProc *lstatProc;
+ /* Function to process a
+ * 'Tcl_FSLstat()' call. If not implemented,
+ * Tcl will attempt to use the 'statProc'
+ * defined above instead. */
Tcl_FSLoadFileProc *loadFileProc;
/* Function to process a
* 'Tcl_FSLoadFile()' call. If not
Index: generic/tclFCmd.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclFCmd.c,v
retrieving revision 1.16
diff -b -u -r1.16 tclFCmd.c
--- generic/tclFCmd.c 15 Feb 2002 14:28:49 -0000 1.16
+++ generic/tclFCmd.c 16 Mar 2002 17:22:42 -0000
@@ -716,10 +716,9 @@
* if path is the root directory, returns no characters.
*
* Results:
- * Appends the string that represents the basename to the end of
- * the specified initialized DString, returning a pointer to the
- * resulting string. If there is an error, an error message is left
- * in interp, NULL is returned, and the Tcl_DString is unmodified.
+ * Returns the string object that represents the basename. If there
+ * is an error, an error message is left in interp, and NULL is
+ * returned.
*
* Side effects:
* None.
Index: generic/tclFileName.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclFileName.c,v
retrieving revision 1.32
diff -b -u -r1.32 tclFileName.c
--- generic/tclFileName.c 27 Feb 2002 06:39:16 -0000 1.32
+++ generic/tclFileName.c 16 Mar 2002 17:22:49 -0000
@@ -2454,21 +2454,18 @@
return TclDoGlob(interp, separators, headPtr, p, types);
} else {
/*
+ * This is the code path reached by a command like 'glob foo'.
+ *
* There are no more wildcards in the pattern and no more
* unprocessed characters in the tail, so now we can construct
- * the path and verify the existence of the file.
- *
- * We can't use 'Tcl_(FS)Access' to verify existence because
- * this fails when the file is a symlink to another file which
- * doesn't actually exist. The problem is that if 'foo' is
- * such a broken link, 'glob foo' and 'glob foo*' return
- * different results. So, we use 'Tcl_FSLstat' below so those
- * two return the same result. This fixes [Bug 434876, L.
- * Virden]
+ * the path, and pass it to Tcl_FSMatchInDirectory with an
+ * empty pattern to verify the existence of the file and check
+ * it is of the correct type (if a 'types' flag it given -- if
+ * no such flag was given, we could just use 'Tcl_FSLStat', but
+ * for simplicity we keep to a common approach).
*/
Tcl_Obj *nameObj;
- Tcl_StatBuf buf;
/* Used to deal with one special case pertinent to MacOS */
int macSpecialCase = 0;
@@ -2518,16 +2515,8 @@
nameObj = Tcl_NewStringObj(name, Tcl_DStringLength(headPtr));
Tcl_IncrRefCount(nameObj);
- if (Tcl_FSLstat(nameObj, &buf) == 0) {
- if (macSpecialCase && (name[1] != '\0')
- && (strchr(name+1, ':') == NULL)) {
- Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp),
- Tcl_NewStringObj(name + 1,-1));
- } else {
- Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp),
- nameObj);
- }
- }
+ Tcl_FSMatchInDirectory(interp, Tcl_GetObjResult(interp), nameObj,
+ NULL, types);
Tcl_DecrRefCount(nameObj);
return TCL_OK;
}
Index: generic/tclIOUtil.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclIOUtil.c,v
retrieving revision 1.36
diff -b -u -r1.36 tclIOUtil.c
--- generic/tclIOUtil.c 15 Feb 2002 23:42:12 -0000 1.36
+++ generic/tclIOUtil.c 16 Mar 2002 17:23:03 -0000
@@ -397,10 +397,10 @@
&TclpObjCreateDirectory,
&TclpObjRemoveDirectory,
&TclpObjDeleteFile,
- &TclpObjLstat,
&TclpObjCopyFile,
&TclpObjRenameFile,
&TclpObjCopyDirectory,
+ &TclpObjLstat,
&TclpLoadFile,
&TclpObjGetCwd,
&TclpObjChdir
@@ -1652,6 +1652,10 @@
* is an ordinary path. In fact this means we could remove such
* special case handling from Tcl's native filesystems.
*
+ * If 'pattern' is NULL, then pathPtr is assumed to be a fully
+ * specified path of a single file/directory which must be
+ * checked for existence and correct type.
+ *
* Results:
*
* The return value is a standard Tcl result indicating whether an
@@ -1703,10 +1707,14 @@
}
}
/*
- * We have a null string, this means we must use the 'cwd', and
- * then manipulate the result. We must deal with this here,
- * since if we don't, every single filesystem's implementation
- * of Tcl_FSMatchInDirectory will have to deal with it for us.
+ * We have an empty or NULL path. This is defined to mean we
+ * must search for files within the current 'cwd'. We
+ * therefore use that, but then since the proc we call will
+ * return results which include the cwd we must then trim it
+ * off the front of each path in the result. We choose to deal
+ * with this here (in the generic code), since if we don't,
+ * every single filesystem's implementation of
+ * Tcl_FSMatchInDirectory will have to deal with it for us.
*/
cwd = Tcl_FSGetCwd(NULL);
if (cwd == NULL) {
@@ -3683,6 +3691,11 @@
* this function is an efficient way of creating the appropriate
* path object type.
*
+ * Any memory which is allocated for 'clientData' should be retained
+ * until clientData is passed to the filesystem's freeInternalRepProc
+ * when it can be freed. The built in platform-specific filesystems
+ * use 'ckalloc' to allocate clientData, and ckfree to free it.
+ *
* Results:
* NULL or a valid path object pointer, with refCount zero.
*
@@ -3741,6 +3754,8 @@
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = clientData;
fsPathPtr->fsRecPtr = fsFromPtr->fsRecPtr;
+ /* We must increase the refCount for this filesystem. */
+ fsPathPtr->fsRecPtr->fileRefCount++;
fsPathPtr->filesystemEpoch = fsFromPtr->filesystemEpoch;
objPtr->internalRep.otherValuePtr = (VOID *) fsPathPtr;
@@ -4574,7 +4589,7 @@
* Tcl_FSEqualPaths --
*
* This function tests whether the two paths given are equal path
- * objects.
+ * objects. If either or both is NULL, 0 is always returned.
*
* Results:
* 1 or 0.
Index: generic/tclTest.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclTest.c,v
retrieving revision 1.47
diff -b -u -r1.47 tclTest.c
--- generic/tclTest.c 7 Mar 2002 20:17:22 -0000 1.47
+++ generic/tclTest.c 16 Mar 2002 17:23:25 -0000
@@ -409,10 +409,10 @@
&TestReportCreateDirectory,
&TestReportRemoveDirectory,
&TestReportDeleteFile,
- &TestReportLstat,
&TestReportCopyFile,
&TestReportRenameFile,
&TestReportCopyDirectory,
+ &TestReportLstat,
&TestReportLoadFile,
NULL /* cwd */,
&TestReportChdir
Index: mac/tclMacFile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/mac/tclMacFile.c,v
retrieving revision 1.17
diff -b -u -r1.17 tclMacFile.c
--- mac/tclMacFile.c 15 Feb 2002 14:28:49 -0000 1.17
+++ mac/tclMacFile.c 16 Mar 2002 17:23:28 -0000
@@ -31,6 +31,8 @@
#include <MoreFilesExtras.h>
#include <FSpCompat.h>
+static int NativeMatchType(Tcl_Obj *tempName, Tcl_GlobTypeData *types,
+ HFileInfo fileInfo, OSType okType, OSType okCreator);
static OSErr FspLocationFromFsPath _ANSI_ARGS_((Tcl_Obj *pathPtr,
FSSpec* specPtr));
@@ -128,11 +130,56 @@
Tcl_Interp *interp; /* Interpreter to receive errors. */
Tcl_Obj *resultPtr; /* List object to lappend results. */
Tcl_Obj *pathPtr; /* Contains path to directory to search. */
- CONST char *pattern; /* Pattern to match against. */
+ CONST char *pattern; /* Pattern to match against. NULL or empty
+ * means pathPtr is actually a single file
+ * to check. */
Tcl_GlobTypeData *types; /* Object containing list of acceptable types.
* May be NULL. In particular the directory
* flag is very important. */
{
+ OSType okType = 0;
+ OSType okCreator = 0;
+ Tcl_Obj *fileNamePtr;
+
+ fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
+ if (fileNamePtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (types != NULL) {
+ if (types->macType != NULL) {
+ Tcl_GetOSTypeFromObj(NULL, types->macType, &okType);
+ }
+ if (types->macCreator != NULL) {
+ Tcl_GetOSTypeFromObj(NULL, types->macCreator, &okCreator);
+ }
+ }
+
+ if (pattern == NULL || (*pattern == '\0')) {
+ /* Match a file directly */
+ struct stat buf;
+ int len;
+ char *fname;
+
+ if (TclpObjLstat(fileNamePtr, &buf) != 0) {
+ /* File doesn't exist */
+ return TCL_OK;
+ }
+
+ fname = Tcl_GetStringFromObj(pathPtr,&len);
+
+ /* Need to get the 'hFileInfo' for this path */
+ if (NativeMatchType(fileNamePtr, types, pb.hFileInfo,
+ okType, okCreator) {
+ if ((len > 1) && (strchr(fname+1, ':') == NULL)) {
+ Tcl_ListObjAppendElement(interp, resultPtr,
+ Tcl_NewStringObj(fname+1, fnameLen-1));
+ } else {
+ Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
+ }
+ }
+ return TCL_OK;
+ } else {
char *fname;
int fnameLen, result = TCL_OK;
int baseLength;
@@ -144,15 +191,8 @@
short itemIndex;
Str255 fileName;
Tcl_DString fileString;
- OSType okType = 0;
- OSType okCreator = 0;
Tcl_DString dsOrig;
- Tcl_Obj *fileNamePtr;
- fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
- if (fileNamePtr == NULL) {
- return TCL_ERROR;
- }
Tcl_DStringInit(&dsOrig);
Tcl_DStringAppend(&dsOrig, Tcl_GetString(fileNamePtr), -1);
baseLength = Tcl_DStringLength(&dsOrig);
@@ -168,8 +208,10 @@
err = FSpLocationFromPath(Tcl_DStringLength(&fileString),
Tcl_DStringValue(&fileString), &dirSpec);
Tcl_DStringFree(&fileString);
- if (err == noErr)
+ if (err == noErr) {
err = FSpGetDirectoryID(&dirSpec, &dirID, &isDirectory);
+ }
+
if ((err != noErr) || !isDirectory) {
/*
* Check if we had a relative path (unix style relative path
@@ -186,8 +228,10 @@
err = FSpLocationFromPath(Tcl_DStringLength(&fileString),
Tcl_DStringValue(&fileString), &dirSpec);
Tcl_DStringFree(&fileString);
- if (err == noErr)
+ if (err == noErr) {
err = FSpGetDirectoryID(&dirSpec, &dirID, &isDirectory);
+ }
+
if ((err != noErr) || !isDirectory) {
Tcl_DStringFree(&dsOrig);
return TCL_OK;
@@ -209,15 +253,6 @@
pb.hFileInfo.ioNamePtr = (StringPtr) fileName;
pb.hFileInfo.ioFDirIndex = itemIndex = 1;
- if (types != NULL) {
- if (types->macType != NULL) {
- Tcl_GetOSTypeFromObj(NULL, types->macType, &okType);
- }
- if (types->macCreator != NULL) {
- Tcl_GetOSTypeFromObj(NULL, types->macCreator, &okCreator);
- }
- }
-
while (1) {
pb.hFileInfo.ioFDirIndex = itemIndex;
pb.hFileInfo.ioDirID = dirID;
@@ -233,7 +268,6 @@
Tcl_ExternalToUtfDString(NULL, (char *) fileName + 1, fileName[0],
&fileString);
if (Tcl_StringMatch(Tcl_DStringValue(&fileString), pattern)) {
- int typeOk = 1;
Tcl_Obj *tempName;
Tcl_DStringSetLength(&dsOrig, baseLength);
Tcl_DStringAppend(&dsOrig, Tcl_DStringValue(&fileString), -1);
@@ -247,30 +281,63 @@
tempName = Tcl_NewStringObj(fname, fnameLen);
Tcl_IncrRefCount(tempName);
+ /* Is the type acceptable? */
+ if (NativeMatchType(tempName, types, pb.hFileInfo,
+ okType, okCreator) {
+ if ((fnameLen > 1) && (strchr(fname+1, ':') == NULL)) {
+ Tcl_ListObjAppendElement(interp, resultPtr,
+ Tcl_NewStringObj(fname+1, fnameLen-1));
+ } else {
+ Tcl_ListObjAppendElement(interp, resultPtr, tempName);
+ }
+ }
+ /*
+ * This will free the object, unless it was inserted in
+ * the result list above.
+ */
+ Tcl_DecrRefCount(tempName);
+ }
+ Tcl_DStringFree(&fileString);
+ itemIndex++;
+ }
+
+ Tcl_DStringFree(&dsOrig);
+ return result;
+ }
+}
+
+static int
+NativeMatchType(
+ Tcl_Obj *tempName, /* Path to check */
+ Tcl_GlobTypeData *types, /* Type description to match against */
+ HFileInfo fileInfo, /* MacOS file info */
+ OSType okType, /* Acceptable MacOS type, or zero */
+ OSType okCreator) /* Acceptable MacOS creator, or zero */
+{
if (types == NULL) {
/* If invisible, don't return the file */
- if (pb.hFileInfo.ioFlFndrInfo.fdFlags & kIsInvisible) {
- typeOk = 0;
+ if (fileInfo.ioFlFndrInfo.fdFlags & kIsInvisible) {
+ return 0;
}
} else {
Tcl_StatBuf buf;
- if (pb.hFileInfo.ioFlFndrInfo.fdFlags & kIsInvisible) {
+ if (fileInfo.ioFlFndrInfo.fdFlags & kIsInvisible) {
/* If invisible */
if ((types->perm == 0) ||
!(types->perm & TCL_GLOB_PERM_HIDDEN)) {
- typeOk = 0;
+ return 0;
}
} else {
/* Visible */
if (types->perm & TCL_GLOB_PERM_HIDDEN) {
- typeOk = 0;
+ return 0;
}
}
- if (typeOk == 1 && types->perm != 0) {
+ if (types->perm != 0) {
if (
((types->perm & TCL_GLOB_PERM_RONLY) &&
- !(pb.hFileInfo.ioFlAttrib & 1)) ||
+ !(fileInfo.ioFlAttrib & 1)) ||
((types->perm & TCL_GLOB_PERM_R) &&
(TclpObjAccess(tempName, R_OK) != 0)) ||
((types->perm & TCL_GLOB_PERM_W) &&
@@ -278,15 +345,14 @@
((types->perm & TCL_GLOB_PERM_X) &&
(TclpObjAccess(tempName, X_OK) != 0))
) {
- typeOk = 0;
+ return 0;
}
}
- if (typeOk == 1 && types->type != 0) {
+ if (types->type != 0) {
if (TclpObjStat(tempName, &buf) != 0) {
/* Posix error occurred */
- typeOk = 0;
+ return 0;
}
- if (typeOk) {
/*
* In order bcdpfls as in 'find -t'
*/
@@ -301,15 +367,15 @@
S_ISFIFO(buf.st_mode)) ||
((types->type & TCL_GLOB_TYPE_FILE) &&
S_ISREG(buf.st_mode))
- #ifdef S_ISSOCK
+#ifdef S_ISSOCK
|| ((types->type & TCL_GLOB_TYPE_SOCK) &&
S_ISSOCK(buf.st_mode))
- #endif
+#endif
) {
/* Do nothing -- this file is ok */
} else {
- typeOk = 0;
- #ifdef S_ISLNK
+ int typeOk = 0;
+#ifdef S_ISLNK
if (types->type & TCL_GLOB_TYPE_LINK) {
if (TclpObjLstat(tempName, &buf) == 0) {
if (S_ISLNK(buf.st_mode)) {
@@ -317,39 +383,22 @@
}
}
}
- #endif
+#endif
+ if (typeOk == 0) {
+ return 0;
}
}
}
- if (typeOk && (
- ((okType != 0) && (okType !=
- pb.hFileInfo.ioFlFndrInfo.fdType)) ||
+ if (((okType != 0) && (okType !=
+ fileInfo.ioFlFndrInfo.fdType)) ||
((okCreator != 0) && (okCreator !=
- pb.hFileInfo.ioFlFndrInfo.fdCreator)))) {
- typeOk = 0;
- }
- }
- if (typeOk) {
- if ((fnameLen > 1) && (strchr(fname+1, ':') == NULL)) {
- Tcl_ListObjAppendElement(interp, resultPtr,
- Tcl_NewStringObj(fname+1, fnameLen-1));
- } else {
- Tcl_ListObjAppendElement(interp, resultPtr, tempName);
+ fileInfo.ioFlFndrInfo.fdCreator))) {
+ return 0;
}
}
- /*
- * This will free the object, unless it was inserted in
- * the result list above.
- */
- Tcl_DecrRefCount(tempName);
- }
- Tcl_DStringFree(&fileString);
- itemIndex++;
- }
-
- Tcl_DStringFree(&dsOrig);
- return result;
+ return 1
}
+
/*
*----------------------------------------------------------------------
Index: tests/cmdAH.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/cmdAH.test,v
retrieving revision 1.17
diff -b -u -r1.17 cmdAH.test
--- tests/cmdAH.test 27 Nov 2001 14:12:35 -0000 1.17
+++ tests/cmdAH.test 16 Mar 2002 17:23:31 -0000
@@ -1496,14 +1496,18 @@
# type
-file delete link.file
-
test cmdAH-29.1 {Tcl_FileObjCmd: type} {
list [catch {file size a b} msg] $msg
} {1 {wrong # args: should be "file size name"}}
test cmdAH-29.2 {Tcl_FileObjCmd: type} {
file type dir.file
} directory
+test cmdAH-29.3.0 {Tcl_FileObjCmd: delete removes link not file} {
+ set exists [list [file exists link.file] [file exists gorp.file]]
+ file delete link.file
+ set exists2 [list [file exists link.file] [file exists gorp.file]]
+ list $exists $exists2
+} {{1 1} {0 1}}
test cmdAH-29.3 {Tcl_FileObjCmd: type} {
file type gorp.file
} file
Index: tests/fileName.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/fileName.test,v
retrieving revision 1.16
diff -b -u -r1.16 fileName.test
--- tests/fileName.test 23 Nov 2001 01:26:06 -0000 1.16
+++ tests/fileName.test 16 Mar 2002 17:23:34 -0000
@@ -1428,9 +1428,36 @@
test filename-12.1 {simple globbing} {unixOrPc} {
list [catch {glob {}} msg] $msg
} {0 .}
+test filename-12.1.1 {simple globbing} {unixOrPc} {
+ list [catch {glob -types f {}} msg] $msg
+} {1 {no files matched glob pattern ""}}
+test filename-12.1.2 {simple globbing} {unixOrPc} {
+ list [catch {glob -types d {}} msg] $msg
+} {0 .}
+test filename-12.1.3 {simple globbing} {unixOnly} {
+ list [catch {glob -types hidden {}} msg] $msg
+} {0 .}
+test filename-12.1.4 {simple globbing} {unixpcOnly} {
+ list [catch {glob -types hidden {}} msg] $msg
+} {1 {no files matched glob pattern ""}}
+test filename-12.1.5 {simple globbing} {pcOnly} {
+ list [catch {glob -types hidden c:/} msg] $msg
+} {1 {no files matched glob pattern "c:/"}}
+test filename-12.1.6 {simple globbing} {pcOnly} {
+ list [catch {glob c:/} msg] $msg
+} {0 c:/}
test filename-12.2 {simple globbing} {macOnly} {
list [catch {glob {}} msg] $msg
} {0 :}
+test filename-12.2.1 {simple globbing} {macOnly} {
+ list [catch {glob -types f {}} msg] $msg
+} {1 {no files matched glob pattern ""}}
+test filename-12.2.2 {simple globbing} {macOnly} {
+ list [catch {glob -types d {}} msg] $msg
+} {0 :}
+test filename-12.2.3 {simple globbing} {macOnly} {
+ list [catch {glob -types hidden {}} msg] $msg
+} {1 {no files matched glob pattern ""}}
test filename-12.3 {simple globbing} {
list [catch {glob -nocomplain \{a1,a2\}} msg] $msg
} {0 {}}
Index: tests/winFCmd.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/winFCmd.test,v
retrieving revision 1.15
diff -b -u -r1.15 winFCmd.test
--- tests/winFCmd.test 19 Nov 2001 17:45:12 -0000 1.15
+++ tests/winFCmd.test 16 Mar 2002 17:23:37 -0000
@@ -840,7 +840,7 @@
close [open td1 w]
list [catch {file attributes td1 -system} msg] $msg [cleanup]
} {0 0 {}}
-test winfcmd-11.5 {GetWinFileAttributes} {pcOnly} {
+test winFCmd-11.5 {GetWinFileAttributes} {pcOnly} {
# attr of relative paths that resolve to root was failing
# don't care about answer, just that test runs.
@@ -851,6 +851,9 @@
file attr .
cd $old
} {}
+test winFCmd-11.6 {GetWinFileAttributes} {pcOnly} {
+ file attr c:/ -hidden
+} {0}
test winFCmd-12.1 {ConvertFileNameFormat} {pcOnly} {
cleanup
Index: unix/tclUnixFCmd.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclUnixFCmd.c,v
retrieving revision 1.17
diff -b -u -r1.17 tclUnixFCmd.c
--- unix/tclUnixFCmd.c 15 Feb 2002 14:28:50 -0000 1.17
+++ unix/tclUnixFCmd.c 16 Mar 2002 17:23:44 -0000
@@ -1618,17 +1618,17 @@
* TclpObjNormalizePath --
*
* This function scans through a path specification and replaces
- * it, in place, with a normalized version. On unix, this simply
- * ascertains where the valid path ends, and makes no change in
- * place.
+ * it, in place, with a normalized version. A normalized version
+ * is one in which all symlinks in the path are replaced with
+ * their expanded form (except a symlink at the very end of the
+ * path).
*
* Results:
* The new 'nextCheckpoint' value, giving as far as we could
* understand in the path.
*
* Side effects:
- * The pathPtr string, which must contain a valid path, is
- * not modified (unlike Windows, MacOS versions).
+ * The pathPtr string, is modified.
*
*---------------------------------------------------------------------------
*/
@@ -1640,13 +1640,15 @@
int nextCheckpoint;
{
char *currentPathEndPosition;
- char *path = Tcl_GetString(pathPtr);
+ int pathLen;
+ char cur;
+ char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
currentPathEndPosition = path + nextCheckpoint;
while (1) {
- char cur = *currentPathEndPosition;
- if ((cur == '/' || cur == 0) && (path != currentPathEndPosition)) {
+ cur = *currentPathEndPosition;
+ if ((cur == '/') && (path != currentPathEndPosition)) {
/* Reached directory separator, or end of string */
Tcl_DString ds;
CONST char *nativePath;
@@ -1660,13 +1662,59 @@
/* File doesn't exist */
break;
}
- if (cur == 0) {
+ /* Update the acceptable point */
+ nextCheckpoint = currentPathEndPosition - path;
+ } else if (cur == 0) {
break;
}
- }
currentPathEndPosition++;
}
- nextCheckpoint = currentPathEndPosition - path;
- /* We should really now convert this to a canonical path */
+ /*
+ * We should really now convert this to a canonical path. We do
+ * that with 'realpath' if we have it available. Otherwise we could
+ * step through every single path component, checking whether it is a
+ * symlink, but that would be a lot of work, and most modern OSes
+ * have 'realpath'.
+ */
+#ifndef NO_REALPATH
+ if (1) {
+ char normPath[MAXPATHLEN];
+ Tcl_DString ds;
+ CONST char *nativePath = Tcl_UtfToExternalDString(NULL, path,
+ nextCheckpoint, &ds);
+
+ if (realpath((char *) nativePath, normPath) != NULL) {
+ /*
+ * Free up the native path and put in its place the
+ * converted, normalized path.
+ */
+ Tcl_DStringFree(&ds);
+ Tcl_ExternalToUtfDString(NULL,normPath,
+ strlen(normPath),&ds);
+
+ if (path[nextCheckpoint] != '\0') {
+ /* not at end, append remaining path */
+ int normLen = Tcl_DStringLength(&ds);
+ Tcl_DStringAppend(&ds, path + nextCheckpoint,
+ pathLen - nextCheckpoint);
+ /*
+ * We recognise up to and including the directory
+ * separator.
+ */
+ nextCheckpoint = normLen + 1;
+ } else {
+ /* We recognise the whole string */
+ nextCheckpoint = Tcl_DStringLength(&ds);
+ }
+ /*
+ * Overwrite with the normalized path.
+ */
+ Tcl_SetStringObj(pathPtr,Tcl_DStringValue(&ds),
+ Tcl_DStringLength(&ds));
+ }
+ Tcl_DStringFree(&ds);
+ }
+#endif /* !NO_REALPATH */
+
return nextCheckpoint;
}
Index: unix/tclUnixFile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclUnixFile.c,v
retrieving revision 1.18
diff -b -u -r1.18 tclUnixFile.c
--- unix/tclUnixFile.c 15 Feb 2002 14:28:50 -0000 1.18
+++ unix/tclUnixFile.c 16 Mar 2002 17:23:44 -0000
@@ -15,6 +15,8 @@
#include "tclInt.h"
#include "tclPort.h"
+static int NativeMatchType(CONST char* nativeName, Tcl_GlobTypeData *types);
+
/*
*---------------------------------------------------------------------------
@@ -205,7 +207,23 @@
* May be NULL. In particular the directory
* flag is very important. */
{
- CONST char *native, *fname, *dirName;
+ CONST char *native;
+ Tcl_Obj *fileNamePtr;
+
+ fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
+ if (fileNamePtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (pattern == NULL || (*pattern == '\0')) {
+ /* Match a file directly */
+ CONST char *native = (CONST char*) Tcl_FSGetNativePath(pathPtr);
+ if (NativeMatchType(native, types)) {
+ Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
+ }
+ return TCL_OK;
+ } else {
+ CONST char *fname, *dirName;
DIR *d;
Tcl_DString ds;
Tcl_StatBuf statBuf;
@@ -213,13 +231,8 @@
int nativeDirLen;
int result = TCL_OK;
Tcl_DString dsOrig;
- Tcl_Obj *fileNamePtr;
int baseLength;
- fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
- if (fileNamePtr == NULL) {
- return TCL_ERROR;
- }
Tcl_DStringInit(&dsOrig);
Tcl_DStringAppend(&dsOrig, Tcl_GetString(fileNamePtr), -1);
baseLength = Tcl_DStringLength(&dsOrig);
@@ -333,15 +346,42 @@
Tcl_DStringAppend(&dsOrig, utf, -1);
fname = Tcl_DStringValue(&dsOrig);
if (types != NULL) {
- Tcl_StatBuf buf;
char *nativeEntry;
Tcl_DStringSetLength(&ds, nativeDirLen);
nativeEntry = Tcl_DStringAppend(&ds, entryPtr->d_name, -1);
+ typeOk = NativeMatchType(nativeEntry, types);
+ }
+ if (typeOk) {
+ Tcl_ListObjAppendElement(interp, resultPtr,
+ Tcl_NewStringObj(fname, Tcl_DStringLength(&dsOrig)));
+ }
+ }
+ Tcl_DStringFree(&utfDs);
+ }
+
+ closedir(d);
+ Tcl_DStringFree(&ds);
+ Tcl_DStringFree(&dsOrig);
+ return result;
+ }
+}
+static int
+NativeMatchType(
+ CONST char* nativeEntry, /* Native path to check */
+ Tcl_GlobTypeData *types) /* Type description to match against */
+{
+ Tcl_StatBuf buf;
+ if (types == NULL) {
/*
- * The native name of the file is in entryPtr->d_name.
- * We can use this below.
+ * Simply check for the file's existence, but do it
+ * with lstat, in case it is a link to a file which
+ * doesn't exist (since that case would not show up
+ * if we used 'access' or 'stat')
*/
-
+ if (Tcl_PlatformLStat(nativeEntry, &buf) != 0) {
+ return 0;
+ }
+ } else {
if (types->perm != 0) {
if (Tcl_PlatformStat(nativeEntry, &buf) != 0) {
/*
@@ -355,15 +395,14 @@
* permission, and therefore it is not
* added to the list of files to return.
*/
- typeOk = 0;
+ return 0;
}
/*
* readonly means that there are NO write permissions
* (even for user), but execute is OK for anybody
*/
- if (typeOk && (
- ((types->perm & TCL_GLOB_PERM_RONLY) &&
+ if (((types->perm & TCL_GLOB_PERM_RONLY) &&
(buf.st_mode & (S_IWOTH|S_IWGRP|S_IWUSR))) ||
((types->perm & TCL_GLOB_PERM_R) &&
(access(nativeEntry, R_OK) != 0)) ||
@@ -371,19 +410,18 @@
(access(nativeEntry, W_OK) != 0)) ||
((types->perm & TCL_GLOB_PERM_X) &&
(access(nativeEntry, X_OK) != 0))
- )) {
- typeOk = 0;
+ ) {
+ return 0;
}
}
- if (typeOk && (types->type != 0)) {
+ if (types->type != 0) {
if (types->perm == 0) {
/* We haven't yet done a stat on the file */
if (Tcl_PlatformStat(nativeEntry, &buf) != 0) {
/* Posix error occurred */
- typeOk = 0;
+ return 0;
}
}
- if (typeOk) {
/*
* In order bcdpfls as in 'find -t'
*/
@@ -398,37 +436,27 @@
S_ISFIFO(buf.st_mode)) ||
((types->type & TCL_GLOB_TYPE_FILE) &&
S_ISREG(buf.st_mode))
-#ifdef S_ISSOCK
+ #ifdef S_ISSOCK
|| ((types->type & TCL_GLOB_TYPE_SOCK) &&
S_ISSOCK(buf.st_mode))
-#endif
+ #endif
) {
/* Do nothing -- this file is ok */
} else {
- typeOk = 0;
-#ifdef S_ISLNK
- if ((types->type & TCL_GLOB_TYPE_LINK)
- && Tcl_PlatformLStat(nativeEntry, &buf)==0
- && S_ISLNK(buf.st_mode)) {
- typeOk = 1;
+ #ifdef S_ISLNK
+ if (types->type & TCL_GLOB_TYPE_LINK) {
+ if (Tcl_PlatformLStat(nativeEntry, &buf) == 0) {
+ if (S_ISLNK(buf.st_mode)) {
+ return 1;
}
-#endif
}
}
+ #endif
+ return 0;
}
}
- if (typeOk) {
- Tcl_ListObjAppendElement(interp, resultPtr,
- Tcl_NewStringObj(fname, Tcl_DStringLength(&dsOrig)));
- }
- }
- Tcl_DStringFree(&utfDs);
}
-
- closedir(d);
- Tcl_DStringFree(&ds);
- Tcl_DStringFree(&dsOrig);
- return result;
+ return 1;
}
/*
@@ -553,12 +581,7 @@
Tcl_Obj *pathPtr; /* Path of file to stat */
Tcl_StatBuf *bufPtr; /* Filled with results of stat call. */
{
- CONST char *path = Tcl_FSGetNativePath(pathPtr);
- if (path == NULL) {
- return -1;
- } else {
- return Tcl_PlatformLStat(path, bufPtr);
- }
+ return Tcl_PlatformLStat(Tcl_FSGetNativePath(pathPtr), bufPtr);
}
/*
Index: win/tclWinFCmd.c
===================================================================
RCS file: /cvsroot/tcl/tcl/win/tclWinFCmd.c,v
retrieving revision 1.27
diff -b -u -r1.27 tclWinFCmd.c
--- win/tclWinFCmd.c 15 Mar 2002 01:10:19 -0000 1.27
+++ win/tclWinFCmd.c 16 Mar 2002 17:23:49 -0000
@@ -872,8 +872,6 @@
* DString filled with UTF-8 name of file
* causing error. */
{
- DWORD attr;
-
/*
* The RemoveDirectory API acts differently under Win95/98 and NT
* WRT NULL and "". Avoid passing these values.
@@ -890,7 +888,7 @@
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
- attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
+ DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
if (attr != 0xffffffff) {
if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
/*
@@ -1234,8 +1232,6 @@
Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled
* with UTF-8 name of file causing error. */
{
- DWORD attr;
-
switch (type) {
case DOTREE_F: {
if (DoCopyFile(nativeSrc, nativeDst) == TCL_OK) {
@@ -1245,7 +1241,7 @@
}
case DOTREE_PRED: {
if (DoCreateDirectory(nativeDst) == TCL_OK) {
- attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
+ DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
if ((*tclWinProcs->setFileAttributesProc)(nativeDst, attr) != FALSE) {
return TCL_OK;
}
@@ -1380,6 +1376,7 @@
{
DWORD result;
CONST TCHAR *nativeName;
+ int attr;
nativeName = Tcl_FSGetNativePath(fileName);
result = (*tclWinProcs->getFileAttributesProc)(nativeName);
@@ -1389,7 +1386,34 @@
return TCL_ERROR;
}
- *attributePtrPtr = Tcl_NewBooleanObj((int) (result & attributeArray[objIndex]));
+ attr = (int)(result & attributeArray[objIndex]);
+ if ((objIndex == WIN_HIDDEN_ATTRIBUTE) && (attr != 0)) {
+ /*
+ * It is hidden. However there is a bug on some Windows
+ * OSes in which root volumes (drives) formatted as NTFS
+ * are declared hidden when they are not (and cannot be).
+ *
+ * We test for, and fix that case, here.
+ */
+ int len;
+ char *str = Tcl_GetStringFromObj(fileName,&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 */
+ attr = 0;
+ } else if ((str[1] == ':')
+ && (len == 2 || (str[2] == '/' || str[2] == '\\'))) {
+ /* Path is of the form 'x:' or 'x:/' or 'x:\' */
+ attr = 0;
+ }
+ }
+ }
+ *attributePtrPtr = Tcl_NewBooleanObj(attr);
return TCL_OK;
}
Index: win/tclWinFile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/win/tclWinFile.c,v
retrieving revision 1.26
diff -b -u -r1.26 tclWinFile.c
--- win/tclWinFile.c 15 Feb 2002 14:28:51 -0000 1.26
+++ win/tclWinFile.c 16 Mar 2002 17:23:53 -0000
@@ -33,6 +33,8 @@
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);
/*
@@ -119,6 +121,33 @@
* May be NULL. In particular the directory
* flag is very important. */
{
+ 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;
+ }
+ }
+ /* 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[] = "?:\\";
const char *message;
CONST char *dir;
@@ -132,7 +161,6 @@
Tcl_DString ds;
Tcl_DString dsOrig;
Tcl_Obj *fileNamePtr;
- CONST TCHAR *nativeName;
int matchSpecialDots;
/*
@@ -272,8 +300,6 @@
CONST TCHAR *nativeMatchResult;
CONST char *name, *fname;
- int typeOk = 1;
-
if (tclWinProcs->useWide) {
nativeName = (CONST TCHAR *) data.w.cFileName;
} else {
@@ -323,6 +349,48 @@
fname = Tcl_DStringValue(&dsOrig);
nativeName = Tcl_WinUtfToTChar(fname, Tcl_DStringLength(&dsOrig), &ds);
+ if (NativeMatchType(0, nativeName, types)) {
+ Tcl_ListObjAppendElement(interp, resultPtr,
+ Tcl_NewStringObj(fname, Tcl_DStringLength(&dsOrig)));
+ }
+ /*
+ * Free ds here to ensure that nativeName is valid above.
+ */
+
+ Tcl_DStringFree(&ds);
+
+ Tcl_DStringSetLength(&dsOrig, dirLength);
+ }
+
+ FindClose(handle);
+ Tcl_DStringFree(&dirString);
+ Tcl_DStringFree(&dsOrig);
+
+ return TCL_OK;
+
+ error:
+ Tcl_DStringFree(&dirString);
+ TclWinConvertError(GetLastError());
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, message, Tcl_DStringValue(&dsOrig), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ Tcl_DStringFree(&dsOrig);
+ return TCL_ERROR;
+ }
+
+}
+
+/*
+ * 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 TCHAR* nativeName, /* Native path to check */
+ Tcl_GlobTypeData *types) /* Type description to match against */
+{
/*
* 'attr' represents the attributes of the file, but we only
* want to retrieve this info if it is absolutely necessary
@@ -332,27 +400,32 @@
* look into.
*/
- attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
+ DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
+ if (attr == 0xffffffff) {
+ /* File doesn't exist */
+ return 0;
+ }
+
if (types == NULL) {
/* If invisible, don't return the file */
- if (attr & FILE_ATTRIBUTE_HIDDEN) {
- typeOk = 0;
+ if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) {
+ return 0;
}
} else {
- if (attr & FILE_ATTRIBUTE_HIDDEN) {
+ if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) {
/* If invisible */
if ((types->perm == 0) ||
!(types->perm & TCL_GLOB_PERM_HIDDEN)) {
- typeOk = 0;
+ return 0;
}
} else {
/* Visible */
if (types->perm & TCL_GLOB_PERM_HIDDEN) {
- typeOk = 0;
+ return 0;
}
}
- if (typeOk == 1 && types->perm != 0) {
+ if (types->perm != 0) {
if (
((types->perm & TCL_GLOB_PERM_RONLY) &&
!(attr & FILE_ATTRIBUTE_READONLY)) ||
@@ -363,10 +436,10 @@
((types->perm & TCL_GLOB_PERM_X) &&
(NativeAccess(nativeName, X_OK) != 0))
) {
- typeOk = 0;
+ return 0;
}
}
- if (typeOk && types->type != 0) {
+ if (types->type != 0) {
Tcl_StatBuf buf;
if (NativeStat(nativeName, &buf) != 0) {
@@ -376,9 +449,8 @@
* strange error. In any case we don't
* return this file.
*/
- typeOk = 0;
+ return 0;
}
- if (typeOk) {
/*
* In order bcdpfls as in 'find -t'
*/
@@ -400,7 +472,6 @@
) {
/* Do nothing -- this file is ok */
} else {
- typeOk = 0;
#ifdef S_ISLNK
if (types->type & TCL_GLOB_TYPE_LINK) {
/*
@@ -409,42 +480,16 @@
*/
if (NativeStat(nativeName, &buf) == 0) {
if (S_ISLNK(buf.st_mode)) {
- typeOk = 1;
+ return 1;
}
}
}
#endif
+ return 0;
}
}
}
- }
- if (typeOk) {
- Tcl_ListObjAppendElement(interp, resultPtr,
- Tcl_NewStringObj(fname, Tcl_DStringLength(&dsOrig)));
- }
- /*
- * Free ds here to ensure that nativeName is valid above.
- */
-
- Tcl_DStringFree(&ds);
-
- Tcl_DStringSetLength(&dsOrig, dirLength);
- }
-
- FindClose(handle);
- Tcl_DStringFree(&dirString);
- Tcl_DStringFree(&dsOrig);
-
- return TCL_OK;
-
- error:
- Tcl_DStringFree(&dirString);
- TclWinConvertError(GetLastError());
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, message, Tcl_DStringValue(&dsOrig), "\": ",
- Tcl_PosixError(interp), (char *) NULL);
- Tcl_DStringFree(&dsOrig);
- return TCL_ERROR;
+ return 1;
}
/*
