Logo Search packages:      
Sourcecode: tclvfs version File versions  Download package

vfs.c

/* 
 * vfs.c --
 *
 *    This file contains the implementation of the Vfs extension
 *    to Tcl.  It provides a script level interface to Tcl's 
 *    virtual file system support, and therefore allows 
 *    vfs's to be implemented in Tcl.
 *    
 *    Some of this file could be used as a basis for a hard-coded
 *    vfs implemented in C (e.g. a zipvfs).
 *    
 *    The code is thread-safe.  Although under normal use only
 *    one interpreter will be used to add/remove mounts and volumes,
 *    it does cope with multiple interpreters in multiple threads.
 *    
 * Copyright (c) 2001-2004 Vince Darley.
 * Copyright (c) 2006 ActiveState Software Inc.
 * 
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include <tcl.h>
/* Required to access the 'stat' structure fields, and TclInExit() */
#include "tclInt.h"
#include "tclPort.h"

/*
 * Windows needs to know which symbols to export.  Unix does not.
 * BUILD_vfs should be undefined for Unix.
 */

#ifdef BUILD_vfs
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT
#endif /* BUILD_vfs */

#ifndef TCL_GLOB_TYPE_MOUNT
#define TCL_GLOB_TYPE_MOUNT         (1<<7)
#endif

/*
 * Only the _Init function is exported.
 */

EXTERN int Vfs_Init _ANSI_ARGS_((Tcl_Interp*));

/* 
 * Functions to add and remove a volume from the list of volumes.
 * These aren't currently exported, but could be in the future.
 */
static void Vfs_AddVolume    _ANSI_ARGS_((Tcl_Obj*));
static int  Vfs_RemoveVolume _ANSI_ARGS_((Tcl_Obj*));

/*
 * struct Vfs_InterpCmd --
 * 
 * Any vfs action which is exposed to Tcl requires both an interpreter
 * and a command prefix for evaluation.  To carry out any filesystem
 * action inside a vfs, this extension will lappend various additional
 * parameters to the command string, evaluate it in the interpreter and
 * then extract the result (the way the result is handled is documented
 * in each individual vfs callback below).
 * 
 * We retain a refCount on the 'mountCmd' object, but there is no need
 * for us to register our interpreter reference, since we will be
 * made invalid when the interpreter disappears.  Also, Tcl_Objs of
 * "path" type which use one of these structures as part of their
 * internal representation also do not need to add to any refCounts,
 * because if this object disappears, all internal representations will
 * be made invalid.
 */

typedef struct Vfs_InterpCmd {
    Tcl_Obj *mountCmd;    /* The Tcl command prefix which will be used
                           * to perform all filesystem actions on this
                           * file. */
    Tcl_Interp *interp;   /* The Tcl interpreter in which the above
                           * command will be evaluated. */
} Vfs_InterpCmd;

/*
 * struct VfsNativeRep --
 * 
 * Structure used for the native representation of a path in a Tcl vfs.
 * To fully specify a file, the string representation is also required.
 * 
 * When a Tcl interpreter is deleted, all mounts whose callbacks
 * are in it are removed and freed.  This also means that the
 * global filesystem epoch that Tcl retains is modified, and all
 * path internal representations are therefore discarded.  Therefore we
 * don't have to worry about vfs files containing stale VfsNativeRep
 * structures (but it also means we mustn't touch the fsCmd field
 * of one of these structures if the interpreter has gone).  This
 * means when we free one of these structures, we just free the
 * memory allocated, and ignore the fsCmd pointer (which may or may
 * not point to valid memory).
 */

typedef struct VfsNativeRep {
    int splitPosition;    /* The index into the string representation
                           * of the file which indicates where the 
                           * vfs filesystem is mounted. */
    Vfs_InterpCmd* fsCmd; /* The Tcl interpreter and command pair
                           * which will be used to perform all filesystem 
                           * actions on this file. */
} VfsNativeRep;

/*
 * struct VfsChannelCleanupInfo --
 * 
 * Structure we use to retain sufficient information about
 * a channel that we can properly clean up all resources
 * when the channel is closed.  This is required when using
 * 'open' on things inside the vfs.
 * 
 * When the channel in question is begin closed, we will
 * temporarily register the channel with the given interpreter,
 * evaluate the closeCallBack, and then detach the channel
 * from the interpreter and return (allowing Tcl to continue
 * closing the channel as normal).
 * 
 * Nothing in the callback can prevent the channel from
 * being closed.
 */

typedef struct VfsChannelCleanupInfo {
    Tcl_Channel channel;    /* The channel which needs cleaning up */
    Tcl_Obj* closeCallback; /* The Tcl command string to evaluate
                             * when the channel is closing, which will
                             * carry out any cleanup that is necessary. */
    Tcl_Interp* interp;     /* The interpreter in which to evaluate the
                             * cleanup operation. */
} VfsChannelCleanupInfo;


/*
 * Forward declarations for procedures defined later in this file:
 */

static int         VfsFilesystemObjCmd _ANSI_ARGS_((ClientData dummy,
                      Tcl_Interp *interp, int objc, 
                      Tcl_Obj *CONST objv[]));

/* 
 * Now we define the virtual filesystem callbacks.  Note that some
 * of these callbacks are passed a Tcl_Interp for error messages.
 * We will copy over the error messages from the vfs interp to the
 * calling interp.  Currently this is done directly, but we
 * could investigate using 'TclTransferResult' which would allow
 * error traces to be copied over as well.
 */

static Tcl_FSStatProc VfsStat;
static Tcl_FSAccessProc VfsAccess;
static Tcl_FSOpenFileChannelProc VfsOpenFileChannel;
static Tcl_FSMatchInDirectoryProc VfsMatchInDirectory;
static Tcl_FSDeleteFileProc VfsDeleteFile;
static Tcl_FSCreateDirectoryProc VfsCreateDirectory;
static Tcl_FSRemoveDirectoryProc VfsRemoveDirectory; 
static Tcl_FSFileAttrStringsProc VfsFileAttrStrings;
static Tcl_FSFileAttrsGetProc VfsFileAttrsGet;
static Tcl_FSFileAttrsSetProc VfsFileAttrsSet;
static Tcl_FSUtimeProc VfsUtime;
static Tcl_FSPathInFilesystemProc VfsPathInFilesystem;
static Tcl_FSFilesystemPathTypeProc VfsFilesystemPathType;
static Tcl_FSFilesystemSeparatorProc VfsFilesystemSeparator;
static Tcl_FSFreeInternalRepProc VfsFreeInternalRep;
static Tcl_FSDupInternalRepProc VfsDupInternalRep;
static Tcl_FSListVolumesProc VfsListVolumes;

static Tcl_Filesystem vfsFilesystem = {
    "tclvfs",
    sizeof(Tcl_Filesystem),
    TCL_FILESYSTEM_VERSION_1,
    &VfsPathInFilesystem,
    &VfsDupInternalRep,
    &VfsFreeInternalRep,
    /* No internal to normalized, since we don't create any
     * pure 'internal' Tcl_Obj path representations */
    NULL,
    /* No create native rep function, since we don't use it
     * or 'Tcl_FSNewNativePath' */
    NULL,
    /* Normalize path isn't needed - we assume paths only have
     * one representation */
    NULL,
    &VfsFilesystemPathType,
    &VfsFilesystemSeparator,
    &VfsStat,
    &VfsAccess,
    &VfsOpenFileChannel,
    &VfsMatchInDirectory,
    &VfsUtime,
    /* We choose not to support symbolic links inside our vfs's */
    NULL,
    &VfsListVolumes,
    &VfsFileAttrStrings,
    &VfsFileAttrsGet,
    &VfsFileAttrsSet,
    &VfsCreateDirectory,
    &VfsRemoveDirectory, 
    &VfsDeleteFile,
    /* No copy file - fallback will occur at Tcl level */
    NULL,
    /* No rename file - fallback will occur at Tcl level */
    NULL,
    /* No copy directory - fallback will occur at Tcl level */
    NULL, 
    /* Use stat for lstat */
    NULL,
    /* No load - fallback on core implementation */
    NULL,
    /* We don't need a getcwd or chdir - fallback on Tcl's versions */
    NULL,
    NULL
};

/*
 * struct VfsMount --
 * 
 * Each filesystem mount point which is registered will result in
 * the allocation of one of these structures.  They are stored
 * in a linked list whose head is 'listOfMounts'.
 */

