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 built-in 4# commands. Sourcing this file into Tcl runs the tests and generates output 5# for errors. No output means no errors were found. 6# 7# Copyright © 2002 Vincent Darley. 8# 9# See the file "license.terms" for information on usage and redistribution of 10# this file, and for a DISCLAIMER OF ALL WARRANTIES. 11 12namespace eval ::tcl::test::fileSystem { 13 14 if {"::tcltest" ni [namespace children]} { 15 package require tcltest 2.5 16 namespace import -force ::tcltest::* 17 } 18 19 catch { 20 file delete -force link.file 21 file delete -force dir.link 22 file delete -force [file join dir.dir linkinside.file] 23 } 24 25testConstraint loaddll 0 26catch { 27 ::tcltest::loadTestedCommands 28 package require -exact tcl::test [info patchlevel] 29 set ::ddever [package require dde] 30 set ::ddelib [info loaded {} Dde] 31 set ::regver [package require registry] 32 set ::reglib [info loaded {} Registry] 33 testConstraint loaddll [expr {$::ddelib ne "" && $::reglib ne ""}] 34} 35 36# Test for commands defined in tcl::test package 37testConstraint testfilesystem [llength [info commands ::testfilesystem]] 38testConstraint testsetplatform [llength [info commands ::testsetplatform]] 39testConstraint testsimplefilesystem [llength [info commands ::testsimplefilesystem]] 40# Some things fail under all Continuous Integration systems for subtle reasons 41# such as CI often running with elevated privileges in a container. 42testConstraint notInCIenv [expr {![info exists ::env(CI)]}] 43 44cd [tcltest::temporaryDirectory] 45makeFile "test file" gorp.file 46makeDirectory dir.dir 47makeDirectory [file join dir.dir dirinside.dir] 48makeFile "test file in directory" [file join dir.dir inside.file] 49 50testConstraint unusedDrive 0 51testConstraint moreThanOneDrive 0 52apply {{} { 53 # The variables 'drive' and 'drives' will be used below. 54 variable drive {} drives {} 55 if {[testConstraint win]} { 56 set vols [string map [list :/ {}] [file volumes]] 57 for {set i 0} {$i < 26} {incr i} { 58 set drive [format %c [expr {$i + 65}]] 59 if {$drive ni $vols} { 60 testConstraint unusedDrive 1 61 break 62 } 63 } 64 65 set dir [pwd] 66 try { 67 foreach vol [file volumes] { 68 if {![catch {cd $vol}]} { 69 lappend drives $vol 70 } 71 } 72 testConstraint moreThanOneDrive [llength $drives] 73 } finally { 74 cd $dir 75 } 76 } 77} ::tcl::test::fileSystem} 78 79proc testPathEqual {one two} { 80 if {$one eq $two} { 81 return "ok" 82 } 83 return "not equal: $one $two" 84} 85 86testConstraint hasLinks [expr {![catch { 87 file link link.file gorp.file 88 cd dir.dir 89 file link \ 90 [file join linkinside.file] \ 91 [file join inside.file] 92 cd .. 93 file link dir.link dir.dir 94 cd dir.dir 95 file link [file join dirinside.link] \ 96 [file join dirinside.dir] 97 cd .. 98}]}] 99 100if {[testConstraint testsetplatform]} { 101 set platform [testgetplatform] 102} 103 104# ---------------------------------------------------------------------- 105 106test filesystem-1.0 {link normalisation} {hasLinks} { 107 string equal [file normalize gorp.file] [file normalize link.file] 108} {0} 109test filesystem-1.1 {link normalisation} {hasLinks} { 110 string equal [file normalize dir.dir] [file normalize dir.link] 111} {0} 112test filesystem-1.2 {link normalisation} {hasLinks unix} { 113 testPathEqual [file normalize [file join gorp.file foo]] \ 114 [file normalize [file join link.file foo]] 115} ok 116test filesystem-1.3 {link normalisation} {hasLinks} { 117 testPathEqual [file normalize [file join dir.dir foo]] \ 118 [file normalize [file join dir.link foo]] 119} ok 120test filesystem-1.4 {link normalisation} {hasLinks} { 121 testPathEqual [file normalize [file join dir.dir inside.file]] \ 122 [file normalize [file join dir.link inside.file]] 123} ok 124test filesystem-1.5 {link normalisation} {hasLinks} { 125 testPathEqual [file normalize [file join dir.dir linkinside.file]] \ 126 [file normalize [file join dir.dir linkinside.file]] 127} ok 128test filesystem-1.6 {link normalisation} {hasLinks} { 129 string equal [file normalize [file join dir.dir linkinside.file]] \ 130 [file normalize [file join dir.link inside.file]] 131} {0} 132test filesystem-1.7 {link normalisation} {hasLinks unix} { 133 testPathEqual [file normalize [file join dir.link linkinside.file foo]] \ 134 [file normalize [file join dir.dir inside.file foo]] 135} ok 136test filesystem-1.8 {link normalisation} {hasLinks} { 137 string equal [file normalize [file join dir.dir linkinside.filefoo]] \ 138 [file normalize [file join dir.link inside.filefoo]] 139} {0} 140test filesystem-1.9 {link normalisation} -setup { 141 file delete -force dir.link 142} -constraints {unix hasLinks} -body { 143 file link dir.link [file nativename dir.dir] 144 testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \ 145 [file normalize [file join dir.link inside.file foo]] 146} -result ok 147test filesystem-1.10 {link normalisation: double link} -constraints { 148 unix hasLinks 149} -body { 150 file link dir2.link dir.link 151 testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \ 152 [file normalize [file join dir2.link inside.file foo]] 153} -cleanup { 154 file delete dir2.link 155} -result ok 156makeDirectory dir2.file 157test filesystem-1.11 {link normalisation: double link, back in tree} {unix hasLinks} { 158 file link dir2.link dir.link 159 file link [file join dir2.file dir2.link] [file join .. dir2.link] 160 testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \ 161 [file normalize [file join dir2.file dir2.link inside.file foo]] 162} ok 163test filesystem-1.12 {file new native path} {} { 164 for {set i 0} {$i < 10} {incr i} { 165 foreach f [lsort [glob -nocomplain -type l *]] { 166 catch {file readlink $f} 167 } 168 } 169 # If we reach here we've succeeded. We used to crash above. 170 expr {1} 171} {1} 172test filesystem-1.13 {file normalisation} {win} { 173 # This used to be broken 174 file normalize C:/thislongnamedoesntexist 175} {C:/thislongnamedoesntexist} 176test filesystem-1.14 {file normalisation} {win} { 177 # This used to be broken 178 file normalize c:/ 179} {C:/} 180test filesystem-1.15 {file normalisation} {win} { 181 file normalize c:/../ 182} {C:/} 183test filesystem-1.16 {file normalisation} {win} { 184 file normalize c:/. 185} {C:/} 186test filesystem-1.17 {file normalisation} {win} { 187 file normalize c:/.. 188} {C:/} 189test filesystem-1.17.1 {file normalisation} {win} { 190 file normalize c:\\.. 191} {C:/} 192test filesystem-1.18 {file normalisation} {win} { 193 file normalize c:/./ 194} {C:/} 195test filesystem-1.19 {file normalisation} {win unusedDrive} { 196 file normalize ${drive}:/./../../.. 197} "${drive}:/" 198test filesystem-1.20 {file normalisation} {win} { 199 file normalize //name/foo/../ 200} {//name/foo} 201test filesystem-1.21 {file normalisation} {win} { 202 file normalize C:///foo/./ 203} {C:/foo} 204test filesystem-1.22 {file normalisation} {win} { 205 file normalize //name/foo/. 206} {//name/foo} 207test filesystem-1.23 {file normalisation} {win} { 208 file normalize c:/./foo 209} {C:/foo} 210test filesystem-1.24 {file normalisation} {win unusedDrive} { 211 file normalize ${drive}:/./../../../a 212} "${drive}:/a" 213test filesystem-1.25 {file normalisation} {win unusedDrive} { 214 file normalize ${drive}:/./.././../../a 215} "${drive}:/a" 216test filesystem-1.25.1 {file normalisation} {win unusedDrive} { 217 file normalize ${drive}:/./.././..\\..\\a\\bb 218} "${drive}:/a/bb" 219test filesystem-1.26 {link normalisation: link and ..} -setup { 220 file delete -force dir2.link 221} -constraints {hasLinks} -body { 222 set dir [file join dir2 foo bar] 223 file mkdir $dir 224 file link dir2.link [file join dir2 foo bar] 225 testPathEqual [file normalize [file join dir2 foo x]] \ 226 [file normalize [file join dir2.link .. x]] 227} -result ok 228test filesystem-1.27 {file normalisation: up and down with ..} { 229 set dir [file join dir2 foo bar] 230 file mkdir $dir 231 set dir2 [file join dir2 .. dir2 foo .. foo bar] 232 list [testPathEqual [file normalize $dir] [file normalize $dir2]] \ 233 [file exists $dir] [file exists $dir2] 234} {ok 1 1} 235test filesystem-1.28 {link normalisation: link with .. and ..} -setup { 236 file delete -force dir2.link 237} -constraints {hasLinks} -body { 238 set dir [file join dir2 foo bar] 239 file mkdir $dir 240 set to [file join dir2 .. dir2 foo .. foo bar] 241 file link dir2.link $to 242 testPathEqual [file normalize [file join dir2 foo x]] \ 243 [file normalize [file join dir2.link .. x]] 244} -result ok 245test filesystem-1.29 {link normalisation: link with ..} -setup { 246 file delete -force dir2.link 247} -constraints {hasLinks} -body { 248 set dir [file join dir2 foo bar] 249 file mkdir $dir 250 set to [file join dir2 .. dir2 foo .. foo bar] 251 file link dir2.link $to 252 set res [file normalize [file join dir2.link x yyy z]] 253 if {[string match *..* $res]} { 254 return "$res must not contain '..'" 255 } 256 return "ok" 257} -result {ok} 258test filesystem-1.29.1 {link normalisation with two consecutive links} {hasLinks} { 259 testPathEqual [file normalize [file join dir.link dirinside.link abc]] \ 260 [file normalize [file join dir.dir dirinside.dir abc]] 261} ok 262file delete -force dir2.file 263file delete -force dir2.link 264file delete -force link.file dir.link 265file delete -force dir2 266file delete -force [file join dir.dir dirinside.link] 267removeFile [file join dir.dir inside.file] 268removeDirectory [file join dir.dir dirinside.dir] 269removeDirectory dir.dir 270test filesystem-1.30 {normalisation of nonexistent user} -body { 271 file normalize ~noonewiththisname 272} -returnCodes error -result {user "noonewiththisname" doesn't exist} 273test filesystem-1.30.1 {normalisation of existing user} -body { 274 catch {file normalize ~$::tcl_platform(user)} 275} -result {0} 276test filesystem-1.30.2 {normalisation of nonexistent user specified as user@domain} -body { 277 file normalize ~nonexistentuser@nonexistentdomain 278} -returnCodes error -result {user "nonexistentuser@nonexistentdomain" doesn't exist} 279test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} { 280 testsetplatform unix 281 file normalize /foo/../bar 282} {/bar} 283test filesystem-1.32 {link normalisation: link near filesystem root} {testsetplatform} { 284 testsetplatform unix 285 file normalize /../bar 286} {/bar} 287test filesystem-1.33 {link normalisation: link near filesystem root} {testsetplatform} { 288 testsetplatform windows 289 set res [file normalize C:/../bar] 290 if {[testConstraint unix]} { 291 # Some unices go further in normalizing this -- not really a problem 292 # since this is a Windows test. 293 regexp {C:/bar$} $res res 294 } 295 set res 296} {C:/bar} 297if {[testConstraint testsetplatform]} { 298 testsetplatform $platform 299} 300test filesystem-1.34 {file normalisation with '/./'} -body { 301 file normalize /foo/bar/anc/./.tml 302} -match regexp -result {^(?:(?!/\./).)*$} 303test filesystem-1.35a {file normalisation with '/./'} -body { 304 file normalize /ffo/bar/anc/./foo/.tml 305} -match regexp -result {^(?:(?!/\./).)*$} 306test filesystem-1.35b {file normalisation with '/./'} { 307 llength [regexp -all foo [file normalize /ffo/bar/anc/./foo/.tml]] 308} 1 309test filesystem-1.36a {file normalisation with '/./'} -body { 310 file normalize /foo/bar/anc/././asdasd/.tml 311} -match regexp -result {^(?:(?!/\./).)*$} 312test filesystem-1.36b {file normalisation with '/./'} { 313 llength [regexp -all asdasd [file normalize /foo/bar/anc/././asdasd/.tml]] 314} 1 315test filesystem-1.37 {file normalisation with '/./'} -body { 316 set fname "/abc/./def/./ghi/./asda/.././.././asd/x/../../../../....." 317 file norm $fname 318} -match regexp -result {^(?:[^/]|/(?:[^/]|$))+$} 319test filesystem-1.38 {file normalisation with volume relative} -setup { 320 set dir [pwd] 321} -constraints {win moreThanOneDrive notInCIenv} -body { 322 set path "[string range [lindex $drives 0] 0 1]foo" 323 cd [lindex $drives 1] 324 file norm $path 325} -cleanup { 326 cd $dir 327} -result "[lindex $drives 0]foo" 328test filesystem-1.39 {file normalisation with volume relative} -setup { 329 set old [pwd] 330} -constraints {win} -body { 331 set drv C:/ 332 cd [lindex [glob -type d -dir $drv *] 0] 333 file norm [string range $drv 0 1] 334} -cleanup { 335 cd $old 336} -match regexp -result {.*[^/]} 337test filesystem-1.40 {file normalisation with repeated separators} { 338 testPathEqual [file norm foo////bar] [file norm foo/bar] 339} ok 340test filesystem-1.41 {file normalisation with repeated separators} {win} { 341 testPathEqual [file norm foo\\\\\\bar] [file norm foo/bar] 342} ok 343test filesystem-1.42 {file normalisation .. beyond root (Bug 1379287)} { 344 testPathEqual [file norm /xxx/..] [file norm /] 345} ok 346test filesystem-1.42.1 {file normalisation .. beyond root (Bug 1379287)} { 347 testPathEqual [file norm /xxx/../] [file norm /] 348} ok 349test filesystem-1.43 {file normalisation .. beyond root (Bug 1379287)} { 350 testPathEqual [file norm /xxx/foo/../..] [file norm /] 351} ok 352test filesystem-1.43.1 {file normalisation .. beyond root (Bug 1379287)} { 353 testPathEqual [file norm /xxx/foo/../../] [file norm /] 354} ok 355test filesystem-1.44 {file normalisation .. beyond root (Bug 1379287)} { 356 testPathEqual [file norm /xxx/foo/../../bar] [file norm /bar] 357} ok 358test filesystem-1.45 {file normalisation .. beyond root (Bug 1379287)} { 359 testPathEqual [file norm /xxx/../../bar] [file norm /bar] 360} ok 361test filesystem-1.46 {file normalisation .. beyond root (Bug 1379287)} { 362 testPathEqual [file norm /xxx/../bar] [file norm /bar] 363} ok 364test filesystem-1.47 {file normalisation .. beyond root (Bug 1379287)} { 365 testPathEqual [file norm /..] [file norm /] 366} ok 367test filesystem-1.48 {file normalisation .. beyond root (Bug 1379287)} { 368 testPathEqual [file norm /../] [file norm /] 369} ok 370test filesystem-1.49 {file normalisation .. beyond root (Bug 1379287)} { 371 testPathEqual [file norm /.] [file norm /] 372} ok 373test filesystem-1.50 {file normalisation .. beyond root (Bug 1379287)} { 374 testPathEqual [file norm /./] [file norm /] 375} ok 376test filesystem-1.51 {file normalisation .. beyond root (Bug 1379287)} { 377 testPathEqual [file norm /../..] [file norm /] 378} ok 379test filesystem-1.51.1 {file normalisation .. beyond root (Bug 1379287)} { 380 testPathEqual [file norm /../../] [file norm /] 381} ok 382test filesystem-1.52 {bug f9f390d0fa: file join where strep is not canonical} -constraints unix -body { 383 set x //foo 384 file normalize $x 385 file join $x bar 386} -result /foo/bar 387test filesystem-1.52.1 {bug f9f390d0fa: file join where strep is not canonical} -body { 388 set x //foo 389 file normalize $x 390 file join $x 391} -result /foo 392test filesystem-1.53 {[Bug 3559678] - normalize when tail is empty} { 393 string match */ [file normalize [lindex [glob -dir [pwd] {{}}] 0]] 394} 0 395test filesystem-1.54 {[Bug ce3a211dcb] - normalize when tail is empty} -setup { 396 set save [pwd] 397 cd [set home [makeDirectory ce3a211dcb]] 398 makeDirectory A $home 399 cd [lindex [glob */] 0] 400} -body { 401 string match */A [pwd] 402} -cleanup { 403 cd $home 404 removeDirectory A $home 405 cd $save 406 removeDirectory ce3a211dcb 407} -result 1 408 409test filesystem-2.0 {new native path} {unix} { 410 foreach f [lsort [glob -nocomplain /usr/bin/c*]] { 411 catch {file readlink $f} 412 } 413 # If we reach here we've succeeded. We used to crash above. 414 return ok 415} ok 416 417# Make sure the testfilesystem hasn't been registered. 418if {[testConstraint testfilesystem]} { 419 proc resetfs {} { 420 while {![catch {testfilesystem 0}]} {} 421 } 422} 423 424test filesystem-3.1 {Tcl_FSRegister & Tcl_FSUnregister} testfilesystem { 425 set result {} 426 lappend result [testfilesystem 1] 427 lappend result [testfilesystem 0] 428 lappend result [catch {testfilesystem 0} msg] $msg 429} {registered unregistered 1 failed} 430test filesystem-3.3 {Tcl_FSRegister} testfilesystem { 431 testfilesystem 1 432 testfilesystem 1 433 testfilesystem 0 434 testfilesystem 0 435} {unregistered} 436test filesystem-3.4 {Tcl_FSRegister} -constraints testfilesystem -body { 437 testfilesystem 1 438 file system bar 439} -cleanup { 440 testfilesystem 0 441} -result {reporting} 442test filesystem-3.5 {Tcl_FSUnregister} testfilesystem { 443 resetfs 444 lindex [file system bar] 0 445} {native} 446 447test filesystem-4.0 {testfilesystem} -constraints testfilesystem -body { 448 testfilesystem 1 449 set filesystemReport {} 450 file exists foo 451 testfilesystem 0 452 return $filesystemReport 453} -match glob -result {*{access foo}} 454test filesystem-4.1 {testfilesystem} -constraints testfilesystem -body { 455 testfilesystem 1 456 set filesystemReport {} 457 catch {file stat foo bar} 458 testfilesystem 0 459 return $filesystemReport 460} -match glob -result {*{stat foo}} 461test filesystem-4.2 {testfilesystem} -constraints testfilesystem -body { 462 testfilesystem 1 463 set filesystemReport {} 464 catch {file lstat foo bar} 465 testfilesystem 0 466 return $filesystemReport 467} -match glob -result {*{lstat foo}} 468test filesystem-4.3 {testfilesystem} -constraints testfilesystem -body { 469 testfilesystem 1 470 set filesystemReport {} 471 catch {glob *} 472 testfilesystem 0 473 return $filesystemReport 474} -match glob -result {*{matchindirectory *}*} 475 476test filesystem-5.1 {cache and ~} -constraints testfilesystem -setup { 477 set orig $::env(HOME) 478} -body { 479 set ::env(HOME) /foo/bar/blah 480 set testdir ~ 481 set res1 "Parent of ~ (/foo/bar/blah) is [file dirname $testdir]" 482 set ::env(HOME) /a/b/c 483 set res2 "Parent of ~ (/a/b/c) is [file dirname $testdir]" 484 list $res1 $res2 485} -cleanup { 486 set ::env(HOME) $orig 487} -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)}} 488 489test filesystem-6.1 {empty file name} -returnCodes error -body { 490 open "" 491} -result {couldn't open "": no such file or directory} 492test filesystem-6.2 {empty file name} -returnCodes error -body { 493 file stat "" arr 494} -result {could not read "": no such file or directory} 495test filesystem-6.3 {empty file name} -returnCodes error -body { 496 file atime "" 497} -result {could not read "": no such file or directory} 498test filesystem-6.4 {empty file name} -returnCodes error -body { 499 file attributes "" 500} -result {could not read "": no such file or directory} 501test filesystem-6.5 {empty file name} -returnCodes error -body { 502 file copy "" "" 503} -result {error copying "": no such file or directory} 504test filesystem-6.6 {empty file name} {file delete ""} {} 505test filesystem-6.7 {empty file name} {file dirname ""} . 506test filesystem-6.8 {empty file name} {file executable ""} 0 507test filesystem-6.9 {empty file name} {file exists ""} 0 508test filesystem-6.10 {empty file name} {file extension ""} {} 509test filesystem-6.11 {empty file name} {file isdirectory ""} 0 510test filesystem-6.12 {empty file name} {file isfile ""} 0 511test filesystem-6.13 {empty file name} {file join ""} {} 512test filesystem-6.14 {empty file name} -returnCodes error -body { 513 file link "" 514} -result {could not read link "": no such file or directory} 515test filesystem-6.15 {empty file name} -returnCodes error -body { 516 file lstat "" arr 517} -result {could not read "": no such file or directory} 518test filesystem-6.16 {empty file name} -returnCodes error -body { 519 file mtime "" 520} -result {could not read "": no such file or directory} 521test filesystem-6.17 {empty file name} -returnCodes error -body { 522 file mtime "" 0 523} -result {could not read "": no such file or directory} 524test filesystem-6.18 {empty file name} -returnCodes error -body { 525 file mkdir "" 526} -result {can't create directory "": no such file or directory} 527test filesystem-6.19 {empty file name} {file nativename ""} {} 528test filesystem-6.20 {empty file name} {file normalize ""} {} 529test filesystem-6.21 {empty file name} {file owned ""} 0 530test filesystem-6.22 {empty file name} {file pathtype ""} relative 531test filesystem-6.23 {empty file name} {file readable ""} 0 532test filesystem-6.24 {empty file name} -returnCodes error -body { 533 file readlink "" 534} -result {could not read link "": no such file or directory} 535test filesystem-6.25 {empty file name} -returnCodes error -body { 536 file rename "" "" 537} -result {error renaming "": no such file or directory} 538test filesystem-6.26 {empty file name} {file rootname ""} {} 539test filesystem-6.27 {empty file name} -returnCodes error -body { 540 file separator "" 541} -result {unrecognised path} 542test filesystem-6.28 {empty file name} -returnCodes error -body { 543 file size "" 544} -result {could not read "": no such file or directory} 545test filesystem-6.29 {empty file name} {file split ""} {} 546test filesystem-6.30 {empty file name} -returnCodes error -body { 547 file system "" 548} -result {unrecognised path} 549test filesystem-6.31 {empty file name} {file tail ""} {} 550test filesystem-6.32 {empty file name} -returnCodes error -body { 551 file type "" 552} -result {could not read "": no such file or directory} 553test filesystem-6.33 {empty file name} {file writable ""} 0 554test filesystem-6.34 {file name with (invalid) nul character} { 555 list [catch "open foo\x00" msg] $msg 556} [list 1 "couldn't open \"foo\x00\": filename is invalid on this platform"] 557 558# Make sure the testfilesystem hasn't been registered. 559if {[testConstraint testfilesystem]} { 560 while {![catch {testfilesystem 0}]} {} 561} 562 563test filesystem-7.1.1 {load from vfs} -setup { 564 set dir [pwd] 565} -constraints {win testsimplefilesystem loaddll} -body { 566 # This may cause a crash on exit 567 cd [file dirname $::ddelib] 568 testsimplefilesystem 1 569 # This loads dde via a complex copy-to-temp operation 570 load simplefs:/[file tail $::ddelib] Dde 571 testsimplefilesystem 0 572 return ok 573 # The real result of this test is what happens when Tcl exits. 574} -cleanup { 575 cd $dir 576} -result ok 577test filesystem-7.1.2 {load from vfs, and then unload again} -setup { 578 set dir [pwd] 579} -constraints {win testsimplefilesystem loaddll} -body { 580 # This may cause a crash on exit 581 cd [file dirname $::reglib] 582 testsimplefilesystem 1 583 # This loads reg via a complex copy-to-temp operation 584 load simplefs:/[file tail $::reglib] Registry 585 unload simplefs:/[file tail $::reglib] 586 testsimplefilesystem 0 587 return ok 588 # The real result of this test is what happens when Tcl exits. 589} -cleanup { 590 cd $dir 591} -result ok 592test filesystem-7.2 {cross-filesystem copy from vfs maintains mtime} -setup { 593 set dir [pwd] 594 cd [tcltest::temporaryDirectory] 595} -constraints testsimplefilesystem -body { 596 # We created this file several tests ago. 597 set origtime [file mtime gorp.file] 598 set res [file exists gorp.file] 599 testsimplefilesystem 1 600 file delete -force theCopy 601 file copy simplefs:/gorp.file theCopy 602 testsimplefilesystem 0 603 set newtime [file mtime theCopy] 604 lappend res [expr {$origtime == $newtime ? 1 : "$origtime != $newtime"}] 605} -cleanup { 606 catch {file delete theCopy} 607 cd $dir 608} -result {1 1} 609test filesystem-7.3 {glob in simplefs} -setup { 610 set dir [pwd] 611 cd [tcltest::temporaryDirectory] 612} -constraints testsimplefilesystem -body { 613 file mkdir simpledir 614 close [open [file join simpledir simplefile] w] 615 testsimplefilesystem 1 616 glob -nocomplain -dir simplefs:/simpledir * 617} -cleanup { 618 catch {testsimplefilesystem 0} 619 file delete -force simpledir 620 cd $dir 621} -result {simplefs:/simpledir/simplefile} 622test filesystem-7.3.1 {glob in simplefs: no path/dir} -setup { 623 set dir [pwd] 624 cd [tcltest::temporaryDirectory] 625} -constraints testsimplefilesystem -body { 626 file mkdir simpledir 627 close [open [file join simpledir simplefile] w] 628 testsimplefilesystem 1 629 set res [glob -nocomplain simplefs:/simpledir/*] 630 lappend res {*}[glob -nocomplain simplefs:/simpledir] 631} -cleanup { 632 catch {testsimplefilesystem 0} 633 file delete -force simpledir 634 cd $dir 635} -result {simplefs:/simpledir/simplefile simplefs:/simpledir} 636test filesystem-7.3.2 {glob in simplefs: no path/dir, no subdirectory} -setup { 637 set dir [pwd] 638 cd [tcltest::temporaryDirectory] 639} -constraints testsimplefilesystem -body { 640 file mkdir simpledir 641 close [open [file join simpledir simplefile] w] 642 testsimplefilesystem 1 643 glob -nocomplain simplefs:/s* 644} -cleanup { 645 catch {testsimplefilesystem 0} 646 file delete -force simpledir 647 cd $dir 648} -match glob -result ?* 649test filesystem-7.3.3 {glob in simplefs: pattern is a volume} -setup { 650 set dir [pwd] 651 cd [tcltest::temporaryDirectory] 652} -constraints testsimplefilesystem -body { 653 file mkdir simpledir 654 close [open [file join simpledir simplefile] w] 655 testsimplefilesystem 1 656 glob -nocomplain simplefs:/* 657} -cleanup { 658 testsimplefilesystem 0 659 file delete -force simpledir 660 cd $dir 661} -match glob -result ?* 662test filesystem-7.4 {cross-filesystem file copy with -force} -setup { 663 set dir [pwd] 664 cd [tcltest::temporaryDirectory] 665 set fout [open [file join simplefile] w] 666 puts -nonewline $fout "1234567890" 667 close $fout 668 testsimplefilesystem 1 669} -constraints testsimplefilesystem -body { 670 # First copy should succeed 671 set res [catch {file copy simplefs:/simplefile file2} err] 672 lappend res $err 673 # Second copy should fail (no -force) 674 lappend res [catch {file copy simplefs:/simplefile file2} err] 675 lappend res $err 676 # Third copy should succeed (-force) 677 lappend res [catch {file copy -force simplefs:/simplefile file2} err] 678 lappend res $err 679 lappend res [file exists file2] 680} -cleanup { 681 catch {testsimplefilesystem 0} 682 file delete -force simplefile 683 file delete -force file2 684 cd $dir 685} -result {0 {} 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 {} 1} 686test filesystem-7.5 {cross-filesystem file copy with -force} -setup { 687 set dir [pwd] 688 cd [tcltest::temporaryDirectory] 689 set fout [open [file join simplefile] w] 690 puts -nonewline $fout "1234567890" 691 close $fout 692 testsimplefilesystem 1 693} -constraints {testsimplefilesystem unix} -body { 694 # First copy should succeed 695 set res [catch {file copy simplefs:/simplefile file2} err] 696 lappend res $err 697 file attributes file2 -permissions 0 698 # Second copy should fail (no -force) 699 lappend res [catch {file copy simplefs:/simplefile file2} err] 700 lappend res $err 701 # Third copy should succeed (-force) 702 lappend res [catch {file copy -force simplefs:/simplefile file2} err] 703 lappend res $err 704 lappend res [file exists file2] 705} -cleanup { 706 testsimplefilesystem 0 707 file delete -force simplefile 708 file delete -force file2 709 cd $dir 710} -result {0 {} 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 {} 1} 711test filesystem-7.6 {cross-filesystem dir copy with -force} -setup { 712 set dir [pwd] 713 cd [tcltest::temporaryDirectory] 714 file delete -force simpledir 715 file mkdir simpledir 716 file mkdir dir2 717 set fout [open [file join simpledir simplefile] w] 718 puts -nonewline $fout "1234567890" 719 close $fout 720 testsimplefilesystem 1 721} -constraints testsimplefilesystem -body { 722 # First copy should succeed 723 set res [catch {file copy simplefs:/simpledir dir2} err] 724 lappend res $err 725 # Second copy should fail (no -force) 726 lappend res [catch {file copy simplefs:/simpledir dir2} err] 727 lappend res $err 728 # Third copy should succeed (-force) 729 lappend res [catch {file copy -force simplefs:/simpledir dir2} err] 730 lappend res $err 731 lappend res [file exists [file join dir2 simpledir]] \ 732 [file exists [file join dir2 simpledir simplefile]] 733} -cleanup { 734 testsimplefilesystem 0 735 file delete -force simpledir 736 file delete -force dir2 737 cd $dir 738} -result {0 {} 1 {error copying "simplefs:/simpledir" to "dir2/simpledir": file already exists} 0 {} 1 1} 739test filesystem-7.7 {cross-filesystem dir copy with -force} -setup { 740 set dir [pwd] 741 cd [tcltest::temporaryDirectory] 742 file delete -force simpledir 743 file mkdir simpledir 744 file mkdir dir2 745 set fout [open [file join simpledir simplefile] w] 746 puts -nonewline $fout "1234567890" 747 close $fout 748 testsimplefilesystem 1 749} -constraints {testsimplefilesystem unix} -body { 750 # First copy should succeed 751 set res [catch {file copy simplefs:/simpledir dir2} err] 752 lappend res $err 753 # Second copy should fail (no -force) 754 lappend res [catch {file copy simplefs:/simpledir dir2} err] 755 lappend res $err 756 # Third copy should succeed (-force) 757 # I've noticed on some Unices that this only succeeds intermittently (some 758 # runs work, some fail). This needs examining further. 759 lappend res [catch {file copy -force simplefs:/simpledir dir2} err] 760 lappend res $err 761 lappend res [file exists [file join dir2 simpledir]] \ 762 [file exists [file join dir2 simpledir simplefile]] 763} -cleanup { 764 testsimplefilesystem 0 765 file delete -force simpledir 766 file delete -force dir2 767 cd $dir 768} -result {0 {} 1 {error copying "simplefs:/simpledir" to "dir2/simpledir": file already exists} 0 {} 1 1} 769removeFile gorp.file 770test filesystem-7.8 {vfs cd} -setup { 771 set dir [pwd] 772 cd [tcltest::temporaryDirectory] 773 file delete -force simpledir 774 file mkdir simpledir 775 testsimplefilesystem 1 776} -constraints testsimplefilesystem -body { 777 # This can variously cause an infinite loop or simply have no effect at 778 # all (before certain bugs were fixed, of course). 779 cd simplefs:/simpledir 780 pwd 781} -cleanup { 782 cd [tcltest::temporaryDirectory] 783 testsimplefilesystem 0 784 file delete -force simpledir 785 cd $dir 786} -result {simplefs:/simpledir} 787 788test filesystem-8.1 {relative path objects and caching of pwd} -setup { 789 set dir [pwd] 790 cd [tcltest::temporaryDirectory] 791} -body { 792 makeDirectory abc 793 makeDirectory def 794 makeFile "contents" [file join abc foo] 795 cd abc 796 set f "foo" 797 set res {} 798 lappend res [file exists $f] 799 lappend res [file exists $f] 800 cd .. 801 cd def 802 # If we haven't cleared the object's cwd cache, Tcl will think it still 803 # exists. 804 lappend res [file exists $f] 805 lappend res [file exists $f] 806} -cleanup { 807 removeFile [file join abc foo] 808 removeDirectory abc 809 removeDirectory def 810 cd $dir 811} -result {1 1 0 0} 812test filesystem-8.2 {relative path objects and use of pwd} -setup { 813 set origdir [pwd] 814 cd [tcltest::temporaryDirectory] 815} -body { 816 set dir "abc" 817 makeDirectory $dir 818 makeFile "contents" [file join abc foo] 819 cd $dir 820 file exists [lindex [glob *] 0] 821} -cleanup { 822 cd [tcltest::temporaryDirectory] 823 removeFile [file join abc foo] 824 removeDirectory abc 825 cd $origdir 826} -result 1 827test filesystem-8.3 {path objects and empty string} { 828 set anchor "" 829 set dst foo 830 set res $dst 831 set yyy [file split $anchor] 832 set dst [file join $anchor $dst] 833 lappend res $dst $yyy 834} {foo foo {}} 835 836proc TestFind1 {d f} { 837 set r1 [file exists [file join $d $f]] 838 lappend res "[file join $d $f] found: $r1" 839 lappend res "is dir a dir? [file isdirectory $d]" 840 set r2 [file exists [file join $d $f]] 841 lappend res "[file join $d $f] found: $r2" 842 return $res 843} 844proc TestFind2 {d f} { 845 set r1 [file exists [file join $d $f]] 846 lappend res "[file join $d $f] found: $r1" 847 lappend res "is dir a dir? [file isdirectory [file join $d]]" 848 set r2 [file exists [file join $d $f]] 849 lappend res "[file join $d $f] found: $r2" 850 return $res 851} 852 853test filesystem-9.1 {path objects and join and object rep} -setup { 854 set origdir [pwd] 855 cd [tcltest::temporaryDirectory] 856} -body { 857 file mkdir [file join a b c] 858 TestFind1 a [file join b . c] 859} -cleanup { 860 file delete -force a 861 cd $origdir 862} -result {{a/b/./c found: 1} {is dir a dir? 1} {a/b/./c found: 1}} 863test filesystem-9.2 {path objects and join and object rep} -setup { 864 set origdir [pwd] 865 cd [tcltest::temporaryDirectory] 866} -body { 867 file mkdir [file join a b c] 868 TestFind2 a [file join b . c] 869} -cleanup { 870 file delete -force a 871 cd $origdir 872} -result {{a/b/./c found: 1} {is dir a dir? 1} {a/b/./c found: 1}} 873test filesystem-9.2.1 {path objects and join and object rep} -setup { 874 set origdir [pwd] 875 cd [tcltest::temporaryDirectory] 876} -body { 877 file mkdir [file join a b c] 878 TestFind2 a [file join b .] 879} -cleanup { 880 file delete -force a 881 cd $origdir 882} -result {{a/b/. found: 1} {is dir a dir? 1} {a/b/. found: 1}} 883test filesystem-9.3 {path objects and join and object rep} -setup { 884 set origdir [pwd] 885 cd [tcltest::temporaryDirectory] 886} -body { 887 file mkdir [file join a b c] 888 TestFind1 a [file join b .. b c] 889} -cleanup { 890 file delete -force a 891 cd $origdir 892} -result {{a/b/../b/c found: 1} {is dir a dir? 1} {a/b/../b/c found: 1}} 893test filesystem-9.4 {path objects and join and object rep} -setup { 894 set origdir [pwd] 895 cd [tcltest::temporaryDirectory] 896} -body { 897 file mkdir [file join a b c] 898 TestFind2 a [file join b .. b c] 899} -cleanup { 900 file delete -force a 901 cd $origdir 902} -result {{a/b/../b/c found: 1} {is dir a dir? 1} {a/b/../b/c found: 1}} 903test filesystem-9.5 {path objects and file tail and object rep} -setup { 904 set origdir [pwd] 905 cd [tcltest::temporaryDirectory] 906} -body { 907 file mkdir dgp 908 close [open dgp/test w] 909 foreach relative [glob -nocomplain [file join * test]] { 910 set absolute [file join [pwd] $relative] 911 set res [list [file tail $absolute] "test"] 912 } 913 return $res 914} -cleanup { 915 file delete -force dgp 916 cd $origdir 917} -result {test test} 918test filesystem-9.6 {path objects and file tail and object rep} win { 919 set res {} 920 set p "C:\\toto" 921 lappend res [file join $p toto] 922 file isdirectory $p 923 lappend res [file join $p toto] 924} {C:/toto/toto C:/toto/toto} 925test filesystem-9.7 {path objects and glob and file tail and tilde} -setup { 926 set res {} 927 set origdir [pwd] 928 cd [tcltest::temporaryDirectory] 929} -body { 930 file mkdir tilde 931 close [open tilde/~testNotExist w] 932 cd tilde 933 set file [lindex [glob *test*] 0] 934 lappend res [file exists $file] [catch {file tail $file} r] $r 935 lappend res $file 936 lappend res [file exists $file] [catch {file tail $file} r] $r 937 lappend res [catch {file tail $file} r] $r 938} -cleanup { 939 cd [tcltest::temporaryDirectory] 940 file delete -force tilde 941 cd $origdir 942} -result {0 1 {user "testNotExist" doesn't exist} ~testNotExist 0 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}} 943test filesystem-9.8 {path objects and glob and file tail and tilde} -setup { 944 set res {} 945 set origdir [pwd] 946 cd [tcltest::temporaryDirectory] 947} -body { 948 file mkdir tilde 949 close [open tilde/~testNotExist w] 950 cd tilde 951 set file1 [lindex [glob *test*] 0] 952 set file2 "~testNotExist" 953 lappend res $file1 $file2 954 lappend res [catch {file tail $file1} r] $r 955 lappend res [catch {file tail $file2} r] $r 956} -cleanup { 957 cd [tcltest::temporaryDirectory] 958 file delete -force tilde 959 cd $origdir 960} -result {~testNotExist ~testNotExist 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}} 961test filesystem-9.9 {path objects and glob and file tail and tilde} -setup { 962 set res {} 963 set origdir [pwd] 964 cd [tcltest::temporaryDirectory] 965} -body { 966 file mkdir tilde 967 close [open tilde/~testNotExist w] 968 cd tilde 969 set file1 [lindex [glob *test*] 0] 970 set file2 "~testNotExist" 971 lappend res [catch {file exists $file1} r] $r 972 lappend res [catch {file exists $file2} r] $r 973 lappend res [string equal $file1 $file2] 974} -cleanup { 975 cd [tcltest::temporaryDirectory] 976 file delete -force tilde 977 cd $origdir 978} -result {0 0 0 0 1} 979 980# ---------------------------------------------------------------------- 981 982test filesystem-10.1 {Bug 3414754} { 983 string match */ [file join [pwd] foo/] 984} 0 985 986cleanupTests 987unset -nocomplain drive drives 988} 989namespace delete ::tcl::test::fileSystem 990return 991 992# Local Variables: 993# mode: tcl 994# End: 995