summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.decls131
-rw-r--r--generic/tcl.h300
-rw-r--r--generic/tclCmdAH.c294
-rw-r--r--generic/tclCmdIL.c13
-rw-r--r--generic/tclCmdMZ.c17
-rw-r--r--generic/tclDate.c4
-rw-r--r--generic/tclDecls.h307
-rw-r--r--generic/tclEncoding.c49
-rw-r--r--generic/tclFCmd.c552
-rw-r--r--generic/tclFileName.c433
-rw-r--r--generic/tclGetDate.y4
-rw-r--r--generic/tclIO.c222
-rw-r--r--generic/tclIOCmd.c4
-rw-r--r--generic/tclIOUtil.c3444
-rw-r--r--generic/tclInt.decls130
-rw-r--r--generic/tclInt.h121
-rw-r--r--generic/tclIntDecls.h225
-rw-r--r--generic/tclLoad.c38
-rw-r--r--generic/tclStubInit.c77
-rw-r--r--generic/tclTest.c404
-rw-r--r--generic/tclUtil.c102
21 files changed, 5842 insertions, 1029 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 679cff8..482d5fa 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tcl.decls,v 1.50 2001/07/12 13:15:09 dkf Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.51 2001/07/31 19:12:06 vincentdarley Exp $
library tcl
@@ -1514,7 +1514,6 @@ declare 432 generic {
declare 433 generic {
Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel)
}
-
# introduced in 8.4a3
declare 434 generic {
Tcl_UniChar * Tcl_GetUnicodeFromObj (Tcl_Obj *objPtr, int *lengthPtr)
@@ -1530,6 +1529,134 @@ declare 436 generic {
declare 437 generic {
Tcl_Obj * Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
}
+declare 438 generic {
+ int Tcl_DetachChannel(Tcl_Interp* interp, Tcl_Channel channel)
+}
+declare 439 generic {
+ int Tcl_IsStandardChannel(Tcl_Channel channel)
+}
+declare 440 generic {
+ int Tcl_FSCopyFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr)
+}
+declare 441 generic {
+ int Tcl_FSCopyDirectory(Tcl_Obj *srcPathPtr, \
+ Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr)
+}
+declare 442 generic {
+ int Tcl_FSCreateDirectory(Tcl_Obj *pathPtr)
+}
+declare 443 generic {
+ int Tcl_FSDeleteFile(Tcl_Obj *pathPtr)
+}
+declare 444 generic {
+ int Tcl_FSLoadFile(Tcl_Interp * interp, \
+ Tcl_Obj *pathPtr, char * sym1, char * sym2, \
+ Tcl_PackageInitProc ** proc1Ptr, \
+ Tcl_PackageInitProc ** proc2Ptr, \
+ ClientData * clientDataPtr, \
+ Tcl_FSUnloadFileProc **unloadProcPtr)
+}
+declare 445 generic {
+ int Tcl_FSMatchInDirectory(Tcl_Interp *interp, Tcl_Obj * result, \
+ Tcl_Obj *pathPtr, \
+ char * pattern, Tcl_GlobTypeData * types)
+}
+declare 446 generic {
+ Tcl_Obj* Tcl_FSReadlink(Tcl_Obj *pathPtr)
+}
+declare 447 generic {
+ int Tcl_FSRemoveDirectory(Tcl_Obj *pathPtr, \
+ int recursive, Tcl_Obj **errorPtr)
+}
+declare 448 generic {
+ int Tcl_FSRenameFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr)
+}
+declare 449 generic {
+ int Tcl_FSLstat(Tcl_Obj *pathPtr, struct stat *buf)
+}
+declare 450 generic {
+ int Tcl_FSUtime(Tcl_Obj *pathPtr, struct utimbuf *tval)
+}
+declare 451 generic {
+ int Tcl_FSFileAttrsGet(Tcl_Interp *interp, \
+ int index, Tcl_Obj *pathPtr, \
+ Tcl_Obj **objPtrRef)
+}
+declare 452 generic {
+ int Tcl_FSFileAttrsSet(Tcl_Interp *interp, \
+ int index, Tcl_Obj *pathPtr, \
+ Tcl_Obj *objPtr)
+}
+declare 453 generic {
+ char** Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef)
+}
+declare 454 generic {
+ int Tcl_FSStat(Tcl_Obj *pathPtr, struct stat *buf)
+}
+declare 455 generic {
+ int Tcl_FSAccess(Tcl_Obj *pathPtr, int mode)
+}
+declare 456 generic {
+ Tcl_Channel Tcl_FSOpenFileChannel(Tcl_Interp *interp, Tcl_Obj *pathPtr, \
+ char *modeString, int permissions)
+}
+declare 457 generic {
+ Tcl_Obj* Tcl_FSGetCwd(Tcl_Interp *interp)
+}
+declare 458 generic {
+ int Tcl_FSChdir(Tcl_Obj *pathPtr)
+}
+declare 459 generic {
+ int Tcl_FSConvertToPathType(Tcl_Interp *interp, Tcl_Obj *pathPtr)
+}
+declare 460 generic {
+ Tcl_Obj* Tcl_FSJoinPath(Tcl_Obj *listObj, int elements)
+}
+declare 461 generic {
+ Tcl_Obj* Tcl_FSSplitPath(Tcl_Obj* pathPtr, int *lenPtr)
+}
+declare 462 generic {
+ int Tcl_FSEqualPaths(Tcl_Obj* firstPtr, Tcl_Obj* secondPtr)
+}
+declare 463 generic {
+ Tcl_Obj* Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj* pathObjPtr)
+}
+declare 464 generic {
+ Tcl_Obj* Tcl_FSJoinToPath(Tcl_Obj *basePtr, int objc, Tcl_Obj *CONST objv[])
+}
+declare 465 generic {
+ ClientData Tcl_FSGetInternalRep(Tcl_Obj* pathObjPtr, Tcl_Filesystem *fsPtr)
+}
+declare 466 generic {
+ char* Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj* pathPtr)
+}
+declare 467 generic {
+ int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName)
+}
+declare 468 generic {
+ Tcl_Obj* Tcl_FSNewNativePath(Tcl_Obj* fromFilesystem, ClientData clientData)
+}
+declare 469 generic {
+ char* Tcl_FSGetNativePath(Tcl_Obj* pathObjPtr)
+}
+declare 470 generic {
+ Tcl_Obj* Tcl_FSFileSystemInfo(Tcl_Obj* pathObjPtr)
+}
+declare 471 generic {
+ Tcl_Obj* Tcl_FSPathSeparator(Tcl_Obj* pathObjPtr)
+}
+declare 472 generic {
+ int Tcl_FSListVolumes(Tcl_Interp *interp)
+}
+declare 473 generic {
+ int Tcl_FSRegister(ClientData clientData, Tcl_Filesystem *fsPtr)
+}
+declare 474 generic {
+ int Tcl_FSUnregister(Tcl_Filesystem *fsPtr)
+}
+declare 475 generic {
+ ClientData Tcl_FSData(Tcl_Filesystem *fsPtr)
+}
##############################################################################
diff --git a/generic/tcl.h b/generic/tcl.h
index 08ae9c3..6e3ab91 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tcl.h,v 1.93 2001/07/17 02:01:23 mdejong Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.94 2001/07/31 19:12:06 vincentdarley Exp $
*/
#ifndef _TCL
@@ -1474,6 +1474,304 @@ typedef enum Tcl_PathType {
TCL_PATH_VOLUME_RELATIVE
} Tcl_PathType;
+/*
+ * The following structure is used to pass glob type data amongst
+ * the various glob routines and Tcl_FSMatchInDirectory.
+ */
+typedef struct Tcl_GlobTypeData {
+ /* Corresponds to bcdpfls as in 'find -t' */
+ int type;
+ /* Corresponds to file permissions */
+ int perm;
+ /* Acceptable mac type */
+ Tcl_Obj* macType;
+ /* Acceptable mac creator */
+ Tcl_Obj* macCreator;
+} Tcl_GlobTypeData;
+
+/*
+ * type and permission definitions for glob command
+ */
+#define TCL_GLOB_TYPE_BLOCK (1<<0)
+#define TCL_GLOB_TYPE_CHAR (1<<1)
+#define TCL_GLOB_TYPE_DIR (1<<2)
+#define TCL_GLOB_TYPE_PIPE (1<<3)
+#define TCL_GLOB_TYPE_FILE (1<<4)
+#define TCL_GLOB_TYPE_LINK (1<<5)
+#define TCL_GLOB_TYPE_SOCK (1<<6)
+
+#define TCL_GLOB_PERM_RONLY (1<<0)
+#define TCL_GLOB_PERM_HIDDEN (1<<1)
+#define TCL_GLOB_PERM_R (1<<2)
+#define TCL_GLOB_PERM_W (1<<3)
+#define TCL_GLOB_PERM_X (1<<4)
+
+/*
+ * Typedefs for the various filesystem operations:
+ */
+
+typedef int (Tcl_FSStatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, struct stat *buf));
+typedef int (Tcl_FSAccessProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, int mode));
+typedef Tcl_Channel (Tcl_FSOpenFileChannelProc)
+ _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr,
+ char *modeString, int permissions));
+typedef int (Tcl_FSMatchInDirectoryProc) _ANSI_ARGS_((Tcl_Interp* interp,
+ Tcl_Obj *result, Tcl_Obj *pathPtr, char *pattern,
+ Tcl_GlobTypeData * types));
+typedef Tcl_Obj* (Tcl_FSGetCwdProc) _ANSI_ARGS_((Tcl_Interp *interp));
+typedef int (Tcl_FSChdirProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
+typedef int (Tcl_FSLstatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ struct stat *buf));
+typedef int (Tcl_FSCreateDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
+typedef int (Tcl_FSDeleteFileProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
+typedef int (Tcl_FSCopyDirectoryProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
+ Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr));
+typedef int (Tcl_FSCopyFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
+ Tcl_Obj *destPathPtr));
+typedef int (Tcl_FSRemoveDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ int recursive, Tcl_Obj **errorPtr));
+typedef int (Tcl_FSRenameFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
+ Tcl_Obj *destPathPtr));
+typedef void (Tcl_FSUnloadFileProc) _ANSI_ARGS_((ClientData clientData));
+typedef int (Tcl_FSListVolumesProc) _ANSI_ARGS_((Tcl_Interp *interp));
+/* We have to declare the utime structure here. */
+struct utimbuf;
+typedef int (Tcl_FSUtimeProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ struct utimbuf *tval));
+typedef int (Tcl_FSNormalizePathProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *pathPtr, int nextCheckpoint));
+typedef int (Tcl_FSFileAttrsGetProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ int index, Tcl_Obj *pathPtr,
+ Tcl_Obj **objPtrRef));
+typedef char** (Tcl_FSFileAttrStringsProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ Tcl_Obj** objPtrRef));
+typedef int (Tcl_FSFileAttrsSetProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ int index, Tcl_Obj *pathPtr,
+ Tcl_Obj *objPtr));
+typedef Tcl_Obj* (Tcl_FSReadlinkProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
+typedef int (Tcl_FSLoadFileProc) _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj *pathPtr, char * sym1, char * sym2,
+ Tcl_PackageInitProc ** proc1Ptr,
+ Tcl_PackageInitProc ** proc2Ptr,
+ ClientData * clientDataPtr));
+typedef int (Tcl_FSPathInFilesystemProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ ClientData *clientDataPtr));
+typedef Tcl_Obj* (Tcl_FSFilesystemPathTypeProc)
+ _ANSI_ARGS_((Tcl_Obj *pathPtr));
+typedef Tcl_Obj* (Tcl_FSFilesystemSeparatorProc)
+ _ANSI_ARGS_((Tcl_Obj *pathPtr));
+typedef void (Tcl_FSFreeInternalRepProc) _ANSI_ARGS_((ClientData clientData));
+typedef ClientData (Tcl_FSDupInternalRepProc)
+ _ANSI_ARGS_((ClientData clientData));
+typedef Tcl_Obj* (Tcl_FSInternalToNormalizedProc)
+ _ANSI_ARGS_((ClientData clientData));
+typedef ClientData (Tcl_FSCreateInternalRepProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
+
+typedef struct Tcl_FSVersion_ *Tcl_FSVersion;
+
+/*
+ *----------------------------------------------------------------
+ * Data structures related to hooking into the filesystem
+ *----------------------------------------------------------------
+ */
+
+/*
+ * Filesystem version tag. This was introduced in 8.4.
+ */
+
+#define TCL_FILESYSTEM_VERSION_1 ((Tcl_FSVersion) 0x1)
+
+/*
+ * struct Tcl_Filesystem:
+ *
+ * One such structure exists for each type (kind) of filesystem.
+ * It collects together in one place all the functions that are
+ * part of the specific filesystem. Tcl always accesses the
+ * filesystem through one of these structures.
+ *
+ * Not all entries need be non-NULL; any which are NULL are simply
+ * ignored. However, a complete filesystem should provide all of
+ * these functions. The explanations in the structure show
+ * the importance of each function.
+ */
+
+typedef struct Tcl_Filesystem {
+ CONST char *typeName; /* The name of the filesystem. */
+ int structureLength; /* Length of this structure, so future
+ * binary compatibility can be assured. */
+ Tcl_FSVersion version;
+ /* Version of the filesystem type. */
+ Tcl_FSPathInFilesystemProc *pathInFilesystemProc;
+ /* Function to check whether a path is in
+ * this filesystem. This is the most
+ * important filesystem procedure. */
+ Tcl_FSDupInternalRepProc *dupInternalRepProc;
+ /* Function to duplicate internal fs rep. May
+ * be NULL (but then fs is less efficient). */
+ Tcl_FSFreeInternalRepProc *freeInternalRepProc;
+ /* Function to free internal fs rep. Must
+ * be implemented, if internal representations
+ * need freeing, otherwise it can be NULL. */
+ Tcl_FSInternalToNormalizedProc *internalToNormalizedProc;
+ /* Function to convert internal representation
+ * to a normalized path. Only required if
+ * the fs creates pure path objects with no
+ * string/path representation. */
+ Tcl_FSCreateInternalRepProc *createInternalRepProc;
+ /* Function to create a filesystem-specific
+ * internal representation. May be NULL
+ * if paths have no internal representation,
+ * or if the Tcl_FSPathInFilesystemProc
+ * for this filesystem always immediately
+ * creates an internal representation for
+ * paths it accepts. */
+ Tcl_FSNormalizePathProc *normalizePathProc;
+ /* Function to normalize a path. Should
+ * be implemented for all filesystems
+ * which can have multiple string
+ * representations for the same path
+ * object. */
+ Tcl_FSFilesystemPathTypeProc *filesystemPathTypeProc;
+ /* Function to determine the type of a
+ * path in this filesystem. May be NULL. */
+ Tcl_FSFilesystemSeparatorProc *filesystemSeparatorProc;
+ /* Function to return the separator
+ * character(s) for this filesystem. Must
+ * be implemented. */
+ Tcl_FSStatProc *statProc;
+ /*
+ * Function to process a 'Tcl_FSStat()'
+ * call. Must be implemented for any
+ * reasonable filesystem.
+ */
+ Tcl_FSAccessProc *accessProc;
+ /*
+ * Function to process a 'Tcl_FSAccess()'
+ * call. Must be implemented for any
+ * reasonable filesystem.
+ */
+ Tcl_FSOpenFileChannelProc *openFileChannelProc;
+ /*
+ * Function to process a
+ * 'Tcl_FSOpenFileChannel()' call. Must be
+ * implemented for any reasonable
+ * filesystem.
+ */
+ Tcl_FSMatchInDirectoryProc *matchInDirectoryProc;
+ /* Function to process a
+ * 'Tcl_FSMatchInDirectory()'. If not
+ * implemented, then glob and recursive
+ * copy functionality will be lacking in
+ * the filesystem. */
+ Tcl_FSUtimeProc *utimeProc;
+ /* Function to process a
+ * 'Tcl_FSUtime()' call. Required to
+ * allow setting (not reading) of times
+ * with 'file mtime', 'file atime' and
+ * the open-r/open-w/fcopy implementation
+ * of 'file copy'. */
+ Tcl_FSReadlinkProc *readlinkProc;
+ /* Function to process a
+ * 'Tcl_FSReadlink()' call. Should be
+ * implemented only if the filesystem supports
+ * links. */
+ Tcl_FSListVolumesProc *listVolumesProc;
+ /* Function to list any filesystem volumes
+ * added by this filesystem. Should be
+ * implemented only if the filesystem adds
+ * volumes at the head of the filesystem. */
+ Tcl_FSFileAttrStringsProc *fileAttrStringsProc;
+ /* Function to list all attributes strings
+ * which are valid for this filesystem.
+ * If not implemented the filesystem will
+ * not support the 'file attributes' command.
+ * This allows arbitrary additional information
+ * to be attached to files in the filesystem. */
+ Tcl_FSFileAttrsGetProc *fileAttrsGetProc;
+ /* Function to process a
+ * 'Tcl_FSFileAttrsGet()' call, used by
+ * 'file attributes'. */
+ Tcl_FSFileAttrsSetProc *fileAttrsSetProc;
+ /* Function to process a
+ * 'Tcl_FSFileAttrsSet()' call, used by
+ * 'file attributes'. */
+ Tcl_FSCreateDirectoryProc *createDirectoryProc;
+ /* Function to process a
+ * 'Tcl_FSCreateDirectory()' call. Should
+ * be implemented unless the FS is
+ * read-only. */
+ Tcl_FSRemoveDirectoryProc *removeDirectoryProc;
+ /* Function to process a
+ * 'Tcl_FSRemoveDirectory()' call. Should
+ * be implemented unless the FS is
+ * read-only. */
+ Tcl_FSDeleteFileProc *deleteFileProc;
+ /* Function to process a
+ * 'Tcl_FSDeleteFile()' call. Should
+ * be implemented unless the FS is
+ * read-only. */
+ Tcl_FSLstatProc *lstatProc;
+ /* Function to process a
+ * 'Tcl_FSLstat()' call. If not implemented,
+ * Tcl will attempt to use the 'statProc'
+ * defined above instead. */
+ Tcl_FSCopyFileProc *copyFileProc;
+ /* Function to process a
+ * 'Tcl_FSCopyFile()' call. If not
+ * implemented Tcl will fall back
+ * on open-r, open-w and fcopy as
+ * a copying mechanism. */
+ Tcl_FSRenameFileProc *renameFileProc;
+ /* Function to process a
+ * 'Tcl_FSRenameFile()' call. If not
+ * implemented, Tcl will fall back on
+ * a copy and delete mechanism. */
+ Tcl_FSCopyDirectoryProc *copyDirectoryProc;
+ /* Function to process a
+ * 'Tcl_FSCopyDirectory()' call. If
+ * not implemented, Tcl will fall back
+ * on a recursive create-dir, file copy
+ * mechanism. */
+ Tcl_FSLoadFileProc *loadFileProc;
+ /* Function to process a
+ * 'Tcl_FSLoadFile()' call. If not
+ * implemented, Tcl will fall back on
+ * a copy to native-temp followed by a
+ * Tcl_FSLoadFile on that temporary copy. */
+ Tcl_FSUnloadFileProc *unloadFileProc;
+ /* Function to unload a previously
+ * successfully loaded file. If load was
+ * implemented, then this should also be
+ * implemented, if there is any cleanup
+ * action required. */
+ Tcl_FSGetCwdProc *getCwdProc;
+ /*
+ * Function to process a 'Tcl_FSGetCwd()'
+ * call. Most filesystems need not
+ * implement this. It will usually only be
+ * called once, if 'getcwd' is called
+ * before 'chdir'. May be NULL.
+ */
+ Tcl_FSChdirProc *chdirProc;
+ /*
+ * Function to process a 'Tcl_FSChdir()'
+ * call. If filesystems do not implement
+ * this, it will be emulated by a series of
+ * directory access checks. Otherwise,
+ * virtual filesystems which do implement
+ * it need only respond with a positive
+ * return result if the dirName is a valid
+ * directory in their filesystem. They
+ * need not remember the result, since that
+ * will be automatically remembered for use
+ * by GetCwd. Real filesystems should
+ * carry out the correct action (i.e. call
+ * the correct system 'chdir' api). If not
+ * implemented, then 'cd' and 'pwd' will
+ * fail inside the filesystem.
+ */
+} Tcl_Filesystem;
+
/*
* The following structure represents the Notifier functions that
* you can override with the Tcl_SetNotifier call.
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index c928224..5866ac4 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -11,15 +11,13 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdAH.c,v 1.12 2000/01/21 02:25:26 hobbs Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.13 2001/07/31 19:12:06 vincentdarley Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
#include <locale.h>
-typedef int (StatProc)_ANSI_ARGS_((CONST char *path, struct stat *buf));
-
/*
* Prototypes for local procedures defined in this file:
*/
@@ -27,15 +25,13 @@ typedef int (StatProc)_ANSI_ARGS_((CONST char *path, struct stat *buf));
static int CheckAccess _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, int mode));
static int GetStatBuf _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *objPtr, StatProc *statProc,
+ Tcl_Obj *objPtr, Tcl_FSStatProc *statProc,
struct stat *statPtr));
static char * GetTypeFromMode _ANSI_ARGS_((int mode));
static int SplitPath _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, int *argcPtr, char ***argvPtr));
static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,
char *varName, struct stat *statPtr));
-static char ** StringifyObjects _ANSI_ARGS_((int objc,
- Tcl_Obj *CONST objv[]));
/*
*----------------------------------------------------------------------
@@ -307,8 +303,7 @@ Tcl_CdObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- char *dirName;
- Tcl_DString ds;
+ Tcl_Obj *dir;
int result;
if (objc > 2) {
@@ -317,23 +312,25 @@ Tcl_CdObjCmd(dummy, interp, objc, objv)
}
if (objc == 2) {
- dirName = Tcl_GetString(objv[1]);
+ dir = objv[1];
} else {
- dirName = "~";
+ dir = Tcl_NewStringObj("~",1);
+ Tcl_IncrRefCount(dir);
}
- if (Tcl_TranslateFileName(interp, dirName, &ds) == NULL) {
- return TCL_ERROR;
+ if (Tcl_FSConvertToPathType(interp, dir) != TCL_OK) {
+ result = TCL_ERROR;
+ } else {
+ result = Tcl_FSChdir(dir);
+ if (result != TCL_OK) {
+ Tcl_AppendResult(interp, "couldn't change working directory to \"",
+ Tcl_GetString(dir), "\": ", Tcl_PosixError(interp), (char *) NULL);
+ result = TCL_ERROR;
+ }
}
-
- result = Tcl_Chdir(Tcl_DStringValue(&ds));
- Tcl_DStringFree(&ds);
-
- if (result != 0) {
- Tcl_AppendResult(interp, "couldn't change working directory to \"",
- dirName, "\": ", Tcl_PosixError(interp), (char *) NULL);
- return TCL_ERROR;
+ if (objc != 2) {
+ Tcl_DecrRefCount(dir);
}
- return TCL_OK;
+ return result;
}
/*
@@ -765,7 +762,9 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv)
* See the user documentation for details on what it does.
* PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH
* EMBEDDED NULLS, WHICH COULD THEORETICALLY HAPPEN ON A MAC.
- *
+ * With the object-based Tcl_FS APIs, the above NOTE may no
+ * longer be true. In any case this assertion should be tested.
+ *
* Results:
* A standard Tcl result.
*
@@ -795,9 +794,11 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
"delete",
"dirname", "executable", "exists", "extension",
"isdirectory", "isfile", "join", "lstat",
- "mtime", "mkdir", "nativename", "owned",
+ "mtime", "mkdir", "nativename",
+ "normalize", "owned",
"pathtype", "readable", "readlink", "rename",
- "rootname", "size", "split", "stat",
+ "rootname", "separator", "size", "split",
+ "stat", "system",
"tail", "type", "volumes", "writable",
(char *) NULL
};
@@ -806,9 +807,11 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
FILE_DELETE,
FILE_DIRNAME, FILE_EXECUTABLE, FILE_EXISTS, FILE_EXTENSION,
FILE_ISDIRECTORY, FILE_ISFILE, FILE_JOIN, FILE_LSTAT,
- FILE_MTIME, FILE_MKDIR, FILE_NATIVENAME, FILE_OWNED,
+ FILE_MTIME, FILE_MKDIR, FILE_NATIVENAME,
+ FILE_NORMALIZE, FILE_OWNED,
FILE_PATHTYPE, FILE_READABLE, FILE_READLINK, FILE_RENAME,
- FILE_ROOTNAME, FILE_SIZE, FILE_SPLIT, FILE_STAT,
+ FILE_ROOTNAME, FILE_SEPARATOR, FILE_SIZE, FILE_SPLIT,
+ FILE_STAT, FILE_SYSTEM,
FILE_TAIL, FILE_TYPE, FILE_VOLUMES, FILE_WRITABLE
};
@@ -825,14 +828,13 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
switch ((enum options) index) {
case FILE_ATIME: {
struct stat buf;
- char *fileName;
struct utimbuf tval;
if ((objc < 3) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
return TCL_ERROR;
}
- if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {
+ if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
if (objc == 4) {
@@ -842,11 +844,10 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
}
tval.actime = buf.st_atime;
tval.modtime = buf.st_mtime;
- fileName = Tcl_GetString(objv[2]);
- if (utime(fileName, &tval) != 0) {
+ if (Tcl_FSUtime(objv[2], &tval) != 0) {
Tcl_AppendStringsToObj(resultPtr,
"could not set access time for file \"",
- fileName, "\": ",
+ Tcl_GetString(objv[2]), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
@@ -856,7 +857,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
* one we sent in. However, fs's like FAT don't
* even know what atime is.
*/
- if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {
+ if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
}
@@ -875,26 +876,14 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
((objc == 2) ? NULL : Tcl_GetString(objv[2])));
}
case FILE_COPY: {
- int result;
- char **argv;
-
- argv = StringifyObjects(objc, objv);
- result = TclFileCopyCmd(interp, objc, argv);
- ckfree((char *) argv);
- return result;
+ return TclFileCopyCmd(interp, objc, objv);
}
case FILE_DELETE: {
- int result;
- char **argv;
-
- argv = StringifyObjects(objc, objv);
- result = TclFileDeleteCmd(interp, objc, argv);
- ckfree((char *) argv);
- return result;
+ return TclFileDeleteCmd(interp, objc, objv);
}
case FILE_DIRNAME: {
int argc;
- char **argv;
+ char ** argv;
if (objc != 3) {
goto only3Args;
@@ -959,7 +948,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
goto only3Args;
}
value = 0;
- if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) {
+ if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
value = S_ISDIR(buf.st_mode);
}
Tcl_SetBooleanObj(resultPtr, value);
@@ -973,27 +962,21 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
goto only3Args;
}
value = 0;
- if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) {
+ if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
value = S_ISREG(buf.st_mode);
}
Tcl_SetBooleanObj(resultPtr, value);
return TCL_OK;
}
case FILE_JOIN: {
- char **argv;
- Tcl_DString ds;
+ Tcl_Obj *resObj;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
return TCL_ERROR;
}
- argv = StringifyObjects(objc - 2, objv + 2);
- Tcl_DStringInit(&ds);
- Tcl_JoinPath(objc - 2, argv, &ds);
- Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds),
- Tcl_DStringLength(&ds));
- Tcl_DStringFree(&ds);
- ckfree((char *) argv);
+ resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2);
+ Tcl_SetObjResult(interp, resObj);
return TCL_OK;
}
case FILE_LSTAT: {
@@ -1004,7 +987,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
Tcl_WrongNumArgs(interp, 2, objv, "name varName");
return TCL_ERROR;
}
- if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) {
+ if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
return TCL_ERROR;
}
varName = Tcl_GetString(objv[3]);
@@ -1012,14 +995,13 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
}
case FILE_MTIME: {
struct stat buf;
- char *fileName;
struct utimbuf tval;
if ((objc < 3) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
return TCL_ERROR;
}
- if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {
+ if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
if (objc == 4) {
@@ -1029,11 +1011,10 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
}
tval.actime = buf.st_atime;
tval.modtime = buf.st_mtime;
- fileName = Tcl_GetString(objv[2]);
- if (utime(fileName, &tval) != 0) {
+ if (Tcl_FSUtime(objv[2], &tval) != 0) {
Tcl_AppendStringsToObj(resultPtr,
"could not set modification time for file \"",
- fileName, "\": ",
+ Tcl_GetString(objv[2]), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
@@ -1043,7 +1024,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
* one we sent in. However, fs's like FAT don't
* even know what atime is.
*/
- if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {
+ if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
}
@@ -1051,17 +1032,11 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
return TCL_OK;
}
case FILE_MKDIR: {
- char **argv;
- int result;
-
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
return TCL_ERROR;
}
- argv = StringifyObjects(objc, objv);
- result = TclFileMakeDirsCmd(interp, objc, argv);
- ckfree((char *) argv);
- return result;
+ return TclFileMakeDirsCmd(interp, objc, objv);
}
case FILE_NATIVENAME: {
char *fileName;
@@ -1079,6 +1054,18 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
Tcl_DStringFree(&ds);
return TCL_OK;
}
+ case FILE_NORMALIZE: {
+ Tcl_Obj *fileName;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "filename");
+ return TCL_ERROR;
+ }
+
+ fileName = Tcl_FSGetNormalizedPath(interp, objv[2]);
+ Tcl_SetObjResult(interp, fileName);
+ return TCL_OK;
+ }
case FILE_OWNED: {
int value;
struct stat buf;
@@ -1087,7 +1074,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
goto only3Args;
}
value = 0;
- if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) {
+ if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
/*
* For Windows and Macintosh, there are no user ids
* associated with a file, so we always return 1.
@@ -1129,52 +1116,30 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
return CheckAccess(interp, objv[2], R_OK);
}
case FILE_READLINK: {
- char *fileName, *contents;
- Tcl_DString name, link;
+ Tcl_Obj *contents;
if (objc != 3) {
goto only3Args;
}
- fileName = Tcl_GetString(objv[2]);
- fileName = Tcl_TranslateFileName(interp, fileName, &name);
- if (fileName == NULL) {
+ if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) {
return TCL_ERROR;
}
- /*
- * 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
- contents = NULL;
- errno = EINVAL;
-#else
- contents = TclpReadlink(fileName, &link);
-#endif /* S_IFLNK */
+ contents = Tcl_FSReadlink(objv[2]);
- Tcl_DStringFree(&name);
if (contents == NULL) {
Tcl_AppendResult(interp, "could not readlink \"",
Tcl_GetString(objv[2]), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
- Tcl_DStringResult(interp, &link);
+ Tcl_SetObjResult(interp, contents);
+ Tcl_DecrRefCount(contents);
return TCL_OK;
}
case FILE_RENAME: {
- int result;
- char **argv;
-
- argv = StringifyObjects(objc, objv);
- result = TclFileRenameCmd(interp, objc, argv);
- ckfree((char *) argv);
- return result;
+ return TclFileRenameCmd(interp, objc, objv);
}
case FILE_ROOTNAME: {
int length;
@@ -1193,34 +1158,54 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
}
return TCL_OK;
}
+ case FILE_SEPARATOR: {
+ if ((objc < 2) || (objc > 3)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?name?");
+ return TCL_ERROR;
+ }
+ if (objc == 2) {
+ char *separator = NULL; /* lint */
+ switch (tclPlatform) {
+ case TCL_PLATFORM_UNIX:
+ separator = "/";
+ break;
+ case TCL_PLATFORM_WINDOWS:
+ separator = "\\";
+ break;
+ case TCL_PLATFORM_MAC:
+ separator = ":";
+ break;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(separator,1));
+ } else {
+ Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]);
+ if (separatorObj != NULL) {
+ Tcl_SetObjResult(interp, separatorObj);
+ } else {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("Unrecognised path",-1));
+ return TCL_ERROR;
+ }
+ }
+ return TCL_OK;
+ }
case FILE_SIZE: {
struct stat buf;
if (objc != 3) {
goto only3Args;
}
- if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {
+ if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetLongObj(resultPtr, (long) buf.st_size);
return TCL_OK;
}
case FILE_SPLIT: {
- int i, argc;
- char **argv;
- char *fileName;
- Tcl_Obj *objPtr;
-
if (objc != 3) {
goto only3Args;
}
- fileName = Tcl_GetString(objv[2]);
- Tcl_SplitPath(fileName, &argc, &argv);
- for (i = 0; i < argc; i++) {
- objPtr = Tcl_NewStringObj(argv[i], -1);
- Tcl_ListObjAppendElement(NULL, resultPtr, objPtr);
- }
- ckfree((char *) argv);
+ Tcl_SetObjResult(interp, Tcl_FSSplitPath(objv[2], NULL));
return TCL_OK;
}
case FILE_STAT: {
@@ -1231,12 +1216,27 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
Tcl_WrongNumArgs(interp, 1, objv, "stat name varName");
return TCL_ERROR;
}
- if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {
+ if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
varName = Tcl_GetString(objv[3]);
return StoreStatData(interp, varName, &buf);
}
+ case FILE_SYSTEM: {
+ Tcl_Obj* fsInfo;
+ if (objc != 3) {
+ goto only3Args;
+ }
+ fsInfo = Tcl_FSFileSystemInfo(objv[2]);
+ if (fsInfo != NULL) {
+ Tcl_SetObjResult(interp, fsInfo);
+ return TCL_OK;
+ } else {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("Unrecognised path",-1));
+ return TCL_ERROR;
+ }
+ }
case FILE_TAIL: {
int argc;
char **argv;
@@ -1268,7 +1268,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
if (objc != 3) {
goto only3Args;
}
- if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) {
+ if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetStringObj(resultPtr,
@@ -1280,7 +1280,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
- return TclpListVolumes(interp);
+ return Tcl_FSListVolumes(interp);
}
case FILE_WRITABLE: {
if (objc != 3) {
@@ -1379,16 +1379,11 @@ CheckAccess(interp, objPtr, mode)
* access(). */
{
int value;
- char *fileName;
- Tcl_DString ds;
- fileName = Tcl_GetString(objPtr);
- fileName = Tcl_TranslateFileName(interp, fileName, &ds);
- if (fileName == NULL) {
+ if (Tcl_FSConvertToPathType(interp, objPtr) != TCL_OK) {
value = 0;
} else {
- value = (TclAccess(fileName, mode) == 0);
- Tcl_DStringFree(&ds);
+ value = (Tcl_FSAccess(objPtr, mode) == 0);
}
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
@@ -1419,23 +1414,18 @@ static int
GetStatBuf(interp, objPtr, statProc, statPtr)
Tcl_Interp *interp; /* Interp for error return. May be NULL. */
Tcl_Obj *objPtr; /* Path name to examine. */
- StatProc *statProc; /* Either stat() or lstat() depending on
+ Tcl_FSStatProc *statProc; /* Either stat() or lstat() depending on
* desired behavior. */
struct stat *statPtr; /* Filled with info about file obtained by
* calling (*statProc)(). */
{
- char *fileName;
- Tcl_DString ds;
int status;
- fileName = Tcl_GetString(objPtr);
- fileName = Tcl_TranslateFileName(interp, fileName, &ds);
- if (fileName == NULL) {
+ if (Tcl_FSConvertToPathType(interp, objPtr) != TCL_OK) {
return TCL_ERROR;
}
- status = (*statProc)(Tcl_DStringValue(&ds), statPtr);
- Tcl_DStringFree(&ds);
+ status = (*statProc)(objPtr, statPtr);
if (status < 0) {
if (interp != NULL) {
@@ -2345,43 +2335,3 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
Tcl_DecrRefCount(resultPtr);
return TCL_ERROR;
}
-
-/*
- *---------------------------------------------------------------------------
- *
- * StringifyObjects --
- *
- * Helper function to bridge the gap between an object-based procedure
- * and an older string-based procedure.
- *
- * Given an array of objects, allocate an array that consists of the
- * string representations of those objects.
- *
- * Results:
- * The return value is a pointer to the newly allocated array of
- * strings. Elements 0 to (objc-1) of the string array point to the
- * string representation of the corresponding element in the source
- * object array; element objc of the string array is NULL.
- *
- * Side effects:
- * Memory allocated. The caller must eventually free this memory
- * by calling ckfree() on the return value.
- *
- *---------------------------------------------------------------------------
- */
-
-static char **
-StringifyObjects(objc, objv)
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
-{
- int i;
- char **argv;
-
- argv = (char **) ckalloc((objc + 1) * sizeof(char *));
- for (i = 0; i < objc; i++) {
- argv[i] = Tcl_GetString(objv[i]);
- }
- argv[i] = NULL;
- return argv;
-}
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 3ba2a34..9cea6a7 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdIL.c,v 1.32 2001/06/28 00:42:55 hobbs Exp $
+ * RCS: @(#) $Id: tclCmdIL.c,v 1.33 2001/07/31 19:12:06 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -1663,17 +1663,14 @@ InfoScriptCmd(dummy, interp, objc, objv)
}
if (objc == 3) {
- int length;
- char *filename = Tcl_GetStringFromObj(objv[2], &length);
-
if (iPtr->scriptFile != NULL) {
- ckfree(iPtr->scriptFile);
+ Tcl_DecrRefCount(iPtr->scriptFile);
}
- iPtr->scriptFile = ckalloc((unsigned) (length + 1));
- strcpy(iPtr->scriptFile, filename);
+ iPtr->scriptFile = objv[2];
+ Tcl_IncrRefCount(iPtr->scriptFile);
}
if (iPtr->scriptFile != NULL) {
- Tcl_SetStringObj(Tcl_GetObjResult(interp), iPtr->scriptFile, -1);
+ Tcl_SetObjResult(interp, iPtr->scriptFile);
}
return TCL_OK;
}
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 49708d7..b70c7d8 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdMZ.c,v 1.41 2001/07/16 18:35:50 hobbs Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.42 2001/07/31 19:12:06 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -102,17 +102,19 @@ Tcl_PwdObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- Tcl_DString ds;
+ Tcl_Obj *retVal;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
- if (Tcl_GetCwd(interp, &ds) == NULL) {
+ retVal = Tcl_FSGetCwd(interp);
+ if (retVal == NULL) {
return TCL_ERROR;
}
- Tcl_DStringResult(interp, &ds);
+ Tcl_SetObjResult(interp, retVal);
+ Tcl_DecrRefCount(retVal);
return TCL_OK;
}
@@ -863,17 +865,12 @@ Tcl_SourceObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- char *bytes;
- int result;
-
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "fileName");
return TCL_ERROR;
}
- bytes = Tcl_GetString(objv[1]);
- result = Tcl_EvalFile(interp, bytes);
- return result;
+ return Tcl_FSEvalFile(interp, objv[1]);
}
/*
diff --git a/generic/tclDate.c b/generic/tclDate.c
index 9874075..29f9037 100644
--- a/generic/tclDate.c
+++ b/generic/tclDate.c
@@ -10,13 +10,13 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclDate.c,v 1.18 2000/05/18 22:29:56 ericm Exp $
+ * RCS: @(#) $Id: tclDate.c,v 1.19 2001/07/31 19:12:06 vincentdarley Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
-#ifdef MAC_TCL
+#if defined(MAC_TCL) && !defined(TCL_MAC_USE_MSL_EPOCH)
# define EPOCH 1904
# define START_OF_TIME 1904
# define END_OF_TIME 2039
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 2e94d6a..2a0da68 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclDecls.h,v 1.52 2001/07/12 13:15:09 dkf Exp $
+ * RCS: @(#) $Id: tclDecls.h,v 1.53 2001/07/31 19:12:06 vincentdarley Exp $
*/
#ifndef _TCLDECLS
@@ -1371,6 +1371,121 @@ EXTERN Tcl_Obj * Tcl_ListMathFuncs _ANSI_ARGS_((Tcl_Interp * interp,
/* 437 */
EXTERN Tcl_Obj * Tcl_SubstObj _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * objPtr, int flags));
+/* 438 */
+EXTERN int Tcl_DetachChannel _ANSI_ARGS_((Tcl_Interp* interp,
+ Tcl_Channel channel));
+/* 439 */
+EXTERN int Tcl_IsStandardChannel _ANSI_ARGS_((
+ Tcl_Channel channel));
+/* 440 */
+EXTERN int Tcl_FSCopyFile _ANSI_ARGS_((Tcl_Obj * srcPathPtr,
+ Tcl_Obj * destPathPtr));
+/* 441 */
+EXTERN int Tcl_FSCopyDirectory _ANSI_ARGS_((
+ Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr,
+ Tcl_Obj ** errorPtr));
+/* 442 */
+EXTERN int Tcl_FSCreateDirectory _ANSI_ARGS_((Tcl_Obj * pathPtr));
+/* 443 */
+EXTERN int Tcl_FSDeleteFile _ANSI_ARGS_((Tcl_Obj * pathPtr));
+/* 444 */
+EXTERN int Tcl_FSLoadFile _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * pathPtr, char * sym1, char * sym2,
+ Tcl_PackageInitProc ** proc1Ptr,
+ Tcl_PackageInitProc ** proc2Ptr,
+ ClientData * clientDataPtr,
+ Tcl_FSUnloadFileProc ** unloadProcPtr));
+/* 445 */
+EXTERN int Tcl_FSMatchInDirectory _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * result,
+ Tcl_Obj * pathPtr, char * pattern,
+ Tcl_GlobTypeData * types));
+/* 446 */
+EXTERN Tcl_Obj* Tcl_FSReadlink _ANSI_ARGS_((Tcl_Obj * pathPtr));
+/* 447 */
+EXTERN int Tcl_FSRemoveDirectory _ANSI_ARGS_((Tcl_Obj * pathPtr,
+ int recursive, Tcl_Obj ** errorPtr));
+/* 448 */
+EXTERN int Tcl_FSRenameFile _ANSI_ARGS_((Tcl_Obj * srcPathPtr,
+ Tcl_Obj * destPathPtr));
+/* 449 */
+EXTERN int Tcl_FSLstat _ANSI_ARGS_((Tcl_Obj * pathPtr,
+ struct stat * buf));
+/* 450 */
+EXTERN int Tcl_FSUtime _ANSI_ARGS_((Tcl_Obj * pathPtr,
+ struct utimbuf * tval));
+/* 451 */
+EXTERN int Tcl_FSFileAttrsGet _ANSI_ARGS_((Tcl_Interp * interp,
+ int index, Tcl_Obj * pathPtr,
+ Tcl_Obj ** objPtrRef));
+/* 452 */
+EXTERN int Tcl_FSFileAttrsSet _ANSI_ARGS_((Tcl_Interp * interp,
+ int index, Tcl_Obj * pathPtr,
+ Tcl_Obj * objPtr));
+/* 453 */
+EXTERN char** Tcl_FSFileAttrStrings _ANSI_ARGS_((Tcl_Obj * pathPtr,
+ Tcl_Obj ** objPtrRef));
+/* 454 */
+EXTERN int Tcl_FSStat _ANSI_ARGS_((Tcl_Obj * pathPtr,
+ struct stat * buf));
+/* 455 */
+EXTERN int Tcl_FSAccess _ANSI_ARGS_((Tcl_Obj * pathPtr,
+ int mode));
+/* 456 */
+EXTERN Tcl_Channel Tcl_FSOpenFileChannel _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * pathPtr,
+ char * modeString, int permissions));
+/* 457 */
+EXTERN Tcl_Obj* Tcl_FSGetCwd _ANSI_ARGS_((Tcl_Interp * interp));
+/* 458 */
+EXTERN int Tcl_FSChdir _ANSI_ARGS_((Tcl_Obj * pathPtr));
+/* 459 */
+EXTERN int Tcl_FSConvertToPathType _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * pathPtr));
+/* 460 */
+EXTERN Tcl_Obj* Tcl_FSJoinPath _ANSI_ARGS_((Tcl_Obj * listObj,
+ int elements));
+/* 461 */
+EXTERN Tcl_Obj* Tcl_FSSplitPath _ANSI_ARGS_((Tcl_Obj* pathPtr,
+ int * lenPtr));
+/* 462 */
+EXTERN int Tcl_FSEqualPaths _ANSI_ARGS_((Tcl_Obj* firstPtr,
+ Tcl_Obj* secondPtr));
+/* 463 */
+EXTERN Tcl_Obj* Tcl_FSGetNormalizedPath _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj* pathObjPtr));
+/* 464 */
+EXTERN Tcl_Obj* Tcl_FSJoinToPath _ANSI_ARGS_((Tcl_Obj * basePtr,
+ int objc, Tcl_Obj *CONST objv[]));
+/* 465 */
+EXTERN ClientData Tcl_FSGetInternalRep _ANSI_ARGS_((
+ Tcl_Obj* pathObjPtr, Tcl_Filesystem * fsPtr));
+/* 466 */
+EXTERN char* Tcl_FSGetTranslatedPath _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj* pathPtr));
+/* 467 */
+EXTERN int Tcl_FSEvalFile _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * fileName));
+/* 468 */
+EXTERN Tcl_Obj* Tcl_FSNewNativePath _ANSI_ARGS_((
+ Tcl_Obj* fromFilesystem,
+ ClientData clientData));
+/* 469 */
+EXTERN char* Tcl_FSGetNativePath _ANSI_ARGS_((Tcl_Obj* pathObjPtr));
+/* 470 */
+EXTERN Tcl_Obj* Tcl_FSFileSystemInfo _ANSI_ARGS_((
+ Tcl_Obj* pathObjPtr));
+/* 471 */
+EXTERN Tcl_Obj* Tcl_FSPathSeparator _ANSI_ARGS_((Tcl_Obj* pathObjPtr));
+/* 472 */
+EXTERN int Tcl_FSListVolumes _ANSI_ARGS_((Tcl_Interp * interp));
+/* 473 */
+EXTERN int Tcl_FSRegister _ANSI_ARGS_((ClientData clientData,
+ Tcl_Filesystem * fsPtr));
+/* 474 */
+EXTERN int Tcl_FSUnregister _ANSI_ARGS_((Tcl_Filesystem * fsPtr));
+/* 475 */
+EXTERN ClientData Tcl_FSData _ANSI_ARGS_((Tcl_Filesystem * fsPtr));
typedef struct TclStubHooks {
struct TclPlatStubs *tclPlatStubs;
@@ -1868,6 +1983,44 @@ typedef struct TclStubs {
int (*tcl_GetMathFuncInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, int * numArgsPtr, Tcl_ValueType ** argTypesPtr, Tcl_MathProc ** procPtr, ClientData * clientDataPtr)); /* 435 */
Tcl_Obj * (*tcl_ListMathFuncs) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pattern)); /* 436 */
Tcl_Obj * (*tcl_SubstObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int flags)); /* 437 */
+ int (*tcl_DetachChannel) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Channel channel)); /* 438 */
+ int (*tcl_IsStandardChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 439 */
+ int (*tcl_FSCopyFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 440 */
+ int (*tcl_FSCopyDirectory) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr, Tcl_Obj ** errorPtr)); /* 441 */
+ int (*tcl_FSCreateDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 442 */
+ int (*tcl_FSDeleteFile) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 443 */
+ int (*tcl_FSLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, char * sym1, char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, ClientData * clientDataPtr, Tcl_FSUnloadFileProc ** unloadProcPtr)); /* 444 */
+ int (*tcl_FSMatchInDirectory) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * result, Tcl_Obj * pathPtr, char * pattern, Tcl_GlobTypeData * types)); /* 445 */
+ Tcl_Obj* (*tcl_FSReadlink) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 446 */
+ int (*tcl_FSRemoveDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr, int recursive, Tcl_Obj ** errorPtr)); /* 447 */
+ int (*tcl_FSRenameFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 448 */
+ int (*tcl_FSLstat) _ANSI_ARGS_((Tcl_Obj * pathPtr, struct stat * buf)); /* 449 */
+ int (*tcl_FSUtime) _ANSI_ARGS_((Tcl_Obj * pathPtr, struct utimbuf * tval)); /* 450 */
+ int (*tcl_FSFileAttrsGet) _ANSI_ARGS_((Tcl_Interp * interp, int index, Tcl_Obj * pathPtr, Tcl_Obj ** objPtrRef)); /* 451 */
+ int (*tcl_FSFileAttrsSet) _ANSI_ARGS_((Tcl_Interp * interp, int index, Tcl_Obj * pathPtr, Tcl_Obj * objPtr)); /* 452 */
+ char** (*tcl_FSFileAttrStrings) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj ** objPtrRef)); /* 453 */
+ int (*tcl_FSStat) _ANSI_ARGS_((Tcl_Obj * pathPtr, struct stat * buf)); /* 454 */
+ int (*tcl_FSAccess) _ANSI_ARGS_((Tcl_Obj * pathPtr, int mode)); /* 455 */
+ Tcl_Channel (*tcl_FSOpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, char * modeString, int permissions)); /* 456 */
+ Tcl_Obj* (*tcl_FSGetCwd) _ANSI_ARGS_((Tcl_Interp * interp)); /* 457 */
+ int (*tcl_FSChdir) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 458 */
+ int (*tcl_FSConvertToPathType) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr)); /* 459 */
+ Tcl_Obj* (*tcl_FSJoinPath) _ANSI_ARGS_((Tcl_Obj * listObj, int elements)); /* 460 */
+ Tcl_Obj* (*tcl_FSSplitPath) _ANSI_ARGS_((Tcl_Obj* pathPtr, int * lenPtr)); /* 461 */
+ int (*tcl_FSEqualPaths) _ANSI_ARGS_((Tcl_Obj* firstPtr, Tcl_Obj* secondPtr)); /* 462 */
+ Tcl_Obj* (*tcl_FSGetNormalizedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathObjPtr)); /* 463 */
+ Tcl_Obj* (*tcl_FSJoinToPath) _ANSI_ARGS_((Tcl_Obj * basePtr, int objc, Tcl_Obj *CONST objv[])); /* 464 */
+ ClientData (*tcl_FSGetInternalRep) _ANSI_ARGS_((Tcl_Obj* pathObjPtr, Tcl_Filesystem * fsPtr)); /* 465 */
+ char* (*tcl_FSGetTranslatedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 466 */
+ int (*tcl_FSEvalFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * fileName)); /* 467 */
+ Tcl_Obj* (*tcl_FSNewNativePath) _ANSI_ARGS_((Tcl_Obj* fromFilesystem, ClientData clientData)); /* 468 */
+ char* (*tcl_FSGetNativePath) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 469 */
+ Tcl_Obj* (*tcl_FSFileSystemInfo) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 470 */
+ Tcl_Obj* (*tcl_FSPathSeparator) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 471 */
+ int (*tcl_FSListVolumes) _ANSI_ARGS_((Tcl_Interp * interp)); /* 472 */
+ int (*tcl_FSRegister) _ANSI_ARGS_((ClientData clientData, Tcl_Filesystem * fsPtr)); /* 473 */
+ int (*tcl_FSUnregister) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 474 */
+ ClientData (*tcl_FSData) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 475 */
} TclStubs;
#ifdef __cplusplus
@@ -3660,6 +3813,158 @@ extern TclStubs *tclStubsPtr;
#define Tcl_SubstObj \
(tclStubsPtr->tcl_SubstObj) /* 437 */
#endif
+#ifndef Tcl_DetachChannel
+#define Tcl_DetachChannel \
+ (tclStubsPtr->tcl_DetachChannel) /* 438 */
+#endif
+#ifndef Tcl_IsStandardChannel
+#define Tcl_IsStandardChannel \
+ (tclStubsPtr->tcl_IsStandardChannel) /* 439 */
+#endif
+#ifndef Tcl_FSCopyFile
+#define Tcl_FSCopyFile \
+ (tclStubsPtr->tcl_FSCopyFile) /* 440 */
+#endif
+#ifndef Tcl_FSCopyDirectory
+#define Tcl_FSCopyDirectory \
+ (tclStubsPtr->tcl_FSCopyDirectory) /* 441 */
+#endif
+#ifndef Tcl_FSCreateDirectory
+#define Tcl_FSCreateDirectory \
+ (tclStubsPtr->tcl_FSCreateDirectory) /* 442 */
+#endif
+#ifndef Tcl_FSDeleteFile
+#define Tcl_FSDeleteFile \
+ (tclStubsPtr->tcl_FSDeleteFile) /* 443 */
+#endif
+#ifndef Tcl_FSLoadFile
+#define Tcl_FSLoadFile \
+ (tclStubsPtr->tcl_FSLoadFile) /* 444 */
+#endif
+#ifndef Tcl_FSMatchInDirectory
+#define Tcl_FSMatchInDirectory \
+ (tclStubsPtr->tcl_FSMatchInDirectory) /* 445 */
+#endif
+#ifndef Tcl_FSReadlink
+#define Tcl_FSReadlink \
+ (tclStubsPtr->tcl_FSReadlink) /* 446 */
+#endif
+#ifndef Tcl_FSRemoveDirectory
+#define Tcl_FSRemoveDirectory \
+ (tclStubsPtr->tcl_FSRemoveDirectory) /* 447 */
+#endif
+#ifndef Tcl_FSRenameFile
+#define Tcl_FSRenameFile \
+ (tclStubsPtr->tcl_FSRenameFile) /* 448 */
+#endif
+#ifndef Tcl_FSLstat
+#define Tcl_FSLstat \
+ (tclStubsPtr->tcl_FSLstat) /* 449 */
+#endif
+#ifndef Tcl_FSUtime
+#define Tcl_FSUtime \
+ (tclStubsPtr->tcl_FSUtime) /* 450 */
+#endif
+#ifndef Tcl_FSFileAttrsGet
+#define Tcl_FSFileAttrsGet \
+ (tclStubsPtr->tcl_FSFileAttrsGet) /* 451 */
+#endif
+#ifndef Tcl_FSFileAttrsSet
+#define Tcl_FSFileAttrsSet \
+ (tclStubsPtr->tcl_FSFileAttrsSet) /* 452 */
+#endif
+#ifndef Tcl_FSFileAttrStrings
+#define Tcl_FSFileAttrStrings \
+ (tclStubsPtr->tcl_FSFileAttrStrings) /* 453 */
+#endif
+#ifndef Tcl_FSStat
+#define Tcl_FSStat \
+ (tclStubsPtr->tcl_FSStat) /* 454 */
+#endif
+#ifndef Tcl_FSAccess
+#define Tcl_FSAccess \
+ (tclStubsPtr->tcl_FSAccess) /* 455 */
+#endif
+#ifndef Tcl_FSOpenFileChannel
+#define Tcl_FSOpenFileChannel \
+ (tclStubsPtr->tcl_FSOpenFileChannel) /* 456 */
+#endif
+#ifndef Tcl_FSGetCwd
+#define Tcl_FSGetCwd \
+ (tclStubsPtr->tcl_FSGetCwd) /* 457 */
+#endif
+#ifndef Tcl_FSChdir
+#define Tcl_FSChdir \
+ (tclStubsPtr->tcl_FSChdir) /* 458 */
+#endif
+#ifndef Tcl_FSConvertToPathType
+#define Tcl_FSConvertToPathType \
+ (tclStubsPtr->tcl_FSConvertToPathType) /* 459 */
+#endif
+#ifndef Tcl_FSJoinPath
+#define Tcl_FSJoinPath \
+ (tclStubsPtr->tcl_FSJoinPath) /* 460 */
+#endif
+#ifndef Tcl_FSSplitPath
+#define Tcl_FSSplitPath \
+ (tclStubsPtr->tcl_FSSplitPath) /* 461 */
+#endif
+#ifndef Tcl_FSEqualPaths
+#define Tcl_FSEqualPaths \
+ (tclStubsPtr->tcl_FSEqualPaths) /* 462 */
+#endif
+#ifndef Tcl_FSGetNormalizedPath
+#define Tcl_FSGetNormalizedPath \
+ (tclStubsPtr->tcl_FSGetNormalizedPath) /* 463 */
+#endif
+#ifndef Tcl_FSJoinToPath
+#define Tcl_FSJoinToPath \
+ (tclStubsPtr->tcl_FSJoinToPath) /* 464 */
+#endif
+#ifndef Tcl_FSGetInternalRep
+#define Tcl_FSGetInternalRep \
+ (tclStubsPtr->tcl_FSGetInternalRep) /* 465 */
+#endif
+#ifndef Tcl_FSGetTranslatedPath
+#define Tcl_FSGetTranslatedPath \
+ (tclStubsPtr->tcl_FSGetTranslatedPath) /* 466 */
+#endif
+#ifndef Tcl_FSEvalFile
+#define Tcl_FSEvalFile \
+ (tclStubsPtr->tcl_FSEvalFile) /* 467 */
+#endif
+#ifndef Tcl_FSNewNativePath
+#define Tcl_FSNewNativePath \
+ (tclStubsPtr->tcl_FSNewNativePath) /* 468 */
+#endif
+#ifndef Tcl_FSGetNativePath
+#define Tcl_FSGetNativePath \
+ (tclStubsPtr->tcl_FSGetNativePath) /* 469 */
+#endif
+#ifndef Tcl_FSFileSystemInfo
+#define Tcl_FSFileSystemInfo \
+ (tclStubsPtr->tcl_FSFileSystemInfo) /* 470 */
+#endif
+#ifndef Tcl_FSPathSeparator
+#define Tcl_FSPathSeparator \
+ (tclStubsPtr->tcl_FSPathSeparator) /* 471 */
+#endif
+#ifndef Tcl_FSListVolumes
+#define Tcl_FSListVolumes \
+ (tclStubsPtr->tcl_FSListVolumes) /* 472 */
+#endif
+#ifndef Tcl_FSRegister
+#define Tcl_FSRegister \
+ (tclStubsPtr->tcl_FSRegister) /* 473 */
+#endif
+#ifndef Tcl_FSUnregister
+#define Tcl_FSUnregister \
+ (tclStubsPtr->tcl_FSUnregister) /* 474 */
+#endif
+#ifndef Tcl_FSData
+#define Tcl_FSData \
+ (tclStubsPtr->tcl_FSData) /* 475 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index beb36e5..f7bc742 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclEncoding.c,v 1.6 2000/12/08 18:55:58 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclEncoding.c,v 1.7 2001/07/31 19:12:06 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -563,20 +563,22 @@ Tcl_GetEncodingNames(interp)
if (pathPtr != NULL) {
int i, objc;
Tcl_Obj **objv;
- Tcl_DString pwdString;
char globArgString[10];
-
+ Tcl_Obj* encodingObj = Tcl_NewStringObj("encoding",-1);
+ Tcl_IncrRefCount(encodingObj);
+
objc = 0;
Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);
- Tcl_GetCwd(interp, &pwdString);
-
for (i = 0; i < objc; i++) {
- char *string;
- int j, objc2, length;
- Tcl_Obj **objv2;
-
- string = Tcl_GetStringFromObj(objv[i], NULL);
+ Tcl_Obj *searchIn;
+
+ /*
+ * Construct the path from the element of pathPtr,
+ * joined with 'encoding'.
+ */
+ searchIn = Tcl_FSJoinToPath(objv[i],1,&encodingObj);
+ Tcl_IncrRefCount(searchIn);
Tcl_ResetResult(interp);
/*
@@ -586,15 +588,22 @@ Tcl_GetEncodingNames(interp)
*/
strcpy(globArgString, "*.enc");
- if ((Tcl_Chdir(string) == 0)
- && (Tcl_Chdir("encoding") == 0)
- && (TclGlob(interp, globArgString, NULL, 0, NULL) == TCL_OK)) {
- objc2 = 0;
+ /*
+ * The GLOBMODE_TAILS flag returns just the tail of each file
+ * which is the encoding name with a .enc extension
+ */
+ if ((TclGlob(interp, globArgString, searchIn,
+ TCL_GLOBMODE_TAILS, NULL) == TCL_OK)) {
+ int objc2 = 0;
+ Tcl_Obj **objv2;
+ int j;
Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp), &objc2,
&objv2);
for (j = 0; j < objc2; j++) {
+ int length;
+ char *string;
string = Tcl_GetStringFromObj(objv2[j], &length);
length -= 4;
if (length > 0) {
@@ -604,9 +613,9 @@ Tcl_GetEncodingNames(interp)
}
}
}
- Tcl_Chdir(Tcl_DStringValue(&pwdString));
+ Tcl_DecrRefCount(searchIn);
}
- Tcl_DStringFree(&pwdString);
+ Tcl_DecrRefCount(encodingObj);
}
/*
@@ -1275,6 +1284,7 @@ OpenEncodingFile(dir, name)
Tcl_DString pathString;
char *path;
Tcl_Channel chan;
+ Tcl_Obj *pathPtr;
argv[0] = (char *) dir;
argv[1] = "encoding";
@@ -1283,7 +1293,12 @@ OpenEncodingFile(dir, name)
Tcl_DStringInit(&pathString);
Tcl_JoinPath(3, argv, &pathString);
path = Tcl_DStringAppend(&pathString, ".enc", -1);
- chan = Tcl_OpenFileChannel(NULL, path, "r", 0);
+ pathPtr = Tcl_NewStringObj(path,-1);
+
+ Tcl_IncrRefCount(pathPtr);
+ chan = Tcl_FSOpenFileChannel(NULL, pathPtr, "r", 0);
+ Tcl_DecrRefCount(pathPtr);
+
Tcl_DStringFree(&pathString);
return chan;
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index d975cc6..c169427 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclFCmd.c,v 1.6 1999/07/01 23:21:07 redman Exp $
+ * RCS: @(#) $Id: tclFCmd.c,v 1.7 2001/07/31 19:12:06 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -20,14 +20,14 @@
*/
static int CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp,
- char *source, char *dest, int copyFlag,
- int force));
-static char * FileBasename _ANSI_ARGS_((Tcl_Interp *interp,
- char *path, Tcl_DString *bufferPtr));
+ Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr,
+ int copyFlag, int force));
+static Tcl_Obj * FileBasename _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *pathPtr));
static int FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp,
- int argc, char **argv, int copyFlag));
+ int objc, Tcl_Obj *CONST objv[], int copyFlag));
static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp,
- int argc, char **argv, int *forcePtr));
+ int objc, Tcl_Obj *CONST objv[], int *forcePtr));
/*
*---------------------------------------------------------------------------
@@ -49,12 +49,12 @@ static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp,
*/
int
-TclFileRenameCmd(interp, argc, argv)
+TclFileRenameCmd(interp, objc, objv)
Tcl_Interp *interp; /* Interp for error reporting. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings passed to Tcl_FileCmd. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */
{
- return FileCopyRename(interp, argc, argv, 0);
+ return FileCopyRename(interp, objc, objv, 0);
}
/*
@@ -77,12 +77,12 @@ TclFileRenameCmd(interp, argc, argv)
*/
int
-TclFileCopyCmd(interp, argc, argv)
+TclFileCopyCmd(interp, objc, objv)
Tcl_Interp *interp; /* Used for error reporting */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings passed to Tcl_FileCmd. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */
{
- return FileCopyRename(interp, argc, argv, 1);
+ return FileCopyRename(interp, objc, objv, 1);
}
/*
@@ -103,26 +103,26 @@ TclFileCopyCmd(interp, argc, argv)
*/
static int
-FileCopyRename(interp, argc, argv, copyFlag)
+FileCopyRename(interp, objc, objv, copyFlag)
Tcl_Interp *interp; /* Used for error reporting. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings passed to Tcl_FileCmd. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */
int copyFlag; /* If non-zero, copy source(s). Otherwise,
* rename them. */
{
int i, result, force;
struct stat statBuf;
- Tcl_DString targetBuffer;
- char *target;
+ Tcl_Obj *target;
- i = FileForceOption(interp, argc - 2, argv + 2, &force);
+ i = FileForceOption(interp, objc - 2, objv + 2, &force);
if (i < 0) {
return TCL_ERROR;
}
i += 2;
- if ((argc - i) < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ", argv[1], " ?options? source ?source ...? target\"",
+ if ((objc - i) < 2) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]),
+ " ?options? source ?source ...? target\"",
(char *) NULL);
return TCL_ERROR;
}
@@ -133,38 +133,38 @@ FileCopyRename(interp, argc, argv, copyFlag)
* directory.
*/
- target = Tcl_TranslateFileName(interp, argv[argc - 1], &targetBuffer);
- if (target == NULL) {
+ target = objv[objc - 1];
+ if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
return TCL_ERROR;
}
result = TCL_OK;
/*
- * Call TclStat() so that if target is a symlink that points to a
+ * Call Tcl_FSStat() so that if target is a symlink that points to a
* directory we will put the sources in that directory instead of
* overwriting the symlink.
*/
- if ((TclStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) {
- if ((argc - i) > 2) {
+ if ((Tcl_FSStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) {
+ if ((objc - i) > 2) {
errno = ENOTDIR;
Tcl_PosixError(interp);
Tcl_AppendResult(interp, "error ",
((copyFlag) ? "copying" : "renaming"), ": target \"",
- argv[argc - 1], "\" is not a directory", (char *) NULL);
+ Tcl_GetString(target), "\" is not a directory",
+ (char *) NULL);
result = TCL_ERROR;
} else {
/*
- * Even though already have target == translated(argv[i+1]),
+ * Even though already have target == translated(objv[i+1]),
* pass the original argument down, so if there's an error, the
* error message will reflect the original arguments.
*/
- result = CopyRenameOneFile(interp, argv[i], argv[i + 1], copyFlag,
+ result = CopyRenameOneFile(interp, objv[i], objv[i + 1], copyFlag,
force);
}
- Tcl_DStringFree(&targetBuffer);
return result;
}
@@ -173,30 +173,30 @@ FileCopyRename(interp, argc, argv, copyFlag)
* from each source, and append it to the end of the target path.
*/
- for ( ; i < argc - 1; i++) {
- char *jargv[2];
- char *source, *newFileName;
- Tcl_DString sourceBuffer, newFileNameBuffer;
-
- source = FileBasename(interp, argv[i], &sourceBuffer);
+ for ( ; i < objc - 1; i++) {
+ Tcl_Obj *jargv[2];
+ Tcl_Obj *source, *newFileName;
+ Tcl_Obj *temp;
+
+ source = FileBasename(interp, objv[i]);
if (source == NULL) {
result = TCL_ERROR;
break;
}
- jargv[0] = argv[argc - 1];
+ jargv[0] = objv[objc - 1];
jargv[1] = source;
- Tcl_DStringInit(&newFileNameBuffer);
- newFileName = Tcl_JoinPath(2, jargv, &newFileNameBuffer);
- result = CopyRenameOneFile(interp, argv[i], newFileName, copyFlag,
+ temp = Tcl_NewListObj(2, jargv);
+ newFileName = Tcl_FSJoinPath(temp, -1);
+ Tcl_IncrRefCount(newFileName);
+ Tcl_DecrRefCount(temp);
+
+ result = CopyRenameOneFile(interp, objv[i], newFileName, copyFlag,
force);
- Tcl_DStringFree(&sourceBuffer);
- Tcl_DStringFree(&newFileNameBuffer);
-
+ Tcl_DecrRefCount(newFileName);
if (result == TCL_ERROR) {
break;
}
}
- Tcl_DStringFree(&targetBuffer);
return result;
}
@@ -219,74 +219,72 @@ FileCopyRename(interp, argc, argv, copyFlag)
*----------------------------------------------------------------------
*/
int
-TclFileMakeDirsCmd(interp, argc, argv)
+TclFileMakeDirsCmd(interp, objc, objv)
Tcl_Interp *interp; /* Used for error reporting. */
- int argc; /* Number of arguments */
- char **argv; /* Argument strings passed to Tcl_FileCmd. */
+ int objc; /* Number of arguments */
+ Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */
{
- Tcl_DString nameBuffer, targetBuffer;
- char *errfile;
- int result, i, j, pargc;
- char **pargv;
+ Tcl_Obj *errfile;
+ int result, i, j, pobjc;
+ Tcl_Obj *split = NULL;
+ Tcl_Obj *target = NULL;
struct stat statBuf;
- pargv = NULL;
errfile = NULL;
- Tcl_DStringInit(&nameBuffer);
- Tcl_DStringInit(&targetBuffer);
result = TCL_OK;
- for (i = 2; i < argc; i++) {
- char *name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer);
- if (name == NULL) {
+ for (i = 2; i < objc; i++) {
+ if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
result = TCL_ERROR;
break;
}
- Tcl_SplitPath(name, &pargc, &pargv);
- if (pargc == 0) {
+ split = Tcl_FSSplitPath(objv[i],&pobjc);
+ if (pobjc == 0) {
errno = ENOENT;
- errfile = argv[i];
+ errfile = objv[i];
break;
}
- for (j = 0; j < pargc; j++) {
- char *target = Tcl_JoinPath(j + 1, pargv, &targetBuffer);
-
+ for (j = 0; j < pobjc; j++) {
+ target = Tcl_FSJoinPath(split, j + 1);
+ Tcl_IncrRefCount(target);
/*
- * Call TclStat() so that if target is a symlink that points
+ * Call Tcl_Stat() so that if target is a symlink that points
* to a directory we will create subdirectories in that
* directory.
*/
- if (TclStat(target, &statBuf) == 0) {
+ if (Tcl_FSStat(target, &statBuf) == 0) {
if (!S_ISDIR(statBuf.st_mode)) {
errno = EEXIST;
errfile = target;
goto done;
}
} else if ((errno != ENOENT)
- || (TclpCreateDirectory(target) != TCL_OK)) {
+ || (Tcl_FSCreateDirectory(target) != TCL_OK)) {
errfile = target;
goto done;
}
- Tcl_DStringFree(&targetBuffer);
+ /* Forget about this sub-path */
+ Tcl_DecrRefCount(target);
+ target = NULL;
}
- ckfree((char *) pargv);
- pargv = NULL;
- Tcl_DStringFree(&nameBuffer);
+ Tcl_DecrRefCount(split);
+ split = NULL;
}
done:
if (errfile != NULL) {
Tcl_AppendResult(interp, "can't create directory \"",
- errfile, "\": ", Tcl_PosixError(interp), (char *) NULL);
+ Tcl_GetString(errfile), "\": ", Tcl_PosixError(interp),
+ (char *) NULL);
result = TCL_ERROR;
}
-
- Tcl_DStringFree(&nameBuffer);
- Tcl_DStringFree(&targetBuffer);
- if (pargv != NULL) {
- ckfree((char *) pargv);
+ if (split != NULL) {
+ Tcl_DecrRefCount(split);
+ }
+ if (target != NULL) {
+ Tcl_DecrRefCount(target);
}
return result;
}
@@ -309,39 +307,34 @@ TclFileMakeDirsCmd(interp, argc, argv)
*/
int
-TclFileDeleteCmd(interp, argc, argv)
+TclFileDeleteCmd(interp, objc, objv)
Tcl_Interp *interp; /* Used for error reporting */
- int argc; /* Number of arguments */
- char **argv; /* Argument strings passed to Tcl_FileCmd. */
+ int objc; /* Number of arguments */
+ Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */
{
- Tcl_DString nameBuffer, errorBuffer;
int i, force, result;
- char *errfile;
+ Tcl_Obj *errfile;
- i = FileForceOption(interp, argc - 2, argv + 2, &force);
+ i = FileForceOption(interp, objc - 2, objv + 2, &force);
if (i < 0) {
return TCL_ERROR;
}
i += 2;
- if ((argc - i) < 1) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ", argv[1], " ?options? file ?file ...?\"", (char *) NULL);
+ if ((objc - i) < 1) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]),
+ " ?options? file ?file ...?\"", (char *) NULL);
return TCL_ERROR;
}
errfile = NULL;
result = TCL_OK;
- Tcl_DStringInit(&errorBuffer);
- Tcl_DStringInit(&nameBuffer);
- for ( ; i < argc; i++) {
+ for ( ; i < objc; i++) {
struct stat statBuf;
- char *name;
- errfile = argv[i];
- Tcl_DStringSetLength(&nameBuffer, 0);
- name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer);
- if (name == NULL) {
+ errfile = objv[i];
+ if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
@@ -350,7 +343,7 @@ TclFileDeleteCmd(interp, argc, argv)
* Call lstat() to get info so can delete symbolic link itself.
*/
- if (TclpLstat(name, &statBuf) != 0) {
+ if (Tcl_FSLstat(objv[i], &statBuf) != 0) {
/*
* Trying to delete a file that does not exist is not
* considered an error, just a no-op
@@ -360,10 +353,12 @@ TclFileDeleteCmd(interp, argc, argv)
result = TCL_ERROR;
}
} else if (S_ISDIR(statBuf.st_mode)) {
- result = TclpRemoveDirectory(name, force, &errorBuffer);
+ Tcl_Obj *errorBuffer = NULL;
+ result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer);
if (result != TCL_OK) {
if ((force == 0) && (errno == EEXIST)) {
- Tcl_AppendResult(interp, "error deleting \"", argv[i],
+ Tcl_AppendResult(interp, "error deleting \"",
+ Tcl_GetString(objv[i]),
"\": directory not empty", (char *) NULL);
Tcl_PosixError(interp);
goto done;
@@ -373,13 +368,14 @@ TclFileDeleteCmd(interp, argc, argv)
* If possible, use the untranslated name for the file.
*/
- errfile = Tcl_DStringValue(&errorBuffer);
- if (strcmp(name, errfile) == 0) {
- errfile = argv[i];
+ errfile = errorBuffer;
+ /* FS supposed to check between translated objv and errfile */
+ if (Tcl_FSEqualPaths(objv[i], errfile)) {
+ errfile = objv[i];
}
}
} else {
- result = TclpDeleteFile(name);
+ result = Tcl_FSDeleteFile(objv[i]);
}
if (result == TCL_ERROR) {
@@ -387,12 +383,20 @@ TclFileDeleteCmd(interp, argc, argv)
}
}
if (result != TCL_OK) {
- Tcl_AppendResult(interp, "error deleting \"", errfile,
- "\": ", Tcl_PosixError(interp), (char *) NULL);
+ if (errfile == NULL) {
+ /*
+ * We try to accomodate poor error results from our
+ * Tcl_FS calls
+ */
+ Tcl_AppendResult(interp, "error deleting unknown file: ",
+ Tcl_PosixError(interp), (char *) NULL);
+ } else {
+ Tcl_AppendResult(interp, "error deleting \"",
+ Tcl_GetString(errfile), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
}
done:
- Tcl_DStringFree(&errorBuffer);
- Tcl_DStringFree(&nameBuffer);
return result;
}
@@ -418,9 +422,9 @@ TclFileDeleteCmd(interp, argc, argv)
static int
CopyRenameOneFile(interp, source, target, copyFlag, force)
Tcl_Interp *interp; /* Used for error reporting. */
- char *source; /* Pathname of file to copy. May need to
+ Tcl_Obj *source; /* Pathname of file to copy. May need to
* be translated. */
- char *target; /* Pathname of file to create/overwrite.
+ Tcl_Obj *target; /* Pathname of file to create/overwrite.
* May need to be translated. */
int copyFlag; /* If non-zero, copy files. Otherwise,
* rename them. */
@@ -429,23 +433,19 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
* exists. */
{
int result;
- Tcl_DString sourcePath, targetPath, errorBuffer;
- char *targetName, *sourceName, *errfile;
+ Tcl_Obj *errfile, *errorBuffer;
struct stat sourceStatBuf, targetStatBuf;
- sourceName = Tcl_TranslateFileName(interp, source, &sourcePath);
- if (sourceName == NULL) {
+ if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) {
return TCL_ERROR;
}
- targetName = Tcl_TranslateFileName(interp, target, &targetPath);
- if (targetName == NULL) {
- Tcl_DStringFree(&sourcePath);
+ if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
return TCL_ERROR;
}
errfile = NULL;
+ errorBuffer = NULL;
result = TCL_ERROR;
- Tcl_DStringInit(&errorBuffer);
/*
* We want to copy/rename links and not the files they point to, so we
@@ -454,11 +454,11 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
* target.
*/
- if (TclpLstat(sourceName, &sourceStatBuf) != 0) {
+ if (Tcl_FSLstat(source, &sourceStatBuf) != 0) {
errfile = source;
goto done;
}
- if (TclpLstat(targetName, &targetStatBuf) != 0) {
+ if (Tcl_FSLstat(target, &targetStatBuf) != 0) {
if (errno != ENOENT) {
errfile = target;
goto done;
@@ -495,28 +495,31 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
if (S_ISDIR(sourceStatBuf.st_mode)
&& !S_ISDIR(targetStatBuf.st_mode)) {
errno = EISDIR;
- Tcl_AppendResult(interp, "can't overwrite file \"", target,
- "\" with directory \"", source, "\"", (char *) NULL);
+ Tcl_AppendResult(interp, "can't overwrite file \"",
+ Tcl_GetString(target), "\" with directory \"",
+ Tcl_GetString(source), "\"", (char *) NULL);
goto done;
}
if (!S_ISDIR(sourceStatBuf.st_mode)
&& S_ISDIR(targetStatBuf.st_mode)) {
errno = EISDIR;
- Tcl_AppendResult(interp, "can't overwrite directory \"", target,
- "\" with file \"", source, "\"", (char *) NULL);
+ Tcl_AppendResult(interp, "can't overwrite directory \"",
+ Tcl_GetString(target), "\" with file \"",
+ Tcl_GetString(source), "\"", (char *) NULL);
goto done;
}
}
if (copyFlag == 0) {
- result = TclpRenameFile(sourceName, targetName);
+ result = Tcl_FSRenameFile(source, target);
if (result == TCL_OK) {
goto done;
}
if (errno == EINVAL) {
- Tcl_AppendResult(interp, "error renaming \"", source, "\" to \"",
- target, "\": trying to rename a volume or ",
+ Tcl_AppendResult(interp, "error renaming \"",
+ Tcl_GetString(source), "\" to \"",
+ Tcl_GetString(target), "\": trying to rename a volume or ",
"move a directory into itself", (char *) NULL);
goto done;
} else if (errno != EXDEV) {
@@ -533,44 +536,122 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
}
if (S_ISDIR(sourceStatBuf.st_mode)) {
- result = TclpCopyDirectory(sourceName, targetName, &errorBuffer);
+ result = Tcl_FSCopyDirectory(source, target, &errorBuffer);
if (result != TCL_OK) {
- errfile = Tcl_DStringValue(&errorBuffer);
- if (strcmp(errfile, sourceName) == 0) {
- errfile = source;
- } else if (strcmp(errfile, targetName) == 0) {
- errfile = target;
+ if (errno == EXDEV) {
+ /*
+ * The copy failed because we're trying to do a
+ * cross-filesystem copy. We do this through our Tcl
+ * library.
+ */
+ Tcl_SavedResult savedResult;
+ Tcl_Obj *copyCommand = Tcl_NewListObj(0,NULL);
+ Tcl_IncrRefCount(copyCommand);
+ Tcl_ListObjAppendElement(interp, copyCommand,
+ Tcl_NewStringObj("::tcl::CopyDirectory",-1));
+ if (copyFlag) {
+ Tcl_ListObjAppendElement(interp, copyCommand,
+ Tcl_NewStringObj("copying",-1));
+ } else {
+ Tcl_ListObjAppendElement(interp, copyCommand,
+ Tcl_NewStringObj("renaming",-1));
+ }
+ Tcl_ListObjAppendElement(interp, copyCommand, source);
+ Tcl_ListObjAppendElement(interp, copyCommand, target);
+ Tcl_SaveResult(interp, &savedResult);
+ result = Tcl_EvalObjEx(interp, copyCommand,
+ TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
+ Tcl_DecrRefCount(copyCommand);
+ if (result != TCL_OK) {
+ /*
+ * There was an error in the Tcl-level copy.
+ * We will pass on the Tcl error message and
+ * can ensure this by setting errfile to NULL
+ */
+ Tcl_DiscardResult(&savedResult);
+ errfile = NULL;
+ } else {
+ /* The copy was successful */
+ Tcl_RestoreResult(interp, &savedResult);
+ }
+ } else {
+ errfile = errorBuffer;
+ if (Tcl_FSEqualPaths(errfile, source)) {
+ errfile = source;
+ } else if (Tcl_FSEqualPaths(errfile, target)) {
+ errfile = target;
+ }
}
}
} else {
- result = TclpCopyFile(sourceName, targetName);
- if (result != TCL_OK) {
+ result = Tcl_FSCopyFile(source, target);
+ if ((result != TCL_OK) && (errno == EXDEV)) {
/*
* Well, there really shouldn't be a problem with source,
* because up there we checked to see if it was ok to copy it.
+ *
+ * Either there is a problem with target, or we're trying
+ * to do a cross-filesystem copy. We open the target for
+ * writing to decide between those two cases.
*/
-
- errfile = target;
+ int prot = 0666;
+ Tcl_Channel out = Tcl_FSOpenFileChannel(interp, target, "w", prot);
+ if (out == NULL) {
+ /* There was a problem with the target */
+ errfile = target;
+ } else {
+ /* 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);
+ errfile = source;
+ } else {
+ 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 */
+ tval.actime = sourceStatBuf.st_atime;
+ tval.modtime = sourceStatBuf.st_mtime;
+ Tcl_FSUtime(source, &tval);
+ }
+ }
}
}
if ((copyFlag == 0) && (result == TCL_OK)) {
if (S_ISDIR(sourceStatBuf.st_mode)) {
- result = TclpRemoveDirectory(sourceName, 1, &errorBuffer);
+ result = Tcl_FSRemoveDirectory(source, 1, &errorBuffer);
if (result != TCL_OK) {
- errfile = Tcl_DStringValue(&errorBuffer);
- if (strcmp(errfile, sourceName) == 0) {
+ if (Tcl_FSEqualPaths(errfile, source) == 0) {
errfile = source;
}
}
} else {
- result = TclpDeleteFile(sourceName);
+ result = Tcl_FSDeleteFile(source);
if (result != TCL_OK) {
errfile = source;
}
}
if (result != TCL_OK) {
- Tcl_AppendResult(interp, "can't unlink \"", errfile, "\": ",
- Tcl_PosixError(interp), (char *) NULL);
+ Tcl_AppendResult(interp, "can't unlink \"",
+ Tcl_GetString(errfile), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
errfile = NULL;
}
}
@@ -579,19 +660,21 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
if (errfile != NULL) {
Tcl_AppendResult(interp,
((copyFlag) ? "error copying \"" : "error renaming \""),
- source, (char *) NULL);
+ Tcl_GetString(source), (char *) NULL);
if (errfile != source) {
- Tcl_AppendResult(interp, "\" to \"", target, (char *) NULL);
+ Tcl_AppendResult(interp, "\" to \"", Tcl_GetString(target),
+ (char *) NULL);
if (errfile != target) {
- Tcl_AppendResult(interp, "\": \"", errfile, (char *) NULL);
+ Tcl_AppendResult(interp, "\": \"", Tcl_GetString(errfile),
+ (char *) NULL);
}
}
Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp),
(char *) NULL);
}
- Tcl_DStringFree(&errorBuffer);
- Tcl_DStringFree(&sourcePath);
- Tcl_DStringFree(&targetPath);
+ if (errorBuffer != NULL) {
+ Tcl_DecrRefCount(errorBuffer);
+ }
return result;
}
@@ -616,10 +699,10 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
*/
static int
-FileForceOption(interp, argc, argv, forcePtr)
+FileForceOption(interp, objc, objv, forcePtr)
Tcl_Interp *interp; /* Interp, for error return. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. First command line
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument strings. First command line
* option, if it exists, begins at 0. */
int *forcePtr; /* If the "-force" was specified, *forcePtr
* is filled with 1, otherwise with 0. */
@@ -627,17 +710,17 @@ FileForceOption(interp, argc, argv, forcePtr)
int force, i;
force = 0;
- for (i = 0; i < argc; i++) {
- if (argv[i][0] != '-') {
+ for (i = 0; i < objc; i++) {
+ if (Tcl_GetString(objv[i])[0] != '-') {
break;
}
- if (strcmp(argv[i], "-force") == 0) {
+ if (strcmp(Tcl_GetString(objv[i]), "-force") == 0) {
force = 1;
- } else if (strcmp(argv[i], "--") == 0) {
+ } else if (strcmp(Tcl_GetString(objv[i]), "--") == 0) {
i++;
break;
} else {
- Tcl_AppendResult(interp, "bad option \"", argv[i],
+ Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[i]),
"\": should be -force or --", (char *)NULL);
return -1;
}
@@ -667,47 +750,51 @@ FileForceOption(interp, argc, argv, forcePtr)
*---------------------------------------------------------------------------
*/
-static char *
-FileBasename(interp, path, bufferPtr)
+static Tcl_Obj *
+FileBasename(interp, pathPtr)
Tcl_Interp *interp; /* Interp, for error return. */
- char *path; /* Path whose basename to extract. */
- Tcl_DString *bufferPtr; /* Initialized DString that receives
- * basename. */
+ Tcl_Obj *pathPtr; /* Path whose basename to extract. */
{
- int argc;
- char **argv;
+ int objc;
+ Tcl_Obj *split;
+ Tcl_Obj *resPtr = NULL;
- Tcl_SplitPath(path, &argc, &argv);
- if (argc == 0) {
- Tcl_DStringInit(bufferPtr);
- } else {
- if ((argc == 1) && (*path == '~')) {
- Tcl_DString buffer;
+ split = Tcl_FSSplitPath(pathPtr, &objc);
+
+ if (objc != 0) {
+ if ((objc == 1) && (*Tcl_GetString(pathPtr) == '~')) {
- ckfree((char *) argv);
- path = Tcl_TranslateFileName(interp, path, &buffer);
- if (path == NULL) {
+ if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
+ Tcl_DecrRefCount(split);
return NULL;
}
- Tcl_SplitPath(path, &argc, &argv);
- Tcl_DStringFree(&buffer);
+ Tcl_DecrRefCount(split);
+ split = Tcl_FSSplitPath(pathPtr, &objc);
}
- Tcl_DStringInit(bufferPtr);
/*
* Return the last component, unless it is the only component, and it
* is the root of an absolute path.
*/
- if (argc > 0) {
- if ((argc > 1)
- || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) {
- Tcl_DStringAppend(bufferPtr, argv[argc - 1], -1);
+ if (objc > 0) {
+ if (objc > 1) {
+ Tcl_ListObjIndex(NULL, split, objc-1, &resPtr);
+ } else {
+ Tcl_Obj *temp;
+ Tcl_ListObjIndex(NULL, split, 0, &temp);
+ if (Tcl_GetPathType(Tcl_GetString(temp)) == TCL_PATH_RELATIVE) {
+ Tcl_ListObjIndex(NULL, split, objc-1, &resPtr);
+ }
}
}
}
- ckfree((char *) argv);
- return Tcl_DStringValue(bufferPtr);
+ if (resPtr == NULL) {
+ resPtr = Tcl_NewStringObj("",0);
+ }
+ Tcl_IncrRefCount(resPtr);
+ Tcl_DecrRefCount(split);
+ return resPtr;
}
/*
@@ -715,15 +802,15 @@ FileBasename(interp, path, bufferPtr)
*
* TclFileAttrsCmd --
*
- * Sets or gets the platform-specific attributes of a file. The objc-objv
- * points to the file name with the rest of the command line following.
- * This routine uses platform-specific tables of option strings
- * and callbacks. The callback to get the attributes take three
- * parameters:
+ * Sets or gets the platform-specific attributes of a file. The
+ * objc-objv points to the file name with the rest of the command
+ * line following. This routine uses platform-specific tables of
+ * option strings and callbacks. The callback to get the
+ * attributes take three parameters:
* Tcl_Interp *interp; The interp to report errors with.
* Since this is an object-based API,
- * the object form of the result should be
- * used.
+ * the object form of the result should
+ * be used.
* CONST char *fileName; This is extracted using
* Tcl_TranslateFileName.
* TclObj **attrObjPtrPtr; A new object to hold the attribute
@@ -751,46 +838,67 @@ TclFileAttrsCmd(interp, objc, objv)
int objc; /* Number of command line arguments. */
Tcl_Obj *CONST objv[]; /* The command line objects. */
{
- char *fileName;
int result;
- Tcl_DString buffer;
-
+ char ** attributeStrings;
+ Tcl_Obj* objStrings = NULL;
+ int numObjStrings = -1;
+ Tcl_Obj *filePtr;
+
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv,
"name ?option? ?value? ?option value ...?");
return TCL_ERROR;
}
- fileName = Tcl_GetString(objv[2]);
- fileName = Tcl_TranslateFileName(interp, fileName, &buffer);
- if (fileName == NULL) {
+ filePtr = objv[2];
+ if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) {
return TCL_ERROR;
}
objc -= 3;
objv += 3;
result = TCL_ERROR;
-
+ attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings);
+ if (attributeStrings == NULL) {
+ int index;
+ Tcl_Obj *objPtr;
+ if (objStrings == NULL) {
+ goto end;
+ }
+ /* We own the object now */
+ Tcl_IncrRefCount(objStrings);
+ /* Use objStrings as a list object */
+ if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) {
+ goto end;
+ }
+ attributeStrings = (char**)ckalloc((1+numObjStrings)*sizeof(char*));
+ for (index = 0; index < numObjStrings; index++) {
+ Tcl_ListObjIndex(interp, objStrings, index, &objPtr);
+ attributeStrings[index] = Tcl_GetString(objPtr);
+ }
+ attributeStrings[index] = NULL;
+ }
if (objc == 0) {
/*
* Get all attributes.
*/
int index;
- Tcl_Obj *listPtr, *objPtr;
+ Tcl_Obj *listPtr;
listPtr = Tcl_NewListObj(0, NULL);
- for (index = 0; tclpFileAttrStrings[index] != NULL; index++) {
- objPtr = Tcl_NewStringObj(tclpFileAttrStrings[index], -1);
+ for (index = 0; attributeStrings[index] != NULL; index++) {
+ Tcl_Obj *objPtr = Tcl_NewStringObj(attributeStrings[index], -1);
Tcl_ListObjAppendElement(interp, listPtr, objPtr);
-
- if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName,
- &objPtr) != TCL_OK) {
+ /* We now forget about objPtr, it is in the list */
+ objPtr = NULL;
+ if (Tcl_FSFileAttrsGet(interp, index, filePtr,
+ &objPtr) != TCL_OK) {
Tcl_DecrRefCount(listPtr);
goto end;
}
Tcl_ListObjAppendElement(interp, listPtr, objPtr);
- }
+ }
Tcl_SetObjResult(interp, listPtr);
} else if (objc == 1) {
/*
@@ -798,13 +906,20 @@ TclFileAttrsCmd(interp, objc, objv)
*/
int index;
- Tcl_Obj *objPtr;
-
- if (Tcl_GetIndexFromObj(interp, objv[0], tclpFileAttrStrings,
+ Tcl_Obj *objPtr = NULL;
+
+ if (numObjStrings == 0) {
+ Tcl_AppendResult(interp, "bad option \"",
+ Tcl_GetString(objv[0]), "\", there are no file attributes"
+ " in this filesystem.", (char *) NULL);
+ goto end;
+ }
+
+ if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings,
"option", 0, &index) != TCL_OK) {
goto end;
- }
- if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName,
+ }
+ if (Tcl_FSFileAttrsGet(interp, index, filePtr,
&objPtr) != TCL_OK) {
goto end;
}
@@ -816,8 +931,15 @@ TclFileAttrsCmd(interp, objc, objv)
int i, index;
+ if (numObjStrings == 0) {
+ Tcl_AppendResult(interp, "bad option \"",
+ Tcl_GetString(objv[0]), "\", there are no file attributes"
+ " in this filesystem.", (char *) NULL);
+ goto end;
+ }
+
for (i = 0; i < objc ; i += 2) {
- if (Tcl_GetIndexFromObj(interp, objv[i], tclpFileAttrStrings,
+ if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings,
"option", 0, &index) != TCL_OK) {
goto end;
}
@@ -827,7 +949,7 @@ TclFileAttrsCmd(interp, objc, objv)
(char *) NULL);
goto end;
}
- if ((*tclpFileAttrProcs[index].setProc)(interp, index, fileName,
+ if (Tcl_FSFileAttrsSet(interp, index, filePtr,
objv[i + 1]) != TCL_OK) {
goto end;
}
@@ -836,6 +958,16 @@ TclFileAttrsCmd(interp, objc, objv)
result = TCL_OK;
end:
- Tcl_DStringFree(&buffer);
+ if (numObjStrings != -1) {
+ /* Free up the array we allocated */
+ ckfree((char*)attributeStrings);
+ /*
+ * We don't need this object that was passed to us
+ * any more.
+ */
+ if (objStrings != NULL) {
+ Tcl_DecrRefCount(objStrings);
+ }
+ }
return result;
}
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index 257f49d..31332ac 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclFileName.c,v 1.14 2001/05/15 21:24:22 hobbs Exp $
+ * RCS: @(#) $Id: tclFileName.c,v 1.15 2001/07/31 19:12:06 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -53,22 +53,14 @@ static Tcl_ThreadDataKey dataKey;
TclPlatformType tclPlatform = TCL_PLATFORM_UNIX;
/*
- * The "globParameters" argument of the globbing functions is an
- * or'ed combination of the following values:
- */
-
-#define GLOBMODE_NO_COMPLAIN 1
-#define GLOBMODE_JOIN 2
-#define GLOBMODE_DIR 4
-
-/*
* Prototypes for local procedures defined in this file:
*/
static char * DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *user, Tcl_DString *resultPtr));
static CONST char * ExtractWinRoot _ANSI_ARGS_((CONST char *path,
- Tcl_DString *resultPtr, int offset, Tcl_PathType *typePtr));
+ Tcl_DString *resultPtr, int offset,
+ Tcl_PathType *typePtr));
static void FileNameCleanup _ANSI_ARGS_((ClientData clientData));
static void FileNameInit _ANSI_ARGS_((void));
static int SkipToChar _ANSI_ARGS_((char **stringPtr,
@@ -314,6 +306,49 @@ Tcl_GetPathType(path)
}
/*
+ *---------------------------------------------------------------------------
+ *
+ * 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.
+ *
+ * Note this function currently calls the older Tcl_SplitPath
+ * routine, which therefore requires more memory allocation and
+ * deallocation than necessary. We could easily rewrite this for
+ * greater efficiency.
+ *
+ * Results:
+ * Returns list object with refCount of zero. If the passed in
+ * lenPtr is non-NULL, we use it to return the number of elements
+ * in the returned list.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+Tcl_FSSplitPath(Tcl_Obj* pathPtr, int *lenPtr) {
+ int argc, i;
+ char** argv;
+ Tcl_Obj* res;
+
+ Tcl_SplitPath(Tcl_GetString(pathPtr),&argc,&argv);
+ if (lenPtr != NULL) {
+ *lenPtr = argc;
+ }
+ res = Tcl_NewListObj(0,NULL);
+ for (i=0;i<argc;i++) {
+ Tcl_ListObjAppendElement(NULL, res, Tcl_NewStringObj(argv[i],-1));
+ }
+ ckfree((char*)argv);
+ return res;
+}
+
+/*
*----------------------------------------------------------------------
*
* Tcl_SplitPath --
@@ -739,6 +774,109 @@ SplitMacPath(path, bufPtr)
}
/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSJoinToPath --
+ *
+ * This function takes the given object, which should usually be a
+ * valid path or NULL, and joins onto it the array of paths
+ * segments given.
+ *
+ * Results:
+ * Returns object with refCount of zero
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+Tcl_FSJoinToPath(basePtr, objc, objv)
+ Tcl_Obj *basePtr;
+ int objc;
+ Tcl_Obj *CONST objv[];
+{
+ int i;
+ Tcl_Obj *lobj, *ret;
+
+ if (basePtr == NULL) {
+ lobj = Tcl_NewListObj(0,NULL);
+ } else {
+ lobj = Tcl_NewListObj(1,&basePtr);
+ }
+
+ for (i = 0; i<objc;i++) {
+ Tcl_ListObjAppendElement(NULL, lobj, objv[i]);
+ }
+ ret = Tcl_FSJoinPath(lobj,-1);
+ Tcl_DecrRefCount(lobj);
+ return ret;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * 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.
+ *
+ * Note this function currently calls the older Tcl_JoinPath
+ * routine, which therefore requires more memory allocation and
+ * deallocation than necessary. We could easily rewrite this for
+ * greater efficiency.
+ *
+ * Results:
+ * Returns object with refCount of zero.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+Tcl_FSJoinPath(listObj, elements)
+ Tcl_Obj *listObj;
+ int elements;
+{
+ char ** argv;
+ int count;
+ Tcl_DString ds;
+ Tcl_Obj *res;
+ 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;
+ }
+ /*
+ * It doesn't actually matter if 'elements' is greater
+ * than the actual number of elements.
+ */
+ }
+ argv = (char **)ckalloc(elements*sizeof(char*));
+
+ for (count = 0; count < elements; count++) {
+ Tcl_Obj* elt;
+ Tcl_ListObjIndex(NULL, listObj,count,&elt);
+ argv[count] = Tcl_GetString(elt);
+ }
+ Tcl_DStringInit(&ds);
+ res = Tcl_NewStringObj(Tcl_JoinPath(elements, argv, &ds),-1);
+ Tcl_DStringFree(&ds);
+ ckfree((char*)argv);
+ return res;
+}
+
+/*
*----------------------------------------------------------------------
*
* Tcl_JoinPath --
@@ -1008,12 +1146,9 @@ Tcl_TranslateFileName(interp, name, bufferPtr)
Tcl_DString *bufferPtr; /* Uninitialized or free DString filled
* with name after tilde substitution. */
{
- register char *p;
-
/*
* Handle tilde substitutions, if needed.
*/
-
if (name[0] == '~') {
int argc, length;
char **argv;
@@ -1039,20 +1174,20 @@ Tcl_TranslateFileName(interp, name, bufferPtr)
return NULL;
}
Tcl_DStringInit(bufferPtr);
- Tcl_JoinPath(argc, (char **) argv, bufferPtr);
+ Tcl_JoinPath(argc, argv, bufferPtr);
Tcl_DStringFree(&temp);
ckfree((char*)argv);
} else {
Tcl_DStringInit(bufferPtr);
- Tcl_JoinPath(1, (char **) &name, bufferPtr);
+ Tcl_JoinPath(1, &name, bufferPtr);
}
/*
* Convert forward slashes to backslashes in Windows paths because
* some system interfaces don't accept forward slashes.
*/
-
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
+ register char *p;
for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
if (*p == '/') {
*p = '\\';
@@ -1214,23 +1349,25 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int index, i, globFlags, pathlength, length, join, dir, result;
- char *string, *pathOrDir, *separators;
+ int index, i, globFlags, length, join, dir, result;
+ char *string, *separators;
Tcl_Obj *typePtr, *resultPtr, *look;
- Tcl_DString prefix, directory;
+ Tcl_Obj *pathOrDir = NULL;
+ Tcl_DString prefix;
static char *options[] = {
- "-directory", "-join", "-nocomplain", "-path", "-types", "--", NULL
+ "-directory", "-join", "-nocomplain", "-path", "-tails",
+ "-types", "--", NULL
};
enum options {
- GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TYPE, GLOB_LAST
+ GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS,
+ GLOB_TYPE, GLOB_LAST
};
enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1};
- GlobTypeData *globTypes = NULL;
+ Tcl_GlobTypeData *globTypes = NULL;
globFlags = 0;
join = 0;
dir = PATH_NONE;
- pathOrDir = NULL;
typePtr = NULL;
resultPtr = Tcl_GetObjResult(interp);
for (i = 1; i < objc; i++) {
@@ -1254,7 +1391,7 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv)
}
switch (index) {
case GLOB_NOCOMPLAIN: /* -nocomplain */
- globFlags |= GLOBMODE_NO_COMPLAIN;
+ globFlags |= TCL_GLOBMODE_NO_COMPLAIN;
break;
case GLOB_DIR: /* -dir */
if (i == (objc-1)) {
@@ -1262,34 +1399,37 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv)
"missing argument to \"-directory\"", -1);
return TCL_ERROR;
}
- if (dir != -1) {
+ if (dir != PATH_NONE) {
Tcl_AppendToObj(resultPtr,
"\"-directory\" cannot be used with \"-path\"",
-1);
return TCL_ERROR;
}
dir = PATH_DIR;
- globFlags |= GLOBMODE_DIR;
- pathOrDir = Tcl_GetStringFromObj(objv[i+1], &pathlength);
+ globFlags |= TCL_GLOBMODE_DIR;
+ pathOrDir = objv[i+1];
i++;
break;
case GLOB_JOIN: /* -join */
join = 1;
break;
+ case GLOB_TAILS: /* -tails */
+ globFlags |= TCL_GLOBMODE_TAILS;
+ break;
case GLOB_PATH: /* -path */
if (i == (objc-1)) {
Tcl_AppendToObj(resultPtr,
"missing argument to \"-path\"", -1);
return TCL_ERROR;
}
- if (dir != -1) {
+ if (dir != PATH_NONE) {
Tcl_AppendToObj(resultPtr,
"\"-path\" cannot be used with \"-directory\"",
-1);
return TCL_ERROR;
}
dir = PATH_GENERAL;
- pathOrDir = Tcl_GetStringFromObj(objv[i+1], &pathlength);
+ pathOrDir = objv[i+1];
i++;
break;
case GLOB_TYPE: /* -types */
@@ -1315,7 +1455,13 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv)
Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?");
return TCL_ERROR;
}
-
+ if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) {
+ Tcl_AppendToObj(resultPtr,
+ "\"-tails\" must be used with either \"-directory\" or \"-path\"",
+ -1);
+ return TCL_ERROR;
+ }
+
separators = NULL; /* lint. */
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
@@ -1329,34 +1475,34 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv)
break;
}
if (dir == PATH_GENERAL) {
+ int pathlength;
char *last;
+ char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength);
/*
* Find the last path separator in the path
*/
- last = pathOrDir + pathlength;
- for (; last != pathOrDir; last--) {
+ last = first + pathlength;
+ for (; last != first; last--) {
if (strchr(separators, *(last-1)) != NULL) {
break;
}
}
- if (last == pathOrDir + pathlength) {
+ if (last == first + pathlength) {
/* It's really a directory */
- dir = 1;
+ dir = PATH_DIR;
} else {
Tcl_DString pref;
char *search, *find;
Tcl_DStringInit(&pref);
- Tcl_DStringInit(&directory);
- if (last == pathOrDir) {
+ if (last == first) {
/* The whole thing is a prefix */
- Tcl_DStringAppend(&pref, pathOrDir, -1);
+ Tcl_DStringAppend(&pref, first, -1);
pathOrDir = NULL;
} else {
/* Have to split off the end */
- Tcl_DStringAppend(&pref, last, pathOrDir+pathlength-last);
- Tcl_DStringAppend(&directory, pathOrDir, last-pathOrDir-1);
- pathOrDir = Tcl_DStringValue(&directory);
+ Tcl_DStringAppend(&pref, last, first+pathlength-last);
+ pathOrDir = Tcl_NewStringObj(first, last-first-1);
}
/* Need to quote 'prefix' */
Tcl_DStringInit(&prefix);
@@ -1376,7 +1522,7 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv)
Tcl_DStringFree(&pref);
}
}
-
+
if (typePtr != NULL) {
/*
* The rest of the possible type arguments (except 'd') are
@@ -1384,7 +1530,7 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv)
* on an incompatible platform.
*/
Tcl_ListObjLength(interp, typePtr, &length);
- globTypes = (GlobTypeData*) ckalloc(sizeof(GlobTypeData));
+ globTypes = (Tcl_GlobTypeData*) ckalloc(sizeof(Tcl_GlobTypeData));
globTypes->type = 0;
globTypes->perm = 0;
globTypes->macType = NULL;
@@ -1476,13 +1622,18 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv)
goto endOfGlob;
badMacTypesArg:
Tcl_AppendToObj(resultPtr,
- "only one MacOS type or creator argument to \"-types\" allowed", -1);
+ "only one MacOS type or creator argument"
+ " to \"-types\" allowed", -1);
result = TCL_ERROR;
goto endOfGlob;
}
}
}
+ if (pathOrDir != NULL) {
+ Tcl_IncrRefCount(pathOrDir);
+ }
+
/*
* Now we perform the actual glob below. This may involve joining
* together the pattern arguments, dealing with particular file types
@@ -1543,7 +1694,7 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv)
}
}
}
- if ((globFlags & GLOBMODE_NO_COMPLAIN) == 0) {
+ if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) {
if (Tcl_ListObjLength(interp, Tcl_GetObjResult(interp),
&length) != TCL_OK) {
/* This should never happen. Maybe we should be more dramatic */
@@ -1571,9 +1722,9 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv)
endOfGlob:
if (join || (dir == PATH_GENERAL)) {
Tcl_DStringFree(&prefix);
- if (dir == PATH_GENERAL) {
- Tcl_DStringFree(&directory);
- }
+ }
+ if (pathOrDir != NULL) {
+ Tcl_DecrRefCount(pathOrDir);
}
if (globTypes != NULL) {
if (globTypes->macType != NULL) {
@@ -1600,11 +1751,11 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv)
* The return value is a standard Tcl result indicating whether
* an error occurred in globbing. After a normal return the
* result in interp (set by TclDoGlob) holds all of the file names
- * given by the dir and rem arguments. After an error the
- * result in interp will hold an error message.
+ * given by the pattern and unquotedPrefix arguments. After an
+ * error the result in interp will hold an error message.
*
* Side effects:
- * The currentArgString is written to.
+ * The 'pattern' is written to.
*
*----------------------------------------------------------------------
*/
@@ -1616,16 +1767,16 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types)
* or appending list of matching file names. */
char *pattern; /* Glob pattern to match. Must not refer
* to a static string. */
- char *unquotedPrefix; /* Prefix to glob pattern, if non-null, which
- * is considered literally. May be static. */
+ Tcl_Obj *unquotedPrefix; /* Prefix to glob pattern, if non-null, which
+ * is considered literally. */
int globFlags; /* Stores or'ed combination of flags */
- GlobTypeData *types; /* Struct containing acceptable types.
+ Tcl_GlobTypeData *types; /* Struct containing acceptable types.
* May be NULL. */
{
char *separators;
char *head, *tail, *start;
char c;
- int result;
+ int result, prefixLen;
Tcl_DString buffer;
separators = NULL; /* lint. */
@@ -1647,7 +1798,7 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types)
Tcl_DStringInit(&buffer);
if (unquotedPrefix != NULL) {
- start = unquotedPrefix;
+ start = Tcl_GetString(unquotedPrefix);
} else {
start = pattern;
}
@@ -1672,35 +1823,15 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types)
}
/*
- * Determine the home directory for the specified user. Note that
- * we don't allow special characters in the user name.
+ * Determine the home directory for the specified user.
*/
c = *tail;
*tail = '\0';
- /*
- * I don't think we need to worry about special characters in
- * the user name anymore (Vince Darley, June 1999), since the
- * new code is designed to handle special chars.
- */
-#ifndef NOT_NEEDED_ANYMORE
head = DoTildeSubst(interp, start+1, &buffer);
-#else
-
- if (strpbrk(start+1, "\\[]*?{}") == NULL) {
- head = DoTildeSubst(interp, start+1, &buffer);
- } else {
- if (!(globFlags & GLOBMODE_NO_COMPLAIN)) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "globbing characters not ",
- "supported in user names", (char *) NULL);
- }
- head = NULL;
- }
-#endif
*tail = c;
if (head == NULL) {
- if (globFlags & GLOBMODE_NO_COMPLAIN) {
+ if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
/*
* We should in fact pass down the nocomplain flag
* or save the interp result or use another mechanism
@@ -1725,29 +1856,76 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types)
} else {
tail = pattern;
if (unquotedPrefix != NULL) {
- Tcl_DStringAppend(&buffer,unquotedPrefix,-1);
+ Tcl_DStringAppend(&buffer,Tcl_GetString(unquotedPrefix),-1);
}
}
+
/*
- * If the prefix is a directory, make sure it ends in a directory
- * separator.
+ * We want to remember the length of the current prefix,
+ * in case we are using TCL_GLOBMODE_TAILS. Also if we
+ * are using TCL_GLOBMODE_DIR, we must make sure the
+ * prefix ends in a directory separator.
*/
- if (unquotedPrefix != NULL) {
- if (globFlags & GLOBMODE_DIR) {
- c = Tcl_DStringValue(&buffer)[Tcl_DStringLength(&buffer)-1];
- if (strchr(separators, c) == NULL) {
+ prefixLen = Tcl_DStringLength(&buffer);
+
+ if (prefixLen > 0) {
+ c = Tcl_DStringValue(&buffer)[prefixLen-1];
+ if (strchr(separators, c) == NULL) {
+ /*
+ * If the prefix is a directory, make sure it ends in a
+ * directory separator.
+ */
+ if (globFlags & TCL_GLOBMODE_DIR) {
Tcl_DStringAppend(&buffer,separators,1);
}
+ prefixLen++;
}
}
result = TclDoGlob(interp, separators, &buffer, tail, types);
Tcl_DStringFree(&buffer);
+
if (result != TCL_OK) {
- if (globFlags & GLOBMODE_NO_COMPLAIN) {
+ if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
Tcl_ResetResult(interp);
return TCL_OK;
}
+ } else {
+ /*
+ * If we only want the tails, we must strip off the prefix now.
+ * It may seem more efficient to pass the tails flag down into
+ * TclDoGlob, Tcl_FSMatchInDirectory, but those functions are
+ * continually adjusting the prefix as the various pieces of
+ * the pattern are assimilated, so that would add a lot of
+ * complexity to the code. This way is a little slower (when
+ * the -tails flag is given), but much simpler to code.
+ */
+ if (globFlags & TCL_GLOBMODE_TAILS) {
+ int objc, i;
+ Tcl_Obj **objv;
+ Tcl_Obj *tailResult;
+ Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp),
+ &objc, &objv);
+ tailResult = Tcl_NewListObj(0,NULL);
+ for (i = 0; i< objc; i++) {
+ int len;
+ char *oldStr = Tcl_GetStringFromObj(objv[i],&len);
+ Tcl_Obj* str;
+ if (len == prefixLen) {
+ if ((pattern[0] == '\0')
+ || (strchr(separators, pattern[0]) == NULL)) {
+ str = Tcl_NewStringObj(".",1);
+ } else {
+ str = Tcl_NewStringObj("/",1);
+ }
+ } else {
+ str = Tcl_NewStringObj(oldStr + prefixLen,
+ len - prefixLen);
+ }
+ Tcl_ListObjAppendElement(interp, tailResult, str);
+ }
+ Tcl_SetObjResult(interp, tailResult);
+ }
}
return result;
}
@@ -1841,8 +2019,8 @@ TclDoGlob(interp, separators, headPtr, tail, types)
Tcl_DString *headPtr; /* Completely expanded prefix. */
char *tail; /* The unexpanded remainder of the path.
* Must not be a pointer to a static string. */
- GlobTypeData *types; /* List object containing list of acceptable types.
- * May be NULL. */
+ Tcl_GlobTypeData *types; /* List object containing list of acceptable
+ * types. May be NULL. */
{
int baseLength, quoted, count;
int result = TCL_OK;
@@ -1999,8 +2177,8 @@ TclDoGlob(interp, separators, headPtr, tail, types)
Tcl_DStringSetLength(&newName, baseLength);
Tcl_DStringAppend(&newName, element, p-element);
Tcl_DStringAppend(&newName, closeBrace+1, -1);
- result = TclDoGlob(interp, separators,
- headPtr, Tcl_DStringValue(&newName), types);
+ result = TclDoGlob(interp, separators, headPtr,
+ Tcl_DStringValue(&newName), types);
if (result != TCL_OK) {
break;
}
@@ -2025,24 +2203,70 @@ TclDoGlob(interp, separators, headPtr, tail, types)
* if the string is a static.
*/
- savedChar = *p;
- *p = '\0';
- firstSpecialChar = strpbrk(tail, "*[]?\\");
- *p = savedChar;
+ savedChar = *p;
+ *p = '\0';
+ firstSpecialChar = strpbrk(tail, "*[]?\\");
+ *p = savedChar;
} else {
firstSpecialChar = strpbrk(tail, "*[]?\\");
}
if (firstSpecialChar != NULL) {
+ int ret;
+ Tcl_Obj *head = Tcl_NewStringObj(Tcl_DStringValue(headPtr),-1);
+ Tcl_IncrRefCount(head);
/*
- * Look for matching files in the current directory. The
- * implementation of this function is platform specific, but may
- * recursively call TclDoGlob. For each file that matches, it will
- * add the match onto the interp's result, or call TclDoGlob if there
- * are more characters to be processed.
+ * Look for matching files in the given directory. The
+ * implementation of this function is platform specific. For
+ * each file that matches, it will add the match onto the
+ * resultPtr given.
*/
+ if (*p == '\0') {
+ ret = Tcl_FSMatchInDirectory(interp, Tcl_GetObjResult(interp),
+ head, tail, types);
+ } else {
+ Tcl_Obj* resultPtr;
- return TclpMatchFilesTypes(interp, separators, headPtr, tail, p, types);
+ /*
+ * We do the recursion ourselves. This makes implementing
+ * Tcl_FSMatchInDirectory for each filesystem much easier.
+ */
+ Tcl_GlobTypeData dirOnly = { TCL_GLOB_TYPE_DIR, 0, NULL, NULL };
+ char save = *p;
+
+ *p = '\0';
+ resultPtr = Tcl_NewListObj(0, NULL);
+ ret = Tcl_FSMatchInDirectory(interp, resultPtr,
+ head, tail, &dirOnly);
+ *p = save;
+ if (ret == TCL_OK) {
+ int resLength;
+ ret = Tcl_ListObjLength(interp, resultPtr, &resLength);
+ if (ret == TCL_OK) {
+ int i;
+ for (i =0; i< resLength; i++) {
+ Tcl_Obj *elt;
+ Tcl_DString ds;
+ Tcl_ListObjIndex(interp, resultPtr, i, &elt);
+ Tcl_DStringInit(&ds);
+ Tcl_DStringAppend(&ds, Tcl_GetString(elt), -1);
+ if(tclPlatform == TCL_PLATFORM_MAC) {
+ Tcl_DStringAppend(&ds, ":",1);
+ } else {
+ Tcl_DStringAppend(&ds, "/",1);
+ }
+ ret = TclDoGlob(interp, separators, &ds, p+1, types);
+ Tcl_DStringFree(&ds);
+ if (ret != TCL_OK) {
+ break;
+ }
+ }
+ }
+ }
+ Tcl_DecrRefCount(resultPtr);
+ }
+ Tcl_DecrRefCount(head);
+ return ret;
}
Tcl_DStringAppend(headPtr, tail, p-tail);
if (*p != '\0') {
@@ -2061,7 +2285,7 @@ TclDoGlob(interp, separators, headPtr, tail, types)
Tcl_DStringAppend(headPtr, ":", 1);
}
name = Tcl_DStringValue(headPtr);
- if (TclpAccess(name, F_OK) == 0) {
+ if (Tcl_Access(name, F_OK) == 0) {
if ((name[1] != '\0') && (strchr(name+1, ':') == NULL)) {
Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp),
Tcl_NewStringObj(name + 1,-1));
@@ -2079,6 +2303,9 @@ TclDoGlob(interp, separators, headPtr, tail, types)
* We need to convert slashes to backslashes before checking
* for the existence of the file. Once we are done, we need
* to convert the slashes back.
+ *
+ * This backslash/forward slash conversion may no longer
+ * be necessary, since we have dropped Win3.1 support.
*/
if (Tcl_DStringLength(headPtr) == 0) {
@@ -2096,7 +2323,7 @@ TclDoGlob(interp, separators, headPtr, tail, types)
}
}
name = Tcl_DStringValue(headPtr);
- exists = (TclpAccess(name, F_OK) == 0);
+ exists = (Tcl_Access(name, F_OK) == 0);
for (p = name; *p != '\0'; p++) {
if (*p == '\\') {
@@ -2118,7 +2345,7 @@ TclDoGlob(interp, separators, headPtr, tail, types)
}
}
name = Tcl_DStringValue(headPtr);
- if (TclpAccess(name, F_OK) == 0) {
+ if (Tcl_Access(name, F_OK) == 0) {
Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp),
Tcl_NewStringObj(name,-1));
}
diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y
index b7da254..dd3310b 100644
--- a/generic/tclGetDate.y
+++ b/generic/tclGetDate.y
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclGetDate.y,v 1.16 2000/05/18 22:29:56 ericm Exp $
+ * RCS: @(#) $Id: tclGetDate.y,v 1.17 2001/07/31 19:12:06 vincentdarley Exp $
*/
%{
@@ -33,7 +33,7 @@
#include "tclInt.h"
#include "tclPort.h"
-#ifdef MAC_TCL
+#if defined(MAC_TCL) && !defined(TCL_MAC_USE_MSL_EPOCH)
# define EPOCH 1904
# define START_OF_TIME 1904
# define END_OF_TIME 2039
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 7bd0938..8ef6e12 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIO.c,v 1.32 2001/07/18 17:13:25 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclIO.c,v 1.33 2001/07/31 19:12:06 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -104,6 +104,8 @@ static void DeleteChannelTable _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp));
static void DeleteScriptRecord _ANSI_ARGS_((Tcl_Interp *interp,
Channel *chanPtr, int mask));
+static int DetachChannel _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Channel chan));
static void DiscardInputQueued _ANSI_ARGS_((ChannelState *statePtr,
int discardSavedBuffers));
static void DiscardOutputQueued _ANSI_ARGS_((
@@ -687,6 +689,38 @@ CheckForStdChannelsBeingClosed(chan)
/*
*----------------------------------------------------------------------
*
+ * Tcl_IsStandardChannel --
+ *
+ * Test if the given channel is a standard channel. No attempt
+ * is made to check if the channel or the standard channels
+ * are initialized or otherwise valid.
+ *
+ * Results:
+ * Returns 1 if true, 0 if false.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+Tcl_IsStandardChannel(chan)
+ Tcl_Channel chan; /* Channel to check. */
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ if ((chan == tsdPtr->stdinChannel)
+ || (chan == tsdPtr->stdoutChannel)
+ || (chan == tsdPtr->stderrChannel)) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_RegisterChannel --
*
* Adds an already-open channel to the channel table of an interpreter.
@@ -747,13 +781,21 @@ Tcl_RegisterChannel(interp, chan)
*
* Deletes the hash entry for a channel associated with an interpreter.
* If the interpreter given as argument is NULL, it only decrements the
- * reference count.
+ * reference count. (This all happens in the Tcl_DetachChannel helper
+ * function).
+ *
+ * Finally, if the reference count of the channel drops to zero,
+ * it is deleted.
*
* Results:
* A standard Tcl result.
*
* Side effects:
- * Deletes the hash entry for a channel associated with an interpreter.
+ * Calls Tcl_DetachChannel which deletes the hash entry for a channel
+ * associated with an interpreter.
+ *
+ * May delete the channel, which can have a variety of consequences,
+ * especially if we are forced to close the channel.
*
*----------------------------------------------------------------------
*/
@@ -763,46 +805,14 @@ Tcl_UnregisterChannel(interp, chan)
Tcl_Interp *interp; /* Interpreter in which channel is defined. */
Tcl_Channel chan; /* Channel to delete. */
{
- Tcl_HashTable *hTblPtr; /* Hash table of channels. */
- Tcl_HashEntry *hPtr; /* Search variable. */
- Channel *chanPtr; /* The real IO channel. */
ChannelState *statePtr; /* State of the real channel. */
- /*
- * Always (un)register bottom-most channel in the stack. This makes
- * management of the channel list easier because no manipulation is
- * necessary during (un)stack operation.
- */
- chanPtr = ((Channel *) chan)->state->bottomChanPtr;
- statePtr = chanPtr->state;
-
- if (interp != (Tcl_Interp *) NULL) {
- hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
- if (hTblPtr == (Tcl_HashTable *) NULL) {
- return TCL_OK;
- }
- hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName);
- if (hPtr == (Tcl_HashEntry *) NULL) {
- return TCL_OK;
- }
- if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) {
- return TCL_OK;
- }
- Tcl_DeleteHashEntry(hPtr);
-
- /*
- * Remove channel handlers that refer to this interpreter, so that they
- * will not be present if the actual close is delayed and more events
- * happen on the channel. This may occur if the channel is shared
- * between several interpreters, or if the channel has async
- * flushing active.
- */
-
- CleanupChannelHandlers(interp, chanPtr);
+ if (DetachChannel(interp, chan) != TCL_OK) {
+ return TCL_OK;
}
-
- statePtr->refCount--;
+ statePtr = ((Channel *) chan)->state->bottomChanPtr->state;
+
/*
* Perform special handling for standard channels being closed. If the
* refCount is now 1 it means that the last reference to the standard
@@ -829,17 +839,143 @@ Tcl_UnregisterChannel(interp, chan)
statePtr->curOutPtr->nextRemoved)) {
statePtr->flags |= BUFFER_READY;
}
- statePtr->flags |= CHANNEL_CLOSED;
+ Tcl_Preserve((ClientData)statePtr);
if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) {
- if (Tcl_Close(interp, chan) != TCL_OK) {
- return TCL_ERROR;
- }
+ /* We don't want to re-enter Tcl_Close */
+ if (!(statePtr->flags & CHANNEL_CLOSED)) {
+ if (Tcl_Close(interp, chan) != TCL_OK) {
+ statePtr->flags |= CHANNEL_CLOSED;
+ Tcl_Release((ClientData)statePtr);
+ return TCL_ERROR;
+ }
+ }
}
+ statePtr->flags |= CHANNEL_CLOSED;
+ Tcl_Release((ClientData)statePtr);
}
return TCL_OK;
}
/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DetachChannel --
+ *
+ * Deletes the hash entry for a channel associated with an interpreter.
+ * If the interpreter given as argument is NULL, it only decrements the
+ * reference count. Even if the ref count drops to zero, the
+ * channel is NOT closed or cleaned up. This allows a channel to
+ * be detached from an interpreter and left in the same state it
+ * was in when it was originally returned by 'Tcl_OpenFileChannel',
+ * for example.
+ *
+ * This function cannot be used on the standard channels, and
+ * will return TCL_ERROR if that is attempted.
+ *
+ * This function should only be necessary for special purposes
+ * in which you need to generate a pristine channel from one
+ * that has already been used. All ordinary purposes will almost
+ * always want to use Tcl_UnregisterChannel instead.
+ *
+ * Results:
+ * A standard Tcl result. If the channel is not currently registered
+ * with the given interpreter, TCL_ERROR is returned, otherwise
+ * TCL_OK. However no error messages are left in the interp's result.
+ *
+ * Side effects:
+ * Deletes the hash entry for a channel associated with an
+ * interpreter.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_DetachChannel(interp, chan)
+ Tcl_Interp *interp; /* Interpreter in which channel is defined. */
+ Tcl_Channel chan; /* Channel to delete. */
+{
+ if (Tcl_IsStandardChannel(chan)) {
+ return TCL_ERROR;
+ }
+
+ return DetachChannel(interp, chan);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DetachChannel --
+ *
+ * Deletes the hash entry for a channel associated with an interpreter.
+ * If the interpreter given as argument is NULL, it only decrements the
+ * reference count. Even if the ref count drops to zero, the
+ * channel is NOT closed or cleaned up. This allows a channel to
+ * be detached from an interpreter and left in the same state it
+ * was in when it was originally returned by 'Tcl_OpenFileChannel',
+ * for example.
+ *
+ * Results:
+ * A standard Tcl result. If the channel is not currently registered
+ * with the given interpreter, TCL_ERROR is returned, otherwise
+ * TCL_OK. However no error messages are left in the interp's result.
+ *
+ * Side effects:
+ * Deletes the hash entry for a channel associated with an
+ * interpreter.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+DetachChannel(interp, chan)
+ Tcl_Interp *interp; /* Interpreter in which channel is defined. */
+ Tcl_Channel chan; /* Channel to delete. */
+{
+ Tcl_HashTable *hTblPtr; /* Hash table of channels. */
+ Tcl_HashEntry *hPtr; /* Search variable. */
+ Channel *chanPtr; /* The real IO channel. */
+ ChannelState *statePtr; /* State of the real channel. */
+
+ /*
+ * Always (un)register bottom-most channel in the stack. This makes
+ * management of the channel list easier because no manipulation is
+ * necessary during (un)stack operation.
+ */
+ chanPtr = ((Channel *) chan)->state->bottomChanPtr;
+ statePtr = chanPtr->state;
+
+ if (interp != (Tcl_Interp *) NULL) {
+ hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
+ if (hTblPtr == (Tcl_HashTable *) NULL) {
+ return TCL_ERROR;
+ }
+ hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName);
+ if (hPtr == (Tcl_HashEntry *) NULL) {
+ return TCL_ERROR;
+ }
+ if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) {
+ return TCL_ERROR;
+ }
+ Tcl_DeleteHashEntry(hPtr);
+
+ /*
+ * Remove channel handlers that refer to this interpreter, so that they
+ * will not be present if the actual close is delayed and more events
+ * happen on the channel. This may occur if the channel is shared
+ * between several interpreters, or if the channel has async
+ * flushing active.
+ */
+
+ CleanupChannelHandlers(interp, chanPtr);
+ }
+
+ statePtr->refCount--;
+
+ return TCL_OK;
+}
+
+
+/*
*---------------------------------------------------------------------------
*
* Tcl_GetChannel --
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index e3f0a6e..78ab3cf 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIOCmd.c,v 1.7 1999/09/21 04:20:40 hobbs Exp $
+ * RCS: @(#) $Id: tclIOCmd.c,v 1.8 2001/07/31 19:12:06 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -953,7 +953,7 @@ Tcl_OpenObjCmd(notUsed, interp, objc, objv)
*/
if (!pipeline) {
- chan = Tcl_OpenFileChannel(interp, what, modeString, prot);
+ chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot);
} else {
#ifdef MAC_TCL
Tcl_AppendResult(interp,
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index f4412e5..ec0e277 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -1,8 +1,12 @@
/*
* tclIOUtil.c --
*
- * This file contains a collection of utility procedures that
- * are shared by the platform specific IO drivers.
+ * 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.
@@ -13,12 +17,187 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIOUtil.c,v 1.11 2000/05/27 23:58:01 hobbs Exp $
+ * RCS: @(#) $Id: tclIOUtil.c,v 1.12 2001/07/31 19:12:06 vincentdarley Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
+
+/*
+ * Prototypes for procedures defined later in this file. The last
+ * of these could perhaps be exported in the future, if extensions
+ * require it.
+ */
+
+static void DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
+ Tcl_Obj *copyPtr));
+static void FreeFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *listPtr));
+static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
+static Tcl_Obj* FSNormalizeAbsolutePath
+ _ANSI_ARGS_((Tcl_Interp* interp, char *path));
+static int TclNormalizeToUniquePath
+ _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr));
+static int SetFsPathFromAbsoluteNormalized
+ _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr));
+static int FindSplitPos _ANSI_ARGS_((char *path, char *separator));
+static Tcl_Filesystem* Tcl_FSGetFileSystemForPath
+ _ANSI_ARGS_((Tcl_Obj* pathObjPtr));
+
+/*
+ * Define the 'path' object type, which Tcl uses to represent
+ * file paths internally.
+ */
+Tcl_ObjType tclFsPathType = {
+ "path", /* name */
+ FreeFsPathInternalRep, /* freeIntRepProc */
+ DupFsPathInternalRep, /* dupIntRepProc */
+ NULL, /* updateStringProc */
+ SetFsPathFromAny /* setFromAnyProc */
+};
+
+/*
+ * These form part of the native filesystem support. They are needed
+ * here because we have a few native filesystem functions (which are
+ * the same for mac/win/unix) in this file. There is no need to place
+ * them in tclInt.h, because they are not (and should not be) used
+ * anywhere else.
+ */
+extern char * tclpFileAttrStrings[];
+extern CONST TclFileAttrProcs tclpFileAttrProcs[];
+
+/*
+ * The following functions are obsolete string based APIs, and should
+ * be removed in a future release.
+ */
+
+/* Obsolete */
+int
+TclStat(path, buf)
+ CONST char *path; /* Path of file to stat (in current CP). */
+ struct stat *buf; /* Filled with results of stat call. */
+{
+ return Tcl_Stat(path,buf);
+}
+
+/* Obsolete */
+int
+TclAccess(path, mode)
+ CONST char *path; /* Path of file to access (in current CP). */
+ int mode; /* Permission setting. */
+{
+ return Tcl_Access(path, mode);
+}
+/* Obsolete */
+int
+Tcl_Stat(path, buf)
+ CONST char *path; /* Path of file to stat (in current CP). */
+ struct stat *buf; /* Filled with results of stat call. */
+{
+ int ret;
+ Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
+ Tcl_IncrRefCount(pathPtr);
+ ret = Tcl_FSStat(pathPtr,buf);
+ Tcl_DecrRefCount(pathPtr);
+ return ret;
+}
+
+/* Obsolete */
+int
+Tcl_Access(path, mode)
+ CONST char *path; /* Path of file to access (in current CP). */
+ int mode; /* Permission setting. */
+{
+ int ret;
+ Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
+ Tcl_IncrRefCount(pathPtr);
+ ret = Tcl_FSAccess(pathPtr,mode);
+ Tcl_DecrRefCount(pathPtr);
+ return ret;
+}
+
+/* Obsolete */
+Tcl_Channel
+Tcl_OpenFileChannel(interp, path, modeString, permissions)
+ Tcl_Interp *interp; /* Interpreter for error reporting;
+ * can be NULL. */
+ char *path; /* Name of file to open. */
+ char *modeString; /* A list of POSIX open modes or
+ * a string such as "rw". */
+ int permissions; /* If the open involves creating a
+ * file, with what modes to create
+ * it? */
+{
+ Tcl_Channel ret;
+ Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
+ Tcl_IncrRefCount(pathPtr);
+ ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions);
+ Tcl_DecrRefCount(pathPtr);
+ return ret;
+
+}
+
+/* Obsolete */
+int
+Tcl_Chdir(dirName)
+ CONST char *dirName;
+{
+ int ret;
+ Tcl_Obj *pathPtr = Tcl_NewStringObj(dirName,-1);
+ Tcl_IncrRefCount(pathPtr);
+ ret = Tcl_FSChdir(pathPtr);
+ Tcl_DecrRefCount(pathPtr);
+ return ret;
+}
+
+/* Obsolete */
+char *
+Tcl_GetCwd(interp, cwdPtr)
+ Tcl_Interp *interp;
+ Tcl_DString *cwdPtr;
+{
+ Tcl_Obj *cwd;
+ cwd = Tcl_FSGetCwd(interp);
+ if (cwd == NULL) {
+ return NULL;
+ } else {
+ Tcl_DStringInit(cwdPtr);
+ Tcl_DStringAppend(cwdPtr, Tcl_GetString(cwd), -1);
+ Tcl_DecrRefCount(cwd);
+ return Tcl_DStringValue(cwdPtr);
+ }
+}
+
+/* Obsolete */
+int
+Tcl_EvalFile(interp, fileName)
+ Tcl_Interp *interp; /* Interpreter in which to process file. */
+ char *fileName; /* Name of file to process. Tilde-substitution
+ * will be performed on this name. */
+{
+ int ret;
+ Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1);
+ Tcl_IncrRefCount(pathPtr);
+ ret = Tcl_FSEvalFile(interp, pathPtr);
+ Tcl_DecrRefCount(pathPtr);
+ return ret;
+}
+
+
+/*
+ * The 3 hooks for Stat, Access and OpenFileChannel are obsolete. The
+ * complete, general hooked filesystem APIs should be used instead.
+ * This define decides whether to include the obsolete hooks and
+ * related code. If these are removed, we'll also want to remove them
+ * from stubs/tclInt. The only known users of these APIs are prowrap
+ * and mktclapp. New code/extensions should not use them, since they
+ * do not provide as full support as the full filesystem API.
+ */
+#define USE_OBSOLETE_FS_HOOKS
+
+
+#ifdef USE_OBSOLETE_FS_HOOKS
/*
* The following typedef declarations allow for hooking into the chain
* of functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' &
@@ -45,10 +224,10 @@ typedef struct OpenFileChannelProc {
} OpenFileChannelProc;
/*
- * For each type of 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.
+ * 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.
@@ -56,26 +235,638 @@ typedef struct OpenFileChannelProc {
* This method avoids the need to call any sort of "initialization"
* function.
*
- * All three lists are protected by a global hookMutex.
+ * All three lists are protected by a global obsoleteFsHookMutex.
*/
-static StatProc defaultStatProc = {
- &TclpStat, NULL
-};
-static StatProc *statProcList = &defaultStatProc;
+static StatProc *statProcList = NULL;
+static AccessProc *accessProcList = NULL;
+static OpenFileChannelProc *openFileChannelProcList = NULL;
+
+TCL_DECLARE_MUTEX(obsoleteFsHookMutex)
+
+#endif /* USE_OBSOLETE_FS_HOOKS */
+
+/*
+ * A filesystem record is used to keep track of each
+ * filesystem currently registered with the core,
+ * in a linked list.
+ */
+typedef struct FilesystemRecord {
+ ClientData clientData; /* Client specific data for the new
+ * filesystem (can be NULL) */
+ Tcl_Filesystem *fsPtr; /* Pointer to filesystem dispatch
+ * table. */
+ int refCount; /* How many Tcl_Obj's use this
+ * filesystem. */
+ struct FilesystemRecord *nextPtr;
+ /* The next filesystem registered
+ * to Tcl, or NULL if no more. */
+} FilesystemRecord;
+
+/*
+ * 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_FSPathInFilesystemProc NativePathInFilesystem;
+static Tcl_FSFilesystemPathTypeProc NativeFilesystemPathType;
+static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator;
+static Tcl_FSFreeInternalRepProc NativeFreeInternalRep;
+static Tcl_FSDupInternalRepProc NativeDupInternalRep;
+static Tcl_FSCreateInternalRepProc NativeCreateNativeRep;
+static Tcl_FSFileAttrStringsProc NativeFileAttrStrings;
+static Tcl_FSFileAttrsGetProc NativeFileAttrsGet;
+static Tcl_FSFileAttrsSetProc NativeFileAttrsSet;
+static Tcl_FSLoadFileProc NativeLoadFile;
+static Tcl_FSOpenFileChannelProc NativeOpenFileChannel;
+static Tcl_FSUtimeProc NativeUtime;
-static AccessProc defaultAccessProc = {
- &TclpAccess, NULL
+/*
+ * The only reason these functions are not static is that they
+ * are either called by code in the native (win/unix/mac) directories
+ * or they are actually implemented in those directories. They
+ * should simply not be called by code outside Tcl's native
+ * filesystem core. i.e. they should be considered 'static' to
+ * Tcl's filesystem code (if we ever built the native filesystem
+ * support into a separate code library, this could actually be
+ * enforced).
+ */
+Tcl_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_FSReadlinkProc TclpObjReadlink;
+Tcl_FSListVolumesProc TclpListVolumes;
+
+/* Define the native filesystem dispatch table */
+static Tcl_Filesystem nativeFilesystem = {
+ "native",
+ sizeof(Tcl_Filesystem),
+ TCL_FILESYSTEM_VERSION_1,
+ &NativePathInFilesystem,
+ &NativeDupInternalRep,
+ &NativeFreeInternalRep,
+ &TclpNativeToNormalized,
+ &NativeCreateNativeRep,
+ &TclpObjNormalizePath,
+ &NativeFilesystemPathType,
+ &NativeFilesystemSeparator,
+ &TclpObjStat,
+ &TclpObjAccess,
+ &NativeOpenFileChannel,
+ &TclpMatchInDirectory,
+ &NativeUtime,
+#ifndef S_IFLNK
+ NULL,
+#else
+ &TclpObjReadlink,
+#endif /* S_IFLNK */
+ &TclpListVolumes,
+ &NativeFileAttrStrings,
+ &NativeFileAttrsGet,
+ &NativeFileAttrsSet,
+ &TclpObjCreateDirectory,
+ &TclpObjRemoveDirectory,
+ &TclpObjDeleteFile,
+ &TclpObjLstat,
+ &TclpObjCopyFile,
+ &TclpObjRenameFile,
+ &TclpObjCopyDirectory,
+ &NativeLoadFile,
+ &TclpUnloadFile,
+ &TclpObjGetCwd,
+ &TclpObjChdir
};
-static AccessProc *accessProcList = &defaultAccessProc;
-static OpenFileChannelProc defaultOpenFileChannelProc = {
- &TclpOpenFileChannel, NULL
+/*
+ * 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.
+ */
+static FilesystemRecord nativeFilesystemRecord = {
+ NULL,
+ &nativeFilesystem,
+ 1,
+ NULL
};
-static OpenFileChannelProc *openFileChannelProcList =
- &defaultOpenFileChannelProc;
-TCL_DECLARE_MUTEX(hookMutex)
+/*
+ * The following few variables are protected by the
+ * filesystemMutex just below.
+ */
+
+/*
+ * 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.
+ */
+int filesystemEpoch = 0;
+/* Stores the linked list of filesystems.*/
+static FilesystemRecord *filesystemList = &nativeFilesystemRecord;
+/*
+ * The number of loops which are currently iterating over the linked
+ * list. If this is greater than zero, we can't modify the list.
+ */
+int filesystemIteratorsInProgress = 0;
+/* Someone wants to modify the list of filesystems if this is set. */
+int filesystemWantToModify = 0;
+
+Tcl_Condition filesystemOkToModify = NULL;
+
+TCL_DECLARE_MUTEX(filesystemMutex)
+
+/*
+ * 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 {
+ char *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. */
+ 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;
+
+/*
+ * Used to implement Tcl_FSGetCwd in a file-system independent way.
+ * This is protected by the cwdMutex below.
+ */
+static Tcl_Obj* cwdPathPtr = NULL;
+TCL_DECLARE_MUTEX(cwdMutex)
+
+/*
+ * Declare fallback support function and
+ * information for Tcl_FSLoadFile
+ */
+static Tcl_FSUnloadFileProc FSUnloadTempFile;
+
+/*
+ * One of these structures is used each time we successfully load a
+ * file from a file system by way of making a temporary copy of the
+ * file on the native filesystem. We need to store both the actual
+ * unloadProc/clientData combination which was used, and the original
+ * and modified filenames, so that we can correctly undo the entire
+ * operation when we want to unload the code.
+ */
+typedef struct FsDivertLoad {
+ ClientData clientData;
+ Tcl_FSUnloadFileProc *unloadProcPtr;
+ Tcl_Obj *divertedFile;
+} FsDivertLoad;
+
+/* Now move on to the basic filesystem implementation */
+
+
+static int
+FsCwdPointerEquals(objPtr)
+ Tcl_Obj* objPtr;
+{
+ Tcl_MutexLock(&cwdMutex);
+ if (cwdPathPtr == objPtr) {
+ Tcl_MutexUnlock(&cwdMutex);
+ return 1;
+ } else {
+ Tcl_MutexUnlock(&cwdMutex);
+ return 0;
+ }
+}
+
+
+static FilesystemRecord*
+FsGetIterator(void) {
+ Tcl_MutexLock(&filesystemMutex);
+ filesystemIteratorsInProgress++;
+ Tcl_MutexUnlock(&filesystemMutex);
+ /* Now we know the list of filesystems cannot be modified */
+ return filesystemList;
+}
+
+static void
+FsReleaseIterator(void) {
+ Tcl_MutexLock(&filesystemMutex);
+ filesystemIteratorsInProgress--;
+ if (filesystemIteratorsInProgress == 0) {
+ /* Notify any waiting threads that things are ok now */
+ if (filesystemWantToModify > 0) {
+ Tcl_ConditionNotify(&filesystemOkToModify);
+ }
+ }
+ Tcl_MutexUnlock(&filesystemMutex);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 TclFilesystemData to
+ * check if it is in the list, provided the ClientData used was
+ * not NULL).
+ *
+ * Note that the filesystem handling is head-to-tail of the list.
+ * Each filesystem is asked in turn whether it can handle a
+ * particular request, _until_ one of them says 'yes'. At that
+ * point no further filesystems are asked.
+ *
+ * In particular this means if you want to add a diagnostic
+ * filesystem (which simply reports all fs activity), it must be
+ * at the head of the list: i.e. it must be the last registered.
+ *
+ * Results:
+ * Normally TCL_OK; TCL_ERROR if memory for a new node in the list
+ * could not be allocated.
+ *
+ * Side effects:
+ * Memory allocataed and modifies the link list for filesystems.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_FSRegister(clientData, fsPtr)
+ ClientData clientData; /* Client specific data for this fs */
+ Tcl_Filesystem *fsPtr; /* The filesystem record for the new fs. */
+{
+ FilesystemRecord *newFilesystemPtr;
+
+ if (fsPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ newFilesystemPtr = (FilesystemRecord *)
+ ckalloc(sizeof(FilesystemRecord));
+
+ newFilesystemPtr->clientData = clientData;
+ newFilesystemPtr->fsPtr = fsPtr;
+
+ /*
+ * Is this lock and wait strictly speaking necessary? Since any
+ * iterators out there will have grabbed a copy of the head of
+ * the list and be iterating away from that, if we add a new
+ * element to the head of the list, it can't possibly have any
+ * effect on any of their loops. In fact it could be better not
+ * to wait, since we are adjusting the filesystem epoch, any
+ * cached representations calculated by existing iterators are
+ * going to have to be thrown away anyway.
+ *
+ * However, since registering and unregistering filesystems is
+ * a very rare action, this is not a very important point.
+ */
+ Tcl_MutexLock(&filesystemMutex);
+ filesystemWantToModify++;
+ Tcl_ConditionWait(&filesystemOkToModify, &filesystemMutex, NULL);
+ filesystemWantToModify--;
+
+ newFilesystemPtr->nextPtr = filesystemList;
+ filesystemList = newFilesystemPtr;
+ /*
+ * Increment the filesystem epoch counter, since existing paths
+ * might conceivably now belong to different filesystems.
+ */
+ filesystemEpoch++;
+ Tcl_MutexUnlock(&filesystemMutex);
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSUnregister --
+ *
+ * Remove the passed filesystem from the list of filesystem
+ * function tables. It also ensures that the built-in
+ * (native) filesystem is not removable, although we may wish
+ * to change that decision in the future to allow a smaller
+ * Tcl core, in which the native filesystem is not used at
+ * all (we could, say, initialise Tcl completely over a network
+ * connection).
+ *
+ * Results:
+ * TCL_OK if the procedure pointer was successfully removed,
+ * TCL_ERROR otherwise.
+ *
+ * Side effects:
+ * Memory is deallocated and the respective list updated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_FSUnregister(fsPtr)
+ Tcl_Filesystem *fsPtr; /* The filesystem record to remove. */
+{
+ int retVal = TCL_ERROR;
+ FilesystemRecord *tmpFsRecPtr;
+ FilesystemRecord *prevFsRecPtr = NULL;
+
+ Tcl_MutexLock(&filesystemMutex);
+ filesystemWantToModify++;
+ Tcl_ConditionWait(&filesystemOkToModify, &filesystemMutex, NULL);
+ filesystemWantToModify--;
+ tmpFsRecPtr = filesystemList;
+ /*
+ * Traverse the 'filesystemList' looking for the particular node
+ * whose 'fsPtr' member matches 'fsPtr' and remove that one from
+ * the list. Ensure that the "default" node cannot be removed.
+ */
+
+ while ((retVal == TCL_ERROR) && (tmpFsRecPtr != &nativeFilesystemRecord)) {
+ if (tmpFsRecPtr->fsPtr == fsPtr) {
+ if (prevFsRecPtr == NULL) {
+ filesystemList = filesystemList->nextPtr;
+ } else {
+ prevFsRecPtr->nextPtr = tmpFsRecPtr->nextPtr;
+ }
+ /*
+ * 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).
+ */
+ filesystemEpoch++;
+
+ ckfree((char *)tmpFsRecPtr);
+
+ retVal = TCL_OK;
+ } else {
+ prevFsRecPtr = tmpFsRecPtr;
+ tmpFsRecPtr = tmpFsRecPtr->nextPtr;
+ }
+ }
+
+ Tcl_MutexUnlock(&filesystemMutex);
+ return (retVal);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSData --
+ *
+ * Retrieve the clientData field for the filesystem given,
+ * or NULL if that filesystem is not registered.
+ *
+ * Results:
+ * A clientData value, or NULL. Note that if the filesystem
+ * was registered with a NULL clientData field, this function
+ * will return that NULL value.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ClientData
+Tcl_FSData(fsPtr)
+ Tcl_Filesystem *fsPtr; /* The filesystem record to query. */
+{
+ ClientData retVal = NULL;
+ FilesystemRecord *tmpFsRecPtr;
+
+ tmpFsRecPtr = FsGetIterator();
+ /*
+ * Traverse the 'filesystemList' looking for the particular node
+ * whose 'fsPtr' member matches 'fsPtr' and remove that one from
+ * the list. Ensure that the "default" node cannot be removed.
+ */
+
+ while ((retVal == NULL) && (tmpFsRecPtr != NULL)) {
+ if (tmpFsRecPtr->fsPtr == fsPtr) {
+ retVal = tmpFsRecPtr->clientData;
+ }
+ tmpFsRecPtr = tmpFsRecPtr->nextPtr;
+ }
+
+ FsReleaseIterator();
+ return (retVal);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * FSNormalizeAbsolutePath --
+ *
+ * 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*
+FSNormalizeAbsolutePath(interp, path)
+ Tcl_Interp* interp; /* Interpreter to use */
+ char *path; /* Absolute path to normalize (UTF-8) */
+{
+ char **sp = NULL, *np[BUFSIZ];
+ int splen = 0, nplen, i;
+ Tcl_Obj *retVal;
+
+ Tcl_SplitPath(path, &splen, &sp);
+
+ nplen = 0;
+ for (i = 0;i < splen;i++) {
+ if (strcmp(sp[i], ".") == 0)
+ continue;
+
+ if (strcmp(sp[i], "..") == 0) {
+ if (nplen > 1) nplen--;
+ } else {
+ np[nplen++] = sp[i];
+ }
+ }
+ if (nplen > 0) {
+ Tcl_DString dtemp;
+ Tcl_DStringInit(&dtemp);
+ Tcl_JoinPath(nplen, np, &dtemp);
+ /*
+ * 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.
+ */
+ retVal = Tcl_NewStringObj(Tcl_DStringValue(&dtemp),-1);
+ Tcl_DStringFree(&dtemp);
+ Tcl_IncrRefCount(retVal);
+ TclNormalizeToUniquePath(interp, retVal);
+ /*
+ * Since we know it is a normalized path, we can
+ * actually convert this object into an FsPath for
+ * greater efficiency
+ */
+ SetFsPathFromAbsoluteNormalized(interp, retVal);
+ } else {
+ /* Init to an empty string */
+ retVal = Tcl_NewStringObj("",0);
+ Tcl_IncrRefCount(retVal);
+ }
+ ckfree((char*) sp);
+
+ /* This has a refCount of 1 for the caller */
+ return retVal;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclNormalizeToUniquePath --
+ *
+ * Description:
+ * Takes a path specification containing no ../, ./ sequences,
+ * and converts it into a unique path for the given platform.
+ * On MacOS, Unix, this means the path must be free of
+ * symbolic links/aliases, and on Windows it means we want the
+ * long form, with that long form's case-dependence (which gives
+ * us a unique, case-dependent path).
+ *
+ * Results:
+ * The 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 is only used by the above function. Also 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.
+ *
+ *---------------------------------------------------------------------------
+ */
+static int
+TclNormalizeToUniquePath(interp, pathPtr)
+ Tcl_Interp *interp;
+ Tcl_Obj *pathPtr;
+{
+ FilesystemRecord *fsRecPtr;
+ int retVal = 0;
+
+ /*
+ * 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).
+ */
+
+ fsRecPtr = FsGetIterator();
+ while (fsRecPtr != NULL) {
+ if (fsRecPtr == &nativeFilesystemRecord) {
+ Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;
+ if (proc != NULL) {
+ retVal = (*proc)(interp, pathPtr, retVal);
+ }
+ break;
+ }
+ fsRecPtr = fsRecPtr->nextPtr;
+ }
+ FsReleaseIterator();
+
+ fsRecPtr = FsGetIterator();
+ while (fsRecPtr != NULL) {
+ /* Skip the native system next time through */
+ if (fsRecPtr != &nativeFilesystemRecord) {
+ Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;
+ if (proc != NULL) {
+ retVal = (*proc)(interp, pathPtr, retVal);
+ }
+ /*
+ * We could add an efficiency check like this:
+ *
+ * if (retVal == Tcl_DStringLength(pathPtr)) {break;}
+ *
+ * but there's not much benefit.
+ */
+ }
+ fsRecPtr = fsRecPtr->nextPtr;
+ }
+ FsReleaseIterator();
+
+ return (retVal);
+}
/*
*---------------------------------------------------------------------------
@@ -255,7 +1046,7 @@ TclGetOpenMode(interp, string, seekFlagPtr)
/*
*----------------------------------------------------------------------
*
- * Tcl_EvalFile --
+ * Tcl_FSEvalFile --
*
* Read in a file and process the entire file as one gigantic
* Tcl command.
@@ -265,44 +1056,47 @@ TclGetOpenMode(interp, string, seekFlagPtr)
* the file or an error indicating why the file couldn't be read.
*
* Side effects:
- * Depends on the commands in the file.
+ * Depends on the commands in the file. During the evaluation
+ * of the contents of the file, iPtr->scriptFile is made to
+ * point to fileName (the old value is cached and replaced when
+ * this function returns).
*
*----------------------------------------------------------------------
*/
int
-Tcl_EvalFile(interp, fileName)
+Tcl_FSEvalFile(interp, fileName)
Tcl_Interp *interp; /* Interpreter in which to process file. */
- char *fileName; /* Name of file to process. Tilde-substitution
+ Tcl_Obj *fileName; /* Name of file to process. Tilde-substitution
* will be performed on this name. */
{
int result, length;
struct stat statBuf;
- char *oldScriptFile;
+ Tcl_Obj *oldScriptFile;
Interp *iPtr;
- Tcl_DString nameString;
- char *name, *string;
+ char *string;
Tcl_Channel chan;
Tcl_Obj *objPtr;
- name = Tcl_TranslateFileName(interp, fileName, &nameString);
- if (name == NULL) {
+ if (Tcl_FSGetTranslatedPath(interp, fileName) == NULL) {
return TCL_ERROR;
}
result = TCL_ERROR;
objPtr = Tcl_NewObj();
- if (TclStat(name, &statBuf) == -1) {
+ if (Tcl_FSStat(fileName, &statBuf) == -1) {
Tcl_SetErrno(errno);
- Tcl_AppendResult(interp, "couldn't read file \"", fileName,
+ Tcl_AppendResult(interp, "couldn't read file \"",
+ Tcl_GetString(fileName),
"\": ", Tcl_PosixError(interp), (char *) NULL);
goto end;
}
- chan = Tcl_OpenFileChannel(interp, name, "r", 0644);
+ chan = Tcl_FSOpenFileChannel(interp, fileName, "r", 0644);
if (chan == (Tcl_Channel) NULL) {
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "couldn't read file \"", fileName,
+ Tcl_AppendResult(interp, "couldn't read file \"",
+ Tcl_GetString(fileName),
"\": ", Tcl_PosixError(interp), (char *) NULL);
goto end;
}
@@ -314,7 +1108,8 @@ Tcl_EvalFile(interp, fileName)
Tcl_SetChannelOption(interp, chan, "-eofchar", "\32");
if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) {
Tcl_Close(interp, chan);
- Tcl_AppendResult(interp, "couldn't read file \"", fileName,
+ Tcl_AppendResult(interp, "couldn't read file \"",
+ Tcl_GetString(fileName),
"\": ", Tcl_PosixError(interp), (char *) NULL);
goto end;
}
@@ -324,11 +1119,18 @@ Tcl_EvalFile(interp, fileName)
iPtr = (Interp *) interp;
oldScriptFile = iPtr->scriptFile;
- iPtr->scriptFile = ckalloc((unsigned) (strlen(fileName) + 1));
- strcpy(iPtr->scriptFile, fileName);
+ iPtr->scriptFile = fileName;
+ Tcl_IncrRefCount(iPtr->scriptFile);
string = Tcl_GetStringFromObj(objPtr, &length);
result = Tcl_EvalEx(interp, string, length, 0);
- ckfree(iPtr->scriptFile);
+ /*
+ * 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 'fileName'.
+ */
+ if (iPtr->scriptFile != NULL) {
+ Tcl_DecrRefCount(iPtr->scriptFile);
+ }
iPtr->scriptFile = oldScriptFile;
if (result == TCL_RETURN) {
@@ -340,14 +1142,13 @@ Tcl_EvalFile(interp, fileName)
* Record information telling where the error occurred.
*/
- sprintf(msg, "\n (file \"%.150s\" line %d)", fileName,
+ sprintf(msg, "\n (file \"%.150s\" line %d)", Tcl_GetString(fileName),
interp->errorLine);
Tcl_AddErrorInfo(interp, msg);
}
end:
Tcl_DecrRefCount(objPtr);
- Tcl_DStringFree(&nameString);
return result;
}
@@ -435,12 +1236,12 @@ Tcl_PosixError(interp)
/*
*----------------------------------------------------------------------
*
- * TclStat --
+ * Tcl_FSStat --
*
* This procedure replaces the library version of stat and lsat.
- * The chain of functions that have been "inserted" into the
- * 'statProcList' will be called in succession until either
- * a value of zero is returned, or the entire list is visited.
+ *
+ * The appropriate function for the filesystem to which pathPtr
+ * belongs will be called.
*
* Results:
* See stat documentation.
@@ -452,38 +1253,94 @@ Tcl_PosixError(interp)
*/
int
-TclStat(path, buf)
- CONST char *path; /* Path of file to stat (in current CP). */
+Tcl_FSStat(pathPtr, buf)
+ Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */
struct stat *buf; /* Filled with results of stat call. */
{
+#ifdef USE_OBSOLETE_FS_HOOKS
StatProc *statProcPtr;
int retVal = -1;
+#endif /* USE_OBSOLETE_FS_HOOKS */
+ Tcl_Filesystem *fsPtr;
+ char *path = Tcl_FSGetTranslatedPath(NULL, pathPtr);
/*
* Call each of the "stat" function in succession. A non-return
* value of -1 indicates the particular function has succeeded.
*/
- Tcl_MutexLock(&hookMutex);
+#ifdef USE_OBSOLETE_FS_HOOKS
+ Tcl_MutexLock(&obsoleteFsHookMutex);
statProcPtr = statProcList;
while ((retVal == -1) && (statProcPtr != NULL)) {
retVal = (*statProcPtr->proc)(path, buf);
statProcPtr = statProcPtr->nextPtr;
}
- Tcl_MutexUnlock(&hookMutex);
+ Tcl_MutexUnlock(&obsoleteFsHookMutex);
+ if (retVal != -1) {
+ return retVal;
+ }
+#endif /* USE_OBSOLETE_FS_HOOKS */
+ fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSStatProc *proc = fsPtr->statProc;
+ if (proc != NULL) {
+ return (*proc)(pathPtr, buf);
+ }
+ }
+ Tcl_SetErrno(ENOENT);
+ return -1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSLstat --
+ *
+ * This procedure replaces the library version of lstat.
+ * The appropriate function for the filesystem to which pathPtr
+ * belongs will be called. If no 'lstat' function is listed,
+ * but a 'stat' function is, then Tcl will fall back on the
+ * stat function.
+ *
+ * Results:
+ * See lstat documentation.
+ *
+ * Side effects:
+ * See lstat documentation.
+ *
+ *----------------------------------------------------------------------
+ */
- return (retVal);
+int
+Tcl_FSLstat(pathPtr, buf)
+ Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */
+ struct stat *buf; /* Filled with results of stat call. */
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSLstatProc *proc = fsPtr->lstatProc;
+ if (proc != NULL) {
+ return (*proc)(pathPtr, buf);
+ } else {
+ Tcl_FSStatProc *sproc = fsPtr->statProc;
+ if (sproc != NULL) {
+ return (*sproc)(pathPtr, buf);
+ }
+ }
+ }
+ Tcl_SetErrno(ENOENT);
+ return -1;
}
/*
*----------------------------------------------------------------------
*
- * TclAccess --
+ * Tcl_FSAccess --
*
* This procedure replaces the library version of access.
- * The chain of functions that have been "inserted" into the
- * 'accessProcList' will be called in succession until either
- * a value of zero is returned, or the entire list is visited.
+ * The appropriate function for the filesystem to which pathPtr
+ * belongs will be called.
*
* Results:
* See access documentation.
@@ -495,38 +1352,53 @@ TclStat(path, buf)
*/
int
-TclAccess(path, mode)
- CONST char *path; /* Path of file to access (in current CP). */
+Tcl_FSAccess(pathPtr, mode)
+ Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */
int mode; /* Permission setting. */
{
+#ifdef USE_OBSOLETE_FS_HOOKS
AccessProc *accessProcPtr;
int retVal = -1;
+#endif /* USE_OBSOLETE_FS_HOOKS */
+ Tcl_Filesystem *fsPtr;
+ char *path = Tcl_FSGetTranslatedPath(NULL, pathPtr);
/*
* Call each of the "access" function in succession. A non-return
* value of -1 indicates the particular function has succeeded.
*/
- Tcl_MutexLock(&hookMutex);
+#ifdef USE_OBSOLETE_FS_HOOKS
+ Tcl_MutexLock(&obsoleteFsHookMutex);
accessProcPtr = accessProcList;
while ((retVal == -1) && (accessProcPtr != NULL)) {
retVal = (*accessProcPtr->proc)(path, mode);
accessProcPtr = accessProcPtr->nextPtr;
}
- Tcl_MutexUnlock(&hookMutex);
+ Tcl_MutexUnlock(&obsoleteFsHookMutex);
+ if (retVal != -1) {
+ return retVal;
+ }
+#endif /* USE_OBSOLETE_FS_HOOKS */
+ fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSAccessProc *proc = fsPtr->accessProc;
+ if (proc != NULL) {
+ return (*proc)(pathPtr, mode);
+ }
+ }
- return (retVal);
+ Tcl_SetErrno(ENOENT);
+ return -1;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_OpenFileChannel --
+ * Tcl_FSOpenFileChannel --
*
- * The chain of functions that have been "inserted" into the
- * 'openFileChannelProcList' will be called in succession until
- * either a valid file channel is returned, or the entire list is
- * visited.
+ * 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.
@@ -539,18 +1411,25 @@ TclAccess(path, mode)
*/
Tcl_Channel
-Tcl_OpenFileChannel(interp, fileName, modeString, permissions)
+Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
- char *fileName; /* Name of file to open. */
+ Tcl_Obj *pathPtr; /* Name of file to open. */
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? */
{
+#ifdef USE_OBSOLETE_FS_HOOKS
OpenFileChannelProc *openFileChannelProcPtr;
Tcl_Channel retVal = NULL;
+#endif /* USE_OBSOLETE_FS_HOOKS */
+ Tcl_Filesystem *fsPtr;
+ char *path = Tcl_FSGetTranslatedPath(interp, pathPtr);
+ if (path == NULL) {
+ return NULL;
+ }
/*
* Call each of the "Tcl_OpenFileChannel" function in succession.
@@ -558,21 +1437,2413 @@ Tcl_OpenFileChannel(interp, fileName, modeString, permissions)
* succeeded.
*/
- Tcl_MutexLock(&hookMutex);
+#ifdef USE_OBSOLETE_FS_HOOKS
+ Tcl_MutexLock(&obsoleteFsHookMutex);
openFileChannelProcPtr = openFileChannelProcList;
while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) {
- retVal = (*openFileChannelProcPtr->proc)(interp, fileName,
+ retVal = (*openFileChannelProcPtr->proc)(interp, path,
modeString, permissions);
openFileChannelProcPtr = openFileChannelProcPtr->nextPtr;
}
- Tcl_MutexUnlock(&hookMutex);
+ Tcl_MutexUnlock(&obsoleteFsHookMutex);
+ if (retVal != NULL) {
+ return retVal;
+ }
+#endif /* USE_OBSOLETE_FS_HOOKS */
+ fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc;
+ if (proc != NULL) {
+ return (*proc)(interp, pathPtr, modeString, permissions);
+ }
+ }
+ return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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, and then remove it
+ * from the results returned. This makes filesystems easy to
+ * write, since they can assume the pathPtr passed to them
+ * is an ordinary path. In fact this means we could remove such
+ * special case handling from Tcl's native filesystems.
+ *
+ * Results:
+ *
+ * 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.
+ *
+ * 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. */
+ char *pattern; /* Pattern to match against. */
+ Tcl_GlobTypeData *types; /* Object containing list of acceptable types.
+ * May be NULL. In particular the directory
+ * flag is very important. */
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc;
+ if (proc != NULL) {
+ return (*proc)(interp, result, pathPtr, pattern, types);
+ }
+ } else {
+ Tcl_Obj* cwd;
+ int ret;
+ 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
+ */
+ return -1;
+ }
+ }
+ /*
+ * We have a null string, this means we must use the 'cwd', and
+ * then manipulate the result. We must deal with this here,
+ * since if we don't, every single filesystem's implementation
+ * of Tcl_FSMatchInDirectory will have to deal with it for us.
+ */
+ cwd = Tcl_FSGetCwd(NULL);
+ if (cwd == NULL) {
+ if (interp != NULL) {
+ Tcl_SetResult(interp, "glob couldn't determine"
+ "the current working directory", TCL_STATIC);
+ }
+ return TCL_ERROR;
+ }
+ fsPtr = Tcl_FSGetFileSystemForPath(cwd);
+ if (fsPtr != NULL) {
+ Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc;
+ if (proc != NULL) {
+ int cwdLen;
+ Tcl_Obj *cwdDir;
+ Tcl_Obj* tmpResultPtr = Tcl_NewListObj(0, NULL);
+ /*
+ * We know the cwd is a normalised object which does
+ * not end in a directory delimiter.
+ */
+ cwdDir = Tcl_DuplicateObj(cwd);
+ #ifdef MAC_TCL
+ Tcl_AppendToObj(cwdDir, ":", 1);
+ #else
+ Tcl_AppendToObj(cwdDir, "/", 1);
+ #endif
+ Tcl_GetStringFromObj(cwdDir, &cwdLen);
+ Tcl_IncrRefCount(cwdDir);
+ ret = (*proc)(interp, tmpResultPtr, cwdDir, pattern, types);
+ Tcl_DecrRefCount(cwdDir);
+ if (ret == TCL_OK) {
+ int resLength;
+ ret = Tcl_ListObjLength(interp, tmpResultPtr, &resLength);
+ if (ret == TCL_OK) {
+ int i;
+ for (i =0; i< resLength; i++) {
+ Tcl_Obj *elt, *cutElt;
+ char *eltStr;
+ int eltLen;
+ Tcl_ListObjIndex(interp, tmpResultPtr, i, &elt);
+ eltStr = Tcl_GetStringFromObj(elt,&eltLen);
+ cutElt = Tcl_NewStringObj(eltStr + cwdLen, eltLen - cwdLen);
+ Tcl_ListObjAppendElement(interp, result, cutElt);
+ }
+ }
+ }
+ Tcl_DecrRefCount(tmpResultPtr);
+ }
+ }
+ Tcl_DecrRefCount(cwd);
+ return ret;
+ }
+ return -1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSGetCwd --
+ *
+ * This function replaces the library version of getcwd().
+ *
+ * Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains
+ * its own record (in a Tcl_Obj) of the cwd, and an attempt
+ * is made to synchronise this with the cwd's containing filesystem,
+ * if that filesystem provides a cwdProc (e.g. the native filesystem).
+ *
+ * Note that if Tcl's cwd is not in the native filesystem, then of
+ * course Tcl's cwd and the native cwd are different: extensions
+ * should therefore ensure they only access the cwd through this
+ * function to avoid confusion.
+ *
+ * If a global cwdPathPtr already exists, it is returned, subject
+ * to a synchronisation attempt in that cwdPathPtr's fs.
+ * Otherwise, the chain of functions that have been "inserted"
+ * into the filesystem will be called in succession until either a
+ * value other than NULL is returned, or the entire list is
+ * visited.
+ *
+ * Results:
+ * The result is a pointer to a Tcl_Obj specifying the current
+ * directory, or NULL if the current directory could not be
+ * determined. If NULL is returned, an error message is left in the
+ * interp's result.
+ *
+ * The result already has its refCount incremented for the caller.
+ * When it is no longer needed, that refCount should be decremented.
+ * This is needed for thread-safety purposes, to allow multiple
+ * threads to access this and related functions, while ensuring the
+ * results are always valid.
+ *
+ * Of course it is probably a bad idea for multiple threads to
+ * be *setting* the cwd anyway, but we can at least try to
+ * help the case of multiple reads with occasional sets.
+ *
+ * Side effects:
+ * Various objects may be freed and allocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+Tcl_FSGetCwd(interp)
+ Tcl_Interp *interp;
+{
+ Tcl_Obj *cwdToReturn;
+
+ if (FsCwdPointerEquals(NULL)) {
+ FilesystemRecord *fsRecPtr;
+ Tcl_Obj *retVal = NULL;
+
+ /*
+ * We've never been called before, try to find a cwd. Call
+ * each of the "Tcl_GetCwd" function in succession. A non-NULL
+ * return value indicates the particular function has
+ * succeeded.
+ */
+
+ fsRecPtr = FsGetIterator();
+ while ((retVal == NULL) && (fsRecPtr != NULL)) {
+ Tcl_FSGetCwdProc *proc = fsRecPtr->fsPtr->getCwdProc;
+ if (proc != NULL) {
+ retVal = (*proc)(interp);
+ }
+ fsRecPtr = fsRecPtr->nextPtr;
+ }
+ FsReleaseIterator();
+ /*
+ * 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 = FSNormalizeAbsolutePath(interp,
+ Tcl_GetString(retVal));
+ if (norm != NULL) {
+ /*
+ * We found a cwd, which is now in our global storage.
+ * We must make a copy. Norm already has a refCount of
+ * 1.
+ *
+ * Threading issue: note that multiple threads at system
+ * startup could in principle call this 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.
+ */
+ Tcl_MutexLock(&cwdMutex);
+ /* Just in case the pointer has been set by another
+ * thread between now and the test above */
+ if (cwdPathPtr != NULL) {
+ Tcl_DecrRefCount(cwdPathPtr);
+ }
+ cwdPathPtr = norm;
+ Tcl_MutexUnlock(&cwdMutex);
+ }
+ Tcl_DecrRefCount(retVal);
+ }
+ } else {
+ /*
+ * We already have a cwd cached, but we want to give the
+ * filesystem it is in a chance to check whether that cwd
+ * has changed, or is perhaps no longer accessible. This
+ * allows an error to be thrown if, say, the permissions on
+ * that directory have changed.
+ */
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(cwdPathPtr);
+ /*
+ * If the filesystem couldn't be found, or if no cwd function
+ * exists for this filesystem, then we simply assume the cached
+ * cwd is ok. If we do call a cwd, we must watch for errors
+ * (if the cwd returns NULL). This ensures that, say, on Unix
+ * if the permissions of the cwd change, 'pwd' does actually
+ * throw the correct error in Tcl. (This is tested for in the
+ * test suite on unix).
+ */
+ if (fsPtr != NULL) {
+ Tcl_FSGetCwdProc *proc = fsPtr->getCwdProc;
+ if (proc != NULL) {
+ Tcl_Obj *retVal = (*proc)(interp);
+ if (retVal != NULL) {
+ Tcl_Obj *norm = FSNormalizeAbsolutePath(interp,
+ Tcl_GetString(retVal));
+ /*
+ * Check whether cwd has changed from the value
+ * previously stored in cwdPathPtr. Really 'norm'
+ * shouldn't be null, but we are careful.
+ */
+ if (norm == NULL) {
+ /* Do nothing */
+ } else if (Tcl_FSEqualPaths(cwdPathPtr, norm)) {
+ /*
+ * If the paths were equal, we can be more
+ * efficient and retain the old path object
+ * which will probably already be shared. In
+ * this case we can simply free the normalized
+ * path we just calculated.
+ */
+ Tcl_DecrRefCount(norm);
+ } else {
+ /* The cwd has in fact changed, so we must
+ * lock down the cwdMutex to modify. */
+ Tcl_MutexLock(&cwdMutex);
+ Tcl_DecrRefCount(cwdPathPtr);
+ cwdPathPtr = norm;
+ Tcl_MutexUnlock(&cwdMutex);
+ }
+ Tcl_DecrRefCount(retVal);
+ } else {
+ /* The 'cwd' function returned an error, so we
+ * reset the cwd after locking down the mutex. */
+ Tcl_MutexLock(&cwdMutex);
+ Tcl_DecrRefCount(cwdPathPtr);
+ cwdPathPtr = NULL;
+ Tcl_MutexUnlock(&cwdMutex);
+ }
+ }
+ }
+ }
+
+ /*
+ * The paths all eventually fall through to here. Note that
+ * we use a bunch of separate mutex locks throughout this
+ * code to help prevent deadlocks between threads. Really
+ * the only weirdness will arise if multiple threads are setting
+ * and reading the cwd, and that behaviour is always going to be
+ * a little suspect.
+ */
+ Tcl_MutexLock(&cwdMutex);
+ cwdToReturn = cwdPathPtr;
+ if (cwdToReturn != NULL) {
+ Tcl_IncrRefCount(cwdToReturn);
+ }
+ Tcl_MutexUnlock(&cwdMutex);
+
+ return (cwdToReturn);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSUtime --
+ *
+ * This procedure replaces the library version of utime.
+ * The appropriate function for the filesystem to which pathPtr
+ * belongs will be called.
+ *
+ * Results:
+ * See utime documentation.
+ *
+ * Side effects:
+ * See utime documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_FSUtime (pathPtr, tval)
+ Tcl_Obj *pathPtr; /* File to change access/modification times */
+ struct utimbuf *tval; /* Structure containing access/modification
+ * times to use. Should not be modified. */
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSUtimeProc *proc = fsPtr->utimeProc;
+ if (proc != NULL) {
+ return (*proc)(pathPtr, tval);
+ }
+ }
+ return -1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NativeFileAttrStrings --
+ *
+ * This procedure implements the platform dependent 'file
+ * attributes' subcommand, for the native filesystem, for listing
+ * the set of possible attribute strings. This function is part
+ * of Tcl's native filesystem support, and is placed here because
+ * it is shared by Unix, MacOS and Windows code.
+ *
+ * Results:
+ * An array of strings
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+char**
+NativeFileAttrStrings(pathPtr, objPtrRef)
+ Tcl_Obj *pathPtr;
+ Tcl_Obj** objPtrRef;
+{
+ return tclpFileAttrStrings;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NativeFileAttrsGet --
+ *
+ * This procedure implements the platform dependent
+ * 'file attributes' subcommand, for the native
+ * filesystem, for 'get' operations. This function is part
+ * of Tcl's native filesystem support, and is placed here
+ * because it is shared by Unix, MacOS and Windows code.
+ *
+ * Results:
+ * Standard Tcl return code. The object placed in objPtrRef
+ * (if TCL_OK was returned) is likely to have a refCount of zero.
+ * Either way we must either store it somewhere (e.g. the Tcl
+ * result), or Incr/Decr its refCount to ensure it is properly
+ * freed.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+NativeFileAttrsGet(interp, index, fileName, objPtrRef)
+ Tcl_Interp *interp; /* The interpreter for error reporting. */
+ int index; /* index of the attribute command. */
+ Tcl_Obj *fileName; /* filename we are operating on. */
+ Tcl_Obj **objPtrRef; /* for output. */
+{
+ return (*tclpFileAttrProcs[index].getProc)(interp, index,
+ Tcl_FSGetTranslatedPath(NULL, fileName),
+ objPtrRef);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NativeFileAttrsSet --
+ *
+ * This procedure implements the platform dependent
+ * 'file attributes' subcommand, for the native
+ * filesystem, for 'set' operations. This function is part
+ * of Tcl's native filesystem support, and is placed here
+ * because it is shared by Unix, MacOS and Windows code.
+ *
+ * Results:
+ * Standard Tcl return code.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+NativeFileAttrsSet(interp, index, fileName, objPtr)
+ Tcl_Interp *interp; /* The interpreter for error reporting. */
+ int index; /* index of the attribute command. */
+ Tcl_Obj *fileName; /* filename we are operating on. */
+ Tcl_Obj *objPtr; /* set to this value. */
+{
+ return (*tclpFileAttrProcs[index].setProc)(interp, index,
+ Tcl_FSGetTranslatedPath(NULL, fileName),
+ objPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSFileAttrStrings --
+ *
+ * This procedure implements part of the hookable 'file
+ * attributes' subcommand. The appropriate function for the
+ * filesystem to which pathPtr belongs will be called.
+ *
+ * Results:
+ * The called procedure may either return an array of strings,
+ * or may instead return NULL and place a Tcl list into the
+ * given objPtrRef. Tcl will take that list and first increment
+ * its refCount before using it. On completion of that use, Tcl
+ * will decrement its refCount. Hence if the list should be
+ * disposed of by Tcl when done, it should have a refCount of zero,
+ * and if the list should not be disposed of, the filesystem
+ * should ensure it retains a refCount on the object.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char**
+Tcl_FSFileAttrStrings(pathPtr, objPtrRef)
+ Tcl_Obj* pathPtr;
+ Tcl_Obj** objPtrRef;
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc;
+ if (proc != NULL) {
+ return (*proc)(pathPtr, objPtrRef);
+ }
+ }
+ return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSFileAttrsGet --
+ *
+ * This procedure implements read access for the hookable 'file
+ * attributes' subcommand. The appropriate function for the
+ * filesystem to which pathPtr belongs will be called.
+ *
+ * Results:
+ * Standard Tcl return code. The object placed in objPtrRef
+ * (if TCL_OK was returned) is likely to have a refCount of zero.
+ * Either way we must either store it somewhere (e.g. the Tcl
+ * result), or Incr/Decr its refCount to ensure it is properly
+ * freed.
+
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_FSFileAttrsGet(interp, index, pathPtr, objPtrRef)
+ Tcl_Interp *interp; /* The interpreter for error reporting. */
+ int index; /* index of the attribute command. */
+ Tcl_Obj *pathPtr; /* filename we are operating on. */
+ Tcl_Obj **objPtrRef; /* for output. */
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSFileAttrsGetProc *proc = fsPtr->fileAttrsGetProc;
+ if (proc != NULL) {
+ return (*proc)(interp, index, pathPtr, objPtrRef);
+ }
+ }
+ return -1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSFileAttrsSet --
+ *
+ * This procedure implements write access for the hookable 'file
+ * attributes' subcommand. The appropriate function for the
+ * filesystem to which pathPtr belongs will be called.
+ *
+ * Results:
+ * Standard Tcl return code.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr)
+ Tcl_Interp *interp; /* The interpreter for error reporting. */
+ int index; /* index of the attribute command. */
+ Tcl_Obj *pathPtr; /* filename we are operating on. */
+ Tcl_Obj *objPtr; /* Input value. */
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSFileAttrsSetProc *proc = fsPtr->fileAttrsSetProc;
+ if (proc != NULL) {
+ return (*proc)(interp, index, pathPtr, objPtr);
+ }
+ }
+ return -1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSChdir --
+ *
+ * This function replaces the library version of chdir().
+ *
+ * The path is normalized and then passed to the filesystem
+ * which claims it.
+ *
+ * Results:
+ * See chdir() documentation. If successful, we keep a
+ * record of the successful path in cwdPathPtr for subsequent
+ * calls to getcwd.
+ *
+ * Side effects:
+ * See chdir() documentation. The global cwdPathPtr may
+ * change value.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+Tcl_FSChdir(pathPtr)
+ Tcl_Obj *pathPtr;
+{
+ Tcl_Filesystem *fsPtr;
+ int retVal = -1;
+ Tcl_Obj *normDirName;
+
+ normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (normDirName == NULL) {
+ return TCL_ERROR;
+ }
+
+ fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSChdirProc *proc = fsPtr->chdirProc;
+ if (proc != NULL) {
+ retVal = (*proc)(pathPtr);
+ } else {
+ /* Fallback on stat-based implementation */
+ struct stat buf;
+ /* If the file can be stat'ed and is a directory and
+ * is readable, then we can chdir. */
+ if ((Tcl_FSStat(pathPtr, &buf) == 0)
+ && (S_ISDIR(buf.st_mode))
+ && (Tcl_FSAccess(pathPtr, R_OK) == 0)) {
+ /* We allow the chdir */
+ retVal = 0;
+ }
+ }
+ }
+
+ if (retVal != -1) {
+ /*
+ * The cwd changed, or an error was thrown. If an error was
+ * thrown, we can just continue (and that will report the error
+ * to the user). If there was no error we must assume that the
+ * cwd was actually changed to the normalized value we
+ * calculated above, and we must therefore cache that
+ * information.
+ */
+ if (retVal == TCL_OK) {
+ /* Get a lock on the cwd while we modify it */
+ Tcl_MutexLock(&cwdMutex);
+ /* Free up the previous cwd we stored */
+ if (cwdPathPtr != NULL) {
+ Tcl_DecrRefCount(cwdPathPtr);
+ }
+ /* Now remember the current cwd */
+ cwdPathPtr = normDirName;
+ Tcl_IncrRefCount(cwdPathPtr);
+ Tcl_MutexUnlock(&cwdMutex);
+ }
+ }
+
return (retVal);
}
/*
*----------------------------------------------------------------------
*
+ * Tcl_FSLoadFile --
+ *
+ * Dynamically loads a binary code file into memory and returns
+ * the addresses of two procedures within that file, if they are
+ * defined. The appropriate function for the filesystem to which
+ * pathPtr belongs will be called.
+ *
+ * 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. We remember which
+ * filesystem loaded the code, so that we can use that filesystem's
+ * unloadProc to unload the code when that occurs.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
+ clientDataPtr, unloadProcPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Obj *pathPtr; /* Name of the file containing the desired
+ * code. */
+ char *sym1, *sym2; /* Names of two procedures to look up in
+ * the file's symbol table. */
+ Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
+ /* Where to return the addresses corresponding
+ * to sym1 and sym2. */
+ ClientData *clientDataPtr; /* Filled with token for dynamically loaded
+ * file which will be passed back to
+ * (*unloadProcPtr)() to unload the file. */
+ Tcl_FSUnloadFileProc **unloadProcPtr;
+ /* Filled with address of Tcl_FSUnloadFileProc
+ * function which should be used for
+ * this file. */
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSLoadFileProc *proc = fsPtr->loadFileProc;
+ if (proc != NULL) {
+ int retVal = (*proc)(interp, pathPtr, sym1, sym2,
+ proc1Ptr, proc2Ptr, clientDataPtr);
+ if (retVal != -1) {
+ /*
+ * We handled it. Remember which unload file
+ * proc to use.
+ */
+ (*unloadProcPtr) = fsPtr->unloadFileProc;
+ }
+ return retVal;
+ } else {
+ Tcl_Filesystem *copyFsPtr;
+ /* Get a temporary filename to use, first to
+ * copy the file into, and then to load. */
+ Tcl_Obj *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. */
+ Tcl_DecrRefCount(copyToPtr);
+ return -1;
+ }
+
+ if (Tcl_FSCopyFile(pathPtr, copyToPtr) == 0) {
+ /*
+ * Do we need to set appropriate permissions
+ * on the file? This may be required on some
+ * systems. On Unix we could do loop over
+ * the file attributes, and set any that are
+ * called "-permissions" to 0777. Or directly:
+ *
+ * Tcl_Obj* perm = Tcl_NewStringObj("0777",-1);
+ * Tcl_IncrRefCount(perm);
+ * Tcl_FSFileAttrsSet(NULL, 2, copyToPtr, perm);
+ * Tcl_DecrRefCount(perm);
+ *
+ */
+ ClientData newClientData = NULL;
+ Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL;
+ FsDivertLoad *tvdlPtr;
+ int retVal;
+
+ retVal = Tcl_FSLoadFile(interp, copyToPtr, sym1, sym2, proc1Ptr,
+ proc2Ptr, &newClientData, &newUnloadProcPtr);
+ if (retVal == -1) {
+ /* The file didn't load successfully */
+ Tcl_FSDeleteFile(copyToPtr);
+ Tcl_DecrRefCount(copyToPtr);
+ return -1;
+ }
+ /*
+ * 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->clientData = newClientData;
+ tvdlPtr->unloadProcPtr = newUnloadProcPtr;
+ /* copyToPtr is already incremented for this reference */
+ tvdlPtr->divertedFile = copyToPtr;
+ copyToPtr = NULL;
+ (*clientDataPtr) = (ClientData) tvdlPtr;
+ (*unloadProcPtr) = &FSUnloadTempFile;
+
+ return retVal;
+ }
+ }
+ }
+ return -1;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * FSUnloadTempFile --
+ *
+ * This function is called when we loaded a library of code via
+ * an intermediate temporary file. This function ensures
+ * the library is correctly unloaded and the temporary file
+ * is correctly deleted.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The effects of the 'unload' function called, and of course
+ * the temporary file will be deleted.
+ *
+ *---------------------------------------------------------------------------
+ */
+static void
+FSUnloadTempFile(clientData)
+ ClientData clientData; /* ClientData returned by a previous call
+ * to Tcl_FSLoadFile(). The clientData is
+ * a token that represents the loaded
+ * file. */
+{
+ FsDivertLoad *tvdlPtr = (FsDivertLoad*)clientData;
+ /*
+ * 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. */
+ if (tvdlPtr->unloadProcPtr != NULL) {
+ (*tvdlPtr->unloadProcPtr)(tvdlPtr->clientData);
+ }
+
+ /* Remove the temporary file we created. */
+ Tcl_FSDeleteFile(tvdlPtr->divertedFile);
+
+ /* And free up the allocations */
+ Tcl_DecrRefCount(tvdlPtr->divertedFile);
+ ckfree((char*)tvdlPtr);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSReadlink --
+ *
+ * This function replaces the library version of readlink().
+ * The appropriate function for the filesystem to which pathPtr
+ * belongs will be called.
+ *
+ * Results:
+ * The result is a Tcl_Obj specifying the contents
+ * of the symbolic link given by 'path', 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.
+ *
+ * Side effects:
+ * See readlink() documentation.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_FSReadlink(pathPtr)
+ Tcl_Obj *pathPtr; /* Path of file to readlink (UTF-8). */
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSReadlinkProc *proc = fsPtr->readlinkProc;
+ if (proc != NULL) {
+ return (*proc)(pathPtr);
+ }
+ }
+ /*
+ * 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;
+#endif /* S_IFLNK */
+ return NULL;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSListVolumes --
+ *
+ * Lists the currently mounted volumes.
+ * The chain of functions that have been "inserted" into the
+ * filesystem will be called in succession; each may add to
+ * the Tcl result, until all mounted file systems are listed.
+ *
+ * Results:
+ * A standard Tcl result. Will always be TCL_OK, since there is no way
+ * that this command can fail. Also, the interpreter's result is set to
+ * the list of volumes.
+ *
+ * Side effects:
+ * None
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_FSListVolumes(interp)
+ Tcl_Interp *interp; /* Interpreter for returning volume list. */
+{
+ FilesystemRecord *fsRecPtr;
+
+ /*
+ * 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 = FsGetIterator();
+ while (fsRecPtr != NULL) {
+ Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc;
+ if (proc != NULL) {
+ /* Ignore return value */
+ (*proc)(interp);
+ }
+ fsRecPtr = fsRecPtr->nextPtr;
+ }
+ FsReleaseIterator();
+
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSRenameFile --
+ *
+ * If the two paths given belong to the same filesystem, we call
+ * that filesystems rename function. Otherwise we simply
+ * return the posix error 'EXDEV', and -1.
+ *
+ * Results:
+ * Standard Tcl error code if a function was called.
+ *
+ * Side effects:
+ * A file may be renamed.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_FSRenameFile(srcPathPtr, destPathPtr)
+ Tcl_Obj* srcPathPtr; /* Pathname of file or dir to be renamed
+ * (UTF-8). */
+ Tcl_Obj *destPathPtr; /* New pathname of file or directory
+ * (UTF-8). */
+{
+ int retVal = -1;
+ Tcl_Filesystem *fsPtr, *fsPtr2;
+ fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
+ fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);
+
+ if (fsPtr == fsPtr2 && fsPtr != NULL) {
+ Tcl_FSRenameFileProc *proc = fsPtr->renameFileProc;
+ if (proc != NULL) {
+ retVal = (*proc)(srcPathPtr, destPathPtr);
+ }
+ }
+ if (retVal == -1) {
+ Tcl_SetErrno(EXDEV);
+ }
+ return retVal;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSCopyFile --
+ *
+ * If the two paths given belong to the same filesystem, we call
+ * that filesystem's copy function. Otherwise we simply
+ * return the posix error 'EXDEV', and -1.
+ *
+ * Results:
+ * Standard Tcl error code if a function was called.
+ *
+ * Side effects:
+ * A file may be copied.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_FSCopyFile(srcPathPtr, destPathPtr)
+ Tcl_Obj* srcPathPtr; /* Pathname of file to be copied (UTF-8). */
+ Tcl_Obj *destPathPtr; /* Pathname of file to copy to (UTF-8). */
+{
+ int retVal = -1;
+ Tcl_Filesystem *fsPtr, *fsPtr2;
+ fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
+ fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);
+
+ if (fsPtr == fsPtr2 && fsPtr != NULL) {
+ Tcl_FSCopyFileProc *proc = fsPtr->copyFileProc;
+ if (proc != NULL) {
+ retVal = (*proc)(srcPathPtr, destPathPtr);
+ }
+ }
+ if (retVal == -1) {
+ Tcl_SetErrno(EXDEV);
+ }
+ return retVal;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSDeleteFile --
+ *
+ * The appropriate function for the filesystem to which pathPtr
+ * belongs will be called.
+ *
+ * Results:
+ * Standard Tcl error code.
+ *
+ * Side effects:
+ * A file may be deleted.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_FSDeleteFile(pathPtr)
+ Tcl_Obj *pathPtr; /* Pathname of file to be removed (UTF-8). */
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSDeleteFileProc *proc = fsPtr->deleteFileProc;
+ if (proc != NULL) {
+ return (*proc)(pathPtr);
+ }
+ }
+ return -1;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSCreateDirectory --
+ *
+ * The appropriate function for the filesystem to which pathPtr
+ * belongs will be called.
+ *
+ * Results:
+ * Standard Tcl error code.
+ *
+ * Side effects:
+ * A directory may be created.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_FSCreateDirectory(pathPtr)
+ Tcl_Obj *pathPtr; /* Pathname of directory to create (UTF-8). */
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSCreateDirectoryProc *proc = fsPtr->createDirectoryProc;
+ if (proc != NULL) {
+ return (*proc)(pathPtr);
+ }
+ }
+ return -1;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSRenameFile --
+ *
+ * If the two paths given belong to the same filesystem, we call
+ * that filesystems copy-directory function. Otherwise we simply
+ * return the posix error 'EXDEV', and -1.
+ *
+ * Results:
+ * Standard Tcl error code if a function was called.
+ *
+ * Side effects:
+ * A directory may be copied.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_FSCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
+ Tcl_Obj* srcPathPtr; /* Pathname of directory to be copied
+ * (UTF-8). */
+ Tcl_Obj *destPathPtr; /* Pathname of target directory (UTF-8). */
+ Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a
+ * new object containing name of file
+ * causing error, with refCount 1. */
+{
+ int retVal = -1;
+ Tcl_Filesystem *fsPtr, *fsPtr2;
+ fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
+ fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);
+
+ if (fsPtr == fsPtr2 && fsPtr != NULL) {
+ Tcl_FSCopyDirectoryProc *proc = fsPtr->copyDirectoryProc;
+ if (proc != NULL) {
+ retVal = (*proc)(srcPathPtr, destPathPtr, errorPtr);
+ }
+ }
+ if (retVal == -1) {
+ Tcl_SetErrno(EXDEV);
+ }
+ return retVal;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSRemoveDirectory --
+ *
+ * The appropriate function for the filesystem to which pathPtr
+ * belongs will be called.
+ *
+ * Results:
+ * Standard Tcl error code.
+ *
+ * Side effects:
+ * A directory may be deleted.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr)
+ Tcl_Obj *pathPtr; /* Pathname of directory to be removed
+ * (UTF-8). */
+ int recursive; /* If non-zero, removes directories that
+ * are nonempty. Otherwise, will only remove
+ * empty directories. */
+ Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a
+ * new object containing name of file
+ * causing error, with refCount 1. */
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSRemoveDirectoryProc *proc = fsPtr->removeDirectoryProc;
+ if (proc != NULL) {
+ return (*proc)(pathPtr, recursive, errorPtr);
+ }
+ }
+ return -1;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * 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. */
+{
+ /*
+ * 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*) objPtr->internalRep.otherValuePtr;
+ if (fsPathPtr->cwdPtr == NULL) {
+ return TCL_OK;
+ } else {
+ if (FsCwdPointerEquals(fsPathPtr->cwdPtr)) {
+ return TCL_OK;
+ } else {
+ FreeFsPathInternalRep(objPtr);
+ objPtr->typePtr = NULL;
+ return Tcl_ConvertToType(interp, objPtr, &tclFsPathType);
+ }
+ }
+ } 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;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * SetFsPathFromAbsoluteNormalized --
+ *
+ * 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.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+SetFsPathFromAbsoluteNormalized(interp, objPtr)
+ Tcl_Interp *interp; /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr; /* The object to convert. */
+{
+ FsPath *fsPathPtr;
+
+ if (objPtr->typePtr == &tclFsPathType) {
+ return TCL_OK;
+ }
+
+ /* Free old representation */
+ if (objPtr->typePtr != NULL) {
+ if (objPtr->bytes == NULL) {
+ 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 = -1;
+
+ objPtr->internalRep.otherValuePtr = fsPathPtr;
+ objPtr->typePtr = &tclFsPathType;
+
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * 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_DString buffer;
+ char *name;
+
+ if (objPtr->typePtr == &tclFsPathType) {
+ return TCL_OK;
+ }
+
+ /* Free old representation */
+ if (objPtr->typePtr != NULL) {
+ if (objPtr->bytes == NULL) {
+ objPtr->typePtr->updateStringProc(objPtr);
+ }
+ if ((objPtr->typePtr->freeIntRepProc) != NULL) {
+ (*objPtr->typePtr->freeIntRepProc)(objPtr);
+ }
+ }
+
+ /*
+ * 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 '~' */
+ 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) {
+ 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);
+
+ Tcl_DStringInit(&buffer);
+ if (split == len) {
+ /* We have the result we need in the wrong DString */
+ Tcl_DStringAppend(&buffer, expandedUser, Tcl_DStringLength(&temp));
+ } else {
+ /*
+ * Build a simple 2 element list and join it up with
+ * the tilde substitution in place
+ */
+ char *argv[2];
+ argv[0] = expandedUser;
+ argv[1] = name+split+1;
+ Tcl_JoinPath(2, argv, &buffer);
+ }
+ Tcl_DStringFree(&temp);
+ } else {
+ Tcl_DStringInit(&buffer);
+ Tcl_JoinPath(1, &name, &buffer);
+ }
+
+ len = Tcl_DStringLength(&buffer);
+
+ /*
+ * Now we have a translated filename in 'buffer', of
+ * length 'len'. This will have forward slashes on
+ * Windows, and will not contain any ~user sequences.
+ */
+
+ fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
+ fsPathPtr->translatedPathPtr = ckalloc((unsigned)(1+len));
+ strcpy(fsPathPtr->translatedPathPtr, Tcl_DStringValue(&buffer));
+ Tcl_DStringFree(&buffer);
+ fsPathPtr->normPathPtr = NULL;
+ fsPathPtr->cwdPtr = NULL;
+ fsPathPtr->nativePathPtr = NULL;
+ fsPathPtr->fsRecPtr = NULL;
+ fsPathPtr->filesystemEpoch = -1;
+
+ objPtr->internalRep.otherValuePtr = fsPathPtr;
+ 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.
+ *
+ * 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_Obj* fromFilesystem;
+ ClientData clientData;
+{
+ Tcl_Obj *objPtr;
+ FsPath *fsPathPtr, *fsFromPtr;
+ Tcl_FSInternalToNormalizedProc *proc;
+
+ if (Tcl_FSConvertToPathType(NULL, fromFilesystem) != TCL_OK) {
+ return NULL;
+ }
+
+ fsFromPtr = (FsPath*) fromFilesystem->internalRep.otherValuePtr;
+
+ proc = fsFromPtr->fsRecPtr->fsPtr->internalToNormalizedProc;
+
+ if (proc == NULL) {
+ return NULL;
+ }
+
+ objPtr = (*proc)(clientData);
+ 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) {
+ 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->fsRecPtr;
+ fsPathPtr->filesystemEpoch = fsFromPtr->filesystemEpoch;
+
+ objPtr->internalRep.otherValuePtr = fsPathPtr;
+ objPtr->typePtr = &tclFsPathType;
+ return objPtr;
+}
+
+static void
+FreeFsPathInternalRep(pathObjPtr)
+ Tcl_Obj *pathObjPtr; /* Path object with internal rep to free. */
+{
+ register FsPath* fsPathPtr =
+ (FsPath*) pathObjPtr->internalRep.otherValuePtr;
+
+ if (fsPathPtr->translatedPathPtr != NULL) {
+ ckfree((char *) 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->refCount--;
+ }
+
+ 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. */
+{
+ register FsPath* srcFsPathPtr =
+ (FsPath*) srcPtr->internalRep.otherValuePtr;
+ register FsPath* copyFsPathPtr =
+ (FsPath*) ckalloc((unsigned)sizeof(FsPath));
+ Tcl_FSDupInternalRepProc *dupProc;
+
+ copyPtr->internalRep.otherValuePtr = copyFsPathPtr;
+
+ if (srcFsPathPtr->translatedPathPtr != NULL) {
+ copyFsPathPtr->translatedPathPtr =
+ ckalloc(1+strlen(srcFsPathPtr->translatedPathPtr));
+ strcpy(copyFsPathPtr->translatedPathPtr,
+ srcFsPathPtr->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;
+ }
+
+ 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->refCount++;
+ }
+
+ copyPtr->typePtr = &tclFsPathType;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSGetTranslatedPath --
+ *
+ * This function attempts to extract the translated path string
+ * 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.
+ *
+ * Results:
+ * NULL or a valid string.
+ *
+ * Side effects:
+ * Only those of 'Tcl_FSConvertToPathType'
+ *
+ *---------------------------------------------------------------------------
+ */
+
+char*
+Tcl_FSGetTranslatedPath(interp, pathPtr)
+ Tcl_Interp *interp;
+ Tcl_Obj* pathPtr;
+{
+ register FsPath* srcFsPathPtr;
+ if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
+ return NULL;
+ }
+ srcFsPathPtr = (FsPath*) pathPtr->internalRep.otherValuePtr;
+ if (srcFsPathPtr->translatedPathPtr == NULL) {
+ /*
+ * 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.
+ */
+ return Tcl_GetString(srcFsPathPtr->normPathPtr);
+ } else {
+ /* It is an ordinary path object */
+ return srcFsPathPtr->translatedPathPtr;
+ }
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * 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;
+{
+ register FsPath* srcFsPathPtr;
+ if (Tcl_FSConvertToPathType(interp, pathObjPtr) != TCL_OK) {
+ return NULL;
+ }
+ srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr;
+ if (srcFsPathPtr->normPathPtr == NULL) {
+ int relative = 0;
+ char *path = srcFsPathPtr->translatedPathPtr;
+ Tcl_DString atemp;
+
+ if ((path[0] != '\0') && (Tcl_GetPathType(path) == TCL_PATH_RELATIVE)) {
+ char * pair[2];
+ Tcl_Obj *cwd = Tcl_FSGetCwd(interp);
+
+ if (cwd == NULL) {
+ return NULL;
+ }
+
+ /*
+ * The efficiency of this piece of code could
+ * be improved, given the new object interfaces.
+ */
+ pair[0] = Tcl_GetString(cwd);
+ pair[1] = path;
+
+ Tcl_DStringInit(&atemp);
+ Tcl_JoinPath(2, pair, &atemp);
+ path = Tcl_DStringValue(&atemp);
+ Tcl_DecrRefCount(cwd);
+
+ relative = 1;
+ }
+
+ /* Already has refCount incremented */
+ srcFsPathPtr->normPathPtr = FSNormalizeAbsolutePath(interp, path);
+ if (!strcmp(Tcl_GetString(srcFsPathPtr->normPathPtr),
+ Tcl_GetString(pathObjPtr))) {
+ /*
+ * The path was already normalized.
+ * Get rid of the duplicate.
+ */
+ Tcl_DecrRefCount(srcFsPathPtr->normPathPtr);
+ /*
+ * We do *not* increment the refCount for
+ * this circular reference
+ */
+ srcFsPathPtr->normPathPtr = pathObjPtr;
+ }
+ if (relative) {
+ Tcl_DStringFree(&atemp);
+
+ /* Get a quick, temporary lock on the cwd while we copy it */
+ Tcl_MutexLock(&cwdMutex);
+ srcFsPathPtr->cwdPtr = cwdPathPtr;
+ Tcl_IncrRefCount(srcFsPathPtr->cwdPtr);
+ Tcl_MutexUnlock(&cwdMutex);
+ }
+ }
+ return srcFsPathPtr->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;
+{
+ register FsPath* srcFsPathPtr;
+
+ if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) {
+ return NULL;
+ }
+ srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr;
+
+ /*
+ * 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 (fsPtr != srcFsPathPtr->fsRecPtr->fsPtr) {
+ return NULL;
+ }
+
+ if (srcFsPathPtr->nativePathPtr == NULL) {
+ Tcl_FSCreateInternalRepProc *proc;
+ proc = srcFsPathPtr->fsRecPtr->fsPtr->createInternalRepProc;
+
+ if (proc == NULL) {
+ return NULL;
+ }
+ srcFsPathPtr->nativePathPtr = (*proc)(pathObjPtr);
+ }
+ return srcFsPathPtr->nativePathPtr;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSGetNativePath --
+ *
+ * This function is for use by the Win/Unix/MacOS native filesystems,
+ * so that they can easily retrieve the native (char* or TCHAR*)
+ * representation of a path. Other filesystems will probably
+ * want to implement similar functions. They basically act as a
+ * safety net around Tcl_FSGetInternalRep. Normally your file-
+ * system procedures will always be called with path objects
+ * already converted to the correct filesystem, but if for
+ * some reason they are called directly (i.e. by procedures
+ * not in this file), then one cannot necessarily guarantee that
+ * the path object pointer is from the correct filesystem.
+ *
+ * Note: in the future it might be desireable to have separate
+ * versions of this function with different signatures, for
+ * example Tcl_FSGetNativeMacPath, Tcl_FSGetNativeUnixPath etc.
+ * Right now, since native paths are all string based, we use just
+ * one function. On MacOS we could possibly use an FSSpec or
+ * FSRef as the native representation.
+ *
+ * Results:
+ * NULL or a valid native path.
+ *
+ * Side effects:
+ * See Tcl_FSGetInternalRep.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+char*
+Tcl_FSGetNativePath(pathObjPtr)
+ Tcl_Obj* pathObjPtr;
+{
+ return (char*)Tcl_FSGetInternalRep(pathObjPtr, &nativeFilesystem);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * NativeCreateNativeRep --
+ *
+ * Create a native representation for the given path.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+ClientData
+NativeCreateNativeRep(pathObjPtr)
+ Tcl_Obj* pathObjPtr;
+{
+ char *nativePathPtr;
+ Tcl_DString ds;
+ Tcl_Obj* normPtr;
+ int len;
+ char *str;
+
+ /* Make sure the normalized path is set */
+ normPtr = Tcl_FSGetNormalizedPath(NULL, pathObjPtr);
+
+ str = Tcl_GetStringFromObj(normPtr,&len);
+#ifdef __WIN32__
+ Tcl_WinUtfToTChar(str, len, &ds);
+ nativePathPtr = ckalloc((unsigned)(2+Tcl_DStringLength(&ds)));
+ memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds),
+ (size_t) (2+Tcl_DStringLength(&ds)));
+#else
+ Tcl_UtfToExternalDString(NULL, str, len, &ds);
+ nativePathPtr = ckalloc((unsigned)(1+Tcl_DStringLength(&ds)));
+ memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds),
+ (size_t) (1+Tcl_DStringLength(&ds)));
+#endif
+
+ Tcl_DStringFree(&ds);
+ return (ClientData)nativePathPtr;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpNativeToNormalized --
+ *
+ * Convert native format to a normalized path object, with refCount
+ * of zero.
+ *
+ * Results:
+ * A valid normalized path.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+Tcl_Obj*
+TclpNativeToNormalized(clientData)
+ ClientData clientData;
+{
+ Tcl_DString ds;
+ Tcl_Obj *objPtr;
+
+#ifdef __WIN32__
+ Tcl_WinTCharToUtf((char*)clientData, -1, &ds);
+#else
+ Tcl_ExternalToUtfDString(NULL, (char*)clientData, -1, &ds);
+#endif
+ objPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
+
+ return objPtr;
+}
+
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * NativeDupInternalRep --
+ *
+ * Duplicate the native representation.
+ *
+ * Results:
+ * The copied native representation, or NULL if it is not possible
+ * to copy the representation.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+ClientData
+NativeDupInternalRep(clientData)
+ ClientData clientData;
+{
+#ifdef __WIN32__
+ /* Copying internal representations is complicated with multi-byte TChars */
+ return NULL;
+#else
+ if (clientData == NULL) {
+ return NULL;
+ } else {
+ char *native = (char*)clientData;
+ char *copy = ckalloc((unsigned)(1+strlen(native)));
+ strcpy(copy,native);
+ return (ClientData)copy;
+ }
+#endif
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * 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).
+ *
+ * Results:
+ * TCL_OK, to indicate 'yes', -1 to indicate no.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+int
+NativePathInFilesystem(pathPtr, clientDataPtr)
+ Tcl_Obj *pathPtr;
+ ClientData *clientDataPtr;
+{
+ int len;
+ Tcl_GetStringFromObj(pathPtr,&len);
+ if (len == 0) {
+ return -1;
+ } else {
+ /* We accept any path as valid */
+ return TCL_OK;
+ }
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * NativeFreeInternalRep --
+ *
+ * Free a native internal representation, which will be non-NULL.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory is released.
+ *
+ *---------------------------------------------------------------------------
+ */
+void
+NativeFreeInternalRep(clientData)
+ ClientData clientData;
+{
+ ckfree((char*)clientData);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSFileSystemInfo --
+ *
+ * This function returns a list of two elements. The first
+ * element is the name of the filesystem (e.g. "native" or "vfs"),
+ * and the second is the particular type of the given path within
+ * that filesystem.
+ *
+ * Results:
+ * A list of two elements.
+ *
+ * Side effects:
+ * The object may be converted to a path type.
+ *
+ *---------------------------------------------------------------------------
+ */
+Tcl_Obj*
+Tcl_FSFileSystemInfo(pathObjPtr)
+ Tcl_Obj* pathObjPtr;
+{
+ Tcl_Obj *resPtr;
+ Tcl_FSFilesystemPathTypeProc *proc;
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr);
+
+ if (fsPtr == NULL) {
+ return NULL;
+ }
+
+ resPtr = Tcl_NewListObj(0,NULL);
+
+ Tcl_ListObjAppendElement(NULL, resPtr,
+ Tcl_NewStringObj(fsPtr->typeName,-1));
+
+ proc = fsPtr->filesystemPathTypeProc;
+ if (proc != NULL) {
+ Tcl_Obj *typePtr = (*proc)(pathObjPtr);
+ if (typePtr != NULL) {
+ Tcl_ListObjAppendElement(NULL, resPtr, typePtr);
+ }
+ }
+
+ return resPtr;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSPathSeparator --
+ *
+ * This function returns the separator to be used for a given
+ * path. The object returned should have a refCount of zero
+ *
+ * Results:
+ * A Tcl object, with a refCount of zero. If the caller
+ * needs to retain a reference to the object, it should
+ * call Tcl_IncrRefCount.
+ *
+ * Side effects:
+ * The path object may be converted to a path type.
+ *
+ *---------------------------------------------------------------------------
+ */
+Tcl_Obj*
+Tcl_FSPathSeparator(pathObjPtr)
+ Tcl_Obj* pathObjPtr;
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr);
+
+ if (fsPtr == NULL) {
+ return NULL;
+ }
+ if (fsPtr->filesystemSeparatorProc != NULL) {
+ return (*fsPtr->filesystemSeparatorProc)(pathObjPtr);
+ }
+
+ return NULL;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * NativeFilesystemSeparator --
+ *
+ * This function is part of the native filesystem support, and
+ * returns the separator for the given path.
+ *
+ * Results:
+ * String object containing the separator character.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+Tcl_Obj*
+NativeFilesystemSeparator(pathObjPtr)
+ Tcl_Obj* pathObjPtr;
+{
+ char *separator = NULL; /* lint */
+ switch (tclPlatform) {
+ case TCL_PLATFORM_UNIX:
+ separator = "/";
+ break;
+ case TCL_PLATFORM_WINDOWS:
+ separator = "\\";
+ break;
+ case TCL_PLATFORM_MAC:
+ separator = ":";
+ break;
+ }
+ return Tcl_NewStringObj(separator,1);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * NativeFilesystemPathType --
+ *
+ * This function is part of the native filesystem support, and
+ * returns the path type of the given path. Right now it simply
+ * returns NULL. In the future it could return specific path
+ * types, like 'network' for a natively-networked path, etc.
+ *
+ * Results:
+ * NULL at present.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+Tcl_Obj*
+NativeFilesystemPathType(pathObjPtr)
+ Tcl_Obj* pathObjPtr;
+{
+ /* All native paths are of the same type */
+ return NULL;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSGetFileSystemForPath --
+ *
+ * This function determines which filesystem to use for a
+ * particular path object, and returns the filesystem which
+ * accepts this file. If no filesystem will accept this object
+ * as a valid file path, then NULL is returned.
+ *
+ * Results:
+ * NULL or a filesystem which will accept this path.
+ *
+ * Side effects:
+ * The object may be converted to a path type.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static Tcl_Filesystem*
+Tcl_FSGetFileSystemForPath(pathObjPtr)
+ Tcl_Obj* pathObjPtr;
+{
+ FilesystemRecord *fsRecPtr;
+ Tcl_Filesystem* retVal = NULL;
+ FsPath* srcFsPathPtr;
+
+ /* Make sure pathObjPtr is of our type */
+
+ if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) {
+ return NULL;
+ }
+
+ if (Tcl_FSGetNormalizedPath(NULL, pathObjPtr) == NULL) {
+ return NULL;
+ }
+
+ /*
+ * Get a lock on filesystemEpoch and the filesystemList
+ *
+ * While we don't need the fsRecPtr until the while loop
+ * below, we do want to make sure the filesystemEpoch doesn't
+ * change between the 'if' and 'while' blocks, getting this
+ * iterator will ensure that everything is consistent
+ */
+ fsRecPtr = FsGetIterator();
+
+ /* Make sure pathObjPtr is of the correct epoch */
+
+ srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr;
+
+ if (srcFsPathPtr->filesystemEpoch != -1) {
+ /*
+ * Check if the filesystem has changed in some way since
+ * this object's internal representation was calculated.
+ */
+ if (srcFsPathPtr->filesystemEpoch != filesystemEpoch) {
+ /*
+ * We have to discard the stale representation and
+ * recalculate it
+ */
+ FreeFsPathInternalRep(pathObjPtr);
+ pathObjPtr->typePtr = NULL;
+ if (SetFsPathFromAny(NULL, pathObjPtr) != TCL_OK) {
+ goto done;
+ }
+ srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr;
+ }
+ }
+
+ /* Check whether the object is already assigned to a fs */
+ if (srcFsPathPtr->fsRecPtr != NULL) {
+ retVal = srcFsPathPtr->fsRecPtr->fsPtr;
+ goto done;
+ }
+
+ /*
+ * Call each of the "pathInFilesystem" functions in succession. A
+ * non-return value of -1 indicates the particular function has
+ * succeeded.
+ */
+
+ while ((retVal == NULL) && (fsRecPtr != NULL)) {
+ Tcl_FSPathInFilesystemProc *proc = fsRecPtr->fsPtr->pathInFilesystemProc;
+ if (proc != NULL) {
+ ClientData clientData = NULL;
+ int ret = (*proc)(pathObjPtr, &clientData);
+ if (ret != -1) {
+ /*
+ * We assume the srcFsPathPtr hasn't been changed
+ * by the above call to the pathInFilesystemProc.
+ */
+ srcFsPathPtr->fsRecPtr = fsRecPtr;
+ srcFsPathPtr->nativePathPtr = clientData;
+ srcFsPathPtr->filesystemEpoch = filesystemEpoch;
+ fsRecPtr->refCount++;
+ retVal = fsRecPtr->fsPtr;
+ }
+ }
+ fsRecPtr = fsRecPtr->nextPtr;
+ }
+
+ done:
+ FsReleaseIterator();
+ return retVal;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSEqualPaths --
+ *
+ * This function tests whether the two paths given are equal path
+ * objects.
+ *
+ * Results:
+ * 1 or 0.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_FSEqualPaths(firstPtr, secondPtr)
+ Tcl_Obj* firstPtr;
+ Tcl_Obj* secondPtr;
+{
+ if (firstPtr == secondPtr) {
+ return 1;
+ } else {
+ int tempErrno;
+
+ if (firstPtr == NULL || secondPtr == NULL) {
+ return 0;
+ }
+ if (!(strcmp(Tcl_GetString(firstPtr), Tcl_GetString(secondPtr)))) {
+ 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;
+ }
+ if (!(strcmp(Tcl_GetString(firstPtr), Tcl_GetString(secondPtr)))) {
+ return 1;
+ }
+ }
+ return 0;
+}
+
+/* Wrappers */
+
+Tcl_Channel
+NativeOpenFileChannel(interp, pathPtr, modeString, permissions)
+ Tcl_Interp *interp;
+ Tcl_Obj *pathPtr;
+ char *modeString;
+ int permissions;
+{
+ char *trans = Tcl_FSGetTranslatedPath(interp, pathPtr);
+ if (trans == NULL) {
+ return NULL;
+ }
+ return TclpOpenFileChannel(interp, trans, modeString, permissions);
+}
+
+/*
+ * utime wants a normalized, NOT native path. I assume a native
+ * version of 'utime' doesn't exist (at least under that name) on NT/2000.
+ * If a native function does exist somewhere, then we could use:
+ *
+ * return native_utime(Tcl_FSGetNativePath(pathPtr),tval);
+ *
+ * This seems rather strange when compared with stat, lstat, access, etc.
+ * all of which want a native path.
+ */
+int
+NativeUtime(pathPtr, tval)
+ Tcl_Obj *pathPtr;
+ struct utimbuf *tval;
+{
+ #ifdef MAC_TCL
+ long gmt_offset=TclpGetGMTOffset();
+ struct utimbuf local_tval;
+ local_tval.actime=tval->actime+gmt_offset;
+ local_tval.modtime=tval->modtime+gmt_offset;
+ return utime(Tcl_GetString(Tcl_FSGetNormalizedPath(NULL,pathPtr)),&local_tval);
+ #else
+ return utime(Tcl_GetString(Tcl_FSGetNormalizedPath(NULL,pathPtr)),tval);
+ #endif
+}
+
+int
+NativeLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
+ Tcl_Interp * interp;
+ Tcl_Obj *pathPtr;
+ char * sym1;
+ char * sym2;
+ Tcl_PackageInitProc ** proc1Ptr;
+ Tcl_PackageInitProc ** proc2Ptr;
+ ClientData * clientDataPtr;
+{
+ return TclpLoadFile(interp, Tcl_FSGetTranslatedPath(NULL, pathPtr),
+ sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr);
+}
+
+/* Everything from here on is contained in this obsolete ifdef */
+#ifdef USE_OBSOLETE_FS_HOOKS
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclStatInsertProc --
*
* Insert the passed procedure pointer at the head of the list of
@@ -605,10 +3876,10 @@ TclStatInsertProc (proc)
if (newStatProcPtr != NULL) {
newStatProcPtr->proc = proc;
- Tcl_MutexLock(&hookMutex);
+ Tcl_MutexLock(&obsoleteFsHookMutex);
newStatProcPtr->nextPtr = statProcList;
statProcList = newStatProcPtr;
- Tcl_MutexUnlock(&hookMutex);
+ Tcl_MutexUnlock(&obsoleteFsHookMutex);
retVal = TCL_OK;
}
@@ -644,7 +3915,7 @@ TclStatDeleteProc (proc)
StatProc *tmpStatProcPtr;
StatProc *prevStatProcPtr = NULL;
- Tcl_MutexLock(&hookMutex);
+ Tcl_MutexLock(&obsoleteFsHookMutex);
tmpStatProcPtr = statProcList;
/*
* Traverse the 'statProcList' looking for the particular node
@@ -652,7 +3923,7 @@ TclStatDeleteProc (proc)
* the list. Ensure that the "default" node cannot be removed.
*/
- while ((retVal == TCL_ERROR) && (tmpStatProcPtr != &defaultStatProc)) {
+ while ((retVal == TCL_ERROR) && (tmpStatProcPtr != NULL)) {
if (tmpStatProcPtr->proc == proc) {
if (prevStatProcPtr == NULL) {
statProcList = tmpStatProcPtr->nextPtr;
@@ -660,7 +3931,7 @@ TclStatDeleteProc (proc)
prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr;
}
- Tcl_Free((char *)tmpStatProcPtr);
+ ckfree((char *)tmpStatProcPtr);
retVal = TCL_OK;
} else {
@@ -669,7 +3940,7 @@ TclStatDeleteProc (proc)
}
}
- Tcl_MutexUnlock(&hookMutex);
+ Tcl_MutexUnlock(&obsoleteFsHookMutex);
return (retVal);
}
@@ -708,10 +3979,10 @@ TclAccessInsertProc(proc)
if (newAccessProcPtr != NULL) {
newAccessProcPtr->proc = proc;
- Tcl_MutexLock(&hookMutex);
+ Tcl_MutexLock(&obsoleteFsHookMutex);
newAccessProcPtr->nextPtr = accessProcList;
accessProcList = newAccessProcPtr;
- Tcl_MutexUnlock(&hookMutex);
+ Tcl_MutexUnlock(&obsoleteFsHookMutex);
retVal = TCL_OK;
}
@@ -753,9 +4024,9 @@ TclAccessDeleteProc(proc)
* the list. Ensure that the "default" node cannot be removed.
*/
- Tcl_MutexLock(&hookMutex);
+ Tcl_MutexLock(&obsoleteFsHookMutex);
tmpAccessProcPtr = accessProcList;
- while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != &defaultAccessProc)) {
+ while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != NULL)) {
if (tmpAccessProcPtr->proc == proc) {
if (prevAccessProcPtr == NULL) {
accessProcList = tmpAccessProcPtr->nextPtr;
@@ -763,7 +4034,7 @@ TclAccessDeleteProc(proc)
prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr;
}
- Tcl_Free((char *)tmpAccessProcPtr);
+ ckfree((char *)tmpAccessProcPtr);
retVal = TCL_OK;
} else {
@@ -771,7 +4042,7 @@ TclAccessDeleteProc(proc)
tmpAccessProcPtr = tmpAccessProcPtr->nextPtr;
}
}
- Tcl_MutexUnlock(&hookMutex);
+ Tcl_MutexUnlock(&obsoleteFsHookMutex);
return (retVal);
}
@@ -813,10 +4084,10 @@ TclOpenFileChannelInsertProc(proc)
if (newOpenFileChannelProcPtr != NULL) {
newOpenFileChannelProcPtr->proc = proc;
- Tcl_MutexLock(&hookMutex);
+ Tcl_MutexLock(&obsoleteFsHookMutex);
newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList;
openFileChannelProcList = newOpenFileChannelProcPtr;
- Tcl_MutexUnlock(&hookMutex);
+ Tcl_MutexUnlock(&obsoleteFsHookMutex);
retVal = TCL_OK;
}
@@ -855,13 +4126,13 @@ TclOpenFileChannelDeleteProc(proc)
/*
* Traverse the 'openFileChannelProcList' 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.
+ * the list.
*/
- Tcl_MutexLock(&hookMutex);
+ Tcl_MutexLock(&obsoleteFsHookMutex);
tmpOpenFileChannelProcPtr = openFileChannelProcList;
while ((retVal == TCL_ERROR) &&
- (tmpOpenFileChannelProcPtr != &defaultOpenFileChannelProc)) {
+ (tmpOpenFileChannelProcPtr != NULL)) {
if (tmpOpenFileChannelProcPtr->proc == proc) {
if (prevOpenFileChannelProcPtr == NULL) {
openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr;
@@ -870,7 +4141,7 @@ TclOpenFileChannelDeleteProc(proc)
tmpOpenFileChannelProcPtr->nextPtr;
}
- Tcl_Free((char *)tmpOpenFileChannelProcPtr);
+ ckfree((char *)tmpOpenFileChannelProcPtr);
retVal = TCL_OK;
} else {
@@ -878,7 +4149,8 @@ TclOpenFileChannelDeleteProc(proc)
tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr;
}
}
- Tcl_MutexUnlock(&hookMutex);
+ Tcl_MutexUnlock(&obsoleteFsHookMutex);
return (retVal);
}
+#endif /* USE_OBSOLETE_FS_HOOKS */
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 4894d2d..b0b883b 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tclInt.decls,v 1.28 2001/06/17 03:48:19 dgp Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.29 2001/07/31 19:12:06 vincentdarley Exp $
library tcl
@@ -74,7 +74,7 @@ declare 12 generic {
}
declare 13 generic {
int TclDoGlob(Tcl_Interp *interp, char *separators, \
- Tcl_DString *headPtr, char *tail, GlobTypeData *types)
+ Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types)
}
declare 14 generic {
void TclDumpMemoryInfo(FILE *outFile)
@@ -86,21 +86,22 @@ declare 14 generic {
declare 16 generic {
void TclExprFloatError(Tcl_Interp *interp, double value)
}
-declare 17 generic {
- int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
-}
-declare 18 generic {
- int TclFileCopyCmd(Tcl_Interp *interp, int argc, char **argv)
-}
-declare 19 generic {
- int TclFileDeleteCmd(Tcl_Interp *interp, int argc, char **argv)
-}
-declare 20 generic {
- int TclFileMakeDirsCmd(Tcl_Interp *interp, int argc, char **argv)
-}
-declare 21 generic {
- int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv)
-}
+# Removed in 8.4
+#declare 17 generic {
+# int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
+#}
+#declare 18 generic {
+# int TclFileCopyCmd(Tcl_Interp *interp, int argc, char **argv)
+#}
+#declare 19 generic {
+# int TclFileDeleteCmd(Tcl_Interp *interp, int argc, char **argv)
+#}
+#declare 20 generic {
+# int TclFileMakeDirsCmd(Tcl_Interp *interp, int argc, char **argv)
+#}
+#declare 21 generic {
+# int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv)
+#}
declare 22 generic {
int TclFindElement(Tcl_Interp *interp, CONST char *listStr, \
int listLength, CONST char **elementPtr, CONST char **nextPtr, \
@@ -235,10 +236,11 @@ declare 58 generic {
int flags, char *msg, int createPart1, int createPart2, \
Var **arrayPtrPtr)
}
-declare 59 generic {
- int TclpMatchFiles(Tcl_Interp *interp, char *separators, \
- Tcl_DString *dirPtr, char *pattern, char *tail)
-}
+# Replaced by Tcl_FSMatchInDirectory in 8.4
+#declare 59 generic {
+# int TclpMatchFiles(Tcl_Interp *interp, char *separators, \
+# Tcl_DString *dirPtr, char *pattern, char *tail)
+#}
declare 60 generic {
int TclNeedSpace(char *start, char *end)
}
@@ -272,19 +274,19 @@ declare 68 generic {
declare 69 generic {
char * TclpAlloc(unsigned int size)
}
-declare 70 generic {
- int TclpCopyFile(CONST char *source, CONST char *dest)
-}
-declare 71 generic {
- int TclpCopyDirectory(CONST char *source, CONST char *dest, \
- Tcl_DString *errorPtr)
-}
-declare 72 generic {
- int TclpCreateDirectory(CONST char *path)
-}
-declare 73 generic {
- int TclpDeleteFile(CONST char *path)
-}
+#declare 70 generic {
+# int TclpCopyFile(CONST char *source, CONST char *dest)
+#}
+#declare 71 generic {
+# int TclpCopyDirectory(CONST char *source, CONST char *dest, \
+# Tcl_DString *errorPtr)
+#}
+#declare 72 generic {
+# int TclpCreateDirectory(CONST char *path)
+#}
+#declare 73 generic {
+# int TclpDeleteFile(CONST char *path)
+#}
declare 74 generic {
void TclpFree(char *ptr)
}
@@ -310,13 +312,13 @@ declare 80 generic {
declare 81 generic {
char * TclpRealloc(char *ptr, unsigned int size)
}
-declare 82 generic {
- int TclpRemoveDirectory(CONST char *path, int recursive, \
- Tcl_DString *errorPtr)
-}
-declare 83 generic {
- int TclpRenameFile(CONST char *source, CONST char *dest)
-}
+#declare 82 generic {
+# int TclpRemoveDirectory(CONST char *path, int recursive, \
+# Tcl_DString *errorPtr)
+#}
+#declare 83 generic {
+# int TclpRenameFile(CONST char *source, CONST char *dest)
+#}
# Removed in 8.1:
# declare 84 generic {
# int TclParseBraces(Tcl_Interp *interp, char *str, char **termPtr, \
@@ -512,9 +514,9 @@ declare 135 generic {
# Added in 8.1:
-declare 137 generic {
- int TclpChdir(CONST char *dirName)
-}
+#declare 137 generic {
+# int TclpChdir(CONST char *dirName)
+#}
declare 138 generic {
char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr)
}
@@ -526,9 +528,9 @@ declare 139 generic {
declare 140 generic {
int TclLooksLikeInt(char *bytes, int length)
}
-declare 141 generic {
- char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
-}
+#declare 141 generic {
+# char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
+#}
declare 142 generic {
int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, \
CompileHookProc *hookProc, ClientData clientData)
@@ -601,10 +603,10 @@ declare 158 generic {
declare 159 generic {
char *TclGetStartupScriptFileName(void)
}
-declare 160 generic {
- int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators, \
- Tcl_DString *dirPtr, char *pattern, char *tail, GlobTypeData *types)
-}
+#declare 160 generic {
+# int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators, \
+# Tcl_DString *dirPtr, char *pattern, char *tail, GlobTypeData *types)
+#}
# new in 8.3.2/8.4a2
declare 161 generic {
@@ -614,6 +616,31 @@ declare 161 generic {
declare 162 generic {
void TclChannelEventScriptInvoker(ClientData clientData, int flags)
}
+# for virtual filesystem support. These should eventually be moved to
+# Tcl's external API and properly documented, to allow extension writers
+# to use them easily (hence providing automatic VFS support to all
+# extensions)
+declare 163 generic {
+ int TclFileCopyCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
+}
+declare 164 generic {
+ int TclFileRenameCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
+}
+declare 165 generic {
+ int TclFileDeleteCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
+}
+declare 166 generic {
+ int TclFileMakeDirsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
+}
+declare 167 generic {
+ int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
+}
+declare 168 generic {
+ Tcl_Obj* TclpTempFileName(void)
+}
+declare 169 generic {
+ void TclpSetInitialEncodings(void)
+}
##############################################################################
@@ -870,3 +897,4 @@ declare 8 unix {
declare 9 unix {
TclFile TclpCreateTempFile(CONST char *contents)
}
+
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 2ee93d0..ddb8fd4 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.57 2001/06/28 01:22:21 hobbs Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.58 2001/07/31 19:12:06 vincentdarley Exp $
*/
#ifndef _TCLINT
@@ -1274,11 +1274,9 @@ typedef struct Interp {
* are added/removed by calling
* Tcl_AddInterpResolvers and
* Tcl_RemoveInterpResolver. */
- char *scriptFile; /* NULL means there is no nested source
+ Tcl_Obj *scriptFile; /* NULL means there is no nested source
* command active; otherwise this points to
- * the name of the file being sourced (it's
- * not malloc-ed: it points to an argument
- * to Tcl_EvalFile. */
+ * pathPtr of the file being sourced. */
int flags; /* Various flag bits. See below. */
long randSeed; /* Seed used for rand() function. */
Trace *tracePtr; /* List of traces for this interpreter. */
@@ -1505,9 +1503,24 @@ typedef struct TclFileAttrProcs {
typedef struct TclFile_ *TclFile;
/*
+ * Opaque names for platform specific types.
+ */
+
+typedef struct TclpTime_t_ *TclpTime_t;
+
+/*
+ * The "globParameters" argument of the function TclGlob is an
+ * or'ed combination of the following values:
+ */
+
+#define TCL_GLOBMODE_NO_COMPLAIN 1
+#define TCL_GLOBMODE_JOIN 2
+#define TCL_GLOBMODE_DIR 4
+#define TCL_GLOBMODE_TAILS 8
+
+/*
*----------------------------------------------------------------
- * Data structures related to hooking 'TclStat(...)' and
- * 'TclAccess(...)'.
+ * Data structures related to obsolete filesystem hooks
*----------------------------------------------------------------
*/
@@ -1517,51 +1530,17 @@ typedef Tcl_Channel (TclOpenFileChannelProc_) _ANSI_ARGS_((Tcl_Interp *interp,
char *fileName, char *modeString,
int permissions));
-typedef int (*TclCmdProcType) _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char *argv[]));
-typedef int (*TclObjCmdProcType) _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST objv[]));
/*
- * Opaque names for platform specific types.
+ *----------------------------------------------------------------
+ * Data structures related to procedures
+ *----------------------------------------------------------------
*/
-typedef struct TclpTime_t_ *TclpTime_t;
-
-/*
- * The following structure is used to pass glob type data amongst
- * the various glob routines and TclpMatchFilesTypes. Currently
- * most of the fields are ignored. However they will be used in
- * a future release to implement glob's ability to find files
- * of particular types/permissions/etc only.
- */
-typedef struct GlobTypeData {
- /* Corresponds to bcdpfls as in 'find -t' */
- int type;
- /* Corresponds to file permissions */
- int perm;
- /* Acceptable mac type */
- Tcl_Obj* macType;
- /* Acceptable mac creator */
- Tcl_Obj* macCreator;
-} GlobTypeData;
-
-/*
- * type and permission definitions for glob command
- */
-#define TCL_GLOB_TYPE_BLOCK (1<<0)
-#define TCL_GLOB_TYPE_CHAR (1<<1)
-#define TCL_GLOB_TYPE_DIR (1<<2)
-#define TCL_GLOB_TYPE_PIPE (1<<3)
-#define TCL_GLOB_TYPE_FILE (1<<4)
-#define TCL_GLOB_TYPE_LINK (1<<5)
-#define TCL_GLOB_TYPE_SOCK (1<<6)
-
-#define TCL_GLOB_PERM_RONLY (1<<0)
-#define TCL_GLOB_PERM_HIDDEN (1<<1)
-#define TCL_GLOB_PERM_R (1<<2)
-#define TCL_GLOB_PERM_W (1<<3)
-#define TCL_GLOB_PERM_X (1<<4)
+typedef int (*TclCmdProcType) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, char *argv[]));
+typedef int (*TclObjCmdProcType) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST objv[]));
/*
*----------------------------------------------------------------
@@ -1577,8 +1556,6 @@ extern char * tclDefaultEncodingDir;
extern Tcl_ChannelType tclFileChannelType;
extern char * tclMemDumpFileName;
extern TclPlatformType tclPlatform;
-extern char * tclpFileAttrStrings[];
-extern CONST TclFileAttrProcs tclpFileAttrProcs[];
/*
* Variables denoting the Tcl object types defined in the core.
@@ -1634,8 +1611,6 @@ extern char * tclEmptyStringRep;
*----------------------------------------------------------------
*/
-EXTERN int TclAccess _ANSI_ARGS_((CONST char *path,
- int mode));
EXTERN int TclAccessDeleteProc _ANSI_ARGS_((TclAccessProc_ *proc));
EXTERN int TclAccessInsertProc _ANSI_ARGS_((TclAccessProc_ *proc));
EXTERN void TclAllocateFreeObjects _ANSI_ARGS_((void));
@@ -1667,7 +1642,7 @@ EXTERN void TclDeleteVars _ANSI_ARGS_((Interp *iPtr,
Tcl_HashTable *tablePtr));
EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp *interp,
char *separators, Tcl_DString *headPtr,
- char *tail, GlobTypeData *types));
+ char *tail, Tcl_GlobTypeData *types));
EXTERN void TclDumpMemoryInfo _ANSI_ARGS_((FILE *outFile));
EXTERN void TclExpandTokenArray _ANSI_ARGS_((
Tcl_Parse *parsePtr));
@@ -1676,13 +1651,13 @@ EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp *interp,
EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
EXTERN int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp *interp,
- int argc, char **argv)) ;
+ int objc, Tcl_Obj *CONST objv[])) ;
EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp *interp,
- int argc, char **argv));
+ int objc, Tcl_Obj *CONST objv[]));
EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp,
- int argc, char **argv)) ;
+ int objc, Tcl_Obj *CONST objv[])) ;
EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp *interp,
- int argc, char **argv)) ;
+ int objc, Tcl_Obj *CONST objv[])) ;
EXTERN void TclFinalizeAllocSubsystem _ANSI_ARGS_((void));
EXTERN void TclFinalizeCompExecEnv _ANSI_ARGS_((void));
EXTERN void TclFinalizeCompilation _ANSI_ARGS_((void));
@@ -1730,8 +1705,8 @@ EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp *interp,
EXTERN Tcl_Command TclGetOriginalCommand _ANSI_ARGS_((
Tcl_Command command));
EXTERN int TclGlob _ANSI_ARGS_((Tcl_Interp *interp,
- char *pattern, char *unquotedPrefix,
- int globFlags, GlobTypeData* types));
+ char *pattern, Tcl_Obj *unquotedPrefix,
+ int globFlags, Tcl_GlobTypeData* types));
EXTERN int TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp *interp,
int argc, char **argv, int flags));
EXTERN int TclGuessPackageName _ANSI_ARGS_((char *fileName,
@@ -1791,8 +1766,10 @@ EXTERN int TclOpenFileChannelDeleteProc _ANSI_ARGS_((
TclOpenFileChannelProc_ *proc));
EXTERN int TclOpenFileChannelInsertProc _ANSI_ARGS_((
TclOpenFileChannelProc_ *proc));
-EXTERN int TclpAccess _ANSI_ARGS_((CONST char *filename,
+EXTERN int TclpObjAccess _ANSI_ARGS_((Tcl_Obj *filename,
int mode));
+EXTERN int TclpObjLstat _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ struct stat *buf));
EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size));
EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void));
EXTERN int TclpCopyFile _ANSI_ARGS_((CONST char *source,
@@ -1816,6 +1793,7 @@ EXTERN int TclpFindVariable _ANSI_ARGS_((CONST char *name,
EXTERN void TclpFree _ANSI_ARGS_((char *ptr));
EXTERN unsigned long TclpGetClicks _ANSI_ARGS_((void));
EXTERN Tcl_Channel TclpGetDefaultStdChannel _ANSI_ARGS_((int type));
+EXTERN long TclpGetGMTOffset _ANSI_ARGS_((void));
EXTERN unsigned long TclpGetSeconds _ANSI_ARGS_((void));
EXTERN void TclpGetTime _ANSI_ARGS_((Tcl_Time *time));
EXTERN int TclpGetTimeZone _ANSI_ARGS_((unsigned long time));
@@ -1832,6 +1810,25 @@ EXTERN void TclpMasterUnlock _ANSI_ARGS_((void));
EXTERN int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp *interp,
char *separators, Tcl_DString *dirPtr,
char *pattern, char *tail));
+EXTERN int TclpObjNormalizePath _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *pathPtr, int nextCheckpoint));
+EXTERN int TclpObjCreateDirectory _ANSI_ARGS_((Tcl_Obj *pathPtr));
+EXTERN int TclpObjDeleteFile _ANSI_ARGS_((Tcl_Obj *pathPtr));
+EXTERN int TclpObjCopyDirectory _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
+ Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr));
+EXTERN int TclpObjCopyFile _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
+ Tcl_Obj *destPathPtr));
+EXTERN int TclpObjRemoveDirectory _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ int recursive, Tcl_Obj **errorPtr));
+EXTERN int TclpObjRenameFile _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
+ Tcl_Obj *destPathPtr));
+EXTERN int TclpMatchInDirectory _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, char *pattern, Tcl_GlobTypeData *types));
+EXTERN int TclpChdir _ANSI_ARGS_((CONST char *dirName));
+EXTERN char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_DString *bufferPtr));
+EXTERN Tcl_Obj* TclpObjGetCwd _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN Tcl_Obj* TclpObjReadlink _ANSI_ARGS_((Tcl_Obj *pathPtr));
+EXTERN int TclpObjChdir _ANSI_ARGS_((Tcl_Obj *pathPtr));
+EXTERN int TclpObjStat _ANSI_ARGS_((Tcl_Obj *pathPtr, struct stat *buf));
EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp,
char *fileName, char *modeString,
int permissions));
@@ -1894,14 +1891,14 @@ EXTERN int TclSockGetPort _ANSI_ARGS_((Tcl_Interp *interp,
char *string, char *proto, int *portPtr));
EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock,
int size));
-EXTERN int TclStat _ANSI_ARGS_((CONST char *path,
- struct stat *buf));
EXTERN int TclStatDeleteProc _ANSI_ARGS_((TclStatProc_ *proc));
EXTERN int TclStatInsertProc _ANSI_ARGS_((TclStatProc_ *proc));
EXTERN void TclTeardownNamespace _ANSI_ARGS_((Namespace *nsPtr));
EXTERN void TclTransferResult _ANSI_ARGS_((Tcl_Interp *sourceInterp,
int result, Tcl_Interp *targetInterp));
EXTERN int TclUpdateReturnInfo _ANSI_ARGS_((Interp *iPtr));
+EXTERN Tcl_Obj* TclpNativeToNormalized
+ _ANSI_ARGS_((ClientData clientData));
/*
*----------------------------------------------------------------
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 32b6ede..8d55864 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIntDecls.h,v 1.24 2001/05/17 02:13:03 hobbs Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.25 2001/07/31 19:12:06 vincentdarley Exp $
*/
#ifndef _TCLINTDECLS
@@ -89,28 +89,18 @@ EXTERN void TclDeleteVars _ANSI_ARGS_((Interp * iPtr,
/* 13 */
EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp * interp,
char * separators, Tcl_DString * headPtr,
- char * tail, GlobTypeData * types));
+ char * tail, Tcl_GlobTypeData * types));
/* 14 */
EXTERN void TclDumpMemoryInfo _ANSI_ARGS_((FILE * outFile));
/* Slot 15 is reserved */
/* 16 */
EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp * interp,
double value));
-/* 17 */
-EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp * interp,
- int objc, Tcl_Obj *CONST objv[]));
-/* 18 */
-EXTERN int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp * interp,
- int argc, char ** argv));
-/* 19 */
-EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp * interp,
- int argc, char ** argv));
-/* 20 */
-EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp * interp,
- int argc, char ** argv));
-/* 21 */
-EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp * interp,
- int argc, char ** argv));
+/* Slot 17 is reserved */
+/* Slot 18 is reserved */
+/* Slot 19 is reserved */
+/* Slot 20 is reserved */
+/* Slot 21 is reserved */
/* 22 */
EXTERN int TclFindElement _ANSI_ARGS_((Tcl_Interp * interp,
CONST char * listStr, int listLength,
@@ -223,10 +213,7 @@ EXTERN Var * TclLookupVar _ANSI_ARGS_((Tcl_Interp * interp,
char * part1, char * part2, int flags,
char * msg, int createPart1, int createPart2,
Var ** arrayPtrPtr));
-/* 59 */
-EXTERN int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp * interp,
- char * separators, Tcl_DString * dirPtr,
- char * pattern, char * tail));
+/* Slot 59 is reserved */
/* 60 */
EXTERN int TclNeedSpace _ANSI_ARGS_((char * start, char * end));
/* 61 */
@@ -253,16 +240,10 @@ EXTERN int TclOpenFileChannelInsertProc _ANSI_ARGS_((
EXTERN int TclpAccess _ANSI_ARGS_((CONST char * path, int mode));
/* 69 */
EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size));
-/* 70 */
-EXTERN int TclpCopyFile _ANSI_ARGS_((CONST char * source,
- CONST char * dest));
-/* 71 */
-EXTERN int TclpCopyDirectory _ANSI_ARGS_((CONST char * source,
- CONST char * dest, Tcl_DString * errorPtr));
-/* 72 */
-EXTERN int TclpCreateDirectory _ANSI_ARGS_((CONST char * path));
-/* 73 */
-EXTERN int TclpDeleteFile _ANSI_ARGS_((CONST char * path));
+/* Slot 70 is reserved */
+/* Slot 71 is reserved */
+/* Slot 72 is reserved */
+/* Slot 73 is reserved */
/* 74 */
EXTERN void TclpFree _ANSI_ARGS_((char * ptr));
/* 75 */
@@ -282,12 +263,8 @@ EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp * interp,
/* 81 */
EXTERN char * TclpRealloc _ANSI_ARGS_((char * ptr,
unsigned int size));
-/* 82 */
-EXTERN int TclpRemoveDirectory _ANSI_ARGS_((CONST char * path,
- int recursive, Tcl_DString * errorPtr));
-/* 83 */
-EXTERN int TclpRenameFile _ANSI_ARGS_((CONST char * source,
- CONST char * dest));
+/* Slot 82 is reserved */
+/* Slot 83 is reserved */
/* Slot 84 is reserved */
/* Slot 85 is reserved */
/* Slot 86 is reserved */
@@ -456,8 +433,7 @@ EXTERN size_t TclpStrftime _ANSI_ARGS_((char * s, size_t maxsize,
/* 135 */
EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void));
/* Slot 136 is reserved */
-/* 137 */
-EXTERN int TclpChdir _ANSI_ARGS_((CONST char * dirName));
+/* Slot 137 is reserved */
/* 138 */
EXTERN char * TclGetEnv _ANSI_ARGS_((CONST char * name,
Tcl_DString * valuePtr));
@@ -470,9 +446,7 @@ EXTERN int TclpLoadFile _ANSI_ARGS_((Tcl_Interp * interp,
/* 140 */
EXTERN int TclLooksLikeInt _ANSI_ARGS_((char * bytes,
int length));
-/* 141 */
-EXTERN char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp * interp,
- Tcl_DString * cwdPtr));
+/* Slot 141 is reserved */
/* 142 */
EXTERN int TclSetByteCodeFromAny _ANSI_ARGS_((
Tcl_Interp * interp, Tcl_Obj * objPtr,
@@ -518,17 +492,32 @@ EXTERN void TclSetStartupScriptFileName _ANSI_ARGS_((
char * filename));
/* 159 */
EXTERN char * TclGetStartupScriptFileName _ANSI_ARGS_((void));
-/* 160 */
-EXTERN int TclpMatchFilesTypes _ANSI_ARGS_((Tcl_Interp * interp,
- char * separators, Tcl_DString * dirPtr,
- char * pattern, char * tail,
- GlobTypeData * types));
+/* Slot 160 is reserved */
/* 161 */
EXTERN int TclChannelTransform _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Channel chan, Tcl_Obj * cmdObjPtr));
/* 162 */
EXTERN void TclChannelEventScriptInvoker _ANSI_ARGS_((
ClientData clientData, int flags));
+/* 163 */
+EXTERN int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp * interp,
+ int objc, Tcl_Obj *CONST objv[]));
+/* 164 */
+EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp * interp,
+ int objc, Tcl_Obj *CONST objv[]));
+/* 165 */
+EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp * interp,
+ int objc, Tcl_Obj *CONST objv[]));
+/* 166 */
+EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp * interp,
+ int objc, Tcl_Obj *CONST objv[]));
+/* 167 */
+EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp * interp,
+ int objc, Tcl_Obj *CONST objv[]));
+/* 168 */
+EXTERN Tcl_Obj* TclpTempFileName _ANSI_ARGS_((void));
+/* 169 */
+EXTERN void TclpSetInitialEncodings _ANSI_ARGS_((void));
typedef struct TclIntStubs {
int magic;
@@ -563,15 +552,15 @@ typedef struct TclIntStubs {
int (*tclCreateProc) _ANSI_ARGS_((Tcl_Interp * interp, Namespace * nsPtr, CONST char * procName, Tcl_Obj * argsPtr, Tcl_Obj * bodyPtr, Proc ** procPtrPtr)); /* 10 */
void (*tclDeleteCompiledLocalVars) _ANSI_ARGS_((Interp * iPtr, CallFrame * framePtr)); /* 11 */
void (*tclDeleteVars) _ANSI_ARGS_((Interp * iPtr, Tcl_HashTable * tablePtr)); /* 12 */
- int (*tclDoGlob) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * headPtr, char * tail, GlobTypeData * types)); /* 13 */
+ int (*tclDoGlob) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * headPtr, char * tail, Tcl_GlobTypeData * types)); /* 13 */
void (*tclDumpMemoryInfo) _ANSI_ARGS_((FILE * outFile)); /* 14 */
void *reserved15;
void (*tclExprFloatError) _ANSI_ARGS_((Tcl_Interp * interp, double value)); /* 16 */
- int (*tclFileAttrsCmd) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 17 */
- int (*tclFileCopyCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 18 */
- int (*tclFileDeleteCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 19 */
- int (*tclFileMakeDirsCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 20 */
- int (*tclFileRenameCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 21 */
+ void *reserved17;
+ void *reserved18;
+ void *reserved19;
+ void *reserved20;
+ void *reserved21;
int (*tclFindElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int listLength, CONST char ** elementPtr, CONST char ** nextPtr, int * sizePtr, int * bracePtr)); /* 22 */
Proc * (*tclFindProc) _ANSI_ARGS_((Interp * iPtr, char * procName)); /* 23 */
int (*tclFormatInt) _ANSI_ARGS_((char * buffer, long n)); /* 24 */
@@ -609,7 +598,7 @@ typedef struct TclIntStubs {
void *reserved56;
void *reserved57;
Var * (*tclLookupVar) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags, char * msg, int createPart1, int createPart2, Var ** arrayPtrPtr)); /* 58 */
- int (*tclpMatchFiles) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * dirPtr, char * pattern, char * tail)); /* 59 */
+ void *reserved59;
int (*tclNeedSpace) _ANSI_ARGS_((char * start, char * end)); /* 60 */
Tcl_Obj * (*tclNewProcBodyObj) _ANSI_ARGS_((Proc * procPtr)); /* 61 */
int (*tclObjCommandComplete) _ANSI_ARGS_((Tcl_Obj * cmdPtr)); /* 62 */
@@ -620,10 +609,10 @@ typedef struct TclIntStubs {
int (*tclOpenFileChannelInsertProc) _ANSI_ARGS_((TclOpenFileChannelProc_ * proc)); /* 67 */
int (*tclpAccess) _ANSI_ARGS_((CONST char * path, int mode)); /* 68 */
char * (*tclpAlloc) _ANSI_ARGS_((unsigned int size)); /* 69 */
- int (*tclpCopyFile) _ANSI_ARGS_((CONST char * source, CONST char * dest)); /* 70 */
- int (*tclpCopyDirectory) _ANSI_ARGS_((CONST char * source, CONST char * dest, Tcl_DString * errorPtr)); /* 71 */
- int (*tclpCreateDirectory) _ANSI_ARGS_((CONST char * path)); /* 72 */
- int (*tclpDeleteFile) _ANSI_ARGS_((CONST char * path)); /* 73 */
+ void *reserved70;
+ void *reserved71;
+ void *reserved72;
+ void *reserved73;
void (*tclpFree) _ANSI_ARGS_((char * ptr)); /* 74 */
unsigned long (*tclpGetClicks) _ANSI_ARGS_((void)); /* 75 */
unsigned long (*tclpGetSeconds) _ANSI_ARGS_((void)); /* 76 */
@@ -632,8 +621,8 @@ typedef struct TclIntStubs {
int (*tclpListVolumes) _ANSI_ARGS_((Tcl_Interp * interp)); /* 79 */
Tcl_Channel (*tclpOpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, char * modeString, int permissions)); /* 80 */
char * (*tclpRealloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 81 */
- int (*tclpRemoveDirectory) _ANSI_ARGS_((CONST char * path, int recursive, Tcl_DString * errorPtr)); /* 82 */
- int (*tclpRenameFile) _ANSI_ARGS_((CONST char * source, CONST char * dest)); /* 83 */
+ void *reserved82;
+ void *reserved83;
void *reserved84;
void *reserved85;
void *reserved86;
@@ -703,11 +692,11 @@ typedef struct TclIntStubs {
size_t (*tclpStrftime) _ANSI_ARGS_((char * s, size_t maxsize, CONST char * format, CONST struct tm * t)); /* 134 */
int (*tclpCheckStackSpace) _ANSI_ARGS_((void)); /* 135 */
void *reserved136;
- int (*tclpChdir) _ANSI_ARGS_((CONST char * dirName)); /* 137 */
+ void *reserved137;
char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); /* 138 */
int (*tclpLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, char * sym1, char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, ClientData * clientDataPtr)); /* 139 */
int (*tclLooksLikeInt) _ANSI_ARGS_((char * bytes, int length)); /* 140 */
- char * (*tclpGetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 141 */
+ void *reserved141;
int (*tclSetByteCodeFromAny) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CompileHookProc * hookProc, ClientData clientData)); /* 142 */
int (*tclAddLiteralObj) _ANSI_ARGS_((struct CompileEnv * envPtr, Tcl_Obj * objPtr, LiteralEntry ** litPtrPtr)); /* 143 */
void (*tclHideLiteral) _ANSI_ARGS_((Tcl_Interp * interp, struct CompileEnv * envPtr, int index)); /* 144 */
@@ -726,9 +715,16 @@ typedef struct TclIntStubs {
Var * (*tclVarTraceExists) _ANSI_ARGS_((Tcl_Interp * interp, char * varName)); /* 157 */
void (*tclSetStartupScriptFileName) _ANSI_ARGS_((char * filename)); /* 158 */
char * (*tclGetStartupScriptFileName) _ANSI_ARGS_((void)); /* 159 */
- int (*tclpMatchFilesTypes) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * dirPtr, char * pattern, char * tail, GlobTypeData * types)); /* 160 */
+ void *reserved160;
int (*tclChannelTransform) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, Tcl_Obj * cmdObjPtr)); /* 161 */
void (*tclChannelEventScriptInvoker) _ANSI_ARGS_((ClientData clientData, int flags)); /* 162 */
+ int (*tclFileCopyCmd) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 163 */
+ int (*tclFileRenameCmd) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 164 */
+ int (*tclFileDeleteCmd) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 165 */
+ int (*tclFileMakeDirsCmd) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 166 */
+ int (*tclFileAttrsCmd) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 167 */
+ Tcl_Obj* (*tclpTempFileName) _ANSI_ARGS_((void)); /* 168 */
+ void (*tclpSetInitialEncodings) _ANSI_ARGS_((void)); /* 169 */
} TclIntStubs;
#ifdef __cplusplus
@@ -823,26 +819,11 @@ extern TclIntStubs *tclIntStubsPtr;
#define TclExprFloatError \
(tclIntStubsPtr->tclExprFloatError) /* 16 */
#endif
-#ifndef TclFileAttrsCmd
-#define TclFileAttrsCmd \
- (tclIntStubsPtr->tclFileAttrsCmd) /* 17 */
-#endif
-#ifndef TclFileCopyCmd
-#define TclFileCopyCmd \
- (tclIntStubsPtr->tclFileCopyCmd) /* 18 */
-#endif
-#ifndef TclFileDeleteCmd
-#define TclFileDeleteCmd \
- (tclIntStubsPtr->tclFileDeleteCmd) /* 19 */
-#endif
-#ifndef TclFileMakeDirsCmd
-#define TclFileMakeDirsCmd \
- (tclIntStubsPtr->tclFileMakeDirsCmd) /* 20 */
-#endif
-#ifndef TclFileRenameCmd
-#define TclFileRenameCmd \
- (tclIntStubsPtr->tclFileRenameCmd) /* 21 */
-#endif
+/* Slot 17 is reserved */
+/* Slot 18 is reserved */
+/* Slot 19 is reserved */
+/* Slot 20 is reserved */
+/* Slot 21 is reserved */
#ifndef TclFindElement
#define TclFindElement \
(tclIntStubsPtr->tclFindElement) /* 22 */
@@ -979,10 +960,7 @@ extern TclIntStubs *tclIntStubsPtr;
#define TclLookupVar \
(tclIntStubsPtr->tclLookupVar) /* 58 */
#endif
-#ifndef TclpMatchFiles
-#define TclpMatchFiles \
- (tclIntStubsPtr->tclpMatchFiles) /* 59 */
-#endif
+/* Slot 59 is reserved */
#ifndef TclNeedSpace
#define TclNeedSpace \
(tclIntStubsPtr->tclNeedSpace) /* 60 */
@@ -1023,22 +1001,10 @@ extern TclIntStubs *tclIntStubsPtr;
#define TclpAlloc \
(tclIntStubsPtr->tclpAlloc) /* 69 */
#endif
-#ifndef TclpCopyFile
-#define TclpCopyFile \
- (tclIntStubsPtr->tclpCopyFile) /* 70 */
-#endif
-#ifndef TclpCopyDirectory
-#define TclpCopyDirectory \
- (tclIntStubsPtr->tclpCopyDirectory) /* 71 */
-#endif
-#ifndef TclpCreateDirectory
-#define TclpCreateDirectory \
- (tclIntStubsPtr->tclpCreateDirectory) /* 72 */
-#endif
-#ifndef TclpDeleteFile
-#define TclpDeleteFile \
- (tclIntStubsPtr->tclpDeleteFile) /* 73 */
-#endif
+/* Slot 70 is reserved */
+/* Slot 71 is reserved */
+/* Slot 72 is reserved */
+/* Slot 73 is reserved */
#ifndef TclpFree
#define TclpFree \
(tclIntStubsPtr->tclpFree) /* 74 */
@@ -1071,14 +1037,8 @@ extern TclIntStubs *tclIntStubsPtr;
#define TclpRealloc \
(tclIntStubsPtr->tclpRealloc) /* 81 */
#endif
-#ifndef TclpRemoveDirectory
-#define TclpRemoveDirectory \
- (tclIntStubsPtr->tclpRemoveDirectory) /* 82 */
-#endif
-#ifndef TclpRenameFile
-#define TclpRenameFile \
- (tclIntStubsPtr->tclpRenameFile) /* 83 */
-#endif
+/* Slot 82 is reserved */
+/* Slot 83 is reserved */
/* Slot 84 is reserved */
/* Slot 85 is reserved */
/* Slot 86 is reserved */
@@ -1286,10 +1246,7 @@ extern TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclpCheckStackSpace) /* 135 */
#endif
/* Slot 136 is reserved */
-#ifndef TclpChdir
-#define TclpChdir \
- (tclIntStubsPtr->tclpChdir) /* 137 */
-#endif
+/* Slot 137 is reserved */
#ifndef TclGetEnv
#define TclGetEnv \
(tclIntStubsPtr->tclGetEnv) /* 138 */
@@ -1302,10 +1259,7 @@ extern TclIntStubs *tclIntStubsPtr;
#define TclLooksLikeInt \
(tclIntStubsPtr->tclLooksLikeInt) /* 140 */
#endif
-#ifndef TclpGetCwd
-#define TclpGetCwd \
- (tclIntStubsPtr->tclpGetCwd) /* 141 */
-#endif
+/* Slot 141 is reserved */
#ifndef TclSetByteCodeFromAny
#define TclSetByteCodeFromAny \
(tclIntStubsPtr->tclSetByteCodeFromAny) /* 142 */
@@ -1372,10 +1326,7 @@ extern TclIntStubs *tclIntStubsPtr;
#define TclGetStartupScriptFileName \
(tclIntStubsPtr->tclGetStartupScriptFileName) /* 159 */
#endif
-#ifndef TclpMatchFilesTypes
-#define TclpMatchFilesTypes \
- (tclIntStubsPtr->tclpMatchFilesTypes) /* 160 */
-#endif
+/* Slot 160 is reserved */
#ifndef TclChannelTransform
#define TclChannelTransform \
(tclIntStubsPtr->tclChannelTransform) /* 161 */
@@ -1384,6 +1335,34 @@ extern TclIntStubs *tclIntStubsPtr;
#define TclChannelEventScriptInvoker \
(tclIntStubsPtr->tclChannelEventScriptInvoker) /* 162 */
#endif
+#ifndef TclFileCopyCmd
+#define TclFileCopyCmd \
+ (tclIntStubsPtr->tclFileCopyCmd) /* 163 */
+#endif
+#ifndef TclFileRenameCmd
+#define TclFileRenameCmd \
+ (tclIntStubsPtr->tclFileRenameCmd) /* 164 */
+#endif
+#ifndef TclFileDeleteCmd
+#define TclFileDeleteCmd \
+ (tclIntStubsPtr->tclFileDeleteCmd) /* 165 */
+#endif
+#ifndef TclFileMakeDirsCmd
+#define TclFileMakeDirsCmd \
+ (tclIntStubsPtr->tclFileMakeDirsCmd) /* 166 */
+#endif
+#ifndef TclFileAttrsCmd
+#define TclFileAttrsCmd \
+ (tclIntStubsPtr->tclFileAttrsCmd) /* 167 */
+#endif
+#ifndef TclpTempFileName
+#define TclpTempFileName \
+ (tclIntStubsPtr->tclpTempFileName) /* 168 */
+#endif
+#ifndef TclpSetInitialEncodings
+#define TclpSetInitialEncodings \
+ (tclIntStubsPtr->tclpSetInitialEncodings) /* 169 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index 3b36b9c..9dd9975 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclLoad.c,v 1.4 1999/12/01 00:08:28 hobbs Exp $
+ * RCS: @(#) $Id: tclLoad.c,v 1.5 2001/07/31 19:12:06 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -19,7 +19,8 @@
* either dynamically (with the "load" command) or statically (as
* indicated by a call to TclGetLoadedPackages). All such packages
* are linked together into a single list for the process. Packages
- * are never unloaded, so these structures are never freed.
+ * are never unloaded, until the application exits, when
+ * TclFinalizeLoad is called, and these structures are freed.
*/
typedef struct LoadedPackage {
@@ -32,7 +33,7 @@ typedef struct LoadedPackage {
* others LC), no "_", as in "Net".
* Malloc-ed. */
ClientData clientData; /* Token for the loaded file which should be
- * passed to TclpUnloadFile() when the file
+ * passed to (*unLoadProcPtr)() when the file
* is no longer needed. If fileName is NULL,
* then this field is irrelevant. */
Tcl_PackageInitProc *initProc;
@@ -46,6 +47,11 @@ typedef struct LoadedPackage {
* untrusted scripts). NULL means the
* package can't be used in unsafe
* interpreters. */
+ Tcl_FSUnloadFileProc *unLoadProcPtr;
+ /* Procedure to use to unload this package.
+ * If NULL, then we do not attempt to unload
+ * the package. If fileName is NULL, then
+ * this field is irrelevant. */
struct LoadedPackage *nextPtr;
/* Next in list of all packages loaded into
* this application process. NULL means
@@ -113,12 +119,13 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv)
{
Tcl_Interp *target;
LoadedPackage *pkgPtr, *defaultPtr;
- Tcl_DString pkgName, tmp, initName, safeInitName, fileName;
+ Tcl_DString pkgName, tmp, initName, safeInitName;
Tcl_PackageInitProc *initProc, *safeInitProc;
InterpPackage *ipFirstPtr, *ipPtr;
int code, namesMatch, filesMatch;
- char *p, *tempString, *fullFileName, *packageName;
+ char *p, *fullFileName, *packageName;
ClientData clientData;
+ Tcl_FSUnloadFileProc *unLoadProcPtr = NULL;
Tcl_UniChar ch;
int offset;
@@ -126,11 +133,11 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv)
Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?");
return TCL_ERROR;
}
- tempString = Tcl_GetString(objv[1]);
- fullFileName = Tcl_TranslateFileName(interp, tempString, &fileName);
- if (fullFileName == NULL) {
+ if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
return TCL_ERROR;
}
+ fullFileName = Tcl_GetString(objv[1]);
+
Tcl_DStringInit(&pkgName);
Tcl_DStringInit(&initName);
Tcl_DStringInit(&safeInitName);
@@ -328,9 +335,9 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv)
*/
Tcl_MutexLock(&packageMutex);
- code = TclpLoadFile(interp, fullFileName, Tcl_DStringValue(&initName),
+ code = Tcl_FSLoadFile(interp, objv[1], Tcl_DStringValue(&initName),
Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc,
- &clientData);
+ &clientData,&unLoadProcPtr);
Tcl_MutexUnlock(&packageMutex);
if (code != TCL_OK) {
goto done;
@@ -338,7 +345,9 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv)
if (initProc == NULL) {
Tcl_AppendResult(interp, "couldn't find procedure ",
Tcl_DStringValue(&initName), (char *) NULL);
- TclpUnloadFile(clientData);
+ if (unLoadProcPtr != NULL) {
+ (*unLoadProcPtr)(clientData);
+ }
code = TCL_ERROR;
goto done;
}
@@ -355,6 +364,7 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv)
(Tcl_DStringLength(&pkgName) + 1));
strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName));
pkgPtr->clientData = clientData;
+ pkgPtr->unLoadProcPtr = unLoadProcPtr;
pkgPtr->initProc = initProc;
pkgPtr->safeInitProc = safeInitProc;
Tcl_MutexLock(&packageMutex);
@@ -410,7 +420,6 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv)
Tcl_DStringFree(&pkgName);
Tcl_DStringFree(&initName);
Tcl_DStringFree(&safeInitName);
- Tcl_DStringFree(&fileName);
Tcl_DStringFree(&tmp);
return code;
}
@@ -653,7 +662,10 @@ TclFinalizeLoad()
* call a function in the dll after it's been unloaded.
*/
if (pkgPtr->fileName[0] != '\0') {
- TclpUnloadFile(pkgPtr->clientData);
+ Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr;
+ if (unLoadProcPtr != NULL) {
+ (*unLoadProcPtr)(pkgPtr->clientData);
+ }
}
#endif
ckfree(pkgPtr->fileName);
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 1fe3582..54f55c6 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStubInit.c,v 1.53 2001/07/12 13:15:09 dkf Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.54 2001/07/31 19:12:06 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -80,11 +80,11 @@ TclIntStubs tclIntStubs = {
TclDumpMemoryInfo, /* 14 */
NULL, /* 15 */
TclExprFloatError, /* 16 */
- TclFileAttrsCmd, /* 17 */
- TclFileCopyCmd, /* 18 */
- TclFileDeleteCmd, /* 19 */
- TclFileMakeDirsCmd, /* 20 */
- TclFileRenameCmd, /* 21 */
+ NULL, /* 17 */
+ NULL, /* 18 */
+ NULL, /* 19 */
+ NULL, /* 20 */
+ NULL, /* 21 */
TclFindElement, /* 22 */
TclFindProc, /* 23 */
TclFormatInt, /* 24 */
@@ -122,7 +122,7 @@ TclIntStubs tclIntStubs = {
NULL, /* 56 */
NULL, /* 57 */
TclLookupVar, /* 58 */
- TclpMatchFiles, /* 59 */
+ NULL, /* 59 */
TclNeedSpace, /* 60 */
TclNewProcBodyObj, /* 61 */
TclObjCommandComplete, /* 62 */
@@ -133,10 +133,10 @@ TclIntStubs tclIntStubs = {
TclOpenFileChannelInsertProc, /* 67 */
TclpAccess, /* 68 */
TclpAlloc, /* 69 */
- TclpCopyFile, /* 70 */
- TclpCopyDirectory, /* 71 */
- TclpCreateDirectory, /* 72 */
- TclpDeleteFile, /* 73 */
+ NULL, /* 70 */
+ NULL, /* 71 */
+ NULL, /* 72 */
+ NULL, /* 73 */
TclpFree, /* 74 */
TclpGetClicks, /* 75 */
TclpGetSeconds, /* 76 */
@@ -145,8 +145,8 @@ TclIntStubs tclIntStubs = {
TclpListVolumes, /* 79 */
TclpOpenFileChannel, /* 80 */
TclpRealloc, /* 81 */
- TclpRemoveDirectory, /* 82 */
- TclpRenameFile, /* 83 */
+ NULL, /* 82 */
+ NULL, /* 83 */
NULL, /* 84 */
NULL, /* 85 */
NULL, /* 86 */
@@ -216,11 +216,11 @@ TclIntStubs tclIntStubs = {
TclpStrftime, /* 134 */
TclpCheckStackSpace, /* 135 */
NULL, /* 136 */
- TclpChdir, /* 137 */
+ NULL, /* 137 */
TclGetEnv, /* 138 */
TclpLoadFile, /* 139 */
TclLooksLikeInt, /* 140 */
- TclpGetCwd, /* 141 */
+ NULL, /* 141 */
TclSetByteCodeFromAny, /* 142 */
TclAddLiteralObj, /* 143 */
TclHideLiteral, /* 144 */
@@ -239,9 +239,16 @@ TclIntStubs tclIntStubs = {
TclVarTraceExists, /* 157 */
TclSetStartupScriptFileName, /* 158 */
TclGetStartupScriptFileName, /* 159 */
- TclpMatchFilesTypes, /* 160 */
+ NULL, /* 160 */
TclChannelTransform, /* 161 */
TclChannelEventScriptInvoker, /* 162 */
+ TclFileCopyCmd, /* 163 */
+ TclFileRenameCmd, /* 164 */
+ TclFileDeleteCmd, /* 165 */
+ TclFileMakeDirsCmd, /* 166 */
+ TclFileAttrsCmd, /* 167 */
+ TclpTempFileName, /* 168 */
+ TclpSetInitialEncodings, /* 169 */
};
TclIntPlatStubs tclIntPlatStubs = {
@@ -833,6 +840,44 @@ TclStubs tclStubs = {
Tcl_GetMathFuncInfo, /* 435 */
Tcl_ListMathFuncs, /* 436 */
Tcl_SubstObj, /* 437 */
+ Tcl_DetachChannel, /* 438 */
+ Tcl_IsStandardChannel, /* 439 */
+ Tcl_FSCopyFile, /* 440 */
+ Tcl_FSCopyDirectory, /* 441 */
+ Tcl_FSCreateDirectory, /* 442 */
+ Tcl_FSDeleteFile, /* 443 */
+ Tcl_FSLoadFile, /* 444 */
+ Tcl_FSMatchInDirectory, /* 445 */
+ Tcl_FSReadlink, /* 446 */
+ Tcl_FSRemoveDirectory, /* 447 */
+ Tcl_FSRenameFile, /* 448 */
+ Tcl_FSLstat, /* 449 */
+ Tcl_FSUtime, /* 450 */
+ Tcl_FSFileAttrsGet, /* 451 */
+ Tcl_FSFileAttrsSet, /* 452 */
+ Tcl_FSFileAttrStrings, /* 453 */
+ Tcl_FSStat, /* 454 */
+ Tcl_FSAccess, /* 455 */
+ Tcl_FSOpenFileChannel, /* 456 */
+ Tcl_FSGetCwd, /* 457 */
+ Tcl_FSChdir, /* 458 */
+ Tcl_FSConvertToPathType, /* 459 */
+ Tcl_FSJoinPath, /* 460 */
+ Tcl_FSSplitPath, /* 461 */
+ Tcl_FSEqualPaths, /* 462 */
+ Tcl_FSGetNormalizedPath, /* 463 */
+ Tcl_FSJoinToPath, /* 464 */
+ Tcl_FSGetInternalRep, /* 465 */
+ Tcl_FSGetTranslatedPath, /* 466 */
+ Tcl_FSEvalFile, /* 467 */
+ Tcl_FSNewNativePath, /* 468 */
+ Tcl_FSGetNativePath, /* 469 */
+ Tcl_FSFileSystemInfo, /* 470 */
+ Tcl_FSPathSeparator, /* 471 */
+ Tcl_FSListVolumes, /* 472 */
+ Tcl_FSRegister, /* 473 */
+ Tcl_FSUnregister, /* 474 */
+ Tcl_FSData, /* 475 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 8c3ae5c..08925bd 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTest.c,v 1.25 2001/04/04 17:35:25 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.26 2001/07/31 19:12:06 vincentdarley Exp $
*/
#define TCL_TEST
@@ -301,7 +301,73 @@ static int TestChannelCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
static int TestChannelEventCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
+/* Filesystem testing */
+static int TestFilesystemObjCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+
+static void TestReport _ANSI_ARGS_((CONST char* cmd, Tcl_Obj* arg1, Tcl_Obj* arg2));
+
+static Tcl_FSStatProc TestReportStat;
+static Tcl_FSAccessProc TestReportAccess;
+static Tcl_FSOpenFileChannelProc TestReportOpenFileChannel;
+static Tcl_FSMatchInDirectoryProc TestReportMatchInDirectory;
+static Tcl_FSGetCwdProc TestReportGetCwd;
+static Tcl_FSChdirProc TestReportChdir;
+static Tcl_FSLstatProc TestReportLstat;
+static Tcl_FSCopyFileProc TestReportCopyFile;
+static Tcl_FSDeleteFileProc TestReportDeleteFile;
+static Tcl_FSRenameFileProc TestReportRenameFile;
+static Tcl_FSCreateDirectoryProc TestReportCreateDirectory;
+static Tcl_FSCopyDirectoryProc TestReportCopyDirectory;
+static Tcl_FSRemoveDirectoryProc TestReportRemoveDirectory;
+static Tcl_FSLoadFileProc TestReportLoadFile;
+static Tcl_FSUnloadFileProc TestReportUnloadFile;
+static Tcl_FSReadlinkProc TestReportReadlink;
+static Tcl_FSListVolumesProc TestReportListVolumes;
+static Tcl_FSFileAttrStringsProc TestReportFileAttrStrings;
+static Tcl_FSFileAttrsGetProc TestReportFileAttrsGet;
+static Tcl_FSFileAttrsSetProc TestReportFileAttrsSet;
+static Tcl_FSUtimeProc TestReportUtime;
+static Tcl_FSNormalizePathProc TestReportNormalizePath;
+
+static Tcl_Filesystem testReportingFilesystem = {
+ "reporting",
+ sizeof(Tcl_Filesystem),
+ TCL_FILESYSTEM_VERSION_1,
+ NULL, /* path in */
+ NULL, /* native dup */
+ NULL, /* native free */
+ NULL, /* native to norm */
+ NULL, /* convert to native */
+ &TestReportNormalizePath,
+ NULL, /* path type */
+ NULL, /* separator */
+ &TestReportStat,
+ &TestReportAccess,
+ &TestReportOpenFileChannel,
+ &TestReportMatchInDirectory,
+ &TestReportUtime,
+ &TestReportReadlink,
+ &TestReportListVolumes,
+ &TestReportFileAttrStrings,
+ &TestReportFileAttrsGet,
+ &TestReportFileAttrsSet,
+ &TestReportCreateDirectory,
+ &TestReportRemoveDirectory,
+ &TestReportDeleteFile,
+ &TestReportLstat,
+ &TestReportCopyFile,
+ &TestReportRenameFile,
+ &TestReportCopyDirectory,
+ &TestReportLoadFile,
+ &TestReportUnloadFile,
+ &TestReportGetCwd,
+ &TestReportChdir
+};
+
+
/*
* External (platform specific) initialization routine, these declarations
* explicitly don't use EXTERN since this code does not get compiled
@@ -352,6 +418,8 @@ Tcltest_Init(interp)
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct",
TestGetIndexFromObjStructObjCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
@@ -4269,10 +4337,18 @@ TestOpenFileChannelProc1(interp, fileName, modeString, permissions)
* file, with what modes to create
* it? */
{
- if (!strcmp("testOpenFileChannel1%.fil", fileName)) {
+ char *expectname="testOpenFileChannel1%.fil";
+ Tcl_DString ds;
+
+ Tcl_DStringInit(&ds);
+ Tcl_JoinPath(1, &expectname, &ds);
+
+ if (!strcmp(Tcl_DStringValue(&ds), fileName)) {
+ Tcl_DStringFree(&ds);
return (TclpOpenFileChannel(interp, "__testOpenFileChannel1%__.fil",
modeString, permissions));
} else {
+ Tcl_DStringFree(&ds);
return (NULL);
}
}
@@ -4289,10 +4365,18 @@ TestOpenFileChannelProc2(interp, fileName, modeString, permissions)
* file, with what modes to create
* it? */
{
- if (!strcmp("testOpenFileChannel2%.fil", fileName)) {
+ char *expectname="testOpenFileChannel2%.fil";
+ Tcl_DString ds;
+
+ Tcl_DStringInit(&ds);
+ Tcl_JoinPath(1, &expectname, &ds);
+
+ if (!strcmp(Tcl_DStringValue(&ds), fileName)) {
+ Tcl_DStringFree(&ds);
return (TclpOpenFileChannel(interp, "__testOpenFileChannel2%__.fil",
modeString, permissions));
} else {
+ Tcl_DStringFree(&ds);
return (NULL);
}
}
@@ -4309,10 +4393,18 @@ TestOpenFileChannelProc3(interp, fileName, modeString, permissions)
* file, with what modes to create
* it? */
{
- if (!strcmp("testOpenFileChannel3%.fil", fileName)) {
+ char *expectname="testOpenFileChannel3%.fil";
+ Tcl_DString ds;
+
+ Tcl_DStringInit(&ds);
+ Tcl_JoinPath(1, &expectname, &ds);
+
+ if (!strcmp(Tcl_DStringValue(&ds), fileName)) {
+ Tcl_DStringFree(&ds);
return (TclpOpenFileChannel(interp, "__testOpenFileChannel3%__.fil",
modeString, permissions));
} else {
+ Tcl_DStringFree(&ds);
return (NULL);
}
}
@@ -4535,6 +4627,17 @@ TestChannelCmd(clientData, interp, argc, argv)
return TCL_OK;
}
+ if ((cmdName[0] == 'i') && (strncmp(cmdName, "isstandard", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ TclFormatInt(buf, Tcl_IsStandardChannel(chan));
+ Tcl_AppendResult(interp, buf, (char *) NULL);
+ return TCL_OK;
+ }
+
if ((cmdName[0] == 'm') && (strncmp(cmdName, "mode", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required",
@@ -5053,3 +5156,296 @@ TestGetIndexFromObjStructObjCmd(dummy, interp, objc, objv)
Tcl_WrongNumArgs(interp, 3, objv, NULL);
return TCL_OK;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestFilesystemObjCmd --
+ *
+ * This procedure implements the "testfilesystem" command. It is
+ * used to test Tcl_FSRegister, Tcl_FSUnregister, and can be used
+ * to test that the pluggable filesystem works.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Inserts or removes a filesystem from Tcl's stack.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestFilesystemObjCmd(dummy, interp, objc, objv)
+ ClientData dummy;
+ Tcl_Interp *interp;
+ int objc;
+ Tcl_Obj *CONST objv[];
+{
+ int res;
+ int onOff;
+
+ if (objc != 2) {
+ char *cmd = Tcl_GetString(objv[0]);
+ Tcl_AppendResult(interp, "wrong # args: should be \"", cmd,
+ " (1 or 0)\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBooleanFromObj(interp, objv[1], &onOff) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (onOff) {
+ res = Tcl_FSRegister((ClientData)interp, &testReportingFilesystem);
+ if (res == TCL_OK) {
+ Tcl_SetResult(interp, "registered", TCL_STATIC);
+ } else {
+ Tcl_SetResult(interp, "failed", TCL_STATIC);
+ }
+ } else {
+ res = Tcl_FSUnregister(&testReportingFilesystem);
+ if (res == TCL_OK) {
+ Tcl_SetResult(interp, "unregistered", TCL_STATIC);
+ } else {
+ Tcl_SetResult(interp, "failed", TCL_STATIC);
+ }
+ }
+ return res;
+}
+
+void
+TestReport(cmd, arg1, arg2)
+ CONST char* cmd;
+ Tcl_Obj* arg1;
+ Tcl_Obj* arg2;
+{
+ Tcl_Interp* interp = (Tcl_Interp*) Tcl_FSData(&testReportingFilesystem);
+ if (interp == NULL) {
+ /* This is bad, but not much we can do about it */
+ } else {
+ Tcl_SavedResult savedResult;
+ Tcl_DString ds;
+ Tcl_DStringInit(&ds);
+ Tcl_DStringAppend(&ds, "puts stderr ",-1);
+ Tcl_DStringStartSublist(&ds);
+ Tcl_DStringAppendElement(&ds, cmd);
+ if (arg1 != NULL) {
+ Tcl_DStringAppendElement(&ds, Tcl_GetString(arg1));
+ }
+ if (arg2 != NULL) {
+ Tcl_DStringAppendElement(&ds, Tcl_GetString(arg2));
+ }
+ Tcl_DStringEndSublist(&ds);
+ Tcl_SaveResult(interp, &savedResult);
+ Tcl_Eval(interp, Tcl_DStringValue(&ds));
+ Tcl_DStringFree(&ds);
+ Tcl_RestoreResult(interp, &savedResult);
+ }
+}
+int
+TestReportStat(path, buf)
+ Tcl_Obj *path; /* Path of file to stat (in current CP). */
+ struct stat *buf; /* Filled with results of stat call. */
+{
+ TestReport("stat",path, NULL);
+ return -1;
+}
+int
+TestReportLstat(path, buf)
+ Tcl_Obj *path; /* Path of file to stat (in current CP). */
+ struct stat *buf; /* Filled with results of stat call. */
+{
+ TestReport("lstat",path, NULL);
+ return -1;
+}
+int
+TestReportAccess(path, mode)
+ Tcl_Obj *path; /* Path of file to access (in current CP). */
+ int mode; /* Permission setting. */
+{
+ TestReport("access",path,NULL);
+ return -1;
+}
+Tcl_Channel
+TestReportOpenFileChannel(interp, fileName, modeString, permissions)
+ Tcl_Interp *interp; /* Interpreter for error reporting;
+ * can be NULL. */
+ Tcl_Obj *fileName; /* Name of file to open. */
+ 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? */
+{
+ TestReport("open",fileName, NULL);
+ return NULL;
+}
+
+int
+TestReportMatchInDirectory(interp, resultPtr, dirPtr, pattern, types)
+ Tcl_Interp *interp; /* Interpreter to receive results. */
+ Tcl_Obj *resultPtr; /* Directory separators to pass to TclDoGlob. */
+ Tcl_Obj *dirPtr; /* Contains path to directory to search. */
+ char *pattern; /* Pattern to match against. */
+ Tcl_GlobTypeData *types; /* Object containing list of acceptable types.
+ * May be NULL. */
+{
+ TestReport("matchindirectory",dirPtr, NULL);
+ return -1;
+}
+Tcl_Obj *
+TestReportGetCwd(interp)
+ Tcl_Interp *interp;
+{
+ TestReport("cwd",NULL,NULL);
+ return NULL;
+}
+int
+TestReportChdir(dirName)
+ Tcl_Obj *dirName;
+{
+ TestReport("chdir",dirName,NULL);
+ return -1;
+}
+int
+TestReportLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Obj *fileName; /* Name of the file containing the desired
+ * code. */
+ char *sym1, *sym2; /* Names of two procedures to look up in
+ * the file's symbol table. */
+ Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
+ /* Where to return the addresses corresponding
+ * to sym1 and sym2. */
+ ClientData *clientDataPtr; /* Filled with token for dynamically loaded
+ * file which will be passed back to
+ * TclpUnloadFile() to unload the file. */
+{
+ TestReport("loadfile",fileName,NULL);
+ return -1;
+}
+void
+TestReportUnloadFile(clientData)
+ ClientData clientData; /* ClientData returned by a previous call
+ * to TclpLoadFile(). The clientData is
+ * a token that represents the loaded
+ * file. */
+{
+ TestReport("unloadfile",NULL,NULL);
+}
+Tcl_Obj *
+TestReportReadlink(path)
+ Tcl_Obj *path; /* Path of file to readlink (UTF-8). */
+{
+ TestReport("readlink",path,NULL);
+ return NULL;
+}
+int
+TestReportListVolumes(interp)
+ Tcl_Interp *interp; /* Interpreter for returning volume list. */
+{
+ TestReport("listvolumes",NULL,NULL);
+ return TCL_OK;
+}
+int
+TestReportRenameFile(src, dst)
+ Tcl_Obj *src; /* Pathname of file or dir to be renamed
+ * (UTF-8). */
+ Tcl_Obj *dst; /* New pathname of file or directory
+ * (UTF-8). */
+{
+ TestReport("renamefile",src,dst);
+ return -1;
+}
+int
+TestReportCopyFile(src, dst)
+ Tcl_Obj *src; /* Pathname of file to be copied (UTF-8). */
+ Tcl_Obj *dst; /* Pathname of file to copy to (UTF-8). */
+{
+ TestReport("copyfile",src,dst);
+ return -1;
+}
+int
+TestReportDeleteFile(path)
+ Tcl_Obj *path; /* Pathname of file to be removed (UTF-8). */
+{
+ TestReport("deletefile",path,NULL);
+ return -1;
+}
+int
+TestReportCreateDirectory(path)
+ Tcl_Obj *path; /* Pathname of directory to create (UTF-8). */
+{
+ TestReport("createdirectory",path,NULL);
+ return -1;
+}
+int
+TestReportCopyDirectory(src, dst, errorPtr)
+ Tcl_Obj *src; /* Pathname of directory to be copied
+ * (UTF-8). */
+ Tcl_Obj *dst; /* Pathname of target directory (UTF-8). */
+ Tcl_Obj **errorPtr; /* If non-NULL, uninitialized or free
+ * DString filled with UTF-8 name of file
+ * causing error. */
+{
+ TestReport("copydirectory",src,dst);
+ return -1;
+}
+int
+TestReportRemoveDirectory(path, recursive, errorPtr)
+ Tcl_Obj *path; /* 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, uninitialized or free
+ * DString filled with UTF-8 name of file
+ * causing error. */
+{
+ TestReport("removedirectory",path,NULL);
+ return -1;
+}
+char**
+TestReportFileAttrStrings(fileName, objPtrRef)
+ Tcl_Obj* fileName;
+ Tcl_Obj** objPtrRef;
+{
+ TestReport("fileattributestrings",fileName,NULL);
+ return NULL;
+}
+int
+TestReportFileAttrsGet(interp, index, fileName, objPtrRef)
+ Tcl_Interp *interp; /* The interpreter for error reporting. */
+ int index; /* index of the attribute command. */
+ Tcl_Obj *fileName; /* filename we are operating on. */
+ Tcl_Obj **objPtrRef; /* for output. */
+{
+ TestReport("fileattributesget",fileName,NULL);
+ return -1;
+}
+int
+TestReportFileAttrsSet(interp, index, fileName, objPtr)
+ Tcl_Interp *interp; /* The interpreter for error reporting. */
+ int index; /* index of the attribute command. */
+ Tcl_Obj *fileName; /* filename we are operating on. */
+ Tcl_Obj *objPtr; /* for input. */
+{
+ TestReport("fileattributesset",fileName,objPtr);
+ return -1;
+}
+int
+TestReportUtime (fileName, tval)
+ Tcl_Obj* fileName;
+ struct utimbuf *tval;
+{
+ TestReport("utime",fileName,NULL);
+ return -1;
+}
+int
+TestReportNormalizePath(interp, pathPtr, nextCheckpoint)
+ Tcl_Interp *interp;
+ Tcl_Obj *pathPtr;
+ int nextCheckpoint;
+{
+ TestReport("normalizepath",pathPtr,NULL);
+ return nextCheckpoint;
+}
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 340d004..daab08c 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclUtil.c,v 1.20 2001/07/03 03:33:42 hobbs Exp $
+ * RCS: @(#) $Id: tclUtil.c,v 1.21 2001/07/31 19:12:07 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -2274,103 +2274,3 @@ Tcl_GetNameOfExecutable()
{
return (tclExecutableName);
}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetCwd --
- *
- * This function replaces the library version of getcwd().
- *
- * Results:
- * The result is a pointer to a string 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. Storage for the result string is allocated in
- * bufferPtr; the caller must call Tcl_DStringFree() when the result
- * is no longer needed.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-char *
-Tcl_GetCwd(interp, cwdPtr)
- Tcl_Interp *interp;
- Tcl_DString *cwdPtr;
-{
- return TclpGetCwd(interp, cwdPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_Chdir --
- *
- * This function replaces the library version of chdir().
- *
- * Results:
- * See chdir() documentation.
- *
- * Side effects:
- * See chdir() documentation.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_Chdir(dirName)
- CONST char *dirName;
-{
- return TclpChdir(dirName);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_Access --
- *
- * This function replaces the library version of access().
- *
- * Results:
- * See access() documentation.
- *
- * Side effects:
- * See access() documentation.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_Access(path, mode)
- CONST char *path; /* Path of file to access (UTF-8). */
- int mode; /* Permission setting. */
-{
- return TclAccess(path, mode);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_Stat --
- *
- * This function replaces the library version of stat().
- *
- * Results:
- * See stat() documentation.
- *
- * Side effects:
- * See stat() documentation.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_Stat(path, bufPtr)
- CONST char *path; /* Path of file to stat (in UTF-8). */
- struct stat *bufPtr; /* Filled with results of stat call. */
-{
- return TclStat(path, bufPtr);
-}
generated by cgit v0.12 at 2024-11-25 15:42:53 (GMT)