typedef struct VfsMount {
    CONST char* mountPoint;
    int mountLen;
    int isVolume;
    Vfs_InterpCmd interpCmd;
    struct VfsMount* nextMount;
} VfsMount;

#define TCL_TSD_INIT(keyPtr)  (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData))

/*
 * Declare a thread-specific list of vfs mounts and volumes.
 *
 * Stores the list of volumes registered with the vfs (and therefore
 * also registered with Tcl).  It is maintained as a valid Tcl list at
 * all times, or NULL if there are none (we don't keep it as an empty
 * list just as a slight optimisation to improve Tcl's efficiency in
 * determining whether paths are absolute or relative).
 *
 * We keep a refCount on this object whenever it is non-NULL.
 *
 * internalErrorScript is evaluated when an internal error is detected in
 * a tclvfs implementation.  This is most useful for debugging.
 *
 * When it is not NULL we keep a refCount on it.
 */

typedef struct ThreadSpecificData {
    VfsMount *listOfMounts;
    Tcl_Obj *vfsVolumes;
    Tcl_Obj *internalErrorScript;
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;

/* We might wish to consider exporting these in the future */

static int             Vfs_AddMount(Tcl_Obj* mountPoint, int isVolume, 
                            Tcl_Interp *interp, Tcl_Obj* mountCmd);
static int             Vfs_RemoveMount(Tcl_Obj* mountPoint, Tcl_Interp* interp);
static Vfs_InterpCmd*  Vfs_FindMount(Tcl_Obj *pathMount, int mountLen);
static Tcl_Obj*        Vfs_ListMounts(void);
static void            Vfs_UnregisterWithInterp _ANSI_ARGS_((ClientData, 
                                               Tcl_Interp*));
static void            Vfs_RegisterWithInterp _ANSI_ARGS_((Tcl_Interp*));

/* Some private helper procedures */

static VfsNativeRep*   VfsGetNativePath(Tcl_Obj* pathPtr);
static Tcl_CloseProc   VfsCloseProc;
static void            VfsExitProc(ClientData clientData);
static void            VfsThreadExitProc(ClientData clientData);
static Tcl_Obj*          VfsFullyNormalizePath(Tcl_Interp *interp, 
                                     Tcl_Obj *pathPtr);
static Tcl_Obj*        VfsBuildCommandForPath(Tcl_Interp **iRef, 
                            CONST char* cmd, Tcl_Obj * pathPtr);
static void            VfsInternalError(Tcl_Interp* interp);

/* 
 * Hard-code platform dependencies.  We do not need to worry 
 * about backslash-separators on windows, because a normalized
 * path will never contain them.
 */
#ifdef MAC_TCL
    #define VFS_SEPARATOR ':'
#else
    #define VFS_SEPARATOR '/'
#endif


/*
 *----------------------------------------------------------------------
 *
 * Vfs_Init --
 *
 *    This procedure is the main initialisation point of the Vfs
 *    extension.
 *
 * Results:
 *    Returns a standard Tcl completion code, and leaves an error
 *    message in the interp's result if an error occurs.
 *
 * Side effects:
 *    Adds a command to the Tcl interpreter.
 *
 *----------------------------------------------------------------------
 */

int
Vfs_Init(interp)
    Tcl_Interp *interp;       /* Interpreter for application. */
{
    if (Tcl_InitStubs(interp, "8.4", 0) == NULL) {
      return TCL_ERROR;
    }
    if (Tcl_PkgRequire(interp, "Tcl", "8.4", 0) == NULL) {
      return TCL_ERROR;
    }
    
    /* 
     * Safe interpreters are not allowed to modify the filesystem!
     * (Since those modifications will affect other interpreters).
     */
    if (Tcl_IsSafe(interp)) {
        return TCL_ERROR;
    }

#ifndef PACKAGE_VERSION
    /* keep in sync with actual version */
#define PACKAGE_VERSION "1.3"
#endif
    if (Tcl_PkgProvide(interp, "vfs", PACKAGE_VERSION) == TCL_ERROR) {
        return TCL_ERROR;
    }

    /*
     * Create 'vfs::filesystem' command, and interpreter-specific
     * initialisation.
     */

    Tcl_CreateObjCommand(interp, "vfs::filesystem", VfsFilesystemObjCmd, 
          (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
    Vfs_RegisterWithInterp(interp);
    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * Vfs_RegisterWithInterp --
 *
 *    Allow the given interpreter to be used to handle vfs callbacks.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    May register the entire vfs code (if not previously registered).
 *    Registers some cleanup action for when this interpreter is
 *    deleted.
 *
 *----------------------------------------------------------------------
 */
static void 
Vfs_RegisterWithInterp(interp)
    Tcl_Interp *interp;
{
    ClientData vfsAlreadyRegistered;
    /* 
     * We need to know if the interpreter is deleted, so we can
     * remove all interp-specific mounts.
     */
    Tcl_SetAssocData(interp, "vfs::inUse", (Tcl_InterpDeleteProc*) 
                 Vfs_UnregisterWithInterp, (ClientData) 1);
    /* 
     * Perform one-off registering of our filesystem if that
     * has not happened before.
     */
    vfsAlreadyRegistered = Tcl_FSData(&vfsFilesystem);
    if (vfsAlreadyRegistered == NULL) {
      Tcl_FSRegister((ClientData)1, &vfsFilesystem);
      Tcl_CreateExitHandler(VfsExitProc, (ClientData)NULL);
      Tcl_CreateThreadExitHandler(VfsThreadExitProc, NULL);
    }
}
   

/*
 *----------------------------------------------------------------------
 *
 * Vfs_UnregisterWithInterp --
 *
 *    Remove all of the mount points that this interpreter handles.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */
static void 
Vfs_UnregisterWithInterp(dummy, interp)
    ClientData dummy;
    Tcl_Interp *interp;
{
    int res = TCL_OK;
    /* Remove all of this interpreters mount points */
    while (res == TCL_OK) {
        res = Vfs_RemoveMount(NULL, interp);
    }
    /* Make sure our assoc data has been deleted */
    Tcl_DeleteAssocData(interp, "vfs::inUse");
}


/*
 *----------------------------------------------------------------------
 *
 * Vfs_AddMount --
 *
 *    Adds a new vfs mount point.  After this call all filesystem
 *    access within that mount point will be redirected to the
 *    interpreter/mountCmd pair.
 *    
 *    This command must not be called unless 'interp' has already
 *    been registered with 'Vfs_RegisterWithInterp' above.  This 
 *    usually happens automatically with a 'package require vfs'.
 *
 * Results:
 *    TCL_OK unless the inputs are bad or a memory allocation
 *    error occurred, or the interpreter is not vfs-registered.
 *
 * Side effects:
 *    A new volume may be added to the list of available volumes.
 *    Future filesystem access inside the mountPoint will be 
 *    redirected.  Tcl is informed that a new mount has been added
 *    and this will make all cached path representations invalid.
 *
 *----------------------------------------------------------------------
 */
static int 
Vfs_AddMount(mountPoint, isVolume, interp, mountCmd)
    Tcl_Obj* mountPoint;
    int isVolume;
    Tcl_Interp* interp;
    Tcl_Obj* mountCmd;
{
    char *strRep;
    int len;
    VfsMount *newMount;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    
    if (mountPoint == NULL || interp == NULL || mountCmd == NULL) {
      return TCL_ERROR;
    }
    /* 
     * Check whether this intepreter can properly clean up
     * mounts on exit.  If not, throw an error.
     */
    if (Tcl_GetAssocData(interp, "vfs::inUse", NULL) == NULL) {
        return TCL_ERROR;
    }
    
    newMount = (VfsMount*) ckalloc(sizeof(VfsMount));
    
    if (newMount == NULL) {
      return TCL_ERROR;
    }
    strRep = Tcl_GetStringFromObj(mountPoint, &len);
    newMount->mountPoint = (char*) ckalloc(1+(unsigned)len);
    newMount->mountLen = len;
    
    if (newMount->mountPoint == NULL) {
      ckfree((char*)newMount);
      return TCL_ERROR;
    }
    
    strcpy((char*)newMount->mountPoint, strRep);
    newMount->interpCmd.mountCmd = mountCmd;
    newMount->interpCmd.interp = interp;
    newMount->isVolume = isVolume;
    Tcl_IncrRefCount(mountCmd);
    
    newMount->nextMount = tsdPtr->listOfMounts;
    tsdPtr->listOfMounts = newMount;

    if (isVolume) {
      Vfs_AddVolume(mountPoint);
    }
    Tcl_FSMountsChanged(&vfsFilesystem);
    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * Vfs_RemoveMount --
 *
 *    This procedure searches for a matching mount point and removes
 *    it if one is found.  If 'mountPoint' is given, then both it and
 *    the interpreter must match for a mount point to be removed.
 *    
 *    If 'mountPoint' is NULL, then the first mount point for the
 *    given interpreter is removed (if any).
 *
 * Results:
 *    TCL_OK if a mount was removed, TCL_ERROR otherwise.
 *
 * Side effects:
 *    A volume may be removed from the current list of volumes
 *    (as returned by 'file volumes').  A vfs may be removed from
 *    the filesystem.  If successful, Tcl will be informed that
 *    the list of current mounts has changed, and all cached file
 *    representations will be made invalid.
 *
 *----------------------------------------------------------------------
 */
static int 
Vfs_RemoveMount(mountPoint, interp)
    Tcl_Obj* mountPoint;
    Tcl_Interp *interp;
{
    /* These two are only used if mountPoint is non-NULL */
    char *strRep = NULL;
    int len = 0;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    
    VfsMount *mountIter;
    /* Set to NULL just to avoid warnings */
    VfsMount *lastMount = NULL;
    
    if (mountPoint != NULL) {
      strRep = Tcl_GetStringFromObj(mountPoint, &len);
    }

    mountIter = tsdPtr->listOfMounts;
    
    while (mountIter != NULL) {
      if ((interp == mountIter->interpCmd.interp) 
          && ((mountPoint == NULL) ||
            (mountIter->mountLen == len && 
             !strcmp(mountIter->mountPoint, strRep)))) {
          /* We've found the mount. */
          if (mountIter == tsdPtr->listOfMounts) {
            tsdPtr->listOfMounts = mountIter->nextMount;
          } else {
            lastMount->nextMount = mountIter->nextMount;
          }
          /* Free the allocated memory */
          if (mountIter->isVolume) {
            if (mountPoint == NULL) {
                Tcl_Obj *volObj = Tcl_NewStringObj(mountIter->mountPoint, 
                                           mountIter->mountLen);
                Tcl_IncrRefCount(volObj);
                Vfs_RemoveVolume(volObj);
                Tcl_DecrRefCount(volObj);
            } else {
                Vfs_RemoveVolume(mountPoint);
            }
          }
          ckfree((char*)mountIter->mountPoint);
          Tcl_DecrRefCount(mountIter->interpCmd.mountCmd);
          ckfree((char*)mountIter);
          Tcl_FSMountsChanged(&vfsFilesystem);
          return TCL_OK;
      }
      lastMount = mountIter;
      mountIter = mountIter->nextMount;
    }
    return TCL_ERROR;
}


/*
 *----------------------------------------------------------------------
 *
 * Vfs_FindMount --
 *
 *    This procedure searches all currently mounted paths for one
 *    which matches the given path.  The given path must be the
 *    absolute, normalized, unique representation for the given path.
 *    If 'len' is -1, we use the entire string representation of the
 *    mountPoint, otherwise we treat 'len' as the length of the mount
 *    we are comparing.
 *
 * Results:
 *    Returns the interpreter, command-prefix pair for the given
 *    mount point, if one is found, otherwise NULL.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */
static Vfs_InterpCmd* 
Vfs_FindMount(pathMount, mountLen)
    Tcl_Obj *pathMount;
    int mountLen;
{
    VfsMount *mountIter;
    char *mountStr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    
    if (pathMount == NULL) {
      return NULL;
    }
    
    if (mountLen == -1) {
        mountStr = Tcl_GetStringFromObj(pathMount, &mountLen);
    } else {
      mountStr = Tcl_GetString(pathMount);
    }

    mountIter = tsdPtr->listOfMounts;
    while (mountIter != NULL) {
      if (mountIter->mountLen == mountLen && 
        !strncmp(mountIter->mountPoint, mountStr, (size_t)mountLen)) {
          Vfs_InterpCmd *ret = &mountIter->interpCmd;
          return ret;
      }
      mountIter = mountIter->nextMount;
    }
    return NULL;
}


/*
 *----------------------------------------------------------------------
 *
 * Vfs_ListMounts --
 *
 *    Returns a valid Tcl list, with refCount of zero, containing
 *    all currently mounted paths.
 *    
 *----------------------------------------------------------------------
 */
static Tcl_Obj* 
Vfs_ListMounts(void) 
{
    VfsMount *mountIter;
    Tcl_Obj *res = Tcl_NewObj();
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /* Build list of mounts */
    mountIter = tsdPtr->listOfMounts;
    while (mountIter != NULL) {
      Tcl_Obj* mount = Tcl_NewStringObj(mountIter->mountPoint, 
                                mountIter->mountLen);
      Tcl_ListObjAppendElement(NULL, res, mount);
      mountIter = mountIter->nextMount;
    }
    return res;
}

/*
 *----------------------------------------------------------------------
 *
 * VfsFilesystemObjCmd --
 *
 *    This procedure implements the "vfs::filesystem" command.  It is
 *    used to mount/unmount particular interfaces to new filesystems,
 *    or to query for what is mounted where.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    Inserts or removes a filesystem from Tcl's stack.
 *
 *----------------------------------------------------------------------
 */

static int
VfsFilesystemObjCmd(dummy, interp, objc, objv)
    ClientData dummy;
    Tcl_Interp *interp;
    int           objc;
    Tcl_Obj *CONST objv[];
{
    int index;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    static CONST char *optionStrings[] = {
      "info", "internalerror", "mount", "unmount", 
      "fullynormalize", "posixerror", 
      NULL
    };
    
    enum options {
      VFS_INFO, VFS_INTERNAL_ERROR, VFS_MOUNT, VFS_UNMOUNT, 
      VFS_NORMALIZE, VFS_POSIXERROR
    };

    if (objc < 2) {
      Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
      return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
          &index) != TCL_OK) {
      return TCL_ERROR;
    }

    switch ((enum options) index) {
      case VFS_INTERNAL_ERROR: {
          if (objc > 3) {
            Tcl_WrongNumArgs(interp, 2, objv, "?script?");
            return TCL_ERROR;
          }
          if (objc == 2) {
              /* Return the current script */
            if (tsdPtr->internalErrorScript != NULL) {
                Tcl_SetObjResult(interp, tsdPtr->internalErrorScript);
            }
          } else {
            /* Set the script */
            int len;
            if (tsdPtr->internalErrorScript != NULL) {
                Tcl_DecrRefCount(tsdPtr->internalErrorScript);
            }
            Tcl_GetStringFromObj(objv[2], &len);
            if (len == 0) {
                /* Clear our script */
                tsdPtr->internalErrorScript = NULL;
            } else {
                /* Set it */
                tsdPtr->internalErrorScript = objv[2];
                Tcl_IncrRefCount(tsdPtr->internalErrorScript);
            }
          }
          return TCL_OK;
      }
      case VFS_POSIXERROR: {
          int posixError = -1;
          if (objc != 3) {
            Tcl_WrongNumArgs(interp, 2, objv, "errorcode");
            return TCL_ERROR;
          }
          if (Tcl_GetIntFromObj(NULL, objv[2], &posixError) != TCL_OK) {
            return TCL_ERROR;
          }
          Tcl_SetErrno(posixError);
          return -1;
      }
      case VFS_NORMALIZE: {
          Tcl_Obj *path;
          if (objc != 3) {
            Tcl_WrongNumArgs(interp, 2, objv, "path");
            return TCL_ERROR;
          }
          path = VfsFullyNormalizePath(interp, objv[2]);
          if (path == NULL) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                  "not a valid path \"", Tcl_GetString(objv[2]), 
                  "\"", (char *) NULL);
          } else {
            Tcl_SetObjResult(interp, path);
            Tcl_DecrRefCount(path);
            return TCL_OK;
          }
      }
        case VFS_MOUNT: {
          if (objc < 4 || objc > 5) {
            Tcl_WrongNumArgs(interp, 1, objv, "mount ?-volume? path cmd");
            return TCL_ERROR;
          }
          if (objc == 5) {
            char *option = Tcl_GetString(objv[2]);
            if (strcmp("-volume", option)) {
                Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                      "bad option \"", option,
                      "\": must be -volume", (char *) NULL);
                return TCL_ERROR;
            }
            return Vfs_AddMount(objv[3], 1, interp, objv[4]);
          } else {
            Tcl_Obj *path;
            int retVal;
            path = VfsFullyNormalizePath(interp, objv[2]);
            retVal = Vfs_AddMount(path, 0, interp, objv[3]);
            if (path != NULL) { Tcl_DecrRefCount(path); }
            return retVal;
          }
          break;
      }
      case VFS_INFO: {
          if (objc > 3) {
            Tcl_WrongNumArgs(interp, 2, objv, "path");
            return TCL_ERROR;
          }
          if (objc == 2) {
            Tcl_SetObjResult(interp, Vfs_ListMounts());
          } else {
            Vfs_InterpCmd *val;
            
            val = Vfs_FindMount(objv[2], -1);
            if (val == NULL) {
                Tcl_Obj *path;
                path = VfsFullyNormalizePath(interp, objv[2]);
                val = Vfs_FindMount(path, -1);
                Tcl_DecrRefCount(path);
                if (val == NULL) {
                  Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                        "no such mount \"", Tcl_GetString(objv[2]), 
                        "\"", (char *) NULL);
                  return TCL_ERROR;
                }
            }
            Tcl_SetObjResult(interp, val->mountCmd);
          }
          break;
      }
      case VFS_UNMOUNT: {
          if (objc != 3) {
            Tcl_WrongNumArgs(interp, 2, objv, "path");
            return TCL_ERROR;
          }
          if (Vfs_RemoveMount(objv[2], interp) == TCL_ERROR) {
            Tcl_Obj *path;
            int retVal;
            path = VfsFullyNormalizePath(interp, objv[2]);
            retVal = Vfs_RemoveMount(path, interp);
            Tcl_DecrRefCount(path);
            if (retVal == TCL_ERROR) {
                Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                      "no such mount \"", Tcl_GetString(objv[2]), 
                      "\"", (char *) NULL);
                return TCL_ERROR;
            }
          }
          return TCL_OK;
      }
    }
    return TCL_OK;
}

