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
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.file linkinside.file]
    }

makeFile "test file" gorp.file
makeDirectory dir.file
makeFile "test file in directory" [file join dir.file inside.file]

if {[catch {
    testfilelink link.file gorp.file 
    testfilelink \
      [file join dir.file linkinside.file] \
      [file join dir.file inside.file]
    testfilelink dir.link dir.file
}]} {
    tcltest::testConstraint links 0
} else {
    tcltest::testConstraint links 1
}

test filesystem-1.0 {link normalisation} {links} {
   string equal [file normalize gorp.file] [file normalize link.file]
} {0}

test filesystem-1.1 {link normalisation} {links} {
   string equal [file normalize dir.file] [file normalize dir.link]
} {0}

test filesystem-1.2 {link normalisation} {links macOrUnix} {
   string equal [file normalize [file join gorp.file foo]] \
     [file normalize [file join link.file foo]]
} {1}

test filesystem-1.3 {link normalisation} {links} {
   string equal [file normalize [file join dir.file foo]] \
     [file normalize [file join dir.link foo]]
} {1}

test filesystem-1.4 {link normalisation} {links} {
   string equal [file normalize [file join dir.file inside.file]] \
     [file normalize [file join dir.link inside.file]]
} {1}

test filesystem-1.5 {link normalisation} {links} {
   string equal [file normalize [file join dir.file linkinside.file]] \
     [file normalize [file join dir.file linkinside.file]]
} {1}

test filesystem-1.6 {link normalisation} {links} {
   string equal [file normalize [file join dir.file linkinside.file]] \
     [file normalize [file join dir.link inside.file]]
} {0}

test filesystem-1.7 {link normalisation} {links macOrUnix} {
   string equal [file normalize [file join dir.link linkinside.file foo]] \
     [file normalize [file join dir.file inside.file foo]]
} {1}

test filesystem-1.8 {link normalisation} {links} {
   string equal [file normalize [file join dir.file linkinside.filefoo]] \
     [file normalize [file join dir.link inside.filefoo]]
} {0}

file delete -force link.file dir.link
removeFile [file join dir.file inside.file]
removeDirectory dir.file
removeFile gorp.file

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)}}
}
	
# Make sure the testfilesystem hasn't been registered.
while {![catch {testfilesystem 0}]} {}
}

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