summaryrefslogtreecommitdiffstats
path: root/tests/fileSystem.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/fileSystem.test')
-rw-r--r--tests/fileSystem.test804
1 files changed, 642 insertions, 162 deletions
diff --git a/tests/fileSystem.test b/tests/fileSystem.test
index f42e776..2acdbd2 100644
--- a/tests/fileSystem.test
+++ b/tests/fileSystem.test
@@ -11,106 +11,135 @@
package require tcltest 2
namespace eval ::tcl::test::fileSystem {
+ namespace import ::tcltest::*
catch {
- namespace import ::tcltest::cleanupTests
- namespace import ::tcltest::makeDirectory
- namespace import ::tcltest::makeFile
- namespace import ::tcltest::removeDirectory
- namespace import ::tcltest::removeFile
- namespace import ::tcltest::test
- }
-
- catch {
file delete -force link.file
file delete -force dir.link
- file delete -force [file join dir.file linkinside.file]
+ file delete -force [file join dir.dir linkinside.file]
}
+# Test for commands defined in Tcltest executable
+testConstraint testfilesystem [llength [info commands ::testfilesystem]]
+testConstraint testsetplatform [llength [info commands ::testsetplatform]]
+testConstraint testsimplefilesystem [llength [info commands ::testsimplefilesystem]]
+
cd [tcltest::temporaryDirectory]
makeFile "test file" gorp.file
-makeDirectory dir.file
-makeFile "test file in directory" [file join dir.file inside.file]
+makeDirectory dir.dir
+makeDirectory [file join dir.dir dirinside.dir]
+makeFile "test file in directory" [file join dir.dir inside.file]
+
+testConstraint unusedDrive 0
+set drive {}
+if {[testConstraint win]} {
+ set vols [string map [list :/ {}] [file volumes]]
+ for {set i 0} {$i < 26} {incr i} {
+ set drive [format %c [expr {$i + 65}]]
+ if {[lsearch -exact $vols $drive] == -1} {
+ testConstraint unusedDrive 1
+ break
+ }
+ }
+ unset i vols
+ # The variable 'drive' will be used below
+}
-if {[catch {
- file link link.file gorp.file
- file link \
- [file join dir.file linkinside.file] \
- [file join dir.file inside.file]
- file link dir.link dir.file
-}]} {
- tcltest::testConstraint hasLinks 0
-} else {
- tcltest::testConstraint hasLinks 1
+testConstraint moreThanOneDrive 0
+set drives [list]
+if {[testConstraint win]} {
+ set dir [pwd]
+ foreach vol [file volumes] {
+ if {![catch {cd $vol}]} {
+ lappend drives $vol
+ }
+ }
+ if {[llength $drives] > 1} {
+ testConstraint moreThanOneDrive 1
+ }
+ # The variable 'drives' will be used below
+ unset vol
+ cd $dir
+ unset dir
}
-tcltest::testConstraint testsimplefilesystem \
- [string equal testsimplefilesystem [info commands testsimplefilesystem]]
+proc testPathEqual {one two} {
+ if {$one eq $two} {
+ return 1
+ } else {
+ return "not equal: $one $two"
+ }
+}
+
+testConstraint hasLinks [expr {![catch {
+ file link link.file gorp.file
+ cd dir.dir
+ file link \
+ [file join linkinside.file] \
+ [file join inside.file]
+ cd ..
+ file link dir.link dir.dir
+ cd dir.dir
+ file link [file join dirinside.link] \
+ [file join dirinside.dir]
+ cd ..
+}]}]
+
+if {[testConstraint testsetplatform]} {
+ set platform [testgetplatform]
+}
test filesystem-1.0 {link normalisation} {hasLinks} {
string equal [file normalize gorp.file] [file normalize link.file]
} {0}
-
test filesystem-1.1 {link normalisation} {hasLinks} {
- string equal [file normalize dir.file] [file normalize dir.link]
+ string equal [file normalize dir.dir] [file normalize dir.link]
} {0}
-
-test filesystem-1.2 {link normalisation} {hasLinks macOrUnix} {
- string equal [file normalize [file join gorp.file foo]] \
- [file normalize [file join link.file foo]]
+test filesystem-1.2 {link normalisation} {hasLinks unix} {
+ testPathEqual [file normalize [file join gorp.file foo]] \
+ [file normalize [file join link.file foo]]
} {1}
-
test filesystem-1.3 {link normalisation} {hasLinks} {
- string equal [file normalize [file join dir.file foo]] \
- [file normalize [file join dir.link foo]]
+ testPathEqual [file normalize [file join dir.dir foo]] \
+ [file normalize [file join dir.link foo]]
} {1}
-
test filesystem-1.4 {link normalisation} {hasLinks} {
- string equal [file normalize [file join dir.file inside.file]] \
- [file normalize [file join dir.link inside.file]]
+ testPathEqual [file normalize [file join dir.dir inside.file]] \
+ [file normalize [file join dir.link inside.file]]
} {1}
-
test filesystem-1.5 {link normalisation} {hasLinks} {
- string equal [file normalize [file join dir.file linkinside.file]] \
- [file normalize [file join dir.file linkinside.file]]
+ testPathEqual [file normalize [file join dir.dir linkinside.file]] \
+ [file normalize [file join dir.dir linkinside.file]]
} {1}
-
test filesystem-1.6 {link normalisation} {hasLinks} {
- string equal [file normalize [file join dir.file linkinside.file]] \
+ string equal [file normalize [file join dir.dir linkinside.file]] \
[file normalize [file join dir.link inside.file]]
} {0}
-
-test filesystem-1.7 {link normalisation} {hasLinks macOrUnix} {
- string equal [file normalize [file join dir.link linkinside.file foo]] \
- [file normalize [file join dir.file inside.file foo]]
+test filesystem-1.7 {link normalisation} {hasLinks unix} {
+ testPathEqual [file normalize [file join dir.link linkinside.file foo]] \
+ [file normalize [file join dir.dir inside.file foo]]
} {1}
-
test filesystem-1.8 {link normalisation} {hasLinks} {
- string equal [file normalize [file join dir.file linkinside.filefoo]] \
- [file normalize [file join dir.link inside.filefoo]]
+ string equal [file normalize [file join dir.dir linkinside.filefoo]] \
+ [file normalize [file join dir.link inside.filefoo]]
} {0}
-
-test filesystem-1.9 {link normalisation} {macOrUnix hasLinks} {
+test filesystem-1.9 {link normalisation} {unix hasLinks} {
file delete -force dir.link
- file link dir.link [file nativename dir.file]
- string equal [file normalize [file join dir.file linkinside.file foo]] \
- [file normalize [file join dir.link inside.file foo]]
+ file link dir.link [file nativename dir.dir]
+ testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \
+ [file normalize [file join dir.link inside.file foo]]
} {1}
-
-test filesystem-1.10 {link normalisation: double link} {macOrUnix hasLinks} {
+test filesystem-1.10 {link normalisation: double link} {unix hasLinks} {
file link dir2.link dir.link
- string equal [file normalize [file join dir.file linkinside.file foo]] \
- [file normalize [file join dir2.link inside.file foo]]
+ testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \
+ [file normalize [file join dir2.link inside.file foo]]
} {1}
-
makeDirectory dir2.file
-
-test filesystem-1.11 {link normalisation: double link, back in tree} {macOrUnix hasLinks} {
- file link [file join dir2.file dir2.link] dir2.link
- string equal [file normalize [file join dir.file linkinside.file foo]] \
- [file normalize [file join dir2.file dir2.link inside.file foo]]
+test filesystem-1.11 {link normalisation: double link, back in tree} {unix hasLinks} {
+ file link [file join dir2.file dir2.link] [file join .. dir2.link]
+ testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \
+ [file normalize [file join dir2.file dir2.link inside.file foo]]
} {1}
-
test filesystem-1.12 {file new native path} {} {
for {set i 0} {$i < 10} {incr i} {
foreach f [lsort [glob -nocomplain -type l *]] {
@@ -120,24 +149,352 @@ test filesystem-1.12 {file new native path} {} {
# If we reach here we've succeeded. We used to crash above.
expr 1
} {1}
-
-test filesystem-1.13 {file normalisation} {winOnly} {
+test filesystem-1.13 {file normalisation} {win} {
# This used to be broken
file normalize C:/thislongnamedoesntexist
} {C:/thislongnamedoesntexist}
-
-test filesystem-1.14 {file normalisation} {winOnly} {
+test filesystem-1.14 {file normalisation} {win} {
# This used to be broken
file normalize c:/
} {C:/}
-
+test filesystem-1.15 {file normalisation} {win} {
+ file normalize c:/../
+} {C:/}
+test filesystem-1.16 {file normalisation} {win} {
+ file normalize c:/.
+} {C:/}
+test filesystem-1.17 {file normalisation} {win} {
+ file normalize c:/..
+} {C:/}
+test filesystem-1.17.1 {file normalisation} {win} {
+ file normalize c:\\..
+} {C:/}
+test filesystem-1.18 {file normalisation} {win} {
+ file normalize c:/./
+} {C:/}
+test filesystem-1.19 {file normalisation} {win unusedDrive} {
+ file normalize ${drive}:/./../../..
+} "${drive}:/"
+test filesystem-1.20 {file normalisation} {win} {
+ file normalize //name/foo/../
+} {//name/foo}
+test filesystem-1.21 {file normalisation} {win} {
+ file normalize C:///foo/./
+} {C:/foo}
+test filesystem-1.22 {file normalisation} {win} {
+ file normalize //name/foo/.
+} {//name/foo}
+test filesystem-1.23 {file normalisation} {win} {
+ file normalize c:/./foo
+} {C:/foo}
+test filesystem-1.24 {file normalisation} {win unusedDrive} {
+ file normalize ${drive}:/./../../../a
+} "${drive}:/a"
+test filesystem-1.25 {file normalisation} {win unusedDrive} {
+ file normalize ${drive}:/./.././../../a
+} "${drive}:/a"
+test filesystem-1.25.1 {file normalisation} {win unusedDrive} {
+ file normalize ${drive}:/./.././..\\..\\a\\bb
+} "${drive}:/a/bb"
+test filesystem-1.26 {link normalisation: link and ..} {hasLinks} {
+ file delete -force dir2.link
+ set dir [file join dir2 foo bar]
+ file mkdir $dir
+ file link dir2.link [file join dir2 foo bar]
+ set res [list [file normalize [file join dir2 foo x]] \
+ [file normalize [file join dir2.link .. x]]]
+ if {![string equal [lindex $res 0] [lindex $res 1]]} {
+ set res "$res not equal"
+ } else {
+ set res "ok"
+ }
+} {ok}
+test filesystem-1.27 {file normalisation: up and down with ..} {
+ set dir [file join dir2 foo bar]
+ file mkdir $dir
+ set dir2 [file join dir2 .. dir2 foo .. foo bar]
+ set res [list [file normalize $dir] [file normalize $dir2]]
+ set res2 [list [file exists $dir] [file exists $dir2]]
+ if {![string equal [lindex $res 0] [lindex $res 1]]} {
+ set res "exists: $res2, $res not equal"
+ } else {
+ set res "ok: $res2"
+ }
+} {ok: 1 1}
+test filesystem-1.28 {link normalisation: link with .. and ..} {hasLinks} {
+ file delete -force dir2.link
+ set dir [file join dir2 foo bar]
+ file mkdir $dir
+ set to [file join dir2 .. dir2 foo .. foo bar]
+ file link dir2.link $to
+ set res [list [file normalize [file join dir2 foo x]] \
+ [file normalize [file join dir2.link .. x]]]
+ if {![string equal [lindex $res 0] [lindex $res 1]]} {
+ set res "$res not equal"
+ } else {
+ set res "ok"
+ }
+} {ok}
+test filesystem-1.29 {link normalisation: link with ..} {hasLinks} {
+ file delete -force dir2.link
+ set dir [file join dir2 foo bar]
+ file mkdir $dir
+ set to [file join dir2 .. dir2 foo .. foo bar]
+ file link dir2.link $to
+ set res [file normalize [file join dir2.link x yyy z]]
+ if {[string first ".." $res] != -1} {
+ set res "$res must not contain '..'"
+ } else {
+ set res "ok"
+ }
+} {ok}
+test filesystem-1.29.1 {link normalisation with two consecutive links} {hasLinks} {
+ testPathEqual [file normalize [file join dir.link dirinside.link abc]] \
+ [file normalize [file join dir.dir dirinside.dir abc]]
+} {1}
file delete -force dir2.file
file delete -force dir2.link
file delete -force link.file dir.link
-removeFile [file join dir.file inside.file]
-removeDirectory dir.file
+file delete -force dir2
+file delete -force [file join dir.dir dirinside.link]
+removeFile [file join dir.dir inside.file]
+removeDirectory [file join dir.dir dirinside.dir]
+removeDirectory dir.dir
+test filesystem-1.30 {normalisation of nonexistent user} {
+ list [catch {file normalize ~noonewiththisname} err] $err
+} {1 {user "noonewiththisname" doesn't exist}}
+test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} {
+ testsetplatform unix
+ file normalize /foo/../bar
+} {/bar}
+test filesystem-1.32 {link normalisation: link near filesystem root} {testsetplatform} {
+ testsetplatform unix
+ file normalize /../bar
+} {/bar}
+test filesystem-1.33 {link normalisation: link near filesystem root} {testsetplatform} {
+ testsetplatform windows
+ set res [file normalize C:/../bar]
+ if {[testConstraint unix]} {
+ # Some unices go further in normalizing this -- not really
+ # a problem since this is a Windows test
+ regexp {C:/bar$} $res res
+ }
+ set res
+} {C:/bar}
+if {[testConstraint testsetplatform]} {
+ testsetplatform $platform
+}
+test filesystem-1.34 {file normalisation with '/./'} {
+ set res [file normalize /foo/bar/anc/./.tml]
+ if {[string first "/./" $res] != -1} {
+ set res "normalization of /foo/bar/anc/./.tml is: $res"
+ } else {
+ set res "ok"
+ }
+ set res
+} {ok}
+test filesystem-1.35 {file normalisation with '/./'} {
+ set res [file normalize /ffo/bar/anc/./foo/.tml]
+ if {[string first "/./" $res] != -1 || ([regsub -all "foo" $res "" reg] == 2)} {
+ set res "normalization of /ffo/bar/anc/./foo/.tml is: $res"
+ } else {
+ set res "ok"
+ }
+ set res
+} {ok}
+test filesystem-1.36 {file normalisation with '/./'} {
+ set res [file normalize /foo/bar/anc/././asdasd/.tml]
+ if {[string first "/./" $res] != -1 || ([regsub -all "asdasd" $res "" reg] == 2) } {
+ set res "normalization of /foo/bar/anc/././asdasd/.tml is: $res"
+ } else {
+ set res "ok"
+ }
+ set res
+} {ok}
+test filesystem-1.37 {file normalisation with '/./'} {
+ set fname "/abc/./def/./ghi/./asda/.././.././asd/x/../../../../....."
+ set res [file norm $fname]
+ if {[string first "//" $res] != -1} {
+ set res "normalization of $fname is: $res"
+ } else {
+ set res "ok"
+ }
+ set res
+} {ok}
+test filesystem-1.38 {file normalisation with volume relative} \
+ {win moreThanOneDrive} {
+ set path "[string range [lindex $drives 0] 0 1]foo"
+ set dir [pwd]
+ cd [lindex $drives 1]
+ set res [file norm $path]
+ cd $dir
+ set res
+} "[lindex $drives 0]foo"
+test filesystem-1.39 {file normalisation with volume relative} {win} {
+ set drv C:/
+ set dir [lindex [glob -type d -dir $drv *] 0]
+ set old [pwd]
+ cd $dir
+ set res [file norm [string range $drv 0 1]]
+ cd $old
+ if {[string index $res end] eq "/"} {
+ set res "Bad normalized path: $res"
+ } else {
+ set res "ok"
+ }
+} {ok}
+test filesystem-1.40 {file normalisation with repeated separators} {
+ set a [file norm foo////bar]
+ set b [file norm foo/bar]
+
+ if {![string equal $a $b]} {
+ set res "Paths should be equal: $a , $b"
+ } else {
+ set res "ok"
+ }
+} {ok}
+test filesystem-1.41 {file normalisation with repeated separators} {win} {
+ set a [file norm foo\\\\\\bar]
+ set b [file norm foo/bar]
+
+ if {![string equal $a $b]} {
+ set res "Paths should be equal: $a , $b"
+ } else {
+ set res "ok"
+ }
+} {ok}
+test filesystem-1.42 {file normalisation .. beyond root (Bug 1379287)} {
+ set a [file norm /xxx/..]
+ set b [file norm /]
+
+ if {![string equal $a $b]} {
+ set res "Paths should be equal: $a , $b"
+ } else {
+ set res "ok"
+ }
+} {ok}
+test filesystem-1.42.1 {file normalisation .. beyond root (Bug 1379287)} {
+ set a [file norm /xxx/../]
+ set b [file norm /]
+
+ if {![string equal $a $b]} {
+ set res "Paths should be equal: $a , $b"
+ } else {
+ set res "ok"
+ }
+} {ok}
+test filesystem-1.43 {file normalisation .. beyond root (Bug 1379287)} {
+ set a [file norm /xxx/foo/../..]
+ set b [file norm /]
+
+ if {![string equal $a $b]} {
+ set res "Paths should be equal: $a , $b"
+ } else {
+ set res "ok"
+ }
+} {ok}
+test filesystem-1.43.1 {file normalisation .. beyond root (Bug 1379287)} {
+ set a [file norm /xxx/foo/../../]
+ set b [file norm /]
+
+ if {![string equal $a $b]} {
+ set res "Paths should be equal: $a , $b"
+ } else {
+ set res "ok"
+ }
+} {ok}
+test filesystem-1.44 {file normalisation .. beyond root (Bug 1379287)} {
+ set a [file norm /xxx/foo/../../bar]
+ set b [file norm /bar]
+
+ if {![string equal $a $b]} {
+ set res "Paths should be equal: $a , $b"
+ } else {
+ set res "ok"
+ }
+} {ok}
+test filesystem-1.45 {file normalisation .. beyond root (Bug 1379287)} {
+ set a [file norm /xxx/../../bar]
+ set b [file norm /bar]
+
+ if {![string equal $a $b]} {
+ set res "Paths should be equal: $a , $b"
+ } else {
+ set res "ok"
+ }
+} {ok}
+test filesystem-1.46 {file normalisation .. beyond root (Bug 1379287)} {
+ set a [file norm /xxx/../bar]
+ set b [file norm /bar]
+
+ if {![string equal $a $b]} {
+ set res "Paths should be equal: $a , $b"
+ } else {
+ set res "ok"
+ }
+} {ok}
+test filesystem-1.47 {file normalisation .. beyond root (Bug 1379287)} {
+ set a [file norm /..]
+ set b [file norm /]
+
+ if {![string equal $a $b]} {
+ set res "Paths should be equal: $a , $b"
+ } else {
+ set res "ok"
+ }
+} {ok}
+test filesystem-1.48 {file normalisation .. beyond root (Bug 1379287)} {
+ set a [file norm /../]
+ set b [file norm /]
+
+ if {![string equal $a $b]} {
+ set res "Paths should be equal: $a , $b"
+ } else {
+ set res "ok"
+ }
+} {ok}
+test filesystem-1.49 {file normalisation .. beyond root (Bug 1379287)} {
+ set a [file norm /.]
+ set b [file norm /]
+
+ if {![string equal $a $b]} {
+ set res "Paths should be equal: $a , $b"
+ } else {
+ set res "ok"
+ }
+} {ok}
+test filesystem-1.50 {file normalisation .. beyond root (Bug 1379287)} {
+ set a [file norm /./]
+ set b [file norm /]
+
+ if {![string equal $a $b]} {
+ set res "Paths should be equal: $a , $b"
+ } else {
+ set res "ok"
+ }
+} {ok}
+test filesystem-1.51 {file normalisation .. beyond root (Bug 1379287)} {
+ set a [file norm /../..]
+ set b [file norm /]
+
+ if {![string equal $a $b]} {
+ set res "Paths should be equal: $a , $b"
+ } else {
+ set res "ok"
+ }
+} {ok}
+test filesystem-1.51.1 {file normalisation .. beyond root (Bug 1379287)} {
+ set a [file norm /../../]
+ set b [file norm /]
+
+ if {![string equal $a $b]} {
+ set res "Paths should be equal: $a , $b"
+ } else {
+ set res "ok"
+ }
+} {ok}
-test filesystem-2.0 {new native path} {unixOnly} {
+test filesystem-2.0 {new native path} {unix} {
foreach f [lsort [glob -nocomplain /usr/bin/c*]] {
catch {file readlink $f}
}
@@ -145,52 +502,37 @@ test filesystem-2.0 {new native path} {unixOnly} {
expr 1
} {1}
-if {[catch {package require tcltest 2}]} {
- puts stderr "Skipping tests filesystem-{3,4}.*: tcltest 2 required."
-} else {
- namespace import ::tcltest::testConstraint
-
- # Is the Tcltest package loaded?
- # - that is, the special C-coded testing commands in tclTest.c
- # - tests use testing commands introduced in Tcltest 8.4
- testConstraint Tcltest [expr {
- [llength [package provide Tcltest]]
- && [package vsatisfies [package provide Tcltest] 8.4]}]
-
# Make sure the testfilesystem hasn't been registered.
-while {![catch {testfilesystem 0}]} {}
+if {[testConstraint testfilesystem]} {
+ while {![catch {testfilesystem 0}]} {}
+}
-test filesystem-3.0 {Tcl_FSRegister} Tcltest {
+test filesystem-3.0 {Tcl_FSRegister} testfilesystem {
testfilesystem 1
} {registered}
-
-test filesystem-3.1 {Tcl_FSUnregister} Tcltest {
+test filesystem-3.1 {Tcl_FSUnregister} testfilesystem {
testfilesystem 0
} {unregistered}
-
-test filesystem-3.2 {Tcl_FSUnregister} Tcltest {
+test filesystem-3.2 {Tcl_FSUnregister} testfilesystem {
list [catch {testfilesystem 0} err] $err
} {1 failed}
-
-test filesystem-3.3 {Tcl_FSRegister} Tcltest {
+test filesystem-3.3 {Tcl_FSRegister} testfilesystem {
testfilesystem 1
testfilesystem 1
testfilesystem 0
testfilesystem 0
} {unregistered}
-
-test filesystem-3.4 {Tcl_FSRegister} Tcltest {
+test filesystem-3.4 {Tcl_FSRegister} testfilesystem {
testfilesystem 1
file system bar
} {reporting}
-
-test filesystem-3.5 {Tcl_FSUnregister} Tcltest {
+test filesystem-3.5 {Tcl_FSUnregister} testfilesystem {
testfilesystem 0
lindex [file system bar] 0
} {native}
test filesystem-4.0 {testfilesystem} {
- -constraints Tcltest
+ -constraints testfilesystem
-match glob
-body {
testfilesystem 1
@@ -199,11 +541,10 @@ test filesystem-4.0 {testfilesystem} {
testfilesystem 0
set filesystemReport
}
- -result {* {access foo}}
+ -result {*{access foo}}
}
-
test filesystem-4.1 {testfilesystem} {
- -constraints Tcltest
+ -constraints testfilesystem
-match glob
-body {
testfilesystem 1
@@ -212,11 +553,10 @@ test filesystem-4.1 {testfilesystem} {
testfilesystem 0
set filesystemReport
}
- -result {* {stat foo}}
+ -result {*{stat foo}}
}
-
test filesystem-4.2 {testfilesystem} {
- -constraints Tcltest
+ -constraints testfilesystem
-match glob
-body {
testfilesystem 1
@@ -225,11 +565,10 @@ test filesystem-4.2 {testfilesystem} {
testfilesystem 0
set filesystemReport
}
- -result {* {lstat foo}}
+ -result {*{lstat foo}}
}
-
test filesystem-4.3 {testfilesystem} {
- -constraints Tcltest
+ -constraints testfilesystem
-match glob
-body {
testfilesystem 1
@@ -238,14 +577,14 @@ test filesystem-4.3 {testfilesystem} {
testfilesystem 0
set filesystemReport
}
- -result {* {matchindirectory *}*}
+ -result {*{matchindirectory *}*}
}
test filesystem-5.1 {cache and ~} {
- -constraints Tcltest
+ -constraints testfilesystem
-match regexp
-body {
- set orig $env(HOME)
+ set orig $::env(HOME)
set ::env(HOME) /foo/bar/blah
set testdir ~
set res1 "Parent of ~ (/foo/bar/blah) is [file dirname $testdir]"
@@ -254,143 +593,112 @@ test filesystem-5.1 {cache and ~} {
set ::env(HOME) $orig
list $res1 $res2
}
- -result {{Parent of ~ \(/foo/bar/blah\) is (/foo/bar|foo:bar)} {Parent of ~ \(/a/b/c\) is (/a/b|a:b)}}
+ -result {{Parent of ~ \(/foo/bar/blah\) is ([a-zA-Z]:)?(/foo/bar|foo:bar)} {Parent of ~ \(/a/b/c\) is ([a-zA-Z]:)?(/a/b|a:b)}}
}
test filesystem-6.1 {empty file name} {
list [catch {open ""} msg] $msg
} {1 {couldn't open "": no such file or directory}}
-
test filesystem-6.2 {empty file name} {
list [catch {file stat "" arr} msg] $msg
} {1 {could not read "": no such file or directory}}
-
test filesystem-6.3 {empty file name} {
list [catch {file atime ""} msg] $msg
} {1 {could not read "": no such file or directory}}
-
test filesystem-6.4 {empty file name} {
list [catch {file attributes ""} msg] $msg
} {1 {could not read "": no such file or directory}}
-
test filesystem-6.5 {empty file name} {
list [catch {file copy "" ""} msg] $msg
} {1 {error copying "": no such file or directory}}
-
test filesystem-6.6 {empty file name} {
list [catch {file delete ""} msg] $msg
} {0 {}}
-
test filesystem-6.7 {empty file name} {
list [catch {file dirname ""} msg] $msg
} {0 .}
-
test filesystem-6.8 {empty file name} {
list [catch {file executable ""} msg] $msg
} {0 0}
-
test filesystem-6.9 {empty file name} {
list [catch {file exists ""} msg] $msg
} {0 0}
-
test filesystem-6.10 {empty file name} {
list [catch {file extension ""} msg] $msg
} {0 {}}
-
test filesystem-6.11 {empty file name} {
list [catch {file isdirectory ""} msg] $msg
} {0 0}
-
test filesystem-6.12 {empty file name} {
list [catch {file isfile ""} msg] $msg
} {0 0}
-
test filesystem-6.13 {empty file name} {
list [catch {file join ""} msg] $msg
} {0 {}}
-
test filesystem-6.14 {empty file name} {
list [catch {file link ""} msg] $msg
} {1 {could not read link "": no such file or directory}}
-
test filesystem-6.15 {empty file name} {
list [catch {file lstat "" arr} msg] $msg
} {1 {could not read "": no such file or directory}}
-
test filesystem-6.16 {empty file name} {
list [catch {file mtime ""} msg] $msg
} {1 {could not read "": no such file or directory}}
-
test filesystem-6.17 {empty file name} {
list [catch {file mtime "" 0} msg] $msg
} {1 {could not read "": no such file or directory}}
-
test filesystem-6.18 {empty file name} {
list [catch {file mkdir ""} msg] $msg
} {1 {can't create directory "": no such file or directory}}
-
test filesystem-6.19 {empty file name} {
list [catch {file nativename ""} msg] $msg
} {0 {}}
-
test filesystem-6.20 {empty file name} {
list [catch {file normalize ""} msg] $msg
} {0 {}}
-
test filesystem-6.21 {empty file name} {
list [catch {file owned ""} msg] $msg
} {0 0}
-
test filesystem-6.22 {empty file name} {
list [catch {file pathtype ""} msg] $msg
} {0 relative}
-
test filesystem-6.23 {empty file name} {
list [catch {file readable ""} msg] $msg
} {0 0}
-
test filesystem-6.24 {empty file name} {
list [catch {file readlink ""} msg] $msg
} {1 {could not readlink "": no such file or directory}}
-
test filesystem-6.25 {empty file name} {
list [catch {file rename "" ""} msg] $msg
} {1 {error renaming "": no such file or directory}}
-
test filesystem-6.26 {empty file name} {
list [catch {file rootname ""} msg] $msg
} {0 {}}
-
test filesystem-6.27 {empty file name} {
list [catch {file separator ""} msg] $msg
} {1 {Unrecognised path}}
-
test filesystem-6.28 {empty file name} {
list [catch {file size ""} msg] $msg
} {1 {could not read "": no such file or directory}}
-
test filesystem-6.29 {empty file name} {
list [catch {file split ""} msg] $msg
} {0 {}}
-
test filesystem-6.30 {empty file name} {
list [catch {file system ""} msg] $msg
} {1 {Unrecognised path}}
-
test filesystem-6.31 {empty file name} {
list [catch {file tail ""} msg] $msg
} {0 {}}
-
test filesystem-6.32 {empty file name} {
list [catch {file type ""} msg] $msg
} {1 {could not read "": no such file or directory}}
-
test filesystem-6.33 {empty file name} {
list [catch {file writable ""} msg] $msg
} {0 0}
# Make sure the testfilesystem hasn't been registered.
-while {![catch {testfilesystem 0}]} {}
+if {[testConstraint testfilesystem]} {
+ while {![catch {testfilesystem 0}]} {}
}
test filesystem-7.1 {load from vfs} {win testsimplefilesystem} {
@@ -406,24 +714,205 @@ test filesystem-7.1 {load from vfs} {win testsimplefilesystem} {
set res "ok"
# The real result of this test is what happens when Tcl exits.
} {ok}
-
test filesystem-7.2 {cross-filesystem copy from vfs maintains mtime} \
{testsimplefilesystem} {
set dir [pwd]
cd [tcltest::temporaryDirectory]
# We created this file several tests ago.
set origtime [file mtime gorp.file]
+ set res [file exists gorp.file]
+ if {[catch {
+ testsimplefilesystem 1
+ file delete -force theCopy
+ file copy simplefs:/gorp.file theCopy
+ testsimplefilesystem 0
+ set newtime [file mtime theCopy]
+ file delete theCopy
+ } err]} {
+ lappend res $err
+ set newtime ""
+ }
+ cd $dir
+ lappend res [expr {$origtime == $newtime}]
+} {1 1}
+test filesystem-7.3 {glob in simplefs} testsimplefilesystem {
+ set dir [pwd]
+ cd [tcltest::temporaryDirectory]
+ file mkdir simpledir
+ close [open [file join simpledir simplefile] w]
testsimplefilesystem 1
- file delete -force theCopy
- file copy simplefs:/gorp.file theCopy
+ set res [glob -nocomplain -dir simplefs:/simpledir *]
testsimplefilesystem 0
- set newtime [file mtime theCopy]
- file delete theCopy
+ file delete -force simpledir
cd $dir
- expr {$origtime == $newtime}
-} {1}
-
+ set res
+} {simplefs:/simpledir/simplefile}
+test filesystem-7.3.1 {glob in simplefs: no path/dir} testsimplefilesystem {
+ set dir [pwd]
+ cd [tcltest::temporaryDirectory]
+ file mkdir simpledir
+ close [open [file join simpledir simplefile] w]
+ testsimplefilesystem 1
+ set res [glob -nocomplain simplefs:/simpledir/*]
+ eval lappend res [glob -nocomplain simplefs:/simpledir]
+ testsimplefilesystem 0
+ file delete -force simpledir
+ cd $dir
+ set res
+} {simplefs:/simpledir/simplefile simplefs:/simpledir}
+test filesystem-7.3.2 {glob in simplefs: no path/dir, no subdirectory} testsimplefilesystem {
+ set dir [pwd]
+ cd [tcltest::temporaryDirectory]
+ file mkdir simpledir
+ close [open [file join simpledir simplefile] w]
+ testsimplefilesystem 1
+ set res [glob -nocomplain simplefs:/s*]
+ testsimplefilesystem 0
+ file delete -force simpledir
+ cd $dir
+ if {[llength $res] > 0} {
+ set res "ok"
+ } else {
+ set res "no files found with 'glob -nocomplain simplefs:/s*'"
+ }
+} {ok}
+test filesystem-7.3.3 {glob in simplefs: pattern is a volume} testsimplefilesystem {
+ set dir [pwd]
+ cd [tcltest::temporaryDirectory]
+ file mkdir simpledir
+ close [open [file join simpledir simplefile] w]
+ testsimplefilesystem 1
+ set res [glob -nocomplain simplefs:/*]
+ testsimplefilesystem 0
+ file delete -force simpledir
+ cd $dir
+ if {[llength $res] > 0} {
+ set res "ok"
+ } else {
+ set res "no files found with 'glob -nocomplain simplefs:/*'"
+ }
+} {ok}
+test filesystem-7.4 {cross-filesystem file copy with -force} testsimplefilesystem {
+ set dir [pwd]
+ cd [tcltest::temporaryDirectory]
+ set fout [open [file join simplefile] w]
+ puts -nonewline $fout "1234567890"
+ close $fout
+ testsimplefilesystem 1
+ # First copy should succeed
+ set res [catch {file copy simplefs:/simplefile file2} err]
+ lappend res $err
+ # Second copy should fail (no -force)
+ lappend res [catch {file copy simplefs:/simplefile file2} err]
+ lappend res $err
+ # Third copy should succeed (-force)
+ lappend res [catch {file copy -force simplefs:/simplefile file2} err]
+ lappend res $err
+ lappend res [file exists file2]
+ testsimplefilesystem 0
+ file delete -force simplefile
+ file delete -force file2
+ cd $dir
+ set res
+} {0 10 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 10 1}
+test filesystem-7.5 {cross-filesystem file copy with -force} {testsimplefilesystem unix} {
+ set dir [pwd]
+ cd [tcltest::temporaryDirectory]
+ set fout [open [file join simplefile] w]
+ puts -nonewline $fout "1234567890"
+ close $fout
+ testsimplefilesystem 1
+ # First copy should succeed
+ set res [catch {file copy simplefs:/simplefile file2} err]
+ lappend res $err
+ file attributes file2 -permissions 0000
+ # Second copy should fail (no -force)
+ lappend res [catch {file copy simplefs:/simplefile file2} err]
+ lappend res $err
+ # Third copy should succeed (-force)
+ lappend res [catch {file copy -force simplefs:/simplefile file2} err]
+ lappend res $err
+ lappend res [file exists file2]
+ testsimplefilesystem 0
+ file delete -force simplefile
+ file delete -force file2
+ cd $dir
+ set res
+} {0 10 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 10 1}
+test filesystem-7.6 {cross-filesystem dir copy with -force} testsimplefilesystem {
+ set dir [pwd]
+ cd [tcltest::temporaryDirectory]
+ file delete -force simpledir
+ file mkdir simpledir
+ file mkdir dir2
+ set fout [open [file join simpledir simplefile] w]
+ puts -nonewline $fout "1234567890"
+ close $fout
+ testsimplefilesystem 1
+ # First copy should succeed
+ set res [catch {file copy simplefs:/simpledir dir2} err]
+ lappend res $err
+ # Second copy should fail (no -force)
+ lappend res [catch {file copy simplefs:/simpledir dir2} err]
+ lappend res $err
+ # Third copy should succeed (-force)
+ lappend res [catch {file copy -force simplefs:/simpledir dir2} err]
+ lappend res $err
+ lappend res [file exists [file join dir2 simpledir]] \
+ [file exists [file join dir2 simpledir simplefile]]
+ testsimplefilesystem 0
+ file delete -force simpledir
+ file delete -force dir2
+ cd $dir
+ set res
+} {0 {} 1 {error copying "simplefs:/simpledir" to "dir2/simpledir": file already exists} 0 {} 1 1}
+test filesystem-7.7 {cross-filesystem dir copy with -force} {testsimplefilesystem unix} {
+ set dir [pwd]
+ cd [tcltest::temporaryDirectory]
+ file delete -force simpledir
+ file mkdir simpledir
+ file mkdir dir2
+ set fout [open [file join simpledir simplefile] w]
+ puts -nonewline $fout "1234567890"
+ close $fout
+ testsimplefilesystem 1
+ # First copy should succeed
+ set res [catch {file copy simplefs:/simpledir dir2} err]
+ lappend res $err
+ # Second copy should fail (no -force)
+ lappend res [catch {file copy simplefs:/simpledir dir2} err]
+ lappend res $err
+ # Third copy should succeed (-force)
+ # I've noticed on some Unices that this only succeeds
+ # intermittently (some runs work, some fail). This needs
+ # examining further.
+ lappend res [catch {file copy -force simplefs:/simpledir dir2} err]
+ lappend res $err
+ lappend res [file exists [file join dir2 simpledir]] \
+ [file exists [file join dir2 simpledir simplefile]]
+ testsimplefilesystem 0
+ file delete -force simpledir
+ file delete -force dir2
+ cd $dir
+ set res
+} {0 {} 1 {error copying "simplefs:/simpledir" to "dir2/simpledir": file already exists} 0 {} 1 1}
removeFile gorp.file
+test filesystem-7.8 {vfs cd} testsimplefilesystem {
+ set dir [pwd]
+ cd [tcltest::temporaryDirectory]
+ file delete -force simpledir
+ file mkdir simpledir
+ testsimplefilesystem 1
+ # This can variously cause an infinite loop or simply have
+ # no effect at all (before certain bugs were fixed, of course).
+ cd simplefs:/simpledir
+ set res [pwd]
+ cd [tcltest::temporaryDirectory]
+ testsimplefilesystem 0
+ file delete -force simpledir
+ cd $dir
+ set res
+} {simplefs:/simpledir}
test filesystem-8.1 {relative path objects and caching of pwd} {
set dir [pwd]
@@ -448,7 +937,6 @@ test filesystem-8.1 {relative path objects and caching of pwd} {
cd $dir
set res
} {1 1 0 0}
-
test filesystem-8.2 {relative path objects and use of pwd} {
set origdir [pwd]
cd [tcltest::temporaryDirectory]
@@ -463,12 +951,10 @@ test filesystem-8.2 {relative path objects and use of pwd} {
cd $origdir
set res
} {1}
-
test filesystem-8.3 {path objects and empty string} {
set anchor ""
set dst foo
set res $dst
-
set yyy [file split $anchor]
set dst [file join $anchor $dst]
lappend res $dst $yyy
@@ -500,7 +986,6 @@ test filesystem-9.1 {path objects and join and object rep} {
cd $origdir
set res
} {{a/b/./c found: 1} {is dir a dir? 1} {a/b/./c found: 1}}
-
test filesystem-9.2 {path objects and join and object rep} {
set origdir [pwd]
cd [tcltest::temporaryDirectory]
@@ -510,7 +995,6 @@ test filesystem-9.2 {path objects and join and object rep} {
cd $origdir
set res
} {{a/b/./c found: 1} {is dir a dir? 1} {a/b/./c found: 1}}
-
test filesystem-9.2.1 {path objects and join and object rep} {
set origdir [pwd]
cd [tcltest::temporaryDirectory]
@@ -520,7 +1004,6 @@ test filesystem-9.2.1 {path objects and join and object rep} {
cd $origdir
set res
} {{a/b/. found: 1} {is dir a dir? 1} {a/b/. found: 1}}
-
test filesystem-9.3 {path objects and join and object rep} {
set origdir [pwd]
cd [tcltest::temporaryDirectory]
@@ -530,7 +1013,6 @@ test filesystem-9.3 {path objects and join and object rep} {
cd $origdir
set res
} {{a/b/../b/c found: 1} {is dir a dir? 1} {a/b/../b/c found: 1}}
-
test filesystem-9.4 {path objects and join and object rep} {
set origdir [pwd]
cd [tcltest::temporaryDirectory]
@@ -540,7 +1022,6 @@ test filesystem-9.4 {path objects and join and object rep} {
cd $origdir
set res
} {{a/b/../b/c found: 1} {is dir a dir? 1} {a/b/../b/c found: 1}}
-
test filesystem-9.5 {path objects and file tail and object rep} {
set origdir [pwd]
cd [tcltest::temporaryDirectory]
@@ -554,15 +1035,13 @@ test filesystem-9.5 {path objects and file tail and object rep} {
cd $origdir
set res
} {test test}
-
-test filesystem-9.6 {path objects and file join and object rep} {winOnly} {
+test filesystem-9.6 {path objects and file tail and object rep} win {
set res {}
set p "C:\\toto"
lappend res [file join $p toto]
file isdirectory $p
lappend res [file join $p toto]
} {C:/toto/toto C:/toto/toto}
-
test filesystem-9.7 {path objects and glob and file tail and tilde} {
set res {}
set origdir [pwd]
@@ -616,6 +1095,7 @@ test filesystem-9.9 {path objects and glob and file tail and tilde} {
} {0 0 0 0 1}
cleanupTests
+unset -nocomplain drive
}
namespace delete ::tcl::test::fileSystem
return
generated by cgit v0.12 at 2025-02-22 11:21:28 (GMT)