/* * 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 /* 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 /* * tclvfs will return this code instead of TCL_OK/ERROR/etc. to propagate * through the Tcl_Eval* calls to indicate a posix error has been raised by * some vfs implementation. -1 is what Tcl expects, adopts from posix's * standard error value. */ #define TCLVFS_POSIXERROR (-1) #ifndef CONST86 #define CONST86 #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.4" #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); /* * This special error code propagate to the Tcl_Eval* calls in * other parts of the vfs C code to indicate a posix error * being raised by some vfs implementation. */ return TCLVFS_POSIXERROR; } 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 'TCLVFS_POSIXERROR' 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 TCLVFS_POSIXERROR; } normedObj = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (normedObj == NULL) { return TCLVFS_POSIXERROR; } 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 TCLVFS_POSIXERROR; } /* 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 TCLVFS_POSIXERROR; } } /* * 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 TCLVFS_POSIXERROR; } 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 != TCLVFS_POSIXERROR) { VfsInternalError(interp); } Tcl_RestoreResult(interp, &savedResult); Tcl_DecrRefCount(mountCmd); if (returnVal != TCL_OK && returnVal != TCLVFS_POSIXERROR) { Tcl_SetErrno(ENOENT); return TCLVFS_POSIXERROR; } 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 TCLVFS_POSIXERROR; } 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 != TCLVFS_POSIXERROR) { VfsInternalError(interp); } Tcl_RestoreResult(interp, &savedResult); Tcl_DecrRefCount(mountCmd); if (returnVal != 0) { Tcl_SetErrno(ENOENT); return TCLVFS_POSIXERROR; } 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 == TCLVFS_POSIXERROR) { 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 != TCLVFS_POSIXERROR) { 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 TCLVFS_POSIXERROR; } 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 != TCLVFS_POSIXERROR) { 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 TCLVFS_POSIXERROR; } /* 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 != TCLVFS_POSIXERROR) { 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 TCLVFS_POSIXERROR; } /* 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 != TCLVFS_POSIXERROR) { 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 TCLVFS_POSIXERROR; } 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 != TCLVFS_POSIXERROR) { 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 * CONST86 * 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 != TCLVFS_POSIXERROR) { 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 TCLVFS_POSIXERROR; } 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 != TCLVFS_POSIXERROR) { *objPtrRef = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); } Tcl_RestoreResult(interp, &savedResult); Tcl_DecrRefCount(mountCmd); if (returnVal != TCLVFS_POSIXERROR) { 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 TCLVFS_POSIXERROR; } 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 != TCLVFS_POSIXERROR && returnVal != TCL_OK) { errorPtr = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); } Tcl_RestoreResult(interp, &savedResult); Tcl_DecrRefCount(mountCmd); if (cmdInterp != NULL) { if (returnVal == TCLVFS_POSIXERROR) { 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 TCLVFS_POSIXERROR; } 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 != TCLVFS_POSIXERROR) { 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: * * "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: * * "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; } }