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 {

    catch {
	namespace import ::tcltest::cleanupTests
	namespace import ::tcltest::makeDirectory
	namespace import ::tcltest::makeFile
	namespace import ::tcltest::removeDirectory
	namespace import ::tcltest::removeFile
	namespace import ::tcltest::test
    }
    
    catch {
	file delete -force link.file
	file delete -force dir.link
	file delete -force [file join dir.dir linkinside.file]
    }

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]

proc testPathEqual {one two} {
    if {[string equal $one $two]} {
	return 1
    } else {
	return "not equal: $one $two"
    }
}

if {[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 ..
}]} {
    tcltest::testConstraint hasLinks 0
} else {
    tcltest::testConstraint hasLinks 1
}

tcltest::testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]]
if {[tcltest::testConstraint testsetplatform]} {
    set platform [testgetplatform]
}

tcltest::testConstraint testsimplefilesystem \
  [string equal testsimplefilesystem [info commands testsimplefilesystem]]

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 macOrUnix} {
    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 macOrUnix} {
    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} {macOrUnix 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} {macOrUnix 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]]
} {1}

makeDirectory dir2.file

test filesystem-1.11 {link normalisation: double link, back in tree} {macOrUnix hasLinks} {
    file link [file join dir2.file dir2.link] [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} {winOnly} {
    # This used to be broken
    file normalize C:/thislongnamedoesntexist
} {C:/thislongnamedoesntexist}

test filesystem-1.14 {file normalisation} {winOnly} {
    # This used to be broken
    file normalize c:/
} {C:/}

test filesystem-1.15 {file normalisation} {winOnly} {
    file normalize c:/../
} {C:/}

test filesystem-1.16 {file normalisation} {winOnly} {
    file normalize c:/.
} {C:/}

test filesystem-1.17 {file normalisation} {winOnly} {
    file normalize c:/..
} {C:/}

test filesystem-1.17.1 {file normalisation} {winOnly} {
    file normalize c:\\..
} {C:/}

test filesystem-1.18 {file normalisation} {winOnly} {
    file normalize c:/./
} {C:/}

test filesystem-1.19 {file normalisation} {winOnly} {
    file normalize w:/./../../..
} {w:/}

test filesystem-1.20 {file normalisation} {winOnly} {
    file normalize //name/foo/../
} {//name/foo}

test filesystem-1.21 {file normalisation} {winOnly} {
    file normalize C:///foo/./
} {C:/foo}

test filesystem-1.22 {file normalisation} {winOnly} {
    file normalize //name/foo/.
} {//name/foo}

test filesystem-1.23 {file normalisation} {winOnly} {
    file normalize c:/./foo
} {C:/foo}

test filesystem-1.24 {file normalisation} {winOnly} {
    file normalize w:/./../../../a
} {w:/a}

test filesystem-1.25 {file normalisation} {winOnly} {
    file normalize w:/./.././../../a
} {w:/a}

test filesystem-1.25.1 {file normalisation} {winOnly} {
    file normalize w:/./.././..\\..\\a\\bb
} {w:/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
    file normalize C:/../bar
} {C:/bar}

if {[tcltest::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-2.0 {new native path} {unixOnly} {
   foreach f [lsort [glob -nocomplain /usr/bin/c*]] {
       catch {file readlink $f}
   }
   # If we reach here we've succeeded. We used to crash above.
   expr 1
} {1}

if {[catch {package require tcltest 2}]} {
    puts stderr "Skipping tests filesystem-{3,4}.*: tcltest 2 required."
} else {
    namespace import ::tcltest::testConstraint

    # Is the Tcltest package loaded?
    #   - that is, the special C-coded testing commands in tclTest.c
    #   - tests use testing commands introduced in Tcltest 8.4
    testConstraint Tcltest [expr {
        [llength [package provide Tcltest]]
        && [package vsatisfies [package provide Tcltest] 8.4]}]

# Make sure the testfilesystem hasn't been registered.
while {![catch {testfilesystem 0}]} {}

test filesystem-3.0 {Tcl_FSRegister} Tcltest {
    testfilesystem 1
} {registered}

test filesystem-3.1 {Tcl_FSUnregister} Tcltest {
    testfilesystem 0
} {unregistered}

test filesystem-3.2 {Tcl_FSUnregister} Tcltest {
    list [catch {testfilesystem 0} err] $err
} {1 failed}

test filesystem-3.3 {Tcl_FSRegister} Tcltest {
    testfilesystem 1
    testfilesystem 1
    testfilesystem 0
    testfilesystem 0
} {unregistered}

test filesystem-3.4 {Tcl_FSRegister} Tcltest {
    testfilesystem 1
    file system bar
} {reporting}

test filesystem-3.5 {Tcl_FSUnregister} Tcltest {
    testfilesystem 0
    lindex [file system bar] 0
} {native}

test filesystem-4.0 {testfilesystem} {
    -constraints Tcltest
    -match glob
    -body {
	testfilesystem 1
	set filesystemReport {}
	file exists foo
	testfilesystem 0
	set filesystemReport
    }
    -result {*{access foo}}
}

test filesystem-4.1 {testfilesystem} {
    -constraints Tcltest
    -match glob
    -body {
	testfilesystem 1
	set filesystemReport {}
	catch {file stat foo bar}
	testfilesystem 0
	set filesystemReport
    }
    -result {*{stat foo}}
}

test filesystem-4.2 {testfilesystem} {
    -constraints Tcltest
    -match glob
    -body {
	testfilesystem 1
	set filesystemReport {}
	catch {file lstat foo bar}
	testfilesystem 0
	set filesystemReport
    }
    -result {*{lstat foo}}
}

test filesystem-4.3 {testfilesystem} {
    -constraints Tcltest
    -match glob
    -body {
	testfilesystem 1
	set filesystemReport {}
	catch {glob *}
	testfilesystem 0
	set filesystemReport
    }
    -result {*{matchindirectory *}*}
}

test filesystem-5.1 {cache and ~} {
    -constraints Tcltest
    -match regexp
    -body {
	set orig $env(HOME)
	set ::env(HOME) /foo/bar/blah
	set testdir ~
	set res1 "Parent of ~ (/foo/bar/blah) is [file dirname $testdir]"
	set ::env(HOME) /a/b/c
	set res2 "Parent of ~ (/a/b/c) is [file dirname $testdir]"
	set ::env(HOME) $orig
	list $res1 $res2
    }
    -result {{Parent of ~ \(/foo/bar/blah\) is (/foo/bar|foo:bar)} {Parent of ~ \(/a/b/c\) is (/a/b|a:b)}}
}

test filesystem-6.1 {empty file name} {
    list [catch {open ""} msg] $msg
} {1 {couldn't open "": no such file or directory}}

test filesystem-6.2 {empty file name} {
    list [catch {file stat "" arr} msg] $msg
} {1 {could not read "": no such file or directory}}

test filesystem-6.3 {empty file name} {
    list [catch {file atime ""} msg] $msg
} {1 {could not read "": no such file or directory}}

test filesystem-6.4 {empty file name} {
    list [catch {file attributes ""} msg] $msg
} {1 {could not read "": no such file or directory}}

test filesystem-6.5 {empty file name} {
    list [catch {file copy "" ""} msg] $msg
} {1 {error copying "": no such file or directory}}

test filesystem-6.6 {empty file name} {
    list [catch {file delete ""} msg] $msg
} {0 {}}

test filesystem-6.7 {empty file name} {
    list [catch {file dirname ""} msg] $msg
} {0 .}

test filesystem-6.8 {empty file name} {
    list [catch {file executable ""} msg] $msg
} {0 0}

test filesystem-6.9 {empty file name} {
    list [catch {file exists ""} msg] $msg
} {0 0}

test filesystem-6.10 {empty file name} {
    list [catch {file extension ""} msg] $msg
} {0 {}}

test filesystem-6.11 {empty file name} {
    list [catch {file isdirectory ""} msg] $msg
} {0 0}

test filesystem-6.12 {empty file name} {
    list [catch {file isfile ""} msg] $msg
} {0 0}

test filesystem-6.13 {empty file name} {
    list [catch {file join ""} msg] $msg
} {0 {}}

test filesystem-6.14 {empty file name} {
    list [catch {file link ""} msg] $msg
} {1 {could not read link "": no such file or directory}}

test filesystem-6.15 {empty file name} {
    list [catch {file lstat "" arr} msg] $msg
} {1 {could not read "": no such file or directory}}

test filesystem-6.16 {empty file name} {
    list [catch {file mtime ""} msg] $msg
} {1 {could not read "": no such file or directory}}

test filesystem-6.17 {empty file name} {
    list [catch {file mtime "" 0} msg] $msg
} {1 {could not read "": no such file or directory}}

test filesystem-6.18 {empty file name} {
    list [catch {file mkdir ""} msg] $msg
} {1 {can't create directory "": no such file or directory}}

test filesystem-6.19 {empty file name} {
    list [catch {file nativename ""} msg] $msg
} {0 {}}

test filesystem-6.20 {empty file name} {
    list [catch {file normalize ""} msg] $msg
} {0 {}}

test filesystem-6.21 {empty file name} {
    list [catch {file owned ""} msg] $msg
} {0 0}

test filesystem-6.22 {empty file name} {
    list [catch {file pathtype ""} msg] $msg
} {0 relative}

test filesystem-6.23 {empty file name} {
    list [catch {file readable ""} msg] $msg
} {0 0}

test filesystem-6.24 {empty file name} {
    list [catch {file readlink ""} msg] $msg
} {1 {could not readlink "": no such file or directory}}

test filesystem-6.25 {empty file name} {
    list [catch {file rename "" ""} msg] $msg
} {1 {error renaming "": no such file or directory}}

test filesystem-6.26 {empty file name} {
    list [catch {file rootname ""} msg] $msg
} {0 {}}

test filesystem-6.27 {empty file name} {
    list [catch {file separator ""} msg] $msg
} {1 {Unrecognised path}}

test filesystem-6.28 {empty file name} {
    list [catch {file size ""} msg] $msg
} {1 {could not read "": no such file or directory}}

test filesystem-6.29 {empty file name} {
    list [catch {file split ""} msg] $msg
} {0 {}}

test filesystem-6.30 {empty file name} {
    list [catch {file system ""} msg] $msg
} {1 {Unrecognised path}}

test filesystem-6.31 {empty file name} {
    list [catch {file tail ""} msg] $msg
} {0 {}}

test filesystem-6.32 {empty file name} {
    list [catch {file type ""} msg] $msg
} {1 {could not read "": no such file or directory}}

test filesystem-6.33 {empty file name} {
    list [catch {file writable ""} msg] $msg
} {0 0}

# Make sure the testfilesystem hasn't been registered.
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]
    testsimplefilesystem 1
    file delete -force theCopy
    file copy simplefs:/gorp.file theCopy
    testsimplefilesystem 0
    set newtime [file mtime theCopy]
    file delete theCopy
    cd $dir
    expr {$origtime == $newtime}
} {1}

removeFile gorp.file

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 {}}

cleanupTests
}
namespace delete ::tcl::test::fileSystem
return