Logo Search packages:      
Sourcecode: tcl8.5 version File versions  Download package

tclPathObj.c

/*
 * 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.66 2007/12/13 15:23:20 dgp Exp $
 */

#include "tclInt.h"
#include "tclFileSystem.h"

/*
 * Prototypes for functions defined later in this file.
 */

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);

/*
 * Define the 'path' object type, which Tcl uses to represent file paths
 * internally.
 */

static 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. */
    struct FilesystemRecord *fsRecPtr;
                        /* Pointer to the filesystem record entry to
                         * use for this path. */
} FsPath;

/*
 * Flag values for FsPath->flags.
 */

#define TCLPATH_APPENDED 1

/*
 * Define some macros to give us convenient access to path-object specific
 * fields.
 */

#define PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.otherValuePtr)
#define SETPATHOBJ(pathPtr,fsPathPtr) \
      ((pathPtr)->internalRep.otherValuePtr = (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 */
    ClientData *clientDataPtr)      /* If non-NULL, then may be set to the
                         * fs-specific clientData for this path. This
                         * will happen when that extra information can
                         * be calculated efficiently as a side-effect
                         * of normalization. */
{
    ClientData clientData = NULL;
    const char *dirSep, *oldDirSep;
    int first = 1;            /* Set to zero once we've passed the first
                         * directory separator - we can't use '..' to
                         * remove the volume in a path. */
    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);
            }
            Tcl_GetStringFromObj(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 *link;
            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);
            }
            Tcl_GetStringFromObj(retVal, &curLen);
            if (curLen == 0) {
                Tcl_AppendToObj(retVal, dirSep, 1);
            }
            if (!first || (tclPlatform == TCL_PLATFORM_UNIX)) {
                link = Tcl_FSLink(retVal, NULL, 0);
                if (link != NULL) {
                  /*
                   * Got a link. Need to check if the link is relative
                   * or absolute, for those platforms where relative
                   * links exist.
                   */

                  if (tclPlatform != TCL_PLATFORM_WINDOWS &&
                        Tcl_FSGetPathType(link) == TCL_PATH_RELATIVE) {
                      /*
                       * We need to follow this link which is relative
                       * to retVal's directory. This means concatenating
                       * the link onto the directory of the path so far.
                       */

                      const char *path =
                            Tcl_GetStringFromObj(retVal, &curLen);

                      while (--curLen >= 0) {
                        if (IsSeparatorOrNull(path[curLen])) {
                            break;
                        }
                      }
                      if (Tcl_IsShared(retVal)) {
                        TclDecrRefCount(retVal);
                        retVal = Tcl_DuplicateObj(retVal);
                        Tcl_IncrRefCount(retVal);
                      }

                      /*
                       * We want the trailing slash.
                       */

                      Tcl_SetObjLength(retVal, curLen+1);
                      Tcl_AppendObjToObj(retVal, link);
                      TclDecrRefCount(link);
                      linkStr = Tcl_GetStringFromObj(retVal, &curLen);
                  } else {
                      /*
                       * Absolute link.
                       */

                      TclDecrRefCount(retVal);
                      retVal = link;
                      linkStr = Tcl_GetStringFromObj(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 = Tcl_GetStringFromObj(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 = Tcl_GetStringFromObj(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, &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;
    }

    /*
     * 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,
    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) {
      return TCL_PATH_RELATIVE;
    }
    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 (TclFSEpochOk(fsPathPtr->filesystemEpoch)
            && (PATHFLAGS(pathPtr) != 0)) {
          switch (portion) {
          case TCL_PATH_DIRNAME: {
            /*
             * Check if the joined-on bit has any directory delimiters in
             * it. If so, the 'dirname' would be a joining of the main
             * part with the dirname of the joined-on bit. We could handle
             * that special case here, but we don't, and instead just use
             * the standardPath code.
             */

            const char *rest = TclGetString(fsPathPtr->normPathPtr);

            if (strchr(rest, '/') != NULL) {
                goto standardPath;
            }
            if (tclPlatform == TCL_PLATFORM_WINDOWS
                  && strchr(rest, '\\') != NULL) {
                goto standardPath;
            }

            /*
             * The joined-on path is simple, so we can just return here.
             */

            Tcl_IncrRefCount(fsPathPtr->cwdPtr);
            return fsPathPtr->cwdPtr;
          }
          case TCL_PATH_TAIL: {
            /*
             * Check if the joined-on bit has any directory delimiters in
             * it. If so, the 'tail' would be only the part following the
             * last delimiter. We could handle that special case here, but
             * we don't, and instead just use the standardPath code.
             */

            const char *rest = TclGetString(fsPathPtr->normPathPtr);

            if (strchr(rest, '/') != NULL) {
                goto standardPath;
            }
            if (tclPlatform == TCL_PLATFORM_WINDOWS
                  && strchr(rest, '\\') != NULL) {
                goto standardPath;
            }
            Tcl_IncrRefCount(fsPathPtr->normPathPtr);
            return fsPathPtr->normPathPtr;
          }
          case TCL_PATH_EXTENSION:
            return GetExtension(fsPathPtr->normPathPtr);
          case TCL_PATH_ROOT: {
            const char *fileName, *extension;
            int length;

            fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr,
                  &length);
            extension = TclGetExtension(fileName);
            if (extension == NULL) {
                /*
                 * There is no extension so the root is the same as the
                 * path we were given.
                 */

                Tcl_IncrRefCount(pathPtr);
                return pathPtr;
            } else {
                /*
                 * Duplicate the object we were given and then trim off
                 * the extension of the tail component of the path.
                 */

                FsPath *fsDupPtr;
                Tcl_Obj *root = Tcl_DuplicateObj(pathPtr);

                Tcl_IncrRefCount(root);
                fsDupPtr = PATHOBJ(root);
                if (Tcl_IsShared(fsDupPtr->normPathPtr)) {
                  TclDecrRefCount(fsDupPtr->normPathPtr);
                  fsDupPtr->normPathPtr = Tcl_NewStringObj(fileName,
                        (int)(length - strlen(extension)));
                  Tcl_IncrRefCount(fsDupPtr->normPathPtr);
                } else {
                  Tcl_SetObjLength(fsDupPtr->normPathPtr,
                        (int)(length - strlen(extension)));
                }

                /*
                 * Must also trim the string representation if we have it.
                 */

                if (root->bytes != NULL && root->length > 0) {
                  root->length -= strlen(extension);
                  root->bytes[root->length] = 0;
                }
                return root;
            }
          }
          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 = Tcl_GetStringFromObj(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 *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;
      }
    }

    res = NULL;

    for (i = 0; i < elements; i++) {
      Tcl_Obj *elt, *driveName = NULL;
      int driveNameLength, strEltLen, length;
      Tcl_PathType type;
      char *strElt, *ptr;

      Tcl_ListObjIndex(NULL, listObj, i, &elt);

      /*
       * This is a special case where we can be much more efficient, where
       * we are joining a single relative path onto an object that is
       * already of path type. The 'TclNewFSPathObj' call below creates an
       * object which can be normalized more efficiently. Currently we only
       * use the special case when we have exactly two elements, but we
       * could expand that in the future.
       */

      if ((i == (elements-2)) && (i == 0) && (elt->typePtr == &tclFsPathType)
            && !(elt->bytes != NULL && (elt->bytes[0] == '\0'))) {
          Tcl_Obj *tail;
          Tcl_PathType type;

          Tcl_ListObjIndex(NULL, listObj, i+1, &tail);
          type = TclGetPathType(tail, NULL, NULL, NULL);
          if (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!
                 */

                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 tail;
          } else {
            const char *str = Tcl_GetString(tail);

            if (tclPlatform == TCL_PLATFORM_WINDOWS) {
                if (strchr(str, '\\') == NULL) {
                  if (res != NULL) {
                      TclDecrRefCount(res);
                  }
                  return tail;
                }
            }
          }
      }
      strElt = Tcl_GetStringFromObj(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 = Tcl_GetStringFromObj(res, &length);
      } else {
          ptr = Tcl_GetStringFromObj(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];
            }
          }

          if (length > 0 && ptr[length -1] != '/') {
            Tcl_AppendToObj(res, &separator, 1);
            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);
      pathPtr->typePtr = NULL;
    }

    return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType);

    /*
     * 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);
     *         pathPtr->typePtr = NULL;
     *         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;
    ThreadSpecificData *tsdPtr;

    tsdPtr = TCL_TSD_INIT(&tclFsDataKey);

    pathPtr = Tcl_NewObj();
    fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath));

    /*
     * Set up the path.
     */

    fsPathPtr->translatedPathPtr = NULL;
    fsPathPtr->normPathPtr = Tcl_NewStringObj(addStrRep, len);
    Tcl_IncrRefCount(fsPathPtr->normPathPtr);
    fsPathPtr->cwdPtr = dirPtr;
    Tcl_IncrRefCount(dirPtr);
    fsPathPtr->nativePathPtr = NULL;
    fsPathPtr->fsRecPtr = NULL;
    fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;

    SETPATHOBJ(pathPtr, fsPathPtr);
    PATHFLAGS(pathPtr) = TCLPATH_APPENDED;
    pathPtr->typePtr = &tclFsPathType;
    pathPtr->bytes = NULL;
    pathPtr->length = 0;

    return pathPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * 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.
 *
 *    In the case where the resulting path would start with a '~', we take
 *    special care to return an ordinary string. This means to use that path
 *    (and not have it interpreted as a user name), one must prepend './'.
 *    This may seem strange, but that is how 'glob' is currently defined.
 *
 * 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;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);

    if (pathPtr->typePtr == &tclFsPathType) {
      FsPath *fsPathPtr = PATHOBJ(pathPtr);

      if (PATHFLAGS(pathPtr) != 0
            && fsPathPtr->cwdPtr == cwdPtr) {
          pathPtr = fsPathPtr->normPathPtr;

          /*
           * Free old representation.
           */

          if (pathPtr->typePtr != NULL) {
            if (pathPtr->bytes == NULL) {
                if (pathPtr->typePtr->updateStringProc == NULL) {
                  if (interp != NULL) {
                      Tcl_ResetResult(interp);
                      Tcl_AppendResult(interp, "can't find object"
                            "string representation", NULL);
                  }
                  return NULL;
                }
                pathPtr->typePtr->updateStringProc(pathPtr);
            }
            TclFreeIntRep(pathPtr);
          }

          /*
           * Now pathPtr is a string object.
           */

          if (Tcl_GetString(pathPtr)[0] == '~') {
            /*
             * If the first character of the path is a tilde, we must just
             * return the path as is, to agree with the defined behaviour
             * of 'glob'.
             */

            return pathPtr;
          }

          fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath));

          /*
           * Circular reference, by design.
           */

          fsPathPtr->translatedPathPtr = pathPtr;
          fsPathPtr->normPathPtr = NULL;
          fsPathPtr->cwdPtr = cwdPtr;
          Tcl_IncrRefCount(cwdPtr);
          fsPathPtr->nativePathPtr = NULL;
          fsPathPtr->fsRecPtr = NULL;
          fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;

          SETPATHOBJ(pathPtr, fsPathPtr);
          PATHFLAGS(pathPtr) = 0;
          pathPtr->typePtr = &tclFsPathType;

          return pathPtr;
      }
    }

    /*
     * 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;
    }
    tempStr = Tcl_GetStringFromObj(pathPtr, &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(
    Tcl_Interp *interp,       /* Used for error reporting if not NULL. */
    Tcl_Obj *pathPtr,         /* The object to convert. */
    ClientData nativeRep)     /* The native rep for the object, if known
                         * else NULL. */
{
    FsPath *fsPathPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);

    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_ResetResult(interp);
                Tcl_AppendResult(interp, "can't find object"
                      "string representation", NULL);
            }
            return TCL_ERROR;
          }
          pathPtr->typePtr->updateStringProc(pathPtr);
      }
      TclFreeIntRep(pathPtr);
    }

    fsPathPtr = (FsPath *) 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 = nativeRep;
    fsPathPtr->fsRecPtr = NULL;
    fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;

    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(
    Tcl_Filesystem *fromFilesystem,
    ClientData clientData)
{
    Tcl_Obj *pathPtr;
    FsPath *fsPathPtr;

    FilesystemRecord *fsFromPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);

    pathPtr = TclFSInternalToNormalized(fromFilesystem, clientData,
          &fsFromPtr);
    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 = (FsPath *) ckalloc(sizeof(FsPath));

    fsPathPtr->translatedPathPtr = NULL;

    /*
     * Circular reference, by design.
     */

    fsPathPtr->normPathPtr = pathPtr;
    fsPathPtr->cwdPtr = NULL;
    fsPathPtr->nativePathPtr = clientData;
    fsPathPtr->fsRecPtr = fsFromPtr;
    fsPathPtr->fsRecPtr->fileRefCount++;
    fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;

    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) {
          retObj = Tcl_FSGetNormalizedPath(interp, pathPtr);
      } 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 = Tcl_GetStringFromObj(transPtr, &len);
      char *result = (char *) ckalloc((unsigned) 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 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 (pathPtr->bytes == NULL) {
          UpdateStringOfFsPath(pathPtr);
      }
      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;
      }
      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) {
          Tcl_Obj *origDir = fsPathPtr->cwdPtr;
          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);
      }
      if (clientData != NULL) {
          fsPathPtr->nativePathPtr = clientData;
      }
      PATHFLAGS(pathPtr) = 0;
    }

    /*
     * Ensure cwd hasn't changed.
     */

    if (fsPathPtr->cwdPtr != NULL) {
      if (!TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) {
          if (pathPtr->bytes == NULL) {
            UpdateStringOfFsPath(pathPtr);
          }
          FreeFsPathInternalRep(pathPtr);
          pathPtr->typePtr = NULL;
          if (Tcl_ConvertToType(interp, pathPtr, &tclFsPathType) != TCL_OK) {
            return NULL;
          }
          fsPathPtr = PATHOBJ(pathPtr);
      } else if (fsPathPtr->normPathPtr == NULL) {
          int cwdLen;
          Tcl_Obj *copy;
          const char *cwdStr;
          ClientData clientData = NULL;

          copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr);
          Tcl_IncrRefCount(copy);
          cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);

          /*
           * Should we perhaps use 'Tcl_FSPathSeparator'? But then what
           * about the Windows special case? Perhaps we should just check if
           * cwd is a root volume. We should never get cwdLen == 0 in this
           * code path.
           */

          switch (tclPlatform) {
          case TCL_PLATFORM_UNIX:
            if (cwdStr[cwdLen-1] != '/') {
                Tcl_AppendToObj(copy, "/", 1);
                cwdLen++;
            }
            break;
          case TCL_PLATFORM_WINDOWS:
            if (cwdStr[cwdLen-1] != '/' && cwdStr[cwdLen-1] != '\\') {
                Tcl_AppendToObj(copy, "/", 1);
                cwdLen++;
            }
            break;
          }
          Tcl_AppendObjToObj(copy, pathPtr);

          /*
           * Normalize the combined string, but only starting after the end
           * of the previously normalized 'dir'. This should be much faster!
           */

          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;
      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') {
          /*
           * 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;
            }

            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;
            }
#endif /* __WIN32__ */
          }
      }

      /*
       * Already has refCount incremented.
       */

      fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp,
            absolutePath,
            (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));
      if (0 && (clientData != NULL)) {
          fsPathPtr->nativePathPtr =
            (*fsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc)(clientData);
      }

      /*
       * Check if path is pure normalized (this can only be the case if it
       * is an absolute path).
       */

      if (useThisCwd == NULL) {
          if (!strcmp(TclGetString(fsPathPtr->normPathPtr),
                TclGetString(pathPtr))) {
            /*
             * 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;
          }
      } else {
          /*
           * We just need to free an object we allocated above for relative
           * paths (this was returned by Tcl_FSJoinToPath above), and then
           * of course store the cwd.
           */

          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,
    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->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(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->fsRecPtr == 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->fsRecPtr->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->fsRecPtr->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,
    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);
      pathPtr->typePtr = NULL;
      if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
          return TCL_ERROR;
      }
      srcFsPathPtr = PATHOBJ(pathPtr);
    }

    /*
     * Check whether the object is already assigned to a fs.
     */

    if (srcFsPathPtr->fsRecPtr != NULL) {
      *fsPtrPtr = srcFsPathPtr->fsRecPtr->fsPtr;
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFSSetPathDetails --
 *
 *    ???
 *
 * Results:
 *    None
 *
 * Side effects:
 *    ???
 *
 *---------------------------------------------------------------------------
 */

void
TclFSSetPathDetails(
    Tcl_Obj *pathPtr,
    FilesystemRecord *fsRecPtr,
    ClientData clientData)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
    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->fsRecPtr = fsRecPtr;
    srcFsPathPtr->nativePathPtr = clientData;
    srcFsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
    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(
    Tcl_Obj *firstPtr,
    Tcl_Obj *secondPtr)
{
    char *firstStr, *secondStr;
    int firstLen, secondLen, tempErrno;

    if (firstPtr == secondPtr) {
      return 1;
    }

    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);
    return (firstLen == secondLen) && (strcmp(firstStr, secondStr) == 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(
    Tcl_Interp *interp,       /* Used for error reporting if not NULL. */
    Tcl_Obj *pathPtr)         /* The object to convert. */
{
    int len;
    FsPath *fsPathPtr;
    Tcl_Obj *transPtr;
    char *name;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);

    if (pathPtr->typePtr == &tclFsPathType) {
      return TCL_OK;
    }

    /*
     * First step is to translate the filename. This is similar to
     * Tcl_TranslateFilename, but shouldn't convert everything to windows
     * backslashes on that platform. The current implementation of this piece
     * is a slightly optimised version of the various Tilde/Split/Join stuff
     * to avoid multiple split/join operations.
     *
     * 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 = Tcl_GetStringFromObj(pathPtr, &len);

    /*
     * Handle tilde substitutions, if needed.
     */

    if (name[0] == '~') {
      char *expandedUser;
      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_ResetResult(interp);
                Tcl_AppendResult(interp, "couldn't find HOME environment "
                      "variable to expand path", 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", 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(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 {
            /*
             * Simple case. "rest" is relative path. Just join it. The
             * "rest" object will be freed when Tcl_FSJoinToPath returns
             * (unless something else claims a refCount on it).
             */

            Tcl_Obj *joined;
            Tcl_Obj *rest = Tcl_NewStringObj(name+split+1, -1);

            Tcl_IncrRefCount(transPtr);
            joined = Tcl_FSJoinToPath(transPtr, 1, &rest);
            TclDecrRefCount(transPtr);
            transPtr = joined;
          }
      }
      Tcl_DStringFree(&temp);
    } else {
      transPtr = Tcl_FSJoinToPath(pathPtr, 0, NULL);
    }

#if defined(__CYGWIN__) && defined(__WIN32__)
    {
      extern int cygwin_conv_to_win32_path(const char *, char *);
      char winbuf[MAX_PATH+1];

      /*
       * In the Cygwin world, call conv_to_win32_path in order to use the
       * mount table to translate the file name into something Windows will
       * understand. Take care when converting empty strings!
       */

      name = Tcl_GetStringFromObj(transPtr, &len);
      if (len > 0) {
          cygwin_conv_to_win32_path(name, winbuf);
          TclWinNoBackslash(winbuf);
          Tcl_SetStringObj(transPtr, winbuf, -1);
      }
    }
#endif /* __CYGWIN__ && __WIN32__ */

    /*
     * Now we have a translated filename in 'transPtr'. This will have forward
     * slashes on Windows, and will not contain any ~user sequences.
     */

    fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath));

    fsPathPtr->translatedPathPtr = transPtr;
    if (transPtr != pathPtr) {
      Tcl_IncrRefCount(fsPathPtr->translatedPathPtr);
    }
    fsPathPtr->normPathPtr = NULL;
    fsPathPtr->cwdPtr = NULL;
    fsPathPtr->nativePathPtr = NULL;
    fsPathPtr->fsRecPtr = NULL;
    fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;

    /*
     * 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->fsRecPtr != NULL) {
      Tcl_FSFreeInternalRepProc *freeProc =
            fsPathPtr->fsRecPtr->fsPtr->freeInternalRepProc;
      if (freeProc != NULL) {
          (*freeProc)(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(
    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 = (FsPath *) ckalloc(sizeof(FsPath));

    SETPATHOBJ(copyPtr, 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) {
      Tcl_FSDupInternalRepProc *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(
    register Tcl_Obj *pathPtr)      /* path obj with string rep to update. */
{
    FsPath *fsPathPtr = PATHOBJ(pathPtr);
    const char *cwdStr;
    int cwdLen;
    Tcl_Obj *copy;

    if (PATHFLAGS(pathPtr) == 0 || fsPathPtr->cwdPtr == NULL) {
      Tcl_Panic("Called UpdateStringOfFsPath with invalid object");
    }

    copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr);
    Tcl_IncrRefCount(copy);

    cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);

    /*
     * Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the
     * Windows special case? Perhaps we should just check if cwd is a root
     * volume. We should never get cwdLen == 0 in this code path.
     */

    switch (tclPlatform) {
    case TCL_PLATFORM_UNIX:
      if (cwdStr[cwdLen-1] != '/') {
          Tcl_AppendToObj(copy, "/", 1);
          cwdLen++;
      }
      break;

    case TCL_PLATFORM_WINDOWS:
      /*
       * We need the extra 'cwdLen != 2', and ':' checks because a volume
       * relative path doesn't get a '/'. For example 'glob C:*cat*.exe'
       * will return 'C:cat32.exe'
       */

      if (cwdStr[cwdLen-1] != '/' && cwdStr[cwdLen-1] != '\\') {
          if (cwdLen != 2 || cwdStr[1] != ':') {
            Tcl_AppendToObj(copy, "/", 1);
            cwdLen++;
          }
      }
      break;
    }

    Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr);
    pathPtr->bytes = Tcl_GetStringFromObj(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;

      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;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Generated by  Doxygen 1.6.0   Back to index