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

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

1 files changed, 76 insertions, 29 deletions

diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index f276939..2c142ae 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.33 2003/05/12 22:51:46 dkf Exp $
+# RCS: @(#) $Id: cmdAH.test,v 1.34 2003/07/04 13:04:12 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2.1
@@ -22,7 +22,7 @@ tcltest::testConstraint testchmod \
 tcltest::testConstraint testsetplatform \
 	[string equal testsetplatform [info commands testsetplatform]]
 tcltest::testConstraint testvolumetype \
-	[string equal testvolumetype [info commands testvoluemtype]]
+	[string equal testvolumetype [info commands testvolumetype]]
 tcltest::testConstraint linkDirectory [expr \
 	{$tcl_platform(platform) ne "windows" || \
 	([string index $tcl_platform(osVersion) 0] >= 5 \
@@ -195,7 +195,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]
@@ -203,13 +203,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}
@@ -1082,8 +1082,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
@@ -1091,13 +1091,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]
@@ -1106,7 +1106,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
 
@@ -1211,7 +1211,7 @@ test cmdAH-20.5 {Tcl_FileObjCmd: atime touch} {unixOnly} {
     set modatime [file atime $file $newatime]
     expr {$newatime == $modatime ? 1 : "$newatime != $modatime"}
 } 1
-test cmdAH-20.6 {Tcl_FileObjCmd: atime touch} {pcOnly testvolumetype} {
+test cmdAH-20.6 {Tcl_FileObjCmd: atime touch} {winOnly testvolumetype} {
     set old [pwd]
     cd $::tcltest::temporaryDirectory
     if {![string equal "NTFS" [testvolumetype]]} {
@@ -1315,8 +1315,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} {
@@ -1330,20 +1349,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} {
@@ -1366,7 +1387,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
@@ -1378,14 +1399,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
@@ -1401,7 +1422,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
 
@@ -1431,7 +1478,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}}}
@@ -1500,14 +1547,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
@@ -1516,15 +1563,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]