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