/*
* 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.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclIOUtil.c,v 1.77.2.12 2003/11/20 19:05:44 vincentdarley Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
#ifdef MAC_TCL
#include "tclMacInt.h"
#endif
#ifdef __WIN32__
/* for tclWinProcs->useWide */
#include "tclWinInt.h"
#endif
/*
* struct FilesystemRecord --
*
* A filesystem record is used to keep track of each
* filesystem currently registered with the core,
* in a linked list. Pointers to these structures
* are also kept by each "path" Tcl_Obj, and we must
* retain a refCount on the number of such references.
*/
typedef struct FilesystemRecord {
ClientData clientData; /* Client specific data for the new
* filesystem (can be NULL) */
Tcl_Filesystem *fsPtr; /* Pointer to filesystem dispatch
* table. */
int fileRefCount; /* How many Tcl_Obj's use this
* filesystem. */
struct FilesystemRecord *nextPtr;
/* The next filesystem registered
* to Tcl, or NULL if no more. */
struct FilesystemRecord *prevPtr;
/* The previous filesystem registered
* to Tcl, or NULL if no more. */
} FilesystemRecord;
/*
* The internal TclFS API provides routines for handling and
* manipulating paths efficiently, taking direct advantage of
* the "path" Tcl_Obj type.
*
* These functions are not exported at all at present.
*/
int TclFSCwdPointerEquals _ANSI_ARGS_((Tcl_Obj* objPtr));
int TclFSMakePathFromNormalized _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, ClientData clientData));
int TclFSNormalizeToUniquePath _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *pathPtr, int startAt, ClientData *clientDataPtr));
Tcl_Obj* TclFSMakePathRelative _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_Obj *cwdPtr));
Tcl_Obj* TclFSInternalToNormalized _ANSI_ARGS_((
Tcl_Filesystem *fromFilesystem, ClientData clientData,
FilesystemRecord **fsRecPtrPtr));
int TclFSEnsureEpochOk _ANSI_ARGS_((Tcl_Obj* pathObjPtr,
Tcl_Filesystem **fsPtrPtr));
void TclFSSetPathDetails _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
FilesystemRecord *fsRecPtr, ClientData clientData));
/*
* Private variables for use in this file
*/
extern Tcl_Filesystem tclNativeFilesystem;
extern int theFilesystemEpoch;
/*
* Private functions for use in this file
*/
Tcl_PathType FSGetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
Tcl_Filesystem **filesystemPtrPtr,
int *driveNameLengthPtr));
Tcl_PathType GetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
Tcl_Filesystem **filesystemPtrPtr,
int *driveNameLengthPtr, Tcl_Obj **driveNameRef));
Tcl_FSPathInFilesystemProc NativePathInFilesystem;
static Tcl_Obj* TclFSNormalizeAbsolutePath
_ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr,
ClientData *clientDataPtr));
/*
* Prototypes for procedures defined later in this file.
*/
static FilesystemRecord* FsGetFirstFilesystem(void);
static void FsThrExitProc(ClientData cd);
static Tcl_Obj* FsListMounts _ANSI_ARGS_((Tcl_Obj *pathPtr,
CONST char *pattern));
static Tcl_Obj* FsAddMountsToGlobResult _ANSI_ARGS_((Tcl_Obj *result,
Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types));
#ifdef TCL_THREADS
static void FsRecacheFilesystemList(void);
#endif
/*
* These form part of the native filesystem support. They are needed
* here because we have a few native filesystem functions (which are
* the same for mac/win/unix) in this file. There is no need to place
* them in tclInt.h, because they are not (and should not be) used
* anywhere else.
*/
extern CONST char * tclpFileAttrStrings[];
extern CONST TclFileAttrProcs tclpFileAttrProcs[];
/*
* The following functions are obsolete string based APIs, and should
* be removed in a future release (Tcl 9 would be a good time).
*/
/* Obsolete */
int
Tcl_Stat(path, oldStyleBuf)
CONST char *path; /* Path of file to stat (in current CP). */
struct stat *oldStyleBuf; /* Filled with results of stat call. */
{
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
# 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...
*/
if (OUT_OF_URANGE(buf.st_ino) || OUT_OF_RANGE(buf.st_size)
#ifdef HAVE_ST_BLOCKS
|| OUT_OF_RANGE(buf.st_blocks)
#endif
) {
#ifdef EFBIG
errno = EFBIG;
#else
# ifdef EOVERFLOW
errno = EOVERFLOW;
# else
# error "What status should be returned for file size out of range?"
# endif
#endif
return -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_ST_BLOCKS
oldStyleBuf->st_blksize = buf.st_blksize;
oldStyleBuf->st_blocks = (blkcnt_t) buf.st_blocks;
#endif
}
return ret;
}
/* Obsolete */
int
Tcl_Access(path, mode)
CONST char *path; /* Path of file to access (in current CP). */
int mode; /* Permission setting. */
{
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
Tcl_IncrRefCount(pathPtr);
ret = Tcl_FSAccess(pathPtr,mode);
Tcl_DecrRefCount(pathPtr);
return ret;
}
/* Obsolete */
Tcl_Channel
Tcl_OpenFileChannel(interp, path, modeString, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
CONST char *path; /* Name of file to open. */
CONST char *modeString; /* A list of POSIX open modes or
* a string such as "rw". */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
Tcl_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 */
int
Tcl_Chdir(dirName)
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(interp, cwdPtr)
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);
return Tcl_DStringValue(cwdPtr);
}
}
/* Obsolete */
int
Tcl_EvalFile(interp, fileName)
Tcl_Interp *interp; /* Interpreter in which to process file. */
CONST char *fileName; /* Name of file to process. Tilde-substitution
* will be performed on this name. */
{
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1);
Tcl_IncrRefCount(pathPtr);
ret = Tcl_FSEvalFile(interp, pathPtr);
Tcl_DecrRefCount(pathPtr);
return ret;
}
/*
* The 3 hooks for Stat, Access and OpenFileChannel are obsolete. The
* complete, general hooked filesystem APIs should be used instead.
* This define decides whether to include the obsolete hooks and
* related code. If these are removed, we'll also want to remove them
* from stubs/tclInt. The only known users of these APIs are prowrap
* and mktclapp. New code/extensions should not use them, since they
* do not provide as full support as the full filesystem API.
*
* As soon as prowrap and mktclapp are updated to use the full
* filesystem support, I suggest all these hooks are removed.
*/
#define USE_OBSOLETE_FS_HOOKS
#ifdef USE_OBSOLETE_FS_HOOKS
/*
* The following typedef declarations allow for hooking into the chain
* of functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' &
* 'Tcl_OpenFileChannel(...)'. Basically for each hookable function
* a linked list is defined.
*/
typedef struct StatProc {
TclStatProc_ *proc; /* Function to process a 'stat()' call */
struct StatProc *nextPtr; /* The next 'stat()' function to call */
} StatProc;
typedef struct AccessProc {
TclAccessProc_ *proc; /* Function to process a 'access()' call */
struct AccessProc *nextPtr; /* The next 'access()' function to call */
} AccessProc;
typedef struct OpenFileChannelProc {
TclOpenFileChannelProc_ *proc; /* Function to process a
* 'Tcl_OpenFileChannel()' call */
struct OpenFileChannelProc *nextPtr;
/* The next 'Tcl_OpenFileChannel()'
* function to call */
} OpenFileChannelProc;
/*
* For each type of (obsolete) hookable function, a static node is
* declared to hold the function pointer for the "built-in" routine
* (e.g. 'TclpStat(...)') and the respective list is initialized as a
* pointer to that node.
*
* The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that
* these statically declared list entry cannot be inadvertently removed.
*
* This method avoids the need to call any sort of "initialization"
* function.
*
* All three lists are protected by a global obsoleteFsHookMutex.
*/
static StatProc *statProcList = NULL;
static AccessProc *accessProcList = NULL;
static OpenFileChannelProc *openFileChannelProcList = NULL;
TCL_DECLARE_MUTEX(obsoleteFsHookMutex)
#endif /* USE_OBSOLETE_FS_HOOKS */
/*
* Declare the native filesystem support. These functions should
* be considered private to Tcl, and should really not be called
* directly by any code other than this file (i.e. neither by
* Tcl's core nor by extensions). Similarly, the old string-based
* Tclp... native filesystem functions should not be called.
*
* The correct API to use now is the Tcl_FS... set of functions,
* which ensure correct and complete virtual filesystem support.
*
* We cannot make all of these static, since some of them
* are implemented in the platform-specific directories.
*/
static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator;
static Tcl_FSFreeInternalRepProc NativeFreeInternalRep;
Tcl_FSDupInternalRepProc NativeDupInternalRep;
static Tcl_FSCreateInternalRepProc NativeCreateNativeRep;
static Tcl_FSFileAttrStringsProc NativeFileAttrStrings;
static Tcl_FSFileAttrsGetProc NativeFileAttrsGet;
static Tcl_FSFileAttrsSetProc NativeFileAttrsSet;
/*
* The only reason these functions are not static is that they
* are either called by code in the native (win/unix/mac) directories
* or they are actually implemented in those directories. They
* should simply not be called by code outside Tcl's native
* filesystem core. i.e. they should be considered 'static' to
* Tcl's filesystem code (if we ever built the native filesystem
* support into a separate code library, this could actually be
* enforced).
*/
Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType;
Tcl_FSInternalToNormalizedProc TclpNativeToNormalized;
Tcl_FSStatProc TclpObjStat;
Tcl_FSAccessProc TclpObjAccess;
Tcl_FSMatchInDirectoryProc TclpMatchInDirectory;
Tcl_FSGetCwdProc TclpObjGetCwd;
Tcl_FSChdirProc TclpObjChdir;
Tcl_FSLstatProc TclpObjLstat;
Tcl_FSCopyFileProc TclpObjCopyFile;
Tcl_FSDeleteFileProc TclpObjDeleteFile;
Tcl_FSRenameFileProc TclpObjRenameFile;
Tcl_FSCreateDirectoryProc TclpObjCreateDirectory;
Tcl_FSCopyDirectoryProc TclpObjCopyDirectory;
Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory;
Tcl_FSUnloadFileProc TclpUnloadFile;
Tcl_FSLinkProc TclpObjLink;
Tcl_FSListVolumesProc TclpObjListVolumes;
/*
* Define the native filesystem dispatch table. If necessary, it
* is ok to make this non-static, but it should only be accessed
* by the functions actually listed within it (or perhaps other
* helper functions of them). Anything which is not part of this
* 'native filesystem implementation' should not be delving inside
* here!
*/
Tcl_Filesystem tclNativeFilesystem = {
"native",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_1,
&NativePathInFilesystem,
&NativeDupInternalRep,
&NativeFreeInternalRep,
&TclpNativeToNormalized,
&NativeCreateNativeRep,
&TclpObjNormalizePath,
&TclpFilesystemPathType,
&NativeFilesystemSeparator,
&TclpObjStat,
&TclpObjAccess,
&TclpOpenFileChannel,
&TclpMatchInDirectory,
&TclpUtime,
#ifndef S_IFLNK
NULL,
#else
&TclpObjLink,
#endif /* S_IFLNK */
&TclpObjListVolumes,
&NativeFileAttrStrings,
&NativeFileAttrsGet,
&NativeFileAttrsSet,
&TclpObjCreateDirectory,
&TclpObjRemoveDirectory,
&TclpObjDeleteFile,
&TclpObjCopyFile,
&TclpObjRenameFile,
&TclpObjCopyDirectory,
&TclpObjLstat,
&TclpDlopen,
&TclpObjGetCwd,
&TclpObjChdir
};
/*
* Define the tail of the linked list. Note that for unconventional
* uses of Tcl without a native filesystem, we may in the future wish
* to modify the current approach of hard-coding the native filesystem
* in the lookup list 'filesystemList' below.
*
* We initialize the record so that it thinks one file uses it. This
* means it will never be freed.
*/
static FilesystemRecord nativeFilesystemRecord = {
NULL,
&tclNativeFilesystem,
1,
NULL
};
/*
* This is incremented each time we modify the linked list of
* filesystems. Any time it changes, all cached filesystem
* representations are suspect and must be freed.
* For multithreading builds, change of the filesystem epoch
* will trigger cache cleanup in all threads.
*/
int theFilesystemEpoch = 0;
/*
* Stores the linked list of filesystems. A 1:1 copy of this
* list is also maintained in the TSD for each thread. This
* is to avoid synchronization issues.
*/
static FilesystemRecord *filesystemList = &nativeFilesystemRecord;
TCL_DECLARE_MUTEX(filesystemMutex)
/*
* Used to implement Tcl_FSGetCwd in a file-system independent way.
*/
static Tcl_Obj* cwdPathPtr = NULL;
static int cwdPathEpoch = 0;
TCL_DECLARE_MUTEX(cwdMutex)
/*
* This structure holds per-thread private copies of
* some global data. This way we avoid most of the
* synchronization calls which boosts performance, at
* cost of having to update this information each
* time the corresponding epoch counter changes.
*
*/
typedef struct ThreadSpecificData {
int initialized;
int cwdPathEpoch;
int filesystemEpoch;
Tcl_Obj *cwdPathPtr;
FilesystemRecord *filesystemList;
} ThreadSpecificData;
Tcl_ThreadDataKey dataKey;
/*
* Declare fallback support function and
* information for Tcl_FSLoadFile
*/
static Tcl_FSUnloadFileProc FSUnloadTempFile;
/*
* One of these structures is used each time we successfully load a
* file from a file system by way of making a temporary copy of the
* file on the native filesystem. We need to store both the actual
* unloadProc/clientData combination which was used, and the original
* and modified filenames, so that we can correctly undo the entire
* operation when we want to unload the code.
*/
typedef struct FsDivertLoad {
Tcl_LoadHandle loadHandle;
Tcl_FSUnloadFileProc *unloadProcPtr;
Tcl_Obj *divertedFile;
Tcl_Filesystem *divertedFilesystem;
ClientData divertedFileNativeRep;
} FsDivertLoad;
/* Now move on to the basic filesystem implementation */
static void
FsThrExitProc(cd)
ClientData cd;
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData*)cd;
FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL;
/* Trash the cwd copy */
if (tsdPtr->cwdPathPtr != NULL) {
Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
}
/* Trash the filesystems cache */
fsRecPtr = tsdPtr->filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr->nextPtr;
if (--fsRecPtr->fileRefCount <= 0) {
ckfree((char *)fsRecPtr);
}
fsRecPtr = tmpFsRecPtr;
}
}
int
TclFSCwdPointerEquals(objPtr)
Tcl_Obj* objPtr;
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_MutexLock(&cwdMutex);
if (tsdPtr->cwdPathPtr == NULL) {
if (cwdPathPtr == NULL) {
tsdPtr->cwdPathPtr = NULL;
} else {
tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr);
Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
}
tsdPtr->cwdPathEpoch = cwdPathEpoch;
} else if (tsdPtr->cwdPathEpoch != cwdPathEpoch) {
Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
if (cwdPathPtr == NULL) {
tsdPtr->cwdPathPtr = NULL;
} else {
tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr);
Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
}
}
Tcl_MutexUnlock(&cwdMutex);
if (tsdPtr->initialized == 0) {
Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData)tsdPtr);
tsdPtr->initialized = 1;
}
return (tsdPtr->cwdPathPtr == objPtr);
}
#ifdef TCL_THREADS
static void
FsRecacheFilesystemList(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL;
/* Trash the current cache */
fsRecPtr = tsdPtr->filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr->nextPtr;
if (--fsRecPtr->fileRefCount <= 0) {
ckfree((char *)fsRecPtr);
}
fsRecPtr = tmpFsRecPtr;
}
tsdPtr->filesystemList = NULL;
/*
* Code below operates on shared data. We
* are already called under mutex lock so
* we can safely proceede.
*/
/* Locate tail of the global filesystem list */
fsRecPtr = filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr;
fsRecPtr = fsRecPtr->nextPtr;
}
/* Refill the cache honouring the order */
fsRecPtr = tmpFsRecPtr;
while (fsRecPtr != NULL) {
tmpFsRecPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord));
*tmpFsRecPtr = *fsRecPtr;
tmpFsRecPtr->nextPtr = tsdPtr->filesystemList;
tmpFsRecPtr->prevPtr = NULL;
if (tsdPtr->filesystemList) {
tsdPtr->filesystemList->prevPtr = tmpFsRecPtr;
}
tsdPtr->filesystemList = tmpFsRecPtr;
fsRecPtr = fsRecPtr->prevPtr;
}
/* Make sure the above gets released on thread exit */
if (tsdPtr->initialized == 0) {
Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData)tsdPtr);
tsdPtr->initialized = 1;
}
}
#endif
static FilesystemRecord *
FsGetFirstFilesystem(void) {
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FilesystemRecord *fsRecPtr;
#ifndef TCL_THREADS
tsdPtr->filesystemEpoch = theFilesystemEpoch;
fsRecPtr = filesystemList;
#else
Tcl_MutexLock(&filesystemMutex);
if (tsdPtr->filesystemList == NULL
|| (tsdPtr->filesystemEpoch != theFilesystemEpoch)) {
FsRecacheFilesystemList();
tsdPtr->filesystemEpoch = theFilesystemEpoch;
}
Tcl_MutexUnlock(&filesystemMutex);
fsRecPtr = tsdPtr->filesystemList;
#endif
return fsRecPtr;
}
static void
FsUpdateCwd(cwdObj)
Tcl_Obj *cwdObj;
{
int len;
char *str = NULL;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (cwdObj != NULL) {
str = Tcl_GetStringFromObj(cwdObj, &len);
}
Tcl_MutexLock(&cwdMutex);
if (cwdPathPtr != NULL) {
Tcl_DecrRefCount(cwdPathPtr);
}
if (cwdObj == NULL) {
cwdPathPtr = NULL;
} else {
/* This MUST be stored as string object! */
cwdPathPtr = Tcl_NewStringObj(str, len);
Tcl_IncrRefCount(cwdPathPtr);
}
cwdPathEpoch++;
tsdPtr->cwdPathEpoch = cwdPathEpoch;
Tcl_MutexUnlock(&cwdMutex);
if (tsdPtr->cwdPathPtr) {
Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
}
if (cwdObj == NULL) {
tsdPtr->cwdPathPtr = NULL;
} else {
tsdPtr->cwdPathPtr = Tcl_NewStringObj(str, len);
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.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeFilesystem()
{
FilesystemRecord *fsRecPtr, *tmpFsRecPtr;
/*
* 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;
}
/*
* Remove all filesystems, freeing any allocated memory
* that is no longer needed
*/
fsRecPtr = filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = filesystemList->nextPtr;
if (fsRecPtr->fileRefCount <= 0) {
/* The native filesystem is static, so we don't free it */
if (fsRecPtr != &nativeFilesystemRecord) {
ckfree((char *)fsRecPtr);
}
}
fsRecPtr = tmpFsRecPtr;
}
filesystemList = NULL;
/*
* Now filesystemList is NULL. This means that any attempt
* to use the filesystem is likely to fail.
*/
statProcList = NULL;
accessProcList = NULL;
openFileChannelProcList = NULL;
#ifdef __WIN32__
TclWinEncodingsCleanup();
#endif
}
/*
*----------------------------------------------------------------------
*
* TclResetFilesystem --
*
* Restore the filesystem to a pristine state.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclResetFilesystem()
{
filesystemList = &nativeFilesystemRecord;
/*
* Note, at this point, I believe nativeFilesystemRecord ->
* fileRefCount should equal 1 and if not, we should try to track
* down the cause.
*/
#ifdef __WIN32__
/*
* Cleans up the win32 API filesystem proc lookup table. This must
* happen very late in finalization so that deleting of copied
* dlls can occur.
*/
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.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSRegister(clientData, fsPtr)
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;
/*
* We start with a refCount of 1. If this drops to zero, then
* anyone is welcome to ckfree us.
*/
newFilesystemPtr->fileRefCount = 1;
/*
* Is this lock and wait strictly speaking necessary? Since any
* iterators out there will have grabbed a copy of the head of
* the list and be iterating away from that, if we add a new
* element to the head of the list, it can't possibly have any
* effect on any of their loops. In fact it could be better not
* to wait, since we are adjusting the filesystem epoch, any
* cached representations calculated by existing iterators are
* 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 procedure 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.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSUnregister(fsPtr)
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++;
fsRecPtr->fileRefCount--;
if (fsRecPtr->fileRefCount <= 0) {
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 each
* filesystem's Tcl_FSMatchInDirectoryProc having to deal with this
* issue, we create a pathPtr on the fly (equal to the cwd), and
* then remove it from the results returned. This makes filesystems
* easy to write, since they can assume the pathPtr passed to them
* is an ordinary path. In fact this means we could remove such
* special case handling from Tcl's native filesystems.
*
* If 'pattern' is NULL, then pathPtr is assumed to be a fully
* specified path of a single file/directory which must be
* checked for existence and correct type.
*
* Results:
*
* The return value is a standard Tcl result indicating whether an
* error occurred in globbing. Error messages are placed in
* interp, but good results are placed in the resultPtr given.
*
* 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.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSMatchInDirectory(interp, result, pathPtr, pattern, types)
Tcl_Interp *interp; /* Interpreter to receive error messages. */
Tcl_Obj *result; /* List object to receive results. */
Tcl_Obj *pathPtr; /* Contains path to directory to search. */
CONST char *pattern; /* Pattern to match against. */
Tcl_GlobTypeData *types; /* Object containing list of acceptable types.
* May be NULL. In particular the directory
* flag is very important. */
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc;
if (proc != NULL) {
int ret = (*proc)(interp, result, pathPtr, pattern, types);
if (ret == TCL_OK && pattern != NULL) {
result = FsAddMountsToGlobResult(result, pathPtr,
pattern, types);
}
return ret;
}
} else {
Tcl_Obj* cwd;
int ret = -1;
if (pathPtr != NULL) {
int len;
Tcl_GetStringFromObj(pathPtr,&len);
if (len != 0) {
/*
* We have no idea how to match files in a directory
* which belongs to no known filesystem
*/
Tcl_SetErrno(ENOENT);
return -1;
}
}
/*
* 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) {
Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc;
if (proc != NULL) {
Tcl_Obj* tmpResultPtr = Tcl_NewListObj(0, NULL);
Tcl_IncrRefCount(tmpResultPtr);
ret = (*proc)(interp, tmpResultPtr, cwd, pattern, types);
if (ret == TCL_OK) {
int resLength;
tmpResultPtr = FsAddMountsToGlobResult(tmpResultPtr, cwd,
pattern, types);
ret = Tcl_ListObjLength(interp, tmpResultPtr, &resLength);
if (ret == TCL_OK) {
int i;
for (i = 0; i < resLength; i++) {
Tcl_Obj *elt;
Tcl_ListObjIndex(interp, tmpResultPtr, i, &elt);
Tcl_ListObjAppendElement(interp, result,
TclFSMakePathRelative(interp, elt, cwd));
}
}
}
Tcl_DecrRefCount(tmpResultPtr);
}
}
Tcl_DecrRefCount(cwd);
return ret;
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*----------------------------------------------------------------------
*
* FsAddMountsToGlobResult --
*
* This routine is used by the globbing code to take the results
* of a directory listing and add any mounted paths to that
* listing. This is required so that simple things like
* 'glob *' merge mounts and listings correctly.
*
* Results:
*
* The passed in 'result' may be modified (in place, if
* necessary), and the correct list is returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj*
FsAddMountsToGlobResult(result, pathPtr, pattern, types)
Tcl_Obj *result; /* The current list of matching paths */
Tcl_Obj *pathPtr; /* The directory in question */
CONST char *pattern;
Tcl_GlobTypeData *types;
{
int mLength, gLength, i;
int dir = (types == NULL || (types->type & TCL_GLOB_TYPE_DIR));
Tcl_Obj *mounts = FsListMounts(pathPtr, pattern);
if (mounts == NULL) return result;
if (Tcl_ListObjLength(NULL, mounts, &mLength) != TCL_OK || mLength == 0) {
goto endOfMounts;
}
if (Tcl_ListObjLength(NULL, result, &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, result, j, &gElt);
if (Tcl_FSEqualPaths(mElt, gElt)) {
found = 1;
if (!dir) {
/* We don't want to list this */
if (Tcl_IsShared(result)) {
Tcl_Obj *newList;
newList = Tcl_DuplicateObj(result);
Tcl_DecrRefCount(result);
result = newList;
}
Tcl_ListObjReplace(NULL, result, j, 1, 0, NULL);
gLength--;
}
/* Break out of for loop */
break;
}
}
if (!found && dir) {
if (Tcl_IsShared(result)) {
Tcl_Obj *newList;
newList = Tcl_DuplicateObj(result);
Tcl_DecrRefCount(result);
result = newList;
}
Tcl_ListObjAppendElement(NULL, result, mElt);
/*
* No need to increment gLength, since we
* don't want to compare mounts against
* mounts.
*/
}
}
endOfMounts:
Tcl_DecrRefCount(mounts);
return result;
}
/*
*----------------------------------------------------------------------
*
* 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).
*
*----------------------------------------------------------------------
*/
void
Tcl_FSMountsChanged(fsPtr)
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(fsPtr)
Tcl_Filesystem *fsPtr; /* The filesystem record to query. */
{
ClientData retVal = NULL;
FilesystemRecord *fsRecPtr = FsGetFirstFilesystem();
/*
* Traverse the 'filesystemList' looking for the particular node
* whose 'fsPtr' member matches 'fsPtr' and remove that one from
* the list. Ensure that the "default" node cannot be removed.
*/
while ((retVal == NULL) && (fsRecPtr != NULL)) {
if (fsRecPtr->fsPtr == fsPtr) {
retVal = fsRecPtr->clientData;
}
fsRecPtr = fsRecPtr->nextPtr;
}
return retVal;
}
/*
*---------------------------------------------------------------------------
*
* TclFSNormalizeAbsolutePath --
*
* Description:
* Takes an absolute path specification and computes a 'normalized'
* path from it.
*
* A normalized path is one which has all '../', './' removed.
* Also it is one which is in the 'standard' format for the native
* platform. On MacOS, Unix, this means the path must be free of
* symbolic links/aliases, and on Windows it means we want the
* long form, with that long form's case-dependence (which gives
* us a unique, case-dependent path).
*
* The behaviour of this function if passed a non-absolute path
* is NOT defined.
*
* Results:
* The result is returned in a Tcl_Obj with a refCount of 1,
* which is therefore owned by the caller. It must be
* freed (with Tcl_DecrRefCount) by the caller when no longer needed.
*
* Side effects:
* None (beyond the memory allocation for the result).
*
* Special note:
* This code is based on code from Matt Newman and Jean-Claude
* Wippler, with additions from Vince Darley and is copyright
* those respective authors.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr)
Tcl_Interp* interp; /* Interpreter to use */
Tcl_Obj *pathPtr; /* Absolute path to normalize */
ClientData *clientDataPtr;
{
int splen = 0, nplen, eltLen, i;
char *eltName;
Tcl_Obj *retVal;
Tcl_Obj *split;
Tcl_Obj *elt;
/* Split has refCount zero */
split = Tcl_FSSplitPath(pathPtr, &splen);
/*
* Modify the list of entries in place, by removing '.', and
* removing '..' and the entry before -- unless that entry before
* is the top-level entry, i.e. the name of a volume.
*/
nplen = 0;
for (i = 0; i < splen; i++) {
Tcl_ListObjIndex(NULL, split, nplen, &elt);
eltName = Tcl_GetStringFromObj(elt, &eltLen);
if ((eltLen == 1) && (eltName[0] == '.')) {
Tcl_ListObjReplace(NULL, split, nplen, 1, 0, NULL);
} else if ((eltLen == 2)
&& (eltName[0] == '.') && (eltName[1] == '.')) {
if (nplen > 1) {
nplen--;
Tcl_ListObjReplace(NULL, split, nplen, 2, 0, NULL);
} else {
Tcl_ListObjReplace(NULL, split, nplen, 1, 0, NULL);
}
} else {
nplen++;
}
}
if (nplen > 0) {
ClientData clientData = NULL;
retVal = Tcl_FSJoinPath(split, nplen);
/*
* Now we have an absolute path, with no '..', '.' sequences,
* but it still may not be in 'unique' form, depending on the
* platform. For instance, Unix is case-sensitive, so the
* path is ok. Windows is case-insensitive, and also has the
* weird 'longname/shortname' thing (e.g. C:/Program Files/ and
* C:/Progra~1/ are equivalent). MacOS is case-insensitive.
*
* Virtual file systems which may be registered may have
* other criteria for normalizing a path.
*/
Tcl_IncrRefCount(retVal);
TclFSNormalizeToUniquePath(interp, retVal, 0, &clientData);
/*
* Since we know it is a normalized path, we can
* actually convert this object into an "path" object for
* greater efficiency
*/
TclFSMakePathFromNormalized(interp, retVal, clientData);
if (clientDataPtr != NULL) {
*clientDataPtr = clientData;
}
} else {
/* Init to an empty string */
retVal = Tcl_NewStringObj("",0);
Tcl_IncrRefCount(retVal);
}
/*
* We increment and then decrement the refCount of split to free
* it. We do this right at the end, in case there are
* optimisations in Tcl_FSJoinPath(split, nplen) above which would
* let it make use of split more effectively if it has a refCount
* of zero. Also we can't just decrement the ref count, in case
* 'split' was actually returned by the join call above, in a
* single-element optimisation when nplen == 1.
*/
Tcl_IncrRefCount(split);
Tcl_DecrRefCount(split);
/* This has a refCount of 1 for the caller */
return retVal;
}
/*
*---------------------------------------------------------------------------
*
* TclFSNormalizeToUniquePath --
*
* Description:
* Takes a path specification containing no ../, ./ sequences,
* and converts it into a unique path for the given platform.
* On MacOS, Unix, this means the path must be free of
* symbolic links/aliases, and on Windows it means we want the
* long form, with that long form's case-dependence (which gives
* us a unique, case-dependent path).
*
* 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/macos.
*
* Important assumption: if startAt is non-zero, it must point
* to a directory separator that we know exists and is already
* normalized (so it is important not to point to the char just
* after the separator).
*---------------------------------------------------------------------------
*/
int
TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr)
Tcl_Interp *interp;
Tcl_Obj *pathPtr;
int startAt;
ClientData *clientDataPtr;
{
FilesystemRecord *fsRecPtr, *firstFsRecPtr;
/* Ignore this variable */
(void)clientDataPtr;
/*
* Call each of the "normalise path" functions in succession. This is
* a special case, in which if we have a native filesystem handler,
* we call it first. This is because the root of Tcl's filesystem
* is always a native filesystem (i.e. '/' on unix is native).
*/
firstFsRecPtr = FsGetFirstFilesystem();
fsRecPtr = firstFsRecPtr;
while (fsRecPtr != NULL) {
if (fsRecPtr == &nativeFilesystemRecord) {
Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;
if (proc != NULL) {
startAt = (*proc)(interp, pathPtr, startAt);
}
break;
}
fsRecPtr = fsRecPtr->nextPtr;
}
fsRecPtr = firstFsRecPtr;
while (fsRecPtr != NULL) {
/* Skip the native system next time through */
if (fsRecPtr != &nativeFilesystemRecord) {
Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;
if (proc != NULL) {
startAt = (*proc)(interp, pathPtr, startAt);
}
/*
* We could add an efficiency check like this:
*
* if (retVal == length-of(pathPtr)) {break;}
*
* but there's not much benefit.
*/
}
fsRecPtr = fsRecPtr->nextPtr;
}
return startAt;
}
/*
*---------------------------------------------------------------------------
*
* TclGetOpenMode --
*
* Description:
* Computes a POSIX mode mask for opening a file, from a given string,
* and also sets a flag to indicate whether the caller should seek to
* EOF after opening the file.
*
* 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.
*
* Special note:
* This code is based on a prototype implementation contributed
* by Mark Diekhans.
*
*---------------------------------------------------------------------------
*/
int
TclGetOpenMode(interp, string, seekFlagPtr)
Tcl_Interp *interp; /* Interpreter to use for error
* reporting - may be NULL. */
CONST char *string; /* Mode string, e.g. "r+" or
* "RDONLY CREAT". */
int *seekFlagPtr; /* Set this to 1 if the caller
* should seek to EOF during the
* opening of the file. */
{
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;
mode = 0;
/*
* Guard against international characters before using byte oriented
* routines.
*/
if (!(string[0] & 0x80)
&& islower(UCHAR(string[0]))) { /* INTL: ISO only. */
switch (string[0]) {
case 'r':
mode = O_RDONLY;
break;
case 'w':
mode = O_WRONLY|O_CREAT|O_TRUNC;
break;
case 'a':
mode = O_WRONLY|O_CREAT;
*seekFlagPtr = 1;
break;
default:
error:
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp,
"illegal access mode \"", string, "\"",
(char *) NULL);
}
return -1;
}
if (string[1] == '+') {
mode &= ~(O_RDONLY|O_WRONLY);
mode |= O_RDWR;
if (string[2] != 0) {
goto error;
}
} else if (string[1] != 0) {
goto error;
}
return mode;
}
/*
* 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, string, &modeArgc, &modeArgv) != TCL_OK) {
if (interp != (Tcl_Interp *) NULL) {
Tcl_AddErrorInfo(interp,
"\n while processing open access modes \"");
Tcl_AddErrorInfo(interp, string);
Tcl_AddErrorInfo(interp, "\"");
}
return -1;
}
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;
#else
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp, "access mode \"", flag,
"\" not supported by this system", (char *) NULL);
}
ckfree((char *) modeArgv);
return -1;
#endif
} else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) {
#if defined(O_NDELAY) || defined(O_NONBLOCK)
# ifdef O_NONBLOCK
mode |= O_NONBLOCK;
# else
mode |= O_NDELAY;
# endif
#else
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp, "access mode \"", flag,
"\" not supported by this system", (char *) NULL);
}
ckfree((char *) modeArgv);
return -1;
#endif
} else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) {
mode |= O_TRUNC;
} else {
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp, "invalid access mode \"", flag,
"\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT",
" EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL);
}
ckfree((char *) modeArgv);
return -1;
}
}
ckfree((char *) modeArgv);
if (!gotRW) {
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp, "access mode must include either",
" RDONLY, WRONLY, or RDWR", (char *) NULL);
}
return -1;
}
return mode;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSEvalFile --
*
* 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).
*
*----------------------------------------------------------------------
*/
int
Tcl_FSEvalFile(interp, pathPtr)
Tcl_Interp *interp; /* Interpreter in which to process file. */
Tcl_Obj *pathPtr; /* Path of file to process. Tilde-substitution
* will be performed on this name. */
{
int result, length;
Tcl_StatBuf statBuf;
Tcl_Obj *oldScriptFile;
Interp *iPtr;
char *string;
Tcl_Channel chan;
Tcl_Obj *objPtr;
if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
return TCL_ERROR;
}
result = TCL_ERROR;
objPtr = Tcl_NewObj();
if (Tcl_FSStat(pathPtr, &statBuf) == -1) {
Tcl_SetErrno(errno);
Tcl_AppendResult(interp, "couldn't read file \"",
Tcl_GetString(pathPtr),
"\": ", Tcl_PosixError(interp), (char *) NULL);
goto end;
}
chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644);
if (chan == (Tcl_Channel) NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't read file \"",
Tcl_GetString(pathPtr),
"\": ", Tcl_PosixError(interp), (char *) NULL);
goto end;
}
/*
* The eofchar is \32 (^Z). This is the usual on Windows, but we
* effect this cross-platform to allow for scripted documents.
* [Bug: 2040]
*/
Tcl_SetChannelOption(interp, chan, "-eofchar", "\32");
if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) {
Tcl_Close(interp, chan);
Tcl_AppendResult(interp, "couldn't read file \"",
Tcl_GetString(pathPtr),
"\": ", Tcl_PosixError(interp), (char *) NULL);
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);
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) {
char msg[200 + TCL_INTEGER_SPACE];
/*
* Record information telling where the error occurred.
*/
sprintf(msg, "\n (file \"%.150s\" line %d)", Tcl_GetString(pathPtr),
interp->errorLine);
Tcl_AddErrorInfo(interp, msg);
}
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.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetErrno()
{
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.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetErrno(err)
int err; /* The new value. */
{
errno = err;
}
/*
*----------------------------------------------------------------------
*
* Tcl_PosixError --
*
* This procedure is typically called after UNIX kernel calls
* return errors. It stores machine-readable information about
* the error in $errorCode returns an information string for
* the caller's use.
*
* Results:
* The return value is a human-readable string describing the
* error.
*
* Side effects:
* The global variable $errorCode is reset.
*
*----------------------------------------------------------------------
*/
CONST char *
Tcl_PosixError(interp)
Tcl_Interp *interp; /* Interpreter whose $errorCode variable
* is to be changed. */
{
CONST char *id, *msg;
msg = Tcl_ErrnoMsg(errno);
id = Tcl_ErrnoId();
Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL);
return msg;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSStat --
*
* This procedure replaces the library version of stat and lsat.
*
* The appropriate function for the filesystem to which pathPtr
* belongs will be called.
*
* Results:
* See stat documentation.
*
* Side effects:
* See stat documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSStat(pathPtr, buf)
Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */
Tcl_StatBuf *buf; /* Filled with results of stat call. */
{
Tcl_Filesystem *fsPtr;
#ifdef USE_OBSOLETE_FS_HOOKS
struct stat oldStyleStatBuffer;
int retVal = -1;
/*
* Call each of the "stat" function in succession. A non-return
* value of -1 indicates the particular function has succeeded.
*/
Tcl_MutexLock(&obsoleteFsHookMutex);
if (statProcList != NULL) {
StatProc *statProcPtr;
char *path;
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (transPtr == NULL) {
path = NULL;
} else {
path = Tcl_GetString(transPtr);
}
statProcPtr = statProcList;
while ((retVal == -1) && (statProcPtr != NULL)) {
retVal = (*statProcPtr->proc)(path, &oldStyleStatBuffer);
statProcPtr = statProcPtr->nextPtr;
}
if (transPtr != NULL) {
Tcl_DecrRefCount(transPtr);
}
}
Tcl_MutexUnlock(&obsoleteFsHookMutex);
if (retVal != -1) {
/*
* Note that EOVERFLOW is not a problem here, and these
* assignments should all be widening (if not identity.)
*/
buf->st_mode = oldStyleStatBuffer.st_mode;
buf->st_ino = oldStyleStatBuffer.st_ino;
buf->st_dev = oldStyleStatBuffer.st_dev;
buf->st_rdev = oldStyleStatBuffer.st_rdev;
buf->st_nlink = oldStyleStatBuffer.st_nlink;
buf->st_uid = oldStyleStatBuffer.st_uid;
buf->st_gid = oldStyleStatBuffer.st_gid;
buf->st_size = Tcl_LongAsWide(oldStyleStatBuffer.st_size);
buf->st_atime = oldStyleStatBuffer.st_atime;
buf->st_mtime = oldStyleStatBuffer.st_mtime;
buf->st_ctime = oldStyleStatBuffer.st_ctime;
#ifdef HAVE_ST_BLOCKS
buf->st_blksize = oldStyleStatBuffer.st_blksize;
buf->st_blocks = Tcl_LongAsWide(oldStyleStatBuffer.st_blocks);
#endif
return retVal;
}
#endif /* USE_OBSOLETE_FS_HOOKS */
fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSStatProc *proc = fsPtr->statProc;
if (proc != NULL) {
return (*proc)(pathPtr, buf);
}
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSLstat --
*
* This procedure replaces the library version of lstat.
* The appropriate function for the filesystem to which pathPtr
* belongs will be called. If no 'lstat' function is listed,
* but a 'stat' function is, then Tcl will fall back on the
* stat function.
*
* Results:
* See lstat documentation.
*
* Side effects:
* See lstat documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSLstat(pathPtr, buf)
Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */
Tcl_StatBuf *buf; /* Filled with results of stat call. */
{
Tcl_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 procedure 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.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSAccess(pathPtr, mode)
Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */
int mode; /* Permission setting. */
{
Tcl_Filesystem *fsPtr;
#ifdef USE_OBSOLETE_FS_HOOKS
int retVal = -1;
/*
* Call each of the "access" function in succession. A non-return
* value of -1 indicates the particular function has succeeded.
*/
Tcl_MutexLock(&obsoleteFsHookMutex);
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(interp, pathPtr, modeString, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
Tcl_Obj *pathPtr; /* Name of file to open. */
CONST char *modeString; /* A list of POSIX open modes or
* a string such as "rw". */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
Tcl_Filesystem *fsPtr;
#ifdef USE_OBSOLETE_FS_HOOKS
Tcl_Channel retVal = NULL;
/*
* Call each of the "Tcl_OpenFileChannel" functions in succession.
* A non-NULL return value indicates the particular function has
* succeeded.
*/
Tcl_MutexLock(&obsoleteFsHookMutex);
if (openFileChannelProcList != NULL) {
OpenFileChannelProc *openFileChannelProcPtr;
char *path;
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
if (transPtr == NULL) {
path = NULL;
} else {
path = Tcl_GetString(transPtr);
}
openFileChannelProcPtr = openFileChannelProcList;
while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) {
retVal = (*openFileChannelProcPtr->proc)(interp, path,
modeString, permissions);
openFileChannelProcPtr = openFileChannelProcPtr->nextPtr;
}
if (transPtr != NULL) {
Tcl_DecrRefCount(transPtr);
}
}
Tcl_MutexUnlock(&obsoleteFsHookMutex);
if (retVal != NULL) {
return retVal;
}
#endif /* USE_OBSOLETE_FS_HOOKS */
/*
* We need this just to ensure we return the correct error messages
* under some circumstances.
*/
if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
return NULL;
}
fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc;
if (proc != NULL) {
int mode, seekFlag;
mode = TclGetOpenMode(interp, modeString, &seekFlag);
if (mode == -1) {
return NULL;
}
retVal = (*proc)(interp, pathPtr, mode, permissions);
if (retVal != NULL) {
if (seekFlag) {
if (Tcl_Seek(retVal, (Tcl_WideInt)0,
SEEK_END) < (Tcl_WideInt)0) {
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp,
"could not seek to end of file while opening \"",
Tcl_GetString(pathPtr), "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
Tcl_Close(NULL, retVal);
return NULL;
}
}
}
return retVal;
}
}
/* File doesn't belong to any filesystem that can open it */
Tcl_SetErrno(ENOENT);
if (interp != NULL) {
Tcl_AppendResult(interp, "couldn't open \"",
Tcl_GetString(pathPtr), "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSUtime --
*
* This procedure 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.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSUtime (pathPtr, tval)
Tcl_Obj *pathPtr; /* File to change access/modification times */
struct utimbuf *tval; /* Structure containing access/modification
* times to use. Should not be modified. */
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSUtimeProc *proc = fsPtr->utimeProc;
if (proc != NULL) {
return (*proc)(pathPtr, tval);
}
}
return -1;
}
/*
*----------------------------------------------------------------------
*
* NativeFileAttrStrings --
*
* This procedure implements the platform dependent 'file
* attributes' subcommand, for the native filesystem, for listing
* the set of possible attribute strings. This function is part
* of Tcl's native filesystem support, and is placed here because
* it is shared by Unix, MacOS and Windows code.
*
* Results:
* An array of strings
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static CONST char**
NativeFileAttrStrings(pathPtr, objPtrRef)
Tcl_Obj *pathPtr;
Tcl_Obj** objPtrRef;
{
return tclpFileAttrStrings;
}
/*
*----------------------------------------------------------------------
*
* NativeFileAttrsGet --
*
* This procedure implements the platform dependent
* 'file attributes' subcommand, for the native
* filesystem, for 'get' operations. This function is part
* of Tcl's native filesystem support, and is placed here
* because it is shared by Unix, MacOS and Windows code.
*
* 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 int
NativeFileAttrsGet(interp, index, pathPtr, objPtrRef)
Tcl_Interp *interp; /* The interpreter for error reporting. */
int index; /* index of the attribute command. */
Tcl_Obj *pathPtr; /* path of file we are operating on. */
Tcl_Obj **objPtrRef; /* for output. */
{
return (*tclpFileAttrProcs[index].getProc)(interp, index,
pathPtr, objPtrRef);
}
/*
*----------------------------------------------------------------------
*
* NativeFileAttrsSet --
*
* This procedure implements the platform dependent
* 'file attributes' subcommand, for the native
* filesystem, for 'set' operations. This function is part
* of Tcl's native filesystem support, and is placed here
* because it is shared by Unix, MacOS and Windows code.
*
* Results:
* Standard Tcl return code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
NativeFileAttrsSet(interp, index, pathPtr, objPtr)
Tcl_Interp *interp; /* The interpreter for error reporting. */
int index; /* index of the attribute command. */
Tcl_Obj *pathPtr; /* path of file we are operating on. */
Tcl_Obj *objPtr; /* set to this value. */
{
return (*tclpFileAttrProcs[index].setProc)(interp, index,
pathPtr, objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSFileAttrStrings --
*
* This procedure implements part of the hookable 'file
* attributes' subcommand. The appropriate function for the
* filesystem to which pathPtr belongs will be called.
*
* Results:
* The called procedure may either return an array of strings,
* or may instead return NULL and place a Tcl list into the
* given objPtrRef. Tcl will take that list and first increment
* its refCount before using it. On completion of that use, Tcl
* will decrement its refCount. Hence if the list should be
* disposed of by Tcl when done, it should have a refCount of zero,
* and if the list should not be disposed of, the filesystem
* should ensure it retains a refCount on the object.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
CONST char **
Tcl_FSFileAttrStrings(pathPtr, objPtrRef)
Tcl_Obj* pathPtr;
Tcl_Obj** objPtrRef;
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc;
if (proc != NULL) {
return (*proc)(pathPtr, objPtrRef);
}
}
Tcl_SetErrno(ENOENT);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSFileAttrsGet --
*
* This procedure implements read access for the hookable 'file
* attributes' subcommand. The appropriate function for the
* filesystem to which pathPtr belongs will be called.
*
* Results:
* Standard Tcl return code. The object placed in objPtrRef
* (if TCL_OK was returned) is likely to have a refCount of zero.
* Either way we must either store it somewhere (e.g. the Tcl
* result), or Incr/Decr its refCount to ensure it is properly
* freed.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSFileAttrsGet(interp, index, pathPtr, objPtrRef)
Tcl_Interp *interp; /* The interpreter for error reporting. */
int index; /* index of the attribute command. */
Tcl_Obj *pathPtr; /* filename we are operating on. */
Tcl_Obj **objPtrRef; /* for output. */
{
Tcl_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 procedure 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.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr)
Tcl_Interp *interp; /* The interpreter for error reporting. */
int index; /* index of the attribute command. */
Tcl_Obj *pathPtr; /* filename we are operating on. */
Tcl_Obj *objPtr; /* Input value. */
{
Tcl_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 synchronise this with the cwd's containing filesystem,
* if that filesystem provides a cwdProc (e.g. the native filesystem).
*
* Note that if Tcl's cwd is not in the native filesystem, then of
* course Tcl's cwd and the native cwd are different: extensions
* should therefore ensure they only access the cwd through this
* function to avoid confusion.
*
* 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(interp)
Tcl_Interp *interp;
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
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();
while ((retVal == NULL) && (fsRecPtr != NULL)) {
Tcl_FSGetCwdProc *proc = fsRecPtr->fsPtr->getCwdProc;
if (proc != NULL) {
retVal = (*proc)(interp);
}
fsRecPtr = fsRecPtr->nextPtr;
}
/*
* Now the 'cwd' may NOT be normalized, at least on some
* platforms. For the sake of efficiency, we want a completely
* normalized cwd at all times.
*
* Finally, if retVal is NULL, we do not have a cwd, which
* could be problematic.
*/
if (retVal != NULL) {
Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL);
if (norm != NULL) {
/*
* We found a cwd, which is now in our global storage.
* We must make a copy. Norm already has a refCount of 1.
*
* Threading issue: note that multiple threads at system
* startup could in principle call this procedure
* simultaneously. They will therefore each set the
* cwdPathPtr independently. That behaviour is a bit
* peculiar, but should be fine. Once we have a cwd,
* we'll always be in the 'else' branch below which
* is simpler.
*/
FsUpdateCwd(norm);
}
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.
*/
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;
if (proc != NULL) {
Tcl_Obj *retVal = (*proc)(interp);
if (retVal != NULL) {
Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL);
/*
* Check whether cwd has changed from the value
* previously stored in cwdPathPtr. Really 'norm'
* shouldn't be null, but we are careful.
*/
if (norm == NULL) {
/* Do nothing */
} else if (Tcl_FSEqualPaths(tsdPtr->cwdPathPtr, norm)) {
/*
* If the paths were equal, we can be more
* efficient and retain the old path object
* which will probably already be shared. In
* this case we can simply free the normalized
* path we just calculated.
*/
Tcl_DecrRefCount(norm);
} else {
FsUpdateCwd(norm);
}
Tcl_DecrRefCount(retVal);
} else {
/* The 'cwd' function returned an error; reset the cwd */
FsUpdateCwd(NULL);
}
}
}
}
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.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSChdir(pathPtr)
Tcl_Obj *pathPtr;
{
Tcl_Filesystem *fsPtr;
int retVal = -1;
if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) {
return TCL_ERROR;
}
fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSChdirProc *proc = fsPtr->chdirProc;
if (proc != NULL) {
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 ((Tcl_FSStat(pathPtr, &buf) == 0)
&& (S_ISDIR(buf.st_mode))
&& (Tcl_FSAccess(pathPtr, R_OK) == 0)) {
/* We allow the chdir */
retVal = 0;
}
}
}
if (retVal != -1) {
/*
* The cwd changed, or an error was thrown. If an error was
* thrown, we can just continue (and that will report the error
* to the user). If there was no error we must assume that the
* cwd was actually changed to the normalized value we
* calculated above, and we must therefore cache that
* information.
*/
if (retVal == TCL_OK) {
/*
* Note that this normalized path may be different to what
* we found above (or at least a different object), if the
* filesystem epoch changed recently. This can actually
* happen with scripted documents very easily. Therefore
* we ask for the normalized path again (the correct value
* will have been cached as a result of the
* Tcl_FSGetFileSystemForPath call above anyway).
*/
Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normDirName == NULL) {
return TCL_ERROR;
}
FsUpdateCwd(normDirName);
}
} else {
Tcl_SetErrno(ENOENT);
}
return (retVal);
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSLoadFile --
*
* Dynamically loads a binary code file into memory and returns
* the addresses of two procedures within that file, if they are
* defined. The appropriate function for the filesystem to which
* pathPtr belongs will be called.
*
* Note that the native filesystem doesn't actually assume
* 'pathPtr' is a path. Rather it assumes filename is either
* a path or just the name of a file which can be found somewhere
* in the environment's loadable path. This behaviour is not
* very compatible with virtual filesystems (and has other problems
* documented in the load man-page), so it is advised that full
* paths are always used.
*
* 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.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
handlePtr, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Obj *pathPtr; /* Name of the file containing the desired
* code. */
CONST char *sym1, *sym2; /* Names of two procedures to look up in
* the file's symbol table. */
Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
/* Where to return the addresses corresponding
* to sym1 and sym2. */
Tcl_LoadHandle *handlePtr; /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr;
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for
* this file. */
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSLoadFileProc *proc = fsPtr->loadFileProc;
if (proc != NULL) {
int retVal = (*proc)(interp, pathPtr, handlePtr, unloadProcPtr);
if (retVal != TCL_OK) {
return retVal;
}
if (*handlePtr == NULL) {
return TCL_ERROR;
}
if (sym1 != NULL) {
*proc1Ptr = TclpFindSymbol(interp, *handlePtr, sym1);
}
if (sym2 != NULL) {
*proc2Ptr = TclpFindSymbol(interp, *handlePtr, sym2);
}
return retVal;
} else {
Tcl_Filesystem *copyFsPtr;
Tcl_Obj *copyToPtr;
/* First check if it is readable -- and exists! */
if (Tcl_FSAccess(pathPtr, R_OK) != 0) {
Tcl_AppendResult(interp, "couldn't load library \"",
Tcl_GetString(pathPtr), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
/*
* Get a temporary filename to use, first to
* copy the file into, and then to load.
*/
copyToPtr = TclpTempFileName();
if (copyToPtr == NULL) {
return -1;
}
Tcl_IncrRefCount(copyToPtr);
copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr);
if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) {
/*
* We already know we can't use Tcl_FSLoadFile from
* this filesystem, and we must avoid a possible
* infinite loop. Try to delete the file we
* probably created, and then exit.
*/
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
return -1;
}
if (TclCrossFilesystemCopy(interp, pathPtr,
copyToPtr) == TCL_OK) {
Tcl_LoadHandle newLoadHandle = NULL;
Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL;
FsDivertLoad *tvdlPtr;
int retVal;
#if !defined(__WIN32__) && !defined(MAC_TCL)
/*
* Do we need to set appropriate permissions
* on the file? This may be required on some
* systems. On Unix we could loop over
* the file attributes, and set any that are
* called "-permissions" to 0700. However,
* we just do this directly, like this:
*/
Tcl_Obj* perm = Tcl_NewStringObj("0700",-1);
Tcl_IncrRefCount(perm);
Tcl_FSFileAttrsSet(NULL, 2, copyToPtr, perm);
Tcl_DecrRefCount(perm);
#endif
/*
* We need to reset the result now, because the cross-
* filesystem copy may have stored the number of bytes
* in the result
*/
Tcl_ResetResult(interp);
retVal = Tcl_FSLoadFile(interp, copyToPtr, sym1, sym2,
proc1Ptr, proc2Ptr,
&newLoadHandle,
&newUnloadProcPtr);
if (retVal != TCL_OK) {
/* The file didn't load successfully */
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
return retVal;
}
/*
* Try to delete the file immediately -- this is
* possible in some OSes, and avoids any worries
* about leaving the copy laying around on exit.
*/
if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) {
Tcl_DecrRefCount(copyToPtr);
/*
* We tell our caller about the real shared
* library which was loaded. Note that this
* does mean that the package list maintained
* by 'load' will store the original (vfs)
* path alongside the temporary load handle
* and unload proc ptr.
*/
(*handlePtr) = newLoadHandle;
(*unloadProcPtr) = newUnloadProcPtr;
return TCL_OK;
}
/*
* When we unload this file, we need to divert the
* unloading so we can unload and cleanup the
* temporary file correctly.
*/
tvdlPtr = (FsDivertLoad*) ckalloc(sizeof(FsDivertLoad));
/*
* Remember three pieces of information. This allows
* us to cleanup the diverted load completely, on
* platforms which allow proper unloading of code.
*/
tvdlPtr->loadHandle = newLoadHandle;
tvdlPtr->unloadProcPtr = newUnloadProcPtr;
if (copyFsPtr != &tclNativeFilesystem) {
/* copyToPtr is already incremented for this reference */
tvdlPtr->divertedFile = copyToPtr;
/*
* This is the filesystem we loaded it into. Since
* we have a reference to 'copyToPtr', we already
* have a refCount on this filesystem, so we don't
* need to worry about it disappearing on us.
*/
tvdlPtr->divertedFilesystem = copyFsPtr;
tvdlPtr->divertedFileNativeRep = NULL;
} else {
/* We need the native rep */
tvdlPtr->divertedFileNativeRep =
NativeDupInternalRep(Tcl_FSGetInternalRep(copyToPtr,
copyFsPtr));
/*
* We don't need or want references to the copied
* Tcl_Obj or the filesystem if it is the native
* one.
*/
tvdlPtr->divertedFile = NULL;
tvdlPtr->divertedFilesystem = NULL;
Tcl_DecrRefCount(copyToPtr);
}
copyToPtr = NULL;
(*handlePtr) = (Tcl_LoadHandle) tvdlPtr;
(*unloadProcPtr) = &FSUnloadTempFile;
return retVal;
} else {
/* Cross-platform copy failed */
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
return TCL_ERROR;
}
}
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
* This function used to be in the platform specific directories, but it
* has now been made to work cross-platform
*/
int
TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
clientDataPtr, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Obj *pathPtr; /* Name of the file containing the desired
* code (UTF-8). */
CONST char *sym1, *sym2; /* Names of two procedures to look up in
* the file's symbol table. */
Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
/* Where to return the addresses corresponding
* to sym1 and sym2. */
ClientData *clientDataPtr; /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr;
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for
* this file. */
{
Tcl_LoadHandle handle = NULL;
int res;
res = TclpDlopen(interp, pathPtr, &handle, unloadProcPtr);
if (res != TCL_OK) {
return res;
}
if (handle == NULL) {
return TCL_ERROR;
}
*clientDataPtr = (ClientData)handle;
*proc1Ptr = TclpFindSymbol(interp, handle, sym1);
*proc2Ptr = TclpFindSymbol(interp, handle, sym2);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* FSUnloadTempFile --
*
* 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.
*
*---------------------------------------------------------------------------
*/
static void
FSUnloadTempFile(loadHandle)
Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
* to Tcl_FSLoadFile(). The loadHandle is
* a token that represents the loaded
* file. */
{
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(pathPtr, toPtr, linkAction)
Tcl_Obj *pathPtr; /* Path of file to readlink or link */
Tcl_Obj *toPtr; /* NULL or path to be linked to */
int linkAction; /* Action to perform */
{
Tcl_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;
#else
Tcl_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();
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;
}
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(pathPtr, pattern)
Tcl_Obj *pathPtr; /* Contains path to directory to search. */
CONST char *pattern; /* Pattern to match against. */
{
FilesystemRecord *fsRecPtr;
Tcl_GlobTypeData mountsOnly = { TCL_GLOB_TYPE_MOUNT, 0, NULL, NULL };
Tcl_Obj *resultPtr = NULL;
/*
* Call each of the "listMounts" functions in succession.
* A non-NULL return value indicates the particular function has
* succeeded. We call all the functions registered, since we want
* a list from each filesystems.
*/
fsRecPtr = FsGetFirstFilesystem();
while (fsRecPtr != NULL) {
if (fsRecPtr != &nativeFilesystemRecord) {
Tcl_FSMatchInDirectoryProc *proc =
fsRecPtr->fsPtr->matchInDirectoryProc;
if (proc != NULL) {
if (resultPtr == NULL) {
resultPtr = Tcl_NewObj();
}
(*proc)(NULL, resultPtr, pathPtr, pattern, &mountsOnly);
}
}
fsRecPtr = fsRecPtr->nextPtr;
}
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(pathPtr, lenPtr)
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 (FSGetPathType(pathPtr, &fsPtr, &driveNameLength)
== TCL_PATH_ABSOLUTE) {
if (fsPtr == &tclNativeFilesystem) {
return TclpNativeSplitPath(pathPtr, lenPtr);
}
} else {
return TclpNativeSplitPath(pathPtr, lenPtr);
}
/* We assume separators are single characters */
if (fsPtr->filesystemSeparatorProc != NULL) {
Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(pathPtr);
if (sep != NULL) {
separator = Tcl_GetString(sep)[0];
}
}
/*
* 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] == '~') {
nextElt = Tcl_NewStringObj("./",2);
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) {
Tcl_ListObjLength(NULL, result, lenPtr);
}
return result;
}
/* Simple helper function */
Tcl_Obj*
TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr)
Tcl_Filesystem *fromFilesystem;
ClientData clientData;
FilesystemRecord **fsRecPtrPtr;
{
FilesystemRecord *fsRecPtr = FsGetFirstFilesystem();
while (fsRecPtr != NULL) {
if (fsRecPtr->fsPtr == fromFilesystem) {
*fsRecPtrPtr = fsRecPtr;
break;
}
fsRecPtr = fsRecPtr->nextPtr;
}
if ((fsRecPtr != NULL)
&& (fromFilesystem->internalToNormalizedProc != NULL)) {
return (*fromFilesystem->internalToNormalizedProc)(clientData);
} else {
return NULL;
}
}
/*
*----------------------------------------------------------------------
*
* GetPathType --
*
* 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
GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef)
Tcl_Obj *pathObjPtr;
Tcl_Filesystem **filesystemPtrPtr;
int *driveNameLengthPtr;
Tcl_Obj **driveNameRef;
{
FilesystemRecord *fsRecPtr;
int pathLen;
char *path;
Tcl_PathType type = TCL_PATH_RELATIVE;
path = Tcl_GetStringFromObj(pathObjPtr, &pathLen);
/*
* Call each of the "listVolumes" function in succession, checking
* whether the given path is an absolute path on any of the volumes
* returned (this is done by checking whether the path's prefix
* matches).
*/
fsRecPtr = FsGetFirstFilesystem();
while (fsRecPtr != NULL) {
Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc;
/*
* We want to skip the native filesystem in this loop because
* otherwise we won't necessarily pass all the Tcl testsuite --
* this is because some of the tests artificially change the
* current platform (between mac, win, unix) but the list
* of volumes we get by calling (*proc) will reflect the current
* (real) platform only and this may cause some tests to fail.
* In particular, on unix '/' will match the beginning of
* certain absolute Windows paths starting '//' and those tests
* will go wrong.
*
* Besides these test-suite issues, there is one other reason
* to skip the native filesystem --- since the tclFilename.c
* code has nice fast 'absolute path' checkers, we don't want
* to waste time repeating that effort here, and this
* function is actually called quite often, so if we can
* save the overhead of the native filesystem returning us
* a list of volumes all the time, it is better.
*/
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 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;
}
if (type != TCL_PATH_ABSOLUTE) {
type = TclpGetNativePathType(pathObjPtr, driveNameLengthPtr,
driveNameRef);
if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) {
*filesystemPtrPtr = &tclNativeFilesystem;
}
}
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.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSRenameFile(srcPathPtr, destPathPtr)
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;
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.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSCopyFile(srcPathPtr, destPathPtr)
Tcl_Obj* srcPathPtr; /* Pathname of file to be copied (UTF-8). */
Tcl_Obj *destPathPtr; /* Pathname of file to copy to (UTF-8). */
{
int retVal = -1;
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.
*
*---------------------------------------------------------------------------
*/
int
TclCrossFilesystemCopy(interp, source, target)
Tcl_Interp *interp; /* For error messages */
Tcl_Obj *source; /* Pathname of file to be copied (UTF-8). */
Tcl_Obj *target; /* Pathname of file to copy to (UTF-8). */
{
int result = TCL_ERROR;
int prot = 0666;
Tcl_Channel out = Tcl_FSOpenFileChannel(interp, target, "w", prot);
if (out != NULL) {
/* It looks like we can copy it over */
Tcl_Channel in = Tcl_FSOpenFileChannel(interp, source,
"r", prot);
if (in == NULL) {
/* This is very strange, we checked this above */
Tcl_Close(interp, out);
} else {
Tcl_StatBuf sourceStatBuf;
struct utimbuf tval;
/*
* Copy it synchronously. We might wish to add an
* asynchronous option to support vfs's which are
* slow (e.g. network sockets).
*/
Tcl_SetChannelOption(interp, in, "-translation", "binary");
Tcl_SetChannelOption(interp, out, "-translation", "binary");
if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) {
result = TCL_OK;
}
/*
* If the copy failed, assume that copy channel left
* a good error message.
*/
Tcl_Close(interp, in);
Tcl_Close(interp, out);
/* Set modification date of copied file */
if (Tcl_FSLstat(source, &sourceStatBuf) == 0) {
tval.actime = sourceStatBuf.st_atime;
tval.modtime = sourceStatBuf.st_mtime;
Tcl_FSUtime(target, &tval);
}
}
}
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.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSDeleteFile(pathPtr)
Tcl_Obj *pathPtr; /* Pathname of file to be removed (UTF-8). */
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSDeleteFileProc *proc = fsPtr->deleteFileProc;
if (proc != NULL) {
return (*proc)(pathPtr);
}
}
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.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSCreateDirectory(pathPtr)
Tcl_Obj *pathPtr; /* Pathname of directory to create (UTF-8). */
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSCreateDirectoryProc *proc = fsPtr->createDirectoryProc;
if (proc != NULL) {
return (*proc)(pathPtr);
}
}
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.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
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;
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.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr)
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. */
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSRemoveDirectoryProc *proc = fsPtr->removeDirectoryProc;
if (proc != NULL) {
if (recursive) {
/*
* We check whether the cwd lies inside this directory
* and move it if it does.
*/
Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL);
if (cwdPtr != NULL) {
char *cwdStr, *normPathStr;
int cwdLen, normLen;
Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normPath != NULL) {
normPathStr = Tcl_GetStringFromObj(normPath, &normLen);
cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
if ((cwdLen >= normLen) && (strncmp(normPathStr,
cwdStr, (size_t) normLen) == 0)) {
/*
* the cwd is inside the directory, so we
* perform a 'cd [file dirname $path]'
*/
Tcl_Obj *dirPtr = TclFileDirname(NULL, pathPtr);
Tcl_FSChdir(dirPtr);
Tcl_DecrRefCount(dirPtr);
}
}
Tcl_DecrRefCount(cwdPtr);
}
}
return (*proc)(pathPtr, recursive, errorPtr);
}
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSGetFileSystemForPath --
*
* This function determines which filesystem to use for a
* particular path object, and returns the filesystem which
* accepts this file. If no filesystem will accept this object
* as a valid file path, then NULL is returned.
*
* Results:
.* NULL or a filesystem which will accept this path.
*
* Side effects:
* The object may be converted to a path type.
*
*---------------------------------------------------------------------------
*/
Tcl_Filesystem*
Tcl_FSGetFileSystemForPath(pathObjPtr)
Tcl_Obj* pathObjPtr;
{
FilesystemRecord *fsRecPtr;
Tcl_Filesystem* retVal = NULL;
/*
* If the object has a refCount of zero, we reject it. This
* is to avoid possible segfaults or nondeterministic memory
* leaks (i.e. the user doesn't know if they should decrement
* the ref count on return or not).
*/
if (pathObjPtr->refCount == 0) {
panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0");
return NULL;
}
/*
* Check if the filesystem has changed in some way since
* this object's internal representation was calculated.
*/
if (TclFSEnsureEpochOk(pathObjPtr, &retVal) != TCL_OK) {
return NULL;
}
/*
* Call each of the "pathInFilesystem" functions in succession. A
* non-return value of -1 indicates the particular function has
* succeeded.
*/
fsRecPtr = FsGetFirstFilesystem();
while ((retVal == NULL) && (fsRecPtr != NULL)) {
Tcl_FSPathInFilesystemProc *proc = fsRecPtr->fsPtr->pathInFilesystemProc;
if (proc != NULL) {
ClientData clientData = NULL;
int ret = (*proc)(pathObjPtr, &clientData);
if (ret != -1) {
/*
* We assume the type of pathObjPtr hasn't been changed
* by the above call to the pathInFilesystemProc.
*/
TclFSSetPathDetails(pathObjPtr, fsRecPtr, clientData);
retVal = fsRecPtr->fsPtr;
}
}
fsRecPtr = fsRecPtr->nextPtr;
}
return retVal;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSGetNativePath --
*
* This function is for use by the Win/Unix/MacOS native filesystems,
* so that they can easily retrieve the native (char* or TCHAR*)
* representation of a path. Other filesystems will probably
* want to implement similar functions. They basically act as a
* safety net around Tcl_FSGetInternalRep. Normally your file-
* system procedures will always be called with path objects
* already converted to the correct filesystem, but if for
* some reason they are called directly (i.e. by procedures
* not in this file), then one cannot necessarily guarantee that
* the path object pointer is from the correct filesystem.
*
* Note: in the future it might be desireable to have separate
* versions of this function with different signatures, for
* example Tcl_FSGetNativeMacPath, Tcl_FSGetNativeUnixPath etc.
* Right now, since native paths are all string based, we use just
* one function. On MacOS we could possibly use an FSSpec or
* FSRef as the native representation.
*
* Results:
* NULL or a valid native path.
*
* Side effects:
* See Tcl_FSGetInternalRep.
*
*---------------------------------------------------------------------------
*/
CONST char *
Tcl_FSGetNativePath(pathObjPtr)
Tcl_Obj *pathObjPtr;
{
return (CONST char *)Tcl_FSGetInternalRep(pathObjPtr, &tclNativeFilesystem);
}
/*
*---------------------------------------------------------------------------
*
* NativeCreateNativeRep --
*
* Create a native representation for the given path.
*
* Results:
* None.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static ClientData
NativeCreateNativeRep(pathObjPtr)
Tcl_Obj* pathObjPtr;
{
char *nativePathPtr;
Tcl_DString ds;
Tcl_Obj* validPathObjPtr;
int len;
char *str;
/* Make sure the normalized path is set */
validPathObjPtr = Tcl_FSGetNormalizedPath(NULL, pathObjPtr);
str = Tcl_GetStringFromObj(validPathObjPtr, &len);
#ifdef __WIN32__
Tcl_WinUtfToTChar(str, len, &ds);
if (tclWinProcs->useWide) {
len = Tcl_DStringLength(&ds) + sizeof(WCHAR);
} else {
len = Tcl_DStringLength(&ds) + sizeof(char);
}
#else
Tcl_UtfToExternalDString(NULL, str, len, &ds);
len = Tcl_DStringLength(&ds) + sizeof(char);
#endif
nativePathPtr = ckalloc((unsigned) len);
memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len);
Tcl_DStringFree(&ds);
return (ClientData)nativePathPtr;
}
/*
*---------------------------------------------------------------------------
*
* TclpNativeToNormalized --
*
* Convert native format to a normalized path object, with refCount
* of zero.
*
* Results:
* A valid normalized path.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
TclpNativeToNormalized(clientData)
ClientData clientData;
{
Tcl_DString ds;
Tcl_Obj *objPtr;
CONST char *copy;
int len;
#ifdef __WIN32__
Tcl_WinTCharToUtf((CONST char*)clientData, -1, &ds);
#else
Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds);
#endif
copy = Tcl_DStringValue(&ds);
len = Tcl_DStringLength(&ds);
#ifdef __WIN32__
/*
* Certain native path representations on Windows have this special
* prefix to indicate that they are to be treated specially. For
* example extremely long paths, or symlinks
*/
if (*copy == '\\') {
if (0 == strncmp(copy,"\\??\\",4)) {
copy += 4;
len -= 4;
} else if (0 == strncmp(copy,"\\\\?\\",4)) {
copy += 4;
len -= 4;
}
}
#endif
objPtr = Tcl_NewStringObj(copy,len);
Tcl_DStringFree(&ds);
return objPtr;
}
/*
*---------------------------------------------------------------------------
*
* NativeDupInternalRep --
*
* Duplicate the native representation.
*
* Results:
* The copied native representation, or NULL if it is not possible
* to copy the representation.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
ClientData
NativeDupInternalRep(clientData)
ClientData clientData;
{
ClientData copy;
size_t len;
if (clientData == NULL) {
return NULL;
}
#ifdef __WIN32__
if (tclWinProcs->useWide) {
/* unicode representation when running on NT/2K/XP */
len = sizeof(WCHAR) + (wcslen((CONST WCHAR*)clientData) * sizeof(WCHAR));
} else {
/* ansi representation when running on 95/98/ME */
len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char));
}
#else
/* ansi representation when running on Unix/MacOS */
len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char));
#endif
copy = (ClientData) ckalloc(len);
memcpy((VOID*)copy, (VOID*)clientData, len);
return copy;
}
/*
*---------------------------------------------------------------------------
*
* NativeFreeInternalRep --
*
* Free a native internal representation, which will be non-NULL.
*
* Results:
* None.
*
* Side effects:
* Memory is released.
*
*---------------------------------------------------------------------------
*/
static void
NativeFreeInternalRep(clientData)
ClientData clientData;
{
ckfree((char*)clientData);
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSFileSystemInfo --
*
* 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(pathObjPtr)
Tcl_Obj* pathObjPtr;
{
Tcl_Obj *resPtr;
Tcl_FSFilesystemPathTypeProc *proc;
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr);
if (fsPtr == NULL) {
return NULL;
}
resPtr = Tcl_NewListObj(0,NULL);
Tcl_ListObjAppendElement(NULL, resPtr,
Tcl_NewStringObj(fsPtr->typeName,-1));
proc = fsPtr->filesystemPathTypeProc;
if (proc != NULL) {
Tcl_Obj *typePtr = (*proc)(pathObjPtr);
if (typePtr != NULL) {
Tcl_ListObjAppendElement(NULL, resPtr, typePtr);
}
}
return resPtr;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSPathSeparator --
*
* This function returns the separator to be used for a given
* path. The object returned should have a refCount of zero
*
* Results:
* A Tcl object, with a refCount of zero. If the caller
* needs to retain a reference to the object, it should
* call Tcl_IncrRefCount.
*
* Side effects:
* The path object may be converted to a path type.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
Tcl_FSPathSeparator(pathObjPtr)
Tcl_Obj* pathObjPtr;
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr);
if (fsPtr == NULL) {
return NULL;
}
if (fsPtr->filesystemSeparatorProc != NULL) {
return (*fsPtr->filesystemSeparatorProc)(pathObjPtr);
}
return NULL;
}
/*
*---------------------------------------------------------------------------
*
* NativeFilesystemSeparator --
*
* This function is part of the native filesystem support, and
* returns the separator for the given path.
*
* Results:
* String object containing the separator character.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static Tcl_Obj*
NativeFilesystemSeparator(pathObjPtr)
Tcl_Obj* pathObjPtr;
{
char *separator = NULL; /* lint */
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
separator = "/";
break;
case TCL_PLATFORM_WINDOWS:
separator = "\\";
break;
case TCL_PLATFORM_MAC:
separator = ":";
break;
}
return Tcl_NewStringObj(separator,1);
}
/* Everything from here on is contained in this obsolete ifdef */
#ifdef USE_OBSOLETE_FS_HOOKS
/*
*----------------------------------------------------------------------
*
* TclStatInsertProc --
*
* Insert the passed procedure pointer at the head of the list of
* functions which are used during a call to 'TclStat(...)'. The
* passed function should behave exactly like 'TclStat' when called
* during that time (see 'TclStat(...)' for more information).
* The function will be added even if it already in the list.
*
* Results:
* Normally TCL_OK; TCL_ERROR if memory for a new node in the list
* could not be allocated.
*
* Side effects:
* Memory allocated and modifies the link list for 'TclStat'
* functions.
*
*----------------------------------------------------------------------
*/
int
TclStatInsertProc (proc)
TclStatProc_ *proc;
{
int retVal = TCL_ERROR;
if (proc != NULL) {
StatProc *newStatProcPtr;
newStatProcPtr = (StatProc *)ckalloc(sizeof(StatProc));
if (newStatProcPtr != NULL) {
newStatProcPtr->proc = proc;
Tcl_MutexLock(&obsoleteFsHookMutex);
newStatProcPtr->nextPtr = statProcList;
statProcList = newStatProcPtr;
Tcl_MutexUnlock(&obsoleteFsHookMutex);
retVal = TCL_OK;
}
}
return retVal;
}
/*
*----------------------------------------------------------------------
*
* TclStatDeleteProc --
*
* Removed the passed function pointer from the list of 'TclStat'
* functions. Ensures that the built-in stat function is not
* removvable.
*
* Results:
* TCL_OK if the procedure pointer was successfully removed,
* TCL_ERROR otherwise.
*
* Side effects:
* Memory is deallocated and the respective list updated.
*
*----------------------------------------------------------------------
*/
int
TclStatDeleteProc (proc)
TclStatProc_ *proc;
{
int retVal = TCL_ERROR;
StatProc *tmpStatProcPtr;
StatProc *prevStatProcPtr = NULL;
Tcl_MutexLock(&obsoleteFsHookMutex);
tmpStatProcPtr = statProcList;
/*
* Traverse the 'statProcList' looking for the particular node
* whose 'proc' member matches 'proc' and remove that one from
* the list. Ensure that the "default" node cannot be removed.
*/
while ((retVal == TCL_ERROR) && (tmpStatProcPtr != NULL)) {
if (tmpStatProcPtr->proc == proc) {
if (prevStatProcPtr == NULL) {
statProcList = tmpStatProcPtr->nextPtr;
} else {
prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr;
}
ckfree((char *)tmpStatProcPtr);
retVal = TCL_OK;
} else {
prevStatProcPtr = tmpStatProcPtr;
tmpStatProcPtr = tmpStatProcPtr->nextPtr;
}
}
Tcl_MutexUnlock(&obsoleteFsHookMutex);
return retVal;
}
/*
*----------------------------------------------------------------------
*
* TclAccessInsertProc --
*
* Insert the passed procedure pointer at the head of the list of
* functions which are used during a call to 'TclAccess(...)'.
* The passed function should behave exactly like 'TclAccess' when
* called during that time (see 'TclAccess(...)' for more
* information). The function will be added even if it already in
* the list.
*
* Results:
* Normally TCL_OK; TCL_ERROR if memory for a new node in the list
* could not be allocated.
*
* Side effects:
* Memory allocated and modifies the link list for 'TclAccess'
* functions.
*
*----------------------------------------------------------------------
*/
int
TclAccessInsertProc(proc)
TclAccessProc_ *proc;
{
int retVal = TCL_ERROR;
if (proc != NULL) {
AccessProc *newAccessProcPtr;
newAccessProcPtr = (AccessProc *)ckalloc(sizeof(AccessProc));
if (newAccessProcPtr != NULL) {
newAccessProcPtr->proc = proc;
Tcl_MutexLock(&obsoleteFsHookMutex);
newAccessProcPtr->nextPtr = accessProcList;
accessProcList = newAccessProcPtr;
Tcl_MutexUnlock(&obsoleteFsHookMutex);
retVal = TCL_OK;
}
}
return retVal;
}
/*
*----------------------------------------------------------------------
*
* TclAccessDeleteProc --
*
* Removed the passed function pointer from the list of 'TclAccess'
* functions. Ensures that the built-in access function is not
* removvable.
*
* Results:
* TCL_OK if the procedure pointer was successfully removed,
* TCL_ERROR otherwise.
*
* Side effects:
* Memory is deallocated and the respective list updated.
*
*----------------------------------------------------------------------
*/
int
TclAccessDeleteProc(proc)
TclAccessProc_ *proc;
{
int retVal = TCL_ERROR;
AccessProc *tmpAccessProcPtr;
AccessProc *prevAccessProcPtr = NULL;
/*
* Traverse the 'accessProcList' looking for the particular node
* whose 'proc' member matches 'proc' and remove that one from
* the list. Ensure that the "default" node cannot be removed.
*/
Tcl_MutexLock(&obsoleteFsHookMutex);
tmpAccessProcPtr = accessProcList;
while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != NULL)) {
if (tmpAccessProcPtr->proc == proc) {
if (prevAccessProcPtr == NULL) {
accessProcList = tmpAccessProcPtr->nextPtr;
} else {
prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr;
}
ckfree((char *)tmpAccessProcPtr);
retVal = TCL_OK;
} else {
prevAccessProcPtr = tmpAccessProcPtr;
tmpAccessProcPtr = tmpAccessProcPtr->nextPtr;
}
}
Tcl_MutexUnlock(&obsoleteFsHookMutex);
return retVal;
}
/*
*----------------------------------------------------------------------
*
* TclOpenFileChannelInsertProc --
*
* Insert the passed procedure pointer at the head of the list of
* functions which are used during a call to
* 'Tcl_OpenFileChannel(...)'. The passed function should behave
* exactly like 'Tcl_OpenFileChannel' when called during that time
* (see 'Tcl_OpenFileChannel(...)' for more information). The
* function will be added even if it already in the list.
*
* Results:
* Normally TCL_OK; TCL_ERROR if memory for a new node in the list
* could not be allocated.
*
* Side effects:
* Memory allocated and modifies the link list for
* 'Tcl_OpenFileChannel' functions.
*
*----------------------------------------------------------------------
*/
int
TclOpenFileChannelInsertProc(proc)
TclOpenFileChannelProc_ *proc;
{
int retVal = TCL_ERROR;
if (proc != NULL) {
OpenFileChannelProc *newOpenFileChannelProcPtr;
newOpenFileChannelProcPtr =
(OpenFileChannelProc *)ckalloc(sizeof(OpenFileChannelProc));
if (newOpenFileChannelProcPtr != NULL) {
newOpenFileChannelProcPtr->proc = proc;
Tcl_MutexLock(&obsoleteFsHookMutex);
newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList;
openFileChannelProcList = newOpenFileChannelProcPtr;
Tcl_MutexUnlock(&obsoleteFsHookMutex);
retVal = TCL_OK;
}
}
return retVal;
}
/*
*----------------------------------------------------------------------
*
* TclOpenFileChannelDeleteProc --
*
* Removed the passed function pointer from the list of
* 'Tcl_OpenFileChannel' functions. Ensures that the built-in
* open file channel function is not removable.
*
* Results:
* TCL_OK if the procedure pointer was successfully removed,
* TCL_ERROR otherwise.
*
* Side effects:
* Memory is deallocated and the respective list updated.
*
*----------------------------------------------------------------------
*/
int
TclOpenFileChannelDeleteProc(proc)
TclOpenFileChannelProc_ *proc;
{
int retVal = TCL_ERROR;
OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList;
OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL;
/*
* Traverse the 'openFileChannelProcList' looking for the particular
* node whose 'proc' member matches 'proc' and remove that one from
* the list.
*/
Tcl_MutexLock(&obsoleteFsHookMutex);
tmpOpenFileChannelProcPtr = openFileChannelProcList;
while ((retVal == TCL_ERROR) &&
(tmpOpenFileChannelProcPtr != NULL)) {
if (tmpOpenFileChannelProcPtr->proc == proc) {
if (prevOpenFileChannelProcPtr == NULL) {
openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr;
} else {
prevOpenFileChannelProcPtr->nextPtr =
tmpOpenFileChannelProcPtr->nextPtr;
}
ckfree((char *)tmpOpenFileChannelProcPtr);
retVal = TCL_OK;
} else {
prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr;
tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr;
}
}
Tcl_MutexUnlock(&obsoleteFsHookMutex);
return retVal;
}
#endif /* USE_OBSOLETE_FS_HOOKS */
/*
* Prototypes for procedures defined later in this file.
*/
static void DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr));
static void FreeFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *listPtr));
static void UpdateStringOfFsPath _ANSI_ARGS_((Tcl_Obj *objPtr));
static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
static int FindSplitPos _ANSI_ARGS_((char *path, char *separator));
/*
* Define the 'path' object type, which Tcl uses to represent
* file paths internally.
*/
Tcl_ObjType tclFsPathType = {
"path", /* name */
FreeFsPathInternalRep, /* freeIntRepProc */
DupFsPathInternalRep, /* dupIntRepProc */
UpdateStringOfFsPath, /* updateStringProc */
SetFsPathFromAny /* setFromAnyProc */
};
/*
* struct FsPath --
*
* Internal representation of a Tcl_Obj of "path" type. This
* can be used to represent relative or absolute paths, and has
* certain optimisations when used to represent paths which are
* already normalized and absolute.
*
* Note that 'normPathPtr' can be a circular reference to the
* container Tcl_Obj of this FsPath.
*/
typedef struct FsPath {
Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences.
* If this is NULL, then this is a
* pure normalized, absolute path
* object, in which the parent Tcl_Obj's
* string rep is already both translated
* and normalized. */
Tcl_Obj *normPathPtr; /* Normalized absolute path, without
* ., .. or ~user sequences. If the
* Tcl_Obj containing
* this FsPath is already normalized,
* this may be a circular reference back
* to the container. If that is NOT the
* case, we have a refCount on the object. */
Tcl_Obj *cwdPtr; /* If null, path is absolute, else
* this points to the cwd object used
* for this path. We have a refCount
* on the object. */
int flags; /* Flags to describe interpretation */
ClientData nativePathPtr; /* Native representation of this path,
* which is filesystem dependent. */
int filesystemEpoch; /* Used to ensure the path representation
* was generated during the correct
* filesystem epoch. The epoch changes
* when filesystem-mounts are changed. */
struct FilesystemRecord *fsRecPtr;
/* Pointer to the filesystem record
* entry to use for this path. */
} FsPath;
/*
* Define some macros to give us convenient access to path-object
* specific fields.
*/
#define PATHOBJ(objPtr) (objPtr->internalRep.otherValuePtr)
#define PATHFLAGS(objPtr) \
(((FsPath*)(objPtr->internalRep.otherValuePtr))->flags)
#define TCLPATH_APPENDED 1
#define TCLPATH_RELATIVE 2
/*
*----------------------------------------------------------------------
*
* Tcl_FSGetPathType --
*
* Determines whether a given path is relative to the current
* directory, relative to the current volume, or absolute.
*
* Results:
* Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
* TCL_PATH_VOLUME_RELATIVE.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_PathType
Tcl_FSGetPathType(pathObjPtr)
Tcl_Obj *pathObjPtr;
{
return FSGetPathType(pathObjPtr, NULL, NULL);
}
/*
*----------------------------------------------------------------------
*
* FSGetPathType --
*
* Determines whether a given path is relative to the current
* directory, relative to the current volume, or absolute. If the
* caller wishes to know which filesystem claimed the path (in the
* case for which the path is absolute), then a reference to a
* filesystem pointer can be passed in (but passing NULL is
* acceptable).
*
* Results:
* Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
* TCL_PATH_VOLUME_RELATIVE. The filesystem reference will
* be set if and only if it is non-NULL and the function's
* return value is TCL_PATH_ABSOLUTE.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_PathType
FSGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr)
Tcl_Obj *pathObjPtr;
Tcl_Filesystem **filesystemPtrPtr;
int *driveNameLengthPtr;
{
if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) {
return GetPathType(pathObjPtr, filesystemPtrPtr,
driveNameLengthPtr, NULL);
} else {
FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
if (fsPathPtr->cwdPtr != NULL) {
if (PATHFLAGS(pathObjPtr) == 0) {
return TCL_PATH_RELATIVE;
}
return FSGetPathType(fsPathPtr->cwdPtr, filesystemPtrPtr,
driveNameLengthPtr);
} else {
return GetPathType(pathObjPtr, filesystemPtrPtr,
driveNameLengthPtr, NULL);
}
}
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSJoinPath --
*
* This function takes the given Tcl_Obj, which should be a valid
* list, and returns the path object given by considering the
* first 'elements' elements as valid path segments. If elements < 0,
* we use the entire list.
*
* Results:
* Returns object with refCount of zero, (or if non-zero, it has
* references elsewhere in Tcl). Either way, the caller must
* increment its refCount before use.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
Tcl_FSJoinPath(listObj, elements)
Tcl_Obj *listObj;
int elements;
{
Tcl_Obj *res;
int i;
Tcl_Filesystem *fsPtr = NULL;
if (elements < 0) {
if (Tcl_ListObjLength(NULL, listObj, &elements) != TCL_OK) {
return NULL;
}
} else {
/* Just make sure it is a valid list */
int listTest;
if (Tcl_ListObjLength(NULL, listObj, &listTest) != TCL_OK) {
return NULL;
}
/*
* Correct this if it is too large, otherwise we will
* waste our time joining null elements to the path
*/
if (elements > listTest) {
elements = listTest;
}
}
res = Tcl_NewObj();
for (i = 0; i < elements; i++) {
Tcl_Obj *elt;
int driveNameLength;
Tcl_PathType type;
char *strElt;
int strEltLen;
int length;
char *ptr;
Tcl_Obj *driveName = NULL;
Tcl_ListObjIndex(NULL, listObj, i, &elt);
/*
* This is a special case where we can be much more
* efficient, where we are joining a single relative path
* onto an object that is already of path type. The
* 'TclNewFSPathObj' call below creates an object which
* can be normalized more efficiently. Currently we only
* use the special case when we have exactly two elements,
* but we could expand that in the future.
*/
if ((i == (elements-2)) && (i == 0) && (elt->typePtr == &tclFsPathType)
&& !(elt->bytes != NULL && (elt->bytes[0] == '\0'))) {
Tcl_Obj *tail;
Tcl_PathType type;
Tcl_ListObjIndex(NULL, listObj, i+1, &tail);
type = GetPathType(tail, NULL, NULL, NULL);
if (type == TCL_PATH_RELATIVE) {
CONST char *str;
int len;
str = Tcl_GetStringFromObj(tail,&len);
if (len == 0) {
/*
* This happens if we try to handle the root volume
* '/'. There's no need to return a special path
* object, when the base itself is just fine!
*/
Tcl_DecrRefCount(res);
return elt;
}
/*
* If it doesn't begin with '.' and is a mac or unix
* path or it a windows path without backslashes, then we
* can be very efficient here. (In fact even a windows
* path with backslashes can be joined efficiently, but
* the path object would not have forward slashes only,
* and this would therefore contradict our 'file join'
* documentation).
*/
if (str[0] != '.' && ((tclPlatform != TCL_PLATFORM_WINDOWS)
|| (strchr(str, '\\') == NULL))) {
Tcl_DecrRefCount(res);
return TclNewFSPathObj(elt, str, len);
}
/*
* Otherwise we don't have an easy join, and
* we must let the more general code below handle
* things
*/
} else {
if (tclPlatform == TCL_PLATFORM_UNIX) {
Tcl_DecrRefCount(res);
return tail;
} else {
CONST char *str;
int len;
str = Tcl_GetStringFromObj(tail,&len);
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
if (strchr(str, '\\') == NULL) {
Tcl_DecrRefCount(res);
return tail;
}
} else if (tclPlatform == TCL_PLATFORM_MAC) {
if (strchr(str, '/') == NULL) {
Tcl_DecrRefCount(res);
return tail;
}
}
}
}
}
strElt = Tcl_GetStringFromObj(elt, &strEltLen);
type = GetPathType(elt, &fsPtr, &driveNameLength, &driveName);
if (type != TCL_PATH_RELATIVE) {
/* Zero out the current result */
Tcl_DecrRefCount(res);
if (driveName != NULL) {
res = Tcl_DuplicateObj(driveName);
Tcl_DecrRefCount(driveName);
} else {
res = Tcl_NewStringObj(strElt, driveNameLength);
}
strElt += driveNameLength;
}
ptr = Tcl_GetStringFromObj(res, &length);
/*
* Strip off any './' before a tilde, unless this is the
* beginning of the path.
*/
if (length > 0 && strEltLen > 0) {
if ((strElt[0] == '.') && (strElt[1] == '/')
&& (strElt[2] == '~')) {
strElt += 2;
}
}
/*
* A NULL value for fsPtr at this stage basically means
* we're trying to join a relative path onto something
* which is also relative (or empty). There's nothing
* particularly wrong with that.
*/
if (*strElt == '\0') continue;
if (fsPtr == &tclNativeFilesystem || fsPtr == NULL) {
TclpNativeJoinPath(res, strElt);
} else {
char separator = '/';
int needsSep = 0;
if (fsPtr->filesystemSeparatorProc != NULL) {
Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(res);
if (sep != NULL) {
separator = Tcl_GetString(sep)[0];
}
}
if (length > 0 && ptr[length -1] != '/') {
Tcl_AppendToObj(res, &separator, 1);
length++;
}
Tcl_SetObjLength(res, length + (int) strlen(strElt));
ptr = Tcl_GetString(res) + length;
for (; *strElt != '\0'; strElt++) {
if (*strElt == separator) {
while (strElt[1] == separator) {
strElt++;
}
if (strElt[1] != '\0') {
if (needsSep) {
*ptr++ = separator;
}
}
} else {
*ptr++ = *strElt;
needsSep = 1;
}
}
length = ptr - Tcl_GetString(res);
Tcl_SetObjLength(res, length);
}
}
return res;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSConvertToPathType --
*
* This function tries to convert the given Tcl_Obj to a valid
* Tcl path type, taking account of the fact that the cwd may
* have changed even if this object is already supposedly of
* the correct type.
*
* The filename may begin with "~" (to indicate current user's
* home directory) or "~<user>" (to indicate any user's home
* directory).
*
* Results:
* Standard Tcl error code.
*
* Side effects:
* The old representation may be freed, and new memory allocated.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSConvertToPathType(interp, objPtr)
Tcl_Interp *interp; /* Interpreter in which to store error
* message (if necessary). */
Tcl_Obj *objPtr; /* Object to convert to a valid, current
* path type. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* While it is bad practice to examine an object's type directly,
* this is actually the best thing to do here. The reason is that
* if we are converting this object to FsPath type for the first
* time, we don't need to worry whether the 'cwd' has changed.
* On the other hand, if this object is already of FsPath type,
* and is a relative path, we do have to worry about the cwd.
* If the cwd has changed, we must recompute the path.
*/
if (objPtr->typePtr == &tclFsPathType) {
FsPath *fsPathPtr = (FsPath*) PATHOBJ(objPtr);
if (fsPathPtr->filesystemEpoch != tsdPtr->filesystemEpoch) {
if (objPtr->bytes == NULL) {
UpdateStringOfFsPath(objPtr);
}
FreeFsPathInternalRep(objPtr);
objPtr->typePtr = NULL;
return Tcl_ConvertToType(interp, objPtr, &tclFsPathType);
}
return TCL_OK;
} else {
return Tcl_ConvertToType(interp, objPtr, &tclFsPathType);
}
}
/*
* Helper function for SetFsPathFromAny. Returns position of first
* directory delimiter in the path.
*/
static int
FindSplitPos(path, separator)
char *path;
char *separator;
{
int count = 0;
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
case TCL_PLATFORM_MAC:
while (path[count] != 0) {
if (path[count] == *separator) {
return count;
}
count++;
}
break;
case TCL_PLATFORM_WINDOWS:
while (path[count] != 0) {
if (path[count] == *separator || path[count] == '\\') {
return count;
}
count++;
}
break;
}
return count;
}
/*
*---------------------------------------------------------------------------
*
* TclNewFSPathObj --
*
* Creates a path object whose string representation is
* '[file join dirPtr addStrRep]', but does so in a way that
* allows for more efficient caching of normalized paths.
*
* Assumptions:
* 'dirPtr' must be an absolute path.
* 'len' may not be zero.
*
* Results:
* The new Tcl object, with refCount zero.
*
* Side effects:
* Memory is allocated. 'dirPtr' gets an additional refCount.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len)
{
FsPath *fsPathPtr;
Tcl_Obj *objPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
objPtr = Tcl_NewObj();
fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
if (tclPlatform == TCL_PLATFORM_MAC) {
/*
* Mac relative paths may begin with a directory separator ':'.
* If present, we need to skip this ':' because we assume that
* we can join dirPtr and addStrRep by concatenating them as
* strings (and we ensure that dirPtr is terminated by a ':').
*/
if (addStrRep[0] == ':') {
addStrRep++;
len--;
}
}
/* Setup the path */
fsPathPtr->translatedPathPtr = NULL;
fsPathPtr->normPathPtr = Tcl_NewStringObj(addStrRep, len);
Tcl_IncrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->cwdPtr = dirPtr;
Tcl_IncrRefCount(dirPtr);
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsRecPtr = NULL;
fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
PATHOBJ(objPtr) = (VOID *) fsPathPtr;
PATHFLAGS(objPtr) = TCLPATH_RELATIVE | TCLPATH_APPENDED;
objPtr->typePtr = &tclFsPathType;
objPtr->bytes = NULL;
objPtr->length = 0;
return objPtr;
}
/*
*---------------------------------------------------------------------------
*
* TclFSMakePathRelative --
*
* Like SetFsPathFromAny, but assumes the given object is an
* absolute normalized path. Only for internal use.
*
* Results:
* Standard Tcl error code.
*
* Side effects:
* The old representation may be freed, and new memory allocated.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
TclFSMakePathRelative(interp, objPtr, cwdPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr; /* The object we have. */
Tcl_Obj *cwdPtr; /* Make it relative to this. */
{
int cwdLen, len;
CONST char *tempStr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (objPtr->typePtr == &tclFsPathType) {
FsPath *fsPathPtr = (FsPath*) PATHOBJ(objPtr);
if (PATHFLAGS(objPtr) != 0
&& fsPathPtr->cwdPtr == cwdPtr) {
objPtr = fsPathPtr->normPathPtr;
/* Free old representation */
if (objPtr->typePtr != NULL) {
if (objPtr->bytes == NULL) {
if (objPtr->typePtr->updateStringProc == NULL) {
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "can't find object",
"string representation", (char *) NULL);
}
return NULL;
}
objPtr->typePtr->updateStringProc(objPtr);
}
if ((objPtr->typePtr->freeIntRepProc) != NULL) {
(*objPtr->typePtr->freeIntRepProc)(objPtr);
}
}
fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
/* Circular reference, by design */
fsPathPtr->translatedPathPtr = objPtr;
fsPathPtr->normPathPtr = NULL;
fsPathPtr->cwdPtr = cwdPtr;
Tcl_IncrRefCount(cwdPtr);
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsRecPtr = NULL;
fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
PATHOBJ(objPtr) = (VOID *) fsPathPtr;
PATHFLAGS(objPtr) = 0;
objPtr->typePtr = &tclFsPathType;
return objPtr;
}
}
/*
* We know the cwd is a normalised object which does
* not end in a directory delimiter, unless the cwd
* is the name of a volume, in which case it will
* end in a delimiter! We handle this situation here.
* A better test than the '!= sep' might be to simply
* check if 'cwd' is a root volume.
*
* Note that if we get this wrong, we will strip off
* either too much or too little below, leading to
* wrong answers returned by glob.
*/
tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
/*
* Should we perhaps use 'Tcl_FSPathSeparator'?
* But then what about the Windows special case?
* Perhaps we should just check if cwd is a root
* volume.
*/
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
if (tempStr[cwdLen-1] != '/') {
cwdLen++;
}
break;
case TCL_PLATFORM_WINDOWS:
if (tempStr[cwdLen-1] != '/'
&& tempStr[cwdLen-1] != '\\') {
cwdLen++;
}
break;
case TCL_PLATFORM_MAC:
if (tempStr[cwdLen-1] != ':') {
cwdLen++;
}
break;
}
tempStr = Tcl_GetStringFromObj(objPtr, &len);
return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen);
}
/*
*---------------------------------------------------------------------------
*
* TclFSMakePathFromNormalized --
*
* Like SetFsPathFromAny, but assumes the given object is an
* absolute normalized path. Only for internal use.
*
* Results:
* Standard Tcl error code.
*
* Side effects:
* The old representation may be freed, and new memory allocated.
*
*---------------------------------------------------------------------------
*/
int
TclFSMakePathFromNormalized(interp, objPtr, nativeRep)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr; /* The object to convert. */
ClientData nativeRep; /* The native rep for the object, if known
* else NULL. */
{
FsPath *fsPathPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (objPtr->typePtr == &tclFsPathType) {
return TCL_OK;
}
/* Free old representation */
if (objPtr->typePtr != NULL) {
if (objPtr->bytes == NULL) {
if (objPtr->typePtr->updateStringProc == NULL) {
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "can't find object",
"string representation", (char *) NULL);
}
return TCL_ERROR;
}
objPtr->typePtr->updateStringProc(objPtr);
}
if ((objPtr->typePtr->freeIntRepProc) != NULL) {
(*objPtr->typePtr->freeIntRepProc)(objPtr);
}
}
fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
/* It's a pure normalized absolute path */
fsPathPtr->translatedPathPtr = NULL;
fsPathPtr->normPathPtr = objPtr;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = nativeRep;
fsPathPtr->fsRecPtr = NULL;
fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
PATHOBJ(objPtr) = (VOID *) fsPathPtr;
PATHFLAGS(objPtr) = 0;
objPtr->typePtr = &tclFsPathType;
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSNewNativePath --
*
* This function performs the something like that reverse of the
* usual obj->path->nativerep conversions. If some code retrieves
* a path in native form (from, e.g. readlink or a native dialog),
* and that path is to be used at the Tcl level, then calling
* this function is an efficient way of creating the appropriate
* path object type.
*
* Any memory which is allocated for 'clientData' should be retained
* until clientData is passed to the filesystem's freeInternalRepProc
* when it can be freed. The built in platform-specific filesystems
* use 'ckalloc' to allocate clientData, and ckfree to free it.
*
* Results:
* NULL or a valid path object pointer, with refCount zero.
*
* Side effects:
* New memory may be allocated.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSNewNativePath(fromFilesystem, clientData)
Tcl_Filesystem* fromFilesystem;
ClientData clientData;
{
Tcl_Obj *objPtr;
FsPath *fsPathPtr;
FilesystemRecord *fsFromPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
objPtr = TclFSInternalToNormalized(fromFilesystem, clientData, &fsFromPtr);
if (objPtr == NULL) {
return NULL;
}
/*
* Free old representation; shouldn't normally be any,
* but best to be safe.
*/
if (objPtr->typePtr != NULL) {
if (objPtr->bytes == NULL) {
if (objPtr->typePtr->updateStringProc == NULL) {
return NULL;
}
objPtr->typePtr->updateStringProc(objPtr);
}
if ((objPtr->typePtr->freeIntRepProc) != NULL) {
(*objPtr->typePtr->freeIntRepProc)(objPtr);
}
}
fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
fsPathPtr->translatedPathPtr = NULL;
/* Circular reference, by design */
fsPathPtr->normPathPtr = objPtr;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = clientData;
fsPathPtr->fsRecPtr = fsFromPtr;
fsPathPtr->fsRecPtr->fileRefCount++;
fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
PATHOBJ(objPtr) = (VOID *) fsPathPtr;
PATHFLAGS(objPtr) = 0;
objPtr->typePtr = &tclFsPathType;
return objPtr;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSGetTranslatedPath --
*
* This function attempts to extract the translated path
* from the given Tcl_Obj. If the translation succeeds (i.e. the
* object is a valid path), then it is returned. Otherwise NULL
* will be returned, and an error message may be left in the
* interpreter (if it is non-NULL)
*
* Results:
* NULL or a valid Tcl_Obj pointer.
*
* Side effects:
* Only those of 'Tcl_FSConvertToPathType'
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
Tcl_FSGetTranslatedPath(interp, pathPtr)
Tcl_Interp *interp;
Tcl_Obj* pathPtr;
{
Tcl_Obj *retObj = NULL;
FsPath *srcFsPathPtr;
if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
return NULL;
}
srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr);
if (srcFsPathPtr->translatedPathPtr == NULL) {
if (PATHFLAGS(pathPtr) != 0) {
return Tcl_FSGetNormalizedPath(interp, pathPtr);
}
/*
* It is a pure absolute, normalized path object.
* This is something like being a 'pure list'. The
* object's string, translatedPath and normalizedPath
* are all identical.
*/
retObj = srcFsPathPtr->normPathPtr;
} else {
/* It is an ordinary path object */
retObj = srcFsPathPtr->translatedPathPtr;
}
Tcl_IncrRefCount(retObj);
return retObj;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSGetTranslatedStringPath --
*
* This function attempts to extract the translated path
* from the given Tcl_Obj. If the translation succeeds (i.e. the
* object is a valid path), then the path is returned. Otherwise NULL
* will be returned, and an error message may be left in the
* interpreter (if it is non-NULL)
*
* Results:
* NULL or a valid string.
*
* Side effects:
* Only those of 'Tcl_FSConvertToPathType'
*
*---------------------------------------------------------------------------
*/
CONST char*
Tcl_FSGetTranslatedStringPath(interp, pathPtr)
Tcl_Interp *interp;
Tcl_Obj* pathPtr;
{
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
if (transPtr != NULL) {
int len;
CONST char *result, *orig;
orig = Tcl_GetStringFromObj(transPtr, &len);
result = (char*) ckalloc((unsigned)(len+1));
memcpy((VOID*) result, (VOID*) orig, (size_t) (len+1));
Tcl_DecrRefCount(transPtr);
return result;
}
return NULL;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSGetNormalizedPath --
*
* This important function attempts to extract from the given Tcl_Obj
* a unique normalised path representation, whose string value can
* be used as a unique identifier for the file.
*
* Results:
* NULL or a valid path object pointer.
*
* Side effects:
* New memory may be allocated. The Tcl 'errno' may be modified
* in the process of trying to examine various path possibilities.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
Tcl_FSGetNormalizedPath(interp, pathObjPtr)
Tcl_Interp *interp;
Tcl_Obj* pathObjPtr;
{
FsPath *fsPathPtr;
if (Tcl_FSConvertToPathType(interp, pathObjPtr) != TCL_OK) {
return NULL;
}
fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
if (PATHFLAGS(pathObjPtr) != 0) {
/*
* This is a special path object which is the result of
* something like 'file join'
*/
Tcl_Obj *dir, *copy;
int cwdLen;
int pathType;
CONST char *cwdStr;
ClientData clientData = NULL;
pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr);
dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr);
if (dir == NULL) {
return NULL;
}
if (pathObjPtr->bytes == NULL) {
UpdateStringOfFsPath(pathObjPtr);
}
copy = Tcl_DuplicateObj(dir);
Tcl_IncrRefCount(copy);
Tcl_IncrRefCount(dir);
/* We now own a reference on both 'dir' and 'copy' */
cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);
/*
* Should we perhaps use 'Tcl_FSPathSeparator'?
* But then what about the Windows special case?
* Perhaps we should just check if cwd is a root volume.
* We should never get cwdLen == 0 in this code path.
*/
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
if (cwdStr[cwdLen-1] != '/') {
Tcl_AppendToObj(copy, "/", 1);
cwdLen++;
}
break;
case TCL_PLATFORM_WINDOWS:
if (cwdStr[cwdLen-1] != '/'
&& cwdStr[cwdLen-1] != '\\') {
Tcl_AppendToObj(copy, "/", 1);
cwdLen++;
}
break;
case TCL_PLATFORM_MAC:
if (cwdStr[cwdLen-1] != ':') {
Tcl_AppendToObj(copy, ":", 1);
cwdLen++;
}
break;
}
Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr);
/*
* Normalize the combined string, but only starting after
* the end of the previously normalized 'dir'. This should
* be much faster! We use 'cwdLen-1' so that we are
* already pointing at the dir-separator that we know about.
* The normalization code will actually start off directly
* after that separator.
*/
TclFSNormalizeToUniquePath(interp, copy, cwdLen-1,
(fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));
/* Now we need to construct the new path object */
if (pathType == TCL_PATH_RELATIVE) {
FsPath* origDirFsPathPtr;
Tcl_Obj *origDir = fsPathPtr->cwdPtr;
origDirFsPathPtr = (FsPath*) PATHOBJ(origDir);
fsPathPtr->cwdPtr = origDirFsPathPtr->cwdPtr;
Tcl_IncrRefCount(fsPathPtr->cwdPtr);
Tcl_DecrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->normPathPtr = copy;
/* That's our reference to copy used */
Tcl_DecrRefCount(dir);
Tcl_DecrRefCount(origDir);
} else {
Tcl_DecrRefCount(fsPathPtr->cwdPtr);
fsPathPtr->cwdPtr = NULL;
Tcl_DecrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->normPathPtr = copy;
/* That's our reference to copy used */
Tcl_DecrRefCount(dir);
}
if (clientData != NULL) {
fsPathPtr->nativePathPtr = clientData;
}
PATHFLAGS(pathObjPtr) = 0;
}
/* Ensure cwd hasn't changed */
if (fsPathPtr->cwdPtr != NULL) {
if (!TclFSCwdPointerEquals(fsPathPtr->cwdPtr)) {
if (pathObjPtr->bytes == NULL) {
UpdateStringOfFsPath(pathObjPtr);
}
FreeFsPathInternalRep(pathObjPtr);
pathObjPtr->typePtr = NULL;
if (Tcl_ConvertToType(interp, pathObjPtr,
&tclFsPathType) != TCL_OK) {
return NULL;
}
fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
} else if (fsPathPtr->normPathPtr == NULL) {
int cwdLen;
Tcl_Obj *copy;
CONST char *cwdStr;
ClientData clientData = NULL;
copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr);
Tcl_IncrRefCount(copy);
cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);
/*
* Should we perhaps use 'Tcl_FSPathSeparator'?
* But then what about the Windows special case?
* Perhaps we should just check if cwd is a root volume.
* We should never get cwdLen == 0 in this code path.
*/
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
if (cwdStr[cwdLen-1] != '/') {
Tcl_AppendToObj(copy, "/", 1);
cwdLen++;
}
break;
case TCL_PLATFORM_WINDOWS:
if (cwdStr[cwdLen-1] != '/'
&& cwdStr[cwdLen-1] != '\\') {
Tcl_AppendToObj(copy, "/", 1);
cwdLen++;
}
break;
case TCL_PLATFORM_MAC:
if (cwdStr[cwdLen-1] != ':') {
Tcl_AppendToObj(copy, ":", 1);
cwdLen++;
}
break;
}
Tcl_AppendObjToObj(copy, pathObjPtr);
/*
* Normalize the combined string, but only starting after
* the end of the previously normalized 'dir'. This should
* be much faster!
*/
TclFSNormalizeToUniquePath(interp, copy, cwdLen-1,
(fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));
fsPathPtr->normPathPtr = copy;
if (clientData != NULL) {
fsPathPtr->nativePathPtr = clientData;
}
}
}
if (fsPathPtr->normPathPtr == NULL) {
ClientData clientData = NULL;
Tcl_Obj *useThisCwd = NULL;
/*
* Since normPathPtr is NULL, but this is a valid path
* object, we know that the translatedPathPtr cannot be NULL.
*/
Tcl_Obj *absolutePath = fsPathPtr->translatedPathPtr;
char *path = Tcl_GetString(absolutePath);
/*
* We have to be a little bit careful here to avoid infinite loops
* we're asking Tcl_FSGetPathType to return the path's type, but
* that call can actually result in a lot of other filesystem
* action, which might loop back through here.
*/
if (path[0] != '\0') {
Tcl_PathType type = Tcl_FSGetPathType(pathObjPtr);
if (type == TCL_PATH_RELATIVE) {
useThisCwd = Tcl_FSGetCwd(interp);
if (useThisCwd == NULL) return NULL;
absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath);
Tcl_IncrRefCount(absolutePath);
/* We have a refCount on the cwd */
#ifdef __WIN32__
} else if (type == TCL_PATH_VOLUME_RELATIVE) {
/*
* Only Windows has volume-relative paths. These
* paths are rather rare, but is is nice if Tcl can
* handle them. It is much better if we can
* handle them here, rather than in the native fs code,
* because we really need to have a real absolute path
* just below.
*
* We do not let this block compile on non-Windows
* platforms because the test suite's manual forcing
* of tclPlatform can otherwise cause this code path
* to be executed, causing various errors because
* volume-relative paths really do not exist.
*/
useThisCwd = Tcl_FSGetCwd(interp);
if (useThisCwd == NULL) return NULL;
if (path[0] == '/') {
/*
* Path of form /foo/bar which is a path in the
* root directory of the current volume.
*/
CONST char *drive = Tcl_GetString(useThisCwd);
absolutePath = Tcl_NewStringObj(drive,2);
Tcl_AppendToObj(absolutePath, path, -1);
Tcl_IncrRefCount(absolutePath);
/* We have a refCount on the cwd */
} else {
/*
* Path of form C:foo/bar, but this only makes
* sense if the cwd is also on drive C.
*/
CONST char *drive = Tcl_GetString(useThisCwd);
char drive_c = path[0];
if (drive_c >= 'a') {
drive_c -= ('a' - 'A');
}
if (drive[0] == drive_c) {
absolutePath = Tcl_DuplicateObj(useThisCwd);
/* We have a refCount on the cwd */
} else {
Tcl_DecrRefCount(useThisCwd);
useThisCwd = NULL;
/*
* The path is not in the current drive, but
* is volume-relative. The way Tcl 8.3 handles
* this is that it treats such a path as
* relative to the root of the drive. We
* therefore behave the same here.
*/
absolutePath = Tcl_NewStringObj(path, 2);
}
Tcl_IncrRefCount(absolutePath);
Tcl_AppendToObj(absolutePath, "/", 1);
Tcl_AppendToObj(absolutePath, path+2, -1);
}
#endif /* __WIN32__ */
}
}
/* Already has refCount incremented */
fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp, absolutePath,
(fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));
if (0 && (clientData != NULL)) {
fsPathPtr->nativePathPtr =
(*fsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc)(clientData);
}
if (!strcmp(Tcl_GetString(fsPathPtr->normPathPtr),
Tcl_GetString(pathObjPtr))) {
/*
* The path was already normalized.
* Get rid of the duplicate.
*/
Tcl_DecrRefCount(fsPathPtr->normPathPtr);
/*
* We do *not* increment the refCount for
* this circular reference
*/
fsPathPtr->normPathPtr = pathObjPtr;
}
if (useThisCwd != NULL) {
/* This was returned by Tcl_FSJoinToPath above */
Tcl_DecrRefCount(absolutePath);
fsPathPtr->cwdPtr = useThisCwd;
}
}
return fsPathPtr->normPathPtr;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSGetInternalRep --
*
* Extract the internal representation of a given path object,
* in the given filesystem. If the path object belongs to a
* different filesystem, we return NULL.
*
* If the internal representation is currently NULL, we attempt
* to generate it, by calling the filesystem's
* 'Tcl_FSCreateInternalRepProc'.
*
* Results:
* NULL or a valid internal representation.
*
* Side effects:
* An attempt may be made to convert the object.
*
*---------------------------------------------------------------------------
*/
ClientData
Tcl_FSGetInternalRep(pathObjPtr, fsPtr)
Tcl_Obj* pathObjPtr;
Tcl_Filesystem *fsPtr;
{
FsPath *srcFsPathPtr;
if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) {
return NULL;
}
srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
/*
* We will only return the native representation for the caller's
* filesystem. Otherwise we will simply return NULL. This means
* that there must be a unique bi-directional mapping between paths
* and filesystems, and that this mapping will not allow 'remapped'
* files -- files which are in one filesystem but mapped into
* another. Another way of putting this is that 'stacked'
* filesystems are not allowed. We recognise that this is a
* potentially useful feature for the future.
*
* Even something simple like a 'pass through' filesystem which
* logs all activity and passes the calls onto the native system
* would be nice, but not easily achievable with the current
* implementation.
*/
if (srcFsPathPtr->fsRecPtr == NULL) {
/*
* This only usually happens in wrappers like TclpStat which
* create a string object and pass it to TclpObjStat. Code
* which calls the Tcl_FS.. functions should always have a
* filesystem already set. Whether this code path is legal or
* not depends on whether we decide to allow external code to
* call the native filesystem directly. It is at least safer
* to allow this sub-optimal routing.
*/
Tcl_FSGetFileSystemForPath(pathObjPtr);
/*
* If we fail through here, then the path is probably not a
* valid path in the filesystsem, and is most likely to be a
* use of the empty path "" via a direct call to one of the
* objectified interfaces (e.g. from the Tcl testsuite).
*/
srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
if (srcFsPathPtr->fsRecPtr == NULL) {
return NULL;
}
}
if (fsPtr != srcFsPathPtr->fsRecPtr->fsPtr) {
/*
* There is still one possibility we should consider; if the
* file belongs to a different filesystem, perhaps it is
* actually linked through to a file in our own filesystem
* which we do care about. The way we can check for this
* is we ask what filesystem this path belongs to.
*/
Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathObjPtr);
if (actualFs == fsPtr) {
return Tcl_FSGetInternalRep(pathObjPtr, fsPtr);
}
return NULL;
}
if (srcFsPathPtr->nativePathPtr == NULL) {
Tcl_FSCreateInternalRepProc *proc;
proc = srcFsPathPtr->fsRecPtr->fsPtr->createInternalRepProc;
if (proc == NULL) {
return NULL;
}
srcFsPathPtr->nativePathPtr = (*proc)(pathObjPtr);
}
return srcFsPathPtr->nativePathPtr;
}
/*
*---------------------------------------------------------------------------
*
* TclFSEnsureEpochOk --
*
* This will ensure the pathObjPtr is up to date and can be
* converted into a "path" type, and that we are able to generate a
* complete normalized path which is used to determine the
* filesystem match.
*
* Results:
* Standard Tcl return code.
*
* Side effects:
* An attempt may be made to convert the object.
*
*---------------------------------------------------------------------------
*/
int
TclFSEnsureEpochOk(pathObjPtr, fsPtrPtr)
Tcl_Obj* pathObjPtr;
Tcl_Filesystem **fsPtrPtr;
{
FsPath *srcFsPathPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* SHOULD BE ABLE TO IMPROVE EFFICIENCY HERE.
*/
if (Tcl_FSGetNormalizedPath(NULL, pathObjPtr) == NULL) {
return TCL_ERROR;
}
srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
/*
* Check if the filesystem has changed in some way since
* this object's internal representation was calculated.
*/
if (srcFsPathPtr->filesystemEpoch != tsdPtr->filesystemEpoch) {
/*
* We have to discard the stale representation and
* recalculate it
*/
if (pathObjPtr->bytes == NULL) {
UpdateStringOfFsPath(pathObjPtr);
}
FreeFsPathInternalRep(pathObjPtr);
pathObjPtr->typePtr = NULL;
if (SetFsPathFromAny(NULL, pathObjPtr) != TCL_OK) {
return TCL_ERROR;
}
srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
}
/* Check whether the object is already assigned to a fs */
if (srcFsPathPtr->fsRecPtr != NULL) {
*fsPtrPtr = srcFsPathPtr->fsRecPtr->fsPtr;
}
return TCL_OK;
}
void
TclFSSetPathDetails(pathObjPtr, fsRecPtr, clientData)
Tcl_Obj *pathObjPtr;
FilesystemRecord *fsRecPtr;
ClientData clientData;
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/* We assume pathObjPtr is already of the correct type */
FsPath *srcFsPathPtr;
srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
srcFsPathPtr->fsRecPtr = fsRecPtr;
srcFsPathPtr->nativePathPtr = clientData;
srcFsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
fsRecPtr->fileRefCount++;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSEqualPaths --
*
* This function tests whether the two paths given are equal path
* objects. If either or both is NULL, 0 is always returned.
*
* Results:
* 1 or 0.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSEqualPaths(firstPtr, secondPtr)
Tcl_Obj* firstPtr;
Tcl_Obj* secondPtr;
{
if (firstPtr == secondPtr) {
return 1;
} else {
char *firstStr, *secondStr;
int firstLen, secondLen, tempErrno;
if (firstPtr == NULL || secondPtr == NULL) {
return 0;
}
firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen);
secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen);
if ((firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0)) {
return 1;
}
/*
* Try the most thorough, correct method of comparing fully
* normalized paths
*/
tempErrno = Tcl_GetErrno();
firstPtr = Tcl_FSGetNormalizedPath(NULL, firstPtr);
secondPtr = Tcl_FSGetNormalizedPath(NULL, secondPtr);
Tcl_SetErrno(tempErrno);
if (firstPtr == NULL || secondPtr == NULL) {
return 0;
}
firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen);
secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen);
if ((firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0)) {
return 1;
}
}
return 0;
}
/*
*---------------------------------------------------------------------------
*
* SetFsPathFromAny --
*
* This function tries to convert the given Tcl_Obj to a valid
* Tcl path type.
*
* The filename may begin with "~" (to indicate current user's
* home directory) or "~<user>" (to indicate any user's home
* directory).
*
* Results:
* Standard Tcl error code.
*
* Side effects:
* The old representation may be freed, and new memory allocated.
*
*---------------------------------------------------------------------------
*/
static int
SetFsPathFromAny(interp, objPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr; /* The object to convert. */
{
int len;
FsPath *fsPathPtr;
Tcl_Obj *transPtr;
char *name;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (objPtr->typePtr == &tclFsPathType) {
return TCL_OK;
}
/*
* First step is to translate the filename. This is similar to
* Tcl_TranslateFilename, but shouldn't convert everything to
* windows backslashes on that platform. The current
* implementation of this piece is a slightly optimised version
* of the various Tilde/Split/Join stuff to avoid multiple
* split/join operations.
*
* We remove any trailing directory separator.
*
* However, the split/join routines are quite complex, and
* one has to make sure not to break anything on Unix, Win
* or MacOS (fCmd.test, fileName.test and cmdAH.test exercise
* most of the code).
*/
name = Tcl_GetStringFromObj(objPtr,&len);
/*
* Handle tilde substitutions, if needed.
*/
if (name[0] == '~') {
char *expandedUser;
Tcl_DString temp;
int split;
char separator='/';
if (tclPlatform==TCL_PLATFORM_MAC) {
if (strchr(name, ':') != NULL) separator = ':';
}
split = FindSplitPos(name, &separator);
if (split != len) {
/* We have multiple pieces '~user/foo/bar...' */
name[split] = '\0';
}
/* Do some tilde substitution */
if (name[1] == '\0') {
/* We have just '~' */
CONST char *dir;
Tcl_DString dirString;
if (split != len) { name[split] = separator; }
dir = TclGetEnv("HOME", &dirString);
if (dir == NULL) {
if (interp) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't find HOME environment ",
"variable to expand path", (char *) NULL);
}
return TCL_ERROR;
}
Tcl_DStringInit(&temp);
Tcl_JoinPath(1, &dir, &temp);
Tcl_DStringFree(&dirString);
} else {
/* We have a user name '~user' */
Tcl_DStringInit(&temp);
if (TclpGetUserHome(name+1, &temp) == NULL) {
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "user \"", (name+1),
"\" doesn't exist", (char *) NULL);
}
Tcl_DStringFree(&temp);
if (split != len) { name[split] = separator; }
return TCL_ERROR;
}
if (split != len) { name[split] = separator; }
}
expandedUser = Tcl_DStringValue(&temp);
transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp));
if (split != len) {
/* Join up the tilde substitution with the rest */
if (name[split+1] == separator) {
/*
* Somewhat tricky case like ~//foo/bar.
* Make use of Split/Join machinery to get it right.
* Assumes all paths beginning with ~ are part of the
* native filesystem.
*/
int objc;
Tcl_Obj **objv;
Tcl_Obj *parts = TclpNativeSplitPath(objPtr, NULL);
Tcl_ListObjGetElements(NULL, parts, &objc, &objv);
/* Skip '~'. It's replaced by its expansion */
objc--; objv++;
while (objc--) {
TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++));
}
Tcl_DecrRefCount(parts);
} else {
/* Simple case. "rest" is relative path. Just join it. */
Tcl_Obj *rest = Tcl_NewStringObj(name+split+1,-1);
transPtr = Tcl_FSJoinToPath(transPtr, 1, &rest);
}
}
Tcl_DStringFree(&temp);
} else {
transPtr = Tcl_FSJoinToPath(objPtr,0,NULL);
}
#if defined(__CYGWIN__) && defined(__WIN32__)
{
extern int cygwin_conv_to_win32_path
_ANSI_ARGS_((CONST char *, char *));
char winbuf[MAX_PATH+1];
/*
* In the Cygwin world, call conv_to_win32_path in order to use the
* mount table to translate the file name into something Windows will
* understand. Take care when converting empty strings!
*/
name = Tcl_GetStringFromObj(transPtr, &len);
if (len > 0) {
cygwin_conv_to_win32_path(name, winbuf);
TclWinNoBackslash(winbuf);
Tcl_SetStringObj(transPtr, winbuf, -1);
}
}
#endif /* __CYGWIN__ && __WIN32__ */
/*
* Now we have a translated filename in 'transPtr'. This will have
* forward slashes on Windows, and will not contain any ~user
* sequences.
*/
fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
fsPathPtr->translatedPathPtr = transPtr;
Tcl_IncrRefCount(fsPathPtr->translatedPathPtr);
fsPathPtr->normPathPtr = NULL;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsRecPtr = NULL;
fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
/*
* Free old representation before installing our new one.
*/
if (objPtr->typePtr != NULL && objPtr->typePtr->freeIntRepProc != NULL) {
(objPtr->typePtr->freeIntRepProc)(objPtr);
}
PATHOBJ(objPtr) = (VOID *) fsPathPtr;
PATHFLAGS(objPtr) = 0;
objPtr->typePtr = &tclFsPathType;
return TCL_OK;
}
static void
FreeFsPathInternalRep(pathObjPtr)
Tcl_Obj *pathObjPtr; /* Path object with internal rep to free. */
{
FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
if (fsPathPtr->translatedPathPtr != NULL) {
if (fsPathPtr->translatedPathPtr != pathObjPtr) {
Tcl_DecrRefCount(fsPathPtr->translatedPathPtr);
}
}
if (fsPathPtr->normPathPtr != NULL) {
if (fsPathPtr->normPathPtr != pathObjPtr) {
Tcl_DecrRefCount(fsPathPtr->normPathPtr);
}
fsPathPtr->normPathPtr = NULL;
}
if (fsPathPtr->cwdPtr != NULL) {
Tcl_DecrRefCount(fsPathPtr->cwdPtr);
}
if (fsPathPtr->nativePathPtr != NULL) {
if (fsPathPtr->fsRecPtr != NULL) {
if (fsPathPtr->fsRecPtr->fsPtr->freeInternalRepProc != NULL) {
(*fsPathPtr->fsRecPtr->fsPtr
->freeInternalRepProc)(fsPathPtr->nativePathPtr);
fsPathPtr->nativePathPtr = NULL;
}
}
}
if (fsPathPtr->fsRecPtr != NULL) {
fsPathPtr->fsRecPtr->fileRefCount--;
if (fsPathPtr->fsRecPtr->fileRefCount <= 0) {
/* It has been unregistered already, so simply free it */
ckfree((char *)fsPathPtr->fsRecPtr);
}
}
ckfree((char*) fsPathPtr);
}
static void
DupFsPathInternalRep(srcPtr, copyPtr)
Tcl_Obj *srcPtr; /* Path obj with internal rep to copy. */
Tcl_Obj *copyPtr; /* Path obj with internal rep to set. */
{
FsPath *srcFsPathPtr = (FsPath*) PATHOBJ(srcPtr);
FsPath *copyFsPathPtr = (FsPath*) ckalloc((unsigned)sizeof(FsPath));
Tcl_FSDupInternalRepProc *dupProc;
PATHOBJ(copyPtr) = (VOID *) copyFsPathPtr;
if (srcFsPathPtr->translatedPathPtr != NULL) {
copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr;
if (copyFsPathPtr->translatedPathPtr != copyPtr) {
Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr);
}
} else {
copyFsPathPtr->translatedPathPtr = NULL;
}
if (srcFsPathPtr->normPathPtr != NULL) {
copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr;
if (copyFsPathPtr->normPathPtr != copyPtr) {
Tcl_IncrRefCount(copyFsPathPtr->normPathPtr);
}
} else {
copyFsPathPtr->normPathPtr = NULL;
}
if (srcFsPathPtr->cwdPtr != NULL) {
copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr;
Tcl_IncrRefCount(copyFsPathPtr->cwdPtr);
} else {
copyFsPathPtr->cwdPtr = NULL;
}
copyFsPathPtr->flags = srcFsPathPtr->flags;
if (srcFsPathPtr->fsRecPtr != NULL
&& srcFsPathPtr->nativePathPtr != NULL) {
dupProc = srcFsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc;
if (dupProc != NULL) {
copyFsPathPtr->nativePathPtr =
(*dupProc)(srcFsPathPtr->nativePathPtr);
} else {
copyFsPathPtr->nativePathPtr = NULL;
}
} else {
copyFsPathPtr->nativePathPtr = NULL;
}
copyFsPathPtr->fsRecPtr = srcFsPathPtr->fsRecPtr;
copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch;
if (copyFsPathPtr->fsRecPtr != NULL) {
copyFsPathPtr->fsRecPtr->fileRefCount++;
}
copyPtr->typePtr = &tclFsPathType;
}
/*
*---------------------------------------------------------------------------
*
* UpdateStringOfFsPath --
*
* Gives an object a valid string rep.
*
* Results:
* None.
*
* Side effects:
* Memory may be allocated.
*
*---------------------------------------------------------------------------
*/
static void
UpdateStringOfFsPath(objPtr)
register Tcl_Obj *objPtr; /* path obj with string rep to update. */
{
FsPath *fsPathPtr = (FsPath*) PATHOBJ(objPtr);
CONST char *cwdStr;
int cwdLen;
Tcl_Obj *copy;
if (PATHFLAGS(objPtr) == 0 || fsPathPtr->cwdPtr == NULL) {
panic("Called UpdateStringOfFsPath with invalid object");
}
copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr);
Tcl_IncrRefCount(copy);
cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);
/*
* Should we perhaps use 'Tcl_FSPathSeparator'?
* But then what about the Windows special case?
* Perhaps we should just check if cwd is a root volume.
* We should never get cwdLen == 0 in this code path.
*/
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
if (cwdStr[cwdLen-1] != '/') {
Tcl_AppendToObj(copy, "/", 1);
cwdLen++;
}
break;
case TCL_PLATFORM_WINDOWS:
/*
* We need the extra 'cwdLen != 2', and ':' checks because
* a volume relative path doesn't get a '/'. For example
* 'glob C:*cat*.exe' will return 'C:cat32.exe'
*/
if (cwdStr[cwdLen-1] != '/'
&& cwdStr[cwdLen-1] != '\\') {
if (cwdLen != 2 || cwdStr[1] != ':') {
Tcl_AppendToObj(copy, "/", 1);
cwdLen++;
}
}
break;
case TCL_PLATFORM_MAC:
if (cwdStr[cwdLen-1] != ':') {
Tcl_AppendToObj(copy, ":", 1);
cwdLen++;
}
break;
}
Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr);
objPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen);
objPtr->length = cwdLen;
copy->bytes = tclEmptyStringRep;
copy->length = 0;
Tcl_DecrRefCount(copy);
}
/*
*---------------------------------------------------------------------------
*
* NativePathInFilesystem --
*
* Any path object is acceptable to the native filesystem, by
* default (we will throw errors when illegal paths are actually
* tried to be used).
*
* However, this behavior means the native filesystem must be
* the last filesystem in the lookup list (otherwise it will
* claim all files belong to it, and other filesystems will
* never get a look in).
*
* Results:
* TCL_OK, to indicate 'yes', -1 to indicate no.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
NativePathInFilesystem(pathPtr, clientDataPtr)
Tcl_Obj *pathPtr;
ClientData *clientDataPtr;
{
/*
* A special case is required to handle the empty path "".
* This is a valid path (i.e. the user should be able
* to do 'file exists ""' without throwing an error), but
* equally the path doesn't exist. Those are the semantics
* of Tcl (at present anyway), so we have to abide by them
* here.
*/
if (pathPtr->typePtr == &tclFsPathType) {
if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') {
/* We reject the empty path "" */
return -1;
}
/* Otherwise there is no way this path can be empty */
} else {
/*
* It is somewhat unusual to reach this code path without
* the object being of tclFsPathType. However, we do
* our best to deal with the situation.
*/
int len;
Tcl_GetStringFromObj(pathPtr,&len);
if (len == 0) {
/* We reject the empty path "" */
return -1;
}
}
/*
* Path is of correct type, or is of non-zero length,
* so we accept it.
*/
return TCL_OK;
}