diff options
| -rw-r--r-- | ChangeLog | 13 | ||||
| -rw-r--r-- | generic/tclIOUtil.c | 12 | ||||
| -rw-r--r-- | generic/tclTest.c | 186 | ||||
| -rw-r--r-- | tests/fileSystem.test | 14 |
4 files changed, 220 insertions, 5 deletions
@@ -1,3 +1,16 @@ +2003-01-28 Vince Darley <vincentdarley@users.sourceforge.net> + + * generic/tclIOUtil.c: fix to setting modification date + in TclCrossFilesystemCopy. Also added 'panic' in + Tcl_FSGetFileSystemForPath under illegal calling circumstances + which lead to hard-to-track-down bugs. + + * generic/tclTest.c: added test suite code to allow + exercising a vfs-crash-on-exit bug in Tcl's finalization caused + by the encodings being cleaned up before unloading occurs. + * tests/fileSystem.test: added new 'knownBug' test 7.1 + to demonstrate the crash on exit. + 2003-01-28 Mo DeJong <mdejong@users.sourceforge.net> * generic/tcl.h: Add TCL_PREFIX_IDENT and diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index e74e94e..5e7c6b2 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.69 2003/01/10 15:03:53 vincentdarley Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.70 2003/01/28 14:52:47 vincentdarley Exp $ */ #include "tclInt.h" @@ -2610,6 +2610,13 @@ Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, Tcl_DecrRefCount(perm); #endif + /* + * We need to reset the result now, because the cross- + * filesystem copy may have stored the number of bytes + * in the result + */ + Tcl_ResetResult(interp); + retVal = Tcl_FSLoadFile(interp, copyToPtr, sym1, sym2, proc1Ptr, proc2Ptr, &newLoadHandle, @@ -3491,7 +3498,7 @@ TclCrossFilesystemCopy(interp, source, target) if (Tcl_FSLstat(source, &sourceStatBuf) != 0) { tval.actime = sourceStatBuf.st_atime; tval.modtime = sourceStatBuf.st_mtime; - Tcl_FSUtime(source, &tval); + Tcl_FSUtime(target, &tval); } } } @@ -4843,6 +4850,7 @@ Tcl_FSGetFileSystemForPath(pathObjPtr) */ if (pathObjPtr->refCount == 0) { + panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0"); return NULL; } diff --git a/generic/tclTest.c b/generic/tclTest.c index 26bc889..f70f587 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.56 2002/08/05 03:24:41 dgp Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.57 2003/01/28 14:52:50 vincentdarley Exp $ */ #define TCL_TEST @@ -334,10 +334,15 @@ static int TestChannelEventCmd _ANSI_ARGS_((ClientData clientData, static int TestFilesystemObjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +static int TestSimpleFilesystemObjCmd _ANSI_ARGS_(( + ClientData dummy, Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); -static void TestReport _ANSI_ARGS_((CONST char* cmd, Tcl_Obj* arg1, Tcl_Obj* arg2)); +static void TestReport _ANSI_ARGS_ ((CONST char* cmd, Tcl_Obj* arg1, + Tcl_Obj* arg2)); -static Tcl_Obj *TestReportGetNativePath(Tcl_Obj* pathObjPtr); +static Tcl_Obj* TestReportGetNativePath _ANSI_ARGS_ (( + Tcl_Obj* pathObjPtr)); static int TestReportStat _ANSI_ARGS_ ((Tcl_Obj *path, Tcl_StatBuf *buf)); @@ -384,6 +389,18 @@ static int TestReportInFilesystem _ANSI_ARGS_ ((Tcl_Obj *pathPtr, ClientData *c static void TestReportFreeInternalRep _ANSI_ARGS_ ((ClientData clientData)); static ClientData TestReportDupInternalRep _ANSI_ARGS_ ((ClientData clientData)); +static int SimpleStat _ANSI_ARGS_ ((Tcl_Obj *path, + Tcl_StatBuf *buf)); +static int SimpleAccess _ANSI_ARGS_ ((Tcl_Obj *path, + int mode)); +static Tcl_Channel SimpleOpenFileChannel _ANSI_ARGS_ (( + Tcl_Interp *interp, Tcl_Obj *fileName, + int mode, int permissions)); +static Tcl_Obj* SimpleListVolumes _ANSI_ARGS_ ((void)); +static int SimplePathInFilesystem _ANSI_ARGS_ (( + Tcl_Obj *pathPtr, ClientData *clientDataPtr)); + + static Tcl_Filesystem testReportingFilesystem = { "reporting", sizeof(Tcl_Filesystem), @@ -418,6 +435,53 @@ static Tcl_Filesystem testReportingFilesystem = { &TestReportChdir }; +static Tcl_Filesystem simpleFilesystem = { + "simple", + sizeof(Tcl_Filesystem), + TCL_FILESYSTEM_VERSION_1, + &SimplePathInFilesystem, + NULL, + NULL, + /* No internal to normalized, since we don't create any + * pure 'internal' Tcl_Obj path representations */ + NULL, + /* No create native rep function, since we don't use it + * or 'Tcl_FSNewNativePath' */ + NULL, + /* Normalize path isn't needed - we assume paths only have + * one representation */ + NULL, + NULL, + NULL, + &SimpleStat, + &SimpleAccess, + &SimpleOpenFileChannel, + NULL, + NULL, + /* We choose not to support symbolic links inside our vfs's */ + NULL, + &SimpleListVolumes, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + /* No copy file - fallback will occur at Tcl level */ + NULL, + /* No rename file - fallback will occur at Tcl level */ + NULL, + /* No copy directory - fallback will occur at Tcl level */ + NULL, + /* Use stat for lstat */ + NULL, + /* No load - fallback on core implementation */ + NULL, + /* We don't need a getcwd or chdir - fallback on Tcl's versions */ + NULL, + NULL +}; + /* * External (platform specific) initialization routine, these declarations @@ -479,6 +543,8 @@ Tcltest_Init(interp) (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct", TestGetIndexFromObjStructObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); @@ -5677,6 +5743,34 @@ TestFilesystemObjCmd(dummy, interp, objc, objv) return res; } +static int +TestSimpleFilesystemObjCmd(dummy, interp, objc, objv) + ClientData dummy; + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; +{ + int res, boolVal; + char *msg; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "boolean"); + return TCL_ERROR; + } + if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) { + return TCL_ERROR; + } + if (boolVal) { + res = Tcl_FSRegister((ClientData)interp, &simpleFilesystem); + msg = (res == TCL_OK) ? "registered" : "failed"; + } else { + res = Tcl_FSUnregister(&simpleFilesystem); + msg = (res == TCL_OK) ? "unregistered" : "failed"; + } + Tcl_SetResult(interp, msg, TCL_VOLATILE); + return res; +} + static int TestReportInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr) { @@ -5959,3 +6053,89 @@ TestReportNormalizePath(interp, pathPtr, nextCheckpoint) TestReport("normalizepath",pathPtr,NULL); return nextCheckpoint; } + +static int +SimplePathInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr) { + CONST char *str = Tcl_GetString(pathPtr); + if (strncmp(str,"simplefs:/",10)) { + return -1; + } + return TCL_OK; +} + +static Tcl_Channel +SimpleOpenFileChannel(interp, pathPtr, mode, permissions) + Tcl_Interp *interp; /* Interpreter for error reporting; + * can be NULL. */ + Tcl_Obj *pathPtr; /* Name of file to open. */ + int mode; /* POSIX open mode. */ + int permissions; /* If the open involves creating a + * file, with what modes to create + * it? */ +{ + Tcl_Obj *tempPtr, *origPtr; + Tcl_Channel chan; + int res; + CONST char *str; + + if ((mode != 0) && !(mode & O_RDONLY)) { + Tcl_AppendResult(interp, "read-only", + (char *) NULL); + return NULL; + } + + tempPtr = TclpTempFileName(); + Tcl_IncrRefCount(tempPtr); + + /* + * We assume the same name in the current directory is ok. + */ + str = Tcl_GetString(pathPtr); + origPtr = Tcl_NewStringObj(str+10,-1); + Tcl_IncrRefCount(origPtr); + + res = TclCrossFilesystemCopy(interp, origPtr, tempPtr); + + Tcl_DecrRefCount(origPtr); + + if (res != TCL_OK) { + Tcl_DecrRefCount(tempPtr); + return NULL; + } + + chan = Tcl_FSOpenFileChannel(interp, tempPtr, "r", permissions); + + Tcl_DecrRefCount(tempPtr); + + return chan; +} + +static int +SimpleAccess(pathPtr, mode) + Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */ + int mode; /* Permission setting. */ +{ + /* All files exist */ + return TCL_OK; +} + +static int +SimpleStat(pathPtr, bufPtr) + Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ + Tcl_StatBuf *bufPtr; /* Filled with results of stat call. */ +{ + /* All files exist */ + return TCL_OK; +} + +static Tcl_Obj* +SimpleListVolumes(void) +{ + /* Add one new volume */ + Tcl_Obj *retVal; + + retVal = Tcl_NewStringObj("simplefs:/",-1); + Tcl_IncrRefCount(retVal); + return retVal; +} + diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 2185dbf..3dbaf88 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -390,6 +390,20 @@ test filesystem-6.33 {empty file name} { while {![catch {testfilesystem 0}]} {} } +test filesystem-7.1 {load from vfs} {win} { + # This may cause a crash on exit + set dir [pwd] + cd [file dirname [info nameof]] + set dde [lindex [glob *dde*[info sharedlib]] 0] + testsimplefilesystem 1 + # This loads dde via a complex copy-to-temp operation + load simplefs:/$dde dde + testsimplefilesystem 0 + cd $dir + set res "ok" + # The real result of this test is what happens when Tcl exits. +} {ok} + cleanupTests } namespace delete ::tcl::test::fileSystem |