/* Handle an error thrown by a tcl vfs implementation */
static void
VfsInternalError(Tcl_Interp* interp)
{
    if (interp != NULL) {
      ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
      if (tsdPtr->internalErrorScript != NULL) {
          Tcl_EvalObjEx(interp, tsdPtr->internalErrorScript,
                    TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
      }
    }
}

/* Return fully normalized path owned by the caller */
static Tcl_Obj*
VfsFullyNormalizePath(Tcl_Interp *interp, Tcl_Obj *pathPtr) {
    Tcl_Obj *path;
    int counter = 0;

    Tcl_IncrRefCount(pathPtr);
    while (1) {
      path = Tcl_FSLink(pathPtr,NULL,0);
      if (path == NULL) {
          break;
      }
      if (Tcl_FSGetPathType(path) != TCL_PATH_ABSOLUTE) {
          /* 
           * This is more complex, we need to find the path
           * relative to the original file, effectively:
           * 
           *  file join [file dirname $pathPtr] $path
           *  
           * or 
           * 
           *  file join $pathPtr .. $path
           *  
           * So...
           */
          Tcl_Obj *dotdotPtr, *joinedPtr;
          Tcl_Obj *joinElements[2];
          
          dotdotPtr = Tcl_NewStringObj("..",2);
          Tcl_IncrRefCount(dotdotPtr);
          
          joinElements[0] = dotdotPtr;
          joinElements[1] = path;

          joinedPtr = Tcl_FSJoinToPath(pathPtr, 2, joinElements);
          
          if (joinedPtr != NULL) {
            Tcl_IncrRefCount(joinedPtr);
            Tcl_DecrRefCount(path);
            path = joinedPtr;
          } else {
            /* We failed, and our action is undefined */
          }
          Tcl_DecrRefCount(dotdotPtr);
      }
      Tcl_DecrRefCount(pathPtr);
      pathPtr = path;
      counter++;
      if (counter > 10) {
          /* Too many links */
          Tcl_DecrRefCount(pathPtr);
          return NULL;
      }
    }
    path = Tcl_FSGetNormalizedPath(interp, pathPtr);
    Tcl_IncrRefCount(path);
    Tcl_DecrRefCount(pathPtr);
    return path;
}

/*
 *----------------------------------------------------------------------
 *
 * VfsPathInFilesystem --
 *
 *    Check whether a path is in any of the mounted points in this
 *    vfs.
 *    
 *    If it is in the vfs, set the clientData given to our private
 *    internal representation for a vfs path.
 *    
 * Results:
 *    Returns TCL_OK on success, or '-1' on failure.  If Tcl is
 *    exiting, we always return a failure code.
 *
 * Side effects:
 *    On success, we allocate some memory for our internal
 *    representation structure.  Tcl will call us to free this
 *    when necessary.
 *
 *----------------------------------------------------------------------
 */
static int 
VfsPathInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr) {
    Tcl_Obj *normedObj;
    int len, splitPosition;
    char *normed;
    VfsNativeRep *nativeRep;
    Vfs_InterpCmd *interpCmd = NULL;
    
    if (TclInExit()) {
      /* 
       * Even Tcl_FSGetNormalizedPath may fail due to lack of system
       * encodings, so we just say we can't handle anything if we are
       * in the middle of the exit sequence.  We could perhaps be
       * more subtle than this!
       */
      return -1;
    }

    normedObj = Tcl_FSGetNormalizedPath(NULL, pathPtr);
    if (normedObj == NULL) {
        return -1;
    }
    normed = Tcl_GetStringFromObj(normedObj, &len);
    splitPosition = len;

    /* 
     * Find the most specific mount point for this path.
     * Mount points are specified by unique strings, so
     * we have to use a unique normalised path for the
     * checks here.
     * 
     * Given mount points are paths, 'most specific' means
     * longest path, so we scan from end to beginning
     * checking for valid mount points at each separator.
     */
    while (1) {
      /* 
       * We need this test here both for an empty string being
       * passed in above, and so that if we are testing a unix
       * absolute path /foo/bar we will come around the loop
       * with splitPosition at 0 for the last iteration, and we
       * must return then.
       */
      if (splitPosition == 0) {
          return -1;
      }
      
      /* Is the path up to 'splitPosition' a valid moint point? */
      interpCmd = Vfs_FindMount(normedObj, splitPosition);
      if (interpCmd != NULL) break;

      while (normed[--splitPosition] != VFS_SEPARATOR) {
          if (splitPosition == 0) {
            /* 
             * We've reached the beginning of the string without
             * finding a mount, so we've failed.
             */
            return -1;
          }
      }
      
      /* 
       * We now know that normed[splitPosition] is a separator.
       * However, we might have mounted a root filesystem with a
       * name (for example 'ftp://') which actually includes a
       * separator.  Therefore we test whether the path with
       * a separator is a mount point.
       * 
       * Since we must have decremented splitPosition at least once
       * already (above) 'splitPosition+1 <= len' so this won't
       * access invalid memory.
       */
      interpCmd = Vfs_FindMount(normedObj, splitPosition+1);
      if (interpCmd != NULL) {
          splitPosition++;
          break;
      }
    }
    
    /* 
     * If we reach here we have a valid mount point, since the
     * only way to escape the above loop is through a 'break' when
     * an interpCmd is non-NULL.
     */
    nativeRep = (VfsNativeRep*) ckalloc(sizeof(VfsNativeRep));
    nativeRep->splitPosition = splitPosition;
    nativeRep->fsCmd = interpCmd;
    *clientDataPtr = (ClientData)nativeRep;
    return TCL_OK;
}

