summaryrefslogtreecommitdiffstats
path: root/generic/tclPathObj.c
diff options
context:
space:
mode:
authorvincentdarley <vincentdarley>2003-04-11 15:59:49 (GMT)
committervincentdarley <vincentdarley>2003-04-11 15:59:49 (GMT)
commita5499a51a90ae1c06f3f39ee05c4b42185e0f28c (patch)
tree324d5cddf5f2dfe379c3cf1427347351d8d683a5 /generic/tclPathObj.c
parent3c51da6d9db3a5e20f2e38f667ef5c0791b2e88d (diff)
downloadtcl-a5499a51a90ae1c06f3f39ee05c4b42185e0f28c.zip
tcl-a5499a51a90ae1c06f3f39ee05c4b42185e0f28c.tar.gz
tcl-a5499a51a90ae1c06f3f39ee05c4b42185e0f28c.tar.bz2
fix 5 small filesystem bugs, and some typos
Diffstat (limited to 'generic/tclPathObj.c')
-rw-r--r--generic/tclPathObj.c1857
1 files changed, 1857 insertions, 0 deletions
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
new file mode 100644
index 0000000..9dcde63
--- /dev/null
+++ b/generic/tclPathObj.c
@@ -0,0 +1,1857 @@
+/*
+ * 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.
+ *
+ * RCS: @(#) $Id: tclPathObj.c,v 1.1 2003/04/11 15:59:58 vincentdarley Exp $
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+#ifdef MAC_TCL
+#include "tclMacInt.h"
+#endif
+#include "tclFileSystem.h"
+
+/*
+ * Prototypes for procedures defined later in this file.
+ */
+
+static void DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
+ Tcl_Obj *copyPtr));
+static void FreeFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *listPtr));
+static void UpdateStringOfFsPath _ANSI_ARGS_((Tcl_Obj *objPtr));
+static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
+static Tcl_Obj* FSNormalizeAbsolutePath
+ _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr,
+ ClientData *clientDataPtr));
+static int FindSplitPos _ANSI_ARGS_((char *path, char *separator));
+
+
+
+/*
+ * Define the 'path' object type, which Tcl uses to represent
+ * file paths internally.
+ */
+Tcl_ObjType tclFsPathType = {
+ "path", /* name */
+ FreeFsPathInternalRep, /* freeIntRepProc */
+ DupFsPathInternalRep, /* dupIntRepProc */
+ UpdateStringOfFsPath, /* updateStringProc */
+ SetFsPathFromAny /* setFromAnyProc */
+};
+
+/*
+ * struct FsPath --
+ *
+ * Internal representation of a Tcl_Obj of "path" type. This
+ * can be used to represent relative or absolute paths, and has
+ * certain optimisations when used to represent paths which are
+ * already normalized and absolute.
+ *
+ * Note that 'normPathPtr' can be a circular reference to the
+ * container Tcl_Obj of this FsPath.
+ */
+typedef struct FsPath {
+ Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences.
+ * If this is NULL, then this is a
+ * pure normalized, absolute path
+ * object, in which the parent Tcl_Obj's
+ * string rep is already both translated
+ * and normalized. */
+ Tcl_Obj *normPathPtr; /* Normalized absolute path, without
+ * ., .. or ~user sequences. If the
+ * Tcl_Obj containing
+ * this FsPath is already normalized,
+ * this may be a circular reference back
+ * to the container. If that is NOT the
+ * case, we have a refCount on the object. */
+ Tcl_Obj *cwdPtr; /* If null, path is absolute, else
+ * this points to the cwd object used
+ * for this path. We have a refCount
+ * on the object. */
+ int flags; /* Flags to describe interpretation */
+ ClientData nativePathPtr; /* Native representation of this path,
+ * which is filesystem dependent. */
+ int filesystemEpoch; /* Used to ensure the path representation
+ * was generated during the correct
+ * filesystem epoch. The epoch changes
+ * when filesystem-mounts are changed. */
+ struct FilesystemRecord *fsRecPtr;
+ /* Pointer to the filesystem record
+ * entry to use for this path. */
+} FsPath;
+
+/*
+ * Define some macros to give us convenient access to path-object
+ * specific fields.
+ */
+#define PATHOBJ(objPtr) (objPtr->internalRep.otherValuePtr)
+#define PATHFLAGS(objPtr) \
+ (((FsPath*)(objPtr->internalRep.otherValuePtr))->flags)
+
+#define TCLPATH_APPENDED 1
+#define TCLPATH_RELATIVE 2
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * FSNormalizeAbsolutePath --
+ *
+ * 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 MacOS, 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.
+ *
+ * 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 is based on code from Matt Newman and Jean-Claude
+ * Wippler, with additions from Vince Darley and is copyright
+ * those respective authors.
+ *
+ *---------------------------------------------------------------------------
+ */
+static Tcl_Obj*
+FSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr)
+ Tcl_Interp* interp; /* Interpreter to use */
+ Tcl_Obj *pathPtr; /* Absolute path to normalize */
+ ClientData *clientDataPtr;
+{
+ int splen = 0, nplen, eltLen, i;
+ char *eltName;
+ Tcl_Obj *retVal;
+ Tcl_Obj *split;
+ Tcl_Obj *elt;
+
+ /* Split has refCount zero */
+ split = Tcl_FSSplitPath(pathPtr, &splen);
+
+ /*
+ * Modify the list of entries in place, by removing '.', and
+ * removing '..' and the entry before -- unless that entry before
+ * is the top-level entry, i.e. the name of a volume.
+ */
+ nplen = 0;
+ for (i = 0; i < splen; i++) {
+ Tcl_ListObjIndex(NULL, split, nplen, &elt);
+ eltName = Tcl_GetStringFromObj(elt, &eltLen);
+
+ if ((eltLen == 1) && (eltName[0] == '.')) {
+ Tcl_ListObjReplace(NULL, split, nplen, 1, 0, NULL);
+ } else if ((eltLen == 2)
+ && (eltName[0] == '.') && (eltName[1] == '.')) {
+ if (nplen > 1) {
+ nplen--;
+ Tcl_ListObjReplace(NULL, split, nplen, 2, 0, NULL);
+ } else {
+ Tcl_ListObjReplace(NULL, split, nplen, 1, 0, NULL);
+ }
+ } else {
+ nplen++;
+ }
+ }
+ if (nplen > 0) {
+ ClientData clientData = NULL;
+
+ retVal = Tcl_FSJoinPath(split, nplen);
+ /*
+ * Now we have an absolute path, with no '..', '.' sequences,
+ * but it still may not be in 'unique' form, depending on the
+ * 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). MacOS is case-insensitive.
+ *
+ * Virtual file systems which may be registered may have
+ * other criteria for normalizing a path.
+ */
+ Tcl_IncrRefCount(retVal);
+ 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
+ */
+ TclFSMakePathFromNormalized(interp, retVal, clientData);
+ if (clientDataPtr != NULL) {
+ *clientDataPtr = clientData;
+ }
+ } else {
+ /* Init to an empty string */
+ retVal = Tcl_NewStringObj("",0);
+ Tcl_IncrRefCount(retVal);
+ }
+ /*
+ * We increment and then decrement the refCount of split to free
+ * it. We do this right at the end, in case there are
+ * optimisations in Tcl_FSJoinPath(split, nplen) above which would
+ * let it make use of split more effectively if it has a refCount
+ * of zero. Also we can't just decrement the ref count, in case
+ * 'split' was actually returned by the join call above, in a
+ * single-element optimisation when nplen == 1.
+ */
+ Tcl_IncrRefCount(split);
+ Tcl_DecrRefCount(split);
+
+ /* This has a refCount of 1 for the caller */
+ return retVal;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSGetPathType --
+ *
+ * Determines whether a given path is relative to the current
+ * directory, relative to the current volume, or absolute.
+ *
+ * Results:
+ * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
+ * TCL_PATH_VOLUME_RELATIVE.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_PathType
+Tcl_FSGetPathType(pathObjPtr)
+ Tcl_Obj *pathObjPtr;
+{
+ return FSGetPathType(pathObjPtr, NULL, NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FSGetPathType --
+ *
+ * Determines whether a given path is relative to the current
+ * directory, relative to the current volume, or absolute. If the
+ * caller wishes to know which filesystem claimed the path (in the
+ * case for which the path is absolute), then a reference to a
+ * filesystem pointer can be passed in (but passing NULL is
+ * acceptable).
+ *
+ * Results:
+ * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
+ * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will
+ * be set if and only if it is non-NULL and the function's
+ * return value is TCL_PATH_ABSOLUTE.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_PathType
+FSGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr)
+ Tcl_Obj *pathObjPtr;
+ Tcl_Filesystem **filesystemPtrPtr;
+ int *driveNameLengthPtr;
+{
+ if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) {
+ return GetPathType(pathObjPtr, filesystemPtrPtr,
+ driveNameLengthPtr, NULL);
+ } else {
+ FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
+ if (fsPathPtr->cwdPtr != NULL) {
+ if (PATHFLAGS(pathObjPtr) == 0) {
+ return TCL_PATH_RELATIVE;
+ }
+ return FSGetPathType(fsPathPtr->cwdPtr, filesystemPtrPtr,
+ driveNameLengthPtr);
+ } else {
+ return GetPathType(pathObjPtr, filesystemPtrPtr,
+ driveNameLengthPtr, NULL);
+ }
+ }
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSJoinPath --
+ *
+ * This function takes the given Tcl_Obj, which should be a valid
+ * list, and returns the path object given by considering the
+ * first 'elements' elements as valid path segments. If elements < 0,
+ * we use the entire list.
+ *
+ * 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.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+Tcl_Obj*
+Tcl_FSJoinPath(listObj, elements)
+ Tcl_Obj *listObj;
+ int elements;
+{
+ Tcl_Obj *res;
+ int i;
+ Tcl_Filesystem *fsPtr = NULL;
+
+ if (elements < 0) {
+ if (Tcl_ListObjLength(NULL, listObj, &elements) != TCL_OK) {
+ return NULL;
+ }
+ } else {
+ /* Just make sure it is a valid list */
+ int listTest;
+ if (Tcl_ListObjLength(NULL, listObj, &listTest) != TCL_OK) {
+ return NULL;
+ }
+ /*
+ * Correct this if it is too large, otherwise we will
+ * waste our time joining null elements to the path
+ */
+ if (elements > listTest) {
+ elements = listTest;
+ }
+ }
+
+ if (elements == 2) {
+ /*
+ * This is a special case where we can be much more
+ * efficient
+ */
+ Tcl_Obj *base;
+
+ Tcl_ListObjIndex(NULL, listObj, 0, &base);
+ /*
+ * There is only any value in doing this if the first object is
+ * of path type, otherwise we'll never actually get any
+ * efficiency benefit elsewhere in the code (from re-using the
+ * normalized representation of the base object).
+ */
+ if (base->typePtr == &tclFsPathType
+ && !(base->bytes != NULL && base->bytes[0] == '\0')) {
+ Tcl_Obj *tail;
+ Tcl_PathType type;
+ Tcl_ListObjIndex(NULL, listObj, 1, &tail);
+ type = GetPathType(tail, NULL, NULL, NULL);
+ if (type == TCL_PATH_RELATIVE) {
+ CONST char *str;
+ int len;
+ str = Tcl_GetStringFromObj(tail,&len);
+ if (len == 0) {
+ /*
+ * This happens if we try to handle the root volume
+ * '/'. There's no need to return a special path
+ * object, when the base itself is just fine!
+ */
+ return base;
+ }
+ if (str[0] != '.') {
+ return TclNewFSPathObj(base, str, len);
+ }
+ /*
+ * Otherwise we don't have an easy join, and
+ * we must let the more general code below handle
+ * things
+ */
+ } else {
+ return tail;
+ }
+ }
+ }
+
+ res = Tcl_NewObj();
+
+ for (i = 0; i < elements; i++) {
+ Tcl_Obj *elt;
+ int driveNameLength;
+ Tcl_PathType type;
+ char *strElt;
+ int strEltLen;
+ int length;
+ char *ptr;
+ Tcl_Obj *driveName = NULL;
+
+ Tcl_ListObjIndex(NULL, listObj, i, &elt);
+ strElt = Tcl_GetStringFromObj(elt, &strEltLen);
+ type = GetPathType(elt, &fsPtr, &driveNameLength, &driveName);
+ if (type != TCL_PATH_RELATIVE) {
+ /* Zero out the current result */
+ Tcl_DecrRefCount(res);
+ if (driveName != NULL) {
+ res = Tcl_DuplicateObj(driveName);
+ Tcl_DecrRefCount(driveName);
+ } else {
+ res = Tcl_NewStringObj(strElt, driveNameLength);
+ }
+ strElt += driveNameLength;
+ }
+
+ ptr = Tcl_GetStringFromObj(res, &length);
+
+ /*
+ * Strip off any './' before a tilde, unless this is the
+ * beginning of the path.
+ */
+ if (length > 0 && strEltLen > 0) {
+ if ((strElt[0] == '.') && (strElt[1] == '/')
+ && (strElt[2] == '~')) {
+ strElt += 2;
+ }
+ }
+
+ /*
+ * A NULL value for fsPtr at this stage basically means
+ * we're trying to join a relative path onto something
+ * which is also relative (or empty). There's nothing
+ * particularly wrong with that.
+ */
+ if (*strElt == '\0') continue;
+
+ if (fsPtr == &tclNativeFilesystem || fsPtr == NULL) {
+ TclpNativeJoinPath(res, strElt);
+ } else {
+ char separator = '/';
+ int needsSep = 0;
+
+ if (fsPtr->filesystemSeparatorProc != NULL) {
+ Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(res);
+ if (sep != NULL) {
+ separator = Tcl_GetString(sep)[0];
+ }
+ }
+
+ if (length > 0 && ptr[length -1] != '/') {
+ Tcl_AppendToObj(res, &separator, 1);
+ length++;
+ }
+ Tcl_SetObjLength(res, length + (int) strlen(strElt));
+
+ ptr = Tcl_GetString(res) + length;
+ for (; *strElt != '\0'; strElt++) {
+ if (*strElt == separator) {
+ while (strElt[1] == separator) {
+ strElt++;
+ }
+ if (strElt[1] != '\0') {
+ if (needsSep) {
+ *ptr++ = separator;
+ }
+ }
+ } else {
+ *ptr++ = *strElt;
+ needsSep = 1;
+ }
+ }
+ length = ptr - Tcl_GetString(res);
+ Tcl_SetObjLength(res, length);
+ }
+ }
+ return res;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * 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(interp, objPtr)
+ Tcl_Interp *interp; /* Interpreter in which to store error
+ * message (if necessary). */
+ Tcl_Obj *objPtr; /* Object to convert to a valid, current
+ * path type. */
+{
+ /*
+ * While it is bad practice to examine an object's type directly,
+ * this is actually the best thing to do here. The reason is that
+ * if we are converting this object to FsPath type for the first
+ * time, we don't need to worry whether the 'cwd' has changed.
+ * On the other hand, if this object is already of FsPath type,
+ * and is a relative path, we do have to worry about the cwd.
+ * If the cwd has changed, we must recompute the path.
+ */
+ if (objPtr->typePtr == &tclFsPathType) {
+ FsPath *fsPathPtr = (FsPath*) PATHOBJ(objPtr);
+ if (fsPathPtr->filesystemEpoch != theFilesystemEpoch) {
+ if (objPtr->bytes == NULL) {
+ UpdateStringOfFsPath(objPtr);
+ }
+ FreeFsPathInternalRep(objPtr);
+ objPtr->typePtr = NULL;
+ return Tcl_ConvertToType(interp, objPtr, &tclFsPathType);
+ }
+ return TCL_OK;
+ /*
+ * This code is intentionally never reached. Once fs-optimisation
+ * is complete, it will be removed/replaced
+ */
+ if (fsPathPtr->cwdPtr == NULL) {
+ return TCL_OK;
+ } else {
+ if (TclFSCwdPointerEquals(fsPathPtr->cwdPtr)) {
+ return TCL_OK;
+ } else {
+ if (objPtr->bytes == NULL) {
+ UpdateStringOfFsPath(objPtr);
+ }
+ FreeFsPathInternalRep(objPtr);
+ objPtr->typePtr = NULL;
+ return Tcl_ConvertToType(interp, objPtr, &tclFsPathType);
+ }
+ }
+ } else {
+ return Tcl_ConvertToType(interp, objPtr, &tclFsPathType);
+ }
+}
+
+/*
+ * Helper function for SetFsPathFromAny. Returns position of first
+ * directory delimiter in the path.
+ */
+static int
+FindSplitPos(path, separator)
+ char *path;
+ char *separator;
+{
+ int count = 0;
+ switch (tclPlatform) {
+ case TCL_PLATFORM_UNIX:
+ case TCL_PLATFORM_MAC:
+ while (path[count] != 0) {
+ if (path[count] == *separator) {
+ return count;
+ }
+ count++;
+ }
+ break;
+
+ 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 caching of normalized paths.
+ *
+ * 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 *objPtr;
+
+ objPtr = Tcl_NewObj();
+ fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
+
+ if (tclPlatform == TCL_PLATFORM_MAC) {
+ /*
+ * Mac relative paths may begin with a directory separator ':'.
+ * If present, we need to skip this ':' because we assume that
+ * we can join dirPtr and addStrRep by concatenating them as
+ * strings (and we ensure that dirPtr is terminated by a ':').
+ */
+ if (addStrRep[0] == ':') {
+ addStrRep++;
+ len--;
+ }
+ }
+ /* Setup the path */
+ fsPathPtr->translatedPathPtr = NULL;
+ fsPathPtr->normPathPtr = Tcl_NewStringObj(addStrRep, len);
+ Tcl_IncrRefCount(fsPathPtr->normPathPtr);
+ fsPathPtr->cwdPtr = dirPtr;
+ Tcl_IncrRefCount(dirPtr);
+ fsPathPtr->nativePathPtr = NULL;
+ fsPathPtr->fsRecPtr = NULL;
+ fsPathPtr->filesystemEpoch = theFilesystemEpoch;
+
+ PATHOBJ(objPtr) = (VOID *) fsPathPtr;
+ PATHFLAGS(objPtr) = TCLPATH_RELATIVE | TCLPATH_APPENDED;
+ objPtr->typePtr = &tclFsPathType;
+ objPtr->bytes = NULL;
+ objPtr->length = 0;
+ return objPtr;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclFSMakePathRelative --
+ *
+ * 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.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+TclFSMakePathRelative(interp, objPtr, cwdPtr)
+ Tcl_Interp *interp; /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr; /* The object we have. */
+ Tcl_Obj *cwdPtr; /* Make it relative to this. */
+{
+ int cwdLen, len;
+ CONST char *tempStr;
+
+ if (objPtr->typePtr == &tclFsPathType) {
+ FsPath* fsPathPtr = (FsPath*) PATHOBJ(objPtr);
+ if (PATHFLAGS(objPtr) != 0
+ && fsPathPtr->cwdPtr == cwdPtr) {
+ objPtr = fsPathPtr->normPathPtr;
+ /* Free old representation */
+ if (objPtr->typePtr != NULL) {
+ if (objPtr->bytes == NULL) {
+ if (objPtr->typePtr->updateStringProc == NULL) {
+ if (interp != NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "can't find object",
+ "string representation", (char *) NULL);
+ }
+ return NULL;
+ }
+ objPtr->typePtr->updateStringProc(objPtr);
+ }
+ if ((objPtr->typePtr->freeIntRepProc) != NULL) {
+ (*objPtr->typePtr->freeIntRepProc)(objPtr);
+ }
+ }
+
+ fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
+
+ /* Circular reference, by design */
+ fsPathPtr->translatedPathPtr = objPtr;
+ fsPathPtr->normPathPtr = NULL;
+ fsPathPtr->cwdPtr = cwdPtr;
+ Tcl_IncrRefCount(cwdPtr);
+ fsPathPtr->nativePathPtr = NULL;
+ fsPathPtr->fsRecPtr = NULL;
+ fsPathPtr->filesystemEpoch = theFilesystemEpoch;
+
+ PATHOBJ(objPtr) = (VOID *) fsPathPtr;
+ PATHFLAGS(objPtr) = 0;
+ objPtr->typePtr = &tclFsPathType;
+
+ return objPtr;
+ }
+ }
+ /*
+ * We know the cwd is a normalised object which does
+ * not end in a directory delimiter, unless the cwd
+ * is the name of a volume, in which case it will
+ * end in a delimiter! We handle this situation here.
+ * A better test than the '!= sep' might be to simply
+ * check if 'cwd' is a root volume.
+ *
+ * Note that if we get this wrong, we will strip off
+ * either too much or too little below, leading to
+ * wrong answers returned by glob.
+ */
+ tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
+ /*
+ * Should we perhaps use 'Tcl_FSPathSeparator'?
+ * But then what about the Windows special case?
+ * Perhaps we should just check if cwd is a root
+ * volume.
+ */
+ switch (tclPlatform) {
+ case TCL_PLATFORM_UNIX:
+ if (tempStr[cwdLen-1] != '/') {
+ cwdLen++;
+ }
+ break;
+ case TCL_PLATFORM_WINDOWS:
+ if (tempStr[cwdLen-1] != '/'
+ && tempStr[cwdLen-1] != '\\') {
+ cwdLen++;
+ }
+ break;
+ case TCL_PLATFORM_MAC:
+ if (tempStr[cwdLen-1] != ':') {
+ cwdLen++;
+ }
+ break;
+ }
+ tempStr = Tcl_GetStringFromObj(objPtr, &len);
+ return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclFSMakePathFromNormalized --
+ *
+ * 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.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclFSMakePathFromNormalized(interp, objPtr, nativeRep)
+ Tcl_Interp *interp; /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr; /* The object to convert. */
+ ClientData nativeRep; /* The native rep for the object, if known
+ * else NULL. */
+{
+ FsPath *fsPathPtr;
+
+ if (objPtr->typePtr == &tclFsPathType) {
+ return TCL_OK;
+ }
+
+ /* Free old representation */
+ if (objPtr->typePtr != NULL) {
+ if (objPtr->bytes == NULL) {
+ if (objPtr->typePtr->updateStringProc == NULL) {
+ if (interp != NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "can't find object",
+ "string representation", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ objPtr->typePtr->updateStringProc(objPtr);
+ }
+ if ((objPtr->typePtr->freeIntRepProc) != NULL) {
+ (*objPtr->typePtr->freeIntRepProc)(objPtr);
+ }
+ }
+
+ fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
+ /* It's a pure normalized absolute path */
+ fsPathPtr->translatedPathPtr = NULL;
+ fsPathPtr->normPathPtr = objPtr;
+ fsPathPtr->cwdPtr = NULL;
+ fsPathPtr->nativePathPtr = nativeRep;
+ fsPathPtr->fsRecPtr = NULL;
+ fsPathPtr->filesystemEpoch = theFilesystemEpoch;
+
+ PATHOBJ(objPtr) = (VOID *) fsPathPtr;
+ PATHFLAGS(objPtr) = 0;
+ objPtr->typePtr = &tclFsPathType;
+
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_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.
+ *
+ * Results:
+ * NULL or a valid path object pointer, with refCount zero.
+ *
+ * Side effects:
+ * New memory may be allocated.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_FSNewNativePath(fromFilesystem, clientData)
+ Tcl_Filesystem* fromFilesystem;
+ ClientData clientData;
+{
+ Tcl_Obj *objPtr;
+ FsPath *fsPathPtr;
+
+ FilesystemRecord *fsFromPtr;
+ int epoch;
+
+ objPtr = TclFSInternalToNormalized(fromFilesystem, clientData,
+ &fsFromPtr, &epoch);
+
+ if (objPtr == NULL) {
+ return NULL;
+ }
+
+ /*
+ * Free old representation; shouldn't normally be any,
+ * but best to be safe.
+ */
+ if (objPtr->typePtr != NULL) {
+ if (objPtr->bytes == NULL) {
+ if (objPtr->typePtr->updateStringProc == NULL) {
+ return NULL;
+ }
+ objPtr->typePtr->updateStringProc(objPtr);
+ }
+ if ((objPtr->typePtr->freeIntRepProc) != NULL) {
+ (*objPtr->typePtr->freeIntRepProc)(objPtr);
+ }
+ }
+
+ fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
+ fsPathPtr->translatedPathPtr = NULL;
+ /* Circular reference, by design */
+ fsPathPtr->normPathPtr = objPtr;
+ fsPathPtr->cwdPtr = NULL;
+ fsPathPtr->nativePathPtr = clientData;
+ fsPathPtr->fsRecPtr = fsFromPtr;
+ /* We must increase the refCount for this filesystem. */
+ fsPathPtr->fsRecPtr->fileRefCount++;
+ fsPathPtr->filesystemEpoch = epoch;
+
+ PATHOBJ(objPtr) = (VOID *) fsPathPtr;
+ PATHFLAGS(objPtr) = 0;
+ objPtr->typePtr = &tclFsPathType;
+ return objPtr;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_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(interp, pathPtr)
+ Tcl_Interp *interp;
+ Tcl_Obj* pathPtr;
+{
+ register FsPath* srcFsPathPtr;
+ if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
+ return NULL;
+ }
+ srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr);
+ if (srcFsPathPtr->translatedPathPtr == NULL) {
+ if (PATHFLAGS(pathPtr) != 0) {
+ return Tcl_FSGetNormalizedPath(interp, pathPtr);
+ }
+ /*
+ * It is a pure absolute, normalized path object.
+ * This is something like being a 'pure list'. The
+ * object's string, translatedPath and normalizedPath
+ * are all identical.
+ */
+ return srcFsPathPtr->normPathPtr;
+ } else {
+ /* It is an ordinary path object */
+ return srcFsPathPtr->translatedPathPtr;
+ }
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * 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(interp, pathPtr)
+ Tcl_Interp *interp;
+ Tcl_Obj* pathPtr;
+{
+ Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
+ if (transPtr == NULL) {
+ return NULL;
+ } else {
+ return Tcl_GetString(transPtr);
+ }
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSGetNormalizedPath --
+ *
+ * This important function attempts to extract from the given Tcl_Obj
+ * 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(interp, pathObjPtr)
+ Tcl_Interp *interp;
+ Tcl_Obj* pathObjPtr;
+{
+ register FsPath* fsPathPtr;
+ if (Tcl_FSConvertToPathType(interp, pathObjPtr) != TCL_OK) {
+ return NULL;
+ }
+ fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
+
+ if (PATHFLAGS(pathObjPtr) != 0) {
+ /*
+ * This is a special path object which is the result of
+ * something like 'file join'
+ */
+ Tcl_Obj *dir, *copy;
+ int cwdLen;
+ int pathType;
+ CONST char *cwdStr;
+ ClientData clientData = NULL;
+
+ pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr);
+ dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr);
+ if (dir == NULL) {
+ return NULL;
+ }
+ if (pathObjPtr->bytes == NULL) {
+ UpdateStringOfFsPath(pathObjPtr);
+ }
+ copy = Tcl_DuplicateObj(dir);
+ Tcl_IncrRefCount(copy);
+ Tcl_IncrRefCount(dir);
+ /* We now own a reference on both 'dir' and 'copy' */
+
+ cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);
+ /*
+ * Should we perhaps use 'Tcl_FSPathSeparator'?
+ * But then what about the Windows special case?
+ * Perhaps we should just check if cwd is a root volume.
+ * We should never get cwdLen == 0 in this code path.
+ */
+ switch (tclPlatform) {
+ case TCL_PLATFORM_UNIX:
+ if (cwdStr[cwdLen-1] != '/') {
+ Tcl_AppendToObj(copy, "/", 1);
+ cwdLen++;
+ }
+ break;
+ case TCL_PLATFORM_WINDOWS:
+ if (cwdStr[cwdLen-1] != '/'
+ && cwdStr[cwdLen-1] != '\\') {
+ Tcl_AppendToObj(copy, "/", 1);
+ cwdLen++;
+ }
+ break;
+ case TCL_PLATFORM_MAC:
+ if (cwdStr[cwdLen-1] != ':') {
+ Tcl_AppendToObj(copy, ":", 1);
+ cwdLen++;
+ }
+ break;
+ }
+ Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr);
+ /*
+ * Normalize the combined string, but only starting after
+ * the end of the previously normalized 'dir'. This should
+ * be much faster! We use 'cwdLen-1' so that we are
+ * already pointing at the dir-separator that we know about.
+ * The normalization code will actually start off directly
+ * after that separator.
+ */
+ TclFSNormalizeToUniquePath(interp, copy, cwdLen-1,
+ (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));
+ /* Now we need to construct the new path object */
+
+ if (pathType == TCL_PATH_RELATIVE) {
+ register FsPath* origDirFsPathPtr;
+ Tcl_Obj *origDir = fsPathPtr->cwdPtr;
+ origDirFsPathPtr = (FsPath*) PATHOBJ(origDir);
+
+ fsPathPtr->cwdPtr = origDirFsPathPtr->cwdPtr;
+ Tcl_IncrRefCount(fsPathPtr->cwdPtr);
+
+ Tcl_DecrRefCount(fsPathPtr->normPathPtr);
+ fsPathPtr->normPathPtr = copy;
+ /* That's our reference to copy used */
+ Tcl_DecrRefCount(dir);
+ Tcl_DecrRefCount(origDir);
+ } else {
+ Tcl_DecrRefCount(fsPathPtr->cwdPtr);
+ fsPathPtr->cwdPtr = NULL;
+ Tcl_DecrRefCount(fsPathPtr->normPathPtr);
+ fsPathPtr->normPathPtr = copy;
+ /* That's our reference to copy used */
+ Tcl_DecrRefCount(dir);
+ }
+ if (clientData != NULL) {
+ fsPathPtr->nativePathPtr = clientData;
+ }
+ PATHFLAGS(pathObjPtr) = 0;
+ }
+ /* Ensure cwd hasn't changed */
+ if (fsPathPtr->cwdPtr != NULL) {
+ if (!TclFSCwdPointerEquals(fsPathPtr->cwdPtr)) {
+ if (pathObjPtr->bytes == NULL) {
+ UpdateStringOfFsPath(pathObjPtr);
+ }
+ FreeFsPathInternalRep(pathObjPtr);
+ pathObjPtr->typePtr = NULL;
+ if (Tcl_ConvertToType(interp, pathObjPtr,
+ &tclFsPathType) != TCL_OK) {
+ return NULL;
+ }
+ fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
+ } else if (fsPathPtr->normPathPtr == NULL) {
+ int cwdLen;
+ Tcl_Obj *copy;
+ CONST char *cwdStr;
+ ClientData clientData = NULL;
+
+ copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr);
+ Tcl_IncrRefCount(copy);
+ cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);
+ /*
+ * Should we perhaps use 'Tcl_FSPathSeparator'?
+ * But then what about the Windows special case?
+ * Perhaps we should just check if cwd is a root volume.
+ * We should never get cwdLen == 0 in this code path.
+ */
+ switch (tclPlatform) {
+ case TCL_PLATFORM_UNIX:
+ if (cwdStr[cwdLen-1] != '/') {
+ Tcl_AppendToObj(copy, "/", 1);
+ cwdLen++;
+ }
+ break;
+ case TCL_PLATFORM_WINDOWS:
+ if (cwdStr[cwdLen-1] != '/'
+ && cwdStr[cwdLen-1] != '\\') {
+ Tcl_AppendToObj(copy, "/", 1);
+ cwdLen++;
+ }
+ break;
+ case TCL_PLATFORM_MAC:
+ if (cwdStr[cwdLen-1] != ':') {
+ Tcl_AppendToObj(copy, ":", 1);
+ cwdLen++;
+ }
+ break;
+ }
+ Tcl_AppendObjToObj(copy, pathObjPtr);
+ /*
+ * Normalize the combined string, but only starting after
+ * the end of the previously normalized 'dir'. This should
+ * be much faster!
+ */
+ TclFSNormalizeToUniquePath(interp, copy, cwdLen-1,
+ (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));
+ fsPathPtr->normPathPtr = copy;
+ if (clientData != NULL) {
+ fsPathPtr->nativePathPtr = clientData;
+ }
+ }
+ }
+ if (fsPathPtr->normPathPtr == NULL) {
+ ClientData clientData = NULL;
+ Tcl_Obj *useThisCwd = NULL;
+ /*
+ * Since normPathPtr is NULL, but this is a valid path
+ * object, we know that the translatedPathPtr cannot be NULL.
+ */
+ Tcl_Obj *absolutePath = fsPathPtr->translatedPathPtr;
+ char *path = Tcl_GetString(absolutePath);
+
+ /*
+ * We have to be a little bit careful here to avoid infinite loops
+ * we're asking Tcl_FSGetPathType to return the path's type, but
+ * that call can actually result in a lot of other filesystem
+ * action, which might loop back through here.
+ */
+ if ((path[0] != '\0') &&
+ (Tcl_FSGetPathType(pathObjPtr) == TCL_PATH_RELATIVE)) {
+ useThisCwd = Tcl_FSGetCwd(interp);
+
+ if (useThisCwd == NULL) {
+ return NULL;
+ }
+
+ absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath);
+ Tcl_IncrRefCount(absolutePath);
+ /* We have a refCount on the cwd */
+ }
+ /* Already has refCount incremented */
+ fsPathPtr->normPathPtr = FSNormalizeAbsolutePath(interp, absolutePath,
+ (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));
+ if (0 && (clientData != NULL)) {
+ fsPathPtr->nativePathPtr =
+ (*fsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc)(clientData);
+ }
+ if (!strcmp(Tcl_GetString(fsPathPtr->normPathPtr),
+ Tcl_GetString(pathObjPtr))) {
+ /*
+ * The path was already normalized.
+ * Get rid of the duplicate.
+ */
+ Tcl_DecrRefCount(fsPathPtr->normPathPtr);
+ /*
+ * We do *not* increment the refCount for
+ * this circular reference
+ */
+ fsPathPtr->normPathPtr = pathObjPtr;
+ }
+ if (useThisCwd != NULL) {
+ /* This was returned by Tcl_FSJoinToPath above */
+ Tcl_DecrRefCount(absolutePath);
+ fsPathPtr->cwdPtr = useThisCwd;
+ }
+ }
+ 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(pathObjPtr, fsPtr)
+ Tcl_Obj* pathObjPtr;
+ Tcl_Filesystem *fsPtr;
+{
+ register FsPath* srcFsPathPtr;
+
+ if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) {
+ return NULL;
+ }
+ srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
+
+ /*
+ * We will only return the native representation for the caller's
+ * filesystem. Otherwise we will simply return NULL. This means
+ * that there must be a unique bi-directional mapping between paths
+ * and filesystems, and that this mapping will not allow 'remapped'
+ * files -- files which are in one filesystem but mapped into
+ * another. Another way of putting this is that 'stacked'
+ * filesystems are not allowed. We recognise that this is a
+ * potentially useful feature for the future.
+ *
+ * Even something simple like a 'pass through' filesystem which
+ * logs all activity and passes the calls onto the native system
+ * would be nice, but not easily achievable with the current
+ * implementation.
+ */
+ if (srcFsPathPtr->fsRecPtr == NULL) {
+ /*
+ * This only usually happens in wrappers like TclpStat which
+ * create a string object and pass it to TclpObjStat. Code
+ * which calls the Tcl_FS.. functions should always have a
+ * filesystem already set. Whether this code path is legal or
+ * not depends on whether we decide to allow external code to
+ * call the native filesystem directly. It is at least safer
+ * to allow this sub-optimal routing.
+ */
+ Tcl_FSGetFileSystemForPath(pathObjPtr);
+
+ /*
+ * If we fail through here, then the path is probably not a
+ * valid path in the filesystsem, and is most likely to be a
+ * use of the empty path "" via a direct call to one of the
+ * objectified interfaces (e.g. from the Tcl testsuite).
+ */
+ srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
+ if (srcFsPathPtr->fsRecPtr == NULL) {
+ return NULL;
+ }
+ }
+
+ if (fsPtr != srcFsPathPtr->fsRecPtr->fsPtr) {
+ /*
+ * There is still one possibility we should consider; if the
+ * file belongs to a different filesystem, perhaps it is
+ * actually linked through to a file in our own filesystem
+ * which we do care about. The way we can check for this
+ * is we ask what filesystem this path belongs to.
+ */
+ Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathObjPtr);
+ if (actualFs == fsPtr) {
+ return Tcl_FSGetInternalRep(pathObjPtr, fsPtr);
+ }
+ return NULL;
+ }
+
+ if (srcFsPathPtr->nativePathPtr == NULL) {
+ Tcl_FSCreateInternalRepProc *proc;
+ proc = srcFsPathPtr->fsRecPtr->fsPtr->createInternalRepProc;
+
+ if (proc == NULL) {
+ return NULL;
+ }
+ srcFsPathPtr->nativePathPtr = (*proc)(pathObjPtr);
+ }
+ return srcFsPathPtr->nativePathPtr;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclFSEnsureEpochOk --
+ *
+ * This will ensure the pathObjPtr is up to date and can be
+ * converted into a "path" type, and that we are able to generate a
+ * complete normalized path which is used to determine the
+ * filesystem match.
+ *
+ * Results:
+ * Standard Tcl return code.
+ *
+ * Side effects:
+ * An attempt may be made to convert the object.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclFSEnsureEpochOk(pathObjPtr, theEpoch, fsPtrPtr)
+ Tcl_Obj* pathObjPtr;
+ int theEpoch;
+ Tcl_Filesystem **fsPtrPtr;
+{
+ FsPath* srcFsPathPtr;
+
+ /*
+ * SHOULD BE ABLE TO IMPROVE EFFICIENCY HERE.
+ */
+
+ if (Tcl_FSGetNormalizedPath(NULL, pathObjPtr) == NULL) {
+ return TCL_ERROR;
+ }
+
+ srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
+
+ /*
+ * Check if the filesystem has changed in some way since
+ * this object's internal representation was calculated.
+ */
+ if (srcFsPathPtr->filesystemEpoch != theEpoch) {
+ /*
+ * We have to discard the stale representation and
+ * recalculate it
+ */
+ if (pathObjPtr->bytes == NULL) {
+ UpdateStringOfFsPath(pathObjPtr);
+ }
+ FreeFsPathInternalRep(pathObjPtr);
+ pathObjPtr->typePtr = NULL;
+ if (SetFsPathFromAny(NULL, pathObjPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
+ }
+ /* Check whether the object is already assigned to a fs */
+ if (srcFsPathPtr->fsRecPtr != NULL) {
+ *fsPtrPtr = srcFsPathPtr->fsRecPtr->fsPtr;
+ }
+ return TCL_OK;
+}
+
+void
+TclFSSetPathDetails(pathObjPtr, fsRecPtr, clientData, theEpoch)
+ Tcl_Obj *pathObjPtr;
+ FilesystemRecord *fsRecPtr;
+ ClientData clientData;
+ int theEpoch;
+{
+ /* We assume pathObjPtr is already of the correct type */
+ FsPath* srcFsPathPtr;
+
+ srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
+ srcFsPathPtr->fsRecPtr = fsRecPtr;
+ srcFsPathPtr->nativePathPtr = clientData;
+ srcFsPathPtr->filesystemEpoch = theEpoch;
+ fsRecPtr->fileRefCount++;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * 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(firstPtr, secondPtr)
+ Tcl_Obj* firstPtr;
+ Tcl_Obj* secondPtr;
+{
+ 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
+ */
+
+ 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;
+ }
+ }
+ return 0;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * 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(interp, objPtr)
+ Tcl_Interp *interp; /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr; /* The object to convert. */
+{
+ int len;
+ FsPath *fsPathPtr;
+ Tcl_Obj *transPtr;
+ char *name;
+
+ if (objPtr->typePtr == &tclFsPathType) {
+ return TCL_OK;
+ }
+
+ /*
+ * First step is to translate the filename. This is similar to
+ * Tcl_TranslateFilename, but shouldn't convert everything to
+ * windows backslashes on that platform. The current
+ * implementation of this piece is a slightly optimised version
+ * of the various Tilde/Split/Join stuff to avoid multiple
+ * split/join operations.
+ *
+ * We remove any trailing directory separator.
+ *
+ * However, the split/join routines are quite complex, and
+ * one has to make sure not to break anything on Unix, Win
+ * or MacOS (fCmd.test, fileName.test and cmdAH.test exercise
+ * most of the code).
+ */
+ name = Tcl_GetStringFromObj(objPtr,&len);
+
+ /*
+ * Handle tilde substitutions, if needed.
+ */
+ if (name[0] == '~') {
+ char *expandedUser;
+ Tcl_DString temp;
+ int split;
+ char separator='/';
+
+ if (tclPlatform==TCL_PLATFORM_MAC) {
+ if (strchr(name, ':') != NULL) separator = ':';
+ }
+
+ split = FindSplitPos(name, &separator);
+ if (split != len) {
+ /* We have multiple pieces '~user/foo/bar...' */
+ name[split] = '\0';
+ }
+ /* Do some tilde substitution */
+ if (name[1] == '\0') {
+ /* We have just '~' */
+ CONST char *dir;
+ Tcl_DString dirString;
+ if (split != len) { name[split] = separator; }
+
+ dir = TclGetEnv("HOME", &dirString);
+ if (dir == NULL) {
+ if (interp) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "couldn't find HOME environment ",
+ "variable to expand path", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ Tcl_DStringInit(&temp);
+ Tcl_JoinPath(1, &dir, &temp);
+ Tcl_DStringFree(&dirString);
+ } else {
+ /* We have a user name '~user' */
+ Tcl_DStringInit(&temp);
+ if (TclpGetUserHome(name+1, &temp) == NULL) {
+ if (interp != NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "user \"", (name+1),
+ "\" doesn't exist", (char *) NULL);
+ }
+ Tcl_DStringFree(&temp);
+ if (split != len) { name[split] = separator; }
+ return TCL_ERROR;
+ }
+ if (split != len) { name[split] = separator; }
+ }
+
+ expandedUser = Tcl_DStringValue(&temp);
+ transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp));
+
+ if (split != len) {
+ /* Join up the tilde substitution with the rest */
+ if (name[split+1] == separator) {
+
+ /*
+ * Somewhat tricky case like ~//foo/bar.
+ * Make use of Split/Join machinery to get it right.
+ * Assumes all paths beginning with ~ are part of the
+ * native filesystem.
+ */
+
+ int objc;
+ Tcl_Obj **objv;
+ Tcl_Obj *parts = TclpNativeSplitPath(objPtr, NULL);
+ Tcl_ListObjGetElements(NULL, parts, &objc, &objv);
+ /* Skip '~'. It's replaced by its expansion */
+ objc--; objv++;
+ while (objc--) {
+ TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++));
+ }
+ Tcl_DecrRefCount(parts);
+ } else {
+ /* Simple case. "rest" is relative path. Just join it. */
+ Tcl_Obj *rest = Tcl_NewStringObj(name+split+1,-1);
+ transPtr = Tcl_FSJoinToPath(transPtr, 1, &rest);
+ }
+ }
+ Tcl_DStringFree(&temp);
+ } else {
+ transPtr = Tcl_FSJoinToPath(objPtr,0,NULL);
+ }
+
+ /*
+ * Now we have a translated filename in 'transPtr'. This will have
+ * forward slashes on Windows, and will not contain any ~user
+ * sequences.
+ */
+
+ fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
+ fsPathPtr->translatedPathPtr = transPtr;
+ Tcl_IncrRefCount(fsPathPtr->translatedPathPtr);
+ fsPathPtr->normPathPtr = NULL;
+ fsPathPtr->cwdPtr = NULL;
+ fsPathPtr->nativePathPtr = NULL;
+ fsPathPtr->fsRecPtr = NULL;
+ fsPathPtr->filesystemEpoch = theFilesystemEpoch;
+
+ /*
+ * Free old representation before installing our new one.
+ */
+ if (objPtr->typePtr != NULL && objPtr->typePtr->freeIntRepProc != NULL) {
+ (objPtr->typePtr->freeIntRepProc)(objPtr);
+ }
+ PATHOBJ(objPtr) = (VOID *) fsPathPtr;
+ PATHFLAGS(objPtr) = 0;
+ objPtr->typePtr = &tclFsPathType;
+
+ return TCL_OK;
+}
+
+static void
+FreeFsPathInternalRep(pathObjPtr)
+ Tcl_Obj *pathObjPtr; /* Path object with internal rep to free. */
+{
+ register FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
+
+ if (fsPathPtr->translatedPathPtr != NULL) {
+ if (fsPathPtr->translatedPathPtr != pathObjPtr) {
+ Tcl_DecrRefCount(fsPathPtr->translatedPathPtr);
+ }
+ }
+ if (fsPathPtr->normPathPtr != NULL) {
+ if (fsPathPtr->normPathPtr != pathObjPtr) {
+ Tcl_DecrRefCount(fsPathPtr->normPathPtr);
+ }
+ fsPathPtr->normPathPtr = NULL;
+ }
+ if (fsPathPtr->cwdPtr != NULL) {
+ Tcl_DecrRefCount(fsPathPtr->cwdPtr);
+ }
+ if (fsPathPtr->nativePathPtr != NULL) {
+ if (fsPathPtr->fsRecPtr != NULL) {
+ if (fsPathPtr->fsRecPtr->fsPtr->freeInternalRepProc != NULL) {
+ (*fsPathPtr->fsRecPtr->fsPtr
+ ->freeInternalRepProc)(fsPathPtr->nativePathPtr);
+ fsPathPtr->nativePathPtr = NULL;
+ }
+ }
+ }
+ if (fsPathPtr->fsRecPtr != NULL) {
+ fsPathPtr->fsRecPtr->fileRefCount--;
+ if (fsPathPtr->fsRecPtr->fileRefCount <= 0) {
+ /* It has been unregistered already */
+ ckfree((char *)fsPathPtr->fsRecPtr);
+ }
+ }
+
+ ckfree((char*) fsPathPtr);
+}
+
+
+static void
+DupFsPathInternalRep(srcPtr, copyPtr)
+ Tcl_Obj *srcPtr; /* Path obj with internal rep to copy. */
+ Tcl_Obj *copyPtr; /* Path obj with internal rep to set. */
+{
+ register FsPath* srcFsPathPtr = (FsPath*) PATHOBJ(srcPtr);
+ register FsPath* copyFsPathPtr =
+ (FsPath*) ckalloc((unsigned)sizeof(FsPath));
+ Tcl_FSDupInternalRepProc *dupProc;
+
+ PATHOBJ(copyPtr) = (VOID *) copyFsPathPtr;
+
+ if (srcFsPathPtr->translatedPathPtr != NULL) {
+ copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr;
+ if (copyFsPathPtr->translatedPathPtr != copyPtr) {
+ Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr);
+ }
+ } else {
+ copyFsPathPtr->translatedPathPtr = NULL;
+ }
+
+ if (srcFsPathPtr->normPathPtr != NULL) {
+ copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr;
+ if (copyFsPathPtr->normPathPtr != copyPtr) {
+ Tcl_IncrRefCount(copyFsPathPtr->normPathPtr);
+ }
+ } else {
+ copyFsPathPtr->normPathPtr = NULL;
+ }
+
+ if (srcFsPathPtr->cwdPtr != NULL) {
+ copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr;
+ Tcl_IncrRefCount(copyFsPathPtr->cwdPtr);
+ } else {
+ copyFsPathPtr->cwdPtr = NULL;
+ }
+
+ copyFsPathPtr->flags = srcFsPathPtr->flags;
+
+ if (srcFsPathPtr->fsRecPtr != NULL
+ && srcFsPathPtr->nativePathPtr != NULL) {
+ dupProc = srcFsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc;
+ if (dupProc != NULL) {
+ copyFsPathPtr->nativePathPtr =
+ (*dupProc)(srcFsPathPtr->nativePathPtr);
+ } else {
+ copyFsPathPtr->nativePathPtr = NULL;
+ }
+ } else {
+ copyFsPathPtr->nativePathPtr = NULL;
+ }
+ copyFsPathPtr->fsRecPtr = srcFsPathPtr->fsRecPtr;
+ copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch;
+ if (copyFsPathPtr->fsRecPtr != NULL) {
+ copyFsPathPtr->fsRecPtr->fileRefCount++;
+ }
+
+ copyPtr->typePtr = &tclFsPathType;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * UpdateStringOfFsPath --
+ *
+ * Gives an object a valid string rep.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory may be allocated.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static void
+UpdateStringOfFsPath(objPtr)
+ register Tcl_Obj *objPtr; /* path obj with string rep to update. */
+{
+ register FsPath* fsPathPtr = (FsPath*) PATHOBJ(objPtr);
+ CONST char *cwdStr;
+ int cwdLen;
+ Tcl_Obj *copy;
+
+ if (PATHFLAGS(objPtr) == 0 || fsPathPtr->cwdPtr == NULL) {
+ panic("Called UpdateStringOfFsPath with invalid object");
+ }
+
+ copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr);
+ Tcl_IncrRefCount(copy);
+
+ cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);
+ /*
+ * Should we perhaps use 'Tcl_FSPathSeparator'?
+ * But then what about the Windows special case?
+ * Perhaps we should just check if cwd is a root volume.
+ * We should never get cwdLen == 0 in this code path.
+ */
+ switch (tclPlatform) {
+ case TCL_PLATFORM_UNIX:
+ if (cwdStr[cwdLen-1] != '/') {
+ Tcl_AppendToObj(copy, "/", 1);
+ cwdLen++;
+ }
+ break;
+ case TCL_PLATFORM_WINDOWS:
+ /*
+ * We need the extra 'cwdLen != 2', and ':' checks because
+ * a volume relative path doesn't get a '/'. For example
+ * 'glob C:*cat*.exe' will return 'C:cat32.exe'
+ */
+ if (cwdStr[cwdLen-1] != '/'
+ && cwdStr[cwdLen-1] != '\\') {
+ if (cwdLen != 2 || cwdStr[1] != ':') {
+ Tcl_AppendToObj(copy, "/", 1);
+ cwdLen++;
+ }
+ }
+ break;
+ case TCL_PLATFORM_MAC:
+ if (cwdStr[cwdLen-1] != ':') {
+ Tcl_AppendToObj(copy, ":", 1);
+ cwdLen++;
+ }
+ break;
+ }
+ Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr);
+ objPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen);
+ objPtr->length = cwdLen;
+ copy->bytes = tclEmptyStringRep;
+ copy->length = 0;
+ Tcl_DecrRefCount(copy);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * NativePathInFilesystem --
+ *
+ * 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
+NativePathInFilesystem(pathPtr, clientDataPtr)
+ 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;
+ Tcl_GetStringFromObj(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;
+}