tcl.git - Tcl is a high-level, general-purpose, interpreted, dynamic programming language. It was designed with the goal of being very simple but powerful.
/* * tclIOUtil.c -- * * This file contains the implementation of Tcl's generic filesystem * code, which supports a pluggable filesystem architecture allowing both * platform specific filesystems and 'virtual filesystems'. All * filesystem access should go through the functions defined in this * file. Most of this code was contributed by Vince Darley. * * 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__# include"tclWinInt.h"#endif#include"tclFileSystem.h"/* * struct FilesystemRecord -- * * A filesystem record is used to keep track of each filesystem currently * registered with the core, in a linked list. */typedefstruct FilesystemRecord {
ClientData clientData;/* Client specific data for the new filesystem * (can be NULL) */
Tcl_Filesystem *fsPtr;/* Pointer to filesystem dispatch table. */struct FilesystemRecord *nextPtr;/* The next filesystem registered to Tcl, or * NULL if no more. */struct FilesystemRecord *prevPtr;/* The previous filesystem registered to Tcl, * or NULL if no more. */} FilesystemRecord;/* * This structure holds per-thread private copy of the current directory * maintained by the global cwdPathPtr. This structure holds per-thread * private copies of some global data. This way we avoid most of the * synchronization calls which boosts performance, at cost of having to update * this information each time the corresponding epoch counter changes. */typedefstruct ThreadSpecificData {int initialized;int cwdPathEpoch;int filesystemEpoch;
Tcl_Obj *cwdPathPtr;
ClientData cwdClientData;
FilesystemRecord *filesystemList;int claims;} ThreadSpecificData;/* * Prototypes for functions defined later in this file. */static FilesystemRecord*FsGetFirstFilesystem(void);static voidFsThrExitProc(ClientData cd);static Tcl_Obj *FsListMounts(Tcl_Obj *pathPtr,const char*pattern);static voidFsAddMountsToGlobResult(Tcl_Obj *resultPtr,
Tcl_Obj *pathPtr,const char*pattern,
Tcl_GlobTypeData *types);static voidFsUpdateCwd(Tcl_Obj *cwdObj, ClientData clientData);static voidFsRecacheFilesystemList(void);static voidClaim(void);static voidDisclaim(void);/* * 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* tclpFileAttrStrings[];
MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[];/* * The following functions are obsolete string based APIs, and should be * removed in a future release (Tcl 9 would be a good time). *//* Obsolete */intTcl_Stat(const char*path,/* Path of file to stat (in current CP). */struct stat *oldStyleBuf)/* Filled with results of stat call. */{int ret;
Tcl_StatBuf buf;
Tcl_Obj *pathPtr =Tcl_NewStringObj(path, -1);Tcl_IncrRefCount(pathPtr);
ret =Tcl_FSStat(pathPtr, &buf);Tcl_DecrRefCount(pathPtr);if(ret != -1) {#ifndef TCL_WIDE_INT_IS_LONG
Tcl_WideInt tmp1, tmp2, tmp3 =0;# define OUT_OF_RANGE(x) \ (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \ ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX))# define OUT_OF_URANGE(x) \ (((Tcl_WideUInt)(x)) > ((Tcl_WideUInt)ULONG_MAX))/* * Perform the result-buffer overflow check manually. * * Note that ino_t/ino64_t is unsigned... * * Workaround gcc warning of "comparison is always false due to * limited range of data type" by assigning to tmp var of type * Tcl_WideInt. */
tmp1 = (Tcl_WideInt) buf.st_ino;
tmp2 = (Tcl_WideInt) buf.st_size;#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
tmp3 = (Tcl_WideInt) buf.st_blocks;#endifif(OUT_OF_URANGE(tmp1) ||OUT_OF_RANGE(tmp2) ||OUT_OF_RANGE(tmp3)) {#if defined(EFBIG)
errno = EFBIG;#elif defined(EOVERFLOW)
errno = EOVERFLOW;#else#error"What status should be returned for file size out of range?"#endifreturn-1;}# undef OUT_OF_RANGE# undef OUT_OF_URANGE#endif/* !TCL_WIDE_INT_IS_LONG *//* * Copy across all supported fields, with possible type coercions on * those fields that change between the normal and lf64 versions of * the stat structure (on Solaris at least). This is slow when the * structure sizes coincide, but that's what you get for using an * obsolete interface. */
oldStyleBuf->st_mode = buf.st_mode;
oldStyleBuf->st_ino = (ino_t) buf.st_ino;
oldStyleBuf->st_dev = buf.st_dev;
oldStyleBuf->st_rdev = buf.st_rdev;
oldStyleBuf->st_nlink = buf.st_nlink;
oldStyleBuf->st_uid = buf.st_uid;
oldStyleBuf->st_gid = buf.st_gid;
oldStyleBuf->st_size = (off_t) buf.st_size;
oldStyleBuf->st_atime = buf.st_atime;
oldStyleBuf->st_mtime = buf.st_mtime;
oldStyleBuf->st_ctime = buf.st_ctime;#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
oldStyleBuf->st_blksize = buf.st_blksize;#endif#ifdef HAVE_STRUCT_STAT_ST_BLOCKS#ifdef HAVE_BLKCNT_T
oldStyleBuf->st_blocks = (blkcnt_t) buf.st_blocks;#else
oldStyleBuf->st_blocks = (unsigned long) buf.st_blocks;#endif#endif}return ret;}/* Obsolete */intTcl_Access(const char*path,/* Path of file to access (in current CP). */int mode)/* Permission setting. */{int ret;
Tcl_Obj *pathPtr =Tcl_NewStringObj(path,-1);Tcl_IncrRefCount(pathPtr);
ret =Tcl_FSAccess(pathPtr,mode);Tcl_DecrRefCount(pathPtr);return ret;}/* Obsolete */
Tcl_Channel
Tcl_OpenFileChannel(
Tcl_Interp *interp,/* Interpreter for error reporting; can be * NULL. */const char*path,/* Name of file to open. */const char*modeString,/* A list of POSIX open modes or a string such * as "rw". */int permissions)/* If the open involves creating a file, with * what modes to create it? */{
Tcl_Channel ret;
Tcl_Obj *pathPtr =Tcl_NewStringObj(path,-1);Tcl_IncrRefCount(pathPtr);
ret =Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions);Tcl_DecrRefCount(pathPtr);return ret;}/* Obsolete */intTcl_Chdir(const char*dirName){int ret;
Tcl_Obj *pathPtr =Tcl_NewStringObj(dirName,-1);Tcl_IncrRefCount(pathPtr);
ret =Tcl_FSChdir(pathPtr);Tcl_DecrRefCount(pathPtr);return ret;}/* Obsolete */char*Tcl_GetCwd(
Tcl_Interp *interp,
Tcl_DString *cwdPtr){
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);returnTcl_DStringValue(cwdPtr);}}/* Obsolete */intTcl_EvalFile(
Tcl_Interp *interp,/* Interpreter in which to process file. */const char*fileName)/* Name of file to process. Tilde-substitution * will be performed on this name. */{int ret;
Tcl_Obj *pathPtr =Tcl_NewStringObj(fileName,-1);Tcl_IncrRefCount(pathPtr);
ret =Tcl_FSEvalFile(interp, pathPtr);Tcl_DecrRefCount(pathPtr);return ret;}/* * The 3 hooks for Stat, Access and OpenFileChannel are obsolete. The * complete, general hooked filesystem APIs should be used instead. This * define decides whether to include the obsolete hooks and related code. If * these are removed, we'll also want to remove them from stubs/tclInt. The * only known users of these APIs are prowrap and mktclapp. New * code/extensions should not use them, since they do not provide as full * support as the full filesystem API. * * As soon as prowrap and mktclapp are updated to use the full filesystem * support, I suggest all these hooks are removed. */#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. */typedefstruct StatProc {
TclStatProc_ *proc;/* Function to process a 'stat()' call */struct StatProc *nextPtr;/* The next 'stat()' function to call */} StatProc;typedefstruct AccessProc {
TclAccessProc_ *proc;/* Function to process a 'access()' call */struct AccessProc *nextPtr;/* The next 'access()' function to call */} AccessProc;typedefstruct 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. */typedefstruct 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 voidFsThrExitProc(
ClientData cd){
ThreadSpecificData *tsdPtr = (ThreadSpecificData *) cd;
FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL;/* * Trash the cwd copy. */if(tsdPtr->cwdPathPtr != NULL) {Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
tsdPtr->cwdPathPtr = NULL;}if(tsdPtr->cwdClientData != NULL) {NativeFreeInternalRep(tsdPtr->cwdClientData);}/* * Trash the filesystems cache. */
fsRecPtr = tsdPtr->filesystemList;while(fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr->nextPtr;
fsRecPtr->fsPtr = NULL;ckfree((char*)fsRecPtr);
fsRecPtr = tmpFsRecPtr;}
tsdPtr->filesystemList = NULL;
tsdPtr->initialized =0;}intTclFSCwdIsNative(void){
ThreadSpecificData *tsdPtr =TCL_TSD_INIT(&fsDataKey);if(tsdPtr->cwdClientData != NULL) {return1;}else{return0;}}/* *---------------------------------------------------------------------- * * TclFSCwdPointerEquals -- * * Check whether the current working directory is equal to the path * given. * * Results: * 1 (equal) or 0 (un-equal) as appropriate. * * Side effects: * If the paths are equal, but are not the same object, this method will * modify the given pathPtrPtr to refer to the same object. In this case * the object pointed to by pathPtrPtr will have its refCount * decremented, and it will be adjusted to point to the cwd (with a new * refCount). * *---------------------------------------------------------------------- */intTclFSCwdPointerEquals(
Tcl_Obj** pathPtrPtr){
ThreadSpecificData *tsdPtr =TCL_TSD_INIT(&fsDataKey);Tcl_MutexLock(&cwdMutex);if(tsdPtr->cwdPathPtr == NULL
|| tsdPtr->cwdPathEpoch != cwdPathEpoch) {if(tsdPtr->cwdPathPtr != NULL) {Tcl_DecrRefCount(tsdPtr->cwdPathPtr);}if(tsdPtr->cwdClientData != NULL) {NativeFreeInternalRep(tsdPtr->cwdClientData);}if(cwdPathPtr == NULL) {
tsdPtr->cwdPathPtr = NULL;}else{
tsdPtr->cwdPathPtr =Tcl_DuplicateObj(cwdPathPtr);Tcl_IncrRefCount(tsdPtr->cwdPathPtr);}if(cwdClientData == NULL) {
tsdPtr->cwdClientData = NULL;}else{
tsdPtr->cwdClientData =TclNativeDupInternalRep(cwdClientData);}
tsdPtr->cwdPathEpoch = cwdPathEpoch;}Tcl_MutexUnlock(&cwdMutex);if(tsdPtr->initialized ==0) {Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr);
tsdPtr->initialized =1;}if(pathPtrPtr == NULL) {return(tsdPtr->cwdPathPtr == NULL);}if(tsdPtr->cwdPathPtr == *pathPtrPtr) {return1;}else{int len1, len2;const char*str1, *str2;
str1 =Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1);
str2 =Tcl_GetStringFromObj(*pathPtrPtr, &len2);if(len1 == len2 && !strcmp(str1,str2)) {/* * They are equal, but different objects. Update so they will be * the same object in the future. */Tcl_DecrRefCount(*pathPtrPtr);*pathPtrPtr = tsdPtr->cwdPathPtr;Tcl_IncrRefCount(*pathPtrPtr);return1;}else{return0;}}}static voidFsRecacheFilesystemList(void){
ThreadSpecificData *tsdPtr =TCL_TSD_INIT(&fsDataKey);
FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL, *toFree = NULL, *list;/* * Trash the current cache. */
fsRecPtr = tsdPtr->filesystemList;while(fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr->nextPtr;
fsRecPtr->nextPtr = toFree;
toFree = fsRecPtr;
fsRecPtr = tmpFsRecPtr;}/* * Locate tail of the global filesystem list. */Tcl_MutexLock(&filesystemMutex);
fsRecPtr = filesystemList;while(fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr;
fsRecPtr = fsRecPtr->nextPtr;}/* * Refill the cache honouring the order. */
list = NULL;
fsRecPtr = tmpFsRecPtr;while(fsRecPtr != NULL) {
tmpFsRecPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord));*tmpFsRecPtr = *fsRecPtr;
tmpFsRecPtr->nextPtr = list;
tmpFsRecPtr->prevPtr = NULL;
list = tmpFsRecPtr;
fsRecPtr = fsRecPtr->prevPtr;}
tsdPtr->filesystemList = list;
tsdPtr->filesystemEpoch = theFilesystemEpoch;Tcl_MutexUnlock(&filesystemMutex);while(toFree) {
FilesystemRecord *next = toFree->nextPtr;
toFree->fsPtr = NULL;ckfree((char*)toFree);
toFree = next;}/* * Make sure the above gets released on thread exit. */if(tsdPtr->initialized ==0) {Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr);
tsdPtr->initialized =1;}}static FilesystemRecord *FsGetFirstFilesystem(void){
ThreadSpecificData *tsdPtr =TCL_TSD_INIT(&fsDataKey);if(tsdPtr->filesystemList == NULL || ((tsdPtr->claims ==0)&& (tsdPtr->filesystemEpoch != theFilesystemEpoch))) {FsRecacheFilesystemList();}return tsdPtr->filesystemList;}/* * The epoch can be changed both by filesystems being added or removed and by * env(HOME) changing. */intTclFSEpochOk(int filesystemEpoch){return(filesystemEpoch ==0|| filesystemEpoch == theFilesystemEpoch);}static voidClaim(){
ThreadSpecificData *tsdPtr =TCL_TSD_INIT(&fsDataKey);
tsdPtr->claims++;}static voidDisclaim(){
ThreadSpecificData *tsdPtr =TCL_TSD_INIT(&fsDataKey);
tsdPtr->claims--;}intTclFSEpoch(){
ThreadSpecificData *tsdPtr =TCL_TSD_INIT(&fsDataKey);return tsdPtr->filesystemEpoch;}/* * If non-NULL, clientData is owned by us and must be freed later. */static voidFsUpdateCwd(
Tcl_Obj *cwdObj,
ClientData clientData){int len;char*str = NULL;
ThreadSpecificData *tsdPtr =TCL_TSD_INIT(&fsDataKey);if(cwdObj != NULL) {
str =Tcl_GetStringFromObj(cwdObj, &len);}Tcl_MutexLock(&cwdMutex);if(cwdPathPtr != NULL) {Tcl_DecrRefCount(cwdPathPtr);}if(cwdClientData != NULL) {NativeFreeInternalRep(cwdClientData);}if(cwdObj == NULL) {
cwdPathPtr = NULL;
cwdClientData = NULL;}else{/* * This must be stored as string obj! */
cwdPathPtr =Tcl_NewStringObj(str, len);Tcl_IncrRefCount(cwdPathPtr);
cwdClientData =TclNativeDupInternalRep(clientData);}
cwdPathEpoch++;
tsdPtr->cwdPathEpoch = cwdPathEpoch;Tcl_MutexUnlock(&cwdMutex);if(tsdPtr->cwdPathPtr) {Tcl_DecrRefCount(tsdPtr->cwdPathPtr);}if(tsdPtr->cwdClientData) {NativeFreeInternalRep(tsdPtr->cwdClientData);}if(cwdObj == NULL) {
tsdPtr->cwdPathPtr = NULL;
tsdPtr->cwdClientData = NULL;}else{
tsdPtr->cwdPathPtr =Tcl_NewStringObj(str, len);
tsdPtr->cwdClientData = clientData;Tcl_IncrRefCount(tsdPtr->cwdPathPtr);}}/* *---------------------------------------------------------------------- * * TclFinalizeFilesystem -- * * Clean up the filesystem. After this, calls to all Tcl_FS... functions * will fail. * * We will later call TclResetFilesystem to restore the FS to a pristine * state. * * Results: * None. * * Side effects: * Frees any memory allocated by the filesystem. * *---------------------------------------------------------------------- */voidTclFinalizeFilesystem(void){
FilesystemRecord *fsRecPtr;/* * Assumption that only one thread is active now. Otherwise we would need * to put various mutexes around this code. */if(cwdPathPtr != NULL) {Tcl_DecrRefCount(cwdPathPtr);
cwdPathPtr = NULL;
cwdPathEpoch =0;}if(cwdClientData != NULL) {NativeFreeInternalRep(cwdClientData);
cwdClientData = NULL;}/* * Remove all filesystems, freeing any allocated memory that is no longer * needed */
fsRecPtr = filesystemList;while(fsRecPtr != NULL) {
FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr;/* The native filesystem is static, so we don't free it. */if(fsRecPtr != &nativeFilesystemRecord) {ckfree((char*)fsRecPtr);}
fsRecPtr = tmpFsRecPtr;}
theFilesystemEpoch++;
filesystemList = NULL;/* * Now filesystemList is NULL. This means that any attempt to use the * filesystem is likely to fail. */#ifdef USE_OBSOLETE_FS_HOOKS
statProcList = NULL;
accessProcList = NULL;
openFileChannelProcList = NULL;#endif#ifdef __WIN32__TclWinEncodingsCleanup();#endif}/* *---------------------------------------------------------------------- * * TclResetFilesystem -- * * Restore the filesystem to a pristine state. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */voidTclResetFilesystem(void){
filesystemList = &nativeFilesystemRecord;
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}/* *---------------------------------------------------------------------- * * Tcl_FSRegister -- * * Insert the filesystem function table at the head of the list of * functions which are used during calls to all file-system operations. * The filesystem will be added even if it is already in the list. (You * can use Tcl_FSData to check if it is in the list, provided the * ClientData used was not NULL). * * Note that the filesystem handling is head-to-tail of the list. Each * filesystem is asked in turn whether it can handle a particular * request, until one of them says 'yes'. At that point no further * filesystems are asked. * * In particular this means if you want to add a diagnostic filesystem * (which simply reports all fs activity), it must be at the head of the * list: i.e. it must be the last registered. * * 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 filesystems. * *---------------------------------------------------------------------- */intTcl_FSRegister(
ClientData clientData,/* Client specific data for this fs */
Tcl_Filesystem *fsPtr)/* The filesystem record for the new fs. */{
FilesystemRecord *newFilesystemPtr;if(fsPtr == NULL) {return TCL_ERROR;}
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;
newFilesystemPtr->prevPtr = NULL;if(filesystemList) {
filesystemList->prevPtr = newFilesystemPtr;}
filesystemList = newFilesystemPtr;/* * Increment the filesystem epoch counter, since existing paths might * conceivably now belong to different filesystems. */
theFilesystemEpoch++;Tcl_MutexUnlock(&filesystemMutex);return TCL_OK;}/* *---------------------------------------------------------------------- * * Tcl_FSUnregister -- * * Remove the passed filesystem from the list of filesystem function * tables. It also ensures that the built-in (native) filesystem is not * removable, although we may wish to change that decision in the future * to allow a smaller Tcl core, in which the native filesystem is not * used at all (we could, say, initialise Tcl completely over a network * connection). * * Results: * TCL_OK if the function pointer was successfully removed, TCL_ERROR * otherwise. * * Side effects: * Memory may be deallocated (or will be later, once no "path" objects * refer to this filesystem), but the list of registered filesystems is * updated immediately. * *---------------------------------------------------------------------- */intTcl_FSUnregister(
Tcl_Filesystem *fsPtr)/* The filesystem record to remove. */{int retVal = TCL_ERROR;
FilesystemRecord *fsRecPtr;Tcl_MutexLock(&filesystemMutex);/* * Traverse the 'filesystemList' looking for the particular node whose * 'fsPtr' member matches 'fsPtr' and remove that one from the list. * Ensure that the "default" node cannot be removed. */
fsRecPtr = filesystemList;while((retVal == TCL_ERROR) && (fsRecPtr != &nativeFilesystemRecord)) {if(fsRecPtr->fsPtr == fsPtr) {if(fsRecPtr->prevPtr) {
fsRecPtr->prevPtr->nextPtr = fsRecPtr->nextPtr;}else{
filesystemList = fsRecPtr->nextPtr;}if(fsRecPtr->nextPtr) {
fsRecPtr->nextPtr->prevPtr = fsRecPtr->prevPtr;}/* * Increment the filesystem epoch counter, since existing paths * might conceivably now belong to different filesystems. This * should also ensure that paths which have cached the filesystem * which is about to be deleted do not reference that filesystem * (which would of course lead to memory exceptions). */
theFilesystemEpoch++;ckfree((char*)fsRecPtr);
retVal = TCL_OK;}else{
fsRecPtr = fsRecPtr->nextPtr;}}Tcl_MutexUnlock(&filesystemMutex);return retVal;}/* *---------------------------------------------------------------------- * * Tcl_FSMatchInDirectory -- * * This routine is used by the globbing code to search a directory for * all files which match a given pattern. The appropriate function for * the filesystem to which pathPtr belongs will be called. If pathPtr * does not belong to any filesystem and if it is NULL or the empty * string, then we assume the pattern is to be matched in the current * working directory. To avoid have the Tcl_FSMatchInDirectoryProc for * each filesystem from having to deal with this issue, we create a * pathPtr on the fly (equal to the cwd), and then remove it from the * results returned. This makes filesystems easy to write, since they can * assume the pathPtr passed to them is an ordinary path. In fact this * means we could remove such special case handling from Tcl's native * filesystems. * * If 'pattern' is NULL, then pathPtr is assumed to be a fully specified * path of a single file/directory which must be checked for existence * and correct type. * * Results: * * The return value is a standard Tcl result indicating whether an error * occurred in globbing. Error messages are placed in interp, but good * results are placed in the resultPtr given. * * 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: * The interpreter may have an error message inserted into it. * *---------------------------------------------------------------------- */intTcl_FSMatchInDirectory(
Tcl_Interp *interp,/* Interpreter to receive error messages, but * may be NULL. */
Tcl_Obj *resultPtr,/* List object to receive results. */
Tcl_Obj *pathPtr,/* Contains path to directory to search. */const char*pattern,/* Pattern to match against. */
Tcl_GlobTypeData *types)/* Object containing list of acceptable types. * May be NULL. In particular the directory * flag is very important. */{const Tcl_Filesystem *fsPtr;
Tcl_Obj *cwd, *tmpResultPtr, **elemsPtr;int resLength, i, ret = -1;if(types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) {/* * We don't currently allow querying of mounts by external code (a * valuable future step), so since we're the only function that * actually knows about mounts, this means we're being called * recursively by ourself. Return no matches. */return TCL_OK;}if(pathPtr != NULL) {
fsPtr =Tcl_FSGetFileSystemForPath(pathPtr);}else{
fsPtr = NULL;}/* * Check if we've successfully mapped the path to a filesystem within * which to search. */if(fsPtr != NULL) {if(fsPtr->matchInDirectoryProc == NULL) {Tcl_SetErrno(ENOENT);return-1;}
ret = (*fsPtr->matchInDirectoryProc)(interp, resultPtr, pathPtr,
pattern, types);if(ret == TCL_OK && pattern != NULL) {FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types);}return ret;}/* * If the path isn't empty, we have no idea how to match files in a * directory which belongs to no known filesystem */if(pathPtr != NULL &&TclGetString(pathPtr)[0] !='\0') {Tcl_SetErrno(ENOENT);return-1;}/* * We have an empty or NULL path. This is defined to mean we must search * for files within the current 'cwd'. We therefore use that, but then * since the proc we call will return results which include the cwd we * must then trim it off the front of each path in the result. We choose * to deal with this here (in the generic code), since if we don't, every * single filesystem's implementation of Tcl_FSMatchInDirectory will have * to deal with it for us. */
cwd =Tcl_FSGetCwd(NULL);if(cwd == NULL) {if(interp != NULL) {Tcl_SetResult(interp,"glob couldn't determine ""the current working directory", TCL_STATIC);}return TCL_ERROR;}
fsPtr =Tcl_FSGetFileSystemForPath(cwd);if(fsPtr != NULL && fsPtr->matchInDirectoryProc != NULL) {TclNewObj(tmpResultPtr);Tcl_IncrRefCount(tmpResultPtr);
ret = (*fsPtr->matchInDirectoryProc)(interp, tmpResultPtr, cwd,
pattern, types);if(ret == TCL_OK) {FsAddMountsToGlobResult(tmpResultPtr, cwd, pattern, types);/* * Note that we know resultPtr and tmpResultPtr are distinct. */
ret =Tcl_ListObjGetElements(interp, tmpResultPtr,&resLength, &elemsPtr);for(i=0; ret==TCL_OK && i<resLength ; i++) {
ret =Tcl_ListObjAppendElement(interp, resultPtr,TclFSMakePathRelative(interp, elemsPtr[i], cwd));}}TclDecrRefCount(tmpResultPtr);}Tcl_DecrRefCount(cwd);return ret;}/* *---------------------------------------------------------------------- * * FsAddMountsToGlobResult -- * * This routine is used by the globbing code to take the results of a * directory listing and add any mounted paths to that listing. This is * required so that simple things like 'glob *' merge mounts and listings * correctly. * * Results: * None. * * Side effects: * Modifies the resultPtr. * *---------------------------------------------------------------------- */static voidFsAddMountsToGlobResult(
Tcl_Obj *resultPtr,/* The current list of matching paths; must * not be shared! */
Tcl_Obj *pathPtr,/* The directory in question */const char*pattern,/* Pattern to match against. */
Tcl_GlobTypeData *types)/* Object containing list of acceptable types. * May be NULL. In particular the directory * flag is very important. */{int mLength, gLength, i;int dir = (types == NULL || (types->type & TCL_GLOB_TYPE_DIR));
Tcl_Obj *mounts =FsListMounts(pathPtr, pattern);if(mounts == NULL) {return;}if(Tcl_ListObjLength(NULL, mounts, &mLength) != TCL_OK || mLength ==0) {goto endOfMounts;}if(Tcl_ListObjLength(NULL, resultPtr, &gLength) != TCL_OK) {goto endOfMounts;}for(i=0; i<mLength ; i++) {
Tcl_Obj *mElt;int j;int found =0;Tcl_ListObjIndex(NULL, mounts, i, &mElt);for(j=0; j<gLength ; j++) {
Tcl_Obj *gElt;Tcl_ListObjIndex(NULL, resultPtr, j, &gElt);if(Tcl_FSEqualPaths(mElt, gElt)) {
found =1;if(!dir) {/* * We don't want to list this. */Tcl_ListObjReplace(NULL, resultPtr, j,1,0, NULL);
gLength--;}break;/* Break out of for loop */}}if(!found && dir) {
Tcl_Obj *norm;int len, mlen;/* * We know mElt is absolute normalized and lies inside pathPtr, so * now we must add to the result the right representation of mElt, * i.e. the representation which is relative to pathPtr. */
norm =Tcl_FSGetNormalizedPath(NULL, pathPtr);if(norm != NULL) {const char*path, *mount;
mount =Tcl_GetStringFromObj(mElt, &mlen);
path =Tcl_GetStringFromObj(norm, &len);if(path[len-1] =='/') {/* * Deal with the root of the volume. */
len--;}
len++;/* account for '/' in the mElt [Bug 1602539] */
mElt =TclNewFSPathObj(pathPtr, mount + len, mlen - len);Tcl_ListObjAppendElement(NULL, resultPtr, mElt);}/* * No need to increment gLength, since we don't want to compare * mounts against mounts. */}}
endOfMounts:Tcl_DecrRefCount(mounts);}/* *---------------------------------------------------------------------- * * Tcl_FSMountsChanged -- * * Notify the filesystem that the available mounted filesystems (or * within any one filesystem type, the number or location of mount * points) have changed. * * Results: * None. * * Side effects: * The global filesystem variable 'theFilesystemEpoch' is incremented. * The effect of this is to make all cached path representations invalid. * Clearly it should only therefore be called when it is really required! * There are a few circumstances when it should be called: * * (1) when a new filesystem is registered or unregistered. Strictly * speaking this is only necessary if the new filesystem accepts file * paths as is (normally the filesystem itself is really a shell which * hasn't yet had any mount points established and so its * 'pathInFilesystem' proc will always fail). However, for safety, Tcl * always calls this for you in these circumstances. * * (2) when additional mount points are established inside any existing * filesystem (except the native fs) * * (3) when any filesystem (except the native fs) changes the list of * available volumes. * * (4) when the mapping from a string representation of a file to a full, * normalized path changes. For example, if 'env(HOME)' is modified, then * any path containing '~' will map to a different filesystem location. * Therefore all such paths need to have their internal representation * invalidated. * * Tcl has no control over (2) and (3), so any registered filesystem must * make sure it calls this function when those situations occur. * * (Note: the reason for the exception in 2,3 for the native filesystem * is that the native filesystem by default claims all unknown files even * if it really doesn't understand them or if they don't exist). * *---------------------------------------------------------------------- */voidTcl_FSMountsChanged(
Tcl_Filesystem *fsPtr){/* * We currently don't do anything with this parameter. We could in the * future only invalidate files for this filesystem or otherwise take more * advanced action. */(void)fsPtr;/* * Increment the filesystem epoch counter, since existing paths might now * belong to different filesystems. */Tcl_MutexLock(&filesystemMutex);
theFilesystemEpoch++;Tcl_MutexUnlock(&filesystemMutex);}/* *---------------------------------------------------------------------- * * Tcl_FSData -- * * Retrieve the clientData field for the filesystem given, or NULL if * that filesystem is not registered. * * Results: * A clientData value, or NULL. Note that if the filesystem was * registered with a NULL clientData field, this function will return * that NULL value. * * Side effects: * None. * *---------------------------------------------------------------------- */
ClientData
Tcl_FSData(
Tcl_Filesystem *fsPtr)/* The filesystem record to query. */{
ClientData retVal = NULL;
FilesystemRecord *fsRecPtr =FsGetFirstFilesystem();/* * Traverse the list of filesystems look for a particular one. If found, * return that filesystem's clientData (originally provided when calling * Tcl_FSRegister). */while((retVal == NULL) && (fsRecPtr != NULL)) {if(fsRecPtr->fsPtr == fsPtr) {
retVal = fsRecPtr->clientData;}
fsRecPtr = fsRecPtr->nextPtr;}return retVal;}/* *--------------------------------------------------------------------------- * * TclFSNormalizeToUniquePath -- * * Takes a path specification containing no ../, ./ sequences, and * converts it into a unique path for the given platform. On Unix, this * means the path must be free of symbolic links/aliases, and on Windows * it means we want the long form, with that long form's case-dependence * (which gives us a unique, case-dependent path). * * Results: * The 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 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). * *--------------------------------------------------------------------------- */intTclFSNormalizeToUniquePath(
Tcl_Interp *interp,/* Used for error messages. */
Tcl_Obj *pathPtr,/* The path to normalize in place */int startAt)/* Start at this char-offset */{
FilesystemRecord *fsRecPtr, *firstFsRecPtr;/* * Call each of the "normalise path" functions in succession. This is a * special case, in which if we have a native filesystem handler, we call * it first. This is because the root of Tcl's filesystem is always a * native filesystem (i.e. '/' on unix is native). */
firstFsRecPtr =FsGetFirstFilesystem();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;}
fsRecPtr = firstFsRecPtr;while(fsRecPtr != NULL) {/* * Skip the native system next time through. */if(fsRecPtr->fsPtr != &tclNativeFilesystem) {
Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;if(proc != NULL) {
startAt = (*proc)(interp, pathPtr, startAt);}/* * We could add an efficiency check like this: * if (retVal == length-of(pathPtr)) {break;} * but there's not much benefit. */}
fsRecPtr = fsRecPtr->nextPtr;}Disclaim();return startAt;}/* *--------------------------------------------------------------------------- * * TclGetOpenMode -- * * 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: * Same as TclGetOpenModeEx(). * * Side effects: * Same as TclGetOpenModeEx(). * *--------------------------------------------------------------------------- */intTclGetOpenMode(
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;returnTclGetOpenModeEx(interp, modeString, seekFlagPtr, &binary);}/* *--------------------------------------------------------------------------- * * TclGetOpenModeEx -- * * 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: * 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 the integer referenced by seekFlagPtr to 1 to tell the caller to * seek to EOF after opening the file, or to 0 otherwise. Sets the * integer referenced by binaryPtr to 1 to tell the caller to seek to * configure the channel for binary data, or to 0 otherwise. * * Special note: * This code is based on a prototype implementation contributed by Mark * Diekhans. * *--------------------------------------------------------------------------- */intTclGetOpenModeEx(
Tcl_Interp *interp,/* Interpreter to use for error reporting - * may be NULL. */const char*modeString,/* Mode string, e.g. "r+" or "RDONLY CREAT" */int*seekFlagPtr,/* Set this to 1 if the caller should seek to * EOF during the opening of the file. */int*binaryPtr)/* Set this to 1 if the caller should * configure the opened channel for binary * operations */{int mode, modeArgc, c, i, gotRW;const char**modeArgv, *flag;#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)/* * Check for the simpler fopen-like access modes (e.g. "r"). They are * distinguished from the POSIX access modes by the presence of a * lower-case first letter. */*seekFlagPtr =0;*binaryPtr =0;
mode =0;/* * Guard against international characters before using byte oriented * routines. */if(!(modeString[0] &0x80)&&islower(UCHAR(modeString[0]))) {/* INTL: ISO only. */switch(modeString[0]) {case'r':
mode = O_RDONLY;break;case'w':
mode = O_WRONLY|O_CREAT|O_TRUNC;break;case'a':/* * Added O_APPEND for proper automatic seek-to-end-on-write by the * OS. [Bug 680143] */
mode = O_WRONLY|O_CREAT|O_APPEND;*seekFlagPtr =1;break;default:goto error;}
i=1;while(i<3&& modeString[i]) {if(modeString[i] == modeString[i-1]) {goto error;}switch(modeString[i++]) {case'+':/* * Must remove the O_APPEND flag so that the seek command * works. [Bug 1773127] */
mode &= ~(O_RDONLY|O_WRONLY|O_APPEND);
mode |= O_RDWR;break;case'b':*binaryPtr =1;break;default:goto error;}}if(modeString[i] !=0) {goto error;}return mode;
error:*seekFlagPtr =0;*binaryPtr =0;if(interp != NULL) {Tcl_AppendResult(interp,"illegal access mode\"", modeString,"\"", NULL);}return-1;}/* * The access modes are specified using a list of POSIX modes such as * O_CREAT. * * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when a NULL * interpreter is passed in. */if(Tcl_SplitList(interp, modeString, &modeArgc, &modeArgv) != TCL_OK) {if(interp != NULL) {Tcl_AddErrorInfo(interp,"\nwhile processing open access modes\"");Tcl_AddErrorInfo(interp, modeString);Tcl_AddErrorInfo(interp,"\"");}return-1;}
gotRW =0;for(i =0; i < modeArgc; i++) {
flag = modeArgv[i];
c = flag[0];if((c =='R') && (strcmp(flag,"RDONLY") ==0)) {
mode = (mode & ~RW_MODES) | O_RDONLY;
gotRW =1;}else if((c =='W') && (strcmp(flag,"WRONLY") ==0)) {
mode = (mode & ~RW_MODES) | O_WRONLY;
gotRW =1;}else if((c =='R') && (strcmp(flag,"RDWR") ==0)) {
mode = (mode & ~RW_MODES) | O_RDWR;
gotRW =1;}else if((c =='A') && (strcmp(flag,"APPEND") ==0)) {
mode |= O_APPEND;*seekFlagPtr =1;}else if((c =='C') && (strcmp(flag,"CREAT") ==0)) {
mode |= O_CREAT;}else if((c =='E') && (strcmp(flag,"EXCL") ==0)) {
mode |= O_EXCL;}else if((c =='N') && (strcmp(flag,"NOCTTY") ==0)) {#ifdef O_NOCTTY
mode |= O_NOCTTY;#elseif(interp != NULL) {Tcl_AppendResult(interp,"access mode\"", flag,"\"not supported by this system", NULL);}ckfree((char*) modeArgv);return-1;#endif}else if((c =='N') && (strcmp(flag,"NONBLOCK") ==0)) {#ifdef O_NONBLOCK
mode |= O_NONBLOCK;#elseif(interp != NULL) {Tcl_AppendResult(interp,"access mode\"", flag,"\"not supported by this system", NULL);}ckfree((char*) modeArgv);return-1;#endif}else if((c =='T') && (strcmp(flag,"TRUNC") ==0)) {
mode |= O_TRUNC;}else if((c =='B') && (strcmp(flag,"BINARY") ==0)) {*binaryPtr =1;}else{if(interp != NULL) {Tcl_AppendResult(interp,"invalid access mode\"", flag,"\": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, ""CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC", NULL);}ckfree((char*) modeArgv);return-1;}}ckfree((char*) modeArgv);if(!gotRW) {if(interp != NULL) {Tcl_AppendResult(interp,"access mode must include either"" RDONLY, WRONLY, or RDWR", NULL);}return-1;}return mode;}/* * Tcl_FSEvalFile is Tcl_FSEvalFileEx without encoding argument. */intTcl_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. */{returnTcl_FSEvalFileEx(interp, pathPtr, NULL);}/* *---------------------------------------------------------------------- * * 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: * 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). * *---------------------------------------------------------------------- */intTcl_FSEvalFileEx(
Tcl_Interp *interp,/* Interpreter in which to process file. */
Tcl_Obj *pathPtr,/* Path of file to process. Tilde-substitution * will be performed on this name. */const char*encodingName)/* If non-NULL, then use this encoding for the * file. NULL means use the system encoding. */{int length, result = TCL_ERROR;
Tcl_StatBuf statBuf;
Tcl_Obj *oldScriptFile;
Interp *iPtr;char*string;
Tcl_Channel chan;
Tcl_Obj *objPtr;if(Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {return result;}if(Tcl_FSStat(pathPtr, &statBuf) == -1) {Tcl_SetErrno(errno);Tcl_AppendResult(interp,"couldn't read file\"",Tcl_GetString(pathPtr),"\": ",Tcl_PosixError(interp), NULL);return result;}
chan =Tcl_FSOpenFileChannel(interp, pathPtr,"r",0644);if(chan == (Tcl_Channel) NULL) {Tcl_ResetResult(interp);Tcl_AppendResult(interp,"couldn't read file\"",Tcl_GetString(pathPtr),"\": ",Tcl_PosixError(interp), NULL);return result;}/* * The eofchar is \32 (^Z). This is the usual on Windows, but we effect * this cross-platform to allow for scripted documents. [Bug: 2040] */Tcl_SetChannelOption(interp, chan,"-eofchar","\32");/* * If the encoding is specified, set it for the channel. Else don't touch * it (and use the system encoding) Report error on unknown encoding. */if(encodingName != NULL) {if(Tcl_SetChannelOption(interp, chan,"-encoding", encodingName)!= TCL_OK) {Tcl_Close(interp,chan);return result;}}
objPtr =Tcl_NewObj();Tcl_IncrRefCount(objPtr);/* Try to read first character of stream, so we can * check for utf-8 BOM to be handled especially. */if(Tcl_ReadChars(chan, objPtr,1,0) <0) {Tcl_Close(interp, chan);Tcl_AppendResult(interp,"couldn't read file\"",Tcl_GetString(pathPtr),"\": ",Tcl_PosixError(interp), NULL);goto end;}
string =Tcl_GetString(objPtr);/* * If first character is not a BOM, append the remaining characters, * otherwise replace them [Bug 3466099]. */if(Tcl_ReadChars(chan, objPtr, -1,memcmp(string,"\xef\xbb\xbf",3)) <0) {Tcl_Close(interp, chan);Tcl_AppendResult(interp,"couldn't read file\"",Tcl_GetString(pathPtr),"\": ",Tcl_PosixError(interp), NULL);goto end;}if(Tcl_Close(interp, chan) != TCL_OK) {goto end;}
iPtr = (Interp *) interp;
oldScriptFile = iPtr->scriptFile;
iPtr->scriptFile = pathPtr;Tcl_IncrRefCount(iPtr->scriptFile);
string =Tcl_GetStringFromObj(objPtr, &length);/* TIP #280 Force the evaluator to open a frame for a sourced * file. */
iPtr->evalFlags |= TCL_EVAL_FILE;
result =Tcl_EvalEx(interp, string, length,0);/* * Now we have to be careful; the script may have changed the * iPtr->scriptFile value, so we must reset it without assuming it still * points to 'pathPtr'. */if(iPtr->scriptFile != NULL) {Tcl_DecrRefCount(iPtr->scriptFile);}
iPtr->scriptFile = oldScriptFile;if(result == TCL_RETURN) {
result =TclUpdateReturnInfo(iPtr);}else if(result == TCL_ERROR) {/* * Record information telling where the error occurred. */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 ? "...":""), interp->errorLine));}
end:Tcl_DecrRefCount(objPtr);return result;}/* *---------------------------------------------------------------------- * * Tcl_GetErrno -- * * Gets the current value of the Tcl error code variable. This is * currently the global variable "errno" but could in the future change * to something else. * * Results: * The value of the Tcl error code variable. * * Side effects: * None. Note that the value of the Tcl error code variable is UNDEFINED * if a call to Tcl_SetErrno did not precede this call. * *---------------------------------------------------------------------- */intTcl_GetErrno(void){return errno;}/* *---------------------------------------------------------------------- * * Tcl_SetErrno -- * * Sets the Tcl error code variable to the supplied value. * * Results: * None. * * Side effects: * Modifies the value of the Tcl error code variable. * *---------------------------------------------------------------------- */voidTcl_SetErrno(int err)/* The new value. */{
errno = err;}/* *---------------------------------------------------------------------- * * Tcl_PosixError -- * * This function is typically called after UNIX kernel calls return * errors. It stores machine-readable information about the error in * errorCode field of interp and returns an information string for the * caller's use. * * Results: * The return value is a human-readable string describing the error. * * Side effects: * The errorCode field of the interp is set. * *---------------------------------------------------------------------- */const char*Tcl_PosixError(
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, NULL);}return msg;}/* *---------------------------------------------------------------------- * * Tcl_FSStat -- * * This function replaces the library version of stat and lsat. * * The appropriate function for the filesystem to which pathPtr belongs * will be called. * * Results: * See stat documentation. * * Side effects: * See stat documentation. * *---------------------------------------------------------------------- */intTcl_FSStat(
Tcl_Obj *pathPtr,/* Path of file to stat (in current CP). */
Tcl_StatBuf *buf)/* Filled with results of stat call. */{const Tcl_Filesystem *fsPtr;#ifdef USE_OBSOLETE_FS_HOOKSstruct stat oldStyleStatBuffer;int retVal = -1;/* * Call each of the "stat" function in succession. A non-return value of * -1 indicates the particular function has succeeded. */Tcl_MutexLock(&obsoleteFsHookMutex);if(statProcList != NULL) {
StatProc *statProcPtr;char*path;
Tcl_Obj *transPtr =Tcl_FSGetTranslatedPath(NULL, pathPtr);if(transPtr == NULL) {
path = NULL;}else{
path =Tcl_GetString(transPtr);}
statProcPtr = statProcList;while((retVal == -1) && (statProcPtr != NULL)) {
retVal = (*statProcPtr->proc)(path, &oldStyleStatBuffer);
statProcPtr = statProcPtr->nextPtr;}if(transPtr != NULL) {Tcl_DecrRefCount(transPtr);}}Tcl_MutexUnlock(&obsoleteFsHookMutex);if(retVal != -1) {/* * Note that EOVERFLOW is not a problem here, and these assignments * should all be widening (if not identity.) */
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);#endifreturn 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;}/* *---------------------------------------------------------------------- * * Tcl_FSLstat -- * * This function replaces the library version of lstat. The appropriate * function for the filesystem to which pathPtr belongs will be called. * If no 'lstat' function is listed, but a 'stat' function is, then Tcl * will fall back on the stat function. * * Results: * See lstat documentation. * * Side effects: * See lstat documentation. * *---------------------------------------------------------------------- */intTcl_FSLstat(
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) {
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);return-1;}/* *---------------------------------------------------------------------- * * Tcl_FSAccess -- * * 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. * * Side effects: * See access documentation. * *---------------------------------------------------------------------- */intTcl_FSAccess(
Tcl_Obj *pathPtr,/* Path of file to access (in current CP). */int mode)/* Permission setting. */{const Tcl_Filesystem *fsPtr;#ifdef USE_OBSOLETE_FS_HOOKSint 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(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;}/* *---------------------------------------------------------------------- * * Tcl_FSOpenFileChannel -- * * The appropriate function for the filesystem to which pathPtr belongs * will be called. * * Results: * The new channel or NULL, if the named file could not be opened. * * Side effects: * May open the channel and may cause creation of a file on the file * system. * *---------------------------------------------------------------------- */
Tcl_Channel
Tcl_FSOpenFileChannel(
Tcl_Interp *interp,/* Interpreter for error reporting; can be * NULL. */
Tcl_Obj *pathPtr,/* Name of file to open. */const char*modeString,/* A list of POSIX open modes or a string such * as "rw". */int permissions)/* If the open involves creating a file, with * what modes to create it? */{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 NULL;}
fsPtr =Tcl_FSGetFileSystemForPath(pathPtr);if(fsPtr != NULL) {
Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc;if(proc != NULL) {int mode, seekFlag, binary;/* * Parse the mode, picking up whether we want to seek to start * with and/or set the channel automatically into binary mode. */
mode =TclGetOpenModeEx(interp, modeString, &seekFlag, &binary);if(mode == -1) {return NULL;}/* * Do the actual open() call. */
retVal = (*proc)(interp, pathPtr, mode, permissions);if(retVal == NULL) {return NULL;}/* * Apply appropriate flags parsed out above. */if(seekFlag &&Tcl_Seek(retVal, (Tcl_WideInt)0,
SEEK_END) < (Tcl_WideInt)0) {if(interp != NULL) {Tcl_AppendResult(interp,"could not seek to end ""of file while opening\"",Tcl_GetString(pathPtr),"\": ",Tcl_PosixError(interp), NULL);}Tcl_Close(NULL, retVal);return NULL;}if(binary) {Tcl_SetChannelOption(interp, retVal,"-translation","binary");}return retVal;}}/* * File doesn't belong to any filesystem that can open it. */Tcl_SetErrno(ENOENT);if(interp != NULL) {Tcl_AppendResult(interp,"couldn't open\"",Tcl_GetString(pathPtr),"\": ",Tcl_PosixError(interp), NULL);}return NULL;}/* *---------------------------------------------------------------------- * * Tcl_FSUtime -- * * 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. * * Side effects: * See utime documentation. * *---------------------------------------------------------------------- */intTcl_FSUtime(
Tcl_Obj *pathPtr,/* File to change access/modification times */struct utimbuf *tval)/* Structure containing access/modification * times to use. Should not be modified. */{const Tcl_Filesystem *fsPtr =Tcl_FSGetFileSystemForPath(pathPtr);if(fsPtr != NULL) {
Tcl_FSUtimeProc *proc = fsPtr->utimeProc;if(proc != NULL) {return(*proc)(pathPtr, tval);}}return-1;}/* *---------------------------------------------------------------------- * * NativeFileAttrStrings -- * * This function implements the platform dependent 'file attributes' * subcommand, for the native filesystem, for listing the set of possible * attribute strings. This function is part of Tcl's native filesystem * support, and is placed here because it is shared by Unix and Windows * code. * * Results: * An array of strings * * Side effects: * None. * *---------------------------------------------------------------------- */static const char**NativeFileAttrStrings(
Tcl_Obj *pathPtr,
Tcl_Obj **objPtrRef){return tclpFileAttrStrings;}/* *---------------------------------------------------------------------- * * NativeFileAttrsGet -- * * This function implements the platform dependent 'file attributes' * subcommand, for the native filesystem, for 'get' operations. This * function is part of Tcl's native filesystem support, and is placed * here because it is shared by Unix and Windows code. * * Results: * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK * was returned) is likely to have a refCount of zero. Either way we must * either store it somewhere (e.g. the Tcl result), or Incr/Decr its * refCount to ensure it is properly freed. * * Side effects: * None. * *---------------------------------------------------------------------- */static intNativeFileAttrsGet(
Tcl_Interp *interp,/* The interpreter for error reporting. */int index,/* index of the attribute command. */
Tcl_Obj *pathPtr,/* path of file we are operating on. */
Tcl_Obj **objPtrRef)/* for output. */{return(*tclpFileAttrProcs[index].getProc)(interp, index, pathPtr,
objPtrRef);}/* *---------------------------------------------------------------------- * * NativeFileAttrsSet -- * * This function implements the platform dependent 'file attributes' * subcommand, for the native filesystem, for 'set' operations. This * function is part of Tcl's native filesystem support, and is placed * here because it is shared by Unix and Windows code. * * Results: * Standard Tcl return code. * * Side effects: * None. * *---------------------------------------------------------------------- */static intNativeFileAttrsSet(
Tcl_Interp *interp,/* The interpreter for error reporting. */int index,/* index of the attribute command. */
Tcl_Obj *pathPtr,/* path of file we are operating on. */
Tcl_Obj *objPtr)/* set to this value. */{return(*tclpFileAttrProcs[index].setProc)(interp, index, pathPtr, objPtr);}/* *---------------------------------------------------------------------- * * Tcl_FSFileAttrStrings -- * * This function implements part of the hookable 'file attributes' * subcommand. The appropriate function for the filesystem to which * pathPtr belongs will be called. * * Results: * The called function may either return an array of strings, or may * instead return NULL and place a Tcl list into the given objPtrRef. * Tcl will take that list and first increment its refCount before using * it. On completion of that use, Tcl will decrement its refCount. Hence * if the list should be disposed of by Tcl when done, it should have a * refCount of zero, and if the list should not be disposed of, the * filesystem should ensure it retains a refCount on the object. * * Side effects: * None. * *---------------------------------------------------------------------- */const char**Tcl_FSFileAttrStrings(
Tcl_Obj *pathPtr,
Tcl_Obj **objPtrRef){const Tcl_Filesystem *fsPtr =Tcl_FSGetFileSystemForPath(pathPtr);if(fsPtr != NULL) {
Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc;if(proc != NULL) {return(*proc)(pathPtr, objPtrRef);}}Tcl_SetErrno(ENOENT);return NULL;}/* *---------------------------------------------------------------------- * * TclFSFileAttrIndex -- * * Helper function for converting an attribute name to an index into the * attribute table. * * Results: * Tcl result code, index written to *indexPtr on result==TCL_OK * * Side effects: * None. * *---------------------------------------------------------------------- */intTclFSFileAttrIndex(
Tcl_Obj *pathPtr,/* File whose attributes are to be indexed * into. */const char*attributeName,/* The attribute being looked for. */int*indexPtr)/* Where to write the found index. */{
Tcl_Obj *listObj = NULL;const char**attrTable;/* * Get the attribute table for the file. */
attrTable =Tcl_FSFileAttrStrings(pathPtr, &listObj);if(listObj != NULL) {Tcl_IncrRefCount(listObj);}if(attrTable != NULL) {/* * It's a constant attribute table, so use T_GIFO. */
Tcl_Obj *tmpObj =Tcl_NewStringObj(attributeName, -1);int result;
result =Tcl_GetIndexFromObj(NULL, tmpObj, attrTable, NULL, TCL_EXACT,
indexPtr);TclDecrRefCount(tmpObj);if(listObj != NULL) {TclDecrRefCount(listObj);}return result;}else if(listObj != NULL) {/* * It's a non-constant attribute list, so do a literal search. */int i, objc;
Tcl_Obj **objv;if(Tcl_ListObjGetElements(NULL, listObj, &objc, &objv) != TCL_OK) {TclDecrRefCount(listObj);return TCL_ERROR;}for(i=0; i<objc ; i++) {if(!strcmp(attributeName,TclGetString(objv[i]))) {TclDecrRefCount(listObj);*indexPtr = i;return TCL_OK;}}TclDecrRefCount(listObj);return TCL_ERROR;}else{return TCL_ERROR;}}/* *---------------------------------------------------------------------- * * Tcl_FSFileAttrsGet -- * * This function implements read access for the hookable 'file * attributes' subcommand. The appropriate function for the filesystem to * which pathPtr belongs will be called. * * Results: * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK * was returned) is likely to have a refCount of zero. Either way we must * either store it somewhere (e.g. the Tcl result), or Incr/Decr its * refCount to ensure it is properly freed. * * Side effects: * None. * *---------------------------------------------------------------------- */intTcl_FSFileAttrsGet(
Tcl_Interp *interp,/* The interpreter for error reporting. */int index,/* index of the attribute command. */
Tcl_Obj *pathPtr,/* filename we are operating on. */
Tcl_Obj **objPtrRef)/* for output. */{const Tcl_Filesystem *fsPtr =Tcl_FSGetFileSystemForPath(pathPtr);if(fsPtr != NULL) {
Tcl_FSFileAttrsGetProc *proc = fsPtr->fileAttrsGetProc;if(proc != NULL) {return(*proc)(interp, index, pathPtr, objPtrRef);}}Tcl_SetErrno(ENOENT);return-1;}/* *---------------------------------------------------------------------- * * Tcl_FSFileAttrsSet -- * * This function implements write access for the hookable 'file * attributes' subcommand. The appropriate function for the filesystem to * which pathPtr belongs will be called. * * Results: * Standard Tcl return code. * * Side effects: * None. * *---------------------------------------------------------------------- */intTcl_FSFileAttrsSet(
Tcl_Interp *interp,/* The interpreter for error reporting. */int index,/* index of the attribute command. */
Tcl_Obj *pathPtr,/* filename we are operating on. */
Tcl_Obj *objPtr)/* Input value. */{const Tcl_Filesystem *fsPtr =Tcl_FSGetFileSystemForPath(pathPtr);if(fsPtr != NULL) {
Tcl_FSFileAttrsSetProc *proc = fsPtr->fileAttrsSetProc;if(proc != NULL) {return(*proc)(interp, index, pathPtr, objPtr);}}Tcl_SetErrno(ENOENT);return-1;}/* *---------------------------------------------------------------------- * * Tcl_FSGetCwd -- * * This function replaces the library version of getcwd(). * * Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains its own * record (in a Tcl_Obj) of the cwd, and an attempt is made to synch this * with the cwd's containing filesystem, if that filesystem provides a * cwdProc (e.g. the native filesystem). * * Note that if Tcl's cwd is not in the native filesystem, then of course * Tcl's cwd and the native cwd are different: extensions should * therefore ensure they only access the cwd through this function to * avoid confusion. * * 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: * The result is a pointer to a Tcl_Obj specifying the current directory, * or NULL if the current directory could not be determined. If NULL is * returned, an error message is left in the interp's result. * * The result already has its refCount incremented for the caller. When * it is no longer needed, that refCount should be decremented. * * Side effects: * Various objects may be freed and allocated. * *---------------------------------------------------------------------- */
Tcl_Obj *Tcl_FSGetCwd(
Tcl_Interp *interp){
ThreadSpecificData *tsdPtr =TCL_TSD_INIT(&fsDataKey);if(TclFSCwdPointerEquals(NULL)) {
FilesystemRecord *fsRecPtr;
Tcl_Obj *retVal = NULL;/* * We've never been called before, try to find a cwd. Call each of the * "Tcl_GetCwd" function in succession. A non-NULL return value * indicates the particular function has succeeded. */
fsRecPtr =FsGetFirstFilesystem();Claim();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{
retVal = (*proc)(interp);}}
fsRecPtr = fsRecPtr->nextPtr;}Disclaim();/* * Now the 'cwd' may NOT be normalized, at least on some platforms. * For the sake of efficiency, we want a completely normalized cwd at * all times. * * Finally, if retVal is NULL, we do not have a cwd, which could be * problematic. */if(retVal != NULL) {
Tcl_Obj *norm =TclFSNormalizeAbsolutePath(interp, retVal);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. */
ClientData cd = (ClientData)Tcl_FSGetNativePath(norm);FsUpdateCwd(norm,TclNativeDupInternalRep(cd));Tcl_DecrRefCount(norm);}Tcl_DecrRefCount(retVal);}}else{/* * We already have a cwd cached, but we want to give the filesystem it * is in a chance to check whether that cwd has changed, or is perhaps * no longer accessible. This allows an error to be thrown if, say, * the permissions on that directory have changed. */const Tcl_Filesystem *fsPtr =Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr);/* * If the filesystem couldn't be found, or if no cwd function exists * for this filesystem, then we simply assume the cached cwd is ok. * If we do call a cwd, we must watch for errors (if the cwd returns * NULL). This ensures that, say, on Unix if the permissions of the * cwd change, 'pwd' does actually throw the correct error in Tcl. * (This is tested for in the test suite on unix). */if(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);}if(retCd == tsdPtr->cwdClientData) {goto cdDidNotChange;}/* * Looks like a new current directory. */
retVal = (*fsPtr->internalToNormalizedProc)(retCd);Tcl_IncrRefCount(retVal);}else{
retVal = (*proc)(interp);}if(retVal != NULL) {
Tcl_Obj *norm =TclFSNormalizeAbsolutePath(interp, retVal);/* * Check whether cwd has changed from the value previously * stored in cwdPathPtr. Really 'norm' shouldn't be NULL, * but we are careful. */if(norm == NULL) {/* Do nothing */if(retCd != NULL) {(*fsPtr->freeInternalRepProc)(retCd);}}else if(norm == tsdPtr->cwdPathPtr) {goto cdEqual;}else{/* * Note that both 'norm' and 'tsdPtr->cwdPathPtr' are * normalized paths. Therefore we can be more * efficient than calling 'Tcl_FSEqualPaths', and in * addition avoid a nasty infinite loop bug when * trying to normalize tsdPtr->cwdPathPtr. */int len1, len2;char*str1, *str2;
str1 =Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1);
str2 =Tcl_GetStringFromObj(norm, &len2);if((len1 == len2) && (strcmp(str1, str2) ==0)) {/* * If the paths were equal, we can be more * efficient and retain the old path object which * will probably already be shared. In this case * we can simply free the normalized path we just * calculated. */
cdEqual:Tcl_DecrRefCount(norm);if(retCd != NULL) {(*fsPtr->freeInternalRepProc)(retCd);}}else{FsUpdateCwd(norm, retCd);Tcl_DecrRefCount(norm);}}Tcl_DecrRefCount(retVal);}else{/* * The 'cwd' function returned an error; reset the cwd. */FsUpdateCwd(NULL, NULL);}}}}
cdDidNotChange:if(tsdPtr->cwdPathPtr != NULL) {Tcl_IncrRefCount(tsdPtr->cwdPathPtr);}return tsdPtr->cwdPathPtr;}/* *---------------------------------------------------------------------- * * Tcl_FSChdir -- * * This function replaces the library version of chdir(). * * The path is normalized and then passed to the filesystem which claims * it. * * Results: * See chdir() documentation. If successful, we keep a record of the * successful path in cwdPathPtr for subsequent calls to getcwd. * * Side effects: * See chdir() documentation. The global cwdPathPtr may change value. * *---------------------------------------------------------------------- */intTcl_FSChdir(
Tcl_Obj *pathPtr){const Tcl_Filesystem *fsPtr;int retVal = -1;if(Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) {Tcl_SetErrno(ENOENT);return retVal;}
fsPtr =Tcl_FSGetFileSystemForPath(pathPtr);if(fsPtr != NULL) {
Tcl_FSChdirProc *proc = fsPtr->chdirProc;if(proc != NULL) {/* * If this fails, an appropriate errno will have been stored using * 'Tcl_SetErrno()'. */
retVal = (*proc)(pathPtr);}else{/* * Fallback on stat-based implementation. */
Tcl_StatBuf buf;/* * If the file can be stat'ed and is a directory and is readable, * then we can chdir. If any of these actions fail, then * 'Tcl_SetErrno()' should automatically have been called to set * an appropriate error code */if((Tcl_FSStat(pathPtr, &buf) ==0) && (S_ISDIR(buf.st_mode))&& (Tcl_FSAccess(pathPtr, R_OK) ==0)) {/* * We allow the chdir. */
retVal =0;}}}else{Tcl_SetErrno(ENOENT);}/* * The cwd changed, or an error was thrown. If an error was thrown, we can * just continue (and that will report the error to the user). If there * was no error we must assume that the cwd was actually changed to the * normalized value we calculated above, and we must therefore cache that * information. *//* * If the filesystem in question has a getCwdProc, then the correct logic * which performs the part below is already part of the Tcl_FSGetCwd() * call, so no need to replicate it again. This will have a side effect * though. The private authoritative representation of the current working * directory stored in cwdPathPtr in static memory will be out-of-sync * with the real OS-maintained value. The first call to Tcl_FSGetCwd will * however recalculate the private copy to match the OS-value so * everything will work right. * * However, if there is no getCwdProc, then we _must_ update our private * storage of the cwd, since this is the only opportunity to do that! * * Note: We currently call this block of code irrespective of whether * there was a getCwdProc or not, but the code should all in principle * work if we only call this block if fsPtr->getCwdProc == NULL. */if(retVal ==0) {/* * Note that this normalized path may be different to what we found * above (or at least a different object), if the filesystem epoch * changed recently. This can actually happen with scripted documents * very easily. Therefore we ask for the normalized path again (the * correct value will have been cached as a result of the * Tcl_FSGetFileSystemForPath call above anyway). */
Tcl_Obj *normDirName =Tcl_FSGetNormalizedPath(NULL, pathPtr);if(normDirName == NULL) {/* Not really true, but what else to do? */Tcl_SetErrno(ENOENT);return-1;}if(fsPtr == &tclNativeFilesystem) {/* * For the native filesystem, we keep a cache of the native * representation of the cwd. But, we want to do that for the * exact format that is returned by 'getcwd' (so that we can later * compare the two representations for equality), which might not * be exactly the same char-string as the native representation of * the fully normalized path (e.g. on Windows there's a * forward-slash vs backslash difference). Hence we ask for this * again here. On Unix it might actually be true that we always * have the correct form in the native rep in which case we could * simply use: * cd = Tcl_FSGetNativePath(pathPtr); * instead. This should be examined by someone on Unix. */
ThreadSpecificData *tsdPtr =TCL_TSD_INIT(&fsDataKey);
ClientData cd;
ClientData oldcd = tsdPtr->cwdClientData;/* * Assumption we are using a filesystem version 2. */
TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)fsPtr->getCwdProc;
cd = (*proc2)(oldcd);if(cd != oldcd) {FsUpdateCwd(normDirName, cd);}}else{FsUpdateCwd(normDirName, NULL);}}return retVal;}/* *---------------------------------------------------------------------- * * Tcl_FSLoadFile -- * * Dynamically loads a binary code file into memory and returns the * addresses of two functions within that file, if they are defined. The * appropriate function for the filesystem to which pathPtr belongs will * be called. * * Note that the native filesystem doesn't actually assume 'pathPtr' is a * path. Rather it assumes pathPtr is either a path or just the name * (tail) of a file which can be found somewhere in the environment's * loadable path. This behaviour is not very compatible with virtual * filesystems (and has other problems documented in the load man-page), * so it is advised that full paths are always used. * * Results: * A standard Tcl completion code. If an error occurs, an error message * is left in the interp's result. * * Side effects: * New code suddenly appears in memory. This may later be unloaded by * passing the clientData to the unloadProc. * *---------------------------------------------------------------------- */intTcl_FSLoadFile(
Tcl_Interp *interp,/* Used for error reporting. */
Tcl_Obj *pathPtr,/* Name of the file containing the desired * code. */const char*sym1,const char*sym2,/* Names of two functions to look up in the * file's symbol table. */
Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr,/* 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_FSUnloadFileProc **unloadProcPtr)/* Filled with address of Tcl_FSUnloadFileProc * function which should be used for this * file. */{const char*symbols[2];
Tcl_PackageInitProc **procPtrs[2];
ClientData clientData;int res;/* * Initialize the arrays. */
symbols[0] = sym1;
symbols[1] = sym2;
procPtrs[0] = proc1Ptr;
procPtrs[1] = proc2Ptr;/* * Perform the load. */
res =TclLoadFile(interp, pathPtr,2, symbols, procPtrs, handlePtr,&clientData, unloadProcPtr);/* * 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;}/* *---------------------------------------------------------------------- * * TclLoadFile -- * * Dynamically loads a binary code file into memory and returns the * addresses of a number of given functions within that file, if they are * defined. The appropriate function for the filesystem to which pathPtr * belongs will be called. * * Note that the native filesystem doesn't actually assume 'pathPtr' is a * path. Rather it assumes pathPtr is either a path or just the name * (tail) of a file which can be found somewhere in the environment's * loadable path. This behaviour is not very compatible with virtual * filesystems (and has other problems documented in the load man-page), * so it is advised that full paths are always used. * * This function is currently private to Tcl. It may be exported in the * future and its interface fixed (but we should clean up the * loadHandle/clientData confusion at that time -- see the above comments * in Tcl_FSLoadFile for details). For a public function, see * Tcl_FSLoadFile. * * Results: * A standard Tcl completion code. If an error occurs, an error message * is left in the interp's result. * * Side effects: * New code suddenly appears in memory. This may later be unloaded by * passing the clientData to the unloadProc. * *---------------------------------------------------------------------- */typedefint(Tcl_FSLoadFileProc2) (Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr,int flags);intTclLoadFile(
Tcl_Interp *interp,/* Used for error reporting. */
Tcl_Obj *pathPtr,/* Name of the file containing the desired * code. */int symc,/* Number of symbols/procPtrs in the next two * arrays. */const char*symbols[],/* Names of functions to look up in the file's * 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. */{const Tcl_Filesystem *fsPtr =Tcl_FSGetFileSystemForPath(pathPtr);
Tcl_FSLoadFileProc *proc;
Tcl_Filesystem *copyFsPtr;
Tcl_Obj *copyToPtr;
Tcl_LoadHandle newLoadHandle = NULL;
ClientData newClientData = NULL;
Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL;
FsDivertLoad *tvdlPtr;int retVal;if(fsPtr == NULL) {Tcl_SetErrno(ENOENT);return TCL_ERROR;}
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;}/* * Copy this across, since both are equal for the native fs. */*clientDataPtr = (ClientData)*handlePtr;Tcl_ResetResult(interp);goto resolveSymbols;}if(Tcl_GetErrno() != EXDEV) {return retVal;}}/* * The filesystem doesn't support 'load', so we fall back on the following * technique: * * First check if it is readable -- and exists! */if(Tcl_FSAccess(pathPtr, R_OK) !=0) {Tcl_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 code from memory, so ask for a buffer of * the appropriate size, read the file into it and load the code from the * buffer: */{int ret, size;void*buffer;
Tcl_StatBuf statBuf;
Tcl_Channel data;
ret =Tcl_FSStat(pathPtr, &statBuf);if(ret <0) {goto mustCopyToTempAnyway;}
size = (int) statBuf.st_size;/* * Tcl_Read takes an int: check that file size isn't wide. */if(size != (Tcl_WideInt) statBuf.st_size) {goto mustCopyToTempAnyway;}
data =Tcl_FSOpenFileChannel(interp, pathPtr,"rb",0666);if(!data) {goto mustCopyToTempAnyway;}
buffer =TclpLoadMemoryGetBuffer(interp, size);if(!buffer) {Tcl_Close(interp, data);goto mustCopyToTempAnyway;}
ret =Tcl_Read(data, buffer, size);Tcl_Close(interp, data);
ret =TclpLoadMemory(interp, buffer, size, ret, handlePtr,
unloadProcPtr);if(ret == TCL_OK && *handlePtr != NULL) {*clientDataPtr = (ClientData) *handlePtr;goto resolveSymbols;}}
mustCopyToTempAnyway:Tcl_ResetResult(interp);#endif/* * Get a temporary filename to use, first to copy the file into, and then * to load. */
copyToPtr =TclpTempFileName();if(copyToPtr == NULL) {Tcl_AppendResult(interp,"couldn't create temporary file: ",Tcl_PosixError(interp), NULL);return TCL_ERROR;}Tcl_IncrRefCount(copyToPtr);
copyFsPtr =Tcl_FSGetFileSystemForPath(copyToPtr);if((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) {/* * We already know we can't use Tcl_FSLoadFile from this filesystem, * and we must avoid a possible infinite loop. Try to delete the file * we probably created, and then exit. */Tcl_FSDeleteFile(copyToPtr);Tcl_DecrRefCount(copyToPtr);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;}#if !defined(__WIN32__)/* * Do we need to set appropriate permissions on the file? This may be * required on some systems. On Unix we could loop over the file * attributes, and set any that are called "-permissions" to 0700. However * we just do this directly, like this: */{int index;
Tcl_Obj *perm;TclNewLiteralStringObj(perm,"0700");Tcl_IncrRefCount(perm);if(TclFSFileAttrIndex(copyToPtr,"-permissions", &index) == TCL_OK) {Tcl_FSFileAttrsSet(NULL, index, copyToPtr, perm);}Tcl_DecrRefCount(perm);}#endif/* * We need to reset the result now, because the cross-filesystem copy may * have stored the number of bytes in the result. */Tcl_ResetResult(interp);
retVal =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 - this is possible in some OSes, and * avoids any worries about leaving the copy laying around on exit. */if(Tcl_FSDeleteFile(copyToPtr) == TCL_OK) {Tcl_DecrRefCount(copyToPtr);/* * We tell our caller about the real shared library which was loaded. * Note that this does mean that the package list maintained by 'load' * will store the original (vfs) path alongside the temporary load * handle and unload proc ptr. */(*handlePtr) = newLoadHandle;(*clientDataPtr) = newClientData;(*unloadProcPtr) = newUnloadProcPtr;Tcl_ResetResult(interp);return TCL_OK;}/* * When we unload this file, we need to divert the unloading so we can * unload and cleanup the temporary file correctly. */
tvdlPtr = (FsDivertLoad *)ckalloc(sizeof(FsDivertLoad));/* * Remember three pieces of information. This allows us to cleanup the * diverted load completely, on platforms which allow proper unloading of * code. */
tvdlPtr->loadHandle = newLoadHandle;
tvdlPtr->unloadProcPtr = newUnloadProcPtr;if(copyFsPtr != &tclNativeFilesystem) {/* * copyToPtr is already incremented for this reference. */
tvdlPtr->divertedFile = copyToPtr;/* * This is the filesystem we loaded it into. Since we have a reference * to 'copyToPtr', we already have a refCount on this filesystem, so * we don't need to worry about it disappearing on us. */
tvdlPtr->divertedFilesystem = copyFsPtr;
tvdlPtr->divertedFileNativeRep = NULL;}else{/* * We need the native rep. */
tvdlPtr->divertedFileNativeRep =TclNativeDupInternalRep(Tcl_FSGetInternalRep(copyToPtr, copyFsPtr));/* * We don't need or want references to the copied Tcl_Obj or the * filesystem if it is the native one. */
tvdlPtr->divertedFile = NULL;
tvdlPtr->divertedFilesystem = NULL;Tcl_DecrRefCount(copyToPtr);}
copyToPtr = NULL;(*handlePtr) = newLoadHandle;(*clientDataPtr) = (ClientData) tvdlPtr;(*unloadProcPtr) = TclFSUnloadTempFile;Tcl_ResetResult(interp);return retVal;
resolveSymbols:{int i;for(i=0; i<symc ; i++) {if(symbols[i] != NULL) {*procPtrs[i] =TclpFindSymbol(interp, *handlePtr, symbols[i]);}}}return TCL_OK;}/* *--------------------------------------------------------------------------- * * TclFSUnloadTempFile -- * * This function is called when we loaded a library of code via an * intermediate temporary file. This function ensures the library is * correctly unloaded and the temporary file is correctly deleted. * * Results: * None. * * Side effects: * The effects of the 'unload' function called, and of course the * temporary file will be deleted. * *--------------------------------------------------------------------------- */voidTclFSUnloadTempFile(
Tcl_LoadHandle loadHandle)/* loadHandle returned by a previous call to * Tcl_FSLoadFile(). The loadHandle is a token * that represents the loaded file. */{
FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle;/* * This test should never trigger, since we give the client data in the * function above. */if(tvdlPtr == NULL) {return;}/* * Call the real 'unloadfile' proc we actually used. It is very important * that we call this first, so that the shared library is actually * unloaded by the OS. Otherwise, the following 'delete' may well fail * because the shared library is still in use. */if(tvdlPtr->unloadProcPtr != NULL) {(*tvdlPtr->unloadProcPtr)(tvdlPtr->loadHandle);}if(tvdlPtr->divertedFilesystem == NULL) {/* * It was the native filesystem, and we have a special function * available just for this purpose, which we know works even at this * late stage. */TclpDeleteFile(tvdlPtr->divertedFileNativeRep);NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep);}else{/* * Remove the temporary file we created. Note, we may crash here * because encodings have been taken down already. */if(tvdlPtr->divertedFilesystem->deleteFileProc(tvdlPtr->divertedFile)!= TCL_OK) {/* * The above may have failed because the filesystem, or something * it depends upon (e.g. encodings) have been taken down because * Tcl is exiting. * * We may need to work out how to delete this file more robustly * (or give the filesystem the information it needs to delete the * file more robustly). * * In particular, one problem might be that the filesystem cannot * extract the information it needs from the above path object * because Tcl's entire filesystem apparatus (the code in this * file) has been finalized, and it refuses to pass the internal * representation to the filesystem. */}/* * And free up the allocations. This will also of course remove a * refCount from the Tcl_Filesystem to which this file belongs, which * could then free up the filesystem if we are exiting. */Tcl_DecrRefCount(tvdlPtr->divertedFile);}ckfree((char*)tvdlPtr);}/* *--------------------------------------------------------------------------- * * Tcl_FSLink -- * * This function replaces the library version of readlink() and can also * be used to make links. The appropriate function for the filesystem to * which pathPtr belongs will be called. * * Results: * If toPtr is NULL, then the result is a Tcl_Obj specifying the contents * of the symbolic link given by 'pathPtr', or NULL if the symbolic link * could not be read. The result is owned by the caller, which should * call Tcl_DecrRefCount when the result is no longer needed. * * If toPtr is non-NULL, then the result is toPtr if the link action was * successful, or NULL if not. In this case the result has no additional * reference count, and need not be freed. The actual action to perform * is given by the 'linkAction' flags, which is an or'd combination of: * * TCL_CREATE_SYMBOLIC_LINK * TCL_CREATE_HARD_LINK * * Note that most filesystems will not support linking across to * different filesystems, so this function will usually fail unless toPtr * is in the same FS as pathPtr. * * Side effects: * See readlink() documentation. A new filesystem link object may appear. * *--------------------------------------------------------------------------- */
Tcl_Obj *Tcl_FSLink(
Tcl_Obj *pathPtr,/* Path of file to readlink or link */
Tcl_Obj *toPtr,/* NULL or path to be linked to */int linkAction)/* Action to perform */{const Tcl_Filesystem *fsPtr =Tcl_FSGetFileSystemForPath(pathPtr);if(fsPtr != NULL) {
Tcl_FSLinkProc *proc = fsPtr->linkProc;if(proc != NULL) {return(*proc)(pathPtr, toPtr, linkAction);}}/* * If S_IFLNK isn't defined it means that the machine doesn't support * symbolic links, so the file can't possibly be a symbolic link. Generate * an EINVAL error, which is what happens on machines that do support * symbolic links when you invoke readlink on a file that isn't a symbolic * link. */#ifndef S_IFLNK
errno = EINVAL;#elseTcl_SetErrno(ENOENT);#endif/* S_IFLNK */return NULL;}/* *--------------------------------------------------------------------------- * * Tcl_FSListVolumes -- * * Lists the currently mounted volumes. The chain of functions that have * been "inserted" into the filesystem will be called in succession; each * may return a list of volumes, all of which are added to the result * until all mounted file systems are listed. * * Notice that we assume the lists returned by each filesystem (if non * NULL) have been given a refCount for us already. However, we are NOT * allowed to hang on to the list itself (it belongs to the filesystem we * called). Therefore we quite naturally add its contents to the result * we are building, and then decrement the refCount. * * Results: * The list of volumes, in an object which has refCount 0. * * Side effects: * None * *--------------------------------------------------------------------------- */
Tcl_Obj*Tcl_FSListVolumes(void){
FilesystemRecord *fsRecPtr;
Tcl_Obj *resultPtr =Tcl_NewObj();/* * Call each of the "listVolumes" function in succession. A non-NULL * return value indicates the particular function has succeeded. We call * all the functions registered, since we want a list of all drives from * all filesystems. */
fsRecPtr =FsGetFirstFilesystem();Claim();while(fsRecPtr != NULL) {
Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc;if(proc != NULL) {
Tcl_Obj *thisFsVolumes = (*proc)();if(thisFsVolumes != NULL) {Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes);Tcl_DecrRefCount(thisFsVolumes);}}
fsRecPtr = fsRecPtr->nextPtr;}Disclaim();return resultPtr;}/* *--------------------------------------------------------------------------- * * FsListMounts -- * * List all mounts within the given directory, which match the given * pattern. * * Results: * The list of mounts, in a list object which has refCount 0, or NULL if * we didn't even find any filesystems to try to list mounts. * * Side effects: * None * *--------------------------------------------------------------------------- */static Tcl_Obj *FsListMounts(
Tcl_Obj *pathPtr,/* Contains path to directory to search. */const char*pattern)/* Pattern to match against. */{
FilesystemRecord *fsRecPtr;
Tcl_GlobTypeData mountsOnly = { TCL_GLOB_TYPE_MOUNT,0, NULL, NULL };
Tcl_Obj *resultPtr = NULL;/* * Call each of the "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) {
Tcl_FSMatchInDirectoryProc *proc =
fsRecPtr->fsPtr->matchInDirectoryProc;if(proc != NULL) {if(resultPtr == NULL) {
resultPtr =Tcl_NewObj();}(*proc)(NULL, resultPtr, pathPtr, pattern, &mountsOnly);}}
fsRecPtr = fsRecPtr->nextPtr;}Disclaim();return resultPtr;}/* *--------------------------------------------------------------------------- * * Tcl_FSSplitPath -- * * This function takes the given Tcl_Obj, which should be a valid path, * and returns a Tcl List object containing each segment of that path as * an element. * * Results: * Returns list object with refCount of zero. If the passed in lenPtr is * non-NULL, we use it to return the number of elements in the returned * list. * * Side effects: * None. * *--------------------------------------------------------------------------- */
Tcl_Obj *Tcl_FSSplitPath(
Tcl_Obj *pathPtr,/* Path to split. */int*lenPtr)/* int to store number of path elements. */{
Tcl_Obj *result = NULL;/* Needed only to prevent gcc warnings. */
Tcl_Filesystem *fsPtr;char separator ='/';int driveNameLength;char*p;/* * Perform platform specific splitting. */if(TclFSGetPathType(pathPtr, &fsPtr,&driveNameLength) == TCL_PATH_ABSOLUTE) {if(fsPtr == &tclNativeFilesystem) {returnTclpNativeSplitPath(pathPtr, lenPtr);}}else{returnTclpNativeSplitPath(pathPtr, lenPtr);}/* * We assume separators are single characters. */if(fsPtr->filesystemSeparatorProc != NULL) {
Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(pathPtr);if(sep != NULL) {Tcl_IncrRefCount(sep);
separator =Tcl_GetString(sep)[0];Tcl_DecrRefCount(sep);}}/* * Place the drive name as first element of the result list. The drive * name may contain strange characters, like colons and multiple forward * slashes (for example 'ftp://' is a valid vfs drive name) */
result =Tcl_NewObj();
p =Tcl_GetString(pathPtr);Tcl_ListObjAppendElement(NULL, result,Tcl_NewStringObj(p, driveNameLength));
p += driveNameLength;/* * Add the remaining path elements to the list. */for(;;) {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);}else{
nextElt =Tcl_NewStringObj(elementStart, length);}Tcl_ListObjAppendElement(NULL, result, nextElt);}if(*p++ =='\0') {break;}}/* * Compute the number of elements in the result. */if(lenPtr != NULL) {TclListObjLength(NULL, result, lenPtr);}return result;}/* *---------------------------------------------------------------------- * * TclGetPathType -- * * Helper function used by FSGetPathType. * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will be set if and * only if it is non-NULL and the function's return value is * TCL_PATH_ABSOLUTE. * * Side effects: * None. * *---------------------------------------------------------------------- */
Tcl_PathType
TclGetPathType(
Tcl_Obj *pathPtr,/* Path to determine type for */
Tcl_Filesystem **filesystemPtrPtr,/* If absolute path and this is not NULL, then * set to the filesystem which claims this * path. */int*driveNameLengthPtr,/* If the path is absolute, and this is * non-NULL, then set to the length of the * driveName. */
Tcl_Obj **driveNameRef)/* If the path is absolute, and this is * non-NULL, then set to the name of the * drive, network-volume which contains the * path, already with a refCount for the * caller. */{int pathLen;char*path;
Tcl_PathType type;
path =Tcl_GetStringFromObj(pathPtr, &pathLen);
type =TclFSNonnativePathType(path, pathLen, filesystemPtrPtr,
driveNameLengthPtr, driveNameRef);if(type != TCL_PATH_ABSOLUTE) {
type =TclpGetNativePathType(pathPtr, driveNameLengthPtr,
driveNameRef);if((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) {*filesystemPtrPtr = &tclNativeFilesystem;}}return type;}/* *---------------------------------------------------------------------- * * TclFSNonnativePathType -- * * Helper function used by TclGetPathType. Its purpose is to check * whether the given path starts with a string which corresponds to a * file volume in any registered filesystem except the native one. For * speed and historical reasons the native filesystem has special * hard-coded checks dotted here and there in the filesystem code. * * Results: * Returns one of TCL_PATH_ABSOLUTE or TCL_PATH_RELATIVE. The filesystem * reference will be set if and only if it is non-NULL and the function's * return value is TCL_PATH_ABSOLUTE. * * Side effects: * None. * *---------------------------------------------------------------------- */
Tcl_PathType
TclFSNonnativePathType(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;/* * Call each of the "listVolumes" function in succession, checking whether * the given path is an absolute path on any of the volumes returned (this * is done by checking whether the path's prefix matches). */
fsRecPtr =FsGetFirstFilesystem();Claim();while(fsRecPtr != NULL) {
Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc;/* * We want to skip the native filesystem in this loop because * otherwise we won't necessarily pass all the Tcl testsuite -- this * is because some of the tests artificially change the current * platform (between win, unix) but the list of volumes we get by * calling (*proc) will reflect the current (real) platform only and * this may cause some tests to fail. In particular, on unix '/' will * match the beginning of certain absolute Windows paths starting '//' * and those tests will go wrong. * * Besides these test-suite issues, there is one other reason to skip * the native filesystem --- since the tclFilename.c code has nice * fast 'absolute path' checkers, we don't want to waste time * repeating that effort here, and this function is actually called * quite often, so if we can save the overhead of the native * filesystem returning us a list of volumes all the time, it is * better. */if((fsRecPtr->fsPtr != &tclNativeFilesystem) && (proc != NULL)) {int numVolumes;
Tcl_Obj *thisFsVolumes = (*proc)();if(thisFsVolumes != NULL) {if(Tcl_ListObjLength(NULL, thisFsVolumes, &numVolumes)!= TCL_OK) {/* * This is VERY bad; the Tcl_FSListVolumesProc didn't * return a valid list. Set numVolumes to -1 so that we * skip the while loop below and just return with the * current value of 'type'. * * It would be better if we could signal an error here * (but Tcl_Panic seems a bit excessive). */
numVolumes = -1;}while(numVolumes >0) {
Tcl_Obj *vol;int len;char*strVol;
numVolumes--;Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol);
strVol =Tcl_GetStringFromObj(vol,&len);if(pathLen < len) {continue;}if(strncmp(strVol, path, (size_t) len) ==0) {
type = TCL_PATH_ABSOLUTE;if(filesystemPtrPtr != NULL) {*filesystemPtrPtr = fsRecPtr->fsPtr;}if(driveNameLengthPtr != NULL) {*driveNameLengthPtr = len;}if(driveNameRef != NULL) {*driveNameRef = vol;Tcl_IncrRefCount(vol);}break;}}Tcl_DecrRefCount(thisFsVolumes);if(type == TCL_PATH_ABSOLUTE) {/* * We don't need to examine any more filesystems. */break;}}}
fsRecPtr = fsRecPtr->nextPtr;}Disclaim();return type;}/* *--------------------------------------------------------------------------- * * Tcl_FSRenameFile -- * * If the two paths given belong to the same filesystem, we call that * filesystems rename function. Otherwise we simply return the POSIX * error 'EXDEV', and -1. * * Results: * Standard Tcl error code if a function was called. * * Side effects: * A file may be renamed. * *--------------------------------------------------------------------------- */intTcl_FSRenameFile(
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)) {
Tcl_FSRenameFileProc *proc = fsPtr->renameFileProc;if(proc != NULL) {
retVal = (*proc)(srcPathPtr, destPathPtr);}}if(retVal == -1) {Tcl_SetErrno(EXDEV);}return retVal;}/* *--------------------------------------------------------------------------- * * Tcl_FSCopyFile -- * * If the two paths given belong to the same filesystem, we call that * filesystem's copy function. Otherwise we simply return the POSIX error * 'EXDEV', and -1. * * Note that in the native filesystems, 'copyFileProc' is defined to copy * soft links (i.e. it copies the links themselves, not the things they * point to). * * Results: * Standard Tcl error code if a function was called. * * Side effects: * A file may be copied. * *--------------------------------------------------------------------------- */intTcl_FSCopyFile(
Tcl_Obj *srcPathPtr,/* Pathname of file to be copied (UTF-8). */
Tcl_Obj *destPathPtr)/* Pathname of file to copy to (UTF-8). */{int retVal = -1;const Tcl_Filesystem *fsPtr, *fsPtr2;
fsPtr =Tcl_FSGetFileSystemForPath(srcPathPtr);
fsPtr2 =Tcl_FSGetFileSystemForPath(destPathPtr);if(fsPtr == fsPtr2 && fsPtr != NULL) {
Tcl_FSCopyFileProc *proc = fsPtr->copyFileProc;if(proc != NULL) {
retVal = (*proc)(srcPathPtr, destPathPtr);}}if(retVal == -1) {Tcl_SetErrno(EXDEV);}return retVal;}/* *--------------------------------------------------------------------------- * * TclCrossFilesystemCopy -- * * Helper for above function, and for Tcl_FSLoadFile, to copy files from * one filesystem to another. This function will overwrite the target * file if it already exists. * * Results: * Standard Tcl error code. * * Side effects: * A file may be created. * *--------------------------------------------------------------------------- */intTclCrossFilesystemCopy(
Tcl_Interp *interp,/* For error messages */
Tcl_Obj *source,/* Pathname of file to be copied (UTF-8). */
Tcl_Obj *target)/* Pathname of file to copy to (UTF-8). */{int result = TCL_ERROR;int prot =0666;
Tcl_Channel in, out;
Tcl_StatBuf sourceStatBuf;struct utimbuf tval;
out =Tcl_FSOpenFileChannel(interp, target,"wb", prot);if(out == NULL) {/* * It looks like we cannot copy it over. Bail out... */goto done;}
in =Tcl_FSOpenFileChannel(interp, source,"rb", prot);if(in == NULL) {/* * This is very strange, caller should have checked this... */Tcl_Close(interp, out);goto done;}/* * Copy it synchronously. We might wish to add an asynchronous option to * support vfs's which are slow (e.g. network sockets). */if(TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) {
result = TCL_OK;}/* * If the copy failed, assume that copy channel left a good error message. */Tcl_Close(interp, in);Tcl_Close(interp, out);/* * Set modification date of copied file. */if(Tcl_FSLstat(source, &sourceStatBuf) ==0) {
tval.actime = sourceStatBuf.st_atime;
tval.modtime = sourceStatBuf.st_mtime;Tcl_FSUtime(target, &tval);}
done:return result;}/* *--------------------------------------------------------------------------- * * Tcl_FSDeleteFile -- * * The appropriate function for the filesystem to which pathPtr belongs * will be called. * * Results: * Standard Tcl error code. * * Side effects: * A file may be deleted. * *--------------------------------------------------------------------------- */intTcl_FSDeleteFile(
Tcl_Obj *pathPtr)/* Pathname of file to be removed (UTF-8). */{const Tcl_Filesystem *fsPtr =Tcl_FSGetFileSystemForPath(pathPtr);if(fsPtr != NULL) {
Tcl_FSDeleteFileProc *proc = fsPtr->deleteFileProc;if(proc != NULL) {return(*proc)(pathPtr);}}Tcl_SetErrno(ENOENT);return-1;}/* *--------------------------------------------------------------------------- * * Tcl_FSCreateDirectory -- * * The appropriate function for the filesystem to which pathPtr belongs * will be called. * * Results: * Standard Tcl error code. * * Side effects: * A directory may be created. * *--------------------------------------------------------------------------- */intTcl_FSCreateDirectory(
Tcl_Obj *pathPtr)/* Pathname of directory to create (UTF-8). */{const Tcl_Filesystem *fsPtr =Tcl_FSGetFileSystemForPath(pathPtr);if(fsPtr != NULL) {
Tcl_FSCreateDirectoryProc *proc = fsPtr->createDirectoryProc;if(proc != NULL) {return(*proc)(pathPtr);}}Tcl_SetErrno(ENOENT);return-1;}/* *--------------------------------------------------------------------------- * * Tcl_FSCopyDirectory -- * * If the two paths given belong to the same filesystem, we call that * filesystems copy-directory function. Otherwise we simply return the * POSIX error 'EXDEV', and -1. * * Results: * Standard Tcl error code if a function was called. * * Side effects: * A directory may be copied. * *--------------------------------------------------------------------------- */intTcl_FSCopyDirectory(
Tcl_Obj* srcPathPtr,/* Pathname of directory to be copied * (UTF-8). */
Tcl_Obj *destPathPtr,/* Pathname of target directory (UTF-8). */
Tcl_Obj **errorPtr)/* If non-NULL, then will be set to a new * object containing name of file causing * error, with refCount 1. */{int retVal = -1;const Tcl_Filesystem *fsPtr, *fsPtr2;
fsPtr =Tcl_FSGetFileSystemForPath(srcPathPtr);
fsPtr2 =Tcl_FSGetFileSystemForPath(destPathPtr);if(fsPtr == fsPtr2 && fsPtr != NULL) {
Tcl_FSCopyDirectoryProc *proc = fsPtr->copyDirectoryProc;if(proc != NULL) {
retVal = (*proc)(srcPathPtr, destPathPtr, errorPtr);}}if(retVal == -1) {Tcl_SetErrno(EXDEV);}return retVal;}/* *--------------------------------------------------------------------------- * * Tcl_FSRemoveDirectory -- * * The appropriate function for the filesystem to which pathPtr belongs * will be called. * * Results: * Standard Tcl error code. * * Side effects: * A directory may be deleted. * *--------------------------------------------------------------------------- */intTcl_FSRemoveDirectory(
Tcl_Obj *pathPtr,/* Pathname of directory to be removed * (UTF-8). */int recursive,/* If non-zero, removes directories that are * nonempty. Otherwise, will only remove empty * directories. */
Tcl_Obj **errorPtr)/* If non-NULL, then will be set to a new * object containing name of file causing * error, with refCount 1. */{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. */
Tcl_Obj *cwdPtr =Tcl_FSGetCwd(NULL);if(cwdPtr != NULL) {char*cwdStr, *normPathStr;int cwdLen, normLen;
Tcl_Obj *normPath =Tcl_FSGetNormalizedPath(NULL, pathPtr);if(normPath != NULL) {
normPathStr =Tcl_GetStringFromObj(normPath, &normLen);
cwdStr =Tcl_GetStringFromObj(cwdPtr, &cwdLen);if((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr,(size_t) normLen) ==0)) {/* * The cwd is inside the directory, so we perform a * 'cd [file dirname $path]'. */
Tcl_Obj *dirPtr =TclPathPart(NULL, pathPtr,
TCL_PATH_DIRNAME);Tcl_FSChdir(dirPtr);Tcl_DecrRefCount(dirPtr);}}Tcl_DecrRefCount(cwdPtr);}}return(*proc)(pathPtr, recursive, errorPtr);}Tcl_SetErrno(ENOENT);return-1;}/* *--------------------------------------------------------------------------- * * Tcl_FSGetFileSystemForPath -- * * This function determines which filesystem to use for a particular path * object, and returns the filesystem which accepts this file. If no * filesystem will accept this object as a valid file path, then NULL is * returned. * * Results: * NULL or a filesystem which will accept this path. * * Side effects: * The object may be converted to a path type. * *--------------------------------------------------------------------------- */
Tcl_Filesystem *Tcl_FSGetFileSystemForPath(
Tcl_Obj* pathPtr){
FilesystemRecord *fsRecPtr;
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) {Tcl_Panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0");return NULL;}/* * Check if the filesystem has changed in some way since this object's * internal representation was calculated. Before doing that, assure we * have the most up-to-date copy of the master filesystem. This is * accomplished by the FsGetFirstFilesystem() call. */
fsRecPtr =FsGetFirstFilesystem();Claim();if(TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) {Disclaim();return NULL;}/* * Call each of the "pathInFilesystem" functions in succession. A * non-return value of -1 indicates the particular function has succeeded. */while((retVal == NULL) && (fsRecPtr != NULL)) {
Tcl_FSPathInFilesystemProc *proc =
fsRecPtr->fsPtr->pathInFilesystemProc;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);
retVal = fsRecPtr->fsPtr;}}
fsRecPtr = fsRecPtr->nextPtr;}Disclaim();return retVal;}/* *--------------------------------------------------------------------------- * * Tcl_FSGetNativePath -- * * 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 char*Tcl_FSGetNativePath(
Tcl_Obj *pathPtr){return(const char*)Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem);}/* *--------------------------------------------------------------------------- * * NativeFreeInternalRep -- * * Free a native internal representation, which will be non-NULL. * * Results: * None. * * Side effects: * Memory is released. * *--------------------------------------------------------------------------- */static voidNativeFreeInternalRep(
ClientData clientData){ckfree((char*) clientData);}/* *--------------------------------------------------------------------------- * * Tcl_FSFileSystemInfo -- * * This function returns a list of two elements. The first element is the * name of the filesystem (e.g. "native" or "vfs"), and the second is the * particular type of the given path within that filesystem. * * Results: * A list of two elements. * * Side effects: * The object may be converted to a path type. * *--------------------------------------------------------------------------- */
Tcl_Obj *Tcl_FSFileSystemInfo(
Tcl_Obj *pathPtr){
Tcl_Obj *resPtr;
Tcl_FSFilesystemPathTypeProc *proc;const Tcl_Filesystem *fsPtr =Tcl_FSGetFileSystemForPath(pathPtr);if(fsPtr == NULL) {return NULL;}
resPtr =Tcl_NewListObj(0, NULL);Tcl_ListObjAppendElement(NULL,resPtr,Tcl_NewStringObj(fsPtr->typeName,-1));
proc = fsPtr->filesystemPathTypeProc;if(proc != NULL) {
Tcl_Obj *typePtr = (*proc)(pathPtr);if(typePtr != NULL) {Tcl_ListObjAppendElement(NULL, resPtr, typePtr);}}return resPtr;}/* *--------------------------------------------------------------------------- * * Tcl_FSPathSeparator -- * * This function returns the separator to be used for a given path. The * object returned should have a refCount of zero * * Results: * A Tcl object, with a refCount of zero. If the caller needs to retain a * reference to the object, it should call Tcl_IncrRefCount, and should * otherwise free the object. * * Side effects: * The path object may be converted to a path type. * *--------------------------------------------------------------------------- */
Tcl_Obj *Tcl_FSPathSeparator(
Tcl_Obj *pathPtr){const Tcl_Filesystem *fsPtr =Tcl_FSGetFileSystemForPath(pathPtr);if(fsPtr == NULL) {return NULL;}if(fsPtr->filesystemSeparatorProc != NULL) {return(*fsPtr->filesystemSeparatorProc)(pathPtr);}else{
Tcl_Obj *resultObj;/* * Allow filesystems not to provide a filesystemSeparatorProc if they * wish to use the standard forward slash. */TclNewLiteralStringObj(resultObj,"/");return resultObj;}}/* *--------------------------------------------------------------------------- * * NativeFilesystemSeparator -- * * This function is part of the native filesystem support, and returns * the separator for the given path. * * Results: * String object containing the separator character. * * Side effects: * None. * *--------------------------------------------------------------------------- */static Tcl_Obj *NativeFilesystemSeparator(
Tcl_Obj *pathPtr){const char*separator = NULL;/* lint */switch(tclPlatform) {case TCL_PLATFORM_UNIX:
separator ="/";break;case TCL_PLATFORM_WINDOWS:
separator ="\\";break;}returnTcl_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. * *---------------------------------------------------------------------- */intTclStatInsertProc(
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. * *---------------------------------------------------------------------- */intTclStatDeleteProc(
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. * *---------------------------------------------------------------------- */intTclAccessInsertProc(
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. * *---------------------------------------------------------------------- */intTclAccessDeleteProc(
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. * *---------------------------------------------------------------------- */intTclOpenFileChannelInsertProc(
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. * *---------------------------------------------------------------------- */intTclOpenFileChannelDeleteProc(
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: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */