diff options
Diffstat (limited to 'generic/tclIOUtil.c')
| -rw-r--r-- | generic/tclIOUtil.c | 3994 |
1 files changed, 1930 insertions, 2064 deletions
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 43b8b31..f624cb7 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -5,7 +5,7 @@ * 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. + * 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. @@ -16,55 +16,248 @@ * * 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.121 2005/07/17 22:04:50 dkf Exp $ */ #include "tclInt.h" -#ifdef __WIN32__ +#ifdef _WIN32 # include "tclWinInt.h" #endif #include "tclFileSystem.h" /* - * Prototypes for procedures defined later in this file. + * struct FilesystemRecord -- + * + * A filesystem record is used to keep track of each filesystem currently + * registered with the core, in a linked list. */ -static FilesystemRecord * FsGetFirstFilesystem _ANSI_ARGS_((void)); -static void FsThrExitProc _ANSI_ARGS_((ClientData cd)); -static Tcl_Obj* FsListMounts _ANSI_ARGS_((Tcl_Obj *pathPtr, - CONST char *pattern)); -static void FsAddMountsToGlobResult _ANSI_ARGS_(( - Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, - CONST char *pattern, - Tcl_GlobTypeData *types)); -static void FsUpdateCwd _ANSI_ARGS_((Tcl_Obj *cwdObj, - ClientData clientData)); - -#ifdef TCL_THREADS -static void FsRecacheFilesystemList(void); -#endif +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); +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 + * 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. + * 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. + */ + +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. */ -extern CONST char * tclpFileAttrStrings[]; -extern CONST TclFileAttrProcs tclpFileAttrProcs[]; +static Tcl_Obj *cwdPathPtr = NULL; +static int cwdPathEpoch = 0; +static ClientData cwdClientData = NULL; +TCL_DECLARE_MUTEX(cwdMutex) + +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; @@ -75,31 +268,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; } @@ -111,7 +310,7 @@ Tcl_Stat(path, oldStyleBuf) /* * 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 + * 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. */ @@ -127,9 +326,15 @@ Tcl_Stat(path, oldStyleBuf) 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; @@ -137,9 +342,9 @@ 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); @@ -153,13 +358,13 @@ Tcl_Access(path, mode) /* Obsolete */ Tcl_Channel -Tcl_OpenFileChannel(interp, path, modeString, permissions) - Tcl_Interp *interp; /* Interpreter for error reporting; can be +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 + 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 + int permissions) /* If the open involves creating a file, with * what modes to create it? */ { Tcl_Channel ret; @@ -174,8 +379,8 @@ Tcl_OpenFileChannel(interp, path, modeString, permissions) /* Obsolete */ int -Tcl_Chdir(dirName) - CONST char *dirName; +Tcl_Chdir( + const char *dirName) { int ret; Tcl_Obj *pathPtr = Tcl_NewStringObj(dirName,-1); @@ -187,31 +392,31 @@ 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); @@ -219,239 +424,14 @@ Tcl_EvalFile(interp, fileName) } /* - * 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; -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; - Tcl_Filesystem *divertedFilesystem; - ClientData divertedFileNativeRep; -} FsDivertLoad; - -/* - * Now move on to the basic filesystem implementation + * 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; /* @@ -460,6 +440,7 @@ FsThrExitProc(cd) if (tsdPtr->cwdPathPtr != NULL) { Tcl_DecrRefCount(tsdPtr->cwdPathPtr); + tsdPtr->cwdPathPtr = NULL; } if (tsdPtr->cwdClientData != NULL) { NativeFreeInternalRep(tsdPtr->cwdClientData); @@ -472,17 +453,18 @@ FsThrExitProc(cd) 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() +TclFSCwdIsNative(void) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); if (tsdPtr->cwdClientData != NULL) { return 1; @@ -504,7 +486,7 @@ TclFSCwdIsNative() * * 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 + * 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). @@ -513,10 +495,10 @@ TclFSCwdIsNative() */ int -TclFSCwdPointerEquals(pathPtrPtr) - Tcl_Obj** pathPtrPtr; +TclFSCwdPointerEquals( + Tcl_Obj **pathPtrPtr) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); Tcl_MutexLock(&cwdMutex); if (tsdPtr->cwdPathPtr == NULL @@ -543,7 +525,7 @@ TclFSCwdPointerEquals(pathPtrPtr) Tcl_MutexUnlock(&cwdMutex); if (tsdPtr->initialized == 0) { - Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr); + Tcl_CreateThreadExitHandler(FsThrExitProc, tsdPtr); tsdPtr->initialized = 1; } @@ -555,13 +537,13 @@ TclFSCwdPointerEquals(pathPtrPtr) return 1; } else { int len1, len2; - CONST char *str1, *str2; + const char *str1, *str2; 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 + * They are equal, but different objects. Update so they will be * the same object in the future. */ @@ -575,12 +557,11 @@ TclFSCwdPointerEquals(pathPtrPtr) } } -#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. @@ -589,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 proceede. - * * Locate tail of the global filesystem list. */ + Tcl_MutexLock(&filesystemMutex); fsRecPtr = filesystemList; while (fsRecPtr != NULL) { tmpFsRecPtr = fsRecPtr; @@ -613,48 +590,46 @@ 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. */ if (tsdPtr->initialized == 0) { - Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr); + Tcl_CreateThreadExitHandler(FsThrExitProc, tsdPtr); 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)) { +FsGetFirstFilesystem(void) +{ + 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; } /* @@ -663,26 +638,49 @@ FsGetFirstFilesystem(void) { */ int -TclFSEpochOk(filesystemEpoch) - int filesystemEpoch; +TclFSEpochOk( + int filesystemEpoch) +{ + return (filesystemEpoch == 0 || filesystemEpoch == theFilesystemEpoch); +} + +static void +Claim(void) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - (void) FsGetFirstFilesystem(); - return (filesystemEpoch == tsdPtr->filesystemEpoch); + 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. */ static void -FsUpdateCwd(cwdObj, clientData) - Tcl_Obj *cwdObj; - ClientData clientData; +FsUpdateCwd( + Tcl_Obj *cwdObj, + 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); @@ -705,7 +703,7 @@ FsUpdateCwd(cwdObj, clientData) */ cwdPathPtr = Tcl_NewStringObj(str, len); - Tcl_IncrRefCount(cwdPathPtr); + Tcl_IncrRefCount(cwdPathPtr); cwdClientData = TclNativeDupInternalRep(clientData); } @@ -735,8 +733,8 @@ FsUpdateCwd(cwdObj, clientData) * * TclFinalizeFilesystem -- * - * Clean up the filesystem. After this, calls to all Tcl_FS... - * functions will fail. + * 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. @@ -751,12 +749,12 @@ FsUpdateCwd(cwdObj, clientData) */ void -TclFinalizeFilesystem() +TclFinalizeFilesystem(void) { FilesystemRecord *fsRecPtr; /* - * Assumption that only one thread is active now. Otherwise we would need + * Assumption that only one thread is active now. Otherwise we would need * to put various mutexes around this code. */ @@ -772,23 +770,21 @@ TclFinalizeFilesystem() /* * 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. - */ - if (fsRecPtr != &nativeFilesystemRecord) { - ckfree((char *)fsRecPtr); - } + /* The native filesystem is static, so we don't free it. */ + + if (fsRecPtr != &nativeFilesystemRecord) { + ckfree(fsRecPtr); } fsRecPtr = tmpFsRecPtr; } + theFilesystemEpoch++; filesystemList = NULL; /* @@ -796,10 +792,7 @@ TclFinalizeFilesystem() * filesystem is likely to fail. */ - statProcList = NULL; - accessProcList = NULL; - openFileChannelProcList = NULL; -#ifdef __WIN32__ +#ifdef _WIN32 TclWinEncodingsCleanup(); #endif } @@ -821,16 +814,12 @@ TclFinalizeFilesystem() */ void -TclResetFilesystem() +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. @@ -851,7 +840,7 @@ TclResetFilesystem() * 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 + * 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. @@ -871,9 +860,9 @@ TclResetFilesystem() */ 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; @@ -881,23 +870,16 @@ 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 + * 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 + * 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. @@ -932,14 +914,14 @@ 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 + * 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 + * TCL_OK if the function pointer was successfully removed, TCL_ERROR * otherwise. * * Side effects: @@ -951,8 +933,8 @@ Tcl_FSRegister(clientData, fsPtr) */ 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; @@ -979,7 +961,7 @@ Tcl_FSUnregister(fsPtr) /* * Increment the filesystem epoch counter, since existing paths - * might conceivably now belong to different filesystems. This + * 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). @@ -987,10 +969,7 @@ Tcl_FSUnregister(fsPtr) theFilesystemEpoch++; - fsRecPtr->fileRefCount--; - if (fsRecPtr->fileRefCount <= 0) { - ckfree((char *)fsRecPtr); - } + ckfree(fsRecPtr); retVal = TCL_OK; } else { @@ -1008,17 +987,17 @@ 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 + * 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 + * 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. + * 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 @@ -1027,14 +1006,14 @@ Tcl_FSUnregister(fsPtr) * Results: * * The return value is a standard Tcl result indicating whether an error - * occurred in globbing. Error messages are placed in interp, but good + * 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 + * parameter. This means the actual filesystem only ever sees patterns * which match in a single directory. * * Side effects: @@ -1044,25 +1023,26 @@ Tcl_FSUnregister(fsPtr) */ int -Tcl_FSMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) - Tcl_Interp *interp; /* Interpreter to receive error messages. */ - Tcl_Obj *resultPtr; /* List object to receive results. */ - Tcl_Obj *pathPtr; /* Contains path to directory to search. */ - CONST char *pattern; /* Pattern to match against. */ - Tcl_GlobTypeData *types; /* Object containing list of acceptable types. +Tcl_FSMatchInDirectory( + 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; + const Tcl_Filesystem *fsPtr; Tcl_Obj *cwd, *tmpResultPtr, **elemsPtr; int resLength, i, ret = -1; - if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) { + 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. + * recursively by ourself. Return no matches. */ return TCL_OK; @@ -1084,8 +1064,8 @@ Tcl_FSMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) 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); } @@ -1094,7 +1074,7 @@ Tcl_FSMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) /* * 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') { @@ -1115,8 +1095,9 @@ Tcl_FSMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) 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; } @@ -1125,8 +1106,8 @@ Tcl_FSMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) 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); @@ -1153,7 +1134,7 @@ Tcl_FSMatchInDirectory(interp, resultPtr, 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 + * directory listing and add any mounted paths to that listing. This is * required so that simple things like 'glob *' merge mounts and listings * correctly. * @@ -1167,12 +1148,12 @@ Tcl_FSMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) */ static void -FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types) - Tcl_Obj *resultPtr; /* The current list of matching paths; must +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. + 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. */ { @@ -1211,13 +1192,12 @@ FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types) Tcl_ListObjReplace(NULL, resultPtr, j, 1, 0, NULL); gLength--; } - break; /* Break out of for loop */ + break; /* Break out of for loop. */ } } if (!found && dir) { + Tcl_Obj *norm; int len, mlen; - CONST char *path; - CONST char *mount; /* * We know mElt is absolute normalized and lies inside pathPtr, so @@ -1225,19 +1205,23 @@ FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types) * i.e. the representation which is relative to pathPtr. */ - mount = Tcl_GetStringFromObj(mElt, &mlen); - path = Tcl_GetStringFromObj(Tcl_FSGetNormalizedPath(NULL, pathPtr), - &len); - if (path[len-1] == '/') { - /* - * Deal with the root of the volume. - */ + norm = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (norm != NULL) { + const char *path, *mount; - len--; - } - mElt = TclNewFSPathObj(pathPtr, mount + len + 1, mlen - len); - Tcl_ListObjAppendElement(NULL, resultPtr, mElt); + mount = Tcl_GetStringFromObj(mElt, &mlen); + path = Tcl_GetStringFromObj(norm, &len); + if (path[len-1] == '/') { + /* + * Deal with the root of the volume. + */ + len--; + } + len++; /* account for '/' in the mElt [Bug 1602539] */ + mElt = TclNewFSPathObj(pathPtr, mount + len, mlen - len); + Tcl_ListObjAppendElement(NULL, resultPtr, mElt); + } /* * No need to increment gLength, since we don't want to compare * mounts against mounts. @@ -1267,7 +1251,7 @@ FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types) * 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 + * (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 @@ -1297,11 +1281,11 @@ FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types) */ 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 + * 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. */ @@ -1327,7 +1311,7 @@ Tcl_FSMountsChanged(fsPtr) * that filesystem is not registered. * * Results: - * A clientData value, or NULL. Note that if the filesystem was + * A clientData value, or NULL. Note that if the filesystem was * registered with a NULL clientData field, this function will return * that NULL value. * @@ -1338,14 +1322,14 @@ Tcl_FSMountsChanged(fsPtr) */ 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 list of filesystems look for a particular one. If found, + * Traverse the list of filesystems look for a particular one. If found, * return that filesystem's clientData (originally provided when calling * Tcl_FSRegister). */ @@ -1366,13 +1350,13 @@ Tcl_FSData(fsPtr) * TclFSNormalizeToUniquePath -- * * Takes a path specification containing no ../, ./ sequences, and - * converts it into a unique path for the given platform. On Unix, this + * 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 pathPtr is modified in place. The return value is the last byte + * The pathPtr is modified in place. The return value is the last byte * offset which was recognised in the path string. * * Side effects: @@ -1381,7 +1365,7 @@ Tcl_FSData(fsPtr) * 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. + * 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 @@ -1391,59 +1375,61 @@ Tcl_FSData(fsPtr) */ int -TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr) - 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. */ +TclFSNormalizeToUniquePath( + Tcl_Interp *interp, /* Used for error messages. */ + 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 * 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 + * 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; + Claim(); + for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) { + if (fsRecPtr->fsPtr != &tclNativeFilesystem) { + continue; } - fsRecPtr = fsRecPtr->nextPtr; + + /* + * TODO: Assume that we always find the native file system; it should + * always be there... + */ + + if (fsRecPtr->fsPtr->normalizePathProc != NULL) { + startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr, + startAt); + } + break; } - fsRecPtr = firstFsRecPtr; - while (fsRecPtr != NULL) { + for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) { /* * Skip the native system next time through. */ - if (fsRecPtr != &nativeFilesystemRecord) { - Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc; - if (proc != NULL) { - startAt = (*proc)(interp, pathPtr, startAt); - } + if (fsRecPtr->fsPtr == &tclNativeFilesystem) { + continue; + } - /* - * We could add an efficiency check like this: - * if (retVal == length-of(pathPtr)) {break;} - * but there's not much benefit. - */ + if (fsRecPtr->fsPtr->normalizePathProc != NULL) { + startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr, + startAt); } - fsRecPtr = fsRecPtr->nextPtr; + + /* + * We could add an efficiency check like this: + * if (retVal == length-of(pathPtr)) {break;} + * but there's not much benefit. + */ } + Disclaim(); return startAt; } @@ -1454,7 +1440,7 @@ TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr) * TclGetOpenMode -- * * This routine is an obsolete, limited version of TclGetOpenModeEx() - * below. It exists only to satisfy any extensions imprudently using it + * below. It exists only to satisfy any extensions imprudently using it * via Tcl's internal stubs table. * * Results: @@ -1467,14 +1453,12 @@ TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr) */ int -TclGetOpenMode(interp, modeString, seekFlagPtr) - 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. */ +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. */ { int binary = 0; return TclGetOpenModeEx(interp, modeString, seekFlagPtr, &binary); @@ -1497,7 +1481,7 @@ TclGetOpenMode(interp, modeString, seekFlagPtr) * * Side effects: * Sets the integer referenced by seekFlagPtr to 1 to tell the caller to - * seek to EOF after opening the file, or to 0 otherwise. Sets the + * 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. * @@ -1509,24 +1493,22 @@ TclGetOpenMode(interp, modeString, seekFlagPtr) */ int -TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr) - 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 */ +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 + * 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. */ @@ -1550,27 +1532,30 @@ TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr) mode = O_WRONLY|O_CREAT|O_TRUNC; break; case 'a': - mode = O_WRONLY|O_CREAT; + /* + * 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: - error: - *seekFlagPtr = 0; - *binaryPtr = 0; - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "illegal access mode \"", modeString, - "\"", (char *) NULL); - } - return -1; + goto error; } - i=1; + i = 1; while (i<3 && modeString[i]) { if (modeString[i] == modeString[i-1]) { goto error; } switch (modeString[i++]) { case '+': - mode &= ~(O_RDONLY|O_WRONLY); + /* + * 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 'b': @@ -1584,6 +1569,15 @@ TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr) goto error; } return mode; + + error: + *seekFlagPtr = 0; + *binaryPtr = 0; + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "illegal access mode \"%s\"", modeString)); + } + return -1; } /* @@ -1595,7 +1589,7 @@ TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr) */ if (Tcl_SplitList(interp, modeString, &modeArgc, &modeArgv) != TCL_OK) { - if (interp != (Tcl_Interp *) NULL) { + if (interp != NULL) { Tcl_AddErrorInfo(interp, "\n while processing open access modes \""); Tcl_AddErrorInfo(interp, modeString); @@ -1629,28 +1623,25 @@ TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr) #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); + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "access mode \"%s\" not supported by this system", + flag)); } - ckfree((char *) modeArgv); + 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); + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "access mode \"%s\" not supported by this system", + flag)); } - ckfree((char *) modeArgv); + ckfree(modeArgv); return -1; #endif @@ -1660,23 +1651,24 @@ TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr) *binaryPtr = 1; } else { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "invalid access mode \"", flag, - "\": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, " - "CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC", - (char *) NULL); + 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((char *) modeArgv); + 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; } @@ -1684,32 +1676,20 @@ TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr) } /* - * Tcl_FSEvalFile is Tcl_FSEvalFileEx without encoding argument. - */ - -int -Tcl_FSEvalFile(interp, pathPtr) - Tcl_Interp *interp; /* Interpreter in which to process file. */ - Tcl_Obj *pathPtr; /* Path of file to process. Tilde-substitution - * will be performed on this name. */ -{ - 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 * 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 + * 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). * @@ -1717,53 +1697,58 @@ Tcl_FSEvalFile(interp, pathPtr) */ int -Tcl_FSEvalFileEx(interp, pathPtr, encodingName) - 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. */ - CONST char *encodingName; /* If non-NULL, then use this encoding for the - * file. */ { - int result, length; + 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 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_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 the encoding is specified, set it for the channel. Else don't touch + * 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. */ @@ -1771,15 +1756,38 @@ Tcl_FSEvalFileEx(interp, pathPtr, encodingName) if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) != TCL_OK) { Tcl_Close(interp,chan); - goto end; + return result; } } - if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) { + 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_AppendResult(interp, "couldn't read file \"", - Tcl_GetString(pathPtr), - "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read file \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); goto end; } @@ -1792,7 +1800,13 @@ Tcl_FSEvalFileEx(interp, pathPtr, encodingName) iPtr->scriptFile = pathPtr; Tcl_IncrRefCount(iPtr->scriptFile); string = Tcl_GetStringFromObj(objPtr, &length); - result = Tcl_EvalEx(interp, string, length, 0); + + /* + * 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 @@ -1812,24 +1826,170 @@ Tcl_FSEvalFileEx(interp, pathPtr, encodingName) * Record information telling where the error occurred. */ - Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine); - Tcl_Obj *msg = Tcl_NewStringObj("\n (file \"", -1); - CONST char *pathString = Tcl_GetStringFromObj(pathPtr, &length); - Tcl_IncrRefCount(msg); - Tcl_IncrRefCount(errorLine); - TclAppendLimitedToObj(msg, pathString, length, 150, ""); - Tcl_AppendToObj(msg, "\" line ", -1); - Tcl_AppendObjToObj(msg, errorLine); - Tcl_DecrRefCount(errorLine); - Tcl_AppendToObj(msg, ")", -1); - TclAppendObjToErrorInfo(interp, msg); - Tcl_DecrRefCount(msg); + const char *pathString = Tcl_GetStringFromObj(pathPtr, &length); + int limit = 150; + int overflow = (length > limit); + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (file \"%.*s%s\" line %d)", + (overflow ? limit : length), pathString, + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } end: Tcl_DecrRefCount(objPtr); return result; } + +int +TclNREvalFile( + Tcl_Interp *interp, /* Interpreter in which to process file. */ + Tcl_Obj *pathPtr, /* Path of file to process. Tilde-substitution + * will be performed on this name. */ + const char *encodingName) /* If non-NULL, then use this encoding for the + * file. NULL means use the system encoding. */ +{ + Tcl_StatBuf statBuf; + Tcl_Obj *oldScriptFile, *objPtr; + Interp *iPtr; + Tcl_Channel chan; + const char *string; + + if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { + return TCL_ERROR; + } + + if (Tcl_FSStat(pathPtr, &statBuf) == -1) { + Tcl_SetErrno(errno); + Tcl_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; +} /* *---------------------------------------------------------------------- @@ -1851,8 +2011,13 @@ Tcl_FSEvalFileEx(interp, pathPtr, encodingName) */ int -Tcl_GetErrno() +Tcl_GetErrno(void) { + /* + * On some platforms, errno is really a thread local (implemented by the C + * library). + */ + return errno; } @@ -1861,7 +2026,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. @@ -1873,9 +2040,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; } @@ -1884,8 +2056,8 @@ 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 + * 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. * @@ -1898,16 +2070,18 @@ Tcl_SetErrno(err) *---------------------------------------------------------------------- */ -CONST char * -Tcl_PosixError(interp) - Tcl_Interp *interp; /* Interpreter whose errorCode field - * is to be set. */ +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; } @@ -1916,7 +2090,7 @@ Tcl_PosixError(interp) * * Tcl_FSStat -- * - * This procedure replaces the library version of stat and lsat. + * This function replaces the library version of stat and lsat. * * The appropriate function for the filesystem to which pathPtr belongs * will be called. @@ -1931,74 +2105,14 @@ Tcl_PosixError(interp) */ 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. - */ - - 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.) - */ + const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - 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; @@ -2009,7 +2123,7 @@ Tcl_FSStat(pathPtr, buf) * * Tcl_FSLstat -- * - * This procedure replaces the library version of lstat. The appropriate + * 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. @@ -2024,20 +2138,18 @@ Tcl_FSStat(pathPtr, buf) */ 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); @@ -2049,9 +2161,8 @@ 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. @@ -2063,55 +2174,15 @@ Tcl_FSLstat(pathPtr, buf) */ 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. - */ - - Tcl_MutexLock(&obsoleteFsHookMutex); + const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (accessProcList != NULL) { - AccessProc *accessProcPtr; - char *path; - Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); - if (transPtr == NULL) { - path = NULL; - } else { - path = Tcl_GetString(transPtr); - } - - accessProcPtr = accessProcList; - while ((retVal == -1) && (accessProcPtr != NULL)) { - retVal = (*accessProcPtr->proc)(path, mode); - accessProcPtr = accessProcPtr->nextPtr; - } - if (transPtr != NULL) { - Tcl_DecrRefCount(transPtr); - } - } - - Tcl_MutexUnlock(&obsoleteFsHookMutex); - if (retVal != -1) { - return retVal; - } -#endif /* USE_OBSOLETE_FS_HOOKS */ - - fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL) { - Tcl_FSAccessProc *proc = fsPtr->accessProc; - if (proc != NULL) { - return (*proc)(pathPtr, mode); - } + if (fsPtr != NULL && fsPtr->accessProc != NULL) { + return fsPtr->accessProc(pathPtr, mode); } - Tcl_SetErrno(ENOENT); return -1; } @@ -2135,54 +2206,19 @@ Tcl_FSAccess(pathPtr, mode) */ Tcl_Channel -Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) - Tcl_Interp *interp; /* Interpreter for error reporting; can be +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 + 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 + 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. - */ - - 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); - } - - openFileChannelProcPtr = openFileChannelProcList; - - while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { - retVal = (*openFileChannelProcPtr->proc)(interp, path, - modeString, permissions); - openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; - } - if (transPtr != NULL) { - Tcl_DecrRefCount(transPtr); - } - } - 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. */ @@ -2192,38 +2228,47 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) } fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL) { - Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc; - if (proc != NULL) { - int mode, seekFlag, binary; + if (fsPtr != NULL && fsPtr->openFileChannelProc != NULL) { + int mode, seekFlag, binary; - mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary); - if (mode == -1) { - return NULL; - } + /* + * Parse the mode, picking up whether we want to seek to start with + * and/or set the channel automatically into binary mode. + */ - 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; - } - } - if (binary) { - Tcl_SetChannelOption(interp, retVal, - "-translation", "binary"); - } + mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary); + if (mode == -1) { + return NULL; + } + + /* + * Do the actual open() call. + */ + + retVal = fsPtr->openFileChannelProc(interp, pathPtr, mode, + permissions); + if (retVal == NULL) { + return NULL; + } + + /* + * 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))); } - return retVal; + Tcl_Close(NULL, retVal); + return NULL; } + if (binary) { + Tcl_SetChannelOption(interp, retVal, "-translation", "binary"); + } + return retVal; } /* @@ -2232,8 +2277,9 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) 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; } @@ -2243,7 +2289,7 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) * * Tcl_FSUtime -- * - * This procedure replaces the library version of utime. The appropriate + * This function replaces the library version of utime. The appropriate * function for the filesystem to which pathPtr belongs will be called. * * Results: @@ -2256,18 +2302,18 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) */ 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. */ +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; } @@ -2276,9 +2322,9 @@ Tcl_FSUtime(pathPtr, tval) * * NativeFileAttrStrings -- * - * This procedure implements the platform dependent 'file attributes' + * 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 + * 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. * @@ -2291,10 +2337,10 @@ Tcl_FSUtime(pathPtr, tval) *---------------------------------------------------------------------- */ -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; } @@ -2304,15 +2350,15 @@ NativeFileAttrStrings(pathPtr, objPtrRef) * * NativeFileAttrsGet -- * - * This procedure implements the platform dependent 'file attributes' - * subcommand, for the native filesystem, for 'get' operations. This + * 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 + * 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: @@ -2322,14 +2368,13 @@ NativeFileAttrStrings(pathPtr, objPtrRef) */ 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); } /* @@ -2337,7 +2382,7 @@ NativeFileAttrsGet(interp, index, pathPtr, objPtrRef) * * NativeFileAttrsSet -- * - * This procedure implements the platform dependent 'file attributes' + * 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. @@ -2352,13 +2397,13 @@ NativeFileAttrsGet(interp, index, pathPtr, objPtrRef) */ 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); } /* @@ -2366,12 +2411,12 @@ 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 + * 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 + * 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 @@ -2385,17 +2430,15 @@ NativeFileAttrsSet(interp, index, pathPtr, objPtr) *---------------------------------------------------------------------- */ -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; @@ -2419,14 +2462,14 @@ Tcl_FSFileAttrStrings(pathPtr, objPtrRef) */ int -TclFSFileAttrIndex(pathPtr, attributeName, indexPtr) - 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. */ +TclFSFileAttrIndex( + Tcl_Obj *pathPtr, /* File whose attributes are to be indexed + * into. */ + const char *attributeName, /* The attribute being looked for. */ + int *indexPtr) /* Where to write the found index. */ { Tcl_Obj *listObj = NULL; - CONST char **attrTable; + const char *const *attrTable; /* * Get the attribute table for the file. @@ -2483,14 +2526,14 @@ TclFSFileAttrIndex(pathPtr, attributeName, indexPtr) * * Tcl_FSFileAttrsGet -- * - * This procedure implements read access for the hookable 'file - * attributes' subcommand. The appropriate function for the filesystem - * to which pathPtr belongs will be called. + * 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 + * 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: @@ -2500,18 +2543,16 @@ TclFSFileAttrIndex(pathPtr, attributeName, indexPtr) */ 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. */ +Tcl_FSFileAttrsGet( + Tcl_Interp *interp, /* The interpreter for error reporting. */ + int index, /* index of the attribute command. */ + Tcl_Obj *pathPtr, /* filename we are operating on. */ + Tcl_Obj **objPtrRef) /* for output. */ { - Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL) { - Tcl_FSFileAttrsGetProc *proc = fsPtr->fileAttrsGetProc; - if (proc != NULL) { - return (*proc)(interp, index, pathPtr, objPtrRef); - } + 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; @@ -2522,9 +2563,9 @@ 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. @@ -2536,18 +2577,16 @@ Tcl_FSFileAttrsGet(interp, index, pathPtr, objPtrRef) */ 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; @@ -2560,10 +2599,10 @@ Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr) * * 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). + * 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 @@ -2580,10 +2619,10 @@ Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr) * * 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 + * 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 + * The result already has its refCount incremented for the caller. When * it is no longer needed, that refCount should be decremented. * * Side effects: @@ -2592,74 +2631,78 @@ 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(&tclFsDataKey); + 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 + * 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) { - if (fsRecPtr->fsPtr->version != TCL_FILESYSTEM_VERSION_1) { - ClientData retCd; - TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc; - - retCd = (*proc2)(NULL); - if (retCd != NULL) { - Tcl_Obj *norm; - /* Looks like a new current directory */ - retVal = (*fsRecPtr->fsPtr->internalToNormalizedProc)( - retCd); - Tcl_IncrRefCount(retVal); - norm = TclFSNormalizeAbsolutePath(interp,retVal,NULL); - if (norm != NULL) { - /* - * We found a cwd, which is now in our global - * storage. We must make a copy. Norm already has - * a refCount of 1. - * - * Threading issue: note that multiple threads at - * system startup could in principle call this - * 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. - */ - - FsUpdateCwd(norm, retCd); - Tcl_DecrRefCount(norm); - } else { - (*fsRecPtr->fsPtr->freeInternalRepProc)(retCd); - } - Tcl_DecrRefCount(retVal); - retVal = NULL; - goto cdDidNotChange; - } else { - if (interp != NULL) { - Tcl_AppendResult(interp, - "error getting working directory name: ", - Tcl_PosixError(interp), (char *) NULL); - } - } + 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 { - retVal = (*proc)(interp); + 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; } + Disclaim(); /* * Now the 'cwd' may NOT be normalized, at least on some platforms. @@ -2671,21 +2714,23 @@ Tcl_FSGetCwd(interp) */ 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. */ ClientData cd = (ClientData) Tcl_FSGetNativePath(norm); + FsUpdateCwd(norm, TclNativeDupInternalRep(cd)); Tcl_DecrRefCount(norm); } @@ -2695,106 +2740,116 @@ Tcl_FSGetCwd(interp) /* * 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, + * 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); + 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 + * 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; - ClientData retCd = NULL; - if (proc != NULL) { - Tcl_Obj *retVal; - if (fsPtr->version != TCL_FILESYSTEM_VERSION_1) { - TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc; - - retCd = (*proc2)(tsdPtr->cwdClientData); - if (retCd == NULL && interp != NULL) { - Tcl_AppendResult(interp, - "error getting working directory name: ", - Tcl_PosixError(interp), (char *) NULL); - } + if (fsPtr == NULL || fsPtr->getCwdProc == NULL) { + goto cdDidNotChange; + } - if (retCd == tsdPtr->cwdClientData) { - goto cdDidNotChange; - } + if (fsPtr->version == TCL_FILESYSTEM_VERSION_1) { + retVal = fsPtr->getCwdProc(interp); + } else { + /* + * New API. + */ - /* - * Looks like a new current directory. - */ + TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2 *) fsPtr->getCwdProc; - retVal = (*fsPtr->internalToNormalizedProc)(retCd); - Tcl_IncrRefCount(retVal); - } else { - retVal = (*proc)(interp); - } - if (retVal != NULL) { - Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, - retVal, NULL); + retCd = proc2(tsdPtr->cwdClientData); + if (retCd == NULL && interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error getting working directory name: %s", + Tcl_PosixError(interp))); + } - /* - * Check whether cwd has changed from the value previously - * stored in cwdPathPtr. Really 'norm' shouldn't be null, - * but we are careful. - */ + if (retCd == tsdPtr->cwdClientData) { + goto cdDidNotChange; + } - 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; - char *str1, *str2; - - str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); - str2 = Tcl_GetStringFromObj(norm, &len2); - if ((len1 == len2) && (strcmp(str1, str2) == 0)) { - /* - * If the paths were equal, we can be more - * efficient and retain the old path object which - * will probably already be shared. In this case - * we can simply free the normalized path we just - * calculated. - */ - - cdEqual: - Tcl_DecrRefCount(norm); - if (retCd != NULL) { - (*fsPtr->freeInternalRepProc)(retCd); - } - } else { - FsUpdateCwd(norm, retCd); - Tcl_DecrRefCount(norm); - } - } - Tcl_DecrRefCount(retVal); - } else { - /* The 'cwd' function returned an error; reset the cwd */ - FsUpdateCwd(NULL, NULL); + /* + * 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 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); + str2 = Tcl_GetStringFromObj(norm, &len2); + if ((len1 == len2) && (strcmp(str1, str2) == 0)) { + /* + * If the paths were equal, we can be more efficient and + * retain the old path object which will probably already be + * shared. In this case we can simply free the normalized path + * we just calculated. + */ + + cdEqual: + Tcl_DecrRefCount(norm); + if (retCd != NULL) { + fsPtr->freeInternalRepProc(retCd); } + } else { + FsUpdateCwd(norm, retCd); + Tcl_DecrRefCount(norm); } } + Tcl_DecrRefCount(retVal); } cdDidNotChange: @@ -2816,20 +2871,20 @@ Tcl_FSGetCwd(interp) * it. * * Results: - * See chdir() documentation. If successful, we keep a record of the + * 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; int retVal = -1; if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) { @@ -2839,14 +2894,13 @@ Tcl_FSChdir(pathPtr) fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { - Tcl_FSChdirProc *proc = fsPtr->chdirProc; - if (proc != NULL) { + if (fsPtr->chdirProc != NULL) { /* * If this fails, an appropriate errno will have been stored using * 'Tcl_SetErrno()'. */ - retVal = (*proc)(pathPtr); + retVal = fsPtr->chdirProc(pathPtr); } else { /* * Fallback on stat-based implementation. @@ -2856,9 +2910,9 @@ Tcl_FSChdir(pathPtr) /* * 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 + * 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)) @@ -2875,22 +2929,20 @@ Tcl_FSChdir(pathPtr) } /* - * 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. + * 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! @@ -2904,8 +2956,8 @@ Tcl_FSChdir(pathPtr) /* * 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 + * 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). */ @@ -2921,29 +2973,33 @@ Tcl_FSChdir(pathPtr) 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 + * 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 + * 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. + * 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; /* * Assumption we are using a filesystem version 2. */ - TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)fsPtr->getCwdProc; - cd = (*proc2)(tsdPtr->cwdClientData); - FsUpdateCwd(normDirName, TclNativeDupInternalRep(cd)); + TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2 *) fsPtr->getCwdProc; + + cd = proc2(oldcd); + if (cd != oldcd) { + FsUpdateCwd(normDirName, cd); + } } else { FsUpdateCwd(normDirName, NULL); } @@ -2958,447 +3014,589 @@ 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. + * 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 + * 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 + * 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 + * 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 + * 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 + const char *sym1, const char *sym2, + /* Names of two functions to look up in the * file's symbol table. */ - Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + 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 + Tcl_LoadHandle *handlePtr, /* Filled with token for dynamically loaded * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr; + Tcl_FSUnloadFileProc **unloadProcPtr) /* Filled with address of Tcl_FSUnloadFileProc * function which should be used for this * file. */ { - CONST char *symbols[2]; - Tcl_PackageInitProc **procPtrs[2]; - ClientData clientData; + const char *symbols[3]; + void *procPtrs[2]; int res; - /* Initialize the arrays */ + /* + * Initialize the arrays. + */ + symbols[0] = sym1; symbols[1] = sym2; - procPtrs[0] = proc1Ptr; - procPtrs[1] = proc2Ptr; - - /* Perform the load */ - res = TclLoadFile(interp, pathPtr, 2, symbols, procPtrs, - handlePtr, &clientData, unloadProcPtr); + symbols[2] = NULL; /* - * 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. + * Perform the load. */ - *handlePtr = (Tcl_LoadHandle) clientData; + 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; } /* *---------------------------------------------------------------------- * - * TclLoadFile -- + * Tcl_LoadFile -- * * Dynamically loads a binary code file into memory and returns the - * addresses of a number of given procedures within that file, if they - * are defined. The appropriate function for the filesystem to which - * pathPtr belongs will be called. + * 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 + * 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 + * 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. * - * 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 + * 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 + * calling TclFS_UnloadFile. * *---------------------------------------------------------------------- */ int -TclLoadFile(interp, pathPtr, symc, symbols, procPtrs, - handlePtr, clientDataPtr, unloadProcPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Obj *pathPtr; /* Name of the file containing the desired +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 procedures to look up in the - * file's symbol table. */ - Tcl_PackageInitProc **procPtrs[]; - /* Where to return the addresses corresponding - * to symbols[]. */ - Tcl_LoadHandle *handlePtr; /* Filled with token for shared library + 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. */ - 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. */ { - Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL) { - Tcl_FSLoadFileProc *proc = fsPtr->loadFileProc; - Tcl_Filesystem *copyFsPtr; - Tcl_Obj *copyToPtr; - - if (proc != NULL) { - int retVal = (*proc)(interp, pathPtr, handlePtr, unloadProcPtr); - if (retVal == TCL_OK) { - int i; - if (*handlePtr == NULL) { - return TCL_ERROR; - } - for (i=0 ; i<symc ; i++) { - if (symbols[i] != NULL) { - *procPtrs[i] = TclpFindSymbol(interp, *handlePtr, - symbols[i]); - } - } + 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; - /* - * Copy this across, since both are equal for the native fs. - */ + if (fsPtr == NULL) { + Tcl_SetErrno(ENOENT); + return TCL_ERROR; + } - *clientDataPtr = (ClientData)*handlePtr; - Tcl_ResetResult(interp); - return TCL_OK; - } - if (Tcl_GetErrno() != EXDEV) { - return retVal; + 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; } + Tcl_ResetResult(interp); + goto resolveSymbols; + } + if (Tcl_GetErrno() != EXDEV) { + return retVal; + } + } + + /* + * The filesystem doesn't support 'load', so we fall back on the following + * technique: + * + * First check if it is readable -- and exists! + */ + + if (Tcl_FSAccess(pathPtr, R_OK) != 0) { + Tcl_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; /* - * The filesystem doesn't support 'load', so we fall back on the - * following technique: - * - * First check if it is readable -- and exists! + * Tcl_Read takes an int: check that file size isn't wide. */ - 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; + 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; } + } -#ifdef TCL_LOAD_FROM_MEMORY + mustCopyToTempAnyway: + 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)) { /* - * 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: + * 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. */ - do { - int ret, size; - void *buffer; - Tcl_StatBuf statBuf; - Tcl_Channel data; + Tcl_FSDeleteFile(copyToPtr); + Tcl_DecrRefCount(copyToPtr); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't load from current filesystem", -1)); + return TCL_ERROR; + } - ret = Tcl_FSStat(pathPtr, &statBuf); - if (ret < 0) { - break; - } - size = (int) statBuf.st_size; + if (TclCrossFilesystemCopy(interp, pathPtr, copyToPtr) != TCL_OK) { + /* + * Cross-platform copy failed. + */ - /* - * Tcl_Read takes an int: check that file size isn't wide. - */ + Tcl_FSDeleteFile(copyToPtr); + Tcl_DecrRefCount(copyToPtr); + return TCL_ERROR; + } - if (size != (Tcl_WideInt) statBuf.st_size) { - break; - } - data = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0666); - if (!data) { - break; - } - buffer = TclpLoadMemoryGetBuffer(interp, size); - if (!buffer) { - Tcl_Close(interp, data); - break; - } - Tcl_SetChannelOption(interp, data, "-translation", "binary"); - ret = Tcl_Read(data, buffer, size); - Tcl_Close(interp, data); - ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr, - unloadProcPtr); - if (ret == TCL_OK) { - int i; - if (*handlePtr == NULL) { - break; - } - for (i = 0;i < symc;i++) { - if (symbols[i] != NULL) { - *procPtrs[i] = TclpFindSymbol(interp, *handlePtr, - symbols[i]); - } - } - *clientDataPtr = (ClientData) *handlePtr; - return TCL_OK; - } - } while (0); - Tcl_ResetResult(interp); +#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_LoadFile(interp, copyToPtr, symbols, flags, procPtrs, + &newLoadHandle); + if (retVal != TCL_OK) { /* - * Get a temporary filename to use, first to copy the file into, and - * then to load. + * The file didn't load successfully. */ - copyToPtr = TclpTempFileName(); - if (copyToPtr == NULL) { - Tcl_AppendResult(interp, "couldn't create temporary file: ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - Tcl_IncrRefCount(copyToPtr); + Tcl_FSDeleteFile(copyToPtr); + Tcl_DecrRefCount(copyToPtr); + return retVal; + } - 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. - */ + /* + * Try to delete the file immediately - this is possible in some OSes, and + * avoids any worries about leaving the copy laying around on exit. + */ - Tcl_FSDeleteFile(copyToPtr); - Tcl_DecrRefCount(copyToPtr); - Tcl_AppendResult(interp, "couldn't load from current filesystem", - (char *) NULL); - return TCL_ERROR; - } + if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) { + Tcl_DecrRefCount(copyToPtr); - if (TclCrossFilesystemCopy(interp, pathPtr, copyToPtr) == TCL_OK) { - Tcl_LoadHandle newLoadHandle = NULL; - ClientData newClientData = NULL; - Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL; - FsDivertLoad *tvdlPtr; - int retVal; + /* + * 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. + */ -#if !defined(__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: - */ + *handlePtr = newLoadHandle; + Tcl_ResetResult(interp); + return TCL_OK; + } - int index; - Tcl_Obj* perm = Tcl_NewStringObj("0700",-1); - Tcl_IncrRefCount(perm); - if (TclFSFileAttrIndex(copyToPtr, "-permissions", - &index) == TCL_OK) { - Tcl_FSFileAttrsSet(NULL, index, copyToPtr, perm); - } - Tcl_DecrRefCount(perm); -#endif + /* + * When we unload this file, we need to divert the unloading so we can + * unload and cleanup the temporary file correctly. + */ - /* - * We need to reset the result now, because the cross- filesystem - * copy may have stored the number of bytes in the result. - */ + tvdlPtr = ckalloc(sizeof(FsDivertLoad)); - Tcl_ResetResult(interp); + /* + * Remember three pieces of information. This allows us to cleanup the + * diverted load completely, on platforms which allow proper unloading of + * code. + */ - retVal = TclLoadFile(interp, copyToPtr, symc, symbols, procPtrs, - &newLoadHandle, &newClientData, &newUnloadProcPtr); - if (retVal != TCL_OK) { - /* The file didn't load successfully */ - Tcl_FSDeleteFile(copyToPtr); - Tcl_DecrRefCount(copyToPtr); - return retVal; - } + tvdlPtr->loadHandle = newLoadHandle; + tvdlPtr->unloadProcPtr = newUnloadProcPtr; - /* - * 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 (copyFsPtr != &tclNativeFilesystem) { + /* + * copyToPtr is already incremented for this reference. + */ - if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) { - Tcl_DecrRefCount(copyToPtr); + tvdlPtr->divertedFile = 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. - */ + /* + * 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. + */ - (*handlePtr) = newLoadHandle; - (*clientDataPtr) = newClientData; - (*unloadProcPtr) = newUnloadProcPtr; - Tcl_ResetResult(interp); - return TCL_OK; - } + tvdlPtr->divertedFilesystem = copyFsPtr; + tvdlPtr->divertedFileNativeRep = NULL; + } else { + /* + * We need the native rep. + */ - /* - * When we unload this file, we need to divert the unloading so we - * can unload and cleanup the temporary file correctly. - */ + tvdlPtr->divertedFileNativeRep = TclNativeDupInternalRep( + Tcl_FSGetInternalRep(copyToPtr, copyFsPtr)); - tvdlPtr = (FsDivertLoad *) ckalloc(sizeof(FsDivertLoad)); + /* + * We don't need or want references to the copied Tcl_Obj or the + * filesystem if it is the native one. + */ - /* - * Remember three pieces of information. This allows us to - * cleanup the diverted load completely, on platforms which allow - * proper unloading of code. - */ + tvdlPtr->divertedFile = NULL; + tvdlPtr->divertedFilesystem = NULL; + Tcl_DecrRefCount(copyToPtr); + } - tvdlPtr->loadHandle = newLoadHandle; - tvdlPtr->unloadProcPtr = newUnloadProcPtr; + copyToPtr = NULL; - if (copyFsPtr != &tclNativeFilesystem) { - /* copyToPtr is already incremented for this reference */ - tvdlPtr->divertedFile = copyToPtr; + divertedLoadHandle = ckalloc(sizeof(struct Tcl_LoadHandle_)); + divertedLoadHandle->clientData = tvdlPtr; + divertedLoadHandle->findSymbolProcPtr = DivertFindSymbol; + divertedLoadHandle->unloadFileProcPtr = DivertUnloadFile; + *handlePtr = divertedLoadHandle; - /* - * 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. - */ + Tcl_ResetResult(interp); + return retVal; - tvdlPtr->divertedFilesystem = copyFsPtr; - tvdlPtr->divertedFileNativeRep = NULL; - } else { - /* We need the native rep */ - tvdlPtr->divertedFileNativeRep = TclNativeDupInternalRep( - Tcl_FSGetInternalRep(copyToPtr, copyFsPtr)); + resolveSymbols: + /* + * At this point, *handlePtr is already set up to the handle for the + * loaded library. We now try to resolve the symbols. + */ - /* - * We don't need or want references to the copied Tcl_Obj or - * the filesystem if it is the native one. + 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->divertedFile = NULL; - tvdlPtr->divertedFilesystem = NULL; - Tcl_DecrRefCount(copyToPtr); + (*handlePtr)->unloadFileProcPtr(*handlePtr); + *handlePtr = NULL; + return TCL_ERROR; } - - copyToPtr = NULL; - (*handlePtr) = newLoadHandle; - (*clientDataPtr) = (ClientData) tvdlPtr; - (*unloadProcPtr) = &FSUnloadTempFile; - Tcl_ResetResult(interp); - return retVal; - - } else { - /* - * Cross-platform copy failed. - */ - - Tcl_FSDeleteFile(copyToPtr); - Tcl_DecrRefCount(copyToPtr); - return TCL_ERROR; } } - Tcl_SetErrno(ENOENT); - 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(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; + 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; - res = TclpDlopen(interp, pathPtr, &handle, unloadProcPtr); + /* + * This test should never trigger, since we give the client data in the + * function above. + */ - if (res != TCL_OK) { - return res; + 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 = (ClientData)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; } /* - *--------------------------------------------------------------------------- + *---------------------------------------------------------------------- * - * FSUnloadTempFile -- + * TclpUnloadFile -- + * + * Unloads a library given its handle + * + * This function was once filesystem-specific, but has been made portable by + * having TclpDlopen return a structure that includes procedure pointers. + * + *---------------------------------------------------------------------- + */ + +void +TclpUnloadFile( + Tcl_LoadHandle handle) +{ + if (handle->unloadFileProcPtr != NULL) { + handle->unloadFileProcPtr(handle); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclFSUnloadTempFile -- * * This function is called when we loaded a library of code via an - * intermediate temporary file. This function ensures the library is + * intermediate temporary file. This function ensures the library is * correctly unloaded and the temporary file is correctly deleted. * * Results: @@ -3408,32 +3606,35 @@ TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, * 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; + FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle; /* * This test should never trigger, since we give the client data in the * function above. */ - if (tvdlPtr == NULL) { return; } + 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 + * 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) { @@ -3445,10 +3646,9 @@ FSUnloadTempFile(loadHandle) TclpDeleteFile(tvdlPtr->divertedFileNativeRep); NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep); - } else { /* - * Remove the temporary file we created. Note, we may crash here + * Remove the temporary file we created. Note, we may crash here * because encodings have been taken down already. */ @@ -3472,7 +3672,7 @@ FSUnloadTempFile(loadHandle) } /* - * And free up the allocations. This will also of course remove a + * 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. */ @@ -3480,7 +3680,7 @@ FSUnloadTempFile(loadHandle) Tcl_DecrRefCount(tvdlPtr->divertedFile); } - ckfree((char*)tvdlPtr); + ckfree(tvdlPtr); } /* @@ -3489,18 +3689,18 @@ 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 + * 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 + * 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 + * 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 @@ -3511,35 +3711,33 @@ FSUnloadTempFile(loadHandle) * 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. + * 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 */ @@ -3551,15 +3749,15 @@ Tcl_FSLink(pathPtr, toPtr, linkAction) * * Tcl_FSListVolumes -- * - * Lists the currently mounted volumes. The chain of functions that have + * 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 + * 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 + * called). Therefore we quite naturally add its contents to the result * we are building, and then decrement the refCount. * * Results: @@ -3571,24 +3769,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 + * 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); @@ -3596,6 +3795,7 @@ Tcl_FSListVolumes(void) } fsRecPtr = fsRecPtr->nextPtr; } + Disclaim(); return resultPtr; } @@ -3618,10 +3818,10 @@ 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 }; @@ -3629,25 +3829,25 @@ FsListMounts(pathPtr, pattern) /* * 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 + * 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; } @@ -3662,7 +3862,7 @@ FsListMounts(pathPtr, pattern) * an element. * * Results: - * Returns list object with refCount of zero. If the passed in lenPtr is + * 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. * @@ -3672,16 +3872,16 @@ 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; + const Tcl_Filesystem *fsPtr; char separator = '/'; int driveNameLength; - char *p; + const char *p; /* * Perform platform specific splitting. @@ -3701,7 +3901,8 @@ Tcl_FSSplitPath(pathPtr, lenPtr) */ 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]; @@ -3710,7 +3911,7 @@ Tcl_FSSplitPath(pathPtr, lenPtr) } /* - * Place the drive name as first element of the result list. The drive + * 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) */ @@ -3726,16 +3927,18 @@ Tcl_FSSplitPath(pathPtr, lenPtr) */ 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); @@ -3752,36 +3955,10 @@ Tcl_FSSplitPath(pathPtr, lenPtr) */ 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; -{ - FilesystemRecord *fsRecPtr = FsGetFirstFilesystem(); - - while (fsRecPtr != NULL) { - if (fsRecPtr->fsPtr == fromFilesystem) { - *fsRecPtrPtr = fsRecPtr; - break; - } - fsRecPtr = fsRecPtr->nextPtr; - } - - if ((fsRecPtr != NULL) - && (fromFilesystem->internalToNormalizedProc != NULL)) { - return (*fromFilesystem->internalToNormalizedProc)(clientData); - } else { - return NULL; - } -} - /* *---------------------------------------------------------------------- * @@ -3791,7 +3968,7 @@ TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr) * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or - * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will be set if and + * 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. * @@ -3802,26 +3979,25 @@ TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr) */ Tcl_PathType -TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef) - Tcl_Obj *pathPtr; /* Path to determine type for */ - 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. */ +TclGetPathType( + Tcl_Obj *pathPtr, /* Path to determine type for. */ + const Tcl_Filesystem **filesystemPtrPtr, + /* If absolute path and this is not NULL, then + * set to the filesystem which claims this + * path. */ + int *driveNameLengthPtr, /* If the path is absolute, and this is + * non-NULL, then set to the length of the + * driveName. */ + Tcl_Obj **driveNameRef) /* If the path is absolute, and this is + * non-NULL, then set to the name of the + * drive, network-volume which contains the + * path, already with a refCount for the + * caller. */ { int pathLen; - char *path; + const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); Tcl_PathType type; - path = Tcl_GetStringFromObj(pathPtr, &pathLen); - type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, driveNameLengthPtr, driveNameRef); @@ -3840,14 +4016,14 @@ TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef) * * TclFSNonnativePathType -- * - * Helper function used by TclGetPathType. Its purpose is to check + * 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 + * file volume in any registered filesystem except the native one. For * speed and historical reasons the native filesystem has special * hard-coded checks dotted here and there in the filesystem code. * * Results: - * Returns one of TCL_PATH_ABSOLUTE or TCL_PATH_RELATIVE. The filesystem + * 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. * @@ -3858,21 +4034,21 @@ TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef) */ Tcl_PathType -TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, driveNameLengthPtr, - driveNameRef) - CONST char *path; /* Path to determine type for */ - int pathLen; /* Length of the path */ - 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. */ +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; Tcl_PathType type = TCL_PATH_RELATIVE; @@ -3884,39 +4060,39 @@ TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, driveNameLengthPtr, */ 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 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. + * 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) && (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) { + 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'. + * 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). @@ -3927,7 +4103,7 @@ TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, driveNameLengthPtr, while (numVolumes > 0) { Tcl_Obj *vol; int len; - char *strVol; + const char *strVol; numVolumes--; Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol); @@ -3952,13 +4128,17 @@ TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, driveNameLengthPtr, } 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; } + Disclaim(); return type; } @@ -3968,7 +4148,7 @@ TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, driveNameLengthPtr, * Tcl_FSRenameFile -- * * If the two paths given belong to the same filesystem, we call that - * filesystems rename function. Otherwise we simply return the posix + * filesystems rename function. Otherwise we simply return the POSIX * error 'EXDEV', and -1. * * Results: @@ -3981,22 +4161,21 @@ TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, driveNameLengthPtr, */ 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); @@ -4010,8 +4189,8 @@ 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. + * 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 @@ -4027,20 +4206,18 @@ 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). */ +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); @@ -4054,7 +4231,7 @@ 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 + * one filesystem to another. This function will overwrite the target * file if it already exists. * * Results: @@ -4065,65 +4242,64 @@ Tcl_FSCopyFile(srcPathPtr, destPathPtr) * *--------------------------------------------------------------------------- */ + 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). */ +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 in, out; + Tcl_StatBuf sourceStatBuf; + struct utimbuf tval; - Tcl_Channel out = Tcl_FSOpenFileChannel(interp, target, "w", prot); - if (out != NULL) { + out = Tcl_FSOpenFileChannel(interp, target, "wb", prot); + if (out == NULL) { /* - * It looks like we can copy it over. + * It looks like we cannot copy it over. Bail out... */ + goto done; + } - 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; + in = Tcl_FSOpenFileChannel(interp, source, "rb", prot); + if (in == NULL) { + /* + * This is very strange, caller should have checked this... + */ - /* - * Copy it synchronously. We might wish to add an asynchronous - * option to support vfs's which are slow (e.g. network sockets). - */ + Tcl_Close(interp, out); + goto done; + } - Tcl_SetChannelOption(interp, in, "-translation", "binary"); - Tcl_SetChannelOption(interp, out, "-translation", "binary"); + /* + * 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 (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) { + result = TCL_OK; + } - /* - * If the copy failed, assume that copy channel left a good error - * message. - */ + /* + * If the copy failed, assume that copy channel left a good error message. + */ - Tcl_Close(interp, in); - Tcl_Close(interp, out); + Tcl_Close(interp, in); + Tcl_Close(interp, out); - /* - * Set modification date of copied file. - */ + /* + * 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); - } - } + if (Tcl_FSLstat(source, &sourceStatBuf) == 0) { + tval.actime = sourceStatBuf.st_atime; + tval.modtime = sourceStatBuf.st_mtime; + Tcl_FSUtime(target, &tval); } + + done: return result; } @@ -4145,15 +4321,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; @@ -4177,15 +4351,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; @@ -4197,8 +4369,8 @@ 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. + * filesystems copy-directory function. Otherwise we simply return the + * POSIX error 'EXDEV', and -1. * * Results: * Standard Tcl error code if a function was called. @@ -4210,24 +4382,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 + 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); @@ -4253,56 +4423,57 @@ 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 + 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 && fsPtr->removeDirectoryProc != NULL) { - Tcl_FSRemoveDirectoryProc *proc = fsPtr->removeDirectoryProc; - if (recursive) { - /* - * We check whether the cwd lies inside this directory and move it - * if it does. - */ + const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + + 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 (*proc)(pathPtr, recursive, errorPtr); } - Tcl_SetErrno(ENOENT); - return -1; + return fsPtr->removeDirectoryProc(pathPtr, recursive, errorPtr); } /* @@ -4311,7 +4482,7 @@ Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr) * Tcl_FSGetFileSystemForPath -- * * This function determines which filesystem to use for a particular path - * object, and returns the filesystem which accepts this file. If no + * 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. * @@ -4324,12 +4495,12 @@ Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr) *--------------------------------------------------------------------------- */ -Tcl_Filesystem* -Tcl_FSGetFileSystemForPath(pathPtr) - Tcl_Obj* pathPtr; +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"); @@ -4337,7 +4508,7 @@ Tcl_FSGetFileSystemForPath(pathPtr) } /* - * If the object has a refCount of zero, we reject it. This is to avoid + * 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). */ @@ -4349,43 +4520,49 @@ Tcl_FSGetFileSystemForPath(pathPtr) /* * Check if the filesystem has changed in some way since this object's - * internal representation was calculated. Before doing that, assure we + * internal representation was calculated. Before doing that, assure we * have the most up-to-date copy of the master filesystem. This is * accomplished by the FsGetFirstFilesystem() call. */ fsRecPtr = FsGetFirstFilesystem(); + Claim(); if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) { + Disclaim(); return NULL; + } else if (retVal != NULL) { + /* TODO: Can this happen? */ + Disclaim(); + return retVal; } /* - * Call each of the "pathInFilesystem" functions in succession. A + * Call each of the "pathInFilesystem" functions in succession. A * non-return value of -1 indicates the particular function has succeeded. */ - while ((retVal == NULL) && (fsRecPtr != NULL)) { - Tcl_FSPathInFilesystemProc *proc = - fsRecPtr->fsPtr->pathInFilesystemProc; + for (; fsRecPtr!=NULL ; fsRecPtr=fsRecPtr->nextPtr) { + ClientData clientData = NULL; - if (proc != NULL) { - ClientData clientData = NULL; - int ret = (*proc)(pathPtr, &clientData); - if (ret != -1) { - /* - * We assume the type of pathPtr hasn't been changed by the - * above call to the pathInFilesystemProc. - */ + if (fsRecPtr->fsPtr->pathInFilesystemProc == NULL) { + continue; + } - TclFSSetPathDetails(pathPtr, fsRecPtr, clientData); - retVal = fsRecPtr->fsPtr; - } + if (fsRecPtr->fsPtr->pathInFilesystemProc(pathPtr, &clientData)!=-1) { + /* + * We assume the type of pathPtr hasn't been changed by the above + * call to the pathInFilesystemProc. + */ + + TclFSSetPathDetails(pathPtr, fsRecPtr->fsPtr, clientData); + Disclaim(); + return fsRecPtr->fsPtr; } - fsRecPtr = fsRecPtr->nextPtr; } + Disclaim(); - return retVal; + return NULL; } /* @@ -4395,17 +4572,17 @@ Tcl_FSGetFileSystemForPath(pathPtr) * * 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 procedures will - * always be called with path objects already converted to the correct + * 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 - * procedures not in this file), then one cannot necessarily guarantee + * 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 + * Tcl_FSGetNativeWinPath, Tcl_FSGetNativeUnixPath etc. Right now, since * native paths are all string based, we use just one function. * * Results: @@ -4417,11 +4594,11 @@ Tcl_FSGetFileSystemForPath(pathPtr) *--------------------------------------------------------------------------- */ -CONST char * -Tcl_FSGetNativePath(pathPtr) - Tcl_Obj *pathPtr; +const void * +Tcl_FSGetNativePath( + Tcl_Obj *pathPtr) { - return (CONST char *) Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem); + return Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem); } /* @@ -4441,10 +4618,10 @@ Tcl_FSGetNativePath(pathPtr) */ static void -NativeFreeInternalRep(clientData) - ClientData clientData; +NativeFreeInternalRep( + ClientData clientData) { - ckfree((char *) clientData); + ckfree(clientData); } /* @@ -4452,9 +4629,9 @@ NativeFreeInternalRep(clientData) * * Tcl_FSFileSystemInfo -- * - * This function returns a list of two elements. The first element is - * the name of the filesystem (e.g. "native" or "vfs"), and the second is - * the particular type of the given path within that filesystem. + * This function returns a list of two elements. The first element is the + * name of the filesystem (e.g. "native" or "vfs"), and the second is the + * particular type of the given path within that filesystem. * * Results: * A list of two elements. @@ -4465,26 +4642,24 @@ NativeFreeInternalRep(clientData) *--------------------------------------------------------------------------- */ -Tcl_Obj* -Tcl_FSFileSystemInfo(pathPtr) - Tcl_Obj* pathPtr; +Tcl_Obj * +Tcl_FSFileSystemInfo( + Tcl_Obj *pathPtr) { Tcl_Obj *resPtr; - Tcl_FSFilesystemPathTypeProc *proc; - Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr == NULL) { return NULL; } - resPtr = Tcl_NewListObj(0,NULL); - + resPtr = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(NULL, resPtr, - Tcl_NewStringObj(fsPtr->typeName,-1)); + Tcl_NewStringObj(fsPtr->typeName, -1)); + + if (fsPtr->filesystemPathTypeProc != NULL) { + Tcl_Obj *typePtr = fsPtr->filesystemPathTypeProc(pathPtr); - proc = fsPtr->filesystemPathTypeProc; - if (proc != NULL) { - Tcl_Obj *typePtr = (*proc)(pathPtr); if (typePtr != NULL) { Tcl_ListObjAppendElement(NULL, resPtr, typePtr); } @@ -4498,7 +4673,7 @@ Tcl_FSFileSystemInfo(pathPtr) * * Tcl_FSPathSeparator -- * - * This function returns the separator to be used for a given path. The + * This function returns the separator to be used for a given path. The * object returned should have a refCount of zero * * Results: @@ -4512,25 +4687,28 @@ Tcl_FSFileSystemInfo(pathPtr) *--------------------------------------------------------------------------- */ -Tcl_Obj* -Tcl_FSPathSeparator(pathPtr) - Tcl_Obj* pathPtr; +Tcl_Obj * +Tcl_FSPathSeparator( + Tcl_Obj *pathPtr) { - Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(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 { - /* - * Allow filesystems not to provide a filesystemSeparatorProc if they - * wish to use the standard forward slash. - */ - return Tcl_NewStringObj("/", 1); + if (fsPtr->filesystemSeparatorProc != NULL) { + return fsPtr->filesystemSeparatorProc(pathPtr); } + + /* + * Allow filesystems not to provide a filesystemSeparatorProc if they wish + * to use the standard forward slash. + */ + + TclNewLiteralStringObj(resultObj, "/"); + return resultObj; } /* @@ -4550,11 +4728,12 @@ Tcl_FSPathSeparator(pathPtr) *--------------------------------------------------------------------------- */ -static Tcl_Obj* -NativeFilesystemSeparator(pathPtr) - Tcl_Obj* pathPtr; +static Tcl_Obj * +NativeFilesystemSeparator( + Tcl_Obj *pathPtr) { - char *separator = NULL; /* lint */ + const char *separator = NULL; /* lint */ + switch (tclPlatform) { case TCL_PLATFORM_UNIX: separator = "/"; @@ -4565,319 +4744,6 @@ NativeFilesystemSeparator(pathPtr) } return Tcl_NewStringObj(separator,1); } - -/* Everything from here on is contained in this obsolete ifdef */ -#ifdef USE_OBSOLETE_FS_HOOKS - -/* - *---------------------------------------------------------------------- - * - * TclStatInsertProc -- - * - * Insert the passed procedure pointer at the head of the list of - * functions which are used during a call to 'TclStat(...)'. The passed - * function should behave exactly like 'TclStat' when called during that - * time (see 'TclStat(...)' for more information). The function will be - * added even if it already in the list. - * - * Results: - * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could - * not be allocated. - * - * Side effects: - * Memory allocated and modifies the link list for 'TclStat' functions. - * - *---------------------------------------------------------------------- - */ - -int -TclStatInsertProc (proc) - TclStatProc_ *proc; -{ - int retVal = TCL_ERROR; - - if (proc != NULL) { - StatProc *newStatProcPtr; - - newStatProcPtr = (StatProc *)ckalloc(sizeof(StatProc)); - - if (newStatProcPtr != NULL) { - newStatProcPtr->proc = proc; - Tcl_MutexLock(&obsoleteFsHookMutex); - newStatProcPtr->nextPtr = statProcList; - statProcList = newStatProcPtr; - Tcl_MutexUnlock(&obsoleteFsHookMutex); - - retVal = TCL_OK; - } - } - - return retVal; -} - -/* - *---------------------------------------------------------------------- - * - * TclStatDeleteProc -- - * - * Removed the passed function pointer from the list of 'TclStat' - * functions. Ensures that the built-in stat function is not removvable. - * - * Results: - * TCL_OK if the procedure pointer was successfully removed, TCL_ERROR - * otherwise. - * - * Side effects: - * Memory is deallocated and the respective list updated. - * - *---------------------------------------------------------------------- - */ - -int -TclStatDeleteProc (proc) - TclStatProc_ *proc; -{ - int retVal = TCL_ERROR; - StatProc *tmpStatProcPtr; - StatProc *prevStatProcPtr = NULL; - - Tcl_MutexLock(&obsoleteFsHookMutex); - tmpStatProcPtr = statProcList; - - /* - * 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. - */ - - while ((retVal == TCL_ERROR) && (tmpStatProcPtr != NULL)) { - if (tmpStatProcPtr->proc == proc) { - if (prevStatProcPtr == NULL) { - statProcList = tmpStatProcPtr->nextPtr; - } else { - prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr; - } - - ckfree((char *)tmpStatProcPtr); - - retVal = TCL_OK; - } else { - prevStatProcPtr = tmpStatProcPtr; - tmpStatProcPtr = tmpStatProcPtr->nextPtr; - } - } - - Tcl_MutexUnlock(&obsoleteFsHookMutex); - - return retVal; -} - -/* - *---------------------------------------------------------------------- - * - * TclAccessInsertProc -- - * - * Insert the passed procedure pointer at the head of the list of - * functions which are used during a call to 'TclAccess(...)'. The - * passed function should behave exactly like 'TclAccess' when called - * during that time (see 'TclAccess(...)' for more information). The - * function will be added even if it already in the list. - * - * Results: - * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could - * not be allocated. - * - * Side effects: - * Memory allocated and modifies the link list for 'TclAccess' functions. - * - *---------------------------------------------------------------------- - */ - -int -TclAccessInsertProc(proc) - TclAccessProc_ *proc; -{ - int retVal = TCL_ERROR; - - if (proc != NULL) { - AccessProc *newAccessProcPtr; - - newAccessProcPtr = (AccessProc *)ckalloc(sizeof(AccessProc)); - - if (newAccessProcPtr != NULL) { - newAccessProcPtr->proc = proc; - Tcl_MutexLock(&obsoleteFsHookMutex); - newAccessProcPtr->nextPtr = accessProcList; - accessProcList = newAccessProcPtr; - Tcl_MutexUnlock(&obsoleteFsHookMutex); - - retVal = TCL_OK; - } - } - - return retVal; -} - -/* - *---------------------------------------------------------------------- - * - * TclAccessDeleteProc -- - * - * Removed the passed function pointer from the list of 'TclAccess' - * functions. Ensures that the built-in access function is not - * removvable. - * - * Results: - * TCL_OK if the procedure pointer was successfully removed, TCL_ERROR - * otherwise. - * - * Side effects: - * Memory is deallocated and the respective list updated. - * - *---------------------------------------------------------------------- - */ - -int -TclAccessDeleteProc(proc) - TclAccessProc_ *proc; -{ - int retVal = TCL_ERROR; - AccessProc *tmpAccessProcPtr; - AccessProc *prevAccessProcPtr = NULL; - - /* - * 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. - */ - - 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)); - - newOpenFileChannelProcPtr->proc = proc; - Tcl_MutexLock(&obsoleteFsHookMutex); - newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; - openFileChannelProcList = newOpenFileChannelProcPtr; - Tcl_MutexUnlock(&obsoleteFsHookMutex); - - retVal = TCL_OK; - } - - return retVal; -} - -/* - *---------------------------------------------------------------------- - * - * TclOpenFileChannelDeleteProc -- - * - * Removed the passed function pointer from the list of - * 'Tcl_OpenFileChannel' functions. Ensures that the built-in open file - * channel function is not removable. - * - * Results: - * TCL_OK if the procedure pointer was successfully removed, TCL_ERROR - * otherwise. - * - * Side effects: - * Memory is deallocated and the respective list updated. - * - *---------------------------------------------------------------------- - */ - -int -TclOpenFileChannelDeleteProc(proc) - TclOpenFileChannelProc_ *proc; -{ - int retVal = TCL_ERROR; - OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList; - OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL; - - /* - * Traverse the 'openFileChannelProcList' looking for the particular node - * whose 'proc' member matches 'proc' and remove that one from the list. - */ - - 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); - - retVal = TCL_OK; - } else { - prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr; - tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr; - } - } - Tcl_MutexUnlock(&obsoleteFsHookMutex); - - return retVal; -} -#endif /* USE_OBSOLETE_FS_HOOKS */ /* * Local Variables: |