summaryrefslogtreecommitdiffstats
path: root/generic/tclIOUtil.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclIOUtil.c')
-rw-r--r--generic/tclIOUtil.c6797
1 files changed, 2604 insertions, 4193 deletions
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index b6f89d9..e4b4ad6 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -1,186 +1,109 @@
-/*
+/*
* 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.
+ * 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.
+ * Parts of this file are based on code contributed by Karl Lehenbauer,
+ * Mark Diekhans and Peter da Silva.
*
* Copyright (c) 1991-1994 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 2001-2004 Vincent Darley.
*
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-#ifndef _WIN64
-/* See [Bug 2935503]: file mtime sets wrong time */
-# define _USE_32BIT_TIME_T
+#if defined(HAVE_SYS_STAT_H) && !defined _WIN32
+# include <sys/stat.h>
#endif
-
-#include <sys/stat.h>
#include "tclInt.h"
-#include "tclPort.h"
-#ifdef MAC_TCL
-#include "tclMacInt.h"
-#endif
#ifdef __WIN32__
-/* for tclWinProcs->useWide */
-#include "tclWinInt.h"
+# include "tclWinInt.h"
#endif
+#include "tclFileSystem.h"
-/*
- * struct FilesystemRecord --
- *
- * A filesystem record is used to keep track of each
- * filesystem currently registered with the core,
- * in a linked list. 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));
-int TclFSNormalizeToUniquePath _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *pathPtr, int startAt));
-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
- */
-static Tcl_PathType FSGetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
- Tcl_Filesystem **filesystemPtrPtr,
- int *driveNameLengthPtr));
-static Tcl_PathType GetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
- Tcl_Filesystem **filesystemPtrPtr,
- int *driveNameLengthPtr, Tcl_Obj **driveNameRef));
-static 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.
+ * Prototypes for functions 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));
+static FilesystemRecord*FsGetFirstFilesystem(void);
+static void FsThrExitProc(ClientData cd);
+static Tcl_Obj * FsListMounts(Tcl_Obj *pathPtr, const char *pattern);
+static void FsAddMountsToGlobResult(Tcl_Obj *resultPtr,
+ Tcl_Obj *pathPtr, const char *pattern,
+ Tcl_GlobTypeData *types);
+static void FsUpdateCwd(Tcl_Obj *cwdObj, ClientData clientData);
#ifdef TCL_THREADS
-static void FsRecacheFilesystemList(void);
+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.
+/*
+ * These form part of the native filesystem support. They are needed here
+ * because we have a few native filesystem functions (which are the same for
+ * win/unix) in this file. There is no need to place them in tclInt.h, because
+ * they are not (and should not be) used anywhere else.
*/
-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).
+MODULE_SCOPE const char * tclpFileAttrStrings[];
+MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[];
+
+/*
+ * The following functions are obsolete string based APIs, and should be
+ * removed in a future release (Tcl 9 would be a good time).
*/
+
/* Obsolete */
int
-Tcl_Stat(path, oldStyleBuf)
- CONST char *path; /* Path of file to stat (in current CP). */
- struct stat *oldStyleBuf; /* Filled with results of stat call. */
+Tcl_Stat(
+ const char *path, /* Path of file to stat (in current CP). */
+ struct stat *oldStyleBuf) /* Filled with results of stat call. */
{
int ret;
Tcl_StatBuf buf;
- Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
+ 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 tmp1, tmp2, tmp3 = 0;
+# define OUT_OF_RANGE(x) \
(((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \
((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX))
-#if defined(__GNUC__) && __GNUC__ >= 2
-/*
- * Workaround gcc warning of "comparison is always false due to limited range of
- * data type" in this macro by checking max type size, and when necessary ANDing
- * with the complement of ULONG_MAX instead of the comparison:
- */
-# define OUT_OF_URANGE(x) \
- ((((Tcl_WideUInt)(~ (__typeof__(x)) 0)) > (Tcl_WideUInt)ULONG_MAX) && \
- (((Tcl_WideUInt)(x)) & ~(Tcl_WideUInt)ULONG_MAX))
-#else
-# define OUT_OF_URANGE(x) \
- (((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX)
-#endif
+# define OUT_OF_URANGE(x) \
+ (((Tcl_WideUInt)(x)) > ((Tcl_WideUInt)ULONG_MAX))
/*
* Perform the result-buffer overflow check manually.
*
* Note that ino_t/ino64_t is unsigned...
+ *
+ * Workaround gcc warning of "comparison is always false due to
+ * limited range of data type" by assigning to tmp var of type
+ * Tcl_WideInt.
*/
- if (OUT_OF_URANGE(buf.st_ino) || OUT_OF_RANGE(buf.st_size)
-#ifdef HAVE_ST_BLOCKS
- || OUT_OF_RANGE(buf.st_blocks)
+ tmp1 = (Tcl_WideInt) buf.st_ino;
+ tmp2 = (Tcl_WideInt) buf.st_size;
+#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
+ tmp3 = (Tcl_WideInt) buf.st_blocks;
#endif
- ) {
-#ifdef EFBIG
+
+ if (OUT_OF_URANGE(tmp1) || OUT_OF_RANGE(tmp2) || OUT_OF_RANGE(tmp3)) {
+#if defined(EFBIG)
errno = EFBIG;
-#else
-# ifdef EOVERFLOW
+#elif defined(EOVERFLOW)
errno = EOVERFLOW;
-# else
-# error "What status should be returned for file size out of range?"
-# endif
+#else
+#error "What status should be returned for file size out of range?"
#endif
return -1;
}
@@ -190,27 +113,33 @@ Tcl_Stat(path, oldStyleBuf)
#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.
+ * 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;
+ oldStyleBuf->st_mode = buf.st_mode;
+ oldStyleBuf->st_ino = (ino_t) buf.st_ino;
+ oldStyleBuf->st_dev = buf.st_dev;
+ oldStyleBuf->st_rdev = buf.st_rdev;
+ oldStyleBuf->st_nlink = buf.st_nlink;
+ oldStyleBuf->st_uid = buf.st_uid;
+ oldStyleBuf->st_gid = buf.st_gid;
+ oldStyleBuf->st_size = (off_t) buf.st_size;
+ oldStyleBuf->st_atime = buf.st_atime;
+ oldStyleBuf->st_mtime = buf.st_mtime;
+ oldStyleBuf->st_ctime = buf.st_ctime;
+#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
+ oldStyleBuf->st_blksize = buf.st_blksize;
+#endif
+#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
+#ifdef HAVE_BLKCNT_T
+ oldStyleBuf->st_blocks = (blkcnt_t) buf.st_blocks;
+#else
+ oldStyleBuf->st_blocks = (unsigned long) buf.st_blocks;
+#endif
#endif
}
return ret;
@@ -218,43 +147,45 @@ Tcl_Stat(path, oldStyleBuf)
/* Obsolete */
int
-Tcl_Access(path, mode)
- CONST char *path; /* Path of file to access (in current CP). */
- int mode; /* Permission setting. */
+Tcl_Access(
+ const char *path, /* Path of file to access (in current CP). */
+ int mode) /* Permission setting. */
{
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
+
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_OpenFileChannel(
+ Tcl_Interp *interp, /* Interpreter for error reporting; can be
+ * NULL. */
+ const char *path, /* Name of file to open. */
+ const char *modeString, /* A list of POSIX open modes or a string such
+ * as "rw". */
+ int permissions) /* If the open involves creating a file, with
+ * what modes to create it? */
{
Tcl_Channel ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
+
Tcl_IncrRefCount(pathPtr);
ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions);
Tcl_DecrRefCount(pathPtr);
- return ret;
+ return ret;
}
/* Obsolete */
int
-Tcl_Chdir(dirName)
- CONST char *dirName;
+Tcl_Chdir(
+ const char *dirName)
{
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(dirName,-1);
@@ -266,9 +197,9 @@ Tcl_Chdir(dirName)
/* Obsolete */
char *
-Tcl_GetCwd(interp, cwdPtr)
- Tcl_Interp *interp;
- Tcl_DString *cwdPtr;
+Tcl_GetCwd(
+ Tcl_Interp *interp,
+ Tcl_DString *cwdPtr)
{
Tcl_Obj *cwd;
cwd = Tcl_FSGetCwd(interp);
@@ -284,9 +215,9 @@ Tcl_GetCwd(interp, cwdPtr)
/* Obsolete */
int
-Tcl_EvalFile(interp, fileName)
- Tcl_Interp *interp; /* Interpreter in which to process file. */
- CONST char *fileName; /* Name of file to process. Tilde-substitution
+Tcl_EvalFile(
+ Tcl_Interp *interp, /* Interpreter in which to process file. */
+ const char *fileName) /* Name of file to process. Tilde-substitution
* will be performed on this name. */
{
int ret;
@@ -297,59 +228,58 @@ Tcl_EvalFile(interp, fileName)
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.
+/*
+ * 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
+#undef USE_OBSOLETE_FS_HOOKS
#ifdef USE_OBSOLETE_FS_HOOKS
+
/*
- * The following typedef declarations allow for hooking into the chain
- * of functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' &
- * 'Tcl_OpenFileChannel(...)'. Basically for each hookable function
- * a linked list is defined.
+ * 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 */
+ 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 */
+ 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 */
+ TclOpenFileChannelProc_ *proc;
+ /* Function to process a
+ * 'Tcl_OpenFileChannel()' call */
struct OpenFileChannelProc *nextPtr;
- /* The next 'Tcl_OpenFileChannel()'
- * function to call */
+ /* 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.
+ * 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.
+ * This method avoids the need to call any sort of "initialization" function.
*
* All three lists are protected by a global obsoleteFsHookMutex.
*/
@@ -362,71 +292,69 @@ 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.
+/*
+ * Declare the native filesystem support. These functions should be considered
+ * private to Tcl, and should really not be called directly by any code other
+ * than this file (i.e. neither by Tcl's core nor by extensions). Similarly,
+ * the old string-based Tclp... native filesystem functions should not be
+ * called.
+ *
+ * The correct API to use now is the Tcl_FS... set of functions, which ensure
+ * correct and complete virtual filesystem support.
+ *
+ * We cannot make all of these static, since some of them are implemented in
+ * the platform-specific directories.
*/
+
static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator;
static Tcl_FSFreeInternalRepProc NativeFreeInternalRep;
-static Tcl_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).
+static Tcl_FSFileAttrsGetProc NativeFileAttrsGet;
+static Tcl_FSFileAttrsSetProc NativeFileAttrsSet;
+
+/*
+ * The only reason these functions are not static is that they are either
+ * called by code in the native (win/unix) directories or they are actually
+ * implemented in those directories. They should simply not be called by code
+ * outside Tcl's native filesystem core i.e. they should be considered
+ * 'static' to Tcl's filesystem code (if we ever built the native filesystem
+ * support into a separate code library, this could actually be enforced).
*/
-Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType;
-Tcl_FSInternalToNormalizedProc TclpNativeToNormalized;
-Tcl_FSStatProc TclpObjStat;
-Tcl_FSAccessProc TclpObjAccess;
-Tcl_FSMatchInDirectoryProc TclpMatchInDirectory;
-Tcl_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_FSFilesystemPathTypeProc TclpFilesystemPathType;
+Tcl_FSInternalToNormalizedProc TclpNativeToNormalized;
+Tcl_FSStatProc TclpObjStat;
+Tcl_FSAccessProc TclpObjAccess;
+Tcl_FSMatchInDirectoryProc TclpMatchInDirectory;
+Tcl_FSChdirProc TclpObjChdir;
+Tcl_FSLstatProc TclpObjLstat;
+Tcl_FSCopyFileProc TclpObjCopyFile;
+Tcl_FSDeleteFileProc TclpObjDeleteFile;
+Tcl_FSRenameFileProc TclpObjRenameFile;
+Tcl_FSCreateDirectoryProc TclpObjCreateDirectory;
+Tcl_FSCopyDirectoryProc TclpObjCopyDirectory;
+Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory;
+Tcl_FSUnloadFileProc TclpUnloadFile;
+Tcl_FSLinkProc TclpObjLink;
+Tcl_FSListVolumesProc TclpObjListVolumes;
+
+/*
+ * Define the native filesystem dispatch table. If necessary, it is ok to make
+ * this non-static, but it should only be accessed by the functions actually
+ * listed within it (or perhaps other helper functions of them). Anything
+ * which is not part of this 'native filesystem implementation' should not be
+ * delving inside here!
*/
+
Tcl_Filesystem tclNativeFilesystem = {
"native",
sizeof(Tcl_Filesystem),
- TCL_FILESYSTEM_VERSION_1,
- &NativePathInFilesystem,
+ TCL_FILESYSTEM_VERSION_2,
+ &TclNativePathInFilesystem,
&TclNativeDupInternalRep,
&NativeFreeInternalRep,
&TclpNativeToNormalized,
- &NativeCreateNativeRep,
+ &TclNativeCreateNativeRep,
&TclpObjNormalizePath,
&TclpFilesystemPathType,
&NativeFilesystemSeparator,
@@ -445,26 +373,28 @@ Tcl_Filesystem tclNativeFilesystem = {
&NativeFileAttrsGet,
&NativeFileAttrsSet,
&TclpObjCreateDirectory,
- &TclpObjRemoveDirectory,
+ &TclpObjRemoveDirectory,
&TclpObjDeleteFile,
&TclpObjCopyFile,
&TclpObjRenameFile,
- &TclpObjCopyDirectory,
+ &TclpObjCopyDirectory,
&TclpObjLstat,
&TclpDlopen,
- &TclpObjGetCwd,
+ /* Needs a cast since we're using version_2 */
+ (Tcl_FSGetCwdProc *) &TclpGetNativeCwd,
&TclpObjChdir
};
-/*
- * Define the tail of the linked list. Note that for unconventional
- * uses of Tcl without a native filesystem, we may in the future wish
- * to modify the current approach of hard-coding the native filesystem
- * in the lookup list 'filesystemList' below.
- *
- * We initialize the record so that it thinks one file uses it. This
- * means it will never be freed.
+/*
+ * 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,
@@ -473,86 +403,79 @@ static FilesystemRecord nativeFilesystemRecord = {
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.
+/*
+ * 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;
+
+static int theFilesystemEpoch = 0;
/*
- * Stores the linked list of filesystems. A 1:1 copy of this
- * list is also maintained in the TSD for each thread. This
- * is to avoid synchronization issues.
+ * 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;
+static FilesystemRecord *filesystemList = &nativeFilesystemRecord;
TCL_DECLARE_MUTEX(filesystemMutex)
-/*
+/*
* Used to implement Tcl_FSGetCwd in a file-system independent way.
*/
+
static Tcl_Obj* cwdPathPtr = NULL;
static int cwdPathEpoch = 0;
+static ClientData cwdClientData = NULL;
TCL_DECLARE_MUTEX(cwdMutex)
-/*
- * 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;
-
-static Tcl_ThreadDataKey dataKey;
-
-/*
- * Declare fallback support function and
- * information for Tcl_FSLoadFile
- */
-static Tcl_FSUnloadFileProc FSUnloadTempFile;
+Tcl_ThreadDataKey tclFsDataKey;
/*
- * 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.
+ * 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_FSUnloadFileProc *unloadProcPtr;
Tcl_Obj *divertedFile;
- Tcl_Filesystem *divertedFilesystem;
+ const Tcl_Filesystem *divertedFilesystem;
ClientData divertedFileNativeRep;
} FsDivertLoad;
-
-/* Now move on to the basic filesystem implementation */
+
+/*
+ * Now move on to the basic filesystem implementation
+ */
static void
-FsThrExitProc(cd)
- ClientData cd;
+FsThrExitProc(
+ ClientData cd)
{
- ThreadSpecificData *tsdPtr = (ThreadSpecificData*)cd;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *) cd;
FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL;
- /* Trash the cwd copy */
+ /*
+ * Trash the cwd copy.
+ */
+
if (tsdPtr->cwdPathPtr != NULL) {
Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
tsdPtr->cwdPathPtr = NULL;
}
- /* Trash the filesystems cache */
+ if (tsdPtr->cwdClientData != NULL) {
+ NativeFreeInternalRep(tsdPtr->cwdClientData);
+ }
+
+ /*
+ * Trash the filesystems cache.
+ */
+
fsRecPtr = tsdPtr->filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr->nextPtr;
@@ -564,47 +487,113 @@ FsThrExitProc(cd)
tsdPtr->initialized = 0;
}
-int
-TclFSCwdPointerEquals(objPtr)
- Tcl_Obj* objPtr;
+int
+TclFSCwdIsNative(void)
{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
+
+ if (tsdPtr->cwdClientData != NULL) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFSCwdPointerEquals --
+ *
+ * Check whether the current working directory is equal to the path
+ * given.
+ *
+ * Results:
+ * 1 (equal) or 0 (un-equal) as appropriate.
+ *
+ * Side effects:
+ * If the paths are equal, but are not the same object, this method will
+ * modify the given pathPtrPtr to refer to the same object. In this case
+ * the object pointed to by pathPtrPtr will have its refCount
+ * decremented, and it will be adjusted to point to the cwd (with a new
+ * refCount).
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclFSCwdPointerEquals(
+ Tcl_Obj** pathPtrPtr)
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
Tcl_MutexLock(&cwdMutex);
- if (tsdPtr->cwdPathPtr == NULL) {
+ if (tsdPtr->cwdPathPtr == NULL
+ || tsdPtr->cwdPathEpoch != cwdPathEpoch) {
+ if (tsdPtr->cwdPathPtr != NULL) {
+ Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
+ }
+ if (tsdPtr->cwdClientData != NULL) {
+ NativeFreeInternalRep(tsdPtr->cwdClientData);
+ }
if (cwdPathPtr == NULL) {
tsdPtr->cwdPathPtr = NULL;
} else {
tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr);
Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
}
- tsdPtr->cwdPathEpoch = cwdPathEpoch;
- } else if (tsdPtr->cwdPathEpoch != cwdPathEpoch) {
- Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
- if (cwdPathPtr == NULL) {
- tsdPtr->cwdPathPtr = NULL;
+ if (cwdClientData == NULL) {
+ tsdPtr->cwdClientData = NULL;
} else {
- tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr);
- Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
+ tsdPtr->cwdClientData = TclNativeDupInternalRep(cwdClientData);
}
+ tsdPtr->cwdPathEpoch = cwdPathEpoch;
}
Tcl_MutexUnlock(&cwdMutex);
if (tsdPtr->initialized == 0) {
- Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData)tsdPtr);
+ Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr);
tsdPtr->initialized = 1;
}
- return (tsdPtr->cwdPathPtr == objPtr);
+
+ if (pathPtrPtr == NULL) {
+ return (tsdPtr->cwdPathPtr == NULL);
+ }
+
+ if (tsdPtr->cwdPathPtr == *pathPtrPtr) {
+ return 1;
+ } else {
+ int len1, len2;
+ const char *str1, *str2;
+
+ str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1);
+ str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2);
+ if (len1 == len2 && !strcmp(str1,str2)) {
+ /*
+ * They are equal, but different objects. Update so they will be
+ * the same object in the future.
+ */
+
+ Tcl_DecrRefCount(*pathPtrPtr);
+ *pathPtrPtr = tsdPtr->cwdPathPtr;
+ Tcl_IncrRefCount(*pathPtrPtr);
+ return 1;
+ } else {
+ return 0;
+ }
+ }
}
-#ifdef TCL_THREADS
+#ifdef TCL_THREADS
static void
FsRecacheFilesystemList(void)
{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL;
- /* Trash the current cache */
+ /*
+ * Trash the current cache.
+ */
+
fsRecPtr = tsdPtr->filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr->nextPtr;
@@ -616,22 +605,25 @@ FsRecacheFilesystemList(void)
tsdPtr->filesystemList = NULL;
/*
- * Code below operates on shared data. We
- * are already called under mutex lock so
- * we can safely proceed.
+ * Code below operates on shared data. We are already called under mutex
+ * lock so we can safely proceed.
+ *
+ * Locate tail of the global filesystem list.
*/
- /* Locate tail of the global filesystem list */
fsRecPtr = filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr;
fsRecPtr = fsRecPtr->nextPtr;
}
-
- /* Refill the cache honouring the order */
+
+ /*
+ * Refill the cache honouring the order.
+ */
+
fsRecPtr = tmpFsRecPtr;
while (fsRecPtr != NULL) {
- tmpFsRecPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord));
+ tmpFsRecPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord));
*tmpFsRecPtr = *fsRecPtr;
tmpFsRecPtr->nextPtr = tsdPtr->filesystemList;
tmpFsRecPtr->prevPtr = NULL;
@@ -639,20 +631,24 @@ FsRecacheFilesystemList(void)
tsdPtr->filesystemList->prevPtr = tmpFsRecPtr;
}
tsdPtr->filesystemList = tmpFsRecPtr;
- fsRecPtr = fsRecPtr->prevPtr;
+ fsRecPtr = fsRecPtr->prevPtr;
}
- /* Make sure the above gets released on thread exit */
+ /*
+ * Make sure the above gets released on thread exit.
+ */
+
if (tsdPtr->initialized == 0) {
- Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData)tsdPtr);
+ Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr);
tsdPtr->initialized = 1;
}
}
-#endif
+#endif /* TCL_THREADS */
static FilesystemRecord *
-FsGetFirstFilesystem(void) {
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+FsGetFirstFilesystem(void)
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
FilesystemRecord *fsRecPtr;
#ifndef TCL_THREADS
tsdPtr->filesystemEpoch = theFilesystemEpoch;
@@ -661,7 +657,7 @@ FsGetFirstFilesystem(void) {
Tcl_MutexLock(&filesystemMutex);
if (tsdPtr->filesystemList == NULL
|| (tsdPtr->filesystemEpoch != theFilesystemEpoch)) {
- FsRecacheFilesystemList();
+ FsRecacheFilesystemList();
tsdPtr->filesystemEpoch = theFilesystemEpoch;
}
Tcl_MutexUnlock(&filesystemMutex);
@@ -670,13 +666,32 @@ FsGetFirstFilesystem(void) {
return fsRecPtr;
}
+/*
+ * The epoch can be changed both by filesystems being added or removed and by
+ * env(HOME) changing.
+ */
+
+int
+TclFSEpochOk(
+ int filesystemEpoch)
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
+ (void) FsGetFirstFilesystem();
+ return (filesystemEpoch == tsdPtr->filesystemEpoch);
+}
+
+/*
+ * If non-NULL, clientData is owned by us and must be freed later.
+ */
+
static void
-FsUpdateCwd(cwdObj)
- Tcl_Obj *cwdObj;
+FsUpdateCwd(
+ Tcl_Obj *cwdObj,
+ ClientData clientData)
{
int len;
char *str = NULL;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
if (cwdObj != NULL) {
str = Tcl_GetStringFromObj(cwdObj, &len);
@@ -684,26 +699,42 @@ FsUpdateCwd(cwdObj)
Tcl_MutexLock(&cwdMutex);
if (cwdPathPtr != NULL) {
- Tcl_DecrRefCount(cwdPathPtr);
+ Tcl_DecrRefCount(cwdPathPtr);
}
+ if (cwdClientData != NULL) {
+ NativeFreeInternalRep(cwdClientData);
+ }
+
if (cwdObj == NULL) {
cwdPathPtr = NULL;
+ cwdClientData = NULL;
} else {
- /* This MUST be stored as string object! */
- cwdPathPtr = Tcl_NewStringObj(str, len);
+ /*
+ * This must be stored as string obj!
+ */
+
+ cwdPathPtr = Tcl_NewStringObj(str, len);
Tcl_IncrRefCount(cwdPathPtr);
+ cwdClientData = TclNativeDupInternalRep(clientData);
}
+
cwdPathEpoch++;
tsdPtr->cwdPathEpoch = cwdPathEpoch;
Tcl_MutexUnlock(&cwdMutex);
if (tsdPtr->cwdPathPtr) {
- Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
+ Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
}
+ if (tsdPtr->cwdClientData) {
+ NativeFreeInternalRep(tsdPtr->cwdClientData);
+ }
+
if (cwdObj == NULL) {
tsdPtr->cwdPathPtr = NULL;
+ tsdPtr->cwdClientData = NULL;
} else {
- tsdPtr->cwdPathPtr = Tcl_NewStringObj(str, len);
+ tsdPtr->cwdPathPtr = Tcl_NewStringObj(str, len);
+ tsdPtr->cwdClientData = clientData;
Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
}
}
@@ -713,12 +744,12 @@ FsUpdateCwd(cwdObj)
*
* 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.
- *
+ * 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.
*
@@ -729,31 +760,38 @@ FsUpdateCwd(cwdObj)
*/
void
-TclFinalizeFilesystem()
+TclFinalizeFilesystem(void)
{
FilesystemRecord *fsRecPtr;
- /*
- * Assumption that only one thread is active now. Otherwise
- * we would need to put various mutexes around this code.
+ /*
+ * 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;
+ cwdPathEpoch = 0;
+ }
+ if (cwdClientData != NULL) {
+ NativeFreeInternalRep(cwdClientData);
+ cwdClientData = NULL;
}
- /*
- * Remove all filesystems, freeing any allocated memory
- * that is no longer needed
+ /*
+ * Remove all filesystems, freeing any allocated memory that is no longer
+ * needed
*/
fsRecPtr = filesystemList;
while (fsRecPtr != NULL) {
FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr;
if (fsRecPtr->fileRefCount <= 0) {
- /* The native filesystem is static, so we don't free it */
+ /*
+ * The native filesystem is static, so we don't free it.
+ */
+
if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
ckfree((char *)fsRecPtr);
}
@@ -763,13 +801,15 @@ TclFinalizeFilesystem()
filesystemList = NULL;
/*
- * Now filesystemList is NULL. This means that any attempt
- * to use the filesystem is likely to fail.
+ * Now filesystemList is NULL. This means that any attempt to use the
+ * filesystem is likely to fail.
*/
+#ifdef USE_OBSOLETE_FS_HOOKS
statProcList = NULL;
accessProcList = NULL;
openFileChannelProcList = NULL;
+#endif
#ifdef __WIN32__
TclWinEncodingsCleanup();
#endif
@@ -781,7 +821,7 @@ TclFinalizeFilesystem()
* TclResetFilesystem --
*
* Restore the filesystem to a pristine state.
- *
+ *
* Results:
* None.
*
@@ -792,22 +832,21 @@ TclFinalizeFilesystem()
*/
void
-TclResetFilesystem()
+TclResetFilesystem(void)
{
filesystemList = &nativeFilesystemRecord;
- /*
- * Note, at this point, I believe nativeFilesystemRecord ->
- * fileRefCount should equal 1 and if not, we should try to track
- * down the cause.
+ /*
+ * 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.
+ /*
+ * 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
}
@@ -817,36 +856,35 @@ TclResetFilesystem()
*
* 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.
+ * 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.
+ * 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.
+ * 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. */
+Tcl_FSRegister(
+ ClientData clientData, /* Client specific data for this fs */
+ Tcl_Filesystem *fsPtr) /* The filesystem record for the new fs. */
{
FilesystemRecord *newFilesystemPtr;
@@ -858,25 +896,27 @@ Tcl_FSRegister(clientData, fsPtr)
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.
+
+ /*
+ * 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
+ /*
+ * 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.
+ *
+ * However, since registering and unregistering filesystems is a very rare
+ * action, this is not a very important point.
*/
+
Tcl_MutexLock(&filesystemMutex);
newFilesystemPtr->nextPtr = filesystemList;
@@ -886,10 +926,11 @@ Tcl_FSRegister(clientData, fsPtr)
}
filesystemList = newFilesystemPtr;
- /*
- * Increment the filesystem epoch counter, since existing paths
- * might conceivably now belong to different filesystems.
+ /*
+ * Increment the filesystem epoch counter, since existing paths might
+ * conceivably now belong to different filesystems.
*/
+
theFilesystemEpoch++;
Tcl_MutexUnlock(&filesystemMutex);
@@ -901,29 +942,28 @@ Tcl_FSRegister(clientData, fsPtr)
*
* Tcl_FSUnregister --
*
- * Remove the passed filesystem from the list of filesystem
- * function tables. It also ensures that the built-in
- * (native) filesystem is not 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).
+ * 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.
+ * TCL_OK if the function pointer was successfully removed, TCL_ERROR
+ * otherwise.
*
* Side effects:
- * Memory may be deallocated (or will be later, once no "path"
- * objects refer to this filesystem), but the list of registered
- * filesystems is updated immediately.
+ * 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. */
+Tcl_FSUnregister(
+ Tcl_Filesystem *fsPtr) /* The filesystem record to remove. */
{
int retVal = TCL_ERROR;
FilesystemRecord *fsRecPtr;
@@ -931,9 +971,9 @@ Tcl_FSUnregister(fsPtr)
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.
+ * 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;
@@ -947,19 +987,20 @@ Tcl_FSUnregister(fsPtr)
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).
+
+ /*
+ * 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);
+ ckfree((char *)fsRecPtr);
}
retVal = TCL_OK;
@@ -969,7 +1010,7 @@ Tcl_FSUnregister(fsPtr)
}
Tcl_MutexUnlock(&filesystemMutex);
- return (retVal);
+ return retVal;
}
/*
@@ -977,132 +1018,145 @@ Tcl_FSUnregister(fsPtr)
*
* Tcl_FSMatchInDirectory --
*
- * This routine is used by the globbing code to search a directory
- * for all files which match a given pattern. The appropriate
- * function for the filesystem to which pathPtr belongs will be
- * called. If pathPtr 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.
- *
+ * This routine is used by the globbing code to search a directory for
+ * all files which match a given pattern. The appropriate function for
+ * the filesystem to which pathPtr belongs will be called. If pathPtr
+ * does not belong to any filesystem and if it is NULL or the empty
+ * string, then we assume the pattern is to be matched in the current
+ * working directory. To avoid have the Tcl_FSMatchInDirectoryProc for
+ * each filesystem from having to deal with this issue, we create a
+ * pathPtr on the fly (equal to the cwd), and then remove it from the
+ * results returned. This makes filesystems easy to write, since they can
+ * assume the pathPtr passed to them is an ordinary path. In fact this
+ * means we could remove such special case handling from Tcl's native
+ * filesystems.
+ *
+ * If 'pattern' is NULL, then pathPtr is assumed to be a fully specified
+ * path of a single file/directory which must be checked for existence
+ * and correct type.
+ *
+ * Results:
+ *
+ * The return value is a standard Tcl result indicating whether an error
+ * occurred in globbing. Error messages are placed in interp, but good
+ * results are placed in the resultPtr given.
+ *
* Recursive searches, e.g.
- *
- * glob -dir $dir -join * pkgIndex.tcl
- *
- * which must recurse through each directory matching '*' are
- * handled internally by Tcl, by passing specific flags in a
- * modified 'types' parameter. This means the actual filesystem
- * only ever sees patterns which match in a single directory.
+ * 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.
+Tcl_FSMatchInDirectory(
+ Tcl_Interp *interp, /* Interpreter to receive error messages, but
+ * may be NULL. */
+ Tcl_Obj *resultPtr, /* List object to receive results. */
+ Tcl_Obj *pathPtr, /* Contains path to directory to search. */
+ const char *pattern, /* Pattern to match against. */
+ Tcl_GlobTypeData *types) /* Object containing list of acceptable types.
* May be NULL. In particular the directory
* flag is very important. */
{
- Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ const Tcl_Filesystem *fsPtr;
+ Tcl_Obj *cwd, *tmpResultPtr, **elemsPtr;
+ int resLength, i, ret = -1;
+
+ if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) {
+ /*
+ * We don't currently allow querying of mounts by external code (a
+ * valuable future step), so since we're the only function that
+ * actually knows about mounts, this means we're being called
+ * recursively by ourself. Return no matches.
+ */
+
+ return TCL_OK;
+ }
+
+ if (pathPtr != NULL) {
+ fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ } else {
+ fsPtr = NULL;
+ }
+
+ /*
+ * Check if we've successfully mapped the path to a filesystem within
+ * which to search.
+ */
+
if (fsPtr != NULL) {
- 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;
+ if (fsPtr->matchInDirectoryProc == NULL) {
+ Tcl_SetErrno(ENOENT);
+ return -1;
}
- } 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;
- }
+ ret = (*fsPtr->matchInDirectoryProc)(interp, resultPtr, pathPtr,
+ pattern, types);
+ if (ret == TCL_OK && pattern != NULL) {
+ FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types);
}
- /*
- * 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;
+ return ret;
+ }
+
+ /*
+ * If the path isn't empty, we have no idea how to match files in a
+ * directory which belongs to no known filesystem
+ */
+
+ if (pathPtr != NULL && TclGetString(pathPtr)[0] != '\0') {
+ Tcl_SetErrno(ENOENT);
+ return -1;
+ }
+
+ /*
+ * We have an empty or NULL path. This is defined to mean we must search
+ * for files within the current 'cwd'. We therefore use that, but then
+ * since the proc we call will return results which include the cwd we
+ * must then trim it off the front of each path in the result. We choose
+ * to deal with this here (in the generic code), since if we don't, every
+ * single filesystem's implementation of Tcl_FSMatchInDirectory will have
+ * to deal with it for us.
+ */
+
+ cwd = Tcl_FSGetCwd(NULL);
+ if (cwd == NULL) {
+ if (interp != NULL) {
+ Tcl_SetResult(interp, "glob couldn't determine "
+ "the current working directory", TCL_STATIC);
}
- 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);
+ return TCL_ERROR;
+ }
+
+ fsPtr = Tcl_FSGetFileSystemForPath(cwd);
+ if (fsPtr != NULL && fsPtr->matchInDirectoryProc != NULL) {
+ TclNewObj(tmpResultPtr);
+ Tcl_IncrRefCount(tmpResultPtr);
+ ret = (*fsPtr->matchInDirectoryProc)(interp, tmpResultPtr, cwd,
+ pattern, types);
+ if (ret == TCL_OK) {
+ FsAddMountsToGlobResult(tmpResultPtr, cwd, pattern, types);
+
+ /*
+ * Note that we know resultPtr and tmpResultPtr are distinct.
+ */
+
+ ret = Tcl_ListObjGetElements(interp, tmpResultPtr,
+ &resLength, &elemsPtr);
+ for (i=0 ; ret==TCL_OK && i<resLength ; i++) {
+ ret = Tcl_ListObjAppendElement(interp, resultPtr,
+ TclFSMakePathRelative(interp, elemsPtr[i], cwd));
}
}
- Tcl_DecrRefCount(cwd);
- return ret;
+ TclDecrRefCount(tmpResultPtr);
}
- Tcl_SetErrno(ENOENT);
- return -1;
+ Tcl_DecrRefCount(cwd);
+ return ret;
}
/*
@@ -1110,85 +1164,104 @@ Tcl_FSMatchInDirectory(interp, result, pathPtr, pattern, types)
*
* FsAddMountsToGlobResult --
*
- * This routine is used by the globbing code to take the results
- * of a directory listing and add any mounted paths to that
- * listing. This is 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.
+ * 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.
*
- * Side effects:
+ * Results:
* None.
*
- *----------------------------------------------------------------------
+ * Side effects:
+ * Modifies the resultPtr.
+ *
+ *----------------------------------------------------------------------
*/
-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;
+
+static void
+FsAddMountsToGlobResult(
+ Tcl_Obj *resultPtr, /* The current list of matching paths; must
+ * not be shared! */
+ Tcl_Obj *pathPtr, /* The directory in question */
+ const char *pattern, /* Pattern to match against. */
+ Tcl_GlobTypeData *types) /* Object containing list of acceptable types.
+ * May be NULL. In particular the directory
+ * flag is very important. */
{
int mLength, gLength, i;
int dir = (types == NULL || (types->type & TCL_GLOB_TYPE_DIR));
Tcl_Obj *mounts = FsListMounts(pathPtr, pattern);
- if (mounts == NULL) return result;
+ if (mounts == NULL) {
+ return;
+ }
if (Tcl_ListObjLength(NULL, mounts, &mLength) != TCL_OK || mLength == 0) {
goto endOfMounts;
}
- if (Tcl_ListObjLength(NULL, result, &gLength) != TCL_OK) {
+ if (Tcl_ListObjLength(NULL, resultPtr, &gLength) != TCL_OK) {
goto endOfMounts;
}
- for (i = 0; i < mLength; i++) {
+ 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++) {
+ for (j=0 ; j<gLength ; j++) {
Tcl_Obj *gElt;
- Tcl_ListObjIndex(NULL, result, j, &gElt);
+
+ Tcl_ListObjIndex(NULL, resultPtr, 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);
+ /*
+ * We don't want to list this.
+ */
+
+ Tcl_ListObjReplace(NULL, resultPtr, j, 1, 0, NULL);
gLength--;
}
- /* Break out of for loop */
- break;
+ break; /* Break out of for loop */
}
}
if (!found && dir) {
- if (Tcl_IsShared(result)) {
- Tcl_Obj *newList;
- newList = Tcl_DuplicateObj(result);
- Tcl_DecrRefCount(result);
- result = newList;
+ Tcl_Obj *norm;
+ int len, mlen;
+
+ /*
+ * We know mElt is absolute normalized and lies inside pathPtr, so
+ * now we must add to the result the right representation of mElt,
+ * i.e. the representation which is relative to pathPtr.
+ */
+
+ norm = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (norm != NULL) {
+ const char *path, *mount;
+
+ mount = Tcl_GetStringFromObj(mElt, &mlen);
+ path = Tcl_GetStringFromObj(norm, &len);
+ if (path[len-1] == '/') {
+ /*
+ * Deal with the root of the volume.
+ */
+
+ len--;
+ }
+ len++; /* account for '/' in the mElt [Bug 1602539] */
+ mElt = TclNewFSPathObj(pathPtr, mount + len, mlen - len);
+ Tcl_ListObjAppendElement(NULL, resultPtr, mElt);
}
- Tcl_ListObjAppendElement(NULL, result, mElt);
- /*
- * No need to increment gLength, since we
- * don't want to compare mounts against
- * mounts.
+ /*
+ * No need to increment gLength, since we don't want to compare
+ * mounts against mounts.
*/
}
}
+
endOfMounts:
Tcl_DecrRefCount(mounts);
- return result;
}
/*
@@ -1196,65 +1269,65 @@ FsAddMountsToGlobResult(result, pathPtr, pattern, types)
*
* 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.
+ * 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.
+ * 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).
+ * 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;
+Tcl_FSMountsChanged(
+ Tcl_Filesystem *fsPtr)
{
- /*
- * We currently don't do anything with this parameter. We
- * could in the future only invalidate files for this filesystem
- * or otherwise take more advanced action.
+ /*
+ * 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.
+
+ /*
+ * Increment the filesystem epoch counter, since existing paths might now
+ * belong to different filesystems.
*/
+
Tcl_MutexLock(&filesystemMutex);
theFilesystemEpoch++;
Tcl_MutexUnlock(&filesystemMutex);
@@ -1265,31 +1338,31 @@ Tcl_FSMountsChanged(fsPtr)
*
* Tcl_FSData --
*
- * Retrieve the clientData field for the filesystem given,
- * or NULL if that filesystem is not registered.
+ * 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.
+ * 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.
+ * None.
*
*----------------------------------------------------------------------
*/
ClientData
-Tcl_FSData(fsPtr)
- Tcl_Filesystem *fsPtr; /* The filesystem record to query. */
+Tcl_FSData(
+ 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.
+ * Traverse the list of filesystems look for a particular one. If found,
+ * return that filesystem's clientData (originally provided when calling
+ * Tcl_FSRegister).
*/
while ((retVal == NULL) && (fsRecPtr != NULL)) {
@@ -1305,196 +1378,77 @@ Tcl_FSData(fsPtr)
/*
*---------------------------------------------------------------------------
*
- * 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.
- *
- *---------------------------------------------------------------------------
- */
-static 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) {
- 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);
- /*
- * Since we know it is a normalized path, we can
- * actually convert this object into an "path" object for
- * greater efficiency
- */
- TclFSMakePathFromNormalized(interp, retVal);
- if (clientDataPtr != NULL) {
- *clientDataPtr = NULL;
- }
- } 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).
+ * Takes a path specification containing no ../, ./ sequences, and
+ * converts it into a unique path for the given platform. On Unix, this
+ * means the path must be free of symbolic links/aliases, and on Windows
+ * it means we want the long form, with that long form's case-dependence
+ * (which gives us a unique, case-dependent path).
*
* Results:
- * The pathPtr is modified in place. The return value is
- * the last byte offset which was recognised in the path
- * string.
+ * 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).
+ * If the filesystem-specific normalizePathProcs can re-introduce ../, ./
+ * sequences into the path, then this function will not return the
+ * correct result. This may be possible with symbolic links on unix.
+ *
+ * Important assumption: if startAt is non-zero, it must point to a
+ * directory separator that we know exists and is already normalized (so
+ * it is important not to point to the char just after the separator).
+ *
*---------------------------------------------------------------------------
*/
+
int
-TclFSNormalizeToUniquePath(interp, pathPtr, startAt)
- Tcl_Interp *interp;
- Tcl_Obj *pathPtr;
- int startAt;
+TclFSNormalizeToUniquePath(
+ Tcl_Interp *interp, /* Used for error messages. */
+ Tcl_Obj *pathPtr, /* The path to normalize in place */
+ int startAt) /* Start at this char-offset */
{
FilesystemRecord *fsRecPtr, *firstFsRecPtr;
-
+
/*
- * 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).
+ * 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->fsPtr == &tclNativeFilesystem) {
+ if (fsRecPtr->fsPtr == &tclNativeFilesystem) {
Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;
if (proc != NULL) {
startAt = (*proc)(interp, pathPtr, startAt);
}
break;
- }
+ }
fsRecPtr = fsRecPtr->nextPtr;
}
-
- fsRecPtr = firstFsRecPtr;
+
+ fsRecPtr = firstFsRecPtr;
while (fsRecPtr != NULL) {
- /* Skip the native system next time through */
+ /*
+ * Skip the native system next time through.
+ */
+
if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;
if (proc != NULL) {
startAt = (*proc)(interp, pathPtr, startAt);
}
- /*
+
+ /*
* We could add an efficiency check like this:
- *
- * if (retVal == length-of(pathPtr)) {break;}
- *
+ * if (retVal == length-of(pathPtr)) {break;}
* but there's not much benefit.
*/
}
@@ -1509,10 +1463,40 @@ TclFSNormalizeToUniquePath(interp, pathPtr, startAt)
*
* TclGetOpenMode --
*
- * Description:
+ * This routine is an obsolete, limited version of TclGetOpenModeEx()
+ * below. It exists only to satisfy any extensions imprudently using it
+ * via Tcl's internal stubs table.
+ *
+ * Results:
+ * Same as TclGetOpenModeEx().
+ *
+ * Side effects:
+ * Same as TclGetOpenModeEx().
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclGetOpenMode(
+ Tcl_Interp *interp, /* Interpreter to use for error reporting -
+ * may be NULL. */
+ const char *modeString, /* Mode string, e.g. "r+" or "RDONLY CREAT" */
+ int *seekFlagPtr) /* Set this to 1 if the caller should seek to
+ * EOF during the opening of the file. */
+{
+ int binary = 0;
+ return TclGetOpenModeEx(interp, modeString, seekFlagPtr, &binary);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclGetOpenModeEx --
+ *
* 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.
+ * and also sets flags to indicate whether the caller should seek to EOF
+ * after opening the file, and whether the caller should configure the
+ * channel for binary data.
*
* Results:
* On success, returns mode to pass to "open". If an error occurs, the
@@ -1520,37 +1504,41 @@ TclFSNormalizeToUniquePath(interp, pathPtr, startAt)
* 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.
+ * Sets the integer referenced by seekFlagPtr to 1 to tell the caller to
+ * seek to EOF after opening the file, or to 0 otherwise. Sets the
+ * integer referenced by binaryPtr to 1 to tell the caller to seek to
+ * configure the channel for binary data, or to 0 otherwise.
*
* Special note:
- * This code is based on a prototype implementation contributed
- * by Mark Diekhans.
+ * 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. */
+TclGetOpenModeEx(
+ Tcl_Interp *interp, /* Interpreter to use for error reporting -
+ * may be NULL. */
+ const char *modeString, /* Mode string, e.g. "r+" or "RDONLY CREAT" */
+ int *seekFlagPtr, /* Set this to 1 if the caller should seek to
+ * EOF during the opening of the file. */
+ int *binaryPtr) /* Set this to 1 if the caller should
+ * configure the opened channel for binary
+ * operations */
{
int mode, modeArgc, c, i, gotRW;
- CONST char **modeArgv, *flag;
+ const char **modeArgv, *flag;
#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)
/*
- * Check for the simpler fopen-like access modes (e.g. "r"). They
- * are distinguished from the POSIX access modes by the presence
- * of a lower-case first letter.
+ * Check for the simpler fopen-like access modes (e.g. "r"). They are
+ * distinguished from the POSIX access modes by the presence of a
+ * lower-case first letter.
*/
*seekFlagPtr = 0;
+ *binaryPtr = 0;
mode = 0;
/*
@@ -1558,66 +1546,82 @@ TclGetOpenMode(interp, string, seekFlagPtr)
* 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':
- /* [Bug 680143].
- * Added O_APPEND for proper automatic
- * seek-to-end-on-write by the OS.
+ if (!(modeString[0] & 0x80)
+ && islower(UCHAR(modeString[0]))) { /* INTL: ISO only. */
+ switch (modeString[0]) {
+ case 'r':
+ mode = O_RDONLY;
+ break;
+ case 'w':
+ mode = O_WRONLY|O_CREAT|O_TRUNC;
+ break;
+ case 'a':
+ /*
+ * Added O_APPEND for proper automatic seek-to-end-on-write by the
+ * OS. [Bug 680143]
+ */
+
+ mode = O_WRONLY|O_CREAT|O_APPEND;
+ *seekFlagPtr = 1;
+ break;
+ default:
+ goto error;
+ }
+ i=1;
+ while (i<3 && modeString[i]) {
+ if (modeString[i] == modeString[i-1]) {
+ goto error;
+ }
+ switch (modeString[i++]) {
+ case '+':
+ /*
+ * Must remove the O_APPEND flag so that the seek command
+ * works. [Bug 1773127]
*/
- mode = O_WRONLY|O_CREAT|O_APPEND;
- *seekFlagPtr = 1;
+
+ mode &= ~(O_RDONLY|O_WRONLY|O_APPEND);
+ mode |= O_RDWR;
+ break;
+ case 'b':
+ *binaryPtr = 1;
break;
default:
- error:
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp,
- "illegal access mode \"", string, "\"",
- (char *) NULL);
- }
- return -1;
- }
- if (string[1] == '+') {
- /*
- * Must remove the O_APPEND flag so that the seek command
- * works. [Bug 1773127]
- */
- mode &= ~(O_RDONLY|O_WRONLY|O_APPEND);
- mode |= O_RDWR;
- if (string[2] != 0) {
goto error;
}
- } else if (string[1] != 0) {
+ }
+ if (modeString[i] != 0) {
goto error;
}
- return mode;
+ return mode;
+
+ error:
+ *seekFlagPtr = 0;
+ *binaryPtr = 0;
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, "illegal access mode \"", modeString,
+ "\"", NULL);
+ }
+ return -1;
}
/*
- * The access modes are specified using a list of POSIX modes
- * such as O_CREAT.
+ * 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.
+ * 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;
+ if (Tcl_SplitList(interp, modeString, &modeArgc, &modeArgv) != TCL_OK) {
+ if (interp != NULL) {
+ Tcl_AddErrorInfo(interp,
+ "\n while processing open access modes \"");
+ Tcl_AddErrorInfo(interp, modeString);
+ Tcl_AddErrorInfo(interp, "\"");
+ }
+ return -1;
}
-
+
gotRW = 0;
for (i = 0; i < modeArgc; i++) {
flag = modeArgv[i];
@@ -1633,88 +1637,106 @@ TclGetOpenMode(interp, string, seekFlagPtr)
gotRW = 1;
} else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) {
mode |= O_APPEND;
- *seekFlagPtr = 1;
+ *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);
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, "access mode \"", flag,
+ "\" not supported by this system", NULL);
+ }
+ ckfree((char *) modeArgv);
return -1;
#endif
+
} else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) {
-#if defined(O_NDELAY) || defined(O_NONBLOCK)
-# ifdef O_NONBLOCK
+#ifdef O_NONBLOCK
mode |= O_NONBLOCK;
-# else
- mode |= O_NDELAY;
-# endif
#else
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "access mode \"", flag,
- "\" not supported by this system", (char *) NULL);
- }
- ckfree((char *) modeArgv);
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, "access mode \"", flag,
+ "\" not supported by this system", NULL);
+ }
+ ckfree((char *) modeArgv);
return -1;
#endif
+
} else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) {
mode |= O_TRUNC;
+ } else if ((c == 'B') && (strcmp(flag, "BINARY") == 0)) {
+ *binaryPtr = 1;
} else {
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "invalid access mode \"", flag,
- "\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT",
- " EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL);
- }
+
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, "invalid access mode \"", flag,
+ "\": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, "
+ "CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC", NULL);
+ }
ckfree((char *) modeArgv);
return -1;
}
}
+
ckfree((char *) modeArgv);
+
if (!gotRW) {
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "access mode must include either",
- " RDONLY, WRONLY, or RDWR", (char *) NULL);
- }
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, "access mode must include either"
+ " RDONLY, WRONLY, or RDWR", NULL);
+ }
return -1;
}
return mode;
}
/*
+ * Tcl_FSEvalFile is Tcl_FSEvalFileEx without encoding argument.
+ */
+
+int
+Tcl_FSEvalFile(
+ Tcl_Interp *interp, /* Interpreter in which to process file. */
+ Tcl_Obj *pathPtr) /* Path of file to process. Tilde-substitution
+ * will be performed on this name. */
+{
+ return Tcl_FSEvalFileEx(interp, pathPtr, NULL);
+}
+
+/*
*----------------------------------------------------------------------
*
- * Tcl_FSEvalFile --
+ * Tcl_FSEvalFileEx --
*
- * Read in a file and process the entire file as one gigantic
- * Tcl command.
+ * 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.
+ * 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).
+ * 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
+Tcl_FSEvalFileEx(
+ Tcl_Interp *interp, /* Interpreter in which to process file. */
+ Tcl_Obj *pathPtr, /* Path of file to process. Tilde-substitution
* will be performed on this name. */
+ const char *encodingName) /* If non-NULL, then use this encoding for the
+ * file. NULL means use the system encoding. */
{
- int result, length;
+ int length, result = TCL_ERROR;
Tcl_StatBuf statBuf;
Tcl_Obj *oldScriptFile;
Interp *iPtr;
@@ -1723,41 +1745,52 @@ Tcl_FSEvalFile(interp, pathPtr)
Tcl_Obj *objPtr;
if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
- return TCL_ERROR;
+ return result;
}
- result = TCL_ERROR;
- objPtr = Tcl_NewObj();
- Tcl_IncrRefCount(objPtr);
-
if (Tcl_FSStat(pathPtr, &statBuf) == -1) {
- Tcl_SetErrno(errno);
- Tcl_AppendResult(interp, "couldn't read file \"",
- Tcl_GetString(pathPtr),
- "\": ", Tcl_PosixError(interp), (char *) NULL);
- goto end;
+ Tcl_SetErrno(errno);
+ Tcl_AppendResult(interp, "couldn't read file \"",
+ Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
+ return result;
}
chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644);
if (chan == (Tcl_Channel) NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "couldn't read file \"",
- Tcl_GetString(pathPtr),
- "\": ", Tcl_PosixError(interp), (char *) NULL);
- goto end;
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "couldn't read file \"",
+ Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
+ return result;
}
+
/*
- * The eofchar is \32 (^Z). This is the usual on Windows, but we
- * effect this cross-platform to allow for scripted documents.
- * [Bug: 2040]
+ * The eofchar is \32 (^Z). This is the usual on Windows, but we effect
+ * this cross-platform to allow for scripted documents. [Bug: 2040]
*/
+
Tcl_SetChannelOption(interp, chan, "-eofchar", "\32");
+
+ /*
+ * If the encoding is specified, set it for the channel. Else don't touch
+ * it (and use the system encoding) Report error on unknown encoding.
+ */
+
+ if (encodingName != NULL) {
+ if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
+ != TCL_OK) {
+ Tcl_Close(interp,chan);
+ return result;
+ }
+ }
+
+ objPtr = Tcl_NewObj();
+ Tcl_IncrRefCount(objPtr);
/* Try to read first character of stream, so we can
* check for utf-8 BOM to be handled especially.
*/
if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) {
Tcl_Close(interp, chan);
- Tcl_AppendResult(interp, "couldn't read file \"",
- Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_AppendResult(interp, "couldn't read file \"",
+ Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
goto end;
}
string = Tcl_GetString(objPtr);
@@ -1772,8 +1805,9 @@ Tcl_FSEvalFile(interp, pathPtr)
Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
goto end;
}
+
if (Tcl_Close(interp, chan) != TCL_OK) {
- goto end;
+ goto end;
}
iPtr = (Interp *) interp;
@@ -1781,18 +1815,17 @@ Tcl_FSEvalFile(interp, pathPtr)
iPtr->scriptFile = pathPtr;
Tcl_IncrRefCount(iPtr->scriptFile);
string = Tcl_GetStringFromObj(objPtr, &length);
-
-#ifdef TCL_TIP280
/* TIP #280 Force the evaluator to open a frame for a sourced
* file. */
iPtr->evalFlags |= TCL_EVAL_FILE;
-#endif
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'.
+ * iPtr->scriptFile value, so we must reset it without assuming it still
+ * points to 'pathPtr'.
*/
+
if (iPtr->scriptFile != NULL) {
Tcl_DecrRefCount(iPtr->scriptFile);
}
@@ -1801,18 +1834,21 @@ Tcl_FSEvalFile(interp, pathPtr)
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);
+ const char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
+ int limit = 150;
+ int overflow = (length > limit);
+
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (file \"%.*s%s\" line %d)",
+ (overflow ? limit : length), pathString,
+ (overflow ? "..." : ""), interp->errorLine));
}
- end:
+ end:
Tcl_DecrRefCount(objPtr);
return result;
}
@@ -1823,21 +1859,21 @@ Tcl_FSEvalFile(interp, pathPtr)
* 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.
+ * 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.
+ * 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()
+Tcl_GetErrno(void)
{
return errno;
}
@@ -1859,8 +1895,8 @@ Tcl_GetErrno()
*/
void
-Tcl_SetErrno(err)
- int err; /* The new value. */
+Tcl_SetErrno(
+ int err) /* The new value. */
{
errno = err;
}
@@ -1870,32 +1906,31 @@ Tcl_SetErrno(err)
*
* Tcl_PosixError --
*
- * This procedure is typically called after UNIX kernel calls
- * return errors. It stores machine-readable information about
- * the error in $errorCode returns an information string for
- * the caller's use.
+ * This function is typically called after UNIX kernel calls return
+ * errors. It stores machine-readable information about the error in
+ * errorCode field of interp and returns an information string for the
+ * caller's use.
*
* Results:
- * The return value is a human-readable string describing the
- * error.
+ * The return value is a human-readable string describing the error.
*
* Side effects:
- * The global variable $errorCode is reset.
+ * The errorCode field of the interp is set.
*
*----------------------------------------------------------------------
*/
-CONST char *
-Tcl_PosixError(interp)
- Tcl_Interp *interp; /* Interpreter whose $errorCode variable
- * is to be changed. */
+const char *
+Tcl_PosixError(
+ Tcl_Interp *interp) /* Interpreter whose errorCode field is to be
+ * set. */
{
- CONST char *id, *msg;
+ const char *id, *msg;
msg = Tcl_ErrnoMsg(errno);
id = Tcl_ErrnoId();
if (interp) {
- Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL);
+ Tcl_SetErrorCode(interp, "POSIX", id, msg, NULL);
}
return msg;
}
@@ -1905,37 +1940,37 @@ Tcl_PosixError(interp)
*
* 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.
+ * This function replaces the library version of stat and lsat.
+ *
+ * The appropriate function for the filesystem to which pathPtr belongs
+ * will be called.
*
* Results:
- * See stat documentation.
+ * See stat documentation.
*
* Side effects:
- * See stat documentation.
+ * 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_FSStat(
+ Tcl_Obj *pathPtr, /* Path of file to stat (in current CP). */
+ Tcl_StatBuf *buf) /* Filled with results of stat call. */
{
- Tcl_Filesystem *fsPtr;
+ const Tcl_Filesystem *fsPtr;
#ifdef USE_OBSOLETE_FS_HOOKS
- Tcl_StatBuf oldStyleStatBuffer;
+ 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.
+ * 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;
@@ -1955,13 +1990,14 @@ Tcl_FSStat(pathPtr, buf)
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.)
+ * 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;
@@ -1973,13 +2009,16 @@ Tcl_FSStat(pathPtr, buf)
buf->st_atime = oldStyleStatBuffer.st_atime;
buf->st_mtime = oldStyleStatBuffer.st_mtime;
buf->st_ctime = oldStyleStatBuffer.st_ctime;
-#ifdef HAVE_ST_BLOCKS
+#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
buf->st_blksize = oldStyleStatBuffer.st_blksize;
+#endif
+#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
buf->st_blocks = Tcl_LongAsWide(oldStyleStatBuffer.st_blocks);
#endif
- return retVal;
+ return retVal;
}
#endif /* USE_OBSOLETE_FS_HOOKS */
+
fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSStatProc *proc = fsPtr->statProc;
@@ -1996,27 +2035,26 @@ Tcl_FSStat(pathPtr, buf)
*
* 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.
+ * This function replaces the library version of lstat. The appropriate
+ * function for the filesystem to which pathPtr belongs will be called.
+ * If no 'lstat' function is listed, but a 'stat' function is, then Tcl
+ * will fall back on the stat function.
*
* Results:
- * See lstat documentation.
+ * See lstat documentation.
*
* Side effects:
- * See lstat documentation.
+ * 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_FSLstat(
+ Tcl_Obj *pathPtr, /* Path of file to stat (in current CP). */
+ Tcl_StatBuf *buf) /* Filled with results of stat call. */
{
- Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSLstatProc *proc = fsPtr->lstatProc;
if (proc != NULL) {
@@ -2037,31 +2075,30 @@ Tcl_FSLstat(pathPtr, buf)
*
* Tcl_FSAccess --
*
- * This procedure replaces the library version of access.
- * The appropriate function for the filesystem to which pathPtr
- * belongs will be called.
+ * This function replaces the library version of access. The appropriate
+ * function for the filesystem to which pathPtr belongs will be called.
*
* Results:
- * See access documentation.
+ * See access documentation.
*
* Side effects:
- * See access documentation.
+ * See access documentation.
*
*----------------------------------------------------------------------
*/
int
-Tcl_FSAccess(pathPtr, mode)
- Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */
- int mode; /* Permission setting. */
+Tcl_FSAccess(
+ Tcl_Obj *pathPtr, /* Path of file to access (in current CP). */
+ int mode) /* Permission setting. */
{
- Tcl_Filesystem *fsPtr;
+ const Tcl_Filesystem *fsPtr;
#ifdef USE_OBSOLETE_FS_HOOKS
int retVal = -1;
/*
- * Call each of the "access" function in succession. A non-return
- * value of -1 indicates the particular function has succeeded.
+ * Call each of the "access" function in succession. A non-return value of
+ * -1 indicates the particular function has succeeded.
*/
Tcl_MutexLock(&obsoleteFsHookMutex);
@@ -2085,12 +2122,13 @@ Tcl_FSAccess(pathPtr, mode)
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;
@@ -2108,38 +2146,36 @@ Tcl_FSAccess(pathPtr, mode)
*
* Tcl_FSOpenFileChannel --
*
- * The appropriate function for the filesystem to which pathPtr
- * belongs will be called.
+ * 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.
+ * 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_FSOpenFileChannel(
+ Tcl_Interp *interp, /* Interpreter for error reporting; can be
+ * NULL. */
+ Tcl_Obj *pathPtr, /* Name of file to open. */
+ const char *modeString, /* A list of POSIX open modes or a string such
+ * as "rw". */
+ int permissions) /* If the open involves creating a file, with
+ * what modes to create it? */
{
- Tcl_Filesystem *fsPtr;
-#ifdef USE_OBSOLETE_FS_HOOKS
+ const Tcl_Filesystem *fsPtr;
Tcl_Channel retVal = NULL;
+#ifdef USE_OBSOLETE_FS_HOOKS
/*
- * Call each of the "Tcl_OpenFileChannel" functions in succession.
- * A non-NULL return value indicates the particular function has
- * succeeded.
+ * Call each of the "Tcl_OpenFileChannel" functions in succession. A
+ * non-NULL return value indicates the particular function has succeeded.
*/
Tcl_MutexLock(&obsoleteFsHookMutex);
@@ -2147,7 +2183,7 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions)
OpenFileChannelProc *openFileChannelProcPtr;
char *path;
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
-
+
if (transPtr == NULL) {
path = NULL;
} else {
@@ -2155,10 +2191,10 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions)
}
openFileChannelProcPtr = openFileChannelProcList;
-
+
while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) {
retVal = (*openFileChannelProcPtr->proc)(interp, path,
- modeString, permissions);
+ modeString, permissions);
openFileChannelProcPtr = openFileChannelProcPtr->nextPtr;
}
if (transPtr != NULL) {
@@ -2170,49 +2206,70 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions)
return retVal;
}
#endif /* USE_OBSOLETE_FS_HOOKS */
-
- /*
- * We need this just to ensure we return the correct error messages
- * under some circumstances.
+
+ /*
+ * We need this just to ensure we return the correct error messages under
+ * some circumstances.
*/
+
if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
- return 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);
+ int mode, seekFlag, binary;
+
+ /*
+ * Parse the mode, picking up whether we want to seek to start
+ * with and/or set the channel automatically into binary mode.
+ */
+
+ mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary);
if (mode == -1) {
- return NULL;
+ return NULL;
}
+
+ /*
+ * Do the actual open() call.
+ */
+
retVal = (*proc)(interp, pathPtr, mode, permissions);
- if (retVal != NULL) {
- if (seekFlag) {
- if (Tcl_Seek(retVal, (Tcl_WideInt)0,
- SEEK_END) < (Tcl_WideInt)0) {
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp,
- "could not seek to end of file while opening \"",
- Tcl_GetString(pathPtr), "\": ",
- Tcl_PosixError(interp), (char *) NULL);
- }
- Tcl_Close(NULL, retVal);
- return NULL;
- }
+ if (retVal == NULL) {
+ return NULL;
+ }
+
+ /*
+ * Apply appropriate flags parsed out above.
+ */
+
+ if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt)0,
+ SEEK_END) < (Tcl_WideInt)0) {
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, "could not seek to end "
+ "of file while opening \"", Tcl_GetString(pathPtr),
+ "\": ", Tcl_PosixError(interp), NULL);
}
+ Tcl_Close(NULL, retVal);
+ return NULL;
+ }
+ if (binary) {
+ Tcl_SetChannelOption(interp, retVal, "-translation", "binary");
}
return retVal;
}
}
- /* File doesn't belong to any filesystem that can open it */
+
+ /*
+ * 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);
+ Tcl_AppendResult(interp, "couldn't open \"", Tcl_GetString(pathPtr),
+ "\": ", Tcl_PosixError(interp), NULL);
}
return NULL;
}
@@ -2222,26 +2279,25 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions)
*
* Tcl_FSUtime --
*
- * This procedure replaces the library version of utime.
- * The appropriate function for the filesystem to which pathPtr
- * belongs will be called.
+ * This function replaces the library version of utime. The appropriate
+ * function for the filesystem to which pathPtr belongs will be called.
*
* Results:
- * See utime documentation.
+ * See utime documentation.
*
* Side effects:
- * See utime documentation.
+ * 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. */
+int
+Tcl_FSUtime(
+ Tcl_Obj *pathPtr, /* File to change access/modification times */
+ struct utimbuf *tval) /* Structure containing access/modification
+ * times to use. Should not be modified. */
{
- Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSUtimeProc *proc = fsPtr->utimeProc;
if (proc != NULL) {
@@ -2256,25 +2312,25 @@ Tcl_FSUtime (pathPtr, tval)
*
* 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.
+ * This function implements the platform dependent 'file attributes'
+ * subcommand, for the native filesystem, for listing the set of possible
+ * attribute strings. This function is part of Tcl's native filesystem
+ * support, and is placed here because it is shared by Unix and Windows
+ * code.
*
* Results:
- * An array of strings
+ * An array of strings
*
* Side effects:
- * None.
+ * None.
*
*----------------------------------------------------------------------
*/
-static CONST char**
-NativeFileAttrStrings(pathPtr, objPtrRef)
- Tcl_Obj *pathPtr;
- Tcl_Obj** objPtrRef;
+static const char **
+NativeFileAttrStrings(
+ Tcl_Obj *pathPtr,
+ Tcl_Obj **objPtrRef)
{
return tclpFileAttrStrings;
}
@@ -2284,34 +2340,32 @@ NativeFileAttrStrings(pathPtr, objPtrRef)
*
* 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.
+ * This function implements the platform dependent 'file attributes'
+ * subcommand, for the native filesystem, for 'get' operations. This
+ * function is part of Tcl's native filesystem support, and is placed
+ * here because it is shared by Unix and Windows code.
*
* Results:
- * Standard Tcl return code. The object placed in objPtrRef
- * (if TCL_OK was returned) is likely to have a refCount of zero.
- * Either way we must either store it somewhere (e.g. the Tcl
- * result), or Incr/Decr its refCount to ensure it is properly
- * freed.
+ * 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.
+ * 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. */
+NativeFileAttrsGet(
+ Tcl_Interp *interp, /* The interpreter for error reporting. */
+ int index, /* index of the attribute command. */
+ Tcl_Obj *pathPtr, /* path of file we are operating on. */
+ Tcl_Obj **objPtrRef) /* for output. */
{
- return (*tclpFileAttrProcs[index].getProc)(interp, index,
- pathPtr, objPtrRef);
+ return (*tclpFileAttrProcs[index].getProc)(interp, index, pathPtr,
+ objPtrRef);
}
/*
@@ -2319,30 +2373,28 @@ NativeFileAttrsGet(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.
+ * This function implements the platform dependent 'file attributes'
+ * subcommand, for the native filesystem, for 'set' operations. This
+ * function is part of Tcl's native filesystem support, and is placed
+ * here because it is shared by Unix and Windows code.
*
* Results:
- * Standard Tcl return code.
+ * Standard Tcl return code.
*
* Side effects:
- * None.
+ * 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. */
+NativeFileAttrsSet(
+ Tcl_Interp *interp, /* The interpreter for error reporting. */
+ int index, /* index of the attribute command. */
+ Tcl_Obj *pathPtr, /* path of file we are operating on. */
+ Tcl_Obj *objPtr) /* set to this value. */
{
- return (*tclpFileAttrProcs[index].setProc)(interp, index,
- pathPtr, objPtr);
+ return (*tclpFileAttrProcs[index].setProc)(interp, index, pathPtr, objPtr);
}
/*
@@ -2350,32 +2402,32 @@ NativeFileAttrsSet(interp, index, pathPtr, objPtr)
*
* Tcl_FSFileAttrStrings --
*
- * This procedure implements part of the hookable 'file
- * attributes' subcommand. The appropriate function for the
- * filesystem to which pathPtr belongs will be called.
+ * This function implements part of the hookable 'file attributes'
+ * subcommand. The appropriate function for the filesystem to which
+ * pathPtr belongs will be called.
*
* Results:
- * The called procedure may either return an array of strings,
- * or may 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.
+ * The called function may either return an array of strings, or may
+ * instead return NULL and place a Tcl list into the given objPtrRef.
+ * Tcl will take that list and first increment its refCount before using
+ * it. On completion of that use, Tcl will decrement its refCount. Hence
+ * if the list should be disposed of by Tcl when done, it should have a
+ * refCount of zero, and if the list should not be disposed of, the
+ * filesystem should ensure it retains a refCount on the object.
*
* Side effects:
- * None.
+ * None.
*
*----------------------------------------------------------------------
*/
-CONST char **
-Tcl_FSFileAttrStrings(pathPtr, objPtrRef)
- Tcl_Obj* pathPtr;
- Tcl_Obj** objPtrRef;
+const char **
+Tcl_FSFileAttrStrings(
+ Tcl_Obj *pathPtr,
+ Tcl_Obj **objPtrRef)
{
- Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+
if (fsPtr != NULL) {
Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc;
if (proc != NULL) {
@@ -2389,34 +2441,110 @@ Tcl_FSFileAttrStrings(pathPtr, objPtrRef)
/*
*----------------------------------------------------------------------
*
- * Tcl_FSFileAttrsGet --
+ * TclFSFileAttrIndex --
*
- * This procedure implements read access for the hookable 'file
- * attributes' subcommand. The appropriate function for the
- * filesystem to which pathPtr belongs will be called.
+ * Helper function for converting an attribute name to an index into the
+ * attribute table.
*
* 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.
+ * Tcl result code, index written to *indexPtr on result==TCL_OK
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclFSFileAttrIndex(
+ Tcl_Obj *pathPtr, /* File whose attributes are to be indexed
+ * into. */
+ const char *attributeName, /* The attribute being looked for. */
+ int *indexPtr) /* Where to write the found index. */
+{
+ Tcl_Obj *listObj = NULL;
+ const char **attrTable;
+ /*
+ * Get the attribute table for the file.
+ */
+
+ attrTable = Tcl_FSFileAttrStrings(pathPtr, &listObj);
+ if (listObj != NULL) {
+ Tcl_IncrRefCount(listObj);
+ }
+
+ if (attrTable != NULL) {
+ /*
+ * It's a constant attribute table, so use T_GIFO.
+ */
+
+ Tcl_Obj *tmpObj = Tcl_NewStringObj(attributeName, -1);
+ int result;
+
+ result = Tcl_GetIndexFromObj(NULL, tmpObj, attrTable, NULL, TCL_EXACT,
+ indexPtr);
+ TclDecrRefCount(tmpObj);
+ if (listObj != NULL) {
+ TclDecrRefCount(listObj);
+ }
+ return result;
+ } else if (listObj != NULL) {
+ /*
+ * It's a non-constant attribute list, so do a literal search.
+ */
+
+ int i, objc;
+ Tcl_Obj **objv;
+
+ if (Tcl_ListObjGetElements(NULL, listObj, &objc, &objv) != TCL_OK) {
+ TclDecrRefCount(listObj);
+ return TCL_ERROR;
+ }
+ for (i=0 ; i<objc ; i++) {
+ if (!strcmp(attributeName, TclGetString(objv[i]))) {
+ TclDecrRefCount(listObj);
+ *indexPtr = i;
+ return TCL_OK;
+ }
+ }
+ TclDecrRefCount(listObj);
+ return TCL_ERROR;
+ } else {
+ return TCL_ERROR;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSFileAttrsGet --
+ *
+ * This function implements read access for the hookable 'file
+ * attributes' subcommand. The appropriate function for the filesystem to
+ * which pathPtr belongs will be called.
+ *
+ * Results:
+ * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK
+ * was returned) is likely to have a refCount of zero. Either way we must
+ * either store it somewhere (e.g. the Tcl result), or Incr/Decr its
+ * refCount to ensure it is properly freed.
*
* Side effects:
- * None.
+ * 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_FSFileAttrsGet(
+ Tcl_Interp *interp, /* The interpreter for error reporting. */
+ int index, /* index of the attribute command. */
+ Tcl_Obj *pathPtr, /* filename we are operating on. */
+ Tcl_Obj **objPtrRef) /* for output. */
{
- Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+
if (fsPtr != NULL) {
Tcl_FSFileAttrsGetProc *proc = fsPtr->fileAttrsGetProc;
if (proc != NULL) {
@@ -2432,27 +2560,28 @@ Tcl_FSFileAttrsGet(interp, index, pathPtr, objPtrRef)
*
* Tcl_FSFileAttrsSet --
*
- * This procedure implements write access for the hookable 'file
- * attributes' subcommand. The appropriate function for the
- * filesystem to which pathPtr belongs will be called.
+ * This function implements write access for the hookable 'file
+ * attributes' subcommand. The appropriate function for the filesystem to
+ * which pathPtr belongs will be called.
*
* Results:
- * Standard Tcl return code.
+ * Standard Tcl return code.
*
* Side effects:
- * None.
+ * 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_FSFileAttrsSet(
+ Tcl_Interp *interp, /* The interpreter for error reporting. */
+ int index, /* index of the attribute command. */
+ Tcl_Obj *pathPtr, /* filename we are operating on. */
+ Tcl_Obj *objPtr) /* Input value. */
{
- Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+
if (fsPtr != NULL) {
Tcl_FSFileAttrsSetProc *proc = fsPtr->fileAttrsSetProc;
if (proc != NULL) {
@@ -2469,34 +2598,32 @@ Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr)
* 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.
- *
+ *
+ * Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains its own
+ * record (in a Tcl_Obj) of the cwd, and an attempt is made to synch this
+ * with the cwd's containing filesystem, if that filesystem provides a
+ * cwdProc (e.g. the native filesystem).
+ *
+ * Note that if Tcl's cwd is not in the native filesystem, then of course
+ * Tcl's cwd and the native cwd are different: extensions should
+ * therefore ensure they only access the cwd through this function to
+ * avoid confusion.
+ *
* If a global cwdPathPtr already exists, it is cached in the thread's
* private data structures and reference to the cached copy is returned,
* subject to a synchronisation attempt in that cwdPathPtr's fs.
- *
- * Otherwise, the chain of functions that have been "inserted"
- * into the filesystem will be called in succession until either a
- * value other than NULL is returned, or the entire list is
- * visited.
+ *
+ * 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.
+ * 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.
@@ -2504,117 +2631,218 @@ Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr)
*----------------------------------------------------------------------
*/
-Tcl_Obj*
-Tcl_FSGetCwd(interp)
- Tcl_Interp *interp;
+Tcl_Obj *
+Tcl_FSGetCwd(
+ Tcl_Interp *interp)
{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
+
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.
+ /*
+ * 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);
+ if (fsRecPtr->fsPtr->version != TCL_FILESYSTEM_VERSION_1) {
+ ClientData retCd;
+ TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc;
+
+ retCd = (*proc2)(NULL);
+ if (retCd != NULL) {
+ Tcl_Obj *norm;
+ /* Looks like a new current directory */
+ retVal = (*fsRecPtr->fsPtr->internalToNormalizedProc)(
+ retCd);
+ Tcl_IncrRefCount(retVal);
+ norm = TclFSNormalizeAbsolutePath(interp,retVal,NULL);
+ if (norm != NULL) {
+ /*
+ * We found a cwd, which is now in our global
+ * storage. We must make a copy. Norm already has
+ * a refCount of 1.
+ *
+ * Threading issue: note that multiple threads at
+ * system startup could in principle call this
+ * function simultaneously. They will therefore
+ * each set the cwdPathPtr independently. That
+ * behaviour is a bit peculiar, but should be
+ * fine. Once we have a cwd, we'll always be in
+ * the 'else' branch below which is simpler.
+ */
+
+ FsUpdateCwd(norm, retCd);
+ Tcl_DecrRefCount(norm);
+ } else {
+ (*fsRecPtr->fsPtr->freeInternalRepProc)(retCd);
+ }
+ Tcl_DecrRefCount(retVal);
+ retVal = NULL;
+ goto cdDidNotChange;
+ } else if (interp != NULL) {
+ Tcl_AppendResult(interp,
+ "error getting working directory name: ",
+ Tcl_PosixError(interp), NULL);
+ }
+ } else {
+ retVal = (*proc)(interp);
+ }
}
fsRecPtr = fsRecPtr->nextPtr;
}
- /*
- * 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.
+
+ /*
+ * 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.
- *
+ /*
+ * We found a cwd, which is now in our global storage. We must
+ * make a copy. Norm already has a refCount of 1.
+ *
* Threading issue: note that multiple threads at system
- * startup could in principle call this procedure
- * simultaneously. They will therefore each set the
- * cwdPathPtr independently. That behaviour is a bit
- * peculiar, but should be fine. Once we have a cwd,
- * we'll always be in the 'else' branch below which
- * is simpler.
+ * startup could in principle call this function
+ * simultaneously. They will therefore each set the cwdPathPtr
+ * independently. That behaviour is a bit peculiar, but should
+ * be fine. Once we have a cwd, we'll always be in the 'else'
+ * branch below which is simpler.
*/
- FsUpdateCwd(norm);
+
+ ClientData cd = (ClientData) Tcl_FSGetNativePath(norm);
+ FsUpdateCwd(norm, TclNativeDupInternalRep(cd));
Tcl_DecrRefCount(norm);
}
Tcl_DecrRefCount(retVal);
}
} else {
- /*
- * We already have a cwd cached, but we want to give the
- * filesystem it is in a chance to check whether that cwd
- * has changed, or is perhaps no longer accessible. This
- * allows an error to be thrown if, say, the permissions on
- * that directory have changed.
+ /*
+ * 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).
+
+ const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr);
+
+ /*
+ * If the filesystem couldn't be found, or if no cwd function exists
+ * for this filesystem, then we simply assume the cached cwd is ok.
+ * If we do call a cwd, we must watch for errors (if the cwd returns
+ * NULL). This ensures that, say, on Unix if the permissions of the
+ * cwd change, 'pwd' does actually throw the correct error in Tcl.
+ * (This is tested for in the test suite on unix).
*/
+
if (fsPtr != NULL) {
Tcl_FSGetCwdProc *proc = fsPtr->getCwdProc;
+ ClientData retCd = NULL;
if (proc != NULL) {
- Tcl_Obj *retVal = (*proc)(interp);
+ Tcl_Obj *retVal;
+ if (fsPtr->version != TCL_FILESYSTEM_VERSION_1) {
+ TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc;
+
+ retCd = (*proc2)(tsdPtr->cwdClientData);
+ if (retCd == NULL && interp != NULL) {
+ Tcl_AppendResult(interp,
+ "error getting working directory name: ",
+ Tcl_PosixError(interp), NULL);
+ }
+
+ if (retCd == tsdPtr->cwdClientData) {
+ goto cdDidNotChange;
+ }
+
+ /*
+ * Looks like a new current directory.
+ */
+
+ retVal = (*fsPtr->internalToNormalizedProc)(retCd);
+ Tcl_IncrRefCount(retVal);
+ } else {
+ retVal = (*proc)(interp);
+ }
if (retVal != NULL) {
- Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL);
- /*
- * Check whether cwd has changed from the value
- * previously stored in cwdPathPtr. Really 'norm'
- * shouldn't be null, but we are careful.
+ 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);
+ if (retCd != NULL) {
+ (*fsPtr->freeInternalRepProc)(retCd);
+ }
+ } else if (norm == tsdPtr->cwdPathPtr) {
+ goto cdEqual;
} else {
- FsUpdateCwd(norm);
- Tcl_DecrRefCount(norm);
+ /*
+ * Note that both 'norm' and 'tsdPtr->cwdPathPtr' are
+ * normalized paths. Therefore we can be more
+ * efficient than calling 'Tcl_FSEqualPaths', and in
+ * addition avoid a nasty infinite loop bug when
+ * trying to normalize tsdPtr->cwdPathPtr.
+ */
+
+ int len1, len2;
+ char *str1, *str2;
+
+ str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1);
+ str2 = Tcl_GetStringFromObj(norm, &len2);
+ if ((len1 == len2) && (strcmp(str1, str2) == 0)) {
+ /*
+ * If the paths were equal, we can be more
+ * efficient and retain the old path object which
+ * will probably already be shared. In this case
+ * we can simply free the normalized path we just
+ * calculated.
+ */
+
+ cdEqual:
+ Tcl_DecrRefCount(norm);
+ if (retCd != NULL) {
+ (*fsPtr->freeInternalRepProc)(retCd);
+ }
+ } else {
+ FsUpdateCwd(norm, retCd);
+ Tcl_DecrRefCount(norm);
+ }
}
Tcl_DecrRefCount(retVal);
} else {
- /* The 'cwd' function returned an error; reset the cwd */
- FsUpdateCwd(NULL);
+ /*
+ * The 'cwd' function returned an error; reset the cwd.
+ */
+
+ FsUpdateCwd(NULL, NULL);
}
}
}
}
-
+
+ cdDidNotChange:
if (tsdPtr->cwdPathPtr != NULL) {
Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
}
-
- return tsdPtr->cwdPathPtr;
+
+ return tsdPtr->cwdPathPtr;
}
/*
@@ -2623,131 +2851,148 @@ Tcl_FSGetCwd(interp)
* Tcl_FSChdir --
*
* This function replaces the library version of chdir().
- *
- * The path is normalized and then passed to the filesystem
- * which claims it.
+ *
+ * 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.
+ * See chdir() documentation. If successful, we keep a record of the
+ * successful path in cwdPathPtr for subsequent calls to getcwd.
*
* Side effects:
- * See chdir() documentation. The global cwdPathPtr may
- * change value.
+ * See chdir() documentation. The global cwdPathPtr may change value.
*
*----------------------------------------------------------------------
*/
+
int
-Tcl_FSChdir(pathPtr)
- Tcl_Obj *pathPtr;
+Tcl_FSChdir(
+ Tcl_Obj *pathPtr)
{
- Tcl_Filesystem *fsPtr;
+ const Tcl_Filesystem *fsPtr;
int retVal = -1;
-
-#ifdef WIN32
- /*
- * This complete hack addresses the bug tested in winFCmd-16.12,
- * where having your HOME as "C:" (IOW, a seemingly path relative
- * dir) would cause a crash when you cd'd to it and requested 'pwd'.
- * The work-around is to force such a dir into an absolute path by
- * tacking on '/'.
- *
- * We check for '~' specifically because that's what Tcl_CdObjCmd
- * passes in that triggers the bug. A direct 'cd C:' call will not
- * because that gets the volumerelative pwd.
- *
- * This is not an issue for 8.5 as that has a more elaborate change
- * that requires the use of TCL_FILESYSTEM_VERSION_2.
- */
- Tcl_Obj *objPtr = NULL;
- if (pathPtr->bytes && pathPtr->length == 1 && pathPtr->bytes[0] == '~') {
- int len;
- char *str;
- objPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
- if (objPtr == NULL) {
- Tcl_SetErrno(ENOENT);
- return -1;
- }
- Tcl_IncrRefCount(objPtr);
- str = Tcl_GetStringFromObj(objPtr, &len);
- if (len == 2 && str[1] == ':') {
- pathPtr = Tcl_NewStringObj(str, len);
- Tcl_AppendToObj(pathPtr, "/", 1);
- Tcl_IncrRefCount(pathPtr);
- Tcl_DecrRefCount(objPtr);
- objPtr = pathPtr;
- } else {
- Tcl_DecrRefCount(objPtr);
- objPtr = NULL;
- }
- }
-#endif
if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) {
-#ifdef WIN32
- if (objPtr) { Tcl_DecrRefCount(objPtr); }
-#endif
Tcl_SetErrno(ENOENT);
- return -1;
+ return retVal;
}
-
+
fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSChdirProc *proc = fsPtr->chdirProc;
if (proc != NULL) {
+ /*
+ * If this fails, an appropriate errno will have been stored using
+ * 'Tcl_SetErrno()'.
+ */
+
retVal = (*proc)(pathPtr);
} else {
- /* Fallback on stat-based implementation */
+ /*
+ * 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 */
+
+ /*
+ * If the file can be stat'ed and is a directory and is readable,
+ * then we can chdir. If any of these actions fail, then
+ * 'Tcl_SetErrno()' should automatically have been called to set
+ * an appropriate error code
+ */
+
+ if ((Tcl_FSStat(pathPtr, &buf) == 0) && (S_ISDIR(buf.st_mode))
+ && (Tcl_FSAccess(pathPtr, R_OK) == 0)) {
+ /*
+ * We allow the chdir.
+ */
+
retVal = 0;
}
}
+ } else {
+ Tcl_SetErrno(ENOENT);
}
- 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.
+ /*
+ * The cwd changed, or an error was thrown. If an error was thrown, we can
+ * just continue (and that will report the error to the user). If there
+ * was no error we must assume that the cwd was actually changed to the
+ * normalized value we calculated above, and we must therefore cache that
+ * information.
+ */
+
+ /*
+ * If the filesystem in question has a getCwdProc, then the correct logic
+ * which performs the part below is already part of the Tcl_FSGetCwd()
+ * call, so no need to replicate it again. This will have a side effect
+ * though. The private authoritative representation of the current working
+ * directory stored in cwdPathPtr in static memory will be out-of-sync
+ * with the real OS-maintained value. The first call to Tcl_FSGetCwd will
+ * however recalculate the private copy to match the OS-value so
+ * everything will work right.
+ *
+ * However, if there is no getCwdProc, then we _must_ update our private
+ * storage of the cwd, since this is the only opportunity to do that!
+ *
+ * Note: We currently call this block of code irrespective of whether
+ * there was a getCwdProc or not, but the code should all in principle
+ * work if we only call this block if fsPtr->getCwdProc == NULL.
+ */
+
+ if (retVal == 0) {
+ /*
+ * Note that this normalized path may be different to what we found
+ * above (or at least a different object), if the filesystem epoch
+ * changed recently. This can actually happen with scripted documents
+ * very easily. Therefore we ask for the normalized path again (the
+ * correct value will have been cached as a result of the
+ * Tcl_FSGetFileSystemForPath call above anyway).
*/
- if (retVal == 0) {
- /*
- * Note that this normalized path may be different to what
- * we found above (or at least a different object), if the
- * filesystem epoch changed recently. This can actually
- * happen with scripted documents very easily. Therefore
- * we ask for the normalized path again (the correct value
- * will have been cached as a result of the
- * Tcl_FSGetFileSystemForPath call above anyway).
+
+ Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+
+ if (normDirName == NULL) {
+ /* Not really true, but what else to do? */
+ Tcl_SetErrno(ENOENT);
+ return -1;
+ }
+
+ if (fsPtr == &tclNativeFilesystem) {
+ /*
+ * For the native filesystem, we keep a cache of the native
+ * representation of the cwd. But, we want to do that for the
+ * exact format that is returned by 'getcwd' (so that we can later
+ * compare the two representations for equality), which might not
+ * be exactly the same char-string as the native representation of
+ * the fully normalized path (e.g. on Windows there's a
+ * forward-slash vs backslash difference). Hence we ask for this
+ * again here. On Unix it might actually be true that we always
+ * have the correct form in the native rep in which case we could
+ * simply use:
+ * cd = Tcl_FSGetNativePath(pathPtr);
+ * instead. This should be examined by someone on Unix.
*/
- Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr);
- if (normDirName == NULL) {
-#ifdef WIN32
- if (objPtr) { Tcl_DecrRefCount(objPtr); }
-#endif
- Tcl_SetErrno(ENOENT);
- return -1;
+
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
+ ClientData cd;
+ ClientData oldcd = tsdPtr->cwdClientData;
+
+ /*
+ * Assumption we are using a filesystem version 2.
+ */
+
+ TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)fsPtr->getCwdProc;
+ cd = (*proc2)(oldcd);
+ if (cd != oldcd) {
+ FsUpdateCwd(normDirName, cd);
}
- FsUpdateCwd(normDirName);
+ } else {
+ FsUpdateCwd(normDirName, NULL);
}
- } else {
- Tcl_SetErrno(ENOENT);
}
-
-#ifdef WIN32
- if (objPtr) { Tcl_DecrRefCount(objPtr); }
-#endif
- return (retVal);
+
+ return retVal;
}
/*
@@ -2755,306 +3000,446 @@ Tcl_FSChdir(pathPtr)
*
* Tcl_FSLoadFile --
*
- * Dynamically loads a binary code file into memory and returns
- * the addresses of two procedures within that file, if they are
- * defined. The appropriate function for the filesystem to which
- * pathPtr belongs will be called.
- *
- * 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.
+ * Dynamically loads a binary code file into memory and returns the
+ * addresses of two functions within that file, if they are defined. The
+ * appropriate function for the filesystem to which pathPtr belongs will
+ * be called.
+ *
+ * Note that the native filesystem doesn't actually assume 'pathPtr' is a
+ * path. Rather it assumes pathPtr is either a path or just the name
+ * (tail) of a file which can be found somewhere in the environment's
+ * loadable path. This behaviour is not very compatible with virtual
+ * filesystems (and has other problems documented in the load man-page),
+ * so it is advised that full paths are always used.
*
* Results:
- * A standard Tcl completion code. If an error occurs, an error
- * message is left in the interp's result.
+ * A standard Tcl completion code. If an error occurs, an error message
+ * is left in the interp's result.
*
* Side effects:
- * New code suddenly appears in memory. This may later be
- * unloaded by passing the clientData to the unloadProc.
+ * New code suddenly appears in memory. This may later be unloaded by
+ * passing the clientData to the unloadProc.
*
*----------------------------------------------------------------------
*/
int
-Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
- handlePtr, unloadProcPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- Tcl_Obj *pathPtr; /* Name of the file containing the desired
+Tcl_FSLoadFile(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code. */
- CONST char *sym1, *sym2; /* Names of two procedures to look up in
- * the file's symbol table. */
- Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
+ const char *sym1, const char *sym2,
+ /* Names of two functions to look up in the
+ * file's symbol table. */
+ Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr,
/* Where to return the addresses corresponding
* to sym1 and sym2. */
- Tcl_LoadHandle *handlePtr; /* Filled with token for dynamically loaded
- * file which will be passed back to
+ 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_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;
- }
+ const char *symbols[2];
+ Tcl_PackageInitProc **procPtrs[2];
+ ClientData clientData;
+ int res;
+
+ /*
+ * Initialize the arrays.
+ */
+
+ symbols[0] = sym1;
+ symbols[1] = sym2;
+ procPtrs[0] = proc1Ptr;
+ procPtrs[1] = proc2Ptr;
+
+ /*
+ * Perform the load.
+ */
+
+ res = TclLoadFile(interp, pathPtr, 2, symbols, procPtrs, handlePtr,
+ &clientData, unloadProcPtr);
+
+ /*
+ * Due to an unfortunate mis-design in Tcl 8.4 fs, when loading a shared
+ * library, we don't keep the loadHandle (for TclpFindSymbol) and the
+ * clientData (for the unloadProc) separately. In fact we effectively
+ * throw away the loadHandle and only use the clientData. It just so
+ * happens, for the native filesystem only, that these two are identical.
+ *
+ * This also means that the signatures Tcl_FSUnloadFileProc and
+ * Tcl_FSLoadFileProc are both misleading.
+ */
+
+ *handlePtr = (Tcl_LoadHandle) clientData;
+ return res;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclLoadFile --
+ *
+ * Dynamically loads a binary code file into memory and returns the
+ * addresses of a number of given functions within that file, if they are
+ * defined. The appropriate function for the filesystem to which pathPtr
+ * belongs will be called.
+ *
+ * Note that the native filesystem doesn't actually assume 'pathPtr' is a
+ * path. Rather it assumes pathPtr is either a path or just the name
+ * (tail) of a file which can be found somewhere in the environment's
+ * loadable path. This behaviour is not very compatible with virtual
+ * filesystems (and has other problems documented in the load man-page),
+ * so it is advised that full paths are always used.
+ *
+ * This function is currently private to Tcl. It may be exported in the
+ * future and its interface fixed (but we should clean up the
+ * loadHandle/clientData confusion at that time -- see the above comments
+ * in Tcl_FSLoadFile for details). For a public function, see
+ * Tcl_FSLoadFile.
+ *
+ * Results:
+ * A standard Tcl completion code. If an error occurs, an error message
+ * is left in the interp's result.
+ *
+ * Side effects:
+ * New code suddenly appears in memory. This may later be unloaded by
+ * passing the clientData to the unloadProc.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclLoadFile(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Obj *pathPtr, /* Name of the file containing the desired
+ * code. */
+ int symc, /* Number of symbols/procPtrs in the next two
+ * arrays. */
+ const char *symbols[], /* Names of functions to look up in the file's
+ * symbol table. */
+ Tcl_PackageInitProc **procPtrs[],
+ /* Where to return the addresses corresponding
+ * to symbols[]. */
+ Tcl_LoadHandle *handlePtr, /* Filled with token for shared library
+ * information which can be used in
+ * TclpFindSymbol. */
+ ClientData *clientDataPtr, /* Filled with token for dynamically loaded
+ * file which will be passed back to
+ * (*unloadProcPtr)() to unload the file. */
+ Tcl_FSUnloadFileProc **unloadProcPtr)
+ /* Filled with address of Tcl_FSUnloadFileProc
+ * function which should be used for this
+ * file. */
+{
+ const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ Tcl_FSLoadFileProc *proc;
+ Tcl_Filesystem *copyFsPtr;
+ Tcl_Obj *copyToPtr;
+ Tcl_LoadHandle newLoadHandle = NULL;
+ ClientData newClientData = NULL;
+ Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL;
+ FsDivertLoad *tvdlPtr;
+ int retVal;
+
+ if (fsPtr == NULL) {
+ Tcl_SetErrno(ENOENT);
+ return TCL_ERROR;
+ }
+
+ proc = fsPtr->loadFileProc;
+ if (proc != NULL) {
+ int retVal = (*proc)(interp, pathPtr, handlePtr, unloadProcPtr);
+ if (retVal == TCL_OK) {
if (*handlePtr == NULL) {
return TCL_ERROR;
}
- if (sym1 != NULL) {
- *proc1Ptr = TclpFindSymbol(interp, *handlePtr, sym1);
- }
- if (sym2 != NULL) {
- *proc2Ptr = TclpFindSymbol(interp, *handlePtr, sym2);
- }
+
+ /*
+ * Copy this across, since both are equal for the native fs.
+ */
+
+ *clientDataPtr = (ClientData)*handlePtr;
+ Tcl_ResetResult(interp);
+ goto resolveSymbols;
+ }
+ if (Tcl_GetErrno() != EXDEV) {
return retVal;
- } 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;
- }
-
+ }
+ }
+
+ /*
+ * The filesystem doesn't support 'load', so we fall back on the following
+ * technique:
+ *
+ * First check if it is readable -- and exists!
+ */
+
+ if (Tcl_FSAccess(pathPtr, R_OK) != 0) {
+ Tcl_AppendResult(interp, "couldn't load library \"",
+ Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
+ return TCL_ERROR;
+ }
+
#ifdef TCL_LOAD_FROM_MEMORY
- /*
- * The platform supports loading code from memory, so ask for a
- * buffer of the appropriate size, read the file into it and
- * load the code from the buffer:
+ /*
+ * The platform supports loading code from memory, so ask for a buffer of
+ * the appropriate size, read the file into it and load the code from the
+ * buffer:
+ */
+
+ {
+ int ret, size;
+ void *buffer;
+ Tcl_StatBuf statBuf;
+ Tcl_Channel data;
+
+ ret = Tcl_FSStat(pathPtr, &statBuf);
+ if (ret < 0) {
+ goto mustCopyToTempAnyway;
+ }
+ size = (int) statBuf.st_size;
+
+ /*
+ * Tcl_Read takes an int: check that file size isn't wide.
*/
- do {
- int ret, size;
- void *buffer;
- Tcl_StatBuf statBuf;
- Tcl_Channel data;
-
- ret = Tcl_FSStat(pathPtr, &statBuf);
- if (ret < 0) {
- break;
- }
- size = (int) statBuf.st_size;
- /* Tcl_Read takes an int: check that file size isn't wide */
- if (size != (Tcl_WideInt)statBuf.st_size) {
- break;
- }
- data = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0666);
- if (!data) {
- break;
- }
- buffer = TclpLoadMemoryGetBuffer(interp, size);
- if (!buffer) {
- Tcl_Close(interp, data);
- break;
- }
- Tcl_SetChannelOption(interp, data, "-translation", "binary");
- ret = Tcl_Read(data, buffer, size);
- Tcl_Close(interp, data);
- ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr, unloadProcPtr);
- if (ret == TCL_OK) {
- if (*handlePtr == NULL) {
- break;
- }
- if (sym1 != NULL) {
- *proc1Ptr = TclpFindSymbol(interp, *handlePtr, sym1);
- }
- if (sym2 != NULL) {
- *proc2Ptr = TclpFindSymbol(interp, *handlePtr, sym2);
- }
- return TCL_OK;
- }
- } while (0);
- Tcl_ResetResult(interp);
+
+ if (size != (Tcl_WideInt) statBuf.st_size) {
+ goto mustCopyToTempAnyway;
+ }
+ data = Tcl_FSOpenFileChannel(interp, pathPtr, "rb", 0666);
+ if (!data) {
+ goto mustCopyToTempAnyway;
+ }
+ buffer = TclpLoadMemoryGetBuffer(interp, size);
+ if (!buffer) {
+ Tcl_Close(interp, data);
+ goto mustCopyToTempAnyway;
+ }
+ ret = Tcl_Read(data, buffer, size);
+ Tcl_Close(interp, data);
+ ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr,
+ unloadProcPtr);
+ if (ret == TCL_OK && *handlePtr != NULL) {
+ *clientDataPtr = (ClientData) *handlePtr;
+ goto resolveSymbols;
+ }
+ }
+
+ mustCopyToTempAnyway:
+ Tcl_ResetResult(interp);
#endif
- /*
- * Get a temporary filename to use, first to
- * copy the file into, and then to load.
- */
- copyToPtr = TclpTempFileName();
- if (copyToPtr == NULL) {
- 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);
+ /*
+ * Get a temporary filename to use, first to copy the file into, and then
+ * to load.
+ */
+
+ copyToPtr = TclpTempFileName();
+ if (copyToPtr == NULL) {
+ Tcl_AppendResult(interp, "couldn't create temporary file: ",
+ Tcl_PosixError(interp), NULL);
+ return TCL_ERROR;
+ }
+ Tcl_IncrRefCount(copyToPtr);
+
+ copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr);
+ if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) {
+ /*
+ * We already know we can't use Tcl_FSLoadFile from this filesystem,
+ * and we must avoid a possible infinite loop. Try to delete the file
+ * we probably created, and then exit.
+ */
+
+ Tcl_FSDeleteFile(copyToPtr);
+ Tcl_DecrRefCount(copyToPtr);
+ Tcl_AppendResult(interp, "couldn't load from current filesystem",NULL);
+ return TCL_ERROR;
+ }
+
+ if (TclCrossFilesystemCopy(interp, pathPtr, copyToPtr) != TCL_OK) {
+ /*
+ * Cross-platform copy failed.
+ */
+
+ Tcl_FSDeleteFile(copyToPtr);
+ Tcl_DecrRefCount(copyToPtr);
+ return TCL_ERROR;
+ }
+
+#if !defined(__WIN32__)
+ /*
+ * Do we need to set appropriate permissions on the file? This may be
+ * required on some systems. On Unix we could loop over the file
+ * attributes, and set any that are called "-permissions" to 0700. However
+ * we just do this directly, like this:
+ */
+
+ {
+ int index;
+ Tcl_Obj *perm;
+
+ TclNewLiteralStringObj(perm, "0700");
+ Tcl_IncrRefCount(perm);
+ if (TclFSFileAttrIndex(copyToPtr, "-permissions", &index) == TCL_OK) {
+ Tcl_FSFileAttrsSet(NULL, index, copyToPtr, perm);
+ }
+ Tcl_DecrRefCount(perm);
+ }
#endif
-
- /*
- * We need to reset the result now, because the cross-
- * filesystem copy may have stored the number of bytes
- * in the result
- */
- Tcl_ResetResult(interp);
-
- retVal = 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 =
- TclNativeDupInternalRep(Tcl_FSGetInternalRep(copyToPtr,
- copyFsPtr));
- /*
- * We don't need or want references to the copied
- * Tcl_Obj or the filesystem if it is the native
- * one.
- */
- tvdlPtr->divertedFile = NULL;
- tvdlPtr->divertedFilesystem = NULL;
- Tcl_DecrRefCount(copyToPtr);
- }
+ /*
+ * We need to reset the result now, because the cross-filesystem copy may
+ * have stored the number of bytes in the result.
+ */
- 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_ResetResult(interp);
+
+ retVal = TclLoadFile(interp, copyToPtr, symc, symbols, procPtrs,
+ &newLoadHandle, &newClientData, &newUnloadProcPtr);
+ if (retVal != TCL_OK) {
+ /*
+ * The file didn't load successfully.
+ */
+
+ Tcl_FSDeleteFile(copyToPtr);
+ Tcl_DecrRefCount(copyToPtr);
+ return retVal;
+ }
+
+ /*
+ * Try to delete the file immediately - this is possible in some OSes, and
+ * avoids any worries about leaving the copy laying around on exit.
+ */
+
+ if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) {
+ Tcl_DecrRefCount(copyToPtr);
+
+ /*
+ * We tell our caller about the real shared library which was loaded.
+ * Note that this does mean that the package list maintained by 'load'
+ * will store the original (vfs) path alongside the temporary load
+ * handle and unload proc ptr.
+ */
+
+ (*handlePtr) = newLoadHandle;
+ (*clientDataPtr) = newClientData;
+ (*unloadProcPtr) = newUnloadProcPtr;
+ Tcl_ResetResult(interp);
+ return TCL_OK;
+ }
+
+ /*
+ * When we unload this file, we need to divert the unloading so we can
+ * unload and cleanup the temporary file correctly.
+ */
+
+ tvdlPtr = (FsDivertLoad *) ckalloc(sizeof(FsDivertLoad));
+
+ /*
+ * Remember three pieces of information. This allows us to cleanup the
+ * diverted load completely, on platforms which allow proper unloading of
+ * code.
+ */
+
+ tvdlPtr->loadHandle = newLoadHandle;
+ tvdlPtr->unloadProcPtr = newUnloadProcPtr;
+
+ if (copyFsPtr != &tclNativeFilesystem) {
+ /*
+ * copyToPtr is already incremented for this reference.
+ */
+
+ tvdlPtr->divertedFile = copyToPtr;
+
+ /*
+ * This is the filesystem we loaded it into. Since we have a reference
+ * to 'copyToPtr', we already have a refCount on this filesystem, so
+ * we don't need to worry about it disappearing on us.
+ */
+
+ tvdlPtr->divertedFilesystem = copyFsPtr;
+ tvdlPtr->divertedFileNativeRep = NULL;
+ } else {
+ /*
+ * We need the native rep.
+ */
+
+ tvdlPtr->divertedFileNativeRep = TclNativeDupInternalRep(
+ Tcl_FSGetInternalRep(copyToPtr, copyFsPtr));
+
+ /*
+ * We don't need or want references to the copied Tcl_Obj or the
+ * filesystem if it is the native one.
+ */
+
+ tvdlPtr->divertedFile = NULL;
+ tvdlPtr->divertedFilesystem = NULL;
+ Tcl_DecrRefCount(copyToPtr);
+ }
+
+ copyToPtr = NULL;
+ (*handlePtr) = newLoadHandle;
+ (*clientDataPtr) = (ClientData) tvdlPtr;
+ (*unloadProcPtr) = TclFSUnloadTempFile;
+
+ Tcl_ResetResult(interp);
+ return retVal;
+
+ resolveSymbols:
+ {
+ int i;
+
+ for (i=0 ; i<symc ; i++) {
+ if (symbols[i] != NULL) {
+ *procPtrs[i] = TclpFindSymbol(interp, *handlePtr, symbols[i]);
}
}
}
- Tcl_SetErrno(ENOENT);
- return -1;
+ return TCL_OK;
}
-/*
- * This function used to be in the platform specific directories, but it
- * has now been made to work cross-platform
+/*
+ * 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
+TclpLoadFile(
+ 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;
+ const char *sym1, CONST char *sym2,
+ /* Names of two functions to look up in the
+ * file's symbol table. */
+ Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr,
/* Where to return the addresses corresponding
* to sym1 and sym2. */
- ClientData *clientDataPtr; /* Filled with token for dynamically loaded
- * file which will be passed back to
+ ClientData *clientDataPtr, /* Filled with token for dynamically loaded
+ * file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
- Tcl_FSUnloadFileProc **unloadProcPtr;
+ Tcl_FSUnloadFileProc **unloadProcPtr)
/* Filled with address of Tcl_FSUnloadFileProc
- * function which should be used for
- * this file. */
+ * 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;
+ return res;
}
if (handle == NULL) {
return TCL_ERROR;
}
-
- *clientDataPtr = (ClientData)handle;
-
+
+ *clientDataPtr = (ClientData) handle;
+
*proc1Ptr = TclpFindSymbol(interp, handle, sym1);
*proc2Ptr = TclpFindSymbol(interp, handle, sym2);
return TCL_OK;
@@ -3063,85 +3448,91 @@ TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
/*
*---------------------------------------------------------------------------
*
- * FSUnloadTempFile --
+ * TclFSUnloadTempFile --
*
- * This function is called when we loaded a library of code via
- * an intermediate temporary file. This function ensures
- * the library is correctly unloaded and the temporary file
- * is correctly deleted.
+ * 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.
+ * The effects of the 'unload' function called, and of course the
+ * temporary file will be deleted.
*
*---------------------------------------------------------------------------
*/
-static void
-FSUnloadTempFile(loadHandle)
- Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
- * to Tcl_FSLoadFile(). The loadHandle is
- * a token that represents the loaded
- * file. */
+
+void
+TclFSUnloadTempFile(
+ Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
+ * Tcl_FSLoadFile(). The loadHandle is a token
+ * that represents the loaded file. */
{
- FsDivertLoad *tvdlPtr = (FsDivertLoad*)loadHandle;
- /*
- * This test should never trigger, since we give
- * the client data in the function above.
+ 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 == 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.
+ /*
+ * 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.
+ /*
+ * 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) {
- /*
+ != 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.
+ *
+ * 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.
+
+ /*
+ * 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);
}
@@ -3153,57 +3544,58 @@ FSUnloadTempFile(loadHandle)
*
* Tcl_FSLink --
*
- * This function replaces the library version of readlink() and
- * can also be used to make links. The appropriate function for
- * the filesystem to which pathPtr belongs will be called.
+ * 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.
- *
+ * 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
+ * See readlink() documentation. A new filesystem link object may appear.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
-Tcl_FSLink(pathPtr, toPtr, linkAction)
- Tcl_Obj *pathPtr; /* Path of file to readlink or link */
- Tcl_Obj *toPtr; /* NULL or path to be linked to */
- int linkAction; /* Action to perform */
+Tcl_FSLink(
+ Tcl_Obj *pathPtr, /* Path of file to readlink or link */
+ Tcl_Obj *toPtr, /* NULL or path to be linked to */
+ int linkAction) /* Action to perform */
{
- Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+
if (fsPtr != NULL) {
Tcl_FSLinkProc *proc = fsPtr->linkProc;
+
if (proc != NULL) {
return (*proc)(pathPtr, toPtr, linkAction);
}
}
+
/*
- * If S_IFLNK isn't defined it means that the machine doesn't
- * support symbolic links, so the file can't possibly be a
- * symbolic link. Generate an EINVAL error, which is what
- * happens on machines that do support symbolic links when
- * you invoke readlink on a file that isn't a symbolic link.
+ * 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
@@ -3217,17 +3609,16 @@ Tcl_FSLink(pathPtr, toPtr, linkAction)
*
* 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.
+ * 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.
@@ -3243,12 +3634,12 @@ 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.
+ * 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();
@@ -3263,7 +3654,7 @@ Tcl_FSListVolumes(void)
}
fsRecPtr = fsRecPtr->nextPtr;
}
-
+
return resultPtr;
}
@@ -3272,13 +3663,12 @@ Tcl_FSListVolumes(void)
*
* FsListMounts --
*
- * List all mounts within the given directory, which match the
- * given pattern.
+ * 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.
+ * 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
@@ -3286,27 +3676,27 @@ Tcl_FSListVolumes(void)
*---------------------------------------------------------------------------
*/
-static Tcl_Obj*
-FsListMounts(pathPtr, pattern)
- Tcl_Obj *pathPtr; /* Contains path to directory to search. */
- CONST char *pattern; /* Pattern to match against. */
+static Tcl_Obj *
+FsListMounts(
+ Tcl_Obj *pathPtr, /* Contains path to directory to search. */
+ const char *pattern) /* Pattern to match against. */
{
FilesystemRecord *fsRecPtr;
Tcl_GlobTypeData mountsOnly = { TCL_GLOB_TYPE_MOUNT, 0, NULL, NULL };
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.
+ * Call each of the "matchInDirectory" functions in succession, with the
+ * specific type information 'mountsOnly'. A non-NULL return value
+ * indicates the particular function has succeeded. We call all the
+ * functions registered, since we want a list from each filesystems.
*/
fsRecPtr = FsGetFirstFilesystem();
while (fsRecPtr != NULL) {
if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
- Tcl_FSMatchInDirectoryProc *proc =
- fsRecPtr->fsPtr->matchInDirectoryProc;
+ Tcl_FSMatchInDirectoryProc *proc =
+ fsRecPtr->fsPtr->matchInDirectoryProc;
if (proc != NULL) {
if (resultPtr == NULL) {
resultPtr = Tcl_NewObj();
@@ -3316,7 +3706,7 @@ FsListMounts(pathPtr, pattern)
}
fsRecPtr = fsRecPtr->nextPtr;
}
-
+
return resultPtr;
}
@@ -3325,14 +3715,14 @@ FsListMounts(pathPtr, pattern)
*
* 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.
+ * 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.
+ * 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.
@@ -3340,23 +3730,23 @@ FsListMounts(pathPtr, pattern)
*---------------------------------------------------------------------------
*/
-Tcl_Obj*
-Tcl_FSSplitPath(pathPtr, lenPtr)
- Tcl_Obj *pathPtr; /* Path to split. */
- int *lenPtr; /* int to store number of path elements. */
+Tcl_Obj *
+Tcl_FSSplitPath(
+ Tcl_Obj *pathPtr, /* Path to split. */
+ int *lenPtr) /* int to store number of path elements. */
{
- Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */
+ Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */
Tcl_Filesystem *fsPtr;
char separator = '/';
int driveNameLength;
char *p;
-
+
/*
- * Perform platform specific splitting.
+ * Perform platform specific splitting.
*/
- if (FSGetPathType(pathPtr, &fsPtr, &driveNameLength)
- == TCL_PATH_ABSOLUTE) {
+ if (TclFSGetPathType(pathPtr, &fsPtr,
+ &driveNameLength) == TCL_PATH_ABSOLUTE) {
if (fsPtr == &tclNativeFilesystem) {
return TclpNativeSplitPath(pathPtr, lenPtr);
}
@@ -3364,27 +3754,35 @@ Tcl_FSSplitPath(pathPtr, lenPtr)
return TclpNativeSplitPath(pathPtr, lenPtr);
}
- /* We assume separators are single characters */
+ /*
+ * We assume separators are single characters.
+ */
+
if (fsPtr->filesystemSeparatorProc != NULL) {
Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(pathPtr);
if (sep != NULL) {
+ Tcl_IncrRefCount(sep);
separator = Tcl_GetString(sep)[0];
+ Tcl_DecrRefCount(sep);
}
}
-
- /*
- * Place the drive name as first element of the
- * result list. The drive name may contain strange
- * characters, like colons and multiple forward slashes
- * (for example 'ftp://' is a valid vfs drive name)
+
+ /*
+ * 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 */
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(p, driveNameLength));
+ p += driveNameLength;
+
+ /*
+ * Add the remaining path elements to the list.
+ */
+
for (;;) {
char *elementStart = p;
int length;
@@ -3395,7 +3793,7 @@ Tcl_FSSplitPath(pathPtr, lenPtr)
if (length > 0) {
Tcl_Obj *nextElt;
if (elementStart[0] == '~') {
- nextElt = Tcl_NewStringObj("./",2);
+ TclNewLiteralStringObj(nextElt, "./");
Tcl_AppendToObj(nextElt, elementStart, length);
} else {
nextElt = Tcl_NewStringObj(elementStart, length);
@@ -3406,23 +3804,23 @@ Tcl_FSSplitPath(pathPtr, lenPtr)
break;
}
}
-
+
/*
* Compute the number of elements in the result.
*/
if (lenPtr != NULL) {
- Tcl_ListObjLength(NULL, result, lenPtr);
+ TclListObjLength(NULL, result, lenPtr);
}
return result;
}
/* Simple helper function */
-Tcl_Obj*
-TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr)
- Tcl_Filesystem *fromFilesystem;
- ClientData clientData;
- FilesystemRecord **fsRecPtrPtr;
+Tcl_Obj *
+TclFSInternalToNormalized(
+ Tcl_Filesystem *fromFilesystem,
+ ClientData clientData,
+ FilesystemRecord **fsRecPtrPtr)
{
FilesystemRecord *fsRecPtr = FsGetFirstFilesystem();
@@ -3433,9 +3831,9 @@ TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr)
}
fsRecPtr = fsRecPtr->nextPtr;
}
-
- if ((fsRecPtr != NULL)
- && (fromFilesystem->internalToNormalizedProc != NULL)) {
+
+ if ((fsRecPtr != NULL)
+ && (fromFilesystem->internalToNormalizedProc != NULL)) {
return (*fromFilesystem->internalToNormalizedProc)(clientData);
} else {
return NULL;
@@ -3445,15 +3843,15 @@ TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr)
/*
*----------------------------------------------------------------------
*
- * GetPathType --
+ * TclGetPathType --
*
* Helper function used by FSGetPathType.
*
* Results:
* Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
- * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will
- * be set if and only if it is non-NULL and the function's
- * return value is TCL_PATH_ABSOLUTE.
+ * 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.
@@ -3461,64 +3859,129 @@ TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr)
*----------------------------------------------------------------------
*/
-static Tcl_PathType
-GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef)
- Tcl_Obj *pathObjPtr;
- Tcl_Filesystem **filesystemPtrPtr;
- int *driveNameLengthPtr;
- Tcl_Obj **driveNameRef;
+Tcl_PathType
+TclGetPathType(
+ Tcl_Obj *pathPtr, /* Path to determine type for */
+ Tcl_Filesystem **filesystemPtrPtr,
+ /* If absolute path and this is not NULL, then
+ * set to the filesystem which claims this
+ * path. */
+ int *driveNameLengthPtr, /* If the path is absolute, and this is
+ * non-NULL, then set to the length of the
+ * driveName. */
+ Tcl_Obj **driveNameRef) /* If the path is absolute, and this is
+ * non-NULL, then set to the name of the
+ * drive, network-volume which contains the
+ * path, already with a refCount for the
+ * caller. */
{
- FilesystemRecord *fsRecPtr;
int pathLen;
char *path;
+ Tcl_PathType type;
+
+ path = Tcl_GetStringFromObj(pathPtr, &pathLen);
+
+ type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr,
+ driveNameLengthPtr, driveNameRef);
+
+ if (type != TCL_PATH_ABSOLUTE) {
+ type = TclpGetNativePathType(pathPtr, driveNameLengthPtr,
+ driveNameRef);
+ if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) {
+ *filesystemPtrPtr = &tclNativeFilesystem;
+ }
+ }
+ return type;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFSNonnativePathType --
+ *
+ * Helper function used by TclGetPathType. Its purpose is to check
+ * whether the given path starts with a string which corresponds to a
+ * file volume in any registered filesystem except the native one. For
+ * speed and historical reasons the native filesystem has special
+ * hard-coded checks dotted here and there in the filesystem code.
+ *
+ * Results:
+ * Returns one of TCL_PATH_ABSOLUTE or TCL_PATH_RELATIVE. The filesystem
+ * reference will be set if and only if it is non-NULL and the function's
+ * return value is TCL_PATH_ABSOLUTE.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_PathType
+TclFSNonnativePathType(
+ const char *path, /* Path to determine type for */
+ int pathLen, /* Length of the path */
+ Tcl_Filesystem **filesystemPtrPtr,
+ /* If absolute path and this is not NULL, then
+ * set to the filesystem which claims this
+ * path. */
+ int *driveNameLengthPtr, /* If the path is absolute, and this is
+ * non-NULL, then set to the length of the
+ * driveName. */
+ Tcl_Obj **driveNameRef) /* If the path is absolute, and this is
+ * non-NULL, then set to the name of the
+ * drive, network-volume which contains the
+ * path, already with a refCount for the
+ * caller. */
+{
+ FilesystemRecord *fsRecPtr;
Tcl_PathType type = TCL_PATH_RELATIVE;
-
- 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).
+ * 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.
+ * otherwise we won't necessarily pass all the Tcl testsuite -- this
+ * is because some of the tests artificially change the current
+ * platform (between win, unix) but the list of volumes we get by
+ * calling (*proc) will reflect the current (real) platform only and
+ * this may cause some tests to fail. In particular, on unix '/' will
+ * match the beginning of certain absolute Windows paths starting '//'
+ * and those tests will go wrong.
+ *
+ * Besides these test-suite issues, there is one other reason to skip
+ * the native filesystem --- since the tclFilename.c code has nice
+ * fast 'absolute path' checkers, we don't want to waste time
+ * repeating that effort here, and this function is actually called
+ * quite often, so if we can save the overhead of the native
+ * filesystem returning us a list of volumes all the time, it is
+ * better.
*/
+
if ((fsRecPtr->fsPtr != &tclNativeFilesystem) && (proc != NULL)) {
int numVolumes;
Tcl_Obj *thisFsVolumes = (*proc)();
+
if (thisFsVolumes != NULL) {
- if (Tcl_ListObjLength(NULL, thisFsVolumes,
- &numVolumes) != TCL_OK) {
- /*
- * This is VERY bad; the Tcl_FSListVolumesProc
- * didn't return a valid list. Set numVolumes to
- * -1 so that we skip the while loop below and just
- * return with the current value of 'type'.
- *
- * It would be better if we could signal an error
- * here (but panic seems a bit excessive).
+ if (Tcl_ListObjLength(NULL, thisFsVolumes, &numVolumes)
+ != TCL_OK) {
+ /*
+ * This is VERY bad; the Tcl_FSListVolumesProc didn't
+ * return a valid list. Set numVolumes to -1 so that we
+ * skip the while loop below and just return with the
+ * current value of 'type'.
+ *
+ * It would be better if we could signal an error here
+ * (but Tcl_Panic seems a bit excessive).
*/
+
numVolumes = -1;
}
while (numVolumes > 0) {
@@ -3549,21 +4012,15 @@ GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef)
}
Tcl_DecrRefCount(thisFsVolumes);
if (type == TCL_PATH_ABSOLUTE) {
- /* We don't need to examine any more filesystems */
+ /*
+ * We don't need to examine any more filesystems.
+ */
break;
}
}
}
fsRecPtr = fsRecPtr->nextPtr;
}
-
- if (type != TCL_PATH_ABSOLUTE) {
- type = TclpGetNativePathType(pathObjPtr, driveNameLengthPtr,
- driveNameRef);
- if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) {
- *filesystemPtrPtr = &tclNativeFilesystem;
- }
- }
return type;
}
@@ -3572,12 +4029,12 @@ GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef)
*
* 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.
+ * 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.
+ * Standard Tcl error code if a function was called.
*
* Side effects:
* A file may be renamed.
@@ -3586,21 +4043,21 @@ GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef)
*/
int
-Tcl_FSRenameFile(srcPathPtr, destPathPtr)
- Tcl_Obj* srcPathPtr; /* Pathname of file or dir to be renamed
+Tcl_FSRenameFile(
+ Tcl_Obj* srcPathPtr, /* Pathname of file or dir to be renamed
* (UTF-8). */
- Tcl_Obj *destPathPtr; /* New pathname of file or directory
+ Tcl_Obj *destPathPtr) /* New pathname of file or directory
* (UTF-8). */
{
int retVal = -1;
- Tcl_Filesystem *fsPtr, *fsPtr2;
+ const Tcl_Filesystem *fsPtr, *fsPtr2;
fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);
- if (fsPtr == fsPtr2 && fsPtr != NULL) {
+ if ((fsPtr == fsPtr2) && (fsPtr != NULL)) {
Tcl_FSRenameFileProc *proc = fsPtr->renameFileProc;
if (proc != NULL) {
- retVal = (*proc)(srcPathPtr, destPathPtr);
+ retVal = (*proc)(srcPathPtr, destPathPtr);
}
}
if (retVal == -1) {
@@ -3614,16 +4071,16 @@ Tcl_FSRenameFile(srcPathPtr, destPathPtr)
*
* Tcl_FSCopyFile --
*
- * If the two paths given belong to the same filesystem, we call
- * that filesystem's copy function. Otherwise we simply
- * return the posix error 'EXDEV', and -1.
- *
- * 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).
+ * 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.
+ * Standard Tcl error code if a function was called.
*
* Side effects:
* A file may be copied.
@@ -3631,13 +4088,13 @@ Tcl_FSRenameFile(srcPathPtr, destPathPtr)
*---------------------------------------------------------------------------
*/
-int
-Tcl_FSCopyFile(srcPathPtr, destPathPtr)
- Tcl_Obj* srcPathPtr; /* Pathname of file to be copied (UTF-8). */
- Tcl_Obj *destPathPtr; /* Pathname of file to copy to (UTF-8). */
+int
+Tcl_FSCopyFile(
+ Tcl_Obj *srcPathPtr, /* Pathname of file to be copied (UTF-8). */
+ Tcl_Obj *destPathPtr) /* Pathname of file to copy to (UTF-8). */
{
int retVal = -1;
- Tcl_Filesystem *fsPtr, *fsPtr2;
+ const Tcl_Filesystem *fsPtr, *fsPtr2;
fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);
@@ -3658,64 +4115,75 @@ Tcl_FSCopyFile(srcPathPtr, destPathPtr)
*
* TclCrossFilesystemCopy --
*
- * Helper for above function, and for Tcl_FSLoadFile, to copy
- * files from one filesystem to another. This function will
- * overwrite the target file if it already exists.
+ * Helper for above function, and for Tcl_FSLoadFile, to copy files from
+ * one filesystem to another. This function will overwrite the target
+ * file if it already exists.
*
* Results:
- * Standard Tcl error code.
+ * 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
+TclCrossFilesystemCopy(
+ Tcl_Interp *interp, /* For error messages */
+ Tcl_Obj *source, /* Pathname of file to be copied (UTF-8). */
+ Tcl_Obj *target) /* Pathname of file to copy to (UTF-8). */
{
int result = TCL_ERROR;
int prot = 0666;
-
- Tcl_Channel 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);
- }
- }
+ Tcl_Channel in, out;
+ Tcl_StatBuf sourceStatBuf;
+ struct utimbuf tval;
+
+ out = Tcl_FSOpenFileChannel(interp, target, "wb", prot);
+ if (out == NULL) {
+ /*
+ * It looks like we cannot copy it over. Bail out...
+ */
+ goto done;
}
+
+ in = Tcl_FSOpenFileChannel(interp, source, "rb", prot);
+ if (in == NULL) {
+ /*
+ * This is very strange, caller should have checked this...
+ */
+
+ Tcl_Close(interp, out);
+ goto done;
+ }
+
+ /*
+ * Copy it synchronously. We might wish to add an asynchronous option to
+ * support vfs's which are slow (e.g. network sockets).
+ */
+
+ if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) {
+ result = TCL_OK;
+ }
+
+ /*
+ * If the copy failed, assume that copy channel left a good error message.
+ */
+
+ Tcl_Close(interp, in);
+ Tcl_Close(interp, out);
+
+ /*
+ * Set modification date of copied file.
+ */
+
+ if (Tcl_FSLstat(source, &sourceStatBuf) == 0) {
+ tval.actime = sourceStatBuf.st_atime;
+ tval.modtime = sourceStatBuf.st_mtime;
+ Tcl_FSUtime(target, &tval);
+ }
+
+ done:
return result;
}
@@ -3724,11 +4192,11 @@ TclCrossFilesystemCopy(interp, source, target)
*
* Tcl_FSDeleteFile --
*
- * The appropriate function for the filesystem to which pathPtr
- * belongs will be called.
+ * The appropriate function for the filesystem to which pathPtr belongs
+ * will be called.
*
* Results:
- * Standard Tcl error code.
+ * Standard Tcl error code.
*
* Side effects:
* A file may be deleted.
@@ -3737,10 +4205,10 @@ TclCrossFilesystemCopy(interp, source, target)
*/
int
-Tcl_FSDeleteFile(pathPtr)
- Tcl_Obj *pathPtr; /* Pathname of file to be removed (UTF-8). */
+Tcl_FSDeleteFile(
+ Tcl_Obj *pathPtr) /* Pathname of file to be removed (UTF-8). */
{
- Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSDeleteFileProc *proc = fsPtr->deleteFileProc;
if (proc != NULL) {
@@ -3756,11 +4224,11 @@ Tcl_FSDeleteFile(pathPtr)
*
* Tcl_FSCreateDirectory --
*
- * The appropriate function for the filesystem to which pathPtr
- * belongs will be called.
+ * The appropriate function for the filesystem to which pathPtr belongs
+ * will be called.
*
* Results:
- * Standard Tcl error code.
+ * Standard Tcl error code.
*
* Side effects:
* A directory may be created.
@@ -3769,10 +4237,10 @@ Tcl_FSDeleteFile(pathPtr)
*/
int
-Tcl_FSCreateDirectory(pathPtr)
- Tcl_Obj *pathPtr; /* Pathname of directory to create (UTF-8). */
+Tcl_FSCreateDirectory(
+ Tcl_Obj *pathPtr) /* Pathname of directory to create (UTF-8). */
{
- Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSCreateDirectoryProc *proc = fsPtr->createDirectoryProc;
if (proc != NULL) {
@@ -3788,12 +4256,12 @@ Tcl_FSCreateDirectory(pathPtr)
*
* Tcl_FSCopyDirectory --
*
- * If the two paths given belong to the same filesystem, we call
- * that filesystems copy-directory function. Otherwise we simply
- * return the posix error 'EXDEV', and -1.
+ * 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.
+ * Standard Tcl error code if a function was called.
*
* Side effects:
* A directory may be copied.
@@ -3802,16 +4270,16 @@ Tcl_FSCreateDirectory(pathPtr)
*/
int
-Tcl_FSCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
- Tcl_Obj* srcPathPtr; /* Pathname of directory to be copied
+Tcl_FSCopyDirectory(
+ Tcl_Obj* srcPathPtr, /* Pathname of directory to be copied
* (UTF-8). */
- Tcl_Obj *destPathPtr; /* Pathname of target directory (UTF-8). */
- Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a
- * new object containing name of file
- * causing error, with refCount 1. */
+ Tcl_Obj *destPathPtr, /* Pathname of target directory (UTF-8). */
+ Tcl_Obj **errorPtr) /* If non-NULL, then will be set to a new
+ * object containing name of file causing
+ * error, with refCount 1. */
{
int retVal = -1;
- Tcl_Filesystem *fsPtr, *fsPtr2;
+ const Tcl_Filesystem *fsPtr, *fsPtr2;
fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);
@@ -3832,11 +4300,11 @@ Tcl_FSCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
*
* Tcl_FSRemoveDirectory --
*
- * The appropriate function for the filesystem to which pathPtr
- * belongs will be called.
+ * The appropriate function for the filesystem to which pathPtr belongs
+ * will be called.
*
* Results:
- * Standard Tcl error code.
+ * Standard Tcl error code.
*
* Side effects:
* A directory may be deleted.
@@ -3845,49 +4313,53 @@ Tcl_FSCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
*/
int
-Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr)
- Tcl_Obj *pathPtr; /* Pathname of directory to be removed
+Tcl_FSRemoveDirectory(
+ Tcl_Obj *pathPtr, /* Pathname of directory to be removed
* (UTF-8). */
- int recursive; /* If non-zero, removes directories that
- * are nonempty. Otherwise, will only remove
- * empty directories. */
- Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a
- * new object containing name of file
- * causing error, with refCount 1. */
+ 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) {
+ const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL && fsPtr->removeDirectoryProc != 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);
- }
+ if (recursive) {
+ /*
+ * We check whether the cwd lies inside this directory and move it
+ * if it does.
+ */
+
+ Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL);
+
+ if (cwdPtr != NULL) {
+ char *cwdStr, *normPathStr;
+ int cwdLen, normLen;
+ Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+
+ if (normPath != NULL) {
+ normPathStr = Tcl_GetStringFromObj(normPath, &normLen);
+ cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
+ if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr,
+ (size_t) normLen) == 0)) {
+ /*
+ * The cwd is inside the directory, so we perform a
+ * 'cd [file dirname $path]'.
+ */
+
+ Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr,
+ TCL_PATH_DIRNAME);
+
+ Tcl_FSChdir(dirPtr);
+ Tcl_DecrRefCount(dirPtr);
}
- Tcl_DecrRefCount(cwdPtr);
}
+ Tcl_DecrRefCount(cwdPtr);
}
- return (*proc)(pathPtr, recursive, errorPtr);
}
+ return (*proc)(pathPtr, recursive, errorPtr);
}
Tcl_SetErrno(ENOENT);
return -1;
@@ -3898,13 +4370,13 @@ Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr)
*
* Tcl_FSGetFileSystemForPath --
*
- * This function determines which filesystem to use for a
- * particular path object, and returns the filesystem which
- * accepts this file. If no filesystem will accept this object
- * as a valid file path, then NULL is returned.
+ * 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.
+ * NULL or a filesystem which will accept this path.
*
* Side effects:
* The object may be converted to a path type.
@@ -3912,56 +4384,60 @@ Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr)
*---------------------------------------------------------------------------
*/
-Tcl_Filesystem*
-Tcl_FSGetFileSystemForPath(pathObjPtr)
- Tcl_Obj* pathObjPtr;
+Tcl_Filesystem *
+Tcl_FSGetFileSystemForPath(
+ Tcl_Obj* pathPtr)
{
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 (pathPtr == NULL) {
+ Tcl_Panic("Tcl_FSGetFileSystemForPath called with NULL object");
+ return NULL;
+ }
+
+ /*
+ * If the object has a refCount of zero, we reject it. This is to avoid
+ * possible segfaults or nondeterministic memory leaks (i.e. the user
+ * doesn't know if they should decrement the ref count on return or not).
*/
-
- if (pathObjPtr->refCount == 0) {
- panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0");
+
+ if (pathPtr->refCount == 0) {
+ Tcl_Panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0");
return NULL;
}
-
- /*
- * Check if the filesystem has changed in some way since
- * this object's internal representation was calculated.
- * Before doing that, assure we have the most up-to-date
- * copy of the master filesystem. This is accomplished
- * by the FsGetFirstFilesystem() call.
+
+ /*
+ * Check if the filesystem has changed in some way since this object's
+ * internal representation was calculated. Before doing that, assure we
+ * have the most up-to-date copy of the master filesystem. This is
+ * accomplished by the FsGetFirstFilesystem() call.
*/
fsRecPtr = FsGetFirstFilesystem();
- if (TclFSEnsureEpochOk(pathObjPtr, &retVal) != TCL_OK) {
+ if (TclFSEnsureEpochOk(pathPtr, &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.
+ * Call each of the "pathInFilesystem" functions in succession. A
+ * non-return value of -1 indicates the particular function has succeeded.
*/
while ((retVal == NULL) && (fsRecPtr != NULL)) {
- Tcl_FSPathInFilesystemProc *proc = fsRecPtr->fsPtr->pathInFilesystemProc;
+ 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.
+ if ((*proc)(pathPtr, &clientData) != -1) {
+ /*
+ * We assume the type of pathPtr hasn't been changed by the
+ * above call to the pathInFilesystemProc.
*/
- TclFSSetPathDetails(pathObjPtr, fsRecPtr, clientData);
+
+ TclFSSetPathDetails(pathPtr, fsRecPtr, clientData);
retVal = fsRecPtr->fsPtr;
}
}
@@ -3976,26 +4452,23 @@ Tcl_FSGetFileSystemForPath(pathObjPtr)
*
* 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.
+ * This function is for use by the Win/Unix native filesystems, so that
+ * they can easily retrieve the native (char* or TCHAR*) representation
+ * of a path. Other filesystems will probably want to implement similar
+ * functions. They basically act as a safety net around
+ * Tcl_FSGetInternalRep. Normally your file-system functions will always
+ * be called with path objects already converted to the correct
+ * filesystem, but if for some reason they are called directly (i.e. by
+ * functions not in this file), then one cannot necessarily guarantee
+ * that the path object pointer is from the correct filesystem.
+ *
+ * Note: in the future it might be desireable to have separate versions
+ * of this function with different signatures, for example
+ * Tcl_FSGetNativeWinPath, Tcl_FSGetNativeUnixPath etc. Right now, since
+ * native paths are all string based, we use just one function.
*
* Results:
- * NULL or a valid native path.
+ * NULL or a valid native path.
*
* Side effects:
* See Tcl_FSGetInternalRep.
@@ -4003,164 +4476,11 @@ Tcl_FSGetFileSystemForPath(pathObjPtr)
*---------------------------------------------------------------------------
*/
-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);
- if (validPathObjPtr == NULL) {
- return NULL;
- }
-
- 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;
+const char *
+Tcl_FSGetNativePath(
+ Tcl_Obj *pathPtr)
{
- 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;
-}
-
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclNativeDupInternalRep --
- *
- * Duplicate the native representation.
- *
- * Results:
- * The copied native representation, or NULL if it is not possible
- * to copy the representation.
- *
- * Side effects:
- * None.
- *
- *---------------------------------------------------------------------------
- */
-ClientData
-TclNativeDupInternalRep(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;
+ return (const char *) Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem);
}
/*
@@ -4168,21 +4488,22 @@ TclNativeDupInternalRep(clientData)
*
* NativeFreeInternalRep --
*
- * Free a native internal representation, which will be non-NULL.
+ * Free a native internal representation, which will be non-NULL.
*
* Results:
- * None.
+ * None.
*
* Side effects:
* Memory is released.
*
*---------------------------------------------------------------------------
*/
-static void
-NativeFreeInternalRep(clientData)
- ClientData clientData;
+
+static void
+NativeFreeInternalRep(
+ ClientData clientData)
{
- ckfree((char*)clientData);
+ ckfree((char *) clientData);
}
/*
@@ -4190,44 +4511,42 @@ NativeFreeInternalRep(clientData)
*
* Tcl_FSFileSystemInfo --
*
- * This function returns a list of two elements. The first
- * element is the name of the filesystem (e.g. "native" or "vfs"),
- * and the second is the particular type of the given path within
- * that filesystem.
+ * This function returns a list of two elements. The first element is the
+ * name of the filesystem (e.g. "native" or "vfs"), and the second is the
+ * particular type of the given path within that filesystem.
*
* Results:
- * A list of two elements.
+ * 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 *
+Tcl_FSFileSystemInfo(
+ Tcl_Obj *pathPtr)
{
Tcl_Obj *resPtr;
Tcl_FSFilesystemPathTypeProc *proc;
- Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr);
-
+ const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+
if (fsPtr == NULL) {
return NULL;
}
-
- resPtr = Tcl_NewListObj(0,NULL);
-
- Tcl_ListObjAppendElement(NULL, resPtr,
- Tcl_NewStringObj(fsPtr->typeName,-1));
+
+ 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);
+ Tcl_Obj *typePtr = (*proc)(pathPtr);
if (typePtr != NULL) {
Tcl_ListObjAppendElement(NULL, resPtr, typePtr);
}
}
-
+
return resPtr;
}
@@ -4236,33 +4555,42 @@ Tcl_FSFileSystemInfo(pathObjPtr)
*
* Tcl_FSPathSeparator --
*
- * This function returns the separator to be used for a given
- * path. The object returned should have a refCount of zero
+ * 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.
+ * A Tcl object, with a refCount of zero. If the caller needs to retain a
+ * reference to the object, it should call Tcl_IncrRefCount, and should
+ * otherwise free the object.
*
* Side effects:
* The path object may be converted to a path type.
*
*---------------------------------------------------------------------------
*/
-Tcl_Obj*
-Tcl_FSPathSeparator(pathObjPtr)
- Tcl_Obj* pathObjPtr;
+
+Tcl_Obj *
+Tcl_FSPathSeparator(
+ Tcl_Obj *pathPtr)
{
- Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr);
-
+ const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+
if (fsPtr == NULL) {
return NULL;
}
if (fsPtr->filesystemSeparatorProc != NULL) {
- return (*fsPtr->filesystemSeparatorProc)(pathObjPtr);
+ return (*fsPtr->filesystemSeparatorProc)(pathPtr);
+ } else {
+ Tcl_Obj *resultObj;
+
+ /*
+ * Allow filesystems not to provide a filesystemSeparatorProc if they
+ * wish to use the standard forward slash.
+ */
+
+ TclNewLiteralStringObj(resultObj, "/");
+ return resultObj;
}
-
- return NULL;
}
/*
@@ -4270,32 +4598,30 @@ Tcl_FSPathSeparator(pathObjPtr)
*
* NativeFilesystemSeparator --
*
- * This function is part of the native filesystem support, and
- * returns the separator for the given path.
+ * This function is part of the native filesystem support, and returns
+ * the separator for the given path.
*
* Results:
- * String object containing the separator character.
+ * String object containing the separator character.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
-static Tcl_Obj*
-NativeFilesystemSeparator(pathObjPtr)
- Tcl_Obj* pathObjPtr;
+
+static Tcl_Obj *
+NativeFilesystemSeparator(
+ Tcl_Obj *pathPtr)
{
- char *separator = NULL; /* lint */
+ const char *separator = NULL; /* lint */
switch (tclPlatform) {
- case TCL_PLATFORM_UNIX:
- separator = "/";
- break;
- case TCL_PLATFORM_WINDOWS:
- separator = "\\";
- break;
- case TCL_PLATFORM_MAC:
- separator = ":";
- break;
+ case TCL_PLATFORM_UNIX:
+ separator = "/";
+ break;
+ case TCL_PLATFORM_WINDOWS:
+ separator = "\\";
+ break;
}
return Tcl_NewStringObj(separator,1);
}
@@ -4308,26 +4634,25 @@ NativeFilesystemSeparator(pathObjPtr)
*
* 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.
+ * Insert the passed function pointer at the head of the list of
+ * functions which are used during a call to 'TclStat(...)'. The passed
+ * function should behave exactly like 'TclStat' when called during that
+ * time (see 'TclStat(...)' for more information). The function will be
+ * added even if it already in the list.
*
* Results:
- * Normally TCL_OK; TCL_ERROR if memory for a new node in the list
- * could not be allocated.
+ * 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.
+ * Memory allocated and modifies the link list for 'TclStat' functions.
*
*----------------------------------------------------------------------
*/
int
-TclStatInsertProc (proc)
- TclStatProc_ *proc;
+TclStatInsertProc(
+ TclStatProc_ *proc)
{
int retVal = TCL_ERROR;
@@ -4356,22 +4681,21 @@ TclStatInsertProc (proc)
* TclStatDeleteProc --
*
* Removed the passed function pointer from the list of 'TclStat'
- * functions. Ensures that the built-in stat function is not
- * removvable.
+ * functions. Ensures that the built-in stat function is not removable.
*
* Results:
- * TCL_OK if the procedure pointer was successfully removed,
- * TCL_ERROR otherwise.
+ * TCL_OK if the function pointer was successfully removed, TCL_ERROR
+ * otherwise.
*
* Side effects:
- * Memory is deallocated and the respective list updated.
+ * Memory is deallocated and the respective list updated.
*
*----------------------------------------------------------------------
*/
int
-TclStatDeleteProc (proc)
- TclStatProc_ *proc;
+TclStatDeleteProc(
+ TclStatProc_ *proc)
{
int retVal = TCL_ERROR;
StatProc *tmpStatProcPtr;
@@ -4379,10 +4703,11 @@ TclStatDeleteProc (proc)
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.
+ * 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)) {
@@ -4412,27 +4737,25 @@ TclStatDeleteProc (proc)
*
* 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.
+ * Insert the passed function pointer at the head of the list of
+ * functions which are used during a call to 'TclAccess(...)'. The passed
+ * function should behave exactly like 'TclAccess' when called during
+ * that time (see 'TclAccess(...)' for more information). The function
+ * will be added even if it already in the list.
*
* Results:
- * Normally TCL_OK; TCL_ERROR if memory for a new node in the list
- * could not be allocated.
+ * 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.
+ * Memory allocated and modifies the link list for 'TclAccess' functions.
*
*----------------------------------------------------------------------
*/
int
-TclAccessInsertProc(proc)
- TclAccessProc_ *proc;
+TclAccessInsertProc(
+ TclAccessProc_ *proc)
{
int retVal = TCL_ERROR;
@@ -4461,31 +4784,30 @@ TclAccessInsertProc(proc)
* TclAccessDeleteProc --
*
* Removed the passed function pointer from the list of 'TclAccess'
- * functions. Ensures that the built-in access function is not
- * removvable.
+ * functions. Ensures that the built-in access function is not removable.
*
* Results:
- * TCL_OK if the procedure pointer was successfully removed,
- * TCL_ERROR otherwise.
+ * TCL_OK if the function pointer was successfully removed, TCL_ERROR
+ * otherwise.
*
* Side effects:
- * Memory is deallocated and the respective list updated.
+ * Memory is deallocated and the respective list updated.
*
*----------------------------------------------------------------------
*/
int
-TclAccessDeleteProc(proc)
- TclAccessProc_ *proc;
+TclAccessDeleteProc(
+ TclAccessProc_ *proc)
{
int retVal = TCL_ERROR;
AccessProc *tmpAccessProcPtr;
AccessProc *prevAccessProcPtr = NULL;
/*
- * Traverse the 'accessProcList' looking for the particular node
- * whose 'proc' member matches 'proc' and remove that one from
- * the list. Ensure that the "default" node cannot be removed.
+ * 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);
@@ -4516,45 +4838,43 @@ TclAccessDeleteProc(proc)
*
* 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.
+ * Insert the passed function pointer at the head of the list of
+ * functions which are used during a call to 'Tcl_OpenFileChannel(...)'.
+ * The passed function should behave exactly like 'Tcl_OpenFileChannel'
+ * when called during that time (see 'Tcl_OpenFileChannel(...)' for more
+ * information). The function will be added even if it already in the
+ * list.
*
* Results:
- * Normally TCL_OK; TCL_ERROR if memory for a new node in the list
- * could not be allocated.
+ * 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.
+ * Memory allocated and modifies the link list for 'Tcl_OpenFileChannel'
+ * functions.
*
*----------------------------------------------------------------------
*/
int
-TclOpenFileChannelInsertProc(proc)
- TclOpenFileChannelProc_ *proc;
+TclOpenFileChannelInsertProc(
+ TclOpenFileChannelProc_ *proc)
{
int retVal = TCL_ERROR;
if (proc != NULL) {
OpenFileChannelProc *newOpenFileChannelProcPtr;
- newOpenFileChannelProcPtr =
- (OpenFileChannelProc *)ckalloc(sizeof(OpenFileChannelProc));
+ newOpenFileChannelProcPtr = (OpenFileChannelProc *)
+ ckalloc(sizeof(OpenFileChannelProc));
- if (newOpenFileChannelProcPtr != NULL) {
- newOpenFileChannelProcPtr->proc = proc;
- Tcl_MutexLock(&obsoleteFsHookMutex);
- newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList;
- openFileChannelProcList = newOpenFileChannelProcPtr;
- Tcl_MutexUnlock(&obsoleteFsHookMutex);
+ newOpenFileChannelProcPtr->proc = proc;
+ Tcl_MutexLock(&obsoleteFsHookMutex);
+ newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList;
+ openFileChannelProcList = newOpenFileChannelProcPtr;
+ Tcl_MutexUnlock(&obsoleteFsHookMutex);
- retVal = TCL_OK;
- }
+ retVal = TCL_OK;
}
return retVal;
@@ -4566,31 +4886,30 @@ TclOpenFileChannelInsertProc(proc)
* 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.
+ * '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.
+ * TCL_OK if the function pointer was successfully removed, TCL_ERROR
+ * otherwise.
*
* Side effects:
- * Memory is deallocated and the respective list updated.
+ * Memory is deallocated and the respective list updated.
*
*----------------------------------------------------------------------
*/
int
-TclOpenFileChannelDeleteProc(proc)
- TclOpenFileChannelProc_ *proc;
+TclOpenFileChannelDeleteProc(
+ TclOpenFileChannelProc_ *proc)
{
int retVal = TCL_ERROR;
OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList;
OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL;
/*
- * Traverse the 'openFileChannelProcList' looking for the particular
- * node whose 'proc' member matches 'proc' and remove that one from
- * the list.
+ * Traverse the 'openFileChannelProcList' looking for the particular node
+ * whose 'proc' member matches 'proc' and remove that one from the list.
*/
Tcl_MutexLock(&obsoleteFsHookMutex);
@@ -4605,7 +4924,7 @@ TclOpenFileChannelDeleteProc(proc)
tmpOpenFileChannelProcPtr->nextPtr;
}
- ckfree((char *)tmpOpenFileChannelProcPtr);
+ ckfree((char *) tmpOpenFileChannelProcPtr);
retVal = TCL_OK;
} else {
@@ -4618,1919 +4937,11 @@ TclOpenFileChannelDeleteProc(proc)
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.
- */
-static 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
-#define TCLPATH_NEEDNORM 4
-
-/*
- *----------------------------------------------------------------------
- *
- * 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.
- *
- *----------------------------------------------------------------------
- */
-
-static 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) {
- /* The path is not absolute... */
-#ifdef __WIN32__
- /* ... on Windows we must make another call to determine
- * whether it's relative or volumerelative [Bug 2571597]. */
- return GetPathType(pathObjPtr, filesystemPtrPtr,
- driveNameLengthPtr, NULL);
-#else
- /* On other systems, quickly deduce !absolute -> relative */
- return TCL_PATH_RELATIVE;
-#endif
- }
- 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))) {
- /*
- * Finally, on Windows, 'file join' is defined to
- * convert all backslashes to forward slashes,
- * so the base part cannot have backslashes either.
- */
- if ((tclPlatform != TCL_PLATFORM_WINDOWS)
- || (strchr(Tcl_GetString(elt), '\\') == NULL)) {
- if (res != NULL) {
- TclDecrRefCount(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);
- Tcl_GetStringFromObj(res, &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);
- CONST char *p;
- int state = 0, count = 0;
-
- 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;
-
- /*
- * Look for path components made up of only "."
- * This is overly conservative analysis to keep simple. It may
- * mark some things as needing more aggressive normalization
- * that don't actually need it. No harm done.
- */
- for (p = addStrRep; len > 0; p++, len--) {
- switch (state) {
- case 0: /* So far only "." since last dirsep or start */
- switch (*p) {
- case '.':
- count++;
- break;
- case '/':
- case '\\':
- case ':':
- if (count) {
- PATHFLAGS(objPtr) |= TCLPATH_NEEDNORM;
- len = 0;
- }
- break;
- default:
- count = 0;
- state = 1;
- }
- case 1: /* Scanning for next dirsep */
- switch (*p) {
- case '/':
- case '\\':
- case ':':
- state = 0;
- break;
- }
- }
- }
- if (len == 0 && count) {
- PATHFLAGS(objPtr) |= TCLPATH_NEEDNORM;
- }
-
- return objPtr;
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclFSMakePathRelative --
- *
- * Only for internal use.
- *
- * Takes a path and a directory, where we _assume_ both path and
- * directory are absolute, normalized and that the path lies
- * inside the directory. Returns a Tcl_Obj representing filename
- * of the path relative to the directory.
- *
- * In the case where the resulting path would start with a '~', we
- * take special care to return an ordinary string. This means to
- * use that path (and not have it interpreted as a user name),
- * one must prepend './'. This may seem strange, but that is how
- * 'glob' is currently defined.
- *
- * Results:
- * NULL on error, otherwise a valid object, typically with
- * refCount of zero, which it is assumed the caller will
- * increment.
- *
- * 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);
- }
- }
- /* Now objPtr is a string object */
-
- if (Tcl_GetString(objPtr)[0] == '~') {
- /*
- * If the first character of the path is a tilde,
- * we must just return the path as is, to agree
- * with the defined behaviour of 'glob'.
- */
- return 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)
- Tcl_Interp *interp; /* Used for error reporting if not NULL. */
- Tcl_Obj *objPtr; /* The object to convert. */
-{
- 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 = NULL;
- 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) {
- /*
- * We lack a translated path result, but we have a directory
- * (cwdPtr) and a tail (normPathPtr), and if we join the
- * translated version of cwdPtr to normPathPtr, we'll get the
- * translated result we need, and can store it for future use.
- */
-
- Tcl_Obj *translatedCwdPtr = Tcl_FSGetTranslatedPath(interp,
- srcFsPathPtr->cwdPtr);
-
- retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1,
- &(srcFsPathPtr->normPathPtr));
- srcFsPathPtr->translatedPathPtr = retObj;
- Tcl_IncrRefCount(retObj);
- Tcl_DecrRefCount(translatedCwdPtr);
- } else {
- /*
- * 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;
- }
-
- if (retObj) {
- 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;
-
- 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. */
-
- if (PATHFLAGS(pathObjPtr) & TCLPATH_NEEDNORM) {
- /*
- * If the "tail" part has components (like /../) that cause
- * the combined path to need more complete normalizing,
- * call on the more powerful routine to accomplish that so
- * we avoid [Bug 2385549] ...
- */
-
- Tcl_Obj *newCopy = TclFSNormalizeAbsolutePath(interp, copy, NULL);
- Tcl_DecrRefCount(copy);
- copy = newCopy;
- } else {
- /*
- * ... but in most cases where we join a trouble free tail
- * to a normalized head, we can more efficiently normalize the
- * combined path by passing over only the unnormalized tail
- * portion. When this is sufficient, prior developers claim
- * 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);
- }
-
- /* 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);
- }
- 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;
-
- 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->normPathPtr = copy;
- }
- }
- 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;
- char *nativePathPtr;
-
- proc = srcFsPathPtr->fsRecPtr->fsPtr->createInternalRepProc;
- if (proc == NULL) {
- return NULL;
- }
-
- nativePathPtr = (*proc)(pathObjPtr);
- srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
- srcFsPathPtr->nativePathPtr = nativePathPtr;
- }
-
- 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);
- }
-
- /*
- * 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.
- *
- *---------------------------------------------------------------------------
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
*/
-static 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;
-}