sl@0: /* sl@0: * tclIOUtil.c -- sl@0: * sl@0: * This file contains the implementation of Tcl's generic sl@0: * filesystem code, which supports a pluggable filesystem sl@0: * architecture allowing both platform specific filesystems and sl@0: * 'virtual filesystems'. All filesystem access should go through sl@0: * the functions defined in this file. Most of this code was sl@0: * contributed by Vince Darley. sl@0: * sl@0: * Parts of this file are based on code contributed by Karl sl@0: * Lehenbauer, Mark Diekhans and Peter da Silva. sl@0: * sl@0: * Copyright (c) 1991-1994 The Regents of the University of California. sl@0: * Copyright (c) 1994-1997 Sun Microsystems, Inc. sl@0: * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved. sl@0: * sl@0: * See the file "license.terms" for information on usage and redistribution sl@0: * of this file, and for a DISCLAIMER OF ALL WARRANTIES. sl@0: * sl@0: * RCS: @(#) $Id: tclIOUtil.c,v 1.77.2.34 2007/02/19 23:49:05 hobbs Exp $ sl@0: */ sl@0: sl@0: #include "tclInt.h" sl@0: #include "tclPort.h" sl@0: #ifdef MAC_TCL sl@0: #include "tclMacInt.h" sl@0: #endif sl@0: #ifdef __WIN32__ sl@0: /* for tclWinProcs->useWide */ sl@0: #include "tclWinInt.h" sl@0: #endif sl@0: #if defined(__SYMBIAN32__) && defined(__WINSCW__) sl@0: #include "tclSymbianGlobals.h" sl@0: #define dataKey getdataKey(4) sl@0: #endif sl@0: sl@0: /* sl@0: * struct FilesystemRecord -- sl@0: * sl@0: * A filesystem record is used to keep track of each sl@0: * filesystem currently registered with the core, sl@0: * in a linked list. Pointers to these structures sl@0: * are also kept by each "path" Tcl_Obj, and we must sl@0: * retain a refCount on the number of such references. sl@0: */ sl@0: typedef struct FilesystemRecord { sl@0: ClientData clientData; /* Client specific data for the new sl@0: * filesystem (can be NULL) */ sl@0: Tcl_Filesystem *fsPtr; /* Pointer to filesystem dispatch sl@0: * table. */ sl@0: int fileRefCount; /* How many Tcl_Obj's use this sl@0: * filesystem. */ sl@0: struct FilesystemRecord *nextPtr; sl@0: /* The next filesystem registered sl@0: * to Tcl, or NULL if no more. */ sl@0: struct FilesystemRecord *prevPtr; sl@0: /* The previous filesystem registered sl@0: * to Tcl, or NULL if no more. */ sl@0: } FilesystemRecord; sl@0: sl@0: /* sl@0: * The internal TclFS API provides routines for handling and sl@0: * manipulating paths efficiently, taking direct advantage of sl@0: * the "path" Tcl_Obj type. sl@0: * sl@0: * These functions are not exported at all at present. sl@0: */ sl@0: sl@0: int TclFSCwdPointerEquals _ANSI_ARGS_((Tcl_Obj* objPtr)); sl@0: int TclFSMakePathFromNormalized _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Obj *objPtr, ClientData clientData)); sl@0: int TclFSNormalizeToUniquePath _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Obj *pathPtr, int startAt, ClientData *clientDataPtr)); sl@0: Tcl_Obj* TclFSMakePathRelative _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Obj *objPtr, Tcl_Obj *cwdPtr)); sl@0: Tcl_Obj* TclFSInternalToNormalized _ANSI_ARGS_(( sl@0: Tcl_Filesystem *fromFilesystem, ClientData clientData, sl@0: FilesystemRecord **fsRecPtrPtr)); sl@0: int TclFSEnsureEpochOk _ANSI_ARGS_((Tcl_Obj* pathObjPtr, sl@0: Tcl_Filesystem **fsPtrPtr)); sl@0: void TclFSSetPathDetails _ANSI_ARGS_((Tcl_Obj *pathObjPtr, sl@0: FilesystemRecord *fsRecPtr, ClientData clientData)); sl@0: sl@0: /* sl@0: * Private variables for use in this file sl@0: */ sl@0: extern Tcl_Filesystem tclNativeFilesystem; sl@0: extern int theFilesystemEpoch; sl@0: sl@0: /* sl@0: * Private functions for use in this file sl@0: */ sl@0: static Tcl_PathType FSGetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr, sl@0: Tcl_Filesystem **filesystemPtrPtr, sl@0: int *driveNameLengthPtr)); sl@0: static Tcl_PathType GetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr, sl@0: Tcl_Filesystem **filesystemPtrPtr, sl@0: int *driveNameLengthPtr, Tcl_Obj **driveNameRef)); sl@0: static Tcl_FSPathInFilesystemProc NativePathInFilesystem; sl@0: static Tcl_Obj* TclFSNormalizeAbsolutePath sl@0: _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr, sl@0: ClientData *clientDataPtr)); sl@0: /* sl@0: * Prototypes for procedures defined later in this file. sl@0: */ sl@0: sl@0: static FilesystemRecord* FsGetFirstFilesystem(void); sl@0: static void FsThrExitProc(ClientData cd); sl@0: static Tcl_Obj* FsListMounts _ANSI_ARGS_((Tcl_Obj *pathPtr, sl@0: CONST char *pattern)); sl@0: static Tcl_Obj* FsAddMountsToGlobResult _ANSI_ARGS_((Tcl_Obj *result, sl@0: Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types)); sl@0: sl@0: #ifdef TCL_THREADS sl@0: static void FsRecacheFilesystemList(void); sl@0: #endif sl@0: sl@0: /* sl@0: * These form part of the native filesystem support. They are needed sl@0: * here because we have a few native filesystem functions (which are sl@0: * the same for mac/win/unix) in this file. There is no need to place sl@0: * them in tclInt.h, because they are not (and should not be) used sl@0: * anywhere else. sl@0: */ sl@0: extern CONST char * tclpFileAttrStrings[]; sl@0: extern CONST TclFileAttrProcs tclpFileAttrProcs[]; sl@0: sl@0: /* sl@0: * The following functions are obsolete string based APIs, and should sl@0: * be removed in a future release (Tcl 9 would be a good time). sl@0: */ sl@0: sl@0: /* Obsolete */ sl@0: EXPORT_C int sl@0: Tcl_Stat(path, oldStyleBuf) sl@0: CONST char *path; /* Path of file to stat (in current CP). */ sl@0: struct stat *oldStyleBuf; /* Filled with results of stat call. */ sl@0: { sl@0: int ret; sl@0: Tcl_StatBuf buf; sl@0: Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); sl@0: sl@0: Tcl_IncrRefCount(pathPtr); sl@0: ret = Tcl_FSStat(pathPtr, &buf); sl@0: Tcl_DecrRefCount(pathPtr); sl@0: if (ret != -1) { sl@0: #ifndef TCL_WIDE_INT_IS_LONG sl@0: # define OUT_OF_RANGE(x) \ sl@0: (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \ sl@0: ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX)) sl@0: #if defined(__GNUC__) && __GNUC__ >= 2 sl@0: /* sl@0: * Workaround gcc warning of "comparison is always false due to limited range of sl@0: * data type" in this macro by checking max type size, and when necessary ANDing sl@0: * with the complement of ULONG_MAX instead of the comparison: sl@0: */ sl@0: # define OUT_OF_URANGE(x) \ sl@0: ((((Tcl_WideUInt)(~ (__typeof__(x)) 0)) > (Tcl_WideUInt)ULONG_MAX) && \ sl@0: (((Tcl_WideUInt)(x)) & ~(Tcl_WideUInt)ULONG_MAX)) sl@0: #else sl@0: # define OUT_OF_URANGE(x) \ sl@0: (((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX) sl@0: #endif sl@0: sl@0: /* sl@0: * Perform the result-buffer overflow check manually. sl@0: * sl@0: * Note that ino_t/ino64_t is unsigned... sl@0: */ sl@0: sl@0: if (OUT_OF_URANGE(buf.st_ino) || OUT_OF_RANGE(buf.st_size) sl@0: #ifdef HAVE_ST_BLOCKS sl@0: || OUT_OF_RANGE(buf.st_blocks) sl@0: #endif sl@0: ) { sl@0: #ifdef EFBIG sl@0: errno = EFBIG; sl@0: #else sl@0: # ifdef EOVERFLOW sl@0: errno = EOVERFLOW; sl@0: # else sl@0: # error "What status should be returned for file size out of range?" sl@0: # endif sl@0: #endif sl@0: return -1; sl@0: } sl@0: sl@0: # undef OUT_OF_RANGE sl@0: # undef OUT_OF_URANGE sl@0: #endif /* !TCL_WIDE_INT_IS_LONG */ sl@0: sl@0: /* sl@0: * Copy across all supported fields, with possible type sl@0: * coercions on those fields that change between the normal sl@0: * and lf64 versions of the stat structure (on Solaris at sl@0: * least.) This is slow when the structure sizes coincide, sl@0: * but that's what you get for using an obsolete interface. sl@0: */ sl@0: sl@0: oldStyleBuf->st_mode = buf.st_mode; sl@0: oldStyleBuf->st_ino = (ino_t) buf.st_ino; sl@0: oldStyleBuf->st_dev = buf.st_dev; sl@0: oldStyleBuf->st_rdev = buf.st_rdev; sl@0: oldStyleBuf->st_nlink = buf.st_nlink; sl@0: oldStyleBuf->st_uid = buf.st_uid; sl@0: oldStyleBuf->st_gid = buf.st_gid; sl@0: oldStyleBuf->st_size = (off_t) buf.st_size; sl@0: oldStyleBuf->st_atime = buf.st_atime; sl@0: oldStyleBuf->st_mtime = buf.st_mtime; sl@0: oldStyleBuf->st_ctime = buf.st_ctime; sl@0: #ifdef HAVE_ST_BLOCKS sl@0: oldStyleBuf->st_blksize = buf.st_blksize; sl@0: oldStyleBuf->st_blocks = (blkcnt_t) buf.st_blocks; sl@0: #endif sl@0: } sl@0: return ret; sl@0: } sl@0: sl@0: /* Obsolete */ sl@0: EXPORT_C int sl@0: Tcl_Access(path, mode) sl@0: CONST char *path; /* Path of file to access (in current CP). */ sl@0: int mode; /* Permission setting. */ sl@0: { sl@0: int ret; sl@0: Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); sl@0: Tcl_IncrRefCount(pathPtr); sl@0: ret = Tcl_FSAccess(pathPtr,mode); sl@0: Tcl_DecrRefCount(pathPtr); sl@0: return ret; sl@0: } sl@0: sl@0: /* Obsolete */ sl@0: EXPORT_C Tcl_Channel sl@0: Tcl_OpenFileChannel(interp, path, modeString, permissions) sl@0: Tcl_Interp *interp; /* Interpreter for error reporting; sl@0: * can be NULL. */ sl@0: CONST char *path; /* Name of file to open. */ sl@0: CONST char *modeString; /* A list of POSIX open modes or sl@0: * a string such as "rw". */ sl@0: int permissions; /* If the open involves creating a sl@0: * file, with what modes to create sl@0: * it? */ sl@0: { sl@0: Tcl_Channel ret; sl@0: Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); sl@0: Tcl_IncrRefCount(pathPtr); sl@0: ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions); sl@0: Tcl_DecrRefCount(pathPtr); sl@0: return ret; sl@0: sl@0: } sl@0: sl@0: /* Obsolete */ sl@0: EXPORT_C int sl@0: Tcl_Chdir(dirName) sl@0: CONST char *dirName; sl@0: { sl@0: int ret; sl@0: Tcl_Obj *pathPtr = Tcl_NewStringObj(dirName,-1); sl@0: Tcl_IncrRefCount(pathPtr); sl@0: ret = Tcl_FSChdir(pathPtr); sl@0: Tcl_DecrRefCount(pathPtr); sl@0: return ret; sl@0: } sl@0: sl@0: /* Obsolete */ sl@0: EXPORT_C char * sl@0: Tcl_GetCwd(interp, cwdPtr) sl@0: Tcl_Interp *interp; sl@0: Tcl_DString *cwdPtr; sl@0: { sl@0: Tcl_Obj *cwd; sl@0: cwd = Tcl_FSGetCwd(interp); sl@0: if (cwd == NULL) { sl@0: return NULL; sl@0: } else { sl@0: Tcl_DStringInit(cwdPtr); sl@0: Tcl_DStringAppend(cwdPtr, Tcl_GetString(cwd), -1); sl@0: Tcl_DecrRefCount(cwd); sl@0: return Tcl_DStringValue(cwdPtr); sl@0: } sl@0: } sl@0: sl@0: /* Obsolete */ sl@0: EXPORT_C int sl@0: Tcl_EvalFile(interp, fileName) sl@0: Tcl_Interp *interp; /* Interpreter in which to process file. */ sl@0: CONST char *fileName; /* Name of file to process. Tilde-substitution sl@0: * will be performed on this name. */ sl@0: { sl@0: int ret; sl@0: Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1); sl@0: Tcl_IncrRefCount(pathPtr); sl@0: ret = Tcl_FSEvalFile(interp, pathPtr); sl@0: Tcl_DecrRefCount(pathPtr); sl@0: return ret; sl@0: } sl@0: sl@0: sl@0: /* sl@0: * The 3 hooks for Stat, Access and OpenFileChannel are obsolete. The sl@0: * complete, general hooked filesystem APIs should be used instead. sl@0: * This define decides whether to include the obsolete hooks and sl@0: * related code. If these are removed, we'll also want to remove them sl@0: * from stubs/tclInt. The only known users of these APIs are prowrap sl@0: * and mktclapp. New code/extensions should not use them, since they sl@0: * do not provide as full support as the full filesystem API. sl@0: * sl@0: * As soon as prowrap and mktclapp are updated to use the full sl@0: * filesystem support, I suggest all these hooks are removed. sl@0: */ sl@0: #define USE_OBSOLETE_FS_HOOKS sl@0: sl@0: sl@0: #ifdef USE_OBSOLETE_FS_HOOKS sl@0: /* sl@0: * The following typedef declarations allow for hooking into the chain sl@0: * of functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' & sl@0: * 'Tcl_OpenFileChannel(...)'. Basically for each hookable function sl@0: * a linked list is defined. sl@0: */ sl@0: sl@0: typedef struct StatProc { sl@0: TclStatProc_ *proc; /* Function to process a 'stat()' call */ sl@0: struct StatProc *nextPtr; /* The next 'stat()' function to call */ sl@0: } StatProc; sl@0: sl@0: typedef struct AccessProc { sl@0: TclAccessProc_ *proc; /* Function to process a 'access()' call */ sl@0: struct AccessProc *nextPtr; /* The next 'access()' function to call */ sl@0: } AccessProc; sl@0: sl@0: typedef struct OpenFileChannelProc { sl@0: TclOpenFileChannelProc_ *proc; /* Function to process a sl@0: * 'Tcl_OpenFileChannel()' call */ sl@0: struct OpenFileChannelProc *nextPtr; sl@0: /* The next 'Tcl_OpenFileChannel()' sl@0: * function to call */ sl@0: } OpenFileChannelProc; sl@0: sl@0: /* sl@0: * For each type of (obsolete) hookable function, a static node is sl@0: * declared to hold the function pointer for the "built-in" routine sl@0: * (e.g. 'TclpStat(...)') and the respective list is initialized as a sl@0: * pointer to that node. sl@0: * sl@0: * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that sl@0: * these statically declared list entry cannot be inadvertently removed. sl@0: * sl@0: * This method avoids the need to call any sort of "initialization" sl@0: * function. sl@0: * sl@0: * All three lists are protected by a global obsoleteFsHookMutex. sl@0: */ sl@0: sl@0: static StatProc *statProcList = NULL; sl@0: static AccessProc *accessProcList = NULL; sl@0: static OpenFileChannelProc *openFileChannelProcList = NULL; sl@0: sl@0: TCL_DECLARE_MUTEX(obsoleteFsHookMutex) sl@0: sl@0: #endif /* USE_OBSOLETE_FS_HOOKS */ sl@0: sl@0: /* sl@0: * Declare the native filesystem support. These functions should sl@0: * be considered private to Tcl, and should really not be called sl@0: * directly by any code other than this file (i.e. neither by sl@0: * Tcl's core nor by extensions). Similarly, the old string-based sl@0: * Tclp... native filesystem functions should not be called. sl@0: * sl@0: * The correct API to use now is the Tcl_FS... set of functions, sl@0: * which ensure correct and complete virtual filesystem support. sl@0: * sl@0: * We cannot make all of these static, since some of them sl@0: * are implemented in the platform-specific directories. sl@0: */ sl@0: static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator; sl@0: static Tcl_FSFreeInternalRepProc NativeFreeInternalRep; sl@0: static Tcl_FSCreateInternalRepProc NativeCreateNativeRep; sl@0: static Tcl_FSFileAttrStringsProc NativeFileAttrStrings; sl@0: static Tcl_FSFileAttrsGetProc NativeFileAttrsGet; sl@0: static Tcl_FSFileAttrsSetProc NativeFileAttrsSet; sl@0: sl@0: /* sl@0: * The only reason these functions are not static is that they sl@0: * are either called by code in the native (win/unix/mac) directories sl@0: * or they are actually implemented in those directories. They sl@0: * should simply not be called by code outside Tcl's native sl@0: * filesystem core. i.e. they should be considered 'static' to sl@0: * Tcl's filesystem code (if we ever built the native filesystem sl@0: * support into a separate code library, this could actually be sl@0: * enforced). sl@0: */ sl@0: Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType; sl@0: Tcl_FSInternalToNormalizedProc TclpNativeToNormalized; sl@0: Tcl_FSStatProc TclpObjStat; sl@0: Tcl_FSAccessProc TclpObjAccess; sl@0: Tcl_FSMatchInDirectoryProc TclpMatchInDirectory; sl@0: Tcl_FSGetCwdProc TclpObjGetCwd; sl@0: Tcl_FSChdirProc TclpObjChdir; sl@0: Tcl_FSLstatProc TclpObjLstat; sl@0: Tcl_FSCopyFileProc TclpObjCopyFile; sl@0: Tcl_FSDeleteFileProc TclpObjDeleteFile; sl@0: Tcl_FSRenameFileProc TclpObjRenameFile; sl@0: Tcl_FSCreateDirectoryProc TclpObjCreateDirectory; sl@0: Tcl_FSCopyDirectoryProc TclpObjCopyDirectory; sl@0: Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory; sl@0: Tcl_FSUnloadFileProc TclpUnloadFile; sl@0: Tcl_FSLinkProc TclpObjLink; sl@0: Tcl_FSListVolumesProc TclpObjListVolumes; sl@0: sl@0: /* sl@0: * Define the native filesystem dispatch table. If necessary, it sl@0: * is ok to make this non-static, but it should only be accessed sl@0: * by the functions actually listed within it (or perhaps other sl@0: * helper functions of them). Anything which is not part of this sl@0: * 'native filesystem implementation' should not be delving inside sl@0: * here! sl@0: */ sl@0: Tcl_Filesystem tclNativeFilesystem = { sl@0: "native", sl@0: sizeof(Tcl_Filesystem), sl@0: TCL_FILESYSTEM_VERSION_1, sl@0: &NativePathInFilesystem, sl@0: &TclNativeDupInternalRep, sl@0: &NativeFreeInternalRep, sl@0: &TclpNativeToNormalized, sl@0: &NativeCreateNativeRep, sl@0: &TclpObjNormalizePath, sl@0: &TclpFilesystemPathType, sl@0: &NativeFilesystemSeparator, sl@0: &TclpObjStat, sl@0: &TclpObjAccess, sl@0: &TclpOpenFileChannel, sl@0: &TclpMatchInDirectory, sl@0: &TclpUtime, sl@0: #ifndef S_IFLNK sl@0: NULL, sl@0: #else sl@0: &TclpObjLink, sl@0: #endif /* S_IFLNK */ sl@0: &TclpObjListVolumes, sl@0: &NativeFileAttrStrings, sl@0: &NativeFileAttrsGet, sl@0: &NativeFileAttrsSet, sl@0: &TclpObjCreateDirectory, sl@0: &TclpObjRemoveDirectory, sl@0: &TclpObjDeleteFile, sl@0: &TclpObjCopyFile, sl@0: &TclpObjRenameFile, sl@0: &TclpObjCopyDirectory, sl@0: &TclpObjLstat, sl@0: &TclpDlopen, sl@0: &TclpObjGetCwd, sl@0: &TclpObjChdir sl@0: }; sl@0: sl@0: /* sl@0: * Define the tail of the linked list. Note that for unconventional sl@0: * uses of Tcl without a native filesystem, we may in the future wish sl@0: * to modify the current approach of hard-coding the native filesystem sl@0: * in the lookup list 'filesystemList' below. sl@0: * sl@0: * We initialize the record so that it thinks one file uses it. This sl@0: * means it will never be freed. sl@0: */ sl@0: static FilesystemRecord nativeFilesystemRecord = { sl@0: NULL, sl@0: &tclNativeFilesystem, sl@0: 1, sl@0: NULL sl@0: }; sl@0: sl@0: /* sl@0: * This is incremented each time we modify the linked list of sl@0: * filesystems. Any time it changes, all cached filesystem sl@0: * representations are suspect and must be freed. sl@0: * For multithreading builds, change of the filesystem epoch sl@0: * will trigger cache cleanup in all threads. sl@0: */ sl@0: int theFilesystemEpoch = 0; sl@0: sl@0: /* sl@0: * Stores the linked list of filesystems. A 1:1 copy of this sl@0: * list is also maintained in the TSD for each thread. This sl@0: * is to avoid synchronization issues. sl@0: */ sl@0: static FilesystemRecord *filesystemList = &nativeFilesystemRecord; sl@0: sl@0: TCL_DECLARE_MUTEX(filesystemMutex) sl@0: sl@0: #if !defined(__SYMBIAN32__) || !defined(__WINSCW__) sl@0: /* sl@0: * Used to implement Tcl_FSGetCwd in a file-system independent way. sl@0: */ sl@0: static Tcl_Obj* cwdPathPtr = NULL; sl@0: static int cwdPathEpoch = 0; sl@0: #endif sl@0: TCL_DECLARE_MUTEX(cwdMutex) sl@0: sl@0: /* sl@0: * This structure holds per-thread private copies of sl@0: * some global data. This way we avoid most of the sl@0: * synchronization calls which boosts performance, at sl@0: * cost of having to update this information each sl@0: * time the corresponding epoch counter changes. sl@0: * sl@0: */ sl@0: typedef struct ThreadSpecificData { sl@0: int initialized; sl@0: int cwdPathEpoch; sl@0: int filesystemEpoch; sl@0: Tcl_Obj *cwdPathPtr; sl@0: FilesystemRecord *filesystemList; sl@0: } ThreadSpecificData; sl@0: sl@0: #if !defined(__SYMBIAN32__) || !defined(__WINSCW__) sl@0: static Tcl_ThreadDataKey dataKey; sl@0: #endif sl@0: sl@0: /* sl@0: * Declare fallback support function and sl@0: * information for Tcl_FSLoadFile sl@0: */ sl@0: static Tcl_FSUnloadFileProc FSUnloadTempFile; sl@0: sl@0: /* sl@0: * One of these structures is used each time we successfully load a sl@0: * file from a file system by way of making a temporary copy of the sl@0: * file on the native filesystem. We need to store both the actual sl@0: * unloadProc/clientData combination which was used, and the original sl@0: * and modified filenames, so that we can correctly undo the entire sl@0: * operation when we want to unload the code. sl@0: */ sl@0: typedef struct FsDivertLoad { sl@0: Tcl_LoadHandle loadHandle; sl@0: Tcl_FSUnloadFileProc *unloadProcPtr; sl@0: Tcl_Obj *divertedFile; sl@0: Tcl_Filesystem *divertedFilesystem; sl@0: ClientData divertedFileNativeRep; sl@0: } FsDivertLoad; sl@0: sl@0: /* Now move on to the basic filesystem implementation */ sl@0: sl@0: static void sl@0: FsThrExitProc(cd) sl@0: ClientData cd; sl@0: { sl@0: ThreadSpecificData *tsdPtr = (ThreadSpecificData*)cd; sl@0: FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL; sl@0: sl@0: /* Trash the cwd copy */ sl@0: if (tsdPtr->cwdPathPtr != NULL) { sl@0: Tcl_DecrRefCount(tsdPtr->cwdPathPtr); sl@0: tsdPtr->cwdPathPtr = NULL; sl@0: } sl@0: /* Trash the filesystems cache */ sl@0: fsRecPtr = tsdPtr->filesystemList; sl@0: while (fsRecPtr != NULL) { sl@0: tmpFsRecPtr = fsRecPtr->nextPtr; sl@0: if (--fsRecPtr->fileRefCount <= 0) { sl@0: ckfree((char *)fsRecPtr); sl@0: } sl@0: fsRecPtr = tmpFsRecPtr; sl@0: } sl@0: tsdPtr->initialized = 0; sl@0: } sl@0: sl@0: int sl@0: TclFSCwdPointerEquals(objPtr) sl@0: Tcl_Obj* objPtr; sl@0: { sl@0: ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); sl@0: sl@0: Tcl_MutexLock(&cwdMutex); sl@0: #if !defined(__SYMBIAN32__) || !defined(__WINSCW__) sl@0: if (tsdPtr->cwdPathPtr == NULL) { sl@0: if (cwdPathPtr == NULL) { sl@0: tsdPtr->cwdPathPtr = NULL; sl@0: } else { sl@0: tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr); sl@0: Tcl_IncrRefCount(tsdPtr->cwdPathPtr); sl@0: } sl@0: tsdPtr->cwdPathEpoch = cwdPathEpoch; sl@0: } else if (tsdPtr->cwdPathEpoch != cwdPathEpoch) { sl@0: Tcl_DecrRefCount(tsdPtr->cwdPathPtr); sl@0: if (cwdPathPtr == NULL) { sl@0: tsdPtr->cwdPathPtr = NULL; sl@0: } else { sl@0: tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr); sl@0: Tcl_IncrRefCount(tsdPtr->cwdPathPtr); sl@0: } sl@0: } sl@0: #else sl@0: if (tsdPtr->cwdPathPtr == NULL) { sl@0: if (glcwdPathPtr == NULL) { sl@0: tsdPtr->cwdPathPtr = NULL; sl@0: } else { sl@0: tsdPtr->cwdPathPtr = Tcl_DuplicateObj(glcwdPathPtr); sl@0: Tcl_IncrRefCount(tsdPtr->cwdPathPtr); sl@0: } sl@0: tsdPtr->cwdPathEpoch = glcwdPathEpoch; sl@0: } else if (tsdPtr->cwdPathEpoch != glcwdPathEpoch) { sl@0: Tcl_DecrRefCount(tsdPtr->cwdPathPtr); sl@0: if (glcwdPathPtr == NULL) { sl@0: tsdPtr->cwdPathPtr = NULL; sl@0: } else { sl@0: tsdPtr->cwdPathPtr = Tcl_DuplicateObj(glcwdPathPtr); sl@0: Tcl_IncrRefCount(tsdPtr->cwdPathPtr); sl@0: } sl@0: } sl@0: #endif sl@0: Tcl_MutexUnlock(&cwdMutex); sl@0: sl@0: if (tsdPtr->initialized == 0) { sl@0: Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData)tsdPtr); sl@0: tsdPtr->initialized = 1; sl@0: } sl@0: return (tsdPtr->cwdPathPtr == objPtr); sl@0: } sl@0: #ifdef TCL_THREADS sl@0: sl@0: static void sl@0: FsRecacheFilesystemList(void) sl@0: { sl@0: ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); sl@0: FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL; sl@0: sl@0: /* Trash the current cache */ sl@0: fsRecPtr = tsdPtr->filesystemList; sl@0: while (fsRecPtr != NULL) { sl@0: tmpFsRecPtr = fsRecPtr->nextPtr; sl@0: if (--fsRecPtr->fileRefCount <= 0) { sl@0: ckfree((char *)fsRecPtr); sl@0: } sl@0: fsRecPtr = tmpFsRecPtr; sl@0: } sl@0: tsdPtr->filesystemList = NULL; sl@0: sl@0: /* sl@0: * Code below operates on shared data. We sl@0: * are already called under mutex lock so sl@0: * we can safely proceed. sl@0: */ sl@0: sl@0: /* Locate tail of the global filesystem list */ sl@0: fsRecPtr = filesystemList; sl@0: while (fsRecPtr != NULL) { sl@0: tmpFsRecPtr = fsRecPtr; sl@0: fsRecPtr = fsRecPtr->nextPtr; sl@0: } sl@0: sl@0: /* Refill the cache honouring the order */ sl@0: fsRecPtr = tmpFsRecPtr; sl@0: while (fsRecPtr != NULL) { sl@0: tmpFsRecPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord)); sl@0: *tmpFsRecPtr = *fsRecPtr; sl@0: tmpFsRecPtr->nextPtr = tsdPtr->filesystemList; sl@0: tmpFsRecPtr->prevPtr = NULL; sl@0: if (tsdPtr->filesystemList) { sl@0: tsdPtr->filesystemList->prevPtr = tmpFsRecPtr; sl@0: } sl@0: tsdPtr->filesystemList = tmpFsRecPtr; sl@0: fsRecPtr = fsRecPtr->prevPtr; sl@0: } sl@0: sl@0: /* Make sure the above gets released on thread exit */ sl@0: if (tsdPtr->initialized == 0) { sl@0: Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData)tsdPtr); sl@0: tsdPtr->initialized = 1; sl@0: } sl@0: } sl@0: #endif sl@0: sl@0: static FilesystemRecord * sl@0: FsGetFirstFilesystem(void) { sl@0: ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); sl@0: FilesystemRecord *fsRecPtr; sl@0: #ifndef TCL_THREADS sl@0: tsdPtr->filesystemEpoch = theFilesystemEpoch; sl@0: fsRecPtr = filesystemList; sl@0: #else sl@0: Tcl_MutexLock(&filesystemMutex); sl@0: if (tsdPtr->filesystemList == NULL sl@0: || (tsdPtr->filesystemEpoch != theFilesystemEpoch)) { sl@0: FsRecacheFilesystemList(); sl@0: tsdPtr->filesystemEpoch = theFilesystemEpoch; sl@0: } sl@0: Tcl_MutexUnlock(&filesystemMutex); sl@0: fsRecPtr = tsdPtr->filesystemList; sl@0: #endif sl@0: return fsRecPtr; sl@0: } sl@0: sl@0: static void sl@0: FsUpdateCwd(cwdObj) sl@0: Tcl_Obj *cwdObj; sl@0: { sl@0: int len; sl@0: char *str = NULL; sl@0: ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); sl@0: sl@0: if (cwdObj != NULL) { sl@0: str = Tcl_GetStringFromObj(cwdObj, &len); sl@0: } sl@0: sl@0: Tcl_MutexLock(&cwdMutex); sl@0: #if !defined(__SYMBIAN32__) || !defined(__WINSCW__) sl@0: if (cwdPathPtr != NULL) { sl@0: Tcl_DecrRefCount(cwdPathPtr); sl@0: } sl@0: if (cwdObj == NULL) { sl@0: cwdPathPtr = NULL; sl@0: } else { sl@0: /* This MUST be stored as string object! */ sl@0: cwdPathPtr = Tcl_NewStringObj(str, len); sl@0: Tcl_IncrRefCount(cwdPathPtr); sl@0: } sl@0: cwdPathEpoch++; sl@0: tsdPtr->cwdPathEpoch = cwdPathEpoch; sl@0: #else sl@0: if (glcwdPathPtr != NULL) { sl@0: Tcl_DecrRefCount(glcwdPathPtr); sl@0: } sl@0: if (cwdObj == NULL) { sl@0: glcwdPathPtr = NULL; sl@0: } else { sl@0: /* This MUST be stored as string object! */ sl@0: glcwdPathPtr = Tcl_NewStringObj(str, len); sl@0: Tcl_IncrRefCount(glcwdPathPtr); sl@0: } sl@0: glcwdPathEpoch++; sl@0: tsdPtr->cwdPathEpoch = glcwdPathEpoch; sl@0: #endif sl@0: Tcl_MutexUnlock(&cwdMutex); sl@0: sl@0: if (tsdPtr->cwdPathPtr) { sl@0: Tcl_DecrRefCount(tsdPtr->cwdPathPtr); sl@0: } sl@0: if (cwdObj == NULL) { sl@0: tsdPtr->cwdPathPtr = NULL; sl@0: } else { sl@0: tsdPtr->cwdPathPtr = Tcl_NewStringObj(str, len); sl@0: Tcl_IncrRefCount(tsdPtr->cwdPathPtr); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclFinalizeFilesystem -- sl@0: * sl@0: * Clean up the filesystem. After this, calls to all Tcl_FS... sl@0: * functions will fail. sl@0: * sl@0: * We will later call TclResetFilesystem to restore the FS sl@0: * to a pristine state. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Frees any memory allocated by the filesystem. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: TclFinalizeFilesystem() sl@0: { sl@0: FilesystemRecord *fsRecPtr; sl@0: sl@0: /* sl@0: * Assumption that only one thread is active now. Otherwise sl@0: * we would need to put various mutexes around this code. sl@0: */ sl@0: #if !defined(__SYMBIAN32__) || !defined(__WINSCW__) sl@0: if (cwdPathPtr != NULL) { sl@0: Tcl_DecrRefCount(cwdPathPtr); sl@0: cwdPathPtr = NULL; sl@0: cwdPathEpoch = 0; sl@0: #else sl@0: if (glcwdPathPtr != NULL) { sl@0: Tcl_DecrRefCount(glcwdPathPtr); sl@0: glcwdPathPtr = NULL; sl@0: glcwdPathEpoch = 0; sl@0: #endif sl@0: } sl@0: sl@0: /* sl@0: * Remove all filesystems, freeing any allocated memory sl@0: * that is no longer needed sl@0: */ sl@0: sl@0: fsRecPtr = filesystemList; sl@0: while (fsRecPtr != NULL) { sl@0: FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr; sl@0: if (fsRecPtr->fileRefCount <= 0) { sl@0: /* The native filesystem is static, so we don't free it */ sl@0: if (fsRecPtr->fsPtr != &tclNativeFilesystem) { sl@0: ckfree((char *)fsRecPtr); sl@0: } sl@0: } sl@0: fsRecPtr = tmpFsRecPtr; sl@0: } sl@0: filesystemList = NULL; sl@0: sl@0: /* sl@0: * Now filesystemList is NULL. This means that any attempt sl@0: * to use the filesystem is likely to fail. sl@0: */ sl@0: sl@0: statProcList = NULL; sl@0: accessProcList = NULL; sl@0: openFileChannelProcList = NULL; sl@0: #ifdef __WIN32__ sl@0: TclWinEncodingsCleanup(); sl@0: #endif sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclResetFilesystem -- sl@0: * sl@0: * Restore the filesystem to a pristine state. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: TclResetFilesystem() sl@0: { sl@0: filesystemList = &nativeFilesystemRecord; sl@0: sl@0: /* sl@0: * Note, at this point, I believe nativeFilesystemRecord -> sl@0: * fileRefCount should equal 1 and if not, we should try to track sl@0: * down the cause. sl@0: */ sl@0: sl@0: #ifdef __WIN32__ sl@0: /* sl@0: * Cleans up the win32 API filesystem proc lookup table. This must sl@0: * happen very late in finalization so that deleting of copied sl@0: * dlls can occur. sl@0: */ sl@0: TclWinResetInterfaces(); sl@0: #endif sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSRegister -- sl@0: * sl@0: * Insert the filesystem function table at the head of the list of sl@0: * functions which are used during calls to all file-system sl@0: * operations. The filesystem will be added even if it is sl@0: * already in the list. (You can use Tcl_FSData to sl@0: * check if it is in the list, provided the ClientData used was sl@0: * not NULL). sl@0: * sl@0: * Note that the filesystem handling is head-to-tail of the list. sl@0: * Each filesystem is asked in turn whether it can handle a sl@0: * particular request, _until_ one of them says 'yes'. At that sl@0: * point no further filesystems are asked. sl@0: * sl@0: * In particular this means if you want to add a diagnostic sl@0: * filesystem (which simply reports all fs activity), it must be sl@0: * at the head of the list: i.e. it must be the last registered. sl@0: * sl@0: * Results: sl@0: * Normally TCL_OK; TCL_ERROR if memory for a new node in the list sl@0: * could not be allocated. sl@0: * sl@0: * Side effects: sl@0: * Memory allocated and modifies the link list for filesystems. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_FSRegister(clientData, fsPtr) sl@0: ClientData clientData; /* Client specific data for this fs */ sl@0: Tcl_Filesystem *fsPtr; /* The filesystem record for the new fs. */ sl@0: { sl@0: FilesystemRecord *newFilesystemPtr; sl@0: sl@0: if (fsPtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: newFilesystemPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord)); sl@0: sl@0: newFilesystemPtr->clientData = clientData; sl@0: newFilesystemPtr->fsPtr = fsPtr; sl@0: /* sl@0: * We start with a refCount of 1. If this drops to zero, then sl@0: * anyone is welcome to ckfree us. sl@0: */ sl@0: newFilesystemPtr->fileRefCount = 1; sl@0: sl@0: /* sl@0: * Is this lock and wait strictly speaking necessary? Since any sl@0: * iterators out there will have grabbed a copy of the head of sl@0: * the list and be iterating away from that, if we add a new sl@0: * element to the head of the list, it can't possibly have any sl@0: * effect on any of their loops. In fact it could be better not sl@0: * to wait, since we are adjusting the filesystem epoch, any sl@0: * cached representations calculated by existing iterators are sl@0: * going to have to be thrown away anyway. sl@0: * sl@0: * However, since registering and unregistering filesystems is sl@0: * a very rare action, this is not a very important point. sl@0: */ sl@0: Tcl_MutexLock(&filesystemMutex); sl@0: sl@0: newFilesystemPtr->nextPtr = filesystemList; sl@0: newFilesystemPtr->prevPtr = NULL; sl@0: if (filesystemList) { sl@0: filesystemList->prevPtr = newFilesystemPtr; sl@0: } sl@0: filesystemList = newFilesystemPtr; sl@0: sl@0: /* sl@0: * Increment the filesystem epoch counter, since existing paths sl@0: * might conceivably now belong to different filesystems. sl@0: */ sl@0: theFilesystemEpoch++; sl@0: Tcl_MutexUnlock(&filesystemMutex); sl@0: sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSUnregister -- sl@0: * sl@0: * Remove the passed filesystem from the list of filesystem sl@0: * function tables. It also ensures that the built-in sl@0: * (native) filesystem is not removable, although we may wish sl@0: * to change that decision in the future to allow a smaller sl@0: * Tcl core, in which the native filesystem is not used at sl@0: * all (we could, say, initialise Tcl completely over a network sl@0: * connection). sl@0: * sl@0: * Results: sl@0: * TCL_OK if the procedure pointer was successfully removed, sl@0: * TCL_ERROR otherwise. sl@0: * sl@0: * Side effects: sl@0: * Memory may be deallocated (or will be later, once no "path" sl@0: * objects refer to this filesystem), but the list of registered sl@0: * filesystems is updated immediately. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_FSUnregister(fsPtr) sl@0: Tcl_Filesystem *fsPtr; /* The filesystem record to remove. */ sl@0: { sl@0: int retVal = TCL_ERROR; sl@0: FilesystemRecord *fsRecPtr; sl@0: sl@0: Tcl_MutexLock(&filesystemMutex); sl@0: sl@0: /* sl@0: * Traverse the 'filesystemList' looking for the particular node sl@0: * whose 'fsPtr' member matches 'fsPtr' and remove that one from sl@0: * the list. Ensure that the "default" node cannot be removed. sl@0: */ sl@0: sl@0: fsRecPtr = filesystemList; sl@0: while ((retVal == TCL_ERROR) && (fsRecPtr->fsPtr != &tclNativeFilesystem)) { sl@0: if (fsRecPtr->fsPtr == fsPtr) { sl@0: if (fsRecPtr->prevPtr) { sl@0: fsRecPtr->prevPtr->nextPtr = fsRecPtr->nextPtr; sl@0: } else { sl@0: filesystemList = fsRecPtr->nextPtr; sl@0: } sl@0: if (fsRecPtr->nextPtr) { sl@0: fsRecPtr->nextPtr->prevPtr = fsRecPtr->prevPtr; sl@0: } sl@0: /* sl@0: * Increment the filesystem epoch counter, since existing sl@0: * paths might conceivably now belong to different sl@0: * filesystems. This should also ensure that paths which sl@0: * have cached the filesystem which is about to be deleted sl@0: * do not reference that filesystem (which would of course sl@0: * lead to memory exceptions). sl@0: */ sl@0: theFilesystemEpoch++; sl@0: sl@0: fsRecPtr->fileRefCount--; sl@0: if (fsRecPtr->fileRefCount <= 0) { sl@0: ckfree((char *)fsRecPtr); sl@0: } sl@0: sl@0: retVal = TCL_OK; sl@0: } else { sl@0: fsRecPtr = fsRecPtr->nextPtr; sl@0: } sl@0: } sl@0: sl@0: Tcl_MutexUnlock(&filesystemMutex); sl@0: return (retVal); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSMatchInDirectory -- sl@0: * sl@0: * This routine is used by the globbing code to search a directory sl@0: * for all files which match a given pattern. The appropriate sl@0: * function for the filesystem to which pathPtr belongs will be sl@0: * called. If pathPtr does not belong to any filesystem and if it sl@0: * is NULL or the empty string, then we assume the pattern is to be sl@0: * matched in the current working directory. To avoid each sl@0: * filesystem's Tcl_FSMatchInDirectoryProc having to deal with this sl@0: * issue, we create a pathPtr on the fly (equal to the cwd), and sl@0: * then remove it from the results returned. This makes filesystems sl@0: * easy to write, since they can assume the pathPtr passed to them sl@0: * is an ordinary path. In fact this means we could remove such sl@0: * special case handling from Tcl's native filesystems. sl@0: * sl@0: * If 'pattern' is NULL, then pathPtr is assumed to be a fully sl@0: * specified path of a single file/directory which must be sl@0: * checked for existence and correct type. sl@0: * sl@0: * Results: sl@0: * sl@0: * The return value is a standard Tcl result indicating whether an sl@0: * error occurred in globbing. Error messages are placed in sl@0: * interp, but good results are placed in the resultPtr given. sl@0: * sl@0: * Recursive searches, e.g. sl@0: * sl@0: * glob -dir $dir -join * pkgIndex.tcl sl@0: * sl@0: * which must recurse through each directory matching '*' are sl@0: * handled internally by Tcl, by passing specific flags in a sl@0: * modified 'types' parameter. This means the actual filesystem sl@0: * only ever sees patterns which match in a single directory. sl@0: * sl@0: * Side effects: sl@0: * The interpreter may have an error message inserted into it. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_FSMatchInDirectory(interp, result, pathPtr, pattern, types) sl@0: Tcl_Interp *interp; /* Interpreter to receive error messages. */ sl@0: Tcl_Obj *result; /* List object to receive results. */ sl@0: Tcl_Obj *pathPtr; /* Contains path to directory to search. */ sl@0: CONST char *pattern; /* Pattern to match against. */ sl@0: Tcl_GlobTypeData *types; /* Object containing list of acceptable types. sl@0: * May be NULL. In particular the directory sl@0: * flag is very important. */ sl@0: { sl@0: Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); sl@0: if (fsPtr != NULL) { sl@0: Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc; sl@0: if (proc != NULL) { sl@0: int ret = (*proc)(interp, result, pathPtr, pattern, types); sl@0: if (ret == TCL_OK && pattern != NULL) { sl@0: result = FsAddMountsToGlobResult(result, pathPtr, sl@0: pattern, types); sl@0: } sl@0: return ret; sl@0: } sl@0: } else { sl@0: Tcl_Obj* cwd; sl@0: int ret = -1; sl@0: if (pathPtr != NULL) { sl@0: int len; sl@0: Tcl_GetStringFromObj(pathPtr,&len); sl@0: if (len != 0) { sl@0: /* sl@0: * We have no idea how to match files in a directory sl@0: * which belongs to no known filesystem sl@0: */ sl@0: Tcl_SetErrno(ENOENT); sl@0: return -1; sl@0: } sl@0: } sl@0: /* sl@0: * We have an empty or NULL path. This is defined to mean we sl@0: * must search for files within the current 'cwd'. We sl@0: * therefore use that, but then since the proc we call will sl@0: * return results which include the cwd we must then trim it sl@0: * off the front of each path in the result. We choose to deal sl@0: * with this here (in the generic code), since if we don't, sl@0: * every single filesystem's implementation of sl@0: * Tcl_FSMatchInDirectory will have to deal with it for us. sl@0: */ sl@0: cwd = Tcl_FSGetCwd(NULL); sl@0: if (cwd == NULL) { sl@0: if (interp != NULL) { sl@0: Tcl_SetResult(interp, "glob couldn't determine " sl@0: "the current working directory", TCL_STATIC); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: fsPtr = Tcl_FSGetFileSystemForPath(cwd); sl@0: if (fsPtr != NULL) { sl@0: Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc; sl@0: if (proc != NULL) { sl@0: Tcl_Obj* tmpResultPtr = Tcl_NewListObj(0, NULL); sl@0: Tcl_IncrRefCount(tmpResultPtr); sl@0: ret = (*proc)(interp, tmpResultPtr, cwd, pattern, types); sl@0: if (ret == TCL_OK) { sl@0: int resLength; sl@0: sl@0: tmpResultPtr = FsAddMountsToGlobResult(tmpResultPtr, cwd, sl@0: pattern, types); sl@0: sl@0: ret = Tcl_ListObjLength(interp, tmpResultPtr, &resLength); sl@0: if (ret == TCL_OK) { sl@0: int i; sl@0: sl@0: for (i = 0; i < resLength; i++) { sl@0: Tcl_Obj *elt; sl@0: sl@0: Tcl_ListObjIndex(interp, tmpResultPtr, i, &elt); sl@0: Tcl_ListObjAppendElement(interp, result, sl@0: TclFSMakePathRelative(interp, elt, cwd)); sl@0: } sl@0: } sl@0: } sl@0: Tcl_DecrRefCount(tmpResultPtr); sl@0: } sl@0: } sl@0: Tcl_DecrRefCount(cwd); sl@0: return ret; sl@0: } sl@0: Tcl_SetErrno(ENOENT); sl@0: return -1; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * FsAddMountsToGlobResult -- sl@0: * sl@0: * This routine is used by the globbing code to take the results sl@0: * of a directory listing and add any mounted paths to that sl@0: * listing. This is required so that simple things like sl@0: * 'glob *' merge mounts and listings correctly. sl@0: * sl@0: * Results: sl@0: * sl@0: * The passed in 'result' may be modified (in place, if sl@0: * necessary), and the correct list is returned. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: static Tcl_Obj* sl@0: FsAddMountsToGlobResult(result, pathPtr, pattern, types) sl@0: Tcl_Obj *result; /* The current list of matching paths */ sl@0: Tcl_Obj *pathPtr; /* The directory in question */ sl@0: CONST char *pattern; sl@0: Tcl_GlobTypeData *types; sl@0: { sl@0: int mLength, gLength, i; sl@0: int dir = (types == NULL || (types->type & TCL_GLOB_TYPE_DIR)); sl@0: Tcl_Obj *mounts = FsListMounts(pathPtr, pattern); sl@0: sl@0: if (mounts == NULL) return result; sl@0: sl@0: if (Tcl_ListObjLength(NULL, mounts, &mLength) != TCL_OK || mLength == 0) { sl@0: goto endOfMounts; sl@0: } sl@0: if (Tcl_ListObjLength(NULL, result, &gLength) != TCL_OK) { sl@0: goto endOfMounts; sl@0: } sl@0: for (i = 0; i < mLength; i++) { sl@0: Tcl_Obj *mElt; sl@0: int j; sl@0: int found = 0; sl@0: sl@0: Tcl_ListObjIndex(NULL, mounts, i, &mElt); sl@0: sl@0: for (j = 0; j < gLength; j++) { sl@0: Tcl_Obj *gElt; sl@0: Tcl_ListObjIndex(NULL, result, j, &gElt); sl@0: if (Tcl_FSEqualPaths(mElt, gElt)) { sl@0: found = 1; sl@0: if (!dir) { sl@0: /* We don't want to list this */ sl@0: if (Tcl_IsShared(result)) { sl@0: Tcl_Obj *newList; sl@0: newList = Tcl_DuplicateObj(result); sl@0: Tcl_DecrRefCount(result); sl@0: result = newList; sl@0: } sl@0: Tcl_ListObjReplace(NULL, result, j, 1, 0, NULL); sl@0: gLength--; sl@0: } sl@0: /* Break out of for loop */ sl@0: break; sl@0: } sl@0: } sl@0: if (!found && dir) { sl@0: if (Tcl_IsShared(result)) { sl@0: Tcl_Obj *newList; sl@0: newList = Tcl_DuplicateObj(result); sl@0: Tcl_DecrRefCount(result); sl@0: result = newList; sl@0: } sl@0: Tcl_ListObjAppendElement(NULL, result, mElt); sl@0: /* sl@0: * No need to increment gLength, since we sl@0: * don't want to compare mounts against sl@0: * mounts. sl@0: */ sl@0: } sl@0: } sl@0: endOfMounts: sl@0: Tcl_DecrRefCount(mounts); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSMountsChanged -- sl@0: * sl@0: * Notify the filesystem that the available mounted filesystems sl@0: * (or within any one filesystem type, the number or location of sl@0: * mount points) have changed. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The global filesystem variable 'theFilesystemEpoch' is sl@0: * incremented. The effect of this is to make all cached sl@0: * path representations invalid. Clearly it should only therefore sl@0: * be called when it is really required! There are a few sl@0: * circumstances when it should be called: sl@0: * sl@0: * (1) when a new filesystem is registered or unregistered. sl@0: * Strictly speaking this is only necessary if the new filesystem sl@0: * accepts file paths as is (normally the filesystem itself is sl@0: * really a shell which hasn't yet had any mount points established sl@0: * and so its 'pathInFilesystem' proc will always fail). However, sl@0: * for safety, Tcl always calls this for you in these circumstances. sl@0: * sl@0: * (2) when additional mount points are established inside any sl@0: * existing filesystem (except the native fs) sl@0: * sl@0: * (3) when any filesystem (except the native fs) changes the list sl@0: * of available volumes. sl@0: * sl@0: * (4) when the mapping from a string representation of a file to sl@0: * a full, normalized path changes. For example, if 'env(HOME)' sl@0: * is modified, then any path containing '~' will map to a different sl@0: * filesystem location. Therefore all such paths need to have sl@0: * their internal representation invalidated. sl@0: * sl@0: * Tcl has no control over (2) and (3), so any registered filesystem sl@0: * must make sure it calls this function when those situations sl@0: * occur. sl@0: * sl@0: * (Note: the reason for the exception in 2,3 for the native sl@0: * filesystem is that the native filesystem by default claims all sl@0: * unknown files even if it really doesn't understand them or if sl@0: * they don't exist). sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_FSMountsChanged(fsPtr) sl@0: Tcl_Filesystem *fsPtr; sl@0: { sl@0: /* sl@0: * We currently don't do anything with this parameter. We sl@0: * could in the future only invalidate files for this filesystem sl@0: * or otherwise take more advanced action. sl@0: */ sl@0: (void)fsPtr; sl@0: /* sl@0: * Increment the filesystem epoch counter, since existing paths sl@0: * might now belong to different filesystems. sl@0: */ sl@0: Tcl_MutexLock(&filesystemMutex); sl@0: theFilesystemEpoch++; sl@0: Tcl_MutexUnlock(&filesystemMutex); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSData -- sl@0: * sl@0: * Retrieve the clientData field for the filesystem given, sl@0: * or NULL if that filesystem is not registered. sl@0: * sl@0: * Results: sl@0: * A clientData value, or NULL. Note that if the filesystem sl@0: * was registered with a NULL clientData field, this function sl@0: * will return that NULL value. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C ClientData sl@0: Tcl_FSData(fsPtr) sl@0: Tcl_Filesystem *fsPtr; /* The filesystem record to query. */ sl@0: { sl@0: ClientData retVal = NULL; sl@0: FilesystemRecord *fsRecPtr = FsGetFirstFilesystem(); sl@0: sl@0: /* sl@0: * Traverse the 'filesystemList' looking for the particular node sl@0: * whose 'fsPtr' member matches 'fsPtr' and remove that one from sl@0: * the list. Ensure that the "default" node cannot be removed. sl@0: */ sl@0: sl@0: while ((retVal == NULL) && (fsRecPtr != NULL)) { sl@0: if (fsRecPtr->fsPtr == fsPtr) { sl@0: retVal = fsRecPtr->clientData; sl@0: } sl@0: fsRecPtr = fsRecPtr->nextPtr; sl@0: } sl@0: sl@0: return retVal; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * TclFSNormalizeAbsolutePath -- sl@0: * sl@0: * Description: sl@0: * Takes an absolute path specification and computes a 'normalized' sl@0: * path from it. sl@0: * sl@0: * A normalized path is one which has all '../', './' removed. sl@0: * Also it is one which is in the 'standard' format for the native sl@0: * platform. On MacOS, Unix, this means the path must be free of sl@0: * symbolic links/aliases, and on Windows it means we want the sl@0: * long form, with that long form's case-dependence (which gives sl@0: * us a unique, case-dependent path). sl@0: * sl@0: * The behaviour of this function if passed a non-absolute path sl@0: * is NOT defined. sl@0: * sl@0: * Results: sl@0: * The result is returned in a Tcl_Obj with a refCount of 1, sl@0: * which is therefore owned by the caller. It must be sl@0: * freed (with Tcl_DecrRefCount) by the caller when no longer needed. sl@0: * sl@0: * Side effects: sl@0: * None (beyond the memory allocation for the result). sl@0: * sl@0: * Special note: sl@0: * This code is based on code from Matt Newman and Jean-Claude sl@0: * Wippler, with additions from Vince Darley and is copyright sl@0: * those respective authors. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: static Tcl_Obj * sl@0: TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) sl@0: Tcl_Interp* interp; /* Interpreter to use */ sl@0: Tcl_Obj *pathPtr; /* Absolute path to normalize */ sl@0: ClientData *clientDataPtr; sl@0: { sl@0: int splen = 0, nplen, eltLen, i; sl@0: char *eltName; sl@0: Tcl_Obj *retVal; sl@0: Tcl_Obj *split; sl@0: Tcl_Obj *elt; sl@0: sl@0: /* Split has refCount zero */ sl@0: split = Tcl_FSSplitPath(pathPtr, &splen); sl@0: sl@0: /* sl@0: * Modify the list of entries in place, by removing '.', and sl@0: * removing '..' and the entry before -- unless that entry before sl@0: * is the top-level entry, i.e. the name of a volume. sl@0: */ sl@0: nplen = 0; sl@0: for (i = 0; i < splen; i++) { sl@0: Tcl_ListObjIndex(NULL, split, nplen, &elt); sl@0: eltName = Tcl_GetStringFromObj(elt, &eltLen); sl@0: sl@0: if ((eltLen == 1) && (eltName[0] == '.')) { sl@0: Tcl_ListObjReplace(NULL, split, nplen, 1, 0, NULL); sl@0: } else if ((eltLen == 2) sl@0: && (eltName[0] == '.') && (eltName[1] == '.')) { sl@0: if (nplen > 1) { sl@0: nplen--; sl@0: Tcl_ListObjReplace(NULL, split, nplen, 2, 0, NULL); sl@0: } else { sl@0: Tcl_ListObjReplace(NULL, split, nplen, 1, 0, NULL); sl@0: } sl@0: } else { sl@0: nplen++; sl@0: } sl@0: } sl@0: if (nplen > 0) { sl@0: ClientData clientData = NULL; sl@0: sl@0: retVal = Tcl_FSJoinPath(split, nplen); sl@0: /* sl@0: * Now we have an absolute path, with no '..', '.' sequences, sl@0: * but it still may not be in 'unique' form, depending on the sl@0: * platform. For instance, Unix is case-sensitive, so the sl@0: * path is ok. Windows is case-insensitive, and also has the sl@0: * weird 'longname/shortname' thing (e.g. C:/Program Files/ and sl@0: * C:/Progra~1/ are equivalent). MacOS is case-insensitive. sl@0: * sl@0: * Virtual file systems which may be registered may have sl@0: * other criteria for normalizing a path. sl@0: */ sl@0: Tcl_IncrRefCount(retVal); sl@0: TclFSNormalizeToUniquePath(interp, retVal, 0, &clientData); sl@0: /* sl@0: * Since we know it is a normalized path, we can sl@0: * actually convert this object into an "path" object for sl@0: * greater efficiency sl@0: */ sl@0: TclFSMakePathFromNormalized(interp, retVal, clientData); sl@0: if (clientDataPtr != NULL) { sl@0: *clientDataPtr = clientData; sl@0: } sl@0: } else { sl@0: /* Init to an empty string */ sl@0: retVal = Tcl_NewStringObj("",0); sl@0: Tcl_IncrRefCount(retVal); sl@0: } sl@0: /* sl@0: * We increment and then decrement the refCount of split to free sl@0: * it. We do this right at the end, in case there are sl@0: * optimisations in Tcl_FSJoinPath(split, nplen) above which would sl@0: * let it make use of split more effectively if it has a refCount sl@0: * of zero. Also we can't just decrement the ref count, in case sl@0: * 'split' was actually returned by the join call above, in a sl@0: * single-element optimisation when nplen == 1. sl@0: */ sl@0: Tcl_IncrRefCount(split); sl@0: Tcl_DecrRefCount(split); sl@0: sl@0: /* This has a refCount of 1 for the caller */ sl@0: return retVal; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * TclFSNormalizeToUniquePath -- sl@0: * sl@0: * Description: sl@0: * Takes a path specification containing no ../, ./ sequences, sl@0: * and converts it into a unique path for the given platform. sl@0: * On MacOS, Unix, this means the path must be free of sl@0: * symbolic links/aliases, and on Windows it means we want the sl@0: * long form, with that long form's case-dependence (which gives sl@0: * us a unique, case-dependent path). sl@0: * sl@0: * Results: sl@0: * The pathPtr is modified in place. The return value is sl@0: * the last byte offset which was recognised in the path sl@0: * string. sl@0: * sl@0: * Side effects: sl@0: * None (beyond the memory allocation for the result). sl@0: * sl@0: * Special notes: sl@0: * If the filesystem-specific normalizePathProcs can re-introduce sl@0: * ../, ./ sequences into the path, then this function will sl@0: * not return the correct result. This may be possible with sl@0: * symbolic links on unix/macos. sl@0: * sl@0: * Important assumption: if startAt is non-zero, it must point sl@0: * to a directory separator that we know exists and is already sl@0: * normalized (so it is important not to point to the char just sl@0: * after the separator). sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: int sl@0: TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr) sl@0: Tcl_Interp *interp; sl@0: Tcl_Obj *pathPtr; sl@0: int startAt; sl@0: ClientData *clientDataPtr; sl@0: { sl@0: FilesystemRecord *fsRecPtr, *firstFsRecPtr; sl@0: /* Ignore this variable */ sl@0: (void)clientDataPtr; sl@0: sl@0: /* sl@0: * Call each of the "normalise path" functions in succession. This is sl@0: * a special case, in which if we have a native filesystem handler, sl@0: * we call it first. This is because the root of Tcl's filesystem sl@0: * is always a native filesystem (i.e. '/' on unix is native). sl@0: */ sl@0: sl@0: firstFsRecPtr = FsGetFirstFilesystem(); sl@0: sl@0: fsRecPtr = firstFsRecPtr; sl@0: while (fsRecPtr != NULL) { sl@0: if (fsRecPtr->fsPtr == &tclNativeFilesystem) { sl@0: Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc; sl@0: if (proc != NULL) { sl@0: startAt = (*proc)(interp, pathPtr, startAt); sl@0: } sl@0: break; sl@0: } sl@0: fsRecPtr = fsRecPtr->nextPtr; sl@0: } sl@0: sl@0: fsRecPtr = firstFsRecPtr; sl@0: while (fsRecPtr != NULL) { sl@0: /* Skip the native system next time through */ sl@0: if (fsRecPtr->fsPtr != &tclNativeFilesystem) { sl@0: Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc; sl@0: if (proc != NULL) { sl@0: startAt = (*proc)(interp, pathPtr, startAt); sl@0: } sl@0: /* sl@0: * We could add an efficiency check like this: sl@0: * sl@0: * if (retVal == length-of(pathPtr)) {break;} sl@0: * sl@0: * but there's not much benefit. sl@0: */ sl@0: } sl@0: fsRecPtr = fsRecPtr->nextPtr; sl@0: } sl@0: sl@0: return startAt; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * TclGetOpenMode -- sl@0: * sl@0: * Description: sl@0: * Computes a POSIX mode mask for opening a file, from a given string, sl@0: * and also sets a flag to indicate whether the caller should seek to sl@0: * EOF after opening the file. sl@0: * sl@0: * Results: sl@0: * On success, returns mode to pass to "open". If an error occurs, the sl@0: * return value is -1 and if interp is not NULL, sets interp's result sl@0: * object to an error message. sl@0: * sl@0: * Side effects: sl@0: * Sets the integer referenced by seekFlagPtr to 1 to tell the caller sl@0: * to seek to EOF after opening the file. sl@0: * sl@0: * Special note: sl@0: * This code is based on a prototype implementation contributed sl@0: * by Mark Diekhans. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclGetOpenMode(interp, string, seekFlagPtr) sl@0: Tcl_Interp *interp; /* Interpreter to use for error sl@0: * reporting - may be NULL. */ sl@0: CONST char *string; /* Mode string, e.g. "r+" or sl@0: * "RDONLY CREAT". */ sl@0: int *seekFlagPtr; /* Set this to 1 if the caller sl@0: * should seek to EOF during the sl@0: * opening of the file. */ sl@0: { sl@0: int mode, modeArgc, c, i, gotRW; sl@0: CONST char **modeArgv, *flag; sl@0: #define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR) sl@0: sl@0: /* sl@0: * Check for the simpler fopen-like access modes (e.g. "r"). They sl@0: * are distinguished from the POSIX access modes by the presence sl@0: * of a lower-case first letter. sl@0: */ sl@0: sl@0: *seekFlagPtr = 0; sl@0: mode = 0; sl@0: sl@0: /* sl@0: * Guard against international characters before using byte oriented sl@0: * routines. sl@0: */ sl@0: sl@0: if (!(string[0] & 0x80) sl@0: && islower(UCHAR(string[0]))) { /* INTL: ISO only. */ sl@0: switch (string[0]) { sl@0: case 'r': sl@0: mode = O_RDONLY; sl@0: break; sl@0: case 'w': sl@0: mode = O_WRONLY|O_CREAT|O_TRUNC; sl@0: break; sl@0: case 'a': sl@0: /* [Bug 680143]. sl@0: * Added O_APPEND for proper automatic sl@0: * seek-to-end-on-write by the OS. sl@0: */ sl@0: mode = O_WRONLY|O_CREAT|O_APPEND; sl@0: *seekFlagPtr = 1; sl@0: break; sl@0: default: sl@0: error: sl@0: if (interp != (Tcl_Interp *) NULL) { sl@0: Tcl_AppendResult(interp, sl@0: "illegal access mode \"", string, "\"", sl@0: (char *) NULL); sl@0: } sl@0: return -1; sl@0: } sl@0: if (string[1] == '+') { sl@0: mode &= ~(O_RDONLY|O_WRONLY); sl@0: mode |= O_RDWR; sl@0: if (string[2] != 0) { sl@0: goto error; sl@0: } sl@0: } else if (string[1] != 0) { sl@0: goto error; sl@0: } sl@0: return mode; sl@0: } sl@0: sl@0: /* sl@0: * The access modes are specified using a list of POSIX modes sl@0: * such as O_CREAT. sl@0: * sl@0: * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when sl@0: * a NULL interpreter is passed in. sl@0: */ sl@0: sl@0: if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) { sl@0: if (interp != (Tcl_Interp *) NULL) { sl@0: Tcl_AddErrorInfo(interp, sl@0: "\n while processing open access modes \""); sl@0: Tcl_AddErrorInfo(interp, string); sl@0: Tcl_AddErrorInfo(interp, "\""); sl@0: } sl@0: return -1; sl@0: } sl@0: sl@0: gotRW = 0; sl@0: for (i = 0; i < modeArgc; i++) { sl@0: flag = modeArgv[i]; sl@0: c = flag[0]; sl@0: if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) { sl@0: mode = (mode & ~RW_MODES) | O_RDONLY; sl@0: gotRW = 1; sl@0: } else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) { sl@0: mode = (mode & ~RW_MODES) | O_WRONLY; sl@0: gotRW = 1; sl@0: } else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) { sl@0: mode = (mode & ~RW_MODES) | O_RDWR; sl@0: gotRW = 1; sl@0: } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) { sl@0: mode |= O_APPEND; sl@0: *seekFlagPtr = 1; sl@0: } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) { sl@0: mode |= O_CREAT; sl@0: } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) { sl@0: mode |= O_EXCL; sl@0: } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) { sl@0: #ifdef O_NOCTTY sl@0: mode |= O_NOCTTY; sl@0: #else sl@0: if (interp != (Tcl_Interp *) NULL) { sl@0: Tcl_AppendResult(interp, "access mode \"", flag, sl@0: "\" not supported by this system", (char *) NULL); sl@0: } sl@0: ckfree((char *) modeArgv); sl@0: return -1; sl@0: #endif sl@0: } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) { sl@0: #if defined(O_NDELAY) || defined(O_NONBLOCK) sl@0: # ifdef O_NONBLOCK sl@0: mode |= O_NONBLOCK; sl@0: # else sl@0: mode |= O_NDELAY; sl@0: # endif sl@0: #else sl@0: if (interp != (Tcl_Interp *) NULL) { sl@0: Tcl_AppendResult(interp, "access mode \"", flag, sl@0: "\" not supported by this system", (char *) NULL); sl@0: } sl@0: ckfree((char *) modeArgv); sl@0: return -1; sl@0: #endif sl@0: } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) { sl@0: mode |= O_TRUNC; sl@0: } else { sl@0: if (interp != (Tcl_Interp *) NULL) { sl@0: Tcl_AppendResult(interp, "invalid access mode \"", flag, sl@0: "\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT", sl@0: " EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL); sl@0: } sl@0: ckfree((char *) modeArgv); sl@0: return -1; sl@0: } sl@0: } sl@0: ckfree((char *) modeArgv); sl@0: if (!gotRW) { sl@0: if (interp != (Tcl_Interp *) NULL) { sl@0: Tcl_AppendResult(interp, "access mode must include either", sl@0: " RDONLY, WRONLY, or RDWR", (char *) NULL); sl@0: } sl@0: return -1; sl@0: } sl@0: return mode; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSEvalFile -- sl@0: * sl@0: * Read in a file and process the entire file as one gigantic sl@0: * Tcl command. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result, which is either the result of executing sl@0: * the file or an error indicating why the file couldn't be read. sl@0: * sl@0: * Side effects: sl@0: * Depends on the commands in the file. During the evaluation sl@0: * of the contents of the file, iPtr->scriptFile is made to sl@0: * point to pathPtr (the old value is cached and replaced when sl@0: * this function returns). sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_FSEvalFile(interp, pathPtr) sl@0: Tcl_Interp *interp; /* Interpreter in which to process file. */ sl@0: Tcl_Obj *pathPtr; /* Path of file to process. Tilde-substitution sl@0: * will be performed on this name. */ sl@0: { sl@0: int result, length; sl@0: Tcl_StatBuf statBuf; sl@0: Tcl_Obj *oldScriptFile; sl@0: Interp *iPtr; sl@0: char *string; sl@0: Tcl_Channel chan; sl@0: Tcl_Obj *objPtr; sl@0: sl@0: if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: result = TCL_ERROR; sl@0: objPtr = Tcl_NewObj(); sl@0: Tcl_IncrRefCount(objPtr); sl@0: sl@0: if (Tcl_FSStat(pathPtr, &statBuf) == -1) { sl@0: Tcl_SetErrno(errno); sl@0: Tcl_AppendResult(interp, "couldn't read file \"", sl@0: Tcl_GetString(pathPtr), sl@0: "\": ", Tcl_PosixError(interp), (char *) NULL); sl@0: goto end; sl@0: } sl@0: chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); sl@0: if (chan == (Tcl_Channel) NULL) { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendResult(interp, "couldn't read file \"", sl@0: Tcl_GetString(pathPtr), sl@0: "\": ", Tcl_PosixError(interp), (char *) NULL); sl@0: goto end; sl@0: } sl@0: /* sl@0: * The eofchar is \32 (^Z). This is the usual on Windows, but we sl@0: * effect this cross-platform to allow for scripted documents. sl@0: * [Bug: 2040] sl@0: */ sl@0: Tcl_SetChannelOption(interp, chan, "-eofchar", "\32"); sl@0: if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) { sl@0: Tcl_Close(interp, chan); sl@0: Tcl_AppendResult(interp, "couldn't read file \"", sl@0: Tcl_GetString(pathPtr), sl@0: "\": ", Tcl_PosixError(interp), (char *) NULL); sl@0: goto end; sl@0: } sl@0: if (Tcl_Close(interp, chan) != TCL_OK) { sl@0: goto end; sl@0: } sl@0: sl@0: iPtr = (Interp *) interp; sl@0: oldScriptFile = iPtr->scriptFile; sl@0: iPtr->scriptFile = pathPtr; sl@0: Tcl_IncrRefCount(iPtr->scriptFile); sl@0: string = Tcl_GetStringFromObj(objPtr, &length); sl@0: sl@0: #ifdef TCL_TIP280 sl@0: /* TIP #280 Force the evaluator to open a frame for a sourced sl@0: * file. */ sl@0: iPtr->evalFlags |= TCL_EVAL_FILE; sl@0: #endif sl@0: result = Tcl_EvalEx(interp, string, length, 0); sl@0: /* sl@0: * Now we have to be careful; the script may have changed the sl@0: * iPtr->scriptFile value, so we must reset it without sl@0: * assuming it still points to 'pathPtr'. sl@0: */ sl@0: if (iPtr->scriptFile != NULL) { sl@0: Tcl_DecrRefCount(iPtr->scriptFile); sl@0: } sl@0: iPtr->scriptFile = oldScriptFile; sl@0: sl@0: if (result == TCL_RETURN) { sl@0: result = TclUpdateReturnInfo(iPtr); sl@0: } else if (result == TCL_ERROR) { sl@0: char msg[200 + TCL_INTEGER_SPACE]; sl@0: sl@0: /* sl@0: * Record information telling where the error occurred. sl@0: */ sl@0: sl@0: sprintf(msg, "\n (file \"%.150s\" line %d)", Tcl_GetString(pathPtr), sl@0: interp->errorLine); sl@0: Tcl_AddErrorInfo(interp, msg); sl@0: } sl@0: sl@0: end: sl@0: Tcl_DecrRefCount(objPtr); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetErrno -- sl@0: * sl@0: * Gets the current value of the Tcl error code variable. This is sl@0: * currently the global variable "errno" but could in the future sl@0: * change to something else. sl@0: * sl@0: * Results: sl@0: * The value of the Tcl error code variable. sl@0: * sl@0: * Side effects: sl@0: * None. Note that the value of the Tcl error code variable is sl@0: * UNDEFINED if a call to Tcl_SetErrno did not precede this call. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_GetErrno() sl@0: { sl@0: return errno; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SetErrno -- sl@0: * sl@0: * Sets the Tcl error code variable to the supplied value. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Modifies the value of the Tcl error code variable. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_SetErrno(err) sl@0: int err; /* The new value. */ sl@0: { sl@0: errno = err; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_PosixError -- sl@0: * sl@0: * This procedure is typically called after UNIX kernel calls sl@0: * return errors. It stores machine-readable information about sl@0: * the error in $errorCode returns an information string for sl@0: * the caller's use. sl@0: * sl@0: * Results: sl@0: * The return value is a human-readable string describing the sl@0: * error. sl@0: * sl@0: * Side effects: sl@0: * The global variable $errorCode is reset. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C CONST char * sl@0: Tcl_PosixError(interp) sl@0: Tcl_Interp *interp; /* Interpreter whose $errorCode variable sl@0: * is to be changed. */ sl@0: { sl@0: CONST char *id, *msg; sl@0: sl@0: msg = Tcl_ErrnoMsg(errno); sl@0: id = Tcl_ErrnoId(); sl@0: if (interp) { sl@0: Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL); sl@0: } sl@0: return msg; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSStat -- sl@0: * sl@0: * This procedure replaces the library version of stat and lsat. sl@0: * sl@0: * The appropriate function for the filesystem to which pathPtr sl@0: * belongs will be called. sl@0: * sl@0: * Results: sl@0: * See stat documentation. sl@0: * sl@0: * Side effects: sl@0: * See stat documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_FSStat(pathPtr, buf) sl@0: Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ sl@0: Tcl_StatBuf *buf; /* Filled with results of stat call. */ sl@0: { sl@0: Tcl_Filesystem *fsPtr; sl@0: #ifdef USE_OBSOLETE_FS_HOOKS sl@0: struct stat oldStyleStatBuffer; sl@0: int retVal = -1; sl@0: sl@0: /* sl@0: * Call each of the "stat" function in succession. A non-return sl@0: * value of -1 indicates the particular function has succeeded. sl@0: */ sl@0: sl@0: Tcl_MutexLock(&obsoleteFsHookMutex); sl@0: sl@0: if (statProcList != NULL) { sl@0: StatProc *statProcPtr; sl@0: char *path; sl@0: Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); sl@0: if (transPtr == NULL) { sl@0: path = NULL; sl@0: } else { sl@0: path = Tcl_GetString(transPtr); sl@0: } sl@0: sl@0: statProcPtr = statProcList; sl@0: while ((retVal == -1) && (statProcPtr != NULL)) { sl@0: retVal = (*statProcPtr->proc)(path, &oldStyleStatBuffer); sl@0: statProcPtr = statProcPtr->nextPtr; sl@0: } sl@0: if (transPtr != NULL) { sl@0: Tcl_DecrRefCount(transPtr); sl@0: } sl@0: } sl@0: sl@0: Tcl_MutexUnlock(&obsoleteFsHookMutex); sl@0: if (retVal != -1) { sl@0: /* sl@0: * Note that EOVERFLOW is not a problem here, and these sl@0: * assignments should all be widening (if not identity.) sl@0: */ sl@0: buf->st_mode = oldStyleStatBuffer.st_mode; sl@0: buf->st_ino = oldStyleStatBuffer.st_ino; sl@0: buf->st_dev = oldStyleStatBuffer.st_dev; sl@0: buf->st_rdev = oldStyleStatBuffer.st_rdev; sl@0: buf->st_nlink = oldStyleStatBuffer.st_nlink; sl@0: buf->st_uid = oldStyleStatBuffer.st_uid; sl@0: buf->st_gid = oldStyleStatBuffer.st_gid; sl@0: buf->st_size = Tcl_LongAsWide(oldStyleStatBuffer.st_size); sl@0: buf->st_atime = oldStyleStatBuffer.st_atime; sl@0: buf->st_mtime = oldStyleStatBuffer.st_mtime; sl@0: buf->st_ctime = oldStyleStatBuffer.st_ctime; sl@0: #ifdef HAVE_ST_BLOCKS sl@0: buf->st_blksize = oldStyleStatBuffer.st_blksize; sl@0: buf->st_blocks = Tcl_LongAsWide(oldStyleStatBuffer.st_blocks); sl@0: #endif sl@0: return retVal; sl@0: } sl@0: #endif /* USE_OBSOLETE_FS_HOOKS */ sl@0: fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); sl@0: if (fsPtr != NULL) { sl@0: Tcl_FSStatProc *proc = fsPtr->statProc; sl@0: if (proc != NULL) { sl@0: return (*proc)(pathPtr, buf); sl@0: } sl@0: } sl@0: Tcl_SetErrno(ENOENT); sl@0: return -1; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSLstat -- sl@0: * sl@0: * This procedure replaces the library version of lstat. sl@0: * The appropriate function for the filesystem to which pathPtr sl@0: * belongs will be called. If no 'lstat' function is listed, sl@0: * but a 'stat' function is, then Tcl will fall back on the sl@0: * stat function. sl@0: * sl@0: * Results: sl@0: * See lstat documentation. sl@0: * sl@0: * Side effects: sl@0: * See lstat documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_FSLstat(pathPtr, buf) sl@0: Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ sl@0: Tcl_StatBuf *buf; /* Filled with results of stat call. */ sl@0: { sl@0: Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); sl@0: if (fsPtr != NULL) { sl@0: Tcl_FSLstatProc *proc = fsPtr->lstatProc; sl@0: if (proc != NULL) { sl@0: return (*proc)(pathPtr, buf); sl@0: } else { sl@0: Tcl_FSStatProc *sproc = fsPtr->statProc; sl@0: if (sproc != NULL) { sl@0: return (*sproc)(pathPtr, buf); sl@0: } sl@0: } sl@0: } sl@0: Tcl_SetErrno(ENOENT); sl@0: return -1; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSAccess -- sl@0: * sl@0: * This procedure replaces the library version of access. sl@0: * The appropriate function for the filesystem to which pathPtr sl@0: * belongs will be called. sl@0: * sl@0: * Results: sl@0: * See access documentation. sl@0: * sl@0: * Side effects: sl@0: * See access documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_FSAccess(pathPtr, mode) sl@0: Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */ sl@0: int mode; /* Permission setting. */ sl@0: { sl@0: Tcl_Filesystem *fsPtr; sl@0: #ifdef USE_OBSOLETE_FS_HOOKS sl@0: int retVal = -1; sl@0: sl@0: /* sl@0: * Call each of the "access" function in succession. A non-return sl@0: * value of -1 indicates the particular function has succeeded. sl@0: */ sl@0: sl@0: Tcl_MutexLock(&obsoleteFsHookMutex); sl@0: sl@0: if (accessProcList != NULL) { sl@0: AccessProc *accessProcPtr; sl@0: char *path; sl@0: Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); sl@0: if (transPtr == NULL) { sl@0: path = NULL; sl@0: } else { sl@0: path = Tcl_GetString(transPtr); sl@0: } sl@0: sl@0: accessProcPtr = accessProcList; sl@0: while ((retVal == -1) && (accessProcPtr != NULL)) { sl@0: retVal = (*accessProcPtr->proc)(path, mode); sl@0: accessProcPtr = accessProcPtr->nextPtr; sl@0: } sl@0: if (transPtr != NULL) { sl@0: Tcl_DecrRefCount(transPtr); sl@0: } sl@0: } sl@0: sl@0: Tcl_MutexUnlock(&obsoleteFsHookMutex); sl@0: if (retVal != -1) { sl@0: return retVal; sl@0: } sl@0: #endif /* USE_OBSOLETE_FS_HOOKS */ sl@0: fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); sl@0: if (fsPtr != NULL) { sl@0: Tcl_FSAccessProc *proc = fsPtr->accessProc; sl@0: if (proc != NULL) { sl@0: return (*proc)(pathPtr, mode); sl@0: } sl@0: } sl@0: sl@0: Tcl_SetErrno(ENOENT); sl@0: return -1; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSOpenFileChannel -- sl@0: * sl@0: * The appropriate function for the filesystem to which pathPtr sl@0: * belongs will be called. sl@0: * sl@0: * Results: sl@0: * The new channel or NULL, if the named file could not be opened. sl@0: * sl@0: * Side effects: sl@0: * May open the channel and may cause creation of a file on the sl@0: * file system. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Channel sl@0: Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) sl@0: Tcl_Interp *interp; /* Interpreter for error reporting; sl@0: * can be NULL. */ sl@0: Tcl_Obj *pathPtr; /* Name of file to open. */ sl@0: CONST char *modeString; /* A list of POSIX open modes or sl@0: * a string such as "rw". */ sl@0: int permissions; /* If the open involves creating a sl@0: * file, with what modes to create sl@0: * it? */ sl@0: { sl@0: Tcl_Filesystem *fsPtr; sl@0: #ifdef USE_OBSOLETE_FS_HOOKS sl@0: Tcl_Channel retVal = NULL; sl@0: sl@0: /* sl@0: * Call each of the "Tcl_OpenFileChannel" functions in succession. sl@0: * A non-NULL return value indicates the particular function has sl@0: * succeeded. sl@0: */ sl@0: sl@0: Tcl_MutexLock(&obsoleteFsHookMutex); sl@0: if (openFileChannelProcList != NULL) { sl@0: OpenFileChannelProc *openFileChannelProcPtr; sl@0: char *path; sl@0: Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); sl@0: sl@0: if (transPtr == NULL) { sl@0: path = NULL; sl@0: } else { sl@0: path = Tcl_GetString(transPtr); sl@0: } sl@0: sl@0: openFileChannelProcPtr = openFileChannelProcList; sl@0: sl@0: while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { sl@0: retVal = (*openFileChannelProcPtr->proc)(interp, path, sl@0: modeString, permissions); sl@0: openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; sl@0: } sl@0: if (transPtr != NULL) { sl@0: Tcl_DecrRefCount(transPtr); sl@0: } sl@0: } sl@0: Tcl_MutexUnlock(&obsoleteFsHookMutex); sl@0: if (retVal != NULL) { sl@0: return retVal; sl@0: } sl@0: #endif /* USE_OBSOLETE_FS_HOOKS */ sl@0: sl@0: /* sl@0: * We need this just to ensure we return the correct error messages sl@0: * under some circumstances. sl@0: */ sl@0: if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { sl@0: return NULL; sl@0: } sl@0: sl@0: fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); sl@0: if (fsPtr != NULL) { sl@0: Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc; sl@0: if (proc != NULL) { sl@0: int mode, seekFlag; sl@0: mode = TclGetOpenMode(interp, modeString, &seekFlag); sl@0: if (mode == -1) { sl@0: return NULL; sl@0: } sl@0: retVal = (*proc)(interp, pathPtr, mode, permissions); sl@0: if (retVal != NULL) { sl@0: if (seekFlag) { sl@0: if (Tcl_Seek(retVal, (Tcl_WideInt)0, sl@0: SEEK_END) < (Tcl_WideInt)0) { sl@0: if (interp != (Tcl_Interp *) NULL) { sl@0: Tcl_AppendResult(interp, sl@0: "could not seek to end of file while opening \"", sl@0: Tcl_GetString(pathPtr), "\": ", sl@0: Tcl_PosixError(interp), (char *) NULL); sl@0: } sl@0: Tcl_Close(NULL, retVal); sl@0: return NULL; sl@0: } sl@0: } sl@0: } sl@0: return retVal; sl@0: } sl@0: } sl@0: /* File doesn't belong to any filesystem that can open it */ sl@0: Tcl_SetErrno(ENOENT); sl@0: if (interp != NULL) { sl@0: Tcl_AppendResult(interp, "couldn't open \"", sl@0: Tcl_GetString(pathPtr), "\": ", sl@0: Tcl_PosixError(interp), (char *) NULL); sl@0: } sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSUtime -- sl@0: * sl@0: * This procedure replaces the library version of utime. sl@0: * The appropriate function for the filesystem to which pathPtr sl@0: * belongs will be called. sl@0: * sl@0: * Results: sl@0: * See utime documentation. sl@0: * sl@0: * Side effects: sl@0: * See utime documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_FSUtime (pathPtr, tval) sl@0: Tcl_Obj *pathPtr; /* File to change access/modification times */ sl@0: struct utimbuf *tval; /* Structure containing access/modification sl@0: * times to use. Should not be modified. */ sl@0: { sl@0: Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); sl@0: if (fsPtr != NULL) { sl@0: Tcl_FSUtimeProc *proc = fsPtr->utimeProc; sl@0: if (proc != NULL) { sl@0: return (*proc)(pathPtr, tval); sl@0: } sl@0: } sl@0: return -1; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * NativeFileAttrStrings -- sl@0: * sl@0: * This procedure implements the platform dependent 'file sl@0: * attributes' subcommand, for the native filesystem, for listing sl@0: * the set of possible attribute strings. This function is part sl@0: * of Tcl's native filesystem support, and is placed here because sl@0: * it is shared by Unix, MacOS and Windows code. sl@0: * sl@0: * Results: sl@0: * An array of strings sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static CONST char** sl@0: NativeFileAttrStrings(pathPtr, objPtrRef) sl@0: Tcl_Obj *pathPtr; sl@0: Tcl_Obj** objPtrRef; sl@0: { sl@0: return tclpFileAttrStrings; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * NativeFileAttrsGet -- sl@0: * sl@0: * This procedure implements the platform dependent sl@0: * 'file attributes' subcommand, for the native sl@0: * filesystem, for 'get' operations. This function is part sl@0: * of Tcl's native filesystem support, and is placed here sl@0: * because it is shared by Unix, MacOS and Windows code. sl@0: * sl@0: * Results: sl@0: * Standard Tcl return code. The object placed in objPtrRef sl@0: * (if TCL_OK was returned) is likely to have a refCount of zero. sl@0: * Either way we must either store it somewhere (e.g. the Tcl sl@0: * result), or Incr/Decr its refCount to ensure it is properly sl@0: * freed. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: NativeFileAttrsGet(interp, index, pathPtr, objPtrRef) sl@0: Tcl_Interp *interp; /* The interpreter for error reporting. */ sl@0: int index; /* index of the attribute command. */ sl@0: Tcl_Obj *pathPtr; /* path of file we are operating on. */ sl@0: Tcl_Obj **objPtrRef; /* for output. */ sl@0: { sl@0: return (*tclpFileAttrProcs[index].getProc)(interp, index, sl@0: pathPtr, objPtrRef); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * NativeFileAttrsSet -- sl@0: * sl@0: * This procedure implements the platform dependent sl@0: * 'file attributes' subcommand, for the native sl@0: * filesystem, for 'set' operations. This function is part sl@0: * of Tcl's native filesystem support, and is placed here sl@0: * because it is shared by Unix, MacOS and Windows code. sl@0: * sl@0: * Results: sl@0: * Standard Tcl return code. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: NativeFileAttrsSet(interp, index, pathPtr, objPtr) sl@0: Tcl_Interp *interp; /* The interpreter for error reporting. */ sl@0: int index; /* index of the attribute command. */ sl@0: Tcl_Obj *pathPtr; /* path of file we are operating on. */ sl@0: Tcl_Obj *objPtr; /* set to this value. */ sl@0: { sl@0: return (*tclpFileAttrProcs[index].setProc)(interp, index, sl@0: pathPtr, objPtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSFileAttrStrings -- sl@0: * sl@0: * This procedure implements part of the hookable 'file sl@0: * attributes' subcommand. The appropriate function for the sl@0: * filesystem to which pathPtr belongs will be called. sl@0: * sl@0: * Results: sl@0: * The called procedure may either return an array of strings, sl@0: * or may instead return NULL and place a Tcl list into the sl@0: * given objPtrRef. Tcl will take that list and first increment sl@0: * its refCount before using it. On completion of that use, Tcl sl@0: * will decrement its refCount. Hence if the list should be sl@0: * disposed of by Tcl when done, it should have a refCount of zero, sl@0: * and if the list should not be disposed of, the filesystem sl@0: * should ensure it retains a refCount on the object. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C CONST char ** sl@0: Tcl_FSFileAttrStrings(pathPtr, objPtrRef) sl@0: Tcl_Obj* pathPtr; sl@0: Tcl_Obj** objPtrRef; sl@0: { sl@0: Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); sl@0: if (fsPtr != NULL) { sl@0: Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc; sl@0: if (proc != NULL) { sl@0: return (*proc)(pathPtr, objPtrRef); sl@0: } sl@0: } sl@0: Tcl_SetErrno(ENOENT); sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSFileAttrsGet -- sl@0: * sl@0: * This procedure implements read access for the hookable 'file sl@0: * attributes' subcommand. The appropriate function for the sl@0: * filesystem to which pathPtr belongs will be called. sl@0: * sl@0: * Results: sl@0: * Standard Tcl return code. The object placed in objPtrRef sl@0: * (if TCL_OK was returned) is likely to have a refCount of zero. sl@0: * Either way we must either store it somewhere (e.g. the Tcl sl@0: * result), or Incr/Decr its refCount to ensure it is properly sl@0: * freed. sl@0: sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_FSFileAttrsGet(interp, index, pathPtr, objPtrRef) sl@0: Tcl_Interp *interp; /* The interpreter for error reporting. */ sl@0: int index; /* index of the attribute command. */ sl@0: Tcl_Obj *pathPtr; /* filename we are operating on. */ sl@0: Tcl_Obj **objPtrRef; /* for output. */ sl@0: { sl@0: Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); sl@0: if (fsPtr != NULL) { sl@0: Tcl_FSFileAttrsGetProc *proc = fsPtr->fileAttrsGetProc; sl@0: if (proc != NULL) { sl@0: return (*proc)(interp, index, pathPtr, objPtrRef); sl@0: } sl@0: } sl@0: Tcl_SetErrno(ENOENT); sl@0: return -1; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSFileAttrsSet -- sl@0: * sl@0: * This procedure implements write access for the hookable 'file sl@0: * attributes' subcommand. The appropriate function for the sl@0: * filesystem to which pathPtr belongs will be called. sl@0: * sl@0: * Results: sl@0: * Standard Tcl return code. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr) sl@0: Tcl_Interp *interp; /* The interpreter for error reporting. */ sl@0: int index; /* index of the attribute command. */ sl@0: Tcl_Obj *pathPtr; /* filename we are operating on. */ sl@0: Tcl_Obj *objPtr; /* Input value. */ sl@0: { sl@0: Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); sl@0: if (fsPtr != NULL) { sl@0: Tcl_FSFileAttrsSetProc *proc = fsPtr->fileAttrsSetProc; sl@0: if (proc != NULL) { sl@0: return (*proc)(interp, index, pathPtr, objPtr); sl@0: } sl@0: } sl@0: Tcl_SetErrno(ENOENT); sl@0: return -1; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSGetCwd -- sl@0: * sl@0: * This function replaces the library version of getcwd(). sl@0: * sl@0: * Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains sl@0: * its own record (in a Tcl_Obj) of the cwd, and an attempt sl@0: * is made to synchronise this with the cwd's containing filesystem, sl@0: * if that filesystem provides a cwdProc (e.g. the native filesystem). sl@0: * sl@0: * Note that if Tcl's cwd is not in the native filesystem, then of sl@0: * course Tcl's cwd and the native cwd are different: extensions sl@0: * should therefore ensure they only access the cwd through this sl@0: * function to avoid confusion. sl@0: * sl@0: * If a global cwdPathPtr already exists, it is cached in the thread's sl@0: * private data structures and reference to the cached copy is returned, sl@0: * subject to a synchronisation attempt in that cwdPathPtr's fs. sl@0: * sl@0: * Otherwise, the chain of functions that have been "inserted" sl@0: * into the filesystem will be called in succession until either a sl@0: * value other than NULL is returned, or the entire list is sl@0: * visited. sl@0: * sl@0: * Results: sl@0: * The result is a pointer to a Tcl_Obj specifying the current sl@0: * directory, or NULL if the current directory could not be sl@0: * determined. If NULL is returned, an error message is left in the sl@0: * interp's result. sl@0: * sl@0: * The result already has its refCount incremented for the caller. sl@0: * When it is no longer needed, that refCount should be decremented. sl@0: * sl@0: * Side effects: sl@0: * Various objects may be freed and allocated. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Obj* sl@0: Tcl_FSGetCwd(interp) sl@0: Tcl_Interp *interp; sl@0: { sl@0: ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); sl@0: sl@0: if (TclFSCwdPointerEquals(NULL)) { sl@0: FilesystemRecord *fsRecPtr; sl@0: Tcl_Obj *retVal = NULL; sl@0: sl@0: /* sl@0: * We've never been called before, try to find a cwd. Call sl@0: * each of the "Tcl_GetCwd" function in succession. A non-NULL sl@0: * return value indicates the particular function has sl@0: * succeeded. sl@0: */ sl@0: sl@0: fsRecPtr = FsGetFirstFilesystem(); sl@0: while ((retVal == NULL) && (fsRecPtr != NULL)) { sl@0: Tcl_FSGetCwdProc *proc = fsRecPtr->fsPtr->getCwdProc; sl@0: if (proc != NULL) { sl@0: retVal = (*proc)(interp); sl@0: } sl@0: fsRecPtr = fsRecPtr->nextPtr; sl@0: } sl@0: /* sl@0: * Now the 'cwd' may NOT be normalized, at least on some sl@0: * platforms. For the sake of efficiency, we want a completely sl@0: * normalized cwd at all times. sl@0: * sl@0: * Finally, if retVal is NULL, we do not have a cwd, which sl@0: * could be problematic. sl@0: */ sl@0: if (retVal != NULL) { sl@0: Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL); sl@0: if (norm != NULL) { sl@0: /* sl@0: * We found a cwd, which is now in our global storage. sl@0: * We must make a copy. Norm already has a refCount of 1. sl@0: * sl@0: * Threading issue: note that multiple threads at system sl@0: * startup could in principle call this procedure sl@0: * simultaneously. They will therefore each set the sl@0: * cwdPathPtr independently. That behaviour is a bit sl@0: * peculiar, but should be fine. Once we have a cwd, sl@0: * we'll always be in the 'else' branch below which sl@0: * is simpler. sl@0: */ sl@0: FsUpdateCwd(norm); sl@0: Tcl_DecrRefCount(norm); sl@0: } sl@0: Tcl_DecrRefCount(retVal); sl@0: } sl@0: } else { sl@0: /* sl@0: * We already have a cwd cached, but we want to give the sl@0: * filesystem it is in a chance to check whether that cwd sl@0: * has changed, or is perhaps no longer accessible. This sl@0: * allows an error to be thrown if, say, the permissions on sl@0: * that directory have changed. sl@0: */ sl@0: Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr); sl@0: /* sl@0: * If the filesystem couldn't be found, or if no cwd function sl@0: * exists for this filesystem, then we simply assume the cached sl@0: * cwd is ok. If we do call a cwd, we must watch for errors sl@0: * (if the cwd returns NULL). This ensures that, say, on Unix sl@0: * if the permissions of the cwd change, 'pwd' does actually sl@0: * throw the correct error in Tcl. (This is tested for in the sl@0: * test suite on unix). sl@0: */ sl@0: if (fsPtr != NULL) { sl@0: Tcl_FSGetCwdProc *proc = fsPtr->getCwdProc; sl@0: if (proc != NULL) { sl@0: Tcl_Obj *retVal = (*proc)(interp); sl@0: if (retVal != NULL) { sl@0: Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL); sl@0: /* sl@0: * Check whether cwd has changed from the value sl@0: * previously stored in cwdPathPtr. Really 'norm' sl@0: * shouldn't be null, but we are careful. sl@0: */ sl@0: if (norm == NULL) { sl@0: /* Do nothing */ sl@0: } else if (Tcl_FSEqualPaths(tsdPtr->cwdPathPtr, norm)) { sl@0: /* sl@0: * If the paths were equal, we can be more sl@0: * efficient and retain the old path object sl@0: * which will probably already be shared. In sl@0: * this case we can simply free the normalized sl@0: * path we just calculated. sl@0: */ sl@0: Tcl_DecrRefCount(norm); sl@0: } else { sl@0: FsUpdateCwd(norm); sl@0: Tcl_DecrRefCount(norm); sl@0: } sl@0: Tcl_DecrRefCount(retVal); sl@0: } else { sl@0: /* The 'cwd' function returned an error; reset the cwd */ sl@0: FsUpdateCwd(NULL); sl@0: } sl@0: } sl@0: } sl@0: } sl@0: sl@0: if (tsdPtr->cwdPathPtr != NULL) { sl@0: Tcl_IncrRefCount(tsdPtr->cwdPathPtr); sl@0: } sl@0: sl@0: return tsdPtr->cwdPathPtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSChdir -- sl@0: * sl@0: * This function replaces the library version of chdir(). sl@0: * sl@0: * The path is normalized and then passed to the filesystem sl@0: * which claims it. sl@0: * sl@0: * Results: sl@0: * See chdir() documentation. If successful, we keep a sl@0: * record of the successful path in cwdPathPtr for subsequent sl@0: * calls to getcwd. sl@0: * sl@0: * Side effects: sl@0: * See chdir() documentation. The global cwdPathPtr may sl@0: * change value. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: EXPORT_C int sl@0: Tcl_FSChdir(pathPtr) sl@0: Tcl_Obj *pathPtr; sl@0: { sl@0: Tcl_Filesystem *fsPtr; sl@0: int retVal = -1; sl@0: sl@0: #ifdef WIN32 sl@0: /* sl@0: * This complete hack addresses the bug tested in winFCmd-16.12, sl@0: * where having your HOME as "C:" (IOW, a seemingly path relative sl@0: * dir) would cause a crash when you cd'd to it and requested 'pwd'. sl@0: * The work-around is to force such a dir into an absolute path by sl@0: * tacking on '/'. sl@0: * sl@0: * We check for '~' specifically because that's what Tcl_CdObjCmd sl@0: * passes in that triggers the bug. A direct 'cd C:' call will not sl@0: * because that gets the volumerelative pwd. sl@0: * sl@0: * This is not an issue for 8.5 as that has a more elaborate change sl@0: * that requires the use of TCL_FILESYSTEM_VERSION_2. sl@0: */ sl@0: Tcl_Obj *objPtr = NULL; sl@0: if (pathPtr->bytes && pathPtr->length == 1 && pathPtr->bytes[0] == '~') { sl@0: int len; sl@0: char *str; sl@0: sl@0: objPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); sl@0: if (objPtr == NULL) { sl@0: Tcl_SetErrno(ENOENT); sl@0: return -1; sl@0: } sl@0: Tcl_IncrRefCount(objPtr); sl@0: str = Tcl_GetStringFromObj(objPtr, &len); sl@0: if (len == 2 && str[1] == ':') { sl@0: pathPtr = Tcl_NewStringObj(str, len); sl@0: Tcl_AppendToObj(pathPtr, "/", 1); sl@0: Tcl_IncrRefCount(pathPtr); sl@0: Tcl_DecrRefCount(objPtr); sl@0: objPtr = pathPtr; sl@0: } else { sl@0: Tcl_DecrRefCount(objPtr); sl@0: objPtr = NULL; sl@0: } sl@0: } sl@0: #endif sl@0: if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) { sl@0: #ifdef WIN32 sl@0: if (objPtr) { Tcl_DecrRefCount(objPtr); } sl@0: #endif sl@0: Tcl_SetErrno(ENOENT); sl@0: return -1; sl@0: } sl@0: sl@0: fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); sl@0: if (fsPtr != NULL) { sl@0: Tcl_FSChdirProc *proc = fsPtr->chdirProc; sl@0: if (proc != NULL) { sl@0: retVal = (*proc)(pathPtr); sl@0: } else { sl@0: /* Fallback on stat-based implementation */ sl@0: Tcl_StatBuf buf; sl@0: /* If the file can be stat'ed and is a directory and sl@0: * is readable, then we can chdir. */ sl@0: if ((Tcl_FSStat(pathPtr, &buf) == 0) sl@0: && (S_ISDIR(buf.st_mode)) sl@0: && (Tcl_FSAccess(pathPtr, R_OK) == 0)) { sl@0: /* We allow the chdir */ sl@0: retVal = 0; sl@0: } sl@0: } sl@0: } sl@0: sl@0: if (retVal != -1) { sl@0: /* sl@0: * The cwd changed, or an error was thrown. If an error was sl@0: * thrown, we can just continue (and that will report the error sl@0: * to the user). If there was no error we must assume that the sl@0: * cwd was actually changed to the normalized value we sl@0: * calculated above, and we must therefore cache that sl@0: * information. sl@0: */ sl@0: if (retVal == 0) { sl@0: /* sl@0: * Note that this normalized path may be different to what sl@0: * we found above (or at least a different object), if the sl@0: * filesystem epoch changed recently. This can actually sl@0: * happen with scripted documents very easily. Therefore sl@0: * we ask for the normalized path again (the correct value sl@0: * will have been cached as a result of the sl@0: * Tcl_FSGetFileSystemForPath call above anyway). sl@0: */ sl@0: Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr); sl@0: if (normDirName == NULL) { sl@0: #ifdef WIN32 sl@0: if (objPtr) { Tcl_DecrRefCount(objPtr); } sl@0: #endif sl@0: Tcl_SetErrno(ENOENT); sl@0: return -1; sl@0: } sl@0: FsUpdateCwd(normDirName); sl@0: } sl@0: } else { sl@0: Tcl_SetErrno(ENOENT); sl@0: } sl@0: sl@0: #ifdef WIN32 sl@0: if (objPtr) { Tcl_DecrRefCount(objPtr); } sl@0: #endif sl@0: return (retVal); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSLoadFile -- sl@0: * sl@0: * Dynamically loads a binary code file into memory and returns sl@0: * the addresses of two procedures within that file, if they are sl@0: * defined. The appropriate function for the filesystem to which sl@0: * pathPtr belongs will be called. sl@0: * sl@0: * Note that the native filesystem doesn't actually assume sl@0: * 'pathPtr' is a path. Rather it assumes filename is either sl@0: * a path or just the name of a file which can be found somewhere sl@0: * in the environment's loadable path. This behaviour is not sl@0: * very compatible with virtual filesystems (and has other problems sl@0: * documented in the load man-page), so it is advised that full sl@0: * paths are always used. sl@0: * sl@0: * Results: sl@0: * A standard Tcl completion code. If an error occurs, an error sl@0: * message is left in the interp's result. sl@0: * sl@0: * Side effects: sl@0: * New code suddenly appears in memory. This may later be sl@0: * unloaded by passing the clientData to the unloadProc. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, sl@0: handlePtr, unloadProcPtr) sl@0: Tcl_Interp *interp; /* Used for error reporting. */ sl@0: Tcl_Obj *pathPtr; /* Name of the file containing the desired sl@0: * code. */ sl@0: CONST char *sym1, *sym2; /* Names of two procedures to look up in sl@0: * the file's symbol table. */ sl@0: Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; sl@0: /* Where to return the addresses corresponding sl@0: * to sym1 and sym2. */ sl@0: Tcl_LoadHandle *handlePtr; /* Filled with token for dynamically loaded sl@0: * file which will be passed back to sl@0: * (*unloadProcPtr)() to unload the file. */ sl@0: Tcl_FSUnloadFileProc **unloadProcPtr; sl@0: /* Filled with address of Tcl_FSUnloadFileProc sl@0: * function which should be used for sl@0: * this file. */ sl@0: { sl@0: Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); sl@0: if (fsPtr != NULL) { sl@0: Tcl_FSLoadFileProc *proc = fsPtr->loadFileProc; sl@0: if (proc != NULL) { sl@0: int retVal = (*proc)(interp, pathPtr, handlePtr, unloadProcPtr); sl@0: if (retVal != TCL_OK) { sl@0: return retVal; sl@0: } sl@0: if (*handlePtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (sym1 != NULL) { sl@0: *proc1Ptr = TclpFindSymbol(interp, *handlePtr, sym1); sl@0: } sl@0: if (sym2 != NULL) { sl@0: *proc2Ptr = TclpFindSymbol(interp, *handlePtr, sym2); sl@0: } sl@0: return retVal; sl@0: } else { sl@0: Tcl_Filesystem *copyFsPtr; sl@0: Tcl_Obj *copyToPtr; sl@0: sl@0: /* First check if it is readable -- and exists! */ sl@0: if (Tcl_FSAccess(pathPtr, R_OK) != 0) { sl@0: Tcl_AppendResult(interp, "couldn't load library \"", sl@0: Tcl_GetString(pathPtr), "\": ", sl@0: Tcl_PosixError(interp), (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: #ifdef TCL_LOAD_FROM_MEMORY sl@0: /* sl@0: * The platform supports loading code from memory, so ask for a sl@0: * buffer of the appropriate size, read the file into it and sl@0: * load the code from the buffer: sl@0: */ sl@0: do { sl@0: int ret, size; sl@0: void *buffer; sl@0: Tcl_StatBuf statBuf; sl@0: Tcl_Channel data; sl@0: sl@0: ret = Tcl_FSStat(pathPtr, &statBuf); sl@0: if (ret < 0) { sl@0: break; sl@0: } sl@0: size = (int) statBuf.st_size; sl@0: /* Tcl_Read takes an int: check that file size isn't wide */ sl@0: if (size != (Tcl_WideInt)statBuf.st_size) { sl@0: break; sl@0: } sl@0: data = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0666); sl@0: if (!data) { sl@0: break; sl@0: } sl@0: buffer = TclpLoadMemoryGetBuffer(interp, size); sl@0: if (!buffer) { sl@0: Tcl_Close(interp, data); sl@0: break; sl@0: } sl@0: Tcl_SetChannelOption(interp, data, "-translation", "binary"); sl@0: ret = Tcl_Read(data, buffer, size); sl@0: Tcl_Close(interp, data); sl@0: ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr, unloadProcPtr); sl@0: if (ret == TCL_OK) { sl@0: if (*handlePtr == NULL) { sl@0: break; sl@0: } sl@0: if (sym1 != NULL) { sl@0: *proc1Ptr = TclpFindSymbol(interp, *handlePtr, sym1); sl@0: } sl@0: if (sym2 != NULL) { sl@0: *proc2Ptr = TclpFindSymbol(interp, *handlePtr, sym2); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: } while (0); sl@0: Tcl_ResetResult(interp); sl@0: #endif sl@0: sl@0: /* sl@0: * Get a temporary filename to use, first to sl@0: * copy the file into, and then to load. sl@0: */ sl@0: copyToPtr = TclpTempFileName(); sl@0: if (copyToPtr == NULL) { sl@0: return -1; sl@0: } sl@0: Tcl_IncrRefCount(copyToPtr); sl@0: sl@0: copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr); sl@0: if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) { sl@0: /* sl@0: * We already know we can't use Tcl_FSLoadFile from sl@0: * this filesystem, and we must avoid a possible sl@0: * infinite loop. Try to delete the file we sl@0: * probably created, and then exit. sl@0: */ sl@0: Tcl_FSDeleteFile(copyToPtr); sl@0: Tcl_DecrRefCount(copyToPtr); sl@0: return -1; sl@0: } sl@0: sl@0: if (TclCrossFilesystemCopy(interp, pathPtr, sl@0: copyToPtr) == TCL_OK) { sl@0: Tcl_LoadHandle newLoadHandle = NULL; sl@0: Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL; sl@0: FsDivertLoad *tvdlPtr; sl@0: int retVal; sl@0: sl@0: #if !defined(__WIN32__) && !defined(MAC_TCL) sl@0: /* sl@0: * Do we need to set appropriate permissions sl@0: * on the file? This may be required on some sl@0: * systems. On Unix we could loop over sl@0: * the file attributes, and set any that are sl@0: * called "-permissions" to 0700. However, sl@0: * we just do this directly, like this: sl@0: */ sl@0: sl@0: Tcl_Obj* perm = Tcl_NewStringObj("0700",-1); sl@0: Tcl_IncrRefCount(perm); sl@0: Tcl_FSFileAttrsSet(NULL, 2, copyToPtr, perm); sl@0: Tcl_DecrRefCount(perm); sl@0: #endif sl@0: sl@0: /* sl@0: * We need to reset the result now, because the cross- sl@0: * filesystem copy may have stored the number of bytes sl@0: * in the result sl@0: */ sl@0: Tcl_ResetResult(interp); sl@0: sl@0: retVal = Tcl_FSLoadFile(interp, copyToPtr, sym1, sym2, sl@0: proc1Ptr, proc2Ptr, sl@0: &newLoadHandle, sl@0: &newUnloadProcPtr); sl@0: if (retVal != TCL_OK) { sl@0: /* The file didn't load successfully */ sl@0: Tcl_FSDeleteFile(copyToPtr); sl@0: Tcl_DecrRefCount(copyToPtr); sl@0: return retVal; sl@0: } sl@0: /* sl@0: * Try to delete the file immediately -- this is sl@0: * possible in some OSes, and avoids any worries sl@0: * about leaving the copy laying around on exit. sl@0: */ sl@0: if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) { sl@0: Tcl_DecrRefCount(copyToPtr); sl@0: /* sl@0: * We tell our caller about the real shared sl@0: * library which was loaded. Note that this sl@0: * does mean that the package list maintained sl@0: * by 'load' will store the original (vfs) sl@0: * path alongside the temporary load handle sl@0: * and unload proc ptr. sl@0: */ sl@0: (*handlePtr) = newLoadHandle; sl@0: (*unloadProcPtr) = newUnloadProcPtr; sl@0: return TCL_OK; sl@0: } sl@0: /* sl@0: * When we unload this file, we need to divert the sl@0: * unloading so we can unload and cleanup the sl@0: * temporary file correctly. sl@0: */ sl@0: tvdlPtr = (FsDivertLoad*) ckalloc(sizeof(FsDivertLoad)); sl@0: sl@0: /* sl@0: * Remember three pieces of information. This allows sl@0: * us to cleanup the diverted load completely, on sl@0: * platforms which allow proper unloading of code. sl@0: */ sl@0: tvdlPtr->loadHandle = newLoadHandle; sl@0: tvdlPtr->unloadProcPtr = newUnloadProcPtr; sl@0: sl@0: if (copyFsPtr != &tclNativeFilesystem) { sl@0: /* copyToPtr is already incremented for this reference */ sl@0: tvdlPtr->divertedFile = copyToPtr; sl@0: sl@0: /* sl@0: * This is the filesystem we loaded it into. Since sl@0: * we have a reference to 'copyToPtr', we already sl@0: * have a refCount on this filesystem, so we don't sl@0: * need to worry about it disappearing on us. sl@0: */ sl@0: tvdlPtr->divertedFilesystem = copyFsPtr; sl@0: tvdlPtr->divertedFileNativeRep = NULL; sl@0: } else { sl@0: /* We need the native rep */ sl@0: tvdlPtr->divertedFileNativeRep = sl@0: TclNativeDupInternalRep(Tcl_FSGetInternalRep(copyToPtr, sl@0: copyFsPtr)); sl@0: /* sl@0: * We don't need or want references to the copied sl@0: * Tcl_Obj or the filesystem if it is the native sl@0: * one. sl@0: */ sl@0: tvdlPtr->divertedFile = NULL; sl@0: tvdlPtr->divertedFilesystem = NULL; sl@0: Tcl_DecrRefCount(copyToPtr); sl@0: } sl@0: sl@0: copyToPtr = NULL; sl@0: (*handlePtr) = (Tcl_LoadHandle) tvdlPtr; sl@0: (*unloadProcPtr) = &FSUnloadTempFile; sl@0: return retVal; sl@0: } else { sl@0: /* Cross-platform copy failed */ sl@0: Tcl_FSDeleteFile(copyToPtr); sl@0: Tcl_DecrRefCount(copyToPtr); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: } sl@0: Tcl_SetErrno(ENOENT); sl@0: return -1; sl@0: } sl@0: /* sl@0: * This function used to be in the platform specific directories, but it sl@0: * has now been made to work cross-platform sl@0: */ sl@0: int sl@0: TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, sl@0: clientDataPtr, unloadProcPtr) sl@0: Tcl_Interp *interp; /* Used for error reporting. */ sl@0: Tcl_Obj *pathPtr; /* Name of the file containing the desired sl@0: * code (UTF-8). */ sl@0: CONST char *sym1, *sym2; /* Names of two procedures to look up in sl@0: * the file's symbol table. */ sl@0: Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; sl@0: /* Where to return the addresses corresponding sl@0: * to sym1 and sym2. */ sl@0: ClientData *clientDataPtr; /* Filled with token for dynamically loaded sl@0: * file which will be passed back to sl@0: * (*unloadProcPtr)() to unload the file. */ sl@0: Tcl_FSUnloadFileProc **unloadProcPtr; sl@0: /* Filled with address of Tcl_FSUnloadFileProc sl@0: * function which should be used for sl@0: * this file. */ sl@0: { sl@0: Tcl_LoadHandle handle = NULL; sl@0: int res; sl@0: sl@0: res = TclpDlopen(interp, pathPtr, &handle, unloadProcPtr); sl@0: sl@0: if (res != TCL_OK) { sl@0: return res; sl@0: } sl@0: sl@0: if (handle == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: *clientDataPtr = (ClientData)handle; sl@0: sl@0: *proc1Ptr = TclpFindSymbol(interp, handle, sym1); sl@0: *proc2Ptr = TclpFindSymbol(interp, handle, sym2); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * FSUnloadTempFile -- sl@0: * sl@0: * This function is called when we loaded a library of code via sl@0: * an intermediate temporary file. This function ensures sl@0: * the library is correctly unloaded and the temporary file sl@0: * is correctly deleted. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The effects of the 'unload' function called, and of course sl@0: * the temporary file will be deleted. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: static void sl@0: FSUnloadTempFile(loadHandle) sl@0: Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call sl@0: * to Tcl_FSLoadFile(). The loadHandle is sl@0: * a token that represents the loaded sl@0: * file. */ sl@0: { sl@0: FsDivertLoad *tvdlPtr = (FsDivertLoad*)loadHandle; sl@0: /* sl@0: * This test should never trigger, since we give sl@0: * the client data in the function above. sl@0: */ sl@0: if (tvdlPtr == NULL) { return; } sl@0: sl@0: /* sl@0: * Call the real 'unloadfile' proc we actually used. It is very sl@0: * important that we call this first, so that the shared library sl@0: * is actually unloaded by the OS. Otherwise, the following sl@0: * 'delete' may well fail because the shared library is still in sl@0: * use. sl@0: */ sl@0: if (tvdlPtr->unloadProcPtr != NULL) { sl@0: (*tvdlPtr->unloadProcPtr)(tvdlPtr->loadHandle); sl@0: } sl@0: sl@0: if (tvdlPtr->divertedFilesystem == NULL) { sl@0: /* sl@0: * It was the native filesystem, and we have a special sl@0: * function available just for this purpose, which we sl@0: * know works even at this late stage. sl@0: */ sl@0: TclpDeleteFile(tvdlPtr->divertedFileNativeRep); sl@0: NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep); sl@0: } else { sl@0: /* sl@0: * Remove the temporary file we created. Note, we may crash sl@0: * here because encodings have been taken down already. sl@0: */ sl@0: if (tvdlPtr->divertedFilesystem->deleteFileProc(tvdlPtr->divertedFile) sl@0: != TCL_OK) { sl@0: /* sl@0: * The above may have failed because the filesystem, or something sl@0: * it depends upon (e.g. encodings) have been taken down because sl@0: * Tcl is exiting. sl@0: * sl@0: * We may need to work out how to delete this file more sl@0: * robustly (or give the filesystem the information it needs sl@0: * to delete the file more robustly). sl@0: * sl@0: * In particular, one problem might be that the filesystem sl@0: * cannot extract the information it needs from the above sl@0: * path object because Tcl's entire filesystem apparatus sl@0: * (the code in this file) has been finalized, and it sl@0: * refuses to pass the internal representation to the sl@0: * filesystem. sl@0: */ sl@0: } sl@0: sl@0: /* sl@0: * And free up the allocations. This will also of course remove sl@0: * a refCount from the Tcl_Filesystem to which this file belongs, sl@0: * which could then free up the filesystem if we are exiting. sl@0: */ sl@0: Tcl_DecrRefCount(tvdlPtr->divertedFile); sl@0: } sl@0: sl@0: ckfree((char*)tvdlPtr); sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSLink -- sl@0: * sl@0: * This function replaces the library version of readlink() and sl@0: * can also be used to make links. The appropriate function for sl@0: * the filesystem to which pathPtr belongs will be called. sl@0: * sl@0: * Results: sl@0: * If toPtr is NULL, then the result is a Tcl_Obj specifying the sl@0: * contents of the symbolic link given by 'pathPtr', or NULL if sl@0: * the symbolic link could not be read. The result is owned by sl@0: * the caller, which should call Tcl_DecrRefCount when the result sl@0: * is no longer needed. sl@0: * sl@0: * If toPtr is non-NULL, then the result is toPtr if the link action sl@0: * was successful, or NULL if not. In this case the result has no sl@0: * additional reference count, and need not be freed. The actual sl@0: * action to perform is given by the 'linkAction' flags, which is sl@0: * an or'd combination of: sl@0: * sl@0: * TCL_CREATE_SYMBOLIC_LINK sl@0: * TCL_CREATE_HARD_LINK sl@0: * sl@0: * Note that most filesystems will not support linking across sl@0: * to different filesystems, so this function will usually sl@0: * fail unless toPtr is in the same FS as pathPtr. sl@0: * sl@0: * Side effects: sl@0: * See readlink() documentation. A new filesystem link sl@0: * object may appear sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_FSLink(pathPtr, toPtr, linkAction) sl@0: Tcl_Obj *pathPtr; /* Path of file to readlink or link */ sl@0: Tcl_Obj *toPtr; /* NULL or path to be linked to */ sl@0: int linkAction; /* Action to perform */ sl@0: { sl@0: Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); sl@0: if (fsPtr != NULL) { sl@0: Tcl_FSLinkProc *proc = fsPtr->linkProc; sl@0: if (proc != NULL) { sl@0: return (*proc)(pathPtr, toPtr, linkAction); sl@0: } sl@0: } sl@0: /* sl@0: * If S_IFLNK isn't defined it means that the machine doesn't sl@0: * support symbolic links, so the file can't possibly be a sl@0: * symbolic link. Generate an EINVAL error, which is what sl@0: * happens on machines that do support symbolic links when sl@0: * you invoke readlink on a file that isn't a symbolic link. sl@0: */ sl@0: #ifndef S_IFLNK sl@0: errno = EINVAL; sl@0: #else sl@0: Tcl_SetErrno(ENOENT); sl@0: #endif /* S_IFLNK */ sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSListVolumes -- sl@0: * sl@0: * Lists the currently mounted volumes. The chain of functions sl@0: * that have been "inserted" into the filesystem will be called in sl@0: * succession; each may return a list of volumes, all of which are sl@0: * added to the result until all mounted file systems are listed. sl@0: * sl@0: * Notice that we assume the lists returned by each filesystem sl@0: * (if non NULL) have been given a refCount for us already. sl@0: * However, we are NOT allowed to hang on to the list itself sl@0: * (it belongs to the filesystem we called). Therefore we sl@0: * quite naturally add its contents to the result we are sl@0: * building, and then decrement the refCount. sl@0: * sl@0: * Results: sl@0: * The list of volumes, in an object which has refCount 0. sl@0: * sl@0: * Side effects: sl@0: * None sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Obj* sl@0: Tcl_FSListVolumes(void) sl@0: { sl@0: FilesystemRecord *fsRecPtr; sl@0: Tcl_Obj *resultPtr = Tcl_NewObj(); sl@0: sl@0: /* sl@0: * Call each of the "listVolumes" function in succession. sl@0: * A non-NULL return value indicates the particular function has sl@0: * succeeded. We call all the functions registered, since we want sl@0: * a list of all drives from all filesystems. sl@0: */ sl@0: sl@0: fsRecPtr = FsGetFirstFilesystem(); sl@0: while (fsRecPtr != NULL) { sl@0: Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc; sl@0: if (proc != NULL) { sl@0: Tcl_Obj *thisFsVolumes = (*proc)(); sl@0: if (thisFsVolumes != NULL) { sl@0: Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes); sl@0: Tcl_DecrRefCount(thisFsVolumes); sl@0: } sl@0: } sl@0: fsRecPtr = fsRecPtr->nextPtr; sl@0: } sl@0: sl@0: return resultPtr; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * FsListMounts -- sl@0: * sl@0: * List all mounts within the given directory, which match the sl@0: * given pattern. sl@0: * sl@0: * Results: sl@0: * The list of mounts, in a list object which has refCount 0, or sl@0: * NULL if we didn't even find any filesystems to try to list sl@0: * mounts. sl@0: * sl@0: * Side effects: sl@0: * None sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static Tcl_Obj* sl@0: FsListMounts(pathPtr, pattern) sl@0: Tcl_Obj *pathPtr; /* Contains path to directory to search. */ sl@0: CONST char *pattern; /* Pattern to match against. */ sl@0: { sl@0: FilesystemRecord *fsRecPtr; sl@0: Tcl_GlobTypeData mountsOnly = { TCL_GLOB_TYPE_MOUNT, 0, NULL, NULL }; sl@0: Tcl_Obj *resultPtr = NULL; sl@0: sl@0: /* sl@0: * Call each of the "listMounts" functions in succession. sl@0: * A non-NULL return value indicates the particular function has sl@0: * succeeded. We call all the functions registered, since we want sl@0: * a list from each filesystems. sl@0: */ sl@0: sl@0: fsRecPtr = FsGetFirstFilesystem(); sl@0: while (fsRecPtr != NULL) { sl@0: if (fsRecPtr->fsPtr != &tclNativeFilesystem) { sl@0: Tcl_FSMatchInDirectoryProc *proc = sl@0: fsRecPtr->fsPtr->matchInDirectoryProc; sl@0: if (proc != NULL) { sl@0: if (resultPtr == NULL) { sl@0: resultPtr = Tcl_NewObj(); sl@0: } sl@0: (*proc)(NULL, resultPtr, pathPtr, pattern, &mountsOnly); sl@0: } sl@0: } sl@0: fsRecPtr = fsRecPtr->nextPtr; sl@0: } sl@0: sl@0: return resultPtr; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSSplitPath -- sl@0: * sl@0: * This function takes the given Tcl_Obj, which should be a valid sl@0: * path, and returns a Tcl List object containing each segment of sl@0: * that path as an element. sl@0: * sl@0: * Results: sl@0: * Returns list object with refCount of zero. If the passed in sl@0: * lenPtr is non-NULL, we use it to return the number of elements sl@0: * in the returned list. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Obj* sl@0: Tcl_FSSplitPath(pathPtr, lenPtr) sl@0: Tcl_Obj *pathPtr; /* Path to split. */ sl@0: int *lenPtr; /* int to store number of path elements. */ sl@0: { sl@0: Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */ sl@0: Tcl_Filesystem *fsPtr; sl@0: char separator = '/'; sl@0: int driveNameLength; sl@0: char *p; sl@0: sl@0: /* sl@0: * Perform platform specific splitting. sl@0: */ sl@0: sl@0: if (FSGetPathType(pathPtr, &fsPtr, &driveNameLength) sl@0: == TCL_PATH_ABSOLUTE) { sl@0: if (fsPtr == &tclNativeFilesystem) { sl@0: return TclpNativeSplitPath(pathPtr, lenPtr); sl@0: } sl@0: } else { sl@0: return TclpNativeSplitPath(pathPtr, lenPtr); sl@0: } sl@0: sl@0: /* We assume separators are single characters */ sl@0: if (fsPtr->filesystemSeparatorProc != NULL) { sl@0: Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(pathPtr); sl@0: if (sep != NULL) { sl@0: separator = Tcl_GetString(sep)[0]; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Place the drive name as first element of the sl@0: * result list. The drive name may contain strange sl@0: * characters, like colons and multiple forward slashes sl@0: * (for example 'ftp://' is a valid vfs drive name) sl@0: */ sl@0: result = Tcl_NewObj(); sl@0: p = Tcl_GetString(pathPtr); sl@0: Tcl_ListObjAppendElement(NULL, result, sl@0: Tcl_NewStringObj(p, driveNameLength)); sl@0: p+= driveNameLength; sl@0: sl@0: /* Add the remaining path elements to the list */ sl@0: for (;;) { sl@0: char *elementStart = p; sl@0: int length; sl@0: while ((*p != '\0') && (*p != separator)) { sl@0: p++; sl@0: } sl@0: length = p - elementStart; sl@0: if (length > 0) { sl@0: Tcl_Obj *nextElt; sl@0: if (elementStart[0] == '~') { sl@0: nextElt = Tcl_NewStringObj("./",2); sl@0: Tcl_AppendToObj(nextElt, elementStart, length); sl@0: } else { sl@0: nextElt = Tcl_NewStringObj(elementStart, length); sl@0: } sl@0: Tcl_ListObjAppendElement(NULL, result, nextElt); sl@0: } sl@0: if (*p++ == '\0') { sl@0: break; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Compute the number of elements in the result. sl@0: */ sl@0: sl@0: if (lenPtr != NULL) { sl@0: Tcl_ListObjLength(NULL, result, lenPtr); sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* Simple helper function */ sl@0: Tcl_Obj* sl@0: TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr) sl@0: Tcl_Filesystem *fromFilesystem; sl@0: ClientData clientData; sl@0: FilesystemRecord **fsRecPtrPtr; sl@0: { sl@0: FilesystemRecord *fsRecPtr = FsGetFirstFilesystem(); sl@0: sl@0: while (fsRecPtr != NULL) { sl@0: if (fsRecPtr->fsPtr == fromFilesystem) { sl@0: *fsRecPtrPtr = fsRecPtr; sl@0: break; sl@0: } sl@0: fsRecPtr = fsRecPtr->nextPtr; sl@0: } sl@0: sl@0: if ((fsRecPtr != NULL) sl@0: && (fromFilesystem->internalToNormalizedProc != NULL)) { sl@0: return (*fromFilesystem->internalToNormalizedProc)(clientData); sl@0: } else { sl@0: return NULL; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * GetPathType -- sl@0: * sl@0: * Helper function used by FSGetPathType. sl@0: * sl@0: * Results: sl@0: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or sl@0: * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will sl@0: * be set if and only if it is non-NULL and the function's sl@0: * return value is TCL_PATH_ABSOLUTE. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static Tcl_PathType sl@0: GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef) sl@0: Tcl_Obj *pathObjPtr; sl@0: Tcl_Filesystem **filesystemPtrPtr; sl@0: int *driveNameLengthPtr; sl@0: Tcl_Obj **driveNameRef; sl@0: { sl@0: FilesystemRecord *fsRecPtr; sl@0: int pathLen; sl@0: char *path; sl@0: Tcl_PathType type = TCL_PATH_RELATIVE; sl@0: sl@0: path = Tcl_GetStringFromObj(pathObjPtr, &pathLen); sl@0: sl@0: /* sl@0: * Call each of the "listVolumes" function in succession, checking sl@0: * whether the given path is an absolute path on any of the volumes sl@0: * returned (this is done by checking whether the path's prefix sl@0: * matches). sl@0: */ sl@0: sl@0: fsRecPtr = FsGetFirstFilesystem(); sl@0: while (fsRecPtr != NULL) { sl@0: Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc; sl@0: /* sl@0: * We want to skip the native filesystem in this loop because sl@0: * otherwise we won't necessarily pass all the Tcl testsuite -- sl@0: * this is because some of the tests artificially change the sl@0: * current platform (between mac, win, unix) but the list sl@0: * of volumes we get by calling (*proc) will reflect the current sl@0: * (real) platform only and this may cause some tests to fail. sl@0: * In particular, on unix '/' will match the beginning of sl@0: * certain absolute Windows paths starting '//' and those tests sl@0: * will go wrong. sl@0: * sl@0: * Besides these test-suite issues, there is one other reason sl@0: * to skip the native filesystem --- since the tclFilename.c sl@0: * code has nice fast 'absolute path' checkers, we don't want sl@0: * to waste time repeating that effort here, and this sl@0: * function is actually called quite often, so if we can sl@0: * save the overhead of the native filesystem returning us sl@0: * a list of volumes all the time, it is better. sl@0: */ sl@0: if ((fsRecPtr->fsPtr != &tclNativeFilesystem) && (proc != NULL)) { sl@0: int numVolumes; sl@0: Tcl_Obj *thisFsVolumes = (*proc)(); sl@0: if (thisFsVolumes != NULL) { sl@0: if (Tcl_ListObjLength(NULL, thisFsVolumes, sl@0: &numVolumes) != TCL_OK) { sl@0: /* sl@0: * This is VERY bad; the Tcl_FSListVolumesProc sl@0: * didn't return a valid list. Set numVolumes to sl@0: * -1 so that we skip the while loop below and just sl@0: * return with the current value of 'type'. sl@0: * sl@0: * It would be better if we could signal an error sl@0: * here (but panic seems a bit excessive). sl@0: */ sl@0: numVolumes = -1; sl@0: } sl@0: while (numVolumes > 0) { sl@0: Tcl_Obj *vol; sl@0: int len; sl@0: char *strVol; sl@0: sl@0: numVolumes--; sl@0: Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol); sl@0: strVol = Tcl_GetStringFromObj(vol,&len); sl@0: if (pathLen < len) { sl@0: continue; sl@0: } sl@0: if (strncmp(strVol, path, (size_t) len) == 0) { sl@0: type = TCL_PATH_ABSOLUTE; sl@0: if (filesystemPtrPtr != NULL) { sl@0: *filesystemPtrPtr = fsRecPtr->fsPtr; sl@0: } sl@0: if (driveNameLengthPtr != NULL) { sl@0: *driveNameLengthPtr = len; sl@0: } sl@0: if (driveNameRef != NULL) { sl@0: *driveNameRef = vol; sl@0: Tcl_IncrRefCount(vol); sl@0: } sl@0: break; sl@0: } sl@0: } sl@0: Tcl_DecrRefCount(thisFsVolumes); sl@0: if (type == TCL_PATH_ABSOLUTE) { sl@0: /* We don't need to examine any more filesystems */ sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: fsRecPtr = fsRecPtr->nextPtr; sl@0: } sl@0: sl@0: if (type != TCL_PATH_ABSOLUTE) { sl@0: type = TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, sl@0: driveNameRef); sl@0: if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) { sl@0: *filesystemPtrPtr = &tclNativeFilesystem; sl@0: } sl@0: } sl@0: return type; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSRenameFile -- sl@0: * sl@0: * If the two paths given belong to the same filesystem, we call sl@0: * that filesystems rename function. Otherwise we simply sl@0: * return the posix error 'EXDEV', and -1. sl@0: * sl@0: * Results: sl@0: * Standard Tcl error code if a function was called. sl@0: * sl@0: * Side effects: sl@0: * A file may be renamed. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_FSRenameFile(srcPathPtr, destPathPtr) sl@0: Tcl_Obj* srcPathPtr; /* Pathname of file or dir to be renamed sl@0: * (UTF-8). */ sl@0: Tcl_Obj *destPathPtr; /* New pathname of file or directory sl@0: * (UTF-8). */ sl@0: { sl@0: int retVal = -1; sl@0: Tcl_Filesystem *fsPtr, *fsPtr2; sl@0: fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); sl@0: fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); sl@0: sl@0: if (fsPtr == fsPtr2 && fsPtr != NULL) { sl@0: Tcl_FSRenameFileProc *proc = fsPtr->renameFileProc; sl@0: if (proc != NULL) { sl@0: retVal = (*proc)(srcPathPtr, destPathPtr); sl@0: } sl@0: } sl@0: if (retVal == -1) { sl@0: Tcl_SetErrno(EXDEV); sl@0: } sl@0: return retVal; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSCopyFile -- sl@0: * sl@0: * If the two paths given belong to the same filesystem, we call sl@0: * that filesystem's copy function. Otherwise we simply sl@0: * return the posix error 'EXDEV', and -1. sl@0: * sl@0: * Note that in the native filesystems, 'copyFileProc' is defined sl@0: * to copy soft links (i.e. it copies the links themselves, not sl@0: * the things they point to). sl@0: * sl@0: * Results: sl@0: * Standard Tcl error code if a function was called. sl@0: * sl@0: * Side effects: sl@0: * A file may be copied. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_FSCopyFile(srcPathPtr, destPathPtr) sl@0: Tcl_Obj* srcPathPtr; /* Pathname of file to be copied (UTF-8). */ sl@0: Tcl_Obj *destPathPtr; /* Pathname of file to copy to (UTF-8). */ sl@0: { sl@0: int retVal = -1; sl@0: Tcl_Filesystem *fsPtr, *fsPtr2; sl@0: fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); sl@0: fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); sl@0: sl@0: if (fsPtr == fsPtr2 && fsPtr != NULL) { sl@0: Tcl_FSCopyFileProc *proc = fsPtr->copyFileProc; sl@0: if (proc != NULL) { sl@0: retVal = (*proc)(srcPathPtr, destPathPtr); sl@0: } sl@0: } sl@0: if (retVal == -1) { sl@0: Tcl_SetErrno(EXDEV); sl@0: } sl@0: return retVal; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * TclCrossFilesystemCopy -- sl@0: * sl@0: * Helper for above function, and for Tcl_FSLoadFile, to copy sl@0: * files from one filesystem to another. This function will sl@0: * overwrite the target file if it already exists. sl@0: * sl@0: * Results: sl@0: * Standard Tcl error code. sl@0: * sl@0: * Side effects: sl@0: * A file may be created. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: int sl@0: TclCrossFilesystemCopy(interp, source, target) sl@0: Tcl_Interp *interp; /* For error messages */ sl@0: Tcl_Obj *source; /* Pathname of file to be copied (UTF-8). */ sl@0: Tcl_Obj *target; /* Pathname of file to copy to (UTF-8). */ sl@0: { sl@0: int result = TCL_ERROR; sl@0: int prot = 0666; sl@0: sl@0: Tcl_Channel out = Tcl_FSOpenFileChannel(interp, target, "w", prot); sl@0: if (out != NULL) { sl@0: /* It looks like we can copy it over */ sl@0: Tcl_Channel in = Tcl_FSOpenFileChannel(interp, source, sl@0: "r", prot); sl@0: if (in == NULL) { sl@0: /* This is very strange, we checked this above */ sl@0: Tcl_Close(interp, out); sl@0: } else { sl@0: Tcl_StatBuf sourceStatBuf; sl@0: struct utimbuf tval; sl@0: /* sl@0: * Copy it synchronously. We might wish to add an sl@0: * asynchronous option to support vfs's which are sl@0: * slow (e.g. network sockets). sl@0: */ sl@0: Tcl_SetChannelOption(interp, in, "-translation", "binary"); sl@0: Tcl_SetChannelOption(interp, out, "-translation", "binary"); sl@0: sl@0: if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) { sl@0: result = TCL_OK; sl@0: } sl@0: /* sl@0: * If the copy failed, assume that copy channel left sl@0: * a good error message. sl@0: */ sl@0: Tcl_Close(interp, in); sl@0: Tcl_Close(interp, out); sl@0: sl@0: /* Set modification date of copied file */ sl@0: if (Tcl_FSLstat(source, &sourceStatBuf) == 0) { sl@0: tval.actime = sourceStatBuf.st_atime; sl@0: tval.modtime = sourceStatBuf.st_mtime; sl@0: Tcl_FSUtime(target, &tval); sl@0: } sl@0: } sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSDeleteFile -- sl@0: * sl@0: * The appropriate function for the filesystem to which pathPtr sl@0: * belongs will be called. sl@0: * sl@0: * Results: sl@0: * Standard Tcl error code. sl@0: * sl@0: * Side effects: sl@0: * A file may be deleted. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_FSDeleteFile(pathPtr) sl@0: Tcl_Obj *pathPtr; /* Pathname of file to be removed (UTF-8). */ sl@0: { sl@0: Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); sl@0: if (fsPtr != NULL) { sl@0: Tcl_FSDeleteFileProc *proc = fsPtr->deleteFileProc; sl@0: if (proc != NULL) { sl@0: return (*proc)(pathPtr); sl@0: } sl@0: } sl@0: Tcl_SetErrno(ENOENT); sl@0: return -1; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSCreateDirectory -- sl@0: * sl@0: * The appropriate function for the filesystem to which pathPtr sl@0: * belongs will be called. sl@0: * sl@0: * Results: sl@0: * Standard Tcl error code. sl@0: * sl@0: * Side effects: sl@0: * A directory may be created. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_FSCreateDirectory(pathPtr) sl@0: Tcl_Obj *pathPtr; /* Pathname of directory to create (UTF-8). */ sl@0: { sl@0: Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); sl@0: if (fsPtr != NULL) { sl@0: Tcl_FSCreateDirectoryProc *proc = fsPtr->createDirectoryProc; sl@0: if (proc != NULL) { sl@0: return (*proc)(pathPtr); sl@0: } sl@0: } sl@0: Tcl_SetErrno(ENOENT); sl@0: return -1; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSCopyDirectory -- sl@0: * sl@0: * If the two paths given belong to the same filesystem, we call sl@0: * that filesystems copy-directory function. Otherwise we simply sl@0: * return the posix error 'EXDEV', and -1. sl@0: * sl@0: * Results: sl@0: * Standard Tcl error code if a function was called. sl@0: * sl@0: * Side effects: sl@0: * A directory may be copied. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_FSCopyDirectory(srcPathPtr, destPathPtr, errorPtr) sl@0: Tcl_Obj* srcPathPtr; /* Pathname of directory to be copied sl@0: * (UTF-8). */ sl@0: Tcl_Obj *destPathPtr; /* Pathname of target directory (UTF-8). */ sl@0: Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a sl@0: * new object containing name of file sl@0: * causing error, with refCount 1. */ sl@0: { sl@0: int retVal = -1; sl@0: Tcl_Filesystem *fsPtr, *fsPtr2; sl@0: fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); sl@0: fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); sl@0: sl@0: if (fsPtr == fsPtr2 && fsPtr != NULL) { sl@0: Tcl_FSCopyDirectoryProc *proc = fsPtr->copyDirectoryProc; sl@0: if (proc != NULL) { sl@0: retVal = (*proc)(srcPathPtr, destPathPtr, errorPtr); sl@0: } sl@0: } sl@0: if (retVal == -1) { sl@0: Tcl_SetErrno(EXDEV); sl@0: } sl@0: return retVal; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSRemoveDirectory -- sl@0: * sl@0: * The appropriate function for the filesystem to which pathPtr sl@0: * belongs will be called. sl@0: * sl@0: * Results: sl@0: * Standard Tcl error code. sl@0: * sl@0: * Side effects: sl@0: * A directory may be deleted. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr) sl@0: Tcl_Obj *pathPtr; /* Pathname of directory to be removed sl@0: * (UTF-8). */ sl@0: int recursive; /* If non-zero, removes directories that sl@0: * are nonempty. Otherwise, will only remove sl@0: * empty directories. */ sl@0: Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a sl@0: * new object containing name of file sl@0: * causing error, with refCount 1. */ sl@0: { sl@0: Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); sl@0: if (fsPtr != NULL) { sl@0: Tcl_FSRemoveDirectoryProc *proc = fsPtr->removeDirectoryProc; sl@0: if (proc != NULL) { sl@0: if (recursive) { sl@0: /* sl@0: * We check whether the cwd lies inside this directory sl@0: * and move it if it does. sl@0: */ sl@0: Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL); sl@0: if (cwdPtr != NULL) { sl@0: char *cwdStr, *normPathStr; sl@0: int cwdLen, normLen; sl@0: Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); sl@0: if (normPath != NULL) { sl@0: normPathStr = Tcl_GetStringFromObj(normPath, &normLen); sl@0: cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); sl@0: if ((cwdLen >= normLen) && (strncmp(normPathStr, sl@0: cwdStr, (size_t) normLen) == 0)) { sl@0: /* sl@0: * the cwd is inside the directory, so we sl@0: * perform a 'cd [file dirname $path]' sl@0: */ sl@0: Tcl_Obj *dirPtr = TclFileDirname(NULL, pathPtr); sl@0: Tcl_FSChdir(dirPtr); sl@0: Tcl_DecrRefCount(dirPtr); sl@0: } sl@0: } sl@0: Tcl_DecrRefCount(cwdPtr); sl@0: } sl@0: } sl@0: return (*proc)(pathPtr, recursive, errorPtr); sl@0: } sl@0: } sl@0: Tcl_SetErrno(ENOENT); sl@0: return -1; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSGetFileSystemForPath -- sl@0: * sl@0: * This function determines which filesystem to use for a sl@0: * particular path object, and returns the filesystem which sl@0: * accepts this file. If no filesystem will accept this object sl@0: * as a valid file path, then NULL is returned. sl@0: * sl@0: * Results: sl@0: .* NULL or a filesystem which will accept this path. sl@0: * sl@0: * Side effects: sl@0: * The object may be converted to a path type. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Filesystem* sl@0: Tcl_FSGetFileSystemForPath(pathObjPtr) sl@0: Tcl_Obj* pathObjPtr; sl@0: { sl@0: FilesystemRecord *fsRecPtr; sl@0: Tcl_Filesystem* retVal = NULL; sl@0: sl@0: /* sl@0: * If the object has a refCount of zero, we reject it. This sl@0: * is to avoid possible segfaults or nondeterministic memory sl@0: * leaks (i.e. the user doesn't know if they should decrement sl@0: * the ref count on return or not). sl@0: */ sl@0: sl@0: if (pathObjPtr->refCount == 0) { sl@0: panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0"); sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: * Check if the filesystem has changed in some way since sl@0: * this object's internal representation was calculated. sl@0: * Before doing that, assure we have the most up-to-date sl@0: * copy of the master filesystem. This is accomplished sl@0: * by the FsGetFirstFilesystem() call. sl@0: */ sl@0: sl@0: fsRecPtr = FsGetFirstFilesystem(); sl@0: sl@0: if (TclFSEnsureEpochOk(pathObjPtr, &retVal) != TCL_OK) { sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: * Call each of the "pathInFilesystem" functions in succession. A sl@0: * non-return value of -1 indicates the particular function has sl@0: * succeeded. sl@0: */ sl@0: sl@0: while ((retVal == NULL) && (fsRecPtr != NULL)) { sl@0: Tcl_FSPathInFilesystemProc *proc = fsRecPtr->fsPtr->pathInFilesystemProc; sl@0: if (proc != NULL) { sl@0: ClientData clientData = NULL; sl@0: int ret = (*proc)(pathObjPtr, &clientData); sl@0: if (ret != -1) { sl@0: /* sl@0: * We assume the type of pathObjPtr hasn't been changed sl@0: * by the above call to the pathInFilesystemProc. sl@0: */ sl@0: TclFSSetPathDetails(pathObjPtr, fsRecPtr, clientData); sl@0: retVal = fsRecPtr->fsPtr; sl@0: } sl@0: } sl@0: fsRecPtr = fsRecPtr->nextPtr; sl@0: } sl@0: sl@0: return retVal; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSGetNativePath -- sl@0: * sl@0: * This function is for use by the Win/Unix/MacOS native filesystems, sl@0: * so that they can easily retrieve the native (char* or TCHAR*) sl@0: * representation of a path. Other filesystems will probably sl@0: * want to implement similar functions. They basically act as a sl@0: * safety net around Tcl_FSGetInternalRep. Normally your file- sl@0: * system procedures will always be called with path objects sl@0: * already converted to the correct filesystem, but if for sl@0: * some reason they are called directly (i.e. by procedures sl@0: * not in this file), then one cannot necessarily guarantee that sl@0: * the path object pointer is from the correct filesystem. sl@0: * sl@0: * Note: in the future it might be desireable to have separate sl@0: * versions of this function with different signatures, for sl@0: * example Tcl_FSGetNativeMacPath, Tcl_FSGetNativeUnixPath etc. sl@0: * Right now, since native paths are all string based, we use just sl@0: * one function. On MacOS we could possibly use an FSSpec or sl@0: * FSRef as the native representation. sl@0: * sl@0: * Results: sl@0: * NULL or a valid native path. sl@0: * sl@0: * Side effects: sl@0: * See Tcl_FSGetInternalRep. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C CONST char * sl@0: Tcl_FSGetNativePath(pathObjPtr) sl@0: Tcl_Obj *pathObjPtr; sl@0: { sl@0: return (CONST char *)Tcl_FSGetInternalRep(pathObjPtr, &tclNativeFilesystem); sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * NativeCreateNativeRep -- sl@0: * sl@0: * Create a native representation for the given path. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: static ClientData sl@0: NativeCreateNativeRep(pathObjPtr) sl@0: Tcl_Obj* pathObjPtr; sl@0: { sl@0: char *nativePathPtr; sl@0: Tcl_DString ds; sl@0: Tcl_Obj* validPathObjPtr; sl@0: int len; sl@0: char *str; sl@0: sl@0: /* Make sure the normalized path is set */ sl@0: validPathObjPtr = Tcl_FSGetNormalizedPath(NULL, pathObjPtr); sl@0: if (validPathObjPtr == NULL) { sl@0: return NULL; sl@0: } sl@0: sl@0: str = Tcl_GetStringFromObj(validPathObjPtr, &len); sl@0: #ifdef __WIN32__ sl@0: Tcl_WinUtfToTChar(str, len, &ds); sl@0: if (tclWinProcs->useWide) { sl@0: len = Tcl_DStringLength(&ds) + sizeof(WCHAR); sl@0: } else { sl@0: len = Tcl_DStringLength(&ds) + sizeof(char); sl@0: } sl@0: #else sl@0: Tcl_UtfToExternalDString(NULL, str, len, &ds); sl@0: len = Tcl_DStringLength(&ds) + sizeof(char); sl@0: #endif sl@0: nativePathPtr = ckalloc((unsigned) len); sl@0: memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len); sl@0: sl@0: Tcl_DStringFree(&ds); sl@0: return (ClientData)nativePathPtr; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * TclpNativeToNormalized -- sl@0: * sl@0: * Convert native format to a normalized path object, with refCount sl@0: * of zero. sl@0: * sl@0: * Results: sl@0: * A valid normalized path. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: Tcl_Obj* sl@0: TclpNativeToNormalized(clientData) sl@0: ClientData clientData; sl@0: { sl@0: Tcl_DString ds; sl@0: Tcl_Obj *objPtr; sl@0: CONST char *copy; sl@0: int len; sl@0: sl@0: #ifdef __WIN32__ sl@0: Tcl_WinTCharToUtf((CONST char*)clientData, -1, &ds); sl@0: #else sl@0: Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds); sl@0: #endif sl@0: sl@0: copy = Tcl_DStringValue(&ds); sl@0: len = Tcl_DStringLength(&ds); sl@0: sl@0: #ifdef __WIN32__ sl@0: /* sl@0: * Certain native path representations on Windows have this special sl@0: * prefix to indicate that they are to be treated specially. For sl@0: * example extremely long paths, or symlinks sl@0: */ sl@0: if (*copy == '\\') { sl@0: if (0 == strncmp(copy,"\\??\\",4)) { sl@0: copy += 4; sl@0: len -= 4; sl@0: } else if (0 == strncmp(copy,"\\\\?\\",4)) { sl@0: copy += 4; sl@0: len -= 4; sl@0: } sl@0: } sl@0: #endif sl@0: sl@0: objPtr = Tcl_NewStringObj(copy,len); sl@0: Tcl_DStringFree(&ds); sl@0: sl@0: return objPtr; sl@0: } sl@0: sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * TclNativeDupInternalRep -- sl@0: * sl@0: * Duplicate the native representation. sl@0: * sl@0: * Results: sl@0: * The copied native representation, or NULL if it is not possible sl@0: * to copy the representation. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: ClientData sl@0: TclNativeDupInternalRep(clientData) sl@0: ClientData clientData; sl@0: { sl@0: ClientData copy; sl@0: size_t len; sl@0: sl@0: if (clientData == NULL) { sl@0: return NULL; sl@0: } sl@0: sl@0: #ifdef __WIN32__ sl@0: if (tclWinProcs->useWide) { sl@0: /* unicode representation when running on NT/2K/XP */ sl@0: len = sizeof(WCHAR) + (wcslen((CONST WCHAR*)clientData) * sizeof(WCHAR)); sl@0: } else { sl@0: /* ansi representation when running on 95/98/ME */ sl@0: len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char)); sl@0: } sl@0: #else sl@0: /* ansi representation when running on Unix/MacOS */ sl@0: len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char)); sl@0: #endif sl@0: sl@0: copy = (ClientData) ckalloc(len); sl@0: memcpy((VOID*)copy, (VOID*)clientData, len); sl@0: return copy; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * NativeFreeInternalRep -- sl@0: * sl@0: * Free a native internal representation, which will be non-NULL. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Memory is released. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: static void sl@0: NativeFreeInternalRep(clientData) sl@0: ClientData clientData; sl@0: { sl@0: ckfree((char*)clientData); sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSFileSystemInfo -- sl@0: * sl@0: * This function returns a list of two elements. The first sl@0: * element is the name of the filesystem (e.g. "native" or "vfs"), sl@0: * and the second is the particular type of the given path within sl@0: * that filesystem. sl@0: * sl@0: * Results: sl@0: * A list of two elements. sl@0: * sl@0: * Side effects: sl@0: * The object may be converted to a path type. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: EXPORT_C Tcl_Obj* sl@0: Tcl_FSFileSystemInfo(pathObjPtr) sl@0: Tcl_Obj* pathObjPtr; sl@0: { sl@0: Tcl_Obj *resPtr; sl@0: Tcl_FSFilesystemPathTypeProc *proc; sl@0: Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr); sl@0: sl@0: if (fsPtr == NULL) { sl@0: return NULL; sl@0: } sl@0: sl@0: resPtr = Tcl_NewListObj(0,NULL); sl@0: sl@0: Tcl_ListObjAppendElement(NULL, resPtr, sl@0: Tcl_NewStringObj(fsPtr->typeName,-1)); sl@0: sl@0: proc = fsPtr->filesystemPathTypeProc; sl@0: if (proc != NULL) { sl@0: Tcl_Obj *typePtr = (*proc)(pathObjPtr); sl@0: if (typePtr != NULL) { sl@0: Tcl_ListObjAppendElement(NULL, resPtr, typePtr); sl@0: } sl@0: } sl@0: sl@0: return resPtr; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSPathSeparator -- sl@0: * sl@0: * This function returns the separator to be used for a given sl@0: * path. The object returned should have a refCount of zero sl@0: * sl@0: * Results: sl@0: * A Tcl object, with a refCount of zero. If the caller sl@0: * needs to retain a reference to the object, it should sl@0: * call Tcl_IncrRefCount. sl@0: * sl@0: * Side effects: sl@0: * The path object may be converted to a path type. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: EXPORT_C Tcl_Obj* sl@0: Tcl_FSPathSeparator(pathObjPtr) sl@0: Tcl_Obj* pathObjPtr; sl@0: { sl@0: Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr); sl@0: sl@0: if (fsPtr == NULL) { sl@0: return NULL; sl@0: } sl@0: if (fsPtr->filesystemSeparatorProc != NULL) { sl@0: return (*fsPtr->filesystemSeparatorProc)(pathObjPtr); sl@0: } sl@0: sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * NativeFilesystemSeparator -- sl@0: * sl@0: * This function is part of the native filesystem support, and sl@0: * returns the separator for the given path. sl@0: * sl@0: * Results: sl@0: * String object containing the separator character. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: static Tcl_Obj* sl@0: NativeFilesystemSeparator(pathObjPtr) sl@0: Tcl_Obj* pathObjPtr; sl@0: { sl@0: char *separator = NULL; /* lint */ sl@0: switch (tclPlatform) { sl@0: case TCL_PLATFORM_UNIX: sl@0: separator = "/"; sl@0: break; sl@0: case TCL_PLATFORM_WINDOWS: sl@0: separator = "\\"; sl@0: break; sl@0: case TCL_PLATFORM_MAC: sl@0: separator = ":"; sl@0: break; sl@0: } sl@0: return Tcl_NewStringObj(separator,1); sl@0: } sl@0: sl@0: /* Everything from here on is contained in this obsolete ifdef */ sl@0: #ifdef USE_OBSOLETE_FS_HOOKS sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclStatInsertProc -- sl@0: * sl@0: * Insert the passed procedure pointer at the head of the list of sl@0: * functions which are used during a call to 'TclStat(...)'. The sl@0: * passed function should behave exactly like 'TclStat' when called sl@0: * during that time (see 'TclStat(...)' for more information). sl@0: * The function will be added even if it already in the list. sl@0: * sl@0: * Results: sl@0: * Normally TCL_OK; TCL_ERROR if memory for a new node in the list sl@0: * could not be allocated. sl@0: * sl@0: * Side effects: sl@0: * Memory allocated and modifies the link list for 'TclStat' sl@0: * functions. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclStatInsertProc (proc) sl@0: TclStatProc_ *proc; sl@0: { sl@0: int retVal = TCL_ERROR; sl@0: sl@0: if (proc != NULL) { sl@0: StatProc *newStatProcPtr; sl@0: sl@0: newStatProcPtr = (StatProc *)ckalloc(sizeof(StatProc)); sl@0: sl@0: if (newStatProcPtr != NULL) { sl@0: newStatProcPtr->proc = proc; sl@0: Tcl_MutexLock(&obsoleteFsHookMutex); sl@0: newStatProcPtr->nextPtr = statProcList; sl@0: statProcList = newStatProcPtr; sl@0: Tcl_MutexUnlock(&obsoleteFsHookMutex); sl@0: sl@0: retVal = TCL_OK; sl@0: } sl@0: } sl@0: sl@0: return retVal; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclStatDeleteProc -- sl@0: * sl@0: * Removed the passed function pointer from the list of 'TclStat' sl@0: * functions. Ensures that the built-in stat function is not sl@0: * removvable. sl@0: * sl@0: * Results: sl@0: * TCL_OK if the procedure pointer was successfully removed, sl@0: * TCL_ERROR otherwise. sl@0: * sl@0: * Side effects: sl@0: * Memory is deallocated and the respective list updated. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclStatDeleteProc (proc) sl@0: TclStatProc_ *proc; sl@0: { sl@0: int retVal = TCL_ERROR; sl@0: StatProc *tmpStatProcPtr; sl@0: StatProc *prevStatProcPtr = NULL; sl@0: sl@0: Tcl_MutexLock(&obsoleteFsHookMutex); sl@0: tmpStatProcPtr = statProcList; sl@0: /* sl@0: * Traverse the 'statProcList' looking for the particular node sl@0: * whose 'proc' member matches 'proc' and remove that one from sl@0: * the list. Ensure that the "default" node cannot be removed. sl@0: */ sl@0: sl@0: while ((retVal == TCL_ERROR) && (tmpStatProcPtr != NULL)) { sl@0: if (tmpStatProcPtr->proc == proc) { sl@0: if (prevStatProcPtr == NULL) { sl@0: statProcList = tmpStatProcPtr->nextPtr; sl@0: } else { sl@0: prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr; sl@0: } sl@0: sl@0: ckfree((char *)tmpStatProcPtr); sl@0: sl@0: retVal = TCL_OK; sl@0: } else { sl@0: prevStatProcPtr = tmpStatProcPtr; sl@0: tmpStatProcPtr = tmpStatProcPtr->nextPtr; sl@0: } sl@0: } sl@0: sl@0: Tcl_MutexUnlock(&obsoleteFsHookMutex); sl@0: sl@0: return retVal; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclAccessInsertProc -- sl@0: * sl@0: * Insert the passed procedure pointer at the head of the list of sl@0: * functions which are used during a call to 'TclAccess(...)'. sl@0: * The passed function should behave exactly like 'TclAccess' when sl@0: * called during that time (see 'TclAccess(...)' for more sl@0: * information). The function will be added even if it already in sl@0: * the list. sl@0: * sl@0: * Results: sl@0: * Normally TCL_OK; TCL_ERROR if memory for a new node in the list sl@0: * could not be allocated. sl@0: * sl@0: * Side effects: sl@0: * Memory allocated and modifies the link list for 'TclAccess' sl@0: * functions. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclAccessInsertProc(proc) sl@0: TclAccessProc_ *proc; sl@0: { sl@0: int retVal = TCL_ERROR; sl@0: sl@0: if (proc != NULL) { sl@0: AccessProc *newAccessProcPtr; sl@0: sl@0: newAccessProcPtr = (AccessProc *)ckalloc(sizeof(AccessProc)); sl@0: sl@0: if (newAccessProcPtr != NULL) { sl@0: newAccessProcPtr->proc = proc; sl@0: Tcl_MutexLock(&obsoleteFsHookMutex); sl@0: newAccessProcPtr->nextPtr = accessProcList; sl@0: accessProcList = newAccessProcPtr; sl@0: Tcl_MutexUnlock(&obsoleteFsHookMutex); sl@0: sl@0: retVal = TCL_OK; sl@0: } sl@0: } sl@0: sl@0: return retVal; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclAccessDeleteProc -- sl@0: * sl@0: * Removed the passed function pointer from the list of 'TclAccess' sl@0: * functions. Ensures that the built-in access function is not sl@0: * removvable. sl@0: * sl@0: * Results: sl@0: * TCL_OK if the procedure pointer was successfully removed, sl@0: * TCL_ERROR otherwise. sl@0: * sl@0: * Side effects: sl@0: * Memory is deallocated and the respective list updated. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclAccessDeleteProc(proc) sl@0: TclAccessProc_ *proc; sl@0: { sl@0: int retVal = TCL_ERROR; sl@0: AccessProc *tmpAccessProcPtr; sl@0: AccessProc *prevAccessProcPtr = NULL; sl@0: sl@0: /* sl@0: * Traverse the 'accessProcList' looking for the particular node sl@0: * whose 'proc' member matches 'proc' and remove that one from sl@0: * the list. Ensure that the "default" node cannot be removed. sl@0: */ sl@0: sl@0: Tcl_MutexLock(&obsoleteFsHookMutex); sl@0: tmpAccessProcPtr = accessProcList; sl@0: while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != NULL)) { sl@0: if (tmpAccessProcPtr->proc == proc) { sl@0: if (prevAccessProcPtr == NULL) { sl@0: accessProcList = tmpAccessProcPtr->nextPtr; sl@0: } else { sl@0: prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr; sl@0: } sl@0: sl@0: ckfree((char *)tmpAccessProcPtr); sl@0: sl@0: retVal = TCL_OK; sl@0: } else { sl@0: prevAccessProcPtr = tmpAccessProcPtr; sl@0: tmpAccessProcPtr = tmpAccessProcPtr->nextPtr; sl@0: } sl@0: } sl@0: Tcl_MutexUnlock(&obsoleteFsHookMutex); sl@0: sl@0: return retVal; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclOpenFileChannelInsertProc -- sl@0: * sl@0: * Insert the passed procedure pointer at the head of the list of sl@0: * functions which are used during a call to sl@0: * 'Tcl_OpenFileChannel(...)'. The passed function should behave sl@0: * exactly like 'Tcl_OpenFileChannel' when called during that time sl@0: * (see 'Tcl_OpenFileChannel(...)' for more information). The sl@0: * function will be added even if it already in the list. sl@0: * sl@0: * Results: sl@0: * Normally TCL_OK; TCL_ERROR if memory for a new node in the list sl@0: * could not be allocated. sl@0: * sl@0: * Side effects: sl@0: * Memory allocated and modifies the link list for sl@0: * 'Tcl_OpenFileChannel' functions. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclOpenFileChannelInsertProc(proc) sl@0: TclOpenFileChannelProc_ *proc; sl@0: { sl@0: int retVal = TCL_ERROR; sl@0: sl@0: if (proc != NULL) { sl@0: OpenFileChannelProc *newOpenFileChannelProcPtr; sl@0: sl@0: newOpenFileChannelProcPtr = sl@0: (OpenFileChannelProc *)ckalloc(sizeof(OpenFileChannelProc)); sl@0: sl@0: if (newOpenFileChannelProcPtr != NULL) { sl@0: newOpenFileChannelProcPtr->proc = proc; sl@0: Tcl_MutexLock(&obsoleteFsHookMutex); sl@0: newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; sl@0: openFileChannelProcList = newOpenFileChannelProcPtr; sl@0: Tcl_MutexUnlock(&obsoleteFsHookMutex); sl@0: sl@0: retVal = TCL_OK; sl@0: } sl@0: } sl@0: sl@0: return retVal; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclOpenFileChannelDeleteProc -- sl@0: * sl@0: * Removed the passed function pointer from the list of sl@0: * 'Tcl_OpenFileChannel' functions. Ensures that the built-in sl@0: * open file channel function is not removable. sl@0: * sl@0: * Results: sl@0: * TCL_OK if the procedure pointer was successfully removed, sl@0: * TCL_ERROR otherwise. sl@0: * sl@0: * Side effects: sl@0: * Memory is deallocated and the respective list updated. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclOpenFileChannelDeleteProc(proc) sl@0: TclOpenFileChannelProc_ *proc; sl@0: { sl@0: int retVal = TCL_ERROR; sl@0: OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList; sl@0: OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL; sl@0: sl@0: /* sl@0: * Traverse the 'openFileChannelProcList' looking for the particular sl@0: * node whose 'proc' member matches 'proc' and remove that one from sl@0: * the list. sl@0: */ sl@0: sl@0: Tcl_MutexLock(&obsoleteFsHookMutex); sl@0: tmpOpenFileChannelProcPtr = openFileChannelProcList; sl@0: while ((retVal == TCL_ERROR) && sl@0: (tmpOpenFileChannelProcPtr != NULL)) { sl@0: if (tmpOpenFileChannelProcPtr->proc == proc) { sl@0: if (prevOpenFileChannelProcPtr == NULL) { sl@0: openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr; sl@0: } else { sl@0: prevOpenFileChannelProcPtr->nextPtr = sl@0: tmpOpenFileChannelProcPtr->nextPtr; sl@0: } sl@0: sl@0: ckfree((char *)tmpOpenFileChannelProcPtr); sl@0: sl@0: retVal = TCL_OK; sl@0: } else { sl@0: prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr; sl@0: tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr; sl@0: } sl@0: } sl@0: Tcl_MutexUnlock(&obsoleteFsHookMutex); sl@0: sl@0: return retVal; sl@0: } sl@0: #endif /* USE_OBSOLETE_FS_HOOKS */ sl@0: sl@0: sl@0: /* sl@0: * Prototypes for procedures defined later in this file. sl@0: */ sl@0: sl@0: static void DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, sl@0: Tcl_Obj *copyPtr)); sl@0: static void FreeFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *listPtr)); sl@0: static void UpdateStringOfFsPath _ANSI_ARGS_((Tcl_Obj *objPtr)); sl@0: static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Obj *objPtr)); sl@0: static int FindSplitPos _ANSI_ARGS_((char *path, char *separator)); sl@0: sl@0: sl@0: sl@0: /* sl@0: * Define the 'path' object type, which Tcl uses to represent sl@0: * file paths internally. sl@0: */ sl@0: static Tcl_ObjType tclFsPathType = { sl@0: "path", /* name */ sl@0: FreeFsPathInternalRep, /* freeIntRepProc */ sl@0: DupFsPathInternalRep, /* dupIntRepProc */ sl@0: UpdateStringOfFsPath, /* updateStringProc */ sl@0: SetFsPathFromAny /* setFromAnyProc */ sl@0: }; sl@0: sl@0: /* sl@0: * struct FsPath -- sl@0: * sl@0: * Internal representation of a Tcl_Obj of "path" type. This sl@0: * can be used to represent relative or absolute paths, and has sl@0: * certain optimisations when used to represent paths which are sl@0: * already normalized and absolute. sl@0: * sl@0: * Note that 'normPathPtr' can be a circular reference to the sl@0: * container Tcl_Obj of this FsPath. sl@0: */ sl@0: typedef struct FsPath { sl@0: Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences. sl@0: * If this is NULL, then this is a sl@0: * pure normalized, absolute path sl@0: * object, in which the parent Tcl_Obj's sl@0: * string rep is already both translated sl@0: * and normalized. */ sl@0: Tcl_Obj *normPathPtr; /* Normalized absolute path, without sl@0: * ., .. or ~user sequences. If the sl@0: * Tcl_Obj containing sl@0: * this FsPath is already normalized, sl@0: * this may be a circular reference back sl@0: * to the container. If that is NOT the sl@0: * case, we have a refCount on the object. */ sl@0: Tcl_Obj *cwdPtr; /* If null, path is absolute, else sl@0: * this points to the cwd object used sl@0: * for this path. We have a refCount sl@0: * on the object. */ sl@0: int flags; /* Flags to describe interpretation */ sl@0: ClientData nativePathPtr; /* Native representation of this path, sl@0: * which is filesystem dependent. */ sl@0: int filesystemEpoch; /* Used to ensure the path representation sl@0: * was generated during the correct sl@0: * filesystem epoch. The epoch changes sl@0: * when filesystem-mounts are changed. */ sl@0: struct FilesystemRecord *fsRecPtr; sl@0: /* Pointer to the filesystem record sl@0: * entry to use for this path. */ sl@0: } FsPath; sl@0: sl@0: /* sl@0: * Define some macros to give us convenient access to path-object sl@0: * specific fields. sl@0: */ sl@0: #define PATHOBJ(objPtr) (objPtr->internalRep.otherValuePtr) sl@0: #define PATHFLAGS(objPtr) \ sl@0: (((FsPath*)(objPtr->internalRep.otherValuePtr))->flags) sl@0: sl@0: #define TCLPATH_APPENDED 1 sl@0: #define TCLPATH_RELATIVE 2 sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSGetPathType -- sl@0: * sl@0: * Determines whether a given path is relative to the current sl@0: * directory, relative to the current volume, or absolute. sl@0: * sl@0: * Results: sl@0: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or sl@0: * TCL_PATH_VOLUME_RELATIVE. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_PathType sl@0: Tcl_FSGetPathType(pathObjPtr) sl@0: Tcl_Obj *pathObjPtr; sl@0: { sl@0: return FSGetPathType(pathObjPtr, NULL, NULL); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * FSGetPathType -- sl@0: * sl@0: * Determines whether a given path is relative to the current sl@0: * directory, relative to the current volume, or absolute. If the sl@0: * caller wishes to know which filesystem claimed the path (in the sl@0: * case for which the path is absolute), then a reference to a sl@0: * filesystem pointer can be passed in (but passing NULL is sl@0: * acceptable). sl@0: * sl@0: * Results: sl@0: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or sl@0: * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will sl@0: * be set if and only if it is non-NULL and the function's sl@0: * return value is TCL_PATH_ABSOLUTE. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static Tcl_PathType sl@0: FSGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr) sl@0: Tcl_Obj *pathObjPtr; sl@0: Tcl_Filesystem **filesystemPtrPtr; sl@0: int *driveNameLengthPtr; sl@0: { sl@0: if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) { sl@0: return GetPathType(pathObjPtr, filesystemPtrPtr, sl@0: driveNameLengthPtr, NULL); sl@0: } else { sl@0: FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); sl@0: if (fsPathPtr->cwdPtr != NULL) { sl@0: if (PATHFLAGS(pathObjPtr) == 0) { sl@0: return TCL_PATH_RELATIVE; sl@0: } sl@0: return FSGetPathType(fsPathPtr->cwdPtr, filesystemPtrPtr, sl@0: driveNameLengthPtr); sl@0: } else { sl@0: return GetPathType(pathObjPtr, filesystemPtrPtr, sl@0: driveNameLengthPtr, NULL); sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSJoinPath -- sl@0: * sl@0: * This function takes the given Tcl_Obj, which should be a valid sl@0: * list, and returns the path object given by considering the sl@0: * first 'elements' elements as valid path segments. If elements < 0, sl@0: * we use the entire list. sl@0: * sl@0: * Results: sl@0: * Returns object with refCount of zero, (or if non-zero, it has sl@0: * references elsewhere in Tcl). Either way, the caller must sl@0: * increment its refCount before use. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: EXPORT_C Tcl_Obj* sl@0: Tcl_FSJoinPath(listObj, elements) sl@0: Tcl_Obj *listObj; sl@0: int elements; sl@0: { sl@0: Tcl_Obj *res; sl@0: int i; sl@0: Tcl_Filesystem *fsPtr = NULL; sl@0: sl@0: if (elements < 0) { sl@0: if (Tcl_ListObjLength(NULL, listObj, &elements) != TCL_OK) { sl@0: return NULL; sl@0: } sl@0: } else { sl@0: /* Just make sure it is a valid list */ sl@0: int listTest; sl@0: if (Tcl_ListObjLength(NULL, listObj, &listTest) != TCL_OK) { sl@0: return NULL; sl@0: } sl@0: /* sl@0: * Correct this if it is too large, otherwise we will sl@0: * waste our time joining null elements to the path sl@0: */ sl@0: if (elements > listTest) { sl@0: elements = listTest; sl@0: } sl@0: } sl@0: sl@0: res = Tcl_NewObj(); sl@0: sl@0: for (i = 0; i < elements; i++) { sl@0: Tcl_Obj *elt; sl@0: int driveNameLength; sl@0: Tcl_PathType type; sl@0: char *strElt; sl@0: int strEltLen; sl@0: int length; sl@0: char *ptr; sl@0: Tcl_Obj *driveName = NULL; sl@0: sl@0: Tcl_ListObjIndex(NULL, listObj, i, &elt); sl@0: sl@0: /* sl@0: * This is a special case where we can be much more sl@0: * efficient, where we are joining a single relative path sl@0: * onto an object that is already of path type. The sl@0: * 'TclNewFSPathObj' call below creates an object which sl@0: * can be normalized more efficiently. Currently we only sl@0: * use the special case when we have exactly two elements, sl@0: * but we could expand that in the future. sl@0: */ sl@0: if ((i == (elements-2)) && (i == 0) && (elt->typePtr == &tclFsPathType) sl@0: && !(elt->bytes != NULL && (elt->bytes[0] == '\0'))) { sl@0: Tcl_Obj *tail; sl@0: Tcl_PathType type; sl@0: Tcl_ListObjIndex(NULL, listObj, i+1, &tail); sl@0: type = GetPathType(tail, NULL, NULL, NULL); sl@0: if (type == TCL_PATH_RELATIVE) { sl@0: CONST char *str; sl@0: int len; sl@0: str = Tcl_GetStringFromObj(tail,&len); sl@0: if (len == 0) { sl@0: /* sl@0: * This happens if we try to handle the root volume sl@0: * '/'. There's no need to return a special path sl@0: * object, when the base itself is just fine! sl@0: */ sl@0: Tcl_DecrRefCount(res); sl@0: return elt; sl@0: } sl@0: /* sl@0: * If it doesn't begin with '.' and is a mac or unix sl@0: * path or it a windows path without backslashes, then we sl@0: * can be very efficient here. (In fact even a windows sl@0: * path with backslashes can be joined efficiently, but sl@0: * the path object would not have forward slashes only, sl@0: * and this would therefore contradict our 'file join' sl@0: * documentation). sl@0: */ sl@0: if (str[0] != '.' && ((tclPlatform != TCL_PLATFORM_WINDOWS) sl@0: || (strchr(str, '\\') == NULL))) { sl@0: /* sl@0: * Finally, on Windows, 'file join' is defined to sl@0: * convert all backslashes to forward slashes, sl@0: * so the base part cannot have backslashes either. sl@0: */ sl@0: if ((tclPlatform != TCL_PLATFORM_WINDOWS) sl@0: || (strchr(Tcl_GetString(elt), '\\') == NULL)) { sl@0: if (res != NULL) { sl@0: TclDecrRefCount(res); sl@0: } sl@0: return TclNewFSPathObj(elt, str, len); sl@0: } sl@0: } sl@0: /* sl@0: * Otherwise we don't have an easy join, and sl@0: * we must let the more general code below handle sl@0: * things sl@0: */ sl@0: } else { sl@0: if (tclPlatform == TCL_PLATFORM_UNIX) { sl@0: Tcl_DecrRefCount(res); sl@0: return tail; sl@0: } else { sl@0: CONST char *str; sl@0: int len; sl@0: str = Tcl_GetStringFromObj(tail,&len); sl@0: if (tclPlatform == TCL_PLATFORM_WINDOWS) { sl@0: if (strchr(str, '\\') == NULL) { sl@0: Tcl_DecrRefCount(res); sl@0: return tail; sl@0: } sl@0: } else if (tclPlatform == TCL_PLATFORM_MAC) { sl@0: if (strchr(str, '/') == NULL) { sl@0: Tcl_DecrRefCount(res); sl@0: return tail; sl@0: } sl@0: } sl@0: } sl@0: } sl@0: } sl@0: strElt = Tcl_GetStringFromObj(elt, &strEltLen); sl@0: type = GetPathType(elt, &fsPtr, &driveNameLength, &driveName); sl@0: if (type != TCL_PATH_RELATIVE) { sl@0: /* Zero out the current result */ sl@0: Tcl_DecrRefCount(res); sl@0: if (driveName != NULL) { sl@0: res = Tcl_DuplicateObj(driveName); sl@0: Tcl_DecrRefCount(driveName); sl@0: } else { sl@0: res = Tcl_NewStringObj(strElt, driveNameLength); sl@0: } sl@0: strElt += driveNameLength; sl@0: } sl@0: sl@0: ptr = Tcl_GetStringFromObj(res, &length); sl@0: sl@0: /* sl@0: * Strip off any './' before a tilde, unless this is the sl@0: * beginning of the path. sl@0: */ sl@0: if (length > 0 && strEltLen > 0) { sl@0: if ((strElt[0] == '.') && (strElt[1] == '/') sl@0: && (strElt[2] == '~')) { sl@0: strElt += 2; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * A NULL value for fsPtr at this stage basically means sl@0: * we're trying to join a relative path onto something sl@0: * which is also relative (or empty). There's nothing sl@0: * particularly wrong with that. sl@0: */ sl@0: if (*strElt == '\0') continue; sl@0: sl@0: if (fsPtr == &tclNativeFilesystem || fsPtr == NULL) { sl@0: TclpNativeJoinPath(res, strElt); sl@0: } else { sl@0: char separator = '/'; sl@0: int needsSep = 0; sl@0: sl@0: if (fsPtr->filesystemSeparatorProc != NULL) { sl@0: Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(res); sl@0: if (sep != NULL) { sl@0: separator = Tcl_GetString(sep)[0]; sl@0: } sl@0: } sl@0: sl@0: if (length > 0 && ptr[length -1] != '/') { sl@0: Tcl_AppendToObj(res, &separator, 1); sl@0: length++; sl@0: } sl@0: Tcl_SetObjLength(res, length + (int) strlen(strElt)); sl@0: sl@0: ptr = Tcl_GetString(res) + length; sl@0: for (; *strElt != '\0'; strElt++) { sl@0: if (*strElt == separator) { sl@0: while (strElt[1] == separator) { sl@0: strElt++; sl@0: } sl@0: if (strElt[1] != '\0') { sl@0: if (needsSep) { sl@0: *ptr++ = separator; sl@0: } sl@0: } sl@0: } else { sl@0: *ptr++ = *strElt; sl@0: needsSep = 1; sl@0: } sl@0: } sl@0: length = ptr - Tcl_GetString(res); sl@0: Tcl_SetObjLength(res, length); sl@0: } sl@0: } sl@0: return res; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSConvertToPathType -- sl@0: * sl@0: * This function tries to convert the given Tcl_Obj to a valid sl@0: * Tcl path type, taking account of the fact that the cwd may sl@0: * have changed even if this object is already supposedly of sl@0: * the correct type. sl@0: * sl@0: * The filename may begin with "~" (to indicate current user's sl@0: * home directory) or "~" (to indicate any user's home sl@0: * directory). sl@0: * sl@0: * Results: sl@0: * Standard Tcl error code. sl@0: * sl@0: * Side effects: sl@0: * The old representation may be freed, and new memory allocated. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: EXPORT_C int sl@0: Tcl_FSConvertToPathType(interp, objPtr) sl@0: Tcl_Interp *interp; /* Interpreter in which to store error sl@0: * message (if necessary). */ sl@0: Tcl_Obj *objPtr; /* Object to convert to a valid, current sl@0: * path type. */ sl@0: { sl@0: ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); sl@0: sl@0: /* sl@0: * While it is bad practice to examine an object's type directly, sl@0: * this is actually the best thing to do here. The reason is that sl@0: * if we are converting this object to FsPath type for the first sl@0: * time, we don't need to worry whether the 'cwd' has changed. sl@0: * On the other hand, if this object is already of FsPath type, sl@0: * and is a relative path, we do have to worry about the cwd. sl@0: * If the cwd has changed, we must recompute the path. sl@0: */ sl@0: if (objPtr->typePtr == &tclFsPathType) { sl@0: FsPath *fsPathPtr = (FsPath*) PATHOBJ(objPtr); sl@0: if (fsPathPtr->filesystemEpoch != tsdPtr->filesystemEpoch) { sl@0: if (objPtr->bytes == NULL) { sl@0: UpdateStringOfFsPath(objPtr); sl@0: } sl@0: FreeFsPathInternalRep(objPtr); sl@0: objPtr->typePtr = NULL; sl@0: return Tcl_ConvertToType(interp, objPtr, &tclFsPathType); sl@0: } sl@0: return TCL_OK; sl@0: } else { sl@0: return Tcl_ConvertToType(interp, objPtr, &tclFsPathType); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Helper function for SetFsPathFromAny. Returns position of first sl@0: * directory delimiter in the path. sl@0: */ sl@0: static int sl@0: FindSplitPos(path, separator) sl@0: char *path; sl@0: char *separator; sl@0: { sl@0: int count = 0; sl@0: switch (tclPlatform) { sl@0: case TCL_PLATFORM_UNIX: sl@0: case TCL_PLATFORM_MAC: sl@0: while (path[count] != 0) { sl@0: if (path[count] == *separator) { sl@0: return count; sl@0: } sl@0: count++; sl@0: } sl@0: break; sl@0: sl@0: case TCL_PLATFORM_WINDOWS: sl@0: while (path[count] != 0) { sl@0: if (path[count] == *separator || path[count] == '\\') { sl@0: return count; sl@0: } sl@0: count++; sl@0: } sl@0: break; sl@0: } sl@0: return count; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * TclNewFSPathObj -- sl@0: * sl@0: * Creates a path object whose string representation is sl@0: * '[file join dirPtr addStrRep]', but does so in a way that sl@0: * allows for more efficient caching of normalized paths. sl@0: * sl@0: * Assumptions: sl@0: * 'dirPtr' must be an absolute path. sl@0: * 'len' may not be zero. sl@0: * sl@0: * Results: sl@0: * The new Tcl object, with refCount zero. sl@0: * sl@0: * Side effects: sl@0: * Memory is allocated. 'dirPtr' gets an additional refCount. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: Tcl_Obj* sl@0: TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len) sl@0: { sl@0: FsPath *fsPathPtr; sl@0: Tcl_Obj *objPtr; sl@0: ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); sl@0: sl@0: objPtr = Tcl_NewObj(); sl@0: fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); sl@0: sl@0: if (tclPlatform == TCL_PLATFORM_MAC) { sl@0: /* sl@0: * Mac relative paths may begin with a directory separator ':'. sl@0: * If present, we need to skip this ':' because we assume that sl@0: * we can join dirPtr and addStrRep by concatenating them as sl@0: * strings (and we ensure that dirPtr is terminated by a ':'). sl@0: */ sl@0: if (addStrRep[0] == ':') { sl@0: addStrRep++; sl@0: len--; sl@0: } sl@0: } sl@0: /* Setup the path */ sl@0: fsPathPtr->translatedPathPtr = NULL; sl@0: fsPathPtr->normPathPtr = Tcl_NewStringObj(addStrRep, len); sl@0: Tcl_IncrRefCount(fsPathPtr->normPathPtr); sl@0: fsPathPtr->cwdPtr = dirPtr; sl@0: Tcl_IncrRefCount(dirPtr); sl@0: fsPathPtr->nativePathPtr = NULL; sl@0: fsPathPtr->fsRecPtr = NULL; sl@0: fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; sl@0: sl@0: PATHOBJ(objPtr) = (VOID *) fsPathPtr; sl@0: PATHFLAGS(objPtr) = TCLPATH_RELATIVE | TCLPATH_APPENDED; sl@0: objPtr->typePtr = &tclFsPathType; sl@0: objPtr->bytes = NULL; sl@0: objPtr->length = 0; sl@0: sl@0: return objPtr; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * TclFSMakePathRelative -- sl@0: * sl@0: * Only for internal use. sl@0: * sl@0: * Takes a path and a directory, where we _assume_ both path and sl@0: * directory are absolute, normalized and that the path lies sl@0: * inside the directory. Returns a Tcl_Obj representing filename sl@0: * of the path relative to the directory. sl@0: * sl@0: * In the case where the resulting path would start with a '~', we sl@0: * take special care to return an ordinary string. This means to sl@0: * use that path (and not have it interpreted as a user name), sl@0: * one must prepend './'. This may seem strange, but that is how sl@0: * 'glob' is currently defined. sl@0: * sl@0: * Results: sl@0: * NULL on error, otherwise a valid object, typically with sl@0: * refCount of zero, which it is assumed the caller will sl@0: * increment. sl@0: * sl@0: * Side effects: sl@0: * The old representation may be freed, and new memory allocated. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: Tcl_Obj* sl@0: TclFSMakePathRelative(interp, objPtr, cwdPtr) sl@0: Tcl_Interp *interp; /* Used for error reporting if not NULL. */ sl@0: Tcl_Obj *objPtr; /* The object we have. */ sl@0: Tcl_Obj *cwdPtr; /* Make it relative to this. */ sl@0: { sl@0: int cwdLen, len; sl@0: CONST char *tempStr; sl@0: ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); sl@0: sl@0: if (objPtr->typePtr == &tclFsPathType) { sl@0: FsPath *fsPathPtr = (FsPath*) PATHOBJ(objPtr); sl@0: if (PATHFLAGS(objPtr) != 0 sl@0: && fsPathPtr->cwdPtr == cwdPtr) { sl@0: objPtr = fsPathPtr->normPathPtr; sl@0: /* Free old representation */ sl@0: if (objPtr->typePtr != NULL) { sl@0: if (objPtr->bytes == NULL) { sl@0: if (objPtr->typePtr->updateStringProc == NULL) { sl@0: if (interp != NULL) { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendResult(interp, "can't find object", sl@0: "string representation", (char *) NULL); sl@0: } sl@0: return NULL; sl@0: } sl@0: objPtr->typePtr->updateStringProc(objPtr); sl@0: } sl@0: if ((objPtr->typePtr->freeIntRepProc) != NULL) { sl@0: (*objPtr->typePtr->freeIntRepProc)(objPtr); sl@0: } sl@0: } sl@0: /* Now objPtr is a string object */ sl@0: sl@0: if (Tcl_GetString(objPtr)[0] == '~') { sl@0: /* sl@0: * If the first character of the path is a tilde, sl@0: * we must just return the path as is, to agree sl@0: * with the defined behaviour of 'glob'. sl@0: */ sl@0: return objPtr; sl@0: } sl@0: sl@0: fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); sl@0: sl@0: /* Circular reference, by design */ sl@0: fsPathPtr->translatedPathPtr = objPtr; sl@0: fsPathPtr->normPathPtr = NULL; sl@0: fsPathPtr->cwdPtr = cwdPtr; sl@0: Tcl_IncrRefCount(cwdPtr); sl@0: fsPathPtr->nativePathPtr = NULL; sl@0: fsPathPtr->fsRecPtr = NULL; sl@0: fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; sl@0: sl@0: PATHOBJ(objPtr) = (VOID *) fsPathPtr; sl@0: PATHFLAGS(objPtr) = 0; sl@0: objPtr->typePtr = &tclFsPathType; sl@0: sl@0: return objPtr; sl@0: } sl@0: } sl@0: /* sl@0: * We know the cwd is a normalised object which does sl@0: * not end in a directory delimiter, unless the cwd sl@0: * is the name of a volume, in which case it will sl@0: * end in a delimiter! We handle this situation here. sl@0: * A better test than the '!= sep' might be to simply sl@0: * check if 'cwd' is a root volume. sl@0: * sl@0: * Note that if we get this wrong, we will strip off sl@0: * either too much or too little below, leading to sl@0: * wrong answers returned by glob. sl@0: */ sl@0: tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); sl@0: /* sl@0: * Should we perhaps use 'Tcl_FSPathSeparator'? sl@0: * But then what about the Windows special case? sl@0: * Perhaps we should just check if cwd is a root sl@0: * volume. sl@0: */ sl@0: switch (tclPlatform) { sl@0: case TCL_PLATFORM_UNIX: sl@0: if (tempStr[cwdLen-1] != '/') { sl@0: cwdLen++; sl@0: } sl@0: break; sl@0: case TCL_PLATFORM_WINDOWS: sl@0: if (tempStr[cwdLen-1] != '/' sl@0: && tempStr[cwdLen-1] != '\\') { sl@0: cwdLen++; sl@0: } sl@0: break; sl@0: case TCL_PLATFORM_MAC: sl@0: if (tempStr[cwdLen-1] != ':') { sl@0: cwdLen++; sl@0: } sl@0: break; sl@0: } sl@0: tempStr = Tcl_GetStringFromObj(objPtr, &len); sl@0: sl@0: return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen); sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * TclFSMakePathFromNormalized -- sl@0: * sl@0: * Like SetFsPathFromAny, but assumes the given object is an sl@0: * absolute normalized path. Only for internal use. sl@0: * sl@0: * Results: sl@0: * Standard Tcl error code. sl@0: * sl@0: * Side effects: sl@0: * The old representation may be freed, and new memory allocated. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclFSMakePathFromNormalized(interp, objPtr, nativeRep) sl@0: Tcl_Interp *interp; /* Used for error reporting if not NULL. */ sl@0: Tcl_Obj *objPtr; /* The object to convert. */ sl@0: ClientData nativeRep; /* The native rep for the object, if known sl@0: * else NULL. */ sl@0: { sl@0: FsPath *fsPathPtr; sl@0: ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); sl@0: sl@0: if (objPtr->typePtr == &tclFsPathType) { sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* Free old representation */ sl@0: if (objPtr->typePtr != NULL) { sl@0: if (objPtr->bytes == NULL) { sl@0: if (objPtr->typePtr->updateStringProc == NULL) { sl@0: if (interp != NULL) { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendResult(interp, "can't find object", sl@0: "string representation", (char *) NULL); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: objPtr->typePtr->updateStringProc(objPtr); sl@0: } sl@0: if ((objPtr->typePtr->freeIntRepProc) != NULL) { sl@0: (*objPtr->typePtr->freeIntRepProc)(objPtr); sl@0: } sl@0: } sl@0: sl@0: fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); sl@0: /* It's a pure normalized absolute path */ sl@0: fsPathPtr->translatedPathPtr = NULL; sl@0: fsPathPtr->normPathPtr = objPtr; sl@0: fsPathPtr->cwdPtr = NULL; sl@0: fsPathPtr->nativePathPtr = nativeRep; sl@0: fsPathPtr->fsRecPtr = NULL; sl@0: fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; sl@0: sl@0: PATHOBJ(objPtr) = (VOID *) fsPathPtr; sl@0: PATHFLAGS(objPtr) = 0; sl@0: objPtr->typePtr = &tclFsPathType; sl@0: sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSNewNativePath -- sl@0: * sl@0: * This function performs the something like that reverse of the sl@0: * usual obj->path->nativerep conversions. If some code retrieves sl@0: * a path in native form (from, e.g. readlink or a native dialog), sl@0: * and that path is to be used at the Tcl level, then calling sl@0: * this function is an efficient way of creating the appropriate sl@0: * path object type. sl@0: * sl@0: * Any memory which is allocated for 'clientData' should be retained sl@0: * until clientData is passed to the filesystem's freeInternalRepProc sl@0: * when it can be freed. The built in platform-specific filesystems sl@0: * use 'ckalloc' to allocate clientData, and ckfree to free it. sl@0: * sl@0: * Results: sl@0: * NULL or a valid path object pointer, with refCount zero. sl@0: * sl@0: * Side effects: sl@0: * New memory may be allocated. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_FSNewNativePath(fromFilesystem, clientData) sl@0: Tcl_Filesystem* fromFilesystem; sl@0: ClientData clientData; sl@0: { sl@0: Tcl_Obj *objPtr; sl@0: FsPath *fsPathPtr; sl@0: sl@0: FilesystemRecord *fsFromPtr; sl@0: ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); sl@0: sl@0: objPtr = TclFSInternalToNormalized(fromFilesystem, clientData, &fsFromPtr); sl@0: if (objPtr == NULL) { sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: * Free old representation; shouldn't normally be any, sl@0: * but best to be safe. sl@0: */ sl@0: if (objPtr->typePtr != NULL) { sl@0: if (objPtr->bytes == NULL) { sl@0: if (objPtr->typePtr->updateStringProc == NULL) { sl@0: return NULL; sl@0: } sl@0: objPtr->typePtr->updateStringProc(objPtr); sl@0: } sl@0: if ((objPtr->typePtr->freeIntRepProc) != NULL) { sl@0: (*objPtr->typePtr->freeIntRepProc)(objPtr); sl@0: } sl@0: } sl@0: sl@0: fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); sl@0: sl@0: fsPathPtr->translatedPathPtr = NULL; sl@0: /* Circular reference, by design */ sl@0: fsPathPtr->normPathPtr = objPtr; sl@0: fsPathPtr->cwdPtr = NULL; sl@0: fsPathPtr->nativePathPtr = clientData; sl@0: fsPathPtr->fsRecPtr = fsFromPtr; sl@0: fsPathPtr->fsRecPtr->fileRefCount++; sl@0: fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; sl@0: sl@0: PATHOBJ(objPtr) = (VOID *) fsPathPtr; sl@0: PATHFLAGS(objPtr) = 0; sl@0: objPtr->typePtr = &tclFsPathType; sl@0: sl@0: return objPtr; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSGetTranslatedPath -- sl@0: * sl@0: * This function attempts to extract the translated path sl@0: * from the given Tcl_Obj. If the translation succeeds (i.e. the sl@0: * object is a valid path), then it is returned. Otherwise NULL sl@0: * will be returned, and an error message may be left in the sl@0: * interpreter (if it is non-NULL) sl@0: * sl@0: * Results: sl@0: * NULL or a valid Tcl_Obj pointer. sl@0: * sl@0: * Side effects: sl@0: * Only those of 'Tcl_FSConvertToPathType' sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Obj* sl@0: Tcl_FSGetTranslatedPath(interp, pathPtr) sl@0: Tcl_Interp *interp; sl@0: Tcl_Obj* pathPtr; sl@0: { sl@0: Tcl_Obj *retObj = NULL; sl@0: FsPath *srcFsPathPtr; sl@0: sl@0: if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { sl@0: return NULL; sl@0: } sl@0: srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); sl@0: if (srcFsPathPtr->translatedPathPtr == NULL) { sl@0: if (PATHFLAGS(pathPtr) != 0) { sl@0: retObj = Tcl_FSGetNormalizedPath(interp, pathPtr); sl@0: } else { sl@0: /* sl@0: * It is a pure absolute, normalized path object. sl@0: * This is something like being a 'pure list'. The sl@0: * object's string, translatedPath and normalizedPath sl@0: * are all identical. sl@0: */ sl@0: retObj = srcFsPathPtr->normPathPtr; sl@0: } sl@0: } else { sl@0: /* It is an ordinary path object */ sl@0: retObj = srcFsPathPtr->translatedPathPtr; sl@0: } sl@0: sl@0: if (retObj) { sl@0: Tcl_IncrRefCount(retObj); sl@0: } sl@0: return retObj; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSGetTranslatedStringPath -- sl@0: * sl@0: * This function attempts to extract the translated path sl@0: * from the given Tcl_Obj. If the translation succeeds (i.e. the sl@0: * object is a valid path), then the path is returned. Otherwise NULL sl@0: * will be returned, and an error message may be left in the sl@0: * interpreter (if it is non-NULL) sl@0: * sl@0: * Results: sl@0: * NULL or a valid string. sl@0: * sl@0: * Side effects: sl@0: * Only those of 'Tcl_FSConvertToPathType' sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: EXPORT_C CONST char* sl@0: Tcl_FSGetTranslatedStringPath(interp, pathPtr) sl@0: Tcl_Interp *interp; sl@0: Tcl_Obj* pathPtr; sl@0: { sl@0: Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); sl@0: sl@0: if (transPtr != NULL) { sl@0: int len; sl@0: CONST char *result, *orig; sl@0: orig = Tcl_GetStringFromObj(transPtr, &len); sl@0: result = (char*) ckalloc((unsigned)(len+1)); sl@0: memcpy((VOID*) result, (VOID*) orig, (size_t) (len+1)); sl@0: Tcl_DecrRefCount(transPtr); sl@0: return result; sl@0: } sl@0: sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSGetNormalizedPath -- sl@0: * sl@0: * This important function attempts to extract from the given Tcl_Obj sl@0: * a unique normalised path representation, whose string value can sl@0: * be used as a unique identifier for the file. sl@0: * sl@0: * Results: sl@0: * NULL or a valid path object pointer. sl@0: * sl@0: * Side effects: sl@0: * New memory may be allocated. The Tcl 'errno' may be modified sl@0: * in the process of trying to examine various path possibilities. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Obj* sl@0: Tcl_FSGetNormalizedPath(interp, pathObjPtr) sl@0: Tcl_Interp *interp; sl@0: Tcl_Obj* pathObjPtr; sl@0: { sl@0: FsPath *fsPathPtr; sl@0: sl@0: if (Tcl_FSConvertToPathType(interp, pathObjPtr) != TCL_OK) { sl@0: return NULL; sl@0: } sl@0: fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); sl@0: sl@0: if (PATHFLAGS(pathObjPtr) != 0) { sl@0: /* sl@0: * This is a special path object which is the result of sl@0: * something like 'file join' sl@0: */ sl@0: Tcl_Obj *dir, *copy; sl@0: int cwdLen; sl@0: int pathType; sl@0: CONST char *cwdStr; sl@0: ClientData clientData = NULL; sl@0: sl@0: pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); sl@0: dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr); sl@0: if (dir == NULL) { sl@0: return NULL; sl@0: } sl@0: if (pathObjPtr->bytes == NULL) { sl@0: UpdateStringOfFsPath(pathObjPtr); sl@0: } sl@0: copy = Tcl_DuplicateObj(dir); sl@0: Tcl_IncrRefCount(copy); sl@0: Tcl_IncrRefCount(dir); sl@0: /* We now own a reference on both 'dir' and 'copy' */ sl@0: sl@0: cwdStr = Tcl_GetStringFromObj(copy, &cwdLen); sl@0: /* sl@0: * Should we perhaps use 'Tcl_FSPathSeparator'? sl@0: * But then what about the Windows special case? sl@0: * Perhaps we should just check if cwd is a root volume. sl@0: * We should never get cwdLen == 0 in this code path. sl@0: */ sl@0: switch (tclPlatform) { sl@0: case TCL_PLATFORM_UNIX: sl@0: if (cwdStr[cwdLen-1] != '/') { sl@0: Tcl_AppendToObj(copy, "/", 1); sl@0: cwdLen++; sl@0: } sl@0: break; sl@0: case TCL_PLATFORM_WINDOWS: sl@0: if (cwdStr[cwdLen-1] != '/' sl@0: && cwdStr[cwdLen-1] != '\\') { sl@0: Tcl_AppendToObj(copy, "/", 1); sl@0: cwdLen++; sl@0: } sl@0: break; sl@0: case TCL_PLATFORM_MAC: sl@0: if (cwdStr[cwdLen-1] != ':') { sl@0: Tcl_AppendToObj(copy, ":", 1); sl@0: cwdLen++; sl@0: } sl@0: break; sl@0: } sl@0: Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr); sl@0: /* sl@0: * Normalize the combined string, but only starting after sl@0: * the end of the previously normalized 'dir'. This should sl@0: * be much faster! We use 'cwdLen-1' so that we are sl@0: * already pointing at the dir-separator that we know about. sl@0: * The normalization code will actually start off directly sl@0: * after that separator. sl@0: */ sl@0: TclFSNormalizeToUniquePath(interp, copy, cwdLen-1, sl@0: (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL)); sl@0: /* Now we need to construct the new path object */ sl@0: sl@0: if (pathType == TCL_PATH_RELATIVE) { sl@0: FsPath* origDirFsPathPtr; sl@0: Tcl_Obj *origDir = fsPathPtr->cwdPtr; sl@0: origDirFsPathPtr = (FsPath*) PATHOBJ(origDir); sl@0: sl@0: fsPathPtr->cwdPtr = origDirFsPathPtr->cwdPtr; sl@0: Tcl_IncrRefCount(fsPathPtr->cwdPtr); sl@0: sl@0: Tcl_DecrRefCount(fsPathPtr->normPathPtr); sl@0: fsPathPtr->normPathPtr = copy; sl@0: /* That's our reference to copy used */ sl@0: Tcl_DecrRefCount(dir); sl@0: Tcl_DecrRefCount(origDir); sl@0: } else { sl@0: Tcl_DecrRefCount(fsPathPtr->cwdPtr); sl@0: fsPathPtr->cwdPtr = NULL; sl@0: Tcl_DecrRefCount(fsPathPtr->normPathPtr); sl@0: fsPathPtr->normPathPtr = copy; sl@0: /* That's our reference to copy used */ sl@0: Tcl_DecrRefCount(dir); sl@0: } sl@0: if (clientData != NULL) { sl@0: fsPathPtr->nativePathPtr = clientData; sl@0: } sl@0: PATHFLAGS(pathObjPtr) = 0; sl@0: } sl@0: /* Ensure cwd hasn't changed */ sl@0: if (fsPathPtr->cwdPtr != NULL) { sl@0: if (!TclFSCwdPointerEquals(fsPathPtr->cwdPtr)) { sl@0: if (pathObjPtr->bytes == NULL) { sl@0: UpdateStringOfFsPath(pathObjPtr); sl@0: } sl@0: FreeFsPathInternalRep(pathObjPtr); sl@0: pathObjPtr->typePtr = NULL; sl@0: if (Tcl_ConvertToType(interp, pathObjPtr, sl@0: &tclFsPathType) != TCL_OK) { sl@0: return NULL; sl@0: } sl@0: fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); sl@0: } else if (fsPathPtr->normPathPtr == NULL) { sl@0: int cwdLen; sl@0: Tcl_Obj *copy; sl@0: CONST char *cwdStr; sl@0: ClientData clientData = NULL; sl@0: sl@0: copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr); sl@0: Tcl_IncrRefCount(copy); sl@0: cwdStr = Tcl_GetStringFromObj(copy, &cwdLen); sl@0: /* sl@0: * Should we perhaps use 'Tcl_FSPathSeparator'? sl@0: * But then what about the Windows special case? sl@0: * Perhaps we should just check if cwd is a root volume. sl@0: * We should never get cwdLen == 0 in this code path. sl@0: */ sl@0: switch (tclPlatform) { sl@0: case TCL_PLATFORM_UNIX: sl@0: if (cwdStr[cwdLen-1] != '/') { sl@0: Tcl_AppendToObj(copy, "/", 1); sl@0: cwdLen++; sl@0: } sl@0: break; sl@0: case TCL_PLATFORM_WINDOWS: sl@0: if (cwdStr[cwdLen-1] != '/' sl@0: && cwdStr[cwdLen-1] != '\\') { sl@0: Tcl_AppendToObj(copy, "/", 1); sl@0: cwdLen++; sl@0: } sl@0: break; sl@0: case TCL_PLATFORM_MAC: sl@0: if (cwdStr[cwdLen-1] != ':') { sl@0: Tcl_AppendToObj(copy, ":", 1); sl@0: cwdLen++; sl@0: } sl@0: break; sl@0: } sl@0: Tcl_AppendObjToObj(copy, pathObjPtr); sl@0: /* sl@0: * Normalize the combined string, but only starting after sl@0: * the end of the previously normalized 'dir'. This should sl@0: * be much faster! sl@0: */ sl@0: TclFSNormalizeToUniquePath(interp, copy, cwdLen-1, sl@0: (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL)); sl@0: fsPathPtr->normPathPtr = copy; sl@0: if (clientData != NULL) { sl@0: fsPathPtr->nativePathPtr = clientData; sl@0: } sl@0: } sl@0: } sl@0: if (fsPathPtr->normPathPtr == NULL) { sl@0: ClientData clientData = NULL; sl@0: Tcl_Obj *useThisCwd = NULL; sl@0: /* sl@0: * Since normPathPtr is NULL, but this is a valid path sl@0: * object, we know that the translatedPathPtr cannot be NULL. sl@0: */ sl@0: Tcl_Obj *absolutePath = fsPathPtr->translatedPathPtr; sl@0: char *path = Tcl_GetString(absolutePath); sl@0: sl@0: /* sl@0: * We have to be a little bit careful here to avoid infinite loops sl@0: * we're asking Tcl_FSGetPathType to return the path's type, but sl@0: * that call can actually result in a lot of other filesystem sl@0: * action, which might loop back through here. sl@0: */ sl@0: if (path[0] != '\0') { sl@0: Tcl_PathType type = Tcl_FSGetPathType(pathObjPtr); sl@0: if (type == TCL_PATH_RELATIVE) { sl@0: useThisCwd = Tcl_FSGetCwd(interp); sl@0: sl@0: if (useThisCwd == NULL) return NULL; sl@0: sl@0: absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath); sl@0: Tcl_IncrRefCount(absolutePath); sl@0: /* We have a refCount on the cwd */ sl@0: #ifdef __WIN32__ sl@0: } else if (type == TCL_PATH_VOLUME_RELATIVE) { sl@0: /* sl@0: * Only Windows has volume-relative paths. These sl@0: * paths are rather rare, but is is nice if Tcl can sl@0: * handle them. It is much better if we can sl@0: * handle them here, rather than in the native fs code, sl@0: * because we really need to have a real absolute path sl@0: * just below. sl@0: * sl@0: * We do not let this block compile on non-Windows sl@0: * platforms because the test suite's manual forcing sl@0: * of tclPlatform can otherwise cause this code path sl@0: * to be executed, causing various errors because sl@0: * volume-relative paths really do not exist. sl@0: */ sl@0: useThisCwd = Tcl_FSGetCwd(interp); sl@0: if (useThisCwd == NULL) return NULL; sl@0: sl@0: if (path[0] == '/') { sl@0: /* sl@0: * Path of form /foo/bar which is a path in the sl@0: * root directory of the current volume. sl@0: */ sl@0: CONST char *drive = Tcl_GetString(useThisCwd); sl@0: absolutePath = Tcl_NewStringObj(drive,2); sl@0: Tcl_AppendToObj(absolutePath, path, -1); sl@0: Tcl_IncrRefCount(absolutePath); sl@0: /* We have a refCount on the cwd */ sl@0: } else { sl@0: /* sl@0: * Path of form C:foo/bar, but this only makes sl@0: * sense if the cwd is also on drive C. sl@0: */ sl@0: CONST char *drive = Tcl_GetString(useThisCwd); sl@0: char drive_c = path[0]; sl@0: if (drive_c >= 'a') { sl@0: drive_c -= ('a' - 'A'); sl@0: } sl@0: if (drive[0] == drive_c) { sl@0: absolutePath = Tcl_DuplicateObj(useThisCwd); sl@0: /* We have a refCount on the cwd */ sl@0: } else { sl@0: Tcl_DecrRefCount(useThisCwd); sl@0: useThisCwd = NULL; sl@0: /* sl@0: * The path is not in the current drive, but sl@0: * is volume-relative. The way Tcl 8.3 handles sl@0: * this is that it treats such a path as sl@0: * relative to the root of the drive. We sl@0: * therefore behave the same here. sl@0: */ sl@0: absolutePath = Tcl_NewStringObj(path, 2); sl@0: } sl@0: Tcl_IncrRefCount(absolutePath); sl@0: Tcl_AppendToObj(absolutePath, "/", 1); sl@0: Tcl_AppendToObj(absolutePath, path+2, -1); sl@0: } sl@0: #endif /* __WIN32__ */ sl@0: } sl@0: } sl@0: /* Already has refCount incremented */ sl@0: fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp, absolutePath, sl@0: (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL)); sl@0: if (0 && (clientData != NULL)) { sl@0: fsPathPtr->nativePathPtr = sl@0: (*fsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc)(clientData); sl@0: } sl@0: if (!strcmp(Tcl_GetString(fsPathPtr->normPathPtr), sl@0: Tcl_GetString(pathObjPtr))) { sl@0: /* sl@0: * The path was already normalized. sl@0: * Get rid of the duplicate. sl@0: */ sl@0: Tcl_DecrRefCount(fsPathPtr->normPathPtr); sl@0: /* sl@0: * We do *not* increment the refCount for sl@0: * this circular reference sl@0: */ sl@0: fsPathPtr->normPathPtr = pathObjPtr; sl@0: } sl@0: if (useThisCwd != NULL) { sl@0: /* This was returned by Tcl_FSJoinToPath above */ sl@0: Tcl_DecrRefCount(absolutePath); sl@0: fsPathPtr->cwdPtr = useThisCwd; sl@0: } sl@0: } sl@0: sl@0: return fsPathPtr->normPathPtr; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSGetInternalRep -- sl@0: * sl@0: * Extract the internal representation of a given path object, sl@0: * in the given filesystem. If the path object belongs to a sl@0: * different filesystem, we return NULL. sl@0: * sl@0: * If the internal representation is currently NULL, we attempt sl@0: * to generate it, by calling the filesystem's sl@0: * 'Tcl_FSCreateInternalRepProc'. sl@0: * sl@0: * Results: sl@0: * NULL or a valid internal representation. sl@0: * sl@0: * Side effects: sl@0: * An attempt may be made to convert the object. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C ClientData sl@0: Tcl_FSGetInternalRep(pathObjPtr, fsPtr) sl@0: Tcl_Obj* pathObjPtr; sl@0: Tcl_Filesystem *fsPtr; sl@0: { sl@0: FsPath *srcFsPathPtr; sl@0: sl@0: if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) { sl@0: return NULL; sl@0: } sl@0: srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); sl@0: sl@0: /* sl@0: * We will only return the native representation for the caller's sl@0: * filesystem. Otherwise we will simply return NULL. This means sl@0: * that there must be a unique bi-directional mapping between paths sl@0: * and filesystems, and that this mapping will not allow 'remapped' sl@0: * files -- files which are in one filesystem but mapped into sl@0: * another. Another way of putting this is that 'stacked' sl@0: * filesystems are not allowed. We recognise that this is a sl@0: * potentially useful feature for the future. sl@0: * sl@0: * Even something simple like a 'pass through' filesystem which sl@0: * logs all activity and passes the calls onto the native system sl@0: * would be nice, but not easily achievable with the current sl@0: * implementation. sl@0: */ sl@0: if (srcFsPathPtr->fsRecPtr == NULL) { sl@0: /* sl@0: * This only usually happens in wrappers like TclpStat which sl@0: * create a string object and pass it to TclpObjStat. Code sl@0: * which calls the Tcl_FS.. functions should always have a sl@0: * filesystem already set. Whether this code path is legal or sl@0: * not depends on whether we decide to allow external code to sl@0: * call the native filesystem directly. It is at least safer sl@0: * to allow this sub-optimal routing. sl@0: */ sl@0: Tcl_FSGetFileSystemForPath(pathObjPtr); sl@0: sl@0: /* sl@0: * If we fail through here, then the path is probably not a sl@0: * valid path in the filesystsem, and is most likely to be a sl@0: * use of the empty path "" via a direct call to one of the sl@0: * objectified interfaces (e.g. from the Tcl testsuite). sl@0: */ sl@0: srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); sl@0: if (srcFsPathPtr->fsRecPtr == NULL) { sl@0: return NULL; sl@0: } sl@0: } sl@0: sl@0: if (fsPtr != srcFsPathPtr->fsRecPtr->fsPtr) { sl@0: /* sl@0: * There is still one possibility we should consider; if the sl@0: * file belongs to a different filesystem, perhaps it is sl@0: * actually linked through to a file in our own filesystem sl@0: * which we do care about. The way we can check for this sl@0: * is we ask what filesystem this path belongs to. sl@0: */ sl@0: Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathObjPtr); sl@0: if (actualFs == fsPtr) { sl@0: return Tcl_FSGetInternalRep(pathObjPtr, fsPtr); sl@0: } sl@0: return NULL; sl@0: } sl@0: sl@0: if (srcFsPathPtr->nativePathPtr == NULL) { sl@0: Tcl_FSCreateInternalRepProc *proc; sl@0: char *nativePathPtr; sl@0: sl@0: proc = srcFsPathPtr->fsRecPtr->fsPtr->createInternalRepProc; sl@0: if (proc == NULL) { sl@0: return NULL; sl@0: } sl@0: sl@0: nativePathPtr = (*proc)(pathObjPtr); sl@0: srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); sl@0: srcFsPathPtr->nativePathPtr = nativePathPtr; sl@0: } sl@0: sl@0: return srcFsPathPtr->nativePathPtr; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * TclFSEnsureEpochOk -- sl@0: * sl@0: * This will ensure the pathObjPtr is up to date and can be sl@0: * converted into a "path" type, and that we are able to generate a sl@0: * complete normalized path which is used to determine the sl@0: * filesystem match. sl@0: * sl@0: * Results: sl@0: * Standard Tcl return code. sl@0: * sl@0: * Side effects: sl@0: * An attempt may be made to convert the object. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclFSEnsureEpochOk(pathObjPtr, fsPtrPtr) sl@0: Tcl_Obj* pathObjPtr; sl@0: Tcl_Filesystem **fsPtrPtr; sl@0: { sl@0: FsPath *srcFsPathPtr; sl@0: ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); sl@0: sl@0: /* sl@0: * SHOULD BE ABLE TO IMPROVE EFFICIENCY HERE. sl@0: */ sl@0: sl@0: if (Tcl_FSGetNormalizedPath(NULL, pathObjPtr) == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); sl@0: sl@0: /* sl@0: * Check if the filesystem has changed in some way since sl@0: * this object's internal representation was calculated. sl@0: */ sl@0: if (srcFsPathPtr->filesystemEpoch != tsdPtr->filesystemEpoch) { sl@0: /* sl@0: * We have to discard the stale representation and sl@0: * recalculate it sl@0: */ sl@0: if (pathObjPtr->bytes == NULL) { sl@0: UpdateStringOfFsPath(pathObjPtr); sl@0: } sl@0: FreeFsPathInternalRep(pathObjPtr); sl@0: pathObjPtr->typePtr = NULL; sl@0: if (SetFsPathFromAny(NULL, pathObjPtr) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); sl@0: } sl@0: /* Check whether the object is already assigned to a fs */ sl@0: if (srcFsPathPtr->fsRecPtr != NULL) { sl@0: *fsPtrPtr = srcFsPathPtr->fsRecPtr->fsPtr; sl@0: } sl@0: sl@0: return TCL_OK; sl@0: } sl@0: sl@0: void sl@0: TclFSSetPathDetails(pathObjPtr, fsRecPtr, clientData) sl@0: Tcl_Obj *pathObjPtr; sl@0: FilesystemRecord *fsRecPtr; sl@0: ClientData clientData; sl@0: { sl@0: ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); sl@0: /* We assume pathObjPtr is already of the correct type */ sl@0: FsPath *srcFsPathPtr; sl@0: sl@0: srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); sl@0: srcFsPathPtr->fsRecPtr = fsRecPtr; sl@0: srcFsPathPtr->nativePathPtr = clientData; sl@0: srcFsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; sl@0: fsRecPtr->fileRefCount++; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FSEqualPaths -- sl@0: * sl@0: * This function tests whether the two paths given are equal path sl@0: * objects. If either or both is NULL, 0 is always returned. sl@0: * sl@0: * Results: sl@0: * 1 or 0. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_FSEqualPaths(firstPtr, secondPtr) sl@0: Tcl_Obj* firstPtr; sl@0: Tcl_Obj* secondPtr; sl@0: { sl@0: if (firstPtr == secondPtr) { sl@0: return 1; sl@0: } else { sl@0: char *firstStr, *secondStr; sl@0: int firstLen, secondLen, tempErrno; sl@0: sl@0: if (firstPtr == NULL || secondPtr == NULL) { sl@0: return 0; sl@0: } sl@0: firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen); sl@0: secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen); sl@0: if ((firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0)) { sl@0: return 1; sl@0: } sl@0: /* sl@0: * Try the most thorough, correct method of comparing fully sl@0: * normalized paths sl@0: */ sl@0: sl@0: tempErrno = Tcl_GetErrno(); sl@0: firstPtr = Tcl_FSGetNormalizedPath(NULL, firstPtr); sl@0: secondPtr = Tcl_FSGetNormalizedPath(NULL, secondPtr); sl@0: Tcl_SetErrno(tempErrno); sl@0: sl@0: if (firstPtr == NULL || secondPtr == NULL) { sl@0: return 0; sl@0: } sl@0: firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen); sl@0: secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen); sl@0: if ((firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0)) { sl@0: return 1; sl@0: } sl@0: } sl@0: sl@0: return 0; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * SetFsPathFromAny -- sl@0: * sl@0: * This function tries to convert the given Tcl_Obj to a valid sl@0: * Tcl path type. sl@0: * sl@0: * The filename may begin with "~" (to indicate current user's sl@0: * home directory) or "~" (to indicate any user's home sl@0: * directory). sl@0: * sl@0: * Results: sl@0: * Standard Tcl error code. sl@0: * sl@0: * Side effects: sl@0: * The old representation may be freed, and new memory allocated. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: SetFsPathFromAny(interp, objPtr) sl@0: Tcl_Interp *interp; /* Used for error reporting if not NULL. */ sl@0: Tcl_Obj *objPtr; /* The object to convert. */ sl@0: { sl@0: int len; sl@0: FsPath *fsPathPtr; sl@0: Tcl_Obj *transPtr; sl@0: char *name; sl@0: ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); sl@0: sl@0: if (objPtr->typePtr == &tclFsPathType) { sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: * First step is to translate the filename. This is similar to sl@0: * Tcl_TranslateFilename, but shouldn't convert everything to sl@0: * windows backslashes on that platform. The current sl@0: * implementation of this piece is a slightly optimised version sl@0: * of the various Tilde/Split/Join stuff to avoid multiple sl@0: * split/join operations. sl@0: * sl@0: * We remove any trailing directory separator. sl@0: * sl@0: * However, the split/join routines are quite complex, and sl@0: * one has to make sure not to break anything on Unix, Win sl@0: * or MacOS (fCmd.test, fileName.test and cmdAH.test exercise sl@0: * most of the code). sl@0: */ sl@0: name = Tcl_GetStringFromObj(objPtr,&len); sl@0: sl@0: /* sl@0: * Handle tilde substitutions, if needed. sl@0: */ sl@0: if (name[0] == '~') { sl@0: char *expandedUser; sl@0: Tcl_DString temp; sl@0: int split; sl@0: char separator='/'; sl@0: sl@0: if (tclPlatform==TCL_PLATFORM_MAC) { sl@0: if (strchr(name, ':') != NULL) separator = ':'; sl@0: } sl@0: sl@0: split = FindSplitPos(name, &separator); sl@0: if (split != len) { sl@0: /* We have multiple pieces '~user/foo/bar...' */ sl@0: name[split] = '\0'; sl@0: } sl@0: /* Do some tilde substitution */ sl@0: if (name[1] == '\0') { sl@0: /* We have just '~' */ sl@0: CONST char *dir; sl@0: Tcl_DString dirString; sl@0: if (split != len) { name[split] = separator; } sl@0: sl@0: dir = TclGetEnv("HOME", &dirString); sl@0: if (dir == NULL) { sl@0: if (interp) { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendResult(interp, "couldn't find HOME environment ", sl@0: "variable to expand path", (char *) NULL); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_DStringInit(&temp); sl@0: Tcl_JoinPath(1, &dir, &temp); sl@0: Tcl_DStringFree(&dirString); sl@0: } else { sl@0: /* We have a user name '~user' */ sl@0: Tcl_DStringInit(&temp); sl@0: if (TclpGetUserHome(name+1, &temp) == NULL) { sl@0: if (interp != NULL) { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendResult(interp, "user \"", (name+1), sl@0: "\" doesn't exist", (char *) NULL); sl@0: } sl@0: Tcl_DStringFree(&temp); sl@0: if (split != len) { name[split] = separator; } sl@0: return TCL_ERROR; sl@0: } sl@0: if (split != len) { name[split] = separator; } sl@0: } sl@0: sl@0: expandedUser = Tcl_DStringValue(&temp); sl@0: transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp)); sl@0: sl@0: if (split != len) { sl@0: /* Join up the tilde substitution with the rest */ sl@0: if (name[split+1] == separator) { sl@0: sl@0: /* sl@0: * Somewhat tricky case like ~//foo/bar. sl@0: * Make use of Split/Join machinery to get it right. sl@0: * Assumes all paths beginning with ~ are part of the sl@0: * native filesystem. sl@0: */ sl@0: sl@0: int objc; sl@0: Tcl_Obj **objv; sl@0: Tcl_Obj *parts = TclpNativeSplitPath(objPtr, NULL); sl@0: Tcl_ListObjGetElements(NULL, parts, &objc, &objv); sl@0: /* Skip '~'. It's replaced by its expansion */ sl@0: objc--; objv++; sl@0: while (objc--) { sl@0: TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++)); sl@0: } sl@0: Tcl_DecrRefCount(parts); sl@0: } else { sl@0: /* Simple case. "rest" is relative path. Just join it. */ sl@0: Tcl_Obj *rest = Tcl_NewStringObj(name+split+1,-1); sl@0: transPtr = Tcl_FSJoinToPath(transPtr, 1, &rest); sl@0: } sl@0: } sl@0: Tcl_DStringFree(&temp); sl@0: } else { sl@0: transPtr = Tcl_FSJoinToPath(objPtr,0,NULL); sl@0: } sl@0: sl@0: #if defined(__CYGWIN__) && defined(__WIN32__) sl@0: { sl@0: extern int cygwin_conv_to_win32_path sl@0: _ANSI_ARGS_((CONST char *, char *)); sl@0: char winbuf[MAX_PATH+1]; sl@0: sl@0: /* sl@0: * In the Cygwin world, call conv_to_win32_path in order to use the sl@0: * mount table to translate the file name into something Windows will sl@0: * understand. Take care when converting empty strings! sl@0: */ sl@0: name = Tcl_GetStringFromObj(transPtr, &len); sl@0: if (len > 0) { sl@0: cygwin_conv_to_win32_path(name, winbuf); sl@0: TclWinNoBackslash(winbuf); sl@0: Tcl_SetStringObj(transPtr, winbuf, -1); sl@0: } sl@0: } sl@0: #endif /* __CYGWIN__ && __WIN32__ */ sl@0: sl@0: /* sl@0: * Now we have a translated filename in 'transPtr'. This will have sl@0: * forward slashes on Windows, and will not contain any ~user sl@0: * sequences. sl@0: */ sl@0: sl@0: fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); sl@0: sl@0: fsPathPtr->translatedPathPtr = transPtr; sl@0: Tcl_IncrRefCount(fsPathPtr->translatedPathPtr); sl@0: fsPathPtr->normPathPtr = NULL; sl@0: fsPathPtr->cwdPtr = NULL; sl@0: fsPathPtr->nativePathPtr = NULL; sl@0: fsPathPtr->fsRecPtr = NULL; sl@0: fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; sl@0: sl@0: /* sl@0: * Free old representation before installing our new one. sl@0: */ sl@0: if (objPtr->typePtr != NULL && objPtr->typePtr->freeIntRepProc != NULL) { sl@0: (objPtr->typePtr->freeIntRepProc)(objPtr); sl@0: } sl@0: PATHOBJ(objPtr) = (VOID *) fsPathPtr; sl@0: PATHFLAGS(objPtr) = 0; sl@0: objPtr->typePtr = &tclFsPathType; sl@0: sl@0: return TCL_OK; sl@0: } sl@0: sl@0: static void sl@0: FreeFsPathInternalRep(pathObjPtr) sl@0: Tcl_Obj *pathObjPtr; /* Path object with internal rep to free. */ sl@0: { sl@0: FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); sl@0: sl@0: if (fsPathPtr->translatedPathPtr != NULL) { sl@0: if (fsPathPtr->translatedPathPtr != pathObjPtr) { sl@0: Tcl_DecrRefCount(fsPathPtr->translatedPathPtr); sl@0: } sl@0: } sl@0: if (fsPathPtr->normPathPtr != NULL) { sl@0: if (fsPathPtr->normPathPtr != pathObjPtr) { sl@0: Tcl_DecrRefCount(fsPathPtr->normPathPtr); sl@0: } sl@0: fsPathPtr->normPathPtr = NULL; sl@0: } sl@0: if (fsPathPtr->cwdPtr != NULL) { sl@0: Tcl_DecrRefCount(fsPathPtr->cwdPtr); sl@0: } sl@0: if (fsPathPtr->nativePathPtr != NULL) { sl@0: if (fsPathPtr->fsRecPtr != NULL) { sl@0: if (fsPathPtr->fsRecPtr->fsPtr->freeInternalRepProc != NULL) { sl@0: (*fsPathPtr->fsRecPtr->fsPtr sl@0: ->freeInternalRepProc)(fsPathPtr->nativePathPtr); sl@0: fsPathPtr->nativePathPtr = NULL; sl@0: } sl@0: } sl@0: } sl@0: if (fsPathPtr->fsRecPtr != NULL) { sl@0: fsPathPtr->fsRecPtr->fileRefCount--; sl@0: if (fsPathPtr->fsRecPtr->fileRefCount <= 0) { sl@0: /* It has been unregistered already, so simply free it */ sl@0: ckfree((char *)fsPathPtr->fsRecPtr); sl@0: } sl@0: } sl@0: sl@0: ckfree((char*) fsPathPtr); sl@0: } sl@0: sl@0: sl@0: static void sl@0: DupFsPathInternalRep(srcPtr, copyPtr) sl@0: Tcl_Obj *srcPtr; /* Path obj with internal rep to copy. */ sl@0: Tcl_Obj *copyPtr; /* Path obj with internal rep to set. */ sl@0: { sl@0: FsPath *srcFsPathPtr = (FsPath*) PATHOBJ(srcPtr); sl@0: FsPath *copyFsPathPtr = (FsPath*) ckalloc((unsigned)sizeof(FsPath)); sl@0: sl@0: Tcl_FSDupInternalRepProc *dupProc; sl@0: sl@0: PATHOBJ(copyPtr) = (VOID *) copyFsPathPtr; sl@0: sl@0: if (srcFsPathPtr->translatedPathPtr != NULL) { sl@0: copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr; sl@0: if (copyFsPathPtr->translatedPathPtr != copyPtr) { sl@0: Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); sl@0: } sl@0: } else { sl@0: copyFsPathPtr->translatedPathPtr = NULL; sl@0: } sl@0: sl@0: if (srcFsPathPtr->normPathPtr != NULL) { sl@0: copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; sl@0: if (copyFsPathPtr->normPathPtr != copyPtr) { sl@0: Tcl_IncrRefCount(copyFsPathPtr->normPathPtr); sl@0: } sl@0: } else { sl@0: copyFsPathPtr->normPathPtr = NULL; sl@0: } sl@0: sl@0: if (srcFsPathPtr->cwdPtr != NULL) { sl@0: copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr; sl@0: Tcl_IncrRefCount(copyFsPathPtr->cwdPtr); sl@0: } else { sl@0: copyFsPathPtr->cwdPtr = NULL; sl@0: } sl@0: sl@0: copyFsPathPtr->flags = srcFsPathPtr->flags; sl@0: sl@0: if (srcFsPathPtr->fsRecPtr != NULL sl@0: && srcFsPathPtr->nativePathPtr != NULL) { sl@0: dupProc = srcFsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc; sl@0: if (dupProc != NULL) { sl@0: copyFsPathPtr->nativePathPtr = sl@0: (*dupProc)(srcFsPathPtr->nativePathPtr); sl@0: } else { sl@0: copyFsPathPtr->nativePathPtr = NULL; sl@0: } sl@0: } else { sl@0: copyFsPathPtr->nativePathPtr = NULL; sl@0: } sl@0: copyFsPathPtr->fsRecPtr = srcFsPathPtr->fsRecPtr; sl@0: copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch; sl@0: if (copyFsPathPtr->fsRecPtr != NULL) { sl@0: copyFsPathPtr->fsRecPtr->fileRefCount++; sl@0: } sl@0: sl@0: copyPtr->typePtr = &tclFsPathType; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * UpdateStringOfFsPath -- sl@0: * sl@0: * Gives an object a valid string rep. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Memory may be allocated. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: UpdateStringOfFsPath(objPtr) sl@0: register Tcl_Obj *objPtr; /* path obj with string rep to update. */ sl@0: { sl@0: FsPath *fsPathPtr = (FsPath*) PATHOBJ(objPtr); sl@0: CONST char *cwdStr; sl@0: int cwdLen; sl@0: Tcl_Obj *copy; sl@0: sl@0: if (PATHFLAGS(objPtr) == 0 || fsPathPtr->cwdPtr == NULL) { sl@0: panic("Called UpdateStringOfFsPath with invalid object"); sl@0: } sl@0: sl@0: copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr); sl@0: Tcl_IncrRefCount(copy); sl@0: sl@0: cwdStr = Tcl_GetStringFromObj(copy, &cwdLen); sl@0: /* sl@0: * Should we perhaps use 'Tcl_FSPathSeparator'? sl@0: * But then what about the Windows special case? sl@0: * Perhaps we should just check if cwd is a root volume. sl@0: * We should never get cwdLen == 0 in this code path. sl@0: */ sl@0: switch (tclPlatform) { sl@0: case TCL_PLATFORM_UNIX: sl@0: if (cwdStr[cwdLen-1] != '/') { sl@0: Tcl_AppendToObj(copy, "/", 1); sl@0: cwdLen++; sl@0: } sl@0: break; sl@0: case TCL_PLATFORM_WINDOWS: sl@0: /* sl@0: * We need the extra 'cwdLen != 2', and ':' checks because sl@0: * a volume relative path doesn't get a '/'. For example sl@0: * 'glob C:*cat*.exe' will return 'C:cat32.exe' sl@0: */ sl@0: if (cwdStr[cwdLen-1] != '/' sl@0: && cwdStr[cwdLen-1] != '\\') { sl@0: if (cwdLen != 2 || cwdStr[1] != ':') { sl@0: Tcl_AppendToObj(copy, "/", 1); sl@0: cwdLen++; sl@0: } sl@0: } sl@0: break; sl@0: case TCL_PLATFORM_MAC: sl@0: if (cwdStr[cwdLen-1] != ':') { sl@0: Tcl_AppendToObj(copy, ":", 1); sl@0: cwdLen++; sl@0: } sl@0: break; sl@0: } sl@0: Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr); sl@0: objPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen); sl@0: objPtr->length = cwdLen; sl@0: copy->bytes = tclEmptyStringRep; sl@0: copy->length = 0; sl@0: Tcl_DecrRefCount(copy); sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * NativePathInFilesystem -- sl@0: * sl@0: * Any path object is acceptable to the native filesystem, by sl@0: * default (we will throw errors when illegal paths are actually sl@0: * tried to be used). sl@0: * sl@0: * However, this behavior means the native filesystem must be sl@0: * the last filesystem in the lookup list (otherwise it will sl@0: * claim all files belong to it, and other filesystems will sl@0: * never get a look in). sl@0: * sl@0: * Results: sl@0: * TCL_OK, to indicate 'yes', -1 to indicate no. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: static int sl@0: NativePathInFilesystem(pathPtr, clientDataPtr) sl@0: Tcl_Obj *pathPtr; sl@0: ClientData *clientDataPtr; sl@0: { sl@0: /* sl@0: * A special case is required to handle the empty path "". sl@0: * This is a valid path (i.e. the user should be able sl@0: * to do 'file exists ""' without throwing an error), but sl@0: * equally the path doesn't exist. Those are the semantics sl@0: * of Tcl (at present anyway), so we have to abide by them sl@0: * here. sl@0: */ sl@0: if (pathPtr->typePtr == &tclFsPathType) { sl@0: if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') { sl@0: /* We reject the empty path "" */ sl@0: return -1; sl@0: } sl@0: /* Otherwise there is no way this path can be empty */ sl@0: } else { sl@0: /* sl@0: * It is somewhat unusual to reach this code path without sl@0: * the object being of tclFsPathType. However, we do sl@0: * our best to deal with the situation. sl@0: */ sl@0: int len; sl@0: Tcl_GetStringFromObj(pathPtr,&len); sl@0: if (len == 0) { sl@0: /* We reject the empty path "" */ sl@0: return -1; sl@0: } sl@0: } sl@0: /* sl@0: * Path is of correct type, or is of non-zero length, sl@0: * so we accept it. sl@0: */ sl@0: return TCL_OK; sl@0: }