From fc8ca7b64060c121189509c2a390627088bf2f85 Mon Sep 17 00:00:00 2001 From: vincentdarley Date: Mon, 14 Apr 2003 15:45:44 +0000 Subject: filesystem fixes backported --- ChangeLog | 30 + generic/tclIOUtil.c | 4909 ++++++++++++++++++++++++++------------------------- tests/cmdAH.test | 13 +- tests/fCmd.test | 7 +- tests/ioUtil.test | 6 +- tests/unixFCmd.test | 20 +- tests/winFile.test | 6 +- win/tclWin32Dll.c | 193 +- win/tclWinFile.c | 241 ++- win/tclWinInt.h | 9 +- 10 files changed, 2935 insertions(+), 2499 deletions(-) diff --git a/ChangeLog b/ChangeLog index ad982e8..9556707 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,33 @@ +2003-04-14 Vince Darley + + Merged various bug fixes from current cvs head: + + * tests/cmdAH.test: better fix to test suite problem + if /home is a symlink [Bug #703264] + + * generic/tclIOUtil.c: fix bad error message with 'cd ""' + [Bug #704917] + * win/tclWinFile.c: + * win/tclWin32Dll.c: + * win/tclWinInt.h: allow Tcl to differentiate between reparse + points which are symlinks and mounted volumes, and correctly + handle the latter. This involves some elaborate code to find + the actual drive letter (if possible) corresponding to a mounted + volume. [Bug #697862] + * tests/fileSystem.test: add constraints to stop tests running + in ordinary tcl interpreter. [Bug #705675] + * generic/tclIOUtil.c: Some re-arrangement of code to bring it + closer to cvs head. No functional changes. + + * tests/fCmd.test: + * win/tclWinFile.c: added some filesystem optimisation to the + 'glob' implementation, and some new tests. + + * tests/winFile.test: + * tests/ioUtil.test: + * tests/unixFCmd.test: renumbered tests with duplicate numbers. + (Bug #710361) + 2003-04-12 Kevin Kenny * tests/clock.test: Renumbered test cases to avoid diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 924689a..6464a5b 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.77.2.1 2003/03/18 10:51:31 vincentdarley Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.77.2.2 2003/04/14 15:45:49 vincentdarley Exp $ */ #include "tclInt.h" @@ -30,44 +30,77 @@ #include "tclWinInt.h" #endif -/* - * Prototypes for procedures defined later in this file. +/* + * struct FilesystemRecord -- + * + * A filesystem record is used to keep track of each + * filesystem currently registered with the core, + * in a linked list. Pointers to these structures + * are also kept by each "path" Tcl_Obj, and we must + * retain a refCount on the number of such references. */ +typedef struct FilesystemRecord { + ClientData clientData; /* Client specific data for the new + * filesystem (can be NULL) */ + Tcl_Filesystem *fsPtr; /* Pointer to filesystem dispatch + * table. */ + int fileRefCount; /* How many Tcl_Obj's use this + * filesystem. */ + struct FilesystemRecord *nextPtr; + /* The next filesystem registered + * to Tcl, or NULL if no more. */ +} FilesystemRecord; -static void DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr)); -static void FreeFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *listPtr)); -static void UpdateStringOfFsPath _ANSI_ARGS_((Tcl_Obj *objPtr)); -static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); -static Tcl_Obj* MakeFsPathFromRelative _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr, Tcl_Obj *cwdPtr)); -static Tcl_Obj* FSNormalizeAbsolutePath - _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr)); -static int TclNormalizeToUniquePath - _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr, - int startAt)); -static int SetFsPathFromAbsoluteNormalized - _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); -static int FindSplitPos _ANSI_ARGS_((char *path, char *separator)); -static Tcl_PathType FSGetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr, +/* + * The internal TclFS API provides routines for handling and + * manipulating paths efficiently, taking direct advantage of + * the "path" Tcl_Obj type. + * + * These functions are not exported at all at present. + */ + +int TclFSCwdPointerEquals _ANSI_ARGS_((Tcl_Obj* objPtr)); +int TclFSMakePathFromNormalized _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, ClientData clientData)); +int TclFSNormalizeToUniquePath _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *pathPtr, int startAt, ClientData *clientDataPtr)); +Tcl_Obj* TclFSMakePathRelative _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, Tcl_Obj *cwdPtr)); +Tcl_Obj* TclFSInternalToNormalized _ANSI_ARGS_(( + Tcl_Filesystem *fromFilesystem, ClientData clientData, + FilesystemRecord **fsRecPtrPtr, int *epochPtr)); +int TclFSEnsureEpochOk _ANSI_ARGS_((Tcl_Obj* pathObjPtr, int theEpoch, + Tcl_Filesystem **fsPtrPtr)); +void TclFSSetPathDetails _ANSI_ARGS_((Tcl_Obj *pathObjPtr, + FilesystemRecord *fsRecPtr, ClientData clientData, + int theEpoch)); + +/* + * Private variables for use in this file + */ +extern Tcl_Filesystem tclNativeFilesystem; +extern int theFilesystemEpoch; + +/* + * Private functions for use in this file + */ +Tcl_PathType FSGetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr, Tcl_Filesystem **filesystemPtrPtr, int *driveNameLengthPtr)); -static Tcl_PathType GetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr, +Tcl_PathType GetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr, Tcl_Filesystem **filesystemPtrPtr, int *driveNameLengthPtr, Tcl_Obj **driveNameRef)); - +Tcl_FSPathInFilesystemProc NativePathInFilesystem; +static Tcl_Obj* TclFSNormalizeAbsolutePath + _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr, + ClientData *clientDataPtr)); /* - * Define the 'path' object type, which Tcl uses to represent - * file paths internally. + * Prototypes for procedures defined later in this file. */ -Tcl_ObjType tclFsPathType = { - "path", /* name */ - FreeFsPathInternalRep, /* freeIntRepProc */ - DupFsPathInternalRep, /* dupIntRepProc */ - UpdateStringOfFsPath, /* updateStringProc */ - SetFsPathFromAny /* setFromAnyProc */ -}; + +static FilesystemRecord* FsGetIterator(void); +static void FsReleaseIterator(void); + /* * These form part of the native filesystem support. They are needed @@ -306,26 +339,6 @@ TCL_DECLARE_MUTEX(obsoleteFsHookMutex) #endif /* USE_OBSOLETE_FS_HOOKS */ /* - * A filesystem record is used to keep track of each - * filesystem currently registered with the core, - * in a linked list. - */ -typedef struct FilesystemRecord { - ClientData clientData; /* Client specific data for the new - * filesystem (can be NULL) */ - Tcl_Filesystem *fsPtr; /* Pointer to filesystem dispatch - * table. */ - int fileRefCount; /* How many Tcl_Obj's use this - * filesystem. */ - struct FilesystemRecord *nextPtr; - /* The next filesystem registered - * to Tcl, or NULL if no more. */ -} FilesystemRecord; - -static FilesystemRecord* GetFilesystemRecord - _ANSI_ARGS_((Tcl_Filesystem *fromFilesystem, int *epoch)); - -/* * Declare the native filesystem support. These functions should * be considered private to Tcl, and should really not be called * directly by any code other than this file (i.e. neither by @@ -338,10 +351,9 @@ static FilesystemRecord* GetFilesystemRecord * We cannot make all of these static, since some of them * are implemented in the platform-specific directories. */ -static Tcl_FSPathInFilesystemProc NativePathInFilesystem; static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator; static Tcl_FSFreeInternalRepProc NativeFreeInternalRep; -static Tcl_FSDupInternalRepProc NativeDupInternalRep; +Tcl_FSDupInternalRepProc NativeDupInternalRep; static Tcl_FSCreateInternalRepProc NativeCreateNativeRep; static Tcl_FSFileAttrStringsProc NativeFileAttrStrings; static Tcl_FSFileAttrsGetProc NativeFileAttrsGet; @@ -383,7 +395,7 @@ Tcl_FSListVolumesProc TclpObjListVolumes; * 'native filesystem implementation' should not be delving inside * here! */ -static Tcl_Filesystem tclNativeFilesystem = { +Tcl_Filesystem tclNativeFilesystem = { "native", sizeof(Tcl_Filesystem), TCL_FILESYSTEM_VERSION_1, @@ -447,7 +459,7 @@ static FilesystemRecord nativeFilesystemRecord = { * filesystems. Any time it changes, all cached filesystem * representations are suspect and must be freed. */ -static int theFilesystemEpoch = 0; +int theFilesystemEpoch = 0; /* * Stores the linked list of filesystems. @@ -472,49 +484,6 @@ static Tcl_Condition filesystemOkToModify = NULL; TCL_DECLARE_MUTEX(filesystemMutex) /* - * struct FsPath -- - * - * Internal representation of a Tcl_Obj of "path" type. This - * can be used to represent relative or absolute paths, and has - * certain optimisations when used to represent paths which are - * already normalized and absolute. - * - * Note that 'normPathPtr' can be a circular reference to the - * container Tcl_Obj of this FsPath. - */ -typedef struct FsPath { - 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 - * string rep is already both translated - * and normalized. */ - Tcl_Obj *normPathPtr; /* Normalized absolute path, without - * ., .. or ~user sequences. If the - * Tcl_Obj containing - * this FsPath is already normalized, - * this may be a circular reference back - * to the container. If that is NOT the - * case, we have a refCount on the object. */ - Tcl_Obj *cwdPtr; /* If null, path is absolute, else - * this points to the cwd object used - * for this path. We have a refCount - * on the object. */ - int flags; /* Flags to describe interpretation */ - ClientData nativePathPtr; /* Native representation of this path, - * which is filesystem dependent. */ - int filesystemEpoch; /* Used to ensure the path representation - * was generated during the correct - * filesystem epoch. The epoch changes - * when filesystem-mounts are changed. */ - struct FilesystemRecord *fsRecPtr; - /* Pointer to the filesystem record - * entry to use for this path. */ -} FsPath; - -#define TCLPATH_APPENDED 1 -#define TCLPATH_RELATIVE 2 -/* * Used to implement Tcl_FSGetCwd in a file-system independent way. * This is protected by the cwdMutex below. */ @@ -546,8 +515,8 @@ typedef struct FsDivertLoad { /* Now move on to the basic filesystem implementation */ -static int -FsCwdPointerEquals(objPtr) +int +TclFSCwdPointerEquals(objPtr) Tcl_Obj* objPtr; { Tcl_MutexLock(&cwdMutex); @@ -559,7 +528,7 @@ FsCwdPointerEquals(objPtr) return 0; } } - + static FilesystemRecord* FsGetIterator(void) { @@ -856,6 +825,131 @@ Tcl_FSUnregister(fsPtr) /* *---------------------------------------------------------------------- * + * Tcl_FSMatchInDirectory -- + * + * This routine is used by the globbing code to search a directory + * for all files which match a given pattern. The appropriate + * function for the filesystem to which pathPtr belongs will be + * called. If pathPtr does not belong to any filesystem and if it + * is NULL or the empty string, then we assume the pattern is to be + * matched in the current working directory. To avoid each + * filesystem's Tcl_FSMatchInDirectoryProc having to deal with this + * issue, we create a pathPtr on the fly (equal to the cwd), and + * then remove it from the results returned. This makes filesystems + * easy to write, since they can assume the pathPtr passed to them + * is an ordinary path. In fact this means we could remove such + * special case handling from Tcl's native filesystems. + * + * If 'pattern' is NULL, then pathPtr is assumed to be a fully + * specified path of a single file/directory which must be + * checked for existence and correct type. + * + * Results: + * + * The return value is a standard Tcl result indicating whether an + * error occurred in globbing. Error messages are placed in + * interp, but good results are placed in the resultPtr given. + * + * Recursive searches, e.g. + * + * glob -dir $dir -join * pkgIndex.tcl + * + * which must recurse through each directory matching '*' are + * handled internally by Tcl, by passing specific flags in a + * modified 'types' parameter. This means the actual filesystem + * only ever sees patterns which match in a single directory. + * + * Side effects: + * The interpreter may have an error message inserted into it. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_FSMatchInDirectory(interp, result, pathPtr, pattern, types) + Tcl_Interp *interp; /* Interpreter to receive error messages. */ + Tcl_Obj *result; /* List object to receive results. */ + Tcl_Obj *pathPtr; /* Contains path to directory to search. */ + CONST char *pattern; /* Pattern to match against. */ + Tcl_GlobTypeData *types; /* Object containing list of acceptable types. + * May be NULL. In particular the directory + * flag is very important. */ +{ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc; + if (proc != NULL) { + return (*proc)(interp, result, pathPtr, pattern, types); + } + } else { + Tcl_Obj* cwd; + int ret = -1; + if (pathPtr != NULL) { + int len; + Tcl_GetStringFromObj(pathPtr,&len); + if (len != 0) { + /* + * We have no idea how to match files in a directory + * which belongs to no known filesystem + */ + Tcl_SetErrno(ENOENT); + return -1; + } + } + /* + * We have an empty or NULL path. This is defined to mean we + * must search for files within the current 'cwd'. We + * therefore use that, but then since the proc we call will + * return results which include the cwd we must then trim it + * off the front of each path in the result. We choose to deal + * with this here (in the generic code), since if we don't, + * every single filesystem's implementation of + * Tcl_FSMatchInDirectory will have to deal with it for us. + */ + cwd = Tcl_FSGetCwd(NULL); + if (cwd == NULL) { + if (interp != NULL) { + Tcl_SetResult(interp, "glob couldn't determine " + "the current working directory", TCL_STATIC); + } + return TCL_ERROR; + } + fsPtr = Tcl_FSGetFileSystemForPath(cwd); + if (fsPtr != NULL) { + Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc; + if (proc != NULL) { + Tcl_Obj* tmpResultPtr = Tcl_NewListObj(0, NULL); + Tcl_IncrRefCount(tmpResultPtr); + ret = (*proc)(interp, tmpResultPtr, cwd, pattern, types); + if (ret == TCL_OK) { + int resLength; + + ret = Tcl_ListObjLength(interp, tmpResultPtr, &resLength); + if (ret == TCL_OK) { + int i; + + for (i = 0; i < resLength; i++) { + Tcl_Obj *elt; + + Tcl_ListObjIndex(interp, tmpResultPtr, i, &elt); + Tcl_ListObjAppendElement(interp, result, + TclFSMakePathRelative(interp, elt, cwd)); + } + } + } + Tcl_DecrRefCount(tmpResultPtr); + } + } + Tcl_DecrRefCount(cwd); + return ret; + } + Tcl_SetErrno(ENOENT); + return -1; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_FSMountsChanged -- * * Notify the filesystem that the available mounted filesystems @@ -969,7 +1063,7 @@ Tcl_FSData(fsPtr) /* *--------------------------------------------------------------------------- * - * FSNormalizeAbsolutePath -- + * TclFSNormalizeAbsolutePath -- * * Description: * Takes an absolute path specification and computes a 'normalized' @@ -1000,10 +1094,11 @@ Tcl_FSData(fsPtr) * *--------------------------------------------------------------------------- */ -static Tcl_Obj* -FSNormalizeAbsolutePath(interp, pathPtr) +Tcl_Obj* +TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) Tcl_Interp* interp; /* Interpreter to use */ Tcl_Obj *pathPtr; /* Absolute path to normalize */ + ClientData *clientDataPtr; { int splen = 0, nplen, eltLen, i; char *eltName; @@ -1039,6 +1134,8 @@ FSNormalizeAbsolutePath(interp, pathPtr) } } if (nplen > 0) { + ClientData clientData = NULL; + retVal = Tcl_FSJoinPath(split, nplen); /* * Now we have an absolute path, with no '..', '.' sequences, @@ -1052,13 +1149,16 @@ FSNormalizeAbsolutePath(interp, pathPtr) * other criteria for normalizing a path. */ Tcl_IncrRefCount(retVal); - TclNormalizeToUniquePath(interp, retVal, 0); + TclFSNormalizeToUniquePath(interp, retVal, 0, &clientData); /* * Since we know it is a normalized path, we can - * actually convert this object into an FsPath for + * actually convert this object into an "path" object for * greater efficiency */ - SetFsPathFromAbsoluteNormalized(interp, retVal); + TclFSMakePathFromNormalized(interp, retVal, clientData); + if (clientDataPtr != NULL) { + *clientDataPtr = clientData; + } } else { /* Init to an empty string */ retVal = Tcl_NewStringObj("",0); @@ -1083,7 +1183,7 @@ FSNormalizeAbsolutePath(interp, pathPtr) /* *--------------------------------------------------------------------------- * - * TclNormalizeToUniquePath -- + * TclFSNormalizeToUniquePath -- * * Description: * Takes a path specification containing no ../, ./ sequences, @@ -1113,14 +1213,17 @@ FSNormalizeAbsolutePath(interp, pathPtr) * after the separator). *--------------------------------------------------------------------------- */ -static int -TclNormalizeToUniquePath(interp, pathPtr, startAt) +int +TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr) Tcl_Interp *interp; Tcl_Obj *pathPtr; int startAt; + ClientData *clientDataPtr; { FilesystemRecord *fsRecPtr; - + /* Ignore this variable */ + (void)clientDataPtr; + /* * Call each of the "normalise path" functions in succession. This is * a special case, in which if we have a native filesystem handler, @@ -1374,7 +1477,7 @@ Tcl_FSEvalFile(interp, pathPtr) Tcl_Channel chan; Tcl_Obj *objPtr; - if (Tcl_FSGetTranslatedPath(interp, pathPtr) == NULL) { + if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { return TCL_ERROR; } @@ -1757,39 +1860,48 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) { Tcl_Filesystem *fsPtr; #ifdef USE_OBSOLETE_FS_HOOKS - OpenFileChannelProc *openFileChannelProcPtr; Tcl_Channel retVal = NULL; - char *path; -#endif /* USE_OBSOLETE_FS_HOOKS */ - 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); - } /* - * Call each of the "Tcl_OpenFileChannel" function in succession. + * Call each of the "Tcl_OpenFileChannel" functions in succession. * A non-NULL return value indicates the particular function has * succeeded. */ Tcl_MutexLock(&obsoleteFsHookMutex); - openFileChannelProcPtr = openFileChannelProcList; - while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { - retVal = (*openFileChannelProcPtr->proc)(interp, path, - modeString, permissions); - openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; + if (openFileChannelProcList != NULL) { + OpenFileChannelProc *openFileChannelProcPtr; + char *path; + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); + + if (transPtr == NULL) { + path = NULL; + } else { + path = Tcl_GetString(transPtr); + } + + openFileChannelProcPtr = openFileChannelProcList; + + while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { + retVal = (*openFileChannelProcPtr->proc)(interp, path, + modeString, permissions); + openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; + } } Tcl_MutexUnlock(&obsoleteFsHookMutex); if (retVal != NULL) { return retVal; } #endif /* USE_OBSOLETE_FS_HOOKS */ + + /* + * We need this just to ensure we return the correct error messages + * under some circumstances. + */ + if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { + return NULL; + } + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc; @@ -1831,484 +1943,119 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) /* *---------------------------------------------------------------------- * - * Tcl_FSMatchInDirectory -- + * Tcl_FSUtime -- * - * This routine is used by the globbing code to search a directory - * for all files which match a given pattern. The appropriate - * function for the filesystem to which pathPtr belongs will be - * called. If pathPtr does not belong to any filesystem and if it - * is NULL or the empty string, then we assume the pattern is to be - * matched in the current working directory. To avoid each - * filesystem's Tcl_FSMatchInDirectoryProc having to deal with this - * issue, we create a pathPtr on the fly (equal to the cwd), and - * then remove it from the results returned. This makes filesystems - * easy to write, since they can assume the pathPtr passed to them - * is an ordinary path. In fact this means we could remove such - * special case handling from Tcl's native filesystems. - * - * If 'pattern' is NULL, then pathPtr is assumed to be a fully - * specified path of a single file/directory which must be - * checked for existence and correct type. + * This procedure replaces the library version of utime. + * The appropriate function for the filesystem to which pathPtr + * belongs will be called. * - * Results: - * - * The return value is a standard Tcl result indicating whether an - * error occurred in globbing. Error messages are placed in - * interp, but good results are placed in the resultPtr given. - * - * Recursive searches, e.g. - * - * glob -dir $dir -join * pkgIndex.tcl - * - * which must recurse through each directory matching '*' are - * handled internally by Tcl, by passing specific flags in a - * modified 'types' parameter. This means the actual filesystem - * only ever sees patterns which match in a single directory. + * Results: + * See utime documentation. * * Side effects: - * The interpreter may have an error message inserted into it. + * See utime documentation. * - *---------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -int -Tcl_FSMatchInDirectory(interp, result, pathPtr, pattern, types) - Tcl_Interp *interp; /* Interpreter to receive error messages. */ - Tcl_Obj *result; /* List object to receive results. */ - Tcl_Obj *pathPtr; /* Contains path to directory to search. */ - CONST char *pattern; /* Pattern to match against. */ - Tcl_GlobTypeData *types; /* Object containing list of acceptable types. - * May be NULL. In particular the directory - * flag is very important. */ +int +Tcl_FSUtime (pathPtr, tval) + Tcl_Obj *pathPtr; /* File to change access/modification times */ + struct utimbuf *tval; /* Structure containing access/modification + * times to use. Should not be modified. */ { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { - Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc; + Tcl_FSUtimeProc *proc = fsPtr->utimeProc; if (proc != NULL) { - return (*proc)(interp, result, pathPtr, pattern, types); - } - } else { - Tcl_Obj* cwd; - int ret = -1; - if (pathPtr != NULL) { - int len; - Tcl_GetStringFromObj(pathPtr,&len); - if (len != 0) { - /* - * We have no idea how to match files in a directory - * which belongs to no known filesystem - */ - Tcl_SetErrno(ENOENT); - return -1; - } - } - /* - * We have an empty or NULL path. This is defined to mean we - * must search for files within the current 'cwd'. We - * therefore use that, but then since the proc we call will - * return results which include the cwd we must then trim it - * off the front of each path in the result. We choose to deal - * with this here (in the generic code), since if we don't, - * every single filesystem's implementation of - * Tcl_FSMatchInDirectory will have to deal with it for us. - */ - cwd = Tcl_FSGetCwd(NULL); - if (cwd == NULL) { - if (interp != NULL) { - Tcl_SetResult(interp, "glob couldn't determine " - "the current working directory", TCL_STATIC); - } - return TCL_ERROR; - } - fsPtr = Tcl_FSGetFileSystemForPath(cwd); - if (fsPtr != NULL) { - Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc; - if (proc != NULL) { - int cwdLen; - char *cwdStr; - Tcl_Obj* tmpResultPtr = Tcl_NewListObj(0, NULL); - Tcl_IncrRefCount(tmpResultPtr); - /* - * We know the cwd is a normalised object which does - * not end in a directory delimiter, unless the cwd - * is the name of a volume, in which case it will - * end in a delimiter! We handle this situation here. - * A better test than the '!= sep' might be to simply - * check if 'cwd' is a root volume. - * - * Note that if we get this wrong, we will strip off - * either too much or too little below, leading to - * wrong answers returned by glob. - */ - cwdStr = Tcl_GetStringFromObj(cwd, &cwdLen); - /* - * Should we perhaps use 'Tcl_FSPathSeparator'? - * But then what about the Windows special case? - * Perhaps we should just check if cwd is a root - * volume. - */ - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - if (cwdStr[cwdLen-1] != '/') { - cwdLen++; - } - break; - case TCL_PLATFORM_WINDOWS: - if (cwdStr[cwdLen-1] != '/' - && cwdStr[cwdLen-1] != '\\') { - cwdLen++; - } - break; - case TCL_PLATFORM_MAC: - if (cwdStr[cwdLen-1] != ':') { - cwdLen++; - } - break; - } - ret = (*proc)(interp, tmpResultPtr, cwd, pattern, types); - if (ret == TCL_OK) { - int resLength; - - ret = Tcl_ListObjLength(interp, tmpResultPtr, &resLength); - if (ret == TCL_OK) { - int i; - - for (i = 0; i < resLength; i++) { - Tcl_Obj *cutElt, *elt; - char *eltStr; - int eltLen; - - Tcl_ListObjIndex(interp, tmpResultPtr, i, &elt); - if (elt->typePtr == &tclFsPathType) { - FsPath* fsPathPtr = (FsPath*) - elt->internalRep.otherValuePtr; - if (fsPathPtr->flags != 0 - && fsPathPtr->cwdPtr == cwd) { - Tcl_ListObjAppendElement(interp, result, - MakeFsPathFromRelative(interp, - fsPathPtr->normPathPtr, cwd)); - continue; - } - } - eltStr = Tcl_GetStringFromObj(elt, &eltLen); - cutElt = Tcl_NewStringObj(eltStr + cwdLen, - eltLen - cwdLen); - Tcl_ListObjAppendElement(interp, result, cutElt); - } - } - } - Tcl_DecrRefCount(tmpResultPtr); - } + return (*proc)(pathPtr, tval); } - Tcl_DecrRefCount(cwd); - return ret; } - Tcl_SetErrno(ENOENT); return -1; } /* *---------------------------------------------------------------------- * - * Tcl_FSGetCwd -- + * NativeFileAttrStrings -- * - * This function replaces the library version of getcwd(). - * - * Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains - * its own record (in a Tcl_Obj) of the cwd, and an attempt - * is made to synchronise this with the cwd's containing filesystem, - * if that filesystem provides a cwdProc (e.g. the native filesystem). - * - * Note that if Tcl's cwd is not in the native filesystem, then of - * course Tcl's cwd and the native cwd are different: extensions - * should therefore ensure they only access the cwd through this - * function to avoid confusion. - * - * If a global cwdPathPtr already exists, it is returned, subject - * to a synchronisation attempt in that cwdPathPtr's fs. - * Otherwise, the chain of functions that have been "inserted" - * into the filesystem will be called in succession until either a - * value other than NULL is returned, or the entire list is - * visited. + * This procedure implements the platform dependent 'file + * attributes' subcommand, for the native filesystem, for listing + * the set of possible attribute strings. This function is part + * of Tcl's native filesystem support, and is placed here because + * it is shared by Unix, MacOS and Windows code. * * Results: - * The result is a pointer to a Tcl_Obj specifying the current - * directory, or NULL if the current directory could not be - * determined. If NULL is returned, an error message is left in the - * interp's result. - * - * The result already has its refCount incremented for the caller. - * When it is no longer needed, that refCount should be decremented. - * This is needed for thread-safety purposes, to allow multiple - * threads to access this and related functions, while ensuring the - * results are always valid. - * - * Of course it is probably a bad idea for multiple threads to - * be *setting* the cwd anyway, but we can at least try to - * help the case of multiple reads with occasional sets. + * An array of strings * * Side effects: - * Various objects may be freed and allocated. + * None. * *---------------------------------------------------------------------- */ -Tcl_Obj* -Tcl_FSGetCwd(interp) - Tcl_Interp *interp; +static CONST char** +NativeFileAttrStrings(pathPtr, objPtrRef) + Tcl_Obj *pathPtr; + Tcl_Obj** objPtrRef; { - Tcl_Obj *cwdToReturn; - - if (FsCwdPointerEquals(NULL)) { - FilesystemRecord *fsRecPtr; - Tcl_Obj *retVal = NULL; + return tclpFileAttrStrings; +} + +/* + *---------------------------------------------------------------------- + * + * NativeFileAttrsGet -- + * + * This procedure implements the platform dependent + * 'file attributes' subcommand, for the native + * filesystem, for 'get' operations. This function is part + * of Tcl's native filesystem support, and is placed here + * because it is shared by Unix, MacOS and Windows code. + * + * Results: + * Standard Tcl return code. The object placed in objPtrRef + * (if TCL_OK was returned) is likely to have a refCount of zero. + * Either way we must either store it somewhere (e.g. the Tcl + * result), or Incr/Decr its refCount to ensure it is properly + * freed. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - /* - * We've never been called before, try to find a cwd. Call - * each of the "Tcl_GetCwd" function in succession. A non-NULL - * return value indicates the particular function has - * succeeded. - */ - - fsRecPtr = FsGetIterator(); - while ((retVal == NULL) && (fsRecPtr != NULL)) { - Tcl_FSGetCwdProc *proc = fsRecPtr->fsPtr->getCwdProc; - if (proc != NULL) { - retVal = (*proc)(interp); - } - fsRecPtr = fsRecPtr->nextPtr; - } - FsReleaseIterator(); - /* - * Now the 'cwd' may NOT be normalized, at least on some - * platforms. For the sake of efficiency, we want a completely - * normalized cwd at all times. - * - * Finally, if retVal is NULL, we do not have a cwd, which - * could be problematic. - */ - if (retVal != NULL) { - Tcl_Obj *norm = FSNormalizeAbsolutePath(interp, retVal); - if (norm != NULL) { - /* - * We found a cwd, which is now in our global storage. - * We must make a copy. Norm already has a refCount of - * 1. - * - * Threading issue: note that multiple threads at system - * startup could in principle call this procedure - * simultaneously. They will therefore each set the - * cwdPathPtr independently. That behaviour is a bit - * peculiar, but should be fine. Once we have a cwd, - * we'll always be in the 'else' branch below which - * is simpler. - */ - Tcl_MutexLock(&cwdMutex); - /* Just in case the pointer has been set by another - * thread between now and the test above */ - if (cwdPathPtr != NULL) { - Tcl_DecrRefCount(cwdPathPtr); - } - cwdPathPtr = norm; - Tcl_MutexUnlock(&cwdMutex); - } - Tcl_DecrRefCount(retVal); - } - } else { - /* - * We already have a cwd cached, but we want to give the - * filesystem it is in a chance to check whether that cwd - * has changed, or is perhaps no longer accessible. This - * allows an error to be thrown if, say, the permissions on - * that directory have changed. - */ - Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(cwdPathPtr); - /* - * If the filesystem couldn't be found, or if no cwd function - * exists for this filesystem, then we simply assume the cached - * cwd is ok. If we do call a cwd, we must watch for errors - * (if the cwd returns NULL). This ensures that, say, on Unix - * if the permissions of the cwd change, 'pwd' does actually - * throw the correct error in Tcl. (This is tested for in the - * test suite on unix). - */ - if (fsPtr != NULL) { - Tcl_FSGetCwdProc *proc = fsPtr->getCwdProc; - if (proc != NULL) { - Tcl_Obj *retVal = (*proc)(interp); - if (retVal != NULL) { - Tcl_Obj *norm = FSNormalizeAbsolutePath(interp, retVal); - /* - * Check whether cwd has changed from the value - * previously stored in cwdPathPtr. Really 'norm' - * shouldn't be null, but we are careful. - */ - if (norm == NULL) { - /* Do nothing */ - } else if (Tcl_FSEqualPaths(cwdPathPtr, norm)) { - /* - * If the paths were equal, we can be more - * efficient and retain the old path object - * which will probably already be shared. In - * this case we can simply free the normalized - * path we just calculated. - */ - Tcl_DecrRefCount(norm); - } else { - /* The cwd has in fact changed, so we must - * lock down the cwdMutex to modify. */ - Tcl_MutexLock(&cwdMutex); - Tcl_DecrRefCount(cwdPathPtr); - cwdPathPtr = norm; - Tcl_MutexUnlock(&cwdMutex); - } - Tcl_DecrRefCount(retVal); - } else { - /* The 'cwd' function returned an error, so we - * reset the cwd after locking down the mutex. */ - Tcl_MutexLock(&cwdMutex); - Tcl_DecrRefCount(cwdPathPtr); - cwdPathPtr = NULL; - Tcl_MutexUnlock(&cwdMutex); - } - } - } - } - - /* - * The paths all eventually fall through to here. Note that - * we use a bunch of separate mutex locks throughout this - * code to help prevent deadlocks between threads. Really - * the only weirdness will arise if multiple threads are setting - * and reading the cwd, and that behaviour is always going to be - * a little suspect. - */ - Tcl_MutexLock(&cwdMutex); - cwdToReturn = cwdPathPtr; - if (cwdToReturn != NULL) { - Tcl_IncrRefCount(cwdToReturn); - } - Tcl_MutexUnlock(&cwdMutex); - - return (cwdToReturn); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FSUtime -- - * - * This procedure replaces the library version of utime. - * The appropriate function for the filesystem to which pathPtr - * belongs will be called. - * - * Results: - * See utime documentation. - * - * Side effects: - * See utime documentation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_FSUtime (pathPtr, tval) - Tcl_Obj *pathPtr; /* File to change access/modification times */ - struct utimbuf *tval; /* Structure containing access/modification - * times to use. Should not be modified. */ -{ - Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL) { - Tcl_FSUtimeProc *proc = fsPtr->utimeProc; - if (proc != NULL) { - return (*proc)(pathPtr, tval); - } - } - return -1; -} - -/* - *---------------------------------------------------------------------- - * - * NativeFileAttrStrings -- - * - * This procedure implements the platform dependent 'file - * attributes' subcommand, for the native filesystem, for listing - * the set of possible attribute strings. This function is part - * of Tcl's native filesystem support, and is placed here because - * it is shared by Unix, MacOS and Windows code. - * - * Results: - * An array of strings - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static CONST char** -NativeFileAttrStrings(pathPtr, objPtrRef) - Tcl_Obj *pathPtr; - Tcl_Obj** objPtrRef; -{ - return tclpFileAttrStrings; -} - -/* - *---------------------------------------------------------------------- - * - * NativeFileAttrsGet -- - * - * This procedure implements the platform dependent - * 'file attributes' subcommand, for the native - * filesystem, for 'get' operations. This function is part - * of Tcl's native filesystem support, and is placed here - * because it is shared by Unix, MacOS and Windows code. - * - * Results: - * Standard Tcl return code. The object placed in objPtrRef - * (if TCL_OK was returned) is likely to have a refCount of zero. - * Either way we must either store it somewhere (e.g. the Tcl - * result), or Incr/Decr its refCount to ensure it is properly - * freed. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -NativeFileAttrsGet(interp, index, pathPtr, objPtrRef) - Tcl_Interp *interp; /* The interpreter for error reporting. */ - int index; /* index of the attribute command. */ - Tcl_Obj *pathPtr; /* path of file we are operating on. */ - Tcl_Obj **objPtrRef; /* for output. */ -{ - return (*tclpFileAttrProcs[index].getProc)(interp, index, - pathPtr, objPtrRef); -} - -/* - *---------------------------------------------------------------------- - * - * NativeFileAttrsSet -- - * - * This procedure implements the platform dependent - * 'file attributes' subcommand, for the native - * filesystem, for 'set' operations. This function is part - * of Tcl's native filesystem support, and is placed here - * because it is shared by Unix, MacOS and Windows code. - * - * Results: - * Standard Tcl return code. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ +static int +NativeFileAttrsGet(interp, index, pathPtr, objPtrRef) + Tcl_Interp *interp; /* The interpreter for error reporting. */ + int index; /* index of the attribute command. */ + Tcl_Obj *pathPtr; /* path of file we are operating on. */ + Tcl_Obj **objPtrRef; /* for output. */ +{ + return (*tclpFileAttrProcs[index].getProc)(interp, index, + pathPtr, objPtrRef); +} + +/* + *---------------------------------------------------------------------- + * + * NativeFileAttrsSet -- + * + * This procedure implements the platform dependent + * 'file attributes' subcommand, for the native + * filesystem, for 'set' operations. This function is part + * of Tcl's native filesystem support, and is placed here + * because it is shared by Unix, MacOS and Windows code. + * + * Results: + * Standard Tcl return code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ static int NativeFileAttrsSet(interp, index, pathPtr, objPtr) @@ -2442,33 +2189,219 @@ Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr) /* *---------------------------------------------------------------------- * - * Tcl_FSChdir -- + * Tcl_FSGetCwd -- * - * This function replaces the library version of chdir(). + * This function replaces the library version of getcwd(). * - * The path is normalized and then passed to the filesystem - * which claims it. + * Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains + * its own record (in a Tcl_Obj) of the cwd, and an attempt + * is made to synchronise this with the cwd's containing filesystem, + * if that filesystem provides a cwdProc (e.g. the native filesystem). + * + * Note that if Tcl's cwd is not in the native filesystem, then of + * course Tcl's cwd and the native cwd are different: extensions + * should therefore ensure they only access the cwd through this + * function to avoid confusion. + * + * If a global cwdPathPtr already exists, it is returned, subject + * to a synchronisation attempt in that cwdPathPtr's fs. + * Otherwise, the chain of functions that have been "inserted" + * into the filesystem will be called in succession until either a + * value other than NULL is returned, or the entire list is + * visited. * * Results: - * See chdir() documentation. If successful, we keep a - * record of the successful path in cwdPathPtr for subsequent - * calls to getcwd. + * The result is a pointer to a Tcl_Obj specifying the current + * directory, or NULL if the current directory could not be + * determined. If NULL is returned, an error message is left in the + * interp's result. + * + * The result already has its refCount incremented for the caller. + * When it is no longer needed, that refCount should be decremented. + * This is needed for thread-safety purposes, to allow multiple + * threads to access this and related functions, while ensuring the + * results are always valid. + * + * Of course it is probably a bad idea for multiple threads to + * be *setting* the cwd anyway, but we can at least try to + * help the case of multiple reads with occasional sets. * * Side effects: - * See chdir() documentation. The global cwdPathPtr may - * change value. + * Various objects may be freed and allocated. * *---------------------------------------------------------------------- */ -int -Tcl_FSChdir(pathPtr) - Tcl_Obj *pathPtr; + +Tcl_Obj* +Tcl_FSGetCwd(interp) + Tcl_Interp *interp; { - Tcl_Filesystem *fsPtr; - int retVal = -1; + Tcl_Obj *cwdToReturn; - if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) { - return TCL_ERROR; + if (TclFSCwdPointerEquals(NULL)) { + FilesystemRecord *fsRecPtr; + Tcl_Obj *retVal = NULL; + + /* + * We've never been called before, try to find a cwd. Call + * each of the "Tcl_GetCwd" function in succession. A non-NULL + * return value indicates the particular function has + * succeeded. + */ + + fsRecPtr = FsGetIterator(); + while ((retVal == NULL) && (fsRecPtr != NULL)) { + Tcl_FSGetCwdProc *proc = fsRecPtr->fsPtr->getCwdProc; + if (proc != NULL) { + retVal = (*proc)(interp); + } + fsRecPtr = fsRecPtr->nextPtr; + } + FsReleaseIterator(); + /* + * Now the 'cwd' may NOT be normalized, at least on some + * platforms. For the sake of efficiency, we want a completely + * normalized cwd at all times. + * + * Finally, if retVal is NULL, we do not have a cwd, which + * could be problematic. + */ + if (retVal != NULL) { + Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL); + if (norm != NULL) { + /* + * We found a cwd, which is now in our global storage. + * We must make a copy. Norm already has a refCount of + * 1. + * + * Threading issue: note that multiple threads at system + * startup could in principle call this procedure + * simultaneously. They will therefore each set the + * cwdPathPtr independently. That behaviour is a bit + * peculiar, but should be fine. Once we have a cwd, + * we'll always be in the 'else' branch below which + * is simpler. + */ + Tcl_MutexLock(&cwdMutex); + /* Just in case the pointer has been set by another + * thread between now and the test above */ + if (cwdPathPtr != NULL) { + Tcl_DecrRefCount(cwdPathPtr); + } + cwdPathPtr = norm; + Tcl_MutexUnlock(&cwdMutex); + } + Tcl_DecrRefCount(retVal); + } + } else { + /* + * We already have a cwd cached, but we want to give the + * filesystem it is in a chance to check whether that cwd + * has changed, or is perhaps no longer accessible. This + * allows an error to be thrown if, say, the permissions on + * that directory have changed. + */ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(cwdPathPtr); + /* + * If the filesystem couldn't be found, or if no cwd function + * exists for this filesystem, then we simply assume the cached + * cwd is ok. If we do call a cwd, we must watch for errors + * (if the cwd returns NULL). This ensures that, say, on Unix + * if the permissions of the cwd change, 'pwd' does actually + * throw the correct error in Tcl. (This is tested for in the + * test suite on unix). + */ + if (fsPtr != NULL) { + Tcl_FSGetCwdProc *proc = fsPtr->getCwdProc; + if (proc != NULL) { + Tcl_Obj *retVal = (*proc)(interp); + if (retVal != NULL) { + Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL); + /* + * Check whether cwd has changed from the value + * previously stored in cwdPathPtr. Really 'norm' + * shouldn't be null, but we are careful. + */ + if (norm == NULL) { + /* Do nothing */ + } else if (Tcl_FSEqualPaths(cwdPathPtr, norm)) { + /* + * If the paths were equal, we can be more + * efficient and retain the old path object + * which will probably already be shared. In + * this case we can simply free the normalized + * path we just calculated. + */ + Tcl_DecrRefCount(norm); + } else { + /* The cwd has in fact changed, so we must + * lock down the cwdMutex to modify. */ + Tcl_MutexLock(&cwdMutex); + Tcl_DecrRefCount(cwdPathPtr); + cwdPathPtr = norm; + Tcl_MutexUnlock(&cwdMutex); + } + Tcl_DecrRefCount(retVal); + } else { + /* The 'cwd' function returned an error, so we + * reset the cwd after locking down the mutex. */ + Tcl_MutexLock(&cwdMutex); + Tcl_DecrRefCount(cwdPathPtr); + cwdPathPtr = NULL; + Tcl_MutexUnlock(&cwdMutex); + } + } + } + } + + /* + * The paths all eventually fall through to here. Note that + * we use a bunch of separate mutex locks throughout this + * code to help prevent deadlocks between threads. Really + * the only weirdness will arise if multiple threads are setting + * and reading the cwd, and that behaviour is always going to be + * a little suspect. + */ + Tcl_MutexLock(&cwdMutex); + cwdToReturn = cwdPathPtr; + if (cwdToReturn != NULL) { + Tcl_IncrRefCount(cwdToReturn); + } + Tcl_MutexUnlock(&cwdMutex); + + return (cwdToReturn); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FSChdir -- + * + * This function replaces the library version of chdir(). + * + * The path is normalized and then passed to the filesystem + * which claims it. + * + * Results: + * See chdir() documentation. If successful, we keep a + * record of the successful path in cwdPathPtr for subsequent + * calls to getcwd. + * + * Side effects: + * See chdir() documentation. The global cwdPathPtr may + * change value. + * + *---------------------------------------------------------------------- + */ +int +Tcl_FSChdir(pathPtr) + Tcl_Obj *pathPtr; +{ + Tcl_Filesystem *fsPtr; + int retVal = -1; + + if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) { + return TCL_ERROR; } fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); @@ -3004,79 +2937,6 @@ Tcl_FSListVolumes(void) } /* - *---------------------------------------------------------------------- - * - * Tcl_FSGetPathType -- - * - * Determines whether a given path is relative to the current - * directory, relative to the current volume, or absolute. - * - * Results: - * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or - * TCL_PATH_VOLUME_RELATIVE. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_PathType -Tcl_FSGetPathType(pathObjPtr) - Tcl_Obj *pathObjPtr; -{ - return FSGetPathType(pathObjPtr, NULL, NULL); -} - -/* - *---------------------------------------------------------------------- - * - * 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. - * - *---------------------------------------------------------------------- - */ - -static Tcl_PathType -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) { - if (fsPathPtr->flags == 0) { - return TCL_PATH_RELATIVE; - } - return FSGetPathType(fsPathPtr->cwdPtr, filesystemPtrPtr, - driveNameLengthPtr); - } else { - return GetPathType(pathObjPtr, filesystemPtrPtr, - driveNameLengthPtr, NULL); - } - } -} - -/* *--------------------------------------------------------------------------- * * Tcl_FSSplitPath -- @@ -3173,210 +3033,53 @@ Tcl_FSSplitPath(pathPtr, lenPtr) return result; } +/* Simple helper function */ +Tcl_Obj* +TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr, epochPtr) + Tcl_Filesystem *fromFilesystem; + ClientData clientData; + FilesystemRecord **fsRecPtrPtr; + int *epochPtr; +{ + FilesystemRecord *fsRecPtr = FsGetIterator(); + while (fsRecPtr != NULL) { + if (fsRecPtr->fsPtr == fromFilesystem) { + *epochPtr = theFilesystemEpoch; + *fsRecPtrPtr = fsRecPtr; + break; + } + fsRecPtr = fsRecPtr->nextPtr; + } + FsReleaseIterator(); + + if ((fsRecPtr != NULL) + && (fromFilesystem->internalToNormalizedProc != NULL)) { + return (*fromFilesystem->internalToNormalizedProc)(clientData); + } else { + return NULL; + } +} + /* - *--------------------------------------------------------------------------- + *---------------------------------------------------------------------- * - * Tcl_FSJoinPath -- + * GetPathType -- + * + * Helper function used by FSGetPathType. * - * 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. - * * Results: - * Returns object with refCount of zero, (or if non-zero, it has - * references elsewhere in Tcl). Either way, the caller must - * increment its refCount before use. + * 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_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 time joining null elements to the path - */ - if (elements > listTest) { - elements = listTest; - } - } - - if (elements == 2) { - /* - * This is a special case where we can be much more - * efficient - */ - Tcl_Obj *base; - - Tcl_ListObjIndex(NULL, listObj, 0, &base); - /* - * There is only any value in doing this if the first object is - * of path type, otherwise we'll never actually get any - * efficiency benefit elsewhere in the code (from re-using the - * normalized representation of the base object). - */ - if (base->typePtr == &tclFsPathType - && !(base->bytes != NULL && base->bytes[0] == '\0')) { - Tcl_Obj *tail; - Tcl_PathType type; - Tcl_ListObjIndex(NULL, listObj, 1, &tail); - type = GetPathType(tail, NULL, NULL, NULL); - if (type == TCL_PATH_RELATIVE) { - CONST char *str; - int len; - str = Tcl_GetStringFromObj(tail,&len); - if (len == 0) { - /* - * This happens if we try to handle the root volume - * '/'. There's no need to return a special path - * object, when the base itself is just fine! - */ - return base; - } - if (str[0] != '.') { - return TclNewFSPathObj(base, str, len); - } - /* - * Otherwise we don't have an easy join, and - * we must let the more general code below handle - * things - */ - } else { - return tail; - } - } - } - - res = Tcl_NewObj(); - - for (i = 0; i < elements; i++) { - Tcl_Obj *elt; - int driveNameLength; - Tcl_PathType type; - char *strElt; - int strEltLen; - int length; - char *ptr; - Tcl_Obj *driveName = NULL; - - Tcl_ListObjIndex(NULL, listObj, i, &elt); - strElt = Tcl_GetStringFromObj(elt, &strEltLen); - 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; - } - - ptr = Tcl_GetStringFromObj(res, &length); - - /* - * Strip off any './' before a tilde, unless this is the - * beginning of the path. - */ - if (length > 0 && strEltLen > 0) { - if ((strElt[0] == '.') && (strElt[1] == '/') - && (strElt[2] == '~')) { - strElt += 2; - } - } - - /* - * 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 == &tclNativeFilesystem || fsPtr == NULL) { - TclpNativeJoinPath(res, strElt); - } else { - char separator = '/'; - int needsSep = 0; - - if (fsPtr->filesystemSeparatorProc != NULL) { - Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(res); - if (sep != NULL) { - separator = Tcl_GetString(sep)[0]; - } - } - - if (length > 0 && ptr[length -1] != '/') { - Tcl_AppendToObj(res, &separator, 1); - length++; - } - Tcl_SetObjLength(res, length + (int) 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 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 +Tcl_PathType GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef) Tcl_Obj *pathObjPtr; Tcl_Filesystem **filesystemPtrPtr; @@ -3812,2011 +3515,2433 @@ Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr) /* *--------------------------------------------------------------------------- * - * Tcl_FSConvertToPathType -- + * Tcl_FSGetFileSystemForPath -- * - * This function tries to convert the given Tcl_Obj to a valid - * Tcl path type, taking account of the fact that the cwd may - * have changed even if this object is already supposedly of - * the correct type. - * - * The filename may begin with "~" (to indicate current user's - * home directory) or "~" (to indicate any user's home - * directory). + * This function determines which filesystem to use for a + * particular path object, and returns the filesystem which + * accepts this file. If no filesystem will accept this object + * as a valid file path, then NULL is returned. * * Results: - * Standard Tcl error code. +.* NULL or a filesystem which will accept this path. * * Side effects: - * The old representation may be freed, and new memory allocated. + * The object may be converted to a path type. * *--------------------------------------------------------------------------- */ -int -Tcl_FSConvertToPathType(interp, objPtr) - Tcl_Interp *interp; /* Interpreter in which to store error - * message (if necessary). */ - Tcl_Obj *objPtr; /* Object to convert to a valid, current - * path type. */ + +Tcl_Filesystem* +Tcl_FSGetFileSystemForPath(pathObjPtr) + Tcl_Obj* pathObjPtr; { + FilesystemRecord *fsRecPtr; + Tcl_Filesystem* retVal = NULL; + /* - * While it is bad practice to examine an object's type directly, - * this is actually the best thing to do here. The reason is that - * if we are converting this object to FsPath type for the first - * time, we don't need to worry whether the 'cwd' has changed. - * On the other hand, if this object is already of FsPath type, - * and is a relative path, we do have to worry about the cwd. - * If the cwd has changed, we must recompute the path. + * If the object has a refCount of zero, we reject it. This + * is to avoid possible segfaults or nondeterministic memory + * leaks (i.e. the user doesn't know if they should decrement + * the ref count on return or not). */ - if (objPtr->typePtr == &tclFsPathType) { - FsPath *fsPathPtr = (FsPath*) objPtr->internalRep.otherValuePtr; - if (fsPathPtr->filesystemEpoch != theFilesystemEpoch) { - if (objPtr->bytes == NULL) { - UpdateStringOfFsPath(objPtr); - } - FreeFsPathInternalRep(objPtr); - objPtr->typePtr = NULL; - return Tcl_ConvertToType(interp, objPtr, &tclFsPathType); - } - return TCL_OK; - /* - * This code is intentionally never reached. Once fs-optimisation - * is complete, it will be removed/replaced - */ - if (fsPathPtr->cwdPtr == NULL) { - return TCL_OK; - } else { - if (FsCwdPointerEquals(fsPathPtr->cwdPtr)) { - return TCL_OK; - } else { - if (objPtr->bytes == NULL) { - UpdateStringOfFsPath(objPtr); - } - FreeFsPathInternalRep(objPtr); - objPtr->typePtr = NULL; - return Tcl_ConvertToType(interp, objPtr, &tclFsPathType); - } - } - } else { - return Tcl_ConvertToType(interp, objPtr, &tclFsPathType); + + if (pathObjPtr->refCount == 0) { + panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0"); + return NULL; + } + + /* + * Check if the filesystem has changed in some way since + * this object's internal representation was calculated. + */ + if (TclFSEnsureEpochOk(pathObjPtr, theFilesystemEpoch, + &retVal) != TCL_OK) { + return NULL; } -} - -/* - * Helper function for SetFsPathFromAny. Returns position of first - * directory delimiter in the path. - */ -static int -FindSplitPos(path, separator) - char *path; - char *separator; -{ - int count = 0; - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - case TCL_PLATFORM_MAC: - while (path[count] != 0) { - if (path[count] == *separator) { - return count; - } - count++; - } - break; + /* + * Call each of the "pathInFilesystem" functions in succession. A + * non-return value of -1 indicates the particular function has + * succeeded. + */ - case TCL_PLATFORM_WINDOWS: - while (path[count] != 0) { - if (path[count] == *separator || path[count] == '\\') { - return count; - } - count++; + fsRecPtr = FsGetIterator(); + while ((retVal == NULL) && (fsRecPtr != NULL)) { + Tcl_FSPathInFilesystemProc *proc = fsRecPtr->fsPtr->pathInFilesystemProc; + if (proc != NULL) { + ClientData clientData = NULL; + int ret = (*proc)(pathObjPtr, &clientData); + if (ret != -1) { + /* + * We assume the type of pathObjPtr hasn't been changed + * by the above call to the pathInFilesystemProc. + */ + TclFSSetPathDetails(pathObjPtr, fsRecPtr, clientData, + theFilesystemEpoch); + retVal = fsRecPtr->fsPtr; } - break; + } + fsRecPtr = fsRecPtr->nextPtr; } - return count; + FsReleaseIterator(); + + return retVal; } /* *--------------------------------------------------------------------------- * - * UpdateStringOfFsPath -- + * Tcl_FSGetNativePath -- * - * Gives an object a valid string rep. + * This function is for use by the Win/Unix/MacOS native filesystems, + * so that they can easily retrieve the native (char* or TCHAR*) + * representation of a path. Other filesystems will probably + * want to implement similar functions. They basically act as a + * safety net around Tcl_FSGetInternalRep. Normally your file- + * system procedures will always be called with path objects + * already converted to the correct filesystem, but if for + * some reason they are called directly (i.e. by procedures + * not in this file), then one cannot necessarily guarantee that + * the path object pointer is from the correct filesystem. * + * Note: in the future it might be desireable to have separate + * versions of this function with different signatures, for + * example Tcl_FSGetNativeMacPath, Tcl_FSGetNativeUnixPath etc. + * Right now, since native paths are all string based, we use just + * one function. On MacOS we could possibly use an FSSpec or + * FSRef as the native representation. + * * Results: - * None. + * NULL or a valid native path. * * Side effects: - * Memory may be allocated. + * See Tcl_FSGetInternalRep. * *--------------------------------------------------------------------------- */ -static void -UpdateStringOfFsPath(objPtr) - register Tcl_Obj *objPtr; /* path obj with string rep to update. */ +CONST char * +Tcl_FSGetNativePath(pathObjPtr) + Tcl_Obj *pathObjPtr; { - register FsPath* fsPathPtr = - (FsPath*) objPtr->internalRep.otherValuePtr; - CONST char *cwdStr; - int cwdLen; - Tcl_Obj *copy; - - if (fsPathPtr->flags == 0 || fsPathPtr->cwdPtr == NULL) { - panic("Called UpdateStringOfFsPath with invalid object"); - } - - copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr); - Tcl_IncrRefCount(copy); - - cwdStr = Tcl_GetStringFromObj(copy, &cwdLen); - /* - * Should we perhaps use 'Tcl_FSPathSeparator'? - * But then what about the Windows special case? - * Perhaps we should just check if cwd is a root volume. - * We should never get cwdLen == 0 in this code path. - */ - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - if (cwdStr[cwdLen-1] != '/') { - Tcl_AppendToObj(copy, "/", 1); - cwdLen++; - } - break; - case TCL_PLATFORM_WINDOWS: - /* - * We need the extra 'cwdLen != 2', and ':' checks because - * a volume relative path doesn't get a '/'. For example - * 'glob C:*cat*.exe' will return 'C:cat32.exe' - */ - if (cwdStr[cwdLen-1] != '/' - && cwdStr[cwdLen-1] != '\\') { - if (cwdLen != 2 || cwdStr[1] != ':') { - Tcl_AppendToObj(copy, "/", 1); - cwdLen++; - } - } - break; - case TCL_PLATFORM_MAC: - if (cwdStr[cwdLen-1] != ':') { - Tcl_AppendToObj(copy, ":", 1); - cwdLen++; - } - break; - } - Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr); - objPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen); - objPtr->length = cwdLen; - copy->bytes = tclEmptyStringRep; - copy->length = 0; - Tcl_DecrRefCount(copy); + return (CONST char *)Tcl_FSGetInternalRep(pathObjPtr, &tclNativeFilesystem); } /* *--------------------------------------------------------------------------- * - * TclNewFSPathObj -- + * NativeCreateNativeRep -- + * + * Create a native representation for the given path. * - * Creates a path object whose string representation is - * '[file join dirPtr addStrRep]', but does so in a way that - * allows for more efficient caching of normalized paths. - * - * Assumptions: - * 'dirPtr' must be an absolute path. - * 'len' may not be zero. - * * Results: - * The new Tcl object. + * None. * * Side effects: - * Memory is allocated. 'dirPtr' gets an additional refCount. + * None. * *--------------------------------------------------------------------------- */ +static ClientData +NativeCreateNativeRep(pathObjPtr) + Tcl_Obj* pathObjPtr; +{ + char *nativePathPtr; + Tcl_DString ds; + Tcl_Obj* validPathObjPtr; + int len; + char *str; -Tcl_Obj* -TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len) + /* Make sure the normalized path is set */ + validPathObjPtr = Tcl_FSGetNormalizedPath(NULL, pathObjPtr); + + str = Tcl_GetStringFromObj(validPathObjPtr, &len); +#ifdef __WIN32__ + Tcl_WinUtfToTChar(str, len, &ds); + if (tclWinProcs->useWide) { + len = Tcl_DStringLength(&ds) + sizeof(WCHAR); + } else { + len = Tcl_DStringLength(&ds) + sizeof(char); + } +#else + Tcl_UtfToExternalDString(NULL, str, len, &ds); + len = Tcl_DStringLength(&ds) + sizeof(char); +#endif + nativePathPtr = ckalloc((unsigned) len); + memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len); + + Tcl_DStringFree(&ds); + return (ClientData)nativePathPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpNativeToNormalized -- + * + * Convert native format to a normalized path object, with refCount + * of zero. + * + * Results: + * A valid normalized path. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +Tcl_Obj* +TclpNativeToNormalized(clientData) + ClientData clientData; { - FsPath *fsPathPtr; + Tcl_DString ds; Tcl_Obj *objPtr; + CONST char *copy; + int len; - objPtr = Tcl_NewObj(); - fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); +#ifdef __WIN32__ + Tcl_WinTCharToUtf((CONST char*)clientData, -1, &ds); +#else + Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds); +#endif - if (tclPlatform == TCL_PLATFORM_MAC) { - /* - * Mac relative paths may begin with a directory separator ':'. - * If present, we need to skip this ':' because we assume that - * we can join dirPtr and addStrRep by concatenating them as - * strings (and we ensure that dirPtr is terminated by a ':'). - */ - if (addStrRep[0] == ':') { - addStrRep++; - len--; + copy = Tcl_DStringValue(&ds); + len = Tcl_DStringLength(&ds); + +#ifdef __WIN32__ + /* + * Certain native path representations on Windows have this special + * prefix to indicate that they are to be treated specially. For + * example extremely long paths, or symlinks + */ + if (*copy == '\\') { + if (0 == strncmp(copy,"\\??\\",4)) { + copy += 4; + len -= 4; + } else if (0 == strncmp(copy,"\\\\?\\",4)) { + copy += 4; + len -= 4; } } - /* Setup the path */ - fsPathPtr->translatedPathPtr = NULL; - fsPathPtr->normPathPtr = Tcl_NewStringObj(addStrRep, len); - Tcl_IncrRefCount(fsPathPtr->normPathPtr); - fsPathPtr->cwdPtr = dirPtr; - Tcl_IncrRefCount(dirPtr); - fsPathPtr->flags = TCLPATH_RELATIVE | TCLPATH_APPENDED; - fsPathPtr->nativePathPtr = NULL; - fsPathPtr->fsRecPtr = NULL; - fsPathPtr->filesystemEpoch = theFilesystemEpoch; +#endif - objPtr->internalRep.otherValuePtr = (VOID *) fsPathPtr; - objPtr->typePtr = &tclFsPathType; - objPtr->bytes = NULL; - objPtr->length = 0; + objPtr = Tcl_NewStringObj(copy,len); + Tcl_DStringFree(&ds); + return objPtr; } + /* *--------------------------------------------------------------------------- * - * MakeFsPathFromRelative -- + * NativeDupInternalRep -- + * + * Duplicate the native representation. * - * Like SetFsPathFromAny, but assumes the given object is an - * absolute normalized path. Only for internal use. - * * Results: - * Standard Tcl error code. + * The copied native representation, or NULL if it is not possible + * to copy the representation. * * Side effects: - * The old representation may be freed, and new memory allocated. + * None. * *--------------------------------------------------------------------------- */ - -static Tcl_Obj* -MakeFsPathFromRelative(interp, objPtr, cwdPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr; /* The object to convert. */ - Tcl_Obj *cwdPtr; /* The object to convert. */ +ClientData +NativeDupInternalRep(clientData) + ClientData clientData; { - FsPath *fsPathPtr; + ClientData copy; + size_t len; - /* Free old representation */ - if (objPtr->typePtr != NULL) { - if (objPtr->bytes == NULL) { - if (objPtr->typePtr->updateStringProc == NULL) { - if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "can't find object", - "string representation", (char *) NULL); - } - return NULL; - } - objPtr->typePtr->updateStringProc(objPtr); - } - if ((objPtr->typePtr->freeIntRepProc) != NULL) { - (*objPtr->typePtr->freeIntRepProc)(objPtr); - } + if (clientData == NULL) { + return NULL; } - fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); - - /* Circular reference, by design */ - fsPathPtr->translatedPathPtr = objPtr; - fsPathPtr->normPathPtr = NULL; - fsPathPtr->flags = 0; - fsPathPtr->cwdPtr = cwdPtr; - Tcl_IncrRefCount(cwdPtr); - fsPathPtr->nativePathPtr = NULL; - fsPathPtr->fsRecPtr = NULL; - fsPathPtr->filesystemEpoch = theFilesystemEpoch; - - objPtr->internalRep.otherValuePtr = (VOID *) fsPathPtr; - objPtr->typePtr = &tclFsPathType; - - return objPtr; +#ifdef __WIN32__ + if (tclWinProcs->useWide) { + /* unicode representation when running on NT/2K/XP */ + len = sizeof(WCHAR) + (wcslen((CONST WCHAR*)clientData) * sizeof(WCHAR)); + } else { + /* ansi representation when running on 95/98/ME */ + len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char)); + } +#else + /* ansi representation when running on Unix/MacOS */ + len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char)); +#endif + + copy = (ClientData) ckalloc(len); + memcpy((VOID*)copy, (VOID*)clientData, len); + return copy; } /* *--------------------------------------------------------------------------- * - * SetFsPathFromAbsoluteNormalized -- + * NativeFreeInternalRep -- + * + * Free a native internal representation, which will be non-NULL. * - * Like SetFsPathFromAny, but assumes the given object is an - * absolute normalized path. Only for internal use. - * * Results: - * Standard Tcl error code. + * None. * * Side effects: - * The old representation may be freed, and new memory allocated. + * Memory is released. * *--------------------------------------------------------------------------- */ - -static int -SetFsPathFromAbsoluteNormalized(interp, objPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr; /* The object to convert. */ +static void +NativeFreeInternalRep(clientData) + ClientData clientData; { - FsPath *fsPathPtr; - - if (objPtr->typePtr == &tclFsPathType) { - return TCL_OK; + ckfree((char*)clientData); +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_FSFileSystemInfo -- + * + * This function returns a list of two elements. The first + * element is the name of the filesystem (e.g. "native" or "vfs"), + * and the second is the particular type of the given path within + * that filesystem. + * + * Results: + * A list of two elements. + * + * Side effects: + * The object may be converted to a path type. + * + *--------------------------------------------------------------------------- + */ +Tcl_Obj* +Tcl_FSFileSystemInfo(pathObjPtr) + Tcl_Obj* pathObjPtr; +{ + Tcl_Obj *resPtr; + Tcl_FSFilesystemPathTypeProc *proc; + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr); + + if (fsPtr == NULL) { + return NULL; } - /* Free old representation */ - if (objPtr->typePtr != NULL) { - if (objPtr->bytes == NULL) { - if (objPtr->typePtr->updateStringProc == NULL) { - if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "can't find object", - "string representation", (char *) NULL); - } - return TCL_ERROR; - } - objPtr->typePtr->updateStringProc(objPtr); - } - if ((objPtr->typePtr->freeIntRepProc) != NULL) { - (*objPtr->typePtr->freeIntRepProc)(objPtr); + resPtr = Tcl_NewListObj(0,NULL); + + Tcl_ListObjAppendElement(NULL, resPtr, + Tcl_NewStringObj(fsPtr->typeName,-1)); + + proc = fsPtr->filesystemPathTypeProc; + if (proc != NULL) { + Tcl_Obj *typePtr = (*proc)(pathObjPtr); + if (typePtr != NULL) { + Tcl_ListObjAppendElement(NULL, resPtr, typePtr); } } - - fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); - /* It's a pure normalized absolute path */ - fsPathPtr->translatedPathPtr = NULL; - fsPathPtr->normPathPtr = objPtr; - fsPathPtr->flags = 0; - fsPathPtr->cwdPtr = NULL; - fsPathPtr->nativePathPtr = NULL; - fsPathPtr->fsRecPtr = NULL; - fsPathPtr->filesystemEpoch = theFilesystemEpoch; - - objPtr->internalRep.otherValuePtr = (VOID *) fsPathPtr; - objPtr->typePtr = &tclFsPathType; - - return TCL_OK; + + return resPtr; } /* *--------------------------------------------------------------------------- * - * SetFsPathFromAny -- + * Tcl_FSPathSeparator -- * - * This function tries to convert the given Tcl_Obj to a valid - * Tcl path type. - * - * The filename may begin with "~" (to indicate current user's - * home directory) or "~" (to indicate any user's home - * directory). + * This function returns the separator to be used for a given + * path. The object returned should have a refCount of zero * * Results: - * Standard Tcl error code. + * A Tcl object, with a refCount of zero. If the caller + * needs to retain a reference to the object, it should + * call Tcl_IncrRefCount. * * Side effects: - * The old representation may be freed, and new memory allocated. + * The path object may be converted to a path type. * *--------------------------------------------------------------------------- */ - -static int -SetFsPathFromAny(interp, objPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr; /* The object to convert. */ +Tcl_Obj* +Tcl_FSPathSeparator(pathObjPtr) + Tcl_Obj* pathObjPtr; { - int len; - FsPath *fsPathPtr; - Tcl_Obj *transPtr; - char *name; + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr); - if (objPtr->typePtr == &tclFsPathType) { - return TCL_OK; + if (fsPtr == NULL) { + return NULL; + } + if (fsPtr->filesystemSeparatorProc != NULL) { + return (*fsPtr->filesystemSeparatorProc)(pathObjPtr); } - /* - * First step is to translate the filename. This is similar to - * Tcl_TranslateFilename, but shouldn't convert everything to - * windows backslashes on that platform. The current - * implementation of this piece is a slightly optimised version - * of the various Tilde/Split/Join stuff to avoid multiple - * split/join operations. - * - * We remove any trailing directory separator. - * - * However, the split/join routines are quite complex, and - * one has to make sure not to break anything on Unix, Win - * or MacOS (fCmd.test, fileName.test and cmdAH.test exercise - * most of the code). - */ - name = Tcl_GetStringFromObj(objPtr,&len); + return NULL; +} + +/* + *--------------------------------------------------------------------------- + * + * NativeFilesystemSeparator -- + * + * This function is part of the native filesystem support, and + * returns the separator for the given path. + * + * Results: + * String object containing the separator character. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +static Tcl_Obj* +NativeFilesystemSeparator(pathObjPtr) + Tcl_Obj* pathObjPtr; +{ + char *separator = NULL; /* lint */ + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + separator = "/"; + break; + case TCL_PLATFORM_WINDOWS: + separator = "\\"; + break; + case TCL_PLATFORM_MAC: + separator = ":"; + break; + } + return Tcl_NewStringObj(separator,1); +} - /* - * Handle tilde substitutions, if needed. - */ - if (name[0] == '~') { - char *expandedUser; - Tcl_DString temp; - int split; - char separator='/'; - - if (tclPlatform==TCL_PLATFORM_MAC) { - if (strchr(name, ':') != NULL) separator = ':'; - } - - split = FindSplitPos(name, &separator); - if (split != len) { - /* We have multiple pieces '~user/foo/bar...' */ - name[split] = '\0'; - } - /* Do some tilde substitution */ - if (name[1] == '\0') { - /* We have just '~' */ - CONST char *dir; - Tcl_DString dirString; - if (split != len) { name[split] = separator; } - - dir = TclGetEnv("HOME", &dirString); - if (dir == NULL) { - if (interp) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't find HOME environment ", - "variable to expand path", (char *) NULL); - } - return TCL_ERROR; - } - Tcl_DStringInit(&temp); - Tcl_JoinPath(1, &dir, &temp); - Tcl_DStringFree(&dirString); - } else { - /* We have a user name '~user' */ - Tcl_DStringInit(&temp); - if (TclpGetUserHome(name+1, &temp) == NULL) { - if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "user \"", (name+1), - "\" doesn't exist", (char *) NULL); - } - Tcl_DStringFree(&temp); - if (split != len) { name[split] = separator; } - return TCL_ERROR; - } - if (split != len) { name[split] = separator; } - } - - expandedUser = Tcl_DStringValue(&temp); - transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp)); +/* Everything from here on is contained in this obsolete ifdef */ +#ifdef USE_OBSOLETE_FS_HOOKS + +/* + *---------------------------------------------------------------------- + * + * TclStatInsertProc -- + * + * Insert the passed procedure pointer at the head of the list of + * functions which are used during a call to 'TclStat(...)'. The + * passed function should behave exactly like 'TclStat' when called + * during that time (see 'TclStat(...)' for more information). + * The function will be added even if it already in the list. + * + * Results: + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list + * could not be allocated. + * + * Side effects: + * Memory allocated and modifies the link list for 'TclStat' + * functions. + * + *---------------------------------------------------------------------- + */ - if (split != len) { - /* Join up the tilde substitution with the rest */ - if (name[split+1] == separator) { +int +TclStatInsertProc (proc) + TclStatProc_ *proc; +{ + int retVal = TCL_ERROR; - /* - * Somewhat tricky case like ~//foo/bar. - * Make use of Split/Join machinery to get it right. - * Assumes all paths beginning with ~ are part of the - * native filesystem. - */ + if (proc != NULL) { + StatProc *newStatProcPtr; - int objc; - Tcl_Obj **objv; - Tcl_Obj *parts = TclpNativeSplitPath(objPtr, NULL); - Tcl_ListObjGetElements(NULL, parts, &objc, &objv); - /* Skip '~'. It's replaced by its expansion */ - objc--; objv++; - while (objc--) { - TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++)); - } - Tcl_DecrRefCount(parts); - } else { - /* Simple case. "rest" is relative path. Just join it. */ - Tcl_Obj *rest = Tcl_NewStringObj(name+split+1,-1); - transPtr = Tcl_FSJoinToPath(transPtr, 1, &rest); - } - } - Tcl_DStringFree(&temp); - } else { - transPtr = Tcl_FSJoinToPath(objPtr,0,NULL); - } + newStatProcPtr = (StatProc *)ckalloc(sizeof(StatProc)); - /* - * 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 = transPtr; - Tcl_IncrRefCount(fsPathPtr->translatedPathPtr); - fsPathPtr->normPathPtr = NULL; - fsPathPtr->flags = 0; - fsPathPtr->cwdPtr = NULL; - fsPathPtr->nativePathPtr = NULL; - fsPathPtr->fsRecPtr = NULL; - fsPathPtr->filesystemEpoch = theFilesystemEpoch; + if (newStatProcPtr != NULL) { + newStatProcPtr->proc = proc; + Tcl_MutexLock(&obsoleteFsHookMutex); + newStatProcPtr->nextPtr = statProcList; + statProcList = newStatProcPtr; + Tcl_MutexUnlock(&obsoleteFsHookMutex); - /* - * Free old representation before installing our new one. - */ - if (objPtr->typePtr != NULL && objPtr->typePtr->freeIntRepProc != NULL) { - (objPtr->typePtr->freeIntRepProc)(objPtr); + retVal = TCL_OK; + } } - objPtr->internalRep.otherValuePtr = (VOID *) fsPathPtr; - objPtr->typePtr = &tclFsPathType; - return TCL_OK; + return (retVal); } /* - *--------------------------------------------------------------------------- + *---------------------------------------------------------------------- * - * Tcl_FSNewNativePath -- + * TclStatDeleteProc -- * - * This function 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 is to be used at the Tcl level, then calling - * this function is an efficient way of creating the appropriate - * path object type. - * - * Any memory which is allocated for 'clientData' should be retained - * until clientData is passed to the filesystem's freeInternalRepProc - * when it can be freed. The built in platform-specific filesystems - * use 'ckalloc' to allocate clientData, and ckfree to free it. + * Removed the passed function pointer from the list of 'TclStat' + * functions. Ensures that the built-in stat function is not + * removvable. * * Results: - * NULL or a valid path object pointer, with refCount zero. + * TCL_OK if the procedure pointer was successfully removed, + * TCL_ERROR otherwise. * * Side effects: - * New memory may be allocated. + * Memory is deallocated and the respective list updated. * - *--------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -Tcl_Obj * -Tcl_FSNewNativePath(fromFilesystem, clientData) - Tcl_Filesystem* fromFilesystem; - ClientData clientData; +int +TclStatDeleteProc (proc) + TclStatProc_ *proc; { - Tcl_Obj *objPtr; - FsPath *fsPathPtr; - FilesystemRecord *fsFromPtr; - Tcl_FSInternalToNormalizedProc *proc; - int epoch; - - fsFromPtr = GetFilesystemRecord(fromFilesystem, &epoch); - - if (fsFromPtr == NULL) { - return NULL; - } - - proc = fsFromPtr->fsPtr->internalToNormalizedProc; + int retVal = TCL_ERROR; + StatProc *tmpStatProcPtr; + StatProc *prevStatProcPtr = NULL; - if (proc == NULL) { - return NULL; - } - - objPtr = (*proc)(clientData); - if (objPtr == NULL) { - return NULL; - } - - /* - * Free old representation; shouldn't normally be any, - * but best to be safe. + Tcl_MutexLock(&obsoleteFsHookMutex); + tmpStatProcPtr = statProcList; + /* + * Traverse the 'statProcList' looking for the particular node + * whose 'proc' member matches 'proc' and remove that one from + * the list. Ensure that the "default" node cannot be removed. */ - if (objPtr->typePtr != NULL) { - if (objPtr->bytes == NULL) { - if (objPtr->typePtr->updateStringProc == NULL) { - return NULL; + + while ((retVal == TCL_ERROR) && (tmpStatProcPtr != NULL)) { + if (tmpStatProcPtr->proc == proc) { + if (prevStatProcPtr == NULL) { + statProcList = tmpStatProcPtr->nextPtr; + } else { + prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr; } - objPtr->typePtr->updateStringProc(objPtr); - } - if ((objPtr->typePtr->freeIntRepProc) != NULL) { - (*objPtr->typePtr->freeIntRepProc)(objPtr); + + ckfree((char *)tmpStatProcPtr); + + retVal = TCL_OK; + } else { + prevStatProcPtr = tmpStatProcPtr; + tmpStatProcPtr = tmpStatProcPtr->nextPtr; } } - - fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); - fsPathPtr->translatedPathPtr = NULL; - /* Circular reference, by design */ - fsPathPtr->normPathPtr = objPtr; - fsPathPtr->flags = 0; - fsPathPtr->cwdPtr = NULL; - fsPathPtr->nativePathPtr = clientData; - fsPathPtr->fsRecPtr = fsFromPtr; - /* We must increase the refCount for this filesystem. */ - fsPathPtr->fsRecPtr->fileRefCount++; - fsPathPtr->filesystemEpoch = epoch; - objPtr->internalRep.otherValuePtr = (VOID *) fsPathPtr; - objPtr->typePtr = &tclFsPathType; - return objPtr; + Tcl_MutexUnlock(&obsoleteFsHookMutex); + return (retVal); } + +/* + *---------------------------------------------------------------------- + * + * TclAccessInsertProc -- + * + * Insert the passed procedure pointer at the head of the list of + * functions which are used during a call to 'TclAccess(...)'. + * The passed function should behave exactly like 'TclAccess' when + * called during that time (see 'TclAccess(...)' for more + * information). The function will be added even if it already in + * the list. + * + * Results: + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list + * could not be allocated. + * + * Side effects: + * Memory allocated and modifies the link list for 'TclAccess' + * functions. + * + *---------------------------------------------------------------------- + */ -static void -FreeFsPathInternalRep(pathObjPtr) - Tcl_Obj *pathObjPtr; /* Path object with internal rep to free. */ +int +TclAccessInsertProc(proc) + TclAccessProc_ *proc; { - register FsPath* fsPathPtr = - (FsPath*) pathObjPtr->internalRep.otherValuePtr; + int retVal = TCL_ERROR; - if (fsPathPtr->translatedPathPtr != NULL) { - if (fsPathPtr->translatedPathPtr != pathObjPtr) { - Tcl_DecrRefCount(fsPathPtr->translatedPathPtr); - } - } - if (fsPathPtr->normPathPtr != NULL) { - if (fsPathPtr->normPathPtr != pathObjPtr) { - Tcl_DecrRefCount(fsPathPtr->normPathPtr); - } - fsPathPtr->normPathPtr = NULL; - } - if (fsPathPtr->cwdPtr != NULL) { - Tcl_DecrRefCount(fsPathPtr->cwdPtr); - } - if (fsPathPtr->nativePathPtr != NULL) { - if (fsPathPtr->fsRecPtr != NULL) { - if (fsPathPtr->fsRecPtr->fsPtr->freeInternalRepProc != NULL) { - (*fsPathPtr->fsRecPtr->fsPtr - ->freeInternalRepProc)(fsPathPtr->nativePathPtr); - fsPathPtr->nativePathPtr = NULL; - } - } - } - if (fsPathPtr->fsRecPtr != NULL) { - fsPathPtr->fsRecPtr->fileRefCount--; - if (fsPathPtr->fsRecPtr->fileRefCount <= 0) { - /* It has been unregistered already */ - ckfree((char *)fsPathPtr->fsRecPtr); - } - } - - ckfree((char*) fsPathPtr); -} + if (proc != NULL) { + AccessProc *newAccessProcPtr; -static void -DupFsPathInternalRep(srcPtr, copyPtr) - Tcl_Obj *srcPtr; /* Path obj with internal rep to copy. */ - Tcl_Obj *copyPtr; /* Path obj with internal rep to set. */ -{ - register FsPath* srcFsPathPtr = - (FsPath*) srcPtr->internalRep.otherValuePtr; - register FsPath* copyFsPathPtr = - (FsPath*) ckalloc((unsigned)sizeof(FsPath)); - Tcl_FSDupInternalRepProc *dupProc; - - copyPtr->internalRep.otherValuePtr = (VOID *) copyFsPathPtr; + newAccessProcPtr = (AccessProc *)ckalloc(sizeof(AccessProc)); - if (srcFsPathPtr->translatedPathPtr != NULL) { - copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr; - if (copyFsPathPtr->translatedPathPtr != copyPtr) { - Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); - } - } else { - copyFsPathPtr->translatedPathPtr = NULL; - } - - if (srcFsPathPtr->normPathPtr != NULL) { - copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; - if (copyFsPathPtr->normPathPtr != copyPtr) { - Tcl_IncrRefCount(copyFsPathPtr->normPathPtr); - } - } else { - copyFsPathPtr->normPathPtr = NULL; - } - - if (srcFsPathPtr->cwdPtr != NULL) { - copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr; - Tcl_IncrRefCount(copyFsPathPtr->cwdPtr); - } else { - copyFsPathPtr->cwdPtr = NULL; - } + if (newAccessProcPtr != NULL) { + newAccessProcPtr->proc = proc; + Tcl_MutexLock(&obsoleteFsHookMutex); + newAccessProcPtr->nextPtr = accessProcList; + accessProcList = newAccessProcPtr; + Tcl_MutexUnlock(&obsoleteFsHookMutex); - copyFsPathPtr->flags = srcFsPathPtr->flags; - - if (srcFsPathPtr->fsRecPtr != NULL - && srcFsPathPtr->nativePathPtr != NULL) { - dupProc = srcFsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc; - if (dupProc != NULL) { - copyFsPathPtr->nativePathPtr = - (*dupProc)(srcFsPathPtr->nativePathPtr); - } else { - copyFsPathPtr->nativePathPtr = NULL; + retVal = TCL_OK; } - } else { - copyFsPathPtr->nativePathPtr = NULL; - } - copyFsPathPtr->fsRecPtr = srcFsPathPtr->fsRecPtr; - copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch; - if (copyFsPathPtr->fsRecPtr != NULL) { - copyFsPathPtr->fsRecPtr->fileRefCount++; } - copyPtr->typePtr = &tclFsPathType; + return (retVal); } /* - *--------------------------------------------------------------------------- + *---------------------------------------------------------------------- * - * Tcl_FSGetTranslatedPath -- + * TclAccessDeleteProc -- * - * 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 (if it is non-NULL) + * Removed the passed function pointer from the list of 'TclAccess' + * functions. Ensures that the built-in access function is not + * removvable. * * Results: - * NULL or a valid Tcl_Obj pointer. + * TCL_OK if the procedure pointer was successfully removed, + * TCL_ERROR otherwise. * * Side effects: - * Only those of 'Tcl_FSConvertToPathType' + * Memory is deallocated and the respective list updated. * - *--------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -Tcl_Obj* -Tcl_FSGetTranslatedPath(interp, pathPtr) - Tcl_Interp *interp; - Tcl_Obj* pathPtr; +int +TclAccessDeleteProc(proc) + TclAccessProc_ *proc; { - register FsPath* srcFsPathPtr; - if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { - return NULL; - } - srcFsPathPtr = (FsPath*) pathPtr->internalRep.otherValuePtr; - if (srcFsPathPtr->translatedPathPtr == NULL) { - if (srcFsPathPtr->flags != 0) { - return Tcl_FSGetNormalizedPath(interp, pathPtr); - } - /* - * It is a pure absolute, normalized path object. - * This is something like being a 'pure list'. The - * object's string, translatedPath and normalizedPath - * are all identical. - */ - return srcFsPathPtr->normPathPtr; - } else { - /* It is an ordinary path object */ - return srcFsPathPtr->translatedPathPtr; + int retVal = TCL_ERROR; + AccessProc *tmpAccessProcPtr; + AccessProc *prevAccessProcPtr = NULL; + + /* + * Traverse the 'accessProcList' looking for the particular node + * whose 'proc' member matches 'proc' and remove that one from + * the list. Ensure that the "default" node cannot be removed. + */ + + Tcl_MutexLock(&obsoleteFsHookMutex); + tmpAccessProcPtr = accessProcList; + while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != NULL)) { + if (tmpAccessProcPtr->proc == proc) { + if (prevAccessProcPtr == NULL) { + accessProcList = tmpAccessProcPtr->nextPtr; + } else { + prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr; + } + + ckfree((char *)tmpAccessProcPtr); + + retVal = TCL_OK; + } else { + prevAccessProcPtr = tmpAccessProcPtr; + tmpAccessProcPtr = tmpAccessProcPtr->nextPtr; + } } + Tcl_MutexUnlock(&obsoleteFsHookMutex); + + return (retVal); } /* - *--------------------------------------------------------------------------- + *---------------------------------------------------------------------- * - * Tcl_FSGetTranslatedStringPath -- + * TclOpenFileChannelInsertProc -- * - * 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) + * Insert the passed procedure pointer at the head of the list of + * functions which are used during a call to + * 'Tcl_OpenFileChannel(...)'. The passed function should behave + * exactly like 'Tcl_OpenFileChannel' when called during that time + * (see 'Tcl_OpenFileChannel(...)' for more information). The + * function will be added even if it already in the list. * * Results: - * NULL or a valid string. + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list + * could not be allocated. * * Side effects: - * Only those of 'Tcl_FSConvertToPathType' + * Memory allocated and modifies the link list for + * 'Tcl_OpenFileChannel' functions. * - *--------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -CONST char* -Tcl_FSGetTranslatedStringPath(interp, pathPtr) - Tcl_Interp *interp; - Tcl_Obj* pathPtr; + +int +TclOpenFileChannelInsertProc(proc) + TclOpenFileChannelProc_ *proc; { - Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); - if (transPtr == NULL) { - return NULL; - } else { - return Tcl_GetString(transPtr); + int retVal = TCL_ERROR; + + if (proc != NULL) { + OpenFileChannelProc *newOpenFileChannelProcPtr; + + newOpenFileChannelProcPtr = + (OpenFileChannelProc *)ckalloc(sizeof(OpenFileChannelProc)); + + if (newOpenFileChannelProcPtr != NULL) { + newOpenFileChannelProcPtr->proc = proc; + Tcl_MutexLock(&obsoleteFsHookMutex); + newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; + openFileChannelProcList = newOpenFileChannelProcPtr; + Tcl_MutexUnlock(&obsoleteFsHookMutex); + + retVal = TCL_OK; + } } + + return (retVal); } /* - *--------------------------------------------------------------------------- + *---------------------------------------------------------------------- * - * Tcl_FSGetNormalizedPath -- + * TclOpenFileChannelDeleteProc -- * - * This important function attempts to extract from the given Tcl_Obj - * a unique normalised path representation, whose string value can - * be used as a unique identifier for the file. + * Removed the passed function pointer from the list of + * 'Tcl_OpenFileChannel' functions. Ensures that the built-in + * open file channel function is not removable. * * Results: - * NULL or a valid path object pointer. + * TCL_OK if the procedure pointer was successfully removed, + * TCL_ERROR otherwise. * * Side effects: - * New memory may be allocated. The Tcl 'errno' may be modified - * in the process of trying to examine various path possibilities. + * Memory is deallocated and the respective list updated. * - *--------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -Tcl_Obj* -Tcl_FSGetNormalizedPath(interp, pathObjPtr) - Tcl_Interp *interp; - Tcl_Obj* pathObjPtr; +int +TclOpenFileChannelDeleteProc(proc) + TclOpenFileChannelProc_ *proc; { - register FsPath* fsPathPtr; - if (Tcl_FSConvertToPathType(interp, pathObjPtr) != TCL_OK) { - return NULL; - } - fsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr; + int retVal = TCL_ERROR; + OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList; + OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL; - if (fsPathPtr->flags != 0) { - /* - * This is a special path object which is the result of - * something like 'file join' - */ - Tcl_Obj *dir, *copy; - int cwdLen; - int pathType; - CONST char *cwdStr; - - pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); - dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr); - if (dir == NULL) { - return NULL; - } - if (pathObjPtr->bytes == NULL) { - UpdateStringOfFsPath(pathObjPtr); - } - copy = Tcl_DuplicateObj(dir); - Tcl_IncrRefCount(copy); - Tcl_IncrRefCount(dir); - /* We now own a reference on both 'dir' and 'copy' */ - - cwdStr = Tcl_GetStringFromObj(copy, &cwdLen); - /* - * Should we perhaps use 'Tcl_FSPathSeparator'? - * But then what about the Windows special case? - * Perhaps we should just check if cwd is a root volume. - * We should never get cwdLen == 0 in this code path. - */ - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - if (cwdStr[cwdLen-1] != '/') { - Tcl_AppendToObj(copy, "/", 1); - cwdLen++; - } - break; - case TCL_PLATFORM_WINDOWS: - if (cwdStr[cwdLen-1] != '/' - && cwdStr[cwdLen-1] != '\\') { - Tcl_AppendToObj(copy, "/", 1); - cwdLen++; - } - break; - case TCL_PLATFORM_MAC: - if (cwdStr[cwdLen-1] != ':') { - Tcl_AppendToObj(copy, ":", 1); - cwdLen++; - } - break; - } - Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr); - /* - * Normalize the combined string, but only starting after - * the end of the previously normalized 'dir'. This should - * be much faster! We use 'cwdLen-1' so that we are - * already pointing at the dir-separator that we know about. - * The normalization code will actually start off directly - * after that separator. - */ - TclNormalizeToUniquePath(interp, copy, cwdLen-1); - /* Now we need to construct the new path object */ - - if (pathType == TCL_PATH_RELATIVE) { - register FsPath* origDirFsPathPtr; - Tcl_Obj *origDir = fsPathPtr->cwdPtr; - origDirFsPathPtr = (FsPath*) origDir->internalRep.otherValuePtr; - - fsPathPtr->cwdPtr = origDirFsPathPtr->cwdPtr; - Tcl_IncrRefCount(fsPathPtr->cwdPtr); - - Tcl_DecrRefCount(fsPathPtr->normPathPtr); - fsPathPtr->normPathPtr = copy; - /* That's our reference to copy used */ - Tcl_DecrRefCount(dir); - Tcl_DecrRefCount(origDir); - } else { - Tcl_DecrRefCount(fsPathPtr->cwdPtr); - fsPathPtr->cwdPtr = NULL; - Tcl_DecrRefCount(fsPathPtr->normPathPtr); - fsPathPtr->normPathPtr = copy; - /* That's our reference to copy used */ - Tcl_DecrRefCount(dir); - } - fsPathPtr->flags = 0; - } - /* Ensure cwd hasn't changed */ - if (fsPathPtr->cwdPtr != NULL) { - if (!FsCwdPointerEquals(fsPathPtr->cwdPtr)) { - if (pathObjPtr->bytes == NULL) { - UpdateStringOfFsPath(pathObjPtr); - } - FreeFsPathInternalRep(pathObjPtr); - pathObjPtr->typePtr = NULL; - if (Tcl_ConvertToType(interp, pathObjPtr, - &tclFsPathType) != TCL_OK) { - return NULL; - } - fsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr; - } else if (fsPathPtr->normPathPtr == NULL) { - int cwdLen; - Tcl_Obj *copy; - CONST char *cwdStr; - - copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr); - Tcl_IncrRefCount(copy); - cwdStr = Tcl_GetStringFromObj(copy, &cwdLen); - /* - * Should we perhaps use 'Tcl_FSPathSeparator'? - * But then what about the Windows special case? - * Perhaps we should just check if cwd is a root volume. - * We should never get cwdLen == 0 in this code path. - */ - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - if (cwdStr[cwdLen-1] != '/') { - Tcl_AppendToObj(copy, "/", 1); - cwdLen++; - } - break; - case TCL_PLATFORM_WINDOWS: - if (cwdStr[cwdLen-1] != '/' - && cwdStr[cwdLen-1] != '\\') { - Tcl_AppendToObj(copy, "/", 1); - cwdLen++; - } - break; - case TCL_PLATFORM_MAC: - if (cwdStr[cwdLen-1] != ':') { - Tcl_AppendToObj(copy, ":", 1); - cwdLen++; - } - break; + /* + * Traverse the 'openFileChannelProcList' looking for the particular + * node whose 'proc' member matches 'proc' and remove that one from + * the list. + */ + + Tcl_MutexLock(&obsoleteFsHookMutex); + tmpOpenFileChannelProcPtr = openFileChannelProcList; + while ((retVal == TCL_ERROR) && + (tmpOpenFileChannelProcPtr != NULL)) { + if (tmpOpenFileChannelProcPtr->proc == proc) { + if (prevOpenFileChannelProcPtr == NULL) { + openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr; + } else { + prevOpenFileChannelProcPtr->nextPtr = + tmpOpenFileChannelProcPtr->nextPtr; } - Tcl_AppendObjToObj(copy, pathObjPtr); - /* - * Normalize the combined string, but only starting after - * the end of the previously normalized 'dir'. This should - * be much faster! - */ - TclNormalizeToUniquePath(interp, copy, cwdLen-1); - fsPathPtr->normPathPtr = copy; + + ckfree((char *)tmpOpenFileChannelProcPtr); + + retVal = TCL_OK; + } else { + prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr; + tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr; } } - if (fsPathPtr->normPathPtr == NULL) { - int relative = 0; - /* - * Since normPathPtr is NULL, but this is a valid path - * object, we know that the translatedPathPtr cannot be NULL. - */ - Tcl_Obj *absolutePath = fsPathPtr->translatedPathPtr; - char *path = Tcl_GetString(absolutePath); - - /* - * 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) == TCL_PATH_RELATIVE)) { - Tcl_Obj *cwd = Tcl_FSGetCwd(interp); + Tcl_MutexUnlock(&obsoleteFsHookMutex); + + return (retVal); +} +#endif /* USE_OBSOLETE_FS_HOOKS */ + + +/* + * Prototypes for procedures defined later in this file. + */ + +static void DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr)); +static void FreeFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *listPtr)); +static void UpdateStringOfFsPath _ANSI_ARGS_((Tcl_Obj *objPtr)); +static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static int FindSplitPos _ANSI_ARGS_((char *path, char *separator)); + + + +/* + * Define the 'path' object type, which Tcl uses to represent + * file paths internally. + */ +Tcl_ObjType tclFsPathType = { + "path", /* name */ + FreeFsPathInternalRep, /* freeIntRepProc */ + DupFsPathInternalRep, /* dupIntRepProc */ + UpdateStringOfFsPath, /* updateStringProc */ + SetFsPathFromAny /* setFromAnyProc */ +}; + +/* + * struct FsPath -- + * + * Internal representation of a Tcl_Obj of "path" type. This + * can be used to represent relative or absolute paths, and has + * certain optimisations when used to represent paths which are + * already normalized and absolute. + * + * Note that 'normPathPtr' can be a circular reference to the + * container Tcl_Obj of this FsPath. + */ +typedef struct FsPath { + 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 + * string rep is already both translated + * and normalized. */ + Tcl_Obj *normPathPtr; /* Normalized absolute path, without + * ., .. or ~user sequences. If the + * Tcl_Obj containing + * this FsPath is already normalized, + * this may be a circular reference back + * to the container. If that is NOT the + * case, we have a refCount on the object. */ + Tcl_Obj *cwdPtr; /* If null, path is absolute, else + * this points to the cwd object used + * for this path. We have a refCount + * on the object. */ + int flags; /* Flags to describe interpretation */ + ClientData nativePathPtr; /* Native representation of this path, + * which is filesystem dependent. */ + int filesystemEpoch; /* Used to ensure the path representation + * was generated during the correct + * filesystem epoch. The epoch changes + * when filesystem-mounts are changed. */ + struct FilesystemRecord *fsRecPtr; + /* Pointer to the filesystem record + * entry to use for this path. */ +} FsPath; + +/* + * Define some macros to give us convenient access to path-object + * specific fields. + */ +#define PATHOBJ(objPtr) (objPtr->internalRep.otherValuePtr) +#define PATHFLAGS(objPtr) \ + (((FsPath*)(objPtr->internalRep.otherValuePtr))->flags) + +#define TCLPATH_APPENDED 1 +#define TCLPATH_RELATIVE 2 + +/* + *---------------------------------------------------------------------- + * + * Tcl_FSGetPathType -- + * + * Determines whether a given path is relative to the current + * directory, relative to the current volume, or absolute. + * + * Results: + * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or + * TCL_PATH_VOLUME_RELATIVE. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_PathType +Tcl_FSGetPathType(pathObjPtr) + Tcl_Obj *pathObjPtr; +{ + return FSGetPathType(pathObjPtr, NULL, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- + */ - if (cwd == NULL) { - return NULL; +Tcl_PathType +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*) PATHOBJ(pathObjPtr); + if (fsPathPtr->cwdPtr != NULL) { + if (PATHFLAGS(pathObjPtr) == 0) { + return TCL_PATH_RELATIVE; } - - absolutePath = Tcl_FSJoinToPath(cwd, 1, &absolutePath); - Tcl_IncrRefCount(absolutePath); - Tcl_DecrRefCount(cwd); - - relative = 1; - } - /* Already has refCount incremented */ - fsPathPtr->normPathPtr = FSNormalizeAbsolutePath(interp, absolutePath); - if (!strcmp(Tcl_GetString(fsPathPtr->normPathPtr), - Tcl_GetString(pathObjPtr))) { - /* - * The path was already normalized. - * Get rid of the duplicate. - */ - Tcl_DecrRefCount(fsPathPtr->normPathPtr); - /* - * We do *not* increment the refCount for - * this circular reference - */ - fsPathPtr->normPathPtr = pathObjPtr; - } - if (relative) { - /* 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); - fsPathPtr->cwdPtr = cwdPathPtr; - Tcl_IncrRefCount(fsPathPtr->cwdPtr); - Tcl_MutexUnlock(&cwdMutex); + return FSGetPathType(fsPathPtr->cwdPtr, filesystemPtrPtr, + driveNameLengthPtr); + } else { + return GetPathType(pathObjPtr, filesystemPtrPtr, + driveNameLengthPtr, NULL); } } - return fsPathPtr->normPathPtr; } /* *--------------------------------------------------------------------------- * - * Tcl_FSGetInternalRep -- + * Tcl_FSJoinPath -- * - * Extract the internal representation of a given path object, - * in the given filesystem. If the path object belongs to a - * different filesystem, we return NULL. + * 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. * - * If the internal representation is currently NULL, we attempt - * to generate it, by calling the filesystem's - * 'Tcl_FSCreateInternalRepProc'. - * * Results: - * NULL or a valid internal representation. + * Returns object with refCount of zero, (or if non-zero, it has + * references elsewhere in Tcl). Either way, the caller must + * increment its refCount before use. * * Side effects: - * An attempt may be made to convert the object. + * None. * *--------------------------------------------------------------------------- */ - -ClientData -Tcl_FSGetInternalRep(pathObjPtr, fsPtr) - Tcl_Obj* pathObjPtr; - Tcl_Filesystem *fsPtr; +Tcl_Obj* +Tcl_FSJoinPath(listObj, elements) + Tcl_Obj *listObj; + int elements; { - register FsPath* srcFsPathPtr; + Tcl_Obj *res; + int i; + Tcl_Filesystem *fsPtr = NULL; - if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) { - return 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 time joining null elements to the path + */ + if (elements > listTest) { + elements = listTest; + } } - srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr; - /* - * We will only return the native representation for the caller's - * filesystem. Otherwise we will simply return NULL. This means - * that there must be a unique bi-directional mapping between paths - * and filesystems, and that this mapping will not allow 'remapped' - * files -- files which are in one filesystem but mapped into - * another. Another way of putting this is that 'stacked' - * filesystems are not allowed. We recognise that this is a - * potentially useful feature for the future. - * - * Even something simple like a 'pass through' filesystem which - * logs all activity and passes the calls onto the native system - * would be nice, but not easily achievable with the current - * implementation. - */ - if (srcFsPathPtr->fsRecPtr == NULL) { + if (elements == 2) { /* - * This only usually happens in wrappers like TclpStat which - * create a string object and pass it to TclpObjStat. Code - * which calls the Tcl_FS.. functions should always have a - * filesystem already set. Whether this code path is legal or - * not depends on whether we decide to allow external code to - * call the native filesystem directly. It is at least safer - * to allow this sub-optimal routing. + * This is a special case where we can be much more + * efficient */ - Tcl_FSGetFileSystemForPath(pathObjPtr); + Tcl_Obj *base; + Tcl_ListObjIndex(NULL, listObj, 0, &base); /* - * If we fail through here, then the path is probably not a - * valid path in the filesystsem, and is most likely to be a - * use of the empty path "" via a direct call to one of the - * objectified interfaces (e.g. from the Tcl testsuite). + * There is only any value in doing this if the first object is + * of path type, otherwise we'll never actually get any + * efficiency benefit elsewhere in the code (from re-using the + * normalized representation of the base object). */ - srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr; - if (srcFsPathPtr->fsRecPtr == NULL) { - return NULL; + if (base->typePtr == &tclFsPathType + && !(base->bytes != NULL && base->bytes[0] == '\0')) { + Tcl_Obj *tail; + Tcl_PathType type; + Tcl_ListObjIndex(NULL, listObj, 1, &tail); + type = GetPathType(tail, NULL, NULL, NULL); + if (type == TCL_PATH_RELATIVE) { + CONST char *str; + int len; + str = Tcl_GetStringFromObj(tail,&len); + if (len == 0) { + /* + * This happens if we try to handle the root volume + * '/'. There's no need to return a special path + * object, when the base itself is just fine! + */ + return base; + } + if (str[0] != '.') { + return TclNewFSPathObj(base, str, len); + } + /* + * Otherwise we don't have an easy join, and + * we must let the more general code below handle + * things + */ + } else { + return tail; + } } } - - if (fsPtr != srcFsPathPtr->fsRecPtr->fsPtr) { + + res = Tcl_NewObj(); + + for (i = 0; i < elements; i++) { + Tcl_Obj *elt; + int driveNameLength; + Tcl_PathType type; + char *strElt; + int strEltLen; + int length; + char *ptr; + Tcl_Obj *driveName = NULL; + + Tcl_ListObjIndex(NULL, listObj, i, &elt); + strElt = Tcl_GetStringFromObj(elt, &strEltLen); + 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; + } + + ptr = Tcl_GetStringFromObj(res, &length); + /* - * There is still one possibility we should consider; if the - * file belongs to a different filesystem, perhaps it is - * actually linked through to a file in our own filesystem - * which we do care about. The way we can check for this - * is we ask what filesystem this path belongs to. + * Strip off any './' before a tilde, unless this is the + * beginning of the path. */ - Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathObjPtr); - if (actualFs == fsPtr) { - return Tcl_FSGetInternalRep(pathObjPtr, fsPtr); + if (length > 0 && strEltLen > 0) { + if ((strElt[0] == '.') && (strElt[1] == '/') + && (strElt[2] == '~')) { + strElt += 2; + } } - return NULL; - } - if (srcFsPathPtr->nativePathPtr == NULL) { - Tcl_FSCreateInternalRepProc *proc; - proc = srcFsPathPtr->fsRecPtr->fsPtr->createInternalRepProc; + /* + * 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 == &tclNativeFilesystem || fsPtr == NULL) { + TclpNativeJoinPath(res, strElt); + } else { + char separator = '/'; + int needsSep = 0; + + if (fsPtr->filesystemSeparatorProc != NULL) { + Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(res); + if (sep != NULL) { + separator = Tcl_GetString(sep)[0]; + } + } - if (proc == NULL) { - return NULL; + if (length > 0 && ptr[length -1] != '/') { + Tcl_AppendToObj(res, &separator, 1); + length++; + } + Tcl_SetObjLength(res, length + (int) 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); } - srcFsPathPtr->nativePathPtr = (*proc)(pathObjPtr); } - return srcFsPathPtr->nativePathPtr; + return res; } /* *--------------------------------------------------------------------------- * - * Tcl_FSGetNativePath -- + * Tcl_FSConvertToPathType -- * - * This function is for use by the Win/Unix/MacOS native filesystems, - * so that they can easily retrieve the native (char* or TCHAR*) - * representation of a path. Other filesystems will probably - * want to implement similar functions. They basically act as a - * safety net around Tcl_FSGetInternalRep. Normally your file- - * system procedures will always be called with path objects - * already converted to the correct filesystem, but if for - * some reason they are called directly (i.e. by procedures - * not in this file), then one cannot necessarily guarantee that - * the path object pointer is from the correct filesystem. + * This function tries to convert the given Tcl_Obj to a valid + * Tcl path type, taking account of the fact that the cwd may + * have changed even if this object is already supposedly of + * the correct type. * - * Note: in the future it might be desireable to have separate - * versions of this function with different signatures, for - * example Tcl_FSGetNativeMacPath, Tcl_FSGetNativeUnixPath etc. - * Right now, since native paths are all string based, we use just - * one function. On MacOS we could possibly use an FSSpec or - * FSRef as the native representation. - * - * Results: - * NULL or a valid native path. - * - * Side effects: - * See Tcl_FSGetInternalRep. - * - *--------------------------------------------------------------------------- - */ - -CONST char * -Tcl_FSGetNativePath(pathObjPtr) - Tcl_Obj *pathObjPtr; -{ - return (CONST char *)Tcl_FSGetInternalRep(pathObjPtr, &tclNativeFilesystem); -} - -/* - *--------------------------------------------------------------------------- - * - * NativeCreateNativeRep -- - * - * Create a native representation for the given path. + * The filename may begin with "~" (to indicate current user's + * home directory) or "~" (to indicate any user's home + * directory). * * Results: - * None. + * Standard Tcl error code. * * Side effects: - * None. + * The old representation may be freed, and new memory allocated. * *--------------------------------------------------------------------------- */ -static ClientData -NativeCreateNativeRep(pathObjPtr) - Tcl_Obj* pathObjPtr; +int +Tcl_FSConvertToPathType(interp, objPtr) + Tcl_Interp *interp; /* Interpreter in which to store error + * message (if necessary). */ + Tcl_Obj *objPtr; /* Object to convert to a valid, current + * path type. */ { - char *nativePathPtr; - Tcl_DString ds; - Tcl_Obj* validPathObjPtr; - int len; - char *str; - - /* Make sure the normalized path is set */ - validPathObjPtr = Tcl_FSGetNormalizedPath(NULL, pathObjPtr); - - str = Tcl_GetStringFromObj(validPathObjPtr, &len); -#ifdef __WIN32__ - Tcl_WinUtfToTChar(str, len, &ds); - if (tclWinProcs->useWide) { - len = Tcl_DStringLength(&ds) + sizeof(WCHAR); + /* + * While it is bad practice to examine an object's type directly, + * this is actually the best thing to do here. The reason is that + * if we are converting this object to FsPath type for the first + * time, we don't need to worry whether the 'cwd' has changed. + * On the other hand, if this object is already of FsPath type, + * and is a relative path, we do have to worry about the cwd. + * If the cwd has changed, we must recompute the path. + */ + if (objPtr->typePtr == &tclFsPathType) { + FsPath *fsPathPtr = (FsPath*) PATHOBJ(objPtr); + if (fsPathPtr->filesystemEpoch != theFilesystemEpoch) { + if (objPtr->bytes == NULL) { + UpdateStringOfFsPath(objPtr); + } + FreeFsPathInternalRep(objPtr); + objPtr->typePtr = NULL; + return Tcl_ConvertToType(interp, objPtr, &tclFsPathType); + } + return TCL_OK; + /* + * This code is intentionally never reached. Once fs-optimisation + * is complete, it will be removed/replaced + */ + if (fsPathPtr->cwdPtr == NULL) { + return TCL_OK; + } else { + if (TclFSCwdPointerEquals(fsPathPtr->cwdPtr)) { + return TCL_OK; + } else { + if (objPtr->bytes == NULL) { + UpdateStringOfFsPath(objPtr); + } + FreeFsPathInternalRep(objPtr); + objPtr->typePtr = NULL; + return Tcl_ConvertToType(interp, objPtr, &tclFsPathType); + } + } } else { - len = Tcl_DStringLength(&ds) + sizeof(char); + return Tcl_ConvertToType(interp, objPtr, &tclFsPathType); } -#else - Tcl_UtfToExternalDString(NULL, str, len, &ds); - len = Tcl_DStringLength(&ds) + sizeof(char); -#endif - nativePathPtr = ckalloc((unsigned) len); - memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len); - - Tcl_DStringFree(&ds); - return (ClientData)nativePathPtr; } -/* - *--------------------------------------------------------------------------- - * - * TclpNativeToNormalized -- - * - * Convert native format to a normalized path object, with refCount - * of zero. - * - * Results: - * A valid normalized path. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- +/* + * Helper function for SetFsPathFromAny. Returns position of first + * directory delimiter in the path. */ -Tcl_Obj* -TclpNativeToNormalized(clientData) - ClientData clientData; +static int +FindSplitPos(path, separator) + char *path; + char *separator; { - Tcl_DString ds; - Tcl_Obj *objPtr; - CONST char *copy; - int len; - -#ifdef __WIN32__ - Tcl_WinTCharToUtf((CONST char*)clientData, -1, &ds); -#else - Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds); -#endif - - copy = Tcl_DStringValue(&ds); - len = Tcl_DStringLength(&ds); + int count = 0; + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + case TCL_PLATFORM_MAC: + while (path[count] != 0) { + if (path[count] == *separator) { + return count; + } + count++; + } + break; -#ifdef __WIN32__ - /* - * Certain native path representations on Windows have this special - * prefix to indicate that they are to be treated specially. For - * example extremely long paths, or symlinks - */ - if (*copy == '\\') { - if (0 == strncmp(copy,"\\??\\",4)) { - copy += 4; - len -= 4; - } else if (0 == strncmp(copy,"\\\\?\\",4)) { - copy += 4; - len -= 4; - } + case TCL_PLATFORM_WINDOWS: + while (path[count] != 0) { + if (path[count] == *separator || path[count] == '\\') { + return count; + } + count++; + } + break; } -#endif - - objPtr = Tcl_NewStringObj(copy,len); - Tcl_DStringFree(&ds); - - return objPtr; + return count; } - /* *--------------------------------------------------------------------------- * - * NativeDupInternalRep -- - * - * Duplicate the native representation. + * TclNewFSPathObj -- * + * Creates a path object whose string representation is + * '[file join dirPtr addStrRep]', but does so in a way that + * allows for more efficient caching of normalized paths. + * + * Assumptions: + * 'dirPtr' must be an absolute path. + * 'len' may not be zero. + * * Results: - * The copied native representation, or NULL if it is not possible - * to copy the representation. + * The new Tcl object, with refCount zero. * * Side effects: - * None. + * Memory is allocated. 'dirPtr' gets an additional refCount. * *--------------------------------------------------------------------------- */ -static ClientData -NativeDupInternalRep(clientData) - ClientData clientData; -{ - ClientData copy; - size_t len; - - if (clientData == NULL) { - return NULL; - } -#ifdef __WIN32__ - if (tclWinProcs->useWide) { - /* unicode representation when running on NT/2K/XP */ - len = sizeof(WCHAR) + (wcslen((CONST WCHAR*)clientData) * sizeof(WCHAR)); - } else { - /* ansi representation when running on 95/98/ME */ - len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char)); - } -#else - /* ansi representation when running on Unix/MacOS */ - len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char)); -#endif +Tcl_Obj* +TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len) +{ + FsPath *fsPathPtr; + Tcl_Obj *objPtr; - copy = (ClientData) ckalloc(len); - memcpy((VOID*)copy, (VOID*)clientData, len); - return copy; + objPtr = Tcl_NewObj(); + fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); + + if (tclPlatform == TCL_PLATFORM_MAC) { + /* + * Mac relative paths may begin with a directory separator ':'. + * If present, we need to skip this ':' because we assume that + * we can join dirPtr and addStrRep by concatenating them as + * strings (and we ensure that dirPtr is terminated by a ':'). + */ + if (addStrRep[0] == ':') { + addStrRep++; + len--; + } + } + /* Setup the path */ + fsPathPtr->translatedPathPtr = NULL; + fsPathPtr->normPathPtr = Tcl_NewStringObj(addStrRep, len); + Tcl_IncrRefCount(fsPathPtr->normPathPtr); + fsPathPtr->cwdPtr = dirPtr; + Tcl_IncrRefCount(dirPtr); + fsPathPtr->nativePathPtr = NULL; + fsPathPtr->fsRecPtr = NULL; + fsPathPtr->filesystemEpoch = theFilesystemEpoch; + + PATHOBJ(objPtr) = (VOID *) fsPathPtr; + PATHFLAGS(objPtr) = TCLPATH_RELATIVE | TCLPATH_APPENDED; + objPtr->typePtr = &tclFsPathType; + objPtr->bytes = NULL; + objPtr->length = 0; + return objPtr; } /* *--------------------------------------------------------------------------- * - * NativePathInFilesystem -- + * TclFSMakePathRelative -- * - * Any path object is acceptable to the native filesystem, by - * default (we will throw errors when illegal paths are actually - * tried to be used). + * Like SetFsPathFromAny, but assumes the given object is an + * absolute normalized path. Only for internal use. * - * However, this behavior means the native filesystem must be - * the last filesystem in the lookup list (otherwise it will - * claim all files belong to it, and other filesystems will - * never get a look in). - * * Results: - * TCL_OK, to indicate 'yes', -1 to indicate no. + * Standard Tcl error code. * * Side effects: - * None. + * The old representation may be freed, and new memory allocated. * *--------------------------------------------------------------------------- */ -static int -NativePathInFilesystem(pathPtr, clientDataPtr) - Tcl_Obj *pathPtr; - ClientData *clientDataPtr; + +Tcl_Obj* +TclFSMakePathRelative(interp, objPtr, cwdPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr; /* The object we have. */ + Tcl_Obj *cwdPtr; /* Make it relative to this. */ { - int len; - Tcl_GetStringFromObj(pathPtr,&len); - if (len == 0) { - return -1; - } else { - /* We accept any path as valid */ - return TCL_OK; + int cwdLen, len; + CONST char *tempStr; + + if (objPtr->typePtr == &tclFsPathType) { + FsPath* fsPathPtr = (FsPath*) PATHOBJ(objPtr); + if (PATHFLAGS(objPtr) != 0 + && fsPathPtr->cwdPtr == cwdPtr) { + objPtr = fsPathPtr->normPathPtr; + /* Free old representation */ + if (objPtr->typePtr != NULL) { + if (objPtr->bytes == NULL) { + if (objPtr->typePtr->updateStringProc == NULL) { + if (interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "can't find object", + "string representation", (char *) NULL); + } + return NULL; + } + objPtr->typePtr->updateStringProc(objPtr); + } + if ((objPtr->typePtr->freeIntRepProc) != NULL) { + (*objPtr->typePtr->freeIntRepProc)(objPtr); + } + } + + fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); + + /* Circular reference, by design */ + fsPathPtr->translatedPathPtr = objPtr; + fsPathPtr->normPathPtr = NULL; + fsPathPtr->cwdPtr = cwdPtr; + Tcl_IncrRefCount(cwdPtr); + fsPathPtr->nativePathPtr = NULL; + fsPathPtr->fsRecPtr = NULL; + fsPathPtr->filesystemEpoch = theFilesystemEpoch; + + PATHOBJ(objPtr) = (VOID *) fsPathPtr; + PATHFLAGS(objPtr) = 0; + objPtr->typePtr = &tclFsPathType; + + return objPtr; + } + } + /* + * We know the cwd is a normalised object which does + * not end in a directory delimiter, unless the cwd + * is the name of a volume, in which case it will + * end in a delimiter! We handle this situation here. + * A better test than the '!= sep' might be to simply + * check if 'cwd' is a root volume. + * + * Note that if we get this wrong, we will strip off + * either too much or too little below, leading to + * wrong answers returned by glob. + */ + tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); + /* + * Should we perhaps use 'Tcl_FSPathSeparator'? + * But then what about the Windows special case? + * Perhaps we should just check if cwd is a root + * volume. + */ + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + if (tempStr[cwdLen-1] != '/') { + cwdLen++; + } + break; + case TCL_PLATFORM_WINDOWS: + if (tempStr[cwdLen-1] != '/' + && tempStr[cwdLen-1] != '\\') { + cwdLen++; + } + break; + case TCL_PLATFORM_MAC: + if (tempStr[cwdLen-1] != ':') { + cwdLen++; + } + break; } + tempStr = Tcl_GetStringFromObj(objPtr, &len); + return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen); } /* *--------------------------------------------------------------------------- * - * NativeFreeInternalRep -- - * - * Free a native internal representation, which will be non-NULL. + * TclFSMakePathFromNormalized -- * + * Like SetFsPathFromAny, but assumes the given object is an + * absolute normalized path. Only for internal use. + * * Results: - * None. + * Standard Tcl error code. * * Side effects: - * Memory is released. + * The old representation may be freed, and new memory allocated. * *--------------------------------------------------------------------------- */ -static void -NativeFreeInternalRep(clientData) - ClientData clientData; + +int +TclFSMakePathFromNormalized(interp, objPtr, nativeRep) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr; /* The object to convert. */ + ClientData nativeRep; /* The native rep for the object, if known + * else NULL. */ { - ckfree((char*)clientData); + FsPath *fsPathPtr; + + if (objPtr->typePtr == &tclFsPathType) { + return TCL_OK; + } + + /* Free old representation */ + if (objPtr->typePtr != NULL) { + if (objPtr->bytes == NULL) { + if (objPtr->typePtr->updateStringProc == NULL) { + if (interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "can't find object", + "string representation", (char *) NULL); + } + return TCL_ERROR; + } + objPtr->typePtr->updateStringProc(objPtr); + } + if ((objPtr->typePtr->freeIntRepProc) != NULL) { + (*objPtr->typePtr->freeIntRepProc)(objPtr); + } + } + + fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); + /* It's a pure normalized absolute path */ + fsPathPtr->translatedPathPtr = NULL; + fsPathPtr->normPathPtr = objPtr; + fsPathPtr->cwdPtr = NULL; + fsPathPtr->nativePathPtr = nativeRep; + fsPathPtr->fsRecPtr = NULL; + fsPathPtr->filesystemEpoch = theFilesystemEpoch; + + PATHOBJ(objPtr) = (VOID *) fsPathPtr; + PATHFLAGS(objPtr) = 0; + objPtr->typePtr = &tclFsPathType; + + return TCL_OK; } /* *--------------------------------------------------------------------------- * - * Tcl_FSFileSystemInfo -- + * Tcl_FSNewNativePath -- * - * This function returns a list of two elements. The first - * element is the name of the filesystem (e.g. "native" or "vfs"), - * and the second is the particular type of the given path within - * that filesystem. + * This function 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 is to be used at the Tcl level, then calling + * this function is an efficient way of creating the appropriate + * path object type. + * + * Any memory which is allocated for 'clientData' should be retained + * until clientData is passed to the filesystem's freeInternalRepProc + * when it can be freed. The built in platform-specific filesystems + * use 'ckalloc' to allocate clientData, and ckfree to free it. * * Results: - * A list of two elements. + * NULL or a valid path object pointer, with refCount zero. * * Side effects: - * The object may be converted to a path type. + * New memory may be allocated. * *--------------------------------------------------------------------------- */ -Tcl_Obj* -Tcl_FSFileSystemInfo(pathObjPtr) - Tcl_Obj* pathObjPtr; + +Tcl_Obj * +Tcl_FSNewNativePath(fromFilesystem, clientData) + Tcl_Filesystem* fromFilesystem; + ClientData clientData; { - Tcl_Obj *resPtr; - Tcl_FSFilesystemPathTypeProc *proc; - Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr); + Tcl_Obj *objPtr; + FsPath *fsPathPtr; + + FilesystemRecord *fsFromPtr; + int epoch; - if (fsPtr == NULL) { + objPtr = TclFSInternalToNormalized(fromFilesystem, clientData, + &fsFromPtr, &epoch); + + if (objPtr == NULL) { return NULL; } - resPtr = Tcl_NewListObj(0,NULL); - - Tcl_ListObjAppendElement(NULL, resPtr, - Tcl_NewStringObj(fsPtr->typeName,-1)); - - proc = fsPtr->filesystemPathTypeProc; - if (proc != NULL) { - Tcl_Obj *typePtr = (*proc)(pathObjPtr); - if (typePtr != NULL) { - Tcl_ListObjAppendElement(NULL, resPtr, typePtr); + /* + * Free old representation; shouldn't normally be any, + * but best to be safe. + */ + if (objPtr->typePtr != NULL) { + if (objPtr->bytes == NULL) { + if (objPtr->typePtr->updateStringProc == NULL) { + return NULL; + } + objPtr->typePtr->updateStringProc(objPtr); + } + if ((objPtr->typePtr->freeIntRepProc) != NULL) { + (*objPtr->typePtr->freeIntRepProc)(objPtr); } } - return resPtr; + fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); + fsPathPtr->translatedPathPtr = NULL; + /* Circular reference, by design */ + fsPathPtr->normPathPtr = objPtr; + fsPathPtr->cwdPtr = NULL; + fsPathPtr->nativePathPtr = clientData; + fsPathPtr->fsRecPtr = fsFromPtr; + /* We must increase the refCount for this filesystem. */ + fsPathPtr->fsRecPtr->fileRefCount++; + fsPathPtr->filesystemEpoch = epoch; + + PATHOBJ(objPtr) = (VOID *) fsPathPtr; + PATHFLAGS(objPtr) = 0; + objPtr->typePtr = &tclFsPathType; + return objPtr; } /* *--------------------------------------------------------------------------- * - * Tcl_FSPathSeparator -- + * Tcl_FSGetTranslatedPath -- * - * This function returns the separator to be used for a given - * path. The object returned should have a refCount of zero + * 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 (if it is non-NULL) * * Results: - * A Tcl object, with a refCount of zero. If the caller - * needs to retain a reference to the object, it should - * call Tcl_IncrRefCount. + * NULL or a valid Tcl_Obj pointer. * * Side effects: - * The path object may be converted to a path type. + * Only those of 'Tcl_FSConvertToPathType' * *--------------------------------------------------------------------------- */ -Tcl_Obj* -Tcl_FSPathSeparator(pathObjPtr) - Tcl_Obj* pathObjPtr; + +Tcl_Obj* +Tcl_FSGetTranslatedPath(interp, pathPtr) + Tcl_Interp *interp; + Tcl_Obj* pathPtr; { - Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr); - - if (fsPtr == NULL) { + register FsPath* srcFsPathPtr; + if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { return NULL; } - if (fsPtr->filesystemSeparatorProc != NULL) { - return (*fsPtr->filesystemSeparatorProc)(pathObjPtr); + srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); + if (srcFsPathPtr->translatedPathPtr == NULL) { + if (PATHFLAGS(pathPtr) != 0) { + return Tcl_FSGetNormalizedPath(interp, pathPtr); + } + /* + * It is a pure absolute, normalized path object. + * This is something like being a 'pure list'. The + * object's string, translatedPath and normalizedPath + * are all identical. + */ + return srcFsPathPtr->normPathPtr; + } else { + /* It is an ordinary path object */ + return srcFsPathPtr->translatedPathPtr; } - - return NULL; } /* *--------------------------------------------------------------------------- * - * NativeFilesystemSeparator -- + * Tcl_FSGetTranslatedStringPath -- * - * This function is part of the native filesystem support, and - * returns the separator for the given path. + * 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: - * String object containing the separator character. + * NULL or a valid string. * * Side effects: - * None. + * Only those of 'Tcl_FSConvertToPathType' * *--------------------------------------------------------------------------- */ -static Tcl_Obj* -NativeFilesystemSeparator(pathObjPtr) - Tcl_Obj* pathObjPtr; +CONST char* +Tcl_FSGetTranslatedStringPath(interp, pathPtr) + Tcl_Interp *interp; + Tcl_Obj* pathPtr; { - char *separator = NULL; /* lint */ - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - separator = "/"; - break; - case TCL_PLATFORM_WINDOWS: - separator = "\\"; - break; - case TCL_PLATFORM_MAC: - separator = ":"; - break; + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); + if (transPtr == NULL) { + return NULL; + } else { + return Tcl_GetString(transPtr); } - return Tcl_NewStringObj(separator,1); } /* *--------------------------------------------------------------------------- * - * Tcl_FSGetFileSystemForPath -- + * Tcl_FSGetNormalizedPath -- * - * This function determines which filesystem to use for a - * particular path object, and returns the filesystem which - * accepts this file. If no filesystem will accept this object - * as a valid file path, then NULL is returned. + * This important function attempts to extract from the given Tcl_Obj + * a unique normalised path representation, whose string value can + * be used as a unique identifier for the file. * * Results: -.* NULL or a filesystem which will accept this path. + * NULL or a valid path object pointer. * * Side effects: - * The object may be converted to a path type. + * New memory may be allocated. The Tcl 'errno' may be modified + * in the process of trying to examine various path possibilities. * *--------------------------------------------------------------------------- */ -Tcl_Filesystem* -Tcl_FSGetFileSystemForPath(pathObjPtr) +Tcl_Obj* +Tcl_FSGetNormalizedPath(interp, pathObjPtr) + Tcl_Interp *interp; Tcl_Obj* pathObjPtr; { - FilesystemRecord *fsRecPtr; - Tcl_Filesystem* retVal = NULL; - FsPath* srcFsPathPtr; - - /* - * If the object has a refCount of zero, we reject it. This - * is to avoid possible segfaults or nondeterministic memory - * leaks (i.e. the user doesn't know if they should decrement - * the ref count on return or not). - */ - - if (pathObjPtr->refCount == 0) { - panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0"); - return NULL; - } - - /* - * This will ensure the pathObjPtr can be converted into a - * "path" type, and that we are able to generate a complete - * normalized path which is used to determine the filesystem - * match. - */ - - if (Tcl_FSGetNormalizedPath(NULL, pathObjPtr) == NULL) { + register FsPath* fsPathPtr; + if (Tcl_FSConvertToPathType(interp, pathObjPtr) != TCL_OK) { return NULL; } - - /* - * Get a lock on theFilesystemEpoch and the filesystemList - * - * While we don't need the fsRecPtr until the while loop below, we - * do want to make sure the theFilesystemEpoch doesn't change - * between the 'if' and 'while' blocks, getting this iterator will - * ensure that everything is consistent - */ - fsRecPtr = FsGetIterator(); - - /* Make sure pathObjPtr is of the correct epoch */ - - srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr; - - /* - * Check if the filesystem has changed in some way since - * this object's internal representation was calculated. - */ - if (srcFsPathPtr->filesystemEpoch != theFilesystemEpoch) { + fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); + + if (PATHFLAGS(pathObjPtr) != 0) { /* - * We have to discard the stale representation and - * recalculate it + * This is a special path object which is the result of + * something like 'file join' */ + Tcl_Obj *dir, *copy; + int cwdLen; + int pathType; + CONST char *cwdStr; + ClientData clientData = NULL; + + pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); + dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr); + if (dir == NULL) { + return NULL; + } if (pathObjPtr->bytes == NULL) { UpdateStringOfFsPath(pathObjPtr); } - FreeFsPathInternalRep(pathObjPtr); - pathObjPtr->typePtr = NULL; - if (SetFsPathFromAny(NULL, pathObjPtr) != TCL_OK) { - goto done; + copy = Tcl_DuplicateObj(dir); + Tcl_IncrRefCount(copy); + Tcl_IncrRefCount(dir); + /* We now own a reference on both 'dir' and 'copy' */ + + cwdStr = Tcl_GetStringFromObj(copy, &cwdLen); + /* + * Should we perhaps use 'Tcl_FSPathSeparator'? + * But then what about the Windows special case? + * Perhaps we should just check if cwd is a root volume. + * We should never get cwdLen == 0 in this code path. + */ + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + if (cwdStr[cwdLen-1] != '/') { + Tcl_AppendToObj(copy, "/", 1); + cwdLen++; + } + break; + case TCL_PLATFORM_WINDOWS: + if (cwdStr[cwdLen-1] != '/' + && cwdStr[cwdLen-1] != '\\') { + Tcl_AppendToObj(copy, "/", 1); + cwdLen++; + } + break; + case TCL_PLATFORM_MAC: + if (cwdStr[cwdLen-1] != ':') { + Tcl_AppendToObj(copy, ":", 1); + cwdLen++; + } + break; } - srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr; + Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr); + /* + * Normalize the combined string, but only starting after + * the end of the previously normalized 'dir'. This should + * be much faster! We use 'cwdLen-1' so that we are + * already pointing at the dir-separator that we know about. + * The normalization code will actually start off directly + * after that separator. + */ + TclFSNormalizeToUniquePath(interp, copy, cwdLen-1, + (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL)); + /* Now we need to construct the new path object */ + + if (pathType == TCL_PATH_RELATIVE) { + register FsPath* origDirFsPathPtr; + Tcl_Obj *origDir = fsPathPtr->cwdPtr; + origDirFsPathPtr = (FsPath*) PATHOBJ(origDir); + + fsPathPtr->cwdPtr = origDirFsPathPtr->cwdPtr; + Tcl_IncrRefCount(fsPathPtr->cwdPtr); + + Tcl_DecrRefCount(fsPathPtr->normPathPtr); + fsPathPtr->normPathPtr = copy; + /* That's our reference to copy used */ + Tcl_DecrRefCount(dir); + Tcl_DecrRefCount(origDir); + } else { + Tcl_DecrRefCount(fsPathPtr->cwdPtr); + fsPathPtr->cwdPtr = NULL; + Tcl_DecrRefCount(fsPathPtr->normPathPtr); + fsPathPtr->normPathPtr = copy; + /* That's our reference to copy used */ + Tcl_DecrRefCount(dir); + } + if (clientData != NULL) { + fsPathPtr->nativePathPtr = clientData; + } + PATHFLAGS(pathObjPtr) = 0; } - - /* Check whether the object is already assigned to a fs */ - if (srcFsPathPtr->fsRecPtr != NULL) { - retVal = srcFsPathPtr->fsRecPtr->fsPtr; - goto done; + /* Ensure cwd hasn't changed */ + if (fsPathPtr->cwdPtr != NULL) { + if (!TclFSCwdPointerEquals(fsPathPtr->cwdPtr)) { + if (pathObjPtr->bytes == NULL) { + UpdateStringOfFsPath(pathObjPtr); + } + FreeFsPathInternalRep(pathObjPtr); + pathObjPtr->typePtr = NULL; + if (Tcl_ConvertToType(interp, pathObjPtr, + &tclFsPathType) != TCL_OK) { + return NULL; + } + fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); + } else if (fsPathPtr->normPathPtr == NULL) { + int cwdLen; + Tcl_Obj *copy; + CONST char *cwdStr; + ClientData clientData = NULL; + + copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr); + Tcl_IncrRefCount(copy); + cwdStr = Tcl_GetStringFromObj(copy, &cwdLen); + /* + * Should we perhaps use 'Tcl_FSPathSeparator'? + * But then what about the Windows special case? + * Perhaps we should just check if cwd is a root volume. + * We should never get cwdLen == 0 in this code path. + */ + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + if (cwdStr[cwdLen-1] != '/') { + Tcl_AppendToObj(copy, "/", 1); + cwdLen++; + } + break; + case TCL_PLATFORM_WINDOWS: + if (cwdStr[cwdLen-1] != '/' + && cwdStr[cwdLen-1] != '\\') { + Tcl_AppendToObj(copy, "/", 1); + cwdLen++; + } + break; + case TCL_PLATFORM_MAC: + if (cwdStr[cwdLen-1] != ':') { + Tcl_AppendToObj(copy, ":", 1); + cwdLen++; + } + break; + } + Tcl_AppendObjToObj(copy, pathObjPtr); + /* + * Normalize the combined string, but only starting after + * the end of the previously normalized 'dir'. This should + * be much faster! + */ + TclFSNormalizeToUniquePath(interp, copy, cwdLen-1, + (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL)); + fsPathPtr->normPathPtr = copy; + if (clientData != NULL) { + fsPathPtr->nativePathPtr = clientData; + } + } } - - /* - * Call each of the "pathInFilesystem" functions in succession. A - * non-return value of -1 indicates the particular function has - * succeeded. - */ + if (fsPathPtr->normPathPtr == NULL) { + ClientData clientData = NULL; + Tcl_Obj *useThisCwd = NULL; + /* + * Since normPathPtr is NULL, but this is a valid path + * object, we know that the translatedPathPtr cannot be NULL. + */ + Tcl_Obj *absolutePath = fsPathPtr->translatedPathPtr; + char *path = Tcl_GetString(absolutePath); + + /* + * 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) == TCL_PATH_RELATIVE)) { + useThisCwd = Tcl_FSGetCwd(interp); - while ((retVal == NULL) && (fsRecPtr != NULL)) { - Tcl_FSPathInFilesystemProc *proc = fsRecPtr->fsPtr->pathInFilesystemProc; - if (proc != NULL) { - ClientData clientData = NULL; - int ret = (*proc)(pathObjPtr, &clientData); - if (ret != -1) { - /* - * We assume the srcFsPathPtr hasn't been changed - * by the above call to the pathInFilesystemProc. - */ - srcFsPathPtr->fsRecPtr = fsRecPtr; - srcFsPathPtr->nativePathPtr = clientData; - srcFsPathPtr->filesystemEpoch = theFilesystemEpoch; - fsRecPtr->fileRefCount++; - retVal = fsRecPtr->fsPtr; + if (useThisCwd == NULL) { + return NULL; } + + absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath); + Tcl_IncrRefCount(absolutePath); + /* We have a refCount on the cwd */ + } + /* Already has refCount incremented */ + fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp, absolutePath, + (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL)); + if (0 && (clientData != NULL)) { + fsPathPtr->nativePathPtr = + (*fsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc)(clientData); + } + if (!strcmp(Tcl_GetString(fsPathPtr->normPathPtr), + Tcl_GetString(pathObjPtr))) { + /* + * The path was already normalized. + * Get rid of the duplicate. + */ + Tcl_DecrRefCount(fsPathPtr->normPathPtr); + /* + * We do *not* increment the refCount for + * this circular reference + */ + fsPathPtr->normPathPtr = pathObjPtr; } - fsRecPtr = fsRecPtr->nextPtr; - } - - done: - FsReleaseIterator(); - return retVal; -} - -/* Simple helper function */ -static FilesystemRecord* -GetFilesystemRecord(fromFilesystem, epoch) - Tcl_Filesystem *fromFilesystem; - int *epoch; -{ - FilesystemRecord *fsRecPtr = FsGetIterator(); - while (fsRecPtr != NULL) { - if (fsRecPtr->fsPtr == fromFilesystem) { - *epoch = theFilesystemEpoch; - break; + if (useThisCwd != NULL) { + /* This was returned by Tcl_FSJoinToPath above */ + Tcl_DecrRefCount(absolutePath); + fsPathPtr->cwdPtr = useThisCwd; } - fsRecPtr = fsRecPtr->nextPtr; } - FsReleaseIterator(); - return fsRecPtr; + return fsPathPtr->normPathPtr; } /* *--------------------------------------------------------------------------- * - * Tcl_FSEqualPaths -- + * Tcl_FSGetInternalRep -- * - * This function tests whether the two paths given are equal path - * objects. If either or both is NULL, 0 is always returned. + * Extract the internal representation of a given path object, + * in the given filesystem. If the path object belongs to a + * different filesystem, we return NULL. + * + * If the internal representation is currently NULL, we attempt + * to generate it, by calling the filesystem's + * 'Tcl_FSCreateInternalRepProc'. * * Results: - * 1 or 0. + * NULL or a valid internal representation. * * Side effects: - * None. + * An attempt may be made to convert the object. * *--------------------------------------------------------------------------- */ -int -Tcl_FSEqualPaths(firstPtr, secondPtr) - Tcl_Obj* firstPtr; - Tcl_Obj* secondPtr; +ClientData +Tcl_FSGetInternalRep(pathObjPtr, fsPtr) + Tcl_Obj* pathObjPtr; + Tcl_Filesystem *fsPtr; { - if (firstPtr == secondPtr) { - return 1; - } else { - char *firstStr, *secondStr; - int firstLen, secondLen, tempErrno; - - if (firstPtr == NULL || secondPtr == NULL) { - return 0; - } - firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen); - secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen); - if ((firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0)) { - return 1; - } + register FsPath* srcFsPathPtr; + + if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) { + return NULL; + } + srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); + + /* + * We will only return the native representation for the caller's + * filesystem. Otherwise we will simply return NULL. This means + * that there must be a unique bi-directional mapping between paths + * and filesystems, and that this mapping will not allow 'remapped' + * files -- files which are in one filesystem but mapped into + * another. Another way of putting this is that 'stacked' + * filesystems are not allowed. We recognise that this is a + * potentially useful feature for the future. + * + * Even something simple like a 'pass through' filesystem which + * logs all activity and passes the calls onto the native system + * would be nice, but not easily achievable with the current + * implementation. + */ + if (srcFsPathPtr->fsRecPtr == NULL) { /* - * Try the most thorough, correct method of comparing fully - * normalized paths - */ - - tempErrno = Tcl_GetErrno(); - firstPtr = Tcl_FSGetNormalizedPath(NULL, firstPtr); - secondPtr = Tcl_FSGetNormalizedPath(NULL, secondPtr); - Tcl_SetErrno(tempErrno); - - if (firstPtr == NULL || secondPtr == NULL) { - return 0; - } - firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen); - secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen); - if ((firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0)) { - return 1; + * This only usually happens in wrappers like TclpStat which + * create a string object and pass it to TclpObjStat. Code + * which calls the Tcl_FS.. functions should always have a + * filesystem already set. Whether this code path is legal or + * not depends on whether we decide to allow external code to + * call the native filesystem directly. It is at least safer + * to allow this sub-optimal routing. + */ + Tcl_FSGetFileSystemForPath(pathObjPtr); + + /* + * If we fail through here, then the path is probably not a + * valid path in the filesystsem, and is most likely to be a + * use of the empty path "" via a direct call to one of the + * objectified interfaces (e.g. from the Tcl testsuite). + */ + srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); + if (srcFsPathPtr->fsRecPtr == NULL) { + return NULL; } } - return 0; -} - -/* Everything from here on is contained in this obsolete ifdef */ -#ifdef USE_OBSOLETE_FS_HOOKS - -/* - *---------------------------------------------------------------------- - * - * TclStatInsertProc -- - * - * Insert the passed procedure pointer at the head of the list of - * functions which are used during a call to 'TclStat(...)'. The - * passed function should behave exactly like 'TclStat' when called - * during that time (see 'TclStat(...)' for more information). - * The function will be added even if it already in the list. - * - * Results: - * Normally TCL_OK; TCL_ERROR if memory for a new node in the list - * could not be allocated. - * - * Side effects: - * Memory allocated and modifies the link list for 'TclStat' - * functions. - * - *---------------------------------------------------------------------- - */ - -int -TclStatInsertProc (proc) - TclStatProc_ *proc; -{ - int retVal = TCL_ERROR; - - if (proc != NULL) { - StatProc *newStatProcPtr; - newStatProcPtr = (StatProc *)ckalloc(sizeof(StatProc)); + if (fsPtr != srcFsPathPtr->fsRecPtr->fsPtr) { + /* + * There is still one possibility we should consider; if the + * file belongs to a different filesystem, perhaps it is + * actually linked through to a file in our own filesystem + * which we do care about. The way we can check for this + * is we ask what filesystem this path belongs to. + */ + Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathObjPtr); + if (actualFs == fsPtr) { + return Tcl_FSGetInternalRep(pathObjPtr, fsPtr); + } + return NULL; + } - if (newStatProcPtr != NULL) { - newStatProcPtr->proc = proc; - Tcl_MutexLock(&obsoleteFsHookMutex); - newStatProcPtr->nextPtr = statProcList; - statProcList = newStatProcPtr; - Tcl_MutexUnlock(&obsoleteFsHookMutex); + if (srcFsPathPtr->nativePathPtr == NULL) { + Tcl_FSCreateInternalRepProc *proc; + proc = srcFsPathPtr->fsRecPtr->fsPtr->createInternalRepProc; - retVal = TCL_OK; + if (proc == NULL) { + return NULL; } + srcFsPathPtr->nativePathPtr = (*proc)(pathObjPtr); } - - return (retVal); + return srcFsPathPtr->nativePathPtr; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * TclStatDeleteProc -- + * TclFSEnsureEpochOk -- * - * Removed the passed function pointer from the list of 'TclStat' - * functions. Ensures that the built-in stat function is not - * removvable. + * This will ensure the pathObjPtr is up to date and can be + * converted into a "path" type, and that we are able to generate a + * complete normalized path which is used to determine the + * filesystem match. * * Results: - * TCL_OK if the procedure pointer was successfully removed, - * TCL_ERROR otherwise. + * Standard Tcl return code. * * Side effects: - * Memory is deallocated and the respective list updated. + * An attempt may be made to convert the object. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -int -TclStatDeleteProc (proc) - TclStatProc_ *proc; +int +TclFSEnsureEpochOk(pathObjPtr, theEpoch, fsPtrPtr) + Tcl_Obj* pathObjPtr; + int theEpoch; + Tcl_Filesystem **fsPtrPtr; { - int retVal = TCL_ERROR; - StatProc *tmpStatProcPtr; - StatProc *prevStatProcPtr = NULL; + FsPath* srcFsPathPtr; - Tcl_MutexLock(&obsoleteFsHookMutex); - tmpStatProcPtr = statProcList; - /* - * Traverse the 'statProcList' looking for the particular node - * whose 'proc' member matches 'proc' and remove that one from - * the list. Ensure that the "default" node cannot be removed. + /* + * SHOULD BE ABLE TO IMPROVE EFFICIENCY HERE. */ - while ((retVal == TCL_ERROR) && (tmpStatProcPtr != NULL)) { - if (tmpStatProcPtr->proc == proc) { - if (prevStatProcPtr == NULL) { - statProcList = tmpStatProcPtr->nextPtr; - } else { - prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr; - } + if (Tcl_FSGetNormalizedPath(NULL, pathObjPtr) == NULL) { + return TCL_ERROR; + } - ckfree((char *)tmpStatProcPtr); + srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); - retVal = TCL_OK; - } else { - prevStatProcPtr = tmpStatProcPtr; - tmpStatProcPtr = tmpStatProcPtr->nextPtr; + /* + * Check if the filesystem has changed in some way since + * this object's internal representation was calculated. + */ + if (srcFsPathPtr->filesystemEpoch != theEpoch) { + /* + * We have to discard the stale representation and + * recalculate it + */ + if (pathObjPtr->bytes == NULL) { + UpdateStringOfFsPath(pathObjPtr); + } + FreeFsPathInternalRep(pathObjPtr); + pathObjPtr->typePtr = NULL; + if (SetFsPathFromAny(NULL, pathObjPtr) != TCL_OK) { + return TCL_ERROR; } + srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); } - - Tcl_MutexUnlock(&obsoleteFsHookMutex); - return (retVal); + /* Check whether the object is already assigned to a fs */ + if (srcFsPathPtr->fsRecPtr != NULL) { + *fsPtrPtr = srcFsPathPtr->fsRecPtr->fsPtr; + } + return TCL_OK; +} + +void +TclFSSetPathDetails(pathObjPtr, fsRecPtr, clientData, theEpoch) + Tcl_Obj *pathObjPtr; + FilesystemRecord *fsRecPtr; + ClientData clientData; + int theEpoch; +{ + /* We assume pathObjPtr is already of the correct type */ + FsPath* srcFsPathPtr; + + srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); + srcFsPathPtr->fsRecPtr = fsRecPtr; + srcFsPathPtr->nativePathPtr = clientData; + srcFsPathPtr->filesystemEpoch = theEpoch; + fsRecPtr->fileRefCount++; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * TclAccessInsertProc -- + * Tcl_FSEqualPaths -- * - * Insert the passed procedure pointer at the head of the list of - * functions which are used during a call to 'TclAccess(...)'. - * The passed function should behave exactly like 'TclAccess' when - * called during that time (see 'TclAccess(...)' for more - * information). The function will be added even if it already in - * the list. + * This function tests whether the two paths given are equal path + * objects. If either or both is NULL, 0 is always returned. * * Results: - * Normally TCL_OK; TCL_ERROR if memory for a new node in the list - * could not be allocated. + * 1 or 0. * * Side effects: - * Memory allocated and modifies the link list for 'TclAccess' - * functions. + * None. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -int -TclAccessInsertProc(proc) - TclAccessProc_ *proc; +int +Tcl_FSEqualPaths(firstPtr, secondPtr) + Tcl_Obj* firstPtr; + Tcl_Obj* secondPtr; { - int retVal = TCL_ERROR; - - if (proc != NULL) { - AccessProc *newAccessProcPtr; + if (firstPtr == secondPtr) { + return 1; + } else { + char *firstStr, *secondStr; + int firstLen, secondLen, tempErrno; - newAccessProcPtr = (AccessProc *)ckalloc(sizeof(AccessProc)); + if (firstPtr == NULL || secondPtr == NULL) { + return 0; + } + firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen); + secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen); + if ((firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0)) { + return 1; + } + /* + * Try the most thorough, correct method of comparing fully + * normalized paths + */ - if (newAccessProcPtr != NULL) { - newAccessProcPtr->proc = proc; - Tcl_MutexLock(&obsoleteFsHookMutex); - newAccessProcPtr->nextPtr = accessProcList; - accessProcList = newAccessProcPtr; - Tcl_MutexUnlock(&obsoleteFsHookMutex); + tempErrno = Tcl_GetErrno(); + firstPtr = Tcl_FSGetNormalizedPath(NULL, firstPtr); + secondPtr = Tcl_FSGetNormalizedPath(NULL, secondPtr); + Tcl_SetErrno(tempErrno); - retVal = TCL_OK; + if (firstPtr == NULL || secondPtr == NULL) { + return 0; + } + firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen); + secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen); + if ((firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0)) { + return 1; } } - - return (retVal); + return 0; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * TclAccessDeleteProc -- + * SetFsPathFromAny -- * - * Removed the passed function pointer from the list of 'TclAccess' - * functions. Ensures that the built-in access function is not - * removvable. + * This function tries to convert the given Tcl_Obj to a valid + * Tcl path type. + * + * The filename may begin with "~" (to indicate current user's + * home directory) or "~" (to indicate any user's home + * directory). * * Results: - * TCL_OK if the procedure pointer was successfully removed, - * TCL_ERROR otherwise. + * Standard Tcl error code. * * Side effects: - * Memory is deallocated and the respective list updated. + * The old representation may be freed, and new memory allocated. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -int -TclAccessDeleteProc(proc) - TclAccessProc_ *proc; +static int +SetFsPathFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr; /* The object to convert. */ { - int retVal = TCL_ERROR; - AccessProc *tmpAccessProcPtr; - AccessProc *prevAccessProcPtr = NULL; + int len; + FsPath *fsPathPtr; + Tcl_Obj *transPtr; + char *name; + + if (objPtr->typePtr == &tclFsPathType) { + return TCL_OK; + } + + /* + * First step is to translate the filename. This is similar to + * Tcl_TranslateFilename, but shouldn't convert everything to + * windows backslashes on that platform. The current + * implementation of this piece is a slightly optimised version + * of the various Tilde/Split/Join stuff to avoid multiple + * split/join operations. + * + * We remove any trailing directory separator. + * + * However, the split/join routines are quite complex, and + * one has to make sure not to break anything on Unix, Win + * or MacOS (fCmd.test, fileName.test and cmdAH.test exercise + * most of the code). + */ + name = Tcl_GetStringFromObj(objPtr,&len); + + /* + * Handle tilde substitutions, if needed. + */ + if (name[0] == '~') { + char *expandedUser; + Tcl_DString temp; + int split; + char separator='/'; + + if (tclPlatform==TCL_PLATFORM_MAC) { + if (strchr(name, ':') != NULL) separator = ':'; + } + + split = FindSplitPos(name, &separator); + if (split != len) { + /* We have multiple pieces '~user/foo/bar...' */ + name[split] = '\0'; + } + /* Do some tilde substitution */ + if (name[1] == '\0') { + /* We have just '~' */ + CONST char *dir; + Tcl_DString dirString; + if (split != len) { name[split] = separator; } + + dir = TclGetEnv("HOME", &dirString); + if (dir == NULL) { + if (interp) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't find HOME environment ", + "variable to expand path", (char *) NULL); + } + return TCL_ERROR; + } + Tcl_DStringInit(&temp); + Tcl_JoinPath(1, &dir, &temp); + Tcl_DStringFree(&dirString); + } else { + /* We have a user name '~user' */ + Tcl_DStringInit(&temp); + if (TclpGetUserHome(name+1, &temp) == NULL) { + if (interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "user \"", (name+1), + "\" doesn't exist", (char *) NULL); + } + Tcl_DStringFree(&temp); + if (split != len) { name[split] = separator; } + return TCL_ERROR; + } + if (split != len) { name[split] = separator; } + } + + expandedUser = Tcl_DStringValue(&temp); + transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp)); + + if (split != len) { + /* Join up the tilde substitution with the rest */ + if (name[split+1] == separator) { + + /* + * Somewhat tricky case like ~//foo/bar. + * Make use of Split/Join machinery to get it right. + * Assumes all paths beginning with ~ are part of the + * native filesystem. + */ + + int objc; + Tcl_Obj **objv; + Tcl_Obj *parts = TclpNativeSplitPath(objPtr, NULL); + Tcl_ListObjGetElements(NULL, parts, &objc, &objv); + /* Skip '~'. It's replaced by its expansion */ + objc--; objv++; + while (objc--) { + TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++)); + } + Tcl_DecrRefCount(parts); + } else { + /* Simple case. "rest" is relative path. Just join it. */ + Tcl_Obj *rest = Tcl_NewStringObj(name+split+1,-1); + transPtr = Tcl_FSJoinToPath(transPtr, 1, &rest); + } + } + Tcl_DStringFree(&temp); + } else { + transPtr = Tcl_FSJoinToPath(objPtr,0,NULL); + } + + /* + * 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 = transPtr; + Tcl_IncrRefCount(fsPathPtr->translatedPathPtr); + fsPathPtr->normPathPtr = NULL; + fsPathPtr->cwdPtr = NULL; + fsPathPtr->nativePathPtr = NULL; + fsPathPtr->fsRecPtr = NULL; + fsPathPtr->filesystemEpoch = theFilesystemEpoch; + + /* + * Free old representation before installing our new one. + */ + if (objPtr->typePtr != NULL && objPtr->typePtr->freeIntRepProc != NULL) { + (objPtr->typePtr->freeIntRepProc)(objPtr); + } + PATHOBJ(objPtr) = (VOID *) fsPathPtr; + PATHFLAGS(objPtr) = 0; + objPtr->typePtr = &tclFsPathType; + + return TCL_OK; +} + +static void +FreeFsPathInternalRep(pathObjPtr) + Tcl_Obj *pathObjPtr; /* Path object with internal rep to free. */ +{ + register FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); + + if (fsPathPtr->translatedPathPtr != NULL) { + if (fsPathPtr->translatedPathPtr != pathObjPtr) { + Tcl_DecrRefCount(fsPathPtr->translatedPathPtr); + } + } + if (fsPathPtr->normPathPtr != NULL) { + if (fsPathPtr->normPathPtr != pathObjPtr) { + Tcl_DecrRefCount(fsPathPtr->normPathPtr); + } + fsPathPtr->normPathPtr = NULL; + } + if (fsPathPtr->cwdPtr != NULL) { + Tcl_DecrRefCount(fsPathPtr->cwdPtr); + } + if (fsPathPtr->nativePathPtr != NULL) { + if (fsPathPtr->fsRecPtr != NULL) { + if (fsPathPtr->fsRecPtr->fsPtr->freeInternalRepProc != NULL) { + (*fsPathPtr->fsRecPtr->fsPtr + ->freeInternalRepProc)(fsPathPtr->nativePathPtr); + fsPathPtr->nativePathPtr = NULL; + } + } + } + if (fsPathPtr->fsRecPtr != NULL) { + fsPathPtr->fsRecPtr->fileRefCount--; + if (fsPathPtr->fsRecPtr->fileRefCount <= 0) { + /* It has been unregistered already */ + ckfree((char *)fsPathPtr->fsRecPtr); + } + } - /* - * Traverse the 'accessProcList' looking for the particular node - * whose 'proc' member matches 'proc' and remove that one from - * the list. Ensure that the "default" node cannot be removed. - */ + ckfree((char*) fsPathPtr); +} + - Tcl_MutexLock(&obsoleteFsHookMutex); - tmpAccessProcPtr = accessProcList; - while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != NULL)) { - if (tmpAccessProcPtr->proc == proc) { - if (prevAccessProcPtr == NULL) { - accessProcList = tmpAccessProcPtr->nextPtr; - } else { - prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr; - } +static void +DupFsPathInternalRep(srcPtr, copyPtr) + Tcl_Obj *srcPtr; /* Path obj with internal rep to copy. */ + Tcl_Obj *copyPtr; /* Path obj with internal rep to set. */ +{ + register FsPath* srcFsPathPtr = (FsPath*) PATHOBJ(srcPtr); + register FsPath* copyFsPathPtr = + (FsPath*) ckalloc((unsigned)sizeof(FsPath)); + Tcl_FSDupInternalRepProc *dupProc; + + PATHOBJ(copyPtr) = (VOID *) copyFsPathPtr; - ckfree((char *)tmpAccessProcPtr); + if (srcFsPathPtr->translatedPathPtr != NULL) { + copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr; + if (copyFsPathPtr->translatedPathPtr != copyPtr) { + Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); + } + } else { + copyFsPathPtr->translatedPathPtr = NULL; + } + + if (srcFsPathPtr->normPathPtr != NULL) { + copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; + if (copyFsPathPtr->normPathPtr != copyPtr) { + Tcl_IncrRefCount(copyFsPathPtr->normPathPtr); + } + } else { + copyFsPathPtr->normPathPtr = NULL; + } + + if (srcFsPathPtr->cwdPtr != NULL) { + copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr; + Tcl_IncrRefCount(copyFsPathPtr->cwdPtr); + } else { + copyFsPathPtr->cwdPtr = NULL; + } - retVal = TCL_OK; + copyFsPathPtr->flags = srcFsPathPtr->flags; + + if (srcFsPathPtr->fsRecPtr != NULL + && srcFsPathPtr->nativePathPtr != NULL) { + dupProc = srcFsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc; + if (dupProc != NULL) { + copyFsPathPtr->nativePathPtr = + (*dupProc)(srcFsPathPtr->nativePathPtr); } else { - prevAccessProcPtr = tmpAccessProcPtr; - tmpAccessProcPtr = tmpAccessProcPtr->nextPtr; + copyFsPathPtr->nativePathPtr = NULL; } + } else { + copyFsPathPtr->nativePathPtr = NULL; + } + copyFsPathPtr->fsRecPtr = srcFsPathPtr->fsRecPtr; + copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch; + if (copyFsPathPtr->fsRecPtr != NULL) { + copyFsPathPtr->fsRecPtr->fileRefCount++; } - Tcl_MutexUnlock(&obsoleteFsHookMutex); - return (retVal); + copyPtr->typePtr = &tclFsPathType; } /* - *---------------------------------------------------------------------- - * - * TclOpenFileChannelInsertProc -- + *--------------------------------------------------------------------------- * - * Insert the passed procedure pointer at the head of the list of - * functions which are used during a call to - * 'Tcl_OpenFileChannel(...)'. The passed function should behave - * exactly like 'Tcl_OpenFileChannel' when called during that time - * (see 'Tcl_OpenFileChannel(...)' for more information). The - * function will be added even if it already in the list. + * UpdateStringOfFsPath -- * + * Gives an object a valid string rep. + * * Results: - * Normally TCL_OK; TCL_ERROR if memory for a new node in the list - * could not be allocated. + * None. * * Side effects: - * Memory allocated and modifies the link list for - * 'Tcl_OpenFileChannel' functions. + * Memory may be allocated. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -int -TclOpenFileChannelInsertProc(proc) - TclOpenFileChannelProc_ *proc; +static void +UpdateStringOfFsPath(objPtr) + register Tcl_Obj *objPtr; /* path obj with string rep to update. */ { - int retVal = TCL_ERROR; - - if (proc != NULL) { - OpenFileChannelProc *newOpenFileChannelProcPtr; - - newOpenFileChannelProcPtr = - (OpenFileChannelProc *)ckalloc(sizeof(OpenFileChannelProc)); - - if (newOpenFileChannelProcPtr != NULL) { - newOpenFileChannelProcPtr->proc = proc; - Tcl_MutexLock(&obsoleteFsHookMutex); - newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; - openFileChannelProcList = newOpenFileChannelProcPtr; - Tcl_MutexUnlock(&obsoleteFsHookMutex); - - retVal = TCL_OK; - } + register FsPath* fsPathPtr = (FsPath*) PATHOBJ(objPtr); + CONST char *cwdStr; + int cwdLen; + Tcl_Obj *copy; + + if (PATHFLAGS(objPtr) == 0 || fsPathPtr->cwdPtr == NULL) { + panic("Called UpdateStringOfFsPath with invalid object"); } - - return (retVal); + + copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr); + Tcl_IncrRefCount(copy); + + cwdStr = Tcl_GetStringFromObj(copy, &cwdLen); + /* + * Should we perhaps use 'Tcl_FSPathSeparator'? + * But then what about the Windows special case? + * Perhaps we should just check if cwd is a root volume. + * We should never get cwdLen == 0 in this code path. + */ + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + if (cwdStr[cwdLen-1] != '/') { + Tcl_AppendToObj(copy, "/", 1); + cwdLen++; + } + break; + case TCL_PLATFORM_WINDOWS: + /* + * We need the extra 'cwdLen != 2', and ':' checks because + * a volume relative path doesn't get a '/'. For example + * 'glob C:*cat*.exe' will return 'C:cat32.exe' + */ + if (cwdStr[cwdLen-1] != '/' + && cwdStr[cwdLen-1] != '\\') { + if (cwdLen != 2 || cwdStr[1] != ':') { + Tcl_AppendToObj(copy, "/", 1); + cwdLen++; + } + } + break; + case TCL_PLATFORM_MAC: + if (cwdStr[cwdLen-1] != ':') { + Tcl_AppendToObj(copy, ":", 1); + cwdLen++; + } + break; + } + Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr); + objPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen); + objPtr->length = cwdLen; + copy->bytes = tclEmptyStringRep; + copy->length = 0; + Tcl_DecrRefCount(copy); } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * TclOpenFileChannelDeleteProc -- + * NativePathInFilesystem -- * - * Removed the passed function pointer from the list of - * 'Tcl_OpenFileChannel' functions. Ensures that the built-in - * open file channel function is not removable. + * Any path object is acceptable to the native filesystem, by + * default (we will throw errors when illegal paths are actually + * tried to be used). + * + * However, this behavior means the native filesystem must be + * the last filesystem in the lookup list (otherwise it will + * claim all files belong to it, and other filesystems will + * never get a look in). * * Results: - * TCL_OK if the procedure pointer was successfully removed, - * TCL_ERROR otherwise. + * TCL_OK, to indicate 'yes', -1 to indicate no. * * Side effects: - * Memory is deallocated and the respective list updated. + * None. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ - -int -TclOpenFileChannelDeleteProc(proc) - TclOpenFileChannelProc_ *proc; +int +NativePathInFilesystem(pathPtr, clientDataPtr) + Tcl_Obj *pathPtr; + ClientData *clientDataPtr; { - int retVal = TCL_ERROR; - OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList; - OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL; - - /* - * Traverse the 'openFileChannelProcList' looking for the particular - * node whose 'proc' member matches 'proc' and remove that one from - * the list. + /* + * A special case is required to handle the empty path "". + * This is a valid path (i.e. the user should be able + * to do 'file exists ""' without throwing an error), but + * equally the path doesn't exist. Those are the semantics + * of Tcl (at present anyway), so we have to abide by them + * here. */ - - Tcl_MutexLock(&obsoleteFsHookMutex); - tmpOpenFileChannelProcPtr = openFileChannelProcList; - while ((retVal == TCL_ERROR) && - (tmpOpenFileChannelProcPtr != NULL)) { - if (tmpOpenFileChannelProcPtr->proc == proc) { - if (prevOpenFileChannelProcPtr == NULL) { - openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr; - } else { - prevOpenFileChannelProcPtr->nextPtr = - tmpOpenFileChannelProcPtr->nextPtr; - } - - ckfree((char *)tmpOpenFileChannelProcPtr); - - retVal = TCL_OK; - } else { - prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr; - tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr; + if (pathPtr->typePtr == &tclFsPathType) { + if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') { + /* We reject the empty path "" */ + return -1; + } + /* Otherwise there is no way this path can be empty */ + } else { + /* + * It is somewhat unusual to reach this code path without + * the object being of tclFsPathType. However, we do + * our best to deal with the situation. + */ + int len; + Tcl_GetStringFromObj(pathPtr,&len); + if (len == 0) { + /* We reject the empty path "" */ + return -1; } } - Tcl_MutexUnlock(&obsoleteFsHookMutex); - - return (retVal); + /* + * Path is of correct type, or is of non-zero length, + * so we accept it. + */ + return TCL_OK; } -#endif /* USE_OBSOLETE_FS_HOOKS */ diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 9b26f8e..9d7dca1 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdAH.test,v 1.30.2.1 2003/03/18 10:51:31 vincentdarley Exp $ +# RCS: @(#) $Id: cmdAH.test,v 1.30.2.2 2003/04/14 15:45:51 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -86,6 +86,9 @@ test cmdAH-2.5 {Tcl_CdObjCmd} { test cmdAH-2.6 {Tcl_CdObjCmd} { list [catch {cd _foobar} msg] $msg } {1 {couldn't change working directory to "_foobar": no such file or directory}} +test cmdAH-2.6.1 {Tcl_CdObjCmd} { + list [catch {cd ""} msg] $msg +} {1 {couldn't change working directory to "": no such file or directory}} test cmdAH-2.7 {Tcl_ConcatObjCmd} { concat @@ -396,12 +399,12 @@ test cmdAH-8.42 {Tcl_FileObjCmd: dirname} { test cmdAH-8.43 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) - set env(HOME) "/home/test" + set env(HOME) "/homewontexist/test" testsetplatform unix set result [list [catch {file dirname ~} msg] $msg] set env(HOME) $temp set result -} [list 0 [expr {([file exists /home] && ([file type /home] == "link")) ? [file readlink /home] : "/home"}]] +} {0 /homewontexist} test cmdAH-8.44 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) @@ -414,12 +417,12 @@ test cmdAH-8.44 {Tcl_FileObjCmd: dirname} { test cmdAH-8.45 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) - set env(HOME) "/home/test" + set env(HOME) "/homewontexist/test" testsetplatform windows set result [list [catch {file dirname ~} msg] $msg] set env(HOME) $temp set result -} [list 0 [expr {([file exists /home] && ([file type /home] == "link")) ? [file readlink /home] : "/home"}]] +} {0 /homewontexist} test cmdAH-8.46 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) diff --git a/tests/fCmd.test b/tests/fCmd.test index e3bec24..c704032 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.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: fCmd.test,v 1.26 2003/02/12 19:18:13 vincentdarley Exp $ +# RCS: @(#) $Id: fCmd.test,v 1.26.2.1 2003/04/14 15:45:54 vincentdarley Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -673,6 +673,11 @@ test fCmd-8.2 {FileBasename: basename of ~user: argc == 1 && *path == ~} \ {unixOnly notRoot} { file tail ~$user } "$user" +test fCmd-8.3 {file copy and path translation: ensure correct error} { + list [catch {file copy ~ [file join this file doesnt exist]} res] $res +} [list 1 \ + "error copying \"~\" to \"[file join this file doesnt exist]\":\ + no such file or directory"] test fCmd-9.1 {file rename: comprehensive: EACCES} {unixOnly notRoot} { cleanup diff --git a/tests/ioUtil.test b/tests/ioUtil.test index 812e3e4..5b0a79e 100644 --- a/tests/ioUtil.test +++ b/tests/ioUtil.test @@ -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: ioUtil.test,v 1.13 2002/07/18 09:40:24 vincentdarley Exp $ +# RCS: @(#) $Id: ioUtil.test,v 1.13.2.1 2003/04/14 15:45:57 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -113,14 +113,14 @@ test ioUtil-1.8 {TclStatDeleteProc: Verify that all procs have been deleted.} {t eval $unsetScript -test ioUtil-1.1 {TclAccess: Check that none of the test procs are there.} { +test ioUtil-1.9 {TclAccess: Check that none of the test procs are there.} { catch {file exists testAccess1%.fil} err1 catch {file exists testAccess2%.fil} err2 catch {file exists testAccess3%.fil} err3 list $err1 $err2 $err3 } {0 0 0} -test ioUtil-1.2 {TclAccessInsertProc: Insert the 3 test TclAccess_ procedures.} {testaccessproc} { +test ioUtil-1.10 {TclAccessInsertProc: Insert the 3 test TclAccess_ procedures.} {testaccessproc} { catch {testaccessproc insert TclpAccess} err1 testaccessproc insert TestAccessProc1 testaccessproc insert TestAccessProc2 diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test index ca707a4..8f47c62 100644 --- a/tests/unixFCmd.test +++ b/tests/unixFCmd.test @@ -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: unixFCmd.test,v 1.17 2003/01/25 00:16:39 hobbs Exp $ +# RCS: @(#) $Id: unixFCmd.test,v 1.17.2.1 2003/04/14 15:45:57 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -285,7 +285,7 @@ test unixFCmd-17.3 {SetPermissionsAttribute} {unixOnly notRoot} { list [catch {file attributes foo.test -permissions foo} msg] $msg \ [file delete -force -- foo.test] } {1 {unknown permission string format "foo"} {}} -test unixFCmd-17.3 {SetPermissionsAttribute} {unixOnly notRoot} { +test unixFCmd-17.4 {SetPermissionsAttribute} {unixOnly notRoot} { catch {file delete -force -- foo.test} close [open foo.test w] list [catch {file attributes foo.test -permissions ---rwx} msg] $msg \ @@ -300,14 +300,14 @@ proc permcheck {testnum permstr expected} { file attributes foo.test -permissions } $expected } -permcheck unixFCmd-17.4 rwxrwxrwx 00777 -permcheck unixFCmd-17.5 r--r---w- 00442 -permcheck unixFCmd-17.6 0 00000 -permcheck unixFCmd-17.7 u+rwx,g+r 00740 -permcheck unixFCmd-17.8 u-w 00540 -permcheck unixFCmd-17.9 o+rwx 00547 -permcheck unixFCmd-17.10 --x--x--x 00111 -permcheck unixFCmd-17.11 a+rwx 00777 +permcheck unixFCmd-17.5 rwxrwxrwx 00777 +permcheck unixFCmd-17.6 r--r---w- 00442 +permcheck unixFCmd-17.7 0 00000 +permcheck unixFCmd-17.8 u+rwx,g+r 00740 +permcheck unixFCmd-17.9 u-w 00540 +permcheck unixFCmd-17.10 o+rwx 00547 +permcheck unixFCmd-17.11 --x--x--x 00111 +permcheck unixFCmd-17.12 a+rwx 00777 file delete -force -- foo.test test unixFCmd-18.1 {Unix pwd} {nonPortable unixOnly notRoot} { diff --git a/tests/winFile.test b/tests/winFile.test index 4b04096..95816ff 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winFile.test,v 1.9 2002/07/18 16:36:56 vincentdarley Exp $ +# RCS: @(#) $Id: winFile.test,v 1.9.2.1 2003/04/14 15:45:58 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -25,7 +25,7 @@ test winFile-1.2 {TclpGetUserHome} {pcOnly nt nonPortable} { catch {glob ~administrator} } {0} -test winFile-1.2 {TclpGetUserHome} {pcOnly 95} { +test winFile-1.3 {TclpGetUserHome} {pcOnly 95} { # Find some user in system.ini and then see if they have a home. set f [open $::env(windir)/system.ini] @@ -44,7 +44,7 @@ test winFile-1.2 {TclpGetUserHome} {pcOnly 95} { close $f set x } {0} -test winFile-1.3 {TclpGetUserHome} {pcOnly nt nonPortable} { +test winFile-1.4 {TclpGetUserHome} {pcOnly nt nonPortable} { catch {glob ~stanton@workgroup} } {0} diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 5b939f9..2e341bc 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.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: tclWin32Dll.c,v 1.24 2003/02/04 17:06:52 vincentdarley Exp $ + * RCS: @(#) $Id: tclWin32Dll.c,v 1.24.2.1 2003/04/14 15:45:59 vincentdarley Exp $ */ #include "tclWinInt.h" @@ -88,7 +88,7 @@ static TclWinProcs asciiProcs = { (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryA, (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesA, /* - * These two function pointers will only be set when + * The three NULL function pointers will only be set when * Tcl_FindExecutable is called. If you don't ever call that * function, the application will crash whenever WinTcl tries to call * functions through these null pointers. That is not a bug in Tcl @@ -97,6 +97,8 @@ static TclWinProcs asciiProcs = { NULL, NULL, (int (__cdecl*)(CONST TCHAR *, struct _utimbuf *)) _utime, + NULL, + NULL, }; static TclWinProcs unicodeProcs = { @@ -135,7 +137,7 @@ static TclWinProcs unicodeProcs = { (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryW, (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesW, /* - * These two function pointers will only be set when + * The three NULL function pointers will only be set when * Tcl_FindExecutable is called. If you don't ever call that * function, the application will crash whenever WinTcl tries to call * functions through these null pointers. That is not a bug in Tcl @@ -144,6 +146,8 @@ static TclWinProcs unicodeProcs = { NULL, NULL, (int (__cdecl*)(CONST TCHAR *, struct _utimbuf *)) _wutime, + NULL, + NULL, }; TclWinProcs *tclWinProcs; @@ -156,6 +160,28 @@ static Tcl_Encoding tclWinTCharEncoding; BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason, LPVOID reserved); +/* + * The following structure and linked list is to allow us to map between + * volume mount points and drive letters on the fly (no Win API exists + * for this). + */ +typedef struct MountPointMap { + CONST WCHAR* volumeName; /* Native wide string volume name */ + char driveLetter; /* Drive letter corresponding to + * the volume name. */ + struct MountPointMap* nextPtr; /* Pointer to next structure in list, + * or NULL */ +} MountPointMap; + +/* + * This is the head of the linked list, which is protected by the + * mutex which follows, for thread-enabled builds. + */ +MountPointMap *driveLetterLookup = NULL; +TCL_DECLARE_MUTEX(mountPointMap) + +/* We will need this below */ +extern Tcl_FSDupInternalRepProc NativeDupInternalRep; #ifdef __WIN32__ #ifndef STATIC_BUILD @@ -531,6 +557,14 @@ TclWinSetInterfaces( (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*, LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance, "CreateHardLinkW"); + tclWinProcs->findFirstFileExProc = + (HANDLE (WINAPI *)(CONST TCHAR*, UINT, + LPVOID, UINT, LPVOID, DWORD)) GetProcAddress(hInstance, + "FindFirstFileExW"); + tclWinProcs->getVolumeNameForVMPProc = + (BOOL (WINAPI *)(CONST TCHAR*, TCHAR*, + DWORD)) GetProcAddress(hInstance, + "GetVolumeNameForVolumeMountPointW"); FreeLibrary(hInstance); } } @@ -547,6 +581,14 @@ TclWinSetInterfaces( (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*, LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance, "CreateHardLinkA"); + tclWinProcs->findFirstFileExProc = + (HANDLE (WINAPI *)(CONST TCHAR*, UINT, + LPVOID, UINT, LPVOID, DWORD)) GetProcAddress(hInstance, + "FindFirstFileExA"); + tclWinProcs->getVolumeNameForVMPProc = + (BOOL (WINAPI *)(CONST TCHAR*, TCHAR*, + DWORD)) GetProcAddress(hInstance, + "GetVolumeNameForVolumeMountPointA"); FreeLibrary(hInstance); } } @@ -562,6 +604,11 @@ TclWinSetInterfaces( * The tclWinProcs-> look up table is still ok to use after * this call, provided no encoding conversion is required. * + * We also clean up any memory allocated in our mount point + * map which is used to follow certain kinds of symlinks. + * That code should never be used once encodings are taken + * down. + * * Results: * None. * @@ -573,10 +620,21 @@ TclWinSetInterfaces( void TclWinResetInterfaceEncodings() { + MountPointMap *dlIter, *dlIter2; if (tclWinTCharEncoding != NULL) { Tcl_FreeEncoding(tclWinTCharEncoding); tclWinTCharEncoding = NULL; } + /* Clean up the mount point map */ + Tcl_MutexLock(&mountPointMap); + dlIter = driveLetterLookup; + while (dlIter != NULL) { + dlIter2 = dlIter->nextPtr; + ckfree((char*)dlIter->volumeName); + ckfree((char*)dlIter); + dlIter = dlIter2; + } + Tcl_MutexUnlock(&mountPointMap); } /* @@ -603,6 +661,135 @@ TclWinResetInterfaces() } /* + *-------------------------------------------------------------------- + * + * TclWinDriveLetterForVolMountPoint + * + * Unfortunately, Windows provides no easy way at all to get hold + * of the drive letter for a volume mount point, but we need that + * information to understand paths correctly. So, we have to + * build an associated array to find these correctly, and allow + * quick and easy lookup from volume mount points to drive letters. + * + * We assume here that we are running on a system for which the wide + * character interfaces are used, which is valid for Win 2000 and WinXP + * which are the only systems on which this function will ever be called. + * + * Result: the drive letter, or -1 if no drive letter corresponds to + * the given mount point. + * + *-------------------------------------------------------------------- + */ +char +TclWinDriveLetterForVolMountPoint(CONST WCHAR *mountPoint) +{ + MountPointMap *dlIter, *dlPtr2; + WCHAR Target[55]; /* Target of mount at mount point */ + WCHAR drive[4] = { L'A', L':', L'\\', L'\0' }; + + /* + * Detect the volume mounted there. Unfortunately, there is no + * simple way to map a unique volume name to a DOS drive letter. + * So, we have to build an associative array. + */ + + Tcl_MutexLock(&mountPointMap); + dlIter = driveLetterLookup; + while (dlIter != NULL) { + if (wcscmp(dlIter->volumeName, mountPoint) == 0) { + /* + * We need to check whether this information is + * still valid, since either the user or various + * programs could have adjusted the mount points on + * the fly. + */ + drive[0] = L'A' + (dlIter->driveLetter - 'A'); + /* Try to read the volume mount point and see where it points */ + if ((*tclWinProcs->getVolumeNameForVMPProc)((TCHAR*)drive, + (TCHAR*)Target, 55) != 0) { + if (wcscmp((WCHAR*)dlIter->volumeName, Target) == 0) { + /* Nothing has changed */ + Tcl_MutexUnlock(&mountPointMap); + return dlIter->driveLetter; + } + } + /* + * If we reach here, unfortunately, this mount point is + * no longer valid at all + */ + if (driveLetterLookup == dlIter) { + dlPtr2 = dlIter; + driveLetterLookup = dlIter->nextPtr; + } else { + for (dlPtr2 = driveLetterLookup; + dlPtr2 != NULL; dlPtr2 = dlPtr2->nextPtr) { + if (dlPtr2->nextPtr == dlIter) { + dlPtr2->nextPtr = dlIter->nextPtr; + dlPtr2 = dlIter; + break; + } + } + } + /* Now dlPtr2 points to the structure to free */ + ckfree((char*)dlPtr2->volumeName); + ckfree((char*)dlPtr2); + /* + * Restart the loop --- we could try to be clever + * and continue half way through, but the logic is a + * bit messy, so it's cleanest just to restart + */ + dlIter = driveLetterLookup; + continue; + } + dlIter = dlIter->nextPtr; + } + + /* We couldn't find it, so we must iterate over the letters */ + + for (drive[0] = L'A'; drive[0] <= L'Z'; drive[0]++) { + /* Try to read the volume mount point and see where it points */ + if ((*tclWinProcs->getVolumeNameForVMPProc)((TCHAR*)drive, + (TCHAR*)Target, 55) != 0) { + int alreadyStored = 0; + for (dlIter = driveLetterLookup; dlIter != NULL; + dlIter = dlIter->nextPtr) { + if (wcscmp((WCHAR*)dlIter->volumeName, Target) == 0) { + alreadyStored = 1; + break; + } + } + if (!alreadyStored) { + dlPtr2 = (MountPointMap*) ckalloc(sizeof(MountPointMap)); + dlPtr2->volumeName = NativeDupInternalRep(Target); + dlPtr2->driveLetter = 'A' + (drive[0] - L'A'); + dlPtr2->nextPtr = driveLetterLookup; + driveLetterLookup = dlPtr2; + } + } + } + /* Try again */ + for (dlIter = driveLetterLookup; dlIter != NULL; + dlIter = dlIter->nextPtr) { + if (wcscmp(dlIter->volumeName, mountPoint) == 0) { + Tcl_MutexUnlock(&mountPointMap); + return dlIter->driveLetter; + } + } + /* + * The volume doesn't appear to correspond to a drive letter -- we + * remember that fact and store '-1' so we don't have to look it + * up each time. + */ + dlPtr2 = (MountPointMap*) ckalloc(sizeof(MountPointMap)); + dlPtr2->volumeName = NativeDupInternalRep((ClientData)mountPoint); + dlPtr2->driveLetter = -1; + dlPtr2->nextPtr = driveLetterLookup; + driveLetterLookup = dlPtr2; + Tcl_MutexUnlock(&mountPointMap); + return -1; +} + +/* *--------------------------------------------------------------------------- * * Tcl_WinUtfToTChar, Tcl_WinTCharToUtf -- diff --git a/win/tclWinFile.c b/win/tclWinFile.c index f44140f..068a029 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.44.2.1 2003/03/18 10:51:31 vincentdarley Exp $ + * RCS: @(#) $Id: tclWinFile.c,v 1.44.2.2 2003/04/14 15:46:00 vincentdarley Exp $ */ //#define _WIN32_WINNT 0x0500 @@ -128,6 +128,20 @@ typedef struct { WCHAR dummyBuf[MAX_PATH*3]; } DUMMY_REPARSE_BUFFER; +#ifdef HAVE_NO_FINDEX_ENUMS +/* These two aren't in VC++ 5.2 headers */ +typedef enum _FINDEX_INFO_LEVELS { + FindExInfoStandard, + FindExInfoMaxInfoLevel +} FINDEX_INFO_LEVELS; +typedef enum _FINDEX_SEARCH_OPS { + FindExSearchNameMatch, + FindExSearchLimitToDirectories, + FindExSearchLimitToDevices, + FindExSearchMaxSearchOp +} FINDEX_SEARCH_OPS; +#endif /* HAVE_NO_FINDEX_ENUMS */ + /* Other typedefs required by this code */ static time_t ToCTime(FILETIME fileTime); @@ -141,6 +155,8 @@ typedef NET_API_STATUS NET_API_FUNCTION NETAPIBUFFERFREEPROC typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC (LPWSTR servername, LPWSTR domainname, LPBYTE *bufptr); +extern Tcl_FSDupInternalRepProc NativeDupInternalRep; + /* * Declarations for local procedures defined in this file: */ @@ -162,7 +178,6 @@ static int WinLink(CONST TCHAR* LinkSource, CONST TCHAR* LinkTarget, int linkAction); static int WinSymLinkDirectory(CONST TCHAR* LinkDirectory, CONST TCHAR* LinkTarget); - /* *-------------------------------------------------------------------- @@ -249,8 +264,7 @@ WinLink(LinkSource, LinkTarget, linkAction) * * WinReadLink * - * What does 'LinkSource' point to? We need the original 'pathPtr' - * just so we can construct a path object in the correct filesystem. + * What does 'LinkSource' point to? *-------------------------------------------------------------------- */ static Tcl_Obj* @@ -429,7 +443,11 @@ TclWinSymLinkDelete(LinkOriginal, linkOnly) * * Assumption that LinkDirectory is a valid, existing directory. * - * Returns a Tcl_Obj with refCount of 1 (i.e. owned by the caller). + * Returns a Tcl_Obj with refCount of 1 (i.e. owned by the caller), + * or NULL if anything went wrong. + * + * In the future we should enhance this to return a path object + * rather than a string. *-------------------------------------------------------------------- */ static Tcl_Obj* @@ -457,38 +475,77 @@ WinReadLinkDirectory(LinkDirectory) Tcl_DString ds; CONST char *copy; int len; + int offset = 0; - Tcl_WinTCharToUtf( - (CONST char*)reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, - (int)reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength, - &ds); - - copy = Tcl_DStringValue(&ds); - len = Tcl_DStringLength(&ds); /* - * Certain native path representations on Windows have this special - * prefix to indicate that they are to be treated specially. For - * example extremely long paths, or symlinks + * Certain native path representations on Windows have a + * special prefix to indicate that they are to be treated + * specially. For example extremely long paths, or symlinks, + * or volumes mounted inside directories. + * + * There is an assumption in this code that 'wide' interfaces + * are being used (see tclWin32Dll.c), which is true for the + * only systems which support reparse tags at present. If + * that changes in the future, this code will have to be + * generalised. */ - if (*copy == '\\') { - if (0 == strncmp(copy,"\\??\\",4)) { - copy += 4; - len -= 4; - if (0 == strncmp(copy,"Volume{",7)) { - /* - * This is actually a mounted drive, which is in any - * case treated as being mounted in place, so it is - * in some sense a symlink to itself - */ - Tcl_DStringFree(&ds); - Tcl_SetErrno(EINVAL); - return NULL; + if (reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer[0] + == L'\\') { + /* Check whether this is a mounted volume */ + if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, + L"\\??\\Volume{",11) == 0) { + char drive; + /* + * There is some confusion between \??\ and \\?\ which + * we have to fix here. It doesn't seem very well + * documented. + */ + reparseBuffer->SymbolicLinkReparseBuffer + .PathBuffer[1] = L'\\'; + /* + * Check if a corresponding drive letter exists, and + * use that if it is found + */ + drive = TclWinDriveLetterForVolMountPoint(reparseBuffer + ->SymbolicLinkReparseBuffer.PathBuffer); + if (drive != -1) { + char driveSpec[3] = { + drive, ':', '\0' + }; + retVal = Tcl_NewStringObj(driveSpec,2); + Tcl_IncrRefCount(retVal); + return retVal; } - } else if (0 == strncmp(copy,"\\\\?\\",4)) { - copy += 4; - len -= 4; + /* + * This is actually a mounted drive, which doesn't + * exists as a DOS drive letter. This means the path + * isn't actually a link, although we partially treat + * it like one ('file type' will return 'link'), but + * then the link will actually just be treated like + * an ordinary directory. I don't believe any + * serious inconsistency will arise from this, but it + * is something to be aware of. + */ + Tcl_SetErrno(EINVAL); + return NULL; + } else if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer + .PathBuffer, L"\\\\?\\",4) == 0) { + /* Strip off the prefix */ + offset = 4; + } else if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer + .PathBuffer, L"\\??\\",4) == 0) { + /* Strip off the prefix */ + offset = 4; } } + + Tcl_WinTCharToUtf( + (CONST char*)reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, + (int)reparseBuffer->SymbolicLinkReparseBuffer + .SubstituteNameLength, &ds); + + copy = Tcl_DStringValue(&ds)+offset; + len = Tcl_DStringLength(&ds)-offset; retVal = Tcl_NewStringObj(copy,len); Tcl_IncrRefCount(retVal); Tcl_DStringFree(&ds); @@ -712,77 +769,97 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) DWORD attr; HANDLE handle; WIN32_FIND_DATAT data; - CONST char *dirName; + CONST char *dirName; /* utf-8 dir name, later + * with pattern appended */ int dirLength; int matchSpecialDots; - Tcl_DString ds; /* native encoding of dir */ + Tcl_DString ds; /* native encoding of dir, also used + * temporarily for other things. */ Tcl_DString dsOrig; /* utf-8 encoding of dir */ - Tcl_DString dirString; /* utf-8 encoding of dir with \'s */ Tcl_Obj *fileNamePtr; + char lastChar; /* - * Convert the path to normalized form since some interfaces only - * accept backslashes. Also, ensure that the directory ends with a - * separator character. + * Get the normalized path representation + * (the main thing is we dont want any '~' sequences). */ - fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr); + fileNamePtr = Tcl_FSGetNormalizedPath(interp, pathPtr); if (fileNamePtr == NULL) { return TCL_ERROR; } - Tcl_DStringInit(&dsOrig); - dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength); - Tcl_DStringAppend(&dsOrig, dirName, dirLength); - - Tcl_DStringInit(&dirString); - if (dirLength == 0) { - Tcl_DStringAppend(&dirString, ".\\", 2); - } else { - char *p; - - Tcl_DStringAppend(&dirString, dirName, dirLength); - for (p = Tcl_DStringValue(&dirString); *p != '\0'; p++) { - if (*p == '/') { - *p = '\\'; - } - } - p--; - /* Make sure we have a trailing directory delimiter */ - if ((*p != '\\') && (*p != ':')) { - Tcl_DStringAppend(&dirString, "\\", 1); - Tcl_DStringAppend(&dsOrig, "/", 1); - dirLength++; - } - } - dirName = Tcl_DStringValue(&dirString); /* - * First verify that the specified path is actually a directory. + * Verify that the specified path exists and + * is actually a directory. */ - - native = Tcl_WinUtfToTChar(dirName, Tcl_DStringLength(&dirString), - &ds); + native = Tcl_FSGetNativePath(pathPtr); + if (native == NULL) { + return TCL_OK; + } attr = (*tclWinProcs->getFileAttributesProc)(native); - Tcl_DStringFree(&ds); if ((attr == 0xffffffff) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) { - Tcl_DStringFree(&dirString); return TCL_OK; } + /* + * Build up the directory name for searching, including + * a trailing directory separator. + */ + + Tcl_DStringInit(&dsOrig); + dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength); + Tcl_DStringAppend(&dsOrig, dirName, dirLength); + + lastChar = dirName[dirLength -1]; + if ((lastChar != '\\') && (lastChar != '/') && (lastChar != ':')) { + Tcl_DStringAppend(&dsOrig, "/", 1); + dirLength++; + } + dirName = Tcl_DStringValue(&dsOrig); + /* - * We need to check all files in the directory, so append a *.* - * to the path. + * We need to check all files in the directory, so we append + * '*.*' to the path, unless the pattern we've been given is + * rather simple, when we can use that instead. */ - dirName = Tcl_DStringAppend(&dirString, "*.*", 3); + if (strpbrk(pattern, "[]\\") == NULL) { + /* + * The pattern is a simple one containing just '*' and/or '?'. + * This means we can get the OS to help us, by passing + * it the pattern. + */ + dirName = Tcl_DStringAppend(&dsOrig, pattern, -1); + } else { + dirName = Tcl_DStringAppend(&dsOrig, "*.*", 3); + } native = Tcl_WinUtfToTChar(dirName, -1, &ds); - handle = (*tclWinProcs->findFirstFileProc)(native, &data); + if (tclWinProcs->findFirstFileExProc == NULL + || (types == NULL) + || (types->type != TCL_GLOB_TYPE_DIR)) { + handle = (*tclWinProcs->findFirstFileProc)(native, &data); + } else { + /* We can be more efficient, for pure directory requests */ + handle = (*tclWinProcs->findFirstFileExProc)(native, + FindExInfoStandard, &data, + FindExSearchLimitToDirectories, NULL, 0); + } Tcl_DStringFree(&ds); if (handle == INVALID_HANDLE_VALUE) { - Tcl_DStringFree(&dirString); - TclWinConvertError(GetLastError()); + DWORD err = GetLastError(); + if (err == ERROR_FILE_NOT_FOUND) { + /* + * We used our 'pattern' above, and matched nothing + * This means we just return TCL_OK, indicating + * no results found. + */ + Tcl_DStringFree(&dsOrig); + return TCL_OK; + } + TclWinConvertError(err); Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't read directory \"", Tcl_DStringValue(&dsOrig), "\": ", @@ -791,6 +868,12 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) return TCL_ERROR; } + /* + * We may use this later, so we must restore it to its + * length including the directory delimiter + */ + Tcl_DStringSetLength(&dsOrig, dirLength); + /* * Check to see if the pattern should match the special * . and .. names, referring to the current directory, @@ -884,7 +967,6 @@ TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) } while ((*tclWinProcs->findNextFileProc)(handle, &data) == TRUE); FindClose(handle); - Tcl_DStringFree(&dirString); Tcl_DStringFree(&dsOrig); return TCL_OK; } @@ -952,10 +1034,9 @@ WinIsDrive( * volume, because for NTFS root volumes, the getFileAttributesProc * returns a 'hidden' attribute when it should not. * - * We only ever make one call to a 'get attributes' routine here, - * so that this function is as fast as possible. Unfortunately, - * it still means we have to make the call for every single file - * we return from 'glob', which is not ideal. + * We never make any calss to a 'get attributes' routine here, + * since we have arranged things so that our caller already knows + * such information. * * Results: * 0 = file doesn't match diff --git a/win/tclWinInt.h b/win/tclWinInt.h index 0e0f11d..b7299eb 100644 --- a/win/tclWinInt.h +++ b/win/tclWinInt.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: tclWinInt.h,v 1.20 2003/02/04 17:06:53 vincentdarley Exp $ + * RCS: @(#) $Id: tclWinInt.h,v 1.20.2.1 2003/04/14 15:46:01 vincentdarley Exp $ */ #ifndef _TCLWININT @@ -102,7 +102,11 @@ typedef struct TclWinProcs { LPSECURITY_ATTRIBUTES); INT (__cdecl *utimeProc)(CONST TCHAR*, struct _utimbuf *); - + /* These two are also NULL at start; see comment above */ + HANDLE (WINAPI *findFirstFileExProc)(CONST TCHAR*, UINT, + LPVOID, UINT, + LPVOID, DWORD); + BOOL (WINAPI *getVolumeNameForVMPProc)(CONST TCHAR*, TCHAR*, DWORD); } TclWinProcs; EXTERN TclWinProcs *tclWinProcs; @@ -119,6 +123,7 @@ EXTERN int TclWinSymLinkCopyDirectory(CONST TCHAR* LinkOriginal, CONST TCHAR* LinkCopy); EXTERN int TclWinSymLinkDelete(CONST TCHAR* LinkOriginal, int linkOnly); +EXTERN char TclWinDriveLetterForVolMountPoint(CONST WCHAR *mountPoint); #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) EXTERN void TclWinFreeAllocCache(void); EXTERN void TclFreeAllocCache(void *); -- cgit v0.12