diff options
Diffstat (limited to 'generic/tclPathObj.c')
| -rw-r--r-- | generic/tclPathObj.c | 3061 |
1 files changed, 1635 insertions, 1426 deletions
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index b27b6b5..fe6063f 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -1,208 +1,213 @@ -/* +/* * tclPathObj.c -- * - * This file contains the implementation of Tcl's "path" object - * type used to represent and manipulate a general (virtual) - * filesystem entity in an efficient manner. + * This file contains the implementation of Tcl's "path" object type used + * to represent and manipulate a general (virtual) filesystem entity in + * an efficient manner. * * Copyright (c) 2003 Vince Darley. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclPathObj.c,v 1.33 2004/06/10 16:55:39 dgp Exp $ + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclFileSystem.h" /* - * Prototypes for procedures defined later in this file. + * Prototypes for functions defined later in this file. */ -static void DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr)); -static void FreeFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *pathPtr)); -static void UpdateStringOfFsPath _ANSI_ARGS_((Tcl_Obj *pathPtr)); -static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *pathPtr)); -static int FindSplitPos _ANSI_ARGS_((CONST char *path, int separator)); -static int IsSeparatorOrNull _ANSI_ARGS_((int ch)); -static Tcl_Obj* GetExtension _ANSI_ARGS_((Tcl_Obj *pathPtr)); - +static Tcl_Obj * AppendPath(Tcl_Obj *head, Tcl_Obj *tail); +static void DupFsPathInternalRep(Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr); +static void FreeFsPathInternalRep(Tcl_Obj *pathPtr); +static void UpdateStringOfFsPath(Tcl_Obj *pathPtr); +static int SetFsPathFromAny(Tcl_Interp *interp, Tcl_Obj *pathPtr); +static int FindSplitPos(const char *path, int separator); +static int IsSeparatorOrNull(int ch); +static Tcl_Obj * GetExtension(Tcl_Obj *pathPtr); +static int MakePathFromNormalized(Tcl_Interp *interp, + Tcl_Obj *pathPtr); /* - * Define the 'path' object type, which Tcl uses to represent - * file paths internally. + * Define the 'path' object type, which Tcl uses to represent file paths + * internally. */ -Tcl_ObjType tclFsPathType = { + +static const Tcl_ObjType tclFsPathType = { "path", /* name */ FreeFsPathInternalRep, /* freeIntRepProc */ - DupFsPathInternalRep, /* dupIntRepProc */ + 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 both 'translatedPathPtr' and 'normPathPtr' can be a - * circular reference to the container Tcl_Obj of this 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 both 'translatedPathPtr' and 'normPathPtr' can be a circular + * reference to the container Tcl_Obj of this FsPath. + * * There are two cases, with the first being the most common: - * - * (i) flags == 0, => Ordinary path. - * - * translatedPathPtr contains the translated path (which may be - * a circular reference to the object itself). If it is NULL - * then the path is pure normalized (and the normPathPtr will be - * a circular reference). cwdPtr is null for an absolute path, - * and non-null for a relative path (unless the cwd has never been - * set, in which case the cwdPtr may also be null for a relative path). - * + * + * (i) flags == 0, => Ordinary path. + * + * translatedPathPtr contains the translated path (which may be a circular + * reference to the object itself). If it is NULL then the path is pure + * normalized (and the normPathPtr will be a circular reference). cwdPtr is + * null for an absolute path, and non-null for a relative path (unless the cwd + * has never been set, in which case the cwdPtr may also be null for a + * relative path). + * * (ii) flags != 0, => Special path, see TclNewFSPathObj - * - * Now, this is a path like 'file join $dir $tail' where, cwdPtr is - * the $dir and normPathPtr is the $tail. - * + * + * Now, this is a path like 'file join $dir $tail' where, cwdPtr is the $dir + * and normPathPtr is the $tail. + * */ + 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 - - * see below. */ - 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. */ + 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 - see + * below. */ + 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. */ + const Tcl_Filesystem *fsPtr;/* The Tcl_Filesystem that claims this path */ } FsPath; /* * Flag values for FsPath->flags. */ + #define TCLPATH_APPENDED 1 +#define TCLPATH_NEEDNORM 4 -/* - * Define some macros to give us convenient access to path-object - * specific fields. +/* + * Define some macros to give us convenient access to path-object specific + * fields. */ -#define PATHOBJ(pathPtr) (pathPtr->internalRep.otherValuePtr) -#define PATHFLAGS(pathPtr) \ - (((FsPath*)(pathPtr->internalRep.otherValuePtr))->flags) +#define PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.twoPtrValue.ptr1) +#define SETPATHOBJ(pathPtr,fsPathPtr) \ + ((pathPtr)->internalRep.twoPtrValue.ptr1 = (void *) (fsPathPtr)) +#define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags) /* *--------------------------------------------------------------------------- * * TclFSNormalizeAbsolutePath -- * - * Description: - * Takes an absolute path specification and computes a 'normalized' - * path from it. - * - * A normalized path is one which has all '../', './' removed. - * Also it is one which is in the 'standard' format for the native - * platform. On Unix, this means the path must be free of - * symbolic links/aliases, and on Windows it means we want the - * long form, with that long form's case-dependence (which gives - * us a unique, case-dependent path). - * - * The behaviour of this function if passed a non-absolute path - * is NOT defined. - * - * pathPtr may have a refCount of zero, or may be a shared - * object. + * Takes an absolute path specification and computes a 'normalized' path + * from it. + * + * A normalized path is one which has all '../', './' removed. Also it is + * one which is in the 'standard' format for the native platform. On + * Unix, this means the path must be free of symbolic links/aliases, and + * on Windows it means we want the long form, with that long form's + * case-dependence (which gives us a unique, case-dependent path). + * + * The behaviour of this function if passed a non-absolute path is NOT + * defined. + * + * pathPtr may have a refCount of zero, or may be a shared object. * * Results: - * The result is returned in a Tcl_Obj with a refCount of 1, - * which is therefore owned by the caller. It must be - * freed (with Tcl_DecrRefCount) by the caller when no longer needed. + * The result is returned in a Tcl_Obj with a refCount of 1, which is + * therefore owned by the caller. It must be freed (with + * Tcl_DecrRefCount) by the caller when no longer needed. * * Side effects: * None (beyond the memory allocation for the result). * * Special note: * This code was originally based on code from Matt Newman and - * Jean-Claude Wippler, but has since been totally rewritten by - * Vince Darley to deal with symbolic links. + * Jean-Claude Wippler, but has since been totally rewritten by Vince + * Darley to deal with symbolic links. * *--------------------------------------------------------------------------- */ -Tcl_Obj* -TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) - Tcl_Interp* interp; /* Interpreter to use */ - Tcl_Obj *pathPtr; /* Absolute path to normalize */ - ClientData *clientDataPtr; /* If non-NULL, then may be set to the - * fs-specific clientData for this path. - * This will happen when that extra - * information can be calculated efficiently - * as a side-effect of normalization. */ + +Tcl_Obj * +TclFSNormalizeAbsolutePath( + Tcl_Interp *interp, /* Interpreter to use */ + Tcl_Obj *pathPtr) /* Absolute path to normalize */ { - ClientData clientData = NULL; - CONST char *dirSep, *oldDirSep; - int first = 1; /* Set to zero once we've passed the first - * directory separator - we can't use '..' to - * remove the volume in a path. */ + const char *dirSep, *oldDirSep; + int first = 1; /* Set to zero once we've passed the first + * directory separator - we can't use '..' to + * remove the volume in a path. */ Tcl_Obj *retVal = NULL; - dirSep = Tcl_GetString(pathPtr); - + dirSep = TclGetString(pathPtr); + if (tclPlatform == TCL_PLATFORM_WINDOWS) { - if (dirSep[0] != 0 && dirSep[1] == ':' && - (dirSep[2] == '/' || dirSep[2] == '\\')) { + if ( (dirSep[0] == '/' || dirSep[0] == '\\') + && (dirSep[1] == '/' || dirSep[1] == '\\') + && (dirSep[2] == '?') + && (dirSep[3] == '/' || dirSep[3] == '\\')) { + /* NT extended path */ + dirSep += 4; + + if ( (dirSep[0] == 'U' || dirSep[0] == 'u') + && (dirSep[1] == 'N' || dirSep[1] == 'n') + && (dirSep[2] == 'C' || dirSep[2] == 'c') + && (dirSep[3] == '/' || dirSep[3] == '\\')) { + /* NT extended UNC path */ + dirSep += 4; + } + } + if (dirSep[0] != 0 && dirSep[1] == ':' && + (dirSep[2] == '/' || dirSep[2] == '\\')) { /* Do nothing */ - } else if ((dirSep[0] == '/' || dirSep[0] == '\\') - && (dirSep[1] == '/' || dirSep[1] == '\\')) { - /* - * UNC style path, where we must skip over the - * first separator, since the first two segments - * are actually inseparable. + } else if ((dirSep[0] == '/' || dirSep[0] == '\\') + && (dirSep[1] == '/' || dirSep[1] == '\\')) { + /* + * UNC style path, where we must skip over the first separator, + * since the first two segments are actually inseparable. */ + dirSep += 2; dirSep += FindSplitPos(dirSep, '/'); if (*dirSep != 0) { - dirSep++; + dirSep++; } } } - - /* - * Scan forward from one directory separator to the next, - * checking for '..' and '.' sequences which must be handled - * specially. In particular handling of '..' can be complicated - * if the directory before is a link, since we will have to - * expand the link to be able to back up one level. + + /* + * Scan forward from one directory separator to the next, checking for + * '..' and '.' sequences which must be handled specially. In particular + * handling of '..' can be complicated if the directory before is a link, + * since we will have to expand the link to be able to back up one level. */ + while (*dirSep != 0) { oldDirSep = dirSep; if (!first) { dirSep++; } - dirSep += FindSplitPos(dirSep, '/'); + dirSep += FindSplitPos(dirSep, '/'); if (dirSep[0] == 0 || dirSep[1] == 0) { if (retVal != NULL) { Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep); @@ -214,14 +219,22 @@ TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep); oldDirSep = dirSep; } - again: + again: if (IsSeparatorOrNull(dirSep[2])) { - /* Need to skip '.' in the path */ + /* + * Need to skip '.' in the path. + */ + int curLen; + if (retVal == NULL) { - CONST char *path = Tcl_GetString(pathPtr); + const char *path = TclGetString(pathPtr); retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } + Tcl_GetStringFromObj(retVal, &curLen); + if (curLen == 0) { + Tcl_AppendToObj(retVal, dirSep, 1); + } dirSep += 2; oldDirSep = dirSep; if (dirSep[0] != 0 && dirSep[1] == '.') { @@ -230,56 +243,88 @@ TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) continue; } if (dirSep[2] == '.' && IsSeparatorOrNull(dirSep[3])) { - Tcl_Obj *link; + Tcl_Obj *linkObj; int curLen; char *linkStr; - /* Have '..' so need to skip previous directory */ + + /* + * Have '..' so need to skip previous directory. + */ + if (retVal == NULL) { - CONST char *path = Tcl_GetString(pathPtr); + const char *path = TclGetString(pathPtr); + retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } + Tcl_GetStringFromObj(retVal, &curLen); + if (curLen == 0) { + Tcl_AppendToObj(retVal, dirSep, 1); + } if (!first || (tclPlatform == TCL_PLATFORM_UNIX)) { - link = Tcl_FSLink(retVal, NULL, 0); - if (link != NULL) { - /* - * Got a link. Need to check if the link - * is relative or absolute, for those platforms - * where relative links exist. + linkObj = Tcl_FSLink(retVal, NULL, 0); + + /* Safety check in case driver caused sharing */ + if (Tcl_IsShared(retVal)) { + TclDecrRefCount(retVal); + retVal = Tcl_DuplicateObj(retVal); + Tcl_IncrRefCount(retVal); + } + + if (linkObj != NULL) { + /* + * Got a link. Need to check if the link is relative + * or absolute, for those platforms where relative + * links exist. */ - if ((tclPlatform != TCL_PLATFORM_WINDOWS) - && (Tcl_FSGetPathType(link) == TCL_PATH_RELATIVE)) { - /* - * We need to follow this link which is - * relative to retVal's directory. This - * means concatenating the link onto - * the directory of the path so far. + + if (tclPlatform != TCL_PLATFORM_WINDOWS + && Tcl_FSGetPathType(linkObj) + == TCL_PATH_RELATIVE) { + /* + * We need to follow this link which is relative + * to retVal's directory. This means concatenating + * the link onto the directory of the path so far. */ - CONST char *path = Tcl_GetStringFromObj(retVal, - &curLen); + + const char *path = + Tcl_GetStringFromObj(retVal, &curLen); + while (--curLen >= 0) { - if (IsSeparatorOrNull(path[curLen])) { - break; - } - } - if (Tcl_IsShared(retVal)) { - Tcl_DecrRefCount(retVal); - retVal = Tcl_DuplicateObj(retVal); - Tcl_IncrRefCount(retVal); + if (IsSeparatorOrNull(path[curLen])) { + break; + } } - /* We want the trailing slash */ + + /* + * We want the trailing slash. + */ + Tcl_SetObjLength(retVal, curLen+1); - Tcl_AppendObjToObj(retVal, link); - Tcl_DecrRefCount(link); + Tcl_AppendObjToObj(retVal, linkObj); + TclDecrRefCount(linkObj); linkStr = Tcl_GetStringFromObj(retVal, &curLen); } else { - /* Absolute link */ - Tcl_DecrRefCount(retVal); - retVal = link; + /* + * Absolute link. + */ + + TclDecrRefCount(retVal); + if (Tcl_IsShared(linkObj)) { + retVal = Tcl_DuplicateObj(linkObj); + TclDecrRefCount(linkObj); + } else { + retVal = linkObj; + } linkStr = Tcl_GetStringFromObj(retVal, &curLen); - /* Convert to forward-slashes on windows */ + + /* + * Convert to forward-slashes on windows. + */ + if (tclPlatform == TCL_PLATFORM_WINDOWS) { int i; + for (i = 0; i < curLen; i++) { if (linkStr[i] == '\\') { linkStr[i] = '/'; @@ -290,16 +335,30 @@ TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) } else { linkStr = Tcl_GetStringFromObj(retVal, &curLen); } - /* Either way, we now remove the last path element */ + + /* + * Either way, we now remove the last path element (but + * not the first character of the path). + */ + while (--curLen >= 0) { if (IsSeparatorOrNull(linkStr[curLen])) { - Tcl_SetObjLength(retVal, curLen); + if (curLen) { + Tcl_SetObjLength(retVal, curLen); + } else { + Tcl_SetObjLength(retVal, 1); + } break; } } } dirSep += 3; oldDirSep = dirSep; + + if ((curLen == 0) && (dirSep[0] != 0)) { + Tcl_SetObjLength(retVal, 0); + } + if (dirSep[0] != 0 && dirSep[1] == '.') { goto again; } @@ -311,41 +370,45 @@ TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep); } } - - /* - * If we didn't make any changes, just use the input path + + /* + * If we didn't make any changes, just use the input path. */ + if (retVal == NULL) { retVal = pathPtr; Tcl_IncrRefCount(retVal); - + if (Tcl_IsShared(retVal)) { - /* - * Unfortunately, the platform-specific normalization code - * which will be called below has no way of dealing with the - * case where an object is shared. It is expecting to - * modify an object in place. So, we must duplicate this - * here to ensure an object with a single ref-count. - * - * If that changes in the future (e.g. the normalize proc is - * given one object and is able to return a different one), - * then we could remove this code. + /* + * Unfortunately, the platform-specific normalization code which + * will be called below has no way of dealing with the case where + * an object is shared. It is expecting to modify an object in + * place. So, we must duplicate this here to ensure an object with + * a single ref-count. + * + * If that changes in the future (e.g. the normalize proc is given + * one object and is able to return a different one), then we + * could remove this code. */ - Tcl_DecrRefCount(retVal); + + TclDecrRefCount(retVal); retVal = Tcl_DuplicateObj(pathPtr); Tcl_IncrRefCount(retVal); } } - /* - * Ensure a windows drive like C:/ has a trailing separator + /* + * Ensure a windows drive like C:/ has a trailing separator. */ + if (tclPlatform == TCL_PLATFORM_WINDOWS) { int len; - CONST char *path = Tcl_GetStringFromObj(retVal, &len); + const char *path = Tcl_GetStringFromObj(retVal, &len); + if (len == 2 && path[0] != 0 && path[1] == ':') { if (Tcl_IsShared(retVal)) { - Tcl_DecrRefCount(retVal); + TclDecrRefCount(retVal); retVal = Tcl_DuplicateObj(retVal); Tcl_IncrRefCount(retVal); } @@ -353,28 +416,30 @@ TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) } } - /* - * Now we have an absolute path, with no '..', '.' sequences, - * but it still may not be in 'unique' form, depending on the - * platform. For instance, Unix is case-sensitive, so the - * path is ok. Windows is case-insensitive, and also has the - * weird 'longname/shortname' thing (e.g. C:/Program Files/ and - * C:/Progra~1/ are equivalent). - * - * Virtual file systems which may be registered may have - * other criteria for normalizing a path. + /* + * Now we have an absolute path, with no '..', '.' sequences, but it still + * may not be in 'unique' form, depending on the platform. For instance, + * Unix is case-sensitive, so the path is ok. Windows is case-insensitive, + * and also has the weird 'longname/shortname' thing (e.g. C:/Program + * Files/ and C:/Progra~1/ are equivalent). + * + * Virtual file systems which may be registered may have other criteria + * for normalizing a path. + */ + + TclFSNormalizeToUniquePath(interp, retVal, 0); + + /* + * Since we know it is a normalized path, we can actually convert this + * object into an FsPath for greater efficiency */ - TclFSNormalizeToUniquePath(interp, retVal, 0, &clientData); - /* - * Since we know it is a normalized path, we can - * actually convert this object into an FsPath for - * greater efficiency + + MakePathFromNormalized(interp, retVal); + + /* + * This has a refCount of 1 for the caller, unlike many Tcl_Obj APIs. */ - TclFSMakePathFromNormalized(interp, retVal, clientData); - if (clientDataPtr != NULL) { - *clientDataPtr = clientData; - } - /* This has a refCount of 1 for the caller */ + return retVal; } @@ -383,8 +448,8 @@ TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) * * Tcl_FSGetPathType -- * - * Determines whether a given path is relative to the current - * directory, relative to the current volume, or absolute. + * 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 @@ -397,8 +462,8 @@ TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) */ Tcl_PathType -Tcl_FSGetPathType(pathPtr) - Tcl_Obj *pathPtr; +Tcl_FSGetPathType( + Tcl_Obj *pathPtr) { return TclFSGetPathType(pathPtr, NULL, NULL); } @@ -408,18 +473,17 @@ Tcl_FSGetPathType(pathPtr) * * TclFSGetPathType -- * - * 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). + * 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. + * 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. @@ -428,27 +492,38 @@ Tcl_FSGetPathType(pathPtr) */ Tcl_PathType -TclFSGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr) - Tcl_Obj *pathPtr; - Tcl_Filesystem **filesystemPtrPtr; - int *driveNameLengthPtr; +TclFSGetPathType( + Tcl_Obj *pathPtr, + const Tcl_Filesystem **filesystemPtrPtr, + int *driveNameLengthPtr) { + FsPath *fsPathPtr; + if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) { - return TclGetPathType(pathPtr, filesystemPtrPtr, - driveNameLengthPtr, NULL); - } else { - FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathPtr); - if (fsPathPtr->cwdPtr != NULL) { - if (PATHFLAGS(pathPtr) == 0) { - return TCL_PATH_RELATIVE; - } - return TclFSGetPathType(fsPathPtr->cwdPtr, filesystemPtrPtr, - driveNameLengthPtr); - } else { - return TclGetPathType(pathPtr, filesystemPtrPtr, - driveNameLengthPtr, NULL); - } + return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, + NULL); + } + + fsPathPtr = PATHOBJ(pathPtr); + if (fsPathPtr->cwdPtr == NULL) { + return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, + NULL); + } + + if (PATHFLAGS(pathPtr) == 0) { + /* The path is not absolute... */ +#ifdef _WIN32 + /* ... on Windows we must make another call to determine whether + * it's relative or volumerelative [Bug 2571597]. */ + return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, + NULL); +#else + /* On other systems, quickly deduce !absolute -> relative */ + return TCL_PATH_RELATIVE; +#endif } + return TclFSGetPathType(fsPathPtr->cwdPtr, filesystemPtrPtr, + driveNameLengthPtr); } /* @@ -456,132 +531,153 @@ TclFSGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr) * * TclPathPart * - * This procedure calculates the requested part of the given - * path, which can be: - * + * This function calculates the requested part of the given path, which + * can be: + * * - the directory above ('file dirname') * - the tail ('file tail') * - the extension ('file extension') * - the root ('file root') - * - * The 'portion' parameter dictates which of these to calculate. - * There are a number of special cases both to be more efficient, - * and because the behaviour when given a path with only a single - * element is defined to require the expansion of that single - * element, where possible. - * - * Should look into integrating 'FileBasename' in tclFCmd.c into - * this function. - * + * + * The 'portion' parameter dictates which of these to calculate. There + * are a number of special cases both to be more efficient, and because + * the behaviour when given a path with only a single element is defined + * to require the expansion of that single element, where possible. + * + * Should look into integrating 'FileBasename' in tclFCmd.c into this + * function. + * * Results: - * NULL if an error occurred, otherwise a Tcl_Obj owned by - * the caller (i.e. most likely with refCount 1). + * NULL if an error occurred, otherwise a Tcl_Obj owned by the caller + * (i.e. most likely with refCount 1). * * Side effects: - * None. + * None. * *--------------------------------------------------------------------------- */ -Tcl_Obj* -TclPathPart(interp, pathPtr, portion) - Tcl_Interp *interp; /* Used for error reporting */ - Tcl_Obj *pathPtr; /* Path to take dirname of */ - Tcl_PathPart portion; /* Requested portion of name */ +Tcl_Obj * +TclPathPart( + Tcl_Interp *interp, /* Used for error reporting */ + Tcl_Obj *pathPtr, /* Path to take dirname of */ + Tcl_PathPart portion) /* Requested portion of name */ { if (pathPtr->typePtr == &tclFsPathType) { - FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathPtr); + FsPath *fsPathPtr = PATHOBJ(pathPtr); + if (PATHFLAGS(pathPtr) != 0) { switch (portion) { - case TCL_PATH_DIRNAME: { - /* - * Check if the joined-on bit has any directory - * delimiters in it. If so, the 'dirname' would - * be a joining of the main part with the dirname - * of the joined-on bit. We could handle that - * special case here, but we don't, and instead - * just use the standardPath code. - */ - CONST char *rest = Tcl_GetString(fsPathPtr->normPathPtr); - if (strchr(rest, '/') != NULL) { - goto standardPath; - } - if ((tclPlatform == TCL_PLATFORM_WINDOWS) - && (strchr(rest, '\\') != NULL)) { - goto standardPath; - } - /* - * The joined-on path is simple, so we can just - * return here. - */ - Tcl_IncrRefCount(fsPathPtr->cwdPtr); - return fsPathPtr->cwdPtr; + case TCL_PATH_DIRNAME: { + /* + * Check if the joined-on bit has any directory delimiters in + * it. If so, the 'dirname' would be a joining of the main + * part with the dirname of the joined-on bit. We could handle + * that special case here, but we don't, and instead just use + * the standardPath code. + */ + + int numBytes; + const char *rest = + Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes); + + if (strchr(rest, '/') != NULL) { + goto standardPath; } - case TCL_PATH_TAIL: { - /* - * Check if the joined-on bit has any directory - * delimiters in it. If so, the 'tail' would - * be only the part following the last delimiter. - * We could handle that special case here, but we - * don't, and instead just use the standardPath code. - */ - CONST char *rest = Tcl_GetString(fsPathPtr->normPathPtr); - if (strchr(rest, '/') != NULL) { - goto standardPath; - } - if ((tclPlatform == TCL_PLATFORM_WINDOWS) - && (strchr(rest, '\\') != NULL)) { - goto standardPath; - } - Tcl_IncrRefCount(fsPathPtr->normPathPtr); - return fsPathPtr->normPathPtr; + /* + * If the joined-on bit is empty, then [file dirname] is + * documented to return all but the last non-empty element + * of the path, so we need to split apart the main part to + * get the right answer. We could do that here, but it's + * simpler to fall back to the standardPath code. + * [Bug 2710920] + */ + if (numBytes == 0) { + goto standardPath; } - case TCL_PATH_EXTENSION: { - return GetExtension(fsPathPtr->normPathPtr); + if (tclPlatform == TCL_PLATFORM_WINDOWS + && strchr(rest, '\\') != NULL) { + goto standardPath; } - case TCL_PATH_ROOT: { - /* Unimplemented */ - CONST char *fileName, *extension; - int length; - fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr, - &length); - extension = TclGetExtension(fileName); - if (extension == NULL) { - /* - * There is no extension so the root is the - * same as the path we were given. - */ - Tcl_IncrRefCount(pathPtr); - return pathPtr; - } else { - /* - * Duplicate the object we were given and - * then trim off the extension of the - * tail component of the path. - */ - Tcl_Obj *root; - FsPath *fsDupPtr; - root = Tcl_DuplicateObj(pathPtr); - Tcl_IncrRefCount(root); - fsDupPtr = (FsPath*) PATHOBJ(root); - if (Tcl_IsShared(fsDupPtr->normPathPtr)) { - Tcl_DecrRefCount(fsDupPtr->normPathPtr); - fsDupPtr->normPathPtr = Tcl_NewStringObj(fileName, - (int)(length - strlen(extension))); - Tcl_IncrRefCount(fsDupPtr->normPathPtr); - } else { - Tcl_SetObjLength(fsDupPtr->normPathPtr, - (int)(length - strlen(extension))); - } - return root; - } + + /* + * The joined-on path is simple, so we can just return here. + */ + + Tcl_IncrRefCount(fsPathPtr->cwdPtr); + return fsPathPtr->cwdPtr; + } + case TCL_PATH_TAIL: { + /* + * Check if the joined-on bit has any directory delimiters in + * it. If so, the 'tail' would be only the part following the + * last delimiter. We could handle that special case here, but + * we don't, and instead just use the standardPath code. + */ + + int numBytes; + const char *rest = + Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes); + + if (strchr(rest, '/') != NULL) { + goto standardPath; } - default: { - /* We should never get here */ - Tcl_Panic("Bad portion to TclPathPart"); - /* For less clever compilers */ - return NULL; + /* + * If the joined-on bit is empty, then [file tail] is + * documented to return the last non-empty element + * of the path, so we need to split off the last element + * of the main part to get the right answer. We could do + * that here, but it's simpler to fall back to the + * standardPath code. [Bug 2710920] + */ + if (numBytes == 0) { + goto standardPath; + } + if (tclPlatform == TCL_PLATFORM_WINDOWS + && strchr(rest, '\\') != NULL) { + goto standardPath; } + Tcl_IncrRefCount(fsPathPtr->normPathPtr); + return fsPathPtr->normPathPtr; + } + case TCL_PATH_EXTENSION: + return GetExtension(fsPathPtr->normPathPtr); + case TCL_PATH_ROOT: { + const char *fileName, *extension; + int length; + + fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr, + &length); + extension = TclGetExtension(fileName); + if (extension == NULL) { + /* + * There is no extension so the root is the same as the + * path we were given. + */ + + Tcl_IncrRefCount(pathPtr); + return pathPtr; + } else { + /* + * Need to return the whole path with the extension + * suffix removed. Do that by joining our "head" to + * our "tail" with the extension suffix removed from + * the tail. + */ + + Tcl_Obj *resultPtr = + TclNewFSPathObj(fsPathPtr->cwdPtr, fileName, + (int)(length - strlen(extension))); + + Tcl_IncrRefCount(resultPtr); + return resultPtr; + } + } + default: + /* We should never get here */ + Tcl_Panic("Bad portion to TclPathPart"); + /* For less clever compilers */ + return NULL; } } else if (fsPathPtr->cwdPtr != NULL) { /* Relative path */ @@ -592,43 +688,43 @@ TclPathPart(interp, pathPtr, portion) } } else { int splitElements; - Tcl_Obj *splitPtr; - Tcl_Obj *resultPtr; - standardPath: + Tcl_Obj *splitPtr, *resultPtr; - resultPtr = NULL; - if (portion == TCL_PATH_EXTENSION) { + standardPath: + resultPtr = NULL; + if (portion == TCL_PATH_EXTENSION) { return GetExtension(pathPtr); - } else if (portion == TCL_PATH_ROOT) { + } else if (portion == TCL_PATH_ROOT) { int length; - CONST char *fileName, *extension; - + const char *fileName, *extension; + fileName = Tcl_GetStringFromObj(pathPtr, &length); extension = TclGetExtension(fileName); if (extension == NULL) { Tcl_IncrRefCount(pathPtr); return pathPtr; } else { - Tcl_Obj *root = Tcl_NewStringObj(fileName, + Tcl_Obj *root = Tcl_NewStringObj(fileName, (int) (length - strlen(extension))); + Tcl_IncrRefCount(root); return root; } - } - - /* - * The behaviour we want here is slightly different to - * the standard Tcl_FSSplitPath in the handling of home - * directories; Tcl_FSSplitPath preserves the "~" while - * this code computes the actual full path name, if we - * had just a single component. - */ + } + + /* + * The behaviour we want here is slightly different to the standard + * Tcl_FSSplitPath in the handling of home directories; + * Tcl_FSSplitPath preserves the "~" while this code computes the + * actual full path name, if we had just a single component. + */ + splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements); Tcl_IncrRefCount(splitPtr); - if ((splitElements == 1) && (Tcl_GetString(pathPtr)[0] == '~')) { + if (splitElements == 1 && TclGetString(pathPtr)[0] == '~') { Tcl_Obj *norm; - - Tcl_DecrRefCount(splitPtr); + + TclDecrRefCount(splitPtr); norm = Tcl_FSGetNormalizedPath(interp, pathPtr); if (norm == NULL) { return NULL; @@ -638,49 +734,50 @@ TclPathPart(interp, pathPtr, portion) } if (portion == TCL_PATH_TAIL) { /* - * Return the last component, unless it is the only component, - * and it is the root of an absolute path. + * Return the last component, unless it is the only component, and + * it is the root of an absolute path. */ - if ((splitElements > 0) && ((splitElements > 1) - || (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE))) { + if ((splitElements > 0) && ((splitElements > 1) || + (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE))) { Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &resultPtr); } else { resultPtr = Tcl_NewObj(); } } else { /* - * Return all but the last component. If there is only one + * Return all but the last component. If there is only one * component, return it if the path was non-relative, otherwise * return the current directory. */ if (splitElements > 1) { resultPtr = Tcl_FSJoinPath(splitPtr, splitElements - 1); - } else if (splitElements == 0 || - (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE)) { - resultPtr = Tcl_NewStringObj(".", 1); + } else if (splitElements == 0 || + (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE)) { + TclNewLiteralStringObj(resultPtr, "."); } else { Tcl_ListObjIndex(NULL, splitPtr, 0, &resultPtr); } } Tcl_IncrRefCount(resultPtr); - Tcl_DecrRefCount(splitPtr); + TclDecrRefCount(splitPtr); return resultPtr; } } /* - * Simple helper function + * Simple helper function */ -static Tcl_Obj* -GetExtension(pathPtr) - Tcl_Obj *pathPtr; + +static Tcl_Obj * +GetExtension( + Tcl_Obj *pathPtr) { - CONST char *tail, *extension; + const char *tail, *extension; Tcl_Obj *ret; - - tail = Tcl_GetString(pathPtr); + + tail = TclGetString(pathPtr); extension = TclGetExtension(tail); if (extension == NULL) { ret = Tcl_NewObj(); @@ -696,137 +793,152 @@ GetExtension(pathPtr) * * Tcl_FSJoinPath -- * - * This function takes the given Tcl_Obj, which should be a valid - * list, and returns the path object given by considering the - * first 'elements' elements as valid path segments (each path - * segment may be a complete path, a partial path or just a single - * possible directory or file name). If any path segment is - * actually an absolute path, then all prior path segments are - * discarded. - * - * If elements < 0, we use the entire list that was given. - * - * It is possible that the returned object is actually an element - * of the given list, so the caller should be careful to store a - * refCount to it before freeing the list. - * + * 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 (each path segment may be a complete + * path, a partial path or just a single possible directory or file + * name). If any path segment is actually an absolute path, then all + * prior path segments are discarded. + * + * If elements < 0, we use the entire list that was given. + * + * It is possible that the returned object is actually an element of the + * given list, so the caller should be careful to store a refCount to it + * before freeing the 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. Note that in the case where - * the caller has asked to join zero elements of the list, the - * return value will be an empty-string Tcl_Obj. - * - * If the given listObj was invalid, then the calling routine has - * a bug, and this function will just return NULL. + * 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. Note that in the case where the caller has + * asked to join zero elements of the list, the return value will be an + * empty-string Tcl_Obj. + * + * If the given listObj was invalid, then the calling routine has a bug, + * and this function will just return NULL. * * Side effects: * None. * *--------------------------------------------------------------------------- */ -Tcl_Obj* -Tcl_FSJoinPath(listObj, elements) - Tcl_Obj *listObj; /* Path elements to join, may have refCount 0 */ - int elements; /* Number of elements to use (-1 = all) */ + +Tcl_Obj * +Tcl_FSJoinPath( + Tcl_Obj *listObj, /* Path elements to join, may have a zero + * reference count. */ + int elements) /* Number of elements to use (-1 = all) */ +{ + Tcl_Obj *copy, *res; + int objc; + Tcl_Obj **objv; + + if (Tcl_ListObjLength(NULL, listObj, &objc) != TCL_OK) { + return NULL; + } + + elements = ((elements >= 0) && (elements <= objc)) ? elements : objc; + copy = TclListObjCopy(NULL, listObj); + Tcl_ListObjGetElements(NULL, listObj, &objc, &objv); + res = TclJoinPath(elements, objv); + Tcl_DecrRefCount(copy); + return res; +} + +Tcl_Obj * +TclJoinPath( + int elements, + Tcl_Obj * const objv[]) { 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; - } - } - + const Tcl_Filesystem *fsPtr = NULL; + res = NULL; - + for (i = 0; i < elements; i++) { - Tcl_Obj *elt; - int driveNameLength; + int driveNameLength, strEltLen, length; Tcl_PathType type; - char *strElt; - int strEltLen; - int length; - char *ptr; + char *strElt, *ptr; Tcl_Obj *driveName = NULL; - - Tcl_ListObjIndex(NULL, listObj, i, &elt); - - /* - * This is a special case where we can be much more - * efficient, where we are joining a single relative path - * onto an object that is already of path type. The - * 'TclNewFSPathObj' call below creates an object which - * can be normalized more efficiently. Currently we only - * use the special case when we have exactly two elements, - * but we could expand that in the future. + Tcl_Obj *elt = objv[i]; + + /* + * This is a special case where we can be much more efficient, where + * we are joining a single relative path onto an object that is + * already of path type. The 'TclNewFSPathObj' call below creates an + * object which can be normalized more efficiently. Currently we only + * use the special case when we have exactly two elements, but we + * could expand that in the future. */ - if ((i == (elements-2)) && (i == 0) && (elt->typePtr == &tclFsPathType) - && !(elt->bytes != NULL && (elt->bytes[0] == '\0'))) { - Tcl_Obj *tail; - Tcl_PathType type; - Tcl_ListObjIndex(NULL, listObj, i+1, &tail); - type = TclGetPathType(tail, NULL, NULL, NULL); + + if ((i == (elements-2)) && (i == 0) + && (elt->typePtr == &tclFsPathType) + && !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))) { + Tcl_Obj *tailObj = objv[i+1]; + + type = TclGetPathType(tailObj, NULL, NULL, NULL); if (type == TCL_PATH_RELATIVE) { - CONST char *str; + const char *str; int len; - str = Tcl_GetStringFromObj(tail,&len); + + str = Tcl_GetStringFromObj(tailObj, &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! + /* + * 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! */ - if (res != NULL) Tcl_DecrRefCount(res); + + if (res != NULL) { + TclDecrRefCount(res); + } return elt; } - /* - * If it doesn't begin with '.' and is a unix - * path or it a windows path without backslashes, then we - * can be very efficient here. (In fact even a windows - * path with backslashes can be joined efficiently, but - * the path object would not have forward slashes only, - * and this would therefore contradict our 'file join' - * documentation). + + /* + * If it doesn't begin with '.' and is a unix path or it a + * windows path without backslashes, then we can be very + * efficient here. (In fact even a windows path with + * backslashes can be joined efficiently, but the path object + * would not have forward slashes only, and this would + * therefore contradict our 'file join' documentation). */ - if (str[0] != '.' && ((tclPlatform != TCL_PLATFORM_WINDOWS) - || (strchr(str, '\\') == NULL))) { - if (res != NULL) Tcl_DecrRefCount(res); - return TclNewFSPathObj(elt, str, len); + + if (str[0] != '.' && ((tclPlatform != TCL_PLATFORM_WINDOWS) + || (strchr(str, '\\') == NULL))) { + /* + * Finally, on Windows, 'file join' is defined to convert + * all backslashes to forward slashes, so the base part + * cannot have backslashes either. + */ + + if ((tclPlatform != TCL_PLATFORM_WINDOWS) + || (strchr(Tcl_GetString(elt), '\\') == NULL)) { + if (res != NULL) { + TclDecrRefCount(res); + } + return TclNewFSPathObj(elt, str, len); + } } - /* - * Otherwise we don't have an easy join, and - * we must let the more general code below handle - * things + + /* + * Otherwise we don't have an easy join, and we must let the + * more general code below handle things. */ + } else if (tclPlatform == TCL_PLATFORM_UNIX) { + if (res != NULL) { + TclDecrRefCount(res); + } + return tailObj; } else { - if (tclPlatform == TCL_PLATFORM_UNIX) { - if (res != NULL) Tcl_DecrRefCount(res); - return tail; - } else { - CONST char *str; - int len; - str = Tcl_GetStringFromObj(tail,&len); - if (tclPlatform == TCL_PLATFORM_WINDOWS) { - if (strchr(str, '\\') == NULL) { - if (res != NULL) Tcl_DecrRefCount(res); - return tail; + const char *str = TclGetString(tailObj); + + if (tclPlatform == TCL_PLATFORM_WINDOWS) { + if (strchr(str, '\\') == NULL) { + if (res != NULL) { + TclDecrRefCount(res); } + return tailObj; } } } @@ -834,117 +946,142 @@ Tcl_FSJoinPath(listObj, elements) strElt = Tcl_GetStringFromObj(elt, &strEltLen); type = TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName); if (type != TCL_PATH_RELATIVE) { - /* Zero out the current result */ - if (res != NULL) Tcl_DecrRefCount(res); + /* + * Zero out the current result. + */ + + if (res != NULL) { + TclDecrRefCount(res); + } if (driveName != NULL) { /* - * We've been given a separate drive-name object, - * because the prefix in 'elt' is not in a suitable - * format for us (e.g. it may contain irrelevant - * multiple separators, like C://///foo). + * We've been given a separate drive-name object, because the + * prefix in 'elt' is not in a suitable format for us (e.g. it + * may contain irrelevant multiple separators, like + * C://///foo). */ + res = Tcl_DuplicateObj(driveName); - Tcl_DecrRefCount(driveName); - /* - * Do not set driveName to NULL, because we will check - * its value below (but we won't access the contents, - * since those have been cleaned-up). + TclDecrRefCount(driveName); + + /* + * Do not set driveName to NULL, because we will check its + * value below (but we won't access the contents, since those + * have been cleaned-up). */ } else { res = Tcl_NewStringObj(strElt, driveNameLength); } strElt += driveNameLength; + } else if (driveName != NULL) { + Tcl_DecrRefCount(driveName); } - - /* - * Optimisation block: if this is the last element to be - * examined, and it is absolute or the only element, and the - * drive-prefix was ok (if there is one), it might be that the - * path is already in a suitable form to be returned. Then we - * can short-cut the rest of this procedure. + + /* + * Optimisation block: if this is the last element to be examined, and + * it is absolute or the only element, and the drive-prefix was ok (if + * there is one), it might be that the path is already in a suitable + * form to be returned. Then we can short-cut the rest of this + * function. */ - if ((driveName == NULL) && (i == (elements - 1)) - && (type != TCL_PATH_RELATIVE || res == NULL)) { - /* - * It's the last path segment. Perform a quick check if - * the path is already in a suitable form. + + if ((driveName == NULL) && (i == (elements - 1)) + && (type != TCL_PATH_RELATIVE || res == NULL)) { + /* + * It's the last path segment. Perform a quick check if the path + * is already in a suitable form. */ - + if (tclPlatform == TCL_PLATFORM_WINDOWS) { if (strchr(strElt, '\\') != NULL) { goto noQuickReturn; } } - ptr = strElt; - while (*ptr != '\0') { - if (*ptr == '/' && (ptr[1] == '/' || ptr[1] == '\0')) { - /* - * We have a repeated file separator, which - * means the path is not in normalized form - */ - goto noQuickReturn; - } - ptr++; - } - if (res != NULL) Tcl_DecrRefCount(res); - /* - * This element is just what we want to return already - - * no further manipulation is requred. - */ - return elt; + ptr = strElt; + while (*ptr != '\0') { + if (*ptr == '/' && (ptr[1] == '/' || ptr[1] == '\0')) { + /* + * We have a repeated file separator, which means the path + * is not in normalized form + */ + + goto noQuickReturn; + } + ptr++; + } + if (res != NULL) { + TclDecrRefCount(res); + } + + /* + * This element is just what we want to return already; no further + * manipulation is requred. + */ + + return elt; } - /* - * The path element was not of a suitable form to be - * returned as is. We need to perform a more complex - * operation here. - */ - noQuickReturn: - + + /* + * The path element was not of a suitable form to be returned as is. + * We need to perform a more complex operation here. + */ + + noQuickReturn: if (res == NULL) { res = Tcl_NewObj(); ptr = Tcl_GetStringFromObj(res, &length); } else { ptr = Tcl_GetStringFromObj(res, &length); } - - /* - * Strip off any './' before a tilde, unless this is the - * beginning of the path. + + /* + * Strip off any './' before a tilde, unless this is the beginning of + * the path. */ - if (length > 0 && strEltLen > 0 - && (strElt[0] == '.') && (strElt[1] == '/') && (strElt[2] == '~')) { + + if (length > 0 && strEltLen > 0 && (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. + /* + * 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 (*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); + Tcl_Obj *sep = fsPtr->filesystemSeparatorProc(res); + if (sep != NULL) { - separator = Tcl_GetString(sep)[0]; + separator = TclGetString(sep)[0]; + } + /* Safety check in case the VFS driver caused sharing */ + if (Tcl_IsShared(res)) { + TclDecrRefCount(res); + res = Tcl_DuplicateObj(res); + Tcl_IncrRefCount(res); } } if (length > 0 && ptr[length -1] != '/') { Tcl_AppendToObj(res, &separator, 1); - length++; + Tcl_GetStringFromObj(res, &length); } Tcl_SetObjLength(res, length + (int) strlen(strElt)); - - ptr = Tcl_GetString(res) + length; + + ptr = TclGetString(res) + length; for (; *strElt != '\0'; strElt++) { if (*strElt == separator) { while (strElt[1] == separator) { @@ -960,12 +1097,12 @@ Tcl_FSJoinPath(listObj, elements) needsSep = 1; } } - length = ptr - Tcl_GetString(res); + length = ptr - TclGetString(res); Tcl_SetObjLength(res, length); } } if (res == NULL) { - res = Tcl_NewObj(); + res = Tcl_NewObj(); } return res; } @@ -975,127 +1112,124 @@ Tcl_FSJoinPath(listObj, elements) * * Tcl_FSConvertToPathType -- * - * 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 "~<user>" (to indicate any user's home - * directory). + * 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 "~<user>" (to indicate any user's home directory). * * Results: - * Standard Tcl error code. + * Standard Tcl error code. * * Side effects: * The old representation may be freed, and new memory allocated. * *--------------------------------------------------------------------------- */ -int -Tcl_FSConvertToPathType(interp, pathPtr) - Tcl_Interp *interp; /* Interpreter in which to store error - * message (if necessary). */ - Tcl_Obj *pathPtr; /* Object to convert to a valid, current - * path type. */ + +int +Tcl_FSConvertToPathType( + Tcl_Interp *interp, /* Interpreter in which to store error message + * (if necessary). */ + Tcl_Obj *pathPtr) /* Object to convert to a valid, current path + * type. */ { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - - /* - * 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. + /* + * 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 (pathPtr->typePtr == &tclFsPathType) { - FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathPtr); - if (fsPathPtr->filesystemEpoch != tsdPtr->filesystemEpoch) { - if (pathPtr->bytes == NULL) { - UpdateStringOfFsPath(pathPtr); - } - FreeFsPathInternalRep(pathPtr); - pathPtr->typePtr = NULL; - return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); + if (TclFSEpochOk(PATHOBJ(pathPtr)->filesystemEpoch)) { + return TCL_OK; } - return TCL_OK; - /* - * We used to have more complex code here: - * - * if (fsPathPtr->cwdPtr == NULL || PATHFLAGS(pathPtr) != 0) { - * return TCL_OK; - * } else { - * if (TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) { - * return TCL_OK; - * } else { - * if (pathPtr->bytes == NULL) { - * UpdateStringOfFsPath(pathPtr); - * } - * FreeFsPathInternalRep(pathPtr); - * pathPtr->typePtr = NULL; - * return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); - * } - * } - * - * But we no longer believe this is necessary. - */ - } else { - return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); + + if (pathPtr->bytes == NULL) { + UpdateStringOfFsPath(pathPtr); + } + FreeFsPathInternalRep(pathPtr); } + + return SetFsPathFromAny(interp, pathPtr); + + /* + * We used to have more complex code here: + * + * FsPath *fsPathPtr = PATHOBJ(pathPtr); + * if (fsPathPtr->cwdPtr == NULL || PATHFLAGS(pathPtr) != 0) { + * return TCL_OK; + * } else { + * if (TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) { + * return TCL_OK; + * } else { + * if (pathPtr->bytes == NULL) { + * UpdateStringOfFsPath(pathPtr); + * } + * FreeFsPathInternalRep(pathPtr); + * return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); + * } + * } + * + * But we no longer believe this is necessary. + */ } -/* +/* * Helper function for normalization. */ + static int -IsSeparatorOrNull(ch) - int ch; +IsSeparatorOrNull( + int ch) { if (ch == 0) { - return 1; + return 1; } switch (tclPlatform) { - case TCL_PLATFORM_UNIX: { - return (ch == '/' ? 1 : 0); - } - case TCL_PLATFORM_WINDOWS: { - return ((ch == '/' || ch == '\\') ? 1 : 0); - } + case TCL_PLATFORM_UNIX: + return (ch == '/' ? 1 : 0); + case TCL_PLATFORM_WINDOWS: + return ((ch == '/' || ch == '\\') ? 1 : 0); } return 0; } -/* - * Helper function for SetFsPathFromAny. Returns position of first - * directory delimiter in the path. If no separator is found, then - * returns the position of the end of the string. +/* + * Helper function for SetFsPathFromAny. Returns position of first directory + * delimiter in the path. If no separator is found, then returns the position + * of the end of the string. */ + static int -FindSplitPos(path, separator) - CONST char *path; - int separator; +FindSplitPos( + const char *path, + int separator) { int count = 0; switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - while (path[count] != 0) { - if (path[count] == separator) { - return count; - } - count++; + case TCL_PLATFORM_UNIX: + while (path[count] != 0) { + if (path[count] == separator) { + return count; } - break; + count++; + } + break; - case TCL_PLATFORM_WINDOWS: - while (path[count] != 0) { - if (path[count] == separator || path[count] == '\\') { - return count; - } - count++; + case TCL_PLATFORM_WINDOWS: + while (path[count] != 0) { + if (path[count] == separator || path[count] == '\\') { + return count; } - break; + count++; + } + break; } return count; } @@ -1105,71 +1239,163 @@ FindSplitPos(path, separator) * * TclNewFSPathObj -- * - * Creates a path object whose string representation is '[file join - * dirPtr addStrRep]', but does so in a way that allows for more - * efficient creation and caching of normalized paths, and more - * efficient 'file dirname', 'file tail', etc. - * + * Creates a path object whose string representation is '[file join + * dirPtr addStrRep]', but does so in a way that allows for more + * efficient creation and caching of normalized paths, and more efficient + * 'file dirname', 'file tail', etc. + * * Assumptions: - * 'dirPtr' must be an absolute path. - * 'len' may not be zero. - * + * 'dirPtr' must be an absolute path. 'len' may not be zero. + * * Results: - * The new Tcl object, with refCount zero. + * The new Tcl object, with refCount zero. * * Side effects: - * Memory is allocated. 'dirPtr' gets an additional refCount. + * Memory is allocated. 'dirPtr' gets an additional refCount. * *--------------------------------------------------------------------------- */ -Tcl_Obj* -TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len) +Tcl_Obj * +TclNewFSPathObj( + Tcl_Obj *dirPtr, + const char *addStrRep, + int len) { FsPath *fsPathPtr; Tcl_Obj *pathPtr; - ThreadSpecificData *tsdPtr; - - tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - + const char *p; + int state = 0, count = 0; + + /* [Bug 2806250] - this is only a partial solution of the problem. + * The PATHFLAGS != 0 representation assumes in many places that + * the "tail" part stored in the normPathPtr field is itself a + * relative path. Strings that begin with "~" are not relative paths, + * so we must prevent their storage in the normPathPtr field. + * + * More generally we ought to be testing "addStrRep" for any value + * that is not a relative path, but in an unconstrained VFS world + * that could be just about anything, and testing could be expensive. + * Since this routine plays a big role in [glob], anything that slows + * it down would be unwelcome. For now, continue the risk of further + * bugs when some Tcl_Filesystem uses otherwise relative path strings + * as absolute path strings. Sensible Tcl_Filesystems will avoid + * that by mounting on path prefixes like foo:// which cannot be the + * name of a file or directory read from a native [glob] operation. + */ + if (addStrRep[0] == '~') { + Tcl_Obj *tail = Tcl_NewStringObj(addStrRep, len); + + pathPtr = AppendPath(dirPtr, tail); + Tcl_DecrRefCount(tail); + return pathPtr; + } + pathPtr = Tcl_NewObj(); - fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); - - /* Setup the path */ + fsPathPtr = ckalloc(sizeof(FsPath)); + + /* + * Set up 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 = tsdPtr->filesystemEpoch; + fsPathPtr->fsPtr = NULL; + fsPathPtr->filesystemEpoch = 0; - PATHOBJ(pathPtr) = (VOID *) fsPathPtr; + SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = TCLPATH_APPENDED; pathPtr->typePtr = &tclFsPathType; pathPtr->bytes = NULL; pathPtr->length = 0; + /* + * Look for path components made up of only "." + * This is overly conservative analysis to keep simple. It may mark some + * things as needing more aggressive normalization that don't actually + * need it. No harm done. + */ + for (p = addStrRep; len > 0; p++, len--) { + switch (state) { + case 0: /* So far only "." since last dirsep or start */ + switch (*p) { + case '.': + count++; + break; + case '/': + case '\\': + case ':': + if (count) { + PATHFLAGS(pathPtr) |= TCLPATH_NEEDNORM; + len = 0; + } + break; + default: + count = 0; + state = 1; + } + case 1: /* Scanning for next dirsep */ + switch (*p) { + case '/': + case '\\': + case ':': + state = 0; + break; + } + } + } + if (len == 0 && count) { + PATHFLAGS(pathPtr) |= TCLPATH_NEEDNORM; + } + return pathPtr; } + +static Tcl_Obj * +AppendPath( + Tcl_Obj *head, + Tcl_Obj *tail) +{ + int numBytes; + const char *bytes; + Tcl_Obj *copy = Tcl_DuplicateObj(head); + + /* + * This is likely buggy when dealing with virtual filesystem drivers + * that use some character other than "/" as a path separator. I know + * of no evidence that such a foolish thing exists. This solution was + * chosen so that "JoinPath" operations that pass through either path + * intrep produce the same results; that is, bugward compatibility. If + * we need to fix that bug here, it needs fixing in TclJoinPath() too. + */ + bytes = Tcl_GetStringFromObj(tail, &numBytes); + if (numBytes == 0) { + Tcl_AppendToObj(copy, "/", 1); + } else { + TclpNativeJoinPath(copy, bytes); + } + return copy; +} /* *--------------------------------------------------------------------------- * * TclFSMakePathRelative -- * - * Only for internal use. - * - * Takes a path and a directory, where we _assume_ both path and - * directory are absolute, normalized and that the path lies - * inside the directory. Returns a Tcl_Obj representing filename - * of the path relative to the directory. - * + * Only for internal use. + * + * Takes a path and a directory, where we _assume_ both path and + * directory are absolute, normalized and that the path lies inside the + * directory. Returns a Tcl_Obj representing filename of the path + * relative to the directory. + * * Results: - * NULL on error, otherwise a valid object, typically with - * refCount of zero, which it is assumed the caller will - * increment. + * NULL on error, otherwise a valid object, typically with refCount of + * zero, which it is assumed the caller will increment. * * Side effects: * The old representation may be freed, and new memory allocated. @@ -1177,88 +1403,53 @@ TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len) *--------------------------------------------------------------------------- */ -Tcl_Obj* -TclFSMakePathRelative(interp, pathPtr, cwdPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - Tcl_Obj *pathPtr; /* The object we have. */ - Tcl_Obj *cwdPtr; /* Make it relative to this. */ +Tcl_Obj * +TclFSMakePathRelative( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *pathPtr, /* The path we have. */ + Tcl_Obj *cwdPtr) /* Make it relative to this. */ { int cwdLen, len; - CONST char *tempStr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - - if (pathPtr->typePtr == &tclFsPathType) { - FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathPtr); - if (PATHFLAGS(pathPtr) != 0 - && fsPathPtr->cwdPtr == cwdPtr) { - pathPtr = fsPathPtr->normPathPtr; - /* Free old representation */ - if (pathPtr->typePtr != NULL) { - if (pathPtr->bytes == NULL) { - if (pathPtr->typePtr->updateStringProc == NULL) { - if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "can't find object", - "string representation", (char *) NULL); - } - return NULL; - } - pathPtr->typePtr->updateStringProc(pathPtr); - } - if ((pathPtr->typePtr->freeIntRepProc) != NULL) { - (*pathPtr->typePtr->freeIntRepProc)(pathPtr); - } - } + const char *tempStr; - fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); - - /* Circular reference, by design */ - fsPathPtr->translatedPathPtr = pathPtr; - fsPathPtr->normPathPtr = NULL; - fsPathPtr->cwdPtr = cwdPtr; - Tcl_IncrRefCount(cwdPtr); - fsPathPtr->nativePathPtr = NULL; - fsPathPtr->fsRecPtr = NULL; - fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; - - PATHOBJ(pathPtr) = (VOID *) fsPathPtr; - PATHFLAGS(pathPtr) = 0; - pathPtr->typePtr = &tclFsPathType; + if (pathPtr->typePtr == &tclFsPathType) { + FsPath *fsPathPtr = PATHOBJ(pathPtr); - return pathPtr; + if (PATHFLAGS(pathPtr) != 0 && fsPathPtr->cwdPtr == cwdPtr) { + return fsPathPtr->normPathPtr; } } - /* - * 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. + + /* + * 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 + + /* + * 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_UNIX: + if (tempStr[cwdLen-1] != '/') { + cwdLen++; + } + break; + case TCL_PLATFORM_WINDOWS: + if (tempStr[cwdLen-1] != '/' && tempStr[cwdLen-1] != '\\') { + cwdLen++; + } + break; } tempStr = Tcl_GetStringFromObj(pathPtr, &len); @@ -1268,13 +1459,13 @@ TclFSMakePathRelative(interp, pathPtr, cwdPtr) /* *--------------------------------------------------------------------------- * - * TclFSMakePathFromNormalized -- + * MakePathFromNormalized -- + * + * Like SetFsPathFromAny, but assumes the given object is an absolute + * normalized path. Only for internal use. * - * Like SetFsPathFromAny, but assumes the given object is an - * absolute normalized path. Only for internal use. - * * Results: - * Standard Tcl error code. + * Standard Tcl error code. * * Side effects: * The old representation may be freed, and new memory allocated. @@ -1282,49 +1473,57 @@ TclFSMakePathRelative(interp, pathPtr, cwdPtr) *--------------------------------------------------------------------------- */ -int -TclFSMakePathFromNormalized(interp, pathPtr, nativeRep) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - Tcl_Obj *pathPtr; /* The object to convert. */ - ClientData nativeRep; /* The native rep for the object, if known - * else NULL. */ +static int +MakePathFromNormalized( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *pathPtr) /* The object to convert. */ { FsPath *fsPathPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); if (pathPtr->typePtr == &tclFsPathType) { return TCL_OK; } - - /* Free old representation */ + + /* + * Free old representation + */ + if (pathPtr->typePtr != NULL) { if (pathPtr->bytes == NULL) { if (pathPtr->typePtr->updateStringProc == NULL) { if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "can't find object", - "string representation", (char *) NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't find object string representation", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "WTF", + NULL); } return TCL_ERROR; } pathPtr->typePtr->updateStringProc(pathPtr); } - if ((pathPtr->typePtr->freeIntRepProc) != NULL) { - (*pathPtr->typePtr->freeIntRepProc)(pathPtr); - } + TclFreeIntRep(pathPtr); } - fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); - /* It's a pure normalized absolute path */ + fsPathPtr = ckalloc(sizeof(FsPath)); + + /* + * It's a pure normalized absolute path. + */ + fsPathPtr->translatedPathPtr = NULL; - /* Circular reference by design */ + + /* + * Circular reference by design. + */ + fsPathPtr->normPathPtr = pathPtr; fsPathPtr->cwdPtr = NULL; - fsPathPtr->nativePathPtr = nativeRep; - fsPathPtr->fsRecPtr = NULL; - fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; + fsPathPtr->nativePathPtr = NULL; + fsPathPtr->fsPtr = NULL; + /* Remember the epoch under which we decided pathPtr was normalized */ + fsPathPtr->filesystemEpoch = TclFSEpoch(); - PATHOBJ(pathPtr) = (VOID *) fsPathPtr; + SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; pathPtr->typePtr = &tclFsPathType; @@ -1336,20 +1535,19 @@ TclFSMakePathFromNormalized(interp, pathPtr, nativeRep) * * Tcl_FSNewNativePath -- * - * 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. + * This function performs the something like the 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: - * NULL or a valid path object pointer, with refCount zero. + * NULL or a valid path object pointer, with refCount zero. * * Side effects: * New memory may be allocated. @@ -1358,26 +1556,26 @@ TclFSMakePathFromNormalized(interp, pathPtr, nativeRep) */ Tcl_Obj * -Tcl_FSNewNativePath(fromFilesystem, clientData) - Tcl_Filesystem* fromFilesystem; - ClientData clientData; +Tcl_FSNewNativePath( + const Tcl_Filesystem *fromFilesystem, + ClientData clientData) { - Tcl_Obj *pathPtr; + Tcl_Obj *pathPtr = NULL; FsPath *fsPathPtr; - FilesystemRecord *fsFromPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - - pathPtr = TclFSInternalToNormalized(fromFilesystem, clientData, - &fsFromPtr); + + if (fromFilesystem->internalToNormalizedProc != NULL) { + pathPtr = (*fromFilesystem->internalToNormalizedProc)(clientData); + } if (pathPtr == NULL) { return NULL; } - - /* - * Free old representation; shouldn't normally be any, - * but best to be safe. + + /* + * Free old representation; shouldn't normally be any, but best to be + * safe. */ + if (pathPtr->typePtr != NULL) { if (pathPtr->bytes == NULL) { if (pathPtr->typePtr->updateStringProc == NULL) { @@ -1385,23 +1583,24 @@ Tcl_FSNewNativePath(fromFilesystem, clientData) } pathPtr->typePtr->updateStringProc(pathPtr); } - if ((pathPtr->typePtr->freeIntRepProc) != NULL) { - (*pathPtr->typePtr->freeIntRepProc)(pathPtr); - } + TclFreeIntRep(pathPtr); } - - fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); + + fsPathPtr = ckalloc(sizeof(FsPath)); fsPathPtr->translatedPathPtr = NULL; - /* Circular reference, by design */ + + /* + * Circular reference, by design. + */ + fsPathPtr->normPathPtr = pathPtr; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = clientData; - fsPathPtr->fsRecPtr = fsFromPtr; - fsPathPtr->fsRecPtr->fileRefCount++; - fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; + fsPathPtr->fsPtr = fromFilesystem; + fsPathPtr->filesystemEpoch = TclFSEpoch(); - PATHOBJ(pathPtr) = (VOID *) fsPathPtr; + SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; pathPtr->typePtr = &tclFsPathType; @@ -1413,14 +1612,13 @@ Tcl_FSNewNativePath(fromFilesystem, clientData) * * Tcl_FSGetTranslatedPath -- * - * 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) + * 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: - * NULL or a valid Tcl_Obj pointer. + * NULL or a valid Tcl_Obj pointer. * * Side effects: * Only those of 'Tcl_FSConvertToPathType' @@ -1428,10 +1626,10 @@ Tcl_FSNewNativePath(fromFilesystem, clientData) *--------------------------------------------------------------------------- */ -Tcl_Obj* -Tcl_FSGetTranslatedPath(interp, pathPtr) - Tcl_Interp *interp; - Tcl_Obj* pathPtr; +Tcl_Obj * +Tcl_FSGetTranslatedPath( + Tcl_Interp *interp, + Tcl_Obj *pathPtr) { Tcl_Obj *retObj = NULL; FsPath *srcFsPathPtr; @@ -1439,25 +1637,53 @@ Tcl_FSGetTranslatedPath(interp, pathPtr) if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { return NULL; } - srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); + srcFsPathPtr = PATHOBJ(pathPtr); if (srcFsPathPtr->translatedPathPtr == NULL) { if (PATHFLAGS(pathPtr) != 0) { - retObj = Tcl_FSGetNormalizedPath(interp, pathPtr); + /* + * We lack a translated path result, but we have a directory + * (cwdPtr) and a tail (normPathPtr), and if we join the + * translated version of cwdPtr to normPathPtr, we'll get the + * translated result we need, and can store it for future use. + */ + + Tcl_Obj *translatedCwdPtr = Tcl_FSGetTranslatedPath(interp, + srcFsPathPtr->cwdPtr); + if (translatedCwdPtr == NULL) { + return NULL; + } + + retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1, + &srcFsPathPtr->normPathPtr); + srcFsPathPtr->translatedPathPtr = retObj; + if (translatedCwdPtr->typePtr == &tclFsPathType) { + srcFsPathPtr->filesystemEpoch + = PATHOBJ(translatedCwdPtr)->filesystemEpoch; + } else { + srcFsPathPtr->filesystemEpoch = 0; + } + Tcl_IncrRefCount(retObj); + Tcl_DecrRefCount(translatedCwdPtr); } else { - /* - * 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. + /* + * 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. */ + retObj = srcFsPathPtr->normPathPtr; } } else { - /* It is an ordinary path object */ + /* + * It is an ordinary path object. + */ + retObj = srcFsPathPtr->translatedPathPtr; } - Tcl_IncrRefCount(retObj); + if (retObj != NULL) { + Tcl_IncrRefCount(retObj); + } return retObj; } @@ -1466,34 +1692,34 @@ Tcl_FSGetTranslatedPath(interp, pathPtr) * * Tcl_FSGetTranslatedStringPath -- * - * This function attempts to extract the translated path - * from the given Tcl_Obj. If the translation succeeds (i.e. the - * object is a valid path), then the path is returned. Otherwise NULL - * will be returned, and an error message may be left in the - * interpreter (if it is non-NULL) + * This function attempts to extract the translated path from the given + * Tcl_Obj. If the translation succeeds (i.e. the object is a valid + * path), then the path is returned. Otherwise NULL will be returned, and + * an error message may be left in the interpreter (if it is non-NULL) * * Results: - * NULL or a valid string. + * NULL or a valid string. * * Side effects: * Only those of 'Tcl_FSConvertToPathType' * *--------------------------------------------------------------------------- */ -CONST char* -Tcl_FSGetTranslatedStringPath(interp, pathPtr) - Tcl_Interp *interp; - Tcl_Obj* pathPtr; + +const char * +Tcl_FSGetTranslatedStringPath( + Tcl_Interp *interp, + Tcl_Obj *pathPtr) { Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); if (transPtr != NULL) { int len; - CONST char *result, *orig; - orig = Tcl_GetStringFromObj(transPtr, &len); - result = (char*) ckalloc((unsigned)(len+1)); - memcpy((VOID*) result, (VOID*) orig, (size_t) (len+1)); - Tcl_DecrRefCount(transPtr); + const char *orig = Tcl_GetStringFromObj(transPtr, &len); + char *result = ckalloc(len+1); + + memcpy(result, orig, (size_t) len+1); + TclDecrRefCount(transPtr); return result; } @@ -1505,311 +1731,291 @@ Tcl_FSGetTranslatedStringPath(interp, pathPtr) * * Tcl_FSGetNormalizedPath -- * - * 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. + * 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 valid path object pointer. + * NULL or a valid path object pointer. * * Side effects: - * New memory may be allocated. The Tcl 'errno' may be modified - * in the process of trying to examine various path possibilities. + * New memory may be allocated. The Tcl 'errno' may be modified in the + * process of trying to examine various path possibilities. * *--------------------------------------------------------------------------- */ -Tcl_Obj* -Tcl_FSGetNormalizedPath(interp, pathPtr) - Tcl_Interp *interp; - Tcl_Obj* pathPtr; +Tcl_Obj * +Tcl_FSGetNormalizedPath( + Tcl_Interp *interp, + Tcl_Obj *pathPtr) { - FsPath *fsPathPtr; if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { return NULL; } - fsPathPtr = (FsPath*) PATHOBJ(pathPtr); + fsPathPtr = PATHOBJ(pathPtr); if (PATHFLAGS(pathPtr) != 0) { - /* - * This is a special path object which is the result of - * something like 'file join' + /* + * 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; - + int tailLen, cwdLen, pathType; + pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr); if (dir == NULL) { return NULL; } + /* TODO: Figure out why this is needed. */ if (pathPtr->bytes == NULL) { UpdateStringOfFsPath(pathPtr); } - copy = Tcl_DuplicateObj(dir); - Tcl_IncrRefCount(copy); + + Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &tailLen); + if (tailLen) { + copy = AppendPath(dir, fsPathPtr->normPathPtr); + } else { + copy = Tcl_DuplicateObj(dir); + } 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. + Tcl_IncrRefCount(copy); + + /* + * We now own a reference on both 'dir' and 'copy' */ - 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; + + (void) Tcl_GetStringFromObj(dir, &cwdLen); + cwdLen += (Tcl_GetString(copy)[cwdLen] == '/'); + + /* Normalize the combined string. */ + + if (PATHFLAGS(pathPtr) & TCLPATH_NEEDNORM) { + /* + * If the "tail" part has components (like /../) that cause the + * combined path to need more complete normalizing, call on the + * more powerful routine to accomplish that so we avoid [Bug + * 2385549] ... + */ + + Tcl_Obj *newCopy = TclFSNormalizeAbsolutePath(interp, copy); + + Tcl_DecrRefCount(copy); + copy = newCopy; + } else { + /* + * ... but in most cases where we join a trouble free tail to a + * normalized head, we can more efficiently normalize the combined + * path by passing over only the unnormalized tail portion. When + * this is sufficient, prior developers claim 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); } - 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 */ - + + /* Now we need to construct the new path object. */ + if (pathType == TCL_PATH_RELATIVE) { - FsPath* origDirFsPathPtr; Tcl_Obj *origDir = fsPathPtr->cwdPtr; - origDirFsPathPtr = (FsPath*) PATHOBJ(origDir); - + + /* + * NOTE: here we are (dangerously?) assuming that origDir points + * to a Tcl_Obj with Tcl_ObjType == &tclFsPathType. The + * pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); + * above that set the pathType value should have established that, + * but it's far less clear on what basis we know there's been no + * shimmering since then. + */ + + FsPath *origDirFsPathPtr = PATHOBJ(origDir); + fsPathPtr->cwdPtr = origDirFsPathPtr->cwdPtr; Tcl_IncrRefCount(fsPathPtr->cwdPtr); - - Tcl_DecrRefCount(fsPathPtr->normPathPtr); + + TclDecrRefCount(fsPathPtr->normPathPtr); fsPathPtr->normPathPtr = copy; - /* That's our reference to copy used */ - Tcl_DecrRefCount(dir); - Tcl_DecrRefCount(origDir); + + /* + * That's our reference to copy used. + */ + + TclDecrRefCount(dir); + TclDecrRefCount(origDir); } else { - Tcl_DecrRefCount(fsPathPtr->cwdPtr); + TclDecrRefCount(fsPathPtr->cwdPtr); fsPathPtr->cwdPtr = NULL; - Tcl_DecrRefCount(fsPathPtr->normPathPtr); + TclDecrRefCount(fsPathPtr->normPathPtr); fsPathPtr->normPathPtr = copy; - /* That's our reference to copy used */ - Tcl_DecrRefCount(dir); - } - if (clientData != NULL) { - fsPathPtr->nativePathPtr = clientData; + + /* + * That's our reference to copy used. + */ + + TclDecrRefCount(dir); } PATHFLAGS(pathPtr) = 0; } - /* Ensure cwd hasn't changed */ + + /* + * Ensure cwd hasn't changed. + */ + if (fsPathPtr->cwdPtr != NULL) { if (!TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) { if (pathPtr->bytes == NULL) { UpdateStringOfFsPath(pathPtr); } FreeFsPathInternalRep(pathPtr); - pathPtr->typePtr = NULL; - if (Tcl_ConvertToType(interp, pathPtr, - &tclFsPathType) != TCL_OK) { + if (SetFsPathFromAny(interp, pathPtr) != TCL_OK) { return NULL; } - fsPathPtr = (FsPath*) PATHOBJ(pathPtr); + fsPathPtr = PATHOBJ(pathPtr); } 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; - } - Tcl_AppendObjToObj(copy, pathPtr); - /* - * Normalize the combined string, but only starting after - * the end of the previously normalized 'dir'. This should - * be much faster! + + copy = AppendPath(fsPathPtr->cwdPtr, pathPtr); + + (void) Tcl_GetStringFromObj(fsPathPtr->cwdPtr, &cwdLen); + cwdLen += (Tcl_GetString(copy)[cwdLen] == '/'); + + /* + * 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)); + + TclFSNormalizeToUniquePath(interp, copy, cwdLen-1); fsPathPtr->normPathPtr = copy; - if (clientData != NULL) { - fsPathPtr->nativePathPtr = clientData; - } + Tcl_IncrRefCount(fsPathPtr->normPathPtr); } } 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. + int pureNormalized = 1; + + /* + * 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); - - /* + const char *path = TclGetString(absolutePath); + + Tcl_IncrRefCount(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. + * 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_PathType type = Tcl_FSGetPathType(pathPtr); + + if (path[0] == '\0') { + /* + * Special handling for the empty string value. This one is very + * weird with [file normalize {}] => {}. (The reasoning supporting + * this is unknown to DGP, but he fears changing it.) Attempt here + * to keep the expectations of other parts of Tcl_Filesystem code + * about state of the FsPath fields satisfied. + * + * In particular, capture the cwd value and save so it can be + * stored in the cwdPtr field below. + */ + + useThisCwd = Tcl_FSGetCwd(interp); + } else { + /* + * We don't ask for the type of 'pathPtr' here, because that is + * not correct for our purposes when we have a path like '~'. Tcl + * has a bit of a contradiction in that '~' paths are defined as + * 'absolute', but in reality can be just about anything, + * depending on how env(HOME) is set. + */ + + Tcl_PathType type = Tcl_FSGetPathType(absolutePath); + if (type == TCL_PATH_RELATIVE) { useThisCwd = Tcl_FSGetCwd(interp); - if (useThisCwd == NULL) return NULL; + if (useThisCwd == NULL) { + return NULL; + } + pureNormalized = 0; + Tcl_DecrRefCount(absolutePath); absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath); Tcl_IncrRefCount(absolutePath); - /* We have a refCount on the cwd */ -#ifdef __WIN32__ + + /* + * We have a refCount on the cwd. + */ +#ifdef _WIN32 } else if (type == TCL_PATH_VOLUME_RELATIVE) { - /* - * Only Windows has volume-relative paths. These - * paths are rather rare, but it is nice if Tcl can - * handle them. It is much better if we can - * handle them here, rather than in the native fs code, - * because we really need to have a real absolute path - * just below. - * - * We do not let this block compile on non-Windows - * platforms because the test suite's manual forcing - * of tclPlatform can otherwise cause this code path - * to be executed, causing various errors because - * volume-relative paths really do not exist. + /* + * Only Windows has volume-relative paths. */ - useThisCwd = Tcl_FSGetCwd(interp); - if (useThisCwd == NULL) return NULL; - - if (path[0] == '/') { - /* - * Path of form /foo/bar which is a path in the - * root directory of the current volume. - */ - CONST char *drive = Tcl_GetString(useThisCwd); - absolutePath = Tcl_NewStringObj(drive,2); - Tcl_AppendToObj(absolutePath, path, -1); - Tcl_IncrRefCount(absolutePath); - /* We have a refCount on the cwd */ - } else { - /* - * Path of form C:foo/bar, but this only makes - * sense if the cwd is also on drive C. - */ - int cwdLen; - CONST char *drive = Tcl_GetStringFromObj(useThisCwd, - &cwdLen); - char drive_cur = path[0]; - if (drive_cur >= 'a') { - drive_cur -= ('a' - 'A'); - } - if (drive[0] == drive_cur) { - absolutePath = Tcl_DuplicateObj(useThisCwd); - /* - * We have a refCount on the cwd, which we - * will release later. - */ - if (drive[cwdLen-1] != '/' && (path[2] != '\0')) { - /* - * Only add a trailing '/' if needed, which - * is if there isn't one already, and if we - * are going to be adding some more - * characters. - */ - Tcl_AppendToObj(absolutePath, "/", 1); - } - } else { - Tcl_DecrRefCount(useThisCwd); - useThisCwd = NULL; - /* - * The path is not in the current drive, but - * is volume-relative. The way Tcl 8.3 handles - * this is that it treats such a path as - * relative to the root of the drive. We - * therefore behave the same here. - */ - absolutePath = Tcl_NewStringObj(path, 2); - Tcl_AppendToObj(absolutePath, "/", 1); - } - Tcl_IncrRefCount(absolutePath); - Tcl_AppendToObj(absolutePath, path+2, -1); + Tcl_DecrRefCount(absolutePath); + absolutePath = TclWinVolumeRelativeNormalize(interp, + path, &useThisCwd); + if (absolutePath == NULL) { + return NULL; } -#endif /* __WIN32__ */ + pureNormalized = 0; +#endif /* _WIN32 */ } } - /* 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); - } - /* - * Check if path is pure normalized (this can only be the case - * if it is an absolute path). + + /* + * Already has refCount incremented. */ - if (useThisCwd == NULL) { - if (!strcmp(Tcl_GetString(fsPathPtr->normPathPtr), - Tcl_GetString(pathPtr))) { - /* - * The path was already normalized. - * Get rid of the duplicate. + + fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp, + absolutePath); + + /* + * Check if path is pure normalized (this can only be the case if it + * is an absolute path). + */ + + if (pureNormalized) { + int normPathLen, pathLen; + const char *normPath; + + path = TclGetStringFromObj(pathPtr, &pathLen); + normPath = TclGetStringFromObj(fsPathPtr->normPathPtr, &normPathLen); + if ((pathLen == normPathLen) && !memcmp(path, normPath, pathLen)) { + /* + * The path was already normalized. Get rid of the duplicate. */ - Tcl_DecrRefCount(fsPathPtr->normPathPtr); - /* - * We do *not* increment the refCount for - * this circular reference + + TclDecrRefCount(fsPathPtr->normPathPtr); + + /* + * We do *not* increment the refCount for this circular + * reference. */ + fsPathPtr->normPathPtr = pathPtr; } - } else { - /* - * We just need to free an object we allocated above for - * relative paths (this was returned by Tcl_FSJoinToPath - * above), and then of course store the cwd. + } + if (useThisCwd != NULL) { + /* + * We just need to free an object we allocated above for relative + * paths (this was returned by Tcl_FSJoinToPath above), and then + * of course store the cwd. */ - Tcl_DecrRefCount(absolutePath); + fsPathPtr->cwdPtr = useThisCwd; } + TclDecrRefCount(absolutePath); } return fsPathPtr->normPathPtr; @@ -1820,16 +2026,16 @@ Tcl_FSGetNormalizedPath(interp, pathPtr) * * Tcl_FSGetInternalRep -- * - * 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'. + * 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: - * NULL or a valid internal representation. + * NULL or a valid internal representation. * * Side effects: * An attempt may be made to convert the object. @@ -1837,66 +2043,67 @@ Tcl_FSGetNormalizedPath(interp, pathPtr) *--------------------------------------------------------------------------- */ -ClientData -Tcl_FSGetInternalRep(pathPtr, fsPtr) - Tcl_Obj* pathPtr; - Tcl_Filesystem *fsPtr; +ClientData +Tcl_FSGetInternalRep( + Tcl_Obj *pathPtr, + const Tcl_Filesystem *fsPtr) { - FsPath* srcFsPathPtr; - + FsPath *srcFsPathPtr; + if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) { return NULL; } - srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); - - /* + srcFsPathPtr = PATHOBJ(pathPtr); + + /* * 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. + * 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) { - /* - * 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. + + if (srcFsPathPtr->fsPtr == NULL) { + /* + * 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(pathPtr); - - /* - * 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). + + /* + * 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(pathPtr); - if (srcFsPathPtr->fsRecPtr == NULL) { + + srcFsPathPtr = PATHOBJ(pathPtr); + if (srcFsPathPtr->fsPtr == NULL) { return NULL; } } - 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(pathPtr); + /* + * 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. + */ + + if (fsPtr != srcFsPathPtr->fsPtr) { + const Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathPtr); + if (actualFs == fsPtr) { return Tcl_FSGetInternalRep(pathPtr, fsPtr); } @@ -1905,12 +2112,16 @@ Tcl_FSGetInternalRep(pathPtr, fsPtr) if (srcFsPathPtr->nativePathPtr == NULL) { Tcl_FSCreateInternalRepProc *proc; - proc = srcFsPathPtr->fsRecPtr->fsPtr->createInternalRepProc; + char *nativePathPtr; + proc = srcFsPathPtr->fsPtr->createInternalRepProc; if (proc == NULL) { return NULL; } - srcFsPathPtr->nativePathPtr = (*proc)(pathPtr); + + nativePathPtr = proc(pathPtr); + srcFsPathPtr = PATHOBJ(pathPtr); + srcFsPathPtr->nativePathPtr = nativePathPtr; } return srcFsPathPtr->nativePathPtr; @@ -1921,13 +2132,12 @@ Tcl_FSGetInternalRep(pathPtr, fsPtr) * * TclFSEnsureEpochOk -- * - * This will ensure the pathPtr 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. + * This will ensure the pathPtr 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: - * Standard Tcl return code. + * Standard Tcl return code. * * Side effects: * An attempt may be made to convert the object. @@ -1935,68 +2145,87 @@ Tcl_FSGetInternalRep(pathPtr, fsPtr) *--------------------------------------------------------------------------- */ -int -TclFSEnsureEpochOk(pathPtr, fsPtrPtr) - Tcl_Obj* pathPtr; - Tcl_Filesystem **fsPtrPtr; +int +TclFSEnsureEpochOk( + Tcl_Obj *pathPtr, + const Tcl_Filesystem **fsPtrPtr) { - FsPath* srcFsPathPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); + FsPath *srcFsPathPtr; if (pathPtr->typePtr != &tclFsPathType) { return TCL_OK; } - srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); + srcFsPathPtr = PATHOBJ(pathPtr); - /* - * Check if the filesystem has changed in some way since - * this object's internal representation was calculated. + /* + * Check if the filesystem has changed in some way since this object's + * internal representation was calculated. */ - if (srcFsPathPtr->filesystemEpoch != tsdPtr->filesystemEpoch) { - /* - * We have to discard the stale representation and - * recalculate it + + if (!TclFSEpochOk(srcFsPathPtr->filesystemEpoch)) { + /* + * We have to discard the stale representation and recalculate it. */ + if (pathPtr->bytes == NULL) { UpdateStringOfFsPath(pathPtr); } FreeFsPathInternalRep(pathPtr); - pathPtr->typePtr = NULL; if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return TCL_ERROR; } - srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); - } - /* Check whether the object is already assigned to a fs */ - if (srcFsPathPtr->fsRecPtr != NULL) { - *fsPtrPtr = srcFsPathPtr->fsRecPtr->fsPtr; + srcFsPathPtr = PATHOBJ(pathPtr); } + /* + * Check whether the object is already assigned to a fs. + */ + + if (srcFsPathPtr->fsPtr != NULL) { + *fsPtrPtr = srcFsPathPtr->fsPtr; + } return TCL_OK; } -void -TclFSSetPathDetails(pathPtr, fsRecPtr, clientData) - Tcl_Obj *pathPtr; - FilesystemRecord *fsRecPtr; - ClientData clientData; +/* + *--------------------------------------------------------------------------- + * + * TclFSSetPathDetails -- + * + * ??? + * + * Results: + * None + * + * Side effects: + * ??? + * + *--------------------------------------------------------------------------- + */ + +void +TclFSSetPathDetails( + Tcl_Obj *pathPtr, + const Tcl_Filesystem *fsPtr, + ClientData clientData) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - FsPath* srcFsPathPtr; - - /* Make sure pathPtr is of the correct type */ + FsPath *srcFsPathPtr; + + /* + * Make sure pathPtr is of the correct type. + */ + if (pathPtr->typePtr != &tclFsPathType) { if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return; } } - - srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); - srcFsPathPtr->fsRecPtr = fsRecPtr; + + srcFsPathPtr = PATHOBJ(pathPtr); + srcFsPathPtr->fsPtr = fsPtr; srcFsPathPtr->nativePathPtr = clientData; - srcFsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; - fsRecPtr->fileRefCount++; + srcFsPathPtr->filesystemEpoch = TclFSEpoch(); } /* @@ -2004,11 +2233,11 @@ TclFSSetPathDetails(pathPtr, fsRecPtr, clientData) * * Tcl_FSEqualPaths -- * - * This function tests whether the two paths given are equal path - * objects. If either or both is NULL, 0 is always returned. + * This function tests whether the two paths given are equal path + * objects. If either or both is NULL, 0 is always returned. * * Results: - * 1 or 0. + * 1 or 0. * * Side effects: * None. @@ -2016,46 +2245,44 @@ TclFSSetPathDetails(pathPtr, fsRecPtr, clientData) *--------------------------------------------------------------------------- */ -int -Tcl_FSEqualPaths(firstPtr, secondPtr) - Tcl_Obj* firstPtr; - Tcl_Obj* secondPtr; +int +Tcl_FSEqualPaths( + Tcl_Obj *firstPtr, + Tcl_Obj *secondPtr) { + const char *firstStr, *secondStr; + int firstLen, secondLen, tempErrno; + 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; - } - /* - * Try the most thorough, correct method of comparing fully - * normalized paths - */ + if (firstPtr == NULL || secondPtr == NULL) { + return 0; + } + firstStr = TclGetStringFromObj(firstPtr, &firstLen); + secondStr = TclGetStringFromObj(secondPtr, &secondLen); + if ((firstLen == secondLen) && !memcmp(firstStr, secondStr, firstLen)) { + return 1; + } + + /* + * 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); + 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; - } + if (firstPtr == NULL || secondPtr == NULL) { + return 0; } - return 0; + firstStr = TclGetStringFromObj(firstPtr, &firstLen); + secondStr = TclGetStringFromObj(secondPtr, &secondLen); + return ((firstLen == secondLen) && !memcmp(firstStr, secondStr, firstLen)); } /* @@ -2063,15 +2290,14 @@ Tcl_FSEqualPaths(firstPtr, secondPtr) * * SetFsPathFromAny -- * - * 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 "~<user>" (to indicate any user's home - * directory). + * 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 "~<user>" (to indicate any user's home directory). * * Results: - * Standard Tcl error code. + * Standard Tcl error code. * * Side effects: * The old representation may be freed, and new memory allocated. @@ -2080,64 +2306,77 @@ Tcl_FSEqualPaths(firstPtr, secondPtr) */ static int -SetFsPathFromAny(interp, pathPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - Tcl_Obj *pathPtr; /* The object to convert. */ +SetFsPathFromAny( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *pathPtr) /* The object to convert. */ { int len; FsPath *fsPathPtr; Tcl_Obj *transPtr; char *name; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - + if (pathPtr->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. - * + + /* + * 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 or Win - * (fCmd.test, fileName.test and cmdAH.test exercise - * most of the code). + * + * However, the split/join routines are quite complex, and one has to make + * sure not to break anything on Unix or Win (fCmd.test, fileName.test and + * cmdAH.test exercise most of the code). */ - name = Tcl_GetStringFromObj(pathPtr,&len); + + name = Tcl_GetStringFromObj(pathPtr, &len); /* * Handle tilde substitutions, if needed. */ + if (name[0] == '~') { - char *expandedUser; Tcl_DString temp; int split; - char separator='/'; - + char separator = '/'; + split = FindSplitPos(name, separator); if (split != len) { - /* We have multiple pieces '~user/foo/bar...' */ + /* + * We have multiple pieces '~user/foo/bar...' + */ + name[split] = '\0'; } - /* Do some tilde substitution */ + + /* + * Do some tilde substitution. + */ + if (name[1] == '\0') { - /* We have just '~' */ - CONST char *dir; + /* + * We have just '~' + */ + + const char *dir; Tcl_DString dirString; - if (split != len) { name[split] = separator; } - + + 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); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't find HOME environment variable to" + " expand path", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", + "HOMELESS", NULL); } return TCL_ERROR; } @@ -2145,212 +2384,196 @@ SetFsPathFromAny(interp, pathPtr) Tcl_JoinPath(1, &dir, &temp); Tcl_DStringFree(&dirString); } else { - /* We have a user name '~user' */ + /* + * We have a user name '~user' + */ + Tcl_DStringInit(&temp); - if (TclpGetUserHome(name+1, &temp) == NULL) { + if (TclpGetUserHome(name+1, &temp) == NULL) { if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "user \"", (name+1), - "\" doesn't exist", (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "user \"%s\" doesn't exist", name+1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER", + NULL); } Tcl_DStringFree(&temp); - if (split != len) { name[split] = separator; } + if (split != len) { + name[split] = separator; + } return TCL_ERROR; } - if (split != len) { name[split] = separator; } + if (split != len) { + name[split] = separator; + } } - - expandedUser = Tcl_DStringValue(&temp); - transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp)); + + transPtr = TclDStringToObj(&temp); if (split != len) { - /* Join up the tilde substitution with the rest */ - if (name[split+1] == separator) { + /* + * 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. + * 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(pathPtr, NULL); + Tcl_ListObjGetElements(NULL, parts, &objc, &objv); - /* Skip '~'. It's replaced by its expansion */ + + /* + * Skip '~'. It's replaced by its expansion. + */ + objc--; objv++; while (objc--) { TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++)); } - Tcl_DecrRefCount(parts); + TclDecrRefCount(parts); } else { - /* - * Simple case. "rest" is relative path. Just join it. - * The "rest" object will be freed when - * Tcl_FSJoinToPath returns (unless something else - * claims a refCount on it). + /* + * Simple case. "rest" is relative path. Just join it. The + * "rest" object will be freed when Tcl_FSJoinToPath returns + * (unless something else claims a refCount on it). */ + Tcl_Obj *joined; - Tcl_Obj *rest = Tcl_NewStringObj(name+split+1,-1); + Tcl_Obj *rest = Tcl_NewStringObj(name+split+1, -1); + Tcl_IncrRefCount(transPtr); joined = Tcl_FSJoinToPath(transPtr, 1, &rest); - Tcl_DecrRefCount(transPtr); + TclDecrRefCount(transPtr); transPtr = joined; } } - Tcl_DStringFree(&temp); } else { - transPtr = Tcl_FSJoinToPath(pathPtr,0,NULL); + transPtr = TclJoinPath(1, &pathPtr); } -#if defined(__CYGWIN__) && defined(__WIN32__) - { - extern int cygwin_conv_to_win32_path - _ANSI_ARGS_((CONST char *, char *)); - char winbuf[MAX_PATH+1]; - /* - * In the Cygwin world, call conv_to_win32_path in order to use the - * mount table to translate the file name into something Windows will - * understand. Take care when converting empty strings! + * Now we have a translated filename in 'transPtr'. This will have forward + * slashes on Windows, and will not contain any ~user sequences. */ - name = Tcl_GetStringFromObj(transPtr, &len); - if (len > 0) { - cygwin_conv_to_win32_path(name, winbuf); - TclWinNoBackslash(winbuf); - Tcl_SetStringObj(transPtr, winbuf, -1); - } - } -#endif /* __CYGWIN__ && __WIN32__ */ - /* - * 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 = ckalloc(sizeof(FsPath)); fsPathPtr->translatedPathPtr = transPtr; if (transPtr != pathPtr) { - Tcl_IncrRefCount(fsPathPtr->translatedPathPtr); + Tcl_IncrRefCount(fsPathPtr->translatedPathPtr); + /* Redo translation when $env(HOME) changes */ + fsPathPtr->filesystemEpoch = TclFSEpoch(); + } else { + fsPathPtr->filesystemEpoch = 0; } fsPathPtr->normPathPtr = NULL; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = NULL; - fsPathPtr->fsRecPtr = NULL; - fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; + fsPathPtr->fsPtr = NULL; /* * Free old representation before installing our new one. */ - if (pathPtr->typePtr != NULL && pathPtr->typePtr->freeIntRepProc != NULL) { - (pathPtr->typePtr->freeIntRepProc)(pathPtr); - } - PATHOBJ(pathPtr) = (VOID *) fsPathPtr; + + TclFreeIntRep(pathPtr); + SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; pathPtr->typePtr = &tclFsPathType; - return TCL_OK; } static void -FreeFsPathInternalRep(pathPtr) - Tcl_Obj *pathPtr; /* Path object with internal rep to free. */ +FreeFsPathInternalRep( + Tcl_Obj *pathPtr) /* Path object with internal rep to free. */ { - FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathPtr); + FsPath *fsPathPtr = PATHOBJ(pathPtr); if (fsPathPtr->translatedPathPtr != NULL) { if (fsPathPtr->translatedPathPtr != pathPtr) { - Tcl_DecrRefCount(fsPathPtr->translatedPathPtr); + TclDecrRefCount(fsPathPtr->translatedPathPtr); } } if (fsPathPtr->normPathPtr != NULL) { if (fsPathPtr->normPathPtr != pathPtr) { - Tcl_DecrRefCount(fsPathPtr->normPathPtr); + TclDecrRefCount(fsPathPtr->normPathPtr); } fsPathPtr->normPathPtr = NULL; } if (fsPathPtr->cwdPtr != NULL) { - Tcl_DecrRefCount(fsPathPtr->cwdPtr); + TclDecrRefCount(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); + if (fsPathPtr->nativePathPtr != NULL && fsPathPtr->fsPtr != NULL) { + Tcl_FSFreeInternalRepProc *freeProc = + fsPathPtr->fsPtr->freeInternalRepProc; + + if (freeProc != NULL) { + freeProc(fsPathPtr->nativePathPtr); + fsPathPtr->nativePathPtr = NULL; } } - ckfree((char*) fsPathPtr); + ckfree(fsPathPtr); + pathPtr->typePtr = NULL; } 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. */ +DupFsPathInternalRep( + Tcl_Obj *srcPtr, /* Path obj with internal rep to copy. */ + Tcl_Obj *copyPtr) /* Path obj with internal rep to set. */ { - FsPath* srcFsPathPtr = (FsPath*) PATHOBJ(srcPtr); - FsPath* copyFsPathPtr = (FsPath*) ckalloc((unsigned)sizeof(FsPath)); + FsPath *srcFsPathPtr = PATHOBJ(srcPtr); + FsPath *copyFsPathPtr = ckalloc(sizeof(FsPath)); - Tcl_FSDupInternalRepProc *dupProc; - - PATHOBJ(copyPtr) = (VOID *) copyFsPathPtr; + SETPATHOBJ(copyPtr, copyFsPathPtr); - if (srcFsPathPtr->translatedPathPtr != NULL) { + if (srcFsPathPtr->translatedPathPtr == srcPtr) { + /* Cycle in src -> make cycle in copy. */ + copyFsPathPtr->translatedPathPtr = copyPtr; + } else { copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr; - if (copyFsPathPtr->translatedPathPtr != copyPtr) { + if (copyFsPathPtr->translatedPathPtr != NULL) { Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); } - } else { - copyFsPathPtr->translatedPathPtr = NULL; } - - if (srcFsPathPtr->normPathPtr != NULL) { + + if (srcFsPathPtr->normPathPtr == srcPtr) { + /* Cycle in src -> make cycle in copy. */ + copyFsPathPtr->normPathPtr = copyPtr; + } else { copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; - if (copyFsPathPtr->normPathPtr != copyPtr) { + if (copyFsPathPtr->normPathPtr != NULL) { Tcl_IncrRefCount(copyFsPathPtr->normPathPtr); } - } else { - copyFsPathPtr->normPathPtr = NULL; } - - if (srcFsPathPtr->cwdPtr != NULL) { - copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr; + + copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr; + if (copyFsPathPtr->cwdPtr != NULL) { Tcl_IncrRefCount(copyFsPathPtr->cwdPtr); - } else { - copyFsPathPtr->cwdPtr = NULL; } copyFsPathPtr->flags = srcFsPathPtr->flags; - - if (srcFsPathPtr->fsRecPtr != NULL - && srcFsPathPtr->nativePathPtr != NULL) { - dupProc = srcFsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc; + + if (srcFsPathPtr->fsPtr != NULL + && srcFsPathPtr->nativePathPtr != NULL) { + Tcl_FSDupInternalRepProc *dupProc = + srcFsPathPtr->fsPtr->dupInternalRepProc; + if (dupProc != NULL) { - copyFsPathPtr->nativePathPtr = - (*dupProc)(srcFsPathPtr->nativePathPtr); + copyFsPathPtr->nativePathPtr = + dupProc(srcFsPathPtr->nativePathPtr); } else { copyFsPathPtr->nativePathPtr = NULL; } } else { copyFsPathPtr->nativePathPtr = NULL; } - copyFsPathPtr->fsRecPtr = srcFsPathPtr->fsRecPtr; + copyFsPathPtr->fsPtr = srcFsPathPtr->fsPtr; copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch; - if (copyFsPathPtr->fsRecPtr != NULL) { - copyFsPathPtr->fsRecPtr->fileRefCount++; - } copyPtr->typePtr = &tclFsPathType; } @@ -2360,10 +2583,10 @@ DupFsPathInternalRep(srcPtr, copyPtr) * * UpdateStringOfFsPath -- * - * Gives an object a valid string rep. - * + * Gives an object a valid string rep. + * * Results: - * None. + * None. * * Side effects: * Memory may be allocated. @@ -2372,56 +2595,24 @@ DupFsPathInternalRep(srcPtr, copyPtr) */ static void -UpdateStringOfFsPath(pathPtr) - register Tcl_Obj *pathPtr; /* path obj with string rep to update. */ +UpdateStringOfFsPath( + register Tcl_Obj *pathPtr) /* path obj with string rep to update. */ { - FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathPtr); - CONST char *cwdStr; + FsPath *fsPathPtr = PATHOBJ(pathPtr); int cwdLen; Tcl_Obj *copy; - + if (PATHFLAGS(pathPtr) == 0 || fsPathPtr->cwdPtr == NULL) { Tcl_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; - } - Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr); + + copy = AppendPath(fsPathPtr->cwdPtr, fsPathPtr->normPathPtr); + pathPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen); pathPtr->length = cwdLen; copy->bytes = tclEmptyStringRep; copy->length = 0; - Tcl_DecrRefCount(copy); + TclDecrRefCount(copy); } /* @@ -2429,58 +2620,76 @@ UpdateStringOfFsPath(pathPtr) * * TclNativePathInFilesystem -- * - * 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). + * 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, to indicate 'yes', -1 to indicate no. + * TCL_OK, to indicate 'yes', -1 to indicate no. * * Side effects: * None. * *--------------------------------------------------------------------------- */ -int -TclNativePathInFilesystem(pathPtr, clientDataPtr) - Tcl_Obj *pathPtr; - ClientData *clientDataPtr; + +int +TclNativePathInFilesystem( + Tcl_Obj *pathPtr, + ClientData *clientDataPtr) { - /* - * 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. + /* + * 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. */ + if (pathPtr->typePtr == &tclFsPathType) { if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') { - /* We reject the empty path "" */ + /* + * We reject the empty path "". + */ + return -1; } - /* Otherwise there is no way this path can be empty */ + + /* + * 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. + /* + * 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); + + (void) Tcl_GetStringFromObj(pathPtr, &len); if (len == 0) { - /* We reject the empty path "" */ + /* + * We reject the empty path "". + */ + return -1; } } - /* - * Path is of correct type, or is of non-zero length, - * so we accept it. + + /* + * Path is of correct type, or is of non-zero length, so we accept it. */ + return TCL_OK; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |