source: downloads/tcl8.5.2/generic/tclIOUtil.c @ 42

/*
 * tclIOUtil.c --
 *
 *      This file contains the implementation of Tcl's generic filesystem
 *      code, which supports a pluggable filesystem architecture allowing both
 *      platform specific filesystems and 'virtual filesystems'. All
 *      filesystem access should go through the functions defined in this
 *      file. Most of this code was contributed by Vince Darley.
 *
 *      Parts of this file are based on code contributed by Karl Lehenbauer,
 *      Mark Diekhans and Peter da Silva.
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 2001-2004 Vincent Darley.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIOUtil.c,v 1.151 2008/02/27 03:35:49 jenglish Exp $
 */

#include "tclInt.h"
#ifdef __WIN32__
#   include "tclWinInt.h"
#endif
#include "tclFileSystem.h"

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

static FilesystemRecord*FsGetFirstFilesystem(void);
static void             FsThrExitProc(ClientData cd);
static Tcl_Obj *        FsListMounts(Tcl_Obj *pathPtr, const char *pattern);
static void             FsAddMountsToGlobResult(Tcl_Obj *resultPtr,
                            Tcl_Obj *pathPtr, const char *pattern,
                            Tcl_GlobTypeData *types);
static void             FsUpdateCwd(Tcl_Obj *cwdObj, ClientData clientData);

#ifdef TCL_THREADS
static void             FsRecacheFilesystemList(void);
#endif

/*
 * These form part of the native filesystem support. They are needed here
 * because we have a few native filesystem functions (which are the same for
 * win/unix) in this file. There is no need to place them in tclInt.h, because
 * they are not (and should not be) used anywhere else.
 */

MODULE_SCOPE const char *               tclpFileAttrStrings[];
MODULE_SCOPE const TclFileAttrProcs     tclpFileAttrProcs[];

/*
 * The following functions are obsolete string based APIs, and should be
 * removed in a future release (Tcl 9 would be a good time).
 */


/* Obsolete */
int
Tcl_Stat(
    const char *path,           /* Path of file to stat (in current CP). */
    struct stat *oldStyleBuf)   /* Filled with results of stat call. */
{
    int ret;
    Tcl_StatBuf buf;
    Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);

#ifndef TCL_WIDE_INT_IS_LONG
    Tcl_WideInt tmp1, tmp2;
#ifdef HAVE_ST_BLOCKS
    Tcl_WideInt tmp3;
#endif
#endif

    Tcl_IncrRefCount(pathPtr);
    ret = Tcl_FSStat(pathPtr, &buf);
    Tcl_DecrRefCount(pathPtr);
    if (ret != -1) {
#ifndef TCL_WIDE_INT_IS_LONG
# define OUT_OF_RANGE(x) \
        (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \
         ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX))
# define OUT_OF_URANGE(x) \
        (((Tcl_WideUInt)(x)) > ((Tcl_WideUInt)ULONG_MAX))

        /*
         * Perform the result-buffer overflow check manually.
         *
         * Note that ino_t/ino64_t is unsigned...
         *
         * Workaround gcc warning of "comparison is always false due to limited range of
         * data type" by assigning to tmp var of type Tcl_WideInt.
         */

        tmp1 = (Tcl_WideInt) buf.st_ino;
        tmp2 = (Tcl_WideInt) buf.st_size;
#ifdef HAVE_ST_BLOCKS
        tmp3 = (Tcl_WideInt) buf.st_blocks;
#endif

        if (OUT_OF_URANGE(tmp1) || OUT_OF_RANGE(tmp2)
#ifdef HAVE_ST_BLOCKS
                || OUT_OF_RANGE(tmp3)
#endif
            ) {
#ifdef EFBIG
            errno = EFBIG;
#else
#  ifdef EOVERFLOW
            errno = EOVERFLOW;
#  else
#    error "What status should be returned for file size out of range?"
#  endif
#endif
            return -1;
        }

#   undef OUT_OF_RANGE
#   undef OUT_OF_URANGE
#endif /* !TCL_WIDE_INT_IS_LONG */

        /*
         * Copy across all supported fields, with possible type coercions on
         * those fields that change between the normal and lf64 versions of
         * the stat structure (on Solaris at least). This is slow when the
         * structure sizes coincide, but that's what you get for using an
         * obsolete interface.
         */

        oldStyleBuf->st_mode    = buf.st_mode;
        oldStyleBuf->st_ino     = (ino_t) buf.st_ino;
        oldStyleBuf->st_dev     = buf.st_dev;
        oldStyleBuf->st_rdev    = buf.st_rdev;
        oldStyleBuf->st_nlink   = buf.st_nlink;
        oldStyleBuf->st_uid     = buf.st_uid;
        oldStyleBuf->st_gid     = buf.st_gid;
        oldStyleBuf->st_size    = (off_t) buf.st_size;
        oldStyleBuf->st_atime   = buf.st_atime;
        oldStyleBuf->st_mtime   = buf.st_mtime;
        oldStyleBuf->st_ctime   = buf.st_ctime;
#ifdef HAVE_ST_BLOCKS
        oldStyleBuf->st_blksize = buf.st_blksize;
        oldStyleBuf->st_blocks  = (blkcnt_t) buf.st_blocks;
#endif
    }
    return ret;
}

/* Obsolete */
int
Tcl_Access(
    const char *path,           /* Path of file to access (in current CP). */
    int mode)                   /* Permission setting. */
{
    int ret;
    Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);

    Tcl_IncrRefCount(pathPtr);
    ret = Tcl_FSAccess(pathPtr,mode);
    Tcl_DecrRefCount(pathPtr);

    return ret;
}

/* Obsolete */
Tcl_Channel
Tcl_OpenFileChannel(
    Tcl_Interp *interp,         /* Interpreter for error reporting; can be
                                 * NULL. */
    const char *path,           /* Name of file to open. */
    const char *modeString,     /* A list of POSIX open modes or a string such
                                 * as "rw". */
    int permissions)            /* If the open involves creating a file, with
                                 * what modes to create it? */
{
    Tcl_Channel ret;
    Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);

    Tcl_IncrRefCount(pathPtr);
    ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions);
    Tcl_DecrRefCount(pathPtr);

    return ret;
}

/* Obsolete */
int
Tcl_Chdir(
    const char *dirName)
{
    int ret;
    Tcl_Obj *pathPtr = Tcl_NewStringObj(dirName,-1);
    Tcl_IncrRefCount(pathPtr);
    ret = Tcl_FSChdir(pathPtr);
    Tcl_DecrRefCount(pathPtr);
    return ret;
}

/* Obsolete */
char *
Tcl_GetCwd(
    Tcl_Interp *interp,
    Tcl_DString *cwdPtr)
{
    Tcl_Obj *cwd;
    cwd = Tcl_FSGetCwd(interp);
    if (cwd == NULL) {
        return NULL;
    } else {
        Tcl_DStringInit(cwdPtr);
        Tcl_DStringAppend(cwdPtr, Tcl_GetString(cwd), -1);
        Tcl_DecrRefCount(cwd);
        return Tcl_DStringValue(cwdPtr);
    }
}

/* Obsolete */
int
Tcl_EvalFile(
    Tcl_Interp *interp,         /* Interpreter in which to process file. */
    const char *fileName)       /* Name of file to process. Tilde-substitution
                                 * will be performed on this name. */
{
    int ret;
    Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1);
    Tcl_IncrRefCount(pathPtr);
    ret = Tcl_FSEvalFile(interp, pathPtr);
    Tcl_DecrRefCount(pathPtr);
    return ret;
}

/*
 * The 3 hooks for Stat, Access and OpenFileChannel are obsolete. The
 * complete, general hooked filesystem APIs should be used instead. This
 * define decides whether to include the obsolete hooks and related code. If
 * these are removed, we'll also want to remove them from stubs/tclInt. The
 * only known users of these APIs are prowrap and mktclapp. New
 * code/extensions should not use them, since they do not provide as full
 * support as the full filesystem API.
 *
 * As soon as prowrap and mktclapp are updated to use the full filesystem
 * support, I suggest all these hooks are removed.
 */

#undef USE_OBSOLETE_FS_HOOKS

#ifdef USE_OBSOLETE_FS_HOOKS

/*
 * The following typedef declarations allow for hooking into the chain of
 * functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' &
 * 'Tcl_OpenFileChannel(...)'. Basically for each hookable function a linked
 * list is defined.
 */

typedef struct StatProc {
    TclStatProc_ *proc;         /* Function to process a 'stat()' call */
    struct StatProc *nextPtr;   /* The next 'stat()' function to call */
} StatProc;

typedef struct AccessProc {
    TclAccessProc_ *proc;       /* Function to process a 'access()' call */
    struct AccessProc *nextPtr; /* The next 'access()' function to call */
} AccessProc;

typedef struct OpenFileChannelProc {
    TclOpenFileChannelProc_ *proc;
                                /* Function to process a
                                 * 'Tcl_OpenFileChannel()' call */
    struct OpenFileChannelProc *nextPtr;
                                /* The next 'Tcl_OpenFileChannel()' function
                                 * to call */
} OpenFileChannelProc;

/*
 * For each type of (obsolete) hookable function, a static node is declared to
 * hold the function pointer for the "built-in" routine (e.g. 'TclpStat(...)')
 * and the respective list is initialized as a pointer to that node.
 *
 * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that these
 * statically declared list entry cannot be inadvertently removed.
 *
 * This method avoids the need to call any sort of "initialization" function.
 *
 * All three lists are protected by a global obsoleteFsHookMutex.
 */

static StatProc *statProcList = NULL;
static AccessProc *accessProcList = NULL;
static OpenFileChannelProc *openFileChannelProcList = NULL;

TCL_DECLARE_MUTEX(obsoleteFsHookMutex)

#endif /* USE_OBSOLETE_FS_HOOKS */

/*
 * Declare the native filesystem support. These functions should be considered
 * private to Tcl, and should really not be called directly by any code other
 * than this file (i.e. neither by Tcl's core nor by extensions). Similarly,
 * the old string-based Tclp... native filesystem functions should not be
 * called.
 *
 * The correct API to use now is the Tcl_FS... set of functions, which ensure
 * correct and complete virtual filesystem support.
 *
 * We cannot make all of these static, since some of them are implemented in
 * the platform-specific directories.
 */

static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator;
static Tcl_FSFreeInternalRepProc NativeFreeInternalRep;
static Tcl_FSFileAttrStringsProc NativeFileAttrStrings;
static Tcl_FSFileAttrsGetProc   NativeFileAttrsGet;
static Tcl_FSFileAttrsSetProc   NativeFileAttrsSet;

/*
 * The only reason these functions are not static is that they are either
 * called by code in the native (win/unix) directories or they are actually
 * implemented in those directories. They should simply not be called by code
 * outside Tcl's native filesystem core i.e. they should be considered
 * 'static' to Tcl's filesystem code (if we ever built the native filesystem
 * support into a separate code library, this could actually be enforced).
 */

Tcl_FSFilesystemPathTypeProc    TclpFilesystemPathType;
Tcl_FSInternalToNormalizedProc  TclpNativeToNormalized;
Tcl_FSStatProc                  TclpObjStat;
Tcl_FSAccessProc                TclpObjAccess;
Tcl_FSMatchInDirectoryProc      TclpMatchInDirectory;
Tcl_FSChdirProc                 TclpObjChdir;
Tcl_FSLstatProc                 TclpObjLstat;
Tcl_FSCopyFileProc              TclpObjCopyFile;
Tcl_FSDeleteFileProc            TclpObjDeleteFile;
Tcl_FSRenameFileProc            TclpObjRenameFile;
Tcl_FSCreateDirectoryProc       TclpObjCreateDirectory;
Tcl_FSCopyDirectoryProc         TclpObjCopyDirectory;
Tcl_FSRemoveDirectoryProc       TclpObjRemoveDirectory;
Tcl_FSUnloadFileProc            TclpUnloadFile;
Tcl_FSLinkProc                  TclpObjLink;
Tcl_FSListVolumesProc           TclpObjListVolumes;

/*
 * Define the native filesystem dispatch table. If necessary, it is ok to make
 * this non-static, but it should only be accessed by the functions actually
 * listed within it (or perhaps other helper functions of them). Anything
 * which is not part of this 'native filesystem implementation' should not be
 * delving inside here!
 */

Tcl_Filesystem tclNativeFilesystem = {
    "native",
    sizeof(Tcl_Filesystem),
    TCL_FILESYSTEM_VERSION_2,
    &TclNativePathInFilesystem,
    &TclNativeDupInternalRep,
    &NativeFreeInternalRep,
    &TclpNativeToNormalized,
    &TclNativeCreateNativeRep,
    &TclpObjNormalizePath,
    &TclpFilesystemPathType,
    &NativeFilesystemSeparator,
    &TclpObjStat,
    &TclpObjAccess,
    &TclpOpenFileChannel,
    &TclpMatchInDirectory,
    &TclpUtime,
#ifndef S_IFLNK
    NULL,
#else
    &TclpObjLink,
#endif /* S_IFLNK */
    &TclpObjListVolumes,
    &NativeFileAttrStrings,
    &NativeFileAttrsGet,
    &NativeFileAttrsSet,
    &TclpObjCreateDirectory,
    &TclpObjRemoveDirectory,
    &TclpObjDeleteFile,
    &TclpObjCopyFile,
    &TclpObjRenameFile,
    &TclpObjCopyDirectory,
    &TclpObjLstat,
    &TclpDlopen,
    /* Needs a cast since we're using version_2 */
    (Tcl_FSGetCwdProc *) &TclpGetNativeCwd,
    &TclpObjChdir
};

/*
 * Define the tail of the linked list. Note that for unconventional uses of
 * Tcl without a native filesystem, we may in the future wish to modify the
 * current approach of hard-coding the native filesystem in the lookup list
 * 'filesystemList' below.
 *
 * We initialize the record so that it thinks one file uses it. This means it
 * will never be freed.
 */

static FilesystemRecord nativeFilesystemRecord = {
    NULL,
    &tclNativeFilesystem,
    1,
    NULL
};

/*
 * This is incremented each time we modify the linked list of filesystems. Any
 * time it changes, all cached filesystem representations are suspect and must
 * be freed. For multithreading builds, change of the filesystem epoch will
 * trigger cache cleanup in all threads.
 */

static int theFilesystemEpoch = 0;

/*
 * Stores the linked list of filesystems. A 1:1 copy of this list is also
 * maintained in the TSD for each thread. This is to avoid synchronization
 * issues.
 */

static FilesystemRecord *filesystemList = &nativeFilesystemRecord;
TCL_DECLARE_MUTEX(filesystemMutex)

/*
 * Used to implement Tcl_FSGetCwd in a file-system independent way.
 */

static Tcl_Obj* cwdPathPtr = NULL;
static int cwdPathEpoch = 0;
static ClientData cwdClientData = NULL;
TCL_DECLARE_MUTEX(cwdMutex)

Tcl_ThreadDataKey tclFsDataKey;

/*
 * Declare fallback support function and information for Tcl_FSLoadFile
 */

static Tcl_FSUnloadFileProc     FSUnloadTempFile;

/*
 * One of these structures is used each time we successfully load a file from
 * a file system by way of making a temporary copy of the file on the native
 * filesystem. We need to store both the actual unloadProc/clientData
 * combination which was used, and the original and modified filenames, so
 * that we can correctly undo the entire operation when we want to unload the
 * code.
 */

typedef struct FsDivertLoad {
    Tcl_LoadHandle loadHandle;
    Tcl_FSUnloadFileProc *unloadProcPtr;
    Tcl_Obj *divertedFile;
    const Tcl_Filesystem *divertedFilesystem;
    ClientData divertedFileNativeRep;
} FsDivertLoad;

/*
 * Now move on to the basic filesystem implementation
 */

static void
FsThrExitProc(
    ClientData cd)
{
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *) cd;
    FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL;

    /*
     * Trash the cwd copy.
     */

    if (tsdPtr->cwdPathPtr != NULL) {
        Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
        tsdPtr->cwdPathPtr = NULL;
    }
    if (tsdPtr->cwdClientData != NULL) {
        NativeFreeInternalRep(tsdPtr->cwdClientData);
    }

    /*
     * Trash the filesystems cache.
     */

    fsRecPtr = tsdPtr->filesystemList;
    while (fsRecPtr != NULL) {
        tmpFsRecPtr = fsRecPtr->nextPtr;
        if (--fsRecPtr->fileRefCount <= 0) {
            ckfree((char *)fsRecPtr);
        }
        fsRecPtr = tmpFsRecPtr;
    }
    tsdPtr->initialized = 0;
}

