summaryrefslogtreecommitdiffstats
path: root/generic/tclPathObj.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclPathObj.c')
-rw-r--r--generic/tclPathObj.c2693
1 files changed, 2693 insertions, 0 deletions
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
new file mode 100644
index 0000000..68ec2c4
--- /dev/null
+++ b/generic/tclPathObj.c
@@ -0,0 +1,2693 @@
+/*
+ * 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.
+ *
+ * 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.
+ */
+
+#include "tclInt.h"
+#include "tclFileSystem.h"
+
+/*
+ * Prototypes for functions defined later in this file.
+ */
+
+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.
+ */
+
+static const Tcl_ObjType tclFsPathType = {
+ "path", /* name */
+ FreeFsPathInternalRep, /* freeIntRepProc */
+ DupFsPathInternalRep, /* dupIntRepProc */
+ UpdateStringOfFsPath, /* updateStringProc */
+ SetFsPathFromAny /* setFromAnyProc */
+};
+
+/*
+ * struct FsPath --
+ *
+ * Internal representation of a Tcl_Obj of "path" type. This can be used to
+ * represent relative or absolute paths, and has certain optimisations when
+ * used to represent paths which are already normalized and absolute.
+ *
+ * Note that 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).
+ *
+ * (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.
+ *
+ */
+
+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. */
+ 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 PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.twoPtrValue.ptr1)
+#define SETPATHOBJ(pathPtr,fsPathPtr) \
+ ((pathPtr)->internalRep.twoPtrValue.ptr1 = (void *) (fsPathPtr))
+#define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags)
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclFSNormalizeAbsolutePath --
+ *
+ * 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.
+ *
+ * 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.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclFSNormalizeAbsolutePath(
+ Tcl_Interp *interp, /* Interpreter to use */
+ Tcl_Obj *pathPtr) /* Absolute path to normalize */
+{
+ 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 = TclGetString(pathPtr);
+
+ if (tclPlatform == TCL_PLATFORM_WINDOWS) {
+ 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.
+ */
+
+ dirSep += 2;
+ dirSep += FindSplitPos(dirSep, '/');
+ if (*dirSep != 0) {
+ 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.
+ */
+
+ while (*dirSep != 0) {
+ oldDirSep = dirSep;
+ if (!first) {
+ dirSep++;
+ }
+ dirSep += FindSplitPos(dirSep, '/');
+ if (dirSep[0] == 0 || dirSep[1] == 0) {
+ if (retVal != NULL) {
+ Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep);
+ }
+ break;
+ }
+ if (dirSep[1] == '.') {
+ if (retVal != NULL) {
+ Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep);
+ oldDirSep = dirSep;
+ }
+ again:
+ if (IsSeparatorOrNull(dirSep[2])) {
+ /*
+ * Need to skip '.' in the path.
+ */
+ int curLen;
+
+ if (retVal == NULL) {
+ const char *path = TclGetString(pathPtr);
+ retVal = Tcl_NewStringObj(path, dirSep - path);
+ Tcl_IncrRefCount(retVal);
+ }
+ TclGetStringFromObj(retVal, &curLen);
+ if (curLen == 0) {
+ Tcl_AppendToObj(retVal, dirSep, 1);
+ }
+ dirSep += 2;
+ oldDirSep = dirSep;
+ if (dirSep[0] != 0 && dirSep[1] == '.') {
+ goto again;
+ }
+ continue;
+ }
+ if (dirSep[2] == '.' && IsSeparatorOrNull(dirSep[3])) {
+ Tcl_Obj *linkObj;
+ int curLen;
+ char *linkStr;
+
+ /*
+ * Have '..' so need to skip previous directory.
+ */
+
+ if (retVal == NULL) {
+ const char *path = TclGetString(pathPtr);
+
+ retVal = Tcl_NewStringObj(path, dirSep - path);
+ Tcl_IncrRefCount(retVal);
+ }
+ TclGetStringFromObj(retVal, &curLen);
+ if (curLen == 0) {
+ Tcl_AppendToObj(retVal, dirSep, 1);
+ }
+ if (!first || (tclPlatform == TCL_PLATFORM_UNIX)) {
+ 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(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 =
+ TclGetStringFromObj(retVal, &curLen);
+
+ while (--curLen >= 0) {
+ if (IsSeparatorOrNull(path[curLen])) {
+ break;
+ }
+ }
+
+ /*
+ * We want the trailing slash.
+ */
+
+ Tcl_SetObjLength(retVal, curLen+1);
+ Tcl_AppendObjToObj(retVal, linkObj);
+ TclDecrRefCount(linkObj);
+ linkStr = TclGetStringFromObj(retVal, &curLen);
+ } else {
+ /*
+ * Absolute link.
+ */
+
+ TclDecrRefCount(retVal);
+ if (Tcl_IsShared(linkObj)) {
+ retVal = Tcl_DuplicateObj(linkObj);
+ TclDecrRefCount(linkObj);
+ } else {
+ retVal = linkObj;
+ }
+ linkStr = TclGetStringFromObj(retVal, &curLen);
+
+ /*
+ * Convert to forward-slashes on windows.
+ */
+
+ if (tclPlatform == TCL_PLATFORM_WINDOWS) {
+ int i;
+
+ for (i = 0; i < curLen; i++) {
+ if (linkStr[i] == '\\') {
+ linkStr[i] = '/';
+ }
+ }
+ }
+ }
+ } else {
+ linkStr = TclGetStringFromObj(retVal, &curLen);
+ }
+
+ /*
+ * Either way, we now remove the last path element (but
+ * not the first character of the path).
+ */
+
+ while (--curLen >= 0) {
+ if (IsSeparatorOrNull(linkStr[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;
+ }
+ continue;
+ }
+ }
+ first = 0;
+ if (retVal != NULL) {
+ Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep);
+ }
+ }
+
+ /*
+ * 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.
+ */
+
+ TclDecrRefCount(retVal);
+ retVal = Tcl_DuplicateObj(pathPtr);
+ Tcl_IncrRefCount(retVal);
+ }
+ }
+
+ /*
+ * Ensure a windows drive like C:/ has a trailing separator.
+ */
+
+ if (tclPlatform == TCL_PLATFORM_WINDOWS) {
+ int len;
+ const char *path = TclGetStringFromObj(retVal, &len);
+
+ if (len == 2 && path[0] != 0 && path[1] == ':') {
+ if (Tcl_IsShared(retVal)) {
+ TclDecrRefCount(retVal);
+ retVal = Tcl_DuplicateObj(retVal);
+ Tcl_IncrRefCount(retVal);
+ }
+ Tcl_AppendToObj(retVal, "/", 1);
+ }
+ }
+
+ /*
+ * 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
+ */
+
+ MakePathFromNormalized(interp, retVal);
+
+ /*
+ * This has a refCount of 1 for the caller, unlike many Tcl_Obj APIs.
+ */
+
+ return retVal;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSGetPathType --
+ *
+ * Determines whether a given path is relative to the current directory,
+ * relative to the current volume, or absolute.
+ *
+ * Results:
+ * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
+ * TCL_PATH_VOLUME_RELATIVE.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_PathType
+Tcl_FSGetPathType(
+ Tcl_Obj *pathPtr)
+{
+ return TclFSGetPathType(pathPtr, NULL, NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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).
+ *
+ * Results:
+ * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
+ * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will be set if and
+ * only if it is non-NULL and the function's return value is
+ * TCL_PATH_ABSOLUTE.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_PathType
+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);
+ }
+
+ 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);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclPathPart
+ *
+ * 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.
+ *
+ * Results:
+ * NULL if an error occurred, otherwise a Tcl_Obj owned by the caller
+ * (i.e. most likely with refCount 1).
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+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 = 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.
+ */
+
+ int numBytes;
+ const char *rest =
+ TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
+
+ if (strchr(rest, '/') != NULL) {
+ goto standardPath;
+ }
+ /*
+ * 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;
+ }
+ 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_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 =
+ TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
+
+ if (strchr(rest, '/') != NULL) {
+ goto standardPath;
+ }
+ /*
+ * 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 = TclGetStringFromObj(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 */
+ goto standardPath;
+ } else {
+ /* Absolute path */
+ goto standardPath;
+ }
+ } else {
+ int splitElements;
+ Tcl_Obj *splitPtr, *resultPtr;
+
+ standardPath:
+ resultPtr = NULL;
+ if (portion == TCL_PATH_EXTENSION) {
+ return GetExtension(pathPtr);
+ } else if (portion == TCL_PATH_ROOT) {
+ int length;
+ const char *fileName, *extension;
+
+ fileName = TclGetStringFromObj(pathPtr, &length);
+ extension = TclGetExtension(fileName);
+ if (extension == NULL) {
+ Tcl_IncrRefCount(pathPtr);
+ return pathPtr;
+ } else {
+ 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.
+ */
+
+ splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements);
+ Tcl_IncrRefCount(splitPtr);
+ if (splitElements == 1 && TclGetString(pathPtr)[0] == '~') {
+ Tcl_Obj *norm;
+
+ TclDecrRefCount(splitPtr);
+ norm = Tcl_FSGetNormalizedPath(interp, pathPtr);
+ if (norm == NULL) {
+ return NULL;
+ }
+ splitPtr = Tcl_FSSplitPath(norm, &splitElements);
+ Tcl_IncrRefCount(splitPtr);
+ }
+ if (portion == TCL_PATH_TAIL) {
+ /*
+ * 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))) {
+ Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &resultPtr);
+ } else {
+ resultPtr = Tcl_NewObj();
+ }
+ } else {
+ /*
+ * 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)) {
+ TclNewLiteralStringObj(resultPtr, ".");
+ } else {
+ Tcl_ListObjIndex(NULL, splitPtr, 0, &resultPtr);
+ }
+ }
+ Tcl_IncrRefCount(resultPtr);
+ TclDecrRefCount(splitPtr);
+ return resultPtr;
+ }
+}
+
+/*
+ * Simple helper function
+ */
+
+static Tcl_Obj *
+GetExtension(
+ Tcl_Obj *pathPtr)
+{
+ const char *tail, *extension;
+ Tcl_Obj *ret;
+
+ tail = TclGetString(pathPtr);
+ extension = TclGetExtension(tail);
+ if (extension == NULL) {
+ ret = Tcl_NewObj();
+ } else {
+ ret = Tcl_NewStringObj(extension, -1);
+ }
+ Tcl_IncrRefCount(ret);
+ return ret;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * 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.
+ *
+ * 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.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+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;
+ const Tcl_Filesystem *fsPtr = NULL;
+
+ res = NULL;
+
+ for (i = 0; i < elements; i++) {
+ int driveNameLength, strEltLen, length;
+ Tcl_PathType type;
+ char *strElt, *ptr;
+ Tcl_Obj *driveName = NULL;
+ 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.
+ *
+ * Bugfix [a47641a0]. TclNewFSPathObj requires first argument
+ * to be an absolute path. Added a check for that elt is absolute.
+ */
+
+ if ((i == (elements-2)) && (i == 0)
+ && (elt->typePtr == &tclFsPathType)
+ && !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))
+ && TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) {
+ Tcl_Obj *tailObj = objv[i+1];
+
+ type = TclGetPathType(tailObj, NULL, NULL, NULL);
+ if (type == TCL_PATH_RELATIVE) {
+ const char *str;
+ int len;
+
+ str = TclGetStringFromObj(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!
+ */
+
+ 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 (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.
+ */
+ } else if (tclPlatform == TCL_PLATFORM_UNIX) {
+ if (res != NULL) {
+ TclDecrRefCount(res);
+ }
+ return tailObj;
+ } else {
+ const char *str = TclGetString(tailObj);
+
+ if (tclPlatform == TCL_PLATFORM_WINDOWS) {
+ if (strchr(str, '\\') == NULL) {
+ if (res != NULL) {
+ TclDecrRefCount(res);
+ }
+ return tailObj;
+ }
+ }
+ }
+ }
+ strElt = TclGetStringFromObj(elt, &strEltLen);
+ type = TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName);
+ if (type != TCL_PATH_RELATIVE) {
+ /*
+ * 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).
+ */
+
+ res = Tcl_DuplicateObj(driveName);
+ 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
+ * 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 (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) {
+ 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:
+ if (res == NULL) {
+ res = Tcl_NewObj();
+ ptr = TclGetStringFromObj(res, &length);
+ } else {
+ ptr = TclGetStringFromObj(res, &length);
+ }
+
+ /*
+ * 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] == '~')) {
+ strElt += 2;
+ }
+
+ /*
+ * A NULL value for fsPtr at this stage basically means we're trying
+ * to join a relative path onto something which is also relative (or
+ * empty). There's nothing particularly wrong with that.
+ */
+
+ if (*strElt == '\0') {
+ continue;
+ }
+
+ if (fsPtr == &tclNativeFilesystem || fsPtr == NULL) {
+ TclpNativeJoinPath(res, strElt);
+ } else {
+ char separator = '/';
+ int needsSep = 0;
+
+ if (fsPtr->filesystemSeparatorProc != NULL) {
+ Tcl_Obj *sep = fsPtr->filesystemSeparatorProc(res);
+
+ if (sep != NULL) {
+ separator = 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);
+ TclGetStringFromObj(res, &length);
+ }
+ Tcl_SetObjLength(res, length + (int) strlen(strElt));
+
+ ptr = TclGetString(res) + length;
+ for (; *strElt != '\0'; strElt++) {
+ if (*strElt == separator) {
+ while (strElt[1] == separator) {
+ strElt++;
+ }
+ if (strElt[1] != '\0') {
+ if (needsSep) {
+ *ptr++ = separator;
+ }
+ }
+ } else {
+ *ptr++ = *strElt;
+ needsSep = 1;
+ }
+ }
+ length = ptr - TclGetString(res);
+ Tcl_SetObjLength(res, length);
+ }
+ }
+ if (res == NULL) {
+ res = Tcl_NewObj();
+ }
+ return res;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * 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).
+ *
+ * Results:
+ * Standard Tcl error code.
+ *
+ * Side effects:
+ * The old representation may be freed, and new memory allocated.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+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. */
+{
+ /*
+ * 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) {
+ if (TclFSEpochOk(PATHOBJ(pathPtr)->filesystemEpoch)) {
+ return TCL_OK;
+ }
+
+ 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(
+ int ch)
+{
+ if (ch == 0) {
+ return 1;
+ }
+ switch (tclPlatform) {
+ 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.
+ */
+
+static int
+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++;
+ }
+ break;
+
+ case TCL_PLATFORM_WINDOWS:
+ while (path[count] != 0) {
+ if (path[count] == separator || path[count] == '\\') {
+ return count;
+ }
+ count++;
+ }
+ break;
+ }
+ return count;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * 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.
+ *
+ * Assumptions:
+ * 'dirPtr' must be an absolute path. 'len' may not be zero.
+ *
+ * Results:
+ * The new Tcl object, with refCount zero.
+ *
+ * Side effects:
+ * Memory is allocated. 'dirPtr' gets an additional refCount.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclNewFSPathObj(
+ Tcl_Obj *dirPtr,
+ const char *addStrRep,
+ int len)
+{
+ FsPath *fsPathPtr;
+ Tcl_Obj *pathPtr;
+ 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 = 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->fsPtr = NULL;
+ fsPathPtr->filesystemEpoch = 0;
+
+ 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 = TclGetStringFromObj(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.
+ *
+ * Results:
+ * 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.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+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;
+
+ if (pathPtr->typePtr == &tclFsPathType) {
+ FsPath *fsPathPtr = PATHOBJ(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.
+ */
+
+ tempStr = TclGetStringFromObj(cwdPtr, &cwdLen);
+
+ /*
+ * Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the
+ * Windows special case? Perhaps we should just check if cwd is a root
+ * volume.
+ */
+
+ switch (tclPlatform) {
+ case TCL_PLATFORM_UNIX:
+ if (tempStr[cwdLen-1] != '/') {
+ cwdLen++;
+ }
+ break;
+ case TCL_PLATFORM_WINDOWS:
+ if (tempStr[cwdLen-1] != '/' && tempStr[cwdLen-1] != '\\') {
+ cwdLen++;
+ }
+ break;
+ }
+ tempStr = TclGetStringFromObj(pathPtr, &len);
+
+ return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * MakePathFromNormalized --
+ *
+ * Like SetFsPathFromAny, but assumes the given object is an absolute
+ * normalized path. Only for internal use.
+ *
+ * Results:
+ * Standard Tcl error code.
+ *
+ * Side effects:
+ * The old representation may be freed, and new memory allocated.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+MakePathFromNormalized(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Obj *pathPtr) /* The object to convert. */
+{
+ FsPath *fsPathPtr;
+
+ if (pathPtr->typePtr == &tclFsPathType) {
+ return TCL_OK;
+ }
+
+ /*
+ * Free old representation
+ */
+
+ if (pathPtr->typePtr != NULL) {
+ if (pathPtr->bytes == NULL) {
+ if (pathPtr->typePtr->updateStringProc == NULL) {
+ if (interp != 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);
+ }
+ TclFreeIntRep(pathPtr);
+ }
+
+ fsPathPtr = ckalloc(sizeof(FsPath));
+
+ /*
+ * It's a pure normalized absolute path.
+ */
+
+ fsPathPtr->translatedPathPtr = NULL;
+
+ /*
+ * Circular reference by design.
+ */
+
+ fsPathPtr->normPathPtr = pathPtr;
+ fsPathPtr->cwdPtr = NULL;
+ fsPathPtr->nativePathPtr = NULL;
+ fsPathPtr->fsPtr = NULL;
+ /* Remember the epoch under which we decided pathPtr was normalized */
+ fsPathPtr->filesystemEpoch = TclFSEpoch();
+
+ SETPATHOBJ(pathPtr, fsPathPtr);
+ PATHFLAGS(pathPtr) = 0;
+ pathPtr->typePtr = &tclFsPathType;
+
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSNewNativePath --
+ *
+ * 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.
+ *
+ * Side effects:
+ * New memory may be allocated.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_FSNewNativePath(
+ const Tcl_Filesystem *fromFilesystem,
+ ClientData clientData)
+{
+ Tcl_Obj *pathPtr = NULL;
+ FsPath *fsPathPtr;
+
+
+ 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.
+ */
+
+ if (pathPtr->typePtr != NULL) {
+ if (pathPtr->bytes == NULL) {
+ if (pathPtr->typePtr->updateStringProc == NULL) {
+ return NULL;
+ }
+ pathPtr->typePtr->updateStringProc(pathPtr);
+ }
+ TclFreeIntRep(pathPtr);
+ }
+
+ fsPathPtr = ckalloc(sizeof(FsPath));
+
+ fsPathPtr->translatedPathPtr = NULL;
+
+ /*
+ * Circular reference, by design.
+ */
+
+ fsPathPtr->normPathPtr = pathPtr;
+ fsPathPtr->cwdPtr = NULL;
+ fsPathPtr->nativePathPtr = clientData;
+ fsPathPtr->fsPtr = fromFilesystem;
+ fsPathPtr->filesystemEpoch = TclFSEpoch();
+
+ SETPATHOBJ(pathPtr, fsPathPtr);
+ PATHFLAGS(pathPtr) = 0;
+ pathPtr->typePtr = &tclFsPathType;
+
+ return pathPtr;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * 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)
+ *
+ * Results:
+ * NULL or a valid Tcl_Obj pointer.
+ *
+ * Side effects:
+ * Only those of 'Tcl_FSConvertToPathType'
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_FSGetTranslatedPath(
+ Tcl_Interp *interp,
+ Tcl_Obj *pathPtr)
+{
+ Tcl_Obj *retObj = NULL;
+ FsPath *srcFsPathPtr;
+
+ if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
+ return NULL;
+ }
+ srcFsPathPtr = PATHOBJ(pathPtr);
+ if (srcFsPathPtr->translatedPathPtr == NULL) {
+ if (PATHFLAGS(pathPtr) != 0) {
+ /*
+ * 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.
+ */
+
+ retObj = srcFsPathPtr->normPathPtr;
+ }
+ } else {
+ /*
+ * It is an ordinary path object.
+ */
+
+ retObj = srcFsPathPtr->translatedPathPtr;
+ }
+
+ if (retObj != NULL) {
+ Tcl_IncrRefCount(retObj);
+ }
+ return retObj;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSGetTranslatedStringPath --
+ *
+ * This function attempts to extract the translated path from the given
+ * Tcl_Obj. If the translation succeeds (i.e. the object is a valid
+ * path), then the path is returned. Otherwise NULL will be returned, and
+ * an error message may be left in the interpreter (if it is non-NULL)
+ *
+ * Results:
+ * NULL or a valid string.
+ *
+ * Side effects:
+ * Only those of 'Tcl_FSConvertToPathType'
+ *
+ *---------------------------------------------------------------------------
+ */
+
+const char *
+Tcl_FSGetTranslatedStringPath(
+ Tcl_Interp *interp,
+ Tcl_Obj *pathPtr)
+{
+ Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
+
+ if (transPtr != NULL) {
+ int len;
+ const char *orig = TclGetStringFromObj(transPtr, &len);
+ char *result = ckalloc(len+1);
+
+ memcpy(result, orig, (size_t) len+1);
+ TclDecrRefCount(transPtr);
+ return result;
+ }
+
+ return NULL;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * 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.
+ *
+ * Results:
+ * 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.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_FSGetNormalizedPath(
+ Tcl_Interp *interp,
+ Tcl_Obj *pathPtr)
+{
+ FsPath *fsPathPtr;
+
+ if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
+ return NULL;
+ }
+ fsPathPtr = PATHOBJ(pathPtr);
+
+ if (PATHFLAGS(pathPtr) != 0) {
+ /*
+ * This is a special path object which is the result of something like
+ * 'file join'
+ */
+
+ Tcl_Obj *dir, *copy;
+ 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);
+ }
+
+ TclGetStringFromObj(fsPathPtr->normPathPtr, &tailLen);
+ if (tailLen) {
+ copy = AppendPath(dir, fsPathPtr->normPathPtr);
+ } else {
+ copy = Tcl_DuplicateObj(dir);
+ }
+ Tcl_IncrRefCount(dir);
+ Tcl_IncrRefCount(copy);
+
+ /*
+ * We now own a reference on both 'dir' and 'copy'
+ */
+
+ (void) TclGetStringFromObj(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);
+ }
+
+ /* Now we need to construct the new path object. */
+
+ if (pathType == TCL_PATH_RELATIVE) {
+ Tcl_Obj *origDir = fsPathPtr->cwdPtr;
+
+ /*
+ * 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);
+
+ TclDecrRefCount(fsPathPtr->normPathPtr);
+ fsPathPtr->normPathPtr = copy;
+
+ /*
+ * That's our reference to copy used.
+ */
+
+ TclDecrRefCount(dir);
+ TclDecrRefCount(origDir);
+ } else {
+ TclDecrRefCount(fsPathPtr->cwdPtr);
+ fsPathPtr->cwdPtr = NULL;
+ TclDecrRefCount(fsPathPtr->normPathPtr);
+ fsPathPtr->normPathPtr = copy;
+
+ /*
+ * That's our reference to copy used.
+ */
+
+ TclDecrRefCount(dir);
+ }
+ PATHFLAGS(pathPtr) = 0;
+ }
+
+ /*
+ * Ensure cwd hasn't changed.
+ */
+
+ if (fsPathPtr->cwdPtr != NULL) {
+ if (!TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) {
+ if (pathPtr->bytes == NULL) {
+ UpdateStringOfFsPath(pathPtr);
+ }
+ FreeFsPathInternalRep(pathPtr);
+ if (SetFsPathFromAny(interp, pathPtr) != TCL_OK) {
+ return NULL;
+ }
+ fsPathPtr = PATHOBJ(pathPtr);
+ } else if (fsPathPtr->normPathPtr == NULL) {
+ int cwdLen;
+ Tcl_Obj *copy;
+
+ copy = AppendPath(fsPathPtr->cwdPtr, pathPtr);
+
+ (void) TclGetStringFromObj(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->normPathPtr = copy;
+ Tcl_IncrRefCount(fsPathPtr->normPathPtr);
+ }
+ }
+ if (fsPathPtr->normPathPtr == NULL) {
+ Tcl_Obj *useThisCwd = 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;
+ 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.
+ */
+
+ 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;
+ }
+
+ pureNormalized = 0;
+ Tcl_DecrRefCount(absolutePath);
+ absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath);
+ Tcl_IncrRefCount(absolutePath);
+
+ /*
+ * We have a refCount on the cwd.
+ */
+#ifdef _WIN32
+ } else if (type == TCL_PATH_VOLUME_RELATIVE) {
+ /*
+ * Only Windows has volume-relative paths.
+ */
+
+ Tcl_DecrRefCount(absolutePath);
+ absolutePath = TclWinVolumeRelativeNormalize(interp,
+ path, &useThisCwd);
+ if (absolutePath == NULL) {
+ return NULL;
+ }
+ pureNormalized = 0;
+#endif /* _WIN32 */
+ }
+ }
+
+ /*
+ * Already has refCount incremented.
+ */
+
+ 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.
+ */
+
+ TclDecrRefCount(fsPathPtr->normPathPtr);
+
+ /*
+ * We do *not* increment the refCount for this circular
+ * reference.
+ */
+
+ fsPathPtr->normPathPtr = pathPtr;
+ }
+ }
+ 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.
+ */
+
+ fsPathPtr->cwdPtr = useThisCwd;
+ }
+ TclDecrRefCount(absolutePath);
+ }
+
+ return fsPathPtr->normPathPtr;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * 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'.
+ *
+ * Results:
+ * NULL or a valid internal representation.
+ *
+ * Side effects:
+ * An attempt may be made to convert the object.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+ClientData
+Tcl_FSGetInternalRep(
+ Tcl_Obj *pathPtr,
+ const Tcl_Filesystem *fsPtr)
+{
+ FsPath *srcFsPathPtr;
+
+ if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) {
+ return NULL;
+ }
+ 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.
+ */
+
+ 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).
+ */
+
+ srcFsPathPtr = PATHOBJ(pathPtr);
+ if (srcFsPathPtr->fsPtr == NULL) {
+ return NULL;
+ }
+ }
+
+ /*
+ * 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);
+ }
+ return NULL;
+ }
+
+ if (srcFsPathPtr->nativePathPtr == NULL) {
+ Tcl_FSCreateInternalRepProc *proc;
+ char *nativePathPtr;
+
+ proc = srcFsPathPtr->fsPtr->createInternalRepProc;
+ if (proc == NULL) {
+ return NULL;
+ }
+
+ nativePathPtr = proc(pathPtr);
+ srcFsPathPtr = PATHOBJ(pathPtr);
+ srcFsPathPtr->nativePathPtr = nativePathPtr;
+ }
+
+ return srcFsPathPtr->nativePathPtr;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * 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.
+ *
+ * Results:
+ * Standard Tcl return code.
+ *
+ * Side effects:
+ * An attempt may be made to convert the object.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclFSEnsureEpochOk(
+ Tcl_Obj *pathPtr,
+ const Tcl_Filesystem **fsPtrPtr)
+{
+ FsPath *srcFsPathPtr;
+
+ if (pathPtr->typePtr != &tclFsPathType) {
+ return TCL_OK;
+ }
+
+ srcFsPathPtr = PATHOBJ(pathPtr);
+
+ /*
+ * Check if the filesystem has changed in some way since this object's
+ * internal representation was calculated.
+ */
+
+ if (!TclFSEpochOk(srcFsPathPtr->filesystemEpoch)) {
+ /*
+ * We have to discard the stale representation and recalculate it.
+ */
+
+ if (pathPtr->bytes == NULL) {
+ UpdateStringOfFsPath(pathPtr);
+ }
+ FreeFsPathInternalRep(pathPtr);
+ if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ srcFsPathPtr = PATHOBJ(pathPtr);
+ }
+
+ /*
+ * Check whether the object is already assigned to a fs.
+ */
+
+ if (srcFsPathPtr->fsPtr != NULL) {
+ *fsPtrPtr = srcFsPathPtr->fsPtr;
+ }
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclFSSetPathDetails --
+ *
+ * ???
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * ???
+ *
+ *---------------------------------------------------------------------------
+ */
+
+void
+TclFSSetPathDetails(
+ Tcl_Obj *pathPtr,
+ const Tcl_Filesystem *fsPtr,
+ ClientData clientData)
+{
+ FsPath *srcFsPathPtr;
+
+ /*
+ * Make sure pathPtr is of the correct type.
+ */
+
+ if (pathPtr->typePtr != &tclFsPathType) {
+ if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
+ return;
+ }
+ }
+
+ srcFsPathPtr = PATHOBJ(pathPtr);
+ srcFsPathPtr->fsPtr = fsPtr;
+ srcFsPathPtr->nativePathPtr = clientData;
+ srcFsPathPtr->filesystemEpoch = TclFSEpoch();
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSEqualPaths --
+ *
+ * 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.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_FSEqualPaths(
+ Tcl_Obj *firstPtr,
+ Tcl_Obj *secondPtr)
+{
+ const char *firstStr, *secondStr;
+ int firstLen, secondLen, tempErrno;
+
+ if (firstPtr == secondPtr) {
+ return 1;
+ }
+
+ 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);
+
+ if (firstPtr == NULL || secondPtr == NULL) {
+ return 0;
+ }
+
+ firstStr = TclGetStringFromObj(firstPtr, &firstLen);
+ secondStr = TclGetStringFromObj(secondPtr, &secondLen);
+ return ((firstLen == secondLen) && !memcmp(firstStr, secondStr, firstLen));
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * 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).
+ *
+ * Results:
+ * Standard Tcl error code.
+ *
+ * Side effects:
+ * The old representation may be freed, and new memory allocated.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+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;
+
+ 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.
+ *
+ * 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).
+ */
+
+ name = TclGetStringFromObj(pathPtr, &len);
+
+ /*
+ * Handle tilde substitutions, if needed.
+ */
+
+ if (name[0] == '~') {
+ Tcl_DString temp;
+ int split;
+ char separator = '/';
+
+ split = FindSplitPos(name, separator);
+ if (split != len) {
+ /*
+ * We have multiple pieces '~user/foo/bar...'
+ */
+
+ name[split] = '\0';
+ }
+
+ /*
+ * Do some tilde substitution.
+ */
+
+ if (name[1] == '\0') {
+ /*
+ * We have just '~'
+ */
+
+ const char *dir;
+ Tcl_DString dirString;
+
+ if (split != len) {
+ name[split] = separator;
+ }
+
+ dir = TclGetEnv("HOME", &dirString);
+ if (dir == NULL) {
+ if (interp) {
+ Tcl_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;
+ }
+ Tcl_DStringInit(&temp);
+ Tcl_JoinPath(1, &dir, &temp);
+ Tcl_DStringFree(&dirString);
+ } else {
+ /*
+ * We have a user name '~user'
+ */
+
+ Tcl_DStringInit(&temp);
+ if (TclpGetUserHome(name+1, &temp) == NULL) {
+ if (interp != NULL) {
+ Tcl_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;
+ }
+ return TCL_ERROR;
+ }
+ if (split != len) {
+ name[split] = separator;
+ }
+ }
+
+ transPtr = TclDStringToObj(&temp);
+
+ if (split != len) {
+ /*
+ * Join up the tilde substitution with the rest.
+ */
+
+ if (name[split+1] == separator) {
+ /*
+ * Somewhat tricky case like ~//foo/bar. Make use of
+ * Split/Join machinery to get it right. Assumes all paths
+ * beginning with ~ are part of the native filesystem.
+ */
+
+ int objc;
+ Tcl_Obj **objv;
+ Tcl_Obj *parts = TclpNativeSplitPath(pathPtr, NULL);
+
+ Tcl_ListObjGetElements(NULL, parts, &objc, &objv);
+
+ /*
+ * Skip '~'. It's replaced by its expansion.
+ */
+
+ objc--; objv++;
+ while (objc--) {
+ TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++));
+ }
+ TclDecrRefCount(parts);
+ } else {
+ Tcl_Obj *pair[2];
+
+ pair[0] = transPtr;
+ pair[1] = Tcl_NewStringObj(name+split+1, -1);
+ transPtr = TclJoinPath(2, pair);
+ Tcl_DecrRefCount(pair[0]);
+ Tcl_DecrRefCount(pair[1]);
+ }
+ }
+ } else {
+ transPtr = TclJoinPath(1, &pathPtr);
+ }
+
+ /*
+ * Now we have a translated filename in 'transPtr'. This will have forward
+ * slashes on Windows, and will not contain any ~user sequences.
+ */
+
+ fsPathPtr = ckalloc(sizeof(FsPath));
+
+ fsPathPtr->translatedPathPtr = transPtr;
+ if (transPtr != pathPtr) {
+ 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->fsPtr = NULL;
+
+ /*
+ * Free old representation before installing our new one.
+ */
+
+ TclFreeIntRep(pathPtr);
+ SETPATHOBJ(pathPtr, fsPathPtr);
+ PATHFLAGS(pathPtr) = 0;
+ pathPtr->typePtr = &tclFsPathType;
+ return TCL_OK;
+}
+
+static void
+FreeFsPathInternalRep(
+ Tcl_Obj *pathPtr) /* Path object with internal rep to free. */
+{
+ FsPath *fsPathPtr = PATHOBJ(pathPtr);
+
+ if (fsPathPtr->translatedPathPtr != NULL) {
+ if (fsPathPtr->translatedPathPtr != pathPtr) {
+ TclDecrRefCount(fsPathPtr->translatedPathPtr);
+ }
+ }
+ if (fsPathPtr->normPathPtr != NULL) {
+ if (fsPathPtr->normPathPtr != pathPtr) {
+ TclDecrRefCount(fsPathPtr->normPathPtr);
+ }
+ fsPathPtr->normPathPtr = NULL;
+ }
+ if (fsPathPtr->cwdPtr != NULL) {
+ TclDecrRefCount(fsPathPtr->cwdPtr);
+ }
+ if (fsPathPtr->nativePathPtr != NULL && fsPathPtr->fsPtr != NULL) {
+ Tcl_FSFreeInternalRepProc *freeProc =
+ fsPathPtr->fsPtr->freeInternalRepProc;
+
+ if (freeProc != NULL) {
+ freeProc(fsPathPtr->nativePathPtr);
+ fsPathPtr->nativePathPtr = NULL;
+ }
+ }
+
+ ckfree(fsPathPtr);
+ pathPtr->typePtr = NULL;
+}
+
+static void
+DupFsPathInternalRep(
+ Tcl_Obj *srcPtr, /* Path obj with internal rep to copy. */
+ Tcl_Obj *copyPtr) /* Path obj with internal rep to set. */
+{
+ FsPath *srcFsPathPtr = PATHOBJ(srcPtr);
+ FsPath *copyFsPathPtr = ckalloc(sizeof(FsPath));
+
+ SETPATHOBJ(copyPtr, copyFsPathPtr);
+
+ if (srcFsPathPtr->translatedPathPtr == srcPtr) {
+ /* Cycle in src -> make cycle in copy. */
+ copyFsPathPtr->translatedPathPtr = copyPtr;
+ } else {
+ copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr;
+ if (copyFsPathPtr->translatedPathPtr != NULL) {
+ Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr);
+ }
+ }
+
+ if (srcFsPathPtr->normPathPtr == srcPtr) {
+ /* Cycle in src -> make cycle in copy. */
+ copyFsPathPtr->normPathPtr = copyPtr;
+ } else {
+ copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr;
+ if (copyFsPathPtr->normPathPtr != NULL) {
+ Tcl_IncrRefCount(copyFsPathPtr->normPathPtr);
+ }
+ }
+
+ copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr;
+ if (copyFsPathPtr->cwdPtr != NULL) {
+ Tcl_IncrRefCount(copyFsPathPtr->cwdPtr);
+ }
+
+ copyFsPathPtr->flags = srcFsPathPtr->flags;
+
+ if (srcFsPathPtr->fsPtr != NULL
+ && srcFsPathPtr->nativePathPtr != NULL) {
+ Tcl_FSDupInternalRepProc *dupProc =
+ srcFsPathPtr->fsPtr->dupInternalRepProc;
+
+ if (dupProc != NULL) {
+ copyFsPathPtr->nativePathPtr =
+ dupProc(srcFsPathPtr->nativePathPtr);
+ } else {
+ copyFsPathPtr->nativePathPtr = NULL;
+ }
+ } else {
+ copyFsPathPtr->nativePathPtr = NULL;
+ }
+ copyFsPathPtr->fsPtr = srcFsPathPtr->fsPtr;
+ copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch;
+
+ copyPtr->typePtr = &tclFsPathType;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * UpdateStringOfFsPath --
+ *
+ * Gives an object a valid string rep.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory may be allocated.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static void
+UpdateStringOfFsPath(
+ register Tcl_Obj *pathPtr) /* path obj with string rep to update. */
+{
+ FsPath *fsPathPtr = PATHOBJ(pathPtr);
+ int cwdLen;
+ Tcl_Obj *copy;
+
+ if (PATHFLAGS(pathPtr) == 0 || fsPathPtr->cwdPtr == NULL) {
+ Tcl_Panic("Called UpdateStringOfFsPath with invalid object");
+ }
+
+ copy = AppendPath(fsPathPtr->cwdPtr, fsPathPtr->normPathPtr);
+
+ pathPtr->bytes = TclGetStringFromObj(copy, &cwdLen);
+ pathPtr->length = cwdLen;
+ copy->bytes = tclEmptyStringRep;
+ copy->length = 0;
+ TclDecrRefCount(copy);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * 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).
+ *
+ * Results:
+ * TCL_OK, to indicate 'yes', -1 to indicate no.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+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.
+ */
+
+ if (pathPtr->typePtr == &tclFsPathType) {
+ if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') {
+ /*
+ * We reject the empty path "".
+ */
+
+ return -1;
+ }
+
+ /*
+ * Otherwise there is no way this path can be empty.
+ */
+ } else {
+ /*
+ * It is somewhat unusual to reach this code path without the object
+ * being of tclFsPathType. However, we do our best to deal with the
+ * situation.
+ */
+
+ int len;
+
+ (void) TclGetStringFromObj(pathPtr, &len);
+ if (len == 0) {
+ /*
+ * We reject the empty path "".
+ */
+
+ return -1;
+ }
+ }
+
+ /*
+ * 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:
+ */