# This file tests the tclUnixFCmd.c file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: unixFCmd.test,v 1.1.1.1 2007/07/10 15:04:24 duncan Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } # These tests really need to be run from a writable directory, which # it is assumed [temporaryDirectory] is. set oldcwd [pwd] cd [temporaryDirectory] # Several tests require need to match results against the unix username set user {} if {$tcl_platform(platform) == "unix"} { catch {set user [exec whoami]} if {$user == ""} { catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} } if {$user == ""} { set user "root" } } proc openup {path} { testchmod 777 $path if {[file isdirectory $path]} { catch { foreach p [glob -directory $path *] { openup $p } } } } proc cleanup {args} { foreach p ". $args" { set x "" catch { set x [glob -directory $p tf* td*] } foreach file $x { if {[catch {file delete -force -- $file}]} { openup $file file delete -force -- $file } } } } test unixFCmd-1.1 {TclpRenameFile: EACCES} {unixOnly notRoot} { cleanup file mkdir td1/td2/td3 file attributes td1/td2 -permissions 0000 set msg [list [catch {file rename td1/td2/td3 td2} msg] $msg] file attributes td1/td2 -permissions 0755 set msg } {1 {error renaming "td1/td2/td3": permission denied}} test unixFCmd-1.2 {TclpRenameFile: EEXIST} {unixOnly notRoot} { cleanup file mkdir td1/td2 file mkdir td2 list [catch {file rename td2 td1} msg] $msg } {1 {error renaming "td2" to "td1/td2": file already exists}} test unixFCmd-1.3 {TclpRenameFile: EINVAL} {unixOnly notRoot} { cleanup file mkdir td1 list [catch {file rename td1 td1} msg] $msg } {1 {error renaming "td1" to "td1/td1": trying to rename a volume or move a directory into itself}} test unixFCmd-1.4 {TclpRenameFile: EISDIR} {emptyTest unixOnly notRoot} { # can't make it happen } {} test unixFCmd-1.5 {TclpRenameFile: ENOENT} {unixOnly notRoot} { cleanup file mkdir td1 list [catch {file rename td2 td1} msg] $msg } {1 {error renaming "td2": no such file or directory}} test unixFCmd-1.6 {TclpRenameFile: ENOTDIR} {emptyTest unixOnly notRoot} { # can't make it happen } {} test unixFCmd-1.7 {TclpRenameFile: EXDEV} {unixOnly notRoot} { cleanup file mkdir foo/bar file attr foo -perm 040555 set catchResult [catch {file rename foo/bar /tmp} msg] set msg [lindex [split $msg :] end] catch {file delete /tmp/bar} catch {file attr foo -perm 040777} catch {file delete -force foo} list $catchResult $msg } {1 { permission denied}} test unixFCmd-1.8 {Checking EINTR Bug} {unixOnly notRoot nonPortable} { testalarm after 2000 list [testgotsig] [testgotsig] } {1 0} test unixFCmd-1.9 {Checking EINTR Bug} {unixOnly notRoot nonPortable} { cleanup set f [open tfalarm w] puts $f { after 2000 puts "hello world" exit 0 } close $f testalarm set pipe [open "|[info nameofexecutable] tfalarm" r+] set line [read $pipe 1] catch {close $pipe} list $line [testgotsig] } {h 1} test unixFCmd-2.1 {TclpCopyFile: target exists: lstat(dst) == 0} \ {unixOnly notRoot} { cleanup close [open tf1 a] close [open tf2 a] file copy -force tf1 tf2 } {} test unixFCmd-2.2.1 {TclpCopyFile: src is symlink} {unixOnly notRoot dontCopyLinks} { # copying links should end up with real files cleanup close [open tf1 a] file link -symbolic tf2 tf1 file copy tf2 tf3 file type tf3 } {file} test unixFCmd-2.2.2 {TclpCopyFile: src is symlink} {unixOnly notRoot} { # copying links should end up with the links copied cleanup close [open tf1 a] file link -symbolic tf2 tf1 file copy tf2 tf3 file type tf3 } {link} test unixFCmd-2.3 {TclpCopyFile: src is block} {unixOnly notRoot} { cleanup set null "/dev/null" while {[file type $null] != "characterSpecial"} { set null [file join [file dirname $null] [file readlink $null]] } # file copy $null tf1 } {} test unixFCmd-2.4 {TclpCopyFile: src is fifo} {unixOnly notRoot} { cleanup if [catch {exec mknod tf1 p}] { list 1 } else { file copy tf1 tf2 expr {"[file type tf1]" == "[file type tf2]"} } } {1} test unixFCmd-2.5 {TclpCopyFile: copy attributes} {unixOnly notRoot} { cleanup close [open tf1 a] file attributes tf1 -permissions 0472 file copy tf1 tf2 file attributes tf2 -permissions } 00472 ;# i.e. perms field of [exec ls -l tf2] is -r--rwx-w- test unixFCmd-3.1 {CopyFile not done} {emptyTest unixOnly notRoot} { } {} test unixFCmd-4.1 {TclpDeleteFile not done} {emptyTest unixOnly notRoot} { } {} test unixFCmd-5.1 {TclpCreateDirectory not done} {emptyTest unixOnly notRoot} { } {} test unixFCmd-6.1 {TclpCopyDirectory not done} {emptyTest unixOnly notRoot} { } {} test unixFCmd-7.1 {TclpRemoveDirectory not done} {emptyTest unixOnly notRoot} { } {} test unixFCmd-8.1 {TraverseUnixTree not done} {emptyTest unixOnly notRoot} { } {} test unixFCmd-9.1 {TraversalCopy not done} {emptyTest unixOnly notRoot} { } {} test unixFCmd-10.1 {TraversalDelete not done} {emptyTest unixOnly notRoot} { } {} test unixFCmd-11.1 {CopyFileAttrs not done} {emptyTest unixOnly notRoot} { } {} test unixFCmd-12.1 {GetGroupAttribute - file not found} {unixOnly notRoot} { catch {file delete -force -- foo.test} list [catch {file attributes foo.test -group} msg] $msg } {1 {could not read "foo.test": no such file or directory}} test unixFCmd-12.2 {GetGroupAttribute - file found} {unixOnly notRoot} { catch {file delete -force -- foo.test} close [open foo.test w] list [catch {file attributes foo.test -group}] [file delete -force -- foo.test] } {0 {}} test unixFCmd-13.1 {GetOwnerAttribute - file not found} {unixOnly notRoot} { catch {file delete -force -- foo.test} list [catch {file attributes foo.test -group} msg] $msg } {1 {could not read "foo.test": no such file or directory}} test unixFCmd-13.2 {GetOwnerAttribute} {unixOnly notRoot} { catch {file delete -force -- foo.test} close [open foo.test w] list [catch {file attributes foo.test -owner} msg] \ [string compare $msg $user] [file delete -force -- foo.test] } {0 0 {}} test unixFCmd-14.1 {GetPermissionsAttribute - file not found} {unixOnly notRoot} { catch {file delete -force -- foo.test} list [catch {file attributes foo.test -permissions} msg] $msg } {1 {could not read "foo.test": no such file or directory}} test unixFCmd-14.2 {GetPermissionsAttribute} {unixOnly notRoot} { catch {file delete -force -- foo.test} close [open foo.test w] list [catch {file attribute foo.test -permissions}] \ [file delete -force -- foo.test] } {0 {}} # Find a group that exists on this system, or else skip tests that require # groups set ::tcltest::testConstraints(foundGroup) 0 if {$tcl_platform(platform) == "unix"} { catch { set groupList [exec groups] set group [lindex $groupList 0] set ::tcltest::testConstraints(foundGroup) 1 } } #groups hard to test test unixFCmd-15.1 {SetGroupAttribute - invalid group} {unixOnly notRoot} { catch {file delete -force -- foo.test} list [catch {file attributes foo.test -group foozzz} msg] \ $msg [file delete -force -- foo.test] } {1 {could not set group for file "foo.test": group "foozzz" does not exist} {}} test unixFCmd-15.2 {SetGroupAttribute - invalid file} \ {unixOnly notRoot foundGroup} { catch {file delete -force -- foo.test} list [catch {file attributes foo.test -group $group} msg] $msg } {1 {could not set group for file "foo.test": no such file or directory}} #changing owners hard to do test unixFCmd-16.1 {SetOwnerAttribute - current owner} {unixOnly notRoot} { catch {file delete -force -- foo.test} close [open foo.test w] list [catch {file attributes foo.test -owner $user} msg] \ $msg [string compare [file attributes foo.test -owner] $user] \ [file delete -force -- foo.test] } {0 {} 0 {}} test unixFCmd-16.2 {SetOwnerAttribute - invalid file} {unixOnly notRoot} { catch {file delete -force -- foo.test} list [catch {file attributes foo.test -owner $user} msg] $msg } {1 {could not set owner for file "foo.test": no such file or directory}} test unixFCmd-16.3 {SetOwnerAttribute - invalid owner} {unixOnly notRoot} { catch {file delete -force -- foo.test} list [catch {file attributes foo.test -owner foozzz} msg] $msg } {1 {could not set owner for file "foo.test": user "foozzz" does not exist}} test unixFCmd-17.1 {SetPermissionsAttribute} {unixOnly notRoot} { catch {file delete -force -- foo.test} close [open foo.test w] list [catch {file attributes foo.test -permissions 0000} msg] \ $msg [file attributes foo.test -permissions] \ [file delete -force -- foo.test] } {0 {} 00000 {}} test unixFCmd-17.2 {SetPermissionsAttribute} {unixOnly notRoot} { catch {file delete -force -- foo.test} list [catch {file attributes foo.test -permissions 0000} msg] $msg } {1 {could not set permissions for file "foo.test": no such file or directory}} test unixFCmd-17.3 {SetPermissionsAttribute} {unixOnly notRoot} { catch {file delete -force -- foo.test} close [open foo.test w] list [catch {file attributes foo.test -permissions foo} msg] $msg \ [file delete -force -- foo.test] } {1 {unknown permission string format "foo"} {}} test unixFCmd-17.4 {SetPermissionsAttribute} {unixOnly notRoot} { catch {file delete -force -- foo.test} close [open foo.test w] list [catch {file attributes foo.test -permissions ---rwx} msg] $msg \ [file delete -force -- foo.test] } {1 {unknown permission string format "---rwx"} {}} close [open foo.test w] set ::i 4 proc permcheck {testnum permstr expected} { test $testnum {SetPermissionsAttribute} {unixOnly notRoot} { file attributes foo.test -permissions $permstr file attributes foo.test -permissions } $expected } permcheck unixFCmd-17.5 rwxrwxrwx 00777 permcheck unixFCmd-17.6 r--r---w- 00442 permcheck unixFCmd-17.7 0 00000 permcheck unixFCmd-17.8 u+rwx,g+r 00740 permcheck unixFCmd-17.9 u-w 00540 permcheck unixFCmd-17.10 o+rwx 00547 permcheck unixFCmd-17.11 --x--x--x 00111 permcheck unixFCmd-17.12 a+rwx 00777 file delete -force -- foo.test test unixFCmd-18.1 {Unix pwd} {nonPortable unixOnly notRoot} { # This test is nonportable because SunOS generates a weird error # message when the current directory isn't readable. set cd [pwd] set nd $cd/tstdir file mkdir $nd cd $nd file attributes $nd -permissions 0000 set r [list [catch {pwd} res] [string range $res 0 36]]; cd $cd; file attributes $nd -permissions 0755 file delete $nd set r } {1 {error getting working directory name:}} # cleanup cleanup cd $oldcwd ::tcltest::cleanupTests return