/* 
 * Simple helper function to extract the native vfs representation of a
 * path object, or NULL if no such representation exists.
 */
static VfsNativeRep* 
VfsGetNativePath(Tcl_Obj* pathPtr) {
    return (VfsNativeRep*) Tcl_FSGetInternalRep(pathPtr, &vfsFilesystem);
}

static void 
VfsFreeInternalRep(ClientData clientData) {
    VfsNativeRep *nativeRep = (VfsNativeRep*)clientData;
    if (nativeRep != NULL) {
      /* Free the native memory allocation */
      ckfree((char*)nativeRep);
    }
}

static ClientData 
VfsDupInternalRep(ClientData clientData) {
    VfsNativeRep *original = (VfsNativeRep*)clientData;

    VfsNativeRep *nativeRep = (VfsNativeRep*) ckalloc(sizeof(VfsNativeRep));
    nativeRep->splitPosition = original->splitPosition;
    nativeRep->fsCmd = original->fsCmd;
    
    return (ClientData)nativeRep;
}

static Tcl_Obj* 
VfsFilesystemPathType(Tcl_Obj *pathPtr) {
    VfsNativeRep* nativeRep = VfsGetNativePath(pathPtr);
    if (nativeRep == NULL) {
      return NULL;
    } else {
      return nativeRep->fsCmd->mountCmd;
    }
}

