From f319c32167c2c52995fe53b438ef4bc34e9a4914 Mon Sep 17 00:00:00 2001 From: vincentdarley Date: Thu, 23 Aug 2001 17:37:07 +0000 Subject: fs update --- ChangeLog | 84 +++++ doc/FileSystem.3 | 53 ++- doc/SplitPath.3 | 5 +- doc/filename.n | 12 +- doc/glob.n | 21 +- generic/tcl.decls | 14 +- generic/tcl.h | 13 +- generic/tclCmdAH.c | 182 +++++------ generic/tclDecls.h | 29 +- generic/tclFCmd.c | 5 +- generic/tclFileName.c | 866 ++++++++++++++++++++++++++++++++++---------------- generic/tclIO.c | 12 +- generic/tclIOUtil.c | 746 +++++++++++++++++++++++++++++++++++-------- generic/tclInt.h | 17 +- generic/tclLoad.c | 17 +- generic/tclStubInit.c | 5 +- generic/tclTest.c | 70 ++-- mac/tclMacFCmd.c | 43 ++- mac/tclMacFile.c | 71 +++-- tests/fileName.test | 57 +++- unix/tclUnixFCmd.c | 163 +++++----- unix/tclUnixFile.c | 121 ++++--- win/tclWinFCmd.c | 446 +++++++++++--------------- win/tclWinFile.c | 73 +++-- 24 files changed, 2039 insertions(+), 1086 deletions(-) diff --git a/ChangeLog b/ChangeLog index ba254e3..6984dca 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,87 @@ +2001-08-24 Vince Darley + + Variety of small filesystem and vfs issues fixed or improved. + The new fs code allows many new opportunities for efficiency + improvements through the objectified API. The main changes + integrated here are such efficiency improvements. Some + limitations of the original implementation have also now been + lifted. Meanwhile a variety of fs bugs (some old, some new) + have also been fixed. + + * generic/tclFileName.c: Made Tcl_FSSplitPath more efficient, + and removed some static string-based procedures which are no + longer used. Much more objectification. Tcl_FSJoinPath + is now very efficient and more aware of virtual filesystems. + Clarified where the Mac-specific code attempts to interpret + Unix-style paths. Modified TclDoGlob to use lstat not + access to fix [Bug: 434876, L. Virden] + * tcl(Win|Unix|Mac)FCmd.c: + * tcl(Win|Unix|Mac)File.c: replaced TclpListVolumes with + TclpObjListVolumes with different signature, updated code due + to more efficient signature of Tcl_FSGetTranslatedPath. Used + cached native paths where possible to improve efficiency -- + this was completed on MacOS, but on Unix and Win the traversal + functions make the task much more complex, so there are still + some improvements possible there. Removed unused + TclpNormalizePath which had been left in tclWinFCmd.c. + Objectified all 'file attributes' functions. Fixed the new + [Bug:451571, Bruce Stephens] which is most obvious on Unix, + but could occur on MacOS or Windows. This bug actually existed + in Tcl 8.3.x but was only made obvious by the recent filesystem + overhaul when the code was exercised more heavily. + * tests/fileName.test: Three new tests to exercise the above bug, + and make sure it is fixed correctly. + * unix/tclUnixFile.c: avoid panic in glob when a link + doesn't point anywhere. It would probably be good to define + exactly what Tcl should do in circumstances like these, and + make sure mac/win/unix all behave accordingly. [Bug: 417111, + Hemang Lavana]. Also fixed misleading/obsolete comment in the code. + * generic/tcl.stubs: changed signature of Tcl_FSGetTranslatedPath + and added Tcl_FSGetTranslatedStringPath. + These changes allow further optimisations in the FS code. + * generic/tcl.h: changed signature of Tcl_FSListVolumes so that + it doesn't require a Tcl interpreter plus result. Renamed + Tcl_FSReadLink to Tcl_FSLink with additional argument so + we can support making links in the future. [Patch: 450340] + * generic/tclInt.h: + added declaration for TclpObjListVolumes. Objectified + internal call signatures for 'file attributes' functions, and + added an internal objectified get path type function. + * generic/tclIOUtil.c: added the moved function TclpListVolumes + which calls platform specific code (needed for backwards + compatibility), and improved efficiency of parts of the FS + (particularly file normalization). Much less copying and + memory allocation is required now. added new GetPathType + so that changes in 'file volumes' can actually affect files' + types, and objectified more code. Made current code work + with test suite artificially changing current platform. + Added 'static' keywords where required. + * generic/tclIO.c: + * generic/tclTest.c: Added 'static' keywords, fixing + [Bug: 453872, Bob Techentin] + * generic/tclCmdAH.c: file command implementation updated for + API changes, removed unnecessary special-case SplitPath static + function, since it no longer helps prevent code duplication. + Moved setting of interpreter result to each individual location + that actually required it, to avoid very large code separation + between reading and setting the result. + * doc/FileSystem.3: updated documentation for the new or + changed APIs, and clarified some issues. + * doc/SplitPath.3: added pointer to newer APIs in FileSystem.3 + * doc/filename.n: clarified current implementation of tilde + support on Mac/Win. [Bug:453514, Sergey Kuzmin] + * doc/glob.n: improved documentation for '-directory' and '-path' + options. + + There are now many private, obsolete, platform-specific 'Tclp' + string-based filesystem APIs which could be removed. We should + check whether any of these are used by extensions and, at least + in Tcl 9, remove them. + + The above changes signify a ***POTENTIAL INCOMPATIBILITY*** + with 8.4a3, since signatures of two functions in the new API + have changed, but not with older versions of Tcl. + 2001-08-23 Donal K. Fellows * generic/tclBinary.c (FormatNumber): Extract a long from the diff --git a/doc/FileSystem.3 b/doc/FileSystem.3 index 1da96c5..7e49235 100644 --- a/doc/FileSystem.3 +++ b/doc/FileSystem.3 @@ -4,13 +4,13 @@ '\" 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.2 2001/08/07 02:59:14 hobbs Exp $ +'\" RCS: @(#) $Id: FileSystem.3,v 1.3 2001/08/23 17:37:07 vincentdarley Exp $ '\" .so man.macros .TH Tcl_FSCopyFile 3 8.4 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_FSRegister, Tcl_FSUnregister, Tcl_FSData, Tcl_FSCopyFile, Tcl_FSCopyDirectory, Tcl_FSCreateDirectory, Tcl_FSDeleteFile, Tcl_FSRemoveDirectory, Tcl_FSRenameFile, Tcl_FSListVolumes, Tcl_FSEvalFile, Tcl_FSLoadFile, Tcl_FSMatchInDirectory, Tcl_FSReadlink, Tcl_FSLstat, Tcl_FSUtime, Tcl_FSFileAttrsGet, Tcl_FSFileAttrsSet, Tcl_FSFileAttrStrings, Tcl_FSStat, Tcl_FSAccess, Tcl_FSOpenFileChannel, Tcl_FSGetCwd, Tcl_FSChdir, Tcl_FSPathSeparator, Tcl_FSJoinPath, Tcl_FSSplitPath, Tcl_FSEqualPaths, Tcl_FSGetNormalizedPath, Tcl_FSJoinToPath, Tcl_FSConvertToPathType, Tcl_FSGetInternalRep, Tcl_FSGetTranslatedPath, Tcl_FSNewNativePath, Tcl_FSGetNativePath, Tcl_FSFileSystemInfo \- procedures to interact with any filesystem +Tcl_FSRegister, Tcl_FSUnregister, Tcl_FSData, Tcl_FSCopyFile, Tcl_FSCopyDirectory, Tcl_FSCreateDirectory, Tcl_FSDeleteFile, Tcl_FSRemoveDirectory, Tcl_FSRenameFile, Tcl_FSListVolumes, Tcl_FSEvalFile, Tcl_FSLoadFile, Tcl_FSMatchInDirectory, Tcl_FSReadlink, Tcl_FSLstat, Tcl_FSUtime, Tcl_FSFileAttrsGet, Tcl_FSFileAttrsSet, Tcl_FSFileAttrStrings, Tcl_FSStat, Tcl_FSAccess, Tcl_FSOpenFileChannel, Tcl_FSGetCwd, Tcl_FSChdir, Tcl_FSPathSeparator, Tcl_FSJoinPath, Tcl_FSSplitPath, Tcl_FSEqualPaths, Tcl_FSGetNormalizedPath, Tcl_FSJoinToPath, Tcl_FSConvertToPathType, Tcl_FSGetInternalRep, Tcl_FSGetTranslatedPath, Tcl_FSGetTranslatedStringPath, Tcl_FSNewNativePath, Tcl_FSGetNativePath, Tcl_FSFileSystemInfo \- procedures to interact with any filesystem .SH SYNOPSIS .nf \fB#include \fR @@ -42,8 +42,8 @@ int int \fBTcl_FSRenameFile\fR(\fIsrcPathPtr, destPathPtr\fR) .sp -int -\fBTcl_FSListVolumes\fR(\fIinterp\fR) +Tcl_Obj* +\fBTcl_FSListVolumes\fR(\fIvoid\fR) .sp int \fBTcl_FSEvalFile\fR(\fIinterp, fileName\fR) @@ -55,7 +55,7 @@ int \fBTcl_FSMatchInDirectory\fR(\fIinterp, result, pathPtr, pattern, types\fR) .sp Tcl_Obj* -\fBTcl_FSReadlink\fR(\fIpathPtr\fR) +\fBTcl_FSLink\fR(\fIpathPtr, toPtr\fR) .sp int \fBTcl_FSLstat\fR(\fIpathPtr, statPtr\fR) @@ -111,9 +111,12 @@ int ClientData \fBTcl_FSGetInternalRep\fR(\fIpathPtr, fsPtr\fR) .sp -char* +Tcl_Obj* \fBTcl_FSGetTranslatedPath\fR(\fIinterp, pathPtr\fR) .sp +char* +\fBTcl_FSGetTranslatedStringPath\fR(\fIinterp, pathPtr\fR) +.sp Tcl_Obj* \fBTcl_FSNewNativePath\fR(\fIfsPtr, clientData\fR) .sp @@ -230,7 +233,20 @@ native files in the native filesystem. If appropriate vfs's have been registered, the 'files' may, to give two examples, be remote (e.g. situated on a remote ftp server) or archived (e.g. lying inside a .zip archive). Such registered filesystems provide a lookup table of -functions to implement all or some of the functionality listed here. +functions to implement all or some of the functionality listed here. +.PP +The \fBTcl_FS...\fR are objectified and may cache internal +representations and other path-related strings (e.g. the current +working directory). One side-effect of this is that one must be +careful when passing in temporary objects with a refCount of zero. +Under some circumstances, the filesystem code may wish to retain a +reference to the passed in object, and so one must not assume that +after any of these calls return, the object still has a refCount of +zero - it may have been incremented. The practical lesson to learn +from this is that \fbTcl_Obj *path = Tcl_NewStringObj(...) ; +Tcl_FS...(path) ; Tcl_DecrRefCount(path)\fR is wrong, and may +segfault. The 'path' must have its refCount incremented before +passing it in, or decrementing it. .PP \fBTcl_FSCopyFile\fR attempts to copy the file given by srcPathPtr to the path name given by destPathPtr. If the two paths given lie in the same @@ -267,8 +283,9 @@ sets Tcl's errno to the 'EXDEV' posix error code (which signifies a 'cross-domain link'). .PP \fBTcl_FSListVolumes\fR calls each filesystem which has a non-NULL 'list -volumes' function and asks those to append their root volumes to -the list in the interpreters result. +volumes' function and asks them to return their list of root volumes. It +accumulates the return values in a list which is returned to the +caller (with a refCount of 0). .PP \fBTcl_FSEvalFile\fR reads the file given by \fIpathPtr\fR and evaluates its contents as a Tcl script. It returns the same information as @@ -305,14 +322,18 @@ matched using the logic of 'string match'. To handle recursion, Tcl will call this function frequently asking only for directories to be returned. .PP -\fBTcl_FSReadlink\fR replaces the library version of readlink(). +\fBTcl_FSLink\fR replaces the library version of readlink(), and may +also be used in the future to allow link creation. The appropriate function for the filesystem to which pathPtr belongs will be called. .PP +If the \fItoPtr\fR is NULL, a readlink action is performed. The result is a Tcl_Obj specifying the contents of the symbolic link -given by 'path', or NULL if the symbolic link could not be read. The +given by \fIpath\fR, or NULL if the symbolic link could not be read. The result is owned by the caller, which should call Tcl_DecrRefCount when -the result is no longer needed. +the result is no longer needed. If the \fItoPtr\fR is not NULL, Tcl +should create a link, but this option is not currently supported (it +is left available for future expansion). .PP \fBTcl_FSLstat\fR fills the stat structure \fIstatPtr\fR with information about the specified file. You do not need any access rights to the @@ -487,13 +508,16 @@ Returns NULL or a valid internal path representation. This internal representation is cached, so that repeated calls to this function will not require additional conversions. .PP -\fBTcl_FSGetTranslatedPath\fR attempts to extract the translated path string +\fBTcl_FSGetTranslatedPath\fR attempts to extract the translated path 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. .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 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 @@ -915,8 +939,7 @@ Should be implemented only if the filesystem adds volumes at the head of the filesystem, so that they can be returned by 'file volumes'. .PP .CS -typedef int Tcl_FSListVolumesProc( - Tcl_Interp *\fIinterp\fR); +typedef Tcl_Obj* Tcl_FSListVolumesProc(void); .CE .PP The result should be TCL_OK, since there is no way this function can diff --git a/doc/SplitPath.3 b/doc/SplitPath.3 index b112b82..71ebe82 100644 --- a/doc/SplitPath.3 +++ b/doc/SplitPath.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: SplitPath.3,v 1.2 1998/09/14 18:39:50 stanton Exp $ +'\" RCS: @(#) $Id: SplitPath.3,v 1.3 2001/08/23 17:37:07 vincentdarley Exp $ '\" .so man.macros .TH Tcl_SplitPath 3 7.5 Tcl "Tcl Library Procedures" @@ -45,6 +45,9 @@ A pointer to an initialized \fBTcl_DString\fR to which the result of .SH DESCRIPTION .PP +These procedures have been superceded by the objectified procedures in +the \fBFileSystem\fR man page, which are more efficient. +.PP These procedures may be used to disassemble and reassemble file paths in a platform independent manner: they provide C-level access to the same functionality as the \fBfile split\fR, \fBfile join\fR, and diff --git a/doc/filename.n b/doc/filename.n index 42a9dce..34939c0 100644 --- a/doc/filename.n +++ b/doc/filename.n @@ -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: filename.n,v 1.4 2000/09/07 14:27:47 poenitz Exp $ +'\" RCS: @(#) $Id: filename.n,v 1.5 2001/08/23 17:37:07 vincentdarley Exp $ '\" .so man.macros .TH filename n 7.5 Tcl "Tcl Built-In Commands" @@ -177,9 +177,13 @@ substitution. .PP The Macintosh and Windows platforms do not support tilde substitution when a user name follows the tilde. On these platforms, attempts to -use a tilde followed by a user name will generate an error. File -names that have a tilde without a user name will be substituted using -the \fB$HOME\fR environment variable, just like for Unix. +use a tilde followed by a user name will generate an error that the +user does not exist when Tcl attempts to interpret that part of the +path or otherwise access the file. The behaviour of these paths +when not trying to interpret them is the same as on Unix. File +names that have a tilde without a user name will be correctly +substituted using the \fB$HOME\fR environment variable, just like +for Unix. .SH "PORTABILITY ISSUES" .PP diff --git a/doc/glob.n b/doc/glob.n index 38a96df..409001b 100644 --- a/doc/glob.n +++ b/doc/glob.n @@ -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: glob.n,v 1.9 2001/07/31 19:12:06 vincentdarley Exp $ +'\" RCS: @(#) $Id: glob.n,v 1.10 2001/08/23 17:37:07 vincentdarley Exp $ '\" .so man.macros .TH glob n 8.3 Tcl "Tcl Built-In Commands" @@ -33,7 +33,8 @@ Search for files which match the given patterns starting in the given \fIdirectory\fR. This allows searching of directories whose name contains glob-sensitive characters without the need to quote such characters explicitly. This option may not be used in conjunction with -\fB\-path\fR. +\fB\-path\fR, which is used to allow searching for complete file paths +whose names may contain glob-sensitive characters. .TP \fB\-join\fR The remaining pattern arguments are treated as a single pattern @@ -48,18 +49,22 @@ switch an error is returned if the result list would be empty. \fB\-path\fR \fIpathPrefix\fR Search for files with the given \fIpathPrefix\fR where the rest of the name matches the given patterns. This allows searching for files with names -similar to a given file even when the names contain glob-sensitive +similar to a given file (as opposed to a directory) even when the names +contain glob-sensitive characters. This option may not be used in conjunction with -\fB\-directory\fR. +\fB\-directory\fR. For example, to find all files with the same root name +as $path, but differing extensions, you should use \fBglob +-path [file rootname $path] .*\fR which will work even if $path contains +numerous glob-sensitive characters. .TP \fB\-tails\fR Only return the part of each file found which follows the last directory named in any \fB\-directory\fR or \fB\-path\fR path specification. -Thus \fBglob -tails -dir $dir *\fR is equivalent to +Thus \fBglob -tails -directory $dir *\fR is equivalent to \fBset pwd [pwd] ; cd $dir ; glob *; cd $pwd\fR. For \fB\-path\fR specifications, the returned names will include the last -path segment, so \fBglob -tails -path /usr/loc */*\fR will return paths -like \fBlocal/bin local/lib\fR etc. +path segment, so \fBglob -tails -path [file rootname ~/foo.tex] .*\fR +will return paths like \fBfoo.aux foo.bib foo.tex\fR etc. .TP \fB\-types\fR \fItypeList\fR Only list files or directories which match \fItypeList\fR, where the items @@ -164,7 +169,7 @@ like ``.../'' and ``..../'' for successively higher up parent directories. .TP \fBMacintosh\fR . -When using the options, \fB\-dir\fR, \fB\-join\fR or \fB\-path\fR, glob +When using the options, \fB\-directory\fR, \fB\-join\fR or \fB\-path\fR, glob assumes the directory separator for the entire pattern is the standard ``:''. When not using these options, glob examines each pattern argument and uses ``/'' unless the pattern contains a ``:''. diff --git a/generic/tcl.decls b/generic/tcl.decls index 482d5fa..65ff02a 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -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: tcl.decls,v 1.51 2001/07/31 19:12:06 vincentdarley Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.52 2001/08/23 17:37:07 vincentdarley Exp $ library tcl @@ -599,7 +599,8 @@ declare 167 unix { int Tcl_GetOpenFile(Tcl_Interp *interp, char *str, int forWriting, \ int checkUsage, ClientData *filePtr) } - +# Obsolete. Should now use Tcl_FSGetPathType which is objectified +# and therefore usually faster. declare 168 generic { Tcl_PathType Tcl_GetPathType(char *path) } @@ -1562,7 +1563,7 @@ declare 445 generic { char * pattern, Tcl_GlobTypeData * types) } declare 446 generic { - Tcl_Obj* Tcl_FSReadlink(Tcl_Obj *pathPtr) + Tcl_Obj* Tcl_FSLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr) } declare 447 generic { int Tcl_FSRemoveDirectory(Tcl_Obj *pathPtr, \ @@ -1628,7 +1629,7 @@ declare 465 generic { ClientData Tcl_FSGetInternalRep(Tcl_Obj* pathObjPtr, Tcl_Filesystem *fsPtr) } declare 466 generic { - char* Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj* pathPtr) + Tcl_Obj* Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj* pathPtr) } declare 467 generic { int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName) @@ -1646,7 +1647,7 @@ declare 471 generic { Tcl_Obj* Tcl_FSPathSeparator(Tcl_Obj* pathObjPtr) } declare 472 generic { - int Tcl_FSListVolumes(Tcl_Interp *interp) + Tcl_Obj* Tcl_FSListVolumes(void) } declare 473 generic { int Tcl_FSRegister(ClientData clientData, Tcl_Filesystem *fsPtr) @@ -1657,6 +1658,9 @@ declare 474 generic { declare 475 generic { ClientData Tcl_FSData(Tcl_Filesystem *fsPtr) } +declare 476 generic { + char* Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp, Tcl_Obj* pathPtr) +} ############################################################################## diff --git a/generic/tcl.h b/generic/tcl.h index aa7ce8a..ba7d9c5 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -12,7 +12,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.95 2001/08/08 22:28:23 dgp Exp $ + * RCS: @(#) $Id: tcl.h,v 1.96 2001/08/23 17:37:07 vincentdarley Exp $ */ #ifndef _TCL @@ -1533,7 +1533,7 @@ typedef int (Tcl_FSRemoveDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, typedef int (Tcl_FSRenameFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr)); typedef void (Tcl_FSUnloadFileProc) _ANSI_ARGS_((ClientData clientData)); -typedef int (Tcl_FSListVolumesProc) _ANSI_ARGS_((Tcl_Interp *interp)); +typedef Tcl_Obj* (Tcl_FSListVolumesProc) _ANSI_ARGS_((void)); /* We have to declare the utime structure here. */ struct utimbuf; typedef int (Tcl_FSUtimeProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, @@ -1548,7 +1548,8 @@ typedef char** (Tcl_FSFileAttrStringsProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, typedef int (Tcl_FSFileAttrsSetProc) _ANSI_ARGS_((Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr)); -typedef Tcl_Obj* (Tcl_FSReadlinkProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); +typedef Tcl_Obj* (Tcl_FSLinkProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, + Tcl_Obj *toPtr)); typedef int (Tcl_FSLoadFileProc) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj *pathPtr, char * sym1, char * sym2, Tcl_PackageInitProc ** proc1Ptr, @@ -1670,11 +1671,11 @@ typedef struct Tcl_Filesystem { * with 'file mtime', 'file atime' and * the open-r/open-w/fcopy implementation * of 'file copy'. */ - Tcl_FSReadlinkProc *readlinkProc; + Tcl_FSLinkProc *linkProc; /* Function to process a - * 'Tcl_FSReadlink()' call. Should be + * 'Tcl_FSLink()' call. Should be * implemented only if the filesystem supports - * links. */ + * links (reading or creating). */ Tcl_FSListVolumesProc *listVolumesProc; /* Function to list any filesystem volumes * added by this filesystem. Should be diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 5866ac4..0793a2e 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.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: tclCmdAH.c,v 1.13 2001/07/31 19:12:06 vincentdarley Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.14 2001/08/23 17:37:07 vincentdarley Exp $ */ #include "tclInt.h" @@ -28,8 +28,6 @@ static int GetStatBuf _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_FSStatProc *statProc, struct stat *statPtr)); static char * GetTypeFromMode _ANSI_ARGS_((int mode)); -static int SplitPath _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr, int *argcPtr, char ***argvPtr)); static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp, char *varName, struct stat *statPtr)); @@ -782,7 +780,6 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Obj *resultPtr; int index; /* @@ -824,7 +821,6 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - resultPtr = Tcl_GetObjResult(interp); switch ((enum options) index) { case FILE_ATIME: { struct stat buf; @@ -845,7 +841,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) tval.actime = buf.st_atime; tval.modtime = buf.st_mtime; if (Tcl_FSUtime(objv[2], &tval) != 0) { - Tcl_AppendStringsToObj(resultPtr, + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "could not set access time for file \"", Tcl_GetString(objv[2]), "\": ", Tcl_PosixError(interp), (char *) NULL); @@ -861,7 +857,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } } - Tcl_SetLongObj(resultPtr, (long) buf.st_atime); + Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) buf.st_atime); return TCL_OK; } case FILE_ATTRIBUTES: { @@ -882,14 +878,28 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) return TclFileDeleteCmd(interp, objc, objv); } case FILE_DIRNAME: { - int argc; - char ** argv; + int splitElements; + Tcl_Obj *splitPtr; + Tcl_Obj *splitResultPtr = NULL; if (objc != 3) { goto only3Args; } - if (SplitPath(interp, objv[2], &argc, &argv) != TCL_OK) { - return TCL_ERROR; + /* + * The behaviour we want here is slightly different to + * the standard Tcl_FSSplitPath in the handling of home + * directories; Tcl_FSSplitPath preserves the "~" while + * this code computes the actual full path name, if we + * had just a single component. + */ + splitPtr = Tcl_FSSplitPath(objv[2], &splitElements); + if ((splitElements == 1) && (Tcl_GetString(objv[2])[0] == '~')) { + Tcl_DecrRefCount(splitPtr); + splitPtr = Tcl_FSGetNormalizedPath(interp, objv[2]); + if (splitPtr == NULL) { + return TCL_ERROR; + } + splitPtr = Tcl_FSSplitPath(splitPtr, &splitElements); } /* @@ -898,22 +908,17 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) * return the current directory. */ - if (argc > 1) { - Tcl_DString ds; - - Tcl_DStringInit(&ds); - Tcl_JoinPath(argc - 1, argv, &ds); - Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - } else if ((argc == 0) - || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) { - Tcl_SetStringObj(resultPtr, + if (splitElements > 1) { + splitResultPtr = Tcl_FSJoinPath(splitPtr, splitElements - 1); + } else if (splitElements == 0 || + (Tcl_FSGetPathType(objv[2], NULL, NULL) == TCL_PATH_RELATIVE)) { + splitResultPtr = Tcl_NewStringObj( ((tclPlatform == TCL_PLATFORM_MAC) ? ":" : "."), 1); } else { - Tcl_SetStringObj(resultPtr, argv[0], -1); + Tcl_ListObjIndex(NULL, splitPtr, 0, &splitResultPtr); } - ckfree((char *) argv); + Tcl_SetObjResult(interp, splitResultPtr); + Tcl_DecrRefCount(splitPtr); return TCL_OK; } case FILE_EXECUTABLE: { @@ -936,7 +941,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) fileName = Tcl_GetString(objv[2]); extension = TclGetExtension(fileName); if (extension != NULL) { - Tcl_SetStringObj(resultPtr, extension, -1); + Tcl_SetStringObj(Tcl_GetObjResult(interp), extension, -1); } return TCL_OK; } @@ -951,7 +956,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { value = S_ISDIR(buf.st_mode); } - Tcl_SetBooleanObj(resultPtr, value); + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value); return TCL_OK; } case FILE_ISFILE: { @@ -965,7 +970,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { value = S_ISREG(buf.st_mode); } - Tcl_SetBooleanObj(resultPtr, value); + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value); return TCL_OK; } case FILE_JOIN: { @@ -1012,7 +1017,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) tval.actime = buf.st_atime; tval.modtime = buf.st_mtime; if (Tcl_FSUtime(objv[2], &tval) != 0) { - Tcl_AppendStringsToObj(resultPtr, + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "could not set modification time for file \"", Tcl_GetString(objv[2]), "\": ", Tcl_PosixError(interp), (char *) NULL); @@ -1028,7 +1033,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } } - Tcl_SetLongObj(resultPtr, (long) buf.st_mtime); + Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) buf.st_mtime); return TCL_OK; } case FILE_MKDIR: { @@ -1050,7 +1055,8 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) if (fileName == NULL) { return TCL_ERROR; } - Tcl_SetStringObj(resultPtr, fileName, Tcl_DStringLength(&ds)); + Tcl_SetStringObj(Tcl_GetObjResult(interp), fileName, + Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); return TCL_OK; } @@ -1086,25 +1092,23 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) value = (geteuid() == buf.st_uid); #endif } - Tcl_SetBooleanObj(resultPtr, value); + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value); return TCL_OK; } case FILE_PATHTYPE: { - char *fileName; - if (objc != 3) { goto only3Args; } - fileName = Tcl_GetString(objv[2]); - switch (Tcl_GetPathType(fileName)) { + switch (Tcl_FSGetPathType(objv[2], NULL, NULL)) { case TCL_PATH_ABSOLUTE: - Tcl_SetStringObj(resultPtr, "absolute", -1); + Tcl_SetStringObj(Tcl_GetObjResult(interp), "absolute", -1); break; case TCL_PATH_RELATIVE: - Tcl_SetStringObj(resultPtr, "relative", -1); + Tcl_SetStringObj(Tcl_GetObjResult(interp), "relative", -1); break; case TCL_PATH_VOLUME_RELATIVE: - Tcl_SetStringObj(resultPtr, "volumerelative", -1); + Tcl_SetStringObj(Tcl_GetObjResult(interp), + "volumerelative", -1); break; } return TCL_OK; @@ -1126,7 +1130,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - contents = Tcl_FSReadlink(objv[2]); + contents = Tcl_FSLink(objv[2], NULL); if (contents == NULL) { Tcl_AppendResult(interp, "could not readlink \"", @@ -1153,7 +1157,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) if (extension == NULL) { Tcl_SetObjResult(interp, objv[2]); } else { - Tcl_SetStringObj(resultPtr, fileName, + Tcl_SetStringObj(Tcl_GetObjResult(interp), fileName, (int) (length - strlen(extension))); } return TCL_OK; @@ -1198,7 +1202,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } - Tcl_SetLongObj(resultPtr, (long) buf.st_size); + Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) buf.st_size); return TCL_OK; } case FILE_SPLIT: { @@ -1238,14 +1242,27 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) } } case FILE_TAIL: { - int argc; - char **argv; + int splitElements; + Tcl_Obj *splitPtr; if (objc != 3) { goto only3Args; } - if (SplitPath(interp, objv[2], &argc, &argv) != TCL_OK) { - return TCL_ERROR; + /* + * The behaviour we want here is slightly different to + * the standard Tcl_FSSplitPath in the handling of home + * directories; Tcl_FSSplitPath preserves the "~" while + * this code computes the actual full path name, if we + * had just a single component. + */ + splitPtr = Tcl_FSSplitPath(objv[2], &splitElements); + if ((splitElements == 1) && (Tcl_GetString(objv[2])[0] == '~')) { + Tcl_DecrRefCount(splitPtr); + splitPtr = Tcl_FSGetNormalizedPath(interp, objv[2]); + if (splitPtr == NULL) { + return TCL_ERROR; + } + splitPtr = Tcl_FSSplitPath(splitPtr, &splitElements); } /* @@ -1253,13 +1270,16 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) * and it is the root of an absolute path. */ - if (argc > 0) { - if ((argc > 1) - || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) { - Tcl_SetStringObj(resultPtr, argv[argc - 1], -1); + if (splitElements > 0) { + if ((splitElements > 1) + || (Tcl_FSGetPathType(objv[2], NULL, NULL) == TCL_PATH_RELATIVE)) { + + Tcl_Obj *tail = NULL; + Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &tail); + Tcl_SetObjResult(interp, tail); } } - ckfree((char *) argv); + Tcl_DecrRefCount(splitPtr); return TCL_OK; } case FILE_TYPE: { @@ -1271,7 +1291,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { return TCL_ERROR; } - Tcl_SetStringObj(resultPtr, + Tcl_SetStringObj(Tcl_GetObjResult(interp), GetTypeFromMode((unsigned short) buf.st_mode), -1); return TCL_OK; } @@ -1280,7 +1300,8 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - return Tcl_FSListVolumes(interp); + Tcl_SetObjResult(interp, Tcl_FSListVolumes()); + return TCL_OK; } case FILE_WRITABLE: { if (objc != 3) { @@ -1298,63 +1319,6 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) /* *--------------------------------------------------------------------------- * - * SplitPath -- - * - * Utility procedure used by Tcl_FileObjCmd() to split a path. - * Differs from standard Tcl_SplitPath in its handling of home - * directories; Tcl_SplitPath preserves the "~" while this - * procedure computes the actual full path name. - * - * Results: - * The return value is TCL_OK if the path could be split, TCL_ERROR - * otherwise. If TCL_ERROR was returned, an error message is left - * in interp. If TCL_OK was returned, *argvPtr is set to a newly - * allocated array of strings that represent the individual - * directories in the specified path, and *argcPtr is filled with - * the length of that array. - * - * Side effects: - * Memory allocated. The caller must eventually free this memory - * by calling ckfree() on *argvPtr. - * - *--------------------------------------------------------------------------- - */ - -static int -SplitPath(interp, objPtr, argcPtr, argvPtr) - Tcl_Interp *interp; /* Interp for error return. May be NULL. */ - Tcl_Obj *objPtr; /* Path to be split. */ - int *argcPtr; /* Filled with length of following array. */ - char ***argvPtr; /* Filled with array of strings representing - * the elements of the specified path. */ -{ - char *fileName; - - fileName = Tcl_GetString(objPtr); - - /* - * If there is only one element, and it starts with a tilde, - * perform tilde substitution and resplit the path. - */ - - Tcl_SplitPath(fileName, argcPtr, argvPtr); - if ((*argcPtr == 1) && (fileName[0] == '~')) { - Tcl_DString ds; - - ckfree((char *) *argvPtr); - fileName = Tcl_TranslateFileName(interp, fileName, &ds); - if (fileName == NULL) { - return TCL_ERROR; - } - Tcl_SplitPath(fileName, argcPtr, argvPtr); - Tcl_DStringFree(&ds); - } - return TCL_OK; -} - -/* - *--------------------------------------------------------------------------- - * * CheckAccess -- * * Utility procedure used by Tcl_FileObjCmd() to query file diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 2a0da68..8aa701d 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDecls.h,v 1.53 2001/07/31 19:12:06 vincentdarley Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.54 2001/08/23 17:37:07 vincentdarley Exp $ */ #ifndef _TCLDECLS @@ -1401,7 +1401,8 @@ EXTERN int Tcl_FSMatchInDirectory _ANSI_ARGS_(( Tcl_Obj * pathPtr, char * pattern, Tcl_GlobTypeData * types)); /* 446 */ -EXTERN Tcl_Obj* Tcl_FSReadlink _ANSI_ARGS_((Tcl_Obj * pathPtr)); +EXTERN Tcl_Obj* Tcl_FSLink _ANSI_ARGS_((Tcl_Obj * pathPtr, + Tcl_Obj * toPtr)); /* 447 */ EXTERN int Tcl_FSRemoveDirectory _ANSI_ARGS_((Tcl_Obj * pathPtr, int recursive, Tcl_Obj ** errorPtr)); @@ -1461,7 +1462,7 @@ EXTERN Tcl_Obj* Tcl_FSJoinToPath _ANSI_ARGS_((Tcl_Obj * basePtr, EXTERN ClientData Tcl_FSGetInternalRep _ANSI_ARGS_(( Tcl_Obj* pathObjPtr, Tcl_Filesystem * fsPtr)); /* 466 */ -EXTERN char* Tcl_FSGetTranslatedPath _ANSI_ARGS_(( +EXTERN Tcl_Obj* Tcl_FSGetTranslatedPath _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 467 */ EXTERN int Tcl_FSEvalFile _ANSI_ARGS_((Tcl_Interp * interp, @@ -1478,7 +1479,7 @@ EXTERN Tcl_Obj* Tcl_FSFileSystemInfo _ANSI_ARGS_(( /* 471 */ EXTERN Tcl_Obj* Tcl_FSPathSeparator _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 472 */ -EXTERN int Tcl_FSListVolumes _ANSI_ARGS_((Tcl_Interp * interp)); +EXTERN Tcl_Obj* Tcl_FSListVolumes _ANSI_ARGS_((void)); /* 473 */ EXTERN int Tcl_FSRegister _ANSI_ARGS_((ClientData clientData, Tcl_Filesystem * fsPtr)); @@ -1486,6 +1487,9 @@ EXTERN int Tcl_FSRegister _ANSI_ARGS_((ClientData clientData, EXTERN int Tcl_FSUnregister _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 475 */ EXTERN ClientData Tcl_FSData _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); +/* 476 */ +EXTERN char* Tcl_FSGetTranslatedStringPath _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj* pathPtr)); typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; @@ -1991,7 +1995,7 @@ typedef struct TclStubs { int (*tcl_FSDeleteFile) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 443 */ int (*tcl_FSLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, char * sym1, char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, ClientData * clientDataPtr, Tcl_FSUnloadFileProc ** unloadProcPtr)); /* 444 */ int (*tcl_FSMatchInDirectory) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * result, Tcl_Obj * pathPtr, char * pattern, Tcl_GlobTypeData * types)); /* 445 */ - Tcl_Obj* (*tcl_FSReadlink) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 446 */ + Tcl_Obj* (*tcl_FSLink) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj * toPtr)); /* 446 */ int (*tcl_FSRemoveDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr, int recursive, Tcl_Obj ** errorPtr)); /* 447 */ int (*tcl_FSRenameFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 448 */ int (*tcl_FSLstat) _ANSI_ARGS_((Tcl_Obj * pathPtr, struct stat * buf)); /* 449 */ @@ -2011,16 +2015,17 @@ typedef struct TclStubs { Tcl_Obj* (*tcl_FSGetNormalizedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathObjPtr)); /* 463 */ Tcl_Obj* (*tcl_FSJoinToPath) _ANSI_ARGS_((Tcl_Obj * basePtr, int objc, Tcl_Obj *CONST objv[])); /* 464 */ ClientData (*tcl_FSGetInternalRep) _ANSI_ARGS_((Tcl_Obj* pathObjPtr, Tcl_Filesystem * fsPtr)); /* 465 */ - char* (*tcl_FSGetTranslatedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 466 */ + Tcl_Obj* (*tcl_FSGetTranslatedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 466 */ int (*tcl_FSEvalFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * fileName)); /* 467 */ Tcl_Obj* (*tcl_FSNewNativePath) _ANSI_ARGS_((Tcl_Obj* fromFilesystem, ClientData clientData)); /* 468 */ char* (*tcl_FSGetNativePath) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 469 */ Tcl_Obj* (*tcl_FSFileSystemInfo) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 470 */ Tcl_Obj* (*tcl_FSPathSeparator) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 471 */ - int (*tcl_FSListVolumes) _ANSI_ARGS_((Tcl_Interp * interp)); /* 472 */ + Tcl_Obj* (*tcl_FSListVolumes) _ANSI_ARGS_((void)); /* 472 */ int (*tcl_FSRegister) _ANSI_ARGS_((ClientData clientData, Tcl_Filesystem * fsPtr)); /* 473 */ int (*tcl_FSUnregister) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 474 */ ClientData (*tcl_FSData) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 475 */ + char* (*tcl_FSGetTranslatedStringPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 476 */ } TclStubs; #ifdef __cplusplus @@ -3845,9 +3850,9 @@ extern TclStubs *tclStubsPtr; #define Tcl_FSMatchInDirectory \ (tclStubsPtr->tcl_FSMatchInDirectory) /* 445 */ #endif -#ifndef Tcl_FSReadlink -#define Tcl_FSReadlink \ - (tclStubsPtr->tcl_FSReadlink) /* 446 */ +#ifndef Tcl_FSLink +#define Tcl_FSLink \ + (tclStubsPtr->tcl_FSLink) /* 446 */ #endif #ifndef Tcl_FSRemoveDirectory #define Tcl_FSRemoveDirectory \ @@ -3965,6 +3970,10 @@ extern TclStubs *tclStubsPtr; #define Tcl_FSData \ (tclStubsPtr->tcl_FSData) /* 475 */ #endif +#ifndef Tcl_FSGetTranslatedStringPath +#define Tcl_FSGetTranslatedStringPath \ + (tclStubsPtr->tcl_FSGetTranslatedStringPath) /* 476 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 8576ca8..7f3c590 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.9 2001/08/11 18:43:21 vincentdarley Exp $ + * RCS: @(#) $Id: tclFCmd.c,v 1.10 2001/08/23 17:37:07 vincentdarley Exp $ */ #include "tclInt.h" @@ -792,8 +792,7 @@ FileBasename(interp, pathPtr) if (objc > 0) { Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr); if ((objc == 1) && - (Tcl_GetPathType(Tcl_GetString(resultPtr)) - != TCL_PATH_RELATIVE)) { + (Tcl_FSGetPathType(resultPtr, NULL, NULL) != TCL_PATH_RELATIVE)) { resultPtr = NULL; } } diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 0da7299..d9d7b62 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.16 2001/08/07 01:00:02 hobbs Exp $ + * RCS: @(#) $Id: tclFileName.c,v 1.17 2001/08/23 17:37:07 vincentdarley Exp $ */ #include "tclInt.h" @@ -20,11 +20,19 @@ /* * The following regular expression matches the root portion of a Windows * absolute or volume relative path. It will match both UNC and drive relative - * paths. + * paths. This pattern is no longer used, since it has been replaced by + * the ExtractWinRoot function. */ #define WIN_ROOT_PATTERN "^(([a-zA-Z]:)|[/\\\\][/\\\\]+([^/\\\\]+)[/\\\\]+([^/\\\\]+)|([/\\\\]))([/\\\\])*" +/* + * This define is used to activate Tcl's interpretation of Unix-style + * paths (containing forward slashes) on MacOS. + */ +#define MAC_UNDERSTANDS_UNIX_PATHS + +#ifdef MAC_UNDERSTANDS_UNIX_PATHS /* * The following regular expression matches the root portion of a Macintosh * absolute path. It will match degenerate Unix-style paths, tilde paths, @@ -32,6 +40,15 @@ */ #define MAC_ROOT_PATTERN "^((/+([.][.]?/+)*([.][.]?)?)|(~[^:/]*)(/[^:]*)?|(~[^:]*)(:.*)?|/+([.][.]?/+)*([^:/]+)(/[^:]*)?|([^:]+):.*)$" +#else +/* + * The following regular expression and some code below needs to be updated + * to allow complete removal of unix-style path matching. For the moment + * this regular expression is the same as the one above. + */ + +#define MAC_ROOT_PATTERN "^((/+([.][.]?/+)*([.][.]?)?)|(~[^:/]*)(/[^:]*)?|(~[^:]*)(:.*)?|/+([.][.]?/+)*([^:/]+)(/[^:]*)?|([^:]+):.*)$" +#endif /* * The following variables are used to hold precompiled regular expressions @@ -65,12 +82,9 @@ static void FileNameCleanup _ANSI_ARGS_((ClientData clientData)); static void FileNameInit _ANSI_ARGS_((void)); static int SkipToChar _ANSI_ARGS_((char **stringPtr, char *match)); -static char * SplitMacPath _ANSI_ARGS_((CONST char *path, - Tcl_DString *bufPtr)); -static char * SplitWinPath _ANSI_ARGS_((CONST char *path, - Tcl_DString *bufPtr)); -static char * SplitUnixPath _ANSI_ARGS_((CONST char *path, - Tcl_DString *bufPtr)); +static Tcl_Obj* SplitMacPath _ANSI_ARGS_((CONST char *path)); +static Tcl_Obj* SplitWinPath _ANSI_ARGS_((CONST char *path)); +static Tcl_Obj* SplitUnixPath _ANSI_ARGS_((CONST char *path)); /* *---------------------------------------------------------------------- @@ -175,6 +189,11 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) break; } if (host[hlen] == 0 || host[hlen+1] == 0) { + /* + * The path given is simply of the form + * '/foo', '//foo', '/////foo' or the same + * with backslashes. + */ *typePtr = TCL_PATH_VOLUME_RELATIVE; Tcl_DStringAppend(resultPtr, "/", 1); return &path[2]; @@ -234,6 +253,10 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) * * Determines whether a given path is relative to the current * directory, relative to the current volume, or absolute. + * + * The objectified Tcl_FSGetPathType should be used in + * preference to this function (as you can see below, this + * is just a wrapper around that other function). * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or @@ -249,58 +272,174 @@ Tcl_PathType Tcl_GetPathType(path) char *path; { - ThreadSpecificData *tsdPtr; - Tcl_PathType type = TCL_PATH_ABSOLUTE; - Tcl_RegExp re; - - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - /* - * Paths that begin with / or ~ are absolute. - */ + Tcl_PathType type; + Tcl_Obj *tempObj = Tcl_NewStringObj(path,-1); + Tcl_IncrRefCount(tempObj); + type = Tcl_FSGetPathType(tempObj, NULL, NULL); + Tcl_DecrRefCount(tempObj); + return type; +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetNativePathType -- + * + * Determines whether a given path is relative to the current + * directory, relative to the current volume, or absolute, but + * ONLY FOR THE NATIVE FILESYSTEM. This function is called from + * tclIOUtil.c (but needs to be here due to its dependence on + * static variables/functions in this file). The exported + * function Tcl_FSGetPathType should be used by extensions. + * + * Results: + * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or + * TCL_PATH_VOLUME_RELATIVE. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if ((path[0] != '/') && (path[0] != '~')) { - type = TCL_PATH_RELATIVE; +Tcl_PathType +TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, driveNameRef) + Tcl_Obj *pathObjPtr; + int *driveNameLengthPtr; + Tcl_Obj **driveNameRef; +{ + Tcl_PathType type = TCL_PATH_ABSOLUTE; + int pathLen; + char *path = Tcl_GetStringFromObj(pathObjPtr, &pathLen); + + if (path[0] == '~') { + /* + * This case is common to all platforms. + * Paths that begin with ~ are absolute. + */ + if (driveNameLengthPtr != NULL) { + char *end = path + 1; + while ((*end != '\0') && (*end != '/')) { + end++; } - break; - - case TCL_PLATFORM_MAC: - if (path[0] == ':') { - type = TCL_PATH_RELATIVE; - } else if (path[0] != '~') { - tsdPtr = TCL_TSD_INIT(&dataKey); - + *driveNameLengthPtr = end - path; + } + } else { + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: { + char *origPath = path; + /* - * Since we have eliminated the easy cases, use the - * root pattern to look for the other types. + * Paths that begin with / are absolute. */ - FileNameInit(); - re = Tcl_GetRegExpFromObj(NULL, tsdPtr->macRootPatternPtr, - REG_ADVANCED); - - if (!Tcl_RegExpExec(NULL, re, path, path)) { +#ifdef __QNX__ + /* + * Check for QNX // prefix + */ + if (*path && (pathLen > 3) && (path[0] == '/') + && (path[1] == '/') && isdigit(UCHAR(path[2]))) { + path += 3; + while (isdigit(UCHAR(*path))) { + ++path; + } + } +#endif + if (path[0] == '/') { + if (driveNameLengthPtr != NULL) { + /* + * We need this addition in case the QNX code + * was used + */ + *driveNameLengthPtr = (1 + path - origPath); + } + } else { + type = TCL_PATH_RELATIVE; + } + break; + } + case TCL_PLATFORM_MAC: + if (path[0] == ':') { type = TCL_PATH_RELATIVE; } else { - char *unixRoot, *dummy; + ThreadSpecificData *tsdPtr; + Tcl_RegExp re; + + tsdPtr = TCL_TSD_INIT(&dataKey); + + /* + * Since we have eliminated the easy cases, use the + * root pattern to look for the other types. + */ - Tcl_RegExpRange(re, 2, &unixRoot, &dummy); - if (unixRoot) { + FileNameInit(); + re = Tcl_GetRegExpFromObj(NULL, tsdPtr->macRootPatternPtr, + REG_ADVANCED); + + if (!Tcl_RegExpExec(NULL, re, path, path)) { type = TCL_PATH_RELATIVE; + } else { + char *root, *end; + + Tcl_RegExpRange(re, 2, &root, &end); + if (root != NULL) { + type = TCL_PATH_RELATIVE; + } else { + if (driveNameLengthPtr != NULL) { + Tcl_RegExpRange(re, 0, &root, &end); + *driveNameLengthPtr = end - root; + } +#ifdef MAC_UNDERSTANDS_UNIX_PATHS + if (driveNameRef != NULL) { + if (*root == '/') { + char *c; + int gotColon = 0; + *driveNameRef = Tcl_NewStringObj(root + 1, end - root -1); + c = Tcl_GetString(*driveNameRef); + while (*c != '\0') { + if (*c == '/') { + gotColon++; + *c = ':'; + } + c++; + } + /* + * If there is no colon, we have just a volume name + * so we must add a colon so it is an absolute path. + */ + if (gotColon == 0) { + Tcl_AppendToObj(*driveNameRef, ":", 1); + } else if ((gotColon > 1) && (*(c-1) == ':')) { + /* We have an extra colon */ + Tcl_SetObjLength(*driveNameRef, + c - Tcl_GetString(*driveNameRef) - 1); + } + } + } +#endif + } } } - } - break; - - case TCL_PLATFORM_WINDOWS: - if (path[0] != '~') { + break; + + case TCL_PLATFORM_WINDOWS: { Tcl_DString ds; - + CONST char *rootEnd; + Tcl_DStringInit(&ds); - (VOID)ExtractWinRoot(path, &ds, 0, &type); + rootEnd = ExtractWinRoot(path, &ds, 0, &type); + if ((rootEnd != path) && (driveNameLengthPtr != NULL)) { + *driveNameLengthPtr = rootEnd - path; + if (driveNameRef != NULL) { + *driveNameRef = Tcl_NewStringObj(Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); + Tcl_IncrRefCount(*driveNameRef); + } + } Tcl_DStringFree(&ds); + break; } - break; + } } return type; } @@ -308,16 +447,15 @@ Tcl_GetPathType(path) /* *--------------------------------------------------------------------------- * - * Tcl_FSSplitPath -- + * TclpNativeSplitPath -- * * This function takes the given Tcl_Obj, which should be a valid * path, and returns a Tcl List object containing each segment * of that path as an element. * - * Note this function currently calls the older Tcl_SplitPath - * routine, which therefore requires more memory allocation and - * deallocation than necessary. We could easily rewrite this for - * greater efficiency. + * Note this function currently calls the older Split(Plat)Path + * functions, which require more memory allocation than is + * desirable. * * Results: * Returns list object with refCount of zero. If the passed in @@ -331,23 +469,37 @@ Tcl_GetPathType(path) */ Tcl_Obj* -Tcl_FSSplitPath(pathPtr, lenPtr) +TclpNativeSplitPath(pathPtr, lenPtr) Tcl_Obj *pathPtr; /* Path to split. */ int *lenPtr; /* int to store number of path elements. */ { - int argc, i; - char **argv; - Tcl_Obj *resultPtr = Tcl_NewObj(); + Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */ - Tcl_SplitPath(Tcl_GetString(pathPtr), &argc, &argv); - if (lenPtr != NULL) { - *lenPtr = argc; + /* + * Perform platform specific splitting. + */ + + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + resultPtr = SplitUnixPath(Tcl_GetString(pathPtr)); + break; + + case TCL_PLATFORM_WINDOWS: + resultPtr = SplitWinPath(Tcl_GetString(pathPtr)); + break; + + case TCL_PLATFORM_MAC: + resultPtr = SplitMacPath(Tcl_GetString(pathPtr)); + break; } - for (i = 0; i < argc; i++) { - Tcl_ListObjAppendElement(NULL, resultPtr, - Tcl_NewStringObj(argv[i], -1)); + + /* + * Compute the number of elements in the result. + */ + + if (lenPtr != NULL) { + Tcl_ListObjLength(NULL, resultPtr, lenPtr); } - ckfree((char *) argv); return resultPtr; } @@ -385,48 +537,35 @@ Tcl_SplitPath(path, argcPtr, argvPtr) char ***argvPtr; /* Pointer to place to store pointer to array * of pointers to path elements. */ { + Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */ + Tcl_Obj *tmpPtr; int i, size; char *p; - Tcl_DString buffer; - - Tcl_DStringInit(&buffer); /* - * Perform platform specific splitting. These routines will leave the - * result in the specified buffer. Individual elements are terminated - * with a null character. + * Perform the splitting, using objectified, vfs-aware code. */ - p = NULL; /* Needed only to prevent gcc warnings. */ - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - p = SplitUnixPath(path, &buffer); - break; + tmpPtr = Tcl_NewStringObj(path, -1); + Tcl_IncrRefCount(tmpPtr); + resultPtr = Tcl_FSSplitPath(tmpPtr, argcPtr); + Tcl_DecrRefCount(tmpPtr); - case TCL_PLATFORM_WINDOWS: - p = SplitWinPath(path, &buffer); - break; - - case TCL_PLATFORM_MAC: - p = SplitMacPath(path, &buffer); - break; - } - - /* - * Compute the number of elements in the result. - */ - - size = Tcl_DStringLength(&buffer); - *argcPtr = 0; - for (i = 0; i < size; i++) { - if (p[i] == '\0') { - (*argcPtr)++; - } + /* Calculate space required for the result */ + + size = 1; + for (i = 0; i < *argcPtr; i++) { + int len; + Tcl_Obj *elt; + + Tcl_ListObjIndex(NULL, resultPtr, i, &elt); + Tcl_GetStringFromObj(elt, &len); + size += len + 1; } /* - * Allocate a buffer large enough to hold the contents of the - * DString plus the argv pointers and the terminating NULL pointer. + * Allocate a buffer large enough to hold the contents of all of + * the list plus the argv pointers and the terminating NULL pointer. */ *argvPtr = (char **) ckalloc((unsigned) @@ -434,23 +573,33 @@ Tcl_SplitPath(path, argcPtr, argvPtr) /* * Position p after the last argv pointer and copy the contents of - * the DString. + * the list in, piece by piece. */ p = (char *) &(*argvPtr)[(*argcPtr) + 1]; - memcpy((VOID *) p, (VOID *) Tcl_DStringValue(&buffer), (size_t) size); - + for (i = 0; i < *argcPtr; i++) { + int len; + Tcl_Obj *elt; + char *str; + + Tcl_ListObjIndex(NULL, resultPtr, i, &elt); + str = Tcl_GetStringFromObj(elt, &len); + strncpy(p, str, len+1); + p += len+1; + } + /* * Now set up the argv pointers. */ + p = (char *) &(*argvPtr)[(*argcPtr) + 1]; + for (i = 0; i < *argcPtr; i++) { (*argvPtr)[i] = p; while ((*p++) != '\0') {} } (*argvPtr)[i] = NULL; - Tcl_DStringFree(&buffer); } /* @@ -458,12 +607,11 @@ Tcl_SplitPath(path, argcPtr, argvPtr) * * SplitUnixPath -- * - * This routine is used by Tcl_SplitPath to handle splitting + * This routine is used by Tcl_(FS)SplitPath to handle splitting * Unix paths. * * Results: - * Stores a null separated array of strings in the specified - * Tcl_DString. + * Returns a newly allocated Tcl list object. * * Side effects: * None. @@ -471,13 +619,13 @@ Tcl_SplitPath(path, argcPtr, argvPtr) *---------------------------------------------------------------------- */ -static char * -SplitUnixPath(path, bufPtr) +static Tcl_Obj* +SplitUnixPath(path) CONST char *path; /* Pointer to string containing a path. */ - Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */ { int length; CONST char *p, *elementStart; + Tcl_Obj *result = Tcl_NewObj(); /* * Deal with the root directory as a special case. @@ -497,7 +645,7 @@ SplitUnixPath(path, bufPtr) #endif if (path[0] == '/') { - Tcl_DStringAppend(bufPtr, "/", 2); + Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj("/",1)); p = path+1; } else { p = path; @@ -515,30 +663,33 @@ SplitUnixPath(path, bufPtr) } length = p - elementStart; if (length > 0) { + Tcl_Obj *nextElt; if ((elementStart[0] == '~') && (elementStart != path)) { - Tcl_DStringAppend(bufPtr, "./", 2); + nextElt = Tcl_NewStringObj("./",2); + Tcl_AppendToObj(nextElt, elementStart, length); + } else { + nextElt = Tcl_NewStringObj(elementStart, length); } - Tcl_DStringAppend(bufPtr, elementStart, length); - Tcl_DStringAppend(bufPtr, "", 1); + Tcl_ListObjAppendElement(NULL, result, nextElt); } if (*p++ == '\0') { break; } } - return Tcl_DStringValue(bufPtr); + return result; } + /* *---------------------------------------------------------------------- * * SplitWinPath -- * - * This routine is used by Tcl_SplitPath to handle splitting + * This routine is used by Tcl_(FS)SplitPath to handle splitting * Windows paths. * * Results: - * Stores a null separated array of strings in the specified - * Tcl_DString. + * Returns a newly allocated Tcl list object. * * Side effects: * None. @@ -546,25 +697,30 @@ SplitUnixPath(path, bufPtr) *---------------------------------------------------------------------- */ -static char * -SplitWinPath(path, bufPtr) +static Tcl_Obj* +SplitWinPath(path) CONST char *path; /* Pointer to string containing a path. */ - Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */ { int length; CONST char *p, *elementStart; Tcl_PathType type = TCL_PATH_ABSOLUTE; - - p = ExtractWinRoot(path, bufPtr, 0, &type); + Tcl_DString buf; + Tcl_Obj *result = Tcl_NewObj(); + Tcl_DStringInit(&buf); + + p = ExtractWinRoot(path, &buf, 0, &type); /* * Terminate the root portion, if we matched something. */ if (p != path) { - Tcl_DStringAppend(bufPtr, "", 1); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(Tcl_DStringValue(&buf), + Tcl_DStringLength(&buf))); } - + Tcl_DStringFree(&buf); + /* * Split on slashes. Embedded elements that start with tilde will be * prefixed with "./" so they are not affected by tilde substitution. @@ -577,15 +733,18 @@ SplitWinPath(path, bufPtr) } length = p - elementStart; if (length > 0) { + Tcl_Obj *nextElt; if ((elementStart[0] == '~') && (elementStart != path)) { - Tcl_DStringAppend(bufPtr, "./", 2); + nextElt = Tcl_NewStringObj("./",2); + Tcl_AppendToObj(nextElt, elementStart, length); + } else { + nextElt = Tcl_NewStringObj(elementStart, length); } - Tcl_DStringAppend(bufPtr, elementStart, length); - Tcl_DStringAppend(bufPtr, "", 1); + Tcl_ListObjAppendElement(NULL, result, nextElt); } } while (*p++ != '\0'); - return Tcl_DStringValue(bufPtr); + return result; } /* @@ -593,11 +752,11 @@ SplitWinPath(path, bufPtr) * * SplitMacPath -- * - * This routine is used by Tcl_SplitPath to handle splitting + * This routine is used by Tcl_(FS)SplitPath to handle splitting * Macintosh paths. * * Results: - * Returns a newly allocated argv array. + * Returns a newly allocated Tcl list object. * * Side effects: * None. @@ -605,17 +764,19 @@ SplitWinPath(path, bufPtr) *---------------------------------------------------------------------- */ -static char * -SplitMacPath(path, bufPtr) +static Tcl_Obj* +SplitMacPath(path) CONST char *path; /* Pointer to string containing a path. */ - Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */ { int isMac = 0; /* 1 if is Mac-style, 0 if Unix-style path. */ int i, length; CONST char *p, *elementStart; Tcl_RegExp re; + Tcl_Obj *result; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + result = Tcl_NewObj(); + /* * Initialize the path name parser for Macintosh path names. */ @@ -632,6 +793,7 @@ SplitMacPath(path, bufPtr) if (Tcl_RegExpExec(NULL, re, path, path) == 1) { char *start, *end; + Tcl_Obj *nextElt; /* * Treat degenerate absolute paths like / and /../.. as @@ -640,10 +802,11 @@ SplitMacPath(path, bufPtr) Tcl_RegExpRange(re, 2, &start, &end); if (start) { - Tcl_DStringAppend(bufPtr, ":", 1); + Tcl_Obj *elt = Tcl_NewStringObj(":", 1); Tcl_RegExpRange(re, 0, &start, &end); - Tcl_DStringAppend(bufPtr, path, end - start + 1); - return Tcl_DStringValue(bufPtr); + Tcl_AppendToObj(elt, path, end - start); + Tcl_ListObjAppendElement(NULL, result, elt); + return result; } Tcl_RegExpRange(re, 5, &start, &end); @@ -696,8 +859,9 @@ SplitMacPath(path, bufPtr) * we are forcing the DString to contain an extra null at the end. */ - Tcl_DStringAppend(bufPtr, start, length); - Tcl_DStringAppend(bufPtr, ":", 2); + nextElt = Tcl_NewStringObj(start, length); + Tcl_AppendToObj(nextElt, ":", 1); + Tcl_ListObjAppendElement(NULL, result, nextElt); p = end; } else { isMac = (strchr(path, ':') != NULL); @@ -716,7 +880,7 @@ SplitMacPath(path, bufPtr) length = p - elementStart; if (length == 1) { while (*p == ':') { - Tcl_DStringAppend(bufPtr, "::", 3); + Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj("::",2)); elementStart = p++; } } else { @@ -729,8 +893,8 @@ SplitMacPath(path, bufPtr) elementStart++; length--; } - Tcl_DStringAppend(bufPtr, elementStart, length); - Tcl_DStringAppend(bufPtr, "", 1); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(elementStart, length)); elementStart = p++; } } @@ -739,8 +903,8 @@ SplitMacPath(path, bufPtr) && (strchr(elementStart+1, '/') == NULL)) { elementStart++; } - Tcl_DStringAppend(bufPtr, elementStart, -1); - Tcl_DStringAppend(bufPtr, "", 1); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(elementStart, -1)); } } else { @@ -756,16 +920,21 @@ SplitMacPath(path, bufPtr) length = p - elementStart; if (length > 0) { if ((length == 1) && (elementStart[0] == '.')) { - Tcl_DStringAppend(bufPtr, ":", 2); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(":", 1)); } else if ((length == 2) && (elementStart[0] == '.') && (elementStart[1] == '.')) { - Tcl_DStringAppend(bufPtr, "::", 3); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj("::", 2)); } else { + Tcl_Obj *nextElt; if (*elementStart == '~') { - Tcl_DStringAppend(bufPtr, ":", 1); + nextElt = Tcl_NewStringObj(":",1); + Tcl_AppendToObj(nextElt, elementStart, length); + } else { + nextElt = Tcl_NewStringObj(elementStart, length); } - Tcl_DStringAppend(bufPtr, elementStart, length); - Tcl_DStringAppend(bufPtr, "", 1); + Tcl_ListObjAppendElement(NULL, result, nextElt); } } if (*p++ == '\0') { @@ -773,7 +942,7 @@ SplitMacPath(path, bufPtr) } } } - return Tcl_DStringValue(bufPtr); + return result; } /* @@ -820,20 +989,12 @@ Tcl_FSJoinToPath(basePtr, objc, objv) /* *--------------------------------------------------------------------------- * - * Tcl_FSJoinPath -- + * TclpNativeJoinPath -- * - * This function takes the given Tcl_Obj, which should be a valid - * list, and returns the path object given by considering the - * first 'elements' elements as valid path segments. If elements < 0, - * we use the entire list. - * - * Note this function currently calls the older Tcl_JoinPath - * routine, which therefore requires more memory allocation and - * deallocation than necessary. We could easily rewrite this for - * greater efficiency. + * 'prefix' is absolute, 'joining' is relative to prefix. * * Results: - * Returns object with refCount of zero. + * modifies prefix * * Side effects: * None. @@ -841,42 +1002,188 @@ Tcl_FSJoinToPath(basePtr, objc, objv) *--------------------------------------------------------------------------- */ -Tcl_Obj* -Tcl_FSJoinPath(listObj, elements) - Tcl_Obj *listObj; - int elements; +void +TclpNativeJoinPath(prefix, joining) + Tcl_Obj *prefix; + char* joining; { - char ** argv; - int count; - Tcl_DString ds; - Tcl_Obj *res; - if (elements < 0) { - if (Tcl_ListObjLength(NULL, listObj, &elements) != TCL_OK) { - return NULL; - } - } else { - /* Just make sure it is a valid list */ - int listTest; - if (Tcl_ListObjLength(NULL, listObj, &listTest) != TCL_OK) { - return NULL; + int length, needsSep; + char *dest, *p, *start; + + start = Tcl_GetStringFromObj(prefix, &length); + + /* + * Remove the ./ from tilde prefixed elements unless + * it is the first component. + */ + + p = joining; + + if (length != 0) { + if ((p[0] == '.') && (p[1] == '/') && (p[2] == '~')) { + p += 2; } - /* - * It doesn't actually matter if 'elements' is greater - * than the actual number of elements. - */ } - argv = (char **)ckalloc(elements*sizeof(char*)); - - for (count = 0; count < elements; count++) { - Tcl_Obj* elt; - Tcl_ListObjIndex(NULL, listObj,count,&elt); - argv[count] = Tcl_GetString(elt); + + if (*p == '\0') { + return; } - Tcl_DStringInit(&ds); - res = Tcl_NewStringObj(Tcl_JoinPath(elements, argv, &ds),-1); - Tcl_DStringFree(&ds); - ckfree((char*)argv); - return res; + + + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + + /* + * Append a separator if needed. + */ + + if (length > 0 && (start[length-1] != '/')) { + Tcl_AppendToObj(prefix, "/", 1); + length++; + } + needsSep = 0; + + /* + * Append the element, eliminating duplicate and trailing + * slashes. + */ + + Tcl_SetObjLength(prefix, length + strlen(p)); + + dest = Tcl_GetString(prefix) + length; + for (; *p != '\0'; p++) { + if (*p == '/') { + while (p[1] == '/') { + p++; + } + if (p[1] != '\0') { + if (needsSep) { + *dest++ = '/'; + } + } + } else { + *dest++ = *p; + needsSep = 1; + } + } + length = dest - Tcl_GetString(prefix); + Tcl_SetObjLength(prefix, length); + break; + + case TCL_PLATFORM_WINDOWS: + /* + * Check to see if we need to append a separator. + */ + + if ((length > 0) && + (start[length-1] != '/') && (start[length-1] != ':')) { + Tcl_AppendToObj(prefix, "/", 1); + length++; + } + needsSep = 0; + + /* + * Append the element, eliminating duplicate and + * trailing slashes. + */ + + Tcl_SetObjLength(prefix, length + strlen(p)); + dest = Tcl_GetString(prefix) + length; + for (; *p != '\0'; p++) { + if ((*p == '/') || (*p == '\\')) { + while ((p[1] == '/') || (p[1] == '\\')) { + p++; + } + if (p[1] != '\0') { + if (needsSep) { + *dest++ = '/'; + } + } + } else { + *dest++ = *p; + needsSep = 1; + } + } + length = dest - Tcl_GetString(prefix); + Tcl_SetObjLength(prefix, length); + break; + + case TCL_PLATFORM_MAC: { + int newLength; + + /* + * Sort out separators. We basically add the object we've + * been given, but we have to make sure that there is + * exactly one separator inbetween (unless the object we're + * adding contains multiple contiguous colons, all of which + * we must add). Also if an object is just ':' we don't + * both to add it unless it's the very first element. + */ + +#ifdef MAC_UNDERSTANDS_UNIX_PATHS + int adjustedPath = 0; + if ((strchr(p, ':') == NULL) && (strchr(p, '/') != NULL)) { + char *start = p; + adjustedPath = 1; + while (*start != '\0') { + if (*start == '/') { + *start = ':'; + } + start++; + } + } +#endif + if (length > 0) { + if ((p[0] == ':') && (p[1] == '\0')) { + return; + } + if (start[length-1] != ':') { + if (*p != '\0' && *p != ':') { + Tcl_AppendToObj(prefix, ":", 1); + length++; + } + } else if (*p == ':') { + p++; + } + } else { + if (*p != '\0' && *p != ':') { + Tcl_AppendToObj(prefix, ":", 1); + length++; + } + } + + /* + * Append the element + */ + + newLength = strlen(p); + Tcl_AppendToObj(prefix, p, newLength); + + /* Remove spurious trailing single ':' */ + dest = Tcl_GetString(prefix) + length + newLength; + if (*(dest-1) == ':') { + if (dest-1 > Tcl_GetString(prefix)) { + if (*(dest-2) != ':') { + Tcl_SetObjLength(prefix, length + newLength -1); + } + } + } +#ifdef MAC_UNDERSTANDS_UNIX_PATHS + /* Revert the path to what it was */ + if (adjustedPath) { + char *start = joining; + while (*start != '\0') { + if (*start == ':') { + *start = '/'; + } + start++; + } + } +#endif + break; + } + } + return; } /* @@ -887,9 +1194,9 @@ Tcl_FSJoinPath(listObj, elements) * Combine a list of paths in a platform specific manner. * * Results: - * Appends the joined path to the end of the specified - * returning a pointer to the resulting string. Note that - * the Tcl_DString must already be initialized. + * Appends the joined path to the end of the specified + * Tcl_DString returning a pointer to the resulting string. Note + * that the Tcl_DString must already be initialized. * * Side effects: * Modifies the Tcl_DString. @@ -904,12 +1211,10 @@ Tcl_JoinPath(argc, argv, resultPtr) Tcl_DString *resultPtr; /* Pointer to previously initialized DString. */ { int oldLength, length, i, needsSep; - Tcl_DString buffer; char c, *dest; CONST char *p; Tcl_PathType type = TCL_PATH_ABSOLUTE; - Tcl_DStringInit(&buffer); oldLength = Tcl_DStringLength(resultPtr); switch (tclPlatform) { @@ -1063,17 +1368,30 @@ Tcl_JoinPath(argc, argv, resultPtr) case TCL_PLATFORM_MAC: needsSep = 1; for (i = 0; i < argc; i++) { - Tcl_DStringSetLength(&buffer, 0); - p = SplitMacPath(argv[i], &buffer); - if ((*p != ':') && (*p != '\0') - && (strchr(p, ':') != NULL)) { + Tcl_Obj *splitPtr; + Tcl_Obj *eltPtr; + int eltLen; + int splitIndex = 0; + int splitElements; + + splitPtr = SplitMacPath(argv[i]); + + Tcl_ListObjLength(NULL, splitPtr, &splitElements); + if (splitElements == 0) { + Tcl_DecrRefCount(splitPtr); + continue; + } + + Tcl_ListObjIndex(NULL, splitPtr, 0, &eltPtr); + p = Tcl_GetStringFromObj(eltPtr, &eltLen); + if ((eltLen != 0) && (*p != ':') && (strchr(p, ':') != NULL)) { Tcl_DStringSetLength(resultPtr, oldLength); length = strlen(p); - Tcl_DStringAppend(resultPtr, p, length); + Tcl_DStringAppend(resultPtr, p, eltLen); needsSep = 0; - p += length+1; + splitIndex++; } - + /* * Now append the rest of the path elements, skipping * : unless it is the first element of the path, and @@ -1081,7 +1399,9 @@ Tcl_JoinPath(argc, argv, resultPtr) * too many colons in the result. */ - for (; *p != '\0'; p += length+1) { + for (; splitIndex < splitElements; splitIndex++) { + Tcl_ListObjIndex(NULL, splitPtr, splitIndex, &eltPtr); + p = Tcl_GetStringFromObj(eltPtr, &eltLen); if (p[0] == ':' && p[1] == '\0') { if (Tcl_DStringLength(resultPtr) != oldLength) { p++; @@ -1104,11 +1424,11 @@ Tcl_JoinPath(argc, argv, resultPtr) length = strlen(p); Tcl_DStringAppend(resultPtr, p, length); } + Tcl_DecrRefCount(splitPtr); } break; } - Tcl_DStringFree(&buffer); return Tcl_DStringValue(resultPtr); } @@ -1235,11 +1555,15 @@ TclGetExtension(name) break; case TCL_PLATFORM_MAC: +#ifdef MAC_UNDERSTANDS_UNIX_PATHS if (strchr(name, ':') == NULL) { lastSep = strrchr(name, '/'); } else { lastSep = strrchr(name, ':'); } +#else + lastSep = strrchr(name, ':'); +#endif break; case TCL_PLATFORM_WINDOWS: @@ -1791,11 +2115,15 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types) separators = "/\\:"; break; case TCL_PLATFORM_MAC: +#ifdef MAC_UNDERSTANDS_UNIX_PATHS if (unquotedPrefix == NULL) { separators = (strchr(pattern, ':') == NULL) ? "/" : ":"; } else { separators = ":"; } +#else + separators = ":"; +#endif break; } @@ -2060,12 +2388,14 @@ TclDoGlob(interp, separators, headPtr, tail, types) switch (tclPlatform) { case TCL_PLATFORM_MAC: +#ifdef MAC_UNDERSTANDS_UNIX_PATHS if (*separators == '/') { if (((length == 0) && (count == 0)) || ((length > 0) && (lastChar != ':'))) { Tcl_DStringAppend(headPtr, ":", 1); } } else { +#endif if (count == 0) { if ((length > 0) && (lastChar != ':')) { Tcl_DStringAppend(headPtr, ":", 1); @@ -2078,7 +2408,9 @@ TclDoGlob(interp, separators, headPtr, tail, types) Tcl_DStringAppend(headPtr, ":", 1); } } +#ifdef MAC_UNDERSTANDS_UNIX_PATHS } +#endif break; case TCL_PLATFORM_WINDOWS: /* @@ -2254,9 +2586,9 @@ TclDoGlob(interp, separators, headPtr, tail, types) Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, Tcl_GetString(elt), -1); if(tclPlatform == TCL_PLATFORM_MAC) { - Tcl_DStringAppend(&ds, ":",1); + Tcl_DStringAppend(&ds, ":",1); } else { - Tcl_DStringAppend(&ds, "/",1); + Tcl_DStringAppend(&ds, "/",1); } ret = TclDoGlob(interp, separators, &ds, p+1, types); Tcl_DStringFree(&ds); @@ -2274,87 +2606,83 @@ TclDoGlob(interp, separators, headPtr, tail, types) Tcl_DStringAppend(headPtr, tail, p-tail); if (*p != '\0') { return TclDoGlob(interp, separators, headPtr, p, types); - } + } else { + /* + * 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] + */ - /* - * 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. - */ + Tcl_Obj *nameObj; + struct stat buf; + /* Used to deal with one special case pertinent to MacOS */ + int macSpecialCase = 0; - switch (tclPlatform) { - case TCL_PLATFORM_MAC: { - if (strchr(Tcl_DStringValue(headPtr), ':') == NULL) { - Tcl_DStringAppend(headPtr, ":", 1); - } - name = Tcl_DStringValue(headPtr); - if (Tcl_Access(name, F_OK) == 0) { - if ((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), - Tcl_NewStringObj(name,-1)); + switch (tclPlatform) { + case TCL_PLATFORM_MAC: { + if (strchr(Tcl_DStringValue(headPtr), ':') == NULL) { + Tcl_DStringAppend(headPtr, ":", 1); } + macSpecialCase = 1; + break; } - break; - } - case TCL_PLATFORM_WINDOWS: { - int exists; - - /* - * We need to convert slashes to backslashes before checking - * for the existence of the file. Once we are done, we need - * to convert the slashes back. - * - * This backslash/forward slash conversion may no longer - * be necessary, since we have dropped Win3.1 support. - */ - - if (Tcl_DStringLength(headPtr) == 0) { - if (((*name == '\\') && (name[1] == '/' || name[1] == '\\')) - || (*name == '/')) { - Tcl_DStringAppend(headPtr, "\\", 1); - } else { - Tcl_DStringAppend(headPtr, ".", 1); + case TCL_PLATFORM_WINDOWS: { + if (Tcl_DStringLength(headPtr) == 0) { + if (((*name == '\\') && (name[1] == '/' || name[1] == '\\')) + || (*name == '/')) { + Tcl_DStringAppend(headPtr, "\\", 1); + } else { + Tcl_DStringAppend(headPtr, ".", 1); + } } - } else { + /* + * Convert to forward slashes. This is required to pass + * some Tcl tests. We should probably remove the conversions + * here and in tclWinFile.c, since they aren't needed since + * the dropping of support for Win32s. + */ for (p = Tcl_DStringValue(headPtr); *p != '\0'; p++) { - if (*p == '/') { - *p = '\\'; + if (*p == '\\') { + *p = '/'; } } + break; } - name = Tcl_DStringValue(headPtr); - exists = (Tcl_Access(name, F_OK) == 0); - - for (p = name; *p != '\0'; p++) { - if (*p == '\\') { - *p = '/'; + case TCL_PLATFORM_UNIX: { + if (Tcl_DStringLength(headPtr) == 0) { + if ((*name == '\\' && name[1] == '/') || (*name == '/')) { + Tcl_DStringAppend(headPtr, "/", 1); + } else { + Tcl_DStringAppend(headPtr, ".", 1); + } } + break; } - if (exists) { - Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp), - Tcl_NewStringObj(name,-1)); - } - break; } - case TCL_PLATFORM_UNIX: { - if (Tcl_DStringLength(headPtr) == 0) { - if ((*name == '\\' && name[1] == '/') || (*name == '/')) { - Tcl_DStringAppend(headPtr, "/", 1); - } else { - Tcl_DStringAppend(headPtr, ".", 1); - } - } - name = Tcl_DStringValue(headPtr); - if (Tcl_Access(name, F_OK) == 0) { + /* Common for all platforms */ + name = Tcl_DStringValue(headPtr); + 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)); + Tcl_NewStringObj(name + 1,-1)); + } else { + Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp), + nameObj); } - break; } + Tcl_DecrRefCount(nameObj); + return TCL_OK; } - - return TCL_OK; } diff --git a/generic/tclIO.c b/generic/tclIO.c index 8ef6e12..c05f530 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.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: tclIO.c,v 1.33 2001/07/31 19:12:06 vincentdarley Exp $ + * RCS: @(#) $Id: tclIO.c,v 1.34 2001/08/23 17:37:07 vincentdarley Exp $ */ #include "tclInt.h" @@ -876,6 +876,10 @@ Tcl_UnregisterChannel(interp, chan) * in which you need to generate a pristine channel from one * that has already been used. All ordinary purposes will almost * always want to use Tcl_UnregisterChannel instead. + * + * Provided the channel is not attached to any other interpreter, + * it can then be closed with Tcl_Close, rather than with + * Tcl_UnregisterChannel. * * Results: * A standard Tcl result. If the channel is not currently registered @@ -926,7 +930,7 @@ Tcl_DetachChannel(interp, chan) *---------------------------------------------------------------------- */ -int +static int DetachChannel(interp, chan) Tcl_Interp *interp; /* Interpreter in which channel is defined. */ Tcl_Channel chan; /* Channel to delete. */ @@ -2823,7 +2827,7 @@ Tcl_WriteChars(chan, src, len) *---------------------------------------------------------------------- */ -int +static int DoWriteChars(chanPtr, src, len) Channel* chanPtr; /* The channel to buffer output for. */ CONST char *src; /* UTF-8 characters to queue in output buffer. */ @@ -4274,7 +4278,7 @@ Tcl_ReadChars(chan, objPtr, toRead, appendFlag) *--------------------------------------------------------------------------- */ -int +static int DoReadChars(chanPtr, objPtr, toRead, appendFlag) Channel* chanPtr; /* The channel to read. */ Tcl_Obj *objPtr; /* Input data is stored in this object. */ diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 4dd0cfa..d191758 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.14 2001/08/11 18:43:21 vincentdarley Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.15 2001/08/23 17:37:08 vincentdarley Exp $ */ #include "tclInt.h" @@ -35,7 +35,7 @@ static void FreeFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *listPtr)); static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static Tcl_Obj* FSNormalizeAbsolutePath - _ANSI_ARGS_((Tcl_Interp* interp, char *path)); + _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr)); static int TclNormalizeToUniquePath _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr)); static int SetFsPathFromAbsoluteNormalized @@ -43,6 +43,9 @@ static int SetFsPathFromAbsoluteNormalized static int FindSplitPos _ANSI_ARGS_((char *path, char *separator)); static Tcl_Filesystem* Tcl_FSGetFileSystemForPath _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); +static Tcl_PathType GetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr, + Tcl_Filesystem **filesystemPtrPtr, + int *driveNameLengthPtr, Tcl_Obj **driveNameRef)); /* * Define the 'path' object type, which Tcl uses to represent @@ -184,6 +187,17 @@ Tcl_EvalFile(interp, fileName) return ret; } +/* Obsolete */ +int +TclpListVolumes( + Tcl_Interp *interp) /* Interpreter for returning volume list. */ +{ + Tcl_Obj *resultPtr = TclpObjListVolumes(); + Tcl_SetObjResult(interp, resultPtr); + Tcl_DecrRefCount(resultPtr); + return TCL_OK; +} + /* * The 3 hooks for Stat, Access and OpenFileChannel are obsolete. The @@ -313,8 +327,8 @@ Tcl_FSCreateDirectoryProc TclpObjCreateDirectory; Tcl_FSCopyDirectoryProc TclpObjCopyDirectory; Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory; Tcl_FSUnloadFileProc TclpUnloadFile; -Tcl_FSReadlinkProc TclpObjReadlink; -Tcl_FSListVolumesProc TclpListVolumes; +Tcl_FSLinkProc TclpObjLink; +Tcl_FSListVolumesProc TclpObjListVolumes; /* Define the native filesystem dispatch table */ static Tcl_Filesystem nativeFilesystem = { @@ -337,9 +351,9 @@ static Tcl_Filesystem nativeFilesystem = { #ifndef S_IFLNK NULL, #else - &TclpObjReadlink, + &TclpObjLink, #endif /* S_IFLNK */ - &TclpListVolumes, + &TclpObjListVolumes, &NativeFileAttrStrings, &NativeFileAttrsGet, &NativeFileAttrsSet, @@ -406,7 +420,7 @@ TCL_DECLARE_MUTEX(filesystemMutex) * container Tcl_Obj of this FsPath. */ typedef struct FsPath { - char *translatedPathPtr; /* Name without any ~user sequences. + Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences. * If this is NULL, then this is a * pure normalized, absolute path * object, in which the parent Tcl_Obj's @@ -731,31 +745,42 @@ Tcl_FSData(fsPtr) *--------------------------------------------------------------------------- */ static Tcl_Obj* -FSNormalizeAbsolutePath(interp, path) +FSNormalizeAbsolutePath(interp, pathPtr) Tcl_Interp* interp; /* Interpreter to use */ - char *path; /* Absolute path to normalize (UTF-8) */ + Tcl_Obj *pathPtr; /* Absolute path to normalize */ { - char **sp = NULL, *np[BUFSIZ]; int splen = 0, nplen, i; Tcl_Obj *retVal; + Tcl_Obj *split; - Tcl_SplitPath(path, &splen, &sp); - + /* Split has refCount zero */ + split = Tcl_FSSplitPath(pathPtr, &splen); + + /* + * Modify the list of entries in place, by removing '.', and + * removing '..' and the entry before -- unless that entry before + * is the top-level entry, i.e. the name of a volume. + */ nplen = 0; for (i = 0;i < splen;i++) { - if (strcmp(sp[i], ".") == 0) - continue; - - if (strcmp(sp[i], "..") == 0) { - if (nplen > 1) nplen--; + Tcl_Obj *elt; + Tcl_ListObjIndex(NULL, split, nplen, &elt); + + if (strcmp(Tcl_GetString(elt), ".") == 0) { + Tcl_ListObjReplace(NULL, split, nplen, 1, 0, NULL); + } else if (strcmp(Tcl_GetString(elt), "..") == 0) { + if (nplen > 1) { + nplen--; + Tcl_ListObjReplace(NULL, split, nplen, 2, 0, NULL); + } else { + Tcl_ListObjReplace(NULL, split, nplen, 1, 0, NULL); + } } else { - np[nplen++] = sp[i]; + nplen++; } } if (nplen > 0) { - Tcl_DString dtemp; - Tcl_DStringInit(&dtemp); - Tcl_JoinPath(nplen, np, &dtemp); + retVal = Tcl_FSJoinPath(split, nplen); /* * Now we have an absolute path, with no '..', '.' sequences, * but it still may not be in 'unique' form, depending on the @@ -767,8 +792,6 @@ FSNormalizeAbsolutePath(interp, path) * Virtual file systems which may be registered may have * other criteria for normalizing a path. */ - retVal = Tcl_NewStringObj(Tcl_DStringValue(&dtemp),-1); - Tcl_DStringFree(&dtemp); Tcl_IncrRefCount(retVal); TclNormalizeToUniquePath(interp, retVal); /* @@ -782,7 +805,17 @@ FSNormalizeAbsolutePath(interp, path) retVal = Tcl_NewStringObj("",0); Tcl_IncrRefCount(retVal); } - ckfree((char*) sp); + /* + * We increment and then decrement the refCount of split to free + * it. We do this right at the end, in case there are + * optimisations in Tcl_FSJoinPath(split, nplen) above which would + * let it make use of split more effectively if it has a refCount + * of zero. Also we can't just decrement the ref count, in case + * 'split' was actually returned by the join call above, in a + * single-element optimisation when nplen == 1. + */ + Tcl_IncrRefCount(split); + Tcl_DecrRefCount(split); /* This has a refCount of 1 for the caller */ return retVal; @@ -1258,12 +1291,18 @@ Tcl_FSStat(pathPtr, buf) Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ struct stat *buf; /* Filled with results of stat call. */ { + Tcl_Filesystem *fsPtr; #ifdef USE_OBSOLETE_FS_HOOKS StatProc *statProcPtr; int retVal = -1; + char *path; + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); + if (transPtr == NULL) { + path = NULL; + } else { + path = Tcl_GetString(transPtr); + } #endif /* USE_OBSOLETE_FS_HOOKS */ - Tcl_Filesystem *fsPtr; - char *path = Tcl_FSGetTranslatedPath(NULL, pathPtr); /* * Call each of the "stat" function in succession. A non-return @@ -1357,12 +1396,18 @@ Tcl_FSAccess(pathPtr, mode) Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */ int mode; /* Permission setting. */ { + Tcl_Filesystem *fsPtr; #ifdef USE_OBSOLETE_FS_HOOKS AccessProc *accessProcPtr; int retVal = -1; + char *path; + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); + if (transPtr == NULL) { + path = NULL; + } else { + path = Tcl_GetString(transPtr); + } #endif /* USE_OBSOLETE_FS_HOOKS */ - Tcl_Filesystem *fsPtr; - char *path = Tcl_FSGetTranslatedPath(NULL, pathPtr); /* * Call each of the "access" function in succession. A non-return @@ -1422,15 +1467,23 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) * file, with what modes to create * it? */ { + Tcl_Filesystem *fsPtr; #ifdef USE_OBSOLETE_FS_HOOKS OpenFileChannelProc *openFileChannelProcPtr; Tcl_Channel retVal = NULL; + char *path; #endif /* USE_OBSOLETE_FS_HOOKS */ - Tcl_Filesystem *fsPtr; - char *path = Tcl_FSGetTranslatedPath(interp, pathPtr); - if (path == NULL) { + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); + if (transPtr == NULL) { return NULL; } +#ifdef USE_OBSOLETE_FS_HOOKS + if (transPtr == NULL) { + path = NULL; + } else { + path = Tcl_GetString(transPtr); + } +#endif /* USE_OBSOLETE_FS_HOOKS */ /* * Call each of the "Tcl_OpenFileChannel" function in succession. @@ -1672,8 +1725,7 @@ Tcl_FSGetCwd(interp) * could be problematic. */ if (retVal != NULL) { - Tcl_Obj *norm = FSNormalizeAbsolutePath(interp, - Tcl_GetString(retVal)); + Tcl_Obj *norm = FSNormalizeAbsolutePath(interp, retVal); if (norm != NULL) { /* * We found a cwd, which is now in our global storage. @@ -1722,8 +1774,7 @@ Tcl_FSGetCwd(interp) if (proc != NULL) { Tcl_Obj *retVal = (*proc)(interp); if (retVal != NULL) { - Tcl_Obj *norm = FSNormalizeAbsolutePath(interp, - Tcl_GetString(retVal)); + Tcl_Obj *norm = FSNormalizeAbsolutePath(interp, retVal); /* * Check whether cwd has changed from the value * previously stored in cwdPathPtr. Really 'norm' @@ -1833,7 +1884,7 @@ Tcl_FSUtime (pathPtr, tval) *---------------------------------------------------------------------- */ -char** +static char** NativeFileAttrStrings(pathPtr, objPtrRef) Tcl_Obj *pathPtr; Tcl_Obj** objPtrRef; @@ -1865,16 +1916,16 @@ NativeFileAttrStrings(pathPtr, objPtrRef) *---------------------------------------------------------------------- */ -int +static int NativeFileAttrsGet(interp, index, fileName, objPtrRef) Tcl_Interp *interp; /* The interpreter for error reporting. */ int index; /* index of the attribute command. */ Tcl_Obj *fileName; /* filename we are operating on. */ Tcl_Obj **objPtrRef; /* for output. */ { + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, fileName); return (*tclpFileAttrProcs[index].getProc)(interp, index, - Tcl_FSGetTranslatedPath(NULL, fileName), - objPtrRef); + transPtr, objPtrRef); } /* @@ -1897,16 +1948,16 @@ NativeFileAttrsGet(interp, index, fileName, objPtrRef) *---------------------------------------------------------------------- */ -int +static int NativeFileAttrsSet(interp, index, fileName, objPtr) Tcl_Interp *interp; /* The interpreter for error reporting. */ int index; /* index of the attribute command. */ Tcl_Obj *fileName; /* filename we are operating on. */ Tcl_Obj *objPtr; /* set to this value. */ { + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, fileName); return (*tclpFileAttrProcs[index].setProc)(interp, index, - Tcl_FSGetTranslatedPath(NULL, fileName), - objPtr); + transPtr, objPtr); } /* @@ -2280,18 +2331,29 @@ FSUnloadTempFile(clientData) /* *--------------------------------------------------------------------------- * - * Tcl_FSReadlink -- + * Tcl_FSLink -- * - * This function replaces the library version of readlink(). - * The appropriate function for the filesystem to which pathPtr - * belongs will be called. + * This function replaces the library version of readlink() and + * can also be used to make links. The appropriate function for + * the filesystem to which pathPtr belongs will be called. * * Results: - * The result is a Tcl_Obj specifying the contents - * of the symbolic link given by 'path', or NULL if the symbolic - * link could not be read. The result is owned by the caller, - * which should call Tcl_DecrRefCount when the result is no longer - * needed. + * If toPtr is NULL, then the result is a Tcl_Obj specifying the + * contents of the symbolic link given by 'pathPtr', or NULL if + * the symbolic link could not be read. The result is owned by + * the caller, which should call Tcl_DecrRefCount when the result + * is no longer needed. + * + * If toPtr is non-NULL, then the result is toPtr if the link + * was successful, or NULL if not. In this case the result has no + * additional reference count, and need not be freed. + * + * Note that most filesystems will not support linking across + * to different filesystems, so this function will usually + * fail unless toPtr is in the same FS as pathPtr. + * + * Note: currently no Tcl filesystems support the 'link' action, + * so we actually always return an error for that call. * * Side effects: * See readlink() documentation. @@ -2300,14 +2362,15 @@ FSUnloadTempFile(clientData) */ Tcl_Obj * -Tcl_FSReadlink(pathPtr) - Tcl_Obj *pathPtr; /* Path of file to readlink (UTF-8). */ +Tcl_FSLink(pathPtr, toPtr) + Tcl_Obj *pathPtr; /* Path of file to readlink or link */ + Tcl_Obj *toPtr; /* NULL or path to be linked to */ { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { - Tcl_FSReadlinkProc *proc = fsPtr->readlinkProc; + Tcl_FSLinkProc *proc = fsPtr->linkProc; if (proc != NULL) { - return (*proc)(pathPtr); + return (*proc)(pathPtr, toPtr); } } /* @@ -2328,15 +2391,13 @@ Tcl_FSReadlink(pathPtr) * * Tcl_FSListVolumes -- * - * Lists the currently mounted volumes. - * The chain of functions that have been "inserted" into the - * filesystem will be called in succession; each may add to - * the Tcl result, until all mounted file systems are listed. + * Lists the currently mounted volumes. The chain of functions + * that have been "inserted" into the filesystem will be called in + * succession; each may return a list of volumes, all of which are + * added to the result until all mounted file systems are listed. * * Results: - * A standard Tcl result. Will always be TCL_OK, since there is no way - * that this command can fail. Also, the interpreter's result is set to - * the list of volumes. + * The list of volumes, in an object which has refCount 0. * * Side effects: * None @@ -2344,12 +2405,12 @@ Tcl_FSReadlink(pathPtr) *--------------------------------------------------------------------------- */ -int -Tcl_FSListVolumes(interp) - Tcl_Interp *interp; /* Interpreter for returning volume list. */ +Tcl_Obj* +Tcl_FSListVolumes(void) { FilesystemRecord *fsRecPtr; - + Tcl_Obj *resultPtr = Tcl_NewObj(); + /* * Call each of the "listVolumes" function in succession. * A non-NULL return value indicates the particular function has @@ -2361,14 +2422,407 @@ Tcl_FSListVolumes(interp) while (fsRecPtr != NULL) { Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc; if (proc != NULL) { - /* Ignore return value */ - (*proc)(interp); + Tcl_Obj *thisFsVolumes = (*proc)(); + if (thisFsVolumes != NULL) { + Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes); + Tcl_DecrRefCount(thisFsVolumes); + } } fsRecPtr = fsRecPtr->nextPtr; } FsReleaseIterator(); - return TCL_OK; + return resultPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FSGetPathType -- + * + * Determines whether a given path is relative to the current + * directory, relative to the current volume, or absolute. If the + * caller wishes to know which filesystem claimed the path (in the + * case for which the path is absolute), then a reference to a + * filesystem pointer can be passed in (but passing NULL is + * acceptable). + * + * Results: + * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or + * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will + * be set if and only if it is non-NULL and the function's + * return value is TCL_PATH_ABSOLUTE. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_PathType +Tcl_FSGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr) + Tcl_Obj *pathObjPtr; + Tcl_Filesystem **filesystemPtrPtr; + int *driveNameLengthPtr; +{ + if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) { + return GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, NULL); + } else { + FsPath *fsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr; + if (fsPathPtr->cwdPtr != NULL) { + return TCL_PATH_RELATIVE; + } else { + return GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, NULL); + } + } +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_FSSplitPath -- + * + * This function takes the given Tcl_Obj, which should be a valid + * path, and returns a Tcl List object containing each segment + * of that path as an element. + * + * Note this function currently calls the older Split(Plat)Path + * functions, which require more memory allocation than is + * desirable. + * + * Results: + * Returns list object with refCount of zero. If the passed in + * lenPtr is non-NULL, we use it to return the number of elements + * in the returned list. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj* +Tcl_FSSplitPath(pathPtr, lenPtr) + Tcl_Obj *pathPtr; /* Path to split. */ + int *lenPtr; /* int to store number of path elements. */ +{ + Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */ + Tcl_Filesystem *fsPtr; + char separator = '/'; + int driveNameLength; + char *p; + + /* + * Perform platform specific splitting. + */ + + if (Tcl_FSGetPathType(pathPtr, &fsPtr, &driveNameLength) + == TCL_PATH_ABSOLUTE) { + if (fsPtr == &nativeFilesystem) { + return TclpNativeSplitPath(pathPtr, lenPtr); + } + } else { + return TclpNativeSplitPath(pathPtr, lenPtr); + } + + /* We assume separators are single characters */ + if (fsPtr->filesystemSeparatorProc != NULL) { + Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(pathPtr); + if (sep != NULL) { + separator = Tcl_GetString(sep)[0]; + } + } + + /* + * Place the drive name as first element of the + * result list. The drive name may contain strange + * characters, like colons and multiple forward slashes + * (for example 'ftp://' is a valid vfs drive name) + */ + result = Tcl_NewObj(); + p = Tcl_GetString(pathPtr); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(p, driveNameLength)); + p+= driveNameLength; + + /* Add the remaining path elements to the list */ + for (;;) { + char *elementStart = p; + int length; + while ((*p != '\0') && (*p != separator)) { + p++; + } + length = p - elementStart; + if (length > 0) { + Tcl_Obj *nextElt; + if (elementStart[0] == '~') { + nextElt = Tcl_NewStringObj("./",2); + Tcl_AppendToObj(nextElt, elementStart, length); + } else { + nextElt = Tcl_NewStringObj(elementStart, length); + } + Tcl_ListObjAppendElement(NULL, result, nextElt); + } + if (*p++ == '\0') { + break; + } + } + + /* + * Compute the number of elements in the result. + */ + + if (lenPtr != NULL) { + Tcl_ListObjLength(NULL, result, lenPtr); + } + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_FSJoinPath -- + * + * This function takes the given Tcl_Obj, which should be a valid + * list, and returns the path object given by considering the + * first 'elements' elements as valid path segments. If elements < 0, + * we use the entire list. + * + * Note this function currently calls the older Tcl_JoinPath + * routine, which therefore requires more memory allocation and + * deallocation than necessary. We could easily rewrite this for + * greater efficiency. + * + * Results: + * Returns object with refCount of zero. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +Tcl_Obj* +Tcl_FSJoinPath(listObj, elements) + Tcl_Obj *listObj; + int elements; +{ + Tcl_Obj *res; + int i; + Tcl_Filesystem *fsPtr = NULL; + + if (elements < 0) { + if (Tcl_ListObjLength(NULL, listObj, &elements) != TCL_OK) { + return NULL; + } + } else { + /* Just make sure it is a valid list */ + int listTest; + if (Tcl_ListObjLength(NULL, listObj, &listTest) != TCL_OK) { + return NULL; + } + /* + * Correct this if it is too large, otherwise we will + * waste our timing joining null elements to the path + */ + if (elements > listTest) { + elements = listTest; + } + } + + res = Tcl_NewObj(); + + for (i = 0; i < elements; i++) { + Tcl_Obj *elt; + int driveNameLength; + Tcl_PathType type; + char *strElt; + Tcl_Obj *driveName = NULL; + + Tcl_ListObjIndex(NULL, listObj, i, &elt); + strElt = Tcl_GetString(elt); + type = GetPathType(elt, &fsPtr, &driveNameLength, &driveName); + if (type != TCL_PATH_RELATIVE) { + /* Zero out the current result */ + Tcl_DecrRefCount(res); + if (driveName != NULL) { + res = Tcl_DuplicateObj(driveName); + Tcl_DecrRefCount(driveName); + } else { + res = Tcl_NewStringObj(strElt, driveNameLength); + } + strElt += driveNameLength; + } + + /* + * A NULL value for fsPtr at this stage basically means + * we're trying to join a relative path onto something + * which is also relative (or empty). There's nothing + * particularly wrong with that. + */ + if (*strElt == '\0') continue; + + if (fsPtr == &nativeFilesystem || fsPtr == NULL) { + TclpNativeJoinPath(res, strElt); + } else { + int length; + char separator = '/'; + char *ptr; + int needsSep = 0; + + if (fsPtr->filesystemSeparatorProc != NULL) { + Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(res); + if (sep != NULL) { + separator = Tcl_GetString(sep)[0]; + } + } + ptr = Tcl_GetStringFromObj(res, &length); + if (length > 0 && ptr[length -1] != '/') { + Tcl_AppendToObj(res, &separator, 1); + length++; + } + Tcl_SetObjLength(res, length + strlen(strElt)); + + ptr = Tcl_GetString(res) + length; + for (; *strElt != '\0'; strElt++) { + if (*strElt == separator) { + while (strElt[1] == separator) { + strElt++; + } + if (strElt[1] != '\0') { + if (needsSep) { + *ptr++ = separator; + } + } + } else { + *ptr++ = *strElt; + needsSep = 1; + } + } + length = ptr - Tcl_GetString(res); + Tcl_SetObjLength(res, length); + } + } + return res; +} + +/* + *---------------------------------------------------------------------- + * + * GetPathType -- + * + * Helper function used by Tcl_FSGetPathType. + * + * Results: + * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or + * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will + * be set if and only if it is non-NULL and the function's + * return value is TCL_PATH_ABSOLUTE. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_PathType +GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef) + Tcl_Obj *pathObjPtr; + Tcl_Filesystem **filesystemPtrPtr; + int *driveNameLengthPtr; + Tcl_Obj **driveNameRef; +{ + FilesystemRecord *fsRecPtr; + int pathLen; + char *path; + Tcl_PathType type = TCL_PATH_RELATIVE; + + path = Tcl_GetStringFromObj(pathObjPtr, &pathLen); + + /* + * Call each of the "listVolumes" function in succession, checking + * whether the given path is an absolute path on any of the volumes + * returned (this is done by checking whether the path's prefix + * matches). + */ + + fsRecPtr = FsGetIterator(); + while (fsRecPtr != NULL) { + Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc; + /* + * We want to skip the native filesystem in this loop because + * otherwise we won't necessarily pass all the Tcl testsuite -- + * this is because some of the tests artificially change the + * current platform (between mac, win, unix) but the list + * of volumes we get by calling (*proc) will reflect the current + * (real) platform only and this may cause some tests to fail. + * In particular, on unix '/' will match the beginning of + * certain absolute Windows paths starting '//' and those tests + * will go wrong. + * + * Besides these test-suite issues, there is actually no + * reason to skip the native filesystem. + */ + if ((fsRecPtr->fsPtr != &nativeFilesystem) && (proc != NULL)) { + int numVolumes; + Tcl_Obj *thisFsVolumes = (*proc)(); + if (thisFsVolumes != NULL) { + if (Tcl_ListObjLength(NULL, thisFsVolumes, + &numVolumes) != TCL_OK) { + /* + * This is VERY bad; Tcl_FSListVolumes didn't + * return a valid list. Set numVolumes to -1 + * so that we skip the while loop below and + * just return with the current value of 'type'. + * + * It would be better if we could signal an error + * here (but panic seems a bit excessive). + */ + numVolumes = -1; + } + while (numVolumes > 0) { + Tcl_Obj *vol; + int len; + char *strVol; + + numVolumes--; + Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol); + strVol = Tcl_GetStringFromObj(vol,&len); + if (pathLen < len) { + continue; + } + if (strncmp(strVol, path, len) == 0) { + type = TCL_PATH_ABSOLUTE; + if (filesystemPtrPtr != NULL) { + *filesystemPtrPtr = fsRecPtr->fsPtr; + } + if (driveNameLengthPtr != NULL) { + *driveNameLengthPtr = len; + } + if (driveNameRef != NULL) { + *driveNameRef = vol; + Tcl_IncrRefCount(vol); + } + break; + } + } + Tcl_DecrRefCount(thisFsVolumes); + if (type == TCL_PATH_ABSOLUTE) { + /* We don't need to examine any more filesystems */ + break; + } + } + } + fsRecPtr = fsRecPtr->nextPtr; + } + FsReleaseIterator(); + + if (type != TCL_PATH_ABSOLUTE) { + type = TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, driveNameRef); + if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) { + *filesystemPtrPtr = &nativeFilesystem; + } + } + return type; } /* @@ -2769,7 +3223,7 @@ SetFsPathFromAny(interp, objPtr) { int len; FsPath *fsPathPtr; - Tcl_DString buffer; + Tcl_Obj *transPtr; char *name; if (objPtr->typePtr == &tclFsPathType) { @@ -2813,7 +3267,7 @@ SetFsPathFromAny(interp, objPtr) char separator='/'; if (tclPlatform==TCL_PLATFORM_MAC) { - if (strchr(name, ':') != NULL) separator = ':'; + if (strchr(name, ':') != NULL) separator = ':'; } split = FindSplitPos(name, &separator); @@ -2855,40 +3309,31 @@ SetFsPathFromAny(interp, objPtr) } if (split != len) { name[split] = separator; } } + expandedUser = Tcl_DStringValue(&temp); + transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp)); - Tcl_DStringInit(&buffer); - if (split == len) { - /* We have the result we need in the wrong DString */ - Tcl_DStringAppend(&buffer, expandedUser, Tcl_DStringLength(&temp)); - } else { + if (split != len) { /* - * Build a simple 2 element list and join it up with - * the tilde substitution in place + * Join up the tilde substitution with the rest */ - char *argv[2]; - argv[0] = expandedUser; - argv[1] = name+split+1; - Tcl_JoinPath(2, argv, &buffer); + Tcl_Obj *rest = Tcl_NewStringObj(name+split+1,-1); + transPtr = Tcl_FSJoinToPath(transPtr, 1, &rest); } Tcl_DStringFree(&temp); } else { - Tcl_DStringInit(&buffer); - Tcl_JoinPath(1, &name, &buffer); + transPtr = Tcl_FSJoinToPath(objPtr,0,NULL); } - len = Tcl_DStringLength(&buffer); - /* - * Now we have a translated filename in 'buffer', of - * length 'len'. This will have forward slashes on - * Windows, and will not contain any ~user sequences. + * Now we have a translated filename in 'transPtr'. This will have + * forward slashes on Windows, and will not contain any ~user + * sequences. */ fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); - fsPathPtr->translatedPathPtr = ckalloc((unsigned)(1+len)); - strcpy(fsPathPtr->translatedPathPtr, Tcl_DStringValue(&buffer)); - Tcl_DStringFree(&buffer); + fsPathPtr->translatedPathPtr = transPtr; + Tcl_IncrRefCount(fsPathPtr->translatedPathPtr); fsPathPtr->normPathPtr = NULL; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = NULL; @@ -2983,7 +3428,7 @@ FreeFsPathInternalRep(pathObjPtr) (FsPath*) pathObjPtr->internalRep.otherValuePtr; if (fsPathPtr->translatedPathPtr != NULL) { - ckfree((char *) fsPathPtr->translatedPathPtr); + Tcl_DecrRefCount(fsPathPtr->translatedPathPtr); } if (fsPathPtr->normPathPtr != NULL) { if (fsPathPtr->normPathPtr != pathObjPtr) { @@ -3024,10 +3469,8 @@ DupFsPathInternalRep(srcPtr, copyPtr) copyPtr->internalRep.otherValuePtr = copyFsPathPtr; if (srcFsPathPtr->translatedPathPtr != NULL) { - copyFsPathPtr->translatedPathPtr = - ckalloc(1+strlen(srcFsPathPtr->translatedPathPtr)); - strcpy(copyFsPathPtr->translatedPathPtr, - srcFsPathPtr->translatedPathPtr); + copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr; + Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); } else { copyFsPathPtr->translatedPathPtr = NULL; } @@ -3074,14 +3517,14 @@ DupFsPathInternalRep(srcPtr, copyPtr) * * Tcl_FSGetTranslatedPath -- * - * This function attempts to extract the translated path string + * This function attempts to extract the translated path * from the given Tcl_Obj. 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. + * interpreter (if it is non-NULL) * * Results: - * NULL or a valid string. + * NULL or a valid Tcl_Obj pointer. * * Side effects: * Only those of 'Tcl_FSConvertToPathType' @@ -3089,7 +3532,7 @@ DupFsPathInternalRep(srcPtr, copyPtr) *--------------------------------------------------------------------------- */ -char* +Tcl_Obj* Tcl_FSGetTranslatedPath(interp, pathPtr) Tcl_Interp *interp; Tcl_Obj* pathPtr; @@ -3106,7 +3549,7 @@ Tcl_FSGetTranslatedPath(interp, pathPtr) * object's string, translatedPath and normalizedPath * are all identical. */ - return Tcl_GetString(srcFsPathPtr->normPathPtr); + return srcFsPathPtr->normPathPtr; } else { /* It is an ordinary path object */ return srcFsPathPtr->translatedPathPtr; @@ -3116,6 +3559,38 @@ Tcl_FSGetTranslatedPath(interp, pathPtr) /* *--------------------------------------------------------------------------- * + * Tcl_FSGetTranslatedStringPath -- + * + * This function attempts to extract the translated path + * from the given Tcl_Obj. If the translation succeeds (i.e. the + * object is a valid path), then the path is returned. Otherwise NULL + * will be returned, and an error message may be left in the + * interpreter (if it is non-NULL) + * + * Results: + * NULL or a valid string. + * + * Side effects: + * Only those of 'Tcl_FSConvertToPathType' + * + *--------------------------------------------------------------------------- + */ +char* +Tcl_FSGetTranslatedStringPath(interp, pathPtr) +Tcl_Interp *interp; +Tcl_Obj* pathPtr; +{ + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); + if (transPtr == NULL) { + return NULL; + } else { + return Tcl_GetString(transPtr); + } +} + +/* + *--------------------------------------------------------------------------- + * * Tcl_FSGetNormalizedPath -- * * This important function attempts to extract from the given Tcl_Obj @@ -3144,34 +3619,35 @@ Tcl_FSGetNormalizedPath(interp, pathObjPtr) srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr; if (srcFsPathPtr->normPathPtr == NULL) { int relative = 0; - char *path = srcFsPathPtr->translatedPathPtr; - Tcl_DString atemp; + /* + * Since normPathPtr is NULL, but this is a valid path + * object, we know that the translatedPathPtr cannot be NULL. + */ + Tcl_Obj *absolutePath = srcFsPathPtr->translatedPathPtr; + char *path = Tcl_GetString(absolutePath); - if ((path[0] != '\0') && (Tcl_GetPathType(path) == TCL_PATH_RELATIVE)) { - char * pair[2]; + /* + * We have to be a little bit careful here to avoid infinite loops + * we're asking Tcl_FSGetPathType to return the path's type, but + * that call can actually result in a lot of other filesystem + * action, which might loop back through here. + */ + if ((path[0] != '\0') && + (Tcl_FSGetPathType(pathObjPtr, NULL, NULL) == TCL_PATH_RELATIVE)) { Tcl_Obj *cwd = Tcl_FSGetCwd(interp); if (cwd == NULL) { return NULL; } - - /* - * The efficiency of this piece of code could - * be improved, given the new object interfaces. - */ - pair[0] = Tcl_GetString(cwd); - pair[1] = path; - Tcl_DStringInit(&atemp); - Tcl_JoinPath(2, pair, &atemp); - path = Tcl_DStringValue(&atemp); + absolutePath = Tcl_FSJoinToPath(cwd, 1, &absolutePath); + Tcl_IncrRefCount(absolutePath); Tcl_DecrRefCount(cwd); relative = 1; } - /* Already has refCount incremented */ - srcFsPathPtr->normPathPtr = FSNormalizeAbsolutePath(interp, path); + srcFsPathPtr->normPathPtr = FSNormalizeAbsolutePath(interp, absolutePath); if (!strcmp(Tcl_GetString(srcFsPathPtr->normPathPtr), Tcl_GetString(pathObjPtr))) { /* @@ -3186,7 +3662,8 @@ Tcl_FSGetNormalizedPath(interp, pathObjPtr) srcFsPathPtr->normPathPtr = pathObjPtr; } if (relative) { - Tcl_DStringFree(&atemp); + /* This was returned by Tcl_FSJoinToPath above */ + Tcl_DecrRefCount(absolutePath); /* Get a quick, temporary lock on the cwd while we copy it */ Tcl_MutexLock(&cwdMutex); @@ -3330,7 +3807,7 @@ Tcl_FSGetNativePath(pathObjPtr) * *--------------------------------------------------------------------------- */ -ClientData +static ClientData NativeCreateNativeRep(pathObjPtr) Tcl_Obj* pathObjPtr; { @@ -3411,7 +3888,7 @@ TclpNativeToNormalized(clientData) * *--------------------------------------------------------------------------- */ -ClientData +static ClientData NativeDupInternalRep(clientData) ClientData clientData; { @@ -3447,7 +3924,7 @@ NativeDupInternalRep(clientData) * *--------------------------------------------------------------------------- */ -int +static int NativePathInFilesystem(pathPtr, clientDataPtr) Tcl_Obj *pathPtr; ClientData *clientDataPtr; @@ -3477,7 +3954,7 @@ NativePathInFilesystem(pathPtr, clientDataPtr) * *--------------------------------------------------------------------------- */ -void +static void NativeFreeInternalRep(clientData) ClientData clientData; { @@ -3580,7 +4057,7 @@ Tcl_FSPathSeparator(pathObjPtr) * *--------------------------------------------------------------------------- */ -Tcl_Obj* +static Tcl_Obj* NativeFilesystemSeparator(pathObjPtr) Tcl_Obj* pathObjPtr; { @@ -3617,7 +4094,7 @@ NativeFilesystemSeparator(pathObjPtr) * *--------------------------------------------------------------------------- */ -Tcl_Obj* +static Tcl_Obj* NativeFilesystemPathType(pathObjPtr) Tcl_Obj* pathObjPtr; { @@ -3787,18 +4264,18 @@ Tcl_FSEqualPaths(firstPtr, secondPtr) /* Wrappers */ -Tcl_Channel +static Tcl_Channel NativeOpenFileChannel(interp, pathPtr, modeString, permissions) Tcl_Interp *interp; Tcl_Obj *pathPtr; char *modeString; int permissions; { - char *trans = Tcl_FSGetTranslatedPath(interp, pathPtr); + Tcl_Obj *trans = Tcl_FSGetTranslatedPath(interp, pathPtr); if (trans == NULL) { return NULL; } - return TclpOpenFileChannel(interp, trans, modeString, permissions); + return TclpOpenFileChannel(interp, Tcl_GetString(trans), modeString, permissions); } /* @@ -3811,7 +4288,7 @@ NativeOpenFileChannel(interp, pathPtr, modeString, permissions) * This seems rather strange when compared with stat, lstat, access, etc. * all of which want a native path. */ -int +static int NativeUtime(pathPtr, tval) Tcl_Obj *pathPtr; struct utimbuf *tval; @@ -3827,7 +4304,7 @@ NativeUtime(pathPtr, tval) #endif } -int +static int NativeLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) Tcl_Interp * interp; Tcl_Obj *pathPtr; @@ -3837,7 +4314,14 @@ NativeLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) Tcl_PackageInitProc ** proc2Ptr; ClientData * clientDataPtr; { - return TclpLoadFile(interp, Tcl_FSGetTranslatedPath(NULL, pathPtr), + char *path; + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); + if (transPtr == NULL) { + path = NULL; + } else { + path = Tcl_GetString(transPtr); + } + return TclpLoadFile(interp, path, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr); } diff --git a/generic/tclInt.h b/generic/tclInt.h index ddb8fd4..984f795 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -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: tclInt.h,v 1.58 2001/07/31 19:12:06 vincentdarley Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.59 2001/08/23 17:37:08 vincentdarley Exp $ */ #ifndef _TCLINT @@ -1486,9 +1486,9 @@ typedef struct List { */ typedef int (TclGetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, CONST char *fileName, Tcl_Obj **attrObjPtrPtr)); + int objIndex, Tcl_Obj *fileName, Tcl_Obj **attrObjPtrPtr)); typedef int (TclSetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, CONST char *fileName, Tcl_Obj *attrObjPtr)); + int objIndex, Tcl_Obj *fileName, Tcl_Obj *attrObjPtr)); typedef struct TclFileAttrProcs { TclGetFileAttrProc *getProc; /* The procedure for getting attrs. */ @@ -1805,6 +1805,7 @@ EXTERN void TclpInitLock _ANSI_ARGS_((void)); EXTERN void TclpInitPlatform _ANSI_ARGS_((void)); EXTERN void TclpInitUnlock _ANSI_ARGS_((void)); EXTERN int TclpListVolumes _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN Tcl_Obj* TclpObjListVolumes _ANSI_ARGS_((void)); EXTERN void TclpMasterLock _ANSI_ARGS_((void)); EXTERN void TclpMasterUnlock _ANSI_ARGS_((void)); EXTERN int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp *interp, @@ -1813,6 +1814,14 @@ EXTERN int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp *interp, EXTERN int TclpObjNormalizePath _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint)); EXTERN int TclpObjCreateDirectory _ANSI_ARGS_((Tcl_Obj *pathPtr)); +EXTERN Tcl_PathType Tcl_FSGetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr, + Tcl_Filesystem **fsPtrPtr, int *driveNameLengthPtr)); +EXTERN void TclpNativeJoinPath _ANSI_ARGS_((Tcl_Obj *prefix, + char *joining)); +EXTERN Tcl_Obj* TclpNativeSplitPath _ANSI_ARGS_((Tcl_Obj *pathPtr, + int *lenPtr)); +EXTERN Tcl_PathType TclpGetNativePathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr, + int *driveNameLengthPtr, Tcl_Obj **driveNameRef)); EXTERN int TclpObjDeleteFile _ANSI_ARGS_((Tcl_Obj *pathPtr)); EXTERN int TclpObjCopyDirectory _ANSI_ARGS_((Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr)); @@ -1826,7 +1835,7 @@ EXTERN int TclpMatchInDirectory _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *resul EXTERN int TclpChdir _ANSI_ARGS_((CONST char *dirName)); EXTERN char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_DString *bufferPtr)); EXTERN Tcl_Obj* TclpObjGetCwd _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN Tcl_Obj* TclpObjReadlink _ANSI_ARGS_((Tcl_Obj *pathPtr)); +EXTERN Tcl_Obj* TclpObjLink _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_Obj *toPtr)); EXTERN int TclpObjChdir _ANSI_ARGS_((Tcl_Obj *pathPtr)); EXTERN int TclpObjStat _ANSI_ARGS_((Tcl_Obj *pathPtr, struct stat *buf)); EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp, diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 9dd9975..1fdd0b9 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.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: tclLoad.c,v 1.5 2001/07/31 19:12:06 vincentdarley Exp $ + * RCS: @(#) $Id: tclLoad.c,v 1.6 2001/08/23 17:37:08 vincentdarley Exp $ */ #include "tclInt.h" @@ -272,8 +272,10 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) */ retc = TclGuessPackageName(fullFileName, &pkgName); if (!retc) { - int pargc; - char **pargv, *pkgGuess; + Tcl_Obj *splitPtr; + Tcl_Obj *pkgGuessPtr; + int pElements; + char *pkgGuess; /* * The platform-specific code couldn't figure out the @@ -283,8 +285,9 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) * characters that follow that. */ - Tcl_SplitPath(fullFileName, &pargc, &pargv); - pkgGuess = pargv[pargc-1]; + splitPtr = Tcl_FSSplitPath(objv[1], &pElements); + Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr); + pkgGuess = Tcl_GetString(pkgGuessPtr); if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i') && (pkgGuess[2] == 'b')) { pkgGuess += 3; @@ -298,7 +301,7 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) } } if (p == pkgGuess) { - ckfree((char *)pargv); + Tcl_DecrRefCount(splitPtr); Tcl_AppendResult(interp, "couldn't figure out package name for ", fullFileName, (char *) NULL); @@ -306,7 +309,7 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) goto done; } Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess)); - ckfree((char *)pargv); + Tcl_DecrRefCount(splitPtr); } } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 54f55c6..647b3c3 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.54 2001/07/31 19:12:06 vincentdarley Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.55 2001/08/23 17:37:08 vincentdarley Exp $ */ #include "tclInt.h" @@ -848,7 +848,7 @@ TclStubs tclStubs = { Tcl_FSDeleteFile, /* 443 */ Tcl_FSLoadFile, /* 444 */ Tcl_FSMatchInDirectory, /* 445 */ - Tcl_FSReadlink, /* 446 */ + Tcl_FSLink, /* 446 */ Tcl_FSRemoveDirectory, /* 447 */ Tcl_FSRenameFile, /* 448 */ Tcl_FSLstat, /* 449 */ @@ -878,6 +878,7 @@ TclStubs tclStubs = { Tcl_FSRegister, /* 473 */ Tcl_FSUnregister, /* 474 */ Tcl_FSData, /* 475 */ + Tcl_FSGetTranslatedStringPath, /* 476 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 08925bd..f6fe969 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.26 2001/07/31 19:12:06 vincentdarley Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.27 2001/08/23 17:37:08 vincentdarley Exp $ */ #define TCL_TEST @@ -324,7 +324,7 @@ static Tcl_FSCopyDirectoryProc TestReportCopyDirectory; static Tcl_FSRemoveDirectoryProc TestReportRemoveDirectory; static Tcl_FSLoadFileProc TestReportLoadFile; static Tcl_FSUnloadFileProc TestReportUnloadFile; -static Tcl_FSReadlinkProc TestReportReadlink; +static Tcl_FSLinkProc TestReportLink; static Tcl_FSListVolumesProc TestReportListVolumes; static Tcl_FSFileAttrStringsProc TestReportFileAttrStrings; static Tcl_FSFileAttrsGetProc TestReportFileAttrsGet; @@ -349,7 +349,7 @@ static Tcl_Filesystem testReportingFilesystem = { &TestReportOpenFileChannel, &TestReportMatchInDirectory, &TestReportUtime, - &TestReportReadlink, + &TestReportLink, &TestReportListVolumes, &TestReportFileAttrStrings, &TestReportFileAttrsGet, @@ -2624,7 +2624,7 @@ TestparsevarnameObjCmd(clientData, interp, objc, objv) */ /* ARGSUSED */ -int +static int TestregexpObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ @@ -4427,7 +4427,7 @@ TestOpenFileChannelProc3(interp, fileName, modeString, permissions) */ /* ARGSUSED */ -int +static int TestChannelCmd(clientData, interp, argc, argv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Interpreter for result. */ @@ -4855,7 +4855,7 @@ TestChannelCmd(clientData, interp, argc, argv) */ /* ARGSUSED */ -int +static int TestChannelEventCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ @@ -5212,7 +5212,7 @@ TestFilesystemObjCmd(dummy, interp, objc, objv) return res; } -void +static void TestReport(cmd, arg1, arg2) CONST char* cmd; Tcl_Obj* arg1; @@ -5241,7 +5241,7 @@ TestReport(cmd, arg1, arg2) Tcl_RestoreResult(interp, &savedResult); } } -int +static int TestReportStat(path, buf) Tcl_Obj *path; /* Path of file to stat (in current CP). */ struct stat *buf; /* Filled with results of stat call. */ @@ -5249,7 +5249,7 @@ TestReportStat(path, buf) TestReport("stat",path, NULL); return -1; } -int +static int TestReportLstat(path, buf) Tcl_Obj *path; /* Path of file to stat (in current CP). */ struct stat *buf; /* Filled with results of stat call. */ @@ -5257,7 +5257,7 @@ TestReportLstat(path, buf) TestReport("lstat",path, NULL); return -1; } -int +static int TestReportAccess(path, mode) Tcl_Obj *path; /* Path of file to access (in current CP). */ int mode; /* Permission setting. */ @@ -5265,7 +5265,7 @@ TestReportAccess(path, mode) TestReport("access",path,NULL); return -1; } -Tcl_Channel +static Tcl_Channel TestReportOpenFileChannel(interp, fileName, modeString, permissions) Tcl_Interp *interp; /* Interpreter for error reporting; * can be NULL. */ @@ -5280,7 +5280,7 @@ TestReportOpenFileChannel(interp, fileName, modeString, permissions) return NULL; } -int +static int TestReportMatchInDirectory(interp, resultPtr, dirPtr, pattern, types) Tcl_Interp *interp; /* Interpreter to receive results. */ Tcl_Obj *resultPtr; /* Directory separators to pass to TclDoGlob. */ @@ -5292,21 +5292,21 @@ TestReportMatchInDirectory(interp, resultPtr, dirPtr, pattern, types) TestReport("matchindirectory",dirPtr, NULL); return -1; } -Tcl_Obj * +static Tcl_Obj * TestReportGetCwd(interp) Tcl_Interp *interp; { TestReport("cwd",NULL,NULL); return NULL; } -int +static int TestReportChdir(dirName) Tcl_Obj *dirName; { TestReport("chdir",dirName,NULL); return -1; } -int +static int TestReportLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Obj *fileName; /* Name of the file containing the desired @@ -5323,7 +5323,7 @@ TestReportLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataP TestReport("loadfile",fileName,NULL); return -1; } -void +static void TestReportUnloadFile(clientData) ClientData clientData; /* ClientData returned by a previous call * to TclpLoadFile(). The clientData is @@ -5332,21 +5332,21 @@ TestReportUnloadFile(clientData) { TestReport("unloadfile",NULL,NULL); } -Tcl_Obj * -TestReportReadlink(path) - Tcl_Obj *path; /* Path of file to readlink (UTF-8). */ +static Tcl_Obj * +TestReportLink(path, to) + Tcl_Obj *path; /* Path of file to readlink or link */ + Tcl_Obj *to; /* Path of file to link to, or NULL */ { - TestReport("readlink",path,NULL); + TestReport("link",path,NULL); return NULL; } -int -TestReportListVolumes(interp) - Tcl_Interp *interp; /* Interpreter for returning volume list. */ +static Tcl_Obj * +TestReportListVolumes() { TestReport("listvolumes",NULL,NULL); - return TCL_OK; + return NULL; } -int +static int TestReportRenameFile(src, dst) Tcl_Obj *src; /* Pathname of file or dir to be renamed * (UTF-8). */ @@ -5356,7 +5356,7 @@ TestReportRenameFile(src, dst) TestReport("renamefile",src,dst); return -1; } -int +static int TestReportCopyFile(src, dst) Tcl_Obj *src; /* Pathname of file to be copied (UTF-8). */ Tcl_Obj *dst; /* Pathname of file to copy to (UTF-8). */ @@ -5364,21 +5364,21 @@ TestReportCopyFile(src, dst) TestReport("copyfile",src,dst); return -1; } -int +static int TestReportDeleteFile(path) Tcl_Obj *path; /* Pathname of file to be removed (UTF-8). */ { TestReport("deletefile",path,NULL); return -1; } -int +static int TestReportCreateDirectory(path) Tcl_Obj *path; /* Pathname of directory to create (UTF-8). */ { TestReport("createdirectory",path,NULL); return -1; } -int +static int TestReportCopyDirectory(src, dst, errorPtr) Tcl_Obj *src; /* Pathname of directory to be copied * (UTF-8). */ @@ -5390,7 +5390,7 @@ TestReportCopyDirectory(src, dst, errorPtr) TestReport("copydirectory",src,dst); return -1; } -int +static int TestReportRemoveDirectory(path, recursive, errorPtr) Tcl_Obj *path; /* Pathname of directory to be removed * (UTF-8). */ @@ -5404,7 +5404,7 @@ TestReportRemoveDirectory(path, recursive, errorPtr) TestReport("removedirectory",path,NULL); return -1; } -char** +static char** TestReportFileAttrStrings(fileName, objPtrRef) Tcl_Obj* fileName; Tcl_Obj** objPtrRef; @@ -5412,7 +5412,7 @@ TestReportFileAttrStrings(fileName, objPtrRef) TestReport("fileattributestrings",fileName,NULL); return NULL; } -int +static int TestReportFileAttrsGet(interp, index, fileName, objPtrRef) Tcl_Interp *interp; /* The interpreter for error reporting. */ int index; /* index of the attribute command. */ @@ -5422,7 +5422,7 @@ TestReportFileAttrsGet(interp, index, fileName, objPtrRef) TestReport("fileattributesget",fileName,NULL); return -1; } -int +static int TestReportFileAttrsSet(interp, index, fileName, objPtr) Tcl_Interp *interp; /* The interpreter for error reporting. */ int index; /* index of the attribute command. */ @@ -5432,7 +5432,7 @@ TestReportFileAttrsSet(interp, index, fileName, objPtr) TestReport("fileattributesset",fileName,objPtr); return -1; } -int +static int TestReportUtime (fileName, tval) Tcl_Obj* fileName; struct utimbuf *tval; @@ -5440,7 +5440,7 @@ TestReportUtime (fileName, tval) TestReport("utime",fileName,NULL); return -1; } -int +static int TestReportNormalizePath(interp, pathPtr, nextCheckpoint) Tcl_Interp *interp; Tcl_Obj *pathPtr; diff --git a/mac/tclMacFCmd.c b/mac/tclMacFCmd.c index 462d48e..e3c2366 100644 --- a/mac/tclMacFCmd.c +++ b/mac/tclMacFCmd.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: tclMacFCmd.c,v 1.8 2001/07/31 19:12:07 vincentdarley Exp $ + * RCS: @(#) $Id: tclMacFCmd.c,v 1.9 2001/08/23 17:37:08 vincentdarley Exp $ */ #include "tclInt.h" @@ -102,14 +102,14 @@ int TclpObjCreateDirectory(pathPtr) Tcl_Obj *pathPtr; { - return TclpCreateDirectory(Tcl_FSGetTranslatedPath(NULL, pathPtr)); + return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr)); } int TclpObjDeleteFile(pathPtr) Tcl_Obj *pathPtr; { - return TclpDeleteFile(Tcl_FSGetTranslatedPath(NULL, pathPtr)); + return DoDeleteFile(Tcl_FSGetNativePath(pathPtr)); } int @@ -120,8 +120,8 @@ TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr) { Tcl_DString ds; int ret; - ret = TclpCopyDirectory(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), - Tcl_FSGetTranslatedPath(NULL,destPathPtr), &ds); + ret = DoCopyDirectory(Tcl_FSGetNativePath(srcPathPtr), + Tcl_FSGetNativePath(destPathPtr), &ds); if (ret != TCL_OK) { *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); Tcl_DStringFree(&ds); @@ -135,8 +135,8 @@ TclpObjCopyFile(srcPathPtr, destPathPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; { - return TclpCopyFile(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), - Tcl_FSGetTranslatedPath(NULL,destPathPtr)); + return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr), + Tcl_FSGetNativePath(destPathPtr)); } int @@ -147,7 +147,7 @@ TclpObjRemoveDirectory(pathPtr, recursive, errorPtr) { Tcl_DString ds; int ret; - ret = TclpRemoveDirectory(Tcl_FSGetTranslatedPath(NULL, pathPtr),recursive, &ds); + ret = DoRemoveDirectory(Tcl_FSGetNativePath(pathPtr),recursive, &ds); if (ret != TCL_OK) { *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); Tcl_DStringFree(&ds); @@ -161,8 +161,8 @@ TclpObjRenameFile(srcPathPtr, destPathPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; { - return TclpRenameFile(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), - Tcl_FSGetTranslatedPath(NULL,destPathPtr)); + return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), + Tcl_FSGetNativePath(destPathPtr)); } /* @@ -744,8 +744,8 @@ TclpCopyDirectory( static int DoCopyDirectory( CONST char *src, /* Pathname of directory to be copied - * (UTF-8). */ - CONST char *dst, /* Pathname of target directory (UTF-8). */ + * (Native). */ + CONST char *dst, /* Pathname of target directory (Native). */ Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free * DString filled with UTF-8 name of file * causing error. */ @@ -1555,23 +1555,20 @@ SetFileReadOnly( /* *--------------------------------------------------------------------------- * - * TclpListVolumes -- + * TclpObjListVolumes -- * * Lists the currently mounted volumes * * Results: - * A standard Tcl result. Will always be TCL_OK, since there is no way - * that this command can fail. Also, the interpreter's result is set to - * the list of volumes. + * The list of volumes. * * Side effects: * None * *--------------------------------------------------------------------------- */ -int -TclpListVolumes( - Tcl_Interp *interp) /* Interpreter to which to pass the volume list */ +Tcl_Obj* +TclpObjListVolumes(void) { HParamBlockRec pb; Str255 name; @@ -1606,15 +1603,15 @@ TclpListVolumes( elemPtr = Tcl_NewStringObj(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr)); Tcl_AppendToObj(elemPtr, ":", 1); - Tcl_ListObjAppendElement(interp, resultPtr, elemPtr); + Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr); Tcl_DStringFree(&dstr); volIndex++; } - - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; + + Tcl_IncrRefCount(resultPtr); + return resultPtr; } /* diff --git a/mac/tclMacFile.c b/mac/tclMacFile.c index fd186b7..c8aaf85 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.10 2001/07/31 19:12:07 vincentdarley Exp $ + * RCS: @(#) $Id: tclMacFile.c,v 1.11 2001/08/23 17:37:08 vincentdarley Exp $ */ /* @@ -146,14 +146,14 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) OSType okType = 0; OSType okCreator = 0; Tcl_DString dsOrig; - char *fileName2; + Tcl_Obj *fileNamePtr; - fileName2 = Tcl_FSGetTranslatedPath(interp, pathPtr); - if (fileName2 == NULL) { + fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr); + if (fileNamePtr == NULL) { return TCL_ERROR; } Tcl_DStringInit(&dsOrig); - Tcl_DStringAppend(&dsOrig, fileName2, -1); + Tcl_DStringAppend(&dsOrig, Tcl_GetString(fileNamePtr), -1); baseLength = Tcl_DStringLength(&dsOrig); /* @@ -241,6 +241,8 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) typeOk = 0; } } else { + struct stat buf; + if (pb.hFileInfo.ioFlFndrInfo.fdFlags & kIsInvisible) { /* If invisible */ if ((types->perm == 0) || @@ -268,12 +270,14 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) } } if (typeOk == 1 && types->type != 0) { - struct stat buf; - /* - * We must match at least one flag to be listed - */ - typeOk = 0; - if (TclpLstat(fname, &buf) >= 0) { + if (types->perm == 0) { + /* We haven't yet done a stat on the file */ + if (TclpStat(fname, &buf) != 0) { + /* Posix error occurred */ + typeOk = 0; + } + } + if (typeOk) { /* * In order bcdpfls as in 'find -t' */ @@ -288,19 +292,24 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) S_ISFIFO(buf.st_mode)) || ((types->type & TCL_GLOB_TYPE_FILE) && S_ISREG(buf.st_mode)) -#ifdef S_ISLNK - || ((types->type & TCL_GLOB_TYPE_LINK) && - S_ISLNK(buf.st_mode)) -#endif -#ifdef S_ISSOCK + #ifdef S_ISSOCK || ((types->type & TCL_GLOB_TYPE_SOCK) && S_ISSOCK(buf.st_mode)) -#endif + #endif ) { - typeOk = 1; + /* Do nothing -- this file is ok */ + } else { + typeOk = 0; + #ifdef S_ISLNK + if (types->type & TCL_GLOB_TYPE_LINK) { + if (TclpLstat(fname, &buf) == 0) { + if (S_ISLNK(buf.st_mode)) { + typeOk = 1; + } + } + } + #endif } - } else { - /* Posix error occurred */ } } if (typeOk && ( @@ -1090,15 +1099,25 @@ TclpTempFileName() #ifdef S_IFLNK Tcl_Obj* -TclpObjReadlink(pathPtr) +TclpObjLink(pathPtr, toPtr) Tcl_Obj *pathPtr; + Tcl_Obj *toPtr; { - Tcl_DString ds; Tcl_Obj* link = NULL; - if (TclpReadlink(Tcl_FSGetTranslatedPath(NULL, pathPtr), &ds) != NULL) { - link = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); - Tcl_IncrRefCount(link); - Tcl_DStringFree(&ds); + + if (toPtr != NULL) { + return NULL; + } else { + Tcl_DString ds; + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); + if (transPtr == NULL) { + return NULL; + } + if (TclpReadlink(Tcl_GetString(transPtr), &ds) != NULL) { + link = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + Tcl_IncrRefCount(link); + Tcl_DStringFree(&ds); + } } return link; } diff --git a/tests/fileName.test b/tests/fileName.test index 318b3ab..a1a0011 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.11 2001/07/31 19:12:07 vincentdarley Exp $ +# RCS: @(#) $Id: fileName.test,v 1.12 2001/08/23 17:37:08 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -1143,6 +1143,61 @@ test filename-11.17.1 {Tcl_GlobCmd} {pcOnly macOnly} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]]] +test filename-11.17.2 {Tcl_GlobCmd} {unixOnly notRoot} { + set dir [pwd] + set ret "error in test" + if {[catch { + cd $globname + exec ln -s a1 link + cd $dir + set ret [list [catch { + lsort [glob -directory $globname -join * b1] + } msg] $msg] + }]} { + cd $dir + } + file delete [file join $globname link] + set ret +} [list 0 [lsort [list [file join $globname a1 b1] \ + [file join $globname link b1]]]] +# Simpler version of the above test to illustrate a given bug. +test filename-11.17.3 {Tcl_GlobCmd} {unixOnly notRoot} { + set dir [pwd] + set ret "error in test" + if {[catch { + cd $globname + exec ln -s a1 link + cd $dir + set ret [list [catch { + lsort [glob -directory $globname -type d *] + } msg] $msg] + }]} { + cd $dir + } + file delete [file join $globname link] + set ret +} [list 0 [lsort [list [file join $globname a1] \ + [file join $globname a2] \ + [file join $globname a3] \ + [file join $globname link]]]] +# Make sure the bugfix isn't too simple. We don't want +# to break 'glob -type l'. +test filename-11.17.4 {Tcl_GlobCmd} {unixOnly notRoot} { + set dir [pwd] + set ret "error in test" + if {[catch { + cd $globname + exec ln -s a1 link + cd $dir + set ret [list [catch { + lsort [glob -directory $globname -type l *] + } msg] $msg] + }]} { + cd $dir + } + file delete [file join $globname link] + set ret +} [list 0 [list [file join $globname link]]] test filename-11.18 {Tcl_GlobCmd} {unixOnly} { list [catch {lsort [glob -path $globname/ *]} msg] $msg } [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\ diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index 8f729e8..223f373 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.8 2001/08/02 01:27:13 hobbs Exp $ + * RCS: @(#) $Id: tclUnixFCmd.c,v 1.9 2001/08/23 17:37:08 vincentdarley Exp $ * * Portions of this code were derived from NetBSD source code which has * the following copyright notice: @@ -71,23 +71,23 @@ */ static int GetGroupAttribute _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, CONST char *fileName, + int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr)); static int GetOwnerAttribute _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, CONST char *fileName, + int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr)); static int GetPermissionsAttribute _ANSI_ARGS_(( Tcl_Interp *interp, int objIndex, - CONST char *fileName, Tcl_Obj **attributePtrPtr)); + Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr)); static int SetGroupAttribute _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, CONST char *fileName, + int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr)); static int SetOwnerAttribute _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, CONST char *fileName, + int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr)); static int SetPermissionsAttribute _ANSI_ARGS_(( Tcl_Interp *interp, int objIndex, - CONST char *fileName, Tcl_Obj *attributePtr)); + Tcl_Obj *fileName, Tcl_Obj *attributePtr)); static int GetModeFromPermString _ANSI_ARGS_(( Tcl_Interp *interp, char *modeStringPtr, mode_t *modePtr)); @@ -131,10 +131,10 @@ static int CopyFile _ANSI_ARGS_((CONST char *src, CONST char *dst, CONST struct stat *statBufPtr)); static int CopyFileAtts _ANSI_ARGS_((CONST char *src, CONST char *dst, CONST struct stat *statBufPtr)); -static int DoCopyFile _ANSI_ARGS_((Tcl_DString *srcPtr, - Tcl_DString *dstPtr)); -static int DoCreateDirectory _ANSI_ARGS_((Tcl_DString *pathPtr)); -static int DoDeleteFile _ANSI_ARGS_((Tcl_DString *pathPtr)); +static int DoCopyFile _ANSI_ARGS_((CONST char *srcPtr, + CONST char *dstPtr)); +static int DoCreateDirectory _ANSI_ARGS_((CONST char *pathPtr)); +static int DoDeleteFile _ANSI_ARGS_((CONST char *path)); static int DoRemoveDirectory _ANSI_ARGS_((Tcl_DString *pathPtr, int recursive, Tcl_DString *errorPtr)); static int DoRenameFile _ANSI_ARGS_((CONST char *src, @@ -154,14 +154,14 @@ int TclpObjCreateDirectory(pathPtr) Tcl_Obj *pathPtr; { - return TclpCreateDirectory(Tcl_FSGetTranslatedPath(NULL, pathPtr)); + return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr)); } int TclpObjDeleteFile(pathPtr) Tcl_Obj *pathPtr; { - return TclpDeleteFile(Tcl_FSGetTranslatedPath(NULL, pathPtr)); + return DoDeleteFile(Tcl_FSGetNativePath(pathPtr)); } int @@ -172,8 +172,8 @@ TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr) { Tcl_DString ds; int ret; - ret = TclpCopyDirectory(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), - Tcl_FSGetTranslatedPath(NULL,destPathPtr), &ds); + ret = TclpCopyDirectory(Tcl_FSGetTranslatedStringPath(NULL,srcPathPtr), + Tcl_FSGetTranslatedStringPath(NULL,destPathPtr), &ds); if (ret != TCL_OK) { *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); Tcl_DStringFree(&ds); @@ -187,8 +187,8 @@ TclpObjCopyFile(srcPathPtr, destPathPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; { - return TclpCopyFile(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), - Tcl_FSGetTranslatedPath(NULL,destPathPtr)); + return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr), + Tcl_FSGetNativePath(destPathPtr)); } int @@ -199,7 +199,7 @@ TclpObjRemoveDirectory(pathPtr, recursive, errorPtr) { Tcl_DString ds; int ret; - ret = TclpRemoveDirectory(Tcl_FSGetTranslatedPath(NULL, pathPtr),recursive, &ds); + ret = TclpRemoveDirectory(Tcl_FSGetTranslatedStringPath(NULL, pathPtr),recursive, &ds); if (ret != TCL_OK) { *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); Tcl_DStringFree(&ds); @@ -213,8 +213,8 @@ TclpObjRenameFile(srcPathPtr, destPathPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; { - return TclpRenameFile(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), - Tcl_FSGetTranslatedPath(NULL,destPathPtr)); + return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), + Tcl_FSGetNativePath(destPathPtr)); } /* @@ -389,22 +389,19 @@ TclpCopyFile(src, dst) Tcl_UtfToExternalDString(NULL, src, -1, &srcString); Tcl_UtfToExternalDString(NULL, dst, -1, &dstString); - result = DoCopyFile(&srcString, &dstString); + result = DoCopyFile(Tcl_DStringValue(&srcString), + Tcl_DStringValue(&dstString)); Tcl_DStringFree(&srcString); Tcl_DStringFree(&dstString); return result; } static int -DoCopyFile(srcPtr, dstPtr) - Tcl_DString *srcPtr; /* Pathname of file to be copied (native). */ - Tcl_DString *dstPtr; /* Pathname of file to copy to (native). */ +DoCopyFile(src, dst) + CONST char *src; /* Pathname of file to be copied (native). */ + CONST char *dst; /* Pathname of file to copy to (native). */ { struct stat srcStatBuf, dstStatBuf; - CONST char *src, *dst; - - src = Tcl_DStringValue(srcPtr); - dst = Tcl_DStringValue(dstPtr); /* * Have to do a stat() to determine the filetype. @@ -591,18 +588,15 @@ TclpDeleteFile(path) Tcl_DString pathString; Tcl_UtfToExternalDString(NULL, path, -1, &pathString); - result = DoDeleteFile(&pathString); + result = DoDeleteFile(Tcl_DStringValue(&pathString)); Tcl_DStringFree(&pathString); return result; } static int -DoDeleteFile(pathPtr) - Tcl_DString *pathPtr; /* Pathname of file to be removed (native). */ +DoDeleteFile(path) + CONST char *path; /* Pathname of file to be removed (native). */ { - CONST char *path; - - path = Tcl_DStringValue(pathPtr); if (unlink(path) != 0) { /* INTL: Native. */ return TCL_ERROR; } @@ -643,19 +637,16 @@ TclpCreateDirectory(path) Tcl_DString pathString; Tcl_UtfToExternalDString(NULL, path, -1, &pathString); - result = DoCreateDirectory(&pathString); + result = DoCreateDirectory(Tcl_DStringValue(&pathString)); Tcl_DStringFree(&pathString); return result; } static int -DoCreateDirectory(pathPtr) - Tcl_DString *pathPtr; /* Pathname of directory to create (native). */ +DoCreateDirectory(path) + CONST char *path; /* Pathname of directory to create (native). */ { mode_t mode; - CONST char *path; - - path = Tcl_DStringValue(pathPtr); mode = umask(0); umask(mode); @@ -975,13 +966,14 @@ TraversalCopy(srcPtr, dstPtr, statBufPtr, type, errorPtr) { switch (type) { case DOTREE_F: - if (DoCopyFile(srcPtr, dstPtr) == TCL_OK) { + if (DoCopyFile(Tcl_DStringValue(srcPtr), + Tcl_DStringValue(dstPtr)) == TCL_OK) { return TCL_OK; } break; case DOTREE_PRED: - if (DoCreateDirectory(dstPtr) == TCL_OK) { + if (DoCreateDirectory(Tcl_DStringValue(dstPtr)) == TCL_OK) { return TCL_OK; } break; @@ -1039,7 +1031,7 @@ TraversalDelete(srcPtr, ignore, statBufPtr, type, errorPtr) { switch (type) { case DOTREE_F: { - if (DoDeleteFile(srcPtr) == 0) { + if (DoDeleteFile(Tcl_DStringValue(srcPtr)) == 0) { return TCL_OK; } break; @@ -1140,17 +1132,18 @@ static int GetGroupAttribute(interp, objIndex, fileName, attributePtrPtr) Tcl_Interp *interp; /* The interp we are using for errors. */ int objIndex; /* The index of the attribute. */ - CONST char *fileName; /* The name of the file (UTF-8). */ + Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ { struct stat statBuf; struct group *groupPtr; int result; - result = TclStat(fileName, &statBuf); + result = TclpObjStat(fileName, &statBuf); if (result != 0) { - Tcl_AppendResult(interp, "could not read \"", fileName, "\": ", + Tcl_AppendResult(interp, "could not read \"", + Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } @@ -1191,17 +1184,18 @@ static int GetOwnerAttribute(interp, objIndex, fileName, attributePtrPtr) Tcl_Interp *interp; /* The interp we are using for errors. */ int objIndex; /* The index of the attribute. */ - CONST char *fileName; /* The name of the file (UTF-8). */ + Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ { struct stat statBuf; struct passwd *pwPtr; int result; - result = TclStat(fileName, &statBuf); + result = TclpObjStat(fileName, &statBuf); if (result != 0) { - Tcl_AppendResult(interp, "could not read \"", fileName, "\": ", + Tcl_AppendResult(interp, "could not read \"", + Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } @@ -1242,17 +1236,18 @@ static int GetPermissionsAttribute(interp, objIndex, fileName, attributePtrPtr) Tcl_Interp *interp; /* The interp we are using for errors. */ int objIndex; /* The index of the attribute. */ - CONST char *fileName; /* The name of the file (UTF-8). */ + Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ { struct stat statBuf; char returnString[7]; int result; - result = TclStat(fileName, &statBuf); + result = TclpObjStat(fileName, &statBuf); if (result != 0) { - Tcl_AppendResult(interp, "could not read \"", fileName, "\": ", + Tcl_AppendResult(interp, "could not read \"", + Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } @@ -1284,15 +1279,15 @@ static int SetGroupAttribute(interp, objIndex, fileName, attributePtr) Tcl_Interp *interp; /* The interp for error reporting. */ int objIndex; /* The index of the attribute. */ - CONST char *fileName; /* The name of the file (UTF-8). */ + Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj *attributePtr; /* New group for file. */ { long gid; int result; - Tcl_DString ds; CONST char *native; if (Tcl_GetLongFromObj(NULL, attributePtr, &gid) != TCL_OK) { + Tcl_DString ds; struct group *groupPtr; CONST char *string; int length; @@ -1306,21 +1301,22 @@ SetGroupAttribute(interp, objIndex, fileName, attributePtr) if (groupPtr == NULL) { endgrent(); Tcl_AppendResult(interp, "could not set group for file \"", - fileName, "\": group \"", string, "\" does not exist", + Tcl_GetString(fileName), "\": group \"", + string, "\" does not exist", (char *) NULL); return TCL_ERROR; } gid = groupPtr->gr_gid; } - native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); + native = Tcl_FSGetNativePath(fileName); result = chown(native, (uid_t) -1, (gid_t) gid); /* INTL: Native. */ - Tcl_DStringFree(&ds); endgrent(); if (result != 0) { Tcl_AppendResult(interp, "could not set group for file \"", - fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), + (char *) NULL); return TCL_ERROR; } return TCL_OK; @@ -1346,15 +1342,15 @@ static int SetOwnerAttribute(interp, objIndex, fileName, attributePtr) Tcl_Interp *interp; /* The interp for error reporting. */ int objIndex; /* The index of the attribute. */ - CONST char *fileName; /* The name of the file (UTF-8). */ + Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj *attributePtr; /* New owner for file. */ { long uid; int result; - Tcl_DString ds; CONST char *native; if (Tcl_GetLongFromObj(NULL, attributePtr, &uid) != TCL_OK) { + Tcl_DString ds; struct passwd *pwPtr; CONST char *string; int length; @@ -1367,20 +1363,21 @@ SetOwnerAttribute(interp, objIndex, fileName, attributePtr) if (pwPtr == NULL) { Tcl_AppendResult(interp, "could not set owner for file \"", - fileName, "\": user \"", string, "\" does not exist", + Tcl_GetString(fileName), "\": user \"", + string, "\" does not exist", (char *) NULL); return TCL_ERROR; } uid = pwPtr->pw_uid; } - native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); + native = Tcl_FSGetNativePath(fileName); result = chown(native, (uid_t) uid, (gid_t) -1); /* INTL: Native. */ - Tcl_DStringFree(&ds); if (result != 0) { - Tcl_AppendResult(interp, "could not set owner for file \"", fileName, - "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_AppendResult(interp, "could not set owner for file \"", + Tcl_GetString(fileName), "\": ", + Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; @@ -1406,14 +1403,13 @@ static int SetPermissionsAttribute(interp, objIndex, fileName, attributePtr) Tcl_Interp *interp; /* The interp we are using for errors. */ int objIndex; /* The index of the attribute. */ - CONST char *fileName; /* The name of the file (UTF-8). */ + Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj *attributePtr; /* The attribute to set. */ { long mode; mode_t newMode; int result; CONST char *native; - Tcl_DString ds; /* * First try if the string is a number @@ -1421,6 +1417,7 @@ SetPermissionsAttribute(interp, objIndex, fileName, attributePtr) if (Tcl_GetLongFromObj(NULL, attributePtr, &mode) == TCL_OK) { newMode = (mode_t) (mode & 0x00007FFF); } else { + Tcl_DString ds; struct stat buf; char *modeStringPtr = Tcl_GetString(attributePtr); @@ -1430,9 +1427,10 @@ SetPermissionsAttribute(interp, objIndex, fileName, attributePtr) * We get the current mode of the file, in order to allow for * ug+-=rwx style chmod strings. */ - result = TclStat(fileName, &buf); + result = TclpObjStat(fileName, &buf); if (result != 0) { - Tcl_AppendResult(interp, "could not read \"", fileName, "\": ", + Tcl_AppendResult(interp, "could not read \"", + Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } @@ -1446,12 +1444,12 @@ SetPermissionsAttribute(interp, objIndex, fileName, attributePtr) } } - native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); + native = Tcl_FSGetNativePath(fileName); result = chmod(native, newMode); /* INTL: Native. */ - Tcl_DStringFree(&ds); if (result != 0) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "could not set permissions for file \"", fileName, "\": ", + "could not set permissions for file \"", + Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } @@ -1461,14 +1459,12 @@ SetPermissionsAttribute(interp, objIndex, fileName, attributePtr) /* *--------------------------------------------------------------------------- * - * TclpListVolumes -- + * TclpObjListVolumes -- * * Lists the currently mounted volumes, which on UNIX is just /. * * Results: - * A standard Tcl result. Will always be TCL_OK, since there is no way - * that this command can fail. Also, the interpreter's result is set to - * the list of volumes. + * The list of volumes. * * Side effects: * None. @@ -1476,16 +1472,13 @@ SetPermissionsAttribute(interp, objIndex, fileName, attributePtr) *--------------------------------------------------------------------------- */ -int -TclpListVolumes(interp) - Tcl_Interp *interp; /* Interpreter to which to pass - * the volume list. */ +Tcl_Obj* +TclpObjListVolumes(void) { - Tcl_Obj *resultPtr; - - resultPtr = Tcl_GetObjResult(interp); - Tcl_SetStringObj(resultPtr, "/", 1); - return TCL_OK; + Tcl_Obj *resultPtr = Tcl_NewStringObj("/",1); + + Tcl_IncrRefCount(resultPtr); + return resultPtr; } /* diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 308a320..bbfebf1 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixFile.c,v 1.10 2001/07/31 19:12:07 vincentdarley Exp $ + * RCS: @(#) $Id: tclUnixFile.c,v 1.11 2001/08/23 17:37:08 vincentdarley Exp $ */ #include "tclInt.h" @@ -210,15 +210,15 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) int matchHidden; int result = TCL_OK; Tcl_DString dsOrig; - char *fileName; + Tcl_Obj *fileNamePtr; int baseLength; - fileName = Tcl_FSGetTranslatedPath(interp, pathPtr); - if (fileName == NULL) { + fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr); + if (fileNamePtr == NULL) { return TCL_ERROR; } Tcl_DStringInit(&dsOrig); - Tcl_DStringAppend(&dsOrig, fileName, -1); + Tcl_DStringAppend(&dsOrig, Tcl_GetString(fileNamePtr), -1); baseLength = Tcl_DStringLength(&dsOrig); /* @@ -315,10 +315,8 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) } /* - * Now check to see if the file matches. If there are more - * characters to be processed, then ensure matching files are - * directories before calling TclDoGlob. Otherwise, just add - * the file to the result. + * Now check to see if the file matches, according to both type + * and pattern. If so, add the file to the result. */ utf = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1, &ds); @@ -329,17 +327,29 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) Tcl_DStringAppend(&dsOrig, utf, -1); fname = Tcl_DStringValue(&dsOrig); if (types != NULL) { - if (types->perm != 0) { - struct stat buf; + struct stat buf; + if (types->perm != 0) { if (TclpStat(fname, &buf) != 0) { - panic("stat failed on known file"); + /* + * Either the file has disappeared between the + * 'readdir' call and the 'TclpStat' call, or + * the file is a link to a file which doesn't + * exist (which we could ascertain with + * TclpLstat), 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 ( + if (typeOk && ( ((types->perm & TCL_GLOB_PERM_RONLY) && (buf.st_mode & (S_IWOTH|S_IWGRP|S_IWUSR))) || ((types->perm & TCL_GLOB_PERM_R) && @@ -348,17 +358,19 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) (TclpAccess(fname, W_OK) != 0)) || ((types->perm & TCL_GLOB_PERM_X) && (TclpAccess(fname, X_OK) != 0)) - ) { + )) { typeOk = 0; } } if (typeOk && (types->type != 0)) { - struct stat buf; - /* - * We must match at least one flag to be listed - */ - typeOk = 0; - if (TclpLstat(fname, &buf) >= 0) { + if (types->perm == 0) { + /* We haven't yet done a stat on the file */ + if (TclpStat(fname, &buf) != 0) { + /* Posix error occurred */ + typeOk = 0; + } + } + if (typeOk) { /* * In order bcdpfls as in 'find -t' */ @@ -373,19 +385,24 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) S_ISFIFO(buf.st_mode)) || ((types->type & TCL_GLOB_TYPE_FILE) && S_ISREG(buf.st_mode)) -#ifdef S_ISLNK - || ((types->type & TCL_GLOB_TYPE_LINK) && - S_ISLNK(buf.st_mode)) -#endif #ifdef S_ISSOCK || ((types->type & TCL_GLOB_TYPE_SOCK) && S_ISSOCK(buf.st_mode)) #endif ) { - typeOk = 1; + /* Do nothing -- this file is ok */ + } else { + typeOk = 0; +#ifdef S_ISLNK + if (types->type & TCL_GLOB_TYPE_LINK) { + if (TclpLstat(fname, &buf) == 0) { + if (S_ISLNK(buf.st_mode)) { + typeOk = 1; + } + } + } +#endif } - } else { - /* Posix error occurred */ } } } @@ -729,32 +746,38 @@ TclpObjAccess(pathPtr, mode) #ifdef S_IFLNK Tcl_Obj* -TclpObjReadlink(pathPtr) +TclpObjLink(pathPtr, toPtr) Tcl_Obj *pathPtr; + Tcl_Obj *toPtr; { - char link[MAXPATHLEN]; - int length; - char *native; - Tcl_Obj* linkPtr; - - if (Tcl_FSGetTranslatedPath(NULL, pathPtr) == NULL) { - return NULL; - } - length = readlink(Tcl_FSGetNativePath(pathPtr), link, sizeof(link)); - if (length < 0) { + Tcl_Obj* linkPtr = NULL; + + if (toPtr != NULL) { return NULL; + } else { + char link[MAXPATHLEN]; + int length; + char *native; + + if (Tcl_FSGetTranslatedPath(NULL, pathPtr) == NULL) { + return NULL; + } + length = readlink(Tcl_FSGetNativePath(pathPtr), link, sizeof(link)); + if (length < 0) { + return NULL; + } + + /* + * Allocate and copy the name, taking care since the + * name need not be null terminated. + */ + native = (char*)ckalloc((unsigned)(1+length)); + strncpy(native, link, (unsigned)length); + native[length] = '\0'; + + linkPtr = Tcl_FSNewNativePath(pathPtr, native); + Tcl_IncrRefCount(linkPtr); } - - /* - * Allocate and copy the name, taking care since the - * name need not be null terminated. - */ - native = (char*)ckalloc((unsigned)(1+length)); - strncpy(native, link, (unsigned)length); - native[length] = '\0'; - - linkPtr = Tcl_FSNewNativePath(pathPtr, native); - Tcl_IncrRefCount(linkPtr); return linkPtr; } diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 230723c..c21fb9e 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.9 2001/07/31 19:12:08 vincentdarley Exp $ + * RCS: @(#) $Id: tclWinFCmd.c,v 1.10 2001/08/23 17:37:08 vincentdarley Exp $ */ #include "tclWinInt.h" @@ -28,19 +28,19 @@ */ static int GetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, CONST char *fileName, + int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr)); static int GetWinFileLongName _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, CONST char *fileName, + int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr)); static int GetWinFileShortName _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, CONST char *fileName, + int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr)); static int SetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, CONST char *fileName, + int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr)); static int CannotSetAttribute _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, CONST char *fileName, + int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr)); /* @@ -77,26 +77,28 @@ const TclFileAttrProcs tclpFileAttrProcs[] = { * Prototype for the TraverseWinTree callback function. */ -typedef int (TraversalProc)(Tcl_DString *srcPtr, Tcl_DString *dstPtr, +typedef int (TraversalProc)(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, int type, Tcl_DString *errorPtr); /* * Declarations for local procedures defined in this file: */ -static void StatError(Tcl_Interp *interp, CONST char *fileName); +static void StatError(Tcl_Interp *interp, Tcl_Obj *fileName); static int ConvertFileNameFormat(Tcl_Interp *interp, - int objIndex, CONST char *fileName, int longShort, + int objIndex, Tcl_Obj *fileName, int longShort, Tcl_Obj **attributePtrPtr); -static int DoCopyFile(Tcl_DString *srcPtr, Tcl_DString *dstPtr); -static int DoCreateDirectory(Tcl_DString *pathPtr); -static int DoDeleteFile(Tcl_DString *pathPtr); +static int DoCopyFile(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr); +static int DoCreateDirectory(CONST TCHAR *pathPtr); +static int DoDeleteFile(CONST TCHAR *pathPtr); +static int DoRemoveJustDirectory(CONST TCHAR *nativeSrc, int recursive, + Tcl_DString *errorPtr); static int DoRemoveDirectory(Tcl_DString *pathPtr, int recursive, Tcl_DString *errorPtr); -static int DoRenameFile(const TCHAR *nativeSrc, Tcl_DString *dstPtr); -static int TraversalCopy(Tcl_DString *srcPtr, Tcl_DString *dstPtr, +static int DoRenameFile(CONST TCHAR *nativeSrc, CONST TCHAR *dstPtr); +static int TraversalCopy(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, int type, Tcl_DString *errorPtr); -static int TraversalDelete(Tcl_DString *srcPtr, Tcl_DString *dstPtr, +static int TraversalDelete(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, int type, Tcl_DString *errorPtr); static int TraverseWinTree(TraversalProc *traverseProc, Tcl_DString *sourcePtr, Tcl_DString *dstPtr, @@ -107,14 +109,14 @@ int TclpObjCreateDirectory(pathPtr) Tcl_Obj *pathPtr; { - return TclpCreateDirectory(Tcl_FSGetTranslatedPath(NULL, pathPtr)); + return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr)); } int TclpObjDeleteFile(pathPtr) Tcl_Obj *pathPtr; { - return TclpDeleteFile(Tcl_FSGetTranslatedPath(NULL, pathPtr)); + return DoDeleteFile(Tcl_FSGetNativePath(pathPtr)); } int @@ -125,8 +127,8 @@ TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr) { Tcl_DString ds; int ret; - ret = TclpCopyDirectory(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), - Tcl_FSGetTranslatedPath(NULL,destPathPtr), &ds); + ret = TclpCopyDirectory(Tcl_FSGetTranslatedStringPath(NULL,srcPathPtr), + Tcl_FSGetTranslatedStringPath(NULL,destPathPtr), &ds); if (ret != TCL_OK) { *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); Tcl_DStringFree(&ds); @@ -140,8 +142,8 @@ TclpObjCopyFile(srcPathPtr, destPathPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; { - return TclpCopyFile(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), - Tcl_FSGetTranslatedPath(NULL,destPathPtr)); + return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr), + Tcl_FSGetNativePath(destPathPtr)); } int @@ -152,7 +154,16 @@ TclpObjRemoveDirectory(pathPtr, recursive, errorPtr) { Tcl_DString ds; int ret; - ret = TclpRemoveDirectory(Tcl_FSGetTranslatedPath(NULL, pathPtr),recursive, &ds); + if (recursive) { + /* + * In the recursive case, the string rep is used to construct a Tcl_DString + * which may be used extensively, so we can't optimize this case easily. + */ + ret = TclpRemoveDirectory(Tcl_FSGetTranslatedStringPath(NULL, pathPtr), + recursive, &ds); + } else { + ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr), recursive, &ds); + } if (ret != TCL_OK) { *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); Tcl_DStringFree(&ds); @@ -166,8 +177,7 @@ TclpObjRenameFile(srcPathPtr, destPathPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; { - return TclpRenameFile(Tcl_FSGetTranslatedPath(NULL,srcPathPtr), - Tcl_FSGetTranslatedPath(NULL,destPathPtr)); + return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), Tcl_FSGetNativePath(destPathPtr)); } /* @@ -221,12 +231,13 @@ TclpRenameFile( { int result; TCHAR *nativeSrc; + TCHAR *nativeDest; Tcl_DString srcString, dstString; nativeSrc = Tcl_WinUtfToTChar(src, -1, &srcString); - Tcl_WinUtfToTChar(dst, -1, &dstString); + nativeDest = Tcl_WinUtfToTChar(dst, -1, &dstString); - result = DoRenameFile(nativeSrc, &dstString); + result = DoRenameFile(nativeSrc, nativeDest); Tcl_DStringFree(&srcString); Tcl_DStringFree(&dstString); return result; @@ -236,14 +247,11 @@ static int DoRenameFile( CONST TCHAR *nativeSrc, /* Pathname of file or dir to be renamed * (native). */ - Tcl_DString *dstPtr) /* New pathname for file or directory + CONST TCHAR *nativeDst) /* New pathname for file or directory * (native). */ { - const TCHAR *nativeDst; DWORD srcAttr, dstAttr; - nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr); - /* * Would throw an exception under NT if one of the arguments is a * char block device. @@ -367,7 +375,7 @@ DoRenameFile( * fails, it's because it wasn't empty. */ - if (DoRemoveDirectory(dstPtr, 0, NULL) == TCL_OK) { + if (DoRemoveJustDirectory(nativeDst, 0, NULL) == TCL_OK) { /* * Now that that empty directory is gone, we can try * renaming again. If that fails, we'll put this empty @@ -507,7 +515,8 @@ TclpCopyFile( Tcl_WinUtfToTChar(src, -1, &srcString); Tcl_WinUtfToTChar(dst, -1, &dstString); - result = DoCopyFile(&srcString, &dstString); + result = DoCopyFile(Tcl_DStringValue(&srcString), + Tcl_DStringValue(&dstString)); Tcl_DStringFree(&srcString); Tcl_DStringFree(&dstString); return result; @@ -515,14 +524,9 @@ TclpCopyFile( static int DoCopyFile( - Tcl_DString *srcPtr, /* Pathname of file to be copied (native). */ - Tcl_DString *dstPtr) /* Pathname of file to copy to (native). */ + CONST TCHAR *nativeSrc, /* Pathname of file to be copied (native). */ + CONST TCHAR *nativeDst) /* Pathname of file to copy to (native). */ { - CONST TCHAR *nativeSrc, *nativeDst; - - nativeSrc = (TCHAR *) Tcl_DStringValue(srcPtr); - nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr); - /* * Would throw an exception under NT if one of the arguments is a char * block device. @@ -604,19 +608,16 @@ TclpDeleteFile( Tcl_DString pathString; Tcl_WinUtfToTChar(path, -1, &pathString); - result = DoDeleteFile(&pathString); + result = DoDeleteFile(Tcl_DStringValue(&pathString)); Tcl_DStringFree(&pathString); return result; } static int DoDeleteFile( - Tcl_DString *pathPtr) /* Pathname of file to be removed (native). */ + CONST TCHAR *nativePath) /* Pathname of file to be removed (native). */ { DWORD attr; - CONST TCHAR *nativePath; - - nativePath = (TCHAR *) Tcl_DStringValue(pathPtr); if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) { return TCL_OK; @@ -716,19 +717,16 @@ TclpCreateDirectory( Tcl_DString pathString; Tcl_WinUtfToTChar(path, -1, &pathString); - result = DoCreateDirectory(&pathString); + result = DoCreateDirectory(Tcl_DStringValue(&pathString)); Tcl_DStringFree(&pathString); return result; } static int DoCreateDirectory( - Tcl_DString *pathPtr) /* Pathname of directory to create (native). */ + CONST TCHAR *nativePath) /* Pathname of directory to create (native). */ { DWORD error; - CONST TCHAR *nativePath; - - nativePath = (TCHAR *) Tcl_DStringValue(pathPtr); if ((*tclWinProcs->createDirectoryProc)(nativePath, NULL) == 0) { error = GetLastError(); TclWinConvertError(error); @@ -836,21 +834,18 @@ TclpRemoveDirectory( } static int -DoRemoveDirectory( - Tcl_DString *pathPtr, /* Pathname of directory to be removed +DoRemoveJustDirectory( + CONST TCHAR *nativePath, /* Pathname of directory to be removed * (native). */ - int recursive, /* If non-zero, removes directories that - * are nonempty. Otherwise, will only remove - * empty directories. */ + int recursive, /* If non-zero, don't initialize the + * errorPtr under some circumstances + * on return. */ Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free * DString filled with UTF-8 name of file * causing error. */ { - CONST TCHAR *nativePath; DWORD attr; - nativePath = (TCHAR *) Tcl_DStringValue(pathPtr); - if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) { return TCL_OK; } @@ -952,19 +947,44 @@ DoRemoveDirectory( Tcl_SetErrno(EEXIST); } if ((recursive != 0) && (Tcl_GetErrno() == EEXIST)) { - /* - * The directory is nonempty, but the recursive flag has been - * specified, so we recursively remove all the files in the directory. + /* + * If we're being recursive, this error may actually + * be ok, so we don't want to initialise the errorPtr + * yet. */ - - return TraverseWinTree(TraversalDelete, pathPtr, NULL, errorPtr); + return TCL_ERROR; } - + end: if (errorPtr != NULL) { Tcl_WinTCharToUtf(nativePath, -1, errorPtr); } return TCL_ERROR; + +} + +static int +DoRemoveDirectory( + Tcl_DString *pathPtr, /* Pathname of directory to be removed + * (native). */ + int recursive, /* If non-zero, removes directories that + * are nonempty. Otherwise, will only remove + * empty directories. */ + Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free + * DString filled with UTF-8 name of file + * causing error. */ +{ + int res = DoRemoveJustDirectory(Tcl_DStringValue(pathPtr), recursive, errorPtr); + + if ((res == TCL_ERROR) && (recursive != 0) && (Tcl_GetErrno() == EEXIST)) { + /* + * The directory is nonempty, but the recursive flag has been + * specified, so we recursively remove all the files in the directory. + */ + return TraverseWinTree(TraversalDelete, pathPtr, NULL, errorPtr); + } else { + return res; + } } /* @@ -996,13 +1016,14 @@ TraverseWinTree( Tcl_DString *sourcePtr, /* Pathname of source directory to be * traversed (native). */ Tcl_DString *targetPtr, /* Pathname of directory to traverse in - * parallel with source directory (native). */ + * parallel with source directory (native), + * may be NULL. */ Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free * DString filled with UTF-8 name of file * causing error. */ { DWORD sourceAttr; - TCHAR *nativeSource, *nativeErrfile; + TCHAR *nativeSource, *nativeTarget, *nativeErrfile; int result, found, sourceLen, targetLen, oldSourceLen, oldTargetLen; HANDLE handle; WIN32_FIND_DATAT data; @@ -1012,6 +1033,8 @@ TraverseWinTree( oldTargetLen = 0; /* lint. */ nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr); + nativeTarget = (TCHAR *) (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)); + oldSourceLen = Tcl_DStringLength(sourcePtr); sourceAttr = (*tclWinProcs->getFileAttributesProc)(nativeSource); if (sourceAttr == 0xffffffff) { @@ -1023,7 +1046,7 @@ TraverseWinTree( * Process the regular file */ - return (*traverseProc)(sourcePtr, targetPtr, DOTREE_F, errorPtr); + return (*traverseProc)(nativeSource, nativeTarget, DOTREE_F, errorPtr); } if (tclWinProcs->useWide) { @@ -1046,7 +1069,7 @@ TraverseWinTree( nativeSource[oldSourceLen + 1] = '\0'; Tcl_DStringSetLength(sourcePtr, oldSourceLen); - result = (*traverseProc)(sourcePtr, targetPtr, DOTREE_PRED, errorPtr); + result = (*traverseProc)(nativeSource, nativeTarget, DOTREE_PRED, errorPtr); if (result != TCL_OK) { FindClose(handle); return result; @@ -1148,8 +1171,9 @@ TraverseWinTree( * files in that directory. */ - result = (*traverseProc)(sourcePtr, targetPtr, DOTREE_POSTD, - errorPtr); + result = (*traverseProc)(Tcl_DStringValue(sourcePtr), + (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)), + DOTREE_POSTD, errorPtr); } end: if (nativeErrfile != NULL) { @@ -1182,26 +1206,23 @@ TraverseWinTree( static int TraversalCopy( - Tcl_DString *srcPtr, /* Source pathname to copy. */ - Tcl_DString *dstPtr, /* Destination pathname of copy. */ + CONST TCHAR *nativeSrc, /* Source pathname to copy. */ + CONST TCHAR *nativeDst, /* Destination pathname of copy. */ int type, /* Reason for call - see TraverseWinTree() */ Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled * with UTF-8 name of file causing error. */ { - TCHAR *nativeDst, *nativeSrc; DWORD attr; switch (type) { case DOTREE_F: { - if (DoCopyFile(srcPtr, dstPtr) == TCL_OK) { + if (DoCopyFile(nativeSrc, nativeDst) == TCL_OK) { return TCL_OK; } break; } case DOTREE_PRED: { - if (DoCreateDirectory(dstPtr) == TCL_OK) { - nativeSrc = (TCHAR *) Tcl_DStringValue(srcPtr); - nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr); + if (DoCreateDirectory(nativeDst) == TCL_OK) { attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc); if ((*tclWinProcs->setFileAttributesProc)(nativeDst, attr) != FALSE) { return TCL_OK; @@ -1221,7 +1242,6 @@ TraversalCopy( */ if (errorPtr != NULL) { - nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr); Tcl_WinTCharToUtf(nativeDst, -1, errorPtr); } return TCL_ERROR; @@ -1250,17 +1270,15 @@ TraversalCopy( static int TraversalDelete( - Tcl_DString *srcPtr, /* Source pathname to delete. */ - Tcl_DString *dstPtr, /* Not used. */ + CONST TCHAR *nativeSrc, /* Source pathname to delete. */ + CONST TCHAR *dstPtr, /* Not used. */ int type, /* Reason for call - see TraverseWinTree() */ Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled * with UTF-8 name of file causing error. */ { - TCHAR *nativeSrc; - switch (type) { case DOTREE_F: { - if (DoDeleteFile(srcPtr) == TCL_OK) { + if (DoDeleteFile(nativeSrc) == TCL_OK) { return TCL_OK; } break; @@ -1269,7 +1287,7 @@ TraversalDelete( return TCL_OK; } case DOTREE_POSTD: { - if (DoRemoveDirectory(srcPtr, 0, NULL) == TCL_OK) { + if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) { return TCL_OK; } break; @@ -1277,7 +1295,6 @@ TraversalDelete( } if (errorPtr != NULL) { - nativeSrc = (TCHAR *) Tcl_DStringValue(srcPtr); Tcl_WinTCharToUtf(nativeSrc, -1, errorPtr); } return TCL_ERROR; @@ -1303,13 +1320,14 @@ TraversalDelete( static void StatError( Tcl_Interp *interp, /* The interp that has the error */ - CONST char *fileName) /* The name of the file which caused the + Tcl_Obj *fileName) /* The name of the file which caused the * error. */ { TclWinConvertError(GetLastError()); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "could not read \"", fileName, "\": ", Tcl_PosixError(interp), - (char *) NULL); + "could not read \"", Tcl_GetString(fileName), + "\": ", Tcl_PosixError(interp), + (char *) NULL); } /* @@ -1335,16 +1353,14 @@ static int GetWinFileAttributes( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ - CONST char *fileName, /* The name of the file. */ + Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ { DWORD result; - Tcl_DString ds; TCHAR *nativeName; - nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds); + nativeName = Tcl_FSGetNativePath(fileName); result = (*tclWinProcs->getFileAttributesProc)(nativeName); - Tcl_DStringFree(&ds); if (result == 0xffffffff) { StatError(interp, fileName); @@ -1356,106 +1372,6 @@ GetWinFileAttributes( } /* - *--------------------------------------------------------------------------- - * - * TclpNormalizePath -- - * - * This function scans through a path specification and replaces - * it, in place, with a normalized version. On windows this - * means using the 'longname'. - * - * 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 - * possibly modified in place. - * - *--------------------------------------------------------------------------- - */ - -int -TclpNormalizePath(interp, pathPtr, nextCheckpoint) - Tcl_Interp *interp; - Tcl_DString *pathPtr; - int nextCheckpoint; -{ - char *currentPathEndPosition; - char *lastValidPathEnd = NULL; - char *path = Tcl_DStringValue(pathPtr); - - currentPathEndPosition = path + nextCheckpoint; - - while (1) { - char cur = *currentPathEndPosition; - if (cur == '/' || cur == 0) { - /* Reached directory separator, or end of string */ - Tcl_DString ds; - DWORD attr; - char * nativePath; - nativePath = Tcl_WinUtfToTChar(path, currentPathEndPosition - path, &ds); - attr = (*tclWinProcs->getFileAttributesProc)(nativePath); - Tcl_DStringFree(&ds); - - if (attr == 0xffffffff) { - /* File doesn't exist */ - break; - } - lastValidPathEnd = currentPathEndPosition; - /* File does exist */ - if (cur == 0) { - break; - } - } - currentPathEndPosition++; - } - nextCheckpoint = currentPathEndPosition - path; - if (lastValidPathEnd != NULL) { - /* - * The leading end of the path description was acceptable to - * us. We therefore convert it to its long form, and return - * that. - */ - Tcl_Obj* objPtr = NULL; - int endOfString; - int useLength = lastValidPathEnd - path; - if (*lastValidPathEnd == 0) { - endOfString = 1; - } else { - endOfString = 0; - path[useLength] = 0; - } - /* - * If this returns an error, we have a strange situation; the - * file exists, but we can't get its long name. We will have - * to assume the name we have is ok. - */ - if (ConvertFileNameFormat(interp, 0, path, 1, &objPtr) == TCL_OK) { - /* objPtr now has a refCount of 0 */ - int len; - (void) Tcl_GetStringFromObj(objPtr,&len); - if (!endOfString) { - /* Be nice and fix the string before we clear it */ - path[useLength] = '/'; - Tcl_AppendToObj(objPtr, lastValidPathEnd, -1); - } - nextCheckpoint += (len - useLength); - Tcl_DStringSetLength(pathPtr,0); - path = Tcl_GetStringFromObj(objPtr,&len); - Tcl_DStringAppend(pathPtr,path,len); - /* Free up the objPtr */ - Tcl_DecrRefCount(objPtr); - } else { - if (!endOfString) { - path[useLength] = '/'; - } - } - } - return nextCheckpoint; -} - -/* *---------------------------------------------------------------------- * * ConvertFileNameFormat -- @@ -1467,6 +1383,11 @@ TclpNormalizePath(interp, pathPtr, nextCheckpoint) * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object * will have ref count 0. If the return value is not TCL_OK, * attributePtrPtr is not touched. + * + * Warning: if you pass this function a drive name like 'c:' it + * will actually return the current working directory on that + * drive. To avoid this, make sure the drive name ends in a + * slash, like this 'c:/'. * * Side effects: * A new object is allocated if the file is valid. @@ -1478,22 +1399,19 @@ static int ConvertFileNameFormat( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ - CONST char *fileName, /* The name of the file. */ + Tcl_Obj *fileName, /* The name of the file. */ int longShort, /* 0 to short name, 1 to long name. */ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ { int pathc, i; - char **pathv, **newv; - char *resultStr; - Tcl_DString resultDString; + Tcl_Obj *splitPath; int result = TCL_OK; - Tcl_SplitPath(fileName, &pathc, &pathv); - newv = (char **) ckalloc(pathc * sizeof(char *)); + splitPath = Tcl_FSSplitPath(fileName, &pathc); - if (pathc == 0) { + if (splitPath == NULL || pathc == 0) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "could not read \"", fileName, + "could not read \"", Tcl_GetString(fileName), "\": no such file or directory", (char *) NULL); result = TCL_ERROR; @@ -1501,10 +1419,16 @@ ConvertFileNameFormat( } for (i = 0; i < pathc; i++) { - if ((pathv[i][0] == '/') - || ((strlen(pathv[i]) == 3) && (pathv[i][1] == ':')) - || (strcmp(pathv[i], ".") == 0) - || (strcmp(pathv[i], "..") == 0)) { + Tcl_Obj *elt; + char *pathv; + int pathLen; + Tcl_ListObjIndex(NULL, splitPath, i, &elt); + + pathv = Tcl_GetStringFromObj(elt, &pathLen); + if ((pathv[0] == '/') + || ((pathLen == 3) && (pathv[1] == ':')) + || (strcmp(pathv, ".") == 0) + || (strcmp(pathv, "..") == 0)) { /* * Handle "/", "//machine/export", "c:/", "." or ".." by just * copying the string literally. Uppercase the drive letter, @@ -1512,20 +1436,32 @@ ConvertFileNameFormat( */ simple: - pathv[i][0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[i][0])); - newv[i] = (char *) ckalloc(strlen(pathv[i]) + 1); - lstrcpyA(newv[i], pathv[i]); + /* Here we are modifying the string representation in place */ + /* I believe this is legal, since this won't affect any + * file representation this thing may have. */ + pathv[0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[0])); } else { - char *str; - TCHAR *nativeName; + Tcl_Obj *tempPath; Tcl_DString ds; + Tcl_DString dsTemp; + TCHAR *nativeName; + char *tempString; + int tempLen; WIN32_FIND_DATAT data; HANDLE handle; DWORD attr; - Tcl_DStringInit(&resultDString); - str = Tcl_JoinPath(i + 1, pathv, &resultDString); - nativeName = Tcl_WinUtfToTChar(str, -1, &ds); + tempPath = Tcl_FSJoinPath(splitPath, i+1); + Tcl_IncrRefCount(tempPath); + /* + * We'd like to call Tcl_FSGetNativePath(tempPath) + * but that is likely to lead to infinite loops + */ + Tcl_DStringInit(&ds); + tempString = Tcl_GetStringFromObj(tempPath,&tempLen); + Tcl_WinUtfToTChar(tempString, tempLen, &ds); + Tcl_DecrRefCount(tempPath); + nativeName = Tcl_DStringValue(&ds); handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data); if (handle == INVALID_HANDLE_VALUE) { /* @@ -1538,16 +1474,12 @@ ConvertFileNameFormat( attr = (*tclWinProcs->getFileAttributesProc)(nativeName); if ((attr != 0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) { Tcl_DStringFree(&ds); - Tcl_DStringFree(&resultDString); - goto simple; } } - Tcl_DStringFree(&ds); - Tcl_DStringFree(&resultDString); if (handle == INVALID_HANDLE_VALUE) { - pathc = i - 1; + Tcl_DStringFree(&ds); StatError(interp, fileName); result = TCL_ERROR; goto cleanup; @@ -1588,26 +1520,24 @@ ConvertFileNameFormat( * fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]); */ - Tcl_WinTCharToUtf(nativeName, -1, &ds); - newv[i] = ckalloc((unsigned int) (Tcl_DStringLength(&ds) + 1)); - lstrcpyA(newv[i], Tcl_DStringValue(&ds)); + Tcl_DStringInit(&dsTemp); + Tcl_WinTCharToUtf(nativeName, -1, &dsTemp); + tempPath = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp), + Tcl_DStringLength(&dsTemp)); + Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath); Tcl_DStringFree(&ds); + Tcl_DStringFree(&dsTemp); FindClose(handle); } } - Tcl_DStringInit(&resultDString); - resultStr = Tcl_JoinPath(pathc, newv, &resultDString); - *attributePtrPtr = Tcl_NewStringObj(resultStr, - Tcl_DStringLength(&resultDString)); - Tcl_DStringFree(&resultDString); + *attributePtrPtr = Tcl_FSJoinPath(splitPath, -1); cleanup: - for (i = 0; i < pathc; i++) { - ckfree(newv[i]); + if (splitPath != NULL) { + Tcl_DecrRefCount(splitPath); } - ckfree((char *) newv); - ckfree((char *) pathv); + return result; } @@ -1634,7 +1564,7 @@ static int GetWinFileLongName( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ - CONST char *fileName, /* The name of the file. */ + Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ { return ConvertFileNameFormat(interp, objIndex, fileName, 1, attributePtrPtr); @@ -1663,7 +1593,7 @@ static int GetWinFileShortName( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ - CONST char *fileName, /* The name of the file. */ + Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ { return ConvertFileNameFormat(interp, objIndex, fileName, 0, attributePtrPtr); @@ -1690,27 +1620,25 @@ static int SetWinFileAttributes( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ - CONST char *fileName, /* The name of the file. */ + Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj *attributePtr) /* The new value of the attribute. */ { DWORD fileAttributes; int yesNo; int result; - Tcl_DString ds; TCHAR *nativeName; - nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds); + nativeName = Tcl_FSGetNativePath(fileName); fileAttributes = (*tclWinProcs->getFileAttributesProc)(nativeName); if (fileAttributes == 0xffffffff) { StatError(interp, fileName); - result = TCL_ERROR; - goto end; + return TCL_ERROR; } result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo); if (result != TCL_OK) { - goto end; + return result; } if (yesNo) { @@ -1721,13 +1649,9 @@ SetWinFileAttributes( if (!(*tclWinProcs->setFileAttributesProc)(nativeName, fileAttributes)) { StatError(interp, fileName); - result = TCL_ERROR; - goto end; + return TCL_ERROR; } - end: - Tcl_DStringFree(&ds); - return result; } @@ -1743,7 +1667,7 @@ SetWinFileAttributes( * TCL_ERROR * * Side effects: - * The object result is set to a pertinant error message. + * The object result is set to a pertinent error message. * *---------------------------------------------------------------------- */ @@ -1752,12 +1676,13 @@ static int CannotSetAttribute( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ - CONST char *fileName, /* The name of the file. */ + Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj *attributePtr) /* The new value of the attribute. */ { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot set attribute \"", tclpFileAttrStrings[objIndex], - "\" for file \"", fileName, "\": attribute is readonly", + "\" for file \"", Tcl_GetString(fileName), + "\": attribute is readonly", (char *) NULL); return TCL_ERROR; } @@ -1766,14 +1691,12 @@ CannotSetAttribute( /* *--------------------------------------------------------------------------- * - * TclpListVolumes -- + * TclpObjListVolumes -- * * Lists the currently mounted volumes * * Results: - * A standard Tcl result. Will always be TCL_OK, since there is no way - * that this command can fail. Also, the interpreter's result is set to - * the list of volumes. + * The list of volumes. * * Side effects: * None @@ -1781,16 +1704,15 @@ CannotSetAttribute( *--------------------------------------------------------------------------- */ -int -TclpListVolumes( - Tcl_Interp *interp) /* Interpreter for returning volume list. */ +Tcl_Obj* +TclpObjListVolumes(void) { Tcl_Obj *resultPtr, *elemPtr; char buf[40 * 4]; /* There couldn't be more than 30 drives??? */ int i; char *p; - resultPtr = Tcl_GetObjResult(interp); + resultPtr = Tcl_NewObj(); /* * On Win32s: @@ -1827,7 +1749,9 @@ TclpListVolumes( Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr); } } - return TCL_OK; + + Tcl_IncrRefCount(resultPtr); + return resultPtr; } /* @@ -1869,7 +1793,8 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint) Tcl_DString ds; DWORD attr; char * nativePath; - nativePath = Tcl_WinUtfToTChar(path, currentPathEndPosition - path, &ds); + nativePath = Tcl_WinUtfToTChar(path, currentPathEndPosition - path, + &ds); attr = (*tclWinProcs->getFileAttributesProc)(nativePath); Tcl_DStringFree(&ds); @@ -1887,6 +1812,7 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint) } nextCheckpoint = currentPathEndPosition - path; if (lastValidPathEnd != NULL) { + Tcl_Obj *tmpPathPtr; /* * The leading end of the path description was acceptable to * us. We therefore convert it to its long form, and return @@ -1896,33 +1822,31 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint) int endOfString; int useLength = lastValidPathEnd - path; if (*lastValidPathEnd == 0) { + tmpPathPtr = Tcl_NewStringObj(path, useLength); endOfString = 1; } else { + tmpPathPtr = Tcl_NewStringObj(path, useLength + 1); endOfString = 0; - path[useLength] = 0; } /* * If this returns an error, we have a strange situation; the * file exists, but we can't get its long name. We will have * to assume the name we have is ok. */ - if (ConvertFileNameFormat(interp, 0, path, 1, &objPtr) == TCL_OK) { + Tcl_IncrRefCount(tmpPathPtr); + if (ConvertFileNameFormat(interp, 0, tmpPathPtr, 1, &objPtr) == TCL_OK) { int len; (void) Tcl_GetStringFromObj(objPtr,&len); if (!endOfString) { /* Be nice and fix the string before we clear it */ - path[useLength] = '/'; Tcl_AppendToObj(objPtr, lastValidPathEnd, -1); } nextCheckpoint += (len - useLength); path = Tcl_GetStringFromObj(objPtr,&len); Tcl_SetStringObj(pathPtr,path, len); Tcl_DecrRefCount(objPtr); - } else { - if (!endOfString) { - path[useLength] = '/'; - } } + Tcl_DecrRefCount(tmpPathPtr); } return nextCheckpoint; } diff --git a/win/tclWinFile.c b/win/tclWinFile.c index c40a0b8..d74fb78 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.11 2001/07/31 19:12:08 vincentdarley Exp $ + * RCS: @(#) $Id: tclWinFile.c,v 1.12 2001/08/23 17:37:08 vincentdarley Exp $ */ #include "tclWinInt.h" @@ -126,7 +126,7 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) BOOL found; Tcl_DString ds; Tcl_DString dsOrig; - char *fileName; + Tcl_Obj *fileNamePtr; TCHAR *nativeName; int matchSpecialDots; @@ -136,12 +136,12 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) * separator character. */ - fileName = Tcl_FSGetTranslatedPath(interp, pathPtr); - if (fileName == NULL) { + fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr); + if (fileNamePtr == NULL) { return TCL_ERROR; } Tcl_DStringInit(&dsOrig); - Tcl_DStringAppend(&dsOrig, fileName, -1); + Tcl_DStringAppend(&dsOrig, Tcl_GetString(fileNamePtr), -1); dirLength = Tcl_DStringLength(&dsOrig); Tcl_DStringInit(&dirString); @@ -333,6 +333,8 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) typeOk = 0; } } else { + struct stat buf; + if (attr & FILE_ATTRIBUTE_HIDDEN) { /* If invisible */ if ((types->perm == 0) || @@ -360,12 +362,14 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) } } if (typeOk && types->type != 0) { - struct stat buf; - /* - * We must match at least one flag to be listed - */ - typeOk = 0; - if (TclpLstat(fname, &buf) >= 0) { + if (types->perm == 0) { + /* We haven't yet done a stat on the file */ + if (TclpStat(fname, &buf) != 0) { + /* Posix error occurred */ + typeOk = 0; + } + } + if (typeOk) { /* * In order bcdpfls as in 'find -t' */ @@ -380,19 +384,24 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) S_ISFIFO(buf.st_mode)) || ((types->type & TCL_GLOB_TYPE_FILE) && S_ISREG(buf.st_mode)) -#ifdef S_ISLNK - || ((types->type & TCL_GLOB_TYPE_LINK) && - S_ISLNK(buf.st_mode)) -#endif #ifdef S_ISSOCK || ((types->type & TCL_GLOB_TYPE_SOCK) && S_ISSOCK(buf.st_mode)) #endif ) { - typeOk = 1; + /* Do nothing -- this file is ok */ + } else { + typeOk = 0; +#ifdef S_ISLNK + if (types->type & TCL_GLOB_TYPE_LINK) { + if (TclpLstat(fname, &buf) == 0) { + if (S_ISLNK(buf.st_mode)) { + typeOk = 1; + } + } + } +#endif } - } else { - /* Posix error occurred */ } } } @@ -824,13 +833,15 @@ TclpObjStat(pathPtr, statPtr) TCHAR *nativePart; char *p, *fullPath; int dev, mode; - + Tcl_Obj *transPtr; + /* * Eliminate file names containing wildcard characters, or subsequent * call to FindFirstFile() will expand them, matching some other file. */ - if (strpbrk(Tcl_FSGetTranslatedPath(NULL, pathPtr), "?*") != NULL) { + transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); + if (transPtr == NULL || (strpbrk(Tcl_GetString(transPtr), "?*") != NULL)) { Tcl_SetErrno(ENOENT); return -1; } @@ -907,7 +918,7 @@ TclpObjStat(pathPtr, statPtr) attr = data.a.dwFileAttributes; mode = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG; mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD | S_IWRITE; - p = strrchr(Tcl_FSGetTranslatedPath(NULL, pathPtr), '.'); + p = strrchr(Tcl_GetString(transPtr), '.'); if (p != NULL) { if ((lstrcmpiA(p, ".exe") == 0) || (lstrcmpiA(p, ".com") == 0) @@ -1140,7 +1151,7 @@ TclpObjAccess(pathPtr, mode) return 0; } - p = strrchr(Tcl_FSGetTranslatedPath(NULL, pathPtr), '.'); + p = strrchr(Tcl_FSGetTranslatedStringPath(NULL, pathPtr), '.'); if (p != NULL) { p++; if ((stricmp(p, "exe") == 0) @@ -1170,15 +1181,21 @@ TclpObjLstat(pathPtr, buf) #ifdef S_IFLNK Tcl_Obj* -TclpObjReadlink(pathPtr) +TclpObjLink(pathPtr, toPtr) Tcl_Obj *pathPtr; + Tcl_Obj *toPtr; { - Tcl_DString ds; Tcl_Obj* link = NULL; - if (TclpReadlink(Tcl_FSGetTranslatedPath(NULL, pathPtr), &ds) != NULL) { - link = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); - Tcl_IncrRefCount(link); - Tcl_DStringFree(&ds); + + if (toPtr != NULL) { + return NULL; + } else { + Tcl_DString ds; + if (TclpReadlink(Tcl_FSGetTranslatedStringPath(NULL, pathPtr), &ds) != NULL) { + link = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + Tcl_IncrRefCount(link); + Tcl_DStringFree(&ds); + } } return link; } -- cgit v0.12