diff options
Diffstat (limited to 'tests/fCmd.test')
| -rw-r--r-- | tests/fCmd.test | 170 |
1 files changed, 83 insertions, 87 deletions
diff --git a/tests/fCmd.test b/tests/fCmd.test index 6d2abc0..00e442a 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.52 2006/03/20 11:39:03 dkf Exp $ +# RCS: @(#) $Id: fCmd.test,v 1.53 2006/03/21 11:12:29 dkf Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -25,9 +25,26 @@ testConstraint notNetworkFilesystem 0 testConstraint 95or98 [expr {[testConstraint 95] || [testConstraint 98]}] testConstraint 2000orNewer [expr {![testConstraint 95or98]}] +# Find a group that exists on this Unix system, or else skip tests that +# require Unix groups. +testConstraint foundGroup [expr {![textConstraint unix]}] +if {[testConstraint unix]} { + catch { + set groupList [exec groups] + set group [lindex $groupList 0] + testConstraint foundGroup 1 + } +} + +testConstraint fileSharing 0 +testConstraint notFileSharing 1 +testConstraint xdev 0 +testConstraint linkFile 1 +testConstraint linkDirectory 1 + # Several tests require need to match results against the unix username set user {} -if {$tcl_platform(platform) == "unix"} { +if {[testConstraint unix]} { catch {set user [exec whoami]} if {$user == ""} { catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} @@ -44,7 +61,7 @@ proc createfile {file {string a}} { return $string } -# +# # checkcontent -- # # Ensures that file "file" contains only the string "matchString" @@ -54,7 +71,7 @@ proc checkcontent {file matchString} { if {[catch { set f [open $file] set fileString [read $f] - close $f + close $f }]} { return 0 } @@ -99,12 +116,8 @@ proc contents {file} { } cd [temporaryDirectory] -testConstraint fileSharing 0 -testConstraint notFileSharing 1 -testConstraint xdev 0 - -if {$tcl_platform(platform) == "unix"} { +if {[testConstraint unix]} { if {[catch {set m1 [exec df .]; set m2 [exec df /tmp]}] == 0} { set m1 [string range $m1 0 [expr [string first " " $m1]-1]] set m2 [string range $m2 0 [expr [string first " " $m2]-1]] @@ -221,10 +234,10 @@ test fCmd-3.15 {FileCopyRename: source[0] == '\0'} {notRoot unixOrPc} { } {1 {error renaming "/" to "td1": file already exists}} test fCmd-3.16 {FileCopyRename: break on first error} {notRoot} { cleanup - createfile tf1 - createfile tf2 - createfile tf3 - createfile tf4 + createfile tf1 + createfile tf2 + createfile tf3 + createfile tf4 file mkdir td1 createfile [file join td1 tf3] list [catch {file rename tf1 tf2 tf3 tf4 td1} msg] $msg @@ -359,7 +372,7 @@ test fCmd-5.8 {TclFileDeleteCmd: file doesn't exist: lstat(name) != 0} {notRoot} set x [file exists tf1] file delete tf1 list $x [file exists tf1] -} {0 0} +} {0 0} test fCmd-5.9 {TclFileDeleteCmd: is directory} {notRoot} { cleanup file mkdir td1 @@ -533,7 +546,7 @@ test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} \ file attributes td1 -permissions 0000 set msg [list [catch {file rename td1 /tmp} msg] $msg] file attributes td1 -permissions 0755 - set msg + set msg } {1 {error renaming "td1": permission denied}} test fCmd-6.24 {CopyRenameOneFile: error uses original name} \ {unix notRoot} { @@ -687,7 +700,7 @@ test fCmd-9.3 {file rename: comprehensive: file to new name} {notRoot testchmod} file rename tf1 tf3 file rename tf2 tf4 list [lsort [glob tf*]] [file writable tf3] [file writable tf4] -} {{tf3 tf4} 1 0} +} {{tf3 tf4} 1 0} test fCmd-9.4 {file rename: comprehensive: dir to new name} {unixOrPc notRoot testchmod} { cleanup file mkdir td1 td2 @@ -695,7 +708,7 @@ test fCmd-9.4 {file rename: comprehensive: dir to new name} {unixOrPc notRoot te file rename td1 td3 file rename td2 td4 list [lsort [glob td*]] [file writable td3] [file writable td4] -} {{td3 td4} 1 0} +} {{td3 td4} 1 0} test fCmd-9.5 {file rename: comprehensive: file to self} {notRoot testchmod} { cleanup createfile tf1 tf1 @@ -704,7 +717,7 @@ test fCmd-9.5 {file rename: comprehensive: file to self} {notRoot testchmod} { file rename -force tf1 tf1 file rename -force tf2 tf2 list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2] -} {tf1 tf2 1 0} +} {tf1 tf2 1 0} test fCmd-9.6 {file rename: comprehensive: dir to self} {notRoot unixOrPc testchmod} { cleanup file mkdir td1 @@ -713,7 +726,7 @@ test fCmd-9.6 {file rename: comprehensive: dir to self} {notRoot unixOrPc testch file rename -force td1 . file rename -force td2 . list [lsort [glob td*]] [file writable td1] [file writable td2] -} {{td1 td2} 1 0} +} {{td1 td2} 1 0} test fCmd-9.7 {file rename: comprehensive: file to existing file} {notRoot testchmod} { cleanup createfile tf1 @@ -735,7 +748,7 @@ test fCmd-9.7 {file rename: comprehensive: file to existing file} {notRoot testc file rename -force tfs2 tfd2 file rename -force tfs3 tfd3 file rename -force tfs4 tfd4 - list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] + list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] } {{tf1 tf2 tfd1 tfd2 tfd3 tfd4} {1 {error renaming "tf1" to "tf2": file already exists}} 1 1 0 0} test fCmd-9.8 {file rename: comprehensive: dir to empty dir} -setup { cleanup @@ -753,7 +766,7 @@ test fCmd-9.8 {file rename: comprehensive: dir to empty dir} -setup { file mkdir [file join tdd2 tds2] file mkdir [file join tdd3 tds3] file mkdir [file join tdd4 tds4] - if {$tcl_platform(platform) != "unix"} { + if {![testConstraint unix]} { testchmod 555 tds3 testchmod 555 tds4 } @@ -764,12 +777,12 @@ test fCmd-9.8 {file rename: comprehensive: dir to empty dir} -setup { file rename -force tds2 tdd2 file rename -force tds3 tdd3 file rename -force tds4 tdd4 - if {$tcl_platform(platform) != "unix"} { - set w3 [file writable [file join tdd3 tds3]] - set w4 [file writable [file join tdd4 tds4]] - } else { + if {[testConstraint unix]} { set w3 0 set w4 0 + } else { + set w3 [file writable [file join tdd3 tds3]] + set w4 [file writable [file join tdd4 tds4]] } list [lsort [glob td*]] $msg [file writable [file join tdd1 tds1]] \ [file writable [file join tdd2 tds2]] $w3 $w4 @@ -782,15 +795,15 @@ test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} -setup { file mkdir tds2 file mkdir [file join tdd1 tds1 xxx] file mkdir [file join tdd2 tds2 xxx] - if {$tcl_platform(platform) != "unix"} { + if {![testConstraint unix]} { testchmod 555 tds2 } set a1 [list [catch {file rename -force tds1 tdd1} msg] $msg] set a2 [list [catch {file rename -force tds2 tdd2} msg] $msg] - if {$tcl_platform(platform) != "unix"} { - set w2 [file writable tds2] - } else { + if {[testConstraint unix]} { set w2 0 + } else { + set w2 [file writable tds2] } list [lsort [glob td*]] $a1 $a2 [file writable tds1] $w2 } -match glob -result \ @@ -811,15 +824,15 @@ test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} {notRoot te file mkdir td1 file mkdir td2 file mkdir td3 - if {$tcl_platform(platform) != "unix"} { + if {![testConstraint unix]} { testchmod 555 td2 } file rename td1 [file join td3 td3] file rename td2 [file join td3 td4] - if {$tcl_platform(platform) != "unix"} { - set w4 [file writable [file join td3 td4]] - } else { + if {[testConstraint unix]} { set w4 0 + } else { + set w4 [file writable [file join td3 td4]] } list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \ [file writable [file join td3 td3]] $w4 @@ -950,7 +963,7 @@ test fCmd-10.4 {file copy: comprehensive: file to existing file} {notRoot testch file copy -force tfs2 tfd2 file copy -force tfs3 tfd3 file copy -force tfs4 tfd4 - list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] + list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] } {{tf1 tf2 tfd1 tfd2 tfd3 tfd4 tfs1 tfs2 tfs3 tfs4} {1 {error copying "tf1" to "tf2": file already exists}} 1 1 0 0} test fCmd-10.5 {file copy: comprehensive: dir to empty dir} {notRoot testchmod} { cleanup @@ -973,7 +986,7 @@ test fCmd-10.5 {file copy: comprehensive: dir to empty dir} {notRoot testchmod} set a3 [catch {file copy -force tds2 tdd2}] set a4 [catch {file copy -force tds3 tdd3}] set a5 [catch {file copy -force tds4 tdd4}] - list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5 + list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5 } [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}] test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} \ {notRoot unixOrPc testchmod} { @@ -1047,9 +1060,9 @@ test fCmd-10.12 {file rename: rename to empty file name} { createfile tf1 list [catch {file rename tf1 ""} msg] $msg } {1 {error renaming "tf1" to "": no such file or directory}} -cleanup +cleanup -# old tests +# old tests test fCmd-11.1 {TclFileRenameCmd: -- option } {notRoot} { catch {file delete -force -- -tfa1} @@ -1080,9 +1093,9 @@ test fCmd-11.4 {TclFileRenameCmd: target filename translation failing} {notRoot} } {1} test fCmd-11.5 {TclFileRenameCmd: > 1 source & target is not a dir} {notRoot} { catch {file delete -force -- tfa1 tfa2 tfa3} - createfile tfa1 - createfile tfa2 - createfile tfa3 + createfile tfa1 + createfile tfa2 + createfile tfa3 set result [catch {file rename tfa1 tfa2 tfa3}] file delete tfa1 tfa2 tfa3 set result @@ -1104,7 +1117,7 @@ test fCmd-11.7 {TclFileRenameCmd: : multiple files into directory} {notRoot} { file rename tfa1 tfa2 tfad set r1 [checkcontent tfad/tfa1 $s1] set r2 [checkcontent tfad/tfa2 $s2] - + set result [expr $r1 && $r2 && ![file exists tfa1] && ![file exists tfa2]] file delete -force tfad @@ -1188,7 +1201,7 @@ test fCmd-12.7 {renamefile: renaming directory into offspring} {notRoot} { file mkdir tfad file mkdir tfad/dir set result [catch {file rename tfad tfad/dir}] - file delete -force tfad + file delete -force tfad set result } {1} test fCmd-12.8 {renamefile: generic error} {unix notRoot} { @@ -1260,9 +1273,9 @@ test fCmd-13.5 {TclCopyFilesCmd: target filename translation failing} { } {1} test fCmd-13.6 {TclCopyFilesCmd: > 1 source & target is not a dir} {notRoot} { catch {file delete -force -- tfa1 tfa2 tfa3} - createfile tfa1 - createfile tfa2 - createfile tfa3 + createfile tfa1 + createfile tfa2 + createfile tfa3 set result [catch {file copy tfa1 tfa2 tfa3}] file delete tfa1 tfa2 tfa3 set result @@ -1306,7 +1319,7 @@ test fCmd-13.9 {TclCopyFilesCmd: error copying file to directory} {notRoot} { # # Coverage tests for copyfile() -# +# test fCmd-14.1 {copyfile: source filename translation failing} {notRoot} { global env set temp $env(HOME) @@ -1392,7 +1405,7 @@ test fCmd-14.8 {copyfile: copy directory failing} {unix notRoot} { test fCmd-15.1 {TclMakeDirsCmd: target filename translation failing} {notRoot} { global env set temp $env(HOME) - unset env(HOME) + unset env(HOME) set result [catch {file mkdir ~/tfa}] set env(HOME) $temp set result @@ -1515,7 +1528,7 @@ test fCmd-16.9 {error while deleting file } {unix notRoot} { file attributes tfa -permissions 0555 set result [catch {file delete tfa/a }] ####### - ####### If any directory in a tree that is being removed does not + ####### If any directory in a tree that is being removed does not ####### have write permission, the process will fail! ####### This is also the case with "rm -rf" ####### @@ -1710,7 +1723,7 @@ test fCmd-18.14 {TclFileRenameCmd : rename a path with sym link} \ file mkdir tfa1/a/b/c/d file mkdir tfa2 - set f [file join [pwd] tfa1/a/b] + set f [file join [pwd] tfa1/a/b] set f2 [file join [pwd] {tfa2/b alias}] file link -symbolic $f2 $f file rename {tfa2/b alias/c} tfa3 @@ -1738,7 +1751,7 @@ test fCmd-18.16 {TclFileRenameCmd: rename a dangling symlink} {unix notRoot} { file mkdir tfa1 file link -symbolic tfalink tfa1 - file delete tfa1 + file delete tfa1 file rename tfalink tfa2 set result [expr [string compare [file type tfa2] "link"] == 0] file delete tfa2 @@ -1773,7 +1786,7 @@ test fCmd-19.3 {recursive remove} {notRoot} { } {0} # -# TclUnixDeleteFile and TraversalDelete are covered by tests from the +# TclUnixDeleteFile and TraversalDelete are covered by tests from the # TclDeleteFilesCmd suite # # @@ -1806,7 +1819,7 @@ test fCmd-20.2 {TraverseUnixTree : recursive delete of large directory: Bug 1034 # # Feature testing for TclCopyFilesCmd -# +# test fCmd-21.1 {copy : single file to nonexistant } {notRoot} { catch {file delete -force -- tfa1 tfa2} set s [createfile tfa1] @@ -1835,9 +1848,9 @@ test fCmd-21.3 {copy : single file into directory } {notRoot} { test fCmd-21.4 {copy : more than one source and target is not a directory} \ {notRoot} { catch {file delete -force -- tfa1 tfa2 tfa3} - createfile tfa1 - createfile tfa2 - createfile tfa3 + createfile tfa1 + createfile tfa2 + createfile tfa3 set result [catch {file copy tfa1 tfa2 tfa3}] file delete tfa1 tfa2 tfa3 set result @@ -1874,7 +1887,7 @@ test fCmd-21.7.1 {TclCopyFilesCmd: copy a dangling link} {unix notRoot dontCopyL file link -symbolic tfalink tfad1 file delete tfad1 set result [list [catch {file copy tfalink tfalink2} msg] $msg] - file delete -force tfalink tfalink2 + file delete -force tfalink tfalink2 set result } {1 {error copying "tfalink": the target of this link doesn't exist}} test fCmd-21.7.2 {TclCopyFilesCmd: copy a dangling link} {unix notRoot} { @@ -1883,7 +1896,7 @@ test fCmd-21.7.2 {TclCopyFilesCmd: copy a dangling link} {unix notRoot} { file delete tfad1 file copy tfalink tfalink2 set result [string match [file type tfalink2] link] - file delete tfalink tfalink2 + file delete tfalink tfalink2 set result } {1} test fCmd-21.8.1 {TclCopyFilesCmd: copy a link } {unix notRoot dontCopyLinks} { @@ -1959,10 +1972,10 @@ test fCmd-22.1 {TclpRenameFile: rename and overwrite in a single dir} {notRoot} } {1} test fCmd-22.2 {TclpRenameFile: attempt to overwrite itself} {unix notRoot} { catch {file delete -force -- tfa1} - set s [createfile tfa1] + set s [createfile tfa1] file rename -force tfa1 tfa1 set result [checkcontent tfa1 $s] - file delete tfa1 + file delete tfa1 set result } {1} test fCmd-22.3 {TclpRenameFile: rename dir to existing dir} {notRoot} { @@ -2012,12 +2025,12 @@ test fCmd-23.1 {TclMacRmdir: trying to remove a nonempty directory} {notRoot} { file mkdir [file join tfad dir] set result [catch {file delete tfad}] - file delete -force tfad + file delete -force tfad set result } {1} # -# TclMacDeleteFile +# TclMacDeleteFile # Error cases are not covered. # test fCmd-24.1 {TclMacDeleteFile: deleting a normal file} {notRoot} { @@ -2089,7 +2102,7 @@ test fCmd-26.2 {TclDeleteFilesCmd: delete dir with symlink} {unix notRoot} { set r1 [file isdir tfad1] set r2 [file exists tfad2] - + set result [expr $r1 && !$r2] file delete tfad1 set result @@ -2104,7 +2117,7 @@ test fCmd-26.3 {TclDeleteFilesCmd: delete dangling symlink} {unix notRoot} { set r1 [file exists tfad1] set r2 [file exists tfad2] - + set result [expr !$r1 && !$r2] set result } {1} @@ -2125,18 +2138,6 @@ test fCmd-27.4 {TclFileAttrsCmd - getting one option} { set attrs [file attributes foo.tmp] list [catch {file attributes foo.tmp {expand}[lindex $attrs 0]}] [file delete -force -- foo.tmp] } {0 {}} -# Find a group that exists on this Unix system, or else skip tests that -# require Unix groups. -if {$tcl_platform(platform) == "unix"} { - ::tcltest::testConstraint foundGroup 0 - catch { - set groupList [exec groups] - set group [lindex $groupList 0] - ::tcltest::testConstraint foundGroup 1 - } -} else { - ::tcltest::testConstraint foundGroup 1 -} test fCmd-27.5 {TclFileAttrsCmd - setting one option} {foundGroup} { catch {file delete -force -- foo.tmp} createfile foo.tmp @@ -2150,18 +2151,13 @@ test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} {foundGroup} { list [catch {file attributes foo.tmp {expand}[lrange $attrs 0 3]} msg] $msg [file delete -force -- foo.tmp] } {0 {} {}} -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 - tcltest::testConstraint linkDirectory 1 +if { + [testConstraint win] && + ([string index $tcl_platform(osVersion) 0] < 5 + || [lindex [file system [temporaryDirectory]] 1] ne "NTFS") +} then { + testConstraint linkDirectory 0 + testConstraint linkFile 0 } test fCmd-28.1 {file link} { |