Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: downloads/tcl8.5.2/tests/fileSystem.test @ 45

Last change on this file since 45 was 25, checked in by landauf, 18 years ago

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