int
TclFSCwdIsNative(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);

    if (tsdPtr->cwdClientData != NULL) {
        return 1;
    } else {
        return 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclFSCwdPointerEquals --
 *
 *      Check whether the current working directory is equal to the path
 *      given.
 *
 * Results:
 *      1 (equal) or 0 (un-equal) as appropriate.
 *
 * Side effects:
 *      If the paths are equal, but are not the same object, this method will
 *      modify the given pathPtrPtr to refer to the same object. In this case
 *      the object pointed to by pathPtrPtr will have its refCount
 *      decremented, and it will be adjusted to point to the cwd (with a new
 *      refCount).
 *
 *----------------------------------------------------------------------
 */

int
TclFSCwdPointerEquals(
    Tcl_Obj** pathPtrPtr)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);

    Tcl_MutexLock(&cwdMutex);
    if (tsdPtr->cwdPathPtr == NULL
            || tsdPtr->cwdPathEpoch != cwdPathEpoch) {
        if (tsdPtr->cwdPathPtr != NULL) {
            Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
        }
        if (tsdPtr->cwdClientData != NULL) {
            NativeFreeInternalRep(tsdPtr->cwdClientData);
        }
        if (cwdPathPtr == NULL) {
            tsdPtr->cwdPathPtr = NULL;
        } else {
            tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr);
            Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
        }
        if (cwdClientData == NULL) {
            tsdPtr->cwdClientData = NULL;
        } else {
            tsdPtr->cwdClientData = TclNativeDupInternalRep(cwdClientData);
        }
        tsdPtr->cwdPathEpoch = cwdPathEpoch;
    }
    Tcl_MutexUnlock(&cwdMutex);

    if (tsdPtr->initialized == 0) {
        Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr);
        tsdPtr->initialized = 1;
    }

    if (pathPtrPtr == NULL) {
        return (tsdPtr->cwdPathPtr == NULL);
    }

    if (tsdPtr->cwdPathPtr == *pathPtrPtr) {
        return 1;
    } else {
        int len1, len2;
        const char *str1, *str2;

        str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1);
        str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2);
        if (len1 == len2 && !strcmp(str1,str2)) {
            /*
             * They are equal, but different objects. Update so they will be
             * the same object in the future.
             */

            Tcl_DecrRefCount(*pathPtrPtr);
            *pathPtrPtr = tsdPtr->cwdPathPtr;
            Tcl_IncrRefCount(*pathPtrPtr);
            return 1;
        } else {
            return 0;
        }
    }
}

#ifdef TCL_THREADS
static void
FsRecacheFilesystemList(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
    FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL;

    /*
     * Trash the current cache.
     */

    fsRecPtr = tsdPtr->filesystemList;
    while (fsRecPtr != NULL) {
        tmpFsRecPtr = fsRecPtr->nextPtr;
        if (--fsRecPtr->fileRefCount <= 0) {
            ckfree((char *)fsRecPtr);
        }
        fsRecPtr = tmpFsRecPtr;
    }
    tsdPtr->filesystemList = NULL;

    /*
     * Code below operates on shared data. We are already called under mutex
     * lock so we can safely proceed.
     *
     * Locate tail of the global filesystem list.
     */

    fsRecPtr = filesystemList;
    while (fsRecPtr != NULL) {
        tmpFsRecPtr = fsRecPtr;
        fsRecPtr = fsRecPtr->nextPtr;
    }

    /*
     * Refill the cache honouring the order.
     */

    fsRecPtr = tmpFsRecPtr;
    while (fsRecPtr != NULL) {
        tmpFsRecPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord));
        *tmpFsRecPtr = *fsRecPtr;
        tmpFsRecPtr->nextPtr = tsdPtr->filesystemList;
        tmpFsRecPtr->prevPtr = NULL;
        if (tsdPtr->filesystemList) {
            tsdPtr->filesystemList->prevPtr = tmpFsRecPtr;
        }
        tsdPtr->filesystemList = tmpFsRecPtr;
        fsRecPtr = fsRecPtr->prevPtr;
    }

    /*
     * Make sure the above gets released on thread exit.
     */

    if (tsdPtr->initialized == 0) {
        Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr);
        tsdPtr->initialized = 1;
    }
}
#endif /* TCL_THREADS */

static FilesystemRecord *
FsGetFirstFilesystem(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
    FilesystemRecord *fsRecPtr;
#ifndef TCL_THREADS
    tsdPtr->filesystemEpoch = theFilesystemEpoch;
    fsRecPtr = filesystemList;
#else
    Tcl_MutexLock(&filesystemMutex);
    if (tsdPtr->filesystemList == NULL
            || (tsdPtr->filesystemEpoch != theFilesystemEpoch)) {
        FsRecacheFilesystemList();
        tsdPtr->filesystemEpoch = theFilesystemEpoch;
    }
    Tcl_MutexUnlock(&filesystemMutex);
    fsRecPtr = tsdPtr->filesystemList;
#endif
    return fsRecPtr;
}

/*
 * The epoch can be changed both by filesystems being added or removed and by
 * env(HOME) changing.
 */

int
TclFSEpochOk(
    int filesystemEpoch)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
    (void) FsGetFirstFilesystem();
    return (filesystemEpoch == tsdPtr->filesystemEpoch);
}

/*
 * If non-NULL, clientData is owned by us and must be freed later.
 */

static void
FsUpdateCwd(
    Tcl_Obj *cwdObj,
    ClientData clientData)
{
    int len;
    char *str = NULL;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);

    if (cwdObj != NULL) {
        str = Tcl_GetStringFromObj(cwdObj, &len);
    }

    Tcl_MutexLock(&cwdMutex);
    if (cwdPathPtr != NULL) {
        Tcl_DecrRefCount(cwdPathPtr);
    }
    if (cwdClientData != NULL) {
        NativeFreeInternalRep(cwdClientData);
    }

    if (cwdObj == NULL) {
        cwdPathPtr = NULL;
        cwdClientData = NULL;
    } else {
        /*
         * This must be stored as string obj!
         */

        cwdPathPtr = Tcl_NewStringObj(str, len);
        Tcl_IncrRefCount(cwdPathPtr);
        cwdClientData = TclNativeDupInternalRep(clientData);
    }

    cwdPathEpoch++;
    tsdPtr->cwdPathEpoch = cwdPathEpoch;
    Tcl_MutexUnlock(&cwdMutex);

    if (tsdPtr->cwdPathPtr) {
        Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
    }
    if (tsdPtr->cwdClientData) {
        NativeFreeInternalRep(tsdPtr->cwdClientData);
    }

    if (cwdObj == NULL) {
        tsdPtr->cwdPathPtr = NULL;
        tsdPtr->cwdClientData = NULL;
    } else {
        tsdPtr->cwdPathPtr = Tcl_NewStringObj(str, len);
        tsdPtr->cwdClientData = clientData;
        Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeFilesystem --
 *
 *      Clean up the filesystem. After this, calls to all Tcl_FS... functions
 *      will fail.
 *
 *      We will later call TclResetFilesystem to restore the FS to a pristine
 *      state.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Frees any memory allocated by the filesystem.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeFilesystem(void)
{
    FilesystemRecord *fsRecPtr;

    /*
     * Assumption that only one thread is active now. Otherwise we would need
     * to put various mutexes around this code.
     */

    if (cwdPathPtr != NULL) {
        Tcl_DecrRefCount(cwdPathPtr);
        cwdPathPtr = NULL;
        cwdPathEpoch = 0;
    }
    if (cwdClientData != NULL) {
        NativeFreeInternalRep(cwdClientData);
        cwdClientData = NULL;
    }

    /*
     * Remove all filesystems, freeing any allocated memory that is no longer
     * needed
     */

    fsRecPtr = filesystemList;
    while (fsRecPtr != NULL) {
        FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr;
        if (fsRecPtr->fileRefCount <= 0) {
            /*
             * The native filesystem is static, so we don't free it.
             */

            if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
                ckfree((char *)fsRecPtr);
            }
        }
        fsRecPtr = tmpFsRecPtr;
    }
    filesystemList = NULL;

    /*
     * Now filesystemList is NULL. This means that any attempt to use the
     * filesystem is likely to fail.
     */

#ifdef USE_OBSOLETE_FS_HOOKS
    statProcList = NULL;
    accessProcList = NULL;
    openFileChannelProcList = NULL;
#endif
#ifdef __WIN32__
    TclWinEncodingsCleanup();
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * TclResetFilesystem --
 *
 *      Restore the filesystem to a pristine state.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

void
TclResetFilesystem(void)
{
    filesystemList = &nativeFilesystemRecord;

    /*
     * Note, at this point, I believe nativeFilesystemRecord -> fileRefCount
     * should equal 1 and if not, we should try to track down the cause.
     */

#ifdef __WIN32__
    /*
     * Cleans up the win32 API filesystem proc lookup table. This must happen
     * very late in finalization so that deleting of copied dlls can occur.
     */

    TclWinResetInterfaces();
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSRegister --
 *
 *      Insert the filesystem function table at the head of the list of
 *      functions which are used during calls to all file-system operations.
 *      The filesystem will be added even if it is already in the list. (You
 *      can use Tcl_FSData to check if it is in the list, provided the
 *      ClientData used was not NULL).
 *
 *      Note that the filesystem handling is head-to-tail of the list. Each
 *      filesystem is asked in turn whether it can handle a particular
 *      request, until one of them says 'yes'. At that point no further
 *      filesystems are asked.
 *
 *      In particular this means if you want to add a diagnostic filesystem
 *      (which simply reports all fs activity), it must be at the head of the
 *      list: i.e. it must be the last registered.
 *
 * Results:
 *      Normally TCL_OK; TCL_ERROR if memory for a new node in the list could
 *      not be allocated.
 *
 * Side effects:
 *      Memory allocated and modifies the link list for filesystems.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSRegister(
    ClientData clientData,      /* Client specific data for this fs */
    Tcl_Filesystem *fsPtr)      /* The filesystem record for the new fs. */
{
    FilesystemRecord *newFilesystemPtr;

    if (fsPtr == NULL) {
        return TCL_ERROR;
    }

    newFilesystemPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord));

    newFilesystemPtr->clientData = clientData;
    newFilesystemPtr->fsPtr = fsPtr;

    /*
     * We start with a refCount of 1. If this drops to zero, then anyone is
     * welcome to ckfree us.
     */

    newFilesystemPtr->fileRefCount = 1;

    /*
     * Is this lock and wait strictly speaking necessary? Since any iterators
     * out there will have grabbed a copy of the head of the list and be
     * iterating away from that, if we add a new element to the head of the
     * list, it can't possibly have any effect on any of their loops. In fact
     * it could be better not to wait, since we are adjusting the filesystem
     * epoch, any cached representations calculated by existing iterators are
     * going to have to be thrown away anyway.
     *
     * However, since registering and unregistering filesystems is a very rare
     * action, this is not a very important point.
     */

    Tcl_MutexLock(&filesystemMutex);

    newFilesystemPtr->nextPtr = filesystemList;
    newFilesystemPtr->prevPtr = NULL;
    if (filesystemList) {
        filesystemList->prevPtr = newFilesystemPtr;
    }
    filesystemList = newFilesystemPtr;

    /*
     * Increment the filesystem epoch counter, since existing paths might
     * conceivably now belong to different filesystems.
     */

    theFilesystemEpoch++;
    Tcl_MutexUnlock(&filesystemMutex);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSUnregister --
 *
 *      Remove the passed filesystem from the list of filesystem function
 *      tables. It also ensures that the built-in (native) filesystem is not
 *      removable, although we may wish to change that decision in the future
 *      to allow a smaller Tcl core, in which the native filesystem is not
 *      used at all (we could, say, initialise Tcl completely over a network
 *      connection).
 *
 * Results:
 *      TCL_OK if the function pointer was successfully removed, TCL_ERROR
 *      otherwise.
 *
 * Side effects:
 *      Memory may be deallocated (or will be later, once no "path" objects
 *      refer to this filesystem), but the list of registered filesystems is
 *      updated immediately.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSUnregister(
    Tcl_Filesystem *fsPtr)      /* The filesystem record to remove. */
{
    int retVal = TCL_ERROR;
    FilesystemRecord *fsRecPtr;

    Tcl_MutexLock(&filesystemMutex);

    /*
     * Traverse the 'filesystemList' looking for the particular node whose
     * 'fsPtr' member matches 'fsPtr' and remove that one from the list.
     * Ensure that the "default" node cannot be removed.
     */

    fsRecPtr = filesystemList;
    while ((retVal == TCL_ERROR) && (fsRecPtr->fsPtr != &tclNativeFilesystem)) {
        if (fsRecPtr->fsPtr == fsPtr) {
            if (fsRecPtr->prevPtr) {
                fsRecPtr->prevPtr->nextPtr = fsRecPtr->nextPtr;
            } else {
                filesystemList = fsRecPtr->nextPtr;
            }
            if (fsRecPtr->nextPtr) {
                fsRecPtr->nextPtr->prevPtr = fsRecPtr->prevPtr;
            }

            /*
             * Increment the filesystem epoch counter, since existing paths
             * might conceivably now belong to different filesystems. This
             * should also ensure that paths which have cached the filesystem
             * which is about to be deleted do not reference that filesystem
             * (which would of course lead to memory exceptions).
             */

            theFilesystemEpoch++;

            fsRecPtr->fileRefCount--;
            if (fsRecPtr->fileRefCount <= 0) {
                ckfree((char *)fsRecPtr);
            }

            retVal = TCL_OK;
        } else {
            fsRecPtr = fsRecPtr->nextPtr;
        }
    }

    Tcl_MutexUnlock(&filesystemMutex);
    return retVal;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSMatchInDirectory --
 *
 *      This routine is used by the globbing code to search a directory for
 *      all files which match a given pattern. The appropriate function for
 *      the filesystem to which pathPtr belongs will be called. If pathPtr
 *      does not belong to any filesystem and if it is NULL or the empty
 *      string, then we assume the pattern is to be matched in the current
 *      working directory. To avoid have the Tcl_FSMatchInDirectoryProc for
 *      each filesystem from having to deal with this issue, we create a
 *      pathPtr on the fly (equal to the cwd), and then remove it from the
 *      results returned. This makes filesystems easy to write, since they can
 *      assume the pathPtr passed to them is an ordinary path. In fact this
 *      means we could remove such special case handling from Tcl's native
 *      filesystems.
 *
 *      If 'pattern' is NULL, then pathPtr is assumed to be a fully specified
 *      path of a single file/directory which must be checked for existence
 *      and correct type.
 *
 * Results:
 *
 *      The return value is a standard Tcl result indicating whether an error
 *      occurred in globbing. Error messages are placed in interp, but good
 *      results are placed in the resultPtr given.
 *
 *      Recursive searches, e.g.
 *              glob -dir $dir -join * pkgIndex.tcl
 *      which must recurse through each directory matching '*' are handled
 *      internally by Tcl, by passing specific flags in a modified 'types'
 *      parameter. This means the actual filesystem only ever sees patterns
 *      which match in a single directory.
 *
 * Side effects:
 *      The interpreter may have an error message inserted into it.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSMatchInDirectory(
    Tcl_Interp *interp,         /* Interpreter to receive error messages, but
                                 * may be NULL. */
    Tcl_Obj *resultPtr,         /* List object to receive results. */
    Tcl_Obj *pathPtr,           /* Contains path to directory to search. */
    const char *pattern,        /* Pattern to match against. */
    Tcl_GlobTypeData *types)    /* Object containing list of acceptable types.
                                 * May be NULL. In particular the directory
                                 * flag is very important. */
{
    const Tcl_Filesystem *fsPtr;
    Tcl_Obj *cwd, *tmpResultPtr, **elemsPtr;
    int resLength, i, ret = -1;

    if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) {
        /*
         * We don't currently allow querying of mounts by external code (a
         * valuable future step), so since we're the only function that
         * actually knows about mounts, this means we're being called
         * recursively by ourself. Return no matches.
         */

        return TCL_OK;
    }

    if (pathPtr != NULL) {
        fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    } else {
        fsPtr = NULL;
    }

    /*
     * Check if we've successfully mapped the path to a filesystem within
     * which to search.
     */

    if (fsPtr != NULL) {
        if (fsPtr->matchInDirectoryProc == NULL) {
            Tcl_SetErrno(ENOENT);
            return -1;
        }
        ret = (*fsPtr->matchInDirectoryProc)(interp, resultPtr, pathPtr,
                pattern, types);
        if (ret == TCL_OK && pattern != NULL) {
            FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types);
        }
        return ret;
    }

    /*
     * If the path isn't empty, we have no idea how to match files in a
     * directory which belongs to no known filesystem
     */

    if (pathPtr != NULL && TclGetString(pathPtr)[0] != '\0') {
        Tcl_SetErrno(ENOENT);
        return -1;
    }

    /*
     * We have an empty or NULL path. This is defined to mean we must search
     * for files within the current 'cwd'. We therefore use that, but then
     * since the proc we call will return results which include the cwd we
     * must then trim it off the front of each path in the result. We choose
     * to deal with this here (in the generic code), since if we don't, every
     * single filesystem's implementation of Tcl_FSMatchInDirectory will have
     * to deal with it for us.
     */

    cwd = Tcl_FSGetCwd(NULL);
    if (cwd == NULL) {
        if (interp != NULL) {
            Tcl_SetResult(interp, "glob couldn't determine "
                    "the current working directory", TCL_STATIC);
        }
        return TCL_ERROR;
    }

    fsPtr = Tcl_FSGetFileSystemForPath(cwd);
    if (fsPtr != NULL && fsPtr->matchInDirectoryProc != NULL) {
        TclNewObj(tmpResultPtr);
        Tcl_IncrRefCount(tmpResultPtr);
        ret = (*fsPtr->matchInDirectoryProc)(interp, tmpResultPtr, cwd,
                pattern, types);
        if (ret == TCL_OK) {
            FsAddMountsToGlobResult(tmpResultPtr, cwd, pattern, types);

            /*
             * Note that we know resultPtr and tmpResultPtr are distinct.
             */

            ret = Tcl_ListObjGetElements(interp, tmpResultPtr,
                    &resLength, &elemsPtr);
            for (i=0 ; ret==TCL_OK && i<resLength ; i++) {
                ret = Tcl_ListObjAppendElement(interp, resultPtr,
                        TclFSMakePathRelative(interp, elemsPtr[i], cwd));
            }
        }
        TclDecrRefCount(tmpResultPtr);
    }
    Tcl_DecrRefCount(cwd);
    return ret;
}

/*
 *----------------------------------------------------------------------
 *
 * FsAddMountsToGlobResult --
 *
 *      This routine is used by the globbing code to take the results of a
 *      directory listing and add any mounted paths to that listing. This is
 *      required so that simple things like 'glob *' merge mounts and listings
 *      correctly.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Modifies the resultPtr.
 *
 *----------------------------------------------------------------------
 */

static void
FsAddMountsToGlobResult(
    Tcl_Obj *resultPtr,         /* The current list of matching paths; must
                                 * not be shared! */
    Tcl_Obj *pathPtr,           /* The directory in question */
    const char *pattern,        /* Pattern to match against. */
    Tcl_GlobTypeData *types)    /* Object containing list of acceptable types.
                                 * May be NULL. In particular the directory
                                 * flag is very important. */
{
    int mLength, gLength, i;
    int dir = (types == NULL || (types->type & TCL_GLOB_TYPE_DIR));
    Tcl_Obj *mounts = FsListMounts(pathPtr, pattern);

    if (mounts == NULL) {
        return;
    }

    if (Tcl_ListObjLength(NULL, mounts, &mLength) != TCL_OK || mLength == 0) {
        goto endOfMounts;
    }
    if (Tcl_ListObjLength(NULL, resultPtr, &gLength) != TCL_OK) {
        goto endOfMounts;
    }
    for (i=0 ; i<mLength ; i++) {
        Tcl_Obj *mElt;
        int j;
        int found = 0;

        Tcl_ListObjIndex(NULL, mounts, i, &mElt);

        for (j=0 ; j<gLength ; j++) {
            Tcl_Obj *gElt;

            Tcl_ListObjIndex(NULL, resultPtr, j, &gElt);
            if (Tcl_FSEqualPaths(mElt, gElt)) {
                found = 1;
                if (!dir) {
                    /*
                     * We don't want to list this.
                     */

                    Tcl_ListObjReplace(NULL, resultPtr, j, 1, 0, NULL);
                    gLength--;
                }
                break;          /* Break out of for loop */
            }
        }
        if (!found && dir) {
            Tcl_Obj *norm;
            int len, mlen;

            /*
             * We know mElt is absolute normalized and lies inside pathPtr, so
             * now we must add to the result the right representation of mElt,
             * i.e. the representation which is relative to pathPtr.
             */

            norm = Tcl_FSGetNormalizedPath(NULL, pathPtr);
            if (norm != NULL) {
                const char *path, *mount;

                mount = Tcl_GetStringFromObj(mElt, &mlen);
                path = Tcl_GetStringFromObj(norm, &len);
                if (path[len-1] == '/') {
                    /*
                     * Deal with the root of the volume.
                     */

                    len--;
                }
                len++; /* account for '/' in the mElt [Bug 1602539] */
                mElt = TclNewFSPathObj(pathPtr, mount + len, mlen - len);
                Tcl_ListObjAppendElement(NULL, resultPtr, mElt);
            }
            /*
             * No need to increment gLength, since we don't want to compare
             * mounts against mounts.
             */
        }
    }

  endOfMounts:
    Tcl_DecrRefCount(mounts);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSMountsChanged --
 *
 *      Notify the filesystem that the available mounted filesystems (or
 *      within any one filesystem type, the number or location of mount
 *      points) have changed.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      The global filesystem variable 'theFilesystemEpoch' is incremented.
 *      The effect of this is to make all cached path representations invalid.
 *      Clearly it should only therefore be called when it is really required!
 *      There are a few circumstances when it should be called:
 *
 *      (1) when a new filesystem is registered or unregistered. Strictly
 *      speaking this is only necessary if the new filesystem accepts file
 *      paths as is (normally the filesystem itself is really a shell which
 *      hasn't yet had any mount points established and so its
 *      'pathInFilesystem' proc will always fail). However, for safety, Tcl
 *      always calls this for you in these circumstances.
 *
 *      (2) when additional mount points are established inside any existing
 *      filesystem (except the native fs)
 *
 *      (3) when any filesystem (except the native fs) changes the list of
 *      available volumes.
 *
 *      (4) when the mapping from a string representation of a file to a full,
 *      normalized path changes. For example, if 'env(HOME)' is modified, then
 *      any path containing '~' will map to a different filesystem location.
 *      Therefore all such paths need to have their internal representation
 *      invalidated.
 *
 *      Tcl has no control over (2) and (3), so any registered filesystem must
 *      make sure it calls this function when those situations occur.
 *
 *      (Note: the reason for the exception in 2,3 for the native filesystem
 *      is that the native filesystem by default claims all unknown files even
 *      if it really doesn't understand them or if they don't exist).
 *
 *----------------------------------------------------------------------
 */

void
Tcl_FSMountsChanged(
    Tcl_Filesystem *fsPtr)
{
    /*
     * We currently don't do anything with this parameter. We could in the
     * future only invalidate files for this filesystem or otherwise take more
     * advanced action.
     */

    (void)fsPtr;

    /*
     * Increment the filesystem epoch counter, since existing paths might now
     * belong to different filesystems.
     */

    Tcl_MutexLock(&filesystemMutex);
    theFilesystemEpoch++;
    Tcl_MutexUnlock(&filesystemMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSData --
 *
 *      Retrieve the clientData field for the filesystem given, or NULL if
 *      that filesystem is not registered.
 *
 * Results:
 *      A clientData value, or NULL. Note that if the filesystem was
 *      registered with a NULL clientData field, this function will return
 *      that NULL value.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

ClientData
Tcl_FSData(
    Tcl_Filesystem *fsPtr) /* The filesystem record to query. */
{
    ClientData retVal = NULL;
    FilesystemRecord *fsRecPtr = FsGetFirstFilesystem();

    /*
     * Traverse the list of filesystems look for a particular one. If found,
     * return that filesystem's clientData (originally provided when calling
     * Tcl_FSRegister).
     */

    while ((retVal == NULL) && (fsRecPtr != NULL)) {
        if (fsRecPtr->fsPtr == fsPtr) {
            retVal = fsRecPtr->clientData;
        }
        fsRecPtr = fsRecPtr->nextPtr;
    }

    return retVal;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFSNormalizeToUniquePath --
 *
 *      Takes a path specification containing no ../, ./ sequences, and
 *      converts it into a unique path for the given 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).
 *
 * Results:
 *      The pathPtr is modified in place. The return value is the last byte
 *      offset which was recognised in the path string.
 *
 * Side effects:
 *      None (beyond the memory allocation for the result).
 *
 * Special notes:
 *      If the filesystem-specific normalizePathProcs can re-introduce ../, ./
 *      sequences into the path, then this function will not return the
 *      correct result. This may be possible with symbolic links on unix.
 *
 *      Important assumption: if startAt is non-zero, it must point to a
 *      directory separator that we know exists and is already normalized (so
 *      it is important not to point to the char just after the separator).
 *
 *---------------------------------------------------------------------------
 */

int
TclFSNormalizeToUniquePath(
    Tcl_Interp *interp,         /* Used for error messages. */
    Tcl_Obj *pathPtr,           /* The path to normalize in place */
    int startAt,                /* Start at this char-offset */
    ClientData *clientDataPtr)  /* If we generated a complete normalized path
                                 * for a given filesystem, we can optionally
                                 * return an fs-specific clientdata here. */
{
    FilesystemRecord *fsRecPtr, *firstFsRecPtr;
    /* Ignore this variable */
    (void) clientDataPtr;

    /*
     * Call each of the "normalise path" functions in succession. This is a
     * special case, in which if we have a native filesystem handler, we call
     * it first. This is because the root of Tcl's filesystem is always a
     * native filesystem (i.e. '/' on unix is native).
     */

    firstFsRecPtr = FsGetFirstFilesystem();

    fsRecPtr = firstFsRecPtr;
    while (fsRecPtr != NULL) {
        if (fsRecPtr->fsPtr == &tclNativeFilesystem) {
            Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;
            if (proc != NULL) {
                startAt = (*proc)(interp, pathPtr, startAt);
            }
            break;
        }
        fsRecPtr = fsRecPtr->nextPtr;
    }

    fsRecPtr = firstFsRecPtr;
    while (fsRecPtr != NULL) {
        /*
         * Skip the native system next time through.
         */

        if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
            Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;
            if (proc != NULL) {
                startAt = (*proc)(interp, pathPtr, startAt);
            }

            /*
             * We could add an efficiency check like this:
             *          if (retVal == length-of(pathPtr)) {break;}
             * but there's not much benefit.
             */
        }
        fsRecPtr = fsRecPtr->nextPtr;
    }

    return startAt;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclGetOpenMode --
 *
 *      This routine is an obsolete, limited version of TclGetOpenModeEx()
 *      below. It exists only to satisfy any extensions imprudently using it
 *      via Tcl's internal stubs table.
 *
 * Results:
 *      Same as TclGetOpenModeEx().
 *
 * Side effects:
 *      Same as TclGetOpenModeEx().
 *
 *---------------------------------------------------------------------------
 */

int
TclGetOpenMode(
    Tcl_Interp *interp,         /* Interpreter to use for error reporting -
                                 * may be NULL. */
    const char *modeString,     /* Mode string, e.g. "r+" or "RDONLY CREAT" */
    int *seekFlagPtr)           /* Set this to 1 if the caller should seek to
                                 * EOF during the opening of the file. */
{
    int binary = 0;
    return TclGetOpenModeEx(interp, modeString, seekFlagPtr, &binary);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclGetOpenModeEx --
 *
 *      Computes a POSIX mode mask for opening a file, from a given string,
 *      and also sets flags to indicate whether the caller should seek to EOF
 *      after opening the file, and whether the caller should configure the
 *      channel for binary data.
 *
 * Results:
 *      On success, returns mode to pass to "open". If an error occurs, the
 *      return value is -1 and if interp is not NULL, sets interp's result
 *      object to an error message.
 *
 * Side effects:
 *      Sets the integer referenced by seekFlagPtr to 1 to tell the caller to
 *      seek to EOF after opening the file, or to 0 otherwise. Sets the
 *      integer referenced by binaryPtr to 1 to tell the caller to seek to
 *      configure the channel for binary data, or to 0 otherwise.
 *
 * Special note:
 *      This code is based on a prototype implementation contributed by Mark
 *      Diekhans.
 *
 *---------------------------------------------------------------------------
 */

int
TclGetOpenModeEx(
    Tcl_Interp *interp,         /* Interpreter to use for error reporting -
                                 * may be NULL. */
    const char *modeString,     /* Mode string, e.g. "r+" or "RDONLY CREAT" */
    int *seekFlagPtr,           /* Set this to 1 if the caller should seek to
                                 * EOF during the opening of the file. */
    int *binaryPtr)             /* Set this to 1 if the caller should
                                 * configure the opened channel for binary
                                 * operations */
{
    int mode, modeArgc, c, i, gotRW;
    const char **modeArgv, *flag;
#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)

    /*
     * Check for the simpler fopen-like access modes (e.g. "r"). They are
     * distinguished from the POSIX access modes by the presence of a
     * lower-case first letter.
     */

    *seekFlagPtr = 0;
    *binaryPtr = 0;
    mode = 0;

    /*
     * Guard against international characters before using byte oriented
     * routines.
     */

    if (!(modeString[0] & 0x80)
            && islower(UCHAR(modeString[0]))) { /* INTL: ISO only. */
        switch (modeString[0]) {
        case 'r':
            mode = O_RDONLY;
            break;
        case 'w':
            mode = O_WRONLY|O_CREAT|O_TRUNC;
            break;
        case 'a':
            /*
             * Added O_APPEND for proper automatic seek-to-end-on-write by the
             * OS. [Bug 680143]
             */

            mode = O_WRONLY|O_CREAT|O_APPEND;
            *seekFlagPtr = 1;
            break;
        default:
            goto error;
        }
        i=1;
        while (i<3 && modeString[i]) {
            if (modeString[i] == modeString[i-1]) {
                goto error;
            }
            switch (modeString[i++]) {
            case '+':
                /*
                 * Must remove the O_APPEND flag so that the seek command
                 * works. [Bug 1773127]
                 */

                mode &= ~(O_RDONLY|O_WRONLY|O_APPEND);
                mode |= O_RDWR;
                break;
            case 'b':
                *binaryPtr = 1;
                break;
            default:
                goto error;
            }
        }
        if (modeString[i] != 0) {
            goto error;
        }
        return mode;

    error:
        *seekFlagPtr = 0;
        *binaryPtr = 0;
        if (interp != NULL) {
            Tcl_AppendResult(interp, "illegal access mode \"", modeString,
                    "\"", NULL);
        }
        return -1;
    }

    /*
     * The access modes are specified using a list of POSIX modes such as
     * O_CREAT.
     *
     * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when a NULL
     * interpreter is passed in.
     */

    if (Tcl_SplitList(interp, modeString, &modeArgc, &modeArgv) != TCL_OK) {
        if (interp != NULL) {
            Tcl_AddErrorInfo(interp,
                    "\n    while processing open access modes \"");
            Tcl_AddErrorInfo(interp, modeString);
            Tcl_AddErrorInfo(interp, "\"");
        }
        return -1;
    }

    gotRW = 0;
    for (i = 0; i < modeArgc; i++) {
        flag = modeArgv[i];
        c = flag[0];
        if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) {
            mode = (mode & ~RW_MODES) | O_RDONLY;
            gotRW = 1;
        } else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) {
            mode = (mode & ~RW_MODES) | O_WRONLY;
            gotRW = 1;
        } else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) {
            mode = (mode & ~RW_MODES) | O_RDWR;
            gotRW = 1;
        } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) {
            mode |= O_APPEND;
            *seekFlagPtr = 1;
        } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) {
            mode |= O_CREAT;
        } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) {
            mode |= O_EXCL;

        } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) {
#ifdef O_NOCTTY
            mode |= O_NOCTTY;
#else
            if (interp != NULL) {
                Tcl_AppendResult(interp, "access mode \"", flag,
                        "\" not supported by this system", NULL);
            }
            ckfree((char *) modeArgv);
            return -1;
#endif

        } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) {
#ifdef O_NONBLOCK
            mode |= O_NONBLOCK;
#else
            if (interp != NULL) {
                Tcl_AppendResult(interp, "access mode \"", flag,
                        "\" not supported by this system", NULL);
            }
            ckfree((char *) modeArgv);
            return -1;
#endif

        } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) {
            mode |= O_TRUNC;
        } else if ((c == 'B') && (strcmp(flag, "BINARY") == 0)) {
            *binaryPtr = 1;
        } else {

            if (interp != NULL) {
                Tcl_AppendResult(interp, "invalid access mode \"", flag,
                        "\": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, "
                        "CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC", NULL);
            }
            ckfree((char *) modeArgv);
            return -1;
        }
    }

    ckfree((char *) modeArgv);

    if (!gotRW) {
        if (interp != NULL) {
            Tcl_AppendResult(interp, "access mode must include either"
                    " RDONLY, WRONLY, or RDWR", NULL);
        }
        return -1;
    }
    return mode;
}

/*
 * Tcl_FSEvalFile is Tcl_FSEvalFileEx without encoding argument.
 */

int
Tcl_FSEvalFile(
    Tcl_Interp *interp,         /* Interpreter in which to process file. */
    Tcl_Obj *pathPtr)           /* Path of file to process. Tilde-substitution
                                 * will be performed on this name. */
{
    return Tcl_FSEvalFileEx(interp, pathPtr, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSEvalFileEx --
 *
 *      Read in a file and process the entire file as one gigantic Tcl
 *      command.
 *
 * Results:
 *      A standard Tcl result, which is either the result of executing the
 *      file or an error indicating why the file couldn't be read.
 *
 * Side effects:
 *      Depends on the commands in the file. During the evaluation of the
 *      contents of the file, iPtr->scriptFile is made to point to pathPtr
 *      (the old value is cached and replaced when this function returns).
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSEvalFileEx(
    Tcl_Interp *interp,         /* Interpreter in which to process file. */
    Tcl_Obj *pathPtr,           /* Path of file to process. Tilde-substitution
                                 * will be performed on this name. */
    const char *encodingName)   /* If non-NULL, then use this encoding for the
                                 * file. NULL means use the system encoding. */
{
    int length, result = TCL_ERROR;
    Tcl_StatBuf statBuf;
    Tcl_Obj *oldScriptFile;
    Interp *iPtr;
    char *string;
    Tcl_Channel chan;
    Tcl_Obj *objPtr;

    if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
        return result;
    }

    if (Tcl_FSStat(pathPtr, &statBuf) == -1) {
        Tcl_SetErrno(errno);
        Tcl_AppendResult(interp, "couldn't read file \"",
                Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
        return result;
    }
    chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644);
    if (chan == (Tcl_Channel) NULL) {
        Tcl_ResetResult(interp);
        Tcl_AppendResult(interp, "couldn't read file \"",
                Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
        return result;
    }

    /*
     * The eofchar is \32 (^Z). This is the usual on Windows, but we effect
     * this cross-platform to allow for scripted documents. [Bug: 2040]
     */

    Tcl_SetChannelOption(interp, chan, "-eofchar", "\32");

    /*
     * If the encoding is specified, set it for the channel. Else don't touch
     * it (and use the system encoding) Report error on unknown encoding.
     */

    if (encodingName != NULL) {
        if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
                != TCL_OK) {
            Tcl_Close(interp,chan);
            return result;
        }
    }

    objPtr = Tcl_NewObj();
    Tcl_IncrRefCount(objPtr);
    if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) {
        Tcl_Close(interp, chan);
        Tcl_AppendResult(interp, "couldn't read file \"",
                Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
        goto end;
    }

    if (Tcl_Close(interp, chan) != TCL_OK) {
        goto end;
    }

    iPtr = (Interp *) interp;
    oldScriptFile = iPtr->scriptFile;
    iPtr->scriptFile = pathPtr;
    Tcl_IncrRefCount(iPtr->scriptFile);
    string = Tcl_GetStringFromObj(objPtr, &length);
    /* TIP #280 Force the evaluator to open a frame for a sourced
     * file. */
    iPtr->evalFlags |= TCL_EVAL_FILE;
    result = Tcl_EvalEx(interp, string, length, 0);

    /*
     * Now we have to be careful; the script may have changed the
     * iPtr->scriptFile value, so we must reset it without assuming it still
     * points to 'pathPtr'.
     */

    if (iPtr->scriptFile != NULL) {
        Tcl_DecrRefCount(iPtr->scriptFile);
    }
    iPtr->scriptFile = oldScriptFile;

    if (result == TCL_RETURN) {
        result = TclUpdateReturnInfo(iPtr);
    } else if (result == TCL_ERROR) {
        /*
         * Record information telling where the error occurred.
         */

        const char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
        int limit = 150;
        int overflow = (length > limit);

        Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
                "\n    (file \"%.*s%s\" line %d)",
                (overflow ? limit : length), pathString,
                (overflow ? "..." : ""), interp->errorLine));
    }

  end:
    Tcl_DecrRefCount(objPtr);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetErrno --
 *
 *      Gets the current value of the Tcl error code variable. This is
 *      currently the global variable "errno" but could in the future change
 *      to something else.
 *
 * Results:
 *      The value of the Tcl error code variable.
 *
 * Side effects:
 *      None. Note that the value of the Tcl error code variable is UNDEFINED
 *      if a call to Tcl_SetErrno did not precede this call.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetErrno(void)
{
    return errno;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetErrno --
 *
 *      Sets the Tcl error code variable to the supplied value.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Modifies the value of the Tcl error code variable.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetErrno(
    int err)                    /* The new value. */
{
    errno = err;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PosixError --
 *
 *      This function is typically called after UNIX kernel calls return
 *      errors. It stores machine-readable information about the error in
 *      errorCode field of interp and returns an information string for the
 *      caller's use.
 *
 * Results:
 *      The return value is a human-readable string describing the error.
 *
 * Side effects:
 *      The errorCode field of the interp is set.
 *
 *----------------------------------------------------------------------
 */

const char *
Tcl_PosixError(
    Tcl_Interp *interp)         /* Interpreter whose errorCode field is to be
                                 * set. */
{
    const char *id, *msg;

    msg = Tcl_ErrnoMsg(errno);
    id = Tcl_ErrnoId();
    if (interp) {
        Tcl_SetErrorCode(interp, "POSIX", id, msg, NULL);
    }
    return msg;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSStat --
 *
 *      This function replaces the library version of stat and lsat.
 *
 *      The appropriate function for the filesystem to which pathPtr belongs
 *      will be called.
 *
 * Results:
 *      See stat documentation.
 *
 * Side effects:
 *      See stat documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSStat(
    Tcl_Obj *pathPtr,           /* Path of file to stat (in current CP). */
    Tcl_StatBuf *buf)           /* Filled with results of stat call. */
{
    const Tcl_Filesystem *fsPtr;
#ifdef USE_OBSOLETE_FS_HOOKS
    struct stat oldStyleStatBuffer;
    int retVal = -1;

    /*
     * Call each of the "stat" function in succession. A non-return value of
     * -1 indicates the particular function has succeeded.
     */

    Tcl_MutexLock(&obsoleteFsHookMutex);

    if (statProcList != NULL) {
        StatProc *statProcPtr;
        char *path;
        Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
        if (transPtr == NULL) {
            path = NULL;
        } else {
            path = Tcl_GetString(transPtr);
        }

        statProcPtr = statProcList;
        while ((retVal == -1) && (statProcPtr != NULL)) {
            retVal = (*statProcPtr->proc)(path, &oldStyleStatBuffer);
            statProcPtr = statProcPtr->nextPtr;
        }
        if (transPtr != NULL) {
            Tcl_DecrRefCount(transPtr);
        }
    }

    Tcl_MutexUnlock(&obsoleteFsHookMutex);
    if (retVal != -1) {
        /*
         * Note that EOVERFLOW is not a problem here, and these assignments
         * should all be widening (if not identity.)
         */

        buf->st_mode = oldStyleStatBuffer.st_mode;
        buf->st_ino = oldStyleStatBuffer.st_ino;
        buf->st_dev = oldStyleStatBuffer.st_dev;
        buf->st_rdev = oldStyleStatBuffer.st_rdev;
        buf->st_nlink = oldStyleStatBuffer.st_nlink;
        buf->st_uid = oldStyleStatBuffer.st_uid;
        buf->st_gid = oldStyleStatBuffer.st_gid;
        buf->st_size = Tcl_LongAsWide(oldStyleStatBuffer.st_size);
        buf->st_atime = oldStyleStatBuffer.st_atime;
        buf->st_mtime = oldStyleStatBuffer.st_mtime;
        buf->st_ctime = oldStyleStatBuffer.st_ctime;
#ifdef HAVE_ST_BLOCKS
        buf->st_blksize = oldStyleStatBuffer.st_blksize;
        buf->st_blocks = Tcl_LongAsWide(oldStyleStatBuffer.st_blocks);
#endif
        return retVal;
    }
#endif /* USE_OBSOLETE_FS_HOOKS */

    fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
        Tcl_FSStatProc *proc = fsPtr->statProc;
        if (proc != NULL) {
            return (*proc)(pathPtr, buf);
        }
    }
    Tcl_SetErrno(ENOENT);
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSLstat --
 *
 *      This function replaces the library version of lstat. The appropriate
 *      function for the filesystem to which pathPtr belongs will be called.
 *      If no 'lstat' function is listed, but a 'stat' function is, then Tcl
 *      will fall back on the stat function.
 *
 * Results:
 *      See lstat documentation.
 *
 * Side effects:
 *      See lstat documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSLstat(
    Tcl_Obj *pathPtr,           /* Path of file to stat (in current CP). */
    Tcl_StatBuf *buf)           /* Filled with results of stat call. */
{
    const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
        Tcl_FSLstatProc *proc = fsPtr->lstatProc;
        if (proc != NULL) {
            return (*proc)(pathPtr, buf);
        } else {
            Tcl_FSStatProc *sproc = fsPtr->statProc;
            if (sproc != NULL) {
                return (*sproc)(pathPtr, buf);
            }
        }
    }
    Tcl_SetErrno(ENOENT);
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSAccess --
 *
 *      This function replaces the library version of access. The appropriate
 *      function for the filesystem to which pathPtr belongs will be called.
 *
 * Results:
 *      See access documentation.
 *
 * Side effects:
 *      See access documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSAccess(
    Tcl_Obj *pathPtr,           /* Path of file to access (in current CP). */
    int mode)                   /* Permission setting. */
{
    const Tcl_Filesystem *fsPtr;
#ifdef USE_OBSOLETE_FS_HOOKS
    int retVal = -1;

    /*
     * Call each of the "access" function in succession. A non-return value of
     * -1 indicates the particular function has succeeded.
     */

    Tcl_MutexLock(&obsoleteFsHookMutex);

    if (accessProcList != NULL) {
        AccessProc *accessProcPtr;
        char *path;
        Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
        if (transPtr == NULL) {
            path = NULL;
        } else {
            path = Tcl_GetString(transPtr);
        }

        accessProcPtr = accessProcList;
        while ((retVal == -1) && (accessProcPtr != NULL)) {
            retVal = (*accessProcPtr->proc)(path, mode);
            accessProcPtr = accessProcPtr->nextPtr;
        }
        if (transPtr != NULL) {
            Tcl_DecrRefCount(transPtr);
        }
    }

    Tcl_MutexUnlock(&obsoleteFsHookMutex);
    if (retVal != -1) {
        return retVal;
    }
#endif /* USE_OBSOLETE_FS_HOOKS */

    fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
        Tcl_FSAccessProc *proc = fsPtr->accessProc;
        if (proc != NULL) {
            return (*proc)(pathPtr, mode);
        }
    }

    Tcl_SetErrno(ENOENT);
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSOpenFileChannel --
 *
 *      The appropriate function for the filesystem to which pathPtr belongs
 *      will be called.
 *
 * Results:
 *      The new channel or NULL, if the named file could not be opened.
 *
 * Side effects:
 *      May open the channel and may cause creation of a file on the file
 *      system.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
Tcl_FSOpenFileChannel(
    Tcl_Interp *interp,         /* Interpreter for error reporting; can be
                                 * NULL. */
    Tcl_Obj *pathPtr,           /* Name of file to open. */
    const char *modeString,     /* A list of POSIX open modes or a string such
                                 * as "rw". */
    int permissions)            /* If the open involves creating a file, with
                                 * what modes to create it? */
{
    const Tcl_Filesystem *fsPtr;
    Tcl_Channel retVal = NULL;

#ifdef USE_OBSOLETE_FS_HOOKS
    /*
     * Call each of the "Tcl_OpenFileChannel" functions in succession. A
     * non-NULL return value indicates the particular function has succeeded.
     */

    Tcl_MutexLock(&obsoleteFsHookMutex);
    if (openFileChannelProcList != NULL) {
        OpenFileChannelProc *openFileChannelProcPtr;
        char *path;
        Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);

        if (transPtr == NULL) {
            path = NULL;
        } else {
            path = Tcl_GetString(transPtr);
        }

        openFileChannelProcPtr = openFileChannelProcList;

        while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) {
            retVal = (*openFileChannelProcPtr->proc)(interp, path,
                    modeString, permissions);
            openFileChannelProcPtr = openFileChannelProcPtr->nextPtr;
        }
        if (transPtr != NULL) {
            Tcl_DecrRefCount(transPtr);
        }
    }
    Tcl_MutexUnlock(&obsoleteFsHookMutex);
    if (retVal != NULL) {
        return retVal;
    }
#endif /* USE_OBSOLETE_FS_HOOKS */

    /*
     * We need this just to ensure we return the correct error messages under
     * some circumstances.
     */

    if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
        return NULL;
    }

    fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
        Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc;
        if (proc != NULL) {
            int mode, seekFlag, binary;

            /*
             * Parse the mode, picking up whether we want to seek to start
             * with and/or set the channel automatically into binary mode.
             */

            mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary);
            if (mode == -1) {
                return NULL;
            }

            /*
             * Do the actual open() call.
             */

            retVal = (*proc)(interp, pathPtr, mode, permissions);
            if (retVal == NULL) {
                return NULL;
            }

            /*
             * Apply appropriate flags parsed out above.
             */

            if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt)0,
                    SEEK_END) < (Tcl_WideInt)0) {
                if (interp != NULL) {
                    Tcl_AppendResult(interp, "could not seek to end "
                            "of file while opening \"", Tcl_GetString(pathPtr),
                            "\": ", Tcl_PosixError(interp), NULL);
                }
                Tcl_Close(NULL, retVal);
                return NULL;
            }
            if (binary) {
                Tcl_SetChannelOption(interp, retVal, "-translation", "binary");
            }
            return retVal;
        }
    }

    /*
     * File doesn't belong to any filesystem that can open it.
     */

    Tcl_SetErrno(ENOENT);
    if (interp != NULL) {
        Tcl_AppendResult(interp, "couldn't open \"", Tcl_GetString(pathPtr),
                "\": ", Tcl_PosixError(interp), NULL);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSUtime --
 *
 *      This function replaces the library version of utime. The appropriate
 *      function for the filesystem to which pathPtr belongs will be called.
 *
 * Results:
 *      See utime documentation.
 *
 * Side effects:
 *      See utime documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSUtime(
    Tcl_Obj *pathPtr,           /* File to change access/modification times */
    struct utimbuf *tval)       /* Structure containing access/modification
                                 * times to use. Should not be modified. */
{
    const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
        Tcl_FSUtimeProc *proc = fsPtr->utimeProc;
        if (proc != NULL) {
            return (*proc)(pathPtr, tval);
        }
    }
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * NativeFileAttrStrings --
 *
 *      This function implements the platform dependent 'file attributes'
 *      subcommand, for the native filesystem, for listing the set of possible
 *      attribute strings. This function is part of Tcl's native filesystem
 *      support, and is placed here because it is shared by Unix and Windows
 *      code.
 *
 * Results:
 *      An array of strings
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

static const char **
NativeFileAttrStrings(
    Tcl_Obj *pathPtr,
    Tcl_Obj **objPtrRef)
{
    return tclpFileAttrStrings;
}

/*
 *----------------------------------------------------------------------
 *
 * NativeFileAttrsGet --
 *
 *      This function implements the platform dependent 'file attributes'
 *      subcommand, for the native filesystem, for 'get' operations. This
 *      function is part of Tcl's native filesystem support, and is placed
 *      here because it is shared by Unix and Windows code.
 *
 * Results:
 *      Standard Tcl return code. The object placed in objPtrRef (if TCL_OK
 *      was returned) is likely to have a refCount of zero. Either way we must
 *      either store it somewhere (e.g. the Tcl result), or Incr/Decr its
 *      refCount to ensure it is properly freed.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

static int
NativeFileAttrsGet(
    Tcl_Interp *interp,         /* The interpreter for error reporting. */
    int index,                  /* index of the attribute command. */
    Tcl_Obj *pathPtr,           /* path of file we are operating on. */
    Tcl_Obj **objPtrRef)        /* for output. */
{
    return (*tclpFileAttrProcs[index].getProc)(interp, index, pathPtr,
            objPtrRef);
}

/*
 *----------------------------------------------------------------------
 *
 * NativeFileAttrsSet --
 *
 *      This function implements the platform dependent 'file attributes'
 *      subcommand, for the native filesystem, for 'set' operations. This
 *      function is part of Tcl's native filesystem support, and is placed
 *      here because it is shared by Unix and Windows code.
 *
 * Results:
 *      Standard Tcl return code.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

static int
NativeFileAttrsSet(
    Tcl_Interp *interp,         /* The interpreter for error reporting. */
    int index,                  /* index of the attribute command. */
    Tcl_Obj *pathPtr,           /* path of file we are operating on. */
    Tcl_Obj *objPtr)            /* set to this value. */
{
    return (*tclpFileAttrProcs[index].setProc)(interp, index, pathPtr, objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSFileAttrStrings --
 *
 *      This function implements part of the hookable 'file attributes'
 *      subcommand. The appropriate function for the filesystem to which
 *      pathPtr belongs will be called.
 *
 * Results:
 *      The called function may either return an array of strings, or may
 *      instead return NULL and place a Tcl list into the given objPtrRef.
 *      Tcl will take that list and first increment its refCount before using
 *      it. On completion of that use, Tcl will decrement its refCount. Hence
 *      if the list should be disposed of by Tcl when done, it should have a
 *      refCount of zero, and if the list should not be disposed of, the
 *      filesystem should ensure it retains a refCount on the object.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

const char **
Tcl_FSFileAttrStrings(
    Tcl_Obj *pathPtr,
    Tcl_Obj **objPtrRef)
{
    const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);

    if (fsPtr != NULL) {
        Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc;
        if (proc != NULL) {
            return (*proc)(pathPtr, objPtrRef);
        }
    }
    Tcl_SetErrno(ENOENT);
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFSFileAttrIndex --
 *
 *      Helper function for converting an attribute name to an index into the
 *      attribute table.
 *
 * Results:
 *      Tcl result code, index written to *indexPtr on result==TCL_OK
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

int
TclFSFileAttrIndex(
    Tcl_Obj *pathPtr,           /* File whose attributes are to be indexed
                                 * into. */
    const char *attributeName,  /* The attribute being looked for. */
    int *indexPtr)              /* Where to write the found index. */
{
    Tcl_Obj *listObj = NULL;
    const char **attrTable;

    /*
     * Get the attribute table for the file.
     */

    attrTable = Tcl_FSFileAttrStrings(pathPtr, &listObj);
    if (listObj != NULL) {
        Tcl_IncrRefCount(listObj);
    }

    if (attrTable != NULL) {
        /*
         * It's a constant attribute table, so use T_GIFO.
         */

        Tcl_Obj *tmpObj = Tcl_NewStringObj(attributeName, -1);
        int result;

        result = Tcl_GetIndexFromObj(NULL, tmpObj, attrTable, NULL, TCL_EXACT,
                indexPtr);
        TclDecrRefCount(tmpObj);
        if (listObj != NULL) {
            TclDecrRefCount(listObj);
        }
        return result;
    } else if (listObj != NULL) {
        /*
         * It's a non-constant attribute list, so do a literal search.
         */

        int i, objc;
        Tcl_Obj **objv;

        if (Tcl_ListObjGetElements(NULL, listObj, &objc, &objv) != TCL_OK) {
            TclDecrRefCount(listObj);
            return TCL_ERROR;
        }
        for (i=0 ; i<objc ; i++) {
            if (!strcmp(attributeName, TclGetString(objv[i]))) {
                TclDecrRefCount(listObj);
                *indexPtr = i;
                return TCL_OK;
            }
        }
        TclDecrRefCount(listObj);
        return TCL_ERROR;
    } else {
        return TCL_ERROR;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSFileAttrsGet --
 *
 *      This function implements read access for the hookable 'file
 *      attributes' subcommand. The appropriate function for the filesystem to
 *      which pathPtr belongs will be called.
 *
 * Results:
 *      Standard Tcl return code. The object placed in objPtrRef (if TCL_OK
 *      was returned) is likely to have a refCount of zero. Either way we must
 *      either store it somewhere (e.g. the Tcl result), or Incr/Decr its
 *      refCount to ensure it is properly freed.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSFileAttrsGet(
    Tcl_Interp *interp,         /* The interpreter for error reporting. */
    int index,                  /* index of the attribute command. */
    Tcl_Obj *pathPtr,           /* filename we are operating on. */
    Tcl_Obj **objPtrRef)        /* for output. */
{
    const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);

    if (fsPtr != NULL) {
        Tcl_FSFileAttrsGetProc *proc = fsPtr->fileAttrsGetProc;
        if (proc != NULL) {
            return (*proc)(interp, index, pathPtr, objPtrRef);
        }
    }
    Tcl_SetErrno(ENOENT);
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSFileAttrsSet --
 *
 *      This function implements write access for the hookable 'file
 *      attributes' subcommand. The appropriate function for the filesystem to
 *      which pathPtr belongs will be called.
 *
 * Results:
 *      Standard Tcl return code.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSFileAttrsSet(
    Tcl_Interp *interp,         /* The interpreter for error reporting. */
    int index,                  /* index of the attribute command. */
    Tcl_Obj *pathPtr,           /* filename we are operating on. */
    Tcl_Obj *objPtr)            /* Input value. */
{
    const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);

    if (fsPtr != NULL) {
        Tcl_FSFileAttrsSetProc *proc = fsPtr->fileAttrsSetProc;
        if (proc != NULL) {
            return (*proc)(interp, index, pathPtr, objPtr);
        }
    }
    Tcl_SetErrno(ENOENT);
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSGetCwd --
 *
 *      This function replaces the library version of getcwd().
 *
 *      Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains its own
 *      record (in a Tcl_Obj) of the cwd, and an attempt is made to synch this
 *      with the cwd's containing filesystem, if that filesystem provides a
 *      cwdProc (e.g. the native filesystem).
 *
 *      Note that if Tcl's cwd is not in the native filesystem, then of course
 *      Tcl's cwd and the native cwd are different: extensions should
 *      therefore ensure they only access the cwd through this function to
 *      avoid confusion.
 *
 *      If a global cwdPathPtr already exists, it is cached in the thread's
 *      private data structures and reference to the cached copy is returned,
 *      subject to a synchronisation attempt in that cwdPathPtr's fs.
 *
 *      Otherwise, the chain of functions that have been "inserted" into the
 *      filesystem will be called in succession until either a value other
 *      than NULL is returned, or the entire list is visited.
 *
 * Results:
 *      The result is a pointer to a Tcl_Obj specifying the current directory,
 *      or NULL if the current directory could not be determined. If NULL is
 *      returned, an error message is left in the interp's result.
 *
 *      The result already has its refCount incremented for the caller. When
 *      it is no longer needed, that refCount should be decremented.
 *
 * Side effects:
 *      Various objects may be freed and allocated.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_FSGetCwd(
    Tcl_Interp *interp)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);

    if (TclFSCwdPointerEquals(NULL)) {
        FilesystemRecord *fsRecPtr;
        Tcl_Obj *retVal = NULL;

        /*
         * We've never been called before, try to find a cwd. Call each of the
         * "Tcl_GetCwd" function in succession. A non-NULL return value
         * indicates the particular function has succeeded.
         */

        fsRecPtr = FsGetFirstFilesystem();
        while ((retVal == NULL) && (fsRecPtr != NULL)) {
            Tcl_FSGetCwdProc *proc = fsRecPtr->fsPtr->getCwdProc;
            if (proc != NULL) {
                if (fsRecPtr->fsPtr->version != TCL_FILESYSTEM_VERSION_1) {
                    ClientData retCd;
                    TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc;

                    retCd = (*proc2)(NULL);
                    if (retCd != NULL) {
                        Tcl_Obj *norm;
                        /* Looks like a new current directory */
                        retVal = (*fsRecPtr->fsPtr->internalToNormalizedProc)(
                                retCd);
                        Tcl_IncrRefCount(retVal);
                        norm = TclFSNormalizeAbsolutePath(interp,retVal,NULL);
                        if (norm != NULL) {
                            /*
                             * We found a cwd, which is now in our global
                             * storage. We must make a copy. Norm already has
                             * a refCount of 1.
                             *
                             * Threading issue: note that multiple threads at
                             * system startup could in principle call this
                             * function simultaneously. They will therefore
                             * each set the cwdPathPtr independently. That
                             * behaviour is a bit peculiar, but should be
                             * fine. Once we have a cwd, we'll always be in
                             * the 'else' branch below which is simpler.
                             */

                            FsUpdateCwd(norm, retCd);
                            Tcl_DecrRefCount(norm);
                        } else {
                            (*fsRecPtr->fsPtr->freeInternalRepProc)(retCd);
                        }
                        Tcl_DecrRefCount(retVal);
                        retVal = NULL;
                        goto cdDidNotChange;
                    } else if (interp != NULL) {
                        Tcl_AppendResult(interp,
                                "error getting working directory name: ",
                                Tcl_PosixError(interp), NULL);
                    }
                } else {
                    retVal = (*proc)(interp);
                }
            }
            fsRecPtr = fsRecPtr->nextPtr;
        }

        /*
         * Now the 'cwd' may NOT be normalized, at least on some platforms.
         * For the sake of efficiency, we want a completely normalized cwd at
         * all times.
         *
         * Finally, if retVal is NULL, we do not have a cwd, which could be
         * problematic.
         */

        if (retVal != NULL) {
            Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL);
            if (norm != NULL) {
                /*
                 * We found a cwd, which is now in our global storage. We must
                 * make a copy. Norm already has a refCount of 1.
                 *
                 * Threading issue: note that multiple threads at system
                 * startup could in principle call this function
                 * simultaneously. They will therefore each set the cwdPathPtr
                 * independently. That behaviour is a bit peculiar, but should
                 * be fine. Once we have a cwd, we'll always be in the 'else'
                 * branch below which is simpler.
                 */

                ClientData cd = (ClientData) Tcl_FSGetNativePath(norm);
                FsUpdateCwd(norm, TclNativeDupInternalRep(cd));
                Tcl_DecrRefCount(norm);
            }
            Tcl_DecrRefCount(retVal);
        }
    } else {
        /*
         * We already have a cwd cached, but we want to give the filesystem it
         * is in a chance to check whether that cwd has changed, or is perhaps
         * no longer accessible. This allows an error to be thrown if, say,
         * the permissions on that directory have changed.
         */

        const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr);

        /*
         * If the filesystem couldn't be found, or if no cwd function exists
         * for this filesystem, then we simply assume the cached cwd is ok.
         * If we do call a cwd, we must watch for errors (if the cwd returns
         * NULL). This ensures that, say, on Unix if the permissions of the
         * cwd change, 'pwd' does actually throw the correct error in Tcl.
         * (This is tested for in the test suite on unix).
         */

        if (fsPtr != NULL) {
            Tcl_FSGetCwdProc *proc = fsPtr->getCwdProc;
            ClientData retCd = NULL;
            if (proc != NULL) {
                Tcl_Obj *retVal;
                if (fsPtr->version != TCL_FILESYSTEM_VERSION_1) {
                    TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc;

                    retCd = (*proc2)(tsdPtr->cwdClientData);
                    if (retCd == NULL && interp != NULL) {
                        Tcl_AppendResult(interp,
                                "error getting working directory name: ",
                                Tcl_PosixError(interp), NULL);
                    }

                    if (retCd == tsdPtr->cwdClientData) {
                        goto cdDidNotChange;
                    }

                    /*
                     * Looks like a new current directory.
                     */

                    retVal = (*fsPtr->internalToNormalizedProc)(retCd);
                    Tcl_IncrRefCount(retVal);
                } else {
                    retVal = (*proc)(interp);
                }
                if (retVal != NULL) {
                    Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp,
                            retVal, NULL);

                    /*
                     * Check whether cwd has changed from the value previously
                     * stored in cwdPathPtr. Really 'norm' shouldn't be NULL,
                     * but we are careful.
                     */

                    if (norm == NULL) {
                        /* Do nothing */
                        if (retCd != NULL) {
                            (*fsPtr->freeInternalRepProc)(retCd);
                        }
                    } else if (norm == tsdPtr->cwdPathPtr) {
                        goto cdEqual;
                    } else {
                        /*
                         * Note that both 'norm' and 'tsdPtr->cwdPathPtr' are
                         * normalized paths. Therefore we can be more
                         * efficient than calling 'Tcl_FSEqualPaths', and in
                         * addition avoid a nasty infinite loop bug when
                         * trying to normalize tsdPtr->cwdPathPtr.
                         */

                        int len1, len2;
                        char *str1, *str2;

                        str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1);
                        str2 = Tcl_GetStringFromObj(norm, &len2);
                        if ((len1 == len2) && (strcmp(str1, str2) == 0)) {
                            /*
                             * If the paths were equal, we can be more
                             * efficient and retain the old path object which
                             * will probably already be shared. In this case
                             * we can simply free the normalized path we just
                             * calculated.
                             */

                        cdEqual:
                            Tcl_DecrRefCount(norm);
                            if (retCd != NULL) {
                                (*fsPtr->freeInternalRepProc)(retCd);
                            }
                        } else {
                            FsUpdateCwd(norm, retCd);
                            Tcl_DecrRefCount(norm);
                        }
                    }
                    Tcl_DecrRefCount(retVal);
                } else {
                    /*
                     * The 'cwd' function returned an error; reset the cwd.
                     */

                    FsUpdateCwd(NULL, NULL);
                }
            }
        }
    }

  cdDidNotChange:
    if (tsdPtr->cwdPathPtr != NULL) {
        Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
    }

    return tsdPtr->cwdPathPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSChdir --
 *
 *      This function replaces the library version of chdir().
 *
 *      The path is normalized and then passed to the filesystem which claims
 *      it.
 *
 * Results:
 *      See chdir() documentation. If successful, we keep a record of the
 *      successful path in cwdPathPtr for subsequent calls to getcwd.
 *
 * Side effects:
 *      See chdir() documentation. The global cwdPathPtr may change value.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSChdir(
    Tcl_Obj *pathPtr)
{
    const Tcl_Filesystem *fsPtr;
    int retVal = -1;

    if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) {
        Tcl_SetErrno(ENOENT);
        return retVal;
    }

    fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
        Tcl_FSChdirProc *proc = fsPtr->chdirProc;
        if (proc != NULL) {
            /*
             * If this fails, an appropriate errno will have been stored using
             * 'Tcl_SetErrno()'.
             */

            retVal = (*proc)(pathPtr);
        } else {
            /*
             * Fallback on stat-based implementation.
             */

            Tcl_StatBuf buf;

            /*
             * If the file can be stat'ed and is a directory and is readable,
             * then we can chdir. If any of these actions fail, then
             * 'Tcl_SetErrno()' should automatically have been called to set
             * an appropriate error code
             */

            if ((Tcl_FSStat(pathPtr, &buf) == 0) && (S_ISDIR(buf.st_mode))
                    && (Tcl_FSAccess(pathPtr, R_OK) == 0)) {
                /*
                 * We allow the chdir.
                 */

                retVal = 0;
            }
        }
    } else {
        Tcl_SetErrno(ENOENT);
    }

    /*
     * The cwd changed, or an error was thrown. If an error was thrown, we can
     * just continue (and that will report the error to the user). If there
     * was no error we must assume that the cwd was actually changed to the
     * normalized value we calculated above, and we must therefore cache that
     * information.
     */

    /*
     * If the filesystem in question has a getCwdProc, then the correct logic
     * which performs the part below is already part of the Tcl_FSGetCwd()
     * call, so no need to replicate it again. This will have a side effect
     * though. The private authoritative representation of the current working
     * directory stored in cwdPathPtr in static memory will be out-of-sync
     * with the real OS-maintained value. The first call to Tcl_FSGetCwd will
     * however recalculate the private copy to match the OS-value so
     * everything will work right.
     *
     * However, if there is no getCwdProc, then we _must_ update our private
     * storage of the cwd, since this is the only opportunity to do that!
     *
     * Note: We currently call this block of code irrespective of whether
     * there was a getCwdProc or not, but the code should all in principle
     * work if we only call this block if fsPtr->getCwdProc == NULL.
     */

    if (retVal == 0) {
        /*
         * Note that this normalized path may be different to what we found
         * above (or at least a different object), if the filesystem epoch
         * changed recently. This can actually happen with scripted documents
         * very easily. Therefore we ask for the normalized path again (the
         * correct value will have been cached as a result of the
         * Tcl_FSGetFileSystemForPath call above anyway).
         */

        Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr);

        if (normDirName == NULL) {
            /* Not really true, but what else to do? */
            Tcl_SetErrno(ENOENT);
            return -1;
        }

        if (fsPtr == &tclNativeFilesystem) {
            /*
             * For the native filesystem, we keep a cache of the native
             * representation of the cwd. But, we want to do that for the
             * exact format that is returned by 'getcwd' (so that we can later
             * compare the two representations for equality), which might not
             * be exactly the same char-string as the native representation of
             * the fully normalized path (e.g. on Windows there's a
             * forward-slash vs backslash difference). Hence we ask for this
             * again here. On Unix it might actually be true that we always
             * have the correct form in the native rep in which case we could
             * simply use:
             *          cd = Tcl_FSGetNativePath(pathPtr);
             * instead. This should be examined by someone on Unix.
             */

            ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
            ClientData cd;
            ClientData oldcd = tsdPtr->cwdClientData;

            /*
             * Assumption we are using a filesystem version 2.
             */

            TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)fsPtr->getCwdProc;
            cd = (*proc2)(oldcd);
            if (cd != oldcd) {
                FsUpdateCwd(normDirName, cd);
            }
        } else {
            FsUpdateCwd(normDirName, NULL);
        }
    }

    return retVal;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSLoadFile --
 *
 *      Dynamically loads a binary code file into memory and returns the
 *      addresses of two functions within that file, if they are defined. The
 *      appropriate function for the filesystem to which pathPtr belongs will
 *      be called.
 *
 *      Note that the native filesystem doesn't actually assume 'pathPtr' is a
 *      path. Rather it assumes pathPtr is either a path or just the name
 *      (tail) of a file which can be found somewhere in the environment's
 *      loadable path. This behaviour is not very compatible with virtual
 *      filesystems (and has other problems documented in the load man-page),
 *      so it is advised that full paths are always used.
 *
 * Results:
 *      A standard Tcl completion code. If an error occurs, an error message
 *      is left in the interp's result.
 *
 * Side effects:
 *      New code suddenly appears in memory. This may later be unloaded by
 *      passing the clientData to the unloadProc.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSLoadFile(
    Tcl_Interp *interp,         /* Used for error reporting. */
    Tcl_Obj *pathPtr,           /* Name of the file containing the desired
                                 * code. */
    const char *sym1, const char *sym2,
                                /* Names of two functions to look up in the
                                 * file's symbol table. */
    Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr,
                                /* Where to return the addresses corresponding
                                 * to sym1 and sym2. */
    Tcl_LoadHandle *handlePtr,  /* Filled with token for dynamically loaded
                                 * file which will be passed back to
                                 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr)
                                /* Filled with address of Tcl_FSUnloadFileProc
                                 * function which should be used for this
                                 * file. */
{
    const char *symbols[2];
    Tcl_PackageInitProc **procPtrs[2];
    ClientData clientData;
    int res;

    /*
     * Initialize the arrays.
     */

    symbols[0] = sym1;
    symbols[1] = sym2;
    procPtrs[0] = proc1Ptr;
    procPtrs[1] = proc2Ptr;

    /*
     * Perform the load.
     */

    res = TclLoadFile(interp, pathPtr, 2, symbols, procPtrs, handlePtr,
            &clientData, unloadProcPtr);

    /*
     * Due to an unfortunate mis-design in Tcl 8.4 fs, when loading a shared
     * library, we don't keep the loadHandle (for TclpFindSymbol) and the
     * clientData (for the unloadProc) separately. In fact we effectively
     * throw away the loadHandle and only use the clientData. It just so
     * happens, for the native filesystem only, that these two are identical.
     *
     * This also means that the signatures Tcl_FSUnloadFileProc and
     * Tcl_FSLoadFileProc are both misleading.
     */

    *handlePtr = (Tcl_LoadHandle) clientData;
    return res;
}

/*
 *----------------------------------------------------------------------
 *
 * TclLoadFile --
 *
 *      Dynamically loads a binary code file into memory and returns the
 *      addresses of a number of given functions within that file, if they are
 *      defined. The appropriate function for the filesystem to which pathPtr
 *      belongs will be called.
 *
 *      Note that the native filesystem doesn't actually assume 'pathPtr' is a
 *      path. Rather it assumes pathPtr is either a path or just the name
 *      (tail) of a file which can be found somewhere in the environment's
 *      loadable path. This behaviour is not very compatible with virtual
 *      filesystems (and has other problems documented in the load man-page),
 *      so it is advised that full paths are always used.
 *
 *      This function is currently private to Tcl. It may be exported in the
 *      future and its interface fixed (but we should clean up the
 *      loadHandle/clientData confusion at that time -- see the above comments
 *      in Tcl_FSLoadFile for details). For a public function, see
 *      Tcl_FSLoadFile.
 *
 * Results:
 *      A standard Tcl completion code. If an error occurs, an error message
 *      is left in the interp's result.
 *
 * Side effects:
 *      New code suddenly appears in memory. This may later be unloaded by
 *      passing the clientData to the unloadProc.
 *
 *----------------------------------------------------------------------
 */

int
TclLoadFile(
    Tcl_Interp *interp,         /* Used for error reporting. */
    Tcl_Obj *pathPtr,           /* Name of the file containing the desired
                                 * code. */
    int symc,                   /* Number of symbols/procPtrs in the next two
                                 * arrays. */
    const char *symbols[],      /* Names of functions to look up in the file's
                                 * symbol table. */
    Tcl_PackageInitProc **procPtrs[],
                                /* Where to return the addresses corresponding
                                 * to symbols[]. */
    Tcl_LoadHandle *handlePtr,  /* Filled with token for shared library
                                 * information which can be used in
                                 * TclpFindSymbol. */
    ClientData *clientDataPtr,  /* Filled with token for dynamically loaded
                                 * file which will be passed back to
                                 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr)
                                /* Filled with address of Tcl_FSUnloadFileProc
                                 * function which should be used for this
                                 * file. */
{
    const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    Tcl_FSLoadFileProc *proc;
    Tcl_Filesystem *copyFsPtr;
    Tcl_Obj *copyToPtr;
    Tcl_LoadHandle newLoadHandle = NULL;
    ClientData newClientData = NULL;
    Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL;
    FsDivertLoad *tvdlPtr;
    int retVal;

    if (fsPtr == NULL) {
        Tcl_SetErrno(ENOENT);
        return TCL_ERROR;
    }

    proc = fsPtr->loadFileProc;
    if (proc != NULL) {
        int retVal = (*proc)(interp, pathPtr, handlePtr, unloadProcPtr);
        if (retVal == TCL_OK) {
            if (*handlePtr == NULL) {
                return TCL_ERROR;
            }

            /*
             * Copy this across, since both are equal for the native fs.
             */

            *clientDataPtr = (ClientData)*handlePtr;
            Tcl_ResetResult(interp);
            goto resolveSymbols;
        }
        if (Tcl_GetErrno() != EXDEV) {
            return retVal;
        }
    }

    /*
     * The filesystem doesn't support 'load', so we fall back on the following
     * technique:
     *
     * First check if it is readable -- and exists!
     */

    if (Tcl_FSAccess(pathPtr, R_OK) != 0) {
        Tcl_AppendResult(interp, "couldn't load library \"",
                Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
        return TCL_ERROR;
    }

#ifdef TCL_LOAD_FROM_MEMORY
    /*
     * The platform supports loading code from memory, so ask for a buffer of
     * the appropriate size, read the file into it and load the code from the
     * buffer:
     */

    {
        int ret, size;
        void *buffer;
        Tcl_StatBuf statBuf;
        Tcl_Channel data;

        ret = Tcl_FSStat(pathPtr, &statBuf);
        if (ret < 0) {
            goto mustCopyToTempAnyway;
        }
        size = (int) statBuf.st_size;

        /*
         * Tcl_Read takes an int: check that file size isn't wide.
         */

        if (size != (Tcl_WideInt) statBuf.st_size) {
            goto mustCopyToTempAnyway;
        }
        data = Tcl_FSOpenFileChannel(interp, pathPtr, "rb", 0666);
        if (!data) {
            goto mustCopyToTempAnyway;
        }
        buffer = TclpLoadMemoryGetBuffer(interp, size);
        if (!buffer) {
            Tcl_Close(interp, data);
            goto mustCopyToTempAnyway;
        }
        ret = Tcl_Read(data, buffer, size);
        Tcl_Close(interp, data);
        ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr,
                unloadProcPtr);
        if (ret == TCL_OK && *handlePtr != NULL) {
            *clientDataPtr = (ClientData) *handlePtr;
            goto resolveSymbols;
        }
    }

  mustCopyToTempAnyway:
    Tcl_ResetResult(interp);
#endif

    /*
     * Get a temporary filename to use, first to copy the file into, and then
     * to load.
     */

    copyToPtr = TclpTempFileName();
    if (copyToPtr == NULL) {
        Tcl_AppendResult(interp, "couldn't create temporary file: ",
                Tcl_PosixError(interp), NULL);
        return TCL_ERROR;
    }
    Tcl_IncrRefCount(copyToPtr);

    copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr);
    if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) {
        /*
         * We already know we can't use Tcl_FSLoadFile from this filesystem,
         * and we must avoid a possible infinite loop. Try to delete the file
         * we probably created, and then exit.
         */

        Tcl_FSDeleteFile(copyToPtr);
        Tcl_DecrRefCount(copyToPtr);
        Tcl_AppendResult(interp, "couldn't load from current filesystem",NULL);
        return TCL_ERROR;
    }

    if (TclCrossFilesystemCopy(interp, pathPtr, copyToPtr) != TCL_OK) {
        /*
         * Cross-platform copy failed.
         */

        Tcl_FSDeleteFile(copyToPtr);
        Tcl_DecrRefCount(copyToPtr);
        return TCL_ERROR;
    }

#if !defined(__WIN32__)
    /*
     * Do we need to set appropriate permissions on the file? This may be
     * required on some systems. On Unix we could loop over the file
     * attributes, and set any that are called "-permissions" to 0700. However
     * we just do this directly, like this:
     */

    {
        int index;
        Tcl_Obj *perm;

        TclNewLiteralStringObj(perm, "0700");
        Tcl_IncrRefCount(perm);
        if (TclFSFileAttrIndex(copyToPtr, "-permissions", &index) == TCL_OK) {
            Tcl_FSFileAttrsSet(NULL, index, copyToPtr, perm);
        }
        Tcl_DecrRefCount(perm);
    }
#endif

    /*
     * We need to reset the result now, because the cross-filesystem copy may
     * have stored the number of bytes in the result.
     */

    Tcl_ResetResult(interp);

    retVal = TclLoadFile(interp, copyToPtr, symc, symbols, procPtrs,
            &newLoadHandle, &newClientData, &newUnloadProcPtr);
    if (retVal != TCL_OK) {
        /*
         * The file didn't load successfully.
         */

        Tcl_FSDeleteFile(copyToPtr);
        Tcl_DecrRefCount(copyToPtr);
        return retVal;
    }

    /*
     * Try to delete the file immediately - this is possible in some OSes, and
     * avoids any worries about leaving the copy laying around on exit.
     */

    if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) {
        Tcl_DecrRefCount(copyToPtr);

        /*
         * We tell our caller about the real shared library which was loaded.
         * Note that this does mean that the package list maintained by 'load'
         * will store the original (vfs) path alongside the temporary load
         * handle and unload proc ptr.
         */

        (*handlePtr) = newLoadHandle;
        (*clientDataPtr) = newClientData;
        (*unloadProcPtr) = newUnloadProcPtr;
        Tcl_ResetResult(interp);
        return TCL_OK;
    }

    /*
     * When we unload this file, we need to divert the unloading so we can
     * unload and cleanup the temporary file correctly.
     */

    tvdlPtr = (FsDivertLoad *) ckalloc(sizeof(FsDivertLoad));

    /*
     * Remember three pieces of information. This allows us to cleanup the
     * diverted load completely, on platforms which allow proper unloading of
     * code.
     */

    tvdlPtr->loadHandle = newLoadHandle;
    tvdlPtr->unloadProcPtr = newUnloadProcPtr;

    if (copyFsPtr != &tclNativeFilesystem) {
        /*
         * copyToPtr is already incremented for this reference.
         */

        tvdlPtr->divertedFile = copyToPtr;

        /*
         * This is the filesystem we loaded it into. Since we have a reference
         * to 'copyToPtr', we already have a refCount on this filesystem, so
         * we don't need to worry about it disappearing on us.
         */

        tvdlPtr->divertedFilesystem = copyFsPtr;
        tvdlPtr->divertedFileNativeRep = NULL;
    } else {
        /*
         * We need the native rep.
         */

        tvdlPtr->divertedFileNativeRep = TclNativeDupInternalRep(
                Tcl_FSGetInternalRep(copyToPtr, copyFsPtr));

        /*
         * We don't need or want references to the copied Tcl_Obj or the
         * filesystem if it is the native one.
         */

        tvdlPtr->divertedFile = NULL;
        tvdlPtr->divertedFilesystem = NULL;
        Tcl_DecrRefCount(copyToPtr);
    }

    copyToPtr = NULL;
    (*handlePtr) = newLoadHandle;
    (*clientDataPtr) = (ClientData) tvdlPtr;
    (*unloadProcPtr) = &FSUnloadTempFile;

    Tcl_ResetResult(interp);
    return retVal;

  resolveSymbols:
    {
        int i;

        for (i=0 ; i<symc ; i++) {
            if (symbols[i] != NULL) {
                *procPtrs[i] = TclpFindSymbol(interp, *handlePtr, symbols[i]);
            }
        }
    }
    return TCL_OK;
}
/*
 * This function used to be in the platform specific directories, but it has
 * now been made to work cross-platform
 */