static Tcl_Obj*
VfsFilesystemSeparator(Tcl_Obj* pathPtr) {
    char sep=VFS_SEPARATOR;
    return Tcl_NewStringObj(&sep,1);
}

static int
VfsStat(pathPtr, bufPtr)
    Tcl_Obj *pathPtr;         /* Path of file to stat (in current CP). */
    Tcl_StatBuf *bufPtr;      /* Filled with results of stat call. */
{
    Tcl_Obj *mountCmd = NULL;
    Tcl_SavedResult savedResult;
    int returnVal;
    Tcl_Interp* interp;
    
    mountCmd = VfsBuildCommandForPath(&interp, "stat", pathPtr);
    if (mountCmd == NULL) {
      return -1;
    }

    Tcl_SaveResult(interp, &savedResult);
    /* Now we execute this mount point's callback. */
    returnVal = Tcl_EvalObjEx(interp, mountCmd, 
                        TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
    if (returnVal == TCL_OK) {
      int statListLength;
      Tcl_Obj* resPtr = Tcl_GetObjResult(interp);
      if (Tcl_ListObjLength(interp, resPtr, &statListLength) == TCL_ERROR) {
          returnVal = TCL_ERROR;
      } else if (statListLength & 1) {
          /* It is odd! */
          returnVal = TCL_ERROR;
      } else {
          /* 
           * The st_mode field is set part by the 'mode'
           * and part by the 'type' stat fields.
           */
          bufPtr->st_mode = 0;
          while (statListLength > 0) {
            Tcl_Obj *field, *val;
            char *fieldName;
            statListLength -= 2;
            Tcl_ListObjIndex(interp, resPtr, statListLength, &field);
            Tcl_ListObjIndex(interp, resPtr, statListLength+1, &val);
            fieldName = Tcl_GetString(field);
            if (!strcmp(fieldName,"dev")) {
                long v;
                if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) {
                  returnVal = TCL_ERROR;
                  break;
                }
                bufPtr->st_dev = v;
            } else if (!strcmp(fieldName,"ino")) {
                long v;
                if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) {
                  returnVal = TCL_ERROR;
                  break;
                }
                bufPtr->st_ino = (unsigned short)v;
            } else if (!strcmp(fieldName,"mode")) {
                int v;
                if (Tcl_GetIntFromObj(interp, val, &v) != TCL_OK) {
                  returnVal = TCL_ERROR;
                  break;
                }
                bufPtr->st_mode |= v;
            } else if (!strcmp(fieldName,"nlink")) {
                long v;
                if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) {
                  returnVal = TCL_ERROR;
                  break;
                }
                bufPtr->st_nlink = (short)v;
            } else if (!strcmp(fieldName,"uid")) {
                long v;
                if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) {
                  returnVal = TCL_ERROR;
                  break;
                }
                bufPtr->st_uid = (short)v;
            } else if (!strcmp(fieldName,"gid")) {
                long v;
                if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) {
                  returnVal = TCL_ERROR;
                  break;
                }
                bufPtr->st_gid = (short)v;
            } else if (!strcmp(fieldName,"size")) {
                Tcl_WideInt v;
                if (Tcl_GetWideIntFromObj(interp, val, &v) != TCL_OK) {
                  returnVal = TCL_ERROR;
                  break;
                }
                bufPtr->st_size = v;
            } else if (!strcmp(fieldName,"atime")) {
                long v;
                if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) {
                  returnVal = TCL_ERROR;
                  break;
                }
                bufPtr->st_atime = v;
            } else if (!strcmp(fieldName,"mtime")) {
                long v;
                if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) {
                  returnVal = TCL_ERROR;
                  break;
                }
                bufPtr->st_mtime = v;
            } else if (!strcmp(fieldName,"ctime")) {
                long v;
                if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) {
                  returnVal = TCL_ERROR;
                  break;
                }
                bufPtr->st_ctime = v;
            } else if (!strcmp(fieldName,"type")) {
                char *str;
                str = Tcl_GetString(val);
                if (!strcmp(str,"directory")) {
                  bufPtr->st_mode |= S_IFDIR;
                } else if (!strcmp(str,"file")) {
                  bufPtr->st_mode |= S_IFREG;
#ifdef S_ISLNK
                } else if (!strcmp(str,"link")) {
                  bufPtr->st_mode |= S_IFLNK;
#endif
                } else {
                  /* 
                   * Do nothing.  This means we do not currently
                   * support anything except files and directories
                   */
                }
            } else {
                /* Ignore additional stat arguments */
            }
          }
      }
    }
    
    if (returnVal != TCL_OK && returnVal != -1) {
      VfsInternalError(interp);
    }

    Tcl_RestoreResult(interp, &savedResult);
    Tcl_DecrRefCount(mountCmd);
    
    if (returnVal != TCL_OK && returnVal != -1) {
      Tcl_SetErrno(ENOENT);
        return -1;
    } else {
      return returnVal;
    }
}

static int
VfsAccess(pathPtr, mode)
    Tcl_Obj *pathPtr;         /* Path of file to access (in current CP). */
    int mode;                   /* Permission setting. */
{
    Tcl_Obj *mountCmd = NULL;
    Tcl_SavedResult savedResult;
    int returnVal;
    Tcl_Interp* interp;
    
    mountCmd = VfsBuildCommandForPath(&interp, "access", pathPtr);
    if (mountCmd == NULL) {
      return -1;
    }

    Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(mode));
    /* Now we execute this mount point's callback. */
    Tcl_SaveResult(interp, &savedResult);
    returnVal = Tcl_EvalObjEx(interp, mountCmd, 
                        TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
    if (returnVal != TCL_OK && returnVal != -1) {
      VfsInternalError(interp);
    }
    Tcl_RestoreResult(interp, &savedResult);
    Tcl_DecrRefCount(mountCmd);

    if (returnVal != 0) {
      Tcl_SetErrno(ENOENT);
      return -1;
    } else {
      return returnVal;
    }
}

static Tcl_Obj*
VfsGetMode(int mode) {
    Tcl_Obj *ret = Tcl_NewObj();
    if (mode & O_RDONLY) {
        Tcl_AppendToObj(ret, "r", 1);
    } else if (mode & O_WRONLY || mode & O_RDWR) {
      if (mode & O_TRUNC) {
          Tcl_AppendToObj(ret, "w", 1);
      } else {
          Tcl_AppendToObj(ret, "a", 1);
      }
      if (mode & O_RDWR) {
          Tcl_AppendToObj(ret, "+", 1);
      }
    }
    return ret;
}

