diff options
| -rw-r--r-- | ChangeLog | 12 | ||||
| -rw-r--r-- | generic/tcl.decls | 5 | ||||
| -rw-r--r-- | generic/tclDecls.h | 10 | ||||
| -rw-r--r-- | generic/tclIOUtil.c | 85 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 3 | ||||
| -rw-r--r-- | generic/tclTest.c | 18 | ||||
| -rw-r--r-- | library/tcltest/tcltest.tcl | 13 |
7 files changed, 117 insertions, 29 deletions
@@ -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 { |