int
TclpLoadFile(
    Tcl_Interp *interp,         /* Used for error reporting. */
    Tcl_Obj *pathPtr,           /* Name of the file containing the desired
                                 * code (UTF-8). */
    const char *sym1, CONST char *sym2,
                                /* Names of two functions to look up in the
                                 * file's symbol table. */
    Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr,
                                /* Where to return the addresses corresponding
                                 * to sym1 and sym2. */
    ClientData *clientDataPtr,  /* Filled with token for dynamically loaded
                                 * file which will be passed back to
                                 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr)
                                /* Filled with address of Tcl_FSUnloadFileProc
                                 * function which should be used for this
                                 * file. */
{
    Tcl_LoadHandle handle = NULL;
    int res;

    res = TclpDlopen(interp, pathPtr, &handle, unloadProcPtr);

    if (res != TCL_OK) {
        return res;
    }

    if (handle == NULL) {
        return TCL_ERROR;
    }

    *clientDataPtr = (ClientData) handle;

    *proc1Ptr = TclpFindSymbol(interp, handle, sym1);
    *proc2Ptr = TclpFindSymbol(interp, handle, sym2);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * FSUnloadTempFile --
 *
 *      This function is called when we loaded a library of code via an
 *      intermediate temporary file. This function ensures the library is
 *      correctly unloaded and the temporary file is correctly deleted.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      The effects of the 'unload' function called, and of course the
 *      temporary file will be deleted.
 *
 *---------------------------------------------------------------------------
 */

static void
FSUnloadTempFile(
    Tcl_LoadHandle loadHandle)  /* loadHandle returned by a previous call to
                                 * Tcl_FSLoadFile(). The loadHandle is a token
                                 * that represents the loaded file. */
{
    FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle;

    /*
     * This test should never trigger, since we give the client data in the
     * function above.
     */

    if (tvdlPtr == NULL) {
        return;
    }

    /*
     * Call the real 'unloadfile' proc we actually used. It is very important
     * that we call this first, so that the shared library is actually
     * unloaded by the OS. Otherwise, the following 'delete' may well fail
     * because the shared library is still in use.
     */

    if (tvdlPtr->unloadProcPtr != NULL) {
        (*tvdlPtr->unloadProcPtr)(tvdlPtr->loadHandle);
    }

    if (tvdlPtr->divertedFilesystem == NULL) {
        /*
         * It was the native filesystem, and we have a special function
         * available just for this purpose, which we know works even at this
         * late stage.
         */

        TclpDeleteFile(tvdlPtr->divertedFileNativeRep);
        NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep);

    } else {
        /*
         * Remove the temporary file we created. Note, we may crash here
         * because encodings have been taken down already.
         */

        if (tvdlPtr->divertedFilesystem->deleteFileProc(tvdlPtr->divertedFile)
                != TCL_OK) {
            /*
             * The above may have failed because the filesystem, or something
             * it depends upon (e.g. encodings) have been taken down because
             * Tcl is exiting.
             *
             * We may need to work out how to delete this file more robustly
             * (or give the filesystem the information it needs to delete the
             * file more robustly).
             *
             * In particular, one problem might be that the filesystem cannot
             * extract the information it needs from the above path object
             * because Tcl's entire filesystem apparatus (the code in this
             * file) has been finalized, and it refuses to pass the internal
             * representation to the filesystem.
             */
        }

        /*
         * And free up the allocations. This will also of course remove a
         * refCount from the Tcl_Filesystem to which this file belongs, which
         * could then free up the filesystem if we are exiting.
         */

        Tcl_DecrRefCount(tvdlPtr->divertedFile);
    }

    ckfree((char*)tvdlPtr);
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSLink --
 *
 *      This function replaces the library version of readlink() and can also
 *      be used to make links. The appropriate function for the filesystem to
 *      which pathPtr belongs will be called.
 *
 * Results:
 *      If toPtr is NULL, then the result is a Tcl_Obj specifying the contents
 *      of the symbolic link given by 'pathPtr', or NULL if the symbolic link
 *      could not be read. The result is owned by the caller, which should
 *      call Tcl_DecrRefCount when the result is no longer needed.
 *
 *      If toPtr is non-NULL, then the result is toPtr if the link action was
 *      successful, or NULL if not. In this case the result has no additional
 *      reference count, and need not be freed. The actual action to perform
 *      is given by the 'linkAction' flags, which is an or'd combination of:
 *
 *              TCL_CREATE_SYMBOLIC_LINK
 *              TCL_CREATE_HARD_LINK
 *
 *      Note that most filesystems will not support linking across to
 *      different filesystems, so this function will usually fail unless toPtr
 *      is in the same FS as pathPtr.
 *
 * Side effects:
 *      See readlink() documentation. A new filesystem link object may appear.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_FSLink(
    Tcl_Obj *pathPtr,           /* Path of file to readlink or link */
    Tcl_Obj *toPtr,             /* NULL or path to be linked to */
    int linkAction)             /* Action to perform */
{
    const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);

    if (fsPtr != NULL) {
        Tcl_FSLinkProc *proc = fsPtr->linkProc;

        if (proc != NULL) {
            return (*proc)(pathPtr, toPtr, linkAction);
        }
    }

    /*
     * If S_IFLNK isn't defined it means that the machine doesn't support
     * symbolic links, so the file can't possibly be a symbolic link. Generate
     * an EINVAL error, which is what happens on machines that do support
     * symbolic links when you invoke readlink on a file that isn't a symbolic
     * link.
     */

#ifndef S_IFLNK
    errno = EINVAL;
#else
    Tcl_SetErrno(ENOENT);
#endif /* S_IFLNK */
    return NULL;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSListVolumes --
 *
 *      Lists the currently mounted volumes. The chain of functions that have
 *      been "inserted" into the filesystem will be called in succession; each
 *      may return a list of volumes, all of which are added to the result
 *      until all mounted file systems are listed.
 *
 *      Notice that we assume the lists returned by each filesystem (if non
 *      NULL) have been given a refCount for us already. However, we are NOT
 *      allowed to hang on to the list itself (it belongs to the filesystem we
 *      called). Therefore we quite naturally add its contents to the result
 *      we are building, and then decrement the refCount.
 *
 * Results:
 *      The list of volumes, in an object which has refCount 0.
 *
 * Side effects:
 *      None
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
Tcl_FSListVolumes(void)
{
    FilesystemRecord *fsRecPtr;
    Tcl_Obj *resultPtr = Tcl_NewObj();

    /*
     * Call each of the "listVolumes" function in succession. A non-NULL
     * return value indicates the particular function has succeeded. We call
     * all the functions registered, since we want a list of all drives from
     * all filesystems.
     */

    fsRecPtr = FsGetFirstFilesystem();
    while (fsRecPtr != NULL) {
        Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc;
        if (proc != NULL) {
            Tcl_Obj *thisFsVolumes = (*proc)();
            if (thisFsVolumes != NULL) {
                Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes);
                Tcl_DecrRefCount(thisFsVolumes);
            }
        }
        fsRecPtr = fsRecPtr->nextPtr;
    }

    return resultPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * FsListMounts --
 *
 *      List all mounts within the given directory, which match the given
 *      pattern.
 *
 * Results:
 *      The list of mounts, in a list object which has refCount 0, or NULL if
 *      we didn't even find any filesystems to try to list mounts.
 *
 * Side effects:
 *      None
 *
 *---------------------------------------------------------------------------
 */

static Tcl_Obj *
FsListMounts(
    Tcl_Obj *pathPtr,           /* Contains path to directory to search. */
    const char *pattern)        /* Pattern to match against. */
{
    FilesystemRecord *fsRecPtr;
    Tcl_GlobTypeData mountsOnly = { TCL_GLOB_TYPE_MOUNT, 0, NULL, NULL };
    Tcl_Obj *resultPtr = NULL;

    /*
     * Call each of the "matchInDirectory" functions in succession, with the
     * specific type information 'mountsOnly'. A non-NULL return value
     * indicates the particular function has succeeded. We call all the
     * functions registered, since we want a list from each filesystems.
     */

    fsRecPtr = FsGetFirstFilesystem();
    while (fsRecPtr != NULL) {
        if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
            Tcl_FSMatchInDirectoryProc *proc =
                    fsRecPtr->fsPtr->matchInDirectoryProc;
            if (proc != NULL) {
                if (resultPtr == NULL) {
                    resultPtr = Tcl_NewObj();
                }
                (*proc)(NULL, resultPtr, pathPtr, pattern, &mountsOnly);
            }
        }
        fsRecPtr = fsRecPtr->nextPtr;
    }

    return resultPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSSplitPath --
 *
 *      This function takes the given Tcl_Obj, which should be a valid path,
 *      and returns a Tcl List object containing each segment of that path as
 *      an element.
 *
 * Results:
 *      Returns list object with refCount of zero. If the passed in lenPtr is
 *      non-NULL, we use it to return the number of elements in the returned
 *      list.
 *
 * Side effects:
 *      None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_FSSplitPath(
    Tcl_Obj *pathPtr,           /* Path to split. */
    int *lenPtr)                /* int to store number of path elements. */
{
    Tcl_Obj *result = NULL;     /* Needed only to prevent gcc warnings. */
    Tcl_Filesystem *fsPtr;
    char separator = '/';
    int driveNameLength;
    char *p;

    /*
     * Perform platform specific splitting.
     */

    if (TclFSGetPathType(pathPtr, &fsPtr,
            &driveNameLength) == TCL_PATH_ABSOLUTE) {
        if (fsPtr == &tclNativeFilesystem) {
            return TclpNativeSplitPath(pathPtr, lenPtr);
        }
    } else {
        return TclpNativeSplitPath(pathPtr, lenPtr);
    }

    /*
     * We assume separators are single characters.
     */

    if (fsPtr->filesystemSeparatorProc != NULL) {
        Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(pathPtr);
        if (sep != NULL) {
            Tcl_IncrRefCount(sep);
            separator = Tcl_GetString(sep)[0];
            Tcl_DecrRefCount(sep);
        }
    }

    /*
     * Place the drive name as first element of the result list. The drive
     * name may contain strange characters, like colons and multiple forward
     * slashes (for example 'ftp://' is a valid vfs drive name)
     */

    result = Tcl_NewObj();
    p = Tcl_GetString(pathPtr);
    Tcl_ListObjAppendElement(NULL, result,
            Tcl_NewStringObj(p, driveNameLength));
    p += driveNameLength;

    /*
     * Add the remaining path elements to the list.
     */

    for (;;) {
        char *elementStart = p;
        int length;
        while ((*p != '\0') && (*p != separator)) {
            p++;
        }
        length = p - elementStart;
        if (length > 0) {
            Tcl_Obj *nextElt;
            if (elementStart[0] == '~') {
                TclNewLiteralStringObj(nextElt, "./");
                Tcl_AppendToObj(nextElt, elementStart, length);
            } else {
                nextElt = Tcl_NewStringObj(elementStart, length);
            }
            Tcl_ListObjAppendElement(NULL, result, nextElt);
        }
        if (*p++ == '\0') {
            break;
        }
    }

    /*
     * Compute the number of elements in the result.
     */

    if (lenPtr != NULL) {
        TclListObjLength(NULL, result, lenPtr);
    }
    return result;
}

/* Simple helper function */
Tcl_Obj *
TclFSInternalToNormalized(
    Tcl_Filesystem *fromFilesystem,
    ClientData clientData,
    FilesystemRecord **fsRecPtrPtr)
{
    FilesystemRecord *fsRecPtr = FsGetFirstFilesystem();

    while (fsRecPtr != NULL) {
        if (fsRecPtr->fsPtr == fromFilesystem) {
            *fsRecPtrPtr = fsRecPtr;
            break;
        }
        fsRecPtr = fsRecPtr->nextPtr;
    }

    if ((fsRecPtr != NULL)
            && (fromFilesystem->internalToNormalizedProc != NULL)) {
        return (*fromFilesystem->internalToNormalizedProc)(clientData);
    } else {
        return NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetPathType --
 *
 *      Helper function used by FSGetPathType.
 *
 * Results:
 *      Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
 *      TCL_PATH_VOLUME_RELATIVE. The filesystem reference will be set if and
 *      only if it is non-NULL and the function's return value is
 *      TCL_PATH_ABSOLUTE.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

Tcl_PathType
TclGetPathType(
    Tcl_Obj *pathPtr,           /* Path to determine type for */
    Tcl_Filesystem **filesystemPtrPtr,
                                /* If absolute path and this is not NULL, then
                                 * set to the filesystem which claims this
                                 * path. */
    int *driveNameLengthPtr,    /* If the path is absolute, and this is
                                 * non-NULL, then set to the length of the
                                 * driveName. */
    Tcl_Obj **driveNameRef)     /* If the path is absolute, and this is
                                 * non-NULL, then set to the name of the
                                 * drive, network-volume which contains the
                                 * path, already with a refCount for the
                                 * caller. */
{
    int pathLen;
    char *path;
    Tcl_PathType type;

    path = Tcl_GetStringFromObj(pathPtr, &pathLen);

    type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr,
            driveNameLengthPtr, driveNameRef);

    if (type != TCL_PATH_ABSOLUTE) {
        type = TclpGetNativePathType(pathPtr, driveNameLengthPtr,
                driveNameRef);
        if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) {
            *filesystemPtrPtr = &tclNativeFilesystem;
        }
    }
    return type;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFSNonnativePathType --
 *
 *      Helper function used by TclGetPathType. Its purpose is to check
 *      whether the given path starts with a string which corresponds to a
 *      file volume in any registered filesystem except the native one. For
 *      speed and historical reasons the native filesystem has special
 *      hard-coded checks dotted here and there in the filesystem code.
 *
 * Results:
 *      Returns one of TCL_PATH_ABSOLUTE or TCL_PATH_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
TclFSNonnativePathType(
    const char *path,           /* Path to determine type for */
    int pathLen,                /* Length of the path */
    Tcl_Filesystem **filesystemPtrPtr,
                                /* If absolute path and this is not NULL, then
                                 * set to the filesystem which claims this
                                 * path. */
    int *driveNameLengthPtr,    /* If the path is absolute, and this is
                                 * non-NULL, then set to the length of the
                                 * driveName. */
    Tcl_Obj **driveNameRef)     /* If the path is absolute, and this is
                                 * non-NULL, then set to the name of the
                                 * drive, network-volume which contains the
                                 * path, already with a refCount for the
                                 * caller. */
{
    FilesystemRecord *fsRecPtr;
    Tcl_PathType type = TCL_PATH_RELATIVE;

    /*
     * Call each of the "listVolumes" function in succession, checking whether
     * the given path is an absolute path on any of the volumes returned (this
     * is done by checking whether the path's prefix matches).
     */

    fsRecPtr = FsGetFirstFilesystem();
    while (fsRecPtr != NULL) {
        Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc;

        /*
         * We want to skip the native filesystem in this loop because
         * otherwise we won't necessarily pass all the Tcl testsuite -- this
         * is because some of the tests artificially change the current
         * platform (between win, unix) but the list of volumes we get by
         * calling (*proc) will reflect the current (real) platform only and
         * this may cause some tests to fail. In particular, on unix '/' will
         * match the beginning of certain absolute Windows paths starting '//'
         * and those tests will go wrong.
         *
         * Besides these test-suite issues, there is one other reason to skip
         * the native filesystem --- since the tclFilename.c code has nice
         * fast 'absolute path' checkers, we don't want to waste time
         * repeating that effort here, and this function is actually called
         * quite often, so if we can save the overhead of the native
         * filesystem returning us a list of volumes all the time, it is
         * better.
         */

        if ((fsRecPtr->fsPtr != &tclNativeFilesystem) && (proc != NULL)) {
            int numVolumes;
            Tcl_Obj *thisFsVolumes = (*proc)();

            if (thisFsVolumes != NULL) {
                if (Tcl_ListObjLength(NULL, thisFsVolumes, &numVolumes)
                        != TCL_OK) {
                    /*
                     * This is VERY bad; the Tcl_FSListVolumesProc didn't
                     * return a valid list. Set numVolumes to -1 so that we
                     * skip the while loop below and just return with the
                     * current value of 'type'.
                     *
                     * It would be better if we could signal an error here
                     * (but Tcl_Panic seems a bit excessive).
                     */

                    numVolumes = -1;
                }
                while (numVolumes > 0) {
                    Tcl_Obj *vol;
                    int len;
                    char *strVol;

                    numVolumes--;
                    Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol);
                    strVol = Tcl_GetStringFromObj(vol,&len);
                    if (pathLen < len) {
                        continue;
                    }
                    if (strncmp(strVol, path, (size_t) len) == 0) {
                        type = TCL_PATH_ABSOLUTE;
                        if (filesystemPtrPtr != NULL) {
                            *filesystemPtrPtr = fsRecPtr->fsPtr;
                        }
                        if (driveNameLengthPtr != NULL) {
                            *driveNameLengthPtr = len;
                        }
                        if (driveNameRef != NULL) {
                            *driveNameRef = vol;
                            Tcl_IncrRefCount(vol);
                        }
                        break;
                    }
                }
                Tcl_DecrRefCount(thisFsVolumes);
                if (type == TCL_PATH_ABSOLUTE) {
                    /*
                     * We don't need to examine any more filesystems.
                     */
                    break;
                }
            }
        }
        fsRecPtr = fsRecPtr->nextPtr;
    }
    return type;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSRenameFile --
 *
 *      If the two paths given belong to the same filesystem, we call that
 *      filesystems rename function. Otherwise we simply return the POSIX
 *      error 'EXDEV', and -1.
 *
 * Results:
 *      Standard Tcl error code if a function was called.
 *
 * Side effects:
 *      A file may be renamed.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_FSRenameFile(
    Tcl_Obj* srcPathPtr,        /* Pathname of file or dir to be renamed
                                 * (UTF-8). */
    Tcl_Obj *destPathPtr)       /* New pathname of file or directory
                                 * (UTF-8). */
{
    int retVal = -1;
    const Tcl_Filesystem *fsPtr, *fsPtr2;
    fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
    fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);

    if ((fsPtr == fsPtr2) && (fsPtr != NULL)) {
        Tcl_FSRenameFileProc *proc = fsPtr->renameFileProc;
        if (proc != NULL) {
            retVal = (*proc)(srcPathPtr, destPathPtr);
        }
    }
    if (retVal == -1) {
        Tcl_SetErrno(EXDEV);
    }
    return retVal;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSCopyFile --
 *
 *      If the two paths given belong to the same filesystem, we call that
 *      filesystem's copy function. Otherwise we simply return the POSIX error
 *      'EXDEV', and -1.
 *
 *      Note that in the native filesystems, 'copyFileProc' is defined to copy
 *      soft links (i.e. it copies the links themselves, not the things they
 *      point to).
 *
 * Results:
 *      Standard Tcl error code if a function was called.
 *
 * Side effects:
 *      A file may be copied.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_FSCopyFile(
    Tcl_Obj *srcPathPtr,        /* Pathname of file to be copied (UTF-8). */
    Tcl_Obj *destPathPtr)       /* Pathname of file to copy to (UTF-8). */
{
    int retVal = -1;
    const Tcl_Filesystem *fsPtr, *fsPtr2;
    fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
    fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);

    if (fsPtr == fsPtr2 && fsPtr != NULL) {
        Tcl_FSCopyFileProc *proc = fsPtr->copyFileProc;
        if (proc != NULL) {
            retVal = (*proc)(srcPathPtr, destPathPtr);
        }
    }
    if (retVal == -1) {
        Tcl_SetErrno(EXDEV);
    }
    return retVal;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclCrossFilesystemCopy --
 *
 *      Helper for above function, and for Tcl_FSLoadFile, to copy files from
 *      one filesystem to another. This function will overwrite the target
 *      file if it already exists.
 *
 * Results:
 *      Standard Tcl error code.
 *
 * Side effects:
 *      A file may be created.
 *
 *---------------------------------------------------------------------------
 */
int
TclCrossFilesystemCopy(
    Tcl_Interp *interp,         /* For error messages */
    Tcl_Obj *source,            /* Pathname of file to be copied (UTF-8). */
    Tcl_Obj *target)            /* Pathname of file to copy to (UTF-8). */
{
    int result = TCL_ERROR;
    int prot = 0666;
    Tcl_Channel in, out;
    Tcl_StatBuf sourceStatBuf;
    struct utimbuf tval;

    out = Tcl_FSOpenFileChannel(interp, target, "wb", prot);
    if (out == NULL) {
        /*
         * It looks like we cannot copy it over. Bail out...
         */
        goto done;
    }

    in = Tcl_FSOpenFileChannel(interp, source, "rb", prot);
    if (in == NULL) {
        /*
         * This is very strange, caller should have checked this...
         */

        Tcl_Close(interp, out);
        goto done;
    }

    /*
     * Copy it synchronously. We might wish to add an asynchronous option to
     * support vfs's which are slow (e.g. network sockets).
     */

    if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) {
        result = TCL_OK;
    }

    /*
     * If the copy failed, assume that copy channel left a good error message.
     */

    Tcl_Close(interp, in);
    Tcl_Close(interp, out);

    /*
     * Set modification date of copied file.
     */

    if (Tcl_FSLstat(source, &sourceStatBuf) == 0) {
        tval.actime = sourceStatBuf.st_atime;
        tval.modtime = sourceStatBuf.st_mtime;
        Tcl_FSUtime(target, &tval);
    }

  done:
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSDeleteFile --
 *
 *      The appropriate function for the filesystem to which pathPtr belongs
 *      will be called.
 *
 * Results:
 *      Standard Tcl error code.
 *
 * Side effects:
 *      A file may be deleted.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_FSDeleteFile(
    Tcl_Obj *pathPtr)           /* Pathname of file to be removed (UTF-8). */
{
    const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
        Tcl_FSDeleteFileProc *proc = fsPtr->deleteFileProc;
        if (proc != NULL) {
            return (*proc)(pathPtr);
        }
    }
    Tcl_SetErrno(ENOENT);
    return -1;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSCreateDirectory --
 *
 *      The appropriate function for the filesystem to which pathPtr belongs
 *      will be called.
 *
 * Results:
 *      Standard Tcl error code.
 *
 * Side effects:
 *      A directory may be created.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_FSCreateDirectory(
    Tcl_Obj *pathPtr)           /* Pathname of directory to create (UTF-8). */
{
    const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
        Tcl_FSCreateDirectoryProc *proc = fsPtr->createDirectoryProc;
        if (proc != NULL) {
            return (*proc)(pathPtr);
        }
    }
    Tcl_SetErrno(ENOENT);
    return -1;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSCopyDirectory --
 *
 *      If the two paths given belong to the same filesystem, we call that
 *      filesystems copy-directory function. Otherwise we simply return the
 *      POSIX error 'EXDEV', and -1.
 *
 * Results:
 *      Standard Tcl error code if a function was called.
 *
 * Side effects:
 *      A directory may be copied.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_FSCopyDirectory(
    Tcl_Obj* srcPathPtr,        /* Pathname of directory to be copied
                                 * (UTF-8). */
    Tcl_Obj *destPathPtr,       /* Pathname of target directory (UTF-8). */
    Tcl_Obj **errorPtr)         /* If non-NULL, then will be set to a new
                                 * object containing name of file causing
                                 * error, with refCount 1. */
{
    int retVal = -1;
    const Tcl_Filesystem *fsPtr, *fsPtr2;
    fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
    fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);

    if (fsPtr == fsPtr2 && fsPtr != NULL) {
        Tcl_FSCopyDirectoryProc *proc = fsPtr->copyDirectoryProc;
        if (proc != NULL) {
            retVal = (*proc)(srcPathPtr, destPathPtr, errorPtr);
        }
    }
    if (retVal == -1) {
        Tcl_SetErrno(EXDEV);
    }
    return retVal;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSRemoveDirectory --
 *
 *      The appropriate function for the filesystem to which pathPtr belongs
 *      will be called.
 *
 * Results:
 *      Standard Tcl error code.
 *
 * Side effects:
 *      A directory may be deleted.
 *
 *---------------------------------------------------------------------------
 */

int
Tcl_FSRemoveDirectory(
    Tcl_Obj *pathPtr,           /* Pathname of directory to be removed
                                 * (UTF-8). */
    int recursive,              /* If non-zero, removes directories that are
                                 * nonempty. Otherwise, will only remove empty
                                 * directories. */
    Tcl_Obj **errorPtr)         /* If non-NULL, then will be set to a new
                                 * object containing name of file causing
                                 * error, with refCount 1. */
{
    const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL && fsPtr->removeDirectoryProc != NULL) {
        Tcl_FSRemoveDirectoryProc *proc = fsPtr->removeDirectoryProc;
        if (recursive) {
            /*
             * We check whether the cwd lies inside this directory and move it
             * if it does.
             */

            Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL);

            if (cwdPtr != NULL) {
                char *cwdStr, *normPathStr;
                int cwdLen, normLen;
                Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);

                if (normPath != NULL) {
                    normPathStr = Tcl_GetStringFromObj(normPath, &normLen);
                    cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
                    if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr,
                            (size_t) normLen) == 0)) {
                        /*
                         * The cwd is inside the directory, so we perform a
                         * 'cd [file dirname $path]'.
                         */

                        Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr,
                                TCL_PATH_DIRNAME);

                        Tcl_FSChdir(dirPtr);
                        Tcl_DecrRefCount(dirPtr);
                    }
                }
                Tcl_DecrRefCount(cwdPtr);
            }
        }
        return (*proc)(pathPtr, recursive, errorPtr);
    }
    Tcl_SetErrno(ENOENT);
    return -1;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSGetFileSystemForPath --
 *
 *      This function determines which filesystem to use for a particular path
 *      object, and returns the filesystem which accepts this file. If no
 *      filesystem will accept this object as a valid file path, then NULL is
 *      returned.
 *
 * Results:
 *      NULL or a filesystem which will accept this path.
 *
 * Side effects:
 *      The object may be converted to a path type.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Filesystem *
