1122 lines
35 KiB
Plaintext
1122 lines
35 KiB
Plaintext
# 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.
|
|
#
|
|
# 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.
|
|
|
|
package require tcltest 2
|
|
namespace eval ::tcl::test::fileSystem {
|
|
namespace import ::tcltest::*
|
|
|
|
catch {
|
|
file delete -force link.file
|
|
file delete -force dir.link
|
|
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.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
|
|
}
|
|
|
|
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
|
|
}
|
|
|
|
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.dir] [file normalize dir.link]
|
|
} {0}
|
|
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} {
|
|
testPathEqual [file normalize [file join dir.dir foo]] \
|
|
[file normalize [file join dir.link foo]]
|
|
} {1}
|
|
test filesystem-1.4 {link normalisation} {hasLinks} {
|
|
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} {
|
|
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.dir linkinside.file]] \
|
|
[file normalize [file join dir.link inside.file]]
|
|
} {0}
|
|
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.dir linkinside.filefoo]] \
|
|
[file normalize [file join dir.link inside.filefoo]]
|
|
} {0}
|
|
test filesystem-1.9 {link normalisation} {unix hasLinks} {
|
|
file delete -force dir.link
|
|
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} -constraints {
|
|
unix hasLinks
|
|
} -body {
|
|
file link dir2.link dir.link
|
|
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 {1}
|
|
makeDirectory dir2.file
|
|
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]]
|
|
} {1}
|
|
test filesystem-1.12 {file new native path} {} {
|
|
for {set i 0} {$i < 10} {incr i} {
|
|
foreach f [lsort [glob -nocomplain -type l *]] {
|
|
catch {file readlink $f}
|
|
}
|
|
}
|
|
# If we reach here we've succeeded. We used to crash above.
|
|
expr 1
|
|
} {1}
|
|
test filesystem-1.13 {file normalisation} {win} {
|
|
# This used to be broken
|
|
file normalize C:/thislongnamedoesntexist
|
|
} {C:/thislongnamedoesntexist}
|
|
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
|
|
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} {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}
|
|
|
|
# Make sure the testfilesystem hasn't been registered.
|
|
if {[testConstraint testfilesystem]} {
|
|
proc resetfs {} {
|
|
while {![catch {testfilesystem 0}]} {}
|
|
}
|
|
}
|
|
|
|
test filesystem-3.0 {Tcl_FSRegister} testfilesystem {
|
|
resetfs
|
|
testfilesystem 1
|
|
} {registered}
|
|
test filesystem-3.1 {Tcl_FSUnregister} testfilesystem {
|
|
resetfs
|
|
testfilesystem 1
|
|
testfilesystem 0
|
|
} {unregistered}
|
|
test filesystem-3.2 {Tcl_FSUnregister} testfilesystem {
|
|
resetfs
|
|
list [catch {testfilesystem 0} err] $err
|
|
} {1 failed}
|
|
test filesystem-3.3 {Tcl_FSRegister} testfilesystem {
|
|
testfilesystem 1
|
|
testfilesystem 1
|
|
testfilesystem 0
|
|
testfilesystem 0
|
|
} {unregistered}
|
|
test filesystem-3.4 {Tcl_FSRegister} -constraints testfilesystem -body {
|
|
testfilesystem 1
|
|
file system bar
|
|
} -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 testfilesystem
|
|
-match glob
|
|
-body {
|
|
testfilesystem 1
|
|
set filesystemReport {}
|
|
file exists foo
|
|
testfilesystem 0
|
|
set filesystemReport
|
|
}
|
|
-result {*{access foo}}
|
|
}
|
|
test filesystem-4.1 {testfilesystem} {
|
|
-constraints testfilesystem
|
|
-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 testfilesystem
|
|
-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 testfilesystem
|
|
-match glob
|
|
-body {
|
|
testfilesystem 1
|
|
set filesystemReport {}
|
|
catch {glob *}
|
|
testfilesystem 0
|
|
set filesystemReport
|
|
}
|
|
-result {*{matchindirectory *}*}
|
|
}
|
|
|
|
test filesystem-5.1 {cache and ~} {
|
|
-constraints testfilesystem
|
|
-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 ([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}
|
|
test filesystem-6.34 {file name with (invalid) nul character} {
|
|
list [catch "open foo\x00" msg] $msg
|
|
} [list 1 "couldn't open \"foo\x00\": filename is invalid on this platform"]
|
|
|
|
# Make sure the testfilesystem hasn't been registered.
|
|
if {[testConstraint testfilesystem]} {
|
|
while {![catch {testfilesystem 0}]} {}
|
|
}
|
|
|
|
test filesystem-7.1 {load from vfs} {win testsimplefilesystem} {
|
|
# This may cause a crash on exit
|
|
set dir [pwd]
|
|
cd [file dirname [info nameof]]
|
|
set dde [lindex [glob *dde*[info sharedlib]] 0]
|
|
testsimplefilesystem 1
|
|
# This loads dde via a complex copy-to-temp operation
|
|
load simplefs:/$dde dde
|
|
testsimplefilesystem 0
|
|
cd $dir
|
|
set res "ok"
|
|
# The real result of this test is what happens when Tcl exits.
|
|
} {ok}
|
|
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
|
|
set res [glob -nocomplain -dir simplefs:/simpledir *]
|
|
testsimplefilesystem 0
|
|
file delete -force simpledir
|
|
cd $dir
|
|
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 {} 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 {} 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 {} 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 {} 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]
|
|
cd [tcltest::temporaryDirectory]
|
|
makeDirectory abc
|
|
makeDirectory def
|
|
makeFile "contents" [file join abc foo]
|
|
cd abc
|
|
set f "foo"
|
|
set res {}
|
|
lappend res [file exists $f]
|
|
lappend res [file exists $f]
|
|
cd ..
|
|
cd def
|
|
# 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]
|
|
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} {
|
|
set origdir [pwd]
|
|
cd [tcltest::temporaryDirectory]
|
|
set dir "abc"
|
|
makeDirectory $dir
|
|
makeFile "contents" [file join abc foo]
|
|
cd $dir
|
|
set res [file exists [lindex [glob *] 0]]
|
|
cd ..
|
|
removeFile [file join abc foo]
|
|
removeDirectory abc
|
|
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
|
|
} {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"
|
|
set 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"
|
|
set res
|
|
}
|
|
|
|
test filesystem-9.1 {path objects and join and object rep} {
|
|
set origdir [pwd]
|
|
cd [tcltest::temporaryDirectory]
|
|
file mkdir [file join a b c]
|
|
set res [TestFind1 a [file join b . c]]
|
|
file delete -force a
|
|
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]
|
|
file mkdir [file join a b c]
|
|
set res [TestFind2 a [file join b . c]]
|
|
file delete -force a
|
|
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]
|
|
file mkdir [file join a b c]
|
|
set res [TestFind2 a [file join b .]]
|
|
file delete -force a
|
|
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]
|
|
file mkdir [file join a b c]
|
|
set res [TestFind1 a [file join b .. b c]]
|
|
file delete -force a
|
|
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]
|
|
file mkdir [file join a b c]
|
|
set res [TestFind2 a [file join b .. b c]]
|
|
file delete -force a
|
|
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]
|
|
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"]
|
|
}
|
|
file delete -force dgp
|
|
cd $origdir
|
|
set res
|
|
} {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} {
|
|
set res {}
|
|
set origdir [pwd]
|
|
cd [tcltest::temporaryDirectory]
|
|
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
|
|
cd ..
|
|
file delete -force tilde
|
|
cd $origdir
|
|
set res
|
|
} {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} {
|
|
set res {}
|
|
set origdir [pwd]
|
|
cd [tcltest::temporaryDirectory]
|
|
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
|
|
cd ..
|
|
file delete -force tilde
|
|
cd $origdir
|
|
set res
|
|
} {~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} {
|
|
set res {}
|
|
set origdir [pwd]
|
|
cd [tcltest::temporaryDirectory]
|
|
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]
|
|
cd ..
|
|
file delete -force tilde
|
|
cd $origdir
|
|
set res
|
|
} {0 0 0 0 1}
|
|
|
|
test filesystem-10.1 {Bug 3414754} {
|
|
string match */ [file join [pwd] foo/]
|
|
} 0
|
|
|
|
cleanupTests
|
|
unset -nocomplain drive
|
|
}
|
|
namespace delete ::tcl::test::fileSystem
|
|
return
|