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