Tcl_FSGetFileSystemForPath(
    Tcl_Obj* pathPtr)
{
    FilesystemRecord *fsRecPtr;
    Tcl_Filesystem* retVal = NULL;

    if (pathPtr == NULL) {
        Tcl_Panic("Tcl_FSGetFileSystemForPath called with NULL object");
        return NULL;
    }

    /*
     * If the object has a refCount of zero, we reject it. This is to avoid
     * possible segfaults or nondeterministic memory leaks (i.e. the user
     * doesn't know if they should decrement the ref count on return or not).
     */

    if (pathPtr->refCount == 0) {
        Tcl_Panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0");
        return NULL;
    }

    /*
     * Check if the filesystem has changed in some way since this object's
     * internal representation was calculated. Before doing that, assure we
     * have the most up-to-date copy of the master filesystem. This is
     * accomplished by the FsGetFirstFilesystem() call.
     */

    fsRecPtr = FsGetFirstFilesystem();

    if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) {
        return NULL;
    }

    /*
     * Call each of the "pathInFilesystem" functions in succession. A
     * non-return value of -1 indicates the particular function has succeeded.
     */

    while ((retVal == NULL) && (fsRecPtr != NULL)) {
        Tcl_FSPathInFilesystemProc *proc =
                fsRecPtr->fsPtr->pathInFilesystemProc;

        if (proc != NULL) {
            ClientData clientData = NULL;
            if ((*proc)(pathPtr, &clientData) != -1) {
                /*
                 * We assume the type of pathPtr hasn't been changed by the
                 * above call to the pathInFilesystemProc.
                 */

                TclFSSetPathDetails(pathPtr, fsRecPtr, clientData);
                retVal = fsRecPtr->fsPtr;
            }
        }
        fsRecPtr = fsRecPtr->nextPtr;
    }

    return retVal;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSGetNativePath --
 *
 *      This function is for use by the Win/Unix native filesystems, so that
 *      they can easily retrieve the native (char* or TCHAR*) representation
 *      of a path. Other filesystems will probably want to implement similar
 *      functions. They basically act as a safety net around
 *      Tcl_FSGetInternalRep. Normally your file-system functions will always
 *      be called with path objects already converted to the correct
 *      filesystem, but if for some reason they are called directly (i.e. by
 *      functions not in this file), then one cannot necessarily guarantee
 *      that the path object pointer is from the correct filesystem.
 *
 *      Note: in the future it might be desireable to have separate versions
 *      of this function with different signatures, for example
 *      Tcl_FSGetNativeWinPath, Tcl_FSGetNativeUnixPath etc. Right now, since
 *      native paths are all string based, we use just one function.
 *
 * Results:
 *      NULL or a valid native path.
 *
 * Side effects:
 *      See Tcl_FSGetInternalRep.
 *
 *---------------------------------------------------------------------------
 */

