diff options
| -rw-r--r-- | ChangeLog | 38 | ||||
| -rw-r--r-- | changes | 7 | ||||
| -rw-r--r-- | doc/FileSystem.3 | 108 | ||||
| -rw-r--r-- | doc/file.n | 70 | ||||
| -rw-r--r-- | generic/tcl.h | 21 | ||||
| -rw-r--r-- | generic/tclFCmd.c | 9 | ||||
| -rw-r--r-- | generic/tclFileName.c | 31 | ||||
| -rw-r--r-- | generic/tclIOUtil.c | 62 | ||||
| -rw-r--r-- | generic/tclTest.c | 12 | ||||
| -rw-r--r-- | mac/tclMacFile.c | 426 | ||||
| -rw-r--r-- | tests/cmdAH.test | 10 | ||||
| -rw-r--r-- | tests/fileName.test | 29 | ||||
| -rw-r--r-- | tests/fileSystem.test | 157 | ||||
| -rw-r--r-- | tests/winFCmd.test | 7 | ||||
| -rw-r--r-- | unix/tclUnixFCmd.c | 80 | ||||
| -rw-r--r-- | unix/tclUnixFile.c | 415 | ||||
| -rw-r--r-- | win/tclWinFCmd.c | 42 | ||||
| -rw-r--r-- | win/tclWinFile.c | 611 | ||||
| -rw-r--r-- | win/tclWinPipe.c | 4 |
19 files changed, 1348 insertions, 791 deletions
@@ -1,3 +1,41 @@ +2002-03-24 Vince Darley <vincentdarley@users.sourceforge.net> + + * generic/tclFilename.c: + * generic/tclFCmd.c: + * generic/tclTest.c: + * generic/tcl.h: + * generic/tclIOUtil.c: + * win/tclWinFile.c: + * win/tclWinFCmd.c: + * win/tclWinPipe.c: + * unix/tclUnixFile.c: + * unix/tclUnixFCmd.c: + * mac/tclMacFile.c: + * doc/FileSystem.3: + * doc/file.n: + * tests/cmdAH.test: + * tests/fileName.test: + * tests/fileSystem.test: (new file) + * tests/winFCmd.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, and 'file normalize' which + wasn't very clear before. Removed inconsistency betweens + docs and the Tcl_Filesystem structure. Also fixed + [Bug 523217] and corrected file normalization on Unix so that + it expands symbolic links. Added some new tests of the + filesystem code (in the new file 'fileSystem.test'), and + some extra tests for correct handling of symbolic links. + Fix to [Bug 530960] which shows up on Win98. Made comparison + with ".com" case insensitive in tclWinPipe.c + + ***POTENTIAL INCOMPATIBILITY***: But only between alpha + releases (users of the new Tcl_Filesystem lookup table in Tcl + 8.4a4 need to handle the new way in which Tcl may call + Tcl_FSMatchInDirectory, and 'file normalize' on unix now + behaves correctly). Only known impact is with the 'tclvfs' + extension. + 2002-03-22 Miguel Sofer <msofer@users.sourceforge.net> * tests/basic.test (basic-46.1): adding test for [Bug 533758], @@ -1,6 +1,6 @@ Recent user-visible changes to Tcl: -RCS: @(#) $Id: changes,v 1.66 2002/03/04 23:12:25 hobbs Exp $ +RCS: @(#) $Id: changes,v 1.67 2002/03/24 11:41:48 vincentdarley Exp $ 1. No more [command1] [command2] construct for grouping multiple commands on a single command line. @@ -5139,8 +5139,9 @@ characters. (hobbs, riefenstahl) 2001-07-18 (bug fix)[427196] corrected memory overwrite error when buffer size of a channel is changed after channel use has already begun (kupries, porter) -2001-07-31 (new feature)[TIP 17] TclFS* APIs provide new virtual file system -(darley) +2001-07-31 (new feature)[TIP 17] TclFS* APIs provide new virtual file +system. This includes the addition of 'file normalize', 'file system', +'file separator' and 'glob -tails' (darley) 2001-08-06 (bug fix) removed use of tmpnam in TclpCreateTempFile on Unix (lim) diff --git a/doc/FileSystem.3 b/doc/FileSystem.3 index cbfa25b..d504b64 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.19 2002/02/15 14:28:47 dkf Exp $ +'\" RCS: @(#) $Id: FileSystem.3,v 1.20 2002/03/24 11:41:48 vincentdarley Exp $ '\" .so man.macros .TH Filesystem 3 8.4 Tcl "Tcl Library Procedures" @@ -495,7 +495,11 @@ string value can be used as a unique identifier for the file. .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 @@ -518,7 +522,7 @@ be left in the interpreter. path object, in the given filesystem. If the path object belongs to a different filesystem, we return NULL. If the internal representation is currently NULL, we attempt to generate it, by calling the filesystem's -\fBTclfsConvertToInternalProc_\fR. +\fBTcl_FSCreateInternalRepProc\fR. .PP Returns NULL or a valid internal path representation. This internal representation is cached, so that repeated calls to this function will @@ -529,12 +533,14 @@ from the given Tcl_Obj. .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 @@ -545,7 +551,15 @@ a Utf-8 string representation if that is required by some Tcl code. .PP \fBTcl_FSGetNativePath\fR is for use by the Win/Unix/MacOS native filesystems, so that they can easily retrieve the native (char* or -TCHAR*) representation of a path. +TCHAR*) representation of a path. This function is a convenience +wrapper around \fBTcl_FSGetInternalRep\fR, and assumes the native +representation is string-based. It may be desirable in the future +to have non-string-based native representations (for example, on +MacOS, a representation using a fileSpec of FSRef structure would +probably be more efficient). On Windows a full Unicode +representation would allow for paths of unlimited length. Currently +the representation is simply a character string containing the +complete, absolute path in the native encoding. .PP The native representation is cached so that repeated calls to this function will not require additional conversions. @@ -666,10 +680,62 @@ functions (it will use \fITcl_FSCopyFileProc\fR followed by \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 +834,13 @@ string representation. Depending on the filesystem, 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 +981,13 @@ typedef int Tcl_FSMatchInDirectoryProc( .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, @@ -919,7 +995,10 @@ but on a TCL_OK result, the interpreter should not be modified, but rather results should be added to the \fIresult\fR object given (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). +(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 +1243,8 @@ than the Tcl level 'file copy' subcommand). 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 @@ -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.13 2001/12/10 15:50:47 dgp Exp $ +'\" RCS: @(#) $Id: file.n,v 1.14 2002/03/24 11:41:48 vincentdarley Exp $ '\" .so man.macros .TH file n 8.3 Tcl "Tcl Built-In Commands" @@ -110,17 +110,20 @@ treated as a \fIsource\fR even if it starts with a \fB\-\fR. .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, -even if the \fB\-force\fR flags is not specified. If the \fB\-force\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. 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 @@ -223,15 +226,27 @@ under Windows or AppleScript on the Macintosh. .TP \fBfile normalize \fIname\fR . -Returns a unique normalised path representation for the file, whose -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 -95/98) with that form's case-dependence (which gives us a unique, -case-dependent path). +Returns a unique normalised path representation for the file-system +object (file, directory, link, etc), whose string value can be used as +a unique identifier for 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 +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). 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). +.PP +Note that this means normalized paths are different on old Windows +operating systems (95/98) and new Windows operating systems +(NT/2000/XP). This is necessary because the APIs +to produce a long normalized path in older operating systems are +unfortunately very slow. .TP \fBfile owned \fIname\fR . @@ -267,12 +282,14 @@ support symbolic links this option is undefined. 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. @@ -331,7 +348,8 @@ empty string. \fBfile system \fIname\fR . Returns a list of two elements, the first of which is the name of the -filesystem to use for the file, and the second the type of the file +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 diff --git a/generic/tcl.h b/generic/tcl.h index d5f4bd3..fbac80c 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.121 2002/03/20 22:47:36 dgp Exp $ + * RCS: @(#) $Id: tcl.h,v 1.122 2002/03/24 11:41:48 vincentdarley Exp $ */ #ifndef _TCL @@ -1788,28 +1788,31 @@ typedef struct Tcl_Filesystem { * '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 diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 61d4df2..cc920ce 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.16 2002/02/15 14:28:49 dkf Exp $ + * RCS: @(#) $Id: tclFCmd.c,v 1.17 2002/03/24 11:41:50 vincentdarley Exp $ */ #include "tclInt.h" @@ -716,10 +716,9 @@ FileForceOption(interp, objc, objv, forcePtr) * 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. diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 28cd1e2..0e184de 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.32 2002/02/27 06:39:16 hobbs Exp $ + * RCS: @(#) $Id: tclFileName.c,v 1.33 2002/03/24 11:41:50 vincentdarley Exp $ */ #include "tclInt.h" @@ -2454,21 +2454,18 @@ TclDoGlob(interp, separators, headPtr, tail, types) 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 @@ TclDoGlob(interp, separators, headPtr, tail, types) 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; } diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 2172bfd..9432c8f 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.36 2002/02/15 23:42:12 kennykb Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.37 2002/03/24 11:41:50 vincentdarley Exp $ */ #include "tclInt.h" @@ -397,10 +397,10 @@ static Tcl_Filesystem nativeFilesystem = { &TclpObjCreateDirectory, &TclpObjRemoveDirectory, &TclpObjDeleteFile, - &TclpObjLstat, &TclpObjCopyFile, &TclpObjRenameFile, &TclpObjCopyDirectory, + &TclpObjLstat, &TclpLoadFile, &TclpObjGetCwd, &TclpObjChdir @@ -1651,6 +1651,10 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) * write, since they can assume the pathPtr passed to them * 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: * @@ -1703,10 +1707,14 @@ Tcl_FSMatchInDirectory(interp, result, pathPtr, pattern, types) } } /* - * 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) { @@ -1723,11 +1731,7 @@ Tcl_FSMatchInDirectory(interp, result, pathPtr, pattern, types) int cwdLen; Tcl_Obj *cwdDir; char *cwdStr; -#ifdef MAC_TCL - char sep = ':'; -#else - char sep = '/'; -#endif + char sep = 0; Tcl_Obj* tmpResultPtr = Tcl_NewListObj(0, NULL); /* * We know the cwd is a normalised object which does @@ -1744,10 +1748,33 @@ Tcl_FSMatchInDirectory(interp, result, pathPtr, pattern, types) cwdDir = Tcl_DuplicateObj(cwd); Tcl_IncrRefCount(cwdDir); cwdStr = Tcl_GetStringFromObj(cwdDir, &cwdLen); - if (cwdStr[cwdLen-1] != sep) { + /* + * Should we perhaps use 'Tcl_FSPathSeparator'? + * But then what about the Windows special case? + * Perhaps we should just check if cwd is a root + * volume. + */ + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + if (cwdStr[cwdLen-1] != '/') { + sep == '/'; + } + break; + case TCL_PLATFORM_WINDOWS: + if (cwdStr[cwdLen-1] != '/' && cwdStr[cwdLen-1] != '\\') { + sep = '/'; + } + break; + case TCL_PLATFORM_MAC: + if (cwdStr[cwdLen-1] != ':') { + sep = ':'; + } + break; + } + if (sep != 0) { Tcl_AppendToObj(cwdDir, &sep, 1); cwdLen++; - /* Note: cwdStr may no longer be a valid pointer */ + /* Note: cwdStr may no longer be a valid pointer now */ } ret = (*proc)(interp, tmpResultPtr, cwdDir, pattern, types); Tcl_DecrRefCount(cwdDir); @@ -3682,6 +3709,11 @@ SetFsPathFromAny(interp, objPtr) * and that path is to be used at the Tcl level, then calling * 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 +3773,8 @@ Tcl_FSNewNativePath(fromFilesystem, clientData) 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 +4608,7 @@ Tcl_FSGetFileSystemForPath(pathObjPtr) * 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. diff --git a/generic/tclTest.c b/generic/tclTest.c index 5aeff82..128b390 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -13,7 +13,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.47 2002/03/07 20:17:22 dgp Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.48 2002/03/24 11:41:50 vincentdarley Exp $ */ #define TCL_TEST @@ -409,10 +409,10 @@ static Tcl_Filesystem testReportingFilesystem = { &TestReportCreateDirectory, &TestReportRemoveDirectory, &TestReportDeleteFile, - &TestReportLstat, &TestReportCopyFile, &TestReportRenameFile, &TestReportCopyDirectory, + &TestReportLstat, &TestReportLoadFile, NULL /* cwd */, &TestReportChdir @@ -5658,10 +5658,15 @@ TestReport(cmd, path, arg2) if (interp == NULL) { /* This is bad, but not much we can do about it */ } else { + /* + * No idea why I decided to program this up using the + * old string-based API, but there you go. We should + * convert it to objects. + */ Tcl_SavedResult savedResult; Tcl_DString ds; Tcl_DStringInit(&ds); - Tcl_DStringAppend(&ds, "puts stderr ",-1); + Tcl_DStringAppend(&ds, "lappend filesystemReport ",-1); Tcl_DStringStartSublist(&ds); Tcl_DStringAppendElement(&ds, cmd); if (path != NULL) { @@ -5677,6 +5682,7 @@ TestReport(cmd, path, arg2) Tcl_RestoreResult(interp, &savedResult); } } + static int TestReportStat(path, buf) Tcl_Obj *path; /* Path of file to stat (in current CP). */ diff --git a/mac/tclMacFile.c b/mac/tclMacFile.c index fe26027..7bea890 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.17 2002/02/15 14:28:49 dkf Exp $ + * RCS: @(#) $Id: tclMacFile.c,v 1.18 2002/03/24 11:41:50 vincentdarley Exp $ */ /* @@ -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,87 +130,22 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) 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. */ { - char *fname; - int fnameLen, result = TCL_OK; - int baseLength; - CInfoPBRec pb; - OSErr err; - FSSpec dirSpec; - Boolean isDirectory; - long dirID; - 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); - - /* - * Make sure that the directory part of the name really is a - * directory. - */ - - Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&dsOrig), - Tcl_DStringLength(&dsOrig), &fileString); - - err = FSpLocationFromPath(Tcl_DStringLength(&fileString), - Tcl_DStringValue(&fileString), &dirSpec); - Tcl_DStringFree(&fileString); - if (err == noErr) - err = FSpGetDirectoryID(&dirSpec, &dirID, &isDirectory); - if ((err != noErr) || !isDirectory) { - /* - * Check if we had a relative path (unix style relative path - * compatibility for glob) - */ - Tcl_DStringFree(&dsOrig); - Tcl_DStringAppend(&dsOrig, ":", 1); - Tcl_DStringAppend(&dsOrig, Tcl_GetString(fileNamePtr), -1); - baseLength = Tcl_DStringLength(&dsOrig); - - Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&dsOrig), - Tcl_DStringLength(&dsOrig), &fileString); - - err = FSpLocationFromPath(Tcl_DStringLength(&fileString), - Tcl_DStringValue(&fileString), &dirSpec); - Tcl_DStringFree(&fileString); - if (err == noErr) - err = FSpGetDirectoryID(&dirSpec, &dirID, &isDirectory); - if ((err != noErr) || !isDirectory) { - Tcl_DStringFree(&dsOrig); - return TCL_OK; - } - } - - /* Make sure we have a trailing directory delimiter */ - if (Tcl_DStringValue(&dsOrig)[baseLength-1] != ':') { - Tcl_DStringAppend(&dsOrig, ":", 1); - baseLength++; - } - /* - * Now open the directory for reading and iterate over the contents. - */ - - pb.hFileInfo.ioVRefNum = dirSpec.vRefNum; - pb.hFileInfo.ioDirID = dirID; - pb.hFileInfo.ioNamePtr = (StringPtr) fileName; - pb.hFileInfo.ioFDirIndex = itemIndex = 1; - if (types != NULL) { if (types->macType != NULL) { Tcl_GetOSTypeFromObj(NULL, types->macType, &okType); @@ -218,138 +155,259 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) } } - while (1) { - pb.hFileInfo.ioFDirIndex = itemIndex; - pb.hFileInfo.ioDirID = dirID; - err = PBGetCatInfoSync(&pb); - if (err != noErr) { - break; + if (pattern == NULL || (*pattern == '\0')) { + /* Match a single file directly */ + Tcl_StatBuf buf; + CInfoPBRec paramBlock; + FSSpec fileSpec; + + if (TclpObjLstat(fileNamePtr, &buf) != 0) { + /* File doesn't exist */ + return TCL_OK; + } + + if (FspLocationFromFsPath(fileNamePtr, &fileSpec) == noErr) { + paramBlock.hFileInfo.ioCompletion = NULL; + paramBlock.hFileInfo.ioNamePtr = fileSpec.name; + paramBlock.hFileInfo.ioVRefNum = fileSpec.vRefNum; + paramBlock.hFileInfo.ioFDirIndex = 0; + paramBlock.hFileInfo.ioDirID = fileSpec.parID; + + PBGetCatInfo(¶mBlock, 0); } + if (NativeMatchType(fileNamePtr, types, paramBlock.hFileInfo, + okType, okCreator) { + int len; + char *fname = Tcl_GetStringFromObj(pathPtr,&len); + 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; + CInfoPBRec pb; + OSErr err; + FSSpec dirSpec; + Boolean isDirectory; + long dirID; + short itemIndex; + Str255 fileName; + Tcl_DString fileString; + Tcl_DString dsOrig; + + Tcl_DStringInit(&dsOrig); + Tcl_DStringAppend(&dsOrig, Tcl_GetString(fileNamePtr), -1); + baseLength = Tcl_DStringLength(&dsOrig); + /* - * Now check to see if the file matches. + * Make sure that the directory part of the name really is a + * directory. */ - - 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); - fname = Tcl_DStringValue(&dsOrig); - fnameLen = Tcl_DStringLength(&dsOrig); - - /* - * We use this tempName in calls to check the file's - * type below. We may also use it for the result. + + Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&dsOrig), + Tcl_DStringLength(&dsOrig), &fileString); + + err = FSpLocationFromPath(Tcl_DStringLength(&fileString), + Tcl_DStringValue(&fileString), &dirSpec); + Tcl_DStringFree(&fileString); + if (err == noErr) { + err = FSpGetDirectoryID(&dirSpec, &dirID, &isDirectory); + } + + if ((err != noErr) || !isDirectory) { + /* + * Check if we had a relative path (unix style relative path + * compatibility for glob) */ - tempName = Tcl_NewStringObj(fname, fnameLen); - Tcl_IncrRefCount(tempName); + Tcl_DStringFree(&dsOrig); + Tcl_DStringAppend(&dsOrig, ":", 1); + Tcl_DStringAppend(&dsOrig, Tcl_GetString(fileNamePtr), -1); + baseLength = Tcl_DStringLength(&dsOrig); - if (types == NULL) { - /* If invisible, don't return the file */ - if (pb.hFileInfo.ioFlFndrInfo.fdFlags & kIsInvisible) { - typeOk = 0; - } - } else { - Tcl_StatBuf buf; + Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&dsOrig), + Tcl_DStringLength(&dsOrig), &fileString); + + err = FSpLocationFromPath(Tcl_DStringLength(&fileString), + Tcl_DStringValue(&fileString), &dirSpec); + Tcl_DStringFree(&fileString); + if (err == noErr) { + err = FSpGetDirectoryID(&dirSpec, &dirID, &isDirectory); + } + + if ((err != noErr) || !isDirectory) { + Tcl_DStringFree(&dsOrig); + return TCL_OK; + } + } + + /* Make sure we have a trailing directory delimiter */ + if (Tcl_DStringValue(&dsOrig)[baseLength-1] != ':') { + Tcl_DStringAppend(&dsOrig, ":", 1); + baseLength++; + } + + /* + * Now open the directory for reading and iterate over the contents. + */ + + pb.hFileInfo.ioVRefNum = dirSpec.vRefNum; + pb.hFileInfo.ioDirID = dirID; + pb.hFileInfo.ioNamePtr = (StringPtr) fileName; + pb.hFileInfo.ioFDirIndex = itemIndex = 1; + + while (1) { + pb.hFileInfo.ioFDirIndex = itemIndex; + pb.hFileInfo.ioDirID = dirID; + err = PBGetCatInfoSync(&pb); + if (err != noErr) { + break; + } + + /* + * Now check to see if the file matches. + */ + + Tcl_ExternalToUtfDString(NULL, (char *) fileName + 1, fileName[0], + &fileString); + if (Tcl_StringMatch(Tcl_DStringValue(&fileString), pattern)) { + Tcl_Obj *tempName; + Tcl_DStringSetLength(&dsOrig, baseLength); + Tcl_DStringAppend(&dsOrig, Tcl_DStringValue(&fileString), -1); + fname = Tcl_DStringValue(&dsOrig); + fnameLen = Tcl_DStringLength(&dsOrig); - if (pb.hFileInfo.ioFlFndrInfo.fdFlags & kIsInvisible) { - /* If invisible */ - if ((types->perm == 0) || - !(types->perm & TCL_GLOB_PERM_HIDDEN)) { - typeOk = 0; - } - } else { - /* Visible */ - if (types->perm & TCL_GLOB_PERM_HIDDEN) { - typeOk = 0; - } - } - if (typeOk == 1 && types->perm != 0) { - if ( - ((types->perm & TCL_GLOB_PERM_RONLY) && - !(pb.hFileInfo.ioFlAttrib & 1)) || - ((types->perm & TCL_GLOB_PERM_R) && - (TclpObjAccess(tempName, R_OK) != 0)) || - ((types->perm & TCL_GLOB_PERM_W) && - (TclpObjAccess(tempName, W_OK) != 0)) || - ((types->perm & TCL_GLOB_PERM_X) && - (TclpObjAccess(tempName, X_OK) != 0)) - ) { - typeOk = 0; + /* + * We use this tempName in calls to check the file's + * type below. We may also use it for the result. + */ + 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); } } - if (typeOk == 1 && types->type != 0) { - if (TclpObjStat(tempName, &buf) != 0) { - /* Posix error occurred */ - typeOk = 0; - } - if (typeOk) { - /* - * In order bcdpfls as in 'find -t' - */ - if ( - ((types->type & TCL_GLOB_TYPE_BLOCK) && - S_ISBLK(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_CHAR) && - S_ISCHR(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_DIR) && - S_ISDIR(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_PIPE) && - S_ISFIFO(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_FILE) && - S_ISREG(buf.st_mode)) - #ifdef S_ISSOCK - || ((types->type & TCL_GLOB_TYPE_SOCK) && - S_ISSOCK(buf.st_mode)) - #endif - ) { - /* Do nothing -- this file is ok */ - } else { - typeOk = 0; - #ifdef S_ISLNK - if (types->type & TCL_GLOB_TYPE_LINK) { - if (TclpObjLstat(tempName, &buf) == 0) { - if (S_ISLNK(buf.st_mode)) { - typeOk = 1; - } - } - } - #endif + /* + * 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 (fileInfo.ioFlFndrInfo.fdFlags & kIsInvisible) { + return 0; + } + } else { + Tcl_StatBuf buf; + + if (fileInfo.ioFlFndrInfo.fdFlags & kIsInvisible) { + /* If invisible */ + if ((types->perm == 0) || + !(types->perm & TCL_GLOB_PERM_HIDDEN)) { + return 0; + } + } else { + /* Visible */ + if (types->perm & TCL_GLOB_PERM_HIDDEN) { + return 0; + } + } + if (types->perm != 0) { + if ( + ((types->perm & TCL_GLOB_PERM_RONLY) && + !(fileInfo.ioFlAttrib & 1)) || + ((types->perm & TCL_GLOB_PERM_R) && + (TclpObjAccess(tempName, R_OK) != 0)) || + ((types->perm & TCL_GLOB_PERM_W) && + (TclpObjAccess(tempName, W_OK) != 0)) || + ((types->perm & TCL_GLOB_PERM_X) && + (TclpObjAccess(tempName, X_OK) != 0)) + ) { + return 0; + } + } + if (types->type != 0) { + if (TclpObjStat(tempName, &buf) != 0) { + /* Posix error occurred */ + return 0; + } + /* + * In order bcdpfls as in 'find -t' + */ + if ( + ((types->type & TCL_GLOB_TYPE_BLOCK) && + S_ISBLK(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_CHAR) && + S_ISCHR(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_DIR) && + S_ISDIR(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_PIPE) && + S_ISFIFO(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_FILE) && + S_ISREG(buf.st_mode)) +#ifdef S_ISSOCK + || ((types->type & TCL_GLOB_TYPE_SOCK) && + S_ISSOCK(buf.st_mode)) +#endif + ) { + /* Do nothing -- this file is ok */ + } else { + int typeOk = 0; +#ifdef S_ISLNK + if (types->type & TCL_GLOB_TYPE_LINK) { + if (TclpObjLstat(tempName, &buf) == 0) { + if (S_ISLNK(buf.st_mode)) { + typeOk = 1; } } } - if (typeOk && ( - ((okType != 0) && (okType != - pb.hFileInfo.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); +#endif + if (typeOk == 0) { + return 0; } } - /* - * This will free the object, unless it was inserted in - * the result list above. - */ - Tcl_DecrRefCount(tempName); } - Tcl_DStringFree(&fileString); - itemIndex++; + if (((okType != 0) && (okType != + fileInfo.ioFlFndrInfo.fdType)) || + ((okCreator != 0) && (okCreator != + fileInfo.ioFlFndrInfo.fdCreator))) { + return 0; + } } - - Tcl_DStringFree(&dsOrig); - return result; + return 1 } + /* *---------------------------------------------------------------------- diff --git a/tests/cmdAH.test b/tests/cmdAH.test index afcc968..7c892d5 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.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: cmdAH.test,v 1.17 2001/11/27 14:12:35 dkf Exp $ +# RCS: @(#) $Id: cmdAH.test,v 1.18 2002/03/24 11:41:50 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -1496,14 +1496,18 @@ catch {unset stat} # 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 diff --git a/tests/fileName.test b/tests/fileName.test index b7616f3..9d2e50b 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.16 2001/11/23 01:26:06 das Exp $ +# RCS: @(#) $Id: fileName.test,v 1.17 2002/03/24 11:41:50 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -1428,9 +1428,36 @@ unset horribleglobname 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 {}} diff --git a/tests/fileSystem.test b/tests/fileSystem.test new file mode 100644 index 0000000..180482b --- /dev/null +++ b/tests/fileSystem.test @@ -0,0 +1,157 @@ +# This file tests the filesystem and vfs internals. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 2002 Vincent Darley. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +makeFile "test file" gorp.file +makeDirectory dir.file +makeFile "test file in directory" [file join dir.file inside.file] + +# It would be good to be able to make these work on MacOS too. +# If we added 'file link from to' we could easily do that. +catch {exec ln -s gorp.file link.file} +catch {exec ln -s inside.file dir.file/linkinside.file} +catch {exec ln -s dir.file dir.link} + +test filesystem-1.0 {link normalisation} {unixOnly} { + string equal [file normalize gorp.file] [file normalize link.file] +} {0} + +test filesystem-1.1 {link normalisation} {unixOnly} { + string equal [file normalize dir.file] [file normalize dir.link] +} {0} + +test filesystem-1.2 {link normalisation} {unixOnly} { + string equal [file normalize gorp.file/foo] [file normalize link.file/foo] +} {1} + +test filesystem-1.3 {link normalisation} {unixOnly} { + string equal [file normalize dir.file/foo] [file normalize dir.link/foo] +} {1} + +test filesystem-1.4 {link normalisation} {unixOnly} { + string equal [file normalize dir.file/inside.file] [file normalize dir.link/inside.file] +} {1} + +test filesystem-1.5 {link normalisation} {unixOnly} { + string equal [file normalize dir.file/linkinside.file] [file normalize dir.file/linkinside.file] +} {1} + +test filesystem-1.6 {link normalisation} {unixOnly} { + string equal [file normalize dir.file/linkinside.file] [file normalize dir.link/inside.file] +} {0} + +test filesystem-1.7 {link normalisation} {unixOnly} { + string equal [file normalize dir.link/linkinside.file/foo] [file normalize dir.file/inside.file/foo] +} {1} + +test filesystem-1.8 {link normalisation} {unixOnly} { + string equal [file normalize dir.file/linkinside.filefoo] [file normalize dir.link/inside.filefoo] +} {0} + +file delete -force gorp.file link.file dir.file dir.link + +test filesystem-2.0 {new native path} {unixOnly} { + foreach f [lsort [glob -nocomplain /usr/bin/c*]] { + catch {file readlink $f} + } + # If we reach here we've succeeded. We used to crash above. + expr 1 +} {1} + +# Make sure the testfilesystem hasn't been registered. +while {![catch {testfilesystem 0}]} {} + +test filesystem-3.0 {Tcl_FSRegister} { + testfilesystem 1 +} {registered} + +test filesystem-3.1 {Tcl_FSUnregister} { + testfilesystem 0 +} {unregistered} + +test filesystem-3.2 {Tcl_FSUnregister} { + list [catch {testfilesystem 0} err] $err +} {1 failed} + +test filesystem-3.3 {Tcl_FSRegister} { + testfilesystem 1 + testfilesystem 1 + testfilesystem 0 + testfilesystem 0 +} {unregistered} + +test filesystem-3.4 {Tcl_FSRegister} { + testfilesystem 1 + file system bar +} {reporting} + +test filesystem-3.5 {Tcl_FSUnregister} { + testfilesystem 0 + file system bar +} {native} + +test filesystem-4.0 {testfilesystem} { + -match glob + -body { + testfilesystem 1 + set filesystemReport {} + file exists foo + testfilesystem 0 + set filesystemReport + } + -result {* {access foo}} +} + +test filesystem-4.1 {testfilesystem} { + -match glob + -body { + testfilesystem 1 + set filesystemReport {} + catch {file stat foo bar} + testfilesystem 0 + set filesystemReport + } + -result {* {stat foo}} +} + +test filesystem-4.2 {testfilesystem} { + -match glob + -body { + testfilesystem 1 + set filesystemReport {} + catch {file lstat foo bar} + testfilesystem 0 + set filesystemReport + } + -result {* {lstat foo}} +} + +test filesystem-4.3 {testfilesystem} { + -match glob + -body { + testfilesystem 1 + set filesystemReport {} + catch {glob *} + testfilesystem 0 + set filesystemReport + } + -result {* {matchindirectory */tests/} *} +} + +catch {unset filesystemReport} +# Make sure the testfilesystem hasn't been registered. +while {![catch {testfilesystem 0}]} {} + + diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 992124c..1da9133 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.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: winFCmd.test,v 1.15 2001/11/19 17:45:12 vincentdarley Exp $ +# RCS: @(#) $Id: winFCmd.test,v 1.16 2002/03/24 11:41:51 vincentdarley Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -840,7 +840,7 @@ test winFCmd-11.4 {GetWinFileAttributes} {pcOnly} { 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 @@ test winfcmd-11.5 {GetWinFileAttributes} {pcOnly} { file attr . cd $old } {} +test winFCmd-11.6 {GetWinFileAttributes} {pcOnly} { + file attr c:/ -hidden +} {0} test winFCmd-12.1 {ConvertFileNameFormat} {pcOnly} { cleanup diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index 80383d8..49131de 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.17 2002/02/15 14:28:50 dkf Exp $ + * RCS: @(#) $Id: tclUnixFCmd.c,v 1.18 2002/03/24 11:41:51 vincentdarley Exp $ * * Portions of this code were derived from NetBSD source code which has * the following copyright notice: @@ -191,7 +191,7 @@ TclpObjRenameFile(srcPathPtr, destPathPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; { - return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), + return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), Tcl_FSGetNativePath(destPathPtr)); } @@ -308,7 +308,7 @@ TclpObjCopyFile(srcPathPtr, destPathPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; { - return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr), + return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr), Tcl_FSGetNativePath(destPathPtr)); } @@ -1618,17 +1618,17 @@ GetModeFromPermString(interp, modeStringPtr, modePtr) * 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 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint) 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 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint) /* File doesn't exist */ break; } - if (cur == 0) { - break; - } + /* 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; } diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 99a0731..3e2c7c8 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -9,12 +9,14 @@ * 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.18 2002/02/15 14:28:50 dkf Exp $ + * RCS: @(#) $Id: tclUnixFile.c,v 1.19 2002/03/24 11:41:51 vincentdarley Exp $ */ #include "tclInt.h" #include "tclPort.h" +static int NativeMatchType(CONST char* nativeName, Tcl_GlobTypeData *types); + /* *--------------------------------------------------------------------------- @@ -205,230 +207,256 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) * May be NULL. In particular the directory * flag is very important. */ { - CONST char *native, *fname, *dirName; - DIR *d; - Tcl_DString ds; - Tcl_StatBuf statBuf; - int matchHidden; - int nativeDirLen; - int result = TCL_OK; - Tcl_DString dsOrig; + CONST char *native; 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); - /* - * Make sure that the directory part of the name really is a - * directory. If the directory name is "", use the name "." - * instead, because some UNIX systems don't treat "" like "." - * automatically. Keep the "" for use in generating file names, - * otherwise "glob foo.c" would return "./foo.c". - */ - - if (baseLength == 0) { - dirName = "."; - } else { - dirName = Tcl_DStringValue(&dsOrig); - /* Make sure we have a trailing directory delimiter */ - if (dirName[baseLength-1] != '/') { - dirName = Tcl_DStringAppend(&dsOrig, "/", 1); - baseLength++; + 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; + int matchHidden; + int nativeDirLen; + int result = TCL_OK; + Tcl_DString dsOrig; + int baseLength; + + Tcl_DStringInit(&dsOrig); + Tcl_DStringAppend(&dsOrig, Tcl_GetString(fileNamePtr), -1); + baseLength = Tcl_DStringLength(&dsOrig); + + /* + * Make sure that the directory part of the name really is a + * directory. If the directory name is "", use the name "." + * instead, because some UNIX systems don't treat "" like "." + * automatically. Keep the "" for use in generating file names, + * otherwise "glob foo.c" would return "./foo.c". + */ - /* - * Check to see if the pattern needs to compare with hidden files. - */ + if (baseLength == 0) { + dirName = "."; + } else { + dirName = Tcl_DStringValue(&dsOrig); + /* Make sure we have a trailing directory delimiter */ + if (dirName[baseLength-1] != '/') { + dirName = Tcl_DStringAppend(&dsOrig, "/", 1); + baseLength++; + } + } + + /* + * Check to see if the pattern needs to compare with hidden files. + */ - if ((pattern[0] == '.') - || ((pattern[0] == '\\') && (pattern[1] == '.'))) { - matchHidden = 1; - } else { - matchHidden = 0; - } + if ((pattern[0] == '.') + || ((pattern[0] == '\\') && (pattern[1] == '.'))) { + matchHidden = 1; + } else { + matchHidden = 0; + } - /* - * Now open the directory for reading and iterate over the contents. - */ + /* + * Now open the directory for reading and iterate over the contents. + */ - native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds); + native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds); - if ((Tcl_PlatformStat(native, &statBuf) != 0) /* INTL: UTF-8. */ - || !S_ISDIR(statBuf.st_mode)) { - Tcl_DStringFree(&dsOrig); - Tcl_DStringFree(&ds); - return TCL_OK; - } + if ((Tcl_PlatformStat(native, &statBuf) != 0) /* INTL: UTF-8. */ + || !S_ISDIR(statBuf.st_mode)) { + Tcl_DStringFree(&dsOrig); + Tcl_DStringFree(&ds); + return TCL_OK; + } - d = opendir(native); /* INTL: Native. */ - if (d == NULL) { - char savedChar = '\0'; - Tcl_ResetResult(interp); - Tcl_DStringFree(&ds); + d = opendir(native); /* INTL: Native. */ + if (d == NULL) { + char savedChar = '\0'; + Tcl_ResetResult(interp); + Tcl_DStringFree(&ds); - /* - * Strip off a trailing '/' if necessary, before reporting the error. - */ + /* + * Strip off a trailing '/' if necessary, before reporting the error. + */ - if (baseLength > 0) { - savedChar = (Tcl_DStringValue(&dsOrig))[baseLength-1]; - if (savedChar == '/') { - (Tcl_DStringValue(&dsOrig))[baseLength-1] = '\0'; + if (baseLength > 0) { + savedChar = (Tcl_DStringValue(&dsOrig))[baseLength-1]; + if (savedChar == '/') { + (Tcl_DStringValue(&dsOrig))[baseLength-1] = '\0'; + } } + Tcl_AppendResult(interp, "couldn't read directory \"", + Tcl_DStringValue(&dsOrig), "\": ", + Tcl_PosixError(interp), (char *) NULL); + if (baseLength > 0) { + (Tcl_DStringValue(&dsOrig))[baseLength-1] = savedChar; + } + Tcl_DStringFree(&dsOrig); + return TCL_ERROR; } - Tcl_AppendResult(interp, "couldn't read directory \"", - Tcl_DStringValue(&dsOrig), "\": ", - Tcl_PosixError(interp), (char *) NULL); - if (baseLength > 0) { - (Tcl_DStringValue(&dsOrig))[baseLength-1] = savedChar; - } - Tcl_DStringFree(&dsOrig); - return TCL_ERROR; - } - nativeDirLen = Tcl_DStringLength(&ds); + nativeDirLen = Tcl_DStringLength(&ds); - while (1) { - Tcl_DString utfDs; - CONST char *utf; - Tcl_DirEntry *entryPtr; - - entryPtr = Tcl_PlatformReaddir(d); /* INTL: Native. */ - if (entryPtr == NULL) { - break; - } - if (types != NULL && (types->perm & TCL_GLOB_PERM_HIDDEN)) { - /* - * We explicitly asked for hidden files, so turn around - * and ignore any file which isn't hidden. - */ - if (*entryPtr->d_name != '.') { - continue; + while (1) { + Tcl_DString utfDs; + CONST char *utf; + Tcl_DirEntry *entryPtr; + + entryPtr = Tcl_PlatformReaddir(d); /* INTL: Native. */ + if (entryPtr == NULL) { + break; } - } else if (!matchHidden && (*entryPtr->d_name == '.')) { + if (types != NULL && (types->perm & TCL_GLOB_PERM_HIDDEN)) { + /* + * We explicitly asked for hidden files, so turn around + * and ignore any file which isn't hidden. + */ + if (*entryPtr->d_name != '.') { + continue; + } + } else if (!matchHidden && (*entryPtr->d_name == '.')) { + /* + * Don't match names starting with "." unless the "." is + * present in the pattern. + */ + continue; + } + /* - * Don't match names starting with "." unless the "." is - * present in the pattern. + * Now check to see if the file matches, according to both type + * and pattern. If so, add the file to the result. */ - continue; + + utf = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1, &utfDs); + if (Tcl_StringMatch(utf, pattern) != 0) { + int typeOk = 1; + + Tcl_DStringSetLength(&dsOrig, baseLength); + Tcl_DStringAppend(&dsOrig, utf, -1); + fname = Tcl_DStringValue(&dsOrig); + if (types != NULL) { + 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); } - /* - * Now check to see if the file matches, according to both type - * and pattern. If so, add the file to the result. + 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) { + /* + * 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') */ - - utf = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1, &utfDs); - if (Tcl_StringMatch(utf, pattern) != 0) { - int typeOk = 1; - - Tcl_DStringSetLength(&dsOrig, baseLength); - 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); + if (Tcl_PlatformLStat(nativeEntry, &buf) != 0) { + return 0; + } + } else { + if (types->perm != 0) { + if (Tcl_PlatformStat(nativeEntry, &buf) != 0) { /* - * The native name of the file is in entryPtr->d_name. - * We can use this below. + * Either the file has disappeared between the + * 'readdir' call and the 'stat' call, or + * the file is a link to a file which doesn't + * exist (which we could ascertain with + * lstat), or there is some other strange + * problem. In all these cases, we define this + * to mean the file does not match any defined + * permission, and therefore it is not + * added to the list of files to return. */ - - if (types->perm != 0) { - if (Tcl_PlatformStat(nativeEntry, &buf) != 0) { - /* - * Either the file has disappeared between the - * 'readdir' call and the 'stat' call, or - * the file is a link to a file which doesn't - * exist (which we could ascertain with - * lstat), or there is some other strange - * problem. In all these cases, we define this - * to mean the file does not match any defined - * permission, and therefore it is not - * added to the list of files to return. - */ - typeOk = 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) && - (buf.st_mode & (S_IWOTH|S_IWGRP|S_IWUSR))) || - ((types->perm & TCL_GLOB_PERM_R) && - (access(nativeEntry, R_OK) != 0)) || - ((types->perm & TCL_GLOB_PERM_W) && - (access(nativeEntry, W_OK) != 0)) || - ((types->perm & TCL_GLOB_PERM_X) && - (access(nativeEntry, X_OK) != 0)) - )) { - typeOk = 0; - } + return 0; + } + + /* + * readonly means that there are NO write permissions + * (even for user), but execute is OK for anybody + */ + 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)) || + ((types->perm & TCL_GLOB_PERM_W) && + (access(nativeEntry, W_OK) != 0)) || + ((types->perm & TCL_GLOB_PERM_X) && + (access(nativeEntry, X_OK) != 0)) + ) { + return 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 */ + return 0; } - if (typeOk && (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; - } - } - if (typeOk) { - /* - * In order bcdpfls as in 'find -t' - */ - if ( - ((types->type & TCL_GLOB_TYPE_BLOCK) && - S_ISBLK(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_CHAR) && - S_ISCHR(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_DIR) && - S_ISDIR(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_PIPE) && - S_ISFIFO(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_FILE) && - S_ISREG(buf.st_mode)) -#ifdef S_ISSOCK - || ((types->type & TCL_GLOB_TYPE_SOCK) && - S_ISSOCK(buf.st_mode)) -#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; - } -#endif + } + /* + * In order bcdpfls as in 'find -t' + */ + if ( + ((types->type & TCL_GLOB_TYPE_BLOCK) && + S_ISBLK(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_CHAR) && + S_ISCHR(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_DIR) && + S_ISDIR(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_PIPE) && + S_ISFIFO(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_FILE) && + S_ISREG(buf.st_mode)) + #ifdef S_ISSOCK + || ((types->type & TCL_GLOB_TYPE_SOCK) && + S_ISSOCK(buf.st_mode)) + #endif + ) { + /* Do nothing -- this file is ok */ + } else { + #ifdef S_ISLNK + if (types->type & TCL_GLOB_TYPE_LINK) { + if (Tcl_PlatformLStat(nativeEntry, &buf) == 0) { + if (S_ISLNK(buf.st_mode)) { + return 1; } } } - } - if (typeOk) { - Tcl_ListObjAppendElement(interp, resultPtr, - Tcl_NewStringObj(fname, Tcl_DStringLength(&dsOrig))); + #endif + return 0; } } - Tcl_DStringFree(&utfDs); } - - closedir(d); - Tcl_DStringFree(&ds); - Tcl_DStringFree(&dsOrig); - return result; + return 1; } /* @@ -553,12 +581,7 @@ TclpObjLstat(pathPtr, bufPtr) 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); } /* diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 1843e8d..ce53359 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.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: tclWinFCmd.c,v 1.27 2002/03/15 01:10:19 mdejong Exp $ + * RCS: @(#) $Id: tclWinFCmd.c,v 1.28 2002/03/24 11:41:51 vincentdarley Exp $ */ #include "tclWinInt.h" @@ -872,8 +872,6 @@ DoRemoveJustDirectory( * 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 @@ DoRemoveJustDirectory( 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 @@ TraversalCopy( 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 @@ TraversalCopy( } 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,7 +1376,8 @@ GetWinFileAttributes( { DWORD result; CONST TCHAR *nativeName; - + int attr; + nativeName = Tcl_FSGetNativePath(fileName); result = (*tclWinProcs->getFileAttributesProc)(nativeName); @@ -1389,7 +1386,34 @@ GetWinFileAttributes( 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; } diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 90feb0c..b0c1854 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.26 2002/02/15 14:28:51 dkf Exp $ + * RCS: @(#) $Id: tclWinFile.c,v 1.27 2002/03/24 11:41:51 vincentdarley Exp $ */ #include "tclWinInt.h" @@ -33,6 +33,8 @@ 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); /* @@ -119,332 +121,375 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) * May be NULL. In particular the directory * flag is very important. */ { - char drivePat[] = "?:\\"; - const char *message; - CONST char *dir; - char *root; - int dirLength; - Tcl_DString dirString; - DWORD attr, volFlags; - HANDLE handle; - WIN32_FIND_DATAT data; - BOOL found; - Tcl_DString ds; - Tcl_DString dsOrig; - Tcl_Obj *fileNamePtr; CONST TCHAR *nativeName; - int matchSpecialDots; - - /* - * Convert the path to normalized form since some interfaces only - * accept backslashes. Also, ensure that the directory ends with a - * separator character. - */ - fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr); - if (fileNamePtr == NULL) { - return TCL_ERROR; - } - Tcl_DStringInit(&dsOrig); - Tcl_DStringAppend(&dsOrig, Tcl_GetString(fileNamePtr), -1); - - dirLength = Tcl_DStringLength(&dsOrig); - Tcl_DStringInit(&dirString); - if (dirLength == 0) { - Tcl_DStringAppend(&dirString, ".\\", 2); - } else { - char *p; - - Tcl_DStringAppend(&dirString, Tcl_DStringValue(&dsOrig), - Tcl_DStringLength(&dsOrig)); - for (p = Tcl_DStringValue(&dirString); *p != '\0'; p++) { - if (*p == '/') { - *p = '\\'; + 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; } } - p--; - /* Make sure we have a trailing directory delimiter */ - if ((*p != '\\') && (*p != ':')) { - Tcl_DStringAppend(&dirString, "\\", 1); - Tcl_DStringAppend(&dsOrig, "/", 1); - dirLength++; + /* Match a file directly */ + nativeName = (CONST TCHAR*) Tcl_FSGetNativePath(pathPtr); + if (NativeMatchType(isDrive, nativeName, types)) { + Tcl_ListObjAppendElement(interp, resultPtr, pathPtr); } - } - dir = Tcl_DStringValue(&dirString); - - /* - * First verify that the specified path is actually a directory. - */ - - nativeName = Tcl_WinUtfToTChar(dir, Tcl_DStringLength(&dirString), &ds); - attr = (*tclWinProcs->getFileAttributesProc)(nativeName); - Tcl_DStringFree(&ds); - - if ((attr == 0xffffffff) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) { - Tcl_DStringFree(&dirString); return TCL_OK; - } + } else { + char drivePat[] = "?:\\"; + const char *message; + CONST char *dir; + char *root; + int dirLength; + Tcl_DString dirString; + DWORD attr, volFlags; + HANDLE handle; + WIN32_FIND_DATAT data; + BOOL found; + Tcl_DString ds; + Tcl_DString dsOrig; + Tcl_Obj *fileNamePtr; + int matchSpecialDots; + + /* + * Convert the path to normalized form since some interfaces only + * accept backslashes. Also, ensure that the directory ends with a + * separator character. + */ - /* - * 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. - */ + fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr); + if (fileNamePtr == NULL) { + return TCL_ERROR; + } + Tcl_DStringInit(&dsOrig); + Tcl_DStringAppend(&dsOrig, Tcl_GetString(fileNamePtr), -1); - switch (Tcl_GetPathType(dir)) { - case TCL_PATH_RELATIVE: - found = GetVolumeInformationA(NULL, NULL, 0, NULL, NULL, - &volFlags, NULL, 0); - break; - case TCL_PATH_VOLUME_RELATIVE: - if (dir[0] == '\\') { - root = NULL; - } else { - root = drivePat; - *root = dir[0]; - } - found = GetVolumeInformationA(root, NULL, 0, NULL, NULL, - &volFlags, NULL, 0); - break; - case TCL_PATH_ABSOLUTE: - if (dir[1] == ':') { - root = drivePat; - *root = dir[0]; - found = GetVolumeInformationA(root, NULL, 0, NULL, NULL, - &volFlags, NULL, 0); - } else if (dir[1] == '\\') { - char *p; + dirLength = Tcl_DStringLength(&dsOrig); + Tcl_DStringInit(&dirString); + if (dirLength == 0) { + Tcl_DStringAppend(&dirString, ".\\", 2); + } else { + char *p; - p = strchr(dir + 2, '\\'); - p = strchr(p + 1, '\\'); - p++; - nativeName = Tcl_WinUtfToTChar(dir, p - dir, &ds); - found = (*tclWinProcs->getVolumeInformationProc)(nativeName, - NULL, 0, NULL, NULL, &volFlags, NULL, 0); - Tcl_DStringFree(&ds); + Tcl_DStringAppend(&dirString, Tcl_DStringValue(&dsOrig), + Tcl_DStringLength(&dsOrig)); + for (p = Tcl_DStringValue(&dirString); *p != '\0'; p++) { + if (*p == '/') { + *p = '\\'; + } } - break; - } + p--; + /* Make sure we have a trailing directory delimiter */ + if ((*p != '\\') && (*p != ':')) { + Tcl_DStringAppend(&dirString, "\\", 1); + Tcl_DStringAppend(&dsOrig, "/", 1); + dirLength++; + } + } + dir = Tcl_DStringValue(&dirString); - if (found == 0) { - message = "couldn't read volume information for \""; - goto error; - } + /* + * First verify that the specified path is actually a directory. + */ - /* - * Check to see if the pattern should match the special - * . and .. names, referring to the current directory, - * or the directory above. We need a special check for - * this because paths beginning with a dot are not considered - * hidden on Windows, and so otherwise a relative glob like - * 'glob -join * *' will actually return './. ../..' etc. - */ + nativeName = Tcl_WinUtfToTChar(dir, Tcl_DStringLength(&dirString), &ds); + attr = (*tclWinProcs->getFileAttributesProc)(nativeName); + Tcl_DStringFree(&ds); - if ((pattern[0] == '.') - || ((pattern[0] == '\\') && (pattern[1] == '.'))) { - matchSpecialDots = 1; - } else { - matchSpecialDots = 0; - } + if ((attr == 0xffffffff) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) { + Tcl_DStringFree(&dirString); + return TCL_OK; + } - /* - * We need to check all files in the directory, so append a *.* - * to the path. - */ + /* + * 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. + */ - dir = Tcl_DStringAppend(&dirString, "*.*", 3); - nativeName = Tcl_WinUtfToTChar(dir, -1, &ds); - handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data); - Tcl_DStringFree(&ds); + switch (Tcl_GetPathType(dir)) { + case TCL_PATH_RELATIVE: + found = GetVolumeInformationA(NULL, NULL, 0, NULL, NULL, + &volFlags, NULL, 0); + break; + case TCL_PATH_VOLUME_RELATIVE: + if (dir[0] == '\\') { + root = NULL; + } else { + root = drivePat; + *root = dir[0]; + } + found = GetVolumeInformationA(root, NULL, 0, NULL, NULL, + &volFlags, NULL, 0); + break; + case TCL_PATH_ABSOLUTE: + if (dir[1] == ':') { + root = drivePat; + *root = dir[0]; + found = GetVolumeInformationA(root, NULL, 0, NULL, NULL, + &volFlags, NULL, 0); + } else if (dir[1] == '\\') { + char *p; + + p = strchr(dir + 2, '\\'); + p = strchr(p + 1, '\\'); + p++; + nativeName = Tcl_WinUtfToTChar(dir, p - dir, &ds); + found = (*tclWinProcs->getVolumeInformationProc)(nativeName, + NULL, 0, NULL, NULL, &volFlags, NULL, 0); + Tcl_DStringFree(&ds); + } + break; + } - if (handle == INVALID_HANDLE_VALUE) { - message = "couldn't read directory \""; - goto error; - } + if (found == 0) { + message = "couldn't read volume information for \""; + goto error; + } - /* - * Now iterate over all of the files in the directory. - */ + /* + * Check to see if the pattern should match the special + * . and .. names, referring to the current directory, + * or the directory above. We need a special check for + * this because paths beginning with a dot are not considered + * hidden on Windows, and so otherwise a relative glob like + * 'glob -join * *' will actually return './. ../..' etc. + */ - for (found = 1; found != 0; - found = (*tclWinProcs->findNextFileProc)(handle, &data)) { - CONST TCHAR *nativeMatchResult; - CONST char *name, *fname; - - int typeOk = 1; - - if (tclWinProcs->useWide) { - nativeName = (CONST TCHAR *) data.w.cFileName; + if ((pattern[0] == '.') + || ((pattern[0] == '\\') && (pattern[1] == '.'))) { + matchSpecialDots = 1; } else { - nativeName = (CONST TCHAR *) data.a.cFileName; + matchSpecialDots = 0; } - name = Tcl_WinTCharToUtf(nativeName, -1, &ds); - if (!matchSpecialDots) { - /* If it is exactly '.' or '..' then we ignore it */ - if (name[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. + * We need to check all files in the directory, so append a *.* + * to the path. */ - nativeMatchResult = NULL; - - if (Tcl_StringCaseMatch(name, pattern, 1) != 0) { - nativeMatchResult = nativeName; - } - Tcl_DStringFree(&ds); + dir = Tcl_DStringAppend(&dirString, "*.*", 3); + nativeName = Tcl_WinUtfToTChar(dir, -1, &ds); + handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data); + Tcl_DStringFree(&ds); - if (nativeMatchResult == NULL) { - continue; + if (handle == INVALID_HANDLE_VALUE) { + message = "couldn't read directory \""; + goto error; } /* - * If the file matches, then we need to process the remainder of the - * path. + * Now iterate over all of the files in the directory. */ - name = Tcl_WinTCharToUtf(nativeMatchResult, -1, &ds); - Tcl_DStringAppend(&dsOrig, name, -1); - Tcl_DStringFree(&ds); + for (found = 1; found != 0; + found = (*tclWinProcs->findNextFileProc)(handle, &data)) { + CONST TCHAR *nativeMatchResult; + CONST char *name, *fname; + + if (tclWinProcs->useWide) { + nativeName = (CONST TCHAR *) data.w.cFileName; + } else { + nativeName = (CONST TCHAR *) data.a.cFileName; + } + name = Tcl_WinTCharToUtf(nativeName, -1, &ds); + + if (!matchSpecialDots) { + /* If it is exactly '.' or '..' then we ignore it */ + if (name[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. + */ + + nativeMatchResult = NULL; + + if (Tcl_StringCaseMatch(name, pattern, 1) != 0) { + nativeMatchResult = nativeName; + } + Tcl_DStringFree(&ds); + + if (nativeMatchResult == NULL) { + continue; + } + + /* + * If the file matches, then we need to process the remainder of the + * path. + */ + + name = Tcl_WinTCharToUtf(nativeMatchResult, -1, &ds); + Tcl_DStringAppend(&dsOrig, name, -1); + Tcl_DStringFree(&ds); + + 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); - fname = Tcl_DStringValue(&dsOrig); - nativeName = Tcl_WinUtfToTChar(fname, Tcl_DStringLength(&dsOrig), &ds); + Tcl_DStringSetLength(&dsOrig, dirLength); + } + + FindClose(handle); + Tcl_DStringFree(&dirString); + Tcl_DStringFree(&dsOrig); + + return TCL_OK; - /* - * 'attr' represents the attributes of the file, but we only - * want to retrieve this info if it is absolutely necessary - * because it is an expensive call. Unfortunately, to deal - * with hidden files properly, we must always retrieve it. - * There are more modern Win32 APIs available which we should - * look into. - */ + 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; + } - attr = (*tclWinProcs->getFileAttributesProc)(nativeName); - if (types == NULL) { - /* If invisible, don't return the file */ - if (attr & FILE_ATTRIBUTE_HIDDEN) { - typeOk = 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 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 + * because it is an expensive call. Unfortunately, to deal + * with hidden files properly, we must always retrieve it. + * There are more modern Win32 APIs available which we should + * look into. + */ + + 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 && !isDrive) { + return 0; + } + } else { + if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) { + /* If invisible */ + if ((types->perm == 0) || + !(types->perm & TCL_GLOB_PERM_HIDDEN)) { + return 0; } } else { - if (attr & FILE_ATTRIBUTE_HIDDEN) { - /* If invisible */ - if ((types->perm == 0) || - !(types->perm & TCL_GLOB_PERM_HIDDEN)) { - typeOk = 0; - } - } else { - /* Visible */ - if (types->perm & TCL_GLOB_PERM_HIDDEN) { - typeOk = 0; - } + /* Visible */ + if (types->perm & TCL_GLOB_PERM_HIDDEN) { + return 0; } + } + + if (types->perm != 0) { + if ( + ((types->perm & TCL_GLOB_PERM_RONLY) && + !(attr & FILE_ATTRIBUTE_READONLY)) || + ((types->perm & TCL_GLOB_PERM_R) && + (NativeAccess(nativeName, R_OK) != 0)) || + ((types->perm & TCL_GLOB_PERM_W) && + (NativeAccess(nativeName, W_OK) != 0)) || + ((types->perm & TCL_GLOB_PERM_X) && + (NativeAccess(nativeName, X_OK) != 0)) + ) { + return 0; + } + } + if (types->type != 0) { + Tcl_StatBuf buf; - if (typeOk == 1 && types->perm != 0) { - if ( - ((types->perm & TCL_GLOB_PERM_RONLY) && - !(attr & FILE_ATTRIBUTE_READONLY)) || - ((types->perm & TCL_GLOB_PERM_R) && - (NativeAccess(nativeName, R_OK) != 0)) || - ((types->perm & TCL_GLOB_PERM_W) && - (NativeAccess(nativeName, W_OK) != 0)) || - ((types->perm & TCL_GLOB_PERM_X) && - (NativeAccess(nativeName, X_OK) != 0)) - ) { - typeOk = 0; - } + if (NativeStat(nativeName, &buf) != 0) { + /* + * Posix error occurred, either the file + * has disappeared, or there is some other + * strange error. In any case we don't + * return this file. + */ + return 0; } - if (typeOk && types->type != 0) { - Tcl_StatBuf buf; - - if (NativeStat(nativeName, &buf) != 0) { - /* - * Posix error occurred, either the file - * has disappeared, or there is some other - * strange error. In any case we don't - * return this file. - */ - typeOk = 0; - } - if (typeOk) { - /* - * In order bcdpfls as in 'find -t' - */ - if ( - ((types->type & TCL_GLOB_TYPE_BLOCK) && - S_ISBLK(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_CHAR) && - S_ISCHR(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_DIR) && - S_ISDIR(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_PIPE) && - S_ISFIFO(buf.st_mode)) || - ((types->type & TCL_GLOB_TYPE_FILE) && - S_ISREG(buf.st_mode)) + /* + * In order bcdpfls as in 'find -t' + */ + if ( + ((types->type & TCL_GLOB_TYPE_BLOCK) && + S_ISBLK(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_CHAR) && + S_ISCHR(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_DIR) && + S_ISDIR(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_PIPE) && + S_ISFIFO(buf.st_mode)) || + ((types->type & TCL_GLOB_TYPE_FILE) && + S_ISREG(buf.st_mode)) #ifdef S_ISSOCK - || ((types->type & TCL_GLOB_TYPE_SOCK) && - S_ISSOCK(buf.st_mode)) + || ((types->type & TCL_GLOB_TYPE_SOCK) && + S_ISSOCK(buf.st_mode)) #endif - ) { - /* Do nothing -- this file is ok */ - } else { - typeOk = 0; + ) { + /* Do nothing -- this file is ok */ + } else { #ifdef S_ISLNK - if (types->type & TCL_GLOB_TYPE_LINK) { - /* - * We should use 'lstat' but it is the - * same as 'stat' on windows. - */ - if (NativeStat(nativeName, &buf) == 0) { - if (S_ISLNK(buf.st_mode)) { - typeOk = 1; - } - } + if (types->type & TCL_GLOB_TYPE_LINK) { + /* + * We should use 'lstat' but it is the + * same as 'stat' on windows. + */ + if (NativeStat(nativeName, &buf) == 0) { + if (S_ISLNK(buf.st_mode)) { + return 1; } -#endif } } - } - } - 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; +#endif + return 0; + } + } + } + return 1; } /* diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index cac423d..d20aa3d 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.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: tclWinPipe.c,v 1.23 2002/01/25 21:36:10 dgp Exp $ + * RCS: @(#) $Id: tclWinPipe.c,v 1.24 2002/03/24 11:41:51 vincentdarley Exp $ */ #include "tclWinInt.h" @@ -1431,7 +1431,7 @@ ApplicationType(interp, originalName, fullName) */ CloseHandle(hFile); - if ((ext != NULL) && (strcmp(ext, ".com") == 0)) { + if ((ext != NULL) && (stricmp(ext, ".com") == 0)) { applType = APPL_DOS; break; } |