Attachment "fsfixes2.patch" to
ticket [219139ffff]
added by
vincentdarley
2001-09-04 22:57:32.
? win/outdata
? win/testfile
? win/_tcl_test_remove_me.txt
Index: ChangeLog
===================================================================
RCS file: /cvsroot/tcl/tcl/ChangeLog,v
retrieving revision 1.559
diff -u -r1.559 ChangeLog
--- ChangeLog 2001/09/03 17:34:16 1.559
+++ ChangeLog 2001/09/04 15:55:56
@@ -8,6 +8,43 @@
* doc/ExprLongObj.3: Fixed error in documentation of argument type
to Tcl_ExprObj [Bug: 457435]
+2001-09-03 Vince Darley <[email protected]>
+
+ Minor bug fixes in filesystem.
+ * tests/fileName.test: ensure new test cleans up after itself
+ * doc/filename.n:
+ * generic/tclFileName.c: improved Mac path handling and document
+ why [Bug: 421842] on Windows handling of UNC paths is not valid.
+ Documentation and code now much clearer on what is and is not a
+ UNC path.
+ * doc/FileSystem.3:
+ * unix/tclUnixPipe.c:
+ * generic/tclFCmd.c:
+ * generic/tclIOUtil.c: fixed error message, fixed [Bug: 453512]
+ about dangerous use of tmpnam, replaced with mkstemp.
+ Documented all the changes.
+ * generic/tclTest.c: made test vfs fully functional as a
+ 'reporting filesystem'.
+ * generic/tcl.stubs:
+ * generic/tcl.h:
+ * generic/tclInt.h:
+ * generic/tclIOUtil.c:
+ * doc/file.n:
+ * various platform-specific 'TclpLoadFile': fixed comments about
+ unload behaviour, and completed objectification of loading.
+ Required change to Tcl_Filesystem lookup table, so incompatible
+ with 8.4a3, but not older versions of Tcl. The change also
+ allows 'link' and 'reporting' filesystems to function correctly
+ when loading files. Implementation of 'file delete -force'
+ copes with case where cwd is inside the directory. Moved
+ overlooked Tcl_FSGetPathType from internal to external API.
+ Documented changes.
+ * unix/tclUnixFCmd.c: when deleting directories recursively,
+ make sure permissions are ok. Together with the above, this
+ fixes [Bug: 219139]
+ * tests/fCmd.test: added test for 'file delete -force' where
+ the cwd is inside.
+
2001-09-02 David Gravereaux <[email protected]>
* win/tclWinThrd.c: Portability fix for Cygwin who's c-runtime,
Index: doc/FileSystem.3
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/FileSystem.3,v
retrieving revision 1.4
diff -u -r1.4 FileSystem.3
--- doc/FileSystem.3 2001/08/30 08:53:14 1.4
+++ doc/FileSystem.3 2001/09/04 15:56:00
@@ -252,8 +252,8 @@
path name given by destPathPtr. If the two paths given lie in the same
filesystem (according to \fBTcl_FSGetFileSystemForPath\fR) then that
filesystem's 'copy file' function is called (if it is non-NULL).
-Otherwise the function returns -1 and sets Tcl's errno to the 'EXDEV'
-posix error code (which signifies a 'cross-domain link').
+Otherwise a cross-filesystem copy is attempted using a combination
+of open-r/open-w/fcopy (at the C level).
.PP
\fBTcl_FSCopyDirectory\fR attempts to copy the directory given by srcPathPtr to the
path name given by destPathPtr. If the two paths given lie in the same
@@ -602,7 +602,6 @@
Tcl_FSCopyDirectoryProc *\fIcopyDirectoryProc\fR;
Tcl_FSLstatProc *\fIlstatProc\fR;
Tcl_FSLoadFileProc *\fIloadFileProc\fR;
- Tcl_FSUnloadFileProc *\fIunloadFileProc\fR;
Tcl_FSGetCwdProc *\fIgetCwdProc\fR;
Tcl_FSChdirProc *\fIchdirProc\fR;
} Tcl_Filesystem;
@@ -630,8 +629,8 @@
implemented there is a further fallback). However, if a
\fITcl_FSRenameFile\fR command is issued at the C level, no such
fallbacks occur. This is true except for the last five entries in the
-filesystem table (lstat, load, unload, getcwd and chdir) for which
-fallbacks do in fact occur at the C level.
+filesystem table (lstat, load, unload, getcwd and chdir) and copyfile
+for which fallbacks do in fact occur at the C level.
.PP
Any functions which take path names in Tcl_Obj form take
those names in UTF\-8 form. The filesystem infrastructure API is
@@ -1155,7 +1154,8 @@
char * \fIsym2\fR,
Tcl_PackageInitProc ** \fIproc1Ptr\fR,
Tcl_PackageInitProc ** \fIproc2Ptr\fR,
- ClientData * \fIclientDataPtr\fR);
+ ClientData * \fIclientDataPtr\fR,
+ Tcl_FSUnloadFileProc * \fIunloadProcPtr\fR);
.CE
.PP
Returns a standard Tcl completion code. If an error occurs, an error
@@ -1163,8 +1163,10 @@
a binary code file into memory and returns the addresses of two
procedures within that file, if they are defined. On a successful
load, the \fIclientDataPtr\fR should be filled with a token for
-the dynamically loaded file which will be passed back to
-the Tcl_FSUnloadFileProc to unload the file.
+the dynamically loaded file, and the \fIunloadProcPtr\fR should be
+filled in with the address of a procedure. The procedure will be
+called with the given clientData as its only parameter when Tcl
+needs to unload the file.
.PP
.SH UNLOADFILEPROC
.PP
Index: doc/file.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/file.n,v
retrieving revision 1.7
diff -u -r1.7 file.n
--- doc/file.n 2001/07/31 19:12:06 1.7
+++ doc/file.n 2001/09/04 15:56:00
@@ -110,9 +110,12 @@
.
Removes the file or directory specified by each \fIpathname\fR argument.
Non-empty directories will be removed only if the \fB\-force\fR option is
-specified. Trying to delete a non-existant file is not considered an
+specified. Trying to delete a non-existent file is not considered an
error. Trying to delete a read-only file will cause the file to be deleted,
-even if the \fB\-force\fR flags is not specified. Arguments are processed
+even if the \fB\-force\fR flags is not specified. If the \fB\-force\fR
+option is specified on a directory, Tcl will attempt both to change
+permissions and move the current directory 'pwd' out of the given path
+if that is necessary to allow the deletion to proceed. Arguments are processed
in the order specified, halting at the first error, if any. A \fB\-\|\-\fR
marks the end of switches; the argument following the \fB\-\|\-\fR will be
treated as a \fIpathname\fR even if it starts with a \fB\-\fR.
Index: doc/filename.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/filename.n,v
retrieving revision 1.6
diff -u -r1.6 filename.n
--- doc/filename.n 2001/08/24 16:40:18 1.6
+++ doc/filename.n 2001/09/04 15:56:00
@@ -136,7 +136,9 @@
style names. Both \fB/\fR and \fB\e\fR may be used as directory separators
in either type of name. Drive-relative names consist of an optional drive
specifier followed by an absolute or relative path. UNC paths follow the
-general form \fB\e\eservername\esharename\epath\efile\fR. In both forms,
+general form \fB\e\eservername\esharename\epath\efile\fR, but must at
+the very least contain the server and share components, i.e.
+\fB\e\eservername\esharename\fR. In both forms,
the file names \fB.\fR and \fB..\fR are special and refer to the current
directory and the parent of the current directory respectively. The
following examples illustrate various forms of path names:
@@ -144,7 +146,9 @@
.TP 15
\fB\&\e\eHost\eshare/file\fR
Absolute UNC path to a file called \fBfile\fR in the root directory of
-the export point \fBshare\fR on the host \fBHost\fR.
+the export point \fBshare\fR on the host \fBHost\fR. Note that
+repeated use of \fBfile dirname\fR on this path will give
+\fB//Host/share\fR, and will never give just /fB//Host/fR.
.TP 15
\fBc:foo\fR
Volume-relative path to a file \fBfoo\fR in the current directory on drive
@@ -161,6 +165,11 @@
\fB\&\efoo\fR
Volume-relative path to a file \fBfoo\fR in the root directory of the current
volume.
+.TP 15
+\fB\&\e\efoo\fR
+Volume-relative path to a file \fBfoo\fR in the root directory of the current
+volume. This is not a valid UNC path, so the assumption is that the
+extra backslashes are superfluous.
.RE
.SH "TILDE SUBSTITUTION"
Index: generic/tcl.decls
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.decls,v
retrieving revision 1.53
diff -u -r1.53 tcl.decls
--- generic/tcl.decls 2001/08/30 08:53:14 1.53
+++ generic/tcl.decls 2001/09/04 15:56:01
@@ -1667,7 +1667,13 @@
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
Index: generic/tcl.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.h,v
retrieving revision 1.97
diff -u -r1.97 tcl.h
--- generic/tcl.h 2001/08/30 15:41:29 1.97
+++ generic/tcl.h 2001/09/04 15:56:02
@@ -1554,7 +1554,8 @@
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 @@
* 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()'
Index: generic/tclCmdAH.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdAH.c,v
retrieving revision 1.14
diff -u -r1.14 tclCmdAH.c
--- generic/tclCmdAH.c 2001/08/23 17:37:07 1.14
+++ generic/tclCmdAH.c 2001/09/04 15:56:02
@@ -878,48 +878,18 @@
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 @@
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 @@
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);
Index: generic/tclDecls.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclDecls.h,v
retrieving revision 1.54
diff -u -r1.54 tclDecls.h
--- generic/tclDecls.h 2001/08/23 17:37:07 1.54
+++ generic/tclDecls.h 2001/09/04 15:56:02
@@ -1490,6 +1490,11 @@
/* 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 @@
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
@@ -3973,6 +3980,14 @@
#ifndef Tcl_FSGetTranslatedStringPath
#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) */
Index: generic/tclFCmd.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclFCmd.c,v
retrieving revision 1.11
diff -u -r1.11 tclFCmd.c
--- generic/tclFCmd.c 2001/08/30 08:53:14 1.11
+++ generic/tclFCmd.c 2001/09/04 15:56:02
@@ -599,53 +599,13 @@
}
} 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 @@
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;
}
}
Index: generic/tclFileName.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclFileName.c,v
retrieving revision 1.19
diff -u -r1.19 tclFileName.c
--- generic/tclFileName.c 2001/08/30 08:53:14 1.19
+++ generic/tclFileName.c 2001/09/04 15:56:04
@@ -17,18 +17,10 @@
#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,20 +28,20 @@
/*
* 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
* for use in filename matching.
@@ -62,6 +54,11 @@
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 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 @@
Tcl_DecrRefCount(tsdPtr->macRootPatternPtr);
tsdPtr->initialized = 0;
}
+#endif
/*
*----------------------------------------------------------------------
@@ -167,8 +164,6 @@
* 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 @@
/*
* 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_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 @@
if (path[0] == ':') {
type = TCL_PATH_RELATIVE;
} else {
+#ifdef MAC_UNDERSTANDS_UNIX_PATHS
ThreadSpecificData *tsdPtr;
Tcl_RegExp re;
@@ -380,7 +383,6 @@
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 @@
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 @@
}
}
}
-#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 @@
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 @@
}
}
}
-
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 @@
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 @@
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 @@
*/
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 ':' */
@@ -2483,4 +2548,70 @@
Tcl_DecrRefCount(nameObj);
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;
}
Index: generic/tclIOUtil.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclIOUtil.c,v
retrieving revision 1.17
diff -u -r1.17 tclIOUtil.c
--- generic/tclIOUtil.c 2001/08/30 08:53:14 1.17
+++ generic/tclIOUtil.c 2001/09/04 15:56:05
@@ -41,11 +41,14 @@
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
@@ -337,7 +340,6 @@
&TclpObjRenameFile,
&TclpObjCopyDirectory,
&TclpLoadFile,
- &TclpUnloadFile,
&TclpObjGetCwd,
&TclpObjChdir
};
@@ -862,7 +864,7 @@
/*
* 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 +1565,7 @@
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;
@@ -2186,19 +2188,15 @@
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 +2205,16 @@
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 +2427,31 @@
* 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 +2470,22 @@
*----------------------------------------------------------------------
*/
-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 +2496,9 @@
* 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 +2525,7 @@
* 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 +2597,6 @@
* 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 +2728,7 @@
*
* 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 +2835,8 @@
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 +2923,80 @@
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 +3059,7 @@
/*
*---------------------------------------------------------------------------
*
- * 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 +3132,33 @@
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);
}
}
@@ -3633,7 +3747,7 @@
* 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) {
@@ -4137,7 +4251,7 @@
*---------------------------------------------------------------------------
*/
-static Tcl_Filesystem*
+Tcl_Filesystem*
Tcl_FSGetFileSystemForPath(pathObjPtr)
Tcl_Obj* pathObjPtr;
{
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.62
diff -u -r1.62 tclInt.h
--- generic/tclInt.h 2001/09/01 00:51:31 1.62
+++ generic/tclInt.h 2001/09/04 15:56:06
@@ -1804,7 +1804,8 @@
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 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 @@
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,
Index: generic/tclStubInit.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclStubInit.c,v
retrieving revision 1.56
diff -u -r1.56 tclStubInit.c
--- generic/tclStubInit.c 2001/08/30 08:53:15 1.56
+++ generic/tclStubInit.c 2001/09/04 15:56:06
@@ -873,6 +873,8 @@
Tcl_FSUnregister, /* 474 */
Tcl_FSData, /* 475 */
Tcl_FSGetTranslatedStringPath, /* 476 */
+ Tcl_FSGetFileSystemForPath, /* 477 */
+ Tcl_FSGetPathType, /* 478 */
};
/* !END!: Do not edit above this line. */
Index: generic/tclTest.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclTest.c,v
retrieving revision 1.28
diff -u -r1.28 tclTest.c
--- generic/tclTest.c 2001/08/30 08:53:15 1.28
+++ generic/tclTest.c 2001/09/04 15:56:19
@@ -319,7 +319,6 @@
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_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 @@
&TestReportMatchInDirectory,
&TestReportUtime,
&TestReportLink,
- &TestReportListVolumes,
+ NULL /* list volumes */,
&TestReportFileAttrStrings,
&TestReportFileAttrsGet,
&TestReportFileAttrsSet,
@@ -368,8 +369,7 @@
&TestReportRenameFile,
&TestReportCopyDirectory,
&TestReportLoadFile,
- &TestReportUnloadFile,
- &TestReportGetCwd,
+ NULL /* cwd */,
&TestReportChdir
};
@@ -5257,10 +5257,62 @@
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 @@
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 @@
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 @@
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 @@
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 @@
* it? */
{
TestReport("open",fileName, NULL);
- return NULL;
+ return Tcl_FSOpenFileChannel(interp, TestReportGetNativePath(fileName),
+ modeString, permissions);
}
static int
@@ -5335,24 +5388,20 @@
* 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 @@
* 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 @@
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 @@
* (UTF-8). */
{
TestReport("renamefile",src,dst);
- return -1;
+ return Tcl_FSRenameFile(TestReportGetNativePath(src),
+ TestReportGetNativePath(dst));
}
static int
TestReportCopyFile(src, dst)
@@ -5407,33 +5456,34 @@
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 @@
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 @@
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 @@
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 @@
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 @@
struct utimbuf *tval;
{
TestReport("utime",fileName,NULL);
- return -1;
+ return Tcl_FSUtime(TestReportGetNativePath(fileName), tval);
}
static int
TestReportNormalizePath(interp, pathPtr, nextCheckpoint)
Index: mac/tclMacLoad.c
===================================================================
RCS file: /cvsroot/tcl/tcl/mac/tclMacLoad.c,v
retrieving revision 1.5
diff -u -r1.5 tclMacLoad.c
--- mac/tclMacLoad.c 2001/08/30 08:53:15 1.5
+++ mac/tclMacLoad.c 2001/09/04 15:56:19
@@ -107,9 +107,13 @@
Tcl_PackageInitProc **proc2Ptr,
/* Where to return the addresses corresponding
* to sym1 and sym2. */
- ClientData *clientDataPtr) /* Filled with token for dynamically loaded
+ 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. */
{
CFragConnectionID connID;
Ptr dummy;
@@ -221,6 +225,7 @@
}
*clientDataPtr = (ClientData) connID;
+ *unloadProcPtr = &TclpUnloadFile;
return TCL_OK;
}
Index: tests/fCmd.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/fCmd.test,v
retrieving revision 1.10
diff -u -r1.10 fCmd.test
--- tests/fCmd.test 2001/07/31 19:12:07 1.10
+++ tests/fCmd.test 2001/09/04 15:56:27
@@ -381,9 +381,26 @@
} {0}
test fCmd-5.10 {TclFileDeleteCmd: TclpRemoveDirectory fails} {notRoot} {
cleanup
- file mkdir td1/td2
+ file mkdir [file join td1 td2]
list [catch {file delete td1} msg] $msg
} {1 {error deleting "td1": directory not empty}}
+test fCmd-5.11 {TclFileDeleteCmd: TclpRemoveDirectory with cwd inside} {notRoot} {
+ cleanup
+ set dir [pwd]
+ file mkdir [file join td1 td2]
+ cd [file join td1 td2]
+ set res [list [catch {file delete -force [file dirname [pwd]]} msg]]
+ cd $dir
+ lappend res [file exists td1] $msg
+} {0 0 {}}
+test fCmd-5.12 {TclFileDeleteCmd: TclpRemoveDirectory with bad perms} {unixOnly} {
+ cleanup
+ file mkdir [file join td1 td2]
+ #exec chmod u-rwx [file join td1 td2]
+ file attributes [file join td1 td2] -permissions u+rwx
+ set res [list [catch {file delete -force td1} msg]]
+ lappend res [file exists td1] $msg
+} {0 0 {}}
test fCmd-6.1 {CopyRenameOneFile: bad source} {notRoot} {
# can't test this, because it's caught by FileCopyRename
Index: tests/fileName.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/fileName.test,v
retrieving revision 1.13
diff -u -r1.13 fileName.test
--- tests/fileName.test 2001/08/30 08:53:15 1.13
+++ tests/fileName.test 2001/09/04 15:56:27
@@ -318,10 +318,13 @@
set norm [string range $norm $idx end]
# fix path away so all platforms are the same
regsub -all ":" $norm "/" norm
+ # make sure we can delete the directory we created
+ cd $oldDir
file delete -force $nastydir
set norm
} err]
cd $oldDir
+ catch {file delete -force tildetmp}
list $res $err
} {0 tildetmp/~tilde}
Index: unix/tclLoadAout.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclLoadAout.c,v
retrieving revision 1.5
diff -u -r1.5 tclLoadAout.c
--- unix/tclLoadAout.c 2001/08/30 08:53:15 1.5
+++ unix/tclLoadAout.c 2001/09/04 15:56:27
@@ -136,7 +136,8 @@
*/
int
-TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
+TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
+ clientDataPtr, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Obj *pathPtr; /* Name of the file containing the desired
* code (UTF-8). */
@@ -147,7 +148,11 @@
* 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. */
{
char * inputSymbolTable; /* Name of the file containing the
* symbol table from the last link. */
Index: unix/tclLoadDl.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclLoadDl.c,v
retrieving revision 1.4
diff -u -r1.4 tclLoadDl.c
--- unix/tclLoadDl.c 2001/08/30 08:53:15 1.4
+++ unix/tclLoadDl.c 2001/09/04 15:56:27
@@ -57,7 +57,8 @@
*/
int
-TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
+TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
+ clientDataPtr, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Obj *pathPtr; /* Name of the file containing the desired
* code. */
@@ -68,7 +69,11 @@
* 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. */
{
VOID *handle;
Tcl_DString newName, ds;
@@ -86,6 +91,8 @@
return TCL_ERROR;
}
+ *unloadProcPtr = &TclpUnloadFile;
+
/*
* Some platforms still add an underscore to the beginning of symbol
* names. If we can't find a name without an underscore, try again
Index: unix/tclLoadDld.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclLoadDld.c,v
retrieving revision 1.4
diff -u -r1.4 tclLoadDld.c
--- unix/tclLoadDld.c 2001/08/30 08:53:15 1.4
+++ unix/tclLoadDld.c 2001/09/04 15:56:27
@@ -49,7 +49,8 @@
*/
int
-TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
+TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
+ clientDataPtr, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Obj *pathPtr; /* Name of the file containing the desired
* code. */
@@ -60,7 +61,11 @@
* 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. */
{
static int firstTime = 1;
int returnCode;
@@ -98,6 +103,7 @@
*proc2Ptr = (Tcl_PackageInitProc *) dld_get_func(sym2);
*clientDataPtr = strcpy(
(char *) ckalloc((unsigned) (strlen(fileName) + 1)), fileName);
+ *unloadProcPtr = &TclpUnloadFile;
return TCL_OK;
}
Index: unix/tclLoadDyld.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclLoadDyld.c,v
retrieving revision 1.3
diff -u -r1.3 tclLoadDyld.c
--- unix/tclLoadDyld.c 2001/08/30 08:53:15 1.3
+++ unix/tclLoadDyld.c 2001/09/04 15:56:27
@@ -40,7 +40,8 @@
*/
int
-TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
+TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
+ clientDataPtr, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Obj *pathPtr; /* Name of the file containing the desired
* code. */
@@ -51,7 +52,11 @@
* 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. */
{
NSObjectFileImageReturnCode err;
NSObjectFileImage image;
@@ -108,7 +113,8 @@
*proc2Ptr = NSAddressOfSymbol(symbol);
*clientDataPtr = module;
-
+ *unloadProcPtr = &TclpUnloadFile;
+
return TCL_OK;
}
Index: unix/tclLoadNext.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclLoadNext.c,v
retrieving revision 1.4
diff -u -r1.4 tclLoadNext.c
--- unix/tclLoadNext.c 2001/08/30 08:53:15 1.4
+++ unix/tclLoadNext.c 2001/09/04 15:56:27
@@ -39,7 +39,8 @@
*/
int
-TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
+TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
+ clientDataPtr, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Obj *pathPtr; /* Name of the file containing the desired
* code. */
@@ -50,7 +51,11 @@
* 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. */
{
struct mach_header *header;
char *data;
@@ -81,7 +86,8 @@
rld_lookup(NULL,sym,(unsigned long *)proc2Ptr);
}
*clientDataPtr = NULL;
-
+ *unloadProcPtr = &TclpUnloadFile;
+
return TCL_OK;
}
Index: unix/tclLoadOSF.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclLoadOSF.c,v
retrieving revision 1.4
diff -u -r1.4 tclLoadOSF.c
--- unix/tclLoadOSF.c 2001/08/30 08:53:15 1.4
+++ unix/tclLoadOSF.c 2001/09/04 15:56:27
@@ -60,7 +60,8 @@
*/
int
-TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
+TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
+ clientDataPtr, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Obj *pathPtr; /* Name of the file containing the desired
* code. */
@@ -71,7 +72,11 @@
* 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. */
{
ldr_module_t lm;
char *pkg;
@@ -100,6 +105,7 @@
pkg++;
*proc1Ptr = ldr_lookup_package(pkg, sym1);
*proc2Ptr = ldr_lookup_package(pkg, sym2);
+ *unloadProcPtr = &TclpUnloadFile;
return TCL_OK;
}
Index: unix/tclLoadShl.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclLoadShl.c,v
retrieving revision 1.5
diff -u -r1.5 tclLoadShl.c
--- unix/tclLoadShl.c 2001/08/30 08:53:15 1.5
+++ unix/tclLoadShl.c 2001/09/04 15:56:27
@@ -47,7 +47,8 @@
*/
int
-TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
+TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
+ clientDataPtr, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Obj *pathPtr; /* Name of the file containing the desired
* code. */
@@ -58,7 +59,11 @@
* 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. */
{
shl_t handle;
Tcl_DString newName;
@@ -112,6 +117,7 @@
}
Tcl_DStringFree(&newName);
}
+ *unloadProcPtr = &TclpUnloadFile;
return TCL_OK;
}
Index: unix/tclUnixFCmd.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclUnixFCmd.c,v
retrieving revision 1.11
diff -u -r1.11 tclUnixFCmd.c
--- unix/tclUnixFCmd.c 2001/08/30 08:53:15 1.11
+++ unix/tclUnixFCmd.c 2001/09/04 15:56:30
@@ -685,19 +685,37 @@
* causing error. */
{
CONST char *path;
-
+ mode_t oldPerm = 0;
+ int result;
+
path = Tcl_DStringValue(pathPtr);
+
+ if (recursive != 0) {
+ /* We should try to change permissions so this can be deleted */
+ struct stat statBuf;
+ int newPerm;
+
+ if (stat(path, &statBuf) == 0) {
+ oldPerm = (mode_t) (statBuf.st_mode & 0x00007FFF);
+ }
+
+ newPerm = oldPerm | (64+128+256);
+ chmod(path, (mode_t) newPerm);
+ }
+
if (rmdir(path) == 0) { /* INTL: Native. */
return TCL_OK;
}
if (errno == ENOTEMPTY) {
errno = EEXIST;
}
+
+ result = TCL_OK;
if ((errno != EEXIST) || (recursive == 0)) {
if (errorPtr != NULL) {
Tcl_ExternalToUtfDString(NULL, path, -1, errorPtr);
}
- return TCL_ERROR;
+ result = TCL_ERROR;
}
/*
@@ -705,7 +723,15 @@
* specified, so we recursively remove all the files in the directory.
*/
- return TraverseUnixTree(TraversalDelete, pathPtr, NULL, errorPtr);
+ if (result == TCL_OK) {
+ result = TraverseUnixTree(TraversalDelete, pathPtr, NULL, errorPtr);
+ }
+
+ if ((result != TCL_OK) && (recursive != 0)) {
+ /* Try to restore permissions */
+ chmod(path, oldPerm);
+ }
+ return result;
}
/*
Index: unix/tclUnixPipe.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclUnixPipe.c,v
retrieving revision 1.14
diff -u -r1.14 tclUnixPipe.c
--- unix/tclUnixPipe.c 2001/08/07 00:42:45 1.14
+++ unix/tclUnixPipe.c 2001/09/04 15:56:30
@@ -238,19 +238,29 @@
Tcl_Obj*
TclpTempFileName()
{
- char fileName[L_tmpnam];
+ char fileName[L_tmpnam + 9];
+ Tcl_Obj *result = NULL;
+ int fd;
/*
- * tmpnam should not be used (see [Patch: #442636]), but mkstemp
- * doesn't provide just the filename. The use of this will have
- * to reconcile that conflict.
+ * We should also check against making more then TMP_MAX of these.
*/
- if (tmpnam(fileName) == NULL) { /* INTL: Native. */
+ strcpy(fileName, P_tmpdir); /* INTL: Native. */
+ if (fileName[strlen(fileName) - 1] != '/') {
+ strcat(fileName, "/"); /* INTL: Native. */
+ }
+ strcat(fileName, "tclXXXXXX");
+ fd = mkstemp(fileName); /* INTL: Native. */
+ if (fd == -1) {
return NULL;
}
+ fcntl(fd, F_SETFD, FD_CLOEXEC);
+ unlink(fileName); /* INTL: Native. */
- return TclpNativeToNormalized((ClientData) fileName);
+ result = TclpNativeToNormalized((ClientData) fileName);
+ close (fd);
+ return result;
}
/*
Index: win/makefile.vc
===================================================================
RCS file: /cvsroot/tcl/tcl/win/makefile.vc,v
retrieving revision 1.63
diff -u -r1.63 makefile.vc
--- win/makefile.vc 2001/09/03 00:49:34 1.63
+++ win/makefile.vc 2001/09/04 15:56:30
@@ -49,12 +49,12 @@
!ELSE
# Visual Studio 5 default
-#TOOLS32 = C:\Progra~1\devstudio\vc
-#TOOLS32_rc = C:\Progra~1\devstudio\sharedide
+TOOLS32 = C:\Progra~1\devstudio\vc
+TOOLS32_rc = C:\Progra~1\devstudio\sharedide
# Visual Studio 6 default
-TOOLS32 = C:\Progra~1\Microsoft Visual Studio\VC98
-TOOLS32_rc = C:\Progra~1\Microsoft Visual Studio\common\MSDev98
+#TOOLS32 = C:\Progra~1\Microsoft Visual Studio\VC98
+#TOOLS32_rc = C:\Progra~1\Microsoft Visual Studio\common\MSDev98
cc32 = "$(TOOLS32)\bin\cl.exe"
link32 = "$(TOOLS32)\bin\link.exe"
@@ -70,7 +70,7 @@
#THREADDEFINES = -DTCL_THREADS=1
# Set NODEBUG to 0 to compile with symbols
-NODEBUG = 1
+NODEBUG = 0
# The following defines can be used to control the amount of debugging
# code that is added to the compilation.
@@ -83,9 +83,9 @@
# needed when using Purify. For IA64, we do
# want to use the native allocator.
#
-#DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
+DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
!IF "$(MACHINE)" == "IA64"
-DEBUGDEFINES = -DUSE_TCLALLOC=0
+#DEBUGDEFINES = -DUSE_TCLALLOC=0
!ELSE
#DEBUGDEFINES = -DUSE_TCLALLOC=0
!ENDIF
Index: win/tclWinFCmd.c
===================================================================
RCS file: /cvsroot/tcl/tcl/win/tclWinFCmd.c,v
retrieving revision 1.11
diff -u -r1.11 tclWinFCmd.c
--- win/tclWinFCmd.c 2001/08/30 08:53:15 1.11
+++ win/tclWinFCmd.c 2001/09/04 15:56:30
@@ -92,7 +92,7 @@
static int DoCreateDirectory(CONST TCHAR *pathPtr);
static int DoDeleteFile(CONST TCHAR *pathPtr);
static int DoRemoveJustDirectory(CONST TCHAR *nativeSrc,
- int recursive, Tcl_DString *errorPtr);
+ int ignoreError, Tcl_DString *errorPtr);
static int DoRemoveDirectory(Tcl_DString *pathPtr, int recursive,
Tcl_DString *errorPtr);
static int DoRenameFile(CONST TCHAR *nativeSrc, CONST TCHAR *dstPtr);
@@ -747,7 +747,7 @@
Tcl_DStringFree(&native);
} else {
ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr),
- recursive, &ds);
+ 0, &ds);
}
if (ret != TCL_OK) {
int len = Tcl_DStringLength(&ds);
@@ -764,7 +764,7 @@
DoRemoveJustDirectory(
CONST TCHAR *nativePath, /* Pathname of directory to be removed
* (native). */
- int recursive, /* If non-zero, don't initialize the
+ int ignoreError, /* If non-zero, don't initialize the
* errorPtr under some circumstances
* on return. */
Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
@@ -877,7 +877,7 @@
Tcl_SetErrno(EEXIST);
}
- if ((recursive != 0) && (Tcl_GetErrno() == EEXIST)) {
+ if ((ignoreError != 0) && (Tcl_GetErrno() == EEXIST)) {
/*
* If we're being recursive, this error may actually
* be ok, so we don't want to initialise the errorPtr
Index: win/tclWinLoad.c
===================================================================
RCS file: /cvsroot/tcl/tcl/win/tclWinLoad.c,v
retrieving revision 1.7
diff -u -r1.7 tclWinLoad.c
--- win/tclWinLoad.c 2001/08/30 08:53:15 1.7
+++ win/tclWinLoad.c 2001/09/04 15:56:30
@@ -36,7 +36,8 @@
*/
int
-TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
+TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
+ clientDataPtr, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Obj *pathPtr; /* Name of the file containing the desired
* code. */
@@ -47,7 +48,11 @@
* 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. */
{
HINSTANCE handle;
TCHAR *nativeName;
@@ -109,8 +114,9 @@
(char *) NULL);
}
return TCL_ERROR;
+ } else {
+ *unloadProcPtr = &TclpUnloadFile;
}
-
/*
* For each symbol, check for both Symbol and _Symbol, since Borland
* generates C symbols with a leading '_' by default.