const char *
Tcl_FSGetNativePath(
    Tcl_Obj *pathPtr)
{
    return (const char *) Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem);
}

/*
 *---------------------------------------------------------------------------
 *
 * NativeFreeInternalRep --
 *
 *      Free a native internal representation, which will be non-NULL.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Memory is released.
 *
 *---------------------------------------------------------------------------
 */

static void
NativeFreeInternalRep(
    ClientData clientData)
{
    ckfree((char *) clientData);
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSFileSystemInfo --
 *
 *      This function returns a list of two elements. The first element is the
 *      name of the filesystem (e.g. "native" or "vfs"), and the second is the
 *      particular type of the given path within that filesystem.
 *
 * Results:
 *      A list of two elements.
 *
 * Side effects:
 *      The object may be converted to a path type.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_FSFileSystemInfo(
    Tcl_Obj *pathPtr)
{
    Tcl_Obj *resPtr;
    Tcl_FSFilesystemPathTypeProc *proc;
    const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);

    if (fsPtr == NULL) {
        return NULL;
    }

    resPtr = Tcl_NewListObj(0, NULL);
    Tcl_ListObjAppendElement(NULL,resPtr,Tcl_NewStringObj(fsPtr->typeName,-1));

    proc = fsPtr->filesystemPathTypeProc;
    if (proc != NULL) {
        Tcl_Obj *typePtr = (*proc)(pathPtr);
        if (typePtr != NULL) {
            Tcl_ListObjAppendElement(NULL, resPtr, typePtr);
        }
    }

    return resPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSPathSeparator --
 *
 *      This function returns the separator to be used for a given path. The
 *      object returned should have a refCount of zero
 *
 * Results:
 *      A Tcl object, with a refCount of zero. If the caller needs to retain a
 *      reference to the object, it should call Tcl_IncrRefCount, and should
 *      otherwise free the object.
 *
 * Side effects:
 *      The path object may be converted to a path type.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_FSPathSeparator(
    Tcl_Obj *pathPtr)
{
    const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);

    if (fsPtr == NULL) {
        return NULL;
    }
    if (fsPtr->filesystemSeparatorProc != NULL) {
        return (*fsPtr->filesystemSeparatorProc)(pathPtr);
    } else {
        Tcl_Obj *resultObj;

        /*
         * Allow filesystems not to provide a filesystemSeparatorProc if they
         * wish to use the standard forward slash.
         */

        TclNewLiteralStringObj(resultObj, "/");
        return resultObj;
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * NativeFilesystemSeparator --
 *
 *      This function is part of the native filesystem support, and returns
 *      the separator for the given path.
 *
 * Results:
 *      String object containing the separator character.
 *
 * Side effects:
 *      None.
 *
 *---------------------------------------------------------------------------
 */

static Tcl_Obj *
NativeFilesystemSeparator(
    Tcl_Obj *pathPtr)
{
    const char *separator = NULL; /* lint */
    switch (tclPlatform) {
    case TCL_PLATFORM_UNIX:
        separator = "/";
        break;
    case TCL_PLATFORM_WINDOWS:
        separator = "\\";
        break;
    }
    return Tcl_NewStringObj(separator,1);
}

/* Everything from here on is contained in this obsolete ifdef */
#ifdef USE_OBSOLETE_FS_HOOKS

/*
 *----------------------------------------------------------------------
 *
 * TclStatInsertProc --
 *
 *      Insert the passed function pointer at the head of the list of
 *      functions which are used during a call to 'TclStat(...)'. The passed
 *      function should behave exactly like 'TclStat' when called during that
 *      time (see 'TclStat(...)' for more information). The function will be
 *      added even if it already in the list.
 *
 * Results:
 *      Normally TCL_OK; TCL_ERROR if memory for a new node in the list could
 *      not be allocated.
 *
 * Side effects:
 *      Memory allocated and modifies the link list for 'TclStat' functions.
 *
 *----------------------------------------------------------------------
 */

int
TclStatInsertProc(
    TclStatProc_ *proc)
{
    int retVal = TCL_ERROR;

    if (proc != NULL) {
        StatProc *newStatProcPtr;

        newStatProcPtr = (StatProc *)ckalloc(sizeof(StatProc));

        if (newStatProcPtr != NULL) {
            newStatProcPtr->proc = proc;
            Tcl_MutexLock(&obsoleteFsHookMutex);
            newStatProcPtr->nextPtr = statProcList;
            statProcList = newStatProcPtr;
            Tcl_MutexUnlock(&obsoleteFsHookMutex);

            retVal = TCL_OK;
        }
    }

    return retVal;
}

/*
 *----------------------------------------------------------------------
 *
 * TclStatDeleteProc --
 *
 *      Removed the passed function pointer from the list of 'TclStat'
 *      functions. Ensures that the built-in stat function is not removable.
 *
 * Results:
 *      TCL_OK if the function pointer was successfully removed, TCL_ERROR
 *      otherwise.
 *
 * Side effects:
 *      Memory is deallocated and the respective list updated.
 *
 *----------------------------------------------------------------------
 */

int
TclStatDeleteProc(
    TclStatProc_ *proc)
{
    int retVal = TCL_ERROR;
    StatProc *tmpStatProcPtr;
    StatProc *prevStatProcPtr = NULL;

    Tcl_MutexLock(&obsoleteFsHookMutex);
    tmpStatProcPtr = statProcList;

    /*
     * Traverse the 'statProcList' looking for the particular node whose
     * 'proc' member matches 'proc' and remove that one from the list. Ensure
     * that the "default" node cannot be removed.
     */

    while ((retVal == TCL_ERROR) && (tmpStatProcPtr != NULL)) {
        if (tmpStatProcPtr->proc == proc) {
            if (prevStatProcPtr == NULL) {
                statProcList = tmpStatProcPtr->nextPtr;
            } else {
                prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr;
            }

            ckfree((char *)tmpStatProcPtr);

            retVal = TCL_OK;
        } else {
            prevStatProcPtr = tmpStatProcPtr;
            tmpStatProcPtr = tmpStatProcPtr->nextPtr;
        }
    }

    Tcl_MutexUnlock(&obsoleteFsHookMutex);

    return retVal;
}

/*
 *----------------------------------------------------------------------
 *
 * TclAccessInsertProc --
 *
 *      Insert the passed function pointer at the head of the list of
 *      functions which are used during a call to 'TclAccess(...)'. The passed
 *      function should behave exactly like 'TclAccess' when called during
 *      that time (see 'TclAccess(...)' for more information). The function
 *      will be added even if it already in the list.
 *
 * Results:
 *      Normally TCL_OK; TCL_ERROR if memory for a new node in the list could
 *      not be allocated.
 *
 * Side effects:
 *      Memory allocated and modifies the link list for 'TclAccess' functions.
 *
 *----------------------------------------------------------------------
 */

int
TclAccessInsertProc(
    TclAccessProc_ *proc)
{
    int retVal = TCL_ERROR;

    if (proc != NULL) {
        AccessProc *newAccessProcPtr;

        newAccessProcPtr = (AccessProc *)ckalloc(sizeof(AccessProc));

        if (newAccessProcPtr != NULL) {
            newAccessProcPtr->proc = proc;
            Tcl_MutexLock(&obsoleteFsHookMutex);
            newAccessProcPtr->nextPtr = accessProcList;
            accessProcList = newAccessProcPtr;
            Tcl_MutexUnlock(&obsoleteFsHookMutex);

            retVal = TCL_OK;
        }
    }

    return retVal;
}

/*
 *----------------------------------------------------------------------
 *
 * TclAccessDeleteProc --
 *
 *      Removed the passed function pointer from the list of 'TclAccess'
 *      functions. Ensures that the built-in access function is not removable.
 *
 * Results:
 *      TCL_OK if the function pointer was successfully removed, TCL_ERROR
 *      otherwise.
 *
 * Side effects:
 *      Memory is deallocated and the respective list updated.
 *
 *----------------------------------------------------------------------
 */

int
TclAccessDeleteProc(
    TclAccessProc_ *proc)
{
    int retVal = TCL_ERROR;
    AccessProc *tmpAccessProcPtr;
    AccessProc *prevAccessProcPtr = NULL;

    /*
     * Traverse the 'accessProcList' looking for the particular node whose
     * 'proc' member matches 'proc' and remove that one from the list. Ensure
     * that the "default" node cannot be removed.
     */

    Tcl_MutexLock(&obsoleteFsHookMutex);
    tmpAccessProcPtr = accessProcList;
    while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != NULL)) {
        if (tmpAccessProcPtr->proc == proc) {
            if (prevAccessProcPtr == NULL) {
                accessProcList = tmpAccessProcPtr->nextPtr;
            } else {
                prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr;
            }

            ckfree((char *)tmpAccessProcPtr);

            retVal = TCL_OK;
        } else {
            prevAccessProcPtr = tmpAccessProcPtr;
            tmpAccessProcPtr = tmpAccessProcPtr->nextPtr;
        }
    }
    Tcl_MutexUnlock(&obsoleteFsHookMutex);

    return retVal;
}

/*
 *----------------------------------------------------------------------
 *
 * TclOpenFileChannelInsertProc --
 *
 *      Insert the passed function pointer at the head of the list of
 *      functions which are used during a call to 'Tcl_OpenFileChannel(...)'.
 *      The passed function should behave exactly like 'Tcl_OpenFileChannel'
 *      when called during that time (see 'Tcl_OpenFileChannel(...)' for more
 *      information). The function will be added even if it already in the
 *      list.
 *
 * Results:
 *      Normally TCL_OK; TCL_ERROR if memory for a new node in the list could
 *      not be allocated.
 *
 * Side effects:
 *      Memory allocated and modifies the link list for 'Tcl_OpenFileChannel'
 *      functions.
 *
 *----------------------------------------------------------------------
 */

int
TclOpenFileChannelInsertProc(
    TclOpenFileChannelProc_ *proc)
{
    int retVal = TCL_ERROR;

    if (proc != NULL) {
        OpenFileChannelProc *newOpenFileChannelProcPtr;

        newOpenFileChannelProcPtr = (OpenFileChannelProc *)
                ckalloc(sizeof(OpenFileChannelProc));

        newOpenFileChannelProcPtr->proc = proc;
        Tcl_MutexLock(&obsoleteFsHookMutex);
        newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList;
        openFileChannelProcList = newOpenFileChannelProcPtr;
        Tcl_MutexUnlock(&obsoleteFsHookMutex);

        retVal = TCL_OK;
    }

    return retVal;
}

/*
 *----------------------------------------------------------------------
 *
 * TclOpenFileChannelDeleteProc --
 *
 *      Removed the passed function pointer from the list of
 *      'Tcl_OpenFileChannel' functions. Ensures that the built-in open file
 *      channel function is not removable.
 *
 * Results:
 *      TCL_OK if the function pointer was successfully removed, TCL_ERROR
 *      otherwise.
 *
 * Side effects:
 *      Memory is deallocated and the respective list updated.
 *
 *----------------------------------------------------------------------
 */

int
TclOpenFileChannelDeleteProc(
    TclOpenFileChannelProc_ *proc)
{
    int retVal = TCL_ERROR;
    OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList;
    OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL;

    /*
     * Traverse the 'openFileChannelProcList' looking for the particular node
     * whose 'proc' member matches 'proc' and remove that one from the list.
     */

    Tcl_MutexLock(&obsoleteFsHookMutex);
    tmpOpenFileChannelProcPtr = openFileChannelProcList;
    while ((retVal == TCL_ERROR) &&
            (tmpOpenFileChannelProcPtr != NULL)) {
        if (tmpOpenFileChannelProcPtr->proc == proc) {
            if (prevOpenFileChannelProcPtr == NULL) {
                openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr;
            } else {
                prevOpenFileChannelProcPtr->nextPtr =
                        tmpOpenFileChannelProcPtr->nextPtr;
            }

            ckfree((char *) tmpOpenFileChannelProcPtr);

            retVal = TCL_OK;
        } else {
            prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr;
            tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr;
        }
    }
    Tcl_MutexUnlock(&obsoleteFsHookMutex);

    return retVal;
}
#endif /* USE_OBSOLETE_FS_HOOKS */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */