summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorvincentdarley <vincentdarley>2001-09-04 18:06:34 (GMT)
committervincentdarley <vincentdarley>2001-09-04 18:06:34 (GMT)
commit6fca271a5115b8b8e94f10dce8efb41fcedb53a9 (patch)
treefe242e0e386c2472085adf41540fa813c334a000 /generic
parentbaf84f971d4274324372aab6f0fd968c63d7dcd4 (diff)
downloadtcl-6fca271a5115b8b8e94f10dce8efb41fcedb53a9.zip
tcl-6fca271a5115b8b8e94f10dce8efb41fcedb53a9.tar.gz
tcl-6fca271a5115b8b8e94f10dce8efb41fcedb53a9.tar.bz2
minor fs, vfs fixes
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.decls10
-rw-r--r--generic/tcl.h11
-rw-r--r--generic/tclCmdAH.c50
-rw-r--r--generic/tclDecls.h17
-rw-r--r--generic/tclFCmd.c56
-rw-r--r--generic/tclFileName.c217
-rw-r--r--generic/tclIOUtil.c238
-rw-r--r--generic/tclInt.h13
-rw-r--r--generic/tclStubInit.c4
-rw-r--r--generic/tclTest.c156
10 files changed, 520 insertions, 252 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 7a93099..f0f64a9 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.53 2001/08/30 08:53:14 vincentdarley Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.54 2001/09/04 18:06:34 vincentdarley Exp $
library tcl
@@ -1667,7 +1667,13 @@ declare 475 generic {
declare 476 generic {
char* Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp, Tcl_Obj* pathPtr)
}
-
+declare 477 generic {
+ Tcl_Filesystem* Tcl_FSGetFileSystemForPath(Tcl_Obj* pathObjPtr)
+}
+declare 478 generic {
+ Tcl_PathType Tcl_FSGetPathType (Tcl_Obj *pathObjPtr)
+}
+
##############################################################################
# Define the platform specific public Tcl interface. These functions are
diff --git a/generic/tcl.h b/generic/tcl.h
index 91e5627..46ef74d 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.97 2001/08/30 15:41:29 dgp Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.98 2001/09/04 18:06:34 vincentdarley Exp $
*/
#ifndef _TCL
@@ -1554,7 +1554,8 @@ typedef int (Tcl_FSLoadFileProc) _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj *pathPtr, char * sym1, char * sym2,
Tcl_PackageInitProc ** proc1Ptr,
Tcl_PackageInitProc ** proc2Ptr,
- ClientData * clientDataPtr));
+ ClientData * clientDataPtr,
+ Tcl_FSUnloadFileProc **unloadProcPtr));
typedef int (Tcl_FSPathInFilesystemProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
ClientData *clientDataPtr));
typedef Tcl_Obj* (Tcl_FSFilesystemPathTypeProc)
@@ -1739,12 +1740,6 @@ typedef struct Tcl_Filesystem {
* 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()'
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 0793a2e..3ea9aad 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -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: tclCmdAH.c,v 1.14 2001/08/23 17:37:07 vincentdarley Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.15 2001/09/04 18:06:34 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -878,48 +878,18 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
return TclFileDeleteCmd(interp, objc, objv);
}
case FILE_DIRNAME: {
- int splitElements;
- Tcl_Obj *splitPtr;
- Tcl_Obj *splitResultPtr = NULL;
-
+ Tcl_Obj *dirPtr;
if (objc != 3) {
goto only3Args;
}
- /*
- * The behaviour we want here is slightly different to
- * the standard Tcl_FSSplitPath in the handling of home
- * directories; Tcl_FSSplitPath preserves the "~" while
- * this code computes the actual full path name, if we
- * had just a single component.
- */
- splitPtr = Tcl_FSSplitPath(objv[2], &splitElements);
- if ((splitElements == 1) && (Tcl_GetString(objv[2])[0] == '~')) {
- Tcl_DecrRefCount(splitPtr);
- splitPtr = Tcl_FSGetNormalizedPath(interp, objv[2]);
- if (splitPtr == NULL) {
- return TCL_ERROR;
- }
- splitPtr = Tcl_FSSplitPath(splitPtr, &splitElements);
- }
-
- /*
- * Return all but the last component. If there is only one
- * component, return it if the path was non-relative, otherwise
- * return the current directory.
- */
-
- if (splitElements > 1) {
- splitResultPtr = Tcl_FSJoinPath(splitPtr, splitElements - 1);
- } else if (splitElements == 0 ||
- (Tcl_FSGetPathType(objv[2], NULL, NULL) == TCL_PATH_RELATIVE)) {
- splitResultPtr = Tcl_NewStringObj(
- ((tclPlatform == TCL_PLATFORM_MAC) ? ":" : "."), 1);
+ dirPtr = TclFileDirname(interp, objv[2]);
+ if (dirPtr == NULL) {
+ return TCL_ERROR;
} else {
- Tcl_ListObjIndex(NULL, splitPtr, 0, &splitResultPtr);
+ Tcl_SetObjResult(interp, dirPtr);
+ Tcl_DecrRefCount(dirPtr);
+ return TCL_OK;
}
- Tcl_SetObjResult(interp, splitResultPtr);
- Tcl_DecrRefCount(splitPtr);
- return TCL_OK;
}
case FILE_EXECUTABLE: {
if (objc != 3) {
@@ -1099,7 +1069,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
if (objc != 3) {
goto only3Args;
}
- switch (Tcl_FSGetPathType(objv[2], NULL, NULL)) {
+ switch (Tcl_FSGetPathType(objv[2])) {
case TCL_PATH_ABSOLUTE:
Tcl_SetStringObj(Tcl_GetObjResult(interp), "absolute", -1);
break;
@@ -1272,7 +1242,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
if (splitElements > 0) {
if ((splitElements > 1)
- || (Tcl_FSGetPathType(objv[2], NULL, NULL) == TCL_PATH_RELATIVE)) {
+ || (Tcl_FSGetPathType(objv[2]) == TCL_PATH_RELATIVE)) {
Tcl_Obj *tail = NULL;
Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &tail);
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 8aa701d..e7c744a 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.54 2001/08/23 17:37:07 vincentdarley Exp $
+ * RCS: @(#) $Id: tclDecls.h,v 1.55 2001/09/04 18:06:34 vincentdarley Exp $
*/
#ifndef _TCLDECLS
@@ -1490,6 +1490,11 @@ EXTERN ClientData Tcl_FSData _ANSI_ARGS_((Tcl_Filesystem * fsPtr));
/* 476 */
EXTERN char* Tcl_FSGetTranslatedStringPath _ANSI_ARGS_((
Tcl_Interp * interp, Tcl_Obj* pathPtr));
+/* 477 */
+EXTERN Tcl_Filesystem* Tcl_FSGetFileSystemForPath _ANSI_ARGS_((
+ Tcl_Obj* pathObjPtr));
+/* 478 */
+EXTERN Tcl_PathType Tcl_FSGetPathType _ANSI_ARGS_((Tcl_Obj * pathObjPtr));
typedef struct TclStubHooks {
struct TclPlatStubs *tclPlatStubs;
@@ -2026,6 +2031,8 @@ typedef struct TclStubs {
int (*tcl_FSUnregister) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 474 */
ClientData (*tcl_FSData) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 475 */
char* (*tcl_FSGetTranslatedStringPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 476 */
+ Tcl_Filesystem* (*tcl_FSGetFileSystemForPath) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 477 */
+ Tcl_PathType (*tcl_FSGetPathType) _ANSI_ARGS_((Tcl_Obj * pathObjPtr)); /* 478 */
} TclStubs;
#ifdef __cplusplus
@@ -3974,6 +3981,14 @@ extern TclStubs *tclStubsPtr;
#define Tcl_FSGetTranslatedStringPath \
(tclStubsPtr->tcl_FSGetTranslatedStringPath) /* 476 */
#endif
+#ifndef Tcl_FSGetFileSystemForPath
+#define Tcl_FSGetFileSystemForPath \
+ (tclStubsPtr->tcl_FSGetFileSystemForPath) /* 477 */
+#endif
+#ifndef Tcl_FSGetPathType
+#define Tcl_FSGetPathType \
+ (tclStubsPtr->tcl_FSGetPathType) /* 478 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index 035446f..c05b7a4 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.11 2001/08/30 08:53:14 vincentdarley Exp $
+ * RCS: @(#) $Id: tclFCmd.c,v 1.12 2001/09/04 18:06:34 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -599,53 +599,13 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
}
} else {
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.
+ if (result != TCL_OK) {
+ /*
+ * We could examine 'errno' to double-check if the problem
+ * was with the target, but we checked the source above,
+ * so it should be quite clear
*/
- 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);
- }
- }
+ errfile = target;
}
}
if ((copyFlag == 0) && (result == TCL_OK)) {
@@ -792,7 +752,7 @@ FileBasename(interp, pathPtr)
if (objc > 0) {
Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr);
if ((objc == 1) &&
- (Tcl_FSGetPathType(resultPtr, NULL, NULL) != TCL_PATH_RELATIVE)) {
+ (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) {
resultPtr = NULL;
}
}
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index 1839564..3eb9a17 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -10,25 +10,17 @@
* 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.19 2001/08/30 08:53:14 vincentdarley Exp $
+ * RCS: @(#) $Id: tclFileName.c,v 1.20 2001/09/04 18:06:34 vincentdarley Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
#include "tclRegexp.h"
-/*
- * The following regular expression matches the root portion of a Windows
- * absolute or volume relative path. It will match both UNC and drive relative
- * paths. This pattern is no longer used, since it has been replaced by
- * the ExtractWinRoot function.
- */
-
-#define WIN_ROOT_PATTERN "^(([a-zA-Z]:)|[/\\\\][/\\\\]+([^/\\\\]+)[/\\\\]+([^/\\\\]+)|([/\\\\]))([/\\\\])*"
-
/*
* This define is used to activate Tcl's interpretation of Unix-style
- * paths (containing forward slashes) on MacOS.
+ * paths (containing forward slashes, '.' and '..') on MacOS. A
+ * side-effect of this is that some paths become ambiguous.
*/
#define MAC_UNDERSTANDS_UNIX_PATHS
@@ -36,19 +28,19 @@
/*
* The following regular expression matches the root portion of a Macintosh
* absolute path. It will match degenerate Unix-style paths, tilde paths,
- * Unix-style paths, and Mac paths.
+ * Unix-style paths, and Mac paths. The various subexpressions in this
+ * can be summarised as follows: ^(/..|~user/unix|~user:mac|/unix|mac:dir).
+ * The subexpression indices which match the root portions, are as follows:
+ *
+ * degenerate unix-style: 2
+ * unix-tilde: 5
+ * mac-tilde: 7
+ * unix-style: 9 (or 10 to cut off the irrelevant header).
+ * mac: 12
+ *
*/
#define MAC_ROOT_PATTERN "^((/+([.][.]?/+)*([.][.]?)?)|(~[^:/]*)(/[^:]*)?|(~[^:]*)(:.*)?|/+([.][.]?/+)*([^:/]+)(/[^:]*)?|([^:]+):.*)$"
-#else
-/*
- * The following regular expression and some code below needs to be updated
- * to allow complete removal of unix-style path matching. For the moment
- * this regular expression is the same as the one above.
- */
-
-#define MAC_ROOT_PATTERN "^((/+([.][.]?/+)*([.][.]?)?)|(~[^:/]*)(/[^:]*)?|(~[^:]*)(:.*)?|/+([.][.]?/+)*([^:/]+)(/[^:]*)?|([^:]+):.*)$"
-#endif
/*
* The following variables are used to hold precompiled regular expressions
@@ -62,6 +54,11 @@ typedef struct ThreadSpecificData {
static Tcl_ThreadDataKey dataKey;
+static void FileNameCleanup _ANSI_ARGS_((ClientData clientData));
+static void FileNameInit _ANSI_ARGS_((void));
+
+#endif
+
/*
* The following variable is set in the TclPlatformInit call to one
* of: TCL_PLATFORM_UNIX, TCL_PLATFORM_MAC, or TCL_PLATFORM_WINDOWS.
@@ -78,13 +75,12 @@ static char * DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp,
static CONST char * ExtractWinRoot _ANSI_ARGS_((CONST char *path,
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,
char *match));
static Tcl_Obj* SplitMacPath _ANSI_ARGS_((CONST char *path));
static Tcl_Obj* SplitWinPath _ANSI_ARGS_((CONST char *path));
static Tcl_Obj* SplitUnixPath _ANSI_ARGS_((CONST char *path));
+#ifdef MAC_UNDERSTANDS_UNIX_PATHS
/*
*----------------------------------------------------------------------
@@ -138,6 +134,7 @@ FileNameCleanup(clientData)
Tcl_DecrRefCount(tsdPtr->macRootPatternPtr);
tsdPtr->initialized = 0;
}
+#endif
/*
*----------------------------------------------------------------------
@@ -167,8 +164,6 @@ ExtractWinRoot(path, resultPtr, offset, typePtr)
* stored. */
Tcl_PathType *typePtr; /* Where to store pathType result */
{
- FileNameInit();
-
if (path[0] == '/' || path[0] == '\\') {
/* Might be a UNC or Vol-Relative path */
char *host, *share, *tail;
@@ -192,7 +187,14 @@ ExtractWinRoot(path, resultPtr, offset, typePtr)
/*
* The path given is simply of the form
* '/foo', '//foo', '/////foo' or the same
- * with backslashes.
+ * with backslashes. If there is exactly
+ * one leading '/' the path is volume relative
+ * (see filename man page). If there are more
+ * than one, we are simply assuming they
+ * are superfluous and we trim them away.
+ * (An alternative interpretation would
+ * be that it is a host name, but we have
+ * been documented that that is not the case).
*/
*typePtr = TCL_PATH_VOLUME_RELATIVE;
Tcl_DStringAppend(resultPtr, "/", 1);
@@ -275,7 +277,7 @@ Tcl_GetPathType(path)
Tcl_PathType type;
Tcl_Obj *tempObj = Tcl_NewStringObj(path,-1);
Tcl_IncrRefCount(tempObj);
- type = Tcl_FSGetPathType(tempObj, NULL, NULL);
+ type = Tcl_FSGetPathType(tempObj);
Tcl_DecrRefCount(tempObj);
return type;
}
@@ -362,6 +364,7 @@ TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, driveNameRef)
if (path[0] == ':') {
type = TCL_PATH_RELATIVE;
} else {
+#ifdef MAC_UNDERSTANDS_UNIX_PATHS
ThreadSpecificData *tsdPtr;
Tcl_RegExp re;
@@ -380,7 +383,6 @@ TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, driveNameRef)
type = TCL_PATH_RELATIVE;
} else {
char *root, *end;
-
Tcl_RegExpRange(re, 2, &root, &end);
if (root != NULL) {
type = TCL_PATH_RELATIVE;
@@ -389,7 +391,6 @@ TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, driveNameRef)
Tcl_RegExpRange(re, 0, &root, &end);
*driveNameLengthPtr = end - root;
}
-#ifdef MAC_UNDERSTANDS_UNIX_PATHS
if (driveNameRef != NULL) {
if (*root == '/') {
char *c;
@@ -416,9 +417,25 @@ TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, driveNameRef)
}
}
}
-#endif
}
}
+#else
+ if (path[0] == '~') {
+ } else if (path[0] == ':') {
+ type = TCL_PATH_RELATIVE;
+ } else {
+ char *colonPos = strchr(path,':');
+ if (colonPos == NULL) {
+ type = TCL_PATH_RELATIVE;
+ } else {
+ }
+ }
+ if (type == TCL_PATH_ABSOLUTE) {
+ if (driveNameLengthPtr != NULL) {
+ *driveNameLengthPtr = strlen(path);
+ }
+ }
+#endif
}
break;
@@ -762,14 +779,18 @@ SplitMacPath(path)
CONST char *path; /* Pointer to string containing a path. */
{
int isMac = 0; /* 1 if is Mac-style, 0 if Unix-style path. */
- int i, length;
+ int length;
CONST char *p, *elementStart;
- Tcl_RegExp re;
Tcl_Obj *result;
+#ifdef MAC_UNDERSTANDS_UNIX_PATHS
+ Tcl_RegExp re;
+ int i;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
+#endif
+
result = Tcl_NewObj();
+#ifdef MAC_UNDERSTANDS_UNIX_PATHS
/*
* Initialize the path name parser for Macintosh path names.
*/
@@ -843,13 +864,11 @@ SplitMacPath(path)
}
}
}
-
Tcl_RegExpRange(re, i, &start, &end);
length = end - start;
/*
- * Append the element and terminate it with a : and a null. Note that
- * we are forcing the DString to contain an extra null at the end.
+ * Append the element and terminate it with a :
*/
nextElt = Tcl_NewStringObj(start, length);
@@ -860,15 +879,49 @@ SplitMacPath(path)
isMac = (strchr(path, ':') != NULL);
p = path;
}
+#else
+ if ((path[0] != ':') && (path[0] == '~' || (strchr(path,':') != NULL))) {
+ CONST char *end;
+ Tcl_Obj *nextElt;
+
+ isMac = 1;
+
+ end = strchr(path,':');
+ if (end == NULL) {
+ length = strlen(path);
+ } else {
+ length = end - path;
+ }
+
+ /*
+ * Append the element and terminate it with a :
+ */
+
+ nextElt = Tcl_NewStringObj(path, length);
+ Tcl_AppendToObj(nextElt, ":", 1);
+ Tcl_ListObjAppendElement(NULL, result, nextElt);
+ p = path + length;
+ } else {
+ isMac = (strchr(path, ':') != NULL);
+ isMac = 1;
+ p = path;
+ }
+#endif
if (isMac) {
/*
* p is pointing at the first colon in the path. There
* will always be one, since this is a Mac-style path.
+ * (This is no longer true if MAC_UNDERSTANDS_UNIX_PATHS
+ * is false, so we must check whether 'p' points to the
+ * end of the string.)
*/
-
- elementStart = p++;
+ elementStart = p;
+ if (*p == ':') {
+ p++;
+ }
+
while ((p = strchr(p, ':')) != NULL) {
length = p - elementStart;
if (length == 1) {
@@ -891,13 +944,20 @@ SplitMacPath(path)
elementStart = p++;
}
}
- if (elementStart[1] != '\0' || elementStart == path) {
- if ((elementStart[1] != '~') && (elementStart[1] != '\0')
- && (strchr(elementStart+1, '/') == NULL)) {
+ if (elementStart[0] != ':') {
+ if (elementStart[0] != '\0') {
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(elementStart, -1));
+ }
+ } else {
+ if (elementStart[1] != '\0' || elementStart == path) {
+ if ((elementStart[1] != '~') && (elementStart[1] != '\0')
+ && (strchr(elementStart+1, '/') == NULL)) {
elementStart++;
+ }
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(elementStart, -1));
}
- Tcl_ListObjAppendElement(NULL, result,
- Tcl_NewStringObj(elementStart, -1));
}
} else {
@@ -1150,6 +1210,11 @@ TclpNativeJoinPath(prefix, joining)
*/
newLength = strlen(p);
+ /*
+ * It may not be good to just do 'Tcl_AppendToObj(prefix,
+ * p, newLength)' because the object may contain duplicate
+ * colons which we want to get rid of.
+ */
Tcl_AppendToObj(prefix, p, newLength);
/* Remove spurious trailing single ':' */
@@ -2484,3 +2549,69 @@ TclDoGlob(interp, separators, headPtr, tail, types)
return TCL_OK;
}
}
+
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclFileDirname
+ *
+ * This procedure calculates the directory above a given
+ * path: basically 'file dirname'. It is used both by
+ * the 'dirname' subcommand of file and by code in tclIOUtil.c.
+ *
+ * Results:
+ * NULL if an error occurred, otherwise a Tcl_Obj owned by
+ * the caller (i.e. most likely with refCount 1).
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+TclFileDirname(interp, pathPtr)
+ Tcl_Interp *interp; /* Used for error reporting */
+ Tcl_Obj *pathPtr; /* Path to take dirname of */
+{
+ int splitElements;
+ Tcl_Obj *splitPtr;
+ Tcl_Obj *splitResultPtr = NULL;
+
+ /*
+ * The behaviour we want here is slightly different to
+ * the standard Tcl_FSSplitPath in the handling of home
+ * directories; Tcl_FSSplitPath preserves the "~" while
+ * this code computes the actual full path name, if we
+ * had just a single component.
+ */
+ splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements);
+ if ((splitElements == 1) && (Tcl_GetString(pathPtr)[0] == '~')) {
+ Tcl_DecrRefCount(splitPtr);
+ splitPtr = Tcl_FSGetNormalizedPath(interp, pathPtr);
+ if (splitPtr == NULL) {
+ return NULL;
+ }
+ splitPtr = Tcl_FSSplitPath(splitPtr, &splitElements);
+ }
+
+ /*
+ * Return all but the last component. If there is only one
+ * component, return it if the path was non-relative, otherwise
+ * return the current directory.
+ */
+
+ if (splitElements > 1) {
+ splitResultPtr = Tcl_FSJoinPath(splitPtr, splitElements - 1);
+ } else if (splitElements == 0 ||
+ (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE)) {
+ splitResultPtr = Tcl_NewStringObj(
+ ((tclPlatform == TCL_PLATFORM_MAC) ? ":" : "."), 1);
+ } else {
+ Tcl_ListObjIndex(NULL, splitPtr, 0, &splitResultPtr);
+ }
+ Tcl_IncrRefCount(splitResultPtr);
+ Tcl_DecrRefCount(splitPtr);
+ return splitResultPtr;
+}
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 2406215..96a33f8 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -17,7 +17,7 @@
* 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.17 2001/08/30 08:53:14 vincentdarley Exp $
+ * RCS: @(#) $Id: tclIOUtil.c,v 1.18 2001/09/04 18:06:34 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -41,11 +41,14 @@ static int TclNormalizeToUniquePath
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));
+static Tcl_PathType FSGetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
+ Tcl_Filesystem **filesystemPtrPtr,
+ int *driveNameLengthPtr));
static Tcl_PathType GetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
Tcl_Filesystem **filesystemPtrPtr,
int *driveNameLengthPtr, Tcl_Obj **driveNameRef));
+static int CrossFilesystemCopy _ANSI_ARGS_((Tcl_Obj *source,
+ Tcl_Obj *target));
/*
* Define the 'path' object type, which Tcl uses to represent
@@ -244,7 +247,7 @@ typedef struct FilesystemRecord {
* filesystem (can be NULL) */
Tcl_Filesystem *fsPtr; /* Pointer to filesystem dispatch
* table. */
- int refCount; /* How many Tcl_Obj's use this
+ int fileRefCount; /* How many Tcl_Obj's use this
* filesystem. */
struct FilesystemRecord *nextPtr;
/* The next filesystem registered
@@ -337,7 +340,6 @@ static Tcl_Filesystem nativeFilesystem = {
&TclpObjRenameFile,
&TclpObjCopyDirectory,
&TclpLoadFile,
- &TclpUnloadFile,
&TclpObjGetCwd,
&TclpObjChdir
};
@@ -534,7 +536,11 @@ Tcl_FSRegister(clientData, fsPtr)
newFilesystemPtr->clientData = clientData;
newFilesystemPtr->fsPtr = fsPtr;
- newFilesystemPtr->refCount = 0;
+ /*
+ * We start with a refCount of 1. If this drops to zero, then
+ * anyone is welcome to ckfree us.
+ */
+ newFilesystemPtr->fileRefCount = 1;
/*
* Is this lock and wait strictly speaking necessary? Since any
@@ -624,8 +630,11 @@ Tcl_FSUnregister(fsPtr)
* lead to memory exceptions).
*/
filesystemEpoch++;
-
- ckfree((char *)tmpFsRecPtr);
+
+ tmpFsRecPtr->fileRefCount--;
+ if (tmpFsRecPtr->fileRefCount <= 0) {
+ ckfree((char *)tmpFsRecPtr);
+ }
retVal = TCL_OK;
} else {
@@ -862,7 +871,7 @@ TclNormalizeToUniquePath(interp, pathPtr)
/*
* We could add an efficiency check like this:
*
- * if (retVal == Tcl_DStringLength(pathPtr)) {break;}
+ * if (retVal == length-of(pathPtr)) {break;}
*
* but there's not much benefit.
*/
@@ -1563,7 +1572,7 @@ Tcl_FSMatchInDirectory(interp, result, pathPtr, pattern, types)
cwd = Tcl_FSGetCwd(NULL);
if (cwd == NULL) {
if (interp != NULL) {
- Tcl_SetResult(interp, "glob couldn't determine"
+ Tcl_SetResult(interp, "glob couldn't determine "
"the current working directory", TCL_STATIC);
}
return TCL_ERROR;
@@ -1909,9 +1918,8 @@ NativeFileAttrsGet(interp, index, fileName, objPtrRef)
Tcl_Obj *fileName; /* filename we are operating on. */
Tcl_Obj **objPtrRef; /* for output. */
{
- Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, fileName);
return (*tclpFileAttrProcs[index].getProc)(interp, index,
- transPtr, objPtrRef);
+ fileName, objPtrRef);
}
/*
@@ -1941,9 +1949,8 @@ NativeFileAttrsSet(interp, index, fileName, objPtr)
Tcl_Obj *fileName; /* filename we are operating on. */
Tcl_Obj *objPtr; /* set to this value. */
{
- Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, fileName);
return (*tclpFileAttrProcs[index].setProc)(interp, index,
- transPtr, objPtr);
+ fileName, objPtr);
}
/*
@@ -2186,19 +2193,15 @@ Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
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;
- }
+ proc1Ptr, proc2Ptr, clientDataPtr,
+ unloadProcPtr);
return retVal;
} else {
Tcl_Filesystem *copyFsPtr;
- /* Get a temporary filename to use, first to
- * copy the file into, and then to load. */
+ /*
+ * Get a temporary filename to use, first to
+ * copy the file into, and then to load.
+ */
Tcl_Obj *copyToPtr = TclpTempFileName();
if (copyToPtr == NULL) {
return -1;
@@ -2207,14 +2210,16 @@ Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr);
if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) {
- /* We already know we can't use Tcl_FSLoadFile from
+ /*
+ * We already know we can't use Tcl_FSLoadFile from
* this filesystem, and we must avoid a possible
- * infinite loop. */
+ * infinite loop.
+ */
Tcl_DecrRefCount(copyToPtr);
return -1;
}
- if (Tcl_FSCopyFile(pathPtr, copyToPtr) == 0) {
+ if (CrossFilesystemCopy(pathPtr, copyToPtr) == TCL_OK) {
/*
* Do we need to set appropriate permissions
* on the file? This may be required on some
@@ -2427,6 +2432,31 @@ Tcl_FSListVolumes(void)
* Tcl_FSGetPathType --
*
* Determines whether a given path is relative to the current
+ * directory, relative to the current volume, or absolute.
+ *
+ * Results:
+ * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
+ * TCL_PATH_VOLUME_RELATIVE.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_PathType
+Tcl_FSGetPathType(pathObjPtr)
+ Tcl_Obj *pathObjPtr;
+{
+ return FSGetPathType(pathObjPtr, NULL, NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FSGetPathType --
+ *
+ * Determines whether a given path is relative to the current
* directory, relative to the current volume, or absolute. If the
* caller wishes to know which filesystem claimed the path (in the
* case for which the path is absolute), then a reference to a
@@ -2445,20 +2475,22 @@ Tcl_FSListVolumes(void)
*----------------------------------------------------------------------
*/
-Tcl_PathType
-Tcl_FSGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr)
+static Tcl_PathType
+FSGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr)
Tcl_Obj *pathObjPtr;
Tcl_Filesystem **filesystemPtrPtr;
int *driveNameLengthPtr;
{
if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) {
- return GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, NULL);
+ return GetPathType(pathObjPtr, filesystemPtrPtr,
+ driveNameLengthPtr, NULL);
} else {
FsPath *fsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr;
if (fsPathPtr->cwdPtr != NULL) {
return TCL_PATH_RELATIVE;
} else {
- return GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, NULL);
+ return GetPathType(pathObjPtr, filesystemPtrPtr,
+ driveNameLengthPtr, NULL);
}
}
}
@@ -2469,13 +2501,9 @@ Tcl_FSGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr)
* 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.
+ * path, and returns a Tcl List object containing each segment of
+ * that path as an element.
*
- * Note this function currently calls the older Split(Plat)Path
- * functions, which require more memory allocation than is
- * desirable.
- *
* 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
@@ -2502,7 +2530,7 @@ Tcl_FSSplitPath(pathPtr, lenPtr)
* Perform platform specific splitting.
*/
- if (Tcl_FSGetPathType(pathPtr, &fsPtr, &driveNameLength)
+ if (FSGetPathType(pathPtr, &fsPtr, &driveNameLength)
== TCL_PATH_ABSOLUTE) {
if (fsPtr == &nativeFilesystem) {
return TclpNativeSplitPath(pathPtr, lenPtr);
@@ -2574,11 +2602,6 @@ Tcl_FSSplitPath(pathPtr, lenPtr)
* 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.
*
@@ -2710,7 +2733,7 @@ Tcl_FSJoinPath(listObj, elements)
*
* GetPathType --
*
- * Helper function used by Tcl_FSGetPathType.
+ * Helper function used by FSGetPathType.
*
* Results:
* Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
@@ -2817,7 +2840,8 @@ GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef)
FsReleaseIterator();
if (type != TCL_PATH_ABSOLUTE) {
- type = TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, driveNameRef);
+ type = TclpGetNativePathType(pathObjPtr, driveNameLengthPtr,
+ driveNameRef);
if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) {
*filesystemPtrPtr = &nativeFilesystem;
}
@@ -2904,12 +2928,80 @@ Tcl_FSCopyFile(srcPathPtr, destPathPtr)
if (retVal == -1) {
Tcl_SetErrno(EXDEV);
}
+ if ((retVal != TCL_OK) && (errno == EXDEV)) {
+ retVal = CrossFilesystemCopy(srcPathPtr, destPathPtr);
+ }
return retVal;
}
/*
*---------------------------------------------------------------------------
*
+ * CrossFilesystemCopy --
+ *
+ * Helper for above function, and for Tcl_FSLoadFile, to copy
+ * files from one filesystem to another. This function will
+ * overwrite the target file if it already exists.
+ *
+ * Results:
+ * Standard Tcl error code.
+ *
+ * Side effects:
+ * A file may be created.
+ *
+ *---------------------------------------------------------------------------
+ */
+static int
+CrossFilesystemCopy(source, target)
+ Tcl_Obj *source; /* Pathname of file to be copied (UTF-8). */
+ Tcl_Obj *target; /* Pathname of file to copy to (UTF-8). */
+{
+ int result = TCL_ERROR;
+ int prot = 0666;
+
+ Tcl_Channel out = Tcl_FSOpenFileChannel(NULL, target, "w", prot);
+ if (out != NULL) {
+ /* It looks like we can copy it over */
+ Tcl_Channel in = Tcl_FSOpenFileChannel(NULL, source,
+ "r", prot);
+ if (in == NULL) {
+ /* This is very strange, we checked this above */
+ Tcl_Close(NULL, out);
+ } else {
+ struct stat sourceStatBuf;
+ struct utimbuf tval;
+ /*
+ * Copy it synchronously. We might wish to add an
+ * asynchronous option to support vfs's which are
+ * slow (e.g. network sockets).
+ */
+ Tcl_SetChannelOption(NULL, in, "-translation", "binary");
+ Tcl_SetChannelOption(NULL, out, "-translation", "binary");
+
+ if (TclCopyChannel(NULL, in, out, -1, NULL) == TCL_OK) {
+ result = TCL_OK;
+ }
+ /*
+ * If the copy failed, assume that copy channel left
+ * a good error message.
+ */
+ Tcl_Close(NULL, in);
+ Tcl_Close(NULL, out);
+
+ /* Set modification date of copied file */
+ if (Tcl_FSLstat(source, &sourceStatBuf) != 0) {
+ tval.actime = sourceStatBuf.st_atime;
+ tval.modtime = sourceStatBuf.st_mtime;
+ Tcl_FSUtime(source, &tval);
+ }
+ }
+ }
+ return result;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
* Tcl_FSDeleteFile --
*
* The appropriate function for the filesystem to which pathPtr
@@ -2972,7 +3064,7 @@ Tcl_FSCreateDirectory(pathPtr)
/*
*---------------------------------------------------------------------------
*
- * Tcl_FSRenameFile --
+ * Tcl_FSCopyDirectory --
*
* If the two paths given belong to the same filesystem, we call
* that filesystems copy-directory function. Otherwise we simply
@@ -3045,6 +3137,33 @@ Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr)
if (fsPtr != NULL) {
Tcl_FSRemoveDirectoryProc *proc = fsPtr->removeDirectoryProc;
if (proc != NULL) {
+ if (recursive) {
+ /*
+ * We check whether the cwd lies inside this directory
+ * and move it if it does.
+ */
+ Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL);
+ if (cwdPtr != NULL) {
+ char *cwdStr, *normPathStr;
+ int cwdLen, normLen;
+ Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (normPath != NULL) {
+ normPathStr = Tcl_GetStringFromObj(normPath, &normLen);
+ cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
+ if ((cwdLen >= normLen) && (strncmp(normPathStr,
+ cwdStr, (size_t) normLen) == 0)) {
+ /*
+ * the cwd is inside the directory, so we
+ * perform a 'cd [file dirname $path]'
+ */
+ Tcl_Obj *dirPtr = TclFileDirname(NULL, pathPtr);
+ Tcl_FSChdir(dirPtr);
+ Tcl_DecrRefCount(dirPtr);
+ }
+ }
+ Tcl_DecrRefCount(cwdPtr);
+ }
+ }
return (*proc)(pathPtr, recursive, errorPtr);
}
}
@@ -3449,7 +3568,11 @@ FreeFsPathInternalRep(pathObjPtr)
}
}
if (fsPathPtr->fsRecPtr != NULL) {
- fsPathPtr->fsRecPtr->refCount--;
+ fsPathPtr->fsRecPtr->fileRefCount--;
+ if (fsPathPtr->fsRecPtr->fileRefCount <= 0) {
+ /* It has been unregistered already */
+ ckfree((char *)fsPathPtr->fsRecPtr);
+ }
}
ckfree((char*) fsPathPtr);
@@ -3506,7 +3629,7 @@ DupFsPathInternalRep(srcPtr, copyPtr)
copyFsPathPtr->fsRecPtr = srcFsPathPtr->fsRecPtr;
copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch;
if (copyFsPathPtr->fsRecPtr != NULL) {
- copyFsPathPtr->fsRecPtr->refCount++;
+ copyFsPathPtr->fsRecPtr->fileRefCount++;
}
copyPtr->typePtr = &tclFsPathType;
@@ -3633,7 +3756,7 @@ Tcl_FSGetNormalizedPath(interp, pathObjPtr)
* action, which might loop back through here.
*/
if ((path[0] != '\0') &&
- (Tcl_FSGetPathType(pathObjPtr, NULL, NULL) == TCL_PATH_RELATIVE)) {
+ (Tcl_FSGetPathType(pathObjPtr) == TCL_PATH_RELATIVE)) {
Tcl_Obj *cwd = Tcl_FSGetCwd(interp);
if (cwd == NULL) {
@@ -3749,6 +3872,17 @@ Tcl_FSGetInternalRep(pathObjPtr, fsPtr)
}
if (fsPtr != srcFsPathPtr->fsRecPtr->fsPtr) {
+ /*
+ * There is still one possibility we should consider; if the
+ * file belongs to a different filesystem, perhaps it is
+ * actually linked through to a file in our own filesystem
+ * which we do care about. The way we can check for this
+ * is we ask what filesystem this path belongs to.
+ */
+ Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathObjPtr);
+ if (actualFs == fsPtr) {
+ return Tcl_FSGetInternalRep(pathObjPtr, fsPtr);
+ }
return NULL;
}
@@ -4129,7 +4263,7 @@ NativeFilesystemPathType(pathObjPtr)
* as a valid file path, then NULL is returned.
*
* Results:
- * NULL or a filesystem which will accept this path.
+.* NULL or a filesystem which will accept this path.
*
* Side effects:
* The object may be converted to a path type.
@@ -4137,7 +4271,7 @@ NativeFilesystemPathType(pathObjPtr)
*---------------------------------------------------------------------------
*/
-static Tcl_Filesystem*
+Tcl_Filesystem*
Tcl_FSGetFileSystemForPath(pathObjPtr)
Tcl_Obj* pathObjPtr;
{
@@ -4213,7 +4347,7 @@ Tcl_FSGetFileSystemForPath(pathObjPtr)
srcFsPathPtr->fsRecPtr = fsRecPtr;
srcFsPathPtr->nativePathPtr = clientData;
srcFsPathPtr->filesystemEpoch = filesystemEpoch;
- fsRecPtr->refCount++;
+ fsRecPtr->fileRefCount++;
retVal = fsRecPtr->fsPtr;
}
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index fce4832..f14e415 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.62 2001/09/01 00:51:31 hobbs Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.63 2001/09/04 18:06:34 vincentdarley Exp $
*/
#ifndef _TCLINT
@@ -1804,7 +1804,8 @@ EXTERN int TclpLoadFile _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *pathPtr, char *sym1, char *sym2,
Tcl_PackageInitProc **proc1Ptr,
Tcl_PackageInitProc **proc2Ptr,
- ClientData *clientDataPtr));
+ ClientData *clientDataPtr,
+ Tcl_FSUnloadFileProc **unloadProcPtr));
EXTERN Tcl_Obj* TclpObjListVolumes _ANSI_ARGS_((void));
EXTERN void TclpMasterLock _ANSI_ARGS_((void));
EXTERN void TclpMasterUnlock _ANSI_ARGS_((void));
@@ -1814,8 +1815,6 @@ EXTERN int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp *interp,
EXTERN int TclpObjNormalizePath _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *pathPtr, int nextCheckpoint));
EXTERN int TclpObjCreateDirectory _ANSI_ARGS_((Tcl_Obj *pathPtr));
-EXTERN Tcl_PathType Tcl_FSGetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
- Tcl_Filesystem **fsPtrPtr, int *driveNameLengthPtr));
EXTERN void TclpNativeJoinPath _ANSI_ARGS_((Tcl_Obj *prefix,
char *joining));
EXTERN Tcl_Obj* TclpNativeSplitPath _ANSI_ARGS_((Tcl_Obj *pathPtr,
@@ -1831,10 +1830,14 @@ 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 TclpMatchInDirectory _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *resultPtr, Tcl_Obj *pathPtr,
+ char *pattern, Tcl_GlobTypeData *types));
EXTERN Tcl_Obj* TclpObjGetCwd _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN Tcl_Obj* TclpObjLink _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_Obj *toPtr));
EXTERN int TclpObjChdir _ANSI_ARGS_((Tcl_Obj *pathPtr));
+EXTERN Tcl_Obj* TclFileDirname _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj*pathPtr));
EXTERN int TclpObjStat _ANSI_ARGS_((Tcl_Obj *pathPtr, struct stat *buf));
EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *pathPtr, char *modeString,
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 932a61b..ab2d80b 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.56 2001/08/30 08:53:15 vincentdarley Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.57 2001/09/04 18:06:34 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -873,6 +873,8 @@ TclStubs tclStubs = {
Tcl_FSUnregister, /* 474 */
Tcl_FSData, /* 475 */
Tcl_FSGetTranslatedStringPath, /* 476 */
+ Tcl_FSGetFileSystemForPath, /* 477 */
+ Tcl_FSGetPathType, /* 478 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index f88412a..af93ff6 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.28 2001/08/30 08:53:15 vincentdarley Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.29 2001/09/04 18:06:34 vincentdarley Exp $
*/
#define TCL_TEST
@@ -319,7 +319,6 @@ 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;
@@ -331,20 +330,22 @@ static Tcl_FSRemoveDirectoryProc TestReportRemoveDirectory;
static Tcl_FSLoadFileProc TestReportLoadFile;
static Tcl_FSUnloadFileProc TestReportUnloadFile;
static Tcl_FSLinkProc TestReportLink;
-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_FSPathInFilesystemProc TestReportInFilesystem;
+static Tcl_FSFreeInternalRepProc TestReportFreeInternalRep;
+static Tcl_FSDupInternalRepProc TestReportDupInternalRep;
static Tcl_Filesystem testReportingFilesystem = {
"reporting",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_1,
- NULL, /* path in */
- NULL, /* native dup */
- NULL, /* native free */
+ &TestReportInFilesystem, /* path in */
+ &TestReportDupInternalRep,
+ &TestReportFreeInternalRep,
NULL, /* native to norm */
NULL, /* convert to native */
&TestReportNormalizePath,
@@ -356,7 +357,7 @@ static Tcl_Filesystem testReportingFilesystem = {
&TestReportMatchInDirectory,
&TestReportUtime,
&TestReportLink,
- &TestReportListVolumes,
+ NULL /* list volumes */,
&TestReportFileAttrStrings,
&TestReportFileAttrsGet,
&TestReportFileAttrsSet,
@@ -368,8 +369,7 @@ static Tcl_Filesystem testReportingFilesystem = {
&TestReportRenameFile,
&TestReportCopyDirectory,
&TestReportLoadFile,
- &TestReportUnloadFile,
- &TestReportGetCwd,
+ NULL /* cwd */,
&TestReportChdir
};
@@ -5257,10 +5257,62 @@ TestFilesystemObjCmd(dummy, interp, objc, objv)
return res;
}
+static int
+TestReportInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr) {
+ static Tcl_Obj* lastPathPtr = NULL;
+
+ if (pathPtr == lastPathPtr) {
+ /* Reject all files second time around */
+ return -1;
+ } else {
+ Tcl_Obj * newPathPtr;
+ /* Try to claim all files first time around */
+
+ newPathPtr = Tcl_DuplicateObj(pathPtr);
+ lastPathPtr = newPathPtr;
+ Tcl_IncrRefCount(newPathPtr);
+ if (Tcl_FSGetFileSystemForPath(newPathPtr) == NULL) {
+ /* Nothing claimed it. Therefore we don't either */
+ Tcl_DecrRefCount(newPathPtr);
+ lastPathPtr = NULL;
+ return -1;
+ } else {
+ lastPathPtr = NULL;
+ *clientDataPtr = (ClientData) newPathPtr;
+ return TCL_OK;
+ }
+ }
+}
+
+/*
+ * Simple helper function to extract the native vfs representation of a
+ * path object, or NULL if no such representation exists.
+ */
+Tcl_Obj*
+TestReportGetNativePath(Tcl_Obj* pathObjPtr) {
+ return (Tcl_Obj*) Tcl_FSGetInternalRep(pathObjPtr, &testReportingFilesystem);
+}
+
+void
+TestReportFreeInternalRep(ClientData clientData) {
+ Tcl_Obj *nativeRep = (Tcl_Obj*)clientData;
+ if (nativeRep != NULL) {
+ /* Free the path */
+ Tcl_DecrRefCount(nativeRep);
+ }
+}
+
+ClientData
+TestReportDupInternalRep(ClientData clientData) {
+ Tcl_Obj *original = (Tcl_Obj*)clientData;
+ Tcl_IncrRefCount(original);
+ return clientData;
+}
+
static void
-TestReport(cmd, arg1, arg2)
+TestReport(cmd, path, arg2)
CONST char* cmd;
- Tcl_Obj* arg1;
+ Tcl_Obj* path;
Tcl_Obj* arg2;
{
Tcl_Interp* interp = (Tcl_Interp*) Tcl_FSData(&testReportingFilesystem);
@@ -5273,8 +5325,8 @@ TestReport(cmd, arg1, arg2)
Tcl_DStringAppend(&ds, "puts stderr ",-1);
Tcl_DStringStartSublist(&ds);
Tcl_DStringAppendElement(&ds, cmd);
- if (arg1 != NULL) {
- Tcl_DStringAppendElement(&ds, Tcl_GetString(arg1));
+ if (path != NULL) {
+ Tcl_DStringAppendElement(&ds, Tcl_GetString(path));
}
if (arg2 != NULL) {
Tcl_DStringAppendElement(&ds, Tcl_GetString(arg2));
@@ -5292,7 +5344,7 @@ TestReportStat(path, buf)
struct stat *buf; /* Filled with results of stat call. */
{
TestReport("stat",path, NULL);
- return -1;
+ return Tcl_FSStat(TestReportGetNativePath(path),buf);
}
static int
TestReportLstat(path, buf)
@@ -5300,7 +5352,7 @@ TestReportLstat(path, buf)
struct stat *buf; /* Filled with results of stat call. */
{
TestReport("lstat",path, NULL);
- return -1;
+ return Tcl_FSLstat(TestReportGetNativePath(path),buf);
}
static int
TestReportAccess(path, mode)
@@ -5308,7 +5360,7 @@ TestReportAccess(path, mode)
int mode; /* Permission setting. */
{
TestReport("access",path,NULL);
- return -1;
+ return Tcl_FSAccess(TestReportGetNativePath(path),mode);
}
static Tcl_Channel
TestReportOpenFileChannel(interp, fileName, modeString, permissions)
@@ -5322,7 +5374,8 @@ TestReportOpenFileChannel(interp, fileName, modeString, permissions)
* it? */
{
TestReport("open",fileName, NULL);
- return NULL;
+ return Tcl_FSOpenFileChannel(interp, TestReportGetNativePath(fileName),
+ modeString, permissions);
}
static int
@@ -5335,24 +5388,20 @@ TestReportMatchInDirectory(interp, resultPtr, dirPtr, pattern, types)
* May be NULL. */
{
TestReport("matchindirectory",dirPtr, NULL);
- return -1;
-}
-static Tcl_Obj *
-TestReportGetCwd(interp)
- Tcl_Interp *interp;
-{
- TestReport("cwd",NULL,NULL);
- return NULL;
+ return Tcl_FSMatchInDirectory(interp, resultPtr,
+ TestReportGetNativePath(dirPtr), pattern,
+ types);
}
static int
TestReportChdir(dirName)
Tcl_Obj *dirName;
{
TestReport("chdir",dirName,NULL);
- return -1;
+ return Tcl_FSChdir(TestReportGetNativePath(dirName));
}
static int
-TestReportLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
+TestReportLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr,
+ clientDataPtr, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Obj *fileName; /* Name of the file containing the desired
* code. */
@@ -5363,10 +5412,15 @@ TestReportLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataP
* to sym1 and sym2. */
ClientData *clientDataPtr; /* Filled with token for dynamically loaded
* file which will be passed back to
- * TclpUnloadFile() to unload the file. */
+ * (*unloadProcPtr)() to unload the file. */
+ Tcl_FSUnloadFileProc **unloadProcPtr;
+ /* Filled with address of Tcl_FSUnloadFileProc
+ * function which should be used for
+ * this file. */
{
TestReport("loadfile",fileName,NULL);
- return -1;
+ return Tcl_FSLoadFile(interp, TestReportGetNativePath(fileName), sym1, sym2,
+ proc1Ptr, proc2Ptr, clientDataPtr, unloadProcPtr);
}
static void
TestReportUnloadFile(clientData)
@@ -5383,13 +5437,7 @@ TestReportLink(path, to)
Tcl_Obj *to; /* Path of file to link to, or NULL */
{
TestReport("link",path,NULL);
- return NULL;
-}
-static Tcl_Obj *
-TestReportListVolumes()
-{
- TestReport("listvolumes",NULL,NULL);
- return NULL;
+ return Tcl_FSLink(TestReportGetNativePath(path),NULL);
}
static int
TestReportRenameFile(src, dst)
@@ -5399,7 +5447,8 @@ TestReportRenameFile(src, dst)
* (UTF-8). */
{
TestReport("renamefile",src,dst);
- return -1;
+ return Tcl_FSRenameFile(TestReportGetNativePath(src),
+ TestReportGetNativePath(dst));
}
static int
TestReportCopyFile(src, dst)
@@ -5407,33 +5456,34 @@ TestReportCopyFile(src, dst)
Tcl_Obj *dst; /* Pathname of file to copy to (UTF-8). */
{
TestReport("copyfile",src,dst);
- return -1;
+ return Tcl_FSCopyFile(TestReportGetNativePath(src),
+ TestReportGetNativePath(dst));
}
static int
TestReportDeleteFile(path)
Tcl_Obj *path; /* Pathname of file to be removed (UTF-8). */
{
TestReport("deletefile",path,NULL);
- return -1;
+ return Tcl_FSDeleteFile(TestReportGetNativePath(path));
}
static int
TestReportCreateDirectory(path)
Tcl_Obj *path; /* Pathname of directory to create (UTF-8). */
{
TestReport("createdirectory",path,NULL);
- return -1;
+ return Tcl_FSCreateDirectory(TestReportGetNativePath(path));
}
static 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. */
+ Tcl_Obj **errorPtr; /* If non-NULL, to be filled with UTF-8 name
+ * of file causing error. */
{
TestReport("copydirectory",src,dst);
- return -1;
+ return Tcl_FSCopyDirectory(TestReportGetNativePath(src),
+ TestReportGetNativePath(dst), errorPtr);
}
static int
TestReportRemoveDirectory(path, recursive, errorPtr)
@@ -5442,12 +5492,12 @@ TestReportRemoveDirectory(path, recursive, errorPtr)
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. */
+ Tcl_Obj **errorPtr; /* If non-NULL, to be filled with UTF-8 name
+ * of file causing error. */
{
TestReport("removedirectory",path,NULL);
- return -1;
+ return Tcl_FSRemoveDirectory(TestReportGetNativePath(path), recursive,
+ errorPtr);
}
static char**
TestReportFileAttrStrings(fileName, objPtrRef)
@@ -5455,7 +5505,7 @@ TestReportFileAttrStrings(fileName, objPtrRef)
Tcl_Obj** objPtrRef;
{
TestReport("fileattributestrings",fileName,NULL);
- return NULL;
+ return Tcl_FSFileAttrStrings(TestReportGetNativePath(fileName), objPtrRef);
}
static int
TestReportFileAttrsGet(interp, index, fileName, objPtrRef)
@@ -5465,7 +5515,8 @@ TestReportFileAttrsGet(interp, index, fileName, objPtrRef)
Tcl_Obj **objPtrRef; /* for output. */
{
TestReport("fileattributesget",fileName,NULL);
- return -1;
+ return Tcl_FSFileAttrsGet(interp, index,
+ TestReportGetNativePath(fileName), objPtrRef);
}
static int
TestReportFileAttrsSet(interp, index, fileName, objPtr)
@@ -5475,7 +5526,8 @@ TestReportFileAttrsSet(interp, index, fileName, objPtr)
Tcl_Obj *objPtr; /* for input. */
{
TestReport("fileattributesset",fileName,objPtr);
- return -1;
+ return Tcl_FSFileAttrsSet(interp, index,
+ TestReportGetNativePath(fileName), objPtr);
}
static int
TestReportUtime (fileName, tval)
@@ -5483,7 +5535,7 @@ TestReportUtime (fileName, tval)
struct utimbuf *tval;
{
TestReport("utime",fileName,NULL);
- return -1;
+ return Tcl_FSUtime(TestReportGetNativePath(fileName), tval);
}
static int
TestReportNormalizePath(interp, pathPtr, nextCheckpoint)