Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/fileSystem.test@260cb5ec6c19

     1 # This file tests the filesystem and vfs internals.

2 #

     3 # This file contains a collection of tests for one or more of the Tcl

     4 # built-in commands.  Sourcing this file into Tcl runs the tests and

     5 # generates output for errors.  No output means no errors were found.

6 #

     7 # Copyright (c) 2002 Vincent Darley.

8 #

     9 # See the file "license.terms" for information on usage and redistribution

    10 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.

    12 package require tcltest 2

    13 namespace eval ::tcl::test::fileSystem {

    15     catch {

    16 	namespace import ::tcltest::cleanupTests

    17 	namespace import ::tcltest::makeDirectory

    18 	namespace import ::tcltest::makeFile

    19 	namespace import ::tcltest::removeDirectory

    20 	namespace import ::tcltest::removeFile

    21 	namespace import ::tcltest::test

    22     }

    24     catch {

    25 	file delete -force link.file

    26 	file delete -force dir.link

    27 	file delete -force [file join dir.file linkinside.file]

    28     }

    30 cd [tcltest::temporaryDirectory]

    31 makeFile "test file" gorp.file

    32 makeDirectory dir.file

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

    35 if {[catch {

    36     file link link.file gorp.file

    37     file link \

    38       [file join dir.file linkinside.file] \

    39       [file join dir.file inside.file]

    40     file link dir.link dir.file

    41 }]} {

    42     tcltest::testConstraint hasLinks 0

    43 } else {

    44     tcltest::testConstraint hasLinks 1

    45 }

    47 tcltest::testConstraint testsimplefilesystem \

    48   [string equal testsimplefilesystem [info commands testsimplefilesystem]]

    50 test filesystem-1.0 {link normalisation} {hasLinks} {

    51    string equal [file normalize gorp.file] [file normalize link.file]

    52 } {0}

    54 test filesystem-1.1 {link normalisation} {hasLinks} {

    55    string equal [file normalize dir.file] [file normalize dir.link]

    56 } {0}

    58 test filesystem-1.2 {link normalisation} {hasLinks macOrUnix} {

    59    string equal [file normalize [file join gorp.file foo]] \

    60      [file normalize [file join link.file foo]]

    61 } {1}

    63 test filesystem-1.3 {link normalisation} {hasLinks} {

    64    string equal [file normalize [file join dir.file foo]] \

    65      [file normalize [file join dir.link foo]]

    66 } {1}

    68 test filesystem-1.4 {link normalisation} {hasLinks} {

    69    string equal [file normalize [file join dir.file inside.file]] \

    70      [file normalize [file join dir.link inside.file]]

    71 } {1}

    73 test filesystem-1.5 {link normalisation} {hasLinks} {

    74    string equal [file normalize [file join dir.file linkinside.file]] \

    75      [file normalize [file join dir.file linkinside.file]]

    76 } {1}

    78 test filesystem-1.6 {link normalisation} {hasLinks} {

    79    string equal [file normalize [file join dir.file linkinside.file]] \

    80      [file normalize [file join dir.link inside.file]]

    81 } {0}

    83 test filesystem-1.7 {link normalisation} {hasLinks macOrUnix} {

    84    string equal [file normalize [file join dir.link linkinside.file foo]] \

    85      [file normalize [file join dir.file inside.file foo]]

    86 } {1}

    88 test filesystem-1.8 {link normalisation} {hasLinks} {

    89    string equal [file normalize [file join dir.file linkinside.filefoo]] \

    90      [file normalize [file join dir.link inside.filefoo]]

    91 } {0}

    93 test filesystem-1.9 {link normalisation} {macOrUnix hasLinks} {

    94     file delete -force dir.link

    95     file link dir.link [file nativename dir.file]

    96     string equal [file normalize [file join dir.file linkinside.file foo]] \

    97       [file normalize [file join dir.link inside.file foo]]

    98 } {1}

   100 test filesystem-1.10 {link normalisation: double link} {macOrUnix hasLinks} {

   101     file link dir2.link dir.link

   102     string equal [file normalize [file join dir.file linkinside.file foo]] \

   103       [file normalize [file join dir2.link inside.file foo]]

   104 } {1}

   106 makeDirectory dir2.file

   108 test filesystem-1.11 {link normalisation: double link, back in tree} {macOrUnix hasLinks} {

   109     file link [file join dir2.file dir2.link] dir2.link

   110     string equal [file normalize [file join dir.file linkinside.file foo]] \

   111       [file normalize [file join dir2.file dir2.link inside.file foo]]

   112 } {1}

   114 test filesystem-1.12 {file new native path} {} {

   115     for {set i 0} {$i < 10} {incr i} {

   116 	foreach f [lsort [glob -nocomplain -type l *]] {

   117 	    catch {file readlink $f}

   118 	}

   119     }

   120     # If we reach here we've succeeded. We used to crash above.

   121     expr 1

   122 } {1}

   124 test filesystem-1.13 {file normalisation} {winOnly} {

   125     # This used to be broken

   126     file normalize C:/thislongnamedoesntexist

   127 } {C:/thislongnamedoesntexist}

   129 test filesystem-1.14 {file normalisation} {winOnly} {

   130     # This used to be broken

   131     file normalize c:/

   132 } {C:/}

   134 file delete -force dir2.file

   135 file delete -force dir2.link

   136 file delete -force link.file dir.link

   137 removeFile [file join dir.file inside.file]

   138 removeDirectory dir.file

   140 test filesystem-2.0 {new native path} {unixOnly} {

   141    foreach f [lsort [glob -nocomplain /usr/bin/c*]] {

   142        catch {file readlink $f}

   143    }

   144    # If we reach here we've succeeded. We used to crash above.

   145    expr 1

   146 } {1}

   148 if {[catch {package require tcltest 2}]} {

   149     puts stderr "Skipping tests filesystem-{3,4}.*: tcltest 2 required."

   150 } else {

   151     namespace import ::tcltest::testConstraint

   153     # Is the Tcltest package loaded?

   154     #   - that is, the special C-coded testing commands in tclTest.c

   155     #   - tests use testing commands introduced in Tcltest 8.4

   156     testConstraint Tcltest [expr {

   157         [llength [package provide Tcltest]]

   158         && [package vsatisfies [package provide Tcltest] 8.4]}]

   160 # Make sure the testfilesystem hasn't been registered.

   161 while {![catch {testfilesystem 0}]} {}

   163 test filesystem-3.0 {Tcl_FSRegister} Tcltest {

   164     testfilesystem 1

   165 } {registered}

   167 test filesystem-3.1 {Tcl_FSUnregister} Tcltest {

   168     testfilesystem 0

   169 } {unregistered}

   171 test filesystem-3.2 {Tcl_FSUnregister} Tcltest {

   172     list [catch {testfilesystem 0} err] $err

   173 } {1 failed}

   175 test filesystem-3.3 {Tcl_FSRegister} Tcltest {

   176     testfilesystem 1

   177     testfilesystem 1

   178     testfilesystem 0

   179     testfilesystem 0

   180 } {unregistered}

   182 test filesystem-3.4 {Tcl_FSRegister} Tcltest {

   183     testfilesystem 1

   184     file system bar

   185 } {reporting}

   187 test filesystem-3.5 {Tcl_FSUnregister} Tcltest {

   188     testfilesystem 0

   189     lindex [file system bar] 0

   190 } {native}

   192 test filesystem-4.0 {testfilesystem} {

   193     -constraints Tcltest

   194     -match glob

   195     -body {

   196 	testfilesystem 1

   197 	set filesystemReport {}

   198 	file exists foo

   199 	testfilesystem 0

   200 	set filesystemReport

   201     }

   202     -result {* {access foo}}

   203 }

   205 test filesystem-4.1 {testfilesystem} {

   206     -constraints Tcltest

   207     -match glob

   208     -body {

   209 	testfilesystem 1

   210 	set filesystemReport {}

   211 	catch {file stat foo bar}

   212 	testfilesystem 0

   213 	set filesystemReport

   214     }

   215     -result {* {stat foo}}

   216 }

   218 test filesystem-4.2 {testfilesystem} {

   219     -constraints Tcltest

   220     -match glob

   221     -body {

   222 	testfilesystem 1

   223 	set filesystemReport {}

   224 	catch {file lstat foo bar}

   225 	testfilesystem 0

   226 	set filesystemReport

   227     }

   228     -result {* {lstat foo}}

   229 }

   231 test filesystem-4.3 {testfilesystem} {

   232     -constraints Tcltest

   233     -match glob

   234     -body {

   235 	testfilesystem 1

   236 	set filesystemReport {}

   237 	catch {glob *}

   238 	testfilesystem 0

   239 	set filesystemReport

   240     }

   241     -result {* {matchindirectory *}*}

   242 }

   244 test filesystem-5.1 {cache and ~} {

   245     -constraints Tcltest

   246     -match regexp

   247     -body {

   248 	set orig $env(HOME)

   249 	set ::env(HOME) /foo/bar/blah

   250 	set testdir ~

   251 	set res1 "Parent of ~ (/foo/bar/blah) is [file dirname $testdir]"

   252 	set ::env(HOME) /a/b/c

   253 	set res2 "Parent of ~ (/a/b/c) is [file dirname $testdir]"

   254 	set ::env(HOME) $orig

   255 	list $res1 $res2

   256     }

   257     -result {{Parent of ~ \(/foo/bar/blah\) is (/foo/bar|foo:bar)} {Parent of ~ \(/a/b/c\) is (/a/b|a:b)}}

   258 }

   260 test filesystem-6.1 {empty file name} {

   261     list [catch {open ""} msg] $msg

   262 } {1 {couldn't open "": no such file or directory}}

   264 test filesystem-6.2 {empty file name} {

   265     list [catch {file stat "" arr} msg] $msg

   266 } {1 {could not read "": no such file or directory}}

   268 test filesystem-6.3 {empty file name} {

   269     list [catch {file atime ""} msg] $msg

   270 } {1 {could not read "": no such file or directory}}

   272 test filesystem-6.4 {empty file name} {

   273     list [catch {file attributes ""} msg] $msg

   274 } {1 {could not read "": no such file or directory}}

   276 test filesystem-6.5 {empty file name} {

   277     list [catch {file copy "" ""} msg] $msg

   278 } {1 {error copying "": no such file or directory}}

   280 test filesystem-6.6 {empty file name} {

   281     list [catch {file delete ""} msg] $msg

   282 } {0 {}}

   284 test filesystem-6.7 {empty file name} {

   285     list [catch {file dirname ""} msg] $msg

   286 } {0 .}

   288 test filesystem-6.8 {empty file name} {

   289     list [catch {file executable ""} msg] $msg

   290 } {0 0}

   292 test filesystem-6.9 {empty file name} {

   293     list [catch {file exists ""} msg] $msg

   294 } {0 0}

   296 test filesystem-6.10 {empty file name} {

   297     list [catch {file extension ""} msg] $msg

   298 } {0 {}}

   300 test filesystem-6.11 {empty file name} {

   301     list [catch {file isdirectory ""} msg] $msg

   302 } {0 0}

   304 test filesystem-6.12 {empty file name} {

   305     list [catch {file isfile ""} msg] $msg

   306 } {0 0}

   308 test filesystem-6.13 {empty file name} {

   309     list [catch {file join ""} msg] $msg

   310 } {0 {}}

   312 test filesystem-6.14 {empty file name} {

   313     list [catch {file link ""} msg] $msg

   314 } {1 {could not read link "": no such file or directory}}

   316 test filesystem-6.15 {empty file name} {

   317     list [catch {file lstat "" arr} msg] $msg

   318 } {1 {could not read "": no such file or directory}}

   320 test filesystem-6.16 {empty file name} {

   321     list [catch {file mtime ""} msg] $msg

   322 } {1 {could not read "": no such file or directory}}

   324 test filesystem-6.17 {empty file name} {

   325     list [catch {file mtime "" 0} msg] $msg

   326 } {1 {could not read "": no such file or directory}}

   328 test filesystem-6.18 {empty file name} {

   329     list [catch {file mkdir ""} msg] $msg

   330 } {1 {can't create directory "": no such file or directory}}

   332 test filesystem-6.19 {empty file name} {

   333     list [catch {file nativename ""} msg] $msg

   334 } {0 {}}

   336 test filesystem-6.20 {empty file name} {

   337     list [catch {file normalize ""} msg] $msg

   338 } {0 {}}

   340 test filesystem-6.21 {empty file name} {

   341     list [catch {file owned ""} msg] $msg

   342 } {0 0}

   344 test filesystem-6.22 {empty file name} {

   345     list [catch {file pathtype ""} msg] $msg

   346 } {0 relative}

   348 test filesystem-6.23 {empty file name} {

   349     list [catch {file readable ""} msg] $msg

   350 } {0 0}

   352 test filesystem-6.24 {empty file name} {

   353     list [catch {file readlink ""} msg] $msg

   354 } {1 {could not readlink "": no such file or directory}}

   356 test filesystem-6.25 {empty file name} {

   357     list [catch {file rename "" ""} msg] $msg

   358 } {1 {error renaming "": no such file or directory}}

   360 test filesystem-6.26 {empty file name} {

   361     list [catch {file rootname ""} msg] $msg

   362 } {0 {}}

   364 test filesystem-6.27 {empty file name} {

   365     list [catch {file separator ""} msg] $msg

   366 } {1 {Unrecognised path}}

   368 test filesystem-6.28 {empty file name} {

   369     list [catch {file size ""} msg] $msg

   370 } {1 {could not read "": no such file or directory}}

   372 test filesystem-6.29 {empty file name} {

   373     list [catch {file split ""} msg] $msg

   374 } {0 {}}

   376 test filesystem-6.30 {empty file name} {

   377     list [catch {file system ""} msg] $msg

   378 } {1 {Unrecognised path}}

   380 test filesystem-6.31 {empty file name} {

   381     list [catch {file tail ""} msg] $msg

   382 } {0 {}}

   384 test filesystem-6.32 {empty file name} {

   385     list [catch {file type ""} msg] $msg

   386 } {1 {could not read "": no such file or directory}}

   388 test filesystem-6.33 {empty file name} {

   389     list [catch {file writable ""} msg] $msg

   390 } {0 0}

   392 # Make sure the testfilesystem hasn't been registered.

   393 while {![catch {testfilesystem 0}]} {}

   394 }

   396 test filesystem-7.1 {load from vfs} {win testsimplefilesystem} {

   397     # This may cause a crash on exit

   398     set dir [pwd]

   399     cd [file dirname [info nameof]]

   400     set dde [lindex [glob *dde*[info sharedlib]] 0]

   401     testsimplefilesystem 1

   402     # This loads dde via a complex copy-to-temp operation

   403     load simplefs:/$dde dde

   404     testsimplefilesystem 0

   405     cd $dir

   406     set res "ok"

   407     # The real result of this test is what happens when Tcl exits.

   408 } {ok}

   410 test filesystem-7.2 {cross-filesystem copy from vfs maintains mtime} \

   411   {testsimplefilesystem} {

   412     set dir [pwd]

   413     cd [tcltest::temporaryDirectory]

   414     # We created this file several tests ago.

   415     set origtime [file mtime gorp.file]

   416     testsimplefilesystem 1

   417     file delete -force theCopy

   418     file copy simplefs:/gorp.file theCopy

   419     testsimplefilesystem 0

   420     set newtime [file mtime theCopy]

   421     file delete theCopy

   422     cd $dir

   423     expr {$origtime == $newtime}

   424 } {1}

   426 removeFile gorp.file

   428 test filesystem-8.1 {relative path objects and caching of pwd} {

   429     set dir [pwd]

   430     cd [tcltest::temporaryDirectory]

   431     makeDirectory abc

   432     makeDirectory def

   433     makeFile "contents" [file join abc foo]

   434     cd abc

   435     set f "foo"

   436     set res {}

   437     lappend res [file exists $f]

   438     lappend res [file exists $f]

   439     cd ..

   440     cd def

   441     # If we haven't cleared the object's cwd cache, Tcl

   442     # will think it still exists.

   443     lappend res [file exists $f]

   444     lappend res [file exists $f]

   445     removeFile [file join abc foo]

   446     removeDirectory abc

   447     removeDirectory def

   448     cd $dir

   449     set res

   450 } {1 1 0 0}

   452 test filesystem-8.2 {relative path objects and use of pwd} {

   453     set origdir [pwd]

   454     cd [tcltest::temporaryDirectory]

   455     set dir "abc"

   456     makeDirectory $dir

   457     makeFile "contents" [file join abc foo]

   458     cd $dir

   459     set res [file exists [lindex [glob *] 0]]

   460     cd ..

   461     removeFile [file join abc foo]

   462     removeDirectory abc

   463     cd $origdir

   464     set res

   465 } {1}

   467 test filesystem-8.3 {path objects and empty string} {

   468     set anchor ""

   469     set dst foo

   470     set res $dst

   472     set yyy [file split $anchor]

   473     set dst [file join  $anchor $dst]

   474     lappend res $dst $yyy

   475 } {foo foo {}}

   477 proc TestFind1 {d f} {

   478     set r1 [file exists [file join $d $f]]

   479     lappend res "[file join $d $f] found: $r1"

   480     lappend res "is dir a dir? [file isdirectory $d]"

   481     set r2 [file exists [file join $d $f]]

   482     lappend res "[file join $d $f] found: $r2"

   483     set res

   484 }

   485 proc TestFind2 {d f} {

   486     set r1 [file exists [file join $d $f]]

   487     lappend res "[file join $d $f] found: $r1"

   488     lappend res "is dir a dir? [file isdirectory [file join $d]]"

   489     set r2 [file exists [file join $d $f]]

   490     lappend res "[file join $d $f] found: $r2"

   491     set res

   492 }

   494 test filesystem-9.1 {path objects and join and object rep} {

   495     set origdir [pwd]

   496     cd [tcltest::temporaryDirectory]

   497     file mkdir [file join a b c]

   498     set res [TestFind1 a [file join b . c]]

   499     file delete -force a

   500     cd $origdir

   501     set res

   502 } {{a/b/./c found: 1} {is dir a dir? 1} {a/b/./c found: 1}}

   504 test filesystem-9.2 {path objects and join and object rep} {

   505     set origdir [pwd]

   506     cd [tcltest::temporaryDirectory]

   507     file mkdir [file join a b c]

   508     set res [TestFind2 a [file join b . c]]

   509     file delete -force a

   510     cd $origdir

   511     set res

   512 } {{a/b/./c found: 1} {is dir a dir? 1} {a/b/./c found: 1}}

   514 test filesystem-9.2.1 {path objects and join and object rep} {

   515     set origdir [pwd]

   516     cd [tcltest::temporaryDirectory]

   517     file mkdir [file join a b c]

   518     set res [TestFind2 a [file join b .]]

   519     file delete -force a

   520     cd $origdir

   521     set res

   522 } {{a/b/. found: 1} {is dir a dir? 1} {a/b/. found: 1}}

   524 test filesystem-9.3 {path objects and join and object rep} {

   525     set origdir [pwd]

   526     cd [tcltest::temporaryDirectory]

   527     file mkdir [file join a b c]

   528     set res [TestFind1 a [file join b .. b c]]

   529     file delete -force a

   530     cd $origdir

   531     set res

   532 } {{a/b/../b/c found: 1} {is dir a dir? 1} {a/b/../b/c found: 1}}

   534 test filesystem-9.4 {path objects and join and object rep} {

   535     set origdir [pwd]

   536     cd [tcltest::temporaryDirectory]

   537     file mkdir [file join a b c]

   538     set res [TestFind2 a [file join b .. b c]]

   539     file delete -force a

   540     cd $origdir

   541     set res

   542 } {{a/b/../b/c found: 1} {is dir a dir? 1} {a/b/../b/c found: 1}}

   544 test filesystem-9.5 {path objects and file tail and object rep} {

   545     set origdir [pwd]

   546     cd [tcltest::temporaryDirectory]

   547     file mkdir dgp

   548     close [open dgp/test w]

   549     foreach relative [glob -nocomplain [file join * test]] {

   550 	set absolute [file join [pwd] $relative]

   551 	set res [list [file tail $absolute] "test"]

   552     }

   553     file delete -force dgp

   554     cd $origdir

   555     set res

   556 } {test test}

   558 test filesystem-9.6 {path objects and file join and object rep} {winOnly} {

   559     set res {}

   560     set p "C:\\toto"

   561     lappend res [file join $p toto]

   562     file isdirectory $p

   563     lappend res [file join $p toto]

   564 } {C:/toto/toto C:/toto/toto}

   566 test filesystem-9.7 {path objects and glob and file tail and tilde} {

   567     set res {}

   568     set origdir [pwd]

   569     cd [tcltest::temporaryDirectory]

   570     file mkdir tilde

   571     close [open tilde/~testNotExist w]

   572     cd tilde

   573     set file [lindex [glob *test*] 0]

   574     lappend res [file exists $file] [catch {file tail $file} r] $r

   575     lappend res $file

   576     lappend res [file exists $file] [catch {file tail $file} r] $r

   577     lappend res [catch {file tail $file} r] $r

   578     cd ..

   579     file delete -force tilde

   580     cd $origdir

   581     set res

   582 } {0 1 {user "testNotExist" doesn't exist} ~testNotExist 0 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}}

   583 test filesystem-9.8 {path objects and glob and file tail and tilde} {

   584     set res {}

   585     set origdir [pwd]

   586     cd [tcltest::temporaryDirectory]

   587     file mkdir tilde

   588     close [open tilde/~testNotExist w]

   589     cd tilde

   590     set file1 [lindex [glob *test*] 0]

   591     set file2 "~testNotExist"

   592     lappend res $file1 $file2

   593     lappend res [catch {file tail $file1} r] $r

   594     lappend res [catch {file tail $file2} r] $r

   595     cd ..

   596     file delete -force tilde

   597     cd $origdir

   598     set res

   599 } {~testNotExist ~testNotExist 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}}

   600 test filesystem-9.9 {path objects and glob and file tail and tilde} {

   601     set res {}

   602     set origdir [pwd]

   603     cd [tcltest::temporaryDirectory]

   604     file mkdir tilde

   605     close [open tilde/~testNotExist w]

   606     cd tilde

   607     set file1 [lindex [glob *test*] 0]

   608     set file2 "~testNotExist"

   609     lappend res [catch {file exists $file1} r] $r

   610     lappend res [catch {file exists $file2} r] $r

   611     lappend res [string equal $file1 $file2]

   612     cd ..

   613     file delete -force tilde

   614     cd $origdir

   615     set res

   616 } {0 0 0 0 1}

   618 cleanupTests

   619 }

   620 namespace delete ::tcl::test::fileSystem

   621 return

author	sl
	Tue, 10 Jun 2014 14:32:02 +0200
changeset 1	260cb5ec6c19
permissions	-rw-r--r--