diff options
Diffstat (limited to 'generic/tclIOUtil.c')
| -rw-r--r-- | generic/tclIOUtil.c | 7855 |
1 files changed, 3218 insertions, 4637 deletions
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index f91a2b6..de5d62d 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -1,136 +1,268 @@ -/* +/* * 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. - * - * RCS: @(#) $Id: tclIOUtil.c,v 1.77.2.16 2004/02/18 01:59:09 hobbs Exp $ + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#include "tclPort.h" -#ifdef MAC_TCL -#include "tclMacInt.h" +#ifdef _WIN32 +# include "tclWinInt.h" +#endif +#include "tclFileSystem.h" + +#ifdef TCL_TEMPLOAD_NO_UNLINK +#ifndef NO_FSTATFS +#include <sys/statfs.h> #endif -#ifdef __WIN32__ -/* for tclWinProcs->useWide */ -#include "tclWinInt.h" #endif -/* +/* * 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. + * + * A filesystem record is used to keep track of each filesystem currently + * registered with the core, in a linked list. */ + 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. */ + ClientData clientData; /* Client specific data for the new filesystem + * (can be NULL) */ + const Tcl_Filesystem *fsPtr;/* Pointer to filesystem dispatch table. */ + 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. +/* + * This structure holds per-thread private copy of the current directory + * maintained by the global cwdPathPtr. 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. */ -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 +typedef struct ThreadSpecificData { + int initialized; + size_t cwdPathEpoch; + size_t filesystemEpoch; + Tcl_Obj *cwdPathPtr; + ClientData cwdClientData; + FilesystemRecord *filesystemList; + size_t claims; +} ThreadSpecificData; + +/* + * Prototypes for functions defined later in this file. */ -extern Tcl_Filesystem tclNativeFilesystem; -extern int theFilesystemEpoch; -/* - * Private functions for use in this file +static Tcl_NRPostProc EvalFileCallback; +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); +static void FsRecacheFilesystemList(void); +static void Claim(void); +static void Disclaim(void); + +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. */ -Tcl_PathType FSGetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr, - Tcl_Filesystem **filesystemPtrPtr, - int *driveNameLengthPtr)); -Tcl_PathType GetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr, - Tcl_Filesystem **filesystemPtrPtr, - int *driveNameLengthPtr, Tcl_Obj **driveNameRef)); -Tcl_FSPathInFilesystemProc NativePathInFilesystem; -static Tcl_Obj* TclFSNormalizeAbsolutePath - _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr, - ClientData *clientDataPtr)); + +MODULE_SCOPE const char *const tclpFileAttrStrings[]; +MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; + /* - * Prototypes for procedures defined later in this file. + * 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 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)); +static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator; +static Tcl_FSFreeInternalRepProc NativeFreeInternalRep; +static Tcl_FSFileAttrStringsProc NativeFileAttrStrings; +static Tcl_FSFileAttrsGetProc NativeFileAttrsGet; +static Tcl_FSFileAttrsSetProc NativeFileAttrsSet; -#ifdef TCL_THREADS -static void FsRecacheFilesystemList(void); -#endif +/* + * 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). + */ -/* - * 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. +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! */ -extern CONST char * tclpFileAttrStrings[]; -extern CONST TclFileAttrProcs tclpFileAttrProcs[]; -/* - * The following functions are obsolete string based APIs, and should - * be removed in a future release (Tcl 9 would be a good time). +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, + /* Needs casts since we're using version_2. */ + (Tcl_FSLoadFileProc *) TclpDlopen, + (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, + 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. */ + +static size_t theFilesystemEpoch = 1; + +/* + * 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 size_t cwdPathEpoch = 0; +static ClientData cwdClientData = NULL; +TCL_DECLARE_MUTEX(cwdMutex) + +static Tcl_ThreadDataKey fsDataKey; + +/* + * One of these structures is used each time we successfully load a file from + * a file system by way of making a temporary copy of the file on the native + * filesystem. We need to store both the actual unloadProc/clientData + * combination which was used, and the original and modified filenames, so + * that we can correctly undo the entire operation when we want to unload the + * code. + */ + +typedef struct FsDivertLoad { + Tcl_LoadHandle loadHandle; + Tcl_FSUnloadFileProc *unloadProcPtr; + Tcl_Obj *divertedFile; + const Tcl_Filesystem *divertedFilesystem; + ClientData divertedFileNativeRep; +} FsDivertLoad; +/* + * 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(path, oldStyleBuf) - CONST char *path; /* Path of file to stat (in current CP). */ - struct stat *oldStyleBuf; /* Filled with results of stat call. */ +Tcl_Stat( + const char *path, /* Path of file to stat (in current CP). */ + struct stat *oldStyleBuf) /* Filled with results of stat call. */ { int ret; Tcl_StatBuf buf; @@ -141,31 +273,37 @@ Tcl_Stat(path, oldStyleBuf) Tcl_DecrRefCount(pathPtr); if (ret != -1) { #ifndef TCL_WIDE_INT_IS_LONG -# define OUT_OF_RANGE(x) \ + Tcl_WideInt tmp1, tmp2, tmp3 = 0; + +# 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) +# define OUT_OF_URANGE(x) \ + (((Tcl_WideUInt)(x)) > ((Tcl_WideUInt)ULONG_MAX)) /* * Perform the result-buffer overflow check manually. * * Note that ino_t/ino64_t is unsigned... + * + * Workaround gcc warning of "comparison is always false due to + * limited range of data type" by assigning to tmp var of type + * Tcl_WideInt. */ - if (OUT_OF_URANGE(buf.st_ino) || OUT_OF_RANGE(buf.st_size) -#ifdef HAVE_ST_BLOCKS - || OUT_OF_RANGE(buf.st_blocks) + tmp1 = (Tcl_WideInt) buf.st_ino; + tmp2 = (Tcl_WideInt) buf.st_size; +#ifdef HAVE_STRUCT_STAT_ST_BLOCKS + tmp3 = (Tcl_WideInt) buf.st_blocks; #endif - ) { -#ifdef EFBIG + + if (OUT_OF_URANGE(tmp1) || OUT_OF_RANGE(tmp2) || OUT_OF_RANGE(tmp3)) { +#if defined(EFBIG) errno = EFBIG; -#else -# ifdef EOVERFLOW +#elif defined(EOVERFLOW) errno = EOVERFLOW; -# else -# error "What status should be returned for file size out of range?" -# endif +#else +#error "What status should be returned for file size out of range?" #endif return -1; } @@ -175,27 +313,33 @@ Tcl_Stat(path, oldStyleBuf) #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_ST_BLOCKS - oldStyleBuf->st_blksize = buf.st_blksize; - oldStyleBuf->st_blocks = (blkcnt_t) buf.st_blocks; + 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 #endif } return ret; @@ -203,43 +347,45 @@ Tcl_Stat(path, oldStyleBuf) /* Obsolete */ int -Tcl_Access(path, mode) - CONST char *path; /* Path of file to access (in current CP). */ - int mode; /* Permission setting. */ +Tcl_Access( + const char *path, /* Path of file to access (in current CP). */ + int mode) /* Permission setting. */ { int ret; Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); + Tcl_IncrRefCount(pathPtr); ret = Tcl_FSAccess(pathPtr,mode); Tcl_DecrRefCount(pathPtr); + return ret; } /* Obsolete */ Tcl_Channel -Tcl_OpenFileChannel(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_OpenFileChannel( + Tcl_Interp *interp, /* Interpreter for error reporting; can be + * NULL. */ + const char *path, /* Name of file to open. */ + const char *modeString, /* A list of POSIX open modes or a string such + * as "rw". */ + int permissions) /* If the open involves creating a file, with + * what modes to create it? */ { Tcl_Channel ret; Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); + Tcl_IncrRefCount(pathPtr); ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions); Tcl_DecrRefCount(pathPtr); - return ret; + return ret; } /* Obsolete */ int -Tcl_Chdir(dirName) - CONST char *dirName; +Tcl_Chdir( + const char *dirName) { int ret; Tcl_Obj *pathPtr = Tcl_NewStringObj(dirName,-1); @@ -251,442 +397,340 @@ Tcl_Chdir(dirName) /* Obsolete */ char * -Tcl_GetCwd(interp, cwdPtr) - Tcl_Interp *interp; - Tcl_DString *cwdPtr; +Tcl_GetCwd( + Tcl_Interp *interp, + Tcl_DString *cwdPtr) { - Tcl_Obj *cwd; - cwd = Tcl_FSGetCwd(interp); + Tcl_Obj *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); + TclDStringAppendObj(cwdPtr, cwd); + Tcl_DecrRefCount(cwd); + return Tcl_DStringValue(cwdPtr); } /* Obsolete */ int -Tcl_EvalFile(interp, fileName) - Tcl_Interp *interp; /* Interpreter in which to process file. */ - CONST char *fileName; /* Name of file to process. Tilde-substitution +Tcl_EvalFile( + Tcl_Interp *interp, /* Interpreter in which to process file. */ + const char *fileName) /* Name of file to process. Tilde-substitution * will be performed on this name. */ { int ret; Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1); + Tcl_IncrRefCount(pathPtr); ret = Tcl_FSEvalFile(interp, pathPtr); Tcl_DecrRefCount(pathPtr); return ret; } - -/* - * The 3 hooks for Stat, Access and OpenFileChannel are obsolete. The - * complete, general hooked filesystem APIs should be used instead. - * This define decides whether to include the obsolete hooks and - * related code. If these are removed, we'll also want to remove them - * from stubs/tclInt. The only known users of these APIs are prowrap - * and mktclapp. New code/extensions should not use them, since they - * do not provide as full support as the full filesystem API. - * - * As soon as prowrap and mktclapp are updated to use the full - * filesystem support, I suggest all these hooks are removed. - */ -#define USE_OBSOLETE_FS_HOOKS - - -#ifdef USE_OBSOLETE_FS_HOOKS -/* - * The following typedef declarations allow for hooking into the chain - * of functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' & - * 'Tcl_OpenFileChannel(...)'. Basically for each hookable function - * a linked list is defined. - */ - -typedef struct StatProc { - TclStatProc_ *proc; /* Function to process a 'stat()' call */ - struct StatProc *nextPtr; /* The next 'stat()' function to call */ -} StatProc; - -typedef struct AccessProc { - TclAccessProc_ *proc; /* Function to process a 'access()' call */ - struct AccessProc *nextPtr; /* The next 'access()' function to call */ -} AccessProc; - -typedef struct OpenFileChannelProc { - TclOpenFileChannelProc_ *proc; /* Function to process a - * 'Tcl_OpenFileChannel()' call */ - struct OpenFileChannelProc *nextPtr; - /* The next 'Tcl_OpenFileChannel()' - * function to call */ -} OpenFileChannelProc; - -/* - * For each type of (obsolete) hookable function, a static node is - * declared to hold the function pointer for the "built-in" routine - * (e.g. 'TclpStat(...)') and the respective list is initialized as a - * pointer to that node. - * - * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that - * these statically declared list entry cannot be inadvertently removed. - * - * This method avoids the need to call any sort of "initialization" - * function. - * - * All three lists are protected by a global obsoleteFsHookMutex. - */ - -static StatProc *statProcList = NULL; -static AccessProc *accessProcList = NULL; -static OpenFileChannelProc *openFileChannelProcList = NULL; - -TCL_DECLARE_MUTEX(obsoleteFsHookMutex) - -#endif /* USE_OBSOLETE_FS_HOOKS */ - -/* - * Declare the native filesystem support. These functions should - * be considered private to Tcl, and should really not be called - * directly by any code other than this file (i.e. neither by - * Tcl's core nor by extensions). Similarly, the old string-based - * Tclp... native filesystem functions should not be called. - * - * The correct API to use now is the Tcl_FS... set of functions, - * which ensure correct and complete virtual filesystem support. - * - * We cannot make all of these static, since some of them - * are implemented in the platform-specific directories. - */ -static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator; -static Tcl_FSFreeInternalRepProc NativeFreeInternalRep; -Tcl_FSDupInternalRepProc NativeDupInternalRep; -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, - &NativeDupInternalRep, - &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 -}; - -/* - * 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. + * Now move on to the basic filesystem implementation. */ -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(cd) - ClientData cd; +FsThrExitProc( + ClientData cd) { - ThreadSpecificData *tsdPtr = (ThreadSpecificData*)cd; + ThreadSpecificData *tsdPtr = 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((char *)fsRecPtr); - } + fsRecPtr->fsPtr = NULL; + ckfree(fsRecPtr); fsRecPtr = tmpFsRecPtr; } + tsdPtr->filesystemList = NULL; + tsdPtr->initialized = 0; } -int -TclFSCwdPointerEquals(objPtr) - Tcl_Obj* objPtr; +int +TclFSCwdIsNative(void) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + + 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(&fsDataKey); Tcl_MutexLock(&cwdMutex); - if (tsdPtr->cwdPathPtr == NULL) { + if (tsdPtr->cwdPathPtr == NULL + || tsdPtr->cwdPathEpoch != cwdPathEpoch) { + if (tsdPtr->cwdPathPtr != NULL) { + Tcl_DecrRefCount(tsdPtr->cwdPathPtr); + } + if (tsdPtr->cwdClientData != NULL) { + NativeFreeInternalRep(tsdPtr->cwdClientData); + } if (cwdPathPtr == NULL) { tsdPtr->cwdPathPtr = NULL; } else { tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr); Tcl_IncrRefCount(tsdPtr->cwdPathPtr); } - tsdPtr->cwdPathEpoch = cwdPathEpoch; - } else if (tsdPtr->cwdPathEpoch != cwdPathEpoch) { - Tcl_DecrRefCount(tsdPtr->cwdPathPtr); - if (cwdPathPtr == NULL) { - tsdPtr->cwdPathPtr = NULL; + if (cwdClientData == NULL) { + tsdPtr->cwdClientData = NULL; } else { - tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr); - Tcl_IncrRefCount(tsdPtr->cwdPathPtr); + tsdPtr->cwdClientData = TclNativeDupInternalRep(cwdClientData); } + tsdPtr->cwdPathEpoch = cwdPathEpoch; } Tcl_MutexUnlock(&cwdMutex); if (tsdPtr->initialized == 0) { - Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData)tsdPtr); + Tcl_CreateThreadExitHandler(FsThrExitProc, tsdPtr); tsdPtr->initialized = 1; } - return (tsdPtr->cwdPathPtr == objPtr); + + if (pathPtrPtr == NULL) { + return (tsdPtr->cwdPathPtr == NULL); + } + + if (tsdPtr->cwdPathPtr == *pathPtrPtr) { + return 1; + } else { + int len1, len2; + const char *str1, *str2; + + str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); + str2 = TclGetStringFromObj(*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; + } + } } -#ifdef TCL_THREADS static void FsRecacheFilesystemList(void) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL, *toFree = NULL, *list; + + /* + * Trash the current cache. + */ - /* Trash the current cache */ fsRecPtr = tsdPtr->filesystemList; while (fsRecPtr != NULL) { tmpFsRecPtr = fsRecPtr->nextPtr; - if (--fsRecPtr->fileRefCount <= 0) { - ckfree((char *)fsRecPtr); - } + fsRecPtr->nextPtr = toFree; + toFree = fsRecPtr; fsRecPtr = tmpFsRecPtr; } - tsdPtr->filesystemList = NULL; /* - * Code below operates on shared data. We - * are already called under mutex lock so - * we can safely proceede. + * Locate tail of the global filesystem list. */ - /* Locate tail of the global filesystem list */ + Tcl_MutexLock(&filesystemMutex); fsRecPtr = filesystemList; while (fsRecPtr != NULL) { tmpFsRecPtr = fsRecPtr; fsRecPtr = fsRecPtr->nextPtr; } - - /* Refill the cache honouring the order */ + + /* + * Refill the cache honouring the order. + */ + + list = NULL; fsRecPtr = tmpFsRecPtr; while (fsRecPtr != NULL) { - tmpFsRecPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord)); + tmpFsRecPtr = ckalloc(sizeof(FilesystemRecord)); *tmpFsRecPtr = *fsRecPtr; - tmpFsRecPtr->nextPtr = tsdPtr->filesystemList; + tmpFsRecPtr->nextPtr = list; tmpFsRecPtr->prevPtr = NULL; - if (tsdPtr->filesystemList) { - tsdPtr->filesystemList->prevPtr = tmpFsRecPtr; - } - tsdPtr->filesystemList = tmpFsRecPtr; - fsRecPtr = fsRecPtr->prevPtr; + list = tmpFsRecPtr; + fsRecPtr = fsRecPtr->prevPtr; + } + tsdPtr->filesystemList = list; + tsdPtr->filesystemEpoch = theFilesystemEpoch; + Tcl_MutexUnlock(&filesystemMutex); + + while (toFree) { + FilesystemRecord *next = toFree->nextPtr; + toFree->fsPtr = NULL; + ckfree(toFree); + toFree = next; } - /* 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, (ClientData)tsdPtr); + Tcl_CreateThreadExitHandler(FsThrExitProc, tsdPtr); tsdPtr->initialized = 1; } } -#endif static FilesystemRecord * -FsGetFirstFilesystem(void) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - FilesystemRecord *fsRecPtr; -#ifndef TCL_THREADS - tsdPtr->filesystemEpoch = theFilesystemEpoch; - fsRecPtr = filesystemList; -#else - Tcl_MutexLock(&filesystemMutex); - if (tsdPtr->filesystemList == NULL - || (tsdPtr->filesystemEpoch != theFilesystemEpoch)) { - FsRecacheFilesystemList(); - tsdPtr->filesystemEpoch = theFilesystemEpoch; +FsGetFirstFilesystem(void) +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + if (tsdPtr->filesystemList == NULL || ((tsdPtr->claims == 0) + && (tsdPtr->filesystemEpoch != theFilesystemEpoch))) { + FsRecacheFilesystemList(); } - Tcl_MutexUnlock(&filesystemMutex); - fsRecPtr = tsdPtr->filesystemList; -#endif - return fsRecPtr; + return tsdPtr->filesystemList; +} + +/* + * The epoch can be changed by filesystems being added or removed, by changing + * the "system encoding" and by env(HOME) changing. + */ + +int +TclFSEpochOk( + size_t filesystemEpoch) +{ + return (filesystemEpoch == 0 || filesystemEpoch == theFilesystemEpoch); +} + +static void +Claim(void) +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + + tsdPtr->claims++; } + +static void +Disclaim(void) +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + + tsdPtr->claims--; +} + +size_t +TclFSEpoch(void) +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + + return tsdPtr->filesystemEpoch; +} + +/* + * If non-NULL, clientData is owned by us and must be freed later. + */ + static void -FsUpdateCwd(cwdObj) - Tcl_Obj *cwdObj; +FsUpdateCwd( + Tcl_Obj *cwdObj, + ClientData clientData) { int len; - char *str = NULL; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + const char *str = NULL; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); if (cwdObj != NULL) { - str = Tcl_GetStringFromObj(cwdObj, &len); + str = TclGetStringFromObj(cwdObj, &len); } Tcl_MutexLock(&cwdMutex); if (cwdPathPtr != NULL) { - Tcl_DecrRefCount(cwdPathPtr); + Tcl_DecrRefCount(cwdPathPtr); } + if (cwdClientData != NULL) { + NativeFreeInternalRep(cwdClientData); + } + if (cwdObj == NULL) { cwdPathPtr = NULL; + cwdClientData = NULL; } else { - /* This MUST be stored as string object! */ - cwdPathPtr = Tcl_NewStringObj(str, len); - Tcl_IncrRefCount(cwdPathPtr); + /* + * This must be stored as string obj! + */ + + cwdPathPtr = Tcl_NewStringObj(str, len); + Tcl_IncrRefCount(cwdPathPtr); + cwdClientData = TclNativeDupInternalRep(clientData); + } + + if (++cwdPathEpoch == 0) { + ++cwdPathEpoch; } - cwdPathEpoch++; tsdPtr->cwdPathEpoch = cwdPathEpoch; Tcl_MutexUnlock(&cwdMutex); if (tsdPtr->cwdPathPtr) { - Tcl_DecrRefCount(tsdPtr->cwdPathPtr); + Tcl_DecrRefCount(tsdPtr->cwdPathPtr); + } + if (tsdPtr->cwdClientData) { + NativeFreeInternalRep(tsdPtr->cwdClientData); } + if (cwdObj == NULL) { tsdPtr->cwdPathPtr = NULL; + tsdPtr->cwdClientData = NULL; } else { - tsdPtr->cwdPathPtr = Tcl_NewStringObj(str, len); + tsdPtr->cwdPathPtr = Tcl_NewStringObj(str, len); + tsdPtr->cwdClientData = clientData; Tcl_IncrRefCount(tsdPtr->cwdPathPtr); } } @@ -696,12 +740,12 @@ FsUpdateCwd(cwdObj) * * 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. * @@ -712,48 +756,52 @@ FsUpdateCwd(cwdObj) */ void -TclFinalizeFilesystem() +TclFinalizeFilesystem(void) { 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; + cwdPathEpoch = 0; + } + if (cwdClientData != NULL) { + NativeFreeInternalRep(cwdClientData); + cwdClientData = NULL; } - /* - * 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 */ - if (fsRecPtr != &nativeFilesystemRecord) { - ckfree((char *)fsRecPtr); - } + + /* The native filesystem is static, so we don't free it. */ + + if (fsRecPtr != &nativeFilesystemRecord) { + ckfree(fsRecPtr); } fsRecPtr = tmpFsRecPtr; } + if (++theFilesystemEpoch == 0) { + ++theFilesystemEpoch; + } 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__ +#ifdef _WIN32 TclWinEncodingsCleanup(); #endif } @@ -764,7 +812,7 @@ TclFinalizeFilesystem() * TclResetFilesystem -- * * Restore the filesystem to a pristine state. - * + * * Results: * None. * @@ -775,22 +823,19 @@ TclFinalizeFilesystem() */ void -TclResetFilesystem() +TclResetFilesystem(void) { filesystemList = &nativeFilesystemRecord; + if (++theFilesystemEpoch == 0) { + ++theFilesystemEpoch; + } - /* - * 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. +#ifdef _WIN32 + /* + * Cleans up the win32 API filesystem proc lookup table. This must happen + * very late in finalization so that deleting of copied dlls can occur. */ + TclWinResetInterfaces(); #endif } @@ -800,36 +845,35 @@ TclResetFilesystem() * * 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, fsPtr) - ClientData clientData; /* Client specific data for this fs */ - Tcl_Filesystem *fsPtr; /* The filesystem record for the new fs. */ +Tcl_FSRegister( + ClientData clientData, /* Client specific data for this fs. */ + const Tcl_Filesystem *fsPtr)/* The filesystem record for the new fs. */ { FilesystemRecord *newFilesystemPtr; @@ -837,29 +881,24 @@ Tcl_FSRegister(clientData, fsPtr) return TCL_ERROR; } - newFilesystemPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord)); + newFilesystemPtr = ckalloc(sizeof(FilesystemRecord)); newFilesystemPtr->clientData = clientData; newFilesystemPtr->fsPtr = fsPtr; - /* - * We start with a refCount of 1. If this drops to zero, then - * anyone is welcome to ckfree us. - */ - newFilesystemPtr->fileRefCount = 1; - - /* - * Is this lock and wait strictly speaking necessary? Since any - * iterators out there will have grabbed a copy of the head of - * the list and be iterating away from that, if we add a new - * element to the head of the list, it can't possibly have any - * effect on any of their loops. In fact it could be better not - * to wait, since we are adjusting the filesystem epoch, any - * cached representations calculated by existing iterators are + + /* + * 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; @@ -869,11 +908,14 @@ Tcl_FSRegister(clientData, fsPtr) } 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++; + + if (++theFilesystemEpoch == 0) { + ++theFilesystemEpoch; + } Tcl_MutexUnlock(&filesystemMutex); return TCL_OK; @@ -884,29 +926,28 @@ Tcl_FSRegister(clientData, fsPtr) * * 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 procedure pointer was successfully removed, - * TCL_ERROR otherwise. + * TCL_OK if the function pointer was successfully removed, TCL_ERROR + * otherwise. * * Side effects: - * Memory may be deallocated (or will be later, once no "path" - * objects refer to this filesystem), but the list of registered - * filesystems is updated immediately. + * 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(fsPtr) - Tcl_Filesystem *fsPtr; /* The filesystem record to remove. */ +Tcl_FSUnregister( + const Tcl_Filesystem *fsPtr) /* The filesystem record to remove. */ { int retVal = TCL_ERROR; FilesystemRecord *fsRecPtr; @@ -914,9 +955,9 @@ Tcl_FSUnregister(fsPtr) 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; @@ -930,21 +971,21 @@ Tcl_FSUnregister(fsPtr) 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((char *)fsRecPtr); + + if (++theFilesystemEpoch == 0) { + ++theFilesystemEpoch; } + ckfree(fsRecPtr); + retVal = TCL_OK; } else { fsRecPtr = fsRecPtr->nextPtr; @@ -952,7 +993,7 @@ Tcl_FSUnregister(fsPtr) } Tcl_MutexUnlock(&filesystemMutex); - return (retVal); + return retVal; } /* @@ -960,132 +1001,146 @@ Tcl_FSUnregister(fsPtr) * * 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 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. - * + * This routine is used by the globbing code to search a directory for + * all files which match a given pattern. The appropriate function for + * the filesystem to which pathPtr belongs will be called. If pathPtr + * does not belong to any filesystem and if it is NULL or the empty + * string, then we assume the pattern is to be matched in the current + * working directory. To avoid have the Tcl_FSMatchInDirectoryProc for + * each filesystem from having to deal with this issue, we create a + * pathPtr on the fly (equal to the cwd), and then remove it from the + * results returned. This makes filesystems easy to write, since they can + * assume the pathPtr passed to them is an ordinary path. In fact this + * means we could remove such special case handling from Tcl's native + * filesystems. + * + * If 'pattern' is NULL, then pathPtr is assumed to be a fully specified + * path of a single file/directory which must be checked for existence + * and correct type. + * + * Results: + * + * The return value is a standard Tcl result indicating whether an error + * occurred in globbing. Error messages are placed in interp, but good + * results are placed in the resultPtr given. + * * Recursive searches, e.g. - * - * glob -dir $dir -join * pkgIndex.tcl - * - * which must recurse through each directory matching '*' are - * handled internally by Tcl, by passing specific flags in a - * modified 'types' parameter. This means the actual filesystem - * only ever sees patterns which match in a single directory. + * 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(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. +Tcl_FSMatchInDirectory( + Tcl_Interp *interp, /* Interpreter to receive error messages, but + * may be NULL. */ + Tcl_Obj *resultPtr, /* List object to receive results. */ + Tcl_Obj *pathPtr, /* Contains path to directory to search. */ + const char *pattern, /* Pattern to match against. */ + Tcl_GlobTypeData *types) /* Object containing list of acceptable types. * May be NULL. In particular the directory * flag is very important. */ { - Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + const Tcl_Filesystem *fsPtr; + Tcl_Obj *cwd, *tmpResultPtr, **elemsPtr; + int resLength, i, ret = -1; + + if (types != NULL && (types->type & TCL_GLOB_TYPE_MOUNT)) { + /* + * We don't currently allow querying of mounts by external code (a + * valuable future step), so since we're the only function that + * actually knows about mounts, this means we're being called + * recursively by ourself. Return no matches. + */ + + return TCL_OK; + } + + if (pathPtr != NULL) { + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + } else { + fsPtr = NULL; + } + + /* + * Check if we've successfully mapped the path to a filesystem within + * which to search. + */ + if (fsPtr != NULL) { - 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; + if (fsPtr->matchInDirectoryProc == NULL) { + Tcl_SetErrno(ENOENT); + return -1; } - } 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; - } + ret = fsPtr->matchInDirectoryProc(interp, resultPtr, pathPtr, pattern, + types); + if (ret == TCL_OK && pattern != NULL) { + FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types); } - /* - * 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 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_SetObjResult(interp, Tcl_NewStringObj( + "glob couldn't determine the current working directory", + -1)); } - 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); + 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)); } } - Tcl_DecrRefCount(cwd); - return ret; + TclDecrRefCount(tmpResultPtr); } - Tcl_SetErrno(ENOENT); - return -1; + Tcl_DecrRefCount(cwd); + return ret; } /* @@ -1093,85 +1148,104 @@ Tcl_FSMatchInDirectory(interp, result, pathPtr, pattern, types) * * 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: - * - * The passed in 'result' may be modified (in place, if - * necessary), and the correct list is returned. + * 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. * - * Side effects: + * Results: * None. * - *---------------------------------------------------------------------- + * Side effects: + * Modifies the resultPtr. + * + *---------------------------------------------------------------------- */ -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; + +static void +FsAddMountsToGlobResult( + Tcl_Obj *resultPtr, /* The current list of matching paths; must + * not be shared! */ + Tcl_Obj *pathPtr, /* The directory in question. */ + const char *pattern, /* Pattern to match against. */ + Tcl_GlobTypeData *types) /* Object containing list of acceptable types. + * May be NULL. In particular the directory + * flag is very important. */ { int mLength, gLength, i; int dir = (types == NULL || (types->type & TCL_GLOB_TYPE_DIR)); Tcl_Obj *mounts = FsListMounts(pathPtr, pattern); - if (mounts == NULL) return result; + if (mounts == NULL) { + return; + } if (Tcl_ListObjLength(NULL, mounts, &mLength) != TCL_OK || mLength == 0) { goto endOfMounts; } - if (Tcl_ListObjLength(NULL, result, &gLength) != TCL_OK) { + if (Tcl_ListObjLength(NULL, resultPtr, &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, result, j, &gElt); + + Tcl_ListObjIndex(NULL, resultPtr, j, &gElt); if (Tcl_FSEqualPaths(mElt, gElt)) { found = 1; if (!dir) { - /* 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); + /* + * We don't want to list this. + */ + + Tcl_ListObjReplace(NULL, resultPtr, j, 1, 0, NULL); gLength--; } - /* Break out of for loop */ - break; + break; /* Break out of for loop. */ } } if (!found && dir) { - if (Tcl_IsShared(result)) { - Tcl_Obj *newList; - newList = Tcl_DuplicateObj(result); - Tcl_DecrRefCount(result); - result = newList; + 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 = TclGetStringFromObj(mElt, &mlen); + path = TclGetStringFromObj(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); } - Tcl_ListObjAppendElement(NULL, result, mElt); - /* - * No need to increment gLength, since we - * don't want to compare mounts against - * mounts. + /* + * No need to increment gLength, since we don't want to compare + * mounts against mounts. */ } } + endOfMounts: Tcl_DecrRefCount(mounts); - return result; } /* @@ -1179,67 +1253,69 @@ FsAddMountsToGlobResult(result, pathPtr, pattern, types) * * 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(fsPtr) - Tcl_Filesystem *fsPtr; +Tcl_FSMountsChanged( + const 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++; + if (++theFilesystemEpoch == 0) { + ++theFilesystemEpoch; + } Tcl_MutexUnlock(&filesystemMutex); } @@ -1248,31 +1324,31 @@ Tcl_FSMountsChanged(fsPtr) * * 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(fsPtr) - Tcl_Filesystem *fsPtr; /* The filesystem record to query. */ +Tcl_FSData( + const Tcl_Filesystem *fsPtr) /* The filesystem record to query. */ { ClientData retVal = NULL; FilesystemRecord *fsRecPtr = FsGetFirstFilesystem(); /* - * 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 list of filesystems look for a particular one. If found, + * return that filesystem's clientData (originally provided when calling + * Tcl_FSRegister). */ while ((retVal == NULL) && (fsRecPtr != NULL)) { @@ -1288,219 +1364,132 @@ Tcl_FSData(fsPtr) /* *--------------------------------------------------------------------------- * - * TclFSNormalizeAbsolutePath -- - * - * 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. + * TclFSNormalizeToUniquePath -- + * + * Takes a path specification containing no ../, ./ sequences, and + * converts it into a unique path for the given platform. On Unix, this + * means the path must be free of symbolic links/aliases, and on Windows + * it means we want the long form, with that long form's case-dependence + * (which gives us a unique, case-dependent path). * * Results: - * The 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. + * The pathPtr is modified in place. The return value is the last byte + * offset which was recognised in the path string. * * Side effects: * None (beyond the memory allocation for the result). * - * Special 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. + * 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). * *--------------------------------------------------------------------------- */ -Tcl_Obj* -TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) - Tcl_Interp* interp; /* Interpreter to use */ - Tcl_Obj *pathPtr; /* Absolute path to normalize */ - ClientData *clientDataPtr; + +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. */ { - 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); - - /* - * 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. + FilesystemRecord *fsRecPtr, *firstFsRecPtr; + + /* + * 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). */ - 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++; + + firstFsRecPtr = FsGetFirstFilesystem(); + + Claim(); + for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) { + if (fsRecPtr->fsPtr != &tclNativeFilesystem) { + continue; } - } - 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. + + /* + * TODO: Assume that we always find the native file system; it should + * always be there... */ - 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 + + if (fsRecPtr->fsPtr->normalizePathProc != NULL) { + startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr, + startAt); + } + break; + } + + for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) { + /* + * Skip the native system next time through. */ - TclFSMakePathFromNormalized(interp, retVal, clientData); - if (clientDataPtr != NULL) { - *clientDataPtr = clientData; + + if (fsRecPtr->fsPtr == &tclNativeFilesystem) { + continue; } - } 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); - /* This has a refCount of 1 for the caller */ - return retVal; + 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. + */ + } + Disclaim(); + + return startAt; } /* *--------------------------------------------------------------------------- * - * TclFSNormalizeToUniquePath -- + * TclGetOpenMode -- * - * 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). + * This routine is an obsolete, limited version of TclGetOpenModeEx() + * below. It exists only to satisfy any extensions imprudently using it + * via Tcl's internal stubs table. * * Results: - * The pathPtr is modified in place. The return value is - * the last byte offset which was recognised in the path - * string. + * Same as TclGetOpenModeEx(). * * Side effects: - * None (beyond the memory allocation for the result). + * Same as TclGetOpenModeEx(). * - * 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 -TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr) - Tcl_Interp *interp; - Tcl_Obj *pathPtr; - int startAt; - ClientData *clientDataPtr; +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. */ { - 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 == &nativeFilesystemRecord) { - 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 != &nativeFilesystemRecord) { - 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; + int binary = 0; + return TclGetOpenModeEx(interp, modeString, seekFlagPtr, &binary); } /* *--------------------------------------------------------------------------- * - * TclGetOpenMode -- + * TclGetOpenModeEx -- * - * Description: * Computes a POSIX mode mask for opening a file, from a given string, - * and also sets a flag to indicate whether the caller should seek to - * EOF after opening the file. + * and also sets flags to indicate whether the caller should seek to EOF + * after opening the file, and whether the caller should configure the + * channel for binary data. * * Results: * On success, returns mode to pass to "open". If an error occurs, the @@ -1508,37 +1497,41 @@ TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr) * 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. + * Sets the integer referenced by seekFlagPtr to 1 to tell the caller to + * seek to EOF after opening the file, or to 0 otherwise. Sets the + * integer referenced by binaryPtr to 1 to tell the caller to seek to + * configure the channel for binary data, or to 0 otherwise. * * Special note: - * This code is based on a prototype implementation contributed - * by Mark Diekhans. + * This code is based on a prototype implementation contributed by Mark + * Diekhans. * *--------------------------------------------------------------------------- */ int -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. */ +TclGetOpenModeEx( + Tcl_Interp *interp, /* Interpreter to use for error reporting - + * may be NULL. */ + const char *modeString, /* Mode string, e.g. "r+" or "RDONLY CREAT" */ + int *seekFlagPtr, /* Set this to 1 if the caller should seek to + * EOF during the opening of the file. */ + int *binaryPtr) /* Set this to 1 if the caller should + * configure the opened channel for binary + * operations. */ { int mode, modeArgc, c, i, gotRW; - CONST char **modeArgv, *flag; + 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; /* @@ -1546,58 +1539,82 @@ TclGetOpenMode(interp, string, seekFlagPtr) * routines. */ - if (!(string[0] & 0x80) - && islower(UCHAR(string[0]))) { /* INTL: ISO only. */ - switch (string[0]) { - case 'r': - mode = O_RDONLY; - break; - case 'w': - mode = O_WRONLY|O_CREAT|O_TRUNC; + if (!(modeString[0] & 0x80) + && islower(UCHAR(modeString[0]))) { /* INTL: ISO only. */ + switch (modeString[0]) { + case 'r': + mode = O_RDONLY; + break; + case 'w': + mode = O_WRONLY|O_CREAT|O_TRUNC; + break; + case 'a': + /* + * Added O_APPEND for proper automatic seek-to-end-on-write by the + * OS. [Bug 680143] + */ + + mode = O_WRONLY|O_CREAT|O_APPEND; + *seekFlagPtr = 1; + break; + default: + goto error; + } + i = 1; + while (i<3 && modeString[i]) { + if (modeString[i] == modeString[i-1]) { + goto error; + } + switch (modeString[i++]) { + case '+': + /* + * Must remove the O_APPEND flag so that the seek command + * works. [Bug 1773127] + */ + + mode &= ~(O_RDONLY|O_WRONLY|O_APPEND); + mode |= O_RDWR; break; - case 'a': - mode = O_WRONLY|O_CREAT; - *seekFlagPtr = 1; + case 'b': + *binaryPtr = 1; break; default: - error: - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, - "illegal access mode \"", string, "\"", - (char *) NULL); - } - return -1; - } - if (string[1] == '+') { - mode &= ~(O_RDONLY|O_WRONLY); - mode |= O_RDWR; - if (string[2] != 0) { goto error; } - } else if (string[1] != 0) { + } + if (modeString[i] != 0) { goto error; } - return mode; + return mode; + + error: + *seekFlagPtr = 0; + *binaryPtr = 0; + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "illegal access mode \"%s\"", modeString)); + } + return -1; } /* - * 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, 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; + if (Tcl_SplitList(interp, modeString, &modeArgc, &modeArgv) != TCL_OK) { + if (interp != NULL) { + Tcl_AddErrorInfo(interp, + "\n while processing open access modes \""); + Tcl_AddErrorInfo(interp, modeString); + Tcl_AddErrorInfo(interp, "\""); + } + return -1; } - + gotRW = 0; for (i = 0; i < modeArgc; i++) { flag = modeArgv[i]; @@ -1613,55 +1630,63 @@ TclGetOpenMode(interp, string, seekFlagPtr) 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 != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "access mode \"", flag, - "\" not supported by this system", (char *) NULL); - } - ckfree((char *) modeArgv); + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "access mode \"%s\" not supported by this system", + flag)); + } + ckfree(modeArgv); return -1; #endif + } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) { -#if defined(O_NDELAY) || defined(O_NONBLOCK) -# ifdef O_NONBLOCK +#ifdef O_NONBLOCK mode |= O_NONBLOCK; -# else - mode |= O_NDELAY; -# endif #else - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "access mode \"", flag, - "\" not supported by this system", (char *) NULL); - } - ckfree((char *) modeArgv); + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "access mode \"%s\" not supported by this system", + flag)); + } + ckfree(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 != (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); + + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid access mode \"%s\": must be RDONLY, WRONLY, " + "RDWR, APPEND, BINARY, CREAT, EXCL, NOCTTY, NONBLOCK," + " or TRUNC", flag)); + } + ckfree(modeArgv); return -1; } } - ckfree((char *) modeArgv); + + ckfree(modeArgv); + if (!gotRW) { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "access mode must include either", - " RDONLY, WRONLY, or RDWR", (char *) NULL); - } + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "access mode must include either RDONLY, WRONLY, or RDWR", + -1)); + } return -1; } return mode; @@ -1670,88 +1695,142 @@ TclGetOpenMode(interp, string, seekFlagPtr) /* *---------------------------------------------------------------------- * - * Tcl_FSEvalFile -- + * Tcl_FSEvalFile, Tcl_FSEvalFileEx, TclNREvalFile -- * - * Read in a file and process the entire file as one gigantic - * Tcl command. + * 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. * * 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(interp, pathPtr) - Tcl_Interp *interp; /* Interpreter in which to process file. */ - Tcl_Obj *pathPtr; /* Path of file to process. Tilde-substitution +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 * 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 result, length; + int length, result = TCL_ERROR; Tcl_StatBuf statBuf; Tcl_Obj *oldScriptFile; Interp *iPtr; - char *string; + const char *string; Tcl_Channel chan; Tcl_Obj *objPtr; if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { - return TCL_ERROR; + return result; } - result = TCL_ERROR; - objPtr = Tcl_NewObj(); - if (Tcl_FSStat(pathPtr, &statBuf) == -1) { - Tcl_SetErrno(errno); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), - "\": ", Tcl_PosixError(interp), (char *) NULL); - goto end; + Tcl_SetErrno(errno); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + return result; } chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); - if (chan == (Tcl_Channel) NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), - "\": ", Tcl_PosixError(interp), (char *) NULL); - goto end; + if (chan == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + return result; } + /* - * The eofchar is \32 (^Z). This is the usual on Windows, but we - * effect this cross-platform to allow for scripted documents. - * [Bug: 2040] + * 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 (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) { - Tcl_Close(interp, chan); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), - "\": ", Tcl_PosixError(interp), (char *) NULL); + + /* + * 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. + */ + + if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) { + Tcl_Close(interp, chan); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); goto end; } + 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_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + goto end; + } + if (Tcl_Close(interp, chan) != TCL_OK) { - goto end; + goto end; } iPtr = (Interp *) interp; oldScriptFile = iPtr->scriptFile; iPtr->scriptFile = pathPtr; Tcl_IncrRefCount(iPtr->scriptFile); - string = Tcl_GetStringFromObj(objPtr, &length); - result = Tcl_EvalEx(interp, string, length, 0); - /* + string = TclGetStringFromObj(objPtr, &length); + + /* + * 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); + + /* * 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); } @@ -1760,18 +1839,172 @@ Tcl_FSEvalFile(interp, pathPtr) if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } else if (result == TCL_ERROR) { - char msg[200 + TCL_INTEGER_SPACE]; + /* + * Record information telling where the error occurred. + */ + + const char *pathString = TclGetStringFromObj(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_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + return TCL_ERROR; + } + chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); + if (chan == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + return TCL_ERROR; + } + TclPkgFileSeen(interp, Tcl_GetString(pathPtr)); + + /* + * 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_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + 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_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + 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; + + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); + } else if (result == TCL_ERROR) { /* * Record information telling where the error occurred. */ - sprintf(msg, "\n (file \"%.150s\" line %d)", Tcl_GetString(pathPtr), - interp->errorLine); - Tcl_AddErrorInfo(interp, msg); + int length; + const char *pathString = TclGetStringFromObj(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))); } - end: Tcl_DecrRefCount(objPtr); return result; } @@ -1782,22 +2015,27 @@ Tcl_FSEvalFile(interp, pathPtr) * 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() +Tcl_GetErrno(void) { + /* + * On some platforms, errno is really a thread local (implemented by the C + * library). + */ + return errno; } @@ -1806,7 +2044,9 @@ Tcl_GetErrno() * * Tcl_SetErrno -- * - * Sets the Tcl error code variable to the supplied value. + * 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! * * Results: * None. @@ -1818,9 +2058,14 @@ Tcl_GetErrno() */ void -Tcl_SetErrno(err) - int err; /* The new value. */ +Tcl_SetErrno( + int err) /* The new value. */ { + /* + * On some platforms, errno is really a thread local (implemented by the C + * library). + */ + errno = err; } @@ -1829,31 +2074,32 @@ Tcl_SetErrno(err) * * Tcl_PosixError -- * - * 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. + * This function is typically called after UNIX kernel calls return + * errors. It stores machine-readable information about the error in + * errorCode field of interp and returns an information string for the + * caller's use. * * Results: - * The return value is a human-readable string describing the - * error. + * The return value is a human-readable string describing the error. * * Side effects: - * The global variable $errorCode is reset. + * The errorCode field of the interp is set. * *---------------------------------------------------------------------- */ -CONST char * -Tcl_PosixError(interp) - Tcl_Interp *interp; /* Interpreter whose $errorCode variable - * is to be changed. */ +const char * +Tcl_PosixError( + Tcl_Interp *interp) /* Interpreter whose errorCode field is to be + * set. */ { - CONST char *id, *msg; + const char *id, *msg; msg = Tcl_ErrnoMsg(errno); id = Tcl_ErrnoId(); - Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL); + if (interp) { + Tcl_SetErrorCode(interp, "POSIX", id, msg, NULL); + } return msg; } @@ -1862,87 +2108,29 @@ Tcl_PosixError(interp) * * Tcl_FSStat -- * - * This procedure replaces the library version of stat and lsat. - * - * The appropriate function for the filesystem to which pathPtr - * belongs will be called. + * This function replaces the library version of stat and lsat. + * + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. * * Results: - * See stat documentation. + * See stat documentation. * * Side effects: - * See stat documentation. + * See stat documentation. * *---------------------------------------------------------------------- */ int -Tcl_FSStat(pathPtr, buf) - Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ - Tcl_StatBuf *buf; /* Filled with results of stat call. */ +Tcl_FSStat( + Tcl_Obj *pathPtr, /* Path of file to stat (in current CP). */ + Tcl_StatBuf *buf) /* Filled with results of stat call. */ { - Tcl_Filesystem *fsPtr; -#ifdef USE_OBSOLETE_FS_HOOKS - struct stat oldStyleStatBuffer; - int retVal = -1; - - /* - * Call each of the "stat" function in succession. A non-return - * value of -1 indicates the particular function has succeeded. - */ + const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - 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); - } + if (fsPtr != NULL && fsPtr->statProc != NULL) { + return fsPtr->statProc(pathPtr, buf); } Tcl_SetErrno(ENOENT); return -1; @@ -1953,36 +2141,33 @@ Tcl_FSStat(pathPtr, buf) * * Tcl_FSLstat -- * - * 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. + * This function replaces the library version of lstat. The appropriate + * function for the filesystem to which pathPtr belongs will be called. + * If no 'lstat' function is listed, but a 'stat' function is, then Tcl + * will fall back on the stat function. * * Results: - * See lstat documentation. + * See lstat documentation. * * Side effects: - * See lstat documentation. + * See lstat documentation. * *---------------------------------------------------------------------- */ int -Tcl_FSLstat(pathPtr, buf) - Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ - Tcl_StatBuf *buf; /* Filled with results of stat call. */ +Tcl_FSLstat( + Tcl_Obj *pathPtr, /* Path of file to stat (in current CP). */ + Tcl_StatBuf *buf) /* Filled with results of stat call. */ { - Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { - Tcl_FSLstatProc *proc = fsPtr->lstatProc; - if (proc != NULL) { - return (*proc)(pathPtr, buf); - } else { - Tcl_FSStatProc *sproc = fsPtr->statProc; - if (sproc != NULL) { - return (*sproc)(pathPtr, buf); - } + if (fsPtr->lstatProc != NULL) { + return fsPtr->lstatProc(pathPtr, buf); + } + if (fsPtr->statProc != NULL) { + return fsPtr->statProc(pathPtr, buf); } } Tcl_SetErrno(ENOENT); @@ -1994,68 +2179,28 @@ Tcl_FSLstat(pathPtr, buf) * * Tcl_FSAccess -- * - * This procedure replaces the library version of access. - * The appropriate function for the filesystem to which pathPtr - * belongs will be called. + * This function replaces the library version of access. The appropriate + * function for the filesystem to which pathPtr belongs will be called. * * Results: - * See access documentation. + * See access documentation. * * Side effects: - * See access documentation. + * See access documentation. * *---------------------------------------------------------------------- */ int -Tcl_FSAccess(pathPtr, mode) - Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */ - int mode; /* Permission setting. */ +Tcl_FSAccess( + Tcl_Obj *pathPtr, /* Path of file to access (in current CP). */ + int mode) /* Permission setting. */ { - 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. - */ + const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - Tcl_MutexLock(&obsoleteFsHookMutex); - - if (accessProcList != NULL) { - AccessProc *accessProcPtr; - char *path; - Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); - if (transPtr == NULL) { - path = NULL; - } else { - path = Tcl_GetString(transPtr); - } - - accessProcPtr = accessProcList; - while ((retVal == -1) && (accessProcPtr != NULL)) { - retVal = (*accessProcPtr->proc)(path, mode); - accessProcPtr = accessProcPtr->nextPtr; - } - if (transPtr != NULL) { - Tcl_DecrRefCount(transPtr); - } - } - - Tcl_MutexUnlock(&obsoleteFsHookMutex); - if (retVal != -1) { - return retVal; + if (fsPtr != NULL && fsPtr->accessProc != NULL) { + return fsPtr->accessProc(pathPtr, mode); } -#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; } @@ -2065,111 +2210,94 @@ Tcl_FSAccess(pathPtr, mode) * * 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(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? */ +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_Filesystem *fsPtr; -#ifdef USE_OBSOLETE_FS_HOOKS + const Tcl_Filesystem *fsPtr; Tcl_Channel retVal = NULL; /* - * Call each of the "Tcl_OpenFileChannel" functions in succession. - * A non-NULL return value indicates the particular function has - * succeeded. + * We need this just to ensure we return the correct error messages under + * some circumstances. */ - 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); + 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; } - openFileChannelProcPtr = openFileChannelProcList; - - while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { - retVal = (*openFileChannelProcPtr->proc)(interp, path, - modeString, permissions); - openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; + /* + * Do the actual open() call. + */ + + retVal = fsPtr->openFileChannelProc(interp, pathPtr, mode, + permissions); + if (retVal == NULL) { + return NULL; } - if (transPtr != NULL) { - Tcl_DecrRefCount(transPtr); + + /* + * Apply appropriate flags parsed out above. + */ + + if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt) 0, SEEK_END) + < (Tcl_WideInt) 0) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not seek to end of file while opening \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + } + Tcl_Close(NULL, retVal); + return NULL; + } + if (binary) { + Tcl_SetChannelOption(interp, retVal, "-translation", "binary"); } - } - Tcl_MutexUnlock(&obsoleteFsHookMutex); - if (retVal != NULL) { return retVal; } -#endif /* USE_OBSOLETE_FS_HOOKS */ - - /* - * We need this just to ensure we return the correct error messages - * under some circumstances. + + /* + * File doesn't belong to any filesystem that can open it. */ - 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), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); } return NULL; } @@ -2179,32 +2307,31 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) * * Tcl_FSUtime -- * - * This procedure replaces the library version of utime. - * The appropriate function for the filesystem to which pathPtr - * belongs will be called. + * This function replaces the library version of utime. The appropriate + * function for the filesystem to which pathPtr belongs will be called. * * Results: - * See utime documentation. + * See utime documentation. * * Side effects: - * See utime documentation. + * See utime documentation. * *---------------------------------------------------------------------- */ -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. */ +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. */ { - Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL) { - Tcl_FSUtimeProc *proc = fsPtr->utimeProc; - if (proc != NULL) { - return (*proc)(pathPtr, tval); - } + const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + + if (fsPtr != NULL && fsPtr->utimeProc != NULL) { + return fsPtr->utimeProc(pathPtr, tval); } + /* TODO: set errno here? Tcl_SetErrno(ENOENT); */ return -1; } @@ -2213,25 +2340,25 @@ Tcl_FSUtime (pathPtr, tval) * * NativeFileAttrStrings -- * - * 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. + * This function implements the platform dependent 'file attributes' + * subcommand, for the native filesystem, for listing the set of possible + * attribute strings. This function is part of Tcl's native filesystem + * support, and is placed here because it is shared by Unix and Windows + * code. * * Results: - * An array of strings + * An array of strings * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ -static CONST char** -NativeFileAttrStrings(pathPtr, objPtrRef) - Tcl_Obj *pathPtr; - Tcl_Obj** objPtrRef; +static const char *const * +NativeFileAttrStrings( + Tcl_Obj *pathPtr, + Tcl_Obj **objPtrRef) { return tclpFileAttrStrings; } @@ -2241,34 +2368,31 @@ NativeFileAttrStrings(pathPtr, objPtrRef) * * NativeFileAttrsGet -- * - * 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. + * This function implements the platform dependent 'file attributes' + * subcommand, for the native filesystem, for 'get' operations. This + * function is part of Tcl's native filesystem support, and is placed + * here because it is shared by Unix and Windows code. * * Results: - * Standard Tcl return code. The object placed in objPtrRef - * (if TCL_OK was returned) is likely to have a refCount of zero. - * Either way we must either store it somewhere (e.g. the Tcl - * result), or Incr/Decr its refCount to ensure it is properly - * freed. + * 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(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. */ +NativeFileAttrsGet( + Tcl_Interp *interp, /* The interpreter for error reporting. */ + int index, /* index of the attribute command. */ + Tcl_Obj *pathPtr, /* path of file we are operating on. */ + Tcl_Obj **objPtrRef) /* for output. */ { - return (*tclpFileAttrProcs[index].getProc)(interp, index, - pathPtr, objPtrRef); + return tclpFileAttrProcs[index].getProc(interp, index, pathPtr,objPtrRef); } /* @@ -2276,30 +2400,28 @@ NativeFileAttrsGet(interp, index, pathPtr, objPtrRef) * * NativeFileAttrsSet -- * - * 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. + * This function implements the platform dependent 'file attributes' + * subcommand, for the native filesystem, for 'set' operations. This + * function is part of Tcl's native filesystem support, and is placed + * here because it is shared by Unix and Windows code. * * Results: - * Standard Tcl return code. + * Standard Tcl return code. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ static int -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. */ +NativeFileAttrsSet( + Tcl_Interp *interp, /* The interpreter for error reporting. */ + int index, /* index of the attribute command. */ + Tcl_Obj *pathPtr, /* path of file we are operating on. */ + Tcl_Obj *objPtr) /* set to this value. */ { - return (*tclpFileAttrProcs[index].setProc)(interp, index, - pathPtr, objPtr); + return tclpFileAttrProcs[index].setProc(interp, index, pathPtr, objPtr); } /* @@ -2307,37 +2429,34 @@ NativeFileAttrsSet(interp, index, pathPtr, objPtr) * * Tcl_FSFileAttrStrings -- * - * This procedure implements part of the hookable 'file - * attributes' subcommand. The appropriate function for the - * filesystem to which pathPtr belongs will be called. + * This function implements part of the hookable 'file attributes' + * subcommand. The appropriate function for the filesystem to which + * pathPtr belongs will be called. * * Results: - * The called 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. + * The called function may either return an array of strings, or may + * instead return NULL and place a Tcl list into the given objPtrRef. + * Tcl will take that list and first increment its refCount before using + * it. On completion of that use, Tcl will decrement its refCount. Hence + * if the list should be disposed of by Tcl when done, it should have a + * refCount of zero, and if the list should not be disposed of, the + * filesystem should ensure it retains a refCount on the object. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ -CONST char ** -Tcl_FSFileAttrStrings(pathPtr, objPtrRef) - Tcl_Obj* pathPtr; - Tcl_Obj** objPtrRef; +const char *const * +Tcl_FSFileAttrStrings( + Tcl_Obj *pathPtr, + Tcl_Obj **objPtrRef) { - Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL) { - Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc; - if (proc != NULL) { - return (*proc)(pathPtr, objPtrRef); - } + const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + + if (fsPtr != NULL && fsPtr->fileAttrStringsProc != NULL) { + return fsPtr->fileAttrStringsProc(pathPtr, objPtrRef); } Tcl_SetErrno(ENOENT); return NULL; @@ -2346,39 +2465,112 @@ Tcl_FSFileAttrStrings(pathPtr, objPtrRef) /* *---------------------------------------------------------------------- * - * Tcl_FSFileAttrsGet -- + * TclFSFileAttrIndex -- * - * This procedure implements read access for the hookable 'file - * attributes' subcommand. The appropriate function for the - * filesystem to which pathPtr belongs will be called. + * Helper function for converting an attribute name to an index into the + * attribute table. * * 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. - + * Tcl result code, index written to *indexPtr on result==TCL_OK * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ int -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. */ +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_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL) { - Tcl_FSFileAttrsGetProc *proc = fsPtr->fileAttrsGetProc; - if (proc != NULL) { - return (*proc)(interp, index, pathPtr, objPtrRef); + 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. + * + * Results: + * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK + * was returned) is likely to have a refCount of zero. Either way we must + * either store it somewhere (e.g. the Tcl result), or Incr/Decr its + * refCount to ensure it is properly freed. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_FSFileAttrsGet( + Tcl_Interp *interp, /* The interpreter for error reporting. */ + int index, /* index of the attribute command. */ + Tcl_Obj *pathPtr, /* filename we are operating on. */ + Tcl_Obj **objPtrRef) /* for output. */ +{ + const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + + if (fsPtr != NULL && fsPtr->fileAttrsGetProc != NULL) { + return fsPtr->fileAttrsGetProc(interp, index, pathPtr, objPtrRef); } Tcl_SetErrno(ENOENT); return -1; @@ -2389,32 +2581,30 @@ Tcl_FSFileAttrsGet(interp, index, pathPtr, objPtrRef) * * Tcl_FSFileAttrsSet -- * - * This procedure implements write access for the hookable 'file - * attributes' subcommand. The appropriate function for the - * filesystem to which pathPtr belongs will be called. + * This function implements write access for the hookable 'file + * attributes' subcommand. The appropriate function for the filesystem to + * which pathPtr belongs will be called. * * Results: - * Standard Tcl return code. + * Standard Tcl return code. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ int -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. */ +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_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL) { - Tcl_FSFileAttrsSetProc *proc = fsPtr->fileAttrsSetProc; - if (proc != NULL) { - return (*proc)(interp, index, pathPtr, objPtr); - } + const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + + if (fsPtr != NULL && fsPtr->fileAttrsSetProc != NULL) { + return fsPtr->fileAttrsSetProc(interp, index, pathPtr, objPtr); } Tcl_SetErrno(ENOENT); return -1; @@ -2426,34 +2616,32 @@ Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr) * 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 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. - * + * + * Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains its own + * record (in a Tcl_Obj) of the cwd, and an attempt is made to synch this + * with the cwd's containing filesystem, if that filesystem provides a + * cwdProc (e.g. the native filesystem). + * + * Note that if Tcl's cwd is not in the native filesystem, then of course + * Tcl's cwd and the native cwd are different: extensions should + * therefore ensure they only access the cwd through this function to + * avoid confusion. + * * If a global cwdPathPtr already exists, it is cached in the thread's * private data structures and reference to the cached copy is returned, * subject to a synchronisation attempt in that cwdPathPtr's fs. - * - * Otherwise, the chain of functions that have been "inserted" - * into the filesystem will be called in succession until either a - * value other than NULL is returned, or the entire list is - * visited. + * + * 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. @@ -2461,117 +2649,233 @@ Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr) *---------------------------------------------------------------------- */ -Tcl_Obj* -Tcl_FSGetCwd(interp) - Tcl_Interp *interp; +Tcl_Obj * +Tcl_FSGetCwd( + Tcl_Interp *interp) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + 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. */ fsRecPtr = FsGetFirstFilesystem(); - while ((retVal == NULL) && (fsRecPtr != NULL)) { - Tcl_FSGetCwdProc *proc = fsRecPtr->fsPtr->getCwdProc; - if (proc != NULL) { - retVal = (*proc)(interp); + Claim(); + for (; (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); + 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; + Disclaim(); + goto cdDidNotChange; + } else if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error getting working directory name: %s", + Tcl_PosixError(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. + Disclaim(); + + /* + * 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); + Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal); + 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 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. + * 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); + + ClientData cd = (ClientData) Tcl_FSGetNativePath(norm); + + FsUpdateCwd(norm, TclNativeDupInternalRep(cd)); Tcl_DecrRefCount(norm); } Tcl_DecrRefCount(retVal); } } else { - /* - * We already have a cwd cached, but we want to give the - * filesystem it is in a chance to check whether that cwd - * has changed, or is perhaps no longer accessible. This - * allows an error to be thrown if, say, the permissions on - * that directory have changed. + /* + * 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. */ - 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). + + 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). */ - 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); + + 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_SetObjResult(interp, Tcl_ObjPrintf( + "error getting working directory name: %s", + Tcl_PosixError(interp))); + } + + 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. + */ + + if (retVal == NULL) { + FsUpdateCwd(NULL, NULL); + goto cdDidNotChange; + } + + /* + * Normalize the path. + */ + + norm = TclFSNormalizeAbsolutePath(interp, retVal); + + /* + * 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 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); + str2 = TclGetStringFromObj(norm, &len2); + if ((len1 == len2) && (strcmp(str1, str2) == 0)) { + /* + * If the paths were equal, we can be more efficient and + * retain the old path object which will probably already be + * shared. In this case we can simply free the normalized path + * we just calculated. + */ + + cdEqual: + Tcl_DecrRefCount(norm); + if (retCd != NULL) { + fsPtr->freeInternalRepProc(retCd); } + } else { + FsUpdateCwd(norm, retCd); + Tcl_DecrRefCount(norm); } } + Tcl_DecrRefCount(retVal); } - + + cdDidNotChange: if (tsdPtr->cwdPathPtr != NULL) { Tcl_IncrRefCount(tsdPtr->cwdPathPtr); } - - return tsdPtr->cwdPathPtr; + + return tsdPtr->cwdPathPtr; } /* @@ -2580,81 +2884,157 @@ Tcl_FSGetCwd(interp) * 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(pathPtr) - Tcl_Obj *pathPtr; +Tcl_FSChdir( + Tcl_Obj *pathPtr) { - Tcl_Filesystem *fsPtr; + const Tcl_Filesystem *fsPtr, *oldFsPtr = NULL; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); int retVal = -1; - + + if (tsdPtr->cwdPathPtr != NULL) { + oldFsPtr = Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr); + } if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) { - return TCL_ERROR; + Tcl_SetErrno(ENOENT); + return retVal; } - + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { - Tcl_FSChdirProc *proc = fsPtr->chdirProc; - if (proc != NULL) { - retVal = (*proc)(pathPtr); + if (fsPtr->chdirProc != NULL) { + /* + * If this fails, an appropriate errno will have been stored using + * 'Tcl_SetErrno()'. + */ + + retVal = fsPtr->chdirProc(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 ((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 any of these actions fail, then + * 'Tcl_SetErrno()' should automatically have been called to set + * an appropriate error code. + */ + + if ((Tcl_FSStat(pathPtr, &buf) == 0) && (S_ISDIR(buf.st_mode)) + && (Tcl_FSAccess(pathPtr, R_OK) == 0)) { + /* + * We allow the chdir. + */ + retVal = 0; } } + } else { + Tcl_SetErrno(ENOENT); } - 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. + /* + * 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 == TCL_OK) { - /* - * Note that this normalized path may be different to what - * we found above (or at least a different object), if the - * filesystem epoch changed recently. This can actually - * happen with scripted documents very easily. Therefore - * we ask for the normalized path again (the correct value - * will have been cached as a result of the - * Tcl_FSGetFileSystemForPath call above anyway). + + Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr); + + if (normDirName == NULL) { + /* Not really true, but what else to do? */ + Tcl_SetErrno(ENOENT); + return -1; + } + + if (fsPtr == &tclNativeFilesystem) { + /* + * For the native filesystem, we keep a cache of the native + * representation of the cwd. But, we want to do that for the + * exact format that is returned by 'getcwd' (so that we can later + * compare the two representations for equality), which might not + * be exactly the same char-string as the native representation of + * the fully normalized path (e.g. on Windows there's a + * forward-slash vs backslash difference). Hence we ask for this + * again here. On Unix it might actually be true that we always + * have the correct form in the native rep in which case we could + * simply use: + * cd = Tcl_FSGetNativePath(pathPtr); + * instead. This should be examined by someone on Unix. */ - Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr); - if (normDirName == NULL) { - return TCL_ERROR; + + ClientData cd; + ClientData oldcd = tsdPtr->cwdClientData; + + /* + * Assumption we are using a filesystem version 2. + */ + + TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2 *) fsPtr->getCwdProc; + + cd = proc2(oldcd); + if (cd != oldcd) { + FsUpdateCwd(normDirName, cd); } - FsUpdateCwd(normDirName); + } else { + FsUpdateCwd(normDirName, NULL); + } + + /* + * If the filesystem changed between old and new cwd + * force filesystem refresh on path objects. + */ + if (oldFsPtr != NULL && fsPtr != oldFsPtr) { + Tcl_FSMountsChanged(NULL); } - } else { - Tcl_SetErrno(ENOENT); } - - return (retVal); + + return retVal; } /* @@ -2662,347 +3042,766 @@ Tcl_FSChdir(pathPtr) * * Tcl_FSLoadFile -- * - * 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. + * Dynamically loads a binary code file into memory and returns the + * addresses of two functions within that file, if they are defined. The + * appropriate function for the filesystem to which pathPtr belongs will + * be called. + * + * Note that the native filesystem doesn't actually assume 'pathPtr' is a + * path. Rather it assumes pathPtr is either a path or just the name + * (tail) of a file which can be found somewhere in the environment's + * loadable path. This behaviour is not very compatible with virtual + * filesystems (and has other problems documented in the load man-page), + * so it is advised that full paths are always used. * * Results: - * A standard Tcl completion code. If an error occurs, an error - * message is left in the interp's result. + * 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(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 +Tcl_FSLoadFile( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Obj *pathPtr, /* Name of the file containing the desired * code. */ - CONST char *sym1, *sym2; /* Names of two procedures to look up in - * the file's symbol table. */ - Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + const char *sym1, const char *sym2, + /* Names of two functions to look up in the + * file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr, /* Where to return the addresses corresponding * to sym1 and sym2. */ - Tcl_LoadHandle *handlePtr; /* Filled with token for dynamically loaded - * file which will be passed back to + 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. */ { - 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; - } + 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. + * + *---------------------------------------------------------------------- + */ + +/* + * Workaround for issue with modern HPUX which do allow the unlink (no ETXTBSY + * error) yet somehow trash some internal data structures which prevents the + * second and further shared libraries from getting properly loaded. Only the + * first is ok. We try to get around the issue by not unlinking, + * i.e. emulating the behaviour of the older HPUX which denied removal. + * + * Doing the unlink is also an issue within docker containers, whose AUFS + * bungles this as well, see + * https://github.com/dotcloud/docker/issues/1911 + * + * For these situations the change below makes the execution of the unlink + * semi-controllable at runtime. + * + * An AUFS filesystem (if it can be detected) will force avoidance of + * unlink. The env variable TCL_TEMPLOAD_NO_UNLINK allows detection of a + * users general request (unlink and not. + * + * By default the unlink is done (if not in AUFS). However if the variable is + * present and set to true (any integer > 0) then the unlink is skipped. + */ + +int +TclSkipUnlink (Tcl_Obj* shlibFile) +{ + /* Order of testing: + * 1. On hpux we generally want to skip unlink in general + * + * Outside of hpux then: + * 2. For a general user request (TCL_TEMPLOAD_NO_UNLINK present, non-empty, => int) + * 3. For general AUFS environment (statfs, if available). + * + * Ad 2: This variable can disable/override the AUFS detection, i.e. for + * testing if a newer AUFS does not have the bug any more. + * + * Ad 3: This is conditionally compiled in. Condition currently must be set manually. + * This part needs proper tests in the configure(.in). + */ + +#ifdef hpux + return 1; +#else + char* skipstr; + + skipstr = getenv ("TCL_TEMPLOAD_NO_UNLINK"); + if (skipstr && (skipstr[0] != '\0')) { + return atoi(skipstr); + } + +#ifdef TCL_TEMPLOAD_NO_UNLINK +#ifndef NO_FSTATFS + { + struct statfs fs; + /* Have fstatfs. May not have the AUFS super magic ... Indeed our build + * box is too old to have it directly in the headers. Define taken from + * http://mooon.googlecode.com/svn/trunk/linux_include/linux/aufs_type.h + * http://aufs.sourceforge.net/ + * Better reference will be gladly taken. + */ +#ifndef AUFS_SUPER_MAGIC +#define AUFS_SUPER_MAGIC ('a' << 24 | 'u' << 16 | 'f' << 8 | 's') +#endif /* AUFS_SUPER_MAGIC */ + if ((statfs(Tcl_GetString (shlibFile), &fs) == 0) && + (fs.f_type == AUFS_SUPER_MAGIC)) { + return 1; + } + } +#endif /* ... NO_FSTATFS */ +#endif /* ... TCL_TEMPLOAD_NO_UNLINK */ + + /* Fallback: !hpux, no EV override, no AUFS (detection, nor detected): + * Don't skip */ + return 0; +#endif /* hpux */ +} + +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 */ + 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 = ((Tcl_FSLoadFileProc2 *)(fsPtr->loadFileProc)) + (interp, pathPtr, handlePtr, &unloadProcPtr, flags); + + if (retVal == TCL_OK) { if (*handlePtr == NULL) { return TCL_ERROR; } - if (sym1 != NULL) { - *proc1Ptr = TclpFindSymbol(interp, *handlePtr, sym1); - } - if (sym2 != NULL) { - *proc2Ptr = TclpFindSymbol(interp, *handlePtr, sym2); + if (interp) { + Tcl_ResetResult(interp); } + goto resolveSymbols; + } + if (Tcl_GetErrno() != EXDEV) { return retVal; - } 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; - } - - /* - * 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); + } + } + + /* + * 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) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't load library \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + +#ifdef TCL_LOAD_FROM_MEMORY + /* + * The platform supports loading code from memory, so ask for a buffer of + * the appropriate size, read the file into it and load the code from the + * buffer: + */ + + { + int ret, size; + void *buffer; + Tcl_StatBuf statBuf; + Tcl_Channel data; + + ret = Tcl_FSStat(pathPtr, &statBuf); + if (ret < 0) { + goto mustCopyToTempAnyway; + } + size = (int) statBuf.st_size; + + /* + * Tcl_Read takes an int: check that file size isn't wide. + */ + + if (size != (Tcl_WideInt) statBuf.st_size) { + goto mustCopyToTempAnyway; + } + data = Tcl_FSOpenFileChannel(interp, pathPtr, "rb", 0666); + if (!data) { + goto mustCopyToTempAnyway; + } + buffer = TclpLoadMemoryGetBuffer(interp, size); + if (!buffer) { + Tcl_Close(interp, data); + goto mustCopyToTempAnyway; + } + ret = Tcl_Read(data, buffer, size); + Tcl_Close(interp, data); + ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr, + &unloadProcPtr, flags); + if (ret == TCL_OK && *handlePtr != NULL) { + goto resolveSymbols; + } + } + + mustCopyToTempAnyway: + if (interp) { + Tcl_ResetResult(interp); + } +#endif /* TCL_LOAD_FROM_MEMORY */ + + /* + * Get a temporary filename to use, first to copy the file into, and then + * to load. + */ + + copyToPtr = TclpTempFileNameForLibrary(interp, pathPtr); + if (copyToPtr == NULL) { + return TCL_ERROR; + } + Tcl_IncrRefCount(copyToPtr); + + copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr); + if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) { + /* + * We already know we can't use Tcl_FSLoadFile from this filesystem, + * and we must avoid a possible infinite loop. Try to delete the file + * we probably created, and then exit. + */ + + Tcl_FSDeleteFile(copyToPtr); + Tcl_DecrRefCount(copyToPtr); + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't load from current filesystem", -1)); + } + 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); + } #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)); - /* - * Remember three pieces of information. This allows - * us to cleanup the diverted load completely, on - * platforms which allow proper unloading of code. + /* + * We need to reset the result now, because the cross-filesystem copy may + * have stored the number of bytes in the result. + */ + + if (interp) { + Tcl_ResetResult(interp); + } + + retVal = Tcl_LoadFile(interp, copyToPtr, symbols, flags, 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 ( + !TclSkipUnlink (copyToPtr) && + (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; + if (interp) { + 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; + + if (interp) { + 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.) */ - 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 = - NativeDupInternalRep(Tcl_FSGetInternalRep(copyToPtr, - copyFsPtr)); - /* - * We don't need or want references to the copied - * Tcl_Obj or the filesystem if it is the native - * one. - */ - tvdlPtr->divertedFile = NULL; - tvdlPtr->divertedFilesystem = NULL; - Tcl_DecrRefCount(copyToPtr); - } - copyToPtr = NULL; - (*handlePtr) = (Tcl_LoadHandle) tvdlPtr; - (*unloadProcPtr) = &FSUnloadTempFile; - return retVal; - } else { - /* Cross-platform copy failed */ - Tcl_FSDeleteFile(copyToPtr); - Tcl_DecrRefCount(copyToPtr); + (*handlePtr)->unloadFileProcPtr(*handlePtr); + *handlePtr = NULL; return TCL_ERROR; } } } - Tcl_SetErrno(ENOENT); - return -1; + return TCL_OK; } -/* - * This function used to be in the platform specific directories, but it - * has now been made to work cross-platform + +/* + *---------------------------------------------------------------------- + * + * DivertFindSymbol -- + * + * Find a symbol in a shared library loaded by copy-from-VFS. + * + *---------------------------------------------------------------------- */ -int -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, *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 - * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr; - /* Filled with address of Tcl_FSUnloadFileProc - * function which should be used for - * this file. */ + +static void * +DivertFindSymbol( + Tcl_Interp *interp, /* Tcl interpreter */ + Tcl_LoadHandle loadHandle, /* Handle to the diverted module */ + const char *symbol) /* Symbol to resolve */ { - Tcl_LoadHandle handle = NULL; - int res; - - res = TclpDlopen(interp, pathPtr, &handle, unloadProcPtr); - - if (res != TCL_OK) { - return res; + 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. + */ + } - if (handle == NULL) { + /* + * 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_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; } - - *clientDataPtr = (ClientData)handle; - - *proc1Ptr = TclpFindSymbol(interp, handle, sym1); - *proc2Ptr = TclpFindSymbol(interp, handle, sym2); + TclpUnloadFile(handle); return TCL_OK; } /* - *--------------------------------------------------------------------------- + *---------------------------------------------------------------------- * - * FSUnloadTempFile -- + * TclpUnloadFile -- * - * 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. + * 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 -- + * + * 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. * - *--------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -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. */ + +void +TclFSUnloadTempFile( + 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((char*)tvdlPtr); + ckfree(tvdlPtr); } /* @@ -3010,59 +3809,56 @@ FSUnloadTempFile(loadHandle) * * 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(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 */ +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_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL) { - Tcl_FSLinkProc *proc = fsPtr->linkProc; - if (proc != NULL) { - return (*proc)(pathPtr, toPtr, linkAction); - } + const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + + if (fsPtr != NULL && fsPtr->linkProc != NULL) { + return fsPtr->linkProc(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; + errno = EINVAL; /* TODO: Change to Tcl_SetErrno()? */ #else Tcl_SetErrno(ENOENT); #endif /* S_IFLNK */ @@ -3074,17 +3870,16 @@ Tcl_FSLink(pathPtr, toPtr, linkAction) * * 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. @@ -3095,24 +3890,25 @@ Tcl_FSLink(pathPtr, toPtr, linkAction) *--------------------------------------------------------------------------- */ -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(); + Claim(); while (fsRecPtr != NULL) { - Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc; - if (proc != NULL) { - Tcl_Obj *thisFsVolumes = (*proc)(); + if (fsRecPtr->fsPtr->listVolumesProc != NULL) { + Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc(); + if (thisFsVolumes != NULL) { Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes); Tcl_DecrRefCount(thisFsVolumes); @@ -3120,7 +3916,8 @@ Tcl_FSListVolumes(void) } fsRecPtr = fsRecPtr->nextPtr; } - + Disclaim(); + return resultPtr; } @@ -3129,13 +3926,12 @@ 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 @@ -3143,37 +3939,37 @@ Tcl_FSListVolumes(void) *--------------------------------------------------------------------------- */ -static Tcl_Obj* -FsListMounts(pathPtr, pattern) - Tcl_Obj *pathPtr; /* Contains path to directory to search. */ - CONST char *pattern; /* Pattern to match against. */ +static Tcl_Obj * +FsListMounts( + Tcl_Obj *pathPtr, /* Contains path to directory to search. */ + const char *pattern) /* Pattern to match against. */ { FilesystemRecord *fsRecPtr; Tcl_GlobTypeData mountsOnly = { TCL_GLOB_TYPE_MOUNT, 0, NULL, NULL }; Tcl_Obj *resultPtr = NULL; - + /* - * Call each of the "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. + * Call each of the "matchInDirectory" functions in succession, with the + * specific type information 'mountsOnly'. A non-NULL return value + * indicates the particular function has succeeded. We call all the + * functions registered, since we want a list from each filesystems. */ fsRecPtr = FsGetFirstFilesystem(); + Claim(); while (fsRecPtr != NULL) { - if (fsRecPtr != &nativeFilesystemRecord) { - Tcl_FSMatchInDirectoryProc *proc = - fsRecPtr->fsPtr->matchInDirectoryProc; - if (proc != NULL) { - if (resultPtr == NULL) { - resultPtr = Tcl_NewObj(); - } - (*proc)(NULL, resultPtr, pathPtr, pattern, &mountsOnly); + if (fsRecPtr->fsPtr != &tclNativeFilesystem && + fsRecPtr->fsPtr->matchInDirectoryProc != NULL) { + if (resultPtr == NULL) { + resultPtr = Tcl_NewObj(); } + fsRecPtr->fsPtr->matchInDirectoryProc(NULL, resultPtr, pathPtr, + pattern, &mountsOnly); } fsRecPtr = fsRecPtr->nextPtr; } - + Disclaim(); + return resultPtr; } @@ -3182,14 +3978,14 @@ FsListMounts(pathPtr, pattern) * * 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. @@ -3197,23 +3993,23 @@ FsListMounts(pathPtr, pattern) *--------------------------------------------------------------------------- */ -Tcl_Obj* -Tcl_FSSplitPath(pathPtr, lenPtr) - Tcl_Obj *pathPtr; /* Path to split. */ - int *lenPtr; /* int to store number of path elements. */ +Tcl_Obj * +Tcl_FSSplitPath( + Tcl_Obj *pathPtr, /* Path to split. */ + int *lenPtr) /* int to store number of path elements. */ { - Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */ - Tcl_Filesystem *fsPtr; + Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */ + const Tcl_Filesystem *fsPtr; char separator = '/'; int driveNameLength; - char *p; - + const char *p; + /* - * Perform platform specific splitting. + * Perform platform specific splitting. */ - if (FSGetPathType(pathPtr, &fsPtr, &driveNameLength) - == TCL_PATH_ABSOLUTE) { + if (TclFSGetPathType(pathPtr, &fsPtr, + &driveNameLength) == TCL_PATH_ABSOLUTE) { if (fsPtr == &tclNativeFilesystem) { return TclpNativeSplitPath(pathPtr, lenPtr); } @@ -3221,38 +4017,49 @@ Tcl_FSSplitPath(pathPtr, lenPtr) 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 (;;) { - char *elementStart = p; + const char *elementStart = p; int length; + while ((*p != '\0') && (*p != separator)) { p++; } length = p - elementStart; if (length > 0) { Tcl_Obj *nextElt; + if (elementStart[0] == '~') { - nextElt = Tcl_NewStringObj("./",2); + TclNewLiteralStringObj(nextElt, "./"); Tcl_AppendToObj(nextElt, elementStart, length); } else { nextElt = Tcl_NewStringObj(elementStart, length); @@ -3263,53 +4070,82 @@ Tcl_FSSplitPath(pathPtr, lenPtr) break; } } - + /* * Compute the number of elements in the result. */ if (lenPtr != NULL) { - Tcl_ListObjLength(NULL, result, lenPtr); + TclListObjLength(NULL, result, lenPtr); } return result; } - -/* Simple helper function */ -Tcl_Obj* -TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr) - Tcl_Filesystem *fromFilesystem; - ClientData clientData; - FilesystemRecord **fsRecPtrPtr; +/* + *---------------------------------------------------------------------- + * + * TclGetPathType -- + * + * Helper function used by FSGetPathType. + * + * Results: + * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or + * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will be set if and + * only if it is non-NULL and the function's return value is + * TCL_PATH_ABSOLUTE. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_PathType +TclGetPathType( + Tcl_Obj *pathPtr, /* Path to determine type for. */ + 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. */ { - FilesystemRecord *fsRecPtr = FsGetFirstFilesystem(); + int pathLen; + const char *path = TclGetStringFromObj(pathPtr, &pathLen); + Tcl_PathType type; - while (fsRecPtr != NULL) { - if (fsRecPtr->fsPtr == fromFilesystem) { - *fsRecPtrPtr = fsRecPtr; - break; + 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; } - fsRecPtr = fsRecPtr->nextPtr; - } - - if ((fsRecPtr != NULL) - && (fromFilesystem->internalToNormalizedProc != NULL)) { - return (*fromFilesystem->internalToNormalizedProc)(clientData); - } else { - return NULL; } + return type; } /* *---------------------------------------------------------------------- * - * GetPathType -- + * TclFSNonnativePathType -- * - * Helper function used by FSGetPathType. + * 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, 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 + * Returns one of TCL_PATH_ABSOLUTE or TCL_PATH_RELATIVE. The filesystem + * reference will be set if and only if it is non-NULL and the function's * return value is TCL_PATH_ABSOLUTE. * * Side effects: @@ -3319,73 +4155,80 @@ TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr) */ Tcl_PathType -GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef) - Tcl_Obj *pathObjPtr; - Tcl_Filesystem **filesystemPtrPtr; - int *driveNameLengthPtr; - Tcl_Obj **driveNameRef; +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. */ { 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(); + Claim(); 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 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. + * 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. */ - if ((fsRecPtr->fsPtr != &tclNativeFilesystem) && (proc != NULL)) { + + if ((fsRecPtr->fsPtr != &tclNativeFilesystem) + && (fsRecPtr->fsPtr->listVolumesProc != NULL)) { int numVolumes; - Tcl_Obj *thisFsVolumes = (*proc)(); + Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc(); + if (thisFsVolumes != NULL) { - if (Tcl_ListObjLength(NULL, thisFsVolumes, - &numVolumes) != TCL_OK) { - /* - * This is VERY bad; the Tcl_FSListVolumesProc - * didn't return a valid list. Set numVolumes to - * -1 so that we skip the while loop below and just - * return with the current value of 'type'. - * - * It would be better if we could signal an error - * here (but panic seems a bit excessive). + 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). */ + numVolumes = -1; } while (numVolumes > 0) { Tcl_Obj *vol; int len; - char *strVol; + const char *strVol; numVolumes--; Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol); - strVol = Tcl_GetStringFromObj(vol,&len); + strVol = TclGetStringFromObj(vol,&len); if (pathLen < len) { continue; } @@ -3406,21 +4249,17 @@ GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef) } 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; - } - } + Disclaim(); return type; } @@ -3429,12 +4268,12 @@ GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef) * * 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. @@ -3443,22 +4282,21 @@ GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef) */ int -Tcl_FSRenameFile(srcPathPtr, destPathPtr) - Tcl_Obj* srcPathPtr; /* Pathname of file or dir to be renamed +Tcl_FSRenameFile( + 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; - Tcl_Filesystem *fsPtr, *fsPtr2; + const Tcl_Filesystem *fsPtr, *fsPtr2; + fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); - if (fsPtr == fsPtr2 && fsPtr != NULL) { - Tcl_FSRenameFileProc *proc = fsPtr->renameFileProc; - if (proc != NULL) { - retVal = (*proc)(srcPathPtr, destPathPtr); - } + if ((fsPtr == fsPtr2) && (fsPtr != NULL) + && (fsPtr->renameFileProc != NULL)) { + retVal = fsPtr->renameFileProc(srcPathPtr, destPathPtr); } if (retVal == -1) { Tcl_SetErrno(EXDEV); @@ -3471,16 +4309,16 @@ Tcl_FSRenameFile(srcPathPtr, destPathPtr) * * 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. @@ -3488,21 +4326,19 @@ Tcl_FSRenameFile(srcPathPtr, destPathPtr) *--------------------------------------------------------------------------- */ -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 +Tcl_FSCopyFile( + Tcl_Obj *srcPathPtr, /* Pathname of file to be copied (UTF-8). */ + Tcl_Obj *destPathPtr) /* Pathname of file to copy to (UTF-8). */ { int retVal = -1; - Tcl_Filesystem *fsPtr, *fsPtr2; + const Tcl_Filesystem *fsPtr, *fsPtr2; + fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); - if (fsPtr == fsPtr2 && fsPtr != NULL) { - Tcl_FSCopyFileProc *proc = fsPtr->copyFileProc; - if (proc != NULL) { - retVal = (*proc)(srcPathPtr, destPathPtr); - } + if (fsPtr == fsPtr2 && fsPtr != NULL && fsPtr->copyFileProc != NULL) { + retVal = fsPtr->copyFileProc(srcPathPtr, destPathPtr); } if (retVal == -1) { Tcl_SetErrno(EXDEV); @@ -3515,64 +4351,76 @@ Tcl_FSCopyFile(srcPathPtr, destPathPtr) * * 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(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 +TclCrossFilesystemCopy( + Tcl_Interp *interp, /* For error messages. */ + Tcl_Obj *source, /* Pathname of file to be copied (UTF-8). */ + Tcl_Obj *target) /* Pathname of file to copy to (UTF-8). */ { int result = TCL_ERROR; int prot = 0666; - - Tcl_Channel 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); - } - } + Tcl_Channel in, out; + Tcl_StatBuf sourceStatBuf; + struct utimbuf tval; + + out = Tcl_FSOpenFileChannel(interp, target, "wb", prot); + if (out == NULL) { + /* + * It looks like we cannot copy it over. Bail out... + */ + goto done; } + + in = Tcl_FSOpenFileChannel(interp, source, "rb", prot); + if (in == NULL) { + /* + * This is very strange, caller should have checked this... + */ + + Tcl_Close(interp, out); + goto done; + } + + /* + * Copy it synchronously. We might wish to add an asynchronous option to + * support vfs's which are slow (e.g. network sockets). + */ + + if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) { + result = TCL_OK; + } + + /* + * If the copy failed, assume that copy channel left a good error message. + */ + + Tcl_Close(interp, in); + Tcl_Close(interp, out); + + /* + * Set modification date of copied file. + */ + + if (Tcl_FSLstat(source, &sourceStatBuf) == 0) { + tval.actime = sourceStatBuf.st_atime; + tval.modtime = sourceStatBuf.st_mtime; + Tcl_FSUtime(target, &tval); + } + + done: return result; } @@ -3581,11 +4429,11 @@ TclCrossFilesystemCopy(interp, source, target) * * 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. @@ -3594,15 +4442,13 @@ TclCrossFilesystemCopy(interp, source, target) */ int -Tcl_FSDeleteFile(pathPtr) - Tcl_Obj *pathPtr; /* Pathname of file to be removed (UTF-8). */ +Tcl_FSDeleteFile( + Tcl_Obj *pathPtr) /* Pathname of file to be removed (UTF-8). */ { - Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL) { - Tcl_FSDeleteFileProc *proc = fsPtr->deleteFileProc; - if (proc != NULL) { - return (*proc)(pathPtr); - } + const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + + if (fsPtr != NULL && fsPtr->deleteFileProc != NULL) { + return fsPtr->deleteFileProc(pathPtr); } Tcl_SetErrno(ENOENT); return -1; @@ -3613,11 +4459,11 @@ Tcl_FSDeleteFile(pathPtr) * * 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. @@ -3626,15 +4472,13 @@ Tcl_FSDeleteFile(pathPtr) */ int -Tcl_FSCreateDirectory(pathPtr) - Tcl_Obj *pathPtr; /* Pathname of directory to create (UTF-8). */ +Tcl_FSCreateDirectory( + Tcl_Obj *pathPtr) /* Pathname of directory to create (UTF-8). */ { - Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL) { - Tcl_FSCreateDirectoryProc *proc = fsPtr->createDirectoryProc; - if (proc != NULL) { - return (*proc)(pathPtr); - } + const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + + if (fsPtr != NULL && fsPtr->createDirectoryProc != NULL) { + return fsPtr->createDirectoryProc(pathPtr); } Tcl_SetErrno(ENOENT); return -1; @@ -3645,12 +4489,12 @@ Tcl_FSCreateDirectory(pathPtr) * * 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. @@ -3659,24 +4503,22 @@ Tcl_FSCreateDirectory(pathPtr) */ int -Tcl_FSCopyDirectory(srcPathPtr, destPathPtr, errorPtr) - Tcl_Obj* srcPathPtr; /* Pathname of directory to be copied +Tcl_FSCopyDirectory( + Tcl_Obj *srcPathPtr, /* Pathname of directory to be copied * (UTF-8). */ - Tcl_Obj *destPathPtr; /* Pathname of target directory (UTF-8). */ - Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a - * new object containing name of file - * causing error, with refCount 1. */ + 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; - Tcl_Filesystem *fsPtr, *fsPtr2; + const Tcl_Filesystem *fsPtr, *fsPtr2; + fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); - if (fsPtr == fsPtr2 && fsPtr != NULL) { - Tcl_FSCopyDirectoryProc *proc = fsPtr->copyDirectoryProc; - if (proc != NULL) { - retVal = (*proc)(srcPathPtr, destPathPtr, errorPtr); - } + if (fsPtr == fsPtr2 && fsPtr != NULL && fsPtr->copyDirectoryProc != NULL){ + retVal = fsPtr->copyDirectoryProc(srcPathPtr, destPathPtr, errorPtr); } if (retVal == -1) { Tcl_SetErrno(EXDEV); @@ -3689,11 +4531,11 @@ Tcl_FSCopyDirectory(srcPathPtr, destPathPtr, errorPtr) * * 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. @@ -3702,2121 +4544,304 @@ Tcl_FSCopyDirectory(srcPathPtr, destPathPtr, errorPtr) */ int -Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr) - Tcl_Obj *pathPtr; /* Pathname of directory to be removed +Tcl_FSRemoveDirectory( + Tcl_Obj *pathPtr, /* Pathname of directory to be removed * (UTF-8). */ - int recursive; /* If non-zero, removes directories that - * are nonempty. Otherwise, will only remove - * empty directories. */ - Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a - * new object containing name of file - * causing error, with refCount 1. */ + 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. */ { - 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. - * - *--------------------------------------------------------------------------- - */ + const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); -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. - */ - if (TclFSEnsureEpochOk(pathObjPtr, &retVal) != TCL_OK) { - return NULL; + if (fsPtr == NULL || fsPtr->removeDirectoryProc == NULL) { + Tcl_SetErrno(ENOENT); + return -1; } /* - * Call each of the "pathInFilesystem" functions in succession. A - * non-return value of -1 indicates the particular function has - * succeeded. + * When working recursively, we check whether the cwd lies inside this + * directory and move it if it does. */ - fsRecPtr = FsGetFirstFilesystem(); - 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; - } - - 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. - * - *--------------------------------------------------------------------------- - */ - -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; + 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 = TclGetStringFromObj(normPath, &normLen); + cwdStr = TclGetStringFromObj(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]'. + */ - /* Make sure the normalized path is set */ - validPathObjPtr = Tcl_FSGetNormalizedPath(NULL, pathObjPtr); + Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr, + TCL_PATH_DIRNAME); - 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; + Tcl_FSChdir(dirPtr); + Tcl_DecrRefCount(dirPtr); + } + } + Tcl_DecrRefCount(cwdPtr); } } -#endif - - objPtr = Tcl_NewStringObj(copy,len); - Tcl_DStringFree(&ds); - - return objPtr; + return fsPtr->removeDirectoryProc(pathPtr, recursive, errorPtr); } - /* *--------------------------------------------------------------------------- * - * NativeDupInternalRep -- - * - * Duplicate the native representation. - * - * Results: - * The copied native representation, or NULL if it is not possible - * to copy the representation. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ -ClientData -NativeDupInternalRep(clientData) - ClientData clientData; -{ - ClientData copy; - size_t len; - - if (clientData == NULL) { - return NULL; - } - -#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; -{ - ckfree((char*)clientData); -} - -/* - *--------------------------------------------------------------------------- - * - * Tcl_FSFileSystemInfo -- + * Tcl_FSGetFileSystemForPath -- * - * 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. + * 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: - * A list of two elements. + * NULL or a filesystem which will accept this path. * * 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)); - 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; +const Tcl_Filesystem * +Tcl_FSGetFileSystemForPath( + Tcl_Obj *pathPtr) { - 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); + FilesystemRecord *fsRecPtr; + const Tcl_Filesystem *retVal = NULL; - retVal = TCL_OK; - } + if (pathPtr == NULL) { + Tcl_Panic("Tcl_FSGetFileSystemForPath called with NULL object"); + return NULL; } - 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; /* - * 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 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). */ - 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; - } + if (pathPtr->refCount == 0) { + Tcl_Panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0"); + return NULL; } - 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; - /* - * 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. + * 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. */ - 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); + fsRecPtr = FsGetFirstFilesystem(); + Claim(); - retVal = TCL_OK; - } + if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) { + Disclaim(); + return NULL; + } else if (retVal != NULL) { + /* TODO: Can this happen? */ + Disclaim(); + return retVal; } - 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; - /* - * Traverse the 'openFileChannelProcList' looking for the particular - * node whose 'proc' member matches 'proc' and remove that one from - * the list. + * Call each of the "pathInFilesystem" functions in succession. A + * non-return value of -1 indicates the particular function has succeeded. */ - Tcl_MutexLock(&obsoleteFsHookMutex); - tmpOpenFileChannelProcPtr = openFileChannelProcList; - while ((retVal == TCL_ERROR) && - (tmpOpenFileChannelProcPtr != NULL)) { - if (tmpOpenFileChannelProcPtr->proc == proc) { - if (prevOpenFileChannelProcPtr == NULL) { - openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr; - } else { - prevOpenFileChannelProcPtr->nextPtr = - tmpOpenFileChannelProcPtr->nextPtr; - } - - ckfree((char *)tmpOpenFileChannelProcPtr); + for (; fsRecPtr!=NULL ; fsRecPtr=fsRecPtr->nextPtr) { + ClientData clientData = NULL; - retVal = TCL_OK; - } else { - prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr; - tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr; + if (fsRecPtr->fsPtr->pathInFilesystemProc == NULL) { + continue; } - } - Tcl_MutexUnlock(&obsoleteFsHookMutex); - - return retVal; -} -#endif /* USE_OBSOLETE_FS_HOOKS */ - - -/* - * 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. - */ -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 - -/* - *---------------------------------------------------------------------- - * - * 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. - * - *---------------------------------------------------------------------- - */ + if (fsRecPtr->fsPtr->pathInFilesystemProc(pathPtr, &clientData)!=-1) { + /* + * We assume the type of pathPtr hasn't been changed by the above + * call to the pathInFilesystemProc. + */ -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) { - return TCL_PATH_RELATIVE; - } - return FSGetPathType(fsPathPtr->cwdPtr, filesystemPtrPtr, - driveNameLengthPtr); - } else { - return GetPathType(pathObjPtr, filesystemPtrPtr, - driveNameLengthPtr, NULL); + TclFSSetPathDetails(pathPtr, fsRecPtr->fsPtr, clientData); + Disclaim(); + return fsRecPtr->fsPtr; } } -} - -/* - *--------------------------------------------------------------------------- - * - * 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))) { - Tcl_DecrRefCount(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; - } - } + Disclaim(); - /* - * 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; + return NULL; } /* *--------------------------------------------------------------------------- * - * Tcl_FSConvertToPathType -- - * - * 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: - * Standard Tcl error code. - * - * Side effects: - * 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); - - /* - * 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; -{ - 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; -} - -/* - *--------------------------------------------------------------------------- + * Tcl_FSGetNativePath -- * - * TclNewFSPathObj -- + * 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. * - * 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. + * NULL or a valid native path. * * Side effects: - * Memory is allocated. 'dirPtr' gets an additional refCount. + * See Tcl_FSGetInternalRep. * *--------------------------------------------------------------------------- */ -Tcl_Obj* -TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len) +const void * +Tcl_FSGetNativePath( + Tcl_Obj *pathPtr) { - FsPath *fsPathPtr; - Tcl_Obj *objPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - 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; - - return objPtr; + return Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem); } /* *--------------------------------------------------------------------------- * - * TclFSMakePathRelative -- - * - * 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. - * - *--------------------------------------------------------------------------- - */ - -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. */ -{ - 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); - } - } - - 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); -} - -/* - *--------------------------------------------------------------------------- + * NativeFreeInternalRep -- * - * TclFSMakePathFromNormalized -- + * Free a native internal representation, which will be non-NULL. * - * Like SetFsPathFromAny, but assumes the given object is an - * absolute normalized path. Only for internal use. - * * Results: - * Standard Tcl error code. + * None. * * Side effects: - * The old representation may be freed, and new memory allocated. + * Memory is released. * *--------------------------------------------------------------------------- */ -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. */ +static void +NativeFreeInternalRep( + ClientData clientData) { - 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; + ckfree(clientData); } /* *--------------------------------------------------------------------------- * - * Tcl_FSNewNativePath -- + * Tcl_FSFileSystemInfo -- * - * 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. + * 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: - * NULL or a valid path object pointer, with refCount zero. + * A list of two elements. * * Side effects: - * New memory may be allocated. + * The object may be converted to a path type. * *--------------------------------------------------------------------------- */ Tcl_Obj * -Tcl_FSNewNativePath(fromFilesystem, clientData) - Tcl_Filesystem* fromFilesystem; - ClientData clientData; +Tcl_FSFileSystemInfo( + Tcl_Obj *pathPtr) { - Tcl_Obj *objPtr; - FsPath *fsPathPtr; + Tcl_Obj *resPtr; + const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - FilesystemRecord *fsFromPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - objPtr = TclFSInternalToNormalized(fromFilesystem, clientData, &fsFromPtr); - if (objPtr == NULL) { + if (fsPtr == 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)); - - 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; - - PATHOBJ(objPtr) = (VOID *) fsPathPtr; - PATHFLAGS(objPtr) = 0; - objPtr->typePtr = &tclFsPathType; - - 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; + resPtr = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(NULL, resPtr, + Tcl_NewStringObj(fsPtr->typeName, -1)); - if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { - return NULL; - } - srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); - if (srcFsPathPtr->translatedPathPtr == NULL) { - if (PATHFLAGS(pathPtr) != 0) { - retObj = Tcl_FSGetNormalizedPath(interp, pathPtr); - } 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; - } + if (fsPtr->filesystemPathTypeProc != NULL) { + Tcl_Obj *typePtr = fsPtr->filesystemPathTypeProc(pathPtr); - Tcl_IncrRefCount(retObj); - return retObj; -} - -/* - *--------------------------------------------------------------------------- - * - * Tcl_FSGetTranslatedStringPath -- - * - * 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: - * NULL or a valid string. - * - * Side effects: - * 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; - } - - 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; -{ - FsPath *fsPathPtr; - - if (Tcl_FSConvertToPathType(interp, pathObjPtr) != TCL_OK) { - return NULL; - } - fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); - - 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, but only starting after - * the end of the previously normalized 'dir'. 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) { - 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); - - 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; + if (typePtr != NULL) { + Tcl_ListObjAppendElement(NULL, resPtr, typePtr); } } - return fsPathPtr->normPathPtr; + return resPtr; } /* *--------------------------------------------------------------------------- * - * Tcl_FSGetInternalRep -- + * Tcl_FSPathSeparator -- * - * 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'. + * This function returns the separator to be used for a given path. The + * object returned should have a refCount of zero * * Results: - * NULL or a valid internal representation. + * A Tcl object, with a refCount of zero. If the caller needs to retain a + * reference to the object, it should call Tcl_IncrRefCount, and should + * otherwise free the object. * * Side effects: - * An attempt may be made to convert the object. + * The path object may be converted to a path type. * *--------------------------------------------------------------------------- */ -ClientData -Tcl_FSGetInternalRep(pathObjPtr, fsPtr) - Tcl_Obj* pathObjPtr; - Tcl_Filesystem *fsPtr; +Tcl_Obj * +Tcl_FSPathSeparator( + Tcl_Obj *pathPtr) { - 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; - } - } + const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + Tcl_Obj *resultObj; - 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); - } + if (fsPtr == NULL) { return NULL; } - if (srcFsPathPtr->nativePathPtr == NULL) { - Tcl_FSCreateInternalRepProc *proc; - proc = srcFsPathPtr->fsRecPtr->fsPtr->createInternalRepProc; - - if (proc == NULL) { - return NULL; - } - srcFsPathPtr->nativePathPtr = (*proc)(pathObjPtr); - } - - return srcFsPathPtr->nativePathPtr; -} - -/* - *--------------------------------------------------------------------------- - * - * TclFSEnsureEpochOk -- - * - * 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: - * 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; + if (fsPtr->filesystemSeparatorProc != NULL) { + return fsPtr->filesystemSeparatorProc(pathPtr); } - srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); - - /* - * Check if the filesystem has changed in some way since - * this object's internal representation was calculated. + /* + * Allow filesystems not to provide a filesystemSeparatorProc if they wish + * to use the standard forward slash. */ - 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++; + TclNewLiteralStringObj(resultObj, "/"); + return resultObj; } /* *--------------------------------------------------------------------------- * - * Tcl_FSEqualPaths -- + * NativeFilesystemSeparator -- * - * This function tests whether the two paths given are equal path - * objects. If either or both is NULL, 0 is always returned. + * This function is part of the native filesystem support, and returns + * the separator for the given path. * * Results: - * 1 or 0. + * String object containing the separator character. * * Side effects: * None. @@ -5824,471 +4849,27 @@ TclFSSetPathDetails(pathObjPtr, fsRecPtr, clientData) *--------------------------------------------------------------------------- */ -int -Tcl_FSEqualPaths(firstPtr, secondPtr) - Tcl_Obj* firstPtr; - Tcl_Obj* secondPtr; +static Tcl_Obj * +NativeFilesystemSeparator( + Tcl_Obj *pathPtr) { - if (firstPtr == secondPtr) { - return 1; - } else { - char *firstStr, *secondStr; - int firstLen, secondLen, tempErrno; + const char *separator = NULL; /* lint */ - 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); - } - -#if defined(__CYGWIN__) && defined(__WIN32__) - { - extern int cygwin_conv_to_win32_path - _ANSI_ARGS_((CONST char *, char *)); - char winbuf[MAX_PATH+1]; - - /* - * In the Cygwin world, call conv_to_win32_path in order to use the - * mount table to translate the file name into something Windows will - * understand. Take care when converting empty strings! - */ - name = Tcl_GetStringFromObj(transPtr, &len); - if (len > 0) { - cygwin_conv_to_win32_path(name, winbuf); - TclWinNoBackslash(winbuf); - Tcl_SetStringObj(transPtr, winbuf, -1); - } - } -#endif /* __CYGWIN__ && __WIN32__ */ - - /* - * 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: - 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; + case TCL_PLATFORM_UNIX: + separator = "/"; + break; + case TCL_PLATFORM_WINDOWS: + separator = "\\"; + break; } - Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr); - objPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen); - objPtr->length = cwdLen; - copy->bytes = tclEmptyStringRep; - copy->length = 0; - Tcl_DecrRefCount(copy); + return Tcl_NewStringObj(separator,1); } /* - *--------------------------------------------------------------------------- - * - * 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. - * - *--------------------------------------------------------------------------- + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: */ -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; -} |