diff options
author | vincentdarley <vincentdarley> | 2002-06-21 14:22:27 (GMT) |
---|---|---|
committer | vincentdarley <vincentdarley> | 2002-06-21 14:22:27 (GMT) |
commit | bb4e2d03bf05b0d16efdf08c97daf5c1f2b35c7b (patch) | |
tree | 4ef5a455a5af3008e1352fe5dce00df230fdef43 /tests | |
parent | e5f38332d33ee51ce394b1273c7c5cb30e3994d8 (diff) | |
download | tcl-bb4e2d03bf05b0d16efdf08c97daf5c1f2b35c7b.zip tcl-bb4e2d03bf05b0d16efdf08c97daf5c1f2b35c7b.tar.gz tcl-bb4e2d03bf05b0d16efdf08c97daf5c1f2b35c7b.tar.bz2 |
tip99
Diffstat (limited to 'tests')
-rw-r--r-- | tests/cmdAH.test | 28 | ||||
-rw-r--r-- | tests/fCmd.test | 127 | ||||
-rw-r--r-- | tests/fileName.test | 14 | ||||
-rw-r--r-- | tests/fileSystem.test | 71 |
4 files changed, 161 insertions, 79 deletions
diff --git a/tests/cmdAH.test b/tests/cmdAH.test index cd0cce8..ff715e0 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdAH.test,v 1.20 2002/05/07 18:03:04 vincentdarley Exp $ +# RCS: @(#) $Id: cmdAH.test,v 1.21 2002/06/21 14:22:29 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -168,7 +168,7 @@ test cmdAH-5.1 {Tcl_FileObjCmd} { } {1 {wrong # args: should be "file option ?arg ...?"}} test cmdAH-5.2 {Tcl_FileObjCmd} { list [catch {file x} msg] $msg -} {1 {bad option "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} +} {1 {bad option "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-5.3 {Tcl_FileObjCmd} { list [catch {file exists} msg] $msg } {1 {wrong # args: should be "file exists name"}} @@ -1220,7 +1220,7 @@ test cmdAH-22.3 {Tcl_FileObjCmd: isfile} {file isfile dir.file} 0 # lstat and readlink: don't run these tests everywhere, since not all # sites will have symbolic links -catch {exec ln -s gorp.file link.file} +catch {file link -symbolic link.file gorp.file} test cmdAH-23.1 {Tcl_FileObjCmd: lstat} { list [catch {file lstat a} msg] $msg } {1 {wrong # args: should be "file lstat name varName"}} @@ -1517,6 +1517,14 @@ test cmdAH-29.4 {Tcl_FileObjCmd: type} {unixOnly nonPortable} { file delete link.file set result } link +test cmdAH-29.4.1 {Tcl_FileObjCmd: type} { + file mkdir temp + file link -symbolic link.dir temp + set result [file type link.dir] + file delete link.dir + file delete temp + set result +} link test cmdAH-29.5 {Tcl_FileObjCmd: type} { string tolower [list [catch {file type _bogus_} msg] $msg $errorCode] } {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} @@ -1525,25 +1533,25 @@ test cmdAH-29.5 {Tcl_FileObjCmd: type} { test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} { list [catch {file gorp x} msg] $msg -} {1 {bad option "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} +} {1 {bad option "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} { list [catch {file ex x} msg] $msg -} {1 {ambiguous option "ex": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} +} {1 {ambiguous option "ex": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} { list [catch {file is x} msg] $msg -} {1 {ambiguous option "is": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} +} {1 {ambiguous option "is": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} { list [catch {file z x} msg] $msg -} {1 {bad option "z": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} +} {1 {bad option "z": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.5 {Tcl_FileObjCmd: error conditions} { list [catch {file read x} msg] $msg -} {1 {ambiguous option "read": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} +} {1 {ambiguous option "read": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} { list [catch {file s x} msg] $msg -} {1 {ambiguous option "s": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} +} {1 {ambiguous option "s": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} { list [catch {file t x} msg] $msg -} {1 {ambiguous option "t": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} +} {1 {ambiguous option "t": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} { list [catch {file dirname ~woohgy} msg] $msg } {1 {user "woohgy" doesn't exist}} diff --git a/tests/fCmd.test b/tests/fCmd.test index a5cb889..964f31d 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: fCmd.test,v 1.13 2002/06/13 13:17:06 vincentdarley Exp $ +# RCS: @(#) $Id: fCmd.test,v 1.14 2002/06/21 14:22:29 vincentdarley Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -2163,36 +2163,37 @@ test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} {foundGroup} { list [catch {eval file attributes foo.tmp [lrange $attrs 0 3]} msg] $msg [file delete -force -- foo.tmp] } {0 {} {}} -if {[string equal testfilelink [info commands testfilelink]]} { - tcltest::testConstraint testfilelink 1 +tcltest::testConstraint hasLinks 1 - if {[string equal $tcl_platform(platform) "windows"]} { - if {[string index $tcl_platform(osVersion) 0] >= 5 \ - && ([lindex [file system [temporaryDirectory]] 1] == "NTFS")} { - tcltest::testConstraint linkDirectory 1 - tcltest::testConstraint linkFile 1 - } else { - tcltest::testConstraint linkDirectory 0 - tcltest::testConstraint linkFile 0 - } - } else { - tcltest::testConstraint linkFile 1 +if {[string equal $tcl_platform(platform) "windows"]} { + if {[string index $tcl_platform(osVersion) 0] >= 5 \ + && ([lindex [file system [temporaryDirectory]] 1] == "NTFS")} { tcltest::testConstraint linkDirectory 1 + tcltest::testConstraint linkFile 1 + } else { + tcltest::testConstraint linkDirectory 0 + tcltest::testConstraint linkFile 0 } - } else { - tcltest::testConstraint testfilelink 0 - tcltest::testConstraint linkDirectory 0 - tcltest::testConstraint linkFile 0 + tcltest::testConstraint linkFile 1 + tcltest::testConstraint linkDirectory 1 } -test fCmd-28.1 {testfilelink} {testfilelink} { - list [catch {testfilelink} msg] $msg -} {1 {wrong # args: should be "testfilelink source ?target?"}} +test fCmd-28.1 {file link} {hasLinks} { + list [catch {file link} msg] $msg +} {1 {wrong # args: should be "file link ?-linktype? source ?target?"}} + +test fCmd-28.2 {file link} {hasLinks} { + list [catch {file link a b c d} msg] $msg +} {1 {wrong # args: should be "file link ?-linktype? source ?target?"}} -test fCmd-28.2 {testfilelink} {testfilelink} { - list [catch {testfilelink a b c d} msg] $msg -} {1 {wrong # args: should be "testfilelink source ?target?"}} +test fCmd-28.3 {file link} {hasLinks} { + list [catch {file link abc b c} msg] $msg +} {1 {bad switch "abc": must be -symbolic or -hard}} + +test fCmd-28.4 {file link} {hasLinks} { + list [catch {file link -abc b c} msg] $msg +} {1 {bad switch "-abc": must be -symbolic or -hard}} catch {file delete -force abc.dir} catch {file delete -force abc2.dir} @@ -2201,46 +2202,76 @@ makeDirectory abc2.dir makeFile contents abc.file makeFile contents abc2.file -test fCmd-28.3 {testfilelink} {linkDirectory winOnly} { - list [catch {testfilelink abc.dir abc2.dir} msg] $msg -} {1 {could not create link from "abc.dir" to "abc2.dir": file already exists}} +test fCmd-28.5 {file link: source already exists} {linkDirectory} { + list [catch {file link abc.dir abc2.dir} msg] $msg +} {1 {could not create new link "abc.dir": that path already exists}} + +test fCmd-28.6 {file link: unsupported operation} {linkDirectory macOrWin} { + list [catch {file link -hard abc.link abc.dir} msg] $msg +} {1 {could not create new link "abc.link" pointing to "abc.dir": illegal operation on a directory}} -test fCmd-28.4 {testfilelink} {linkFile winOnly} { - list [catch {testfilelink abc.file abc2.file} msg] $msg -} {1 {could not create link from "abc.file" to "abc2.file": file already exists}} +test fCmd-28.7 {file link: source already exists} {linkFile} { + list [catch {file link abc.file abc2.file} msg] $msg +} {1 {could not create new link "abc.file": that path already exists}} -test fCmd-28.5 {testfilelink} {linkFile winOnly} { +test fCmd-28.8 {file link} {linkFile winOnly} { + list [catch {file link -symbolic abc.link abc.file} msg] $msg +} {1 {could not create new link "abc.link" pointing to "abc.file": not a directory}} + +test fCmd-28.9 {file link: success with file} {linkFile} { file delete -force abc.link - list [catch {testfilelink abc.link abc.file} msg] $msg + list [catch {file link abc.link abc.file} msg] $msg } {0 abc.file} catch {file delete -force abc.link} -test fCmd-28.6 {testfilelink} {linkDirectory winOnly} { +test fCmd-28.10 {file link: linking to nonexistent path} {linkDirectory} { file delete -force abc.link - list [catch {testfilelink abc.link abc2.doesnt} msg] $msg -} {1 {could not create link from "abc.link" to "abc2.doesnt": no such file or directory}} + list [catch {file link abc.link abc2.doesnt} msg] $msg +} {1 {could not create new link "abc.link" since target "abc2.doesnt" doesn't exist}} -test fCmd-28.7 {testfilelink} {linkDirectory winOnly} { +test fCmd-28.11 {file link: success with directory} {linkDirectory} { file delete -force abc.link - list [catch {testfilelink abc.link abc.dir} msg] $msg + list [catch {file link abc.link abc.dir} msg] $msg } {0 abc.dir} -test fCmd-28.7.1 {testfilelink} {linkDirectory winOnly} { +test fCmd-28.12 {file link: cd into a link} {linkDirectory} { + file delete -force abc.link + file link abc.link abc.dir + set orig [pwd] + cd abc.link + set dir [pwd] + cd .. + set up [pwd] + cd $orig + # now '$up' should be either $orig or [file dirname abc.dir], + # depending on whether 'cd' actually moves to the destination + # of a link, or simply treats the link as a directory. + # (on windows the former, on unix the latter, I believe) + if {([file normalize $up] != [file normalize $orig]) \ + && ([file normalize $up] != [file normalize [file dirname abc.dir]])} { + set res "wrong directory with 'cd $link ; cd ..'" + } else { + set res "ok" + } + set res +} {ok} + +test fCmd-28.13 {file link} {linkDirectory} { # duplicate link throws error - list [catch {testfilelink abc.link abc.dir} msg] $msg -} {1 {could not create link from "abc.link" to "abc.dir": file already exists}} + list [catch {file link abc.link abc.dir} msg] $msg +} {1 {could not create new link "abc.link": that path already exists}} -test fCmd-28.8 {testfilelink: deletes link not dir} {linkDirectory winOnly} { +test fCmd-28.14 {file link: deletes link not dir} {linkDirectory} { file delete -force abc.link list [file exists abc.link] [file exists abc.dir] } {0 1} -test fCmd-28.9 {testfilelink: copies link not dir} {linkDirectory winOnly} { +test fCmd-28.15 {file link: copies link not dir} {linkDirectory} { file delete -force abc.link - testfilelink abc.link abc.dir + file link abc.link abc.dir file copy abc.link abc2.link - list [file type abc2.link] [file tail [testfilelink abc2.link]] + list [file type abc2.link] [file tail [file link abc2.link]] } {link abc.dir} file delete -force abc.link @@ -2249,17 +2280,17 @@ file delete -force abc2.link file copy abc.file abc.dir file copy abc2.file abc.dir -test fCmd-28.10 {testfilelink: glob inside link} {linkDirectory winOnly} { +test fCmd-28.16 {file link: glob inside link} {linkDirectory} { file delete -force abc.link - testfilelink abc.link abc.dir + file link abc.link abc.dir glob -dir abc.link -tails * } {abc.file abc2.file} -test fCmd-28.11 {testfilelink: glob -type l} {linkDirectory winOnly} { +test fCmd-28.17 {file link: glob -type l} {linkDirectory} { glob -dir [pwd] -type l -tails abc* } {abc.link} -test fCmd-28.12 {testfilelink: glob -type d} {linkDirectory winOnly} { +test fCmd-28.18 {file link: glob -type d} {linkDirectory} { lsort [glob -dir [pwd] -type d -tails abc*] } [lsort [list abc.link abc.dir abc2.dir]] diff --git a/tests/fileName.test b/tests/fileName.test index cdf3572..5ded8c5 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: fileName.test,v 1.22 2002/05/30 09:27:11 vincentdarley Exp $ +# RCS: @(#) $Id: fileName.test,v 1.23 2002/06/21 14:22:29 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -1172,12 +1172,12 @@ test filename-11.17.1 {Tcl_GlobCmd} {pcOnly macOnly} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]]] -test filename-11.17.2 {Tcl_GlobCmd} {unixOnly notRoot} { +test filename-11.17.2 {Tcl_GlobCmd} {notRoot} { set dir [pwd] set ret "error in test" if {[catch { cd $globname - exec ln -s a1 link + file link -symbolic link a1 cd $dir set ret [list [catch { lsort [glob -directory $globname -join * b1] @@ -1190,12 +1190,12 @@ test filename-11.17.2 {Tcl_GlobCmd} {unixOnly notRoot} { } [list 0 [lsort [list [file join $globname a1 b1] \ [file join $globname link b1]]]] # Simpler version of the above test to illustrate a given bug. -test filename-11.17.3 {Tcl_GlobCmd} {unixOnly notRoot} { +test filename-11.17.3 {Tcl_GlobCmd} {notRoot} { set dir [pwd] set ret "error in test" if {[catch { cd $globname - exec ln -s a1 link + file link -symbolic link a1 cd $dir set ret [list [catch { lsort [glob -directory $globname -type d *] @@ -1211,12 +1211,12 @@ test filename-11.17.3 {Tcl_GlobCmd} {unixOnly notRoot} { [file join $globname link]]]] # Make sure the bugfix isn't too simple. We don't want # to break 'glob -type l'. -test filename-11.17.4 {Tcl_GlobCmd} {unixOnly notRoot} { +test filename-11.17.4 {Tcl_GlobCmd} {notRoot} { set dir [pwd] set ret "error in test" if {[catch { cd $globname - exec ln -s a1 link + file link -symbolic link a1 cd $dir set ret [list [catch { lsort [glob -directory $globname -type l *] diff --git a/tests/fileSystem.test b/tests/fileSystem.test index eb3f6cb..5e5e9c8 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -32,60 +32,103 @@ makeDirectory dir.file makeFile "test file in directory" [file join dir.file inside.file] if {[catch { - testfilelink link.file gorp.file - testfilelink \ + file link link.file gorp.file + file link \ [file join dir.file linkinside.file] \ [file join dir.file inside.file] - testfilelink dir.link dir.file + file link dir.link dir.file }]} { - tcltest::testConstraint links 0 + tcltest::testConstraint hasLinks 0 } else { - tcltest::testConstraint links 1 + tcltest::testConstraint hasLinks 1 } -test filesystem-1.0 {link normalisation} {links} { +test filesystem-1.0 {link normalisation} {hasLinks} { string equal [file normalize gorp.file] [file normalize link.file] } {0} -test filesystem-1.1 {link normalisation} {links} { +test filesystem-1.1 {link normalisation} {hasLinks} { string equal [file normalize dir.file] [file normalize dir.link] } {0} -test filesystem-1.2 {link normalisation} {links macOrUnix} { +test filesystem-1.2 {link normalisation} {hasLinks macOrUnix} { string equal [file normalize [file join gorp.file foo]] \ [file normalize [file join link.file foo]] } {1} -test filesystem-1.3 {link normalisation} {links} { +test filesystem-1.3 {link normalisation} {hasLinks} { string equal [file normalize [file join dir.file foo]] \ [file normalize [file join dir.link foo]] } {1} -test filesystem-1.4 {link normalisation} {links} { +test filesystem-1.4 {link normalisation} {hasLinks} { string equal [file normalize [file join dir.file inside.file]] \ [file normalize [file join dir.link inside.file]] } {1} -test filesystem-1.5 {link normalisation} {links} { +test filesystem-1.5 {link normalisation} {hasLinks} { string equal [file normalize [file join dir.file linkinside.file]] \ [file normalize [file join dir.file linkinside.file]] } {1} -test filesystem-1.6 {link normalisation} {links} { +test filesystem-1.6 {link normalisation} {hasLinks} { string equal [file normalize [file join dir.file linkinside.file]] \ [file normalize [file join dir.link inside.file]] } {0} -test filesystem-1.7 {link normalisation} {links macOrUnix} { +test filesystem-1.7 {link normalisation} {hasLinks macOrUnix} { string equal [file normalize [file join dir.link linkinside.file foo]] \ [file normalize [file join dir.file inside.file foo]] } {1} -test filesystem-1.8 {link normalisation} {links} { +test filesystem-1.8 {link normalisation} {hasLinks} { string equal [file normalize [file join dir.file linkinside.filefoo]] \ [file normalize [file join dir.link inside.filefoo]] } {0} +test filesystem-1.9 {link normalisation} {hasLinks} { + file delete -force dir.link + file link dir.link [file nativename dir.file] + string equal [file normalize [file join dir.file linkinside.file foo]] \ + [file normalize [file join dir.link inside.file foo]] +} {0} + +test filesystem-1.10 {link normalisation: double link} {hasLinks} { + file link dir2.link dir.link + string equal [file normalize [file join dir.file linkinside.file foo]] \ + [file normalize [file join dir2.link inside.file foo]] +} {0} + +makeDirectory dir2.file + +test filesystem-1.11 {link normalisation: double link, back in tree} {hasLinks} { + file link [file join dir2.file dir2.link] dir2.link + string equal [file normalize [file join dir.file linkinside.file foo]] \ + [file normalize [file join dir2.file dir2.link inside.file foo]] +} {0} + +test filesystem-1.12 {file new native path} {} { + for {set i 0} {$i < 10} {incr i} { + foreach f [lsort [glob -nocomplain -type l *]] { + catch {file readlink $f} + } + } + # If we reach here we've succeeded. We used to crash above. + expr 1 +} {1} + +test filesystem-1.13 {file normalisation} {winOnly} { + # This used to be broken + file normalize C:/thislongnamedoesntexist +} {C:/thislongnamedoesntexist} + +test filesystem-1.14 {file normalisation} {winOnly} { + # This used to be broken + file normalize c:/ +} {C:/} + +file delete -force dir2.file +file delete -force dir2.link file delete -force link.file dir.link removeFile [file join dir.file inside.file] removeDirectory dir.file |