diff options
Diffstat (limited to 'generic/tclIOUtil.c')
| -rw-r--r-- | generic/tclIOUtil.c | 1487 |
1 files changed, 899 insertions, 588 deletions
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 89465a0..f624cb7 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -16,20 +16,57 @@ * * 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.154 2008/05/02 10:27:07 dkf Exp $ */ #include "tclInt.h" -#ifdef __WIN32__ +#ifdef _WIN32 # include "tclWinInt.h" #endif #include "tclFileSystem.h" /* + * struct FilesystemRecord -- + * + * 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) */ + 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; + +/* + * 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. + */ + +typedef struct ThreadSpecificData { + int initialized; + int cwdPathEpoch; + int filesystemEpoch; + Tcl_Obj *cwdPathPtr; + ClientData cwdClientData; + FilesystemRecord *filesystemList; + int claims; +} ThreadSpecificData; + +/* * Prototypes for functions defined later in this file. */ +static int EvalFileCallback(ClientData data[], + Tcl_Interp *interp, int result); static FilesystemRecord*FsGetFirstFilesystem(void); static void FsThrExitProc(ClientData cd); static Tcl_Obj * FsListMounts(Tcl_Obj *pathPtr, const char *pattern); @@ -37,10 +74,13 @@ static void FsAddMountsToGlobResult(Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, const char *pattern, Tcl_GlobTypeData *types); static void FsUpdateCwd(Tcl_Obj *cwdObj, ClientData clientData); - -#ifdef TCL_THREADS static void FsRecacheFilesystemList(void); -#endif +static void 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 @@ -49,15 +89,170 @@ static void FsRecacheFilesystemList(void); * they are not (and should not be) used anywhere else. */ -MODULE_SCOPE const char * tclpFileAttrStrings[]; +MODULE_SCOPE const char *const tclpFileAttrStrings[]; MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; + +/* + * Declare the native filesystem support. These functions should be considered + * private to Tcl, and should really not be called directly by any code other + * than this file (i.e. neither by Tcl's core nor by extensions). Similarly, + * the old string-based Tclp... native filesystem functions should not be + * called. + * + * The correct API to use now is the Tcl_FS... set of functions, which ensure + * correct and complete virtual filesystem support. + * + * We cannot make all of these static, since some of them are implemented in + * the platform-specific directories. + */ + +static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator; +static Tcl_FSFreeInternalRepProc NativeFreeInternalRep; +static Tcl_FSFileAttrStringsProc NativeFileAttrStrings; +static Tcl_FSFileAttrsGetProc NativeFileAttrsGet; +static Tcl_FSFileAttrsSetProc NativeFileAttrsSet; + +/* + * The only reason these functions are not static is that they are either + * called by code in the native (win/unix) directories or they are actually + * implemented in those directories. They should simply not be called by code + * outside Tcl's native filesystem core i.e. they should be considered + * 'static' to Tcl's filesystem code (if we ever built the native filesystem + * support into a separate code library, this could actually be enforced). + */ + +Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType; +Tcl_FSInternalToNormalizedProc TclpNativeToNormalized; +Tcl_FSStatProc TclpObjStat; +Tcl_FSAccessProc TclpObjAccess; +Tcl_FSMatchInDirectoryProc TclpMatchInDirectory; +Tcl_FSChdirProc TclpObjChdir; +Tcl_FSLstatProc TclpObjLstat; +Tcl_FSCopyFileProc TclpObjCopyFile; +Tcl_FSDeleteFileProc TclpObjDeleteFile; +Tcl_FSRenameFileProc TclpObjRenameFile; +Tcl_FSCreateDirectoryProc TclpObjCreateDirectory; +Tcl_FSCopyDirectoryProc TclpObjCopyDirectory; +Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory; +Tcl_FSUnloadFileProc TclpUnloadFile; +Tcl_FSLinkProc TclpObjLink; +Tcl_FSListVolumesProc TclpObjListVolumes; + +/* + * Define the native filesystem dispatch table. If necessary, it is ok to make + * this non-static, but it should only be accessed by the functions actually + * listed within it (or perhaps other helper functions of them). Anything + * which is not part of this 'native filesystem implementation' should not be + * delving inside here! + */ + +const Tcl_Filesystem tclNativeFilesystem = { + "native", + sizeof(Tcl_Filesystem), + TCL_FILESYSTEM_VERSION_2, + TclNativePathInFilesystem, + TclNativeDupInternalRep, + NativeFreeInternalRep, + TclpNativeToNormalized, + TclNativeCreateNativeRep, + TclpObjNormalizePath, + TclpFilesystemPathType, + NativeFilesystemSeparator, + TclpObjStat, + TclpObjAccess, + TclpOpenFileChannel, + TclpMatchInDirectory, + TclpUtime, +#ifndef S_IFLNK + NULL, +#else + TclpObjLink, +#endif /* S_IFLNK */ + TclpObjListVolumes, + NativeFileAttrStrings, + NativeFileAttrsGet, + NativeFileAttrsSet, + TclpObjCreateDirectory, + TclpObjRemoveDirectory, + TclpObjDeleteFile, + TclpObjCopyFile, + TclpObjRenameFile, + TclpObjCopyDirectory, + TclpObjLstat, + /* 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 int 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 int 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( @@ -67,18 +262,14 @@ Tcl_Stat( int ret; Tcl_StatBuf buf; Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); -#ifndef TCL_WIDE_INT_IS_LONG - Tcl_WideInt tmp1, tmp2; -#ifdef HAVE_ST_BLOCKS - Tcl_WideInt tmp3; -#endif -#endif Tcl_IncrRefCount(pathPtr); ret = Tcl_FSStat(pathPtr, &buf); Tcl_DecrRefCount(pathPtr); if (ret != -1) { #ifndef TCL_WIDE_INT_IS_LONG + 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)) @@ -95,25 +286,19 @@ Tcl_Stat( * Tcl_WideInt. */ - tmp1 = (Tcl_WideInt) buf.st_ino; - tmp2 = (Tcl_WideInt) buf.st_size; -#ifdef HAVE_ST_BLOCKS - tmp3 = (Tcl_WideInt) 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 - if (OUT_OF_URANGE(tmp1) || OUT_OF_RANGE(tmp2) -#ifdef HAVE_ST_BLOCKS - || OUT_OF_RANGE(tmp3) -#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; } @@ -141,9 +326,15 @@ Tcl_Stat( oldStyleBuf->st_atime = buf.st_atime; oldStyleBuf->st_mtime = buf.st_mtime; oldStyleBuf->st_ctime = buf.st_ctime; -#ifdef HAVE_ST_BLOCKS +#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; @@ -211,7 +402,7 @@ Tcl_GetCwd( return NULL; } Tcl_DStringInit(cwdPtr); - Tcl_DStringAppend(cwdPtr, Tcl_GetString(cwd), -1); + TclDStringAppendObj(cwdPtr, cwd); Tcl_DecrRefCount(cwd); return Tcl_DStringValue(cwdPtr); } @@ -233,184 +424,7 @@ Tcl_EvalFile( } /* - * 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. - */ - - - -/* - * Declare the native filesystem support. These functions should be considered - * private to Tcl, and should really not be called directly by any code other - * than this file (i.e. neither by Tcl's core nor by extensions). Similarly, - * the old string-based Tclp... native filesystem functions should not be - * called. - * - * The correct API to use now is the Tcl_FS... set of functions, which ensure - * correct and complete virtual filesystem support. - * - * We cannot make all of these static, since some of them are implemented in - * the platform-specific directories. - */ - -static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator; -static Tcl_FSFreeInternalRepProc NativeFreeInternalRep; -static Tcl_FSFileAttrStringsProc NativeFileAttrStrings; -static Tcl_FSFileAttrsGetProc NativeFileAttrsGet; -static Tcl_FSFileAttrsSetProc NativeFileAttrsSet; - -/* - * The only reason these functions are not static is that they are either - * called by code in the native (win/unix) directories or they are actually - * implemented in those directories. They should simply not be called by code - * outside Tcl's native filesystem core i.e. they should be considered - * 'static' to Tcl's filesystem code (if we ever built the native filesystem - * support into a separate code library, this could actually be enforced). - */ - -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! - */ - -Tcl_Filesystem tclNativeFilesystem = { - "native", - sizeof(Tcl_Filesystem), - TCL_FILESYSTEM_VERSION_2, - &TclNativePathInFilesystem, - &TclNativeDupInternalRep, - &NativeFreeInternalRep, - &TclpNativeToNormalized, - &TclNativeCreateNativeRep, - &TclpObjNormalizePath, - &TclpFilesystemPathType, - &NativeFilesystemSeparator, - &TclpObjStat, - &TclpObjAccess, - &TclpOpenFileChannel, - &TclpMatchInDirectory, - &TclpUtime, -#ifndef S_IFLNK - NULL, -#else - &TclpObjLink, -#endif /* S_IFLNK */ - &TclpObjListVolumes, - &NativeFileAttrStrings, - &NativeFileAttrsGet, - &NativeFileAttrsSet, - &TclpObjCreateDirectory, - &TclpObjRemoveDirectory, - &TclpObjDeleteFile, - &TclpObjCopyFile, - &TclpObjRenameFile, - &TclpObjCopyDirectory, - &TclpObjLstat, - &TclpDlopen, - /* Needs a cast since we're using version_2 */ - (Tcl_FSGetCwdProc *) &TclpGetNativeCwd, - &TclpObjChdir -}; - -/* - * Define the tail of the linked list. Note that for unconventional uses of - * Tcl without a native filesystem, we may in the future wish to modify the - * current approach of hard-coding the native filesystem in the lookup list - * 'filesystemList' below. - * - * We initialize the record so that it thinks one file uses it. This means it - * will never be freed. - */ - -static FilesystemRecord nativeFilesystemRecord = { - NULL, - &tclNativeFilesystem, - 1, - NULL -}; - -/* - * 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 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; -static ClientData cwdClientData = NULL; -TCL_DECLARE_MUTEX(cwdMutex) - -Tcl_ThreadDataKey tclFsDataKey; - -/* - * Declare fallback support function and information for Tcl_FSLoadFile - */ - -static Tcl_FSUnloadFileProc FSUnloadTempFile; - -/* - * One of these structures is used each time we successfully load a file from - * a file system by way of making a temporary copy of the file on the native - * filesystem. We need to store both the actual unloadProc/clientData - * combination which was used, and the original and modified filenames, so - * that we can correctly undo the entire operation when we want to unload the - * code. - */ - -typedef struct FsDivertLoad { - Tcl_LoadHandle loadHandle; - Tcl_FSUnloadFileProc *unloadProcPtr; - Tcl_Obj *divertedFile; - const Tcl_Filesystem *divertedFilesystem; - ClientData divertedFileNativeRep; -} FsDivertLoad; - -/* - * Now move on to the basic filesystem implementation + * Now move on to the basic filesystem implementation. */ static void @@ -439,18 +453,18 @@ FsThrExitProc( 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 TclFSCwdIsNative(void) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); if (tsdPtr->cwdClientData != NULL) { return 1; @@ -484,7 +498,7 @@ int TclFSCwdPointerEquals( Tcl_Obj **pathPtrPtr) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); Tcl_MutexLock(&cwdMutex); if (tsdPtr->cwdPathPtr == NULL @@ -527,7 +541,7 @@ TclFSCwdPointerEquals( str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2); - if (len1 == len2 && !strcmp(str1,str2)) { + if ((len1 == len2) && !memcmp(str1, str2, len1)) { /* * They are equal, but different objects. Update so they will be * the same object in the future. @@ -543,12 +557,11 @@ TclFSCwdPointerEquals( } } -#ifdef TCL_THREADS static void FsRecacheFilesystemList(void) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL, *toFree = NULL, *list; /* * Trash the current cache. @@ -557,20 +570,16 @@ FsRecacheFilesystemList(void) 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 proceed. - * * Locate tail of the global filesystem list. */ + Tcl_MutexLock(&filesystemMutex); fsRecPtr = filesystemList; while (fsRecPtr != NULL) { tmpFsRecPtr = fsRecPtr; @@ -581,18 +590,26 @@ FsRecacheFilesystemList(void) * 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; + 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. @@ -603,28 +620,16 @@ FsRecacheFilesystemList(void) tsdPtr->initialized = 1; } } -#endif /* TCL_THREADS */ static FilesystemRecord * FsGetFirstFilesystem(void) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - FilesystemRecord *fsRecPtr; - -#ifndef TCL_THREADS - tsdPtr->filesystemEpoch = theFilesystemEpoch; - fsRecPtr = filesystemList; -#else - Tcl_MutexLock(&filesystemMutex); - if (tsdPtr->filesystemList == NULL - || (tsdPtr->filesystemEpoch != theFilesystemEpoch)) { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + if (tsdPtr->filesystemList == NULL || ((tsdPtr->claims == 0) + && (tsdPtr->filesystemEpoch != theFilesystemEpoch))) { FsRecacheFilesystemList(); - tsdPtr->filesystemEpoch = theFilesystemEpoch; } - Tcl_MutexUnlock(&filesystemMutex); - fsRecPtr = tsdPtr->filesystemList; -#endif - return fsRecPtr; + return tsdPtr->filesystemList; } /* @@ -636,10 +641,33 @@ int TclFSEpochOk( int filesystemEpoch) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - (void) FsGetFirstFilesystem(); - return (filesystemEpoch == tsdPtr->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--; +} + +int +TclFSEpoch(void) +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + + return tsdPtr->filesystemEpoch; } + /* * If non-NULL, clientData is owned by us and must be freed later. @@ -651,8 +679,8 @@ FsUpdateCwd( ClientData clientData) { int len; - char *str = NULL; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); + const char *str = NULL; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); if (cwdObj != NULL) { str = Tcl_GetStringFromObj(cwdObj, &len); @@ -675,7 +703,7 @@ FsUpdateCwd( */ cwdPathPtr = Tcl_NewStringObj(str, len); - Tcl_IncrRefCount(cwdPathPtr); + Tcl_IncrRefCount(cwdPathPtr); cwdClientData = TclNativeDupInternalRep(clientData); } @@ -742,24 +770,21 @@ TclFinalizeFilesystem(void) /* * Remove all filesystems, freeing any allocated memory that is no longer - * needed + * needed. */ fsRecPtr = filesystemList; while (fsRecPtr != NULL) { FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr; - if (fsRecPtr->fileRefCount <= 0) { - /* - * The native filesystem is static, so we don't free it. - */ + /* The native filesystem is static, so we don't free it. */ - if (fsRecPtr->fsPtr != &tclNativeFilesystem) { - ckfree((char *) fsRecPtr); - } + if (fsRecPtr != &nativeFilesystemRecord) { + ckfree(fsRecPtr); } fsRecPtr = tmpFsRecPtr; } + theFilesystemEpoch++; filesystemList = NULL; /* @@ -767,7 +792,7 @@ TclFinalizeFilesystem(void) * filesystem is likely to fail. */ -#ifdef __WIN32__ +#ifdef _WIN32 TclWinEncodingsCleanup(); #endif } @@ -792,13 +817,9 @@ void TclResetFilesystem(void) { filesystemList = &nativeFilesystemRecord; + 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__ +#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. @@ -840,8 +861,8 @@ TclResetFilesystem(void) int Tcl_FSRegister( - ClientData clientData, /* Client specific data for this fs */ - Tcl_Filesystem *fsPtr) /* The filesystem record for the new fs. */ + ClientData clientData, /* Client specific data for this fs. */ + const Tcl_Filesystem *fsPtr)/* The filesystem record for the new fs. */ { FilesystemRecord *newFilesystemPtr; @@ -849,19 +870,12 @@ Tcl_FSRegister( 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 @@ -920,7 +934,7 @@ Tcl_FSRegister( int Tcl_FSUnregister( - Tcl_Filesystem *fsPtr) /* The filesystem record to remove. */ + const Tcl_Filesystem *fsPtr) /* The filesystem record to remove. */ { int retVal = TCL_ERROR; FilesystemRecord *fsRecPtr; @@ -934,7 +948,7 @@ Tcl_FSUnregister( */ fsRecPtr = filesystemList; - while ((retVal == TCL_ERROR) && (fsRecPtr->fsPtr != &tclNativeFilesystem)) { + while ((retVal == TCL_ERROR) && (fsRecPtr != &nativeFilesystemRecord)) { if (fsRecPtr->fsPtr == fsPtr) { if (fsRecPtr->prevPtr) { fsRecPtr->prevPtr->nextPtr = fsRecPtr->nextPtr; @@ -955,10 +969,7 @@ Tcl_FSUnregister( theFilesystemEpoch++; - fsRecPtr->fileRefCount--; - if (fsRecPtr->fileRefCount <= 0) { - ckfree((char *) fsRecPtr); - } + ckfree(fsRecPtr); retVal = TCL_OK; } else { @@ -1014,7 +1025,7 @@ Tcl_FSUnregister( int Tcl_FSMatchInDirectory( Tcl_Interp *interp, /* Interpreter to receive error messages, but - * may be NULL. */ + * 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. */ @@ -1053,8 +1064,8 @@ Tcl_FSMatchInDirectory( Tcl_SetErrno(ENOENT); return -1; } - ret = (*fsPtr->matchInDirectoryProc)(interp, resultPtr, pathPtr, - pattern, types); + ret = fsPtr->matchInDirectoryProc(interp, resultPtr, pathPtr, pattern, + types); if (ret == TCL_OK && pattern != NULL) { FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types); } @@ -1063,7 +1074,7 @@ Tcl_FSMatchInDirectory( /* * If the path isn't empty, we have no idea how to match files in a - * directory which belongs to no known filesystem + * directory which belongs to no known filesystem. */ if (pathPtr != NULL && TclGetString(pathPtr)[0] != '\0') { @@ -1084,8 +1095,9 @@ Tcl_FSMatchInDirectory( cwd = Tcl_FSGetCwd(NULL); if (cwd == NULL) { if (interp != NULL) { - Tcl_SetResult(interp, "glob couldn't determine " - "the current working directory", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "glob couldn't determine the current working directory", + -1)); } return TCL_ERROR; } @@ -1094,8 +1106,8 @@ Tcl_FSMatchInDirectory( if (fsPtr != NULL && fsPtr->matchInDirectoryProc != NULL) { TclNewObj(tmpResultPtr); Tcl_IncrRefCount(tmpResultPtr); - ret = (*fsPtr->matchInDirectoryProc)(interp, tmpResultPtr, cwd, - pattern, types); + ret = fsPtr->matchInDirectoryProc(interp, tmpResultPtr, cwd, pattern, + types); if (ret == TCL_OK) { FsAddMountsToGlobResult(tmpResultPtr, cwd, pattern, types); @@ -1139,7 +1151,7 @@ static void FsAddMountsToGlobResult( Tcl_Obj *resultPtr, /* The current list of matching paths; must * not be shared! */ - Tcl_Obj *pathPtr, /* The directory in question */ + 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 @@ -1180,7 +1192,7 @@ FsAddMountsToGlobResult( Tcl_ListObjReplace(NULL, resultPtr, j, 1, 0, NULL); gLength--; } - break; /* Break out of for loop */ + break; /* Break out of for loop. */ } } if (!found && dir) { @@ -1270,7 +1282,7 @@ FsAddMountsToGlobResult( void Tcl_FSMountsChanged( - Tcl_Filesystem *fsPtr) + const Tcl_Filesystem *fsPtr) { /* * We currently don't do anything with this parameter. We could in the @@ -1311,7 +1323,7 @@ Tcl_FSMountsChanged( ClientData Tcl_FSData( - Tcl_Filesystem *fsPtr) /* The filesystem record to query. */ + const Tcl_Filesystem *fsPtr) /* The filesystem record to query. */ { ClientData retVal = NULL; FilesystemRecord *fsRecPtr = FsGetFirstFilesystem(); @@ -1365,15 +1377,10 @@ Tcl_FSData( int TclFSNormalizeToUniquePath( Tcl_Interp *interp, /* Used for error messages. */ - Tcl_Obj *pathPtr, /* The path to normalize in place */ - int startAt, /* Start at this char-offset */ - ClientData *clientDataPtr) /* If we generated a complete normalized path - * for a given filesystem, we can optionally - * return an fs-specific clientdata here. */ + Tcl_Obj *pathPtr, /* The path to normalize in place. */ + int startAt) /* Start at this char-offset. */ { FilesystemRecord *fsRecPtr, *firstFsRecPtr; - /* Ignore this variable */ - (void) clientDataPtr; /* * Call each of the "normalise path" functions in succession. This is a @@ -1384,6 +1391,7 @@ TclFSNormalizeToUniquePath( firstFsRecPtr = FsGetFirstFilesystem(); + Claim(); for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) { if (fsRecPtr->fsPtr != &tclNativeFilesystem) { continue; @@ -1421,6 +1429,7 @@ TclFSNormalizeToUniquePath( * but there's not much benefit. */ } + Disclaim(); return startAt; } @@ -1492,7 +1501,7 @@ TclGetOpenModeEx( * EOF during the opening of the file. */ int *binaryPtr) /* Set this to 1 if the caller should * configure the opened channel for binary - * operations */ + * operations. */ { int mode, modeArgc, c, i, gotRW; const char **modeArgv, *flag; @@ -1534,7 +1543,7 @@ TclGetOpenModeEx( default: goto error; } - i=1; + i = 1; while (i<3 && modeString[i]) { if (modeString[i] == modeString[i-1]) { goto error; @@ -1565,8 +1574,8 @@ TclGetOpenModeEx( *seekFlagPtr = 0; *binaryPtr = 0; if (interp != NULL) { - Tcl_AppendResult(interp, "illegal access mode \"", modeString, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "illegal access mode \"%s\"", modeString)); } return -1; } @@ -1615,10 +1624,11 @@ TclGetOpenModeEx( mode |= O_NOCTTY; #else if (interp != NULL) { - Tcl_AppendResult(interp, "access mode \"", flag, - "\" not supported by this system", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "access mode \"%s\" not supported by this system", + flag)); } - ckfree((char *) modeArgv); + ckfree(modeArgv); return -1; #endif @@ -1627,10 +1637,11 @@ TclGetOpenModeEx( mode |= O_NONBLOCK; #else if (interp != NULL) { - Tcl_AppendResult(interp, "access mode \"", flag, - "\" not supported by this system", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "access mode \"%s\" not supported by this system", + flag)); } - ckfree((char *) modeArgv); + ckfree(modeArgv); return -1; #endif @@ -1641,21 +1652,23 @@ TclGetOpenModeEx( } else { if (interp != NULL) { - Tcl_AppendResult(interp, "invalid access mode \"", flag, - "\": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, " - "CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid access mode \"%s\": must be RDONLY, WRONLY, " + "RDWR, APPEND, BINARY, CREAT, EXCL, NOCTTY, NONBLOCK," + " or TRUNC", flag)); } - ckfree((char *) modeArgv); + ckfree(modeArgv); return -1; } } - ckfree((char *) modeArgv); + ckfree(modeArgv); if (!gotRW) { if (interp != NULL) { - Tcl_AppendResult(interp, "access mode must include either" - " RDONLY, WRONLY, or RDWR", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "access mode must include either RDONLY, WRONLY, or RDWR", + -1)); } return -1; } @@ -1663,25 +1676,13 @@ TclGetOpenModeEx( } /* - * Tcl_FSEvalFile is Tcl_FSEvalFileEx without encoding argument. - */ - -int -Tcl_FSEvalFile( - Tcl_Interp *interp, /* Interpreter in which to process file. */ - Tcl_Obj *pathPtr) /* Path of file to process. Tilde-substitution - * will be performed on this name. */ -{ - return Tcl_FSEvalFileEx(interp, pathPtr, NULL); -} - -/* *---------------------------------------------------------------------- * - * Tcl_FSEvalFileEx -- + * Tcl_FSEvalFile, Tcl_FSEvalFileEx, TclNREvalFile -- * * Read in a file and process the entire file as one gigantic Tcl - * command. + * 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 @@ -1696,6 +1697,15 @@ Tcl_FSEvalFile( */ int +Tcl_FSEvalFile( + Tcl_Interp *interp, /* Interpreter in which to process file. */ + Tcl_Obj *pathPtr) /* Path of file to process. Tilde-substitution + * will be performed on this name. */ +{ + return Tcl_FSEvalFileEx(interp, pathPtr, NULL); +} + +int Tcl_FSEvalFileEx( Tcl_Interp *interp, /* Interpreter in which to process file. */ Tcl_Obj *pathPtr, /* Path of file to process. Tilde-substitution @@ -1707,7 +1717,7 @@ Tcl_FSEvalFileEx( Tcl_StatBuf statBuf; Tcl_Obj *oldScriptFile; Interp *iPtr; - char *string; + const char *string; Tcl_Channel chan; Tcl_Obj *objPtr; @@ -1717,15 +1727,16 @@ Tcl_FSEvalFileEx( if (Tcl_FSStat(pathPtr, &statBuf) == -1) { Tcl_SetErrno(errno); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + 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 == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return result; } @@ -1751,10 +1762,32 @@ Tcl_FSEvalFileEx( objPtr = Tcl_NewObj(); Tcl_IncrRefCount(objPtr); - if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) { + + /* + * Try to read first character of stream, so we can check for utf-8 BOM to + * be handled especially. + */ + + if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) { Tcl_Close(interp, chan); - Tcl_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_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; } @@ -1773,7 +1806,7 @@ Tcl_FSEvalFileEx( */ iPtr->evalFlags |= TCL_EVAL_FILE; - result = Tcl_EvalEx(interp, string, length, 0); + result = TclEvalEx(interp, string, length, 0, 1, NULL, string); /* * Now we have to be careful; the script may have changed the @@ -1800,13 +1833,163 @@ Tcl_FSEvalFileEx( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (file \"%.*s%s\" line %d)", (overflow ? limit : length), pathString, - (overflow ? "..." : ""), interp->errorLine)); + (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; + } + + /* + * 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. + */ + + int length; + const char *pathString = Tcl_GetStringFromObj(pathPtr, &length); + const int limit = 150; + int overflow = (length > limit); + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (file \"%.*s%s\" line %d)", + (overflow ? limit : length), pathString, + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); + } + + Tcl_DecrRefCount(objPtr); + return result; +} /* *---------------------------------------------------------------------- @@ -1843,7 +2026,9 @@ Tcl_GetErrno(void) * * 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. @@ -2073,9 +2258,9 @@ Tcl_FSOpenFileChannel( if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt) 0, SEEK_END) < (Tcl_WideInt) 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not seek to end of file " - "while opening \"", Tcl_GetString(pathPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_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; @@ -2092,8 +2277,9 @@ Tcl_FSOpenFileChannel( Tcl_SetErrno(ENOENT); if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open \"", Tcl_GetString(pathPtr), - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); } return NULL; } @@ -2117,7 +2303,8 @@ Tcl_FSOpenFileChannel( int Tcl_FSUtime( - Tcl_Obj *pathPtr, /* File to change access/modification times */ + Tcl_Obj *pathPtr, /* File to change access/modification + * times. */ struct utimbuf *tval) /* Structure containing access/modification * times to use. Should not be modified. */ { @@ -2150,7 +2337,7 @@ Tcl_FSUtime( *---------------------------------------------------------------------- */ -static const char ** +static const char *const * NativeFileAttrStrings( Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef) @@ -2187,8 +2374,7 @@ NativeFileAttrsGet( 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); } /* @@ -2217,7 +2403,7 @@ NativeFileAttrsSet( 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); } /* @@ -2244,7 +2430,7 @@ NativeFileAttrsSet( *---------------------------------------------------------------------- */ -const char ** +const char *const * Tcl_FSFileAttrStrings( Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef) @@ -2283,7 +2469,7 @@ TclFSFileAttrIndex( int *indexPtr) /* Where to write the found index. */ { Tcl_Obj *listObj = NULL; - const char **attrTable; + const char *const *attrTable; /* * Get the attribute table for the file. @@ -2449,7 +2635,7 @@ Tcl_Obj * Tcl_FSGetCwd( Tcl_Interp *interp) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); if (TclFSCwdPointerEquals(NULL)) { FilesystemRecord *fsRecPtr; @@ -2461,8 +2647,9 @@ Tcl_FSGetCwd( * indicates the particular function has succeeded. */ - for (fsRecPtr = FsGetFirstFilesystem(); - (retVal == NULL) && (fsRecPtr != NULL); + fsRecPtr = FsGetFirstFilesystem(); + Claim(); + for (; (retVal == NULL) && (fsRecPtr != NULL); fsRecPtr = fsRecPtr->nextPtr) { ClientData retCd; TclFSGetCwdProc2 *proc2; @@ -2480,10 +2667,13 @@ Tcl_FSGetCwd( if (retCd != NULL) { Tcl_Obj *norm; - /* Looks like a new current directory */ - retVal = (*fsRecPtr->fsPtr->internalToNormalizedProc)(retCd); + /* + * Looks like a new current directory. + */ + + retVal = fsRecPtr->fsPtr->internalToNormalizedProc(retCd); Tcl_IncrRefCount(retVal); - norm = TclFSNormalizeAbsolutePath(interp,retVal,NULL); + norm = TclFSNormalizeAbsolutePath(interp,retVal); if (norm != NULL) { /* * We found a cwd, which is now in our global storage. We @@ -2500,17 +2690,19 @@ Tcl_FSGetCwd( FsUpdateCwd(norm, retCd); Tcl_DecrRefCount(norm); } else { - (*fsRecPtr->fsPtr->freeInternalRepProc)(retCd); + fsRecPtr->fsPtr->freeInternalRepProc(retCd); } Tcl_DecrRefCount(retVal); retVal = NULL; + Disclaim(); goto cdDidNotChange; } else if (interp != NULL) { - Tcl_AppendResult(interp, - "error getting working directory name: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error getting working directory name: %s", + Tcl_PosixError(interp))); } } + Disclaim(); /* * Now the 'cwd' may NOT be normalized, at least on some platforms. @@ -2522,7 +2714,7 @@ Tcl_FSGetCwd( */ if (retVal != NULL) { - Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL); + Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal); if (norm != NULL) { /* @@ -2581,9 +2773,9 @@ Tcl_FSGetCwd( retCd = proc2(tsdPtr->cwdClientData); if (retCd == NULL && interp != NULL) { - Tcl_AppendResult(interp, - "error getting working directory name: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error getting working directory name: %s", + Tcl_PosixError(interp))); } if (retCd == tsdPtr->cwdClientData) { @@ -2612,7 +2804,7 @@ Tcl_FSGetCwd( * Normalize the path. */ - norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL); + norm = TclFSNormalizeAbsolutePath(interp, retVal); /* * Check whether cwd has changed from the value previously stored in @@ -2635,7 +2827,7 @@ Tcl_FSGetCwd( */ int len1, len2; - char *str1, *str2; + const char *str1, *str2; str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); str2 = Tcl_GetStringFromObj(norm, &len2); @@ -2720,7 +2912,7 @@ Tcl_FSChdir( * 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 + * an appropriate error code. */ if ((Tcl_FSStat(pathPtr, &buf) == 0) && (S_ISDIR(buf.st_mode)) @@ -2794,7 +2986,7 @@ Tcl_FSChdir( * instead. This should be examined by someone on Unix. */ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); ClientData cd; ClientData oldcd = tsdPtr->cwdClientData; @@ -2863,9 +3055,8 @@ Tcl_FSLoadFile( * function which should be used for this * file. */ { - const char *symbols[2]; - Tcl_PackageInitProc **procPtrs[2]; - ClientData clientData; + const char *symbols[3]; + void *procPtrs[2]; int res; /* @@ -2874,35 +3065,27 @@ Tcl_FSLoadFile( symbols[0] = sym1; symbols[1] = sym2; - procPtrs[0] = proc1Ptr; - procPtrs[1] = proc2Ptr; + symbols[2] = NULL; /* * Perform the load. */ - res = TclLoadFile(interp, pathPtr, 2, symbols, procPtrs, handlePtr, - &clientData, unloadProcPtr); - - /* - * Due to an unfortunate mis-design in Tcl 8.4 fs, when loading a shared - * library, we don't keep the loadHandle (for TclpFindSymbol) and the - * clientData (for the unloadProc) separately. In fact we effectively - * throw away the loadHandle and only use the clientData. It just so - * happens, for the native filesystem only, that these two are identical. - * - * This also means that the signatures Tcl_FSUnloadFileProc and - * Tcl_FSLoadFileProc are both misleading. - */ + 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; + } - *handlePtr = clientData; return res; } /* *---------------------------------------------------------------------- * - * TclLoadFile -- + * 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 @@ -2916,54 +3099,42 @@ Tcl_FSLoadFile( * filesystems (and has other problems documented in the load man-page), * so it is advised that full paths are always used. * - * This function is currently private to Tcl. It may be exported in the - * future and its interface fixed (but we should clean up the - * loadHandle/clientData confusion at that time -- see the above comments - * in Tcl_FSLoadFile for details). For a public function, see - * Tcl_FSLoadFile. - * * 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 - * passing the clientData to the unloadProc. + * calling TclFS_UnloadFile. * *---------------------------------------------------------------------- */ int -TclLoadFile( +Tcl_LoadFile( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Obj *pathPtr, /* Name of the file containing the desired * code. */ - int symc, /* Number of symbols/procPtrs in the next two - * arrays. */ - const char *symbols[], /* Names of functions to look up in the file's + const char *const symbols[],/* Names of functions to look up in the file's * symbol table. */ - Tcl_PackageInitProc **procPtrs[], - /* Where to return the addresses corresponding + int flags, /* Flags */ + void *procVPtrs, /* Where to return the addresses corresponding * to symbols[]. */ - Tcl_LoadHandle *handlePtr, /* Filled with token for shared library + Tcl_LoadHandle *handlePtr) /* Filled with token for shared library * information which can be used in * TclpFindSymbol. */ - 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. */ { + void **procPtrs = (void **) procVPtrs; const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - Tcl_Filesystem *copyFsPtr; + const Tcl_Filesystem *copyFsPtr; + Tcl_FSUnloadFileProc *unloadProcPtr; Tcl_Obj *copyToPtr; Tcl_LoadHandle newLoadHandle = NULL; - ClientData newClientData = NULL; + Tcl_LoadHandle divertedLoadHandle = NULL; Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL; FsDivertLoad *tvdlPtr; int retVal; + int i; if (fsPtr == NULL) { Tcl_SetErrno(ENOENT); @@ -2971,19 +3142,13 @@ TclLoadFile( } if (fsPtr->loadFileProc != NULL) { - int retVal = fsPtr->loadFileProc(interp, pathPtr, handlePtr, - unloadProcPtr); + int retVal = ((Tcl_FSLoadFileProc2 *)(fsPtr->loadFileProc)) + (interp, pathPtr, handlePtr, &unloadProcPtr, flags); if (retVal == TCL_OK) { if (*handlePtr == NULL) { return TCL_ERROR; } - - /* - * Copy this across, since both are equal for the native fs. - */ - - *clientDataPtr = *handlePtr; Tcl_ResetResult(interp); goto resolveSymbols; } @@ -3000,8 +3165,9 @@ TclLoadFile( */ if (Tcl_FSAccess(pathPtr, R_OK) != 0) { - Tcl_AppendResult(interp, "couldn't load library \"", - Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't load library \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -3043,26 +3209,23 @@ TclLoadFile( ret = Tcl_Read(data, buffer, size); Tcl_Close(interp, data); ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr, - unloadProcPtr); + &unloadProcPtr, flags); if (ret == TCL_OK && *handlePtr != NULL) { - *clientDataPtr = *handlePtr; goto resolveSymbols; } } mustCopyToTempAnyway: Tcl_ResetResult(interp); -#endif +#endif /* TCL_LOAD_FROM_MEMORY */ /* * Get a temporary filename to use, first to copy the file into, and then * to load. */ - copyToPtr = TclpTempFileName(); + copyToPtr = TclpTempFileNameForLibrary(interp, pathPtr); if (copyToPtr == NULL) { - Tcl_AppendResult(interp, "couldn't create temporary file: ", - Tcl_PosixError(interp), NULL); return TCL_ERROR; } Tcl_IncrRefCount(copyToPtr); @@ -3077,7 +3240,8 @@ TclLoadFile( Tcl_FSDeleteFile(copyToPtr); Tcl_DecrRefCount(copyToPtr); - Tcl_AppendResult(interp, "couldn't load from current filesystem",NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't load from current filesystem", -1)); return TCL_ERROR; } @@ -3091,7 +3255,7 @@ TclLoadFile( return TCL_ERROR; } -#if !defined(__WIN32__) +#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 @@ -3119,8 +3283,8 @@ TclLoadFile( Tcl_ResetResult(interp); - retVal = TclLoadFile(interp, copyToPtr, symc, symbols, procPtrs, - &newLoadHandle, &newClientData, &newUnloadProcPtr); + retVal = Tcl_LoadFile(interp, copyToPtr, symbols, flags, procPtrs, + &newLoadHandle); if (retVal != TCL_OK) { /* * The file didn't load successfully. @@ -3147,8 +3311,6 @@ TclLoadFile( */ *handlePtr = newLoadHandle; - *clientDataPtr = newClientData; - *unloadProcPtr = newUnloadProcPtr; Tcl_ResetResult(interp); return TCL_OK; } @@ -3158,7 +3320,7 @@ TclLoadFile( * unload and cleanup the temporary file correctly. */ - tvdlPtr = (FsDivertLoad *) ckalloc(sizeof(FsDivertLoad)); + tvdlPtr = ckalloc(sizeof(FsDivertLoad)); /* * Remember three pieces of information. This allows us to cleanup the @@ -3203,73 +3365,235 @@ TclLoadFile( } copyToPtr = NULL; - *handlePtr = newLoadHandle; - *clientDataPtr = tvdlPtr; - *unloadProcPtr = &FSUnloadTempFile; + + divertedLoadHandle = ckalloc(sizeof(struct Tcl_LoadHandle_)); + divertedLoadHandle->clientData = tvdlPtr; + divertedLoadHandle->findSymbolProcPtr = DivertFindSymbol; + divertedLoadHandle->unloadFileProcPtr = DivertUnloadFile; + *handlePtr = divertedLoadHandle; Tcl_ResetResult(interp); return retVal; resolveSymbols: - { - int i; + /* + * At this point, *handlePtr is already set up to the handle for the + * loaded library. We now try to resolve the symbols. + */ - for (i=0 ; i<symc ; i++) { - if (symbols[i] != NULL) { - *procPtrs[i] = TclpFindSymbol(interp, *handlePtr, symbols[i]); + 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.) + */ + + (*handlePtr)->unloadFileProcPtr(*handlePtr); + *handlePtr = NULL; + return TCL_ERROR; } } } 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( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Obj *pathPtr, /* Name of the file containing the desired - * code (UTF-8). */ - const char *sym1, const char *sym2, - /* Names of two functions to look up in the - * file's symbol table. */ - Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr, - /* 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; + 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 + * + *---------------------------------------------------------------------- + */ - res = TclpDlopen(interp, pathPtr, &handle, unloadProcPtr); +static void +DivertUnloadFile( + Tcl_LoadHandle loadHandle) +{ + FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle->clientData; + Tcl_LoadHandle originalHandle; - if (res != TCL_OK) { - return res; + /* + * This test should never trigger, since we give the client data in the + * function above. + */ + + if (tvdlPtr == NULL) { + return; } + originalHandle = tvdlPtr->loadHandle; - if (handle == NULL) { - return TCL_ERROR; + /* + * Call the real 'unloadfile' proc we actually used. It is very important + * that we call this first, so that the shared library is actually + * unloaded by the OS. Otherwise, the following 'delete' may well fail + * because the shared library is still in use. + */ + + originalHandle->unloadFileProcPtr(originalHandle); + + /* + * What filesystem contains the temp copy of the library? + */ + + if (tvdlPtr->divertedFilesystem == NULL) { + /* + * It was the native filesystem, and we have a special function + * available just for this purpose, which we know works even at this + * late stage. + */ + + TclpDeleteFile(tvdlPtr->divertedFileNativeRep); + NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep); + } else { + /* + * Remove the temporary file we created. Note, we may crash here + * because encodings have been taken down already. + */ + + if (tvdlPtr->divertedFilesystem->deleteFileProc(tvdlPtr->divertedFile) + != TCL_OK) { + /* + * The above may have failed because the filesystem, or something + * it depends upon (e.g. encodings) have been taken down because + * Tcl is exiting. + * + * We may need to work out how to delete this file more robustly + * (or give the filesystem the information it needs to delete the + * file more robustly). + * + * In particular, one problem might be that the filesystem cannot + * extract the information it needs from the above path object + * because Tcl's entire filesystem apparatus (the code in this + * file) has been finalized, and it refuses to pass the internal + * representation to the filesystem. + */ + } + + /* + * And free up the allocations. This will also of course remove a + * refCount from the Tcl_Filesystem to which this file belongs, which + * could then free up the filesystem if we are exiting. + */ + + Tcl_DecrRefCount(tvdlPtr->divertedFile); } - *clientDataPtr = handle; + 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. + * + *---------------------------------------------------------------------- + */ - *proc1Ptr = TclpFindSymbol(interp, handle, sym1); - *proc2Ptr = TclpFindSymbol(interp, handle, sym2); +int +Tcl_FSUnloadFile( + Tcl_Interp *interp, /* Tcl interpreter */ + Tcl_LoadHandle handle) /* Handle of the file to unload */ +{ + if (handle->unloadFileProcPtr == NULL) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot unload: filesystem does not support unloading", + -1)); + } + return TCL_ERROR; + } + TclpUnloadFile(handle); return TCL_OK; } /* - *--------------------------------------------------------------------------- + *---------------------------------------------------------------------- + * + * TclpUnloadFile -- * - * FSUnloadTempFile -- + * 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 @@ -3282,11 +3606,11 @@ TclpLoadFile( * The effects of the 'unload' function called, and of course the * temporary file will be deleted. * - *--------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -static void -FSUnloadTempFile( +void +TclFSUnloadTempFile( Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to * Tcl_FSLoadFile(). The loadHandle is a token * that represents the loaded file. */ @@ -3310,7 +3634,7 @@ FSUnloadTempFile( */ if (tvdlPtr->unloadProcPtr != NULL) { - (*tvdlPtr->unloadProcPtr)(tvdlPtr->loadHandle); + tvdlPtr->unloadProcPtr(tvdlPtr->loadHandle); } if (tvdlPtr->divertedFilesystem == NULL) { @@ -3356,7 +3680,7 @@ FSUnloadTempFile( Tcl_DecrRefCount(tvdlPtr->divertedFile); } - ckfree((char *) tvdlPtr); + ckfree(tvdlPtr); } /* @@ -3394,9 +3718,9 @@ FSUnloadTempFile( Tcl_Obj * Tcl_FSLink( - Tcl_Obj *pathPtr, /* Path of file to readlink or link */ - Tcl_Obj *toPtr, /* NULL or path to be linked to */ - int linkAction) /* Action to perform */ + Tcl_Obj *pathPtr, /* Path of file to readlink or link. */ + Tcl_Obj *toPtr, /* NULL or path to be linked to. */ + int linkAction) /* Action to perform. */ { const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); @@ -3459,6 +3783,7 @@ Tcl_FSListVolumes(void) */ fsRecPtr = FsGetFirstFilesystem(); + Claim(); while (fsRecPtr != NULL) { if (fsRecPtr->fsPtr->listVolumesProc != NULL) { Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc(); @@ -3470,6 +3795,7 @@ Tcl_FSListVolumes(void) } fsRecPtr = fsRecPtr->nextPtr; } + Disclaim(); return resultPtr; } @@ -3509,6 +3835,7 @@ FsListMounts( */ fsRecPtr = FsGetFirstFilesystem(); + Claim(); while (fsRecPtr != NULL) { if (fsRecPtr->fsPtr != &tclNativeFilesystem && fsRecPtr->fsPtr->matchInDirectoryProc != NULL) { @@ -3520,6 +3847,7 @@ FsListMounts( } fsRecPtr = fsRecPtr->nextPtr; } + Disclaim(); return resultPtr; } @@ -3550,10 +3878,10 @@ Tcl_FSSplitPath( int *lenPtr) /* int to store number of path elements. */ { Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */ - Tcl_Filesystem *fsPtr; + const Tcl_Filesystem *fsPtr; char separator = '/'; int driveNameLength; - char *p; + const char *p; /* * Perform platform specific splitting. @@ -3573,7 +3901,7 @@ Tcl_FSSplitPath( */ if (fsPtr->filesystemSeparatorProc != NULL) { - Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(pathPtr); + Tcl_Obj *sep = fsPtr->filesystemSeparatorProc(pathPtr); if (sep != NULL) { Tcl_IncrRefCount(sep); @@ -3599,7 +3927,7 @@ Tcl_FSSplitPath( */ for (;;) { - char *elementStart = p; + const char *elementStart = p; int length; while ((*p != '\0') && (*p != separator)) { @@ -3631,31 +3959,6 @@ Tcl_FSSplitPath( } return result; } - -/* Simple helper function */ -Tcl_Obj * -TclFSInternalToNormalized( - Tcl_Filesystem *fromFilesystem, - ClientData clientData, - FilesystemRecord **fsRecPtrPtr) -{ - FilesystemRecord *fsRecPtr = FsGetFirstFilesystem(); - - while (fsRecPtr != NULL) { - if (fsRecPtr->fsPtr == fromFilesystem) { - *fsRecPtrPtr = fsRecPtr; - break; - } - fsRecPtr = fsRecPtr->nextPtr; - } - - if ((fsRecPtr == NULL) - || (fromFilesystem->internalToNormalizedProc == NULL)) { - return NULL; - } - return (*fromFilesystem->internalToNormalizedProc)(clientData); -} - /* *---------------------------------------------------------------------- * @@ -3677,8 +3980,8 @@ TclFSInternalToNormalized( Tcl_PathType TclGetPathType( - Tcl_Obj *pathPtr, /* Path to determine type for */ - Tcl_Filesystem **filesystemPtrPtr, + 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. */ @@ -3692,7 +3995,7 @@ TclGetPathType( * caller. */ { int pathLen; - char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); + const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); Tcl_PathType type; type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, @@ -3732,9 +4035,9 @@ TclGetPathType( Tcl_PathType TclFSNonnativePathType( - const char *path, /* Path to determine type for */ - int pathLen, /* Length of the path */ - Tcl_Filesystem **filesystemPtrPtr, + 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. */ @@ -3757,24 +4060,24 @@ TclFSNonnativePathType( */ fsRecPtr = FsGetFirstFilesystem(); + Claim(); while (fsRecPtr != NULL) { /* * We want to skip the native filesystem in this loop because - * otherwise we won't necessarily pass all the Tcl testsuite -- this - * is because some of the tests artificially change the current - * platform (between win, unix) but the list of volumes we get by - * calling fsRecPtr->fsPtr->listVolumesProc will reflect the current - * (real) platform only and this may cause some tests to fail. In - * particular, on Unix '/' will match the beginning of certain - * absolute Windows paths starting '//' and those tests will go wrong. + * 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. + * 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) @@ -3800,7 +4103,7 @@ TclFSNonnativePathType( while (numVolumes > 0) { Tcl_Obj *vol; int len; - char *strVol; + const char *strVol; numVolumes--; Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol); @@ -3835,6 +4138,7 @@ TclFSNonnativePathType( } fsRecPtr = fsRecPtr->nextPtr; } + Disclaim(); return type; } @@ -3941,7 +4245,7 @@ Tcl_FSCopyFile( int TclCrossFilesystemCopy( - Tcl_Interp *interp, /* For error messages */ + 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). */ { @@ -4131,44 +4435,45 @@ Tcl_FSRemoveDirectory( { const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL && fsPtr->removeDirectoryProc != NULL) { - if (recursive) { - /* - * We check whether the cwd lies inside this directory and move it - * if it does. - */ + if (fsPtr == NULL || fsPtr->removeDirectoryProc == NULL) { + Tcl_SetErrno(ENOENT); + return -1; + } - Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL); + /* + * When working recursively, we check whether the cwd lies inside this + * directory and move it if it does. + */ - if (cwdPtr != NULL) { - char *cwdStr, *normPathStr; - int cwdLen, normLen; - Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (recursive) { + Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL); - 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]'. - */ + if (cwdPtr != NULL) { + const char *cwdStr, *normPathStr; + int cwdLen, normLen; + Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); - Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr, - TCL_PATH_DIRNAME); + 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_FSChdir(dirPtr); - Tcl_DecrRefCount(dirPtr); - } + Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr, + TCL_PATH_DIRNAME); + + Tcl_FSChdir(dirPtr); + Tcl_DecrRefCount(dirPtr); } - Tcl_DecrRefCount(cwdPtr); } + Tcl_DecrRefCount(cwdPtr); } - return fsPtr->removeDirectoryProc(pathPtr, recursive, errorPtr); } - Tcl_SetErrno(ENOENT); - return -1; + return fsPtr->removeDirectoryProc(pathPtr, recursive, errorPtr); } /* @@ -4190,12 +4495,12 @@ Tcl_FSRemoveDirectory( *--------------------------------------------------------------------------- */ -Tcl_Filesystem * +const Tcl_Filesystem * Tcl_FSGetFileSystemForPath( Tcl_Obj *pathPtr) { FilesystemRecord *fsRecPtr; - Tcl_Filesystem *retVal = NULL; + const Tcl_Filesystem *retVal = NULL; if (pathPtr == NULL) { Tcl_Panic("Tcl_FSGetFileSystemForPath called with NULL object"); @@ -4221,10 +4526,14 @@ Tcl_FSGetFileSystemForPath( */ fsRecPtr = FsGetFirstFilesystem(); + Claim(); + if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) { + Disclaim(); return NULL; } else if (retVal != NULL) { /* TODO: Can this happen? */ + Disclaim(); return retVal; } @@ -4246,10 +4555,12 @@ Tcl_FSGetFileSystemForPath( * call to the pathInFilesystemProc. */ - TclFSSetPathDetails(pathPtr, fsRecPtr, clientData); + TclFSSetPathDetails(pathPtr, fsRecPtr->fsPtr, clientData); + Disclaim(); return fsRecPtr->fsPtr; } } + Disclaim(); return NULL; } @@ -4269,7 +4580,7 @@ Tcl_FSGetFileSystemForPath( * 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 desireable to have separate versions + * 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. @@ -4283,11 +4594,11 @@ Tcl_FSGetFileSystemForPath( *--------------------------------------------------------------------------- */ -const char * +const void * Tcl_FSGetNativePath( Tcl_Obj *pathPtr) { - return (const char *) Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem); + return Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem); } /* @@ -4310,7 +4621,7 @@ static void NativeFreeInternalRep( ClientData clientData) { - ckfree((char *) clientData); + ckfree(clientData); } /* @@ -4381,23 +4692,23 @@ Tcl_FSPathSeparator( Tcl_Obj *pathPtr) { const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + Tcl_Obj *resultObj; if (fsPtr == NULL) { return NULL; } + if (fsPtr->filesystemSeparatorProc != NULL) { - return (*fsPtr->filesystemSeparatorProc)(pathPtr); - } else { - Tcl_Obj *resultObj; + return fsPtr->filesystemSeparatorProc(pathPtr); + } - /* - * Allow filesystems not to provide a filesystemSeparatorProc if they - * wish to use the standard forward slash. - */ + /* + * Allow filesystems not to provide a filesystemSeparatorProc if they wish + * to use the standard forward slash. + */ - TclNewLiteralStringObj(resultObj, "/"); - return resultObj; - } + TclNewLiteralStringObj(resultObj, "/"); + return resultObj; } /* @@ -4422,6 +4733,7 @@ NativeFilesystemSeparator( Tcl_Obj *pathPtr) { const char *separator = NULL; /* lint */ + switch (tclPlatform) { case TCL_PLATFORM_UNIX: separator = "/"; @@ -4432,7 +4744,6 @@ NativeFilesystemSeparator( } return Tcl_NewStringObj(separator,1); } - /* * Local Variables: |