diff options
Diffstat (limited to 'generic/tclIOUtil.c')
| -rw-r--r-- | generic/tclIOUtil.c | 4191 |
1 files changed, 2272 insertions, 1919 deletions
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index b3643fe..82ffd88 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -1,22 +1,25 @@ /* * tclIOUtil.c -- * - * Provides an interface for managing filesystems in Tcl, and also for - * creating a filesystem interface in Tcl arbitrary facilities. All - * filesystem operations are performed via this interface. Vince Darley - * is the primary author. Other signifiant contributors are Karl - * Lehenbauer, Mark Diekhans and Peter da Silva. + * This file contains the implementation of Tcl's generic filesystem + * code, which supports a pluggable filesystem architecture allowing both + * platform specific filesystems and 'virtual filesystems'. All + * filesystem access should go through the functions defined in this + * file. Most of this code was contributed by Vince Darley. * - * Copyright © 1991-1994 The Regents of the University of California. - * Copyright © 1994-1997 Sun Microsystems, Inc. - * Copyright © 2001-2004 Vincent Darley. + * Parts of this file are based on code contributed by Karl Lehenbauer, + * Mark Diekhans and Peter da Silva. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 2001-2004 Vincent Darley. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#ifdef _WIN32 +#ifdef __WIN32__ # include "tclWinInt.h" #endif #include "tclFileSystem.h" @@ -30,223 +33,82 @@ /* * struct FilesystemRecord -- * - * An item in a linked list of registered filesystems + * A filesystem record is used to keep track of each filesystem currently + * registered with the core, in a linked list. */ typedef struct FilesystemRecord { - void *clientData; /* Client-specific data for the filesystem + ClientData clientData; /* Client specific data for the new filesystem * (can be NULL) */ - const Tcl_Filesystem *fsPtr;/* Pointer to filesystem dispatch table. */ + Tcl_Filesystem *fsPtr; /* Pointer to filesystem dispatch table. */ struct FilesystemRecord *nextPtr; - /* The next registered filesystem, or NULL to - * indicate the end of the list. */ + /* The next filesystem registered to Tcl, or + * NULL if no more. */ struct FilesystemRecord *prevPtr; - /* The previous filesystem, or NULL to indicate - * the ned of the list */ + /* 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 { +typedef struct ThreadSpecificData { int initialized; - size_t cwdPathEpoch; /* Compared with the global cwdPathEpoch to - * determine whether cwdPathPtr is stale. - */ - size_t filesystemEpoch; - Tcl_Obj *cwdPathPtr; /* A private copy of cwdPathPtr. Updated when - * the value is accessed and cwdPathEpoch has - * changed. - */ - void *cwdClientData; + int cwdPathEpoch; + int filesystemEpoch; + Tcl_Obj *cwdPathPtr; + ClientData cwdClientData; FilesystemRecord *filesystemList; - size_t claims; + int claims; } ThreadSpecificData; /* - * Forward declarations. + * Prototypes for functions defined later in this file. */ -static Tcl_NRPostProc EvalFileCallback; static FilesystemRecord*FsGetFirstFilesystem(void); -static void FsThrExitProc(void *cd); +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, void *clientData); +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); - -/* - * Functions that provide native filesystem support. They are private and - * should be used only here. They should be called instead of calling Tclp... - * native filesystem functions. Others should use the Tcl_FS... functions - * which ensure correct and complete virtual filesystem support. - */ - -static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator; -static Tcl_FSFreeInternalRepProc NativeFreeInternalRep; -static Tcl_FSFileAttrStringsProc NativeFileAttrStrings; -static Tcl_FSFileAttrsGetProc NativeFileAttrsGet; -static Tcl_FSFileAttrsSetProc NativeFileAttrsSet; /* - * Functions that support the native filesystem functions listed above. They - * are the same for win/unix, and not in tclInt.h because they are and should - * be used only 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. */ -MODULE_SCOPE const char *const tclpFileAttrStrings[]; +MODULE_SCOPE const char * tclpFileAttrStrings[]; MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; - -/* - * These these functions are not static either because routines in the native - * (win/unix) directories call them or they are actually implemented in those - * directories. They should be called from outside Tcl's native filesystem - * routines. 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_FSLinkProc TclpObjLink; -Tcl_FSListVolumesProc TclpObjListVolumes; - -/* - * The native filesystem dispatch table. This could me made public but it - * should only be accessed by the functions it points to, or perhaps - * subordinate helper functions. - */ - -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 *)(void *) TclpDlopen, - (Tcl_FSGetCwdProc *) TclpGetNativeCwd, - TclpObjChdir -}; - -/* - * An initial record in the linked list for the native filesystem. Remains at - * the tail of the list and is never freed. Currently the native filesystem is - * hard-coded. It may make sense to modify this to accommodate unconventional - * uses of Tcl that provide no native filesystem. - */ - -static FilesystemRecord nativeFilesystemRecord = { - NULL, - &tclNativeFilesystem, - NULL, - NULL -}; - -/* - * Incremented each time the linked list of filesystems is modified. For - * multithreaded builds, invalidates all cached filesystem internal - * representations. - */ - -static size_t theFilesystemEpoch = 1; - -/* - * The linked list of filesystems. To minimize locking each thread maintains a - * local copy of this list. - * - */ - -static FilesystemRecord *filesystemList = &nativeFilesystemRecord; -TCL_DECLARE_MUTEX(filesystemMutex) - -/* - * A files-system indepent sense of the current directory. - */ - -static Tcl_Obj *cwdPathPtr = NULL; -static size_t cwdPathEpoch = 0; /* The pathname of the current directory */ -static void *cwdClientData = NULL; -TCL_DECLARE_MUTEX(cwdMutex) - -static Tcl_ThreadDataKey fsDataKey; - /* - * When a temporary copy of a file is created on the native filesystem in order - * to load the file, an FsDivertLoad structure is created to track both the - * actual unloadProc/clientData combination which was used, and the original and - * modified filenames. This makes it possible to correctly undo the entire - * operation in order to unload the library. + * The following functions are obsolete string based APIs, and should be + * removed in a future release (Tcl 9 would be a good time). */ -typedef struct { - Tcl_LoadHandle loadHandle; - Tcl_FSUnloadFileProc *unloadProcPtr; - Tcl_Obj *divertedFile; - const Tcl_Filesystem *divertedFilesystem; - void *divertedFileNativeRep; -} FsDivertLoad; -/* - * Obsolete string-based APIs that should be removed in a future release, - * perhaps in Tcl 9. - */ - /* Obsolete */ int Tcl_Stat( - const char *path, /* Pathname of file to stat (in current CP). */ + 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; - Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); + Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1); Tcl_IncrRefCount(pathPtr); ret = Tcl_FSStat(pathPtr, &buf); @@ -254,10 +116,9 @@ Tcl_Stat( if (ret != -1) { #ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt tmp1, tmp2, tmp3 = 0; - # define OUT_OF_RANGE(x) \ - (((Tcl_WideInt)(x)) < LONG_MIN || \ - ((Tcl_WideInt)(x)) > LONG_MAX) + (((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)) @@ -271,10 +132,10 @@ Tcl_Stat( * Tcl_WideInt. */ - tmp1 = (Tcl_WideInt) buf.st_ino; - tmp2 = (Tcl_WideInt) buf.st_size; + tmp1 = (Tcl_WideInt) buf.st_ino; + tmp2 = (Tcl_WideInt) buf.st_size; #ifdef HAVE_STRUCT_STAT_ST_BLOCKS - tmp3 = (Tcl_WideInt) buf.st_blocks; + tmp3 = (Tcl_WideInt) buf.st_blocks; #endif if (OUT_OF_URANGE(tmp1) || OUT_OF_RANGE(tmp2) || OUT_OF_RANGE(tmp3)) { @@ -293,7 +154,7 @@ Tcl_Stat( #endif /* !TCL_WIDE_INT_IS_LONG */ /* - * Copy across all supported fields, with possible type coercion on + * Copy across all supported fields, with possible type coercions on * those fields that change between the normal and lf64 versions of * the stat structure (on Solaris at least). This is slow when the * structure sizes coincide, but that's what you get for using an @@ -308,9 +169,9 @@ Tcl_Stat( oldStyleBuf->st_uid = buf.st_uid; oldStyleBuf->st_gid = buf.st_gid; oldStyleBuf->st_size = (off_t) buf.st_size; - oldStyleBuf->st_atime = Tcl_GetAccessTimeFromStat(&buf); - oldStyleBuf->st_mtime = Tcl_GetModificationTimeFromStat(&buf); - oldStyleBuf->st_ctime = Tcl_GetChangeTimeFromStat(&buf); + oldStyleBuf->st_atime = buf.st_atime; + oldStyleBuf->st_mtime = buf.st_mtime; + oldStyleBuf->st_ctime = buf.st_ctime; #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE oldStyleBuf->st_blksize = buf.st_blksize; #endif @@ -328,8 +189,7 @@ Tcl_Stat( /* Obsolete */ int Tcl_Access( - const char *path, /* Pathname of file to access (in current CP). - */ + const char *path, /* Path of file to access (in current CP). */ int mode) /* Permission setting. */ { int ret; @@ -345,12 +205,13 @@ Tcl_Access( /* Obsolete */ Tcl_Channel Tcl_OpenFileChannel( - Tcl_Interp *interp, /* Interpreter for error reporting. May be + Tcl_Interp *interp, /* Interpreter for error reporting; can be * NULL. */ - const char *path, /* Pathname of file to open. */ + 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) /* The modes to use if creating a new file. */ + int permissions) /* If the open involves creating a file, with + * what modes to create it? */ { Tcl_Channel ret; Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); @@ -381,27 +242,27 @@ Tcl_GetCwd( Tcl_Interp *interp, Tcl_DString *cwdPtr) { - Tcl_Obj *cwd = Tcl_FSGetCwd(interp); - + Tcl_Obj *cwd; + cwd = Tcl_FSGetCwd(interp); if (cwd == NULL) { return NULL; + } else { + Tcl_DStringInit(cwdPtr); + Tcl_DStringAppend(cwdPtr, Tcl_GetString(cwd), -1); + Tcl_DecrRefCount(cwd); + return Tcl_DStringValue(cwdPtr); } - Tcl_DStringInit(cwdPtr); - TclDStringAppendObj(cwdPtr, cwd); - Tcl_DecrRefCount(cwd); - return Tcl_DStringValue(cwdPtr); } +/* Obsolete */ int Tcl_EvalFile( - Tcl_Interp *interp, /* Interpreter in which to evaluate the script. */ - const char *fileName) /* Pathname of the file containing the script. - * Performs Tilde-substitution on this - * pathaname. */ + 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); @@ -409,18 +270,238 @@ Tcl_EvalFile( } /* - * The basic filesystem implementation. + * 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. + */ + +#undef 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, + NULL, + NULL +}; + +/* + * This is incremented each time we modify the linked list of filesystems. Any + * time it changes, all cached filesystem representations are suspect and must + * be freed. For multithreading builds, change of the filesystem epoch will + * trigger cache cleanup in all threads. + */ + +static int theFilesystemEpoch = 1; + +/* + * Stores the linked list of filesystems. A 1:1 copy of this list is also + * maintained in the TSD for each thread. This is to avoid synchronization + * issues. + */ + +static FilesystemRecord *filesystemList = &nativeFilesystemRecord; +TCL_DECLARE_MUTEX(filesystemMutex) + +/* + * Used to implement Tcl_FSGetCwd in a file-system independent way. + */ + +static Tcl_Obj* cwdPathPtr = NULL; +static int cwdPathEpoch = 0; +static ClientData cwdClientData = NULL; +TCL_DECLARE_MUTEX(cwdMutex) + +static Tcl_ThreadDataKey fsDataKey; + +/* + * One of these structures is used each time we successfully load a file from + * a file system by way of making a temporary copy of the file on the native + * filesystem. We need to store both the actual unloadProc/clientData + * combination which was used, and the original and modified filenames, so + * that we can correctly undo the entire operation when we want to unload the + * code. + */ + +typedef struct FsDivertLoad { + Tcl_LoadHandle loadHandle; + Tcl_FSUnloadFileProc *unloadProcPtr; + Tcl_Obj *divertedFile; + const Tcl_Filesystem *divertedFilesystem; + ClientData divertedFileNativeRep; +} FsDivertLoad; + +/* + * Now move on to the basic filesystem implementation */ static void FsThrExitProc( - void *cd) + ClientData cd) { - ThreadSpecificData *tsdPtr = (ThreadSpecificData *)cd; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) cd; FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL; /* - * Discard the cwd copy. + * Trash the cwd copy. */ if (tsdPtr->cwdPathPtr != NULL) { @@ -432,14 +513,14 @@ FsThrExitProc( } /* - * Discard the filesystems cache. + * Trash the filesystems cache. */ fsRecPtr = tsdPtr->filesystemList; while (fsRecPtr != NULL) { tmpFsRecPtr = fsRecPtr->nextPtr; fsRecPtr->fsPtr = NULL; - ckfree(fsRecPtr); + ckfree((char *)fsRecPtr); fsRecPtr = tmpFsRecPtr; } tsdPtr->filesystemList = NULL; @@ -462,26 +543,26 @@ TclFSCwdIsNative(void) *---------------------------------------------------------------------- * * TclFSCwdPointerEquals -- - * Determine whether the given pathname is equal to the current working - * directory. + * + * Check whether the current working directory is equal to the path + * given. * * Results: - * 1 if equal, 0 otherwise. + * 1 (equal) or 0 (un-equal) as appropriate. * * Side effects: - * Updates TSD if needed. + * If the paths are equal, but are not the same object, this method will + * modify the given pathPtrPtr to refer to the same object. In this case + * the object pointed to by pathPtrPtr will have its refCount + * decremented, and it will be adjusted to point to the cwd (with a new + * refCount). * - * Stores a pointer to the current directory in *pathPtrPtr if it is not - * already there and the current directory is not NULL. - * - * If *pathPtrPtr is not null its reference count is decremented - * before it is replaced. *---------------------------------------------------------------------- */ int TclFSCwdPointerEquals( - Tcl_Obj **pathPtrPtr) + Tcl_Obj** pathPtrPtr) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); @@ -510,7 +591,7 @@ TclFSCwdPointerEquals( Tcl_MutexUnlock(&cwdMutex); if (tsdPtr->initialized == 0) { - Tcl_CreateThreadExitHandler(FsThrExitProc, tsdPtr); + Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr); tsdPtr->initialized = 1; } @@ -521,15 +602,15 @@ TclFSCwdPointerEquals( if (tsdPtr->cwdPathPtr == *pathPtrPtr) { return 1; } else { - Tcl_Size len1, len2; + int len1, len2; const char *str1, *str2; - str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); - str2 = TclGetStringFromObj(*pathPtrPtr, &len2); - if ((len1 == len2) && !memcmp(str1, str2, len1)) { + str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); + str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2); + if (len1 == len2 && !strcmp(str1,str2)) { /* - * The values are equal but the objects are different. Cache the - * current structure in place of the old one. + * They are equal, but different objects. Update so they will be + * the same object in the future. */ Tcl_DecrRefCount(*pathPtrPtr); @@ -572,13 +653,13 @@ FsRecacheFilesystemList(void) } /* - * Refill the cache, honouring the order. + * Refill the cache honouring the order. */ list = NULL; fsRecPtr = tmpFsRecPtr; while (fsRecPtr != NULL) { - tmpFsRecPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord)); + tmpFsRecPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord)); *tmpFsRecPtr = *fsRecPtr; tmpFsRecPtr->nextPtr = list; tmpFsRecPtr->prevPtr = NULL; @@ -591,9 +672,8 @@ FsRecacheFilesystemList(void) while (toFree) { FilesystemRecord *next = toFree->nextPtr; - toFree->fsPtr = NULL; - ckfree(toFree); + ckfree((char *)toFree); toFree = next; } @@ -602,7 +682,7 @@ FsRecacheFilesystemList(void) */ if (tsdPtr->initialized == 0) { - Tcl_CreateThreadExitHandler(FsThrExitProc, tsdPtr); + Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr); tsdPtr->initialized = 1; } } @@ -619,56 +699,54 @@ FsGetFirstFilesystem(void) } /* - * The epoch can is changed when a filesystems is added or removed, when - * "system encoding" changes, and when env(HOME) changes. + * The epoch can be changed both by filesystems being added or removed and by + * env(HOME) changing. */ int TclFSEpochOk( - size_t filesystemEpoch) + int filesystemEpoch) { return (filesystemEpoch == 0 || filesystemEpoch == theFilesystemEpoch); } static void -Claim(void) +Claim() { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); - tsdPtr->claims++; } static void -Disclaim(void) +Disclaim() { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); - tsdPtr->claims--; } -size_t -TclFSEpoch(void) +int +TclFSEpoch() { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); - return tsdPtr->filesystemEpoch; } + /* - * If non-NULL, take posession of clientData and free it later. + * If non-NULL, clientData is owned by us and must be freed later. */ static void FsUpdateCwd( Tcl_Obj *cwdObj, - void *clientData) + ClientData clientData) { - Tcl_Size len; - const char *str = NULL; + int len; + char *str = NULL; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); if (cwdObj != NULL) { - str = TclGetStringFromObj(cwdObj, &len); + str = Tcl_GetStringFromObj(cwdObj, &len); } Tcl_MutexLock(&cwdMutex); @@ -684,17 +762,15 @@ FsUpdateCwd( cwdClientData = NULL; } else { /* - * This must be stored as a string obj! + * This must be stored as string obj! */ cwdPathPtr = Tcl_NewStringObj(str, len); - Tcl_IncrRefCount(cwdPathPtr); + Tcl_IncrRefCount(cwdPathPtr); cwdClientData = TclNativeDupInternalRep(clientData); } - if (++cwdPathEpoch == 0) { - ++cwdPathEpoch; - } + cwdPathEpoch++; tsdPtr->cwdPathEpoch = cwdPathEpoch; Tcl_MutexUnlock(&cwdMutex); @@ -720,17 +796,17 @@ FsUpdateCwd( * * TclFinalizeFilesystem -- * - * Clean up the filesystem. After this, any call to a Tcl_FS... function - * fails. + * Clean up the filesystem. After this, calls to all Tcl_FS... functions + * will fail. * - * If TclResetFilesystem is called later, it restores the filesystem to a - * pristine state. + * We will later call TclResetFilesystem to restore the FS to a pristine + * state. * * Results: * None. * * Side effects: - * Frees memory allocated for the filesystem. + * Frees any memory allocated by the filesystem. * *---------------------------------------------------------------------- */ @@ -741,9 +817,8 @@ TclFinalizeFilesystem(void) FilesystemRecord *fsRecPtr; /* - * Assume that only one thread is active. Otherwise mutexes would be needed - * around this code. - * TO DO: This assumption is false, isn't it? + * Assumption that only one thread is active now. Otherwise we would need + * to put various mutexes around this code. */ if (cwdPathPtr != NULL) { @@ -758,34 +833,34 @@ TclFinalizeFilesystem(void) /* * Remove all filesystems, freeing any allocated memory that is no longer - * needed. + * needed */ - TclZipfsFinalize(); fsRecPtr = filesystemList; while (fsRecPtr != NULL) { FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr; - /* - * The native filesystem is static, so don't free it. - */ + /* The native filesystem is static, so we don't free it. */ if (fsRecPtr != &nativeFilesystemRecord) { - ckfree(fsRecPtr); + ckfree((char *)fsRecPtr); } fsRecPtr = tmpFsRecPtr; } - if (++theFilesystemEpoch == 0) { - ++theFilesystemEpoch; - } + theFilesystemEpoch++; filesystemList = NULL; /* - * filesystemList is now NULL. Any attempt to use the filesystem is likely - * to fail. + * Now filesystemList is NULL. This means that any attempt to use the + * filesystem is likely to fail. */ -#ifdef _WIN32 +#ifdef USE_OBSOLETE_FS_HOOKS + statProcList = NULL; + accessProcList = NULL; + openFileChannelProcList = NULL; +#endif +#ifdef __WIN32__ TclWinEncodingsCleanup(); #endif } @@ -810,9 +885,16 @@ void TclResetFilesystem(void) { filesystemList = &nativeFilesystemRecord; - if (++theFilesystemEpoch == 0) { - ++theFilesystemEpoch; - } + theFilesystemEpoch++; + +#ifdef __WIN32__ + /* + * Cleans up the win32 API filesystem proc lookup table. This must happen + * very late in finalization so that deleting of copied dlls can occur. + */ + + TclWinResetInterfaces(); +#endif } /* @@ -820,32 +902,35 @@ TclResetFilesystem(void) * * Tcl_FSRegister -- * - * Prepends to the list of registered fileystems a new FilesystemRecord - * for the given Tcl_Filesystem, which is added even if it is already in - * the list. To determine whether the filesystem is already in the list, - * use Tcl_FSData(). + * Insert the filesystem function table at the head of the list of + * functions which are used during calls to all file-system operations. + * The filesystem will be added even if it is already in the list. (You + * can use Tcl_FSData to check if it is in the list, provided the + * ClientData used was not NULL). + * + * Note that the filesystem handling is head-to-tail of the list. Each + * filesystem is asked in turn whether it can handle a particular + * request, until one of them says 'yes'. At that point no further + * filesystems are asked. * - * Functions that use the list generally process it from head to tail and - * use the first filesystem that is suitable. Therefore, when adding a - * diagnostic filsystem (one which simply reports all fs activity), it - * must be at the head of the list. I.e. it must be the last one - * registered. + * In particular this means if you want to add a diagnostic filesystem + * (which simply reports all fs activity), it must be at the head of the + * list: i.e. it must be the last registered. * * Results: - * TCL_OK, or TCL_ERROR if memory for a new node in the list could + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could * not be allocated. * * Side effects: - * Allocates memory for a filesystem record and modifies the list of - * registered filesystems. + * Memory allocated and modifies the link list for filesystems. * *---------------------------------------------------------------------- */ int Tcl_FSRegister( - void *clientData, /* Client-specific data for this filesystem. */ - const Tcl_Filesystem *fsPtr)/* The filesystem record for the new fs. */ + ClientData clientData, /* Client specific data for this fs */ + Tcl_Filesystem *fsPtr) /* The filesystem record for the new fs. */ { FilesystemRecord *newFilesystemPtr; @@ -853,11 +938,24 @@ Tcl_FSRegister( return TCL_ERROR; } - newFilesystemPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord)); + newFilesystemPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord)); newFilesystemPtr->clientData = clientData; newFilesystemPtr->fsPtr = fsPtr; + /* + * Is this lock and wait strictly speaking necessary? Since any iterators + * out there will have grabbed a copy of the head of the list and be + * iterating away from that, if we add a new element to the head of the + * list, it can't possibly have any effect on any of their loops. In fact + * it could be better not to wait, since we are adjusting the filesystem + * epoch, any cached representations calculated by existing iterators are + * going to have to be thrown away anyway. + * + * However, since registering and unregistering filesystems is a very rare + * action, this is not a very important point. + */ + Tcl_MutexLock(&filesystemMutex); newFilesystemPtr->nextPtr = filesystemList; @@ -868,13 +966,11 @@ Tcl_FSRegister( filesystemList = newFilesystemPtr; /* - * Increment the filesystem epoch counter since existing pathnames might + * Increment the filesystem epoch counter, since existing paths might * conceivably now belong to different filesystems. */ - if (++theFilesystemEpoch == 0) { - ++theFilesystemEpoch; - } + theFilesystemEpoch++; Tcl_MutexUnlock(&filesystemMutex); return TCL_OK; @@ -885,26 +981,28 @@ Tcl_FSRegister( * * Tcl_FSUnregister -- * - * Removes the record for given filesystem from the list of registered - * filesystems. Refuses to remove the built-in (native) filesystem. This - * might be changed in the future to allow a smaller Tcl core in which the - * native filesystem is not used at all, e.g. initializing Tcl over a - * network connection. + * Remove the passed filesystem from the list of filesystem function + * tables. It also ensures that the built-in (native) filesystem is not + * removable, although we may wish to change that decision in the future + * to allow a smaller Tcl core, in which the native filesystem is not + * used at all (we could, say, initialise Tcl completely over a network + * connection). * * Results: - * TCL_OK if the function pointer was successfully removed, or TCL_ERROR + * TCL_OK if the function pointer was successfully removed, TCL_ERROR * otherwise. * * Side effects: - * The list of registered filesystems is updated. Memory for the - * corresponding FilesystemRecord is eventually freed. + * Memory may be deallocated (or will be later, once no "path" objects + * refer to this filesystem), but the list of registered filesystems is + * updated immediately. * *---------------------------------------------------------------------- */ int Tcl_FSUnregister( - const Tcl_Filesystem *fsPtr)/* The filesystem record to remove. */ + Tcl_Filesystem *fsPtr) /* The filesystem record to remove. */ { int retVal = TCL_ERROR; FilesystemRecord *fsRecPtr; @@ -912,9 +1010,9 @@ Tcl_FSUnregister( Tcl_MutexLock(&filesystemMutex); /* - * Traverse filesystemList in search of the record whose - * 'fsPtr' member matches 'fsPtr' and remove that record from the list. - * Do not revmoe the record for the native filesystem. + * Traverse the 'filesystemList' looking for the particular node whose + * 'fsPtr' member matches 'fsPtr' and remove that one from the list. + * Ensure that the "default" node cannot be removed. */ fsRecPtr = filesystemList; @@ -930,16 +1028,16 @@ Tcl_FSUnregister( } /* - * Each cached pathname could now belong to a different filesystem, - * so increment the filesystem epoch counter to ensure that cached - * information about the removed filesystem is not used. + * Increment the filesystem epoch counter, since existing paths + * might conceivably now belong to different filesystems. This + * should also ensure that paths which have cached the filesystem + * which is about to be deleted do not reference that filesystem + * (which would of course lead to memory exceptions). */ - if (++theFilesystemEpoch == 0) { - ++theFilesystemEpoch; - } + theFilesystemEpoch++; - ckfree(fsRecPtr); + ckfree((char *)fsRecPtr); retVal = TCL_OK; } else { @@ -956,49 +1054,63 @@ Tcl_FSUnregister( * * Tcl_FSMatchInDirectory -- * - * Search in the given pathname for files matching the given pattern. - * Used by [glob]. Processes just one pattern for one directory. Callers - * such as TclGlob and DoGlob implement manage the searching of multiple - * directories in cases such as - * glob -dir $dir -join * pkgIndex.tcl + * This routine is used by the globbing code to search a directory for + * all files which match a given pattern. The appropriate function for + * the filesystem to which pathPtr belongs will be called. If pathPtr + * does not belong to any filesystem and if it is NULL or the empty + * string, then we assume the pattern is to be matched in the current + * working directory. To avoid have the Tcl_FSMatchInDirectoryProc for + * each filesystem from having to deal with this issue, we create a + * pathPtr on the fly (equal to the cwd), and then remove it from the + * results returned. This makes filesystems easy to write, since they can + * assume the pathPtr passed to them is an ordinary path. In fact this + * means we could remove such special case handling from Tcl's native + * filesystems. + * + * If 'pattern' is NULL, then pathPtr is assumed to be a fully specified + * path of a single file/directory which must be checked for existence + * and correct type. * * Results: * - * TCL_OK, or TCL_ERROR + * The return value is a standard Tcl result indicating whether an error + * occurred in globbing. Error messages are placed in interp, but good + * results are placed in the resultPtr given. + * + * Recursive searches, e.g. + * glob -dir $dir -join * pkgIndex.tcl + * which must recurse through each directory matching '*' are handled + * internally by Tcl, by passing specific flags in a modified 'types' + * parameter. This means the actual filesystem only ever sees patterns + * which match in a single directory. * * Side effects: - * resultPtr is populated, or in the case of an TCL_ERROR, an error message is - * set in the interpreter. + * The interpreter may have an error message inserted into it. * *---------------------------------------------------------------------- */ int Tcl_FSMatchInDirectory( - Tcl_Interp *interp, /* Interpreter to receive error messages, or - * NULL */ - Tcl_Obj *resultPtr, /* List that results are added to. */ - Tcl_Obj *pathPtr, /* Pathname of directory to search. If NULL, - * the current working directory is used. */ - const char *pattern, /* Pattern to match. If NULL, pathPtr must be - * a fully-specified pathname of a single - * file/directory which already exists and is - * of the correct type. */ - Tcl_GlobTypeData *types) /* Specifies acceptable types. - * May be NULL. The directory flag is - * particularly significant. */ + 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. */ { const Tcl_Filesystem *fsPtr; Tcl_Obj *cwd, *tmpResultPtr, **elemsPtr; - Tcl_Size resLength, i; - int ret = -1; + int resLength, i, ret = -1; - if (types != NULL && (types->type & TCL_GLOB_TYPE_MOUNT)) { + if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) { /* - * Currently external callers may not query mounts, which would be a - * valuable future step. This is the only routine that knows about - * mounts, so we're being called recursively by ourself. Return no - * matches. + * We don't currently allow querying of mounts by external code (a + * valuable future step), so since we're the only function that + * actually knows about mounts, this means we're being called + * recursively by ourself. Return no matches. */ return TCL_OK; @@ -1010,46 +1122,49 @@ Tcl_FSMatchInDirectory( fsPtr = NULL; } - if (fsPtr != NULL) { - /* - * A corresponding filesystem was found. Search within it. - */ + /* + * Check if we've successfully mapped the path to a filesystem within + * which to search. + */ + if (fsPtr != NULL) { if (fsPtr->matchInDirectoryProc == NULL) { 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); } return ret; } - if (pathPtr != NULL && TclGetString(pathPtr)[0] != '\0') { - /* - * There is a pathname but it belongs to no known filesystem. Mayday! - */ + /* + * If the path isn't empty, we have no idea how to match files in a + * directory which belongs to no known filesystem + */ + if (pathPtr != NULL && TclGetString(pathPtr)[0] != '\0') { Tcl_SetErrno(ENOENT); return -1; } /* - * The pathname is empty or NULL so search in the current working - * directory. matchInDirectoryProc prefixes each result with this - * directory, so trim it from each result. Deal with this here in the - * generic code because otherwise every filesystem implementation of - * Tcl_FSMatchInDirectory has to do it. + * We have an empty or NULL path. This is defined to mean we must search + * for files within the current 'cwd'. We therefore use that, but then + * since the proc we call will return results which include the cwd we + * must then trim it off the front of each path in the result. We choose + * to deal with this here (in the generic code), since if we don't, every + * single filesystem's implementation of Tcl_FSMatchInDirectory will have + * to deal with it for us. */ cwd = Tcl_FSGetCwd(NULL); if (cwd == NULL) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "glob couldn't determine the current working directory", - -1)); + Tcl_SetResult(interp, "glob couldn't determine " + "the current working directory", TCL_STATIC); } return TCL_ERROR; } @@ -1058,16 +1173,16 @@ Tcl_FSMatchInDirectory( if (fsPtr != NULL && fsPtr->matchInDirectoryProc != NULL) { TclNewObj(tmpResultPtr); Tcl_IncrRefCount(tmpResultPtr); - ret = fsPtr->matchInDirectoryProc(interp, tmpResultPtr, cwd, pattern, - types); + ret = (*fsPtr->matchInDirectoryProc)(interp, tmpResultPtr, cwd, + pattern, types); if (ret == TCL_OK) { FsAddMountsToGlobResult(tmpResultPtr, cwd, pattern, types); /* - * resultPtr and tmpResultPtr are guaranteed to be distinct. + * Note that we know resultPtr and tmpResultPtr are distinct. */ - ret = TclListObjGetElements(interp, tmpResultPtr, + ret = Tcl_ListObjGetElements(interp, tmpResultPtr, &resLength, &elemsPtr); for (i=0 ; ret==TCL_OK && i<resLength ; i++) { ret = Tcl_ListObjAppendElement(interp, resultPtr, @@ -1084,30 +1199,32 @@ Tcl_FSMatchInDirectory( *---------------------------------------------------------------------- * * FsAddMountsToGlobResult -- - * Adds any mounted pathnames to a set of results so that simple things - * like 'glob *' merge mounts and listings correctly. Used by the - * Tcl_FSMatchInDirectory. + * + * This routine is used by the globbing code to take the results of a + * directory listing and add any mounted paths to that listing. This is + * required so that simple things like 'glob *' merge mounts and listings + * correctly. * * Results: * None. * * Side effects: - * Stores a result in resultPtr. + * Modifies the resultPtr. * *---------------------------------------------------------------------- */ static void FsAddMountsToGlobResult( - Tcl_Obj *resultPtr, /* The current list of matching pathnames. Must - * not be shared. */ - Tcl_Obj *pathPtr, /* The directory that was searched. */ - const char *pattern, /* Pattern to match mounts against. */ - Tcl_GlobTypeData *types) /* Acceptable types. May be NULL. The - * directory flag is particularly significant. - */ + Tcl_Obj *resultPtr, /* The current list of matching paths; must + * not be shared! */ + Tcl_Obj *pathPtr, /* The directory in question */ + const char *pattern, /* Pattern to match against. */ + Tcl_GlobTypeData *types) /* Object containing list of acceptable types. + * May be NULL. In particular the directory + * flag is very important. */ { - Tcl_Size mLength, gLength, i; + int mLength, gLength, i; int dir = (types == NULL || (types->type & TCL_GLOB_TYPE_DIR)); Tcl_Obj *mounts = FsListMounts(pathPtr, pattern); @@ -1115,15 +1232,15 @@ FsAddMountsToGlobResult( return; } - if (TclListObjLength(NULL, mounts, &mLength) != TCL_OK || mLength == 0) { + if (Tcl_ListObjLength(NULL, mounts, &mLength) != TCL_OK || mLength == 0) { goto endOfMounts; } - if (TclListObjLength(NULL, resultPtr, &gLength) != TCL_OK) { + if (Tcl_ListObjLength(NULL, resultPtr, &gLength) != TCL_OK) { goto endOfMounts; } for (i=0 ; i<mLength ; i++) { Tcl_Obj *mElt; - Tcl_Size j; + int j; int found = 0; Tcl_ListObjIndex(NULL, mounts, i, &mElt); @@ -1142,25 +1259,25 @@ FsAddMountsToGlobResult( Tcl_ListObjReplace(NULL, resultPtr, j, 1, 0, NULL); gLength--; } - break; /* Break out of for loop. */ + break; /* Break out of for loop */ } } if (!found && dir) { Tcl_Obj *norm; - Tcl_Size len, mlen; + int len, mlen; /* - * mElt is normalized and lies inside pathPtr so - * add to the result the right representation of mElt, - * i.e. the representation relative to pathPtr. + * We know mElt is absolute normalized and lies inside pathPtr, so + * now we must add to the result the right representation of mElt, + * i.e. the representation which is relative to pathPtr. */ norm = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (norm != NULL) { const char *path, *mount; - mount = TclGetStringFromObj(mElt, &mlen); - path = TclGetStringFromObj(norm, &len); + mount = Tcl_GetStringFromObj(mElt, &mlen); + path = Tcl_GetStringFromObj(norm, &len); if (path[len-1] == '/') { /* * Deal with the root of the volume. @@ -1168,14 +1285,13 @@ FsAddMountsToGlobResult( len--; } - len++; /* account for '/' in the mElt [Bug 1602539] */ - - + len++; /* account for '/' in the mElt [Bug 1602539] */ mElt = TclNewFSPathObj(pathPtr, mount + len, mlen - len); Tcl_ListObjAppendElement(NULL, resultPtr, mElt); } /* - * Not comparing mounts to mounts, so no need to increment gLength + * No need to increment gLength, since we don't want to compare + * mounts against mounts. */ } } @@ -1189,62 +1305,67 @@ FsAddMountsToGlobResult( * * Tcl_FSMountsChanged -- * - * Announecs that mount points have changed or that the system encoding - * has changed. + * Notify the filesystem that the available mounted filesystems (or + * within any one filesystem type, the number or location of mount + * points) have changed. * * Results: * None. * * Side effects: - * The shared 'theFilesystemEpoch' is incremented, invalidating every - * exising cached internal representation of a pathname. Avoid calling - * Tcl_FSMountsChanged whenever possible. It must be called when: + * The global filesystem variable 'theFilesystemEpoch' is incremented. + * The effect of this is to make all cached path representations invalid. + * Clearly it should only therefore be called when it is really required! + * There are a few circumstances when it should be called: * - * (1) A filesystem is registered or unregistered. This is only necessary - * if the new filesystem accepts file pathnames as-is. Normally the - * filesystem is really a shell which doesn't yet have any mount points - * established and so its 'pathInFilesystem' routine always fails. - * However, for safety, Tcl calls 'Tcl_FSMountsChanged' each time a - * filesystem is registered or unregistered. + * (1) when a new filesystem is registered or unregistered. Strictly + * speaking this is only necessary if the new filesystem accepts file + * paths as is (normally the filesystem itself is really a shell which + * hasn't yet had any mount points established and so its + * 'pathInFilesystem' proc will always fail). However, for safety, Tcl + * always calls this for you in these circumstances. * - * (2) An additional mount point is established inside an existing - * filesystem (except for the native file system; see note below). + * (2) when additional mount points are established inside any existing + * filesystem (except the native fs) * - * (3) A filesystem changes the list of available volumes (except for the - * native file system; see note below). + * (3) when any filesystem (except the native fs) changes the list of + * available volumes. * - * (4) The mapping from a string representation of a file to a full, - * normalized pathname changes. For example, if 'env(HOME)' is modified, - * then any pathname containing '~' maps to a different item, possibly in - * a different filesystem. + * (4) when the mapping from a string representation of a file to a full, + * normalized path changes. For example, if 'env(HOME)' is modified, then + * any path containing '~' will map to a different filesystem location. + * Therefore all such paths need to have their internal representation + * invalidated. * - * Tcl has no control over (2) and (3), so each registered filesystem must - * call Tcl_FSMountsChnaged in each of those circumstances. + * Tcl has no control over (2) and (3), so any registered filesystem must + * make sure it calls this function when those situations occur. * - * The reason for the exception in 2,3 for the native filesystem is that - * the native filesystem claims every file without determining whether - * whether the file exists, or even whether the pathname makes sense. + * (Note: the reason for the exception in 2,3 for the native filesystem + * is that the native filesystem by default claims all unknown files even + * if it really doesn't understand them or if they don't exist). * *---------------------------------------------------------------------- */ void Tcl_FSMountsChanged( - TCL_UNUSED(const Tcl_Filesystem *) /*fsPtr*/) + Tcl_Filesystem *fsPtr) +{ /* - * fsPtr is currently unused. In the future it might invalidate files for - * a particular filesystem, or take some other more advanced action. + * We currently don't do anything with this parameter. We could in the + * future only invalidate files for this filesystem or otherwise take more + * advanced action. */ -{ + + (void)fsPtr; + /* - * Increment the filesystem epoch to invalidate every existing cached - * internal representation. + * Increment the filesystem epoch counter, since existing paths might now + * belong to different filesystems. */ Tcl_MutexLock(&filesystemMutex); - if (++theFilesystemEpoch == 0) { - ++theFilesystemEpoch; - } + theFilesystemEpoch++; Tcl_MutexUnlock(&filesystemMutex); } @@ -1253,11 +1374,13 @@ Tcl_FSMountsChanged( * * Tcl_FSData -- * - * Retrieves the clientData member of the given filesystem. + * Retrieve the clientData field for the filesystem given, or NULL if + * that filesystem is not registered. * * Results: - * A clientData value, or NULL if the given filesystem is not registered. - * The clientData value itself may also be NULL. + * A clientData value, or NULL. Note that if the filesystem was + * registered with a NULL clientData field, this function will return + * that NULL value. * * Side effects: * None. @@ -1265,16 +1388,17 @@ Tcl_FSMountsChanged( *---------------------------------------------------------------------- */ -void * +ClientData Tcl_FSData( - const Tcl_Filesystem *fsPtr) /* The filesystem to find in the list of - * registered filesystems. */ + Tcl_Filesystem *fsPtr) /* The filesystem record to query. */ { - void *retVal = NULL; + ClientData retVal = NULL; FilesystemRecord *fsRecPtr = FsGetFirstFilesystem(); /* - * Find the filesystem in and retrieve its clientData. + * Traverse the list of filesystems look for a particular one. If found, + * return that filesystem's clientData (originally provided when calling + * Tcl_FSRegister). */ while ((retVal == NULL) && (fsRecPtr != NULL)) { @@ -1292,24 +1416,27 @@ Tcl_FSData( * * TclFSNormalizeToUniquePath -- * - * Converts the given pathname, containing no ../, ./ components, into a - * unique pathname for the given platform. On Unix the resulting pathname - * is free of symbolic links/aliases, and on Windows it is the long - * case-preserving form. - * + * Takes a path specification containing no ../, ./ sequences, and + * converts it into a unique path for the given platform. On Unix, this + * means the path must be free of symbolic links/aliases, and on Windows + * it means we want the long form, with that long form's case-dependence + * (which gives us a unique, case-dependent path). * * Results: - * Stores the resulting pathname in pathPtr and returns the offset of the - * last byte processed in pathPtr. + * The pathPtr is modified in place. The return value is the last byte + * offset which was recognised in the path string. * * Side effects: * None (beyond the memory allocation for the result). * * Special notes: - * If the filesystem-specific normalizePathProcs can reintroduce ../, ./ - * components into the pathname, this function does not return the correct - * result. This may be possible with symbolic links on unix. + * If the filesystem-specific normalizePathProcs can re-introduce ../, ./ + * sequences into the path, then this function will not return the + * correct result. This may be possible with symbolic links on unix. * + * Important assumption: if startAt is non-zero, it must point to a + * directory separator that we know exists and is already normalized (so + * it is important not to point to the char just after the separator). * *--------------------------------------------------------------------------- */ @@ -1317,92 +1444,52 @@ Tcl_FSData( int TclFSNormalizeToUniquePath( Tcl_Interp *interp, /* Used for error messages. */ - Tcl_Obj *pathPtr, /* An Pathname to normalize in-place. Must be - * unshared. */ - int startAt) /* Offset the string of pathPtr to start at. - * Must either be 0 or offset of a directory - * separator at the end of a pathname part that - * is already normalized, I.e. not the index of - * the byte just after the separator. */ + Tcl_Obj *pathPtr, /* The path to normalize in place */ + int startAt) /* Start at this char-offset */ { FilesystemRecord *fsRecPtr, *firstFsRecPtr; - Tcl_Size i; - int isVfsPath = 0; - const char *path; - /* - * Pathnames starting with a UNC prefix and ending with a colon character - * are reserved for VFS use. These names can not conflict with real UNC - * pathnames per https://msdn.microsoft.com/en-us/library/gg465305.aspx and - * rfc3986's definition of reg-name. - * - * We check these first to avoid useless calls to the native filesystem's - * normalizePathProc. + * Call each of the "normalise path" functions in succession. This is a + * special case, in which if we have a native filesystem handler, we call + * it first. This is because the root of Tcl's filesystem is always a + * native filesystem (i.e. '/' on unix is native). */ - path = TclGetStringFromObj(pathPtr, &i); - if ( (i >= 3) && ( (path[0] == '/' && path[1] == '/') - || (path[0] == '\\' && path[1] == '\\') ) ) { - for ( i = 2; ; i++) { - if (path[i] == '\0') break; - if (path[i] == path[0]) break; - } - --i; - if (path[i] == ':') isVfsPath = 1; - } - - /* - * Call the the normalizePathProc routine of each registered filesystem. - */ firstFsRecPtr = FsGetFirstFilesystem(); Claim(); + fsRecPtr = firstFsRecPtr; + while (fsRecPtr != NULL) { + if (fsRecPtr->fsPtr == &tclNativeFilesystem) { + Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc; + if (proc != NULL) { + startAt = (*proc)(interp, pathPtr, startAt); + } + break; + } + fsRecPtr = fsRecPtr->nextPtr; + } - if (!isVfsPath) { - + fsRecPtr = firstFsRecPtr; + while (fsRecPtr != NULL) { /* - * Find and call the native filesystem handler first if there is one - * because the root of Tcl's filesystem is always a native filesystem - * (i.e., '/' on unix is native). + * Skip the native system next time through. */ - for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) { - if (fsRecPtr->fsPtr != &tclNativeFilesystem) { - continue; - } - - /* - * TODO: Always call the normalizePathProc here because it should - * always exist. - */ - - if (fsRecPtr->fsPtr->normalizePathProc != NULL) { - startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr, - startAt); + if (fsRecPtr->fsPtr != &tclNativeFilesystem) { + Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc; + if (proc != NULL) { + startAt = (*proc)(interp, pathPtr, startAt); } - break; - } - } - for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) { - if (fsRecPtr->fsPtr == &tclNativeFilesystem) { /* - * Skip the native system this time through. + * We could add an efficiency check like this: + * if (retVal == length-of(pathPtr)) {break;} + * but there's not much benefit. */ - continue; - } - - if (fsRecPtr->fsPtr->normalizePathProc != NULL) { - startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr, - startAt); } - - /* - * This efficiency check could be added: - * if (retVal == length-of(pathPtr)) {break;} - * but there's not much benefit. - */ + fsRecPtr = fsRecPtr->nextPtr; } Disclaim(); @@ -1414,27 +1501,26 @@ TclFSNormalizeToUniquePath( * * TclGetOpenMode -- * - * Obsolete. A limited version of TclGetOpenModeEx() which exists only to - * satisfy any extensions imprudently using it via Tcl's internal stubs - * table. + * This routine is an obsolete, limited version of TclGetOpenModeEx() + * below. It exists only to satisfy any extensions imprudently using it + * via Tcl's internal stubs table. * * Results: - * See TclGetOpenModeEx(). + * Same as TclGetOpenModeEx(). * * Side effects: - * See TclGetOpenModeEx(). + * Same as TclGetOpenModeEx(). * *--------------------------------------------------------------------------- */ int TclGetOpenMode( - Tcl_Interp *interp, /* Interpreter to use for error reporting. May - * be NULL. */ - const char *modeString, /* e.g. "r+" or "RDONLY CREAT". */ - int *seekFlagPtr) /* Sets this to 1 to tell the caller to seek to - EOF after opening the file, and - * 0 otherwise. */ + 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); @@ -1445,45 +1531,46 @@ TclGetOpenMode( * * TclGetOpenModeEx -- * - * Computes a POSIX mode mask for opening a file. + * Computes a POSIX mode mask for opening a file, from a given string, + * and also sets flags to indicate whether the caller should seek to EOF + * after opening the file, and whether the caller should configure the + * channel for binary data. * * Results: - * The mode to pass to "open", or -1 if an error occurs. + * On success, returns mode to pass to "open". If an error occurs, the + * return value is -1 and if interp is not NULL, sets interp's result + * object to an error message. * * Side effects: - * Sets *seekFlagPtr to 1 to tell the caller to - * seek to EOF after opening the file, or to 0 otherwise. - * - * Sets *binaryPtr to 1 to tell the caller to configure the channel as a - * binary channel, or to 0 otherwise. - * - * If there is an error and interp is not NULL, sets interpreter result to - * an error message. + * Sets the integer referenced by seekFlagPtr to 1 to tell the caller to + * seek to EOF after opening the file, or to 0 otherwise. Sets the + * integer referenced by binaryPtr to 1 to tell the caller to seek to + * configure the channel for binary data, or to 0 otherwise. * * Special note: - * Based on a prototype implementation contributed by Mark Diekhans. + * This code is based on a prototype implementation contributed by Mark + * Diekhans. * *--------------------------------------------------------------------------- */ int TclGetOpenModeEx( - Tcl_Interp *interp, /* Interpreter, possibly NULL, to use for - * error reporting. */ + 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, /* Sets this to 1 to tell the the caller to seek to - * EOF after opening the file, and 0 otherwise. */ - int *binaryPtr) /* Sets this to 1 to tell the caller to - * configure the channel for binary - * operations after opening the file. */ + 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, c, gotRW; - Tcl_Size modeArgc, i; + int mode, modeArgc, c, i, gotRW; const char **modeArgv, *flag; #define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR) /* - * Check for the simpler fopen-like access modes like "r" which 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. */ @@ -1493,7 +1580,8 @@ TclGetOpenModeEx( mode = 0; /* - * Guard against wide characters before using byte-oriented routines. + * Guard against international characters before using byte oriented + * routines. */ if (!(modeString[0] & 0x80) @@ -1507,7 +1595,7 @@ TclGetOpenModeEx( break; case 'a': /* - * Add O_APPEND for proper automatic seek-to-end-on-write by the + * Added O_APPEND for proper automatic seek-to-end-on-write by the * OS. [Bug 680143] */ @@ -1517,7 +1605,7 @@ TclGetOpenModeEx( default: goto error; } - i = 1; + i=1; while (i<3 && modeString[i]) { if (modeString[i] == modeString[i-1]) { goto error; @@ -1525,8 +1613,8 @@ TclGetOpenModeEx( switch (modeString[i++]) { case '+': /* - * Remove O_APPEND so that the seek command works. [Bug - * 1773127] + * Must remove the O_APPEND flag so that the seek command + * works. [Bug 1773127] */ mode &= ~(O_RDONLY|O_WRONLY|O_APPEND); @@ -1548,16 +1636,18 @@ TclGetOpenModeEx( *seekFlagPtr = 0; *binaryPtr = 0; if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "illegal access mode \"%s\"", modeString)); + Tcl_AppendResult(interp, "illegal access mode \"", modeString, + "\"", NULL); } return -1; } /* - * The access modes are specified as a list of POSIX modes like O_CREAT. + * The access modes are specified using a list of POSIX modes such as + * O_CREAT. * - * Tcl_SplitList must work correctly when interp is NULL. + * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when a NULL + * interpreter is passed in. */ if (Tcl_SplitList(interp, modeString, &modeArgc, &modeArgv) != TCL_OK) { @@ -1596,11 +1686,10 @@ TclGetOpenModeEx( mode |= O_NOCTTY; #else if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "access mode \"%s\" not supported by this system", - flag)); + Tcl_AppendResult(interp, "access mode \"", flag, + "\" not supported by this system", NULL); } - ckfree(modeArgv); + ckfree((char *) modeArgv); return -1; #endif @@ -1609,11 +1698,10 @@ TclGetOpenModeEx( mode |= O_NONBLOCK; #else if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "access mode \"%s\" not supported by this system", - flag)); + Tcl_AppendResult(interp, "access mode \"", flag, + "\" not supported by this system", NULL); } - ckfree(modeArgv); + ckfree((char *) modeArgv); return -1; #endif @@ -1624,23 +1712,21 @@ TclGetOpenModeEx( } else { 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)); + Tcl_AppendResult(interp, "invalid access mode \"", flag, + "\": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, " + "CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC", NULL); } - ckfree(modeArgv); + ckfree((char *) modeArgv); return -1; } } - ckfree(modeArgv); + ckfree((char *) modeArgv); if (!gotRW) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "access mode must include either RDONLY, WRONLY, or RDWR", - -1)); + Tcl_AppendResult(interp, "access mode must include either" + " RDONLY, WRONLY, or RDWR", NULL); } return -1; } @@ -1648,53 +1734,51 @@ TclGetOpenModeEx( } /* + * Tcl_FSEvalFile is Tcl_FSEvalFileEx without encoding argument. + */ + +int +Tcl_FSEvalFile( + Tcl_Interp *interp, /* Interpreter in which to process file. */ + Tcl_Obj *pathPtr) /* Path of file to process. Tilde-substitution + * will be performed on this name. */ +{ + return Tcl_FSEvalFileEx(interp, pathPtr, NULL); +} + +/* *---------------------------------------------------------------------- * - * Tcl_FSEvalFile, Tcl_FSEvalFileEx, TclNREvalFile -- + * Tcl_FSEvalFileEx -- * - * Reads a file and evaluates it as a script. - * - * Tcl_FSEvalFile is Tcl_FSEvalFileEx without the encoding argument. - * - * TclNREvalFile is an NRE-enabled version of Tcl_FSEvalFileEx. + * Read in a file and process the entire file as one gigantic Tcl + * command. * * Results: * A standard Tcl result, which is either the result of executing the * file or an error indicating why the file couldn't be read. * * Side effects: - * Arbitrary, depending on the contents of the script. While the script - * is evaluated iPtr->scriptFile is a reference to pathPtr, and after the - * evaluation completes, has its original value restored again. + * Depends on the commands in the file. During the evaluation of the + * contents of the file, iPtr->scriptFile is made to point to pathPtr + * (the old value is cached and replaced when this function returns). * *---------------------------------------------------------------------- */ int -Tcl_FSEvalFile( - Tcl_Interp *interp, /* Interpreter that evaluates the script. */ - Tcl_Obj *pathPtr) /* Pathname of file containing the script. - * Tilde-substitution is performed on this - * pathname. */ -{ - return Tcl_FSEvalFileEx(interp, pathPtr, NULL); -} - -int Tcl_FSEvalFileEx( - Tcl_Interp *interp, /* Interpreter that evaluates the script. */ - Tcl_Obj *pathPtr, /* Pathname of the file to process. - * Tilde-substitution is performed on this - * pathname. */ - const char *encodingName) /* Either the name of an encoding or NULL to - use the utf-8 encoding. */ + 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_Size length; - int result = TCL_ERROR; + int length, result = TCL_ERROR; Tcl_StatBuf statBuf; Tcl_Obj *oldScriptFile; Interp *iPtr; - const char *string; + char *string; Tcl_Channel chan; Tcl_Obj *objPtr; @@ -1704,67 +1788,59 @@ Tcl_FSEvalFileEx( 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))); + Tcl_AppendResult(interp, "couldn't read file \"", + Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); return result; } 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))); + if (chan == (Tcl_Channel) NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't read file \"", + Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); return result; } /* - * The eof character is \x1A (^Z). Tcl uses it on every 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", "\x1A {}"); + Tcl_SetChannelOption(interp, chan, "-eofchar", "\32"); /* - * If the encoding is specified, set the channel to that encoding. - * Otherwise use utf-8. If the encoding is unknown report an error. + * 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) { - encodingName = "utf-8"; - } - if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) - != TCL_OK) { - Tcl_Close(interp,chan); - return result; + if (encodingName != NULL) { + if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) + != TCL_OK) { + Tcl_Close(interp,chan); + return result; + } } - TclNewObj(objPtr); + objPtr = Tcl_NewObj(); Tcl_IncrRefCount(objPtr); - - /* - * Read first character of stream to check for utf-8 BOM + /* 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) == TCL_IO_FAILURE) { + 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_AppendResult(interp, "couldn't read file \"", + Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); goto end; } string = Tcl_GetString(objPtr); - /* - * If first character is not a BOM, append the remaining characters. - * Otherwise, replace them. [Bug 3466099] + * If first character is not a BOM, append the remaining characters, + * otherwise replace them [Bug 3466099]. */ - - if (Tcl_ReadChars(chan, objPtr, TCL_INDEX_NONE, - memcmp(string, "\xEF\xBB\xBF", 3)) == TCL_IO_FAILURE) { + 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_AppendResult(interp, "couldn't read file \"", + Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); goto end; } @@ -1776,19 +1852,16 @@ Tcl_FSEvalFileEx( oldScriptFile = iPtr->scriptFile; iPtr->scriptFile = pathPtr; Tcl_IncrRefCount(iPtr->scriptFile); - string = TclGetStringFromObj(objPtr, &length); - - /* - * TIP #280: Open a frame for the evaluated script. - */ - + string = Tcl_GetStringFromObj(objPtr, &length); + /* TIP #280 Force the evaluator to open a frame for a sourced + * file. */ iPtr->evalFlags |= TCL_EVAL_FILE; - result = TclEvalEx(interp, string, length, 0, 1, NULL, string); + result = Tcl_EvalEx(interp, string, length, 0); /* - * Restore the original iPtr->scriptFile value, but because the value may - * have hanged during evaluation, don't assume it currently points to - * pathPtr. + * 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) { @@ -1800,190 +1873,39 @@ Tcl_FSEvalFileEx( result = TclUpdateReturnInfo(iPtr); } else if (result == TCL_ERROR) { /* - * Record information about where the error occurred. + * Record information telling where the error occurred. */ - const char *pathString = TclGetStringFromObj(pathPtr, &length); + 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))); + (overflow ? "..." : ""), interp->errorLine)); } end: Tcl_DecrRefCount(objPtr); return result; } - -int -TclNREvalFile( - Tcl_Interp *interp, /* Interpreter in which to evaluate the script. */ - Tcl_Obj *pathPtr, /* Pathname of a file containing the script to - * evaluate. Tilde-substitution is performed on - * this pathname. */ - const char *encodingName) /* The name of an encoding to use, or NULL to - * use the utf-8 encoding. */ -{ - Tcl_StatBuf statBuf; - Tcl_Obj *oldScriptFile, *objPtr; - Interp *iPtr; - Tcl_Channel chan; - const char *string; - - if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { - return TCL_ERROR; - } - - if (Tcl_FSStat(pathPtr, &statBuf) == -1) { - Tcl_SetErrno(errno); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); - return TCL_ERROR; - } - chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); - if (chan == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't read file \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); - return TCL_ERROR; - } - TclPkgFileSeen(interp, Tcl_GetString(pathPtr)); - - /* - * The eof character is \x1A (^Z). Tcl uses it on every platform to allow - * for scripted documents. [Bug: 2040] - */ - - Tcl_SetChannelOption(interp, chan, "-eofchar", "\x1A {}"); - - /* - * If the encoding is specified, set the channel to that encoding. - * Otherwise use utf-8. If the encoding is unknown report an error. - */ - - if (encodingName == NULL) { - encodingName = "utf-8"; - } - if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) - != TCL_OK) { - Tcl_Close(interp, chan); - return TCL_ERROR; - } - - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - - /* - * Read first character of stream to check for utf-8 BOM - */ - - if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) { - 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, TCL_INDEX_NONE, - memcmp(string, "\xEF\xBB\xBF", 3)) == TCL_IO_FAILURE) { - 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: Open a frame for the evaluated script. - */ - - iPtr->evalFlags |= TCL_EVAL_FILE; - TclNRAddCallback(interp, EvalFileCallback, oldScriptFile, pathPtr, objPtr, - NULL); - return TclNREvalObjEx(interp, objPtr, 0, NULL, INT_MIN); -} - -static int -EvalFileCallback( - void *data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - Tcl_Obj *oldScriptFile = (Tcl_Obj *)data[0]; - Tcl_Obj *pathPtr = (Tcl_Obj *)data[1]; - Tcl_Obj *objPtr = (Tcl_Obj *)data[2]; - - /* - * Restore the original iPtr->scriptFile value, but because the value may - * have hanged during evaluation, don't assume it currently 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 about where the error occurred. - */ - - Tcl_Size length; - const char *pathString = TclGetStringFromObj(pathPtr, &length); - const int limit = 150; - int overflow = (length > limit); - - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (file \"%.*s%s\" line %d)", - (overflow ? limit : length), pathString, - (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); - } - - Tcl_DecrRefCount(objPtr); - return result; -} /* *---------------------------------------------------------------------- * * Tcl_GetErrno -- * - * Currently the global variable "errno", but could in the future change + * Gets the current value of the Tcl error code variable. This is + * currently the global variable "errno" but could in the future change * to something else. * * Results: - * The current Tcl error number. + * The value of the Tcl error code variable. * * Side effects: - * None. The value of the Tcl error code variable is only defined if it - * was set by a previous call to Tcl_SetErrno. + * None. Note that the value of the Tcl error code variable is UNDEFINED + * if a call to Tcl_SetErrno did not precede this call. * *---------------------------------------------------------------------- */ @@ -1991,11 +1913,6 @@ EvalFileCallback( int Tcl_GetErrno(void) { - /* - * On some platforms errno is thread-local, as implemented by the C - * library. - */ - return errno; } @@ -2004,15 +1921,13 @@ Tcl_GetErrno(void) * * Tcl_SetErrno -- * - * Sets the Tcl error code to the given value. On some saner platforms - * this is implemented in the C library as a thread-local value , but this - * is *really* unsafe to assume! + * Sets the Tcl error code variable to the supplied value. * * Results: * None. * * Side effects: - * Modifies the the Tcl error code value. + * Modifies the value of the Tcl error code variable. * *---------------------------------------------------------------------- */ @@ -2021,11 +1936,6 @@ void Tcl_SetErrno( int err) /* The new value. */ { - /* - * On some platforms, errno is implemented by the C library as a thread - * local value - */ - errno = err; } @@ -2034,28 +1944,31 @@ Tcl_SetErrno( * * Tcl_PosixError -- * - * Typically called after a UNIX kernel call returns an error. Sets the - * interpreter errorCode to machine-parsable information about the error. + * This function is typically called after UNIX kernel calls return + * errors. It stores machine-readable information about the error in + * errorCode field of interp and returns an information string for the + * caller's use. * * Results: - * A human-readable sring describing the error. + * The return value is a human-readable string describing the error. * * Side effects: - * Sets the errorCode value of the interpreter. + * The errorCode field of the interp is set. * *---------------------------------------------------------------------- */ const char * Tcl_PosixError( - Tcl_Interp *interp) /* Interpreter to set the errorCode of */ + Tcl_Interp *interp) /* Interpreter whose errorCode field is to be + * set. */ { const char *id, *msg; msg = Tcl_ErrnoMsg(errno); id = Tcl_ErrnoId(); if (interp) { - Tcl_SetErrorCode(interp, "POSIX", id, msg, (void *)NULL); + Tcl_SetErrorCode(interp, "POSIX", id, msg, NULL); } return msg; } @@ -2064,9 +1977,11 @@ Tcl_PosixError( *---------------------------------------------------------------------- * * Tcl_FSStat -- - * Calls 'statProc' of the filesystem corresponding to pathPtr. * - * Replaces the standard library "stat" routine. + * This function replaces the library version of stat and lsat. + * + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. * * Results: * See stat documentation. @@ -2079,15 +1994,75 @@ Tcl_PosixError( int Tcl_FSStat( - Tcl_Obj *pathPtr, /* Pathname of the file to call stat on (in - * current CP). */ - Tcl_StatBuf *buf) /* A buffer to hold the results of the call to - * stat. */ + Tcl_Obj *pathPtr, /* Path of file to stat (in current CP). */ + Tcl_StatBuf *buf) /* Filled with results of stat call. */ { - const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + const 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. + */ - if (fsPtr != NULL && fsPtr->statProc != NULL) { - return fsPtr->statProc(pathPtr, buf); + Tcl_MutexLock(&obsoleteFsHookMutex); + + if (statProcList != NULL) { + StatProc *statProcPtr; + char *path; + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); + if (transPtr == NULL) { + path = NULL; + } else { + path = Tcl_GetString(transPtr); + } + + statProcPtr = statProcList; + while ((retVal == -1) && (statProcPtr != NULL)) { + retVal = (*statProcPtr->proc)(path, &oldStyleStatBuffer); + statProcPtr = statProcPtr->nextPtr; + } + if (transPtr != NULL) { + Tcl_DecrRefCount(transPtr); + } + } + + Tcl_MutexUnlock(&obsoleteFsHookMutex); + if (retVal != -1) { + /* + * Note that EOVERFLOW is not a problem here, and these assignments + * should all be widening (if not identity.) + */ + + buf->st_mode = oldStyleStatBuffer.st_mode; + buf->st_ino = oldStyleStatBuffer.st_ino; + buf->st_dev = oldStyleStatBuffer.st_dev; + buf->st_rdev = oldStyleStatBuffer.st_rdev; + buf->st_nlink = oldStyleStatBuffer.st_nlink; + buf->st_uid = oldStyleStatBuffer.st_uid; + buf->st_gid = oldStyleStatBuffer.st_gid; + buf->st_size = Tcl_LongAsWide(oldStyleStatBuffer.st_size); + buf->st_atime = oldStyleStatBuffer.st_atime; + buf->st_mtime = oldStyleStatBuffer.st_mtime; + buf->st_ctime = oldStyleStatBuffer.st_ctime; +#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE + buf->st_blksize = oldStyleStatBuffer.st_blksize; +#endif +#ifdef HAVE_STRUCT_STAT_ST_BLOCKS + buf->st_blocks = Tcl_LongAsWide(oldStyleStatBuffer.st_blocks); +#endif + return retVal; + } +#endif /* USE_OBSOLETE_FS_HOOKS */ + + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSStatProc *proc = fsPtr->statProc; + if (proc != NULL) { + return (*proc)(pathPtr, buf); + } } Tcl_SetErrno(ENOENT); return -1; @@ -2097,11 +2072,11 @@ Tcl_FSStat( *---------------------------------------------------------------------- * * Tcl_FSLstat -- - * Calls the 'lstatProc' of the filesystem corresponding to pathPtr. * - * Replaces the library version of lstat. If the filesystem doesn't - * provide lstatProc but does provide statProc, Tcl falls back to - * statProc. + * This function replaces the library version of lstat. The appropriate + * function for the filesystem to which pathPtr belongs will be called. + * If no 'lstat' function is listed, but a 'stat' function is, then Tcl + * will fall back on the stat function. * * Results: * See lstat documentation. @@ -2114,18 +2089,19 @@ Tcl_FSStat( int Tcl_FSLstat( - Tcl_Obj *pathPtr, /* Pathname of the file to call stat on (in - current CP). */ - Tcl_StatBuf *buf) /* Filled with results of that call to stat. */ + Tcl_Obj *pathPtr, /* Path of file to stat (in current CP). */ + Tcl_StatBuf *buf) /* Filled with results of stat call. */ { const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL) { - if (fsPtr->lstatProc != NULL) { - return fsPtr->lstatProc(pathPtr, buf); - } - if (fsPtr->statProc != NULL) { - return fsPtr->statProc(pathPtr, buf); + Tcl_FSLstatProc *proc = fsPtr->lstatProc; + if (proc != NULL) { + return (*proc)(pathPtr, buf); + } else { + Tcl_FSStatProc *sproc = fsPtr->statProc; + if (sproc != NULL) { + return (*sproc)(pathPtr, buf); + } } } Tcl_SetErrno(ENOENT); @@ -2137,9 +2113,8 @@ Tcl_FSLstat( * * Tcl_FSAccess -- * - * Calls 'accessProc' of the filesystem corresponding to pathPtr. - * - * Replaces the library version of access. + * 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. @@ -2152,14 +2127,54 @@ Tcl_FSLstat( int Tcl_FSAccess( - Tcl_Obj *pathPtr, /* Pathname of file to access (in current CP). */ + Tcl_Obj *pathPtr, /* Path of file to access (in current CP). */ int mode) /* Permission setting. */ { - const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + const Tcl_Filesystem *fsPtr; +#ifdef USE_OBSOLETE_FS_HOOKS + int retVal = -1; + + /* + * Call each of the "access" function in succession. A non-return value of + * -1 indicates the particular function has succeeded. + */ + + Tcl_MutexLock(&obsoleteFsHookMutex); - if (fsPtr != NULL && fsPtr->accessProc != NULL) { - return fsPtr->accessProc(pathPtr, mode); + if (accessProcList != NULL) { + AccessProc *accessProcPtr; + char *path; + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); + if (transPtr == NULL) { + path = NULL; + } else { + path = Tcl_GetString(transPtr); + } + + accessProcPtr = accessProcList; + while ((retVal == -1) && (accessProcPtr != NULL)) { + retVal = (*accessProcPtr->proc)(path, mode); + accessProcPtr = accessProcPtr->nextPtr; + } + if (transPtr != NULL) { + Tcl_DecrRefCount(transPtr); + } + } + + Tcl_MutexUnlock(&obsoleteFsHookMutex); + if (retVal != -1) { + return retVal; } +#endif /* USE_OBSOLETE_FS_HOOKS */ + + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSAccessProc *proc = fsPtr->accessProc; + if (proc != NULL) { + return (*proc)(pathPtr, mode); + } + } + Tcl_SetErrno(ENOENT); return -1; } @@ -2169,81 +2184,120 @@ Tcl_FSAccess( * * Tcl_FSOpenFileChannel -- * - * Calls 'openfileChannelProc' of the filesystem corresponding to - * pathPtr. + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. * * Results: - * The new channel, or NULL if the named file could not be opened. + * The new channel or NULL, if the named file could not be opened. * * Side effects: - * Opens a channel, possibly creating the corresponding the file on the - * filesystem. + * May open the channel and may cause creation of a file on the file + * system. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_FSOpenFileChannel( - Tcl_Interp *interp, /* Interpreter for error reporting, or NULL */ - Tcl_Obj *pathPtr, /* Pathname of file to open. */ + Tcl_Interp *interp, /* Interpreter for error reporting; can be + * NULL. */ + Tcl_Obj *pathPtr, /* Name of file to open. */ const char *modeString, /* A list of POSIX open modes or a string such * as "rw". */ - int permissions) /* What modes to use if opening the file - involves creating it. */ + int permissions) /* If the open involves creating a file, with + * what modes to create it? */ { const Tcl_Filesystem *fsPtr; Tcl_Channel retVal = NULL; +#ifdef USE_OBSOLETE_FS_HOOKS + /* + * 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. + */ if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { - /* - * Return the correct error message. - */ return NULL; } fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL && fsPtr->openFileChannelProc != NULL) { - int mode, seekFlag, binary; + if (fsPtr != NULL) { + Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc; + if (proc != NULL) { + int mode, seekFlag, binary; - /* - * Parse the mode to determine whether to seek at the outset - * and/or set the channel into binary mode. - */ + /* + * Parse the mode, picking up whether we want to seek to start + * with and/or set the channel automatically into binary mode. + */ - mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary); - if (mode == -1) { - return NULL; - } + mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary); + if (mode == -1) { + return NULL; + } - /* - * Open the file. - */ + /* + * Do the actual open() call. + */ - retVal = fsPtr->openFileChannelProc(interp, pathPtr, mode, - permissions); - if (retVal == NULL) { - return NULL; - } + retVal = (*proc)(interp, pathPtr, mode, permissions); + if (retVal == NULL) { + return NULL; + } - /* - * Seek and/or set binary mode as determined above. - */ + /* + * 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))); + if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt)0, + SEEK_END) < (Tcl_WideInt)0) { + if (interp != NULL) { + Tcl_AppendResult(interp, "could not seek to end " + "of file while opening \"", Tcl_GetString(pathPtr), + "\": ", Tcl_PosixError(interp), NULL); + } + Tcl_Close(NULL, retVal); + return NULL; } - Tcl_Close(NULL, retVal); - return NULL; - } - if (binary) { - Tcl_SetChannelOption(interp, retVal, "-translation", "binary"); + if (binary) { + Tcl_SetChannelOption(interp, retVal, "-translation", "binary"); + } + return retVal; } - return retVal; } /* @@ -2252,9 +2306,8 @@ Tcl_FSOpenFileChannel( Tcl_SetErrno(ENOENT); if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't open \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "couldn't open \"", Tcl_GetString(pathPtr), + "\": ", Tcl_PosixError(interp), NULL); } return NULL; } @@ -2264,10 +2317,8 @@ Tcl_FSOpenFileChannel( * * Tcl_FSUtime -- * - * Calls 'uTimeProc' of the filesystem corresponding to the given - * pathname. - * - * Replaces the library version of utime. + * This function replaces the library version of utime. The appropriate + * function for the filesystem to which pathPtr belongs will be called. * * Results: * See utime documentation. @@ -2280,22 +2331,17 @@ Tcl_FSOpenFileChannel( int Tcl_FSUtime( - Tcl_Obj *pathPtr, /* Pathaname of file to call uTimeProc on */ - struct utimbuf *tval) /* Specifies the access/modification + Tcl_Obj *pathPtr, /* File to change access/modification times */ + struct utimbuf *tval) /* Structure containing access/modification * times to use. Should not be modified. */ { const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - int err; - - if (fsPtr == NULL) { - err = ENOENT; - } else { - if (fsPtr->utimeProc != NULL) { - return fsPtr->utimeProc(pathPtr, tval); + if (fsPtr != NULL) { + Tcl_FSUtimeProc *proc = fsPtr->utimeProc; + if (proc != NULL) { + return (*proc)(pathPtr, tval); } - err = ENOTSUP; } - Tcl_SetErrno(err); return -1; } @@ -2304,10 +2350,11 @@ Tcl_FSUtime( * * NativeFileAttrStrings -- * - * Implements the platform-dependent 'file attributes' subcommand for the - * native filesystem, for listing the set of possible attribute strings. - * Part of Tcl's native filesystem support. Placed here because it is used - * under both Unix and Windows. + * This function implements the platform dependent 'file attributes' + * subcommand, for the native filesystem, for listing the set of possible + * attribute strings. This function is part of Tcl's native filesystem + * support, and is placed here because it is shared by Unix and Windows + * code. * * Results: * An array of strings @@ -2318,10 +2365,10 @@ Tcl_FSUtime( *---------------------------------------------------------------------- */ -static const char *const * +static const char ** NativeFileAttrStrings( - TCL_UNUSED(Tcl_Obj *), - TCL_UNUSED(Tcl_Obj **)) + Tcl_Obj *pathPtr, + Tcl_Obj **objPtrRef) { return tclpFileAttrStrings; } @@ -2331,18 +2378,16 @@ NativeFileAttrStrings( * * NativeFileAttrsGet -- * - * Implements the platform-dependent 'file attributes' subcommand for the - * native filesystem for 'get' operations. Part of Tcl's native - * filesystem support. Defined here because it is used under both Unix - * and Windows. + * 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. - * - * If there was no error, stores in objPtrRef a pointer to a new object - * having a refCount of zero and holding the result. The caller should - * store it somewhere, e.g. as the Tcl result, or decrement its refCount - * to free it. + * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK + * was returned) is likely to have a refCount of zero. Either way we must + * either store it somewhere (e.g. the Tcl result), or Incr/Decr its + * refCount to ensure it is properly freed. * * Side effects: * None. @@ -2354,10 +2399,11 @@ static int NativeFileAttrsGet( Tcl_Interp *interp, /* The interpreter for error reporting. */ int index, /* index of the attribute command. */ - Tcl_Obj *pathPtr, /* Pathname of the file */ - Tcl_Obj **objPtrRef) /* Where to store the a pointer to the result. */ + 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); } /* @@ -2365,13 +2411,13 @@ NativeFileAttrsGet( * * NativeFileAttrsSet -- * - * Implements the platform-dependent 'file attributes' subcommand for the - * native filesystem for 'set' operations. A part of Tcl's native - * filesystem support, it is defined here because it is used under both - * Unix and Windows. + * This function implements the platform dependent 'file attributes' + * subcommand, for the native filesystem, for 'set' operations. This + * function is part of Tcl's native filesystem support, and is placed + * here because it is shared by Unix and Windows code. * * Results: - * A standard Tcl return code. + * Standard Tcl return code. * * Side effects: * None. @@ -2383,10 +2429,10 @@ static int NativeFileAttrsSet( Tcl_Interp *interp, /* The interpreter for error reporting. */ int index, /* index of the attribute command. */ - Tcl_Obj *pathPtr, /* Pathname of the file */ - Tcl_Obj *objPtr) /* The value to set. */ + 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); } /* @@ -2394,16 +2440,18 @@ NativeFileAttrsSet( * * Tcl_FSFileAttrStrings -- * - * Implements part of the hookable 'file attributes' - * subcommand. - * - * Calls 'fileAttrStringsProc' of the filesystem corresponding to the - * given pathname. + * This function implements part of the hookable 'file attributes' + * subcommand. The appropriate function for the filesystem to which + * pathPtr belongs will be called. * * Results: - * Returns an array of strings, or returns NULL and stores in objPtrRef - * a pointer to a new Tcl list having a refCount of zero, and containing - * the file attribute strings. + * The called function may either return an array of strings, or may + * instead return NULL and place a Tcl list into the given objPtrRef. + * Tcl will take that list and first increment its refCount before using + * it. On completion of that use, Tcl will decrement its refCount. Hence + * if the list should be disposed of by Tcl when done, it should have a + * refCount of zero, and if the list should not be disposed of, the + * filesystem should ensure it retains a refCount on the object. * * Side effects: * None. @@ -2411,15 +2459,18 @@ NativeFileAttrsSet( *---------------------------------------------------------------------- */ -const char *const * +const char ** Tcl_FSFileAttrStrings( Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef) { const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL && fsPtr->fileAttrStringsProc != NULL) { - return fsPtr->fileAttrStringsProc(pathPtr, objPtrRef); + if (fsPtr != NULL) { + Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc; + if (proc != NULL) { + return (*proc)(pathPtr, objPtrRef); + } } Tcl_SetErrno(ENOENT); return NULL; @@ -2430,13 +2481,11 @@ Tcl_FSFileAttrStrings( * * TclFSFileAttrIndex -- * - * Given an attribute name, determines the index of the attribute in the + * Helper function for converting an attribute name to an index into the * attribute table. * * Results: - * A standard Tcl result code. - * - * If there is no error, stores the index in *indexPtr. + * Tcl result code, index written to *indexPtr on result==TCL_OK * * Side effects: * None. @@ -2446,12 +2495,13 @@ Tcl_FSFileAttrStrings( int TclFSFileAttrIndex( - Tcl_Obj *pathPtr, /* Pathname of the file. */ - const char *attributeName, /* The name of the attribute. */ - int *indexPtr) /* A place to store the result. */ + Tcl_Obj *pathPtr, /* File whose attributes are to be indexed + * into. */ + const char *attributeName, /* The attribute being looked for. */ + int *indexPtr) /* Where to write the found index. */ { Tcl_Obj *listObj = NULL; - const char *const *attrTable; + const char **attrTable; /* * Get the attribute table for the file. @@ -2482,10 +2532,10 @@ TclFSFileAttrIndex( * It's a non-constant attribute list, so do a literal search. */ - Tcl_Size i, objc; + int i, objc; Tcl_Obj **objv; - if (TclListObjGetElements(NULL, listObj, &objc, &objv) != TCL_OK) { + if (Tcl_ListObjGetElements(NULL, listObj, &objc, &objv) != TCL_OK) { TclDecrRefCount(listObj); return TCL_ERROR; } @@ -2508,16 +2558,15 @@ TclFSFileAttrIndex( * * Tcl_FSFileAttrsGet -- * - * Implements read access for the hookable 'file attributes' subcommand. - * - * Calls 'fileAttrsGetProc' of the filesystem corresponding to the given - * pathname. + * 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: - * A standard Tcl return code. - * - * On success, stores in objPtrRef a pointer to a new Tcl_Obj having a - * refCount of zero, and containing the result. + * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK + * was returned) is likely to have a refCount of zero. Either way we must + * either store it somewhere (e.g. the Tcl result), or Incr/Decr its + * refCount to ensure it is properly freed. * * Side effects: * None. @@ -2528,14 +2577,17 @@ TclFSFileAttrIndex( int Tcl_FSFileAttrsGet( Tcl_Interp *interp, /* The interpreter for error reporting. */ - int index, /* The index of the attribute command. */ - Tcl_Obj *pathPtr, /* The pathname of the file. */ - Tcl_Obj **objPtrRef) /* A place to store the result. */ + int index, /* index of the attribute command. */ + Tcl_Obj *pathPtr, /* filename we are operating on. */ + Tcl_Obj **objPtrRef) /* for output. */ { const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL && fsPtr->fileAttrsGetProc != NULL) { - return fsPtr->fileAttrsGetProc(interp, index, pathPtr, objPtrRef); + if (fsPtr != NULL) { + Tcl_FSFileAttrsGetProc *proc = fsPtr->fileAttrsGetProc; + if (proc != NULL) { + return (*proc)(interp, index, pathPtr, objPtrRef); + } } Tcl_SetErrno(ENOENT); return -1; @@ -2546,14 +2598,12 @@ Tcl_FSFileAttrsGet( * * Tcl_FSFileAttrsSet -- * - * Implements write access for the hookable 'file - * attributes' subcommand. - * - * Calls 'fileAttrsSetProc' for the filesystem corresponding to the given - * pathname. + * 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: - * A standard Tcl return code. + * Standard Tcl return code. * * Side effects: * None. @@ -2564,14 +2614,17 @@ Tcl_FSFileAttrsGet( int Tcl_FSFileAttrsSet( Tcl_Interp *interp, /* The interpreter for error reporting. */ - int index, /* The index of the attribute command. */ - Tcl_Obj *pathPtr, /* The pathname of the file. */ - Tcl_Obj *objPtr) /* A place to store the result. */ + int index, /* index of the attribute command. */ + Tcl_Obj *pathPtr, /* filename we are operating on. */ + Tcl_Obj *objPtr) /* Input value. */ { const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL && fsPtr->fileAttrsSetProc != NULL) { - return fsPtr->fileAttrsSetProc(interp, index, pathPtr, objPtr); + if (fsPtr != NULL) { + Tcl_FSFileAttrsSetProc *proc = fsPtr->fileAttrsSetProc; + if (proc != NULL) { + return (*proc)(interp, index, pathPtr, objPtr); + } } Tcl_SetErrno(ENOENT); return -1; @@ -2582,25 +2635,33 @@ Tcl_FSFileAttrsSet( * * Tcl_FSGetCwd -- * - * Replaces the library version of getcwd(). + * This function replaces the library version of getcwd(). * - * Most virtual filesystems do not implement cwdProc. Tcl maintains its - * own record of the current directory which it keeps synchronized with - * the filesystem corresponding to the pathname of the current directory - * if the filesystem provides a cwdProc (the native filesystem does). + * 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). * - * If Tcl's current directory is not in the native filesystem, Tcl's - * current directory and the current directory of the process are - * different. To avoid confusion, extensions should call Tcl_FSGetCwd to - * obtain the current directory from Tcl rather than from the operating - * system. + * Note that if Tcl's cwd is not in the native filesystem, then of course + * Tcl's cwd and the native cwd are different: extensions should + * therefore ensure they only access the cwd through this function to + * avoid confusion. + * + * If a global cwdPathPtr already exists, it is cached in the thread's + * private data structures and reference to the cached copy is returned, + * subject to a synchronisation attempt in that cwdPathPtr's fs. + * + * Otherwise, the chain of functions that have been "inserted" into the + * filesystem will be called in succession until either a value other + * than NULL is returned, or the entire list is visited. * * Results: - * Returns a pointer to a Tcl_Obj having a refCount of 1 and containing - * the current thread's local copy of the global cwdPathPtr value. + * The result is a pointer to a Tcl_Obj specifying the current directory, + * or NULL if the current directory could not be determined. If NULL is + * returned, an error message is left in the interp's result. * - * Returns NULL if the current directory could not be determined, and - * leaves an error message in the interpreter's result. + * The result already has its refCount incremented for the caller. When + * it is no longer needed, that refCount should be decremented. * * Side effects: * Various objects may be freed and allocated. @@ -2619,216 +2680,201 @@ Tcl_FSGetCwd( Tcl_Obj *retVal = NULL; /* - * This is the first time this routine has been called. Call - * 'getCwdProc' for each registered filsystems until one returns - * something other than NULL, which is a pointer to the pathname of the - * current directory. + * 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(); Claim(); - for (; (retVal == NULL) && (fsRecPtr != NULL); - fsRecPtr = fsRecPtr->nextPtr) { - void *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; - - /* - * Found the pathname of the current directory. - */ - - retVal = fsRecPtr->fsPtr->internalToNormalizedProc(retCd); - Tcl_IncrRefCount(retVal); - norm = TclFSNormalizeAbsolutePath(interp,retVal); - if (norm != NULL) { - /* - * Assign to global storage the pathname of the current - * directory and copy it into thread-local storage as - * well. - * - * At system startup multiple threads could in principle - * call this function simultaneously, which is a little - * peculiar, but should be fine given the mutex locks in - * FSUPdateCWD. Once some value is assigned to the global - * variable the 'else' branch below is always taken, which - * is simpler. - */ - - FsUpdateCwd(norm, retCd); - Tcl_DecrRefCount(norm); + 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); + if (norm != NULL) { + /* + * We found a cwd, which is now in our global + * storage. We must make a copy. Norm already has + * a refCount of 1. + * + * Threading issue: note that multiple threads at + * system startup could in principle call this + * function simultaneously. They will therefore + * each set the cwdPathPtr independently. That + * behaviour is a bit peculiar, but should be + * fine. Once we have a cwd, we'll always be in + * the 'else' branch below which is simpler. + */ + + FsUpdateCwd(norm, retCd); + Tcl_DecrRefCount(norm); + } else { + (*fsRecPtr->fsPtr->freeInternalRepProc)(retCd); + } + Tcl_DecrRefCount(retVal); + retVal = NULL; + Disclaim(); + goto cdDidNotChange; + } else if (interp != NULL) { + Tcl_AppendResult(interp, + "error getting working directory name: ", + Tcl_PosixError(interp), NULL); + } } else { - fsRecPtr->fsPtr->freeInternalRepProc(retCd); + retVal = (*proc)(interp); } - 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(); - if (retVal != NULL) { - /* - * On some platforms the pathname of the current directory might - * not be normalized. For efficiency, ensure that it is - * normalized. For the sake of efficiency, we want a completely - * normalized current working directory at all times. - */ + /* + * Now the 'cwd' may NOT be normalized, at least on some platforms. + * For the sake of efficiency, we want a completely normalized cwd at + * all times. + * + * Finally, if retVal is NULL, we do not have a cwd, which could be + * problematic. + */ + if (retVal != NULL) { Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal); - if (norm != NULL) { /* - * We found a current working directory, 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: Multiple threads at system startup could in - * principle call this function simultaneously. They will - * therefore each set the cwdPathPtr independently, which 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. + * 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. */ - void *cd = (void *) Tcl_FSGetNativePath(norm); - + ClientData cd = (ClientData) Tcl_FSGetNativePath(norm); FsUpdateCwd(norm, TclNativeDupInternalRep(cd)); Tcl_DecrRefCount(norm); } Tcl_DecrRefCount(retVal); - } else { - /* - * retVal is NULL. There is no current directory, which could be - * problematic. - */ } } else { /* - * There is a thread-local value for the pathname of the current - * directory. Give corresponding filesystem a chance update the value - * if it is out-of-date. This allows an error to be thrown if, for - * example, the permissions on the current working directory have - * changed. + * We already have a cwd cached, but we want to give the filesystem it + * is in a chance to check whether that cwd has changed, or is perhaps + * no longer accessible. This allows an error to be thrown if, say, + * the permissions on that directory have changed. */ - const Tcl_Filesystem *fsPtr = - Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr); - void *retCd = NULL; - Tcl_Obj *retVal, *norm; - - if (fsPtr == NULL || fsPtr->getCwdProc == NULL) { - /* - * There is no corresponding filesystem or the filesystem does not - * have a getCwd routine. Just assume current local value is ok. - */ - goto cdDidNotChange; - } - - if (fsPtr->version == TCL_FILESYSTEM_VERSION_1) { - retVal = fsPtr->getCwdProc(interp); - } else { - /* - * New API. - */ - - TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2 *) fsPtr->getCwdProc; - - retCd = proc2(tsdPtr->cwdClientData); - if (retCd == NULL && interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error getting working directory name: %s", - Tcl_PosixError(interp))); - } - - if (retCd == tsdPtr->cwdClientData) { - goto cdDidNotChange; - } - - /* - * Looks like a new current directory. - */ + const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr); - retVal = fsPtr->internalToNormalizedProc(retCd); - Tcl_IncrRefCount(retVal); - } + /* + * If the filesystem couldn't be found, or if no cwd function exists + * for this filesystem, then we simply assume the cached cwd is ok. + * If we do call a cwd, we must watch for errors (if the cwd returns + * NULL). This ensures that, say, on Unix if the permissions of the + * cwd change, 'pwd' does actually throw the correct error in Tcl. + * (This is tested for in the test suite on unix). + */ - if (retVal == NULL) { - /* - * The current directory could not not determined. Reset the - * current direcory to ensure, for example, that '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), NULL); + } - FsUpdateCwd(NULL, NULL); - goto cdDidNotChange; - } + if (retCd == tsdPtr->cwdClientData) { + goto cdDidNotChange; + } - norm = TclFSNormalizeAbsolutePath(interp, retVal); + /* + * Looks like a new current directory. + */ - if (norm == NULL) { - /* - * 'norm' shouldn't ever be NULL, but we are careful. - */ + retVal = (*fsPtr->internalToNormalizedProc)(retCd); + Tcl_IncrRefCount(retVal); + } else { + retVal = (*proc)(interp); + } + if (retVal != NULL) { + Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal); - /* Do nothing */ - if (retCd != NULL) { - fsPtr->freeInternalRepProc(retCd); - } - } else if (norm == tsdPtr->cwdPathPtr) { - goto cdEqual; - } else { - /* - * Determine whether the filesystem's answer is the same as the - * cached local value. Since both 'norm' and 'tsdPtr->cwdPathPtr' - * are normalized pathnames, do something more efficient than - * calling 'Tcl_FSEqualPaths', and in addition avoid a nasty - * infinite loop bug when trying to normalize tsdPtr->cwdPathPtr. - */ + /* + * Check whether cwd has changed from the value previously + * stored in cwdPathPtr. Really 'norm' shouldn't be NULL, + * but we are careful. + */ - Tcl_Size len1, len2; - const char *str1, *str2; + 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. + */ - str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); - str2 = TclGetStringFromObj(norm, &len2); - if ((len1 == len2) && (strcmp(str1, str2) == 0)) { - /* - * The pathname values are equal so retain the old pathname - * object which is probably already shared and free the - * normalized pathname that was just produced. - */ - cdEqual: - Tcl_DecrRefCount(norm); - if (retCd != NULL) { - fsPtr->freeInternalRepProc(retCd); + FsUpdateCwd(NULL, NULL); } - } else { - /* - * The pathname of the current directory is not the same as - * this thread's local cached value. Replace the local value. - */ - FsUpdateCwd(norm, retCd); - Tcl_DecrRefCount(norm); } } - Tcl_DecrRefCount(retVal); } cdDidNotChange: @@ -2844,19 +2890,17 @@ Tcl_FSGetCwd( * * Tcl_FSChdir -- * - * Replaces the library version of chdir(). + * This function replaces the library version of chdir(). * - * Calls 'chdirProc' of the filesystem that corresponds to the given - * pathname. + * The path is normalized and then passed to the filesystem which claims + * it. * * Results: - * See chdir() documentation. + * 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. - * - * On success stores in cwdPathPtr the pathname of the new current - * directory. + * See chdir() documentation. The global cwdPathPtr may change value. * *---------------------------------------------------------------------- */ @@ -2865,13 +2909,9 @@ int Tcl_FSChdir( Tcl_Obj *pathPtr) { - const Tcl_Filesystem *fsPtr, *oldFsPtr = NULL; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + const Tcl_Filesystem *fsPtr; int retVal = -1; - if (tsdPtr->cwdPathPtr != NULL) { - oldFsPtr = Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr); - } if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) { Tcl_SetErrno(ENOENT); return retVal; @@ -2879,48 +2919,75 @@ Tcl_FSChdir( fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { - if (fsPtr->chdirProc != NULL) { + Tcl_FSChdirProc *proc = fsPtr->chdirProc; + if (proc != NULL) { /* - * If this fails Tcl_SetErrno() has already been called. + * If this fails, an appropriate errno will have been stored using + * 'Tcl_SetErrno()'. */ - retVal = fsPtr->chdirProc(pathPtr); + retVal = (*proc)(pathPtr); } else { /* - * Fallback to stat-based implementation. + * Fallback on stat-based implementation. */ Tcl_StatBuf buf; + /* + * If the file can be stat'ed and is a directory and is readable, + * then we can chdir. If any of these actions fail, then + * 'Tcl_SetErrno()' should automatically have been called to set + * an appropriate error code + */ + if ((Tcl_FSStat(pathPtr, &buf) == 0) && (S_ISDIR(buf.st_mode)) && (Tcl_FSAccess(pathPtr, R_OK) == 0)) { /* - * stat was successful, and the file is a directory and is - * readable. Can proceed to change the current directory. + * We allow the chdir. */ retVal = 0; - } else { - /* - * 'Tcl_SetErrno()' has already been called. - */ } } } else { Tcl_SetErrno(ENOENT); } - if (retVal == 0) { + /* + * 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. + */ - /* Assume that the cwd was actually changed to the normalized value - * just calculated, and cache that information. */ + /* + * If the filesystem in question has a getCwdProc, then the correct logic + * which performs the part below is already part of the Tcl_FSGetCwd() + * call, so no need to replicate it again. This will have a side effect + * though. The private authoritative representation of the current working + * directory stored in cwdPathPtr in static memory will be out-of-sync + * with the real OS-maintained value. The first call to Tcl_FSGetCwd will + * however recalculate the private copy to match the OS-value so + * everything will work right. + * + * However, if there is no getCwdProc, then we _must_ update our private + * storage of the cwd, since this is the only opportunity to do that! + * + * Note: We currently call this block of code irrespective of whether + * there was a getCwdProc or not, but the code should all in principle + * work if we only call this block if fsPtr->getCwdProc == NULL. + */ + if (retVal == 0) { /* - * If the filesystem epoch changed recently, the normalized pathname or - * its internal handle may be different from what was found above. - * This can easily be the case with scripted documents . Therefore get - * the normalized pathname again. The correct value will have been - * cached as a result of the Tcl_FSGetFileSystemForPath call, above. + * Note that this normalized path may be different to what we found + * above (or at least a different object), if the filesystem epoch + * changed recently. This can actually happen with scripted documents + * very easily. Therefore we ask for the normalized path again (the + * correct value will have been cached as a result of the + * Tcl_FSGetFileSystemForPath call above anyway). */ Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr); @@ -2932,60 +2999,37 @@ Tcl_FSChdir( } if (fsPtr == &tclNativeFilesystem) { - void *cd; - void *oldcd = tsdPtr->cwdClientData; - /* - * Assume that the native filesystem has a getCwdProc and that it - * is at version 2. + * For the native filesystem, we keep a cache of the native + * representation of the cwd. But, we want to do that for the + * exact format that is returned by 'getcwd' (so that we can later + * compare the two representations for equality), which might not + * be exactly the same char-string as the native representation of + * the fully normalized path (e.g. on Windows there's a + * forward-slash vs backslash difference). Hence we ask for this + * again here. On Unix it might actually be true that we always + * have the correct form in the native rep in which case we could + * simply use: + * cd = Tcl_FSGetNativePath(pathPtr); + * instead. This should be examined by someone on Unix. */ - TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2 *) fsPtr->getCwdProc; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + ClientData cd; + ClientData oldcd = tsdPtr->cwdClientData; - cd = proc2(oldcd); - if (cd != oldcd) { - /* - * Call getCwdProc() and store the resulting internal handle to - * compare things with it later. This might might not be - * exactly the same string as that of the fully normalized - * pathname. For example, for the Windows internal handle the - * separator is the backslash character. On Unix it might well - * be true that the internal handle is the fully normalized - * pathname and one could simply use: - * cd = Tcl_FSGetNativePath(pathPtr); - * but this can't be guaranteed in the general case. In fact, - * the internal handle could be any value the filesystem - * decides to use to identify a node. - */ + /* + * Assumption we are using a filesystem version 2. + */ + TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)fsPtr->getCwdProc; + cd = (*proc2)(oldcd); + if (cd != oldcd) { FsUpdateCwd(normDirName, cd); } } else { - /* - * Tcl_FSGetCwd() synchronizes the file-global cwdPathPtr if - * needed. However, if there is no 'getCwdProc', cwdPathPtr must be - * updated right now because there won't be another chance. This - * block of code is currently executed whether or not the - * filesystem provides a getCwdProc, but it should in principle - * work to only call this block if fsPtr->getCwdProc == NULL. - */ - FsUpdateCwd(normDirName, NULL); } - - if (oldFsPtr != NULL && fsPtr != oldFsPtr) { - /* - * The filesystem of the current directory is not the same as the - * filesystem of the previous current directory. Invalidate All - * FsPath objects. - */ - Tcl_FSMountsChanged(NULL); - } - } else { - /* - * The current directory is now changed or an error occurred and an - * error message is now set. Just continue. - */ } return retVal; @@ -2996,17 +3040,25 @@ Tcl_FSChdir( * * Tcl_FSLoadFile -- * - * Loads a dynamic shared object by passing the given pathname unmodified - * to Tcl_LoadFile, and provides pointers to the functions named by 'sym1' - * and 'sym2', and another pointer to a function that unloads the object. + * Dynamically loads a binary code file into memory and returns the + * addresses of two functions within that file, if they are defined. The + * appropriate function for the filesystem to which pathPtr belongs will + * be called. + * + * Note that the native filesystem doesn't actually assume 'pathPtr' is a + * path. Rather it assumes pathPtr is either a path or just the name + * (tail) of a file which can be found somewhere in the environment's + * loadable path. This behaviour is not very compatible with virtual + * filesystems (and has other problems documented in the load man-page), + * so it is advised that full paths are always used. * * Results: - * A standard Tcl completion code. If an error occurs, sets the - * interpreter's result to an error message. + * A standard Tcl completion code. If an error occurs, an error message + * is left in the interp's result. * * Side effects: - * A dynamic shared object is loaded into memory. This may later be - * unloaded by passing the handlePtr to *unloadProcPtr. + * New code suddenly appears in memory. This may later be unloaded by + * passing the clientData to the unloadProc. * *---------------------------------------------------------------------- */ @@ -3014,192 +3066,224 @@ Tcl_FSChdir( int Tcl_FSLoadFile( Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Obj *pathPtr, /* Pathname of the file containing the dynamic shared object. - */ + Tcl_Obj *pathPtr, /* Name of the file containing the desired + * code. */ const char *sym1, const char *sym2, - /* Names of two functions to find in the - * dynamic shared object. */ - Tcl_LibraryInitProc **proc1Ptr, Tcl_LibraryInitProc **proc2Ptr, - /* Places to store pointers to the functions - * named by sym1 and sym2. */ - Tcl_LoadHandle *handlePtr, /* A place to store the token for the loaded - * object. Can be passed to + /* Names of two functions to look up in the + * file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr, + /* Where to return the addresses corresponding + * to sym1 and sym2. */ + Tcl_LoadHandle *handlePtr, /* Filled with token for dynamically loaded + * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - TCL_UNUSED(Tcl_FSUnloadFileProc **)) + Tcl_FSUnloadFileProc **unloadProcPtr) + /* Filled with address of Tcl_FSUnloadFileProc + * function which should be used for this + * file. */ { - const char *symbols[3]; - void *procPtrs[2]; + const char *symbols[2]; + Tcl_PackageInitProc **procPtrs[2]; + ClientData clientData; int res; + /* + * Initialize the arrays. + */ + symbols[0] = sym1; symbols[1] = sym2; - symbols[2] = NULL; + procPtrs[0] = proc1Ptr; + procPtrs[1] = proc2Ptr; - res = Tcl_LoadFile(interp, pathPtr, symbols, 0, procPtrs, handlePtr); - if (res == TCL_OK) { - *proc1Ptr = (Tcl_LibraryInitProc *) procPtrs[0]; - *proc2Ptr = (Tcl_LibraryInitProc *) procPtrs[1]; - } else { - *proc1Ptr = *proc2Ptr = NULL; - } + /* + * Perform the load. + */ + + res = TclLoadFile(interp, pathPtr, 2, symbols, procPtrs, handlePtr, + &clientData, unloadProcPtr); + + /* + * Due to an unfortunate mis-design in Tcl 8.4 fs, when loading a shared + * library, we don't keep the loadHandle (for TclpFindSymbol) and the + * clientData (for the unloadProc) separately. In fact we effectively + * throw away the loadHandle and only use the clientData. It just so + * happens, for the native filesystem only, that these two are identical. + * + * This also means that the signatures Tcl_FSUnloadFileProc and + * Tcl_FSLoadFileProc are both misleading. + */ + *handlePtr = (Tcl_LoadHandle) clientData; return res; } /* *---------------------------------------------------------------------- * - * Tcl_LoadFile -- + * TclLoadFile -- * - * Load a dynamic shared object by calling 'loadFileProc' of the - * filesystem corresponding to the given pathname, and then finds within - * the loaded object the functions named in symbols[]. + * Dynamically loads a binary code file into memory and returns the + * addresses of a number of given functions within that file, if they are + * defined. The appropriate function for the filesystem to which pathPtr + * belongs will be called. * - * The given pathname is passed unmodified to `loadFileProc`, which - * decides how to resolve it. On POSIX systems the native filesystem - * passes the given pathname to dlopen(), which resolves the filename - * according to its own set of rules. This behaviour is not very - * compatible with virtual filesystems, and has other problems as - * documented for [load], so it is recommended to use an absolute - * pathname. + * Note that the native filesystem doesn't actually assume 'pathPtr' is a + * path. Rather it assumes pathPtr is either a path or just the name + * (tail) of a file which can be found somewhere in the environment's + * loadable path. This behaviour is not very compatible with virtual + * filesystems (and has other problems documented in the load man-page), + * so it is advised that full paths are always used. + * + * 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, sets the - * interpreter result to an error message. + * A standard Tcl completion code. If an error occurs, an error message + * is left in the interp's result. * * Side effects: - * Memory is allocated for the new object. May be freed by calling - * TclFS_UnloadFile. + * New code suddenly appears in memory. This may later be unloaded by + * passing the clientData to the unloadProc. * *---------------------------------------------------------------------- */ +typedef int (Tcl_FSLoadFileProc2) (Tcl_Interp *interp, Tcl_Obj *pathPtr, + Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); + /* - * Modern HPUX allows the unlink (no ETXTBSY error) yet somehow trashes some - * internal data structures, preventing any additional dynamic shared objects - * from getting properly loaded. Only the first is ok. Work around the issue - * by not unlinking, i.e., emulating the behaviour of the older HPUX which - * denied removal. + * Workaround for issue with modern HPUX which do allow the unlink (no ETXTBSY + * error) yet somehow trash some internal data structures which prevents the + * second and further shared libraries from getting properly loaded. Only the + * first is ok. We try to get around the issue by not unlinking, + * i.e. emulating the behaviour of the older HPUX which denied removal. * * Doing the unlink is also an issue within docker containers, whose AUFS * bungles this as well, see * https://github.com/dotcloud/docker/issues/1911 * + * For these situations the change below makes the execution of the unlink + * semi-controllable at runtime. + * + * An AUFS filesystem (if it can be detected) will force avoidance of + * unlink. The env variable TCL_TEMPLOAD_NO_UNLINK allows detection of a + * users general request (unlink and not. + * + * By default the unlink is done (if not in AUFS). However if the variable is + * present and set to true (any integer > 0) then the unlink is skipped. */ -#ifdef _WIN32 -#define getenv(x) _wgetenv(L##x) -#define atoi(x) _wtoi(x) -#else -#define WCHAR char -#endif - -static int -skipUnlink( - Tcl_Obj *shlibFile) +int +TclSkipUnlink (Tcl_Obj* shlibFile) { - /* - * Unlinking is not performed in the following cases: + /* Order of testing: + * 1. On hpux we generally want to skip unlink in general * - * 1. The operating system is HPUX. - * - * 2. If the environment variable TCL_TEMPLOAD_NO_UNLINK is present and - * set to true (an integer > 0) - * - * 3. TCL_TEMPLOAD_NO_UNLINK is not true (an integer > 0) and AUFS filesystem can be detected (using statfs, if available). + * Outside of hpux then: + * 2. For a general user request (TCL_TEMPLOAD_NO_UNLINK present, non-empty, => int) + * 3. For general AUFS environment (statfs, if available). * + * Ad 2: This variable can disable/override the AUFS detection, i.e. for + * testing if a newer AUFS does not have the bug any more. + * + * Ad 3: This is conditionally compiled in. Condition currently must be set manually. + * This part needs proper tests in the configure(.in). */ - #ifdef hpux - (void)shlibFile; return 1; #else - WCHAR *skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK"); + char* skipstr; + skipstr = getenv ("TCL_TEMPLOAD_NO_UNLINK"); if (skipstr && (skipstr[0] != '\0')) { return atoi(skipstr); } -#ifndef TCL_TEMPLOAD_NO_UNLINK - (void)shlibFile; -#else -/* At built time TCL_TEMPLOAD_NO_UNLINK can be set manually to control whether - * this automatic overriding of unlink is included. - */ +#ifdef TCL_TEMPLOAD_NO_UNLINK #ifndef NO_FSTATFS { struct statfs fs; - /* - * Have fstatfs. May not have the AUFS super magic ... Indeed our build + /* Have fstatfs. May not have the AUFS super magic ... Indeed our build * box is too old to have it directly in the headers. Define taken from * http://mooon.googlecode.com/svn/trunk/linux_include/linux/aufs_type.h * http://aufs.sourceforge.net/ - * Better reference will be gladly accepted. + * Better reference will be gladly taken. */ #ifndef AUFS_SUPER_MAGIC -/* AUFS_SUPER_MAGIC can disable/override the AUFS detection, i.e. for - * testing if a newer AUFS does not have the bug any more. -*/ #define AUFS_SUPER_MAGIC ('a' << 24 | 'u' << 16 | 'f' << 8 | 's') #endif /* AUFS_SUPER_MAGIC */ - if ((statfs(Tcl_GetString(shlibFile), &fs) == 0) - && (fs.f_type == AUFS_SUPER_MAGIC)) { + if ((statfs(Tcl_GetString (shlibFile), &fs) == 0) && + (fs.f_type == AUFS_SUPER_MAGIC)) { return 1; } } #endif /* ... NO_FSTATFS */ #endif /* ... TCL_TEMPLOAD_NO_UNLINK */ - /* - * No HPUX, environment variable override, or AUFS detected. Perform - * unlink. - */ + /* Fallback: !hpux, no EV override, no AUFS (detection, nor detected): + * Don't skip */ return 0; #endif /* hpux */ } int -Tcl_LoadFile( +TclLoadFile( Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Obj *pathPtr, /* Pathname of the file containing the dynamic - * shared object. */ - const char *const symbols[],/* A null-terminated array of names of - * functions to find in the loaded object. */ - int flags, /* Flags */ - void *procVPtrs, /* A place to store pointers to the functions - * named by symbols[]. */ - Tcl_LoadHandle *handlePtr) /* A place to hold a token for the loaded object. - * Can be used by TclpFindSymbol. */ + Tcl_Obj *pathPtr, /* Name of the file containing the desired + * code. */ + int symc, /* Number of symbols/procPtrs in the next two + * arrays. */ + const char *symbols[], /* Names of functions to look up in the file's + * symbol table. */ + Tcl_PackageInitProc **procPtrs[], + /* 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. */ { - void **procPtrs = (void **) procVPtrs; const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - const Tcl_Filesystem *copyFsPtr; - Tcl_FSUnloadFileProc *unloadProcPtr; + Tcl_FSLoadFileProc *proc; + Tcl_Filesystem *copyFsPtr; Tcl_Obj *copyToPtr; Tcl_LoadHandle newLoadHandle = NULL; - Tcl_LoadHandle divertedLoadHandle = NULL; + ClientData newClientData = NULL; Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL; FsDivertLoad *tvdlPtr; int retVal; - int i; if (fsPtr == NULL) { Tcl_SetErrno(ENOENT); return TCL_ERROR; } - if (fsPtr->loadFileProc != NULL) { - retVal = ((Tcl_FSLoadFileProc2 *)(void *)(fsPtr->loadFileProc)) - (interp, pathPtr, handlePtr, &unloadProcPtr, flags); - + proc = fsPtr->loadFileProc; + if (proc != NULL) { + int retVal = ((Tcl_FSLoadFileProc2 *)proc) + (interp, pathPtr, handlePtr, unloadProcPtr, 0); if (retVal == TCL_OK) { if (*handlePtr == NULL) { return TCL_ERROR; } - if (interp) { - Tcl_ResetResult(interp); - } + + /* + * Copy this across, since both are equal for the native fs. + */ + + *clientDataPtr = (ClientData)*handlePtr; + Tcl_ResetResult(interp); goto resolveSymbols; } if (Tcl_GetErrno() != EXDEV) { @@ -3208,27 +3292,23 @@ Tcl_LoadFile( } /* - * The filesystem doesn't support 'load'. Fall to the following: - */ - - /* - * Make sure the file is accessible. + * The filesystem doesn't support 'load', so we fall back on the following + * technique: + * + * First check if it is readable -- and exists! */ if (Tcl_FSAccess(pathPtr, R_OK) != 0) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't load library \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); - } + Tcl_AppendResult(interp, "couldn't load library \"", + Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); return TCL_ERROR; } #ifdef TCL_LOAD_FROM_MEMORY /* - * The platform supports loading a dynamic shared object from memory. - * Create a sufficiently large buffer, read the file into it, and then load - * the dynamic shared object from the buffer: + * 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: */ { @@ -3244,7 +3324,7 @@ Tcl_LoadFile( size = (int) statBuf.st_size; /* - * Tcl_Read takes an int: Determine whether the file size is wide. + * Tcl_Read takes an int: check that file size isn't wide. */ if (size != (Tcl_WideInt) statBuf.st_size) { @@ -3259,27 +3339,29 @@ Tcl_LoadFile( Tcl_Close(interp, data); goto mustCopyToTempAnyway; } - ret = Tcl_Read(data, (char *)buffer, size); + ret = Tcl_Read(data, buffer, size); Tcl_Close(interp, data); ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr, - &unloadProcPtr, flags); + unloadProcPtr); if (ret == TCL_OK && *handlePtr != NULL) { + *clientDataPtr = (ClientData) *handlePtr; goto resolveSymbols; } } mustCopyToTempAnyway: - if (interp) { - Tcl_ResetResult(interp); - } -#endif /* TCL_LOAD_FROM_MEMORY */ + Tcl_ResetResult(interp); +#endif /* - * Get a temporary filename, first to copy the file into, and then to load. + * Get a temporary filename to use, first to copy the file into, and then + * to load. */ - copyToPtr = TclpTempFileNameForLibrary(interp, pathPtr); + copyToPtr = TclpTempFileName(); if (copyToPtr == NULL) { + Tcl_AppendResult(interp, "couldn't create temporary file: ", + Tcl_PosixError(interp), NULL); return TCL_ERROR; } Tcl_IncrRefCount(copyToPtr); @@ -3287,35 +3369,33 @@ Tcl_LoadFile( copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr); if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) { /* - * Tcl_FSLoadFile isn't available for the filesystem of the temporary - * file. In order to avoid a possible infinite loop, do not attempt to - * load further. + * 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 we probably created and then exit. - */ - Tcl_FSDeleteFile(copyToPtr); Tcl_DecrRefCount(copyToPtr); - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "couldn't load from current filesystem", -1)); - } + Tcl_AppendResult(interp, "couldn't load from current filesystem",NULL); return TCL_ERROR; } if (TclCrossFilesystemCopy(interp, pathPtr, copyToPtr) != TCL_OK) { + /* + * Cross-platform copy failed. + */ + Tcl_FSDeleteFile(copyToPtr); Tcl_DecrRefCount(copyToPtr); return TCL_ERROR; } -#ifndef _WIN32 +#if !defined(__WIN32__) /* - * It might be necessary on some systems to set the appropriate permissions - * on the file. On Unix we could loop over the file attributes and set any - * that are called "-permissions" to 0700, but just do it directly instead: + * 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: */ { @@ -3332,80 +3412,90 @@ Tcl_LoadFile( #endif /* - * The cross-filesystem copy may have stored the number of bytes in the - * result, so reset the result now. + * We need to reset the result now, because the cross-filesystem copy may + * have stored the number of bytes in the result. */ - if (interp) { - Tcl_ResetResult(interp); - } + Tcl_ResetResult(interp); - retVal = Tcl_LoadFile(interp, copyToPtr, symbols, flags, procPtrs, - &newLoadHandle); + 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; } /* - * Try to delete the file immediately. Some operatings systems allow this, - * and it avoids leaving the copy laying around after 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. */ - if (!skipUnlink(copyToPtr) && - (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) { + if ( + !TclSkipUnlink (copyToPtr) && + (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) { Tcl_DecrRefCount(copyToPtr); /* - * Tell the caller all the details: The package list maintained by - * 'load' stores the original (vfs) pathname, the handle of object - * loaded from the temporary file, and the unloadProcPtr. + * We tell our caller about the real shared library which was loaded. + * Note that this does mean that the package list maintained by 'load' + * will store the original (vfs) path alongside the temporary load + * handle and unload proc ptr. */ - *handlePtr = newLoadHandle; - if (interp) { - Tcl_ResetResult(interp); - } + (*handlePtr) = newLoadHandle; + (*clientDataPtr) = newClientData; + (*unloadProcPtr) = newUnloadProcPtr; + Tcl_ResetResult(interp); return TCL_OK; } /* - * Divert the unloading in order to unload and cleanup the temporary file. + * When we unload this file, we need to divert the unloading so we can + * unload and cleanup the temporary file correctly. */ - tvdlPtr = (FsDivertLoad *)ckalloc(sizeof(FsDivertLoad)); + tvdlPtr = (FsDivertLoad *) ckalloc(sizeof(FsDivertLoad)); /* - * Remember three pieces of information in order to clean up the diverted - * load completely on platforms which allow proper unloading of code. + * Remember three pieces of information. This allows us to cleanup the + * diverted load completely, on platforms which allow proper unloading of + * code. */ tvdlPtr->loadHandle = newLoadHandle; tvdlPtr->unloadProcPtr = newUnloadProcPtr; if (copyFsPtr != &tclNativeFilesystem) { - /* refCount of copyToPtr is already incremented. */ + /* + * copyToPtr is already incremented for this reference. + */ + tvdlPtr->divertedFile = copyToPtr; /* - * This is the filesystem for the temporary file the object was loaded - * from. A reference to copyToPtr is already stored in - * tvdlPtr->divertedFile, so need need to increment the refCount again. + * This is the filesystem we loaded it into. Since we have a reference + * to 'copyToPtr', we already have a refCount on this filesystem, so + * we don't need to worry about it disappearing on us. */ tvdlPtr->divertedFilesystem = copyFsPtr; tvdlPtr->divertedFileNativeRep = NULL; } else { /* - * Grab the native representation. + * We need the native rep. */ tvdlPtr->divertedFileNativeRep = TclNativeDupInternalRep( Tcl_FSGetInternalRep(copyToPtr, copyFsPtr)); /* - * Don't keeep a reference to the Tcl_Obj or the native filesystem. + * We don't need or want references to the copied Tcl_Obj or the + * filesystem if it is the native one. */ tvdlPtr->divertedFile = NULL; @@ -3414,37 +3504,20 @@ Tcl_LoadFile( } copyToPtr = NULL; + (*handlePtr) = newLoadHandle; + (*clientDataPtr) = (ClientData) tvdlPtr; + (*unloadProcPtr) = TclFSUnloadTempFile; - divertedLoadHandle = (Tcl_LoadHandle)ckalloc(sizeof(struct Tcl_LoadHandle_)); - divertedLoadHandle->clientData = tvdlPtr; - divertedLoadHandle->findSymbolProcPtr = DivertFindSymbol; - divertedLoadHandle->unloadFileProcPtr = DivertUnloadFile; - *handlePtr = divertedLoadHandle; - - if (interp) { - Tcl_ResetResult(interp); - } + Tcl_ResetResult(interp); return retVal; resolveSymbols: - /* - * handlePtr now contains a token for the loaded object. - * Resolve the symbols. - */ - - if (symbols != NULL) { - for (i=0 ; symbols[i] != NULL; i++) { - procPtrs[i] = Tcl_FindSymbol(interp, *handlePtr, symbols[i]); - if (procPtrs[i] == NULL) { - /* - * At least one symbol in the list was not found. Unload the - * file and return an error code. Tcl_FindSymbol should have - * already left an appropriate error message. - */ + { + int i; - (*handlePtr)->unloadFileProcPtr(*handlePtr); - *handlePtr = NULL; - return TCL_ERROR; + for (i=0 ; i<symc ; i++) { + if (symbols[i] != NULL) { + *procPtrs[i] = TclpFindSymbol(interp, *handlePtr, symbols[i]); } } } @@ -3452,164 +3525,97 @@ Tcl_LoadFile( } /* - *---------------------------------------------------------------------- - * - * DivertFindSymbol -- + *--------------------------------------------------------------------------- * - * Find a symbol in a shared library loaded by making a copying a file - * from the virtual filesystem to a native filesystem. + * TclFSUnloadTempFile -- * - *---------------------------------------------------------------------- - */ - -static void * -DivertFindSymbol( - Tcl_Interp *interp, /* The relevant interpreter. */ - Tcl_LoadHandle loadHandle, /* A handle to the diverted module. */ - const char *symbol) /* The name of symbol to resolve. */ -{ - FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle->clientData; - Tcl_LoadHandle originalHandle = tvdlPtr->loadHandle; - - return originalHandle->findSymbolProcPtr(interp, originalHandle, symbol); -} - -/* - *---------------------------------------------------------------------- + * This function is called when we loaded a library of code via an + * intermediate temporary file. This function ensures the library is + * correctly unloaded and the temporary file is correctly deleted. * - * DivertUnloadFile -- + * Results: + * None. * - * Unloads an object that was loaded from a temporary file copied from the - * virtual filesystem the native filesystem. + * Side effects: + * The effects of the 'unload' function called, and of course the + * temporary file will be deleted. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -static void -DivertUnloadFile( - Tcl_LoadHandle loadHandle) /* A handle for the loaded object. */ +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->clientData; - Tcl_LoadHandle originalHandle; + FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle; - if (tvdlPtr == NULL) { - /* - * tvdlPtr was provided by Tcl_LoadFile so it should not be NULL here. - */ + /* + * This test should never trigger, since we give the client data in the + * function above. + */ + if (tvdlPtr == NULL) { return; } - originalHandle = tvdlPtr->loadHandle; /* - * Call the real 'unloadfile' proc. This must be called first so that the - * shared library is actually unloaded by the OS. Otherwise, the following - * 'delete' may fail because the shared library is still in use. + * 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); - - /* - * Determine which filesystem contains the temporary copy of the file. - */ + if (tvdlPtr->unloadProcPtr != NULL) { + (*tvdlPtr->unloadProcPtr)(tvdlPtr->loadHandle); + } if (tvdlPtr->divertedFilesystem == NULL) { /* - * Use the function for the native filsystem, which works works even at - * this late stage. + * It was the native filesystem, and we have a special function + * available just for this purpose, which we know works even at this + * late stage. */ TclpDeleteFile(tvdlPtr->divertedFileNativeRep); NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep); + } else { /* - * Remove the temporary file. If encodings have been cleaned up - * already, this may crash. + * 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) { /* - * This may have happened because Tcl is exiting, and encodings may - * have already been deleted or something else the filesystem - * depends on may be gone. + * The above may have failed because the filesystem, or something + * it depends upon (e.g. encodings) have been taken down because + * Tcl is exiting. * - * TO DO: Figure out how to delete this file more robustly, or - * give the filesystem the information it needs to delete the file - * more robustly. One problem might be that the filesystem cannot - * extract the information it needs from the above pathname object + * 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 there is no way to get the native - * handle of the file. + * file) has been finalized, and it refuses to pass the internal + * representation to the filesystem. */ } /* - * This also decrements the refCount of the Tcl_Filesystem - * corresponding to this file. which might cause the filesystem to be - * deallocated if Tcl is exiting. + * And free up the allocations. This will also of course remove a + * refCount from the Tcl_Filesystem to which this file belongs, which + * could then free up the filesystem if we are exiting. */ Tcl_DecrRefCount(tvdlPtr->divertedFile); } - ckfree(tvdlPtr); - ckfree(loadHandle); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FindSymbol -- - * - * Find a symbol in a loaded object. - * - * Previously filesystem-specific, but has been made portable by having - * TclpDlopen return a structure that includes procedure pointers. - * - * Results: - * Returns a pointer to the symbol if found. Otherwise, sets - * an error message in the interpreter result and returns NULL. - * - *---------------------------------------------------------------------- - */ - -void * -Tcl_FindSymbol( - Tcl_Interp *interp, /* The relevant interpreter. */ - Tcl_LoadHandle loadHandle, /* A handle for the loaded object. */ - const char *symbol) /* The name name of the symbol to resolve. */ -{ - return loadHandle->findSymbolProcPtr(interp, loadHandle, symbol); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FSUnloadFile -- - * - * Unloads a loaded object if unloading is supported for the object. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_FSUnloadFile( - Tcl_Interp *interp, /* The relevant interpreter. */ - Tcl_LoadHandle handle) /* A handle for the object 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; - } - if (handle->unloadFileProcPtr != NULL) { - handle->unloadFileProcPtr(handle); - } - return TCL_OK; + ckfree((char*)tvdlPtr); } /* @@ -3617,63 +3623,60 @@ Tcl_FSUnloadFile( * * Tcl_FSLink -- * - * Creates or inspects a link by calling 'linkProc' of the filesystem - * corresponding to the given pathname. Replaces the library version of - * readlink(). + * This function replaces the library version of readlink() and can also + * be used to make links. The appropriate function for the filesystem to + * which pathPtr belongs will be called. * * Results: - * If toPtr is NULL, a Tcl_Obj containing the value the symbolic link for - * 'pathPtr', or NULL if a symbolic link was not accessible. The caller - * should Tcl_DecrRefCount on the result to release it. Otherwise NULL. + * If toPtr is NULL, then the result is a Tcl_Obj specifying the contents + * of the symbolic link given by 'pathPtr', or NULL if the symbolic link + * could not be read. The result is owned by the caller, which should + * call Tcl_DecrRefCount when the result is no longer needed. * - * 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 a combination of: + * If toPtr is non-NULL, then the result is toPtr if the link action was + * successful, or NULL if not. In this case the result has no additional + * reference count, and need not be freed. The actual action to perform + * is given by the 'linkAction' flags, which is an or'd combination of: * * TCL_CREATE_SYMBOLIC_LINK * TCL_CREATE_HARD_LINK * - * Most filesystems do not support linking across to different - * filesystems, so this function usually fails if the filesystem - * corresponding to toPtr is not the same as the filesystem corresponding - * to pathPtr. + * Note that most filesystems will not support linking across to + * different filesystems, so this function will usually fail unless toPtr + * is in the same FS as pathPtr. * * Side effects: - * Creates or sets a link if toPtr is not NULL. - * - * See readlink(). + * See readlink() documentation. A new filesystem link object may appear. * *--------------------------------------------------------------------------- */ Tcl_Obj * Tcl_FSLink( - Tcl_Obj *pathPtr, /* Pathaname of file. */ - Tcl_Obj *toPtr, /* - * NULL or the pathname of a file to link to. - */ - int linkAction) /* Action to perform. */ + Tcl_Obj *pathPtr, /* Path of file to readlink or link */ + Tcl_Obj *toPtr, /* NULL or path to be linked to */ + int linkAction) /* Action to perform */ { const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr) { - if (fsPtr->linkProc == NULL) { - Tcl_SetErrno(ENOTSUP); - return NULL; - } else { - return fsPtr->linkProc(pathPtr, toPtr, linkAction); + if (fsPtr != NULL) { + Tcl_FSLinkProc *proc = fsPtr->linkProc; + + if (proc != NULL) { + return (*proc)(pathPtr, toPtr, linkAction); } } /* - * If S_IFLNK isn't defined 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 - * readlink is called for a file that isn't a symbolic link. + * If S_IFLNK isn't defined it means that the machine doesn't support + * symbolic links, so the file can't possibly be a symbolic link. Generate + * an EINVAL error, which is what happens on machines that do support + * symbolic links when you invoke readlink on a file that isn't a symbolic + * link. */ #ifndef S_IFLNK - errno = EINVAL; /* TODO: Change to Tcl_SetErrno()? */ + errno = EINVAL; #else Tcl_SetErrno(ENOENT); #endif /* S_IFLNK */ @@ -3685,9 +3688,16 @@ Tcl_FSLink( * * Tcl_FSListVolumes -- * - * Lists the currently mounted volumes by calling `listVolumesProc` of - * each registered filesystem, and combining the results to form a list of - * volumes. + * Lists the currently mounted volumes. The chain of functions that have + * been "inserted" into the filesystem will be called in succession; each + * may return a list of volumes, all of which are added to the result + * until all mounted file systems are listed. + * + * Notice that we assume the lists returned by each filesystem (if non + * NULL) have been given a refCount for us already. However, we are NOT + * allowed to hang on to the list itself (it belongs to the filesystem we + * called). Therefore we quite naturally add its contents to the result + * we are building, and then decrement the refCount. * * Results: * The list of volumes, in an object which has refCount 0. @@ -3698,33 +3708,27 @@ Tcl_FSLink( *--------------------------------------------------------------------------- */ -Tcl_Obj * +Tcl_Obj* Tcl_FSListVolumes(void) { FilesystemRecord *fsRecPtr; - Tcl_Obj *resultPtr; + Tcl_Obj *resultPtr = Tcl_NewObj(); /* - * Call each "listVolumes" function of each registered filesystem in - * succession. A non-NULL return value indicates the particular function - * has succeeded. + * 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. */ - TclNewObj(resultPtr); fsRecPtr = FsGetFirstFilesystem(); Claim(); while (fsRecPtr != NULL) { - if (fsRecPtr->fsPtr->listVolumesProc != NULL) { - Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc(); - + Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc; + if (proc != NULL) { + Tcl_Obj *thisFsVolumes = (*proc)(); if (thisFsVolumes != NULL) { Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes); - /* - * The refCount of each list returned by a `listVolumesProc` - * is already incremented. Do not hang onto the list, though. - * It belongs to the filesystem. Add its contents to the - * result we are building, and then decrement the refCount. - */ Tcl_DecrRefCount(thisFsVolumes); } } @@ -3740,21 +3744,22 @@ Tcl_FSListVolumes(void) * * FsListMounts -- * - * Lists the mounts mathing the given pattern in the given directory. + * List all mounts within the given directory, which match the given + * pattern. * * Results: - * A list, having a refCount of 0, of the matching mounts, or NULL if no - * search was performed because no filesystem provided a search routine. + * The list of mounts, in a list object which has refCount 0, or NULL if + * we didn't even find any filesystems to try to list mounts. * * Side effects: - * None. + * None * *--------------------------------------------------------------------------- */ static Tcl_Obj * FsListMounts( - Tcl_Obj *pathPtr, /* Pathname of directory to search. */ + Tcl_Obj *pathPtr, /* Contains path to directory to search. */ const char *pattern) /* Pattern to match against. */ { FilesystemRecord *fsRecPtr; @@ -3762,20 +3767,24 @@ FsListMounts( Tcl_Obj *resultPtr = NULL; /* - * Call the matchInDirectory function of each registered filesystem, - * passing it 'mountsOnly'. Results accumulate in resultPtr. + * Call each of the "matchInDirectory" functions in succession, with the + * specific type information 'mountsOnly'. A non-NULL return value + * indicates the particular function has succeeded. We call all the + * functions registered, since we want a list from each filesystems. */ fsRecPtr = FsGetFirstFilesystem(); Claim(); while (fsRecPtr != NULL) { - if (fsRecPtr->fsPtr != &tclNativeFilesystem && - fsRecPtr->fsPtr->matchInDirectoryProc != NULL) { - if (resultPtr == NULL) { - TclNewObj(resultPtr); + if (fsRecPtr->fsPtr != &tclNativeFilesystem) { + Tcl_FSMatchInDirectoryProc *proc = + fsRecPtr->fsPtr->matchInDirectoryProc; + if (proc != NULL) { + if (resultPtr == NULL) { + resultPtr = Tcl_NewObj(); + } + (*proc)(NULL, resultPtr, pathPtr, pattern, &mountsOnly); } - fsRecPtr->fsPtr->matchInDirectoryProc(NULL, resultPtr, pathPtr, - pattern, &mountsOnly); } fsRecPtr = fsRecPtr->nextPtr; } @@ -3789,31 +3798,34 @@ FsListMounts( * * Tcl_FSSplitPath -- * - * Splits a pathname into its components. + * This function takes the given Tcl_Obj, which should be a valid path, + * and returns a Tcl List object containing each segment of that path as + * an element. * * Results: - * A list with refCount of zero. + * Returns list object with refCount of zero. If the passed in lenPtr is + * non-NULL, we use it to return the number of elements in the returned + * list. * * Side effects: - * If lenPtr is not null, sets it to the number of elements in the result. + * None. * *--------------------------------------------------------------------------- */ Tcl_Obj * Tcl_FSSplitPath( - Tcl_Obj *pathPtr, /* The pathname to split. */ - Tcl_Size *lenPtr) /* A place to hold the number of pathname - * elements. */ + Tcl_Obj *pathPtr, /* Path to split. */ + int *lenPtr) /* int to store number of path elements. */ { - Tcl_Obj *result = NULL; /* Just to squelch gcc warnings. */ - const Tcl_Filesystem *fsPtr; + Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */ + Tcl_Filesystem *fsPtr; char separator = '/'; - Tcl_Size driveNameLength; - const char *p; + int driveNameLength; + char *p; /* - * Perform platform-specific splitting. + * Perform platform specific splitting. */ if (TclFSGetPathType(pathPtr, &fsPtr, @@ -3825,11 +3837,12 @@ Tcl_FSSplitPath( return TclpNativeSplitPath(pathPtr, lenPtr); } - /* Assume each separator is a single character. */ + /* + * We assume separators are single characters. + */ if (fsPtr->filesystemSeparatorProc != NULL) { - Tcl_Obj *sep = fsPtr->filesystemSeparatorProc(pathPtr); - + Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(pathPtr); if (sep != NULL) { Tcl_IncrRefCount(sep); separator = Tcl_GetString(sep)[0]; @@ -3838,32 +3851,30 @@ Tcl_FSSplitPath( } /* - * Add the drive name as first element of the result. The drive name may - * contain strange characters like colons and sequences of forward slashes - * For example, 'ftp://' is a valid drive name. + * Place the drive name as first element of the result list. The drive + * name may contain strange characters, like colons and multiple forward + * slashes (for example 'ftp://' is a valid vfs drive name) */ - TclNewObj(result); + result = Tcl_NewObj(); p = Tcl_GetString(pathPtr); Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(p, driveNameLength)); p += driveNameLength; /* - * Add the remaining pathname elements to the list. + * Add the remaining path elements to the list. */ for (;;) { - const char *elementStart = p; - Tcl_Size length; - + char *elementStart = p; + int length; while ((*p != '\0') && (*p != separator)) { p++; } length = p - elementStart; if (length > 0) { Tcl_Obj *nextElt; - if (elementStart[0] == '~') { TclNewLiteralStringObj(nextElt, "./"); Tcl_AppendToObj(nextElt, elementStart, length); @@ -3877,46 +3888,57 @@ Tcl_FSSplitPath( } } + /* + * Compute the number of elements in the result. + */ + if (lenPtr != NULL) { TclListObjLength(NULL, result, lenPtr); } return result; } + /* *---------------------------------------------------------------------- * * TclGetPathType -- * - * Helper function used by TclFSGetPathType and TclJoinPath. + * Helper function used by FSGetPathType. * * Results: - * One of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or - * TCL_PATH_VOLUME_RELATIVE. + * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or + * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will be set if and + * only if it is non-NULL and the function's return value is + * TCL_PATH_ABSOLUTE. * * Side effects: - * See **filesystemPtrptr, *driveNameLengthPtr and **driveNameRef, + * None. * *---------------------------------------------------------------------- */ Tcl_PathType TclGetPathType( - Tcl_Obj *pathPtr, /* Pathname to determine type of. */ - const Tcl_Filesystem **filesystemPtrPtr, - /* If not NULL, a place in which to store a - * pointer to the filesystem for this pathname - * if it is absolute. */ - Tcl_Size *driveNameLengthPtr, /* If not NULL, a place in which to store the - * length of the volume name. */ - Tcl_Obj **driveNameRef) /* If not NULL, for an absolute pathname, a - * place to store a pointer to an object with a - * refCount of 1, and whose value is the name - * of the volume. */ + 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. */ { - Tcl_Size pathLen; - const char *path = TclGetStringFromObj(pathPtr, &pathLen); + int pathLen; + char *path; Tcl_PathType type; + path = Tcl_GetStringFromObj(pathPtr, &pathLen); + type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, driveNameLengthPtr, driveNameRef); @@ -3935,14 +3957,14 @@ TclGetPathType( * * TclFSNonnativePathType -- * - * Helper function used by TclGetPathType. Checks whether the given - * pathname starts with a string which corresponds to a file volume in - * some registered filesystem other than the native one. For speed and - * historical reasons the native filesystem has special hard-coded checks - * dotted here and there in the filesystem code. + * Helper function used by TclGetPathType. Its purpose is to check + * whether the given path starts with a string which corresponds to a + * file volume in any registered filesystem except the native one. For + * speed and historical reasons the native filesystem has special + * hard-coded checks dotted here and there in the filesystem code. * * Results: - * 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. * @@ -3954,78 +3976,85 @@ TclGetPathType( Tcl_PathType TclFSNonnativePathType( - const char *path, /* Pathname to determine the type of. */ - Tcl_Size pathLen, /* Length of the pathname. */ - const Tcl_Filesystem **filesystemPtrPtr, - /* If not NULL, a place to store a pointer to - * the filesystem for this pathname when it is - * an absolute pathname. */ - Tcl_Size *driveNameLengthPtr,/* If not NULL, a place to store the length of - * the volume name if the pathname is absolute. - */ - Tcl_Obj **driveNameRef) /* If not NULL, a place to store a pointer to - * an object having its its refCount already - * incremented, and contining the name of the - * volume if the pathname is absolute. */ + 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. */ { FilesystemRecord *fsRecPtr; Tcl_PathType type = TCL_PATH_RELATIVE; /* - * Determine whether the given pathname is an absolute pathname on some - * filesystem other than the native filesystem. + * Call each of the "listVolumes" function in succession, checking whether + * the given path is an absolute path on any of the volumes returned (this + * is done by checking whether the path's prefix matches). */ fsRecPtr = FsGetFirstFilesystem(); Claim(); while (fsRecPtr != NULL) { + Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc; + /* - * Skip the the native filesystem because otherwise some of the tests - * in the Tcl testsuite might fail because some of the tests - * artificially change the current platform (between win, unix) but the - * list of volumes obtained by calling fsRecPtr->fsPtr->listVolumesProc - * reflects the current (real) platform only. In particular, on Unix - * '/' matchs the beginning of certain absolute Windows pathnames - * starting '//' and those tests go wrong. + * 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. * - * There is another reason to skip the native filesystem: Since the - * tclFilename.c code has nice fast 'absolute path' checkers, there is - * no reason to waste time doing that in this frequently-called - * function. It is better to save the overhead of the native - * filesystem continuously returning a list of volumes. + * Besides these test-suite issues, there is one other reason to skip + * the native filesystem --- since the tclFilename.c code has nice + * fast 'absolute path' checkers, we don't want to waste time + * repeating that effort here, and this function is actually called + * quite often, so if we can save the overhead of the native + * filesystem returning us a list of volumes all the time, it is + * better. */ - if ((fsRecPtr->fsPtr != &tclNativeFilesystem) - && (fsRecPtr->fsPtr->listVolumesProc != NULL)) { - Tcl_Size numVolumes; - Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc(); + if ((fsRecPtr->fsPtr != &tclNativeFilesystem) && (proc != NULL)) { + int numVolumes; + Tcl_Obj *thisFsVolumes = (*proc)(); if (thisFsVolumes != NULL) { - if (TclListObjLength(NULL, thisFsVolumes, &numVolumes) + if (Tcl_ListObjLength(NULL, thisFsVolumes, &numVolumes) != TCL_OK) { /* - * This is VERY bad; the listVolumesProc didn't return a - * valid list. Set numVolumes to -1 to skip the loop below - * and just return with the current value of 'type'. + * This is VERY bad; the Tcl_FSListVolumesProc didn't + * return a valid list. Set numVolumes to -1 so that we + * skip the while loop below and just return with the + * current value of 'type'. * - * It would be better to signal an error here, but - * Tcl_Panic seems a bit excessive. + * It would be better if we could signal an error here + * (but Tcl_Panic seems a bit excessive). */ - numVolumes = TCL_INDEX_NONE; + numVolumes = -1; } while (numVolumes > 0) { Tcl_Obj *vol; - Tcl_Size len; - const char *strVol; + int len; + char *strVol; numVolumes--; Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol); - strVol = TclGetStringFromObj(vol,&len); + strVol = Tcl_GetStringFromObj(vol,&len); if (pathLen < len) { continue; } - if (strncmp(strVol, path, len) == 0) { + if (strncmp(strVol, path, (size_t) len) == 0) { type = TCL_PATH_ABSOLUTE; if (filesystemPtrPtr != NULL) { *filesystemPtrPtr = fsRecPtr->fsPtr; @@ -4043,9 +4072,8 @@ TclFSNonnativePathType( Tcl_DecrRefCount(thisFsVolumes); if (type == TCL_PATH_ABSOLUTE) { /* - * No need to to examine additional filesystems. + * We don't need to examine any more filesystems. */ - break; } } @@ -4061,13 +4089,12 @@ TclFSNonnativePathType( * * Tcl_FSRenameFile -- * - * If the two pathnames correspond to the same filesystem, call - * 'renameFileProc' of that filesystem. Otherwise return the POSIX error - * 'EXDEV', and -1. + * If the two paths given belong to the same filesystem, we call that + * filesystems rename function. Otherwise we simply return the POSIX + * error 'EXDEV', and -1. * * Results: - * A standard Tcl error code if a rename function was called, or -1 - * otherwise. + * Standard Tcl error code if a function was called. * * Side effects: * A file may be renamed. @@ -4077,19 +4104,21 @@ TclFSNonnativePathType( int Tcl_FSRenameFile( - Tcl_Obj *srcPathPtr, /* The pathname of a file or directory to be - renamed. */ - Tcl_Obj *destPathPtr) /* The new pathname for the file. */ + Tcl_Obj* srcPathPtr, /* Pathname of file or dir to be renamed + * (UTF-8). */ + Tcl_Obj *destPathPtr) /* New pathname of file or directory + * (UTF-8). */ { int retVal = -1; const Tcl_Filesystem *fsPtr, *fsPtr2; - fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); - if ((fsPtr == fsPtr2) && (fsPtr != NULL) - && (fsPtr->renameFileProc != NULL)) { - retVal = fsPtr->renameFileProc(srcPathPtr, destPathPtr); + if ((fsPtr == fsPtr2) && (fsPtr != NULL)) { + Tcl_FSRenameFileProc *proc = fsPtr->renameFileProc; + if (proc != NULL) { + retVal = (*proc)(srcPathPtr, destPathPtr); + } } if (retVal == -1) { Tcl_SetErrno(EXDEV); @@ -4102,36 +4131,38 @@ Tcl_FSRenameFile( * * Tcl_FSCopyFile -- * - * If both pathnames correspond to the same filesystem, calls - * 'copyFileProc' of that filesystem. + * 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. * - * In the native filesystems, 'copyFileProc' copies a link itself, not the - * thing the link points to. + * Note that in the native filesystems, 'copyFileProc' is defined to copy + * soft links (i.e. it copies the links themselves, not the things they + * point to). * * Results: - * A standard Tcl return code if a copyFileProc was called, or -1 - * otherwise. + * Standard Tcl error code if a function was called. * * Side effects: - * A file might be copied. The POSIX error 'EXDEV' is set if a copy - * function was not called. + * A file may be copied. * *--------------------------------------------------------------------------- */ int Tcl_FSCopyFile( - Tcl_Obj *srcPathPtr, /* The pathname of file to be copied. */ - Tcl_Obj *destPathPtr) /* The new pathname to copy the file to. */ + Tcl_Obj *srcPathPtr, /* Pathname of file to be copied (UTF-8). */ + Tcl_Obj *destPathPtr) /* Pathname of file to copy to (UTF-8). */ { int retVal = -1; const Tcl_Filesystem *fsPtr, *fsPtr2; - fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); - if (fsPtr == fsPtr2 && fsPtr != NULL && fsPtr->copyFileProc != NULL) { - retVal = fsPtr->copyFileProc(srcPathPtr, destPathPtr); + if (fsPtr == fsPtr2 && fsPtr != NULL) { + Tcl_FSCopyFileProc *proc = fsPtr->copyFileProc; + if (proc != NULL) { + retVal = (*proc)(srcPathPtr, destPathPtr); + } } if (retVal == -1) { Tcl_SetErrno(EXDEV); @@ -4144,23 +4175,23 @@ Tcl_FSCopyFile( * * TclCrossFilesystemCopy -- * - * Helper for Tcl_FSCopyFile and Tcl_FSLoadFile. Copies a file from one - * filesystem to another, overwiting any file that already exists. + * Helper for above function, and for Tcl_FSLoadFile, to copy files from + * one filesystem to another. This function will overwrite the target + * file if it already exists. * * Results: - * A standard Tcl return code. + * Standard Tcl error code. * * Side effects: - * A file may be copied. + * A file may be created. * *--------------------------------------------------------------------------- */ - int TclCrossFilesystemCopy( - Tcl_Interp *interp, /* For error messages. */ - Tcl_Obj *source, /* Pathname of file to be copied. */ - Tcl_Obj *target) /* Pathname to copy the file to. */ + 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; @@ -4171,7 +4202,7 @@ TclCrossFilesystemCopy( out = Tcl_FSOpenFileChannel(interp, target, "wb", prot); if (out == NULL) { /* - * Failed to open an output channel. Bail out. + * It looks like we cannot copy it over. Bail out... */ goto done; } @@ -4179,7 +4210,7 @@ TclCrossFilesystemCopy( in = Tcl_FSOpenFileChannel(interp, source, "rb", prot); if (in == NULL) { /* - * Could not open an input channel. Why didn't the caller check this? + * This is very strange, caller should have checked this... */ Tcl_Close(interp, out); @@ -4187,8 +4218,8 @@ TclCrossFilesystemCopy( } /* - * Copy the file synchronously. TO DO: Maybe add an asynchronous option - * to support virtual filesystems that are slow (e.g. network sockets). + * 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) { @@ -4196,7 +4227,7 @@ TclCrossFilesystemCopy( } /* - * If the copy failed, assume that copy channel left an error message. + * If the copy failed, assume that copy channel left a good error message. */ Tcl_Close(interp, in); @@ -4207,8 +4238,8 @@ TclCrossFilesystemCopy( */ if (Tcl_FSLstat(source, &sourceStatBuf) == 0) { - tval.actime = Tcl_GetAccessTimeFromStat(&sourceStatBuf); - tval.modtime = Tcl_GetModificationTimeFromStat(&sourceStatBuf); + tval.actime = sourceStatBuf.st_atime; + tval.modtime = sourceStatBuf.st_mtime; Tcl_FSUtime(target, &tval); } @@ -4221,11 +4252,11 @@ TclCrossFilesystemCopy( * * Tcl_FSDeleteFile -- * - * Calls 'deleteFileProc' of the filesystem corresponding to the given - * pathname. + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. * * Results: - * A standard Tcl return code. + * Standard Tcl error code. * * Side effects: * A file may be deleted. @@ -4238,17 +4269,13 @@ Tcl_FSDeleteFile( Tcl_Obj *pathPtr) /* Pathname of file to be removed (UTF-8). */ { const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - int err; - - if (fsPtr == NULL) { - err = ENOENT; - } else { - if (fsPtr->deleteFileProc != NULL) { - return fsPtr->deleteFileProc(pathPtr); + if (fsPtr != NULL) { + Tcl_FSDeleteFileProc *proc = fsPtr->deleteFileProc; + if (proc != NULL) { + return (*proc)(pathPtr); } - err = ENOTSUP; } - Tcl_SetErrno(err); + Tcl_SetErrno(ENOENT); return -1; } @@ -4257,15 +4284,14 @@ Tcl_FSDeleteFile( * * Tcl_FSCreateDirectory -- * - * Calls 'createDirectoryProc' of the filesystem corresponding to the - * given pathname. + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. * * Results: - * A standard Tcl return code, or -1 if no createDirectoryProc is found. + * Standard Tcl error code. * * Side effects: - * A directory may be created. POSIX error 'ENOENT' is set if no - * createDirectoryProc is found. + * A directory may be created. * *--------------------------------------------------------------------------- */ @@ -4275,17 +4301,13 @@ Tcl_FSCreateDirectory( Tcl_Obj *pathPtr) /* Pathname of directory to create (UTF-8). */ { const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - int err; - - if (fsPtr == NULL) { - err = ENOENT; - } else { - if (fsPtr->createDirectoryProc != NULL) { - return fsPtr->createDirectoryProc(pathPtr); + if (fsPtr != NULL) { + Tcl_FSCreateDirectoryProc *proc = fsPtr->createDirectoryProc; + if (proc != NULL) { + return (*proc)(pathPtr); } - err = ENOTSUP; } - Tcl_SetErrno(err); + Tcl_SetErrno(ENOENT); return -1; } @@ -4294,38 +4316,38 @@ Tcl_FSCreateDirectory( * * Tcl_FSCopyDirectory -- * - * If both pathnames correspond to the the same filesystem, calls - * 'copyDirectoryProc' of that filesystem. + * If the two paths given belong to the same filesystem, we call that + * filesystems copy-directory function. Otherwise we simply return the + * POSIX error 'EXDEV', and -1. * * Results: - * A standard Tcl return code, or -1 if no 'copyDirectoryProc' is found. + * Standard Tcl error code if a function was called. * * Side effects: - * A directory may be copied. POSIX error 'EXDEV' is set if no - * copyDirectoryProc is found. + * A directory may be copied. * *--------------------------------------------------------------------------- */ int Tcl_FSCopyDirectory( - Tcl_Obj *srcPathPtr, /* The pathname of the directory to be - * copied. */ - Tcl_Obj *destPathPtr, /* The pathname of the target directory. */ - Tcl_Obj **errorPtr) /* If not NULL, and there is an error, a place - * to store a pointer to a new object, with - * its refCount already incremented, and - * containing the pathname name of file - * causing the error. */ + Tcl_Obj* srcPathPtr, /* Pathname of directory to be copied + * (UTF-8). */ + Tcl_Obj *destPathPtr, /* Pathname of target directory (UTF-8). */ + Tcl_Obj **errorPtr) /* If non-NULL, then will be set to a new + * object containing name of file causing + * error, with refCount 1. */ { int retVal = -1; const Tcl_Filesystem *fsPtr, *fsPtr2; - fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); - if (fsPtr == fsPtr2 && fsPtr != NULL && fsPtr->copyDirectoryProc != NULL){ - retVal = fsPtr->copyDirectoryProc(srcPathPtr, destPathPtr, errorPtr); + if (fsPtr == fsPtr2 && fsPtr != NULL) { + Tcl_FSCopyDirectoryProc *proc = fsPtr->copyDirectoryProc; + if (proc != NULL) { + retVal = (*proc)(srcPathPtr, destPathPtr, errorPtr); + } } if (retVal == -1) { Tcl_SetErrno(EXDEV); @@ -4338,71 +4360,69 @@ Tcl_FSCopyDirectory( * * Tcl_FSRemoveDirectory -- * - * Calls 'removeDirectoryProc' of the filesystem corresponding to remove - * pathPtr. + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. * * Results: - * A standard Tcl return code, or -1 if no removeDirectoryProc is found. + * Standard Tcl error code. * * Side effects: - * A directory may be removed. POSIX error 'ENOENT' is set if no - * removeDirectoryProc is found. + * A directory may be deleted. * *--------------------------------------------------------------------------- */ int Tcl_FSRemoveDirectory( - Tcl_Obj *pathPtr, /* The pathname of the directory to be removed. - */ - int recursive, /* If zero, removes only an empty directory. - * Otherwise, removes the directory and all its - * contents. */ - Tcl_Obj **errorPtr) /* If not NULL and an error occurs, stores a - * place to store a a pointer to a new - * object having a refCount of 1 and containing - * the name of the file that produced an error. - * */ + Tcl_Obj *pathPtr, /* Pathname of directory to be removed + * (UTF-8). */ + int recursive, /* If non-zero, removes directories that are + * nonempty. Otherwise, will only remove empty + * directories. */ + Tcl_Obj **errorPtr) /* If non-NULL, then will be set to a new + * object containing name of file causing + * error, with refCount 1. */ { const 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. + */ - if (fsPtr == NULL) { - Tcl_SetErrno(ENOENT); - return -1; - } - if (fsPtr->removeDirectoryProc == NULL) { - Tcl_SetErrno(ENOTSUP); - return -1; - } + Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL); - if (recursive) { - Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL); - if (cwdPtr != NULL) { - const char *cwdStr, *normPathStr; - Tcl_Size cwdLen, normLen; - Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (cwdPtr != NULL) { + char *cwdStr, *normPathStr; + int cwdLen, normLen; + Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); - if (normPath != NULL) { - normPathStr = TclGetStringFromObj(normPath, &normLen); - cwdStr = TclGetStringFromObj(cwdPtr, &cwdLen); - if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr, - normLen) == 0)) { - /* - * The cwd is inside the directory to be removed. Change - * the cwd to [file dirname $path]. - */ + if (normPath != NULL) { + normPathStr = Tcl_GetStringFromObj(normPath, &normLen); + cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); + if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr, + (size_t) normLen) == 0)) { + /* + * The cwd is inside the directory, so we perform a + * 'cd [file dirname $path]'. + */ - Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr, - TCL_PATH_DIRNAME); + Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr, + TCL_PATH_DIRNAME); - Tcl_FSChdir(dirPtr); - Tcl_DecrRefCount(dirPtr); + Tcl_FSChdir(dirPtr); + Tcl_DecrRefCount(dirPtr); + } } + Tcl_DecrRefCount(cwdPtr); } - Tcl_DecrRefCount(cwdPtr); } + return (*proc)(pathPtr, recursive, errorPtr); } - return fsPtr->removeDirectoryProc(pathPtr, recursive, errorPtr); + Tcl_SetErrno(ENOENT); + return -1; } /* @@ -4410,83 +4430,84 @@ Tcl_FSRemoveDirectory( * * Tcl_FSGetFileSystemForPath -- * - * Produces the filesystem that corresponds to the given pathname. + * This function determines which filesystem to use for a particular path + * object, and returns the filesystem which accepts this file. If no + * filesystem will accept this object as a valid file path, then NULL is + * returned. * * Results: - * The corresponding Tcl_Filesystem, or NULL if the pathname is invalid. + * NULL or a filesystem which will accept this path. * * Side effects: - * The internal representation of fsPtrPtr is converted to fsPathType if - * needed, and that internal representation is updated as needed. + * The object may be converted to a path type. * *--------------------------------------------------------------------------- */ -const Tcl_Filesystem * +Tcl_Filesystem * Tcl_FSGetFileSystemForPath( - Tcl_Obj *pathPtr) + Tcl_Obj* pathPtr) { FilesystemRecord *fsRecPtr; - const Tcl_Filesystem *retVal = NULL; + Tcl_Filesystem* retVal = NULL; if (pathPtr == NULL) { Tcl_Panic("Tcl_FSGetFileSystemForPath called with NULL object"); return NULL; } + /* + * If the object has a refCount of zero, we reject it. This is to avoid + * possible segfaults or nondeterministic memory leaks (i.e. the user + * doesn't know if they should decrement the ref count on return or not). + */ + if (pathPtr->refCount == 0) { - /* - * Avoid possible segfaults or nondeterministic memory leaks where the - * reference count has been incorreclty managed. - */ Tcl_Panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0"); return NULL; } - /* Start with an up-to-date copy of the filesystem. */ + /* + * Check if the filesystem has changed in some way since this object's + * internal representation was calculated. Before doing that, assure we + * have the most up-to-date copy of the master filesystem. This is + * accomplished by the FsGetFirstFilesystem() call. + */ + fsRecPtr = FsGetFirstFilesystem(); Claim(); - /* - * Ensure that pathPtr is a valid pathname. - */ if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) { - /* not a valid pathname */ Disclaim(); return NULL; - } else if (retVal != NULL) { - /* - * Found the filesystem in the internal representation of pathPtr. - */ - Disclaim(); - return retVal; } /* - * Call each of the "pathInFilesystem" functions in succession until the - * corresponding filesystem is found. + * Call each of the "pathInFilesystem" functions in succession. A + * non-return value of -1 indicates the particular function has succeeded. */ - for (; fsRecPtr!=NULL ; fsRecPtr=fsRecPtr->nextPtr) { - void *clientData = NULL; - if (fsRecPtr->fsPtr->pathInFilesystemProc == NULL) { - continue; - } + while ((retVal == NULL) && (fsRecPtr != NULL)) { + Tcl_FSPathInFilesystemProc *proc = + fsRecPtr->fsPtr->pathInFilesystemProc; - if (fsRecPtr->fsPtr->pathInFilesystemProc(pathPtr, &clientData)!=-1) { - /* This is the filesystem for pathPtr. Assume the type of pathPtr - * hasn't been changed by the above call to the - * pathInFilesystemProc, and cache this result in the internal - * representation of pathPtr. */ + if (proc != NULL) { + ClientData clientData = NULL; + if ((*proc)(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; + TclFSSetPathDetails(pathPtr, fsRecPtr->fsPtr, clientData); + retVal = fsRecPtr->fsPtr; + } } + fsRecPtr = fsRecPtr->nextPtr; } Disclaim(); - return NULL; + return retVal; } /* @@ -4494,16 +4515,35 @@ Tcl_FSGetFileSystemForPath( * * Tcl_FSGetNativePath -- * - * See Tcl_FSGetInternalRep. + * This function is for use by the Win/Unix native filesystems, so that + * they can easily retrieve the native (char* or TCHAR*) representation + * of a path. Other filesystems will probably want to implement similar + * functions. They basically act as a safety net around + * Tcl_FSGetInternalRep. Normally your file-system functions will always + * be called with path objects already converted to the correct + * filesystem, but if for some reason they are called directly (i.e. by + * functions not in this file), then one cannot necessarily guarantee + * that the path object pointer is from the correct filesystem. + * + * Note: in the future it might be desireable to have separate versions + * of this function with different signatures, for example + * Tcl_FSGetNativeWinPath, Tcl_FSGetNativeUnixPath etc. Right now, since + * native paths are all string based, we use just one function. + * + * Results: + * NULL or a valid native path. + * + * Side effects: + * See Tcl_FSGetInternalRep. * *--------------------------------------------------------------------------- */ -const void * +const char * Tcl_FSGetNativePath( Tcl_Obj *pathPtr) { - return Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem); + return (const char *) Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem); } /* @@ -4511,7 +4551,7 @@ Tcl_FSGetNativePath( * * NativeFreeInternalRep -- * - * Free a native internal representation. + * Free a native internal representation, which will be non-NULL. * * Results: * None. @@ -4524,26 +4564,25 @@ Tcl_FSGetNativePath( static void NativeFreeInternalRep( - void *clientData) + ClientData clientData) { - ckfree(clientData); + ckfree((char *) clientData); } /* *--------------------------------------------------------------------------- * * Tcl_FSFileSystemInfo -- - * Produce the type of a pathname and the type of its 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 where the first item is the name of the filesystem (e.g. - * "native" or "vfs"), and the second item is the type of the given - * pathname within that filesystem. + * A list of two elements. * * Side effects: - * The internal representation of pathPtr may be converted to a - * fsPathType. + * The object may be converted to a path type. * *--------------------------------------------------------------------------- */ @@ -4553,6 +4592,7 @@ Tcl_FSFileSystemInfo( Tcl_Obj *pathPtr) { Tcl_Obj *resPtr; + Tcl_FSFilesystemPathTypeProc *proc; const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr == NULL) { @@ -4560,12 +4600,11 @@ Tcl_FSFileSystemInfo( } resPtr = Tcl_NewListObj(0, NULL); - Tcl_ListObjAppendElement(NULL, resPtr, - Tcl_NewStringObj(fsPtr->typeName, -1)); - - if (fsPtr->filesystemPathTypeProc != NULL) { - Tcl_Obj *typePtr = fsPtr->filesystemPathTypeProc(pathPtr); + Tcl_ListObjAppendElement(NULL,resPtr,Tcl_NewStringObj(fsPtr->typeName,-1)); + proc = fsPtr->filesystemPathTypeProc; + if (proc != NULL) { + Tcl_Obj *typePtr = (*proc)(pathPtr); if (typePtr != NULL) { Tcl_ListObjAppendElement(NULL, resPtr, typePtr); } @@ -4579,13 +4618,16 @@ Tcl_FSFileSystemInfo( * * Tcl_FSPathSeparator -- * - * Produces the separator for given pathname. + * This function returns the separator to be used for a given path. The + * object returned should have a refCount of zero * * Results: - * A Tcl object having a refCount of zero. + * A Tcl object, with a refCount of zero. If the caller needs to retain a + * reference to the object, it should call Tcl_IncrRefCount, and should + * otherwise free the object. * * Side effects: - * The internal representation of pathPtr may be converted to a fsPathType + * The path object may be converted to a path type. * *--------------------------------------------------------------------------- */ @@ -4595,23 +4637,23 @@ Tcl_FSPathSeparator( Tcl_Obj *pathPtr) { const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - Tcl_Obj *resultObj; if (fsPtr == NULL) { return NULL; } - if (fsPtr->filesystemSeparatorProc != NULL) { - return fsPtr->filesystemSeparatorProc(pathPtr); - } + return (*fsPtr->filesystemSeparatorProc)(pathPtr); + } else { + Tcl_Obj *resultObj; - /* - * Use the standard forward slash character if filesystem does not to - * provide a filesystemSeparatorProc. - */ + /* + * Allow filesystems not to provide a filesystemSeparatorProc if they + * wish to use the standard forward slash. + */ - TclNewLiteralStringObj(resultObj, "/"); - return resultObj; + TclNewLiteralStringObj(resultObj, "/"); + return resultObj; + } } /* @@ -4619,11 +4661,11 @@ Tcl_FSPathSeparator( * * NativeFilesystemSeparator -- * - * This function, part of the native filesystem support, returns the - * separator for the given pathname. + * This function is part of the native filesystem support, and returns + * the separator for the given path. * * Results: - * The separator character. + * String object containing the separator character. * * Side effects: * None. @@ -4633,10 +4675,9 @@ Tcl_FSPathSeparator( static Tcl_Obj * NativeFilesystemSeparator( - TCL_UNUSED(Tcl_Obj *) /*pathPtr*/) + Tcl_Obj *pathPtr) { - const char *separator = NULL; - + const char *separator = NULL; /* lint */ switch (tclPlatform) { case TCL_PLATFORM_UNIX: separator = "/"; @@ -4647,6 +4688,318 @@ NativeFilesystemSeparator( } return Tcl_NewStringObj(separator,1); } + +/* Everything from here on is contained in this obsolete ifdef */ +#ifdef USE_OBSOLETE_FS_HOOKS + +/* + *---------------------------------------------------------------------- + * + * TclStatInsertProc -- + * + * Insert the passed function 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( + 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 removable. + * + * Results: + * TCL_OK if the function pointer was successfully removed, TCL_ERROR + * otherwise. + * + * Side effects: + * Memory is deallocated and the respective list updated. + * + *---------------------------------------------------------------------- + */ + +int +TclStatDeleteProc( + 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 function 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( + 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 removable. + * + * Results: + * TCL_OK if the function pointer was successfully removed, TCL_ERROR + * otherwise. + * + * Side effects: + * Memory is deallocated and the respective list updated. + * + *---------------------------------------------------------------------- + */ + +int +TclAccessDeleteProc( + 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 function 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( + 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 function pointer was successfully removed, TCL_ERROR + * otherwise. + * + * Side effects: + * Memory is deallocated and the respective list updated. + * + *---------------------------------------------------------------------- + */ + +int +TclOpenFileChannelDeleteProc( + 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: |