summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog42
-rw-r--r--doc/FileSystem.320
-rw-r--r--doc/file.n9
-rw-r--r--doc/filename.n15
-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
-rw-r--r--mac/tclMacLoad.c11
-rw-r--r--tests/fCmd.test21
-rw-r--r--tests/fileName.test5
-rw-r--r--tests/winFCmd.test29
-rw-r--r--unix/tclLoadAout.c11
-rw-r--r--unix/tclLoadDl.c13
-rw-r--r--unix/tclLoadDld.c12
-rw-r--r--unix/tclLoadDyld.c14
-rw-r--r--unix/tclLoadNext.c14
-rw-r--r--unix/tclLoadOSF.c12
-rw-r--r--unix/tclLoadShl.c12
-rw-r--r--unix/tclUnixFCmd.c34
-rw-r--r--unix/tclUnixPipe.c24
-rw-r--r--win/tclWinFCmd.c10
-rw-r--r--win/tclWinLoad.c14
29 files changed, 774 insertions, 320 deletions
diff --git a/ChangeLog b/ChangeLog
index af2eb33..1dc230d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,45 @@
+2001-09-04 Vince Darley <vincentdarley@users.sourceforge.net>
+
+ Minor bug fixes in filesystem, plus small vfs changes as a
+ result of enabling the test filesystem to work properly.
+ * 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.
+ Made sure filesystems which are registered and then unregistered
+ are only freed when all references to them are gone.
+ Documented changes.
+ * unix/tclUnixFCmd.c: when deleting directories recursively,
+ make sure permissions are ok. Together with the above, this
+ fixes [Bug: 219139]
+ * tests/winFCmd.test: differentiated test results for win2k
+ versus not. This fixes [Bug: 219239]
+ * tests/fCmd.test: added tests for 'file delete -force' where
+ the cwd is inside, and when permissions are inadequate.
+
2001-09-04 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclCompile.c: fixed incorrect opreands for INST_LIST
diff --git a/doc/FileSystem.3 b/doc/FileSystem.3
index 9836dea..97bfe2c 100644
--- a/doc/FileSystem.3
+++ b/doc/FileSystem.3
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: FileSystem.3,v 1.4 2001/08/30 08:53:14 vincentdarley Exp $
+'\" RCS: @(#) $Id: FileSystem.3,v 1.5 2001/09/04 18:06:34 vincentdarley Exp $
'\"
.so man.macros
.TH Tcl_FSCopyFile 3 8.4 Tcl "Tcl Library Procedures"
@@ -252,8 +252,8 @@ passing it in, or decrementing it.
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 @@ typedef struct Tcl_Filesystem {
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 @@ functions (it will use \fITcl_FSCopyFileProc\fR followed by
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 @@ typedef int Tcl_FSLoadFileProc(
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 @@ message is left in the interp's result. The function dynamically loads
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
diff --git a/doc/file.n b/doc/file.n
index 681207f..df71bd5 100644
--- a/doc/file.n
+++ b/doc/file.n
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: file.n,v 1.7 2001/07/31 19:12:06 vincentdarley Exp $
+'\" RCS: @(#) $Id: file.n,v 1.8 2001/09/04 18:06:34 vincentdarley Exp $
'\"
.so man.macros
.TH file n 8.3 Tcl "Tcl Built-In Commands"
@@ -110,9 +110,12 @@ starts with a \fB\-\fR.
.
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.
diff --git a/doc/filename.n b/doc/filename.n
index 4721e5b..c0e2a68 100644
--- a/doc/filename.n
+++ b/doc/filename.n
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: filename.n,v 1.6 2001/08/24 16:40:18 vincentdarley Exp $
+'\" RCS: @(#) $Id: filename.n,v 1.7 2001/09/04 18:06:34 vincentdarley Exp $
'\"
.so man.macros
.TH filename n 7.5 Tcl "Tcl Built-In Commands"
@@ -136,7 +136,9 @@ On Microsoft Windows platforms, Tcl supports both drive-relative and UNC
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 @@ following examples illustrate various forms of path names:
.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 @@ directory on the current volume.
\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"
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)
diff --git a/mac/tclMacLoad.c b/mac/tclMacLoad.c
index fd355ae..ef9da8e 100644
--- a/mac/tclMacLoad.c
+++ b/mac/tclMacLoad.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclMacLoad.c,v 1.5 2001/08/30 08:53:15 vincentdarley Exp $
+ * RCS: @(#) $Id: tclMacLoad.c,v 1.6 2001/09/04 18:06:34 vincentdarley Exp $
*/
#include <CodeFragments.h>
@@ -107,9 +107,13 @@ TclpLoadFile(
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 @@ TclpLoadFile(
}
*clientDataPtr = (ClientData) connID;
+ *unloadProcPtr = &TclpUnloadFile;
return TCL_OK;
}
diff --git a/tests/fCmd.test b/tests/fCmd.test
index c9e4ca0..9b3d997 100644
--- a/tests/fCmd.test
+++ b/tests/fCmd.test
@@ -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: fCmd.test,v 1.10 2001/07/31 19:12:07 vincentdarley Exp $
+# RCS: @(#) $Id: fCmd.test,v 1.11 2001/09/04 18:06:34 vincentdarley Exp $
#
if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -381,9 +381,26 @@ test fCmd-5.9 {TclFileDeleteCmd: is directory} {notRoot} {
} {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
diff --git a/tests/fileName.test b/tests/fileName.test
index 5545cb1..92f0e30 100644
--- a/tests/fileName.test
+++ b/tests/fileName.test
@@ -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: fileName.test,v 1.13 2001/08/30 08:53:15 vincentdarley Exp $
+# RCS: @(#) $Id: fileName.test,v 1.14 2001/09/04 18:06:34 vincentdarley Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -318,10 +318,13 @@ test filename-4.19 {Tcl_SplitPath} {
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}
diff --git a/tests/winFCmd.test b/tests/winFCmd.test
index 1e63666..d63a073 100644
--- a/tests/winFCmd.test
+++ b/tests/winFCmd.test
@@ -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: winFCmd.test,v 1.11 2001/08/30 08:53:15 vincentdarley Exp $
+# RCS: @(#) $Id: winFCmd.test,v 1.12 2001/09/04 18:06:34 vincentdarley Exp $
#
if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -44,6 +44,15 @@ proc cleanup {args} {
}
}
+if {[string equal $tcl_platform(os) "Windows NT"] \
+ && [string equal [string index $tcl_platform(osVersion) 0] "5"]} {
+ tcltest::testConstraint win2000 1
+ tcltest::testConstraint notWin2000 0
+} else {
+ tcltest::testConstraint win2000 0
+ tcltest::testConstraint notWin2000 1
+}
+
set ::tcltest::testConstraints(cdrom) 0
set ::tcltest::testConstraints(exdev) 0
@@ -188,7 +197,11 @@ test winFCmd-1.12 {TclpRenameFile: errno: EACCES} {pcOnly} {
close $fd
set msg
} {1 EACCES}
-test winFCmd-1.13 {TclpRenameFile: errno: EACCES} {pcOnly} {
+test winFCmd-1.13 {TclpRenameFile: errno: EACCES} {win2000} {
+ cleanup
+ list [catch {testfile mv nul tf1} msg] $msg
+} {1 EINVAL}
+test winFCmd-1.13.1 {TclpRenameFile: errno: EACCES} {notWin2000} {
cleanup
list [catch {testfile mv nul tf1} msg] $msg
} {1 EACCES}
@@ -216,7 +229,11 @@ test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} {pcOnly} {
cleanup
list [catch {testfile mv tf1 tf2} msg] $msg
} {1 ENOENT}
-test winFCmd-1.19 {TclpRenameFile: errno == EACCES} {pcOnly} {
+test winFCmd-1.19 {TclpRenameFile: errno == EACCES} {win2000} {
+ cleanup
+ list [catch {testfile mv nul tf1} msg] $msg
+} {1 EINVAL}
+test winFCmd-1.19.1 {TclpRenameFile: errno == EACCES} {notWin2000} {
cleanup
list [catch {testfile mv nul tf1} msg] $msg
} {1 EACCES}
@@ -361,7 +378,11 @@ test winFCmd-2.7 {TclpCopyFile: errno: EACCES} {95} {
close $fd
set msg
} {1 EACCES}
-test winFCmd-2.8 {TclpCopyFile: errno: EACCES} {nt} {
+test winFCmd-2.8 {TclpCopyFile: errno: EACCES} {win2000} {
+ cleanup
+ list [catch {testfile cp nul tf1} msg] $msg
+} {1 EINVAL}
+test winFCmd-2.8.1 {TclpCopyFile: errno: EACCES} {nt notWin2000} {
cleanup
list [catch {testfile cp nul tf1} msg] $msg
} {1 EACCES}
diff --git a/unix/tclLoadAout.c b/unix/tclLoadAout.c
index 51e38b3..ddc5316 100644
--- a/unix/tclLoadAout.c
+++ b/unix/tclLoadAout.c
@@ -14,7 +14,7 @@
* and Design Engineering (MADE) Initiative through ARPA contract
* F33615-94-C-4400.
*
- * RCS: @(#) $Id: tclLoadAout.c,v 1.5 2001/08/30 08:53:15 vincentdarley Exp $
+ * RCS: @(#) $Id: tclLoadAout.c,v 1.6 2001/09/04 18:06:34 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -136,7 +136,8 @@ static void UnlinkSymbolTable _ANSI_ARGS_((void));
*/
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 @@ TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
* 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. */
diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c
index bfe52e9..1d20521 100644
--- a/unix/tclLoadDl.c
+++ b/unix/tclLoadDl.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclLoadDl.c,v 1.4 2001/08/30 08:53:15 vincentdarley Exp $
+ * RCS: @(#) $Id: tclLoadDl.c,v 1.5 2001/09/04 18:06:34 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -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 @@ TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
* 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 @@ TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
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
diff --git a/unix/tclLoadDld.c b/unix/tclLoadDld.c
index 2b15148..ecf5b12 100644
--- a/unix/tclLoadDld.c
+++ b/unix/tclLoadDld.c
@@ -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: tclLoadDld.c,v 1.4 2001/08/30 08:53:15 vincentdarley Exp $
+ * RCS: @(#) $Id: tclLoadDld.c,v 1.5 2001/09/04 18:06:34 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -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 @@ TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
* 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 @@ TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
*proc2Ptr = (Tcl_PackageInitProc *) dld_get_func(sym2);
*clientDataPtr = strcpy(
(char *) ckalloc((unsigned) (strlen(fileName) + 1)), fileName);
+ *unloadProcPtr = &TclpUnloadFile;
return TCL_OK;
}
diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c
index 58eb5a5..aed76ff 100644
--- a/unix/tclLoadDyld.c
+++ b/unix/tclLoadDyld.c
@@ -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: tclLoadDyld.c,v 1.3 2001/08/30 08:53:15 vincentdarley Exp $
+ * RCS: @(#) $Id: tclLoadDyld.c,v 1.4 2001/09/04 18:06:34 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -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 @@ TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
* 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 @@ TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
*proc2Ptr = NSAddressOfSymbol(symbol);
*clientDataPtr = module;
-
+ *unloadProcPtr = &TclpUnloadFile;
+
return TCL_OK;
}
diff --git a/unix/tclLoadNext.c b/unix/tclLoadNext.c
index f460524..17f124b 100644
--- a/unix/tclLoadNext.c
+++ b/unix/tclLoadNext.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclLoadNext.c,v 1.4 2001/08/30 08:53:15 vincentdarley Exp $
+ * RCS: @(#) $Id: tclLoadNext.c,v 1.5 2001/09/04 18:06:34 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -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 @@ TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
* 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 @@ TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
rld_lookup(NULL,sym,(unsigned long *)proc2Ptr);
}
*clientDataPtr = NULL;
-
+ *unloadProcPtr = &TclpUnloadFile;
+
return TCL_OK;
}
diff --git a/unix/tclLoadOSF.c b/unix/tclLoadOSF.c
index cd6a393..cdaf92c 100644
--- a/unix/tclLoadOSF.c
+++ b/unix/tclLoadOSF.c
@@ -31,7 +31,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclLoadOSF.c,v 1.4 2001/08/30 08:53:15 vincentdarley Exp $
+ * RCS: @(#) $Id: tclLoadOSF.c,v 1.5 2001/09/04 18:06:34 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -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 @@ TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
* 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 @@ TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
pkg++;
*proc1Ptr = ldr_lookup_package(pkg, sym1);
*proc2Ptr = ldr_lookup_package(pkg, sym2);
+ *unloadProcPtr = &TclpUnloadFile;
return TCL_OK;
}
diff --git a/unix/tclLoadShl.c b/unix/tclLoadShl.c
index 0d7c648..5feb489 100644
--- a/unix/tclLoadShl.c
+++ b/unix/tclLoadShl.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclLoadShl.c,v 1.5 2001/08/30 08:53:15 vincentdarley Exp $
+ * RCS: @(#) $Id: tclLoadShl.c,v 1.6 2001/09/04 18:06:34 vincentdarley Exp $
*/
#include <dl.h>
@@ -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 @@ TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
* 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 @@ TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
}
Tcl_DStringFree(&newName);
}
+ *unloadProcPtr = &TclpUnloadFile;
return TCL_OK;
}
diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c
index 264a7a6..98d5224 100644
--- a/unix/tclUnixFCmd.c
+++ b/unix/tclUnixFCmd.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclUnixFCmd.c,v 1.11 2001/08/30 08:53:15 vincentdarley Exp $
+ * RCS: @(#) $Id: tclUnixFCmd.c,v 1.12 2001/09/04 18:06:34 vincentdarley Exp $
*
* Portions of this code were derived from NetBSD source code which has
* the following copyright notice:
@@ -685,19 +685,37 @@ DoRemoveDirectory(pathPtr, recursive, errorPtr)
* 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 @@ DoRemoveDirectory(pathPtr, recursive, errorPtr)
* 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;
}
/*
diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c
index 964b3b1..85316c0 100644
--- a/unix/tclUnixPipe.c
+++ b/unix/tclUnixPipe.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclUnixPipe.c,v 1.14 2001/08/07 00:42:45 hobbs Exp $
+ * RCS: @(#) $Id: tclUnixPipe.c,v 1.15 2001/09/04 18:06:35 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -238,19 +238,29 @@ TclpCreateTempFile(contents)
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;
}
/*
diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c
index a04fc45..1832a76 100644
--- a/win/tclWinFCmd.c
+++ b/win/tclWinFCmd.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: tclWinFCmd.c,v 1.11 2001/08/30 08:53:15 vincentdarley Exp $
+ * RCS: @(#) $Id: tclWinFCmd.c,v 1.12 2001/09/04 18:06:35 vincentdarley Exp $
*/
#include "tclWinInt.h"
@@ -92,7 +92,7 @@ static int DoCopyFile(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr);
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 @@ TclpObjRemoveDirectory(pathPtr, recursive, errorPtr)
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 @@ static int
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 @@ DoRemoveJustDirectory(
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
diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c
index c0923d5..50d14c9 100644
--- a/win/tclWinLoad.c
+++ b/win/tclWinLoad.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclWinLoad.c,v 1.7 2001/08/30 08:53:15 vincentdarley Exp $
+ * RCS: @(#) $Id: tclWinLoad.c,v 1.8 2001/09/04 18:06:35 vincentdarley Exp $
*/
#include "tclWinInt.h"
@@ -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 @@ TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
* 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 @@ TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
(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.
generated by cgit v0.12 at 2024-11-01 19:04:15 (GMT)