diff options
Diffstat (limited to 'tests/fileSystem.test')
| -rw-r--r-- | tests/fileSystem.test | 1167 |
1 files changed, 822 insertions, 345 deletions
diff --git a/tests/fileSystem.test b/tests/fileSystem.test index f35eae1..942a86c 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -1,112 +1,159 @@ # This file tests the filesystem and vfs internals. # -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. +# This file contains a collection of tests for one or more of the Tcl built-in +# commands. Sourcing this file into Tcl runs the tests and generates output +# for errors. No output means no errors were found. # # Copyright (c) 2002 Vincent Darley. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest +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] } +testConstraint loaddll 0 +catch { + ::tcltest::loadTestedCommands + package require -exact Tcltest [info patchlevel] + set ::ddever [package require dde] + set ::ddelib [lindex [package ifneeded dde $::ddever] 1] + set ::regver [package require registry] + set ::reglib [lindex [package ifneeded registry $::regver] 1] + testConstraint loaddll 1 +} + +# 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 +testConstraint moreThanOneDrive 0 +apply {{} { + # The variables 'drive' and 'drives' will be used below. + variable drive {} drives {} + 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 {$drive ni $vols} { + testConstraint unusedDrive 1 + break + } + } + + set dir [pwd] + try { + foreach vol [file volumes] { + if {![catch {cd $vol}]} { + lappend drives $vol + } + } + testConstraint moreThanOneDrive [llength $drives] + } finally { + cd $dir + } + } +} ::tcl::test::fileSystem} -if {[catch { - file link link.file gorp.file +proc testPathEqual {one two} { + if {$one eq $two} { + return "ok" + } + return "not equal: $one $two" +} + +testConstraint hasLinks [expr {![catch { + file link link.file gorp.file + cd dir.dir 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 + [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]] -} {1} - +test filesystem-1.2 {link normalisation} {hasLinks unix} { + testPathEqual [file normalize [file join gorp.file foo]] \ + [file normalize [file join link.file foo]] +} ok test filesystem-1.3 {link normalisation} {hasLinks} { - string equal [file normalize [file join dir.file foo]] \ - [file normalize [file join dir.link foo]] -} {1} - + testPathEqual [file normalize [file join dir.dir foo]] \ + [file normalize [file join dir.link foo]] +} ok 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]] -} {1} - + testPathEqual [file normalize [file join dir.dir inside.file]] \ + [file normalize [file join dir.link inside.file]] +} ok 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]] -} {1} - + testPathEqual [file normalize [file join dir.dir linkinside.file]] \ + [file normalize [file join dir.dir linkinside.file]] +} ok test filesystem-1.6 {link normalisation} {hasLinks} { - string equal [file normalize [file join dir.file linkinside.file]] \ - [file normalize [file join dir.link inside.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]] -} {1} - +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]] +} ok 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} -setup { 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]] -} {1} - -test filesystem-1.10 {link normalisation: double link} {macOrUnix hasLinks} { +} -constraints {unix hasLinks} -body { + 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]] +} -result ok +test filesystem-1.10 {link normalisation: double link} -constraints { + unix hasLinks +} -body { 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]] -} {1} - + testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \ + [file normalize [file join dir2.link inside.file foo]] +} -cleanup { + file delete dir2.link +} -result ok 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]] -} {1} - +test filesystem-1.11 {link normalisation: double link, back in tree} {unix hasLinks} { + file link dir2.link dir.link + 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]] +} ok test filesystem-1.12 {file new native path} {} { for {set i 0} {$i < 10} {incr i} { foreach f [lsort [glob -nocomplain -type l *]] { @@ -116,313 +163,591 @@ 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 ..} -setup { + file delete -force dir2.link +} -constraints {hasLinks} -body { + set dir [file join dir2 foo bar] + file mkdir $dir + file link dir2.link [file join dir2 foo bar] + testPathEqual [file normalize [file join dir2 foo x]] \ + [file normalize [file join dir2.link .. x]] +} -result 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] + list [testPathEqual [file normalize $dir] [file normalize $dir2]] \ + [file exists $dir] [file exists $dir2] +} {ok 1 1} +test filesystem-1.28 {link normalisation: link with .. and ..} -setup { + file delete -force dir2.link +} -constraints {hasLinks} -body { + set dir [file join dir2 foo bar] + file mkdir $dir + set to [file join dir2 .. dir2 foo .. foo bar] + file link dir2.link $to + testPathEqual [file normalize [file join dir2 foo x]] \ + [file normalize [file join dir2.link .. x]] +} -result ok +test filesystem-1.29 {link normalisation: link with ..} -setup { + file delete -force dir2.link +} -constraints {hasLinks} -body { + 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 match *..* $res]} { + return "$res must not contain '..'" + } + return "ok" +} -result {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]] +} ok 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 - -test filesystem-2.0 {new native path} {unixOnly} { +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} -body { + file normalize ~noonewiththisname +} -returnCodes error -result {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 '/./'} -body { + file normalize /foo/bar/anc/./.tml +} -match regexp -result {^(?:(?!/\./).)*$} +test filesystem-1.35a {file normalisation with '/./'} -body { + file normalize /ffo/bar/anc/./foo/.tml +} -match regexp -result {^(?:(?!/\./).)*$} +test filesystem-1.35b {file normalisation with '/./'} { + llength [regexp -all foo [file normalize /ffo/bar/anc/./foo/.tml]] +} 1 +test filesystem-1.36a {file normalisation with '/./'} -body { + file normalize /foo/bar/anc/././asdasd/.tml +} -match regexp -result {^(?:(?!/\./).)*$} +test filesystem-1.36b {file normalisation with '/./'} { + llength [regexp -all asdasd [file normalize /foo/bar/anc/././asdasd/.tml]] +} 1 +test filesystem-1.37 {file normalisation with '/./'} -body { + set fname "/abc/./def/./ghi/./asda/.././.././asd/x/../../../../....." + file norm $fname +} -match regexp -result {^(?:[^/]|/(?:[^/]|$))+$} +test filesystem-1.38 {file normalisation with volume relative} -setup { + set dir [pwd] +} -constraints {win moreThanOneDrive} -body { + set path "[string range [lindex $drives 0] 0 1]foo" + cd [lindex $drives 1] + file norm $path +} -cleanup { + cd $dir +} -result "[lindex $drives 0]foo" +test filesystem-1.39 {file normalisation with volume relative} -setup { + set old [pwd] +} -constraints {win} -body { + set drv C:/ + cd [lindex [glob -type d -dir $drv *] 0] + file norm [string range $drv 0 1] +} -cleanup { + cd $old +} -match regexp -result {.*[^/]} +test filesystem-1.40 {file normalisation with repeated separators} { + testPathEqual [file norm foo////bar] [file norm foo/bar] +} ok +test filesystem-1.41 {file normalisation with repeated separators} {win} { + testPathEqual [file norm foo\\\\\\bar] [file norm foo/bar] +} ok +test filesystem-1.42 {file normalisation .. beyond root (Bug 1379287)} { + testPathEqual [file norm /xxx/..] [file norm /] +} ok +test filesystem-1.42.1 {file normalisation .. beyond root (Bug 1379287)} { + testPathEqual [file norm /xxx/../] [file norm /] +} ok +test filesystem-1.43 {file normalisation .. beyond root (Bug 1379287)} { + testPathEqual [file norm /xxx/foo/../..] [file norm /] +} ok +test filesystem-1.43.1 {file normalisation .. beyond root (Bug 1379287)} { + testPathEqual [file norm /xxx/foo/../../] [file norm /] +} ok +test filesystem-1.44 {file normalisation .. beyond root (Bug 1379287)} { + testPathEqual [file norm /xxx/foo/../../bar] [file norm /bar] +} ok +test filesystem-1.45 {file normalisation .. beyond root (Bug 1379287)} { + testPathEqual [file norm /xxx/../../bar] [file norm /bar] +} ok +test filesystem-1.46 {file normalisation .. beyond root (Bug 1379287)} { + testPathEqual [file norm /xxx/../bar] [file norm /bar] +} ok +test filesystem-1.47 {file normalisation .. beyond root (Bug 1379287)} { + testPathEqual [file norm /..] [file norm /] +} ok +test filesystem-1.48 {file normalisation .. beyond root (Bug 1379287)} { + testPathEqual [file norm /../] [file norm /] +} ok +test filesystem-1.49 {file normalisation .. beyond root (Bug 1379287)} { + testPathEqual [file norm /.] [file norm /] +} ok +test filesystem-1.50 {file normalisation .. beyond root (Bug 1379287)} { + testPathEqual [file norm /./] [file norm /] +} ok +test filesystem-1.51 {file normalisation .. beyond root (Bug 1379287)} { + testPathEqual [file norm /../..] [file norm /] +} ok +test filesystem-1.51.1 {file normalisation .. beyond root (Bug 1379287)} { + testPathEqual [file norm /../../] [file norm /] +} ok + +test filesystem-2.0 {new native path} {unix} { foreach f [lsort [glob -nocomplain /usr/bin/c*]] { catch {file readlink $f} } # If we reach here we've succeeded. We used to crash above. - 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]}] + return ok +} ok # Make sure the testfilesystem hasn't been registered. -while {![catch {testfilesystem 0}]} {} - -test filesystem-3.0 {Tcl_FSRegister} Tcltest { - testfilesystem 1 -} {registered} - -test filesystem-3.1 {Tcl_FSUnregister} Tcltest { - testfilesystem 0 -} {unregistered} - -test filesystem-3.2 {Tcl_FSUnregister} Tcltest { - list [catch {testfilesystem 0} err] $err -} {1 failed} +if {[testConstraint testfilesystem]} { + proc resetfs {} { + while {![catch {testfilesystem 0}]} {} + } +} -test filesystem-3.3 {Tcl_FSRegister} Tcltest { +test filesystem-3.1 {Tcl_FSRegister & Tcl_FSUnregister} testfilesystem { + set result {} + lappend result [testfilesystem 1] + lappend result [testfilesystem 0] + lappend result [catch {testfilesystem 0} msg] $msg +} {registered unregistered 1 failed} +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} -constraints testfilesystem -body { testfilesystem 1 file system bar -} {reporting} - -test filesystem-3.5 {Tcl_FSUnregister} Tcltest { +} -cleanup { testfilesystem 0 +} -result {reporting} +test filesystem-3.5 {Tcl_FSUnregister} testfilesystem { + resetfs lindex [file system bar] 0 } {native} -test filesystem-4.0 {testfilesystem} { - -constraints Tcltest - -match glob - -body { - testfilesystem 1 - set filesystemReport {} - file exists foo - testfilesystem 0 - set filesystemReport - } - -result {* {access foo}} -} - -test filesystem-4.1 {testfilesystem} { - -constraints Tcltest - -match glob - -body { - testfilesystem 1 - set filesystemReport {} - catch {file stat foo bar} - testfilesystem 0 - set filesystemReport - } - -result {* {stat foo}} -} - -test filesystem-4.2 {testfilesystem} { - -constraints Tcltest - -match glob - -body { - testfilesystem 1 - set filesystemReport {} - catch {file lstat foo bar} - testfilesystem 0 - set filesystemReport - } - -result {* {lstat foo}} -} - -test filesystem-4.3 {testfilesystem} { - -constraints Tcltest - -match glob - -body { - testfilesystem 1 - set filesystemReport {} - catch {glob *} - testfilesystem 0 - set filesystemReport - } - -result {* {matchindirectory *}*} -} - -test filesystem-5.1 {cache and ~} { - -constraints Tcltest - -match regexp - -body { - set orig $env(HOME) - set ::env(HOME) /foo/bar/blah - set testdir ~ - set res1 "Parent of ~ (/foo/bar/blah) is [file dirname $testdir]" - set ::env(HOME) /a/b/c - set res2 "Parent of ~ (/a/b/c) is [file dirname $testdir]" - 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)}} -} - -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} +test filesystem-4.0 {testfilesystem} -constraints testfilesystem -body { + testfilesystem 1 + set filesystemReport {} + file exists foo + testfilesystem 0 + return $filesystemReport +} -match glob -result {*{access foo}} +test filesystem-4.1 {testfilesystem} -constraints testfilesystem -body { + testfilesystem 1 + set filesystemReport {} + catch {file stat foo bar} + testfilesystem 0 + return $filesystemReport +} -match glob -result {*{stat foo}} +test filesystem-4.2 {testfilesystem} -constraints testfilesystem -body { + testfilesystem 1 + set filesystemReport {} + catch {file lstat foo bar} + testfilesystem 0 + return $filesystemReport +} -match glob -result {*{lstat foo}} +test filesystem-4.3 {testfilesystem} -constraints testfilesystem -body { + testfilesystem 1 + set filesystemReport {} + catch {glob *} + testfilesystem 0 + return $filesystemReport +} -match glob -result {*{matchindirectory *}*} + +test filesystem-5.1 {cache and ~} -constraints testfilesystem -setup { + set orig $::env(HOME) +} -body { + set ::env(HOME) /foo/bar/blah + set testdir ~ + set res1 "Parent of ~ (/foo/bar/blah) is [file dirname $testdir]" + set ::env(HOME) /a/b/c + set res2 "Parent of ~ (/a/b/c) is [file dirname $testdir]" + list $res1 $res2 +} -cleanup { + set ::env(HOME) $orig +} -match regexp -result {{Parent of ~ \(/foo/bar/blah\) is ([a-zA-Z]:)?(/cygwin)?(/foo/bar|foo:bar)} {Parent of ~ \(/a/b/c\) is ([a-zA-Z]:)?(/cygwin)?(/a/b|a:b)}} + +test filesystem-6.1 {empty file name} -returnCodes error -body { + open "" +} -result {couldn't open "": no such file or directory} +test filesystem-6.2 {empty file name} -returnCodes error -body { + file stat "" arr +} -result {could not read "": no such file or directory} +test filesystem-6.3 {empty file name} -returnCodes error -body { + file atime "" +} -result {could not read "": no such file or directory} +test filesystem-6.4 {empty file name} -returnCodes error -body { + file attributes "" +} -result {could not read "": no such file or directory} +test filesystem-6.5 {empty file name} -returnCodes error -body { + file copy "" "" +} -result {error copying "": no such file or directory} +test filesystem-6.6 {empty file name} {file delete ""} {} +test filesystem-6.7 {empty file name} {file dirname ""} . +test filesystem-6.8 {empty file name} {file executable ""} 0 +test filesystem-6.9 {empty file name} {file exists ""} 0 +test filesystem-6.10 {empty file name} {file extension ""} {} +test filesystem-6.11 {empty file name} {file isdirectory ""} 0 +test filesystem-6.12 {empty file name} {file isfile ""} 0 +test filesystem-6.13 {empty file name} {file join ""} {} +test filesystem-6.14 {empty file name} -returnCodes error -body { + file link "" +} -result {could not read link "": no such file or directory} +test filesystem-6.15 {empty file name} -returnCodes error -body { + file lstat "" arr +} -result {could not read "": no such file or directory} +test filesystem-6.16 {empty file name} -returnCodes error -body { + file mtime "" +} -result {could not read "": no such file or directory} +test filesystem-6.17 {empty file name} -returnCodes error -body { + file mtime "" 0 +} -result {could not read "": no such file or directory} +test filesystem-6.18 {empty file name} -returnCodes error -body { + file mkdir "" +} -result {can't create directory "": no such file or directory} +test filesystem-6.19 {empty file name} {file nativename ""} {} +test filesystem-6.20 {empty file name} {file normalize ""} {} +test filesystem-6.21 {empty file name} {file owned ""} 0 +test filesystem-6.22 {empty file name} {file pathtype ""} relative +test filesystem-6.23 {empty file name} {file readable ""} 0 +test filesystem-6.24 {empty file name} -returnCodes error -body { + file readlink "" +} -result {could not read link "": no such file or directory} +test filesystem-6.25 {empty file name} -returnCodes error -body { + file rename "" "" +} -result {error renaming "": no such file or directory} +test filesystem-6.26 {empty file name} {file rootname ""} {} +test filesystem-6.27 {empty file name} -returnCodes error -body { + file separator "" +} -result {unrecognised path} +test filesystem-6.28 {empty file name} -returnCodes error -body { + file size "" +} -result {could not read "": no such file or directory} +test filesystem-6.29 {empty file name} {file split ""} {} +test filesystem-6.30 {empty file name} -returnCodes error -body { + file system "" +} -result {unrecognised path} +test filesystem-6.31 {empty file name} {file tail ""} {} +test filesystem-6.32 {empty file name} -returnCodes error -body { + file type "" +} -result {could not read "": no such file or directory} +test filesystem-6.33 {empty file name} {file writable ""} 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} { - # This may cause a crash on exit +test filesystem-7.1.1 {load from vfs} -setup { set dir [pwd] - cd [file dirname [info nameof]] - set dde [lindex [glob *dde*[info sharedlib]] 0] +} -constraints {win testsimplefilesystem loaddll} -body { + # This may cause a crash on exit + cd [file dirname $::ddelib] testsimplefilesystem 1 # This loads dde via a complex copy-to-temp operation - load simplefs:/$dde dde + load simplefs:/[file tail $::ddelib] dde testsimplefilesystem 0 + return ok + # The real result of this test is what happens when Tcl exits. +} -cleanup { cd $dir - set res "ok" +} -result ok +test filesystem-7.1.2 {load from vfs, and then unload again} -setup { + set dir [pwd] +} -constraints {win testsimplefilesystem loaddll} -body { + # This may cause a crash on exit + cd [file dirname $::reglib] + testsimplefilesystem 1 + # This loads reg via a complex copy-to-temp operation + load simplefs:/[file tail $::reglib] Registry + unload simplefs:/[file tail $::reglib] + testsimplefilesystem 0 + return 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} { +} -cleanup { + cd $dir +} -result ok +test filesystem-7.2 {cross-filesystem copy from vfs maintains mtime} -setup { set dir [pwd] cd [tcltest::temporaryDirectory] +} -constraints testsimplefilesystem -body { # We created this file several tests ago. set origtime [file mtime gorp.file] + set res [file exists gorp.file] testsimplefilesystem 1 file delete -force theCopy file copy simplefs:/gorp.file theCopy testsimplefilesystem 0 set newtime [file mtime theCopy] - file delete theCopy + lappend res [expr {$origtime == $newtime ? 1 : "$origtime != $newtime"}] +} -cleanup { + catch {file delete theCopy} cd $dir - expr {$origtime == $newtime} -} {1} - +} -result {1 1} +test filesystem-7.3 {glob in simplefs} -setup { + set dir [pwd] + cd [tcltest::temporaryDirectory] +} -constraints testsimplefilesystem -body { + file mkdir simpledir + close [open [file join simpledir simplefile] w] + testsimplefilesystem 1 + glob -nocomplain -dir simplefs:/simpledir * +} -cleanup { + catch {testsimplefilesystem 0} + file delete -force simpledir + cd $dir +} -result {simplefs:/simpledir/simplefile} +test filesystem-7.3.1 {glob in simplefs: no path/dir} -setup { + set dir [pwd] + cd [tcltest::temporaryDirectory] +} -constraints testsimplefilesystem -body { + file mkdir simpledir + close [open [file join simpledir simplefile] w] + testsimplefilesystem 1 + set res [glob -nocomplain simplefs:/simpledir/*] + lappend res {*}[glob -nocomplain simplefs:/simpledir] +} -cleanup { + catch {testsimplefilesystem 0} + file delete -force simpledir + cd $dir +} -result {simplefs:/simpledir/simplefile simplefs:/simpledir} +test filesystem-7.3.2 {glob in simplefs: no path/dir, no subdirectory} -setup { + set dir [pwd] + cd [tcltest::temporaryDirectory] +} -constraints testsimplefilesystem -body { + file mkdir simpledir + close [open [file join simpledir simplefile] w] + testsimplefilesystem 1 + glob -nocomplain simplefs:/s* +} -cleanup { + catch {testsimplefilesystem 0} + file delete -force simpledir + cd $dir +} -match glob -result ?* +test filesystem-7.3.3 {glob in simplefs: pattern is a volume} -setup { + set dir [pwd] + cd [tcltest::temporaryDirectory] +} -constraints testsimplefilesystem -body { + file mkdir simpledir + close [open [file join simpledir simplefile] w] + testsimplefilesystem 1 + glob -nocomplain simplefs:/* +} -cleanup { + testsimplefilesystem 0 + file delete -force simpledir + cd $dir +} -match glob -result ?* +test filesystem-7.4 {cross-filesystem file copy with -force} -setup { + set dir [pwd] + cd [tcltest::temporaryDirectory] + set fout [open [file join simplefile] w] + puts -nonewline $fout "1234567890" + close $fout + testsimplefilesystem 1 +} -constraints testsimplefilesystem -body { + # 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] +} -cleanup { + catch {testsimplefilesystem 0} + file delete -force simplefile + file delete -force file2 + cd $dir +} -result {0 {} 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 {} 1} +test filesystem-7.5 {cross-filesystem file copy with -force} -setup { + set dir [pwd] + cd [tcltest::temporaryDirectory] + set fout [open [file join simplefile] w] + puts -nonewline $fout "1234567890" + close $fout + testsimplefilesystem 1 +} -constraints {testsimplefilesystem unix} -body { + # 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] +} -cleanup { + testsimplefilesystem 0 + file delete -force simplefile + file delete -force file2 + cd $dir +} -result {0 {} 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 {} 1} +test filesystem-7.6 {cross-filesystem dir copy with -force} -setup { + 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 +} -constraints testsimplefilesystem -body { + # 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]] +} -cleanup { + testsimplefilesystem 0 + file delete -force simpledir + file delete -force dir2 + cd $dir +} -result {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} -setup { + 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 +} -constraints {testsimplefilesystem unix} -body { + # 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]] +} -cleanup { + testsimplefilesystem 0 + file delete -force simpledir + file delete -force dir2 + cd $dir +} -result {0 {} 1 {error copying "simplefs:/simpledir" to "dir2/simpledir": file already exists} 0 {} 1 1} removeFile gorp.file +test filesystem-7.8 {vfs cd} -setup { + set dir [pwd] + cd [tcltest::temporaryDirectory] + file delete -force simpledir + file mkdir simpledir + testsimplefilesystem 1 +} -constraints testsimplefilesystem -body { + # This can variously cause an infinite loop or simply have no effect at + # all (before certain bugs were fixed, of course). + cd simplefs:/simpledir + pwd +} -cleanup { + cd [tcltest::temporaryDirectory] + testsimplefilesystem 0 + file delete -force simpledir + cd $dir +} -result {simplefs:/simpledir} -test filesystem-8.1 {relative path objects and caching of pwd} { +test filesystem-8.1 {relative path objects and caching of pwd} -setup { set dir [pwd] cd [tcltest::temporaryDirectory] +} -body { makeDirectory abc makeDirectory def makeFile "contents" [file join abc foo] @@ -433,44 +758,196 @@ test filesystem-8.1 {relative path objects and caching of pwd} { lappend res [file exists $f] cd .. cd def - # If we haven't cleared the object's cwd cache, Tcl - # will think it still exists. + # If we haven't cleared the object's cwd cache, Tcl will think it still + # exists. lappend res [file exists $f] lappend res [file exists $f] +} -cleanup { removeFile [file join abc foo] removeDirectory abc removeDirectory def cd $dir - set res -} {1 1 0 0} - -test filesystem-8.2 {relative path objects and use of pwd} { +} -result {1 1 0 0} +test filesystem-8.2 {relative path objects and use of pwd} -setup { set origdir [pwd] cd [tcltest::temporaryDirectory] +} -body { set dir "abc" makeDirectory $dir makeFile "contents" [file join abc foo] cd $dir - set res [file exists [lindex [glob *] 0]] - cd .. + file exists [lindex [glob *] 0] +} -cleanup { + cd [tcltest::temporaryDirectory] removeFile [file join abc foo] removeDirectory abc - removeDirectory def cd $origdir - set res -} {1} - +} -result 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 } {foo foo {}} +proc TestFind1 {d f} { + set r1 [file exists [file join $d $f]] + lappend res "[file join $d $f] found: $r1" + lappend res "is dir a dir? [file isdirectory $d]" + set r2 [file exists [file join $d $f]] + lappend res "[file join $d $f] found: $r2" + return $res +} +proc TestFind2 {d f} { + set r1 [file exists [file join $d $f]] + lappend res "[file join $d $f] found: $r1" + lappend res "is dir a dir? [file isdirectory [file join $d]]" + set r2 [file exists [file join $d $f]] + lappend res "[file join $d $f] found: $r2" + return $res +} + +test filesystem-9.1 {path objects and join and object rep} -setup { + set origdir [pwd] + cd [tcltest::temporaryDirectory] +} -body { + file mkdir [file join a b c] + TestFind1 a [file join b . c] +} -cleanup { + file delete -force a + cd $origdir +} -result {{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} -setup { + set origdir [pwd] + cd [tcltest::temporaryDirectory] +} -body { + file mkdir [file join a b c] + TestFind2 a [file join b . c] +} -cleanup { + file delete -force a + cd $origdir +} -result {{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} -setup { + set origdir [pwd] + cd [tcltest::temporaryDirectory] +} -body { + file mkdir [file join a b c] + TestFind2 a [file join b .] +} -cleanup { + file delete -force a + cd $origdir +} -result {{a/b/. found: 1} {is dir a dir? 1} {a/b/. found: 1}} +test filesystem-9.3 {path objects and join and object rep} -setup { + set origdir [pwd] + cd [tcltest::temporaryDirectory] +} -body { + file mkdir [file join a b c] + TestFind1 a [file join b .. b c] +} -cleanup { + file delete -force a + cd $origdir +} -result {{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} -setup { + set origdir [pwd] + cd [tcltest::temporaryDirectory] +} -body { + file mkdir [file join a b c] + TestFind2 a [file join b .. b c] +} -cleanup { + file delete -force a + cd $origdir +} -result {{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} -setup { + set origdir [pwd] + cd [tcltest::temporaryDirectory] +} -body { + file mkdir dgp + close [open dgp/test w] + foreach relative [glob -nocomplain [file join * test]] { + set absolute [file join [pwd] $relative] + set res [list [file tail $absolute] "test"] + } + return $res +} -cleanup { + file delete -force dgp + cd $origdir +} -result {test test} +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} -setup { + set res {} + set origdir [pwd] + cd [tcltest::temporaryDirectory] +} -body { + file mkdir tilde + close [open tilde/~testNotExist w] + cd tilde + set file [lindex [glob *test*] 0] + lappend res [file exists $file] [catch {file tail $file} r] $r + lappend res $file + lappend res [file exists $file] [catch {file tail $file} r] $r + lappend res [catch {file tail $file} r] $r +} -cleanup { + cd [tcltest::temporaryDirectory] + file delete -force tilde + cd $origdir +} -result {0 1 {user "testNotExist" doesn't exist} ~testNotExist 0 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}} +test filesystem-9.8 {path objects and glob and file tail and tilde} -setup { + set res {} + set origdir [pwd] + cd [tcltest::temporaryDirectory] +} -body { + file mkdir tilde + close [open tilde/~testNotExist w] + cd tilde + set file1 [lindex [glob *test*] 0] + set file2 "~testNotExist" + lappend res $file1 $file2 + lappend res [catch {file tail $file1} r] $r + lappend res [catch {file tail $file2} r] $r +} -cleanup { + cd [tcltest::temporaryDirectory] + file delete -force tilde + cd $origdir +} -result {~testNotExist ~testNotExist 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}} +test filesystem-9.9 {path objects and glob and file tail and tilde} -setup { + set res {} + set origdir [pwd] + cd [tcltest::temporaryDirectory] +} -body { + file mkdir tilde + close [open tilde/~testNotExist w] + cd tilde + set file1 [lindex [glob *test*] 0] + set file2 "~testNotExist" + lappend res [catch {file exists $file1} r] $r + lappend res [catch {file exists $file2} r] $r + lappend res [string equal $file1 $file2] +} -cleanup { + cd [tcltest::temporaryDirectory] + file delete -force tilde + cd $origdir +} -result {0 0 0 0 1} + +# ---------------------------------------------------------------------- + +test filesystem-10.1 {Bug 3414754} { + string match */ [file join [pwd] foo/] +} 0 + cleanupTests +unset -nocomplain drive drives } namespace delete ::tcl::test::fileSystem return + +# Local Variables: +# mode: tcl +# End: |