summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorvincentdarley <vincentdarley>2001-09-06 17:51:00 (GMT)
committervincentdarley <vincentdarley>2001-09-06 17:51:00 (GMT)
commit21bfd2e23db4c36f3bf8b253681b9c40c1947aca (patch)
tree39b09d3009512cdbe8e554ff455a6e9cf1e8901f
parentb2eb53e7e42203f94e7f10658405a1ac3f4ad8db (diff)
downloadtcl-21bfd2e23db4c36f3bf8b253681b9c40c1947aca.zip
tcl-21bfd2e23db4c36f3bf8b253681b9c40c1947aca.tar.gz
tcl-21bfd2e23db4c36f3bf8b253681b9c40c1947aca.tar.bz2
fs
-rw-r--r--ChangeLog12
-rw-r--r--generic/tcl.decls5
-rw-r--r--generic/tclDecls.h10
-rw-r--r--generic/tclIOUtil.c85
-rw-r--r--generic/tclStubInit.c3
-rw-r--r--generic/tclTest.c18
-rw-r--r--library/tcltest/tcltest.tcl13
7 files changed, 117 insertions, 29 deletions
diff --git a/ChangeLog b/ChangeLog
index 32c4198..f47ddc7 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,15 @@
+2001-09-06 Vince Darley <vincentdarley@users.sourceforge.net>
+
+ * generic/tclTest.c: tests of old-fs hooks no longer cause problems
+ in threaded builds. Also removed unused unload proc.
+ * generic/tcl.decls:
+ * generic/tclIOUtilc: added Tcl_FSMountsChanged so that a vfs
+ can inform the filesystem that the filesystem epoch must be
+ changed (since cached filesystems may now be incorrect). Fixes
+ problem running tclvfs extension.
+ * library/tcltest/tcltest.tcl: if tests aren't in a native
+ filesystem, then don't use pipes to run them. [Bug 458741]
+
2001-09-06 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tcl.decls (479 generic):
diff --git a/generic/tcl.decls b/generic/tcl.decls
index a4783ab..a356955 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.55 2001/09/06 09:35:38 dkf Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.56 2001/09/06 17:51:00 vincentdarley Exp $
library tcl
@@ -1678,6 +1678,9 @@ declare 478 generic {
declare 479 generic {
int Tcl_OutputBuffered(Tcl_Channel chan)
}
+declare 480 generic {
+ void Tcl_FSMountsChanged(Tcl_Filesystem *fsPtr)
+}
##############################################################################
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index a0c3a73..ca2d0f1 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.56 2001/09/06 09:35:38 dkf Exp $
+ * RCS: @(#) $Id: tclDecls.h,v 1.57 2001/09/06 17:51:00 vincentdarley Exp $
*/
#ifndef _TCLDECLS
@@ -1497,6 +1497,9 @@ EXTERN Tcl_Filesystem* Tcl_FSGetFileSystemForPath _ANSI_ARGS_((
EXTERN Tcl_PathType Tcl_FSGetPathType _ANSI_ARGS_((Tcl_Obj * pathObjPtr));
/* 479 */
EXTERN int Tcl_OutputBuffered _ANSI_ARGS_((Tcl_Channel chan));
+/* 480 */
+EXTERN void Tcl_FSMountsChanged _ANSI_ARGS_((
+ Tcl_Filesystem * fsPtr));
typedef struct TclStubHooks {
struct TclPlatStubs *tclPlatStubs;
@@ -2036,6 +2039,7 @@ typedef struct TclStubs {
Tcl_Filesystem* (*tcl_FSGetFileSystemForPath) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 477 */
Tcl_PathType (*tcl_FSGetPathType) _ANSI_ARGS_((Tcl_Obj * pathObjPtr)); /* 478 */
int (*tcl_OutputBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 479 */
+ void (*tcl_FSMountsChanged) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 480 */
} TclStubs;
#ifdef __cplusplus
@@ -3996,6 +4000,10 @@ extern TclStubs *tclStubsPtr;
#define Tcl_OutputBuffered \
(tclStubsPtr->tcl_OutputBuffered) /* 479 */
#endif
+#ifndef Tcl_FSMountsChanged
+#define Tcl_FSMountsChanged \
+ (tclStubsPtr->tcl_FSMountsChanged) /* 480 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 96a33f8..2650ecd 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.18 2001/09/04 18:06:34 vincentdarley Exp $
+ * RCS: @(#) $Id: tclIOUtil.c,v 1.19 2001/09/06 17:51:00 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -367,7 +367,7 @@ static FilesystemRecord nativeFilesystemRecord = {
* filesystems. Any time it changes, all cached filesystem
* representations are suspect and must be freed.
*/
-int filesystemEpoch = 0;
+int theFilesystemEpoch = 0;
/* Stores the linked list of filesystems.*/
static FilesystemRecord *filesystemList = &nativeFilesystemRecord;
/*
@@ -566,7 +566,7 @@ Tcl_FSRegister(clientData, fsPtr)
* Increment the filesystem epoch counter, since existing paths
* might conceivably now belong to different filesystems.
*/
- filesystemEpoch++;
+ theFilesystemEpoch++;
Tcl_MutexUnlock(&filesystemMutex);
return TCL_OK;
@@ -629,7 +629,7 @@ Tcl_FSUnregister(fsPtr)
* do not reference that filesystem (which would of course
* lead to memory exceptions).
*/
- filesystemEpoch++;
+ theFilesystemEpoch++;
tmpFsRecPtr->fileRefCount--;
if (tmpFsRecPtr->fileRefCount <= 0) {
@@ -650,6 +650,69 @@ Tcl_FSUnregister(fsPtr)
/*
*----------------------------------------------------------------------
*
+ * Tcl_FSMountsChanged --
+ *
+ * Notify the filesystem that the available mounted filesystems
+ * (or within any one filesystem type, the number or location of
+ * mount points) have changed.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The global filesystem variable 'theFilesystemEpoch' is
+ * incremented. The effect of this is to make all cached
+ * path representations invalid. Clearly it should only therefore
+ * be called when it is really required! There are a few
+ * circumstances when it should be called:
+ *
+ * (1) when a new filesystem is registered or unregistered.
+ * Strictly speaking this is only necessary if the new filesystem
+ * accepts file paths as is (normally the filesystem itself is
+ * really a shell which hasn't yet had any mount points established
+ * and so its 'pathInFilesystem' proc will always fail). However,
+ * for safety, Tcl always calls this for you in these circumstances.
+ *
+ * (2) when additional mount points are established inside any
+ * existing filesystem (except the native fs)
+ *
+ * (3) when any filesystem (except the native fs) changes the list
+ * of available volumes.
+ *
+ * Tcl has no control over (2) and (3), so any registered filesystem
+ * must make sure it calls this function when those situations
+ * occur.
+ *
+ * (Note: the reason for the exception in 2,3 for the native
+ * filesystem is that the native filesystem by default claims all
+ * unknown files even if it really doesn't understand them or if
+ * they don't exist).
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_FSMountsChanged(fsPtr)
+ Tcl_Filesystem *fsPtr;
+{
+ /*
+ * We currently don't do anything with this parameter. We
+ * could in the future only invalidate files for this filesystem
+ * or otherwise take more advanced action.
+ */
+ (void)fsPtr;
+ /*
+ * Increment the filesystem epoch counter, since existing paths
+ * might now belong to different filesystems.
+ */
+ Tcl_MutexLock(&filesystemMutex);
+ theFilesystemEpoch++;
+ Tcl_MutexUnlock(&filesystemMutex);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_FSData --
*
* Retrieve the clientData field for the filesystem given,
@@ -4290,12 +4353,12 @@ Tcl_FSGetFileSystemForPath(pathObjPtr)
}
/*
- * Get a lock on filesystemEpoch and the filesystemList
+ * Get a lock on theFilesystemEpoch and the filesystemList
*
- * While we don't need the fsRecPtr until the while loop
- * below, we do want to make sure the filesystemEpoch doesn't
- * change between the 'if' and 'while' blocks, getting this
- * iterator will ensure that everything is consistent
+ * While we don't need the fsRecPtr until the while loop below, we
+ * do want to make sure the theFilesystemEpoch doesn't change
+ * between the 'if' and 'while' blocks, getting this iterator will
+ * ensure that everything is consistent
*/
fsRecPtr = FsGetIterator();
@@ -4308,7 +4371,7 @@ Tcl_FSGetFileSystemForPath(pathObjPtr)
* Check if the filesystem has changed in some way since
* this object's internal representation was calculated.
*/
- if (srcFsPathPtr->filesystemEpoch != filesystemEpoch) {
+ if (srcFsPathPtr->filesystemEpoch != theFilesystemEpoch) {
/*
* We have to discard the stale representation and
* recalculate it
@@ -4346,7 +4409,7 @@ Tcl_FSGetFileSystemForPath(pathObjPtr)
*/
srcFsPathPtr->fsRecPtr = fsRecPtr;
srcFsPathPtr->nativePathPtr = clientData;
- srcFsPathPtr->filesystemEpoch = filesystemEpoch;
+ srcFsPathPtr->filesystemEpoch = theFilesystemEpoch;
fsRecPtr->fileRefCount++;
retVal = fsRecPtr->fsPtr;
}
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index a3c6b02..f216358 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.58 2001/09/06 09:35:39 dkf Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.59 2001/09/06 17:51:00 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -876,6 +876,7 @@ TclStubs tclStubs = {
Tcl_FSGetFileSystemForPath, /* 477 */
Tcl_FSGetPathType, /* 478 */
Tcl_OutputBuffered, /* 479 */
+ Tcl_FSMountsChanged, /* 480 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index af93ff6..396a321 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.29 2001/09/04 18:06:34 vincentdarley Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.30 2001/09/06 17:51:00 vincentdarley Exp $
*/
#define TCL_TEST
@@ -328,7 +328,6 @@ static Tcl_FSCreateDirectoryProc TestReportCreateDirectory;
static Tcl_FSCopyDirectoryProc TestReportCopyDirectory;
static Tcl_FSRemoveDirectoryProc TestReportRemoveDirectory;
static Tcl_FSLoadFileProc TestReportLoadFile;
-static Tcl_FSUnloadFileProc TestReportUnloadFile;
static Tcl_FSLinkProc TestReportLink;
static Tcl_FSFileAttrStringsProc TestReportFileAttrStrings;
static Tcl_FSFileAttrsGetProc TestReportFileAttrsGet;
@@ -4091,7 +4090,7 @@ static int PretendTclpStat(path, buf)
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1);
Tcl_IncrRefCount(pathPtr);
- ret = Tcl_FSStat(pathPtr, buf);
+ ret = TclpObjStat(pathPtr, buf);
Tcl_DecrRefCount(pathPtr);
return ret;
}
@@ -4245,7 +4244,7 @@ static int PretendTclpAccess(path, mode)
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1);
Tcl_IncrRefCount(pathPtr);
- ret = Tcl_FSAccess(pathPtr, mode);
+ ret = TclpObjAccess(pathPtr, mode);
Tcl_DecrRefCount(pathPtr);
return ret;
}
@@ -4366,7 +4365,7 @@ PretendTclpOpenFileChannel(interp, fileName, modeString, permissions)
Tcl_Channel ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName, -1);
Tcl_IncrRefCount(pathPtr);
- ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions);
+ ret = TclpOpenFileChannel(interp, pathPtr, modeString, permissions);
Tcl_DecrRefCount(pathPtr);
return ret;
}
@@ -5422,15 +5421,6 @@ TestReportLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr,
return Tcl_FSLoadFile(interp, TestReportGetNativePath(fileName), sym1, sym2,
proc1Ptr, proc2Ptr, clientDataPtr, unloadProcPtr);
}
-static void
-TestReportUnloadFile(clientData)
- ClientData clientData; /* ClientData returned by a previous call
- * to TclpLoadFile(). The clientData is
- * a token that represents the loaded
- * file. */
-{
- TestReport("unloadfile",NULL,NULL);
-}
static Tcl_Obj *
TestReportLink(path, to)
Tcl_Obj *path; /* Path of file to readlink or link */
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index 83c584e..bca10be 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -13,7 +13,7 @@
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
-# RCS: @(#) $Id: tcltest.tcl,v 1.32 2001/08/22 23:55:45 hobbs Exp $
+# RCS: @(#) $Id: tcltest.tcl,v 1.33 2001/09/06 17:51:00 vincentdarley Exp $
# create the "tcltest" namespace for all testing variables and procedures
@@ -2921,6 +2921,17 @@ proc tcltest::runAllTests { {shell ""} } {
puts [outputChannel] "Tests located in: $tcltest::testsDirectory"
puts [outputChannel] "Tests running in: [tcltest::workingDirectory]"
puts [outputChannel] "Temporary files stored in $tcltest::temporaryDirectory"
+
+ if {[package vcompare [package provide Tcl] 8.4] >= 0} {
+ # If we aren't running in the native filesystem, then we must
+ # run the tests in a single process (via 'source'), because
+ # trying to run then via a pipe will fail since the files don't
+ # really exist.
+ if {[lindex [file system [tcltest::testsDirectory]] 0] != "native"} {
+ tcltest::singleProcess 1
+ }
+ }
+
if {[tcltest::singleProcess]} {
puts [outputChannel] "Test files sourced into current interpreter"
} else {