static Tcl_Channel
VfsOpenFileChannel(cmdInterp, pathPtr, mode, permissions)
    Tcl_Interp *cmdInterp;              /* Interpreter for error reporting;
                               * can be NULL. */
    Tcl_Obj *pathPtr;                   /* Name of file to open. */
    int mode;                       /* POSIX open mode. */
    int permissions;                    /* If the open involves creating a
                               * file, with what modes to create
                               * it? */
{
    Tcl_Channel chan = NULL;
    Tcl_Obj *mountCmd = NULL;
    Tcl_Obj *closeCallback = NULL;
    Tcl_SavedResult savedResult;
    int returnVal;
    Tcl_Interp* interp;
    
    mountCmd = VfsBuildCommandForPath(&interp, "open", pathPtr);
    if (mountCmd == NULL) {
      return NULL;
    }

    Tcl_ListObjAppendElement(interp, mountCmd, VfsGetMode(mode));
    Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(permissions));
    Tcl_SaveResult(interp, &savedResult);
    /* Now we execute this mount point's callback. */
    returnVal = Tcl_EvalObjEx(interp, mountCmd, 
                        TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
    if (returnVal == TCL_OK) {
      int reslen;
      Tcl_Obj *resultObj;
      /* 
       * There may be file channel leaks on these two 
       * error conditions, if the open command actually
       * created a channel, but then passed us a bogus list.
       */
      resultObj =  Tcl_GetObjResult(interp);
      if ((Tcl_ListObjLength(interp, resultObj, &reslen) == TCL_ERROR) 
        || (reslen > 2) || (reslen == 0)) {
          returnVal = TCL_ERROR;
      } else {
          Tcl_Obj *element;
          Tcl_ListObjIndex(interp, resultObj, 0, &element);
          chan = Tcl_GetChannel(interp, Tcl_GetString(element), 0);
          
          if (chan == NULL) {
              returnVal = TCL_ERROR;
          } else {
            if (reslen == 2) {
                Tcl_ListObjIndex(interp, resultObj, 1, &element);
                closeCallback = element;
                Tcl_IncrRefCount(closeCallback);
            }
          }
      }
      Tcl_RestoreResult(interp, &savedResult);
    } else {
      /* Leave an error message if the cmdInterp is non NULL */
      if (cmdInterp != NULL) {
          if (returnVal == -1) {
            Tcl_ResetResult(cmdInterp);
            Tcl_AppendResult(cmdInterp, "couldn't open \"", 
                         Tcl_GetString(pathPtr), "\": ",
                         Tcl_PosixError(cmdInterp), (char *) NULL);
          } else {
            Tcl_Obj* error = Tcl_GetObjResult(interp);
            /* 
             * Copy over the error message to cmdInterp,
             * duplicating it in case of threading issues.
             */
            Tcl_SetObjResult(cmdInterp, Tcl_DuplicateObj(error));
          }
      } else {
          /* Report any error, since otherwise it is lost */
          if (returnVal != -1) {
            VfsInternalError(interp);
          }
      }
      if (interp == cmdInterp) {
          /* 
           * We want our error message to propagate up,
           * so we want to forget this result
           */
          Tcl_DiscardResult(&savedResult);
      } else {
          Tcl_RestoreResult(interp, &savedResult);
      }
    }

    Tcl_DecrRefCount(mountCmd);

    if (chan != NULL) {
      /*
       * We got the Channel from some Tcl code.  This means it was
       * registered with the interpreter.  But we want a pristine
       * channel which hasn't been registered with anyone.  We use
       * Tcl_DetachChannel to do this for us.  We must use the
       * correct interpreter.
       */
      if (Tcl_IsStandardChannel(chan)) {
          /*
           * If we have somehow ended up with a VFS channel being a std
           * channel, it is likely auto-inherited, which we need to reverse.
           * [Bug 1468291]
           */
          if (chan == Tcl_GetStdChannel(TCL_STDIN)) {
            Tcl_SetStdChannel(NULL, TCL_STDIN);
          } else if (chan == Tcl_GetStdChannel(TCL_STDOUT)) {
            Tcl_SetStdChannel(NULL, TCL_STDOUT);
          } else if (chan == Tcl_GetStdChannel(TCL_STDERR)) {
            Tcl_SetStdChannel(NULL, TCL_STDERR);
          }
          Tcl_UnregisterChannel(NULL, chan);
      }
      Tcl_DetachChannel(interp, chan);

      if (closeCallback != NULL) {
          VfsChannelCleanupInfo *channelRet = NULL;
          channelRet = (VfsChannelCleanupInfo*) 
                      ckalloc(sizeof(VfsChannelCleanupInfo));
          channelRet->channel = chan;
          channelRet->interp = interp;
          channelRet->closeCallback = closeCallback;
          /* The channelRet structure will be freed in the callback */
          Tcl_CreateCloseHandler(chan, &VfsCloseProc, 
                           (ClientData)channelRet);
      }
    }
    return chan;
}

/* 
 * IMPORTANT: This procedure must *not* modify the interpreter's result
 * this leads to the objResultPtr being corrupted (somehow), and curious
 * crashes in the future (which are very hard to debug ;-).
 * 
 * This is particularly important since we are evaluating arbitrary
 * Tcl code in the callback.
 * 
 * Also note we are relying on the close-callback to occur just before
 * the channel is about to be properly closed, but after all output
 * has been flushed.  That way we can, in the callback, read in the
 * entire contents of the channel and, say, compress it for storage
 * into a tclkit or zip archive.
 */
