* tests/cmdAH.test: Made tests of [file mtime] work better on FAT

	filesystems. [Patch 760768]  Also a little general cleanup.

2 files changed, 79 insertions, 27 deletions

diff --git a/ChangeLog b/ChangeLog
index de52562..b1bb5bb 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2003-07-04  Donal K. Fellows  <fellowsd@cs.man.ac.uk>
+
+	* tests/cmdAH.test: Made tests of [file mtime] work better on FAT
+	filesystems. [Patch 760768]  Also a little general cleanup.
+
 2003-06-25  Mo DeJong  <mdejong@users.sourceforge.net>
 
 	* unix/configure: Regen.
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index 9d7dca1..51ecf99 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.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: cmdAH.test,v 1.30.2.2 2003/04/14 15:45:51 vincentdarley Exp $
+# RCS: @(#) $Id: cmdAH.test,v 1.30.2.3 2003/07/04 13:16:13 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2.1
@@ -183,7 +183,7 @@ test cmdAH-5.4 {Tcl_FileObjCmd} {
 #volume
 
 test cmdAH-6.1 {Tcl_FileObjCmd: volumes} {
-    list [catch {file volumes x} msg] $msg	
+    list [catch {file volumes x} msg] $msg
 } {1 {wrong # args: should be "file volumes"}}
 test cmdAH-6.2 {Tcl_FileObjCmd: volumes} {
 	set volumeList [file volumes]
@@ -191,13 +191,13 @@ test cmdAH-6.2 {Tcl_FileObjCmd: volumes} {
 		set result 0
 	} else {
 		set result 1
-	}	
+	}
 } {1}
 test cmdAH-6.3 {Tcl_FileObjCmd: volumes} {macOrUnix} {
     set volumeList [file volumes]
     catch [list glob -nocomplain [lindex $volumeList 0]*]
 } {0}
-test cmdAH-6.4 {Tcl_FileObjCmd: volumes} {pcOnly} {
+test cmdAH-6.4 {Tcl_FileObjCmd: volumes} winOnly {
     set volumeList [string tolower [file volumes]]
     list [catch {lsearch $volumeList "c:/"} element] [expr $element != -1] [catch {list glob -nocomplain [lindex $volumeList $element]*}]
 } {0 1 0}
@@ -1069,8 +1069,8 @@ test cmdAH-18.2 {Tcl_FileObjCmd: executable} {testchmod} {
 } 0
 test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unixOnly testchmod} {
     # Only on unix will setting the execute bit on a regular file
-    # cause that file to be executable.   
-    
+    # cause that file to be executable.
+
     testchmod 0775 $gorpfile
     file exe $gorpfile
 } 1
@@ -1078,13 +1078,13 @@ test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unixOnly testchmod} {
 test cmdAH-18.4 {Tcl_FileObjCmd: executable} {macOnly testchmod} {
     # On mac, the only executable files are of type APPL.
 
-    set x [file exe $gorpfile]    
+    set x [file exe $gorpfile]
     file attrib $gorpfile -type APPL
     lappend x [file exe $gorpfile]
 } {0 1}
-test cmdAH-18.5 {Tcl_FileObjCmd: executable} {pcOnly testchmod} {
+test cmdAH-18.5 {Tcl_FileObjCmd: executable} {winOnly testchmod} {
     # On pc, must be a .exe, .com, etc.
-    
+
     set x [file exe $gorpfile]
     set gorpexe [makeFile foo gorp.exe]
     lappend x [file exe $gorpexe]
@@ -1093,7 +1093,7 @@ test cmdAH-18.5 {Tcl_FileObjCmd: executable} {pcOnly testchmod} {
 } {0 1}
 test cmdAH-18.6 {Tcl_FileObjCmd: executable} {testchmod} {
     # Directories are always executable.
-    
+
     file exe $dirfile
 } 1
 
@@ -1302,8 +1302,27 @@ test cmdAH-23.10 {Tcl_FileObjCmd: mkdir} {
     set res
 } {1 1}
 
-# mtime 
-
+# mtime
+
+proc waitForEvenSecondForFAT {} {
+    # Windows 9x uses filesystems (the FAT* family of FSes) without
+    # enough data in its timestamps for even per-second-accurate
+    # timings.  :^(
+    # This procedure based on work by Helmut Giese
+
+    global tcl_platform
+    if {$tcl_platform(platform) ne "windows"} {return}
+    if {[lindex [file system [temporaryDirectory]] 1] == "NTFS"} {return}
+    # Assume non-NTFS means FAT{12,16,32} and hence in need of special help
+    set start [clock seconds]
+    while {1} {
+	set now [clock seconds]
+	if {$now!=$start && !($now & 1)} {
+	    return
+	}
+	after 50
+    }
+}
 set file [makeFile "data" touch.me]
 
 test cmdAH-24.1 {Tcl_FileObjCmd: mtime} {
@@ -1317,20 +1336,22 @@ test cmdAH-24.1 {Tcl_FileObjCmd: mtime} {
 # completely horrible "keep on trying to write until you managed to do
 # it all in less than a second."  - DKF
 test cmdAH-24.2 {Tcl_FileObjCmd: mtime} {
+    waitForEvenSecondForFAT
     set f [open $gorpfile w]
     puts $f "More text"
-    set localOld [clock seconds]
     close $f
-    set old [file mtime $gorpfile]
+    set clockOld [clock seconds]
+    set fileOld [file mtime $gorpfile]
     after 2000
     set f [open $gorpfile w]
     puts $f "More text"
-    set localNew [clock seconds]
     close $f
-    set new [file mtime $gorpfile]
+    set clockNew [clock seconds]
+    set fileNew [file mtime $gorpfile]
     expr {
-	($new > $old) && ($localNew > $localOld) &&
-	(abs(($new-$old) - ($localNew-$localOld)) <= 1)
+	(($fileNew > $fileOld) && ($clockNew > $clockOld) &&
+	(abs(($fileNew-$fileOld) - ($clockNew-$clockOld)) <= 1)) ? "1" :
+	"file:($fileOld=>$fileNew) clock:($clockOld=>$clockNew)"
     }
 } {1}
 test cmdAH-24.3 {Tcl_FileObjCmd: mtime} {
@@ -1353,7 +1374,7 @@ test cmdAH-24.5 {Tcl_FileObjCmd: mtime} {
 	set name [file join [temporaryDirectory] tf]
     }
 
-    # Make sure that a new file's time is correct.  10 seconds variance 
+    # Make sure that a new file's time is correct.  10 seconds variance
     # is allowed used due to slow networks or clock skew on a network drive.
 
     file delete -force $name
@@ -1365,14 +1386,14 @@ test cmdAH-24.5 {Tcl_FileObjCmd: mtime} {
 test cmdAH-24.7 {Tcl_FileObjCmd: mtime} {
     list [catch {file mtime $file notint} msg] $msg
 } {1 {expected integer but got "notint"}}
-test cmdAH-24.8 {Tcl_FileObjCmd: mtime touch} {
+test cmdAH-24.8 {Tcl_FileObjCmd: mtime touch} macOrUnix {
     set mtime [file mtime $file]
     after 1100; # pause a sec to notice change in mtime
     set newmtime [clock seconds]
     set modmtime [file mtime $file $newmtime]
     expr {$newmtime == $modmtime ? 1 : "$newmtime != $modmtime"}
 } 1
-test cmdAH-24.9 {Tcl_FileObjCmd: mtime touch with non-ascii chars} {
+test cmdAH-24.9 {Tcl_FileObjCmd: mtime touch with non-ascii chars} macOrUnix {
     set oldfile $file
     # introduce some non-ascii characters.
     append file \u2022
@@ -1388,7 +1409,33 @@ test cmdAH-24.9 {Tcl_FileObjCmd: mtime touch with non-ascii chars} {
     }
     expr {$newmtime == $modmtime ? 1 : "$newmtime != $modmtime"}
 } 1
+test cmdAH-24.10 {Tcl_FileObjCmd: mtime touch} winOnly {
+    waitForEvenSecondForFAT
+    set mtime [file mtime $file]
+    after 2100; # pause two secs to notice change in mtime on FAT fs'es
+    set newmtime [clock seconds]
+    set modmtime [file mtime $file $newmtime]
+    expr {$newmtime == $modmtime ? 1 : "$newmtime != $modmtime"}
+} 1
+test cmdAH-24.11 {Tcl_FileObjCmd: mtime touch with non-ascii chars} winOnly {
+    waitForEvenSecondForFAT
+    set oldfile $file
+    # introduce some non-ascii characters.
+    append file \u2022
+    file delete -force $file
+    file rename $oldfile $file
+    set mtime [file mtime $file]
+    after 2100; # pause two secs to notice change in mtime on FAT fs'es
+    set newmtime [clock seconds]
+    set err [catch {file mtime $file $newmtime} modmtime]
+    file rename $file $oldfile
+    if {$err} {
+	error $modmtime
+    }
+    expr {$newmtime == $modmtime ? 1 : "$newmtime != $modmtime"}
+} 1
 removeFile touch.me
+rename waitForEvenSecondForFAT {}
 
 # owned
 
@@ -1418,7 +1465,7 @@ test cmdAH-26.4 {Tcl_FileObjCmd: readlink errors} {macOnly nonPortable} {
     list [catch {file readlink _bogus_} msg] [string tolower $msg] \
 	    [string tolower $errorCode]
 } {1 {could not readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
-test cmdAH-26.5 {Tcl_FileObjCmd: readlink errors} {pcOnly nonPortable} {
+test cmdAH-26.5 {Tcl_FileObjCmd: readlink errors} {winOnly nonPortable} {
     list [catch {file readlink _bogus_} msg] [string tolower $msg] \
 	    [string tolower $errorCode]
 } {1 {could not readlink "_bogus_": invalid argument} {posix einval {invalid argument}}}
@@ -1487,14 +1534,14 @@ test cmdAH-28.8 {Tcl_FileObjCmd: stat} {
     removeFile $filename
     set x
 } 1
-test cmdAH-28.9 {Tcl_FileObjCmd: stat} {pcOnly} {
+test cmdAH-28.9 {Tcl_FileObjCmd: stat} winOnly {
     # stat of root directory was failing.
     # don't care about answer, just that test runs.
 
     # relative paths that resolve to root
     set old [pwd]
     cd c:/
-    file stat c: stat	    
+    file stat c: stat
     file stat c:. stat
     file stat . stat
     cd $old
@@ -1503,15 +1550,15 @@ test cmdAH-28.9 {Tcl_FileObjCmd: stat} {pcOnly} {
     file stat c:/ stat
     file stat c:/. stat
 } {}
-test cmdAH-28.10 {Tcl_FileObjCmd: stat} {pcOnly nonPortable} {
+test cmdAH-28.10 {Tcl_FileObjCmd: stat} {winOnly nonPortable} {
     # stat of root directory was failing.
     # don't care about answer, just that test runs.
 
     file stat //pop/$env(USERNAME) stat
     file stat //pop/$env(USERNAME)/ stat
     file stat //pop/$env(USERNAME)/. stat
-} {}    
-test cmdAH-28.11 {Tcl_FileObjCmd: stat} {pcOnly nonPortable} {
+} {}
+test cmdAH-28.11 {Tcl_FileObjCmd: stat} {winOnly nonPortable} {
     # stat of network directory was returning id of current local drive.
 
     set old [pwd]