filesystem bug fix and new test

4 files changed, 220 insertions, 5 deletions

diff --git a/ChangeLog b/ChangeLog
index 688005f..58f3e27 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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