path: root/tests/fileSystem.test

# 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]
    }

catch {
    ::tcltest::loadTestedCommands
    package require -exact Tcltest [info patchlevel]
    set ::ddelib [lindex [package ifneeded dde 1.4.0b1] 1]
    set ::reglib [lindex [package ifneeded registry 1.3.0] 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.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}

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 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]]
} 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} {unix hasLinks} {
    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]]
} ok
makeDirectory dir2.file
test filesystem-1.11 {link normalisation: double link, back in tree} {unix hasLinks} {
    file link [file join dir2.file dir2.link] [file join .. dir2.link]
    testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \
	[file normalize [file join dir2.file dir2.link inside.file foo]]
} 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} -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.
   return ok
} ok

# Make sure the testfilesystem hasn't been registered.
if {[testConstraint testfilesystem]} {
    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} testfilesystem {
    testfilesystem 1
    file system bar
} {reporting}
test filesystem-3.5 {Tcl_FSUnregister} testfilesystem {
    testfilesystem 0
    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 *}*}

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 readlink "": 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.
if {[testConstraint testfilesystem]} {
    while {![catch {testfilesystem 0}]} {}
}

test filesystem-7.1.1 {load from vfs} -setup {
    set dir [pwd]
} -constraints {win testsimplefilesystem} -body {
    # This may cause a crash on exit
    cd [file dirname [info nameof]]
    testsimplefilesystem 1
    # This loads dde via a complex copy-to-temp operation
    load simplefs:/$::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} -body {
    # This may cause a crash on exit
    cd [file dirname [info nameof]]
    testsimplefilesystem 1
    # This loads reg via a complex copy-to-temp operation
    load simplefs:/$::reglib Registry
    unload simplefs:/$::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 10 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 10 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 10 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 10 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} -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 {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: