tcl/tests/unixFCmd.test

   1 # This file tests the tclUnixFCmd.c file.
   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) 1996 Sun Microsystems, Inc.
   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 #
  12 # RCS: @(#) $Id$
  13
  14 if {[lsearch [namespace children] ::tcltest] == -1} {
  15     package require tcltest
  16     namespace import -force ::tcltest::*
  17 }
  18
  19 # These tests really need to be run from a writable directory, which
  20 # it is assumed [temporaryDirectory] is.
  21 set oldcwd [pwd]
  22 cd [temporaryDirectory]
  23
  24 # Several tests require need to match results against the unix username
  25 set user {}
  26 if {$tcl_platform(platform) == "unix"} {
  27     catch {set user [exec whoami]}
  28     if {$user == ""} {
  29         catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
  30     }
  31     if {$user == ""} {
  32         set user "root"
  33     }
  34 }
  35
  36 proc openup {path} {
  37     testchmod 777 $path
  38     if {[file isdirectory $path]} {
  39         catch {
  40             foreach p [glob -directory $path *] {
  41                 openup $p
  42             }
  43         }
  44     }
  45 }
  46
  47 proc cleanup {args} {
  48     foreach p ". $args" {
  49         set x ""
  50         catch {
  51             set x [glob -directory $p tf* td*]
  52         }
  53         foreach file $x {
  54             if {[catch {file delete -force -- $file}]} {
  55                 openup $file
  56                 file delete -force -- $file
  57             }
  58         }
  59     }
  60 }
  61
  62 test unixFCmd-1.1 {TclpRenameFile: EACCES} {unixOnly notRoot} {
  63     cleanup
  64     file mkdir td1/td2/td3
  65     file attributes td1/td2 -permissions 0000
  66     set msg [list [catch {file rename td1/td2/td3 td2} msg] $msg]
  67     file attributes td1/td2 -permissions 0755
  68     set msg
  69 } {1 {error renaming "td1/td2/td3": permission denied}}
  70 test unixFCmd-1.2 {TclpRenameFile: EEXIST} {unixOnly notRoot} {
  71     cleanup
  72     file mkdir td1/td2
  73     file mkdir td2
  74     list [catch {file rename td2 td1} msg] $msg
  75 } {1 {error renaming "td2" to "td1/td2": file already exists}}
  76 test unixFCmd-1.3 {TclpRenameFile: EINVAL} {unixOnly notRoot} {
  77     cleanup
  78     file mkdir td1
  79     list [catch {file rename td1 td1} msg] $msg
  80 } {1 {error renaming "td1" to "td1/td1": trying to rename a volume or move a directory into itself}}
  81 test unixFCmd-1.4 {TclpRenameFile: EISDIR} {emptyTest unixOnly notRoot} {
  82     # can't make it happen
  83 } {}
  84 test unixFCmd-1.5 {TclpRenameFile: ENOENT} {unixOnly notRoot} {
  85     cleanup
  86     file mkdir td1
  87     list [catch {file rename td2 td1} msg] $msg
  88 } {1 {error renaming "td2": no such file or directory}}
  89 test unixFCmd-1.6 {TclpRenameFile: ENOTDIR} {emptyTest unixOnly notRoot} {
  90     # can't make it happen
  91 } {}
  92 test unixFCmd-1.7 {TclpRenameFile: EXDEV} {unixOnly notRoot} {
  93     cleanup
  94     file mkdir foo/bar
  95     file attr foo -perm 040555
  96     set catchResult [catch {file rename foo/bar /tmp} msg]
  97     set msg [lindex [split $msg :] end]
  98     catch {file delete /tmp/bar}
  99     catch {file attr foo -perm 040777}
 100     catch {file delete -force foo}
 101     list $catchResult $msg
 102 } {1 { permission denied}}
 103 test unixFCmd-1.8 {Checking EINTR Bug} {unixOnly notRoot nonPortable} {
 104     testalarm
 105     after 2000
 106     list [testgotsig] [testgotsig]
 107 } {1 0}
 108 test unixFCmd-1.9 {Checking EINTR Bug} {unixOnly notRoot nonPortable} {
 109     cleanup
 110     set f [open tfalarm w]
 111     puts $f {
 112         after 2000
 113         puts "hello world"
 114         exit 0
 115     }
 116     close $f
 117     testalarm
 118     set pipe [open "|[info nameofexecutable] tfalarm" r+]
 119     set line [read $pipe 1]
 120     catch {close $pipe}
 121     list $line [testgotsig]
 122 } {h 1}
 123 test unixFCmd-2.1 {TclpCopyFile: target exists: lstat(dst) == 0} \
 124         {unixOnly notRoot} {
 125     cleanup
 126     close [open tf1 a]
 127     close [open tf2 a]
 128     file copy -force tf1 tf2
 129 } {}
 130 test unixFCmd-2.2.1 {TclpCopyFile: src is symlink} {unixOnly notRoot dontCopyLinks} {
 131     # copying links should end up with real files
 132     cleanup
 133     close [open tf1 a]
 134     file link -symbolic tf2 tf1
 135     file copy tf2 tf3
 136     file type tf3
 137 } {file}
 138 test unixFCmd-2.2.2 {TclpCopyFile: src is symlink} {unixOnly notRoot} {
 139     # copying links should end up with the links copied
 140     cleanup
 141     close [open tf1 a]
 142     file link -symbolic tf2 tf1
 143     file copy tf2 tf3
 144     file type tf3
 145 } {link}
 146 test unixFCmd-2.3 {TclpCopyFile: src is block} {unixOnly notRoot} {
 147     cleanup
 148     set null "/dev/null"
 149     while {[file type $null] != "characterSpecial"} {
 150         set null [file join [file dirname $null] [file readlink $null]]
 151     }
 152     # file copy $null tf1
 153 } {}
 154 test unixFCmd-2.4 {TclpCopyFile: src is fifo} {unixOnly notRoot} {
 155     cleanup
 156     if [catch {exec mknod tf1 p}] {
 157         list 1
 158     } else {
 159         file copy tf1 tf2
 160         expr {"[file type tf1]" == "[file type tf2]"}
 161     }
 162 } {1}
 163 test unixFCmd-2.5 {TclpCopyFile: copy attributes} {unixOnly notRoot} {
 164     cleanup
 165     close [open tf1 a]
 166     file attributes tf1 -permissions 0472
 167     file copy tf1 tf2
 168     file attributes tf2 -permissions
 169 } 00472 ;# i.e. perms field of [exec ls -l tf2] is -r--rwx-w-
 170
 171 test unixFCmd-3.1 {CopyFile not done} {emptyTest unixOnly notRoot} {
 172 } {}
 173
 174 test unixFCmd-4.1 {TclpDeleteFile not done} {emptyTest unixOnly notRoot} {
 175 } {}
 176
 177 test unixFCmd-5.1 {TclpCreateDirectory not done} {emptyTest unixOnly notRoot} {
 178 } {}
 179
 180 test unixFCmd-6.1 {TclpCopyDirectory not done} {emptyTest unixOnly notRoot} {
 181 } {}
 182
 183 test unixFCmd-7.1 {TclpRemoveDirectory not done} {emptyTest unixOnly notRoot} {
 184 } {}
 185
 186 test unixFCmd-8.1 {TraverseUnixTree not done} {emptyTest unixOnly notRoot} {
 187 } {}
 188
 189 test unixFCmd-9.1 {TraversalCopy not done} {emptyTest unixOnly notRoot} {
 190 } {}
 191
 192 test unixFCmd-10.1 {TraversalDelete not done} {emptyTest unixOnly notRoot} {
 193 } {}
 194
 195 test unixFCmd-11.1 {CopyFileAttrs not done} {emptyTest unixOnly notRoot} {
 196 } {}
 197
 198 test unixFCmd-12.1 {GetGroupAttribute - file not found} {unixOnly notRoot} {
 199     catch {file delete -force -- foo.test}
 200     list [catch {file attributes foo.test -group} msg] $msg
 201 } {1 {could not read "foo.test": no such file or directory}}
 202 test unixFCmd-12.2 {GetGroupAttribute - file found} {unixOnly notRoot} {
 203     catch {file delete -force -- foo.test}
 204     close [open foo.test w]
 205     list [catch {file attributes foo.test -group}] [file delete -force -- foo.test]
 206 } {0 {}}
 207
 208 test unixFCmd-13.1 {GetOwnerAttribute - file not found} {unixOnly notRoot} {
 209     catch {file delete -force -- foo.test}
 210     list [catch {file attributes foo.test -group} msg] $msg
 211 } {1 {could not read "foo.test": no such file or directory}}
 212 test unixFCmd-13.2 {GetOwnerAttribute} {unixOnly notRoot} {
 213     catch {file delete -force -- foo.test}
 214     close [open foo.test w]
 215     list [catch {file attributes foo.test -owner} msg] \
 216             [string compare $msg $user] [file delete -force -- foo.test]
 217 } {0 0 {}}
 218
 219 test unixFCmd-14.1 {GetPermissionsAttribute - file not found} {unixOnly notRoot} {
 220     catch {file delete -force -- foo.test}
 221     list [catch {file attributes foo.test -permissions} msg] $msg
 222 } {1 {could not read "foo.test": no such file or directory}}
 223 test unixFCmd-14.2 {GetPermissionsAttribute} {unixOnly notRoot} {
 224     catch {file delete -force -- foo.test}
 225     close [open foo.test w]
 226     list [catch {file attribute foo.test -permissions}] \
 227             [file delete -force -- foo.test]
 228 } {0 {}}
 229
 230 # Find a group that exists on this system, or else skip tests that require
 231 # groups
 232 set ::tcltest::testConstraints(foundGroup) 0
 233 catch {
 234     set groupList [exec groups]
 235     set group [lindex $groupList 0]
 236     set ::tcltest::testConstraints(foundGroup) 1
 237 }
 238
 239 #groups hard to test
 240 test unixFCmd-15.1 {SetGroupAttribute - invalid group} {unixOnly notRoot} {
 241     catch {file delete -force -- foo.test}
 242     list [catch {file attributes foo.test -group foozzz} msg] \
 243             $msg [file delete -force -- foo.test]
 244 } {1 {could not set group for file "foo.test": group "foozzz" does not exist} {}}
 245 test unixFCmd-15.2 {SetGroupAttribute - invalid file} \
 246         {unixOnly notRoot foundGroup} {
 247     catch {file delete -force -- foo.test}
 248     list [catch {file attributes foo.test -group $group} msg] $msg
 249 } {1 {could not set group for file "foo.test": no such file or directory}}
 250
 251 #changing owners hard to do
 252 test unixFCmd-16.1 {SetOwnerAttribute - current owner} {unixOnly notRoot} {
 253     catch {file delete -force -- foo.test}
 254     close [open foo.test w]
 255     list [catch {file attributes foo.test -owner $user} msg] \
 256             $msg [string compare [file attributes foo.test -owner] $user] \
 257             [file delete -force -- foo.test]
 258 } {0 {} 0 {}}
 259 test unixFCmd-16.2 {SetOwnerAttribute - invalid file} {unixOnly notRoot} {
 260     catch {file delete -force -- foo.test}
 261     list [catch {file attributes foo.test -owner $user} msg] $msg
 262 } {1 {could not set owner for file "foo.test": no such file or directory}}
 263 test unixFCmd-16.3 {SetOwnerAttribute - invalid owner} {unixOnly notRoot} {
 264     catch {file delete -force -- foo.test}
 265     list [catch {file attributes foo.test -owner foozzz} msg] $msg
 266 } {1 {could not set owner for file "foo.test": user "foozzz" does not exist}}
 267
 268
 269 test unixFCmd-17.1 {SetPermissionsAttribute} {unixOnly notRoot} {
 270     catch {file delete -force -- foo.test}
 271     close [open foo.test w]
 272     list [catch {file attributes foo.test -permissions 0000} msg] \
 273             $msg [file attributes foo.test -permissions] \
 274             [file delete -force -- foo.test]
 275 } {0 {} 00000 {}}
 276 test unixFCmd-17.2 {SetPermissionsAttribute} {unixOnly notRoot} {
 277     catch {file delete -force -- foo.test}
 278     list [catch {file attributes foo.test -permissions 0000} msg] $msg
 279 } {1 {could not set permissions for file "foo.test": no such file or directory}}
 280 test unixFCmd-17.3 {SetPermissionsAttribute} {unixOnly notRoot} {
 281     catch {file delete -force -- foo.test}
 282     close [open foo.test w]
 283     list [catch {file attributes foo.test -permissions foo} msg] $msg \
 284             [file delete -force -- foo.test]
 285 } {1 {unknown permission string format "foo"} {}}
 286 test unixFCmd-17.3 {SetPermissionsAttribute} {unixOnly notRoot} {
 287     catch {file delete -force -- foo.test}
 288     close [open foo.test w]
 289     list [catch {file attributes foo.test -permissions ---rwx} msg] $msg \
 290             [file delete -force -- foo.test]
 291 } {1 {unknown permission string format "---rwx"} {}}
 292
 293 close [open foo.test w]
 294 set ::i 4
 295 proc permcheck {testnum permstr expected} {
 296     test $testnum {SetPermissionsAttribute} {unixOnly notRoot} {
 297         file attributes foo.test -permissions $permstr
 298         file attributes foo.test -permissions
 299     } $expected
 300 }
 301 permcheck unixFCmd-17.4   rwxrwxrwx     00777
 302 permcheck unixFCmd-17.5   r--r---w-     00442
 303 permcheck unixFCmd-17.6   0             00000
 304 permcheck unixFCmd-17.7   u+rwx,g+r     00740
 305 permcheck unixFCmd-17.8   u-w           00540
 306 permcheck unixFCmd-17.9   o+rwx         00547
 307 permcheck unixFCmd-17.10  --x--x--x     00111
 308 permcheck unixFCmd-17.11  a+rwx         00777
 309 file delete -force -- foo.test
 310
 311 test unixFCmd-18.1 {Unix pwd} {nonPortable unixOnly notRoot} {
 312     # This test is nonportable because SunOS generates a weird error
 313     # message when the current directory isn't readable.
 314     set cd [pwd]
 315     set nd $cd/tstdir
 316     file mkdir $nd
 317     cd $nd
 318     file attributes $nd -permissions 0000
 319     set r [list [catch {pwd} res] [string range $res 0 36]];
 320     cd $cd;
 321     file attributes $nd -permissions 0755
 322     file delete $nd
 323     set r
 324 } {1 {error getting working directory name:}}
 325
 326 # cleanup
 327 cleanup
 328 cd $oldcwd
 329 ::tcltest::cleanupTests
 330 return