static void 
VfsCloseProc(ClientData clientData) {
    VfsChannelCleanupInfo * channelRet = (VfsChannelCleanupInfo*) clientData;
    int returnVal;
    Tcl_SavedResult savedResult;
    Tcl_Channel chan = channelRet->channel;
    Tcl_Interp * interp = channelRet->interp;

    Tcl_SaveResult(interp, &savedResult);

    /* 
     * The interpreter needs to know about the channel, else the Tcl
     * callback will fail, so we register the channel (this allows
     * the Tcl code to use the channel's string-name).
     */
    if (!Tcl_IsStandardChannel(chan)) {
      Tcl_RegisterChannel(interp, chan);
    }

    if (!(Tcl_GetChannelMode(chan) & TCL_READABLE)) {
      /* 
       * We need to make this channel readable, since tclvfs
       * documents that close callbacks are allowed to read
       * from the channels we create.
       */
      
      /* Currently if we reach here we have a bug */
    }
    
    returnVal = Tcl_EvalObjEx(interp, channelRet->closeCallback, 
              TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
    if (returnVal != TCL_OK) {
      VfsInternalError(interp);
    }
    Tcl_DecrRefCount(channelRet->closeCallback);

    /* 
     * More complications; we can't just unregister the channel,
     * because it is in the middle of being cleaned up, and the cleanup
     * code doesn't like a channel to be closed again while it is
     * already being closed.  So, we do the same trick as above to
     * unregister it without cleanup.
     */
    if (!Tcl_IsStandardChannel(chan)) {
      Tcl_DetachChannel(interp, chan);
    }

    Tcl_RestoreResult(interp, &savedResult);
    ckfree((char*)channelRet);
}

static int
VfsMatchInDirectory(
    Tcl_Interp *cmdInterp,    /* Interpreter to receive error msgs. */
    Tcl_Obj *returnPtr,       /* Object to receive results. */
    Tcl_Obj *dirPtr,            /* 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. */
{
    if ((types != NULL) && (types->type & TCL_GLOB_TYPE_MOUNT)) {
      VfsMount *mountIter;
      int len;
      CONST char *prefix;
      ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

      prefix = Tcl_GetStringFromObj(Tcl_FSGetNormalizedPath(NULL, dirPtr), 
                              &len);
      if (prefix[len-1] == '/') {
          /* 
           * It's a root directory; we must subtract one for
           * our comparisons below
           */
          len--;
      }

      /* Build list of mounts */
      mountIter = tsdPtr->listOfMounts;
      while (mountIter != NULL) {
          if (mountIter->mountLen > (len+1) 
            && !strncmp(mountIter->mountPoint, prefix, (size_t)len) 
            && mountIter->mountPoint[len] == '/'
            && strchr(mountIter->mountPoint+len+1, '/') == NULL
            && Tcl_StringCaseMatch(mountIter->mountPoint+len+1, 
                               pattern, 0)) {
            Tcl_Obj* mount = Tcl_NewStringObj(mountIter->mountPoint, 
                                      mountIter->mountLen);
            Tcl_ListObjAppendElement(NULL, returnPtr, mount);
          }
          mountIter = mountIter->nextMount;
      }
      return TCL_OK;
    } else {
      Tcl_Obj *mountCmd = NULL;
      Tcl_SavedResult savedResult;
      int returnVal;
      Tcl_Interp* interp;
      int type = 0;
      Tcl_Obj *vfsResultPtr = NULL;
      
      mountCmd = VfsBuildCommandForPath(&interp, "matchindirectory", dirPtr);
      if (mountCmd == NULL) {
          return -1;
      }

      if (types != NULL) {
          type = types->type;
      }

      if (pattern == NULL) {
          Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewObj());
      } else {
          Tcl_ListObjAppendElement(interp, mountCmd, 
                             Tcl_NewStringObj(pattern,-1));
      }
      Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(type));
      Tcl_SaveResult(interp, &savedResult);
      /* Now we execute this mount point's callback. */
      returnVal = Tcl_EvalObjEx(interp, mountCmd, 
                          TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
      if (returnVal != -1) {
          vfsResultPtr = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
      }
      Tcl_RestoreResult(interp, &savedResult);
      Tcl_DecrRefCount(mountCmd);

      if (vfsResultPtr != NULL) {
          if (returnVal == TCL_OK) {
            Tcl_IncrRefCount(vfsResultPtr);
            Tcl_ListObjAppendList(cmdInterp, returnPtr, vfsResultPtr);
            Tcl_DecrRefCount(vfsResultPtr);
          } else {
            if (cmdInterp != NULL) {
                Tcl_SetObjResult(cmdInterp, vfsResultPtr);
            } else {
                Tcl_DecrRefCount(vfsResultPtr);
            }
          }
      }
      return returnVal;
    }
}

static int
VfsDeleteFile(
    Tcl_Obj *pathPtr)         /* Pathname of file to be removed */
{
    Tcl_Obj *mountCmd = NULL;
    Tcl_SavedResult savedResult;
    int returnVal;
    Tcl_Interp* interp;
    
    mountCmd = VfsBuildCommandForPath(&interp, "deletefile", pathPtr);
    if (mountCmd == NULL) {
      return -1;
    }

    /* Now we execute this mount point's callback. */
    Tcl_SaveResult(interp, &savedResult);
    returnVal = Tcl_EvalObjEx(interp, mountCmd, 
                        TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
    if (returnVal != TCL_OK && returnVal != -1) {
      VfsInternalError(interp);
    }
    Tcl_RestoreResult(interp, &savedResult);
    Tcl_DecrRefCount(mountCmd);
    return returnVal;
}

static int
VfsCreateDirectory(
    Tcl_Obj *pathPtr)         /* Pathname of directory to create */
{
    Tcl_Obj *mountCmd = NULL;
    Tcl_SavedResult savedResult;
    int returnVal;
    Tcl_Interp* interp;
    
    mountCmd = VfsBuildCommandForPath(&interp, "createdirectory", pathPtr);
    if (mountCmd == NULL) {
      return -1;
    }

    /* Now we execute this mount point's callback. */
    Tcl_SaveResult(interp, &savedResult);
    returnVal = Tcl_EvalObjEx(interp, mountCmd, 
                        TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
    if (returnVal != TCL_OK && returnVal != -1) {
      VfsInternalError(interp);
    }
    Tcl_RestoreResult(interp, &savedResult);
    Tcl_DecrRefCount(mountCmd);
    return returnVal;
}

static int
VfsRemoveDirectory(
    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)         /* Location to store name of file
                         * causing error. */
{
    Tcl_Obj *mountCmd = NULL;
    Tcl_SavedResult savedResult;
    int returnVal;
    Tcl_Interp* interp;
    
    mountCmd = VfsBuildCommandForPath(&interp, "removedirectory", pathPtr);
    if (mountCmd == NULL) {
      return -1;
    }

    Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(recursive));
    /* Now we execute this mount point's callback. */
    Tcl_SaveResult(interp, &savedResult);
    returnVal = Tcl_EvalObjEx(interp, mountCmd, 
                        TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
    if (returnVal != TCL_OK && returnVal != -1) {
      VfsInternalError(interp);
    }
    Tcl_RestoreResult(interp, &savedResult);
    Tcl_DecrRefCount(mountCmd);

    if (returnVal == TCL_ERROR) {
      /* Assume there was a problem with the directory being non-empty */
        if (errorPtr != NULL) {
            *errorPtr = pathPtr;
          Tcl_IncrRefCount(*errorPtr);
        }
      Tcl_SetErrno(EEXIST);
    }
    return returnVal;
}

static CONST char**
VfsFileAttrStrings(pathPtr, objPtrRef)
    Tcl_Obj* pathPtr;
    Tcl_Obj** objPtrRef;
{
    Tcl_Obj *mountCmd = NULL;
    Tcl_SavedResult savedResult;
    int returnVal;
    Tcl_Interp* interp;
    
    mountCmd = VfsBuildCommandForPath(&interp, "fileattributes", pathPtr);
    if (mountCmd == NULL) {
      *objPtrRef = NULL;
      return NULL;
    }

    Tcl_SaveResult(interp, &savedResult);
    /* Now we execute this mount point's callback. */
    returnVal = Tcl_EvalObjEx(interp, mountCmd, 
                        TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
    if (returnVal != TCL_OK && returnVal != -1) {
      VfsInternalError(interp);
    }
    if (returnVal == TCL_OK) {
      *objPtrRef = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
    } else {
      *objPtrRef = NULL;
    }
    Tcl_RestoreResult(interp, &savedResult);
    Tcl_DecrRefCount(mountCmd);
    return NULL;
}

static int
VfsFileAttrsGet(cmdInterp, index, pathPtr, objPtrRef)
    Tcl_Interp *cmdInterp;    /* 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. */
{
    Tcl_Obj *mountCmd = NULL;
    Tcl_SavedResult savedResult;
    int returnVal;
    Tcl_Interp* interp;
    
    mountCmd = VfsBuildCommandForPath(&interp, "fileattributes", pathPtr);
    if (mountCmd == NULL) {
      return -1;
    }

    Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(index));
    Tcl_SaveResult(interp, &savedResult);
    /* Now we execute this mount point's callback. */
    returnVal = Tcl_EvalObjEx(interp, mountCmd, 
                        TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
    if (returnVal != -1) {
      *objPtrRef = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
    }
    Tcl_RestoreResult(interp, &savedResult);
    Tcl_DecrRefCount(mountCmd);
    
    if (returnVal != -1) {
      if (returnVal == TCL_OK) {
          /* 
           * Our caller expects a ref count of zero in
           * the returned object pointer.
           */
      } else {
          /* Leave error message in correct interp */
          if (cmdInterp != NULL) {
            Tcl_SetObjResult(cmdInterp, *objPtrRef);
          } else {
            Tcl_DecrRefCount(*objPtrRef);
          }
          *objPtrRef = NULL;
      }
    } else {
      if (cmdInterp != NULL) {
          Tcl_ResetResult(cmdInterp);
          Tcl_AppendResult(cmdInterp, "couldn't read attributes for \"", 
                       Tcl_GetString(pathPtr), "\": ",
                       Tcl_PosixError(cmdInterp), (char *) NULL);
      }
    }
    
    return returnVal;
}

static int
VfsFileAttrsSet(cmdInterp, index, pathPtr, objPtr)
    Tcl_Interp *cmdInterp;    /* The interpreter for error reporting. */
    int index;                /* index of the attribute command. */
    Tcl_Obj *pathPtr;         /* filename we are operating on. */
    Tcl_Obj *objPtr;          /* for input. */
{
    Tcl_Obj *mountCmd = NULL;
    Tcl_SavedResult savedResult;
    int returnVal;
    Tcl_Interp* interp;
    Tcl_Obj *errorPtr = NULL;
    
    mountCmd = VfsBuildCommandForPath(&interp, "fileattributes", pathPtr);
    if (mountCmd == NULL) {
      return -1;
    }

    Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(index));
    Tcl_ListObjAppendElement(interp, mountCmd, objPtr);
    Tcl_SaveResult(interp, &savedResult);
    /* Now we execute this mount point's callback. */
    returnVal = Tcl_EvalObjEx(interp, mountCmd, 
                        TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
    if (returnVal != -1 && returnVal != TCL_OK) {
      errorPtr = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
    }

    Tcl_RestoreResult(interp, &savedResult);
    Tcl_DecrRefCount(mountCmd);
    
    if (cmdInterp != NULL) {
      if (returnVal == -1) {
          Tcl_ResetResult(cmdInterp);
          Tcl_AppendResult(cmdInterp, "couldn't set attributes for \"", 
                       Tcl_GetString(pathPtr), "\": ",
                       Tcl_PosixError(cmdInterp), (char *) NULL);
      } else if (errorPtr != NULL) {
          /* 
           * Leave error message in correct interp, errorPtr was
           * duplicated above, in case of threading issues.
           */
          Tcl_SetObjResult(cmdInterp, errorPtr);
      }
    } else if (errorPtr != NULL) {
      Tcl_DecrRefCount(errorPtr);
    }
    return returnVal;
}

static int 
VfsUtime(pathPtr, tval)
    Tcl_Obj* pathPtr;
    struct utimbuf *tval;
{
    Tcl_Obj *mountCmd = NULL;
    Tcl_SavedResult savedResult;
    int returnVal;
    Tcl_Interp* interp;
    
    mountCmd = VfsBuildCommandForPath(&interp, "utime", pathPtr);
    if (mountCmd == NULL) {
      return -1;
    }

    Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewLongObj(tval->actime));
    Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewLongObj(tval->modtime));
    /* Now we execute this mount point's callback. */
    Tcl_SaveResult(interp, &savedResult);
    returnVal = Tcl_EvalObjEx(interp, mountCmd, 
                        TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
    if (returnVal != TCL_OK && returnVal != -1) {
      VfsInternalError(interp);
    }
    Tcl_RestoreResult(interp, &savedResult);
    Tcl_DecrRefCount(mountCmd);

    return returnVal;
}

static Tcl_Obj*
VfsListVolumes(void)
{
    Tcl_Obj *retVal;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (tsdPtr->vfsVolumes != NULL) {
      Tcl_IncrRefCount(tsdPtr->vfsVolumes);
      retVal = tsdPtr->vfsVolumes;
    } else {
      retVal = NULL;
    }

    return retVal;
}

static void
Vfs_AddVolume(volume)
    Tcl_Obj *volume;
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (tsdPtr->vfsVolumes == NULL) {
        tsdPtr->vfsVolumes = Tcl_NewObj();
      Tcl_IncrRefCount(tsdPtr->vfsVolumes);
    } else {
#if 0
      if (Tcl_IsShared(tsdPtr->vfsVolumes)) {
          /* 
           * Another thread is using this object, so we duplicate the
           * object and reduce the refCount on the shared one.
           */
          Tcl_Obj *oldVols = tsdPtr->vfsVolumes;
          tsdPtr->vfsVolumes = Tcl_DuplicateObj(oldVols);
          Tcl_IncrRefCount(tsdPtr->vfsVolumes);
          Tcl_DecrRefCount(oldVols);
      }
#endif
    }
    Tcl_ListObjAppendElement(NULL, tsdPtr->vfsVolumes, volume);
}

static int
Vfs_RemoveVolume(volume)
    Tcl_Obj *volume;
{
    int i, len;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    Tcl_ListObjLength(NULL, tsdPtr->vfsVolumes, &len);
    for (i = 0;i < len; i++) {
      Tcl_Obj *vol;
        Tcl_ListObjIndex(NULL, tsdPtr->vfsVolumes, i, &vol);
      if (!strcmp(Tcl_GetString(vol),Tcl_GetString(volume))) {
          /* It's in the list, at index i */
          if (len == 1) {
            /* An optimization here */
            Tcl_DecrRefCount(tsdPtr->vfsVolumes);
            tsdPtr->vfsVolumes = NULL;
          } else {
            /*
             * Make ourselves the unique owner
             * XXX: May be unnecessary now that it is tsd
             */
            if (Tcl_IsShared(tsdPtr->vfsVolumes)) {
                Tcl_Obj *oldVols = tsdPtr->vfsVolumes;
                tsdPtr->vfsVolumes = Tcl_DuplicateObj(oldVols);
                Tcl_IncrRefCount(tsdPtr->vfsVolumes);
                Tcl_DecrRefCount(oldVols);
            }
            /* Remove the element */
            Tcl_ListObjReplace(NULL, tsdPtr->vfsVolumes, i, 1, 0, NULL);
            return TCL_OK;
          }
      }
    }

    return TCL_ERROR;
}


/*
 *----------------------------------------------------------------------
 *
 * VfsBuildCommandForPath --
 *
 *    Given a path object which we know belongs to the vfs, and a 
 *    command string (one of the standard filesystem operations
 *    "stat", "matchindirectory" etc), build the standard vfs
 *    Tcl command and arguments to carry out that operation.
 *    
 *    If the command is successfully built, it is returned to the
 *    caller with a refCount of 1.  The caller also needs to know
 *    which Tcl interpreter to evaluate the command in; this
 *    is returned in the 'iRef' provided.
 *    
 *    Each mount-point dictates a command prefix to use for a 
 *    particular file.  We start with that and then add 4 parameters,
 *    as follows:
 *    
 *    (1) the 'cmd' to use
 *    (2) the mount point of this path (which is the portion of the
 *    path string which lies outside the vfs).
 *    (3) the remainder of the path which lies inside the vfs
 *    (4) the original (possibly unnormalized) path string used
 *    in the command.
 *    
 *    Example (i):
 *    
 *    If 'C:/Apps/data.zip' is mounted on top of
 *    itself, then if we do:
 *    
 *    cd C:/Apps
 *    file exists data.zip/foo/bar.txt
 *    
 *    this will lead to:
 *    
 *    <mountcmd> "access" C:/Apps/data.zip foo/bar.txt data.zip/foo/bar.txt
 *    
 *    Example (ii)
 *    
 *    If 'ftp://' is mounted as a new volume,
 *    then 'glob -dir ftp://ftp.scriptics.com *' will lead to:
 *    
 *    <mountcmd> "matchindirectory" ftp:// ftp.scriptics.com \
 *      ftp://ftp.scriptics.com
 *      
 *    
 * Results:
 *    Returns a list containing the command, or NULL if an
 *    error occurred.  If the interpreter for this vfs command
 *    is in the process of being deleted, we always return NULL.
 *
 * Side effects:
 *    None except memory allocation.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj* 
VfsBuildCommandForPath(Tcl_Interp **iRef, CONST char* cmd, Tcl_Obj *pathPtr) {
    Tcl_Obj *normed;
    Tcl_Obj *mountCmd;
    int len;
    int splitPosition;
    int dummyLen;
    VfsNativeRep *nativeRep;
    Tcl_Interp *interp;
    
    char *normedString;

    nativeRep = VfsGetNativePath(pathPtr);
    if (nativeRep == NULL) {
      return NULL;
    }
    
    interp = nativeRep->fsCmd->interp;
    
    if (Tcl_InterpDeleted(interp)) {
        return NULL;
    }
    
    splitPosition = nativeRep->splitPosition;
    normed = Tcl_FSGetNormalizedPath(NULL, pathPtr);
    normedString = Tcl_GetStringFromObj(normed, &len);
    
    mountCmd = Tcl_DuplicateObj(nativeRep->fsCmd->mountCmd);
    Tcl_IncrRefCount(mountCmd);
    if (Tcl_ListObjLength(NULL, mountCmd, &dummyLen) == TCL_ERROR) {
      Tcl_DecrRefCount(mountCmd);
      return NULL;
    }
    Tcl_ListObjAppendElement(NULL, mountCmd, Tcl_NewStringObj(cmd,-1));
    if (splitPosition == len) {
      Tcl_ListObjAppendElement(NULL, mountCmd, normed);
      Tcl_ListObjAppendElement(NULL, mountCmd, Tcl_NewStringObj("",0));
    } else {
      Tcl_ListObjAppendElement(NULL, mountCmd, 
            Tcl_NewStringObj(normedString,splitPosition));
      if ((normedString[splitPosition] != VFS_SEPARATOR) 
          || (VFS_SEPARATOR ==':')) {
          /* This will occur if we mount 'ftp://' */
          splitPosition--;
      }
      Tcl_ListObjAppendElement(NULL, mountCmd, 
            Tcl_NewStringObj(normedString+splitPosition+1,
                         len-splitPosition-1));
    }
    Tcl_ListObjAppendElement(NULL, mountCmd, pathPtr);

    if (iRef != NULL) {
        *iRef = interp;
    }
    
    return mountCmd;
}

static void 
VfsExitProc(ClientData clientData)
{
    Tcl_FSUnregister(&vfsFilesystem);
}

static void
VfsThreadExitProc(ClientData clientData)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    /*
     * This is probably no longer needed, because each individual
     * interp's cleanup will trigger removal of all volumes which
     * belong to it.
     */
    if (tsdPtr->vfsVolumes != NULL) {
      Tcl_DecrRefCount(tsdPtr->vfsVolumes);
      tsdPtr->vfsVolumes = NULL;
    }
    if (tsdPtr->internalErrorScript != NULL) {
      Tcl_DecrRefCount(tsdPtr->internalErrorScript);
      tsdPtr->internalErrorScript = NULL;
    }
}

Generated by  Doxygen 1.6.0   Back to index