mirror of
https://github.com/tcltk/tcl.git
synced 2026-05-29 00:27:49 +08:00
1278 lines
44 KiB
Plaintext
1278 lines
44 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 © 2002 Vincent Darley.
|
||
#
|
||
# See the file "license.terms" for information on usage and redistribution of
|
||
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||
|
||
namespace eval ::tcl::test::fileSystem {
|
||
|
||
if {"::tcltest" ni [namespace children]} {
|
||
package require tcltest 2.5
|
||
namespace import -force ::tcltest::*
|
||
}
|
||
|
||
catch {
|
||
file delete -force link.file dir.link
|
||
file delete -force dir.link
|
||
file delete -force [file join dir.dir linkinside.file]
|
||
file delete -force MixedCaseLink.File MixedCaseLink.Dir
|
||
}
|
||
|
||
# notWSL constraint is true when running under native Windows or
|
||
# native Unix.
|
||
testConstraint notWSL \
|
||
[expr {
|
||
$::tcl_platform(platform) eq "windows"
|
||
|| [llength [array names ::env *WSL*]] == 0
|
||
}]
|
||
|
||
testConstraint loaddll 0
|
||
catch {
|
||
::tcltest::loadTestedCommands
|
||
package require -exact tcl::test [info patchlevel]
|
||
set ::ddever [package require dde]
|
||
set ::ddelib [info loaded {} Dde]
|
||
set ::regver [package require registry]
|
||
set ::reglib [info loaded {} Registry]
|
||
testConstraint loaddll [expr {$::ddelib ne "" && $::reglib ne ""}]
|
||
}
|
||
|
||
# Test for commands defined in tcl::test package
|
||
testConstraint testfilesystem [llength [info commands ::testfilesystem]]
|
||
testConstraint testsetplatform [llength [info commands ::testsetplatform]]
|
||
testConstraint testsimplefilesystem [llength [info commands ::testsimplefilesystem]]
|
||
# Some things fail under all Continuous Integration systems for subtle reasons
|
||
# such as CI often running with elevated privileges in a container.
|
||
testConstraint notInCIenv [expr {![info exists ::env(CI)]}]
|
||
|
||
variable caseSensitiveFS [expr {
|
||
$::tcl_platform(os) ne "Darwin" && $::tcl_platform(os) ne "Windows NT"
|
||
}]
|
||
testConstraint caseSensitiveFS $caseSensitiveFS
|
||
|
||
cd [tcltest::temporaryDirectory]
|
||
variable tempDir [pwd]
|
||
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]
|
||
makeFile "Mixed case in name" MixedCase.File
|
||
makeDirectory MixedCase.Dir
|
||
makeFile "test file in mixed directory" [file join MixedCase.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 {
|
||
set drives [lmap vol [file volumes] {
|
||
if {$vol eq [zipfs root] || [catch {cd $vol}]} {
|
||
continue
|
||
}
|
||
set vol
|
||
}]
|
||
testConstraint moreThanOneDrive [expr {[llength $drives] > 1}]
|
||
} finally {
|
||
cd $dir
|
||
}
|
||
}
|
||
} ::tcl::test::fileSystem}
|
||
|
||
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
|
||
file link MixedCaseLink.File MixedCase.File
|
||
file link MixedCaseLink.Dir MixedCase.Dir
|
||
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 ..
|
||
}]}]
|
||
|
||
# Normalization code path specializes components in root
|
||
variable dirInRoot [lindex [glob -types d /*] 0]
|
||
if {$dirInRoot ne ""} {
|
||
testConstraint hasDirInRoot 1
|
||
variable casedDirInRoot [string toupper $dirInRoot]
|
||
if {$casedDirInRoot eq $dirInRoot} {
|
||
set casedDirInRoot [string tolower $dirInRoot]
|
||
}
|
||
} else {
|
||
testConstraint hasDirInRoot 0
|
||
}
|
||
|
||
variable linkInRoot [lindex [glob -types l /*] 0]
|
||
if {[testConstraint hasLinks] && $linkInRoot ne ""} {
|
||
testConstraint hasLinkInRoot 1
|
||
variable linkInRootTarget [file link $linkInRoot]
|
||
variable casedLinkInRoot [string toupper $linkInRoot]
|
||
if {$casedLinkInRoot eq $linkInRoot} {
|
||
set casedLinkInRoot [string tolower $linkInRoot]
|
||
}
|
||
} else {
|
||
testConstraint hasLinkInRoot 0
|
||
set casedLinkInRoot ""
|
||
}
|
||
|
||
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]]
|
||
} ok
|
||
test filesystem-1.3 {link normalisation} {hasLinks} {
|
||
testPathEqual [file normalize [file join dir.dir foo]] \
|
||
[file normalize [file join dir.link foo]]
|
||
} ok
|
||
test filesystem-1.4 {link normalisation} {hasLinks} {
|
||
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} {
|
||
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.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]]
|
||
} ok
|
||
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} -setup {
|
||
file delete -force dir.link
|
||
} -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
|
||
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} {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 *]] {
|
||
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 ..} -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
|
||
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 - verify no tilde expansion
|
||
} -body {
|
||
file normalize ~noonewiththisname
|
||
} -result [file join [pwd] ~noonewiththisname]
|
||
test filesystem-1.30.1 {normalisation of existing user} -body {
|
||
file normalize ~$::tcl_platform(user)
|
||
} -result [file join [pwd] ~$::tcl_platform(user)]
|
||
test filesystem-1.30.3 {file normalization should distinguish between ~ and ~user} -setup {
|
||
set oldhome $::env(HOME)
|
||
set olduserhome [file normalize [file home $::tcl_platform(user)]]
|
||
set ::env(HOME) [file join $oldhome temp]
|
||
} -cleanup {
|
||
set ::env(HOME) $oldhome
|
||
} -body {
|
||
list [string equal [file normalize [file home]] [file normalize $::env(HOME)]] \
|
||
[string equal $olduserhome [file normalize [file home $::tcl_platform(user)]]]
|
||
} -result {1 1}
|
||
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 notInCIenv} -body {
|
||
if {[string index $dir 0] eq [string index [lindex $drives 0] 0]} {
|
||
set path "[string range [lindex $drives 0] 0 1]foo"
|
||
cd [lindex $drives 1]
|
||
} else {
|
||
set path "[string range [lindex $drives 1] 0 1]foo"
|
||
cd [lindex $drives 0]
|
||
}
|
||
set path "[string range [lindex $drives 0] 0 1]foo"
|
||
string equal [file norm $path] [file join $dir foo]
|
||
} -cleanup {
|
||
cd $dir
|
||
unset -nocomplain path
|
||
} -result 1
|
||
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-1.52 {bug f9f390d0fa: file join where strep is not canonical} -body {
|
||
set x ///foo
|
||
file normalize $x
|
||
file join $x bar
|
||
} -result /foo/bar
|
||
test filesystem-1.52.1 {bug f9f390d0fa: file join where strep is not canonical} -body {
|
||
set x ///foo
|
||
file normalize $x
|
||
file join $x
|
||
} -result /foo
|
||
test filesystem-1.53 {[Bug 3559678] - normalize when tail is empty} {
|
||
string match */ [file normalize [lindex [glob -dir [pwd] {{}}] 0]]
|
||
} 0
|
||
test filesystem-1.54 {[Bug ce3a211dcb] - normalize when tail is empty} -setup {
|
||
set save [pwd]
|
||
cd [set home [makeDirectory ce3a211dcb]]
|
||
makeDirectory A $home
|
||
cd [lindex [glob */] 0]
|
||
} -body {
|
||
string match */A [pwd]
|
||
} -cleanup {
|
||
cd $home
|
||
removeDirectory A $home
|
||
cd $save
|
||
removeDirectory ce3a211dcb
|
||
} -result 1
|
||
|
||
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.
|
||
return ok
|
||
} ok
|
||
|
||
# Make sure the testfilesystem hasn't been registered.
|
||
if {[testConstraint testfilesystem]} {
|
||
proc resetfs {} {
|
||
while {![catch {testfilesystem 0}]} {}
|
||
}
|
||
}
|
||
|
||
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} -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 -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 *}*}
|
||
|
||
# This test is meaningless if there is no tilde expansion
|
||
test filesystem-5.1 {cache and ~} -constraints {
|
||
testfilesystem tildeexpansion
|
||
} -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
|
||
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.1 {load from vfs} -setup {
|
||
set dir [pwd]
|
||
} -constraints {win testsimplefilesystem loaddll} -body {
|
||
# This may cause a crash on exit
|
||
if {[file dirname $::ddelib] ne "."} {
|
||
cd [file dirname $::ddelib]
|
||
} else {
|
||
cd [file dirname [info nameofexecutable]]
|
||
}
|
||
if {![file exists [file tail $::ddelib]]} {
|
||
::tcltest::Skip "no-ddelib"
|
||
}
|
||
testsimplefilesystem 1
|
||
# This loads dde via a complex copy-to-temp operation
|
||
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
|
||
} -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
|
||
if {[file dirname $::reglib] ne "."} {
|
||
cd [file dirname $::reglib]
|
||
} else {
|
||
cd [file dirname [info nameofexecutable]]
|
||
}
|
||
if {![file exists [file tail $::reglib]]} {
|
||
::tcltest::Skip "no-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.
|
||
} -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]
|
||
lappend res [expr {$origtime == $newtime ? 1 : "$origtime != $newtime"}]
|
||
} -cleanup {
|
||
catch {file delete theCopy}
|
||
cd $dir
|
||
} -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 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 0
|
||
# 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 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 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 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} -setup {
|
||
set dir [pwd]
|
||
cd [tcltest::temporaryDirectory]
|
||
} -body {
|
||
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]
|
||
} -cleanup {
|
||
removeFile [file join abc foo]
|
||
removeDirectory abc
|
||
removeDirectory def
|
||
cd $dir
|
||
} -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
|
||
file exists [lindex [glob *] 0]
|
||
} -cleanup {
|
||
cd [tcltest::temporaryDirectory]
|
||
removeFile [file join abc foo]
|
||
removeDirectory abc
|
||
cd $origdir
|
||
} -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 {1 0 ~testNotExist ~testNotExist 1 0 ~testNotExist 0 ~testNotExist}
|
||
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 0 ~testNotExist 0 ~testNotExist}
|
||
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 1 0 1 1}
|
||
|
||
# ----------------------------------------------------------------------
|
||
|
||
test filesystem-10.1 {Bug 3414754} {
|
||
string match */ [file join [pwd] foo/]
|
||
} 0
|
||
|
||
# The filesystem-11.* tests are currently disabled on WSL because it is
|
||
# case-sensitivity depends on whether running on a Windows FS or Unix FS.
|
||
|
||
test filesystem-11.1 {
|
||
Bug 10890417 - case of tail is correct after normalization
|
||
} -constraints notWSL -body {
|
||
lmap file1 [glob $tempDir/mixedcase.file \
|
||
$tempDir/MIXEDCASE.FILE \
|
||
$tempDir/MixedCase.File \
|
||
] {
|
||
file normalize $file1
|
||
}
|
||
} -result [expr {
|
||
$caseSensitiveFS
|
||
? [list $tempDir/MixedCase.File]
|
||
: [lrepeat 3 $tempDir/MixedCase.File]
|
||
}]
|
||
|
||
test filesystem-11.2 {
|
||
Bug 10890417 - case of tail is correct after normalization (-directory)
|
||
} -constraints notWSL -body {
|
||
lmap file1 [glob -directory $tempDir \
|
||
mixedcase.file MIXEDCASE.FILE MixedCase.File ] {
|
||
file normalize $file1
|
||
}
|
||
} -result [expr {
|
||
$caseSensitiveFS
|
||
? [list [file join $tempDir MixedCase.File]]
|
||
: [lrepeat 3 [file join $tempDir MixedCase.File]]
|
||
}]
|
||
|
||
test filesystem-11.3 {
|
||
Bug 10890417 - case of dir is correct after normalization
|
||
} -constraints notWSL -body {
|
||
lmap file1 [glob \
|
||
$tempDir/mixedcase.dir/inside.file \
|
||
$tempDir/MIXEDCASE.DIR/INSIDE.FILE \
|
||
$tempDir/MixedCase.Dir/Inside.File] {
|
||
file tail [file dirname [file normalize $file1]]
|
||
}
|
||
} -result [expr {
|
||
$caseSensitiveFS ? [list MixedCase.Dir] :[lrepeat 3 MixedCase.Dir]
|
||
}]
|
||
|
||
test filesystem-11.4 {
|
||
Bug 10890417 - case of dir is correct after normalization (-directory)
|
||
} -constraints notWSL -body {
|
||
lmap file1 [concat \
|
||
[glob -dir $tempDir/mixedcase.dir inside.file] \
|
||
[glob -dir $tempDir/MIXEDCASE.DIR INSIDE.FILE] \
|
||
[glob -dir $tempDir/MixedCase.Dir Inside.File]] {
|
||
file tail [file dirname [file normalize $file1]]
|
||
}
|
||
} -result [expr {
|
||
$caseSensitiveFS ? [list MixedCase.Dir] :[lrepeat 3 MixedCase.Dir]
|
||
}]
|
||
|
||
test filesystem-12.1 {
|
||
Bug e6ca0b1b67 - glob inconsistency with wildcards
|
||
} -setup {
|
||
set dir [file dirname [makeFile "" qxyz]]
|
||
} -cleanup {
|
||
removeFile qxyz
|
||
unset -nocomplain dir
|
||
} -constraints notWSL -body {
|
||
# Note this does not test correctness of glob. Rather it ensures use of
|
||
# wildcards returns the entry or not, same as specifying the full name
|
||
# (i.e. f* and foo) irrespective of character case. Note the actual
|
||
# string value need not be the same as glob does not guarantee case
|
||
# on case-insensitive file systems.
|
||
# Assumes no other files that start with qx
|
||
list \
|
||
[string equal [string tolower [glob $dir/qx*]] \
|
||
[string tolower [glob $dir/qxyz]]] \
|
||
[string equal [string tolower [glob $dir/QX*]] \
|
||
[string tolower [glob $dir/QXYZ]]]
|
||
} -result {1 1}
|
||
|
||
#
|
||
# File normalization tests for mixed case scenarios
|
||
|
||
# Flushes the path internal representation, if any. There are potentially
|
||
# different code paths taken depending on whether there is an internal rep
|
||
# for the path. So test with both forms
|
||
# makeStringRep - string
|
||
# makePathRep - internal representation is path
|
||
proc makeStringRep path {
|
||
set path [string range $path 0 end]
|
||
if {[regexp {value is a path} [tcl::unsupported::representation $path]]} {
|
||
error "Could not flush internal representation of path"
|
||
}
|
||
return $path
|
||
}
|
||
proc makePathRep path {
|
||
file exists $path
|
||
if {![regexp {value is a path} [tcl::unsupported::representation $path]]} {
|
||
error "Could not generate internal representation of path"
|
||
}
|
||
return $path
|
||
}
|
||
|
||
proc testcasenormalize {id comment path actualPath args} {
|
||
variable caseSensitiveFS
|
||
if {$actualPath eq ""} {
|
||
# Path does not actually exist. Normalize should return original
|
||
set actualPath $path
|
||
}
|
||
# Test the actual path is correctly normalized
|
||
test $id.0 $comment -body {
|
||
list \
|
||
[file normalize [makeStringRep $actualPath]] \
|
||
[file normalize [makePathRep $actualPath]]
|
||
} -result [list $actualPath $actualPath] {*}$args
|
||
|
||
# Test the path with changed case is correctly normalized
|
||
test $id.1 $comment -body {
|
||
list \
|
||
[file normalize [makeStringRep $path]] \
|
||
[file normalize [makePathRep $path]]
|
||
} -result [expr {
|
||
$caseSensitiveFS
|
||
? [list $path $path]
|
||
: [list $actualPath $actualPath]
|
||
}] {*}$args
|
||
}
|
||
|
||
test filesystem-13.0 {
|
||
Normalize root component
|
||
} -body {file normalize $dirInRoot} -result $dirInRoot -constraints hasDirInRoot
|
||
|
||
|
||
testcasenormalize filesystem-13.1 {
|
||
Normalize root component
|
||
} $casedDirInRoot $dirInRoot -constraints hasDirInRoot
|
||
|
||
testcasenormalize filesystem-13.2 {
|
||
Normalize root component that is a link
|
||
} $casedLinkInRoot $linkInRoot -constraints hasLinkInRoot
|
||
|
||
testcasenormalize filesystem-13.3 {
|
||
Normalize non-existing root component
|
||
} ${dirInRoot}xyz "" -constraints hasDirInRoot
|
||
|
||
testcasenormalize filesystem-13.4 {
|
||
Normalize existing path
|
||
} $tempDir/mixedcase.file $tempDir/MixedCase.File
|
||
|
||
testcasenormalize filesystem-13.5 {
|
||
Normalize existing link
|
||
} $tempDir/mixedcaselink.file $tempDir/MixedCaseLink.File -constraints hasLinks
|
||
|
||
testcasenormalize filesystem-13.6 {
|
||
Normalize non-existing path
|
||
} $tempDir/nosuch.File $tempDir/nosuch.File
|
||
|
||
testcasenormalize filesystem-13.7 {
|
||
Normalize mixed case intermediate component
|
||
} $tempDir/mixedcase.dir/inside.file \
|
||
$tempDir/MixedCase.Dir/Inside.File
|
||
|
||
testcasenormalize filesystem-13.8 {
|
||
Normalize mixed case intermediate component
|
||
} $tempDir/mixedcase.dir/inside.file \
|
||
$tempDir/MixedCase.Dir/Inside.File
|
||
|
||
testcasenormalize filesystem-13.9 {
|
||
Normalize mixed case intermediate link
|
||
} $tempDir/mixedcaselink.dir/inside.file $tempDir/MixedCase.Dir/Inside.File \
|
||
-constraints {hasLinks notWSL}
|
||
|
||
test filesystem-13.10 {
|
||
Normalize relative leaf
|
||
} -body {
|
||
list [file normalize MixedCase.File] [file normalize mixedcase.file]
|
||
} -result [list $tempDir/MixedCase.File [expr {
|
||
$caseSensitiveFS
|
||
? "$tempDir/mixedcase.file"
|
||
: "$tempDir/MixedCase.File"
|
||
}]]
|
||
|
||
test filesystem-13.11 {
|
||
Normalize relative link
|
||
} -body {
|
||
list [file normalize MixedCaseLink.File] [file normalize mixedcaselink.file]
|
||
} -constraints {notWSL hasLinks} \
|
||
-result [list $tempDir/MixedCaseLink.File [expr {
|
||
$caseSensitiveFS
|
||
? "$tempDir/mixedcaselink.file"
|
||
: "$tempDir/MixedCaseLink.File"
|
||
}]]
|
||
|
||
test filesystem-13.12 {
|
||
Normalize relative directory
|
||
} -body {
|
||
list [file normalize MixedCase.Dir/Inside.File] \
|
||
[file normalize mixedcase.dir/inside.file]
|
||
} -result [list $tempDir/MixedCase.Dir/Inside.File [expr {
|
||
$caseSensitiveFS
|
||
? "$tempDir/mixedcase.dir/inside.file"
|
||
: "$tempDir/MixedCase.Dir/Inside.File"
|
||
}]]
|
||
|
||
file delete -force MixedCaseLink.Dir MixedCaseLink.File
|
||
|
||
cleanupTests
|
||
unset -nocomplain drive drives
|
||
}
|
||
namespace delete ::tcl::test::fileSystem
|
||
return
|
||
|
||
# Local Variables:
|
||
# mode: tcl
|
||
# End:
|