diff options
Diffstat (limited to 'tests/winFile.test')
| -rw-r--r-- | tests/winFile.test | 198 |
1 files changed, 174 insertions, 24 deletions
diff --git a/tests/winFile.test b/tests/winFile.test index 756144e..bfba9cf 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -1,29 +1,41 @@ # This file tests the tclWinFile.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. +# 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) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* +if {[catch {package require tcltest 2.0.2}]} { + puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." + return } +namespace import -force ::tcltest::* -test winFile-1.1 {TclpGetUserHome} {pcOnly} { +testConstraint testvolumetype [llength [info commands testvolumetype]] +testConstraint notNTFS 0 +testConstraint win2000 0 + +if {[testConstraint testvolumetype]} { + testConstraint notNTFS [expr {[testvolumetype] eq "NTFS"}] +} +if {[testConstraint nt] && $::tcl_platform(osVersion) >= 5.0} { + testConstraint win2000 1 +} + +test winFile-1.1 {TclpGetUserHome} {win} { list [catch {glob ~nosuchuser} msg] $msg } {1 {user "nosuchuser" doesn't exist}} -test winFile-1.2 {TclpGetUserHome} {pcOnly nt nonPortable} { +test winFile-1.2 {TclpGetUserHome} {win nt nonPortable} { # The administrator account should always exist. catch {glob ~administrator} } {0} -test winFile-1.3 {TclpGetUserHome} {pcOnly 95} { +test winFile-1.3 {TclpGetUserHome} {win 95} { # Find some user in system.ini and then see if they have a home. set f [open $::env(windir)/system.ini] @@ -42,25 +54,24 @@ test winFile-1.3 {TclpGetUserHome} {pcOnly 95} { close $f set x } {0} -test winFile-1.4 {TclpGetUserHome} {pcOnly nt nonPortable} { +test winFile-1.4 {TclpGetUserHome} {win nt nonPortable} { catch {glob ~stanton@workgroup} } {0} -test winFile-2.1 {TclpMatchFiles: case sensitivity} {pcOnly} { +test winFile-2.1 {TclpMatchFiles: case sensitivity} {win} { makeFile {} GlobCapS set result [list [glob -nocomplain GlobC*] [glob -nocomplain globc*]] removeFile GlobCapS set result } {GlobCapS GlobCapS} - -test winFile-2.2 {TclpMatchFiles: case sensitivity} {pcOnly} { +test winFile-2.2 {TclpMatchFiles: case sensitivity} {win} { makeFile {} globlower set result [list [glob -nocomplain globl*] [glob -nocomplain gLOBl*]] removeFile globlower set result } {globlower globlower} -test winFile-3.1 {file system} {pcOnly} { +test winFile-3.1 {file system} {win testvolumetype} { set res "volume types ok" foreach vol [file volumes] { # Have to catch in case there is a removable drive (CDROM, floppy) @@ -76,18 +87,157 @@ test winFile-3.1 {file system} {pcOnly} { set res } {volume types ok} -# cleanup -::tcltest::cleanupTests -return - - - - - +proc cacls {fname args} { + string trim [eval [list exec cacls [file nativename $fname]] $args <<y] +} +# dir/q output: +# 2003-11-03 20:36 598 OCTAVIAN\benny filename.txt +# Note this output from a german win2k machine: +# 14.12.2007 14:26 30 VORDEFINIERT\Administratest.dat +# +# Modified to cope with Msys environment and use ls -l. +proc getuser {fname} { + global env + set tryname $fname + if {[file isdirectory $fname]} { + set tryname [file dirname $fname] + } + set owner "" + set tail [file tail $tryname] + if {[info exists env(OSTYPE)] && [string equal $env(OSTYPE) "msys"]} { + set dirtext [exec ls -l $fname] + foreach line [split $dirtext "\n"] { + set owner [lindex $line 2] + } + } else { + set dirtext [exec cmd /c dir /q [file nativename $fname]] + foreach line [split $dirtext "\n"] { + if {[string match -nocase "*$tail" $line]} { + set attrs [string range $line \ + 0 end-[string length $tail]] + regexp { [^ \\]+\\.*$} $attrs owner + set owner [string trim $owner] + } + } + } + if {[string length $owner] == 0} { + error "getuser: Owner not found in output of dir/q" + } + return $owner +} +proc test_read {fname} { + if {[catch {set ifs [open $fname r]}]} { + return 0 + } + set readfailed [catch {read $ifs}] + return [expr {![catch {close $ifs}] && !$readfailed}] +} +proc test_writ {fname} { + if {[catch {set ofs [open $fname w]}]} { + return 0 + } + set writefailed [catch {puts $ofs "Hello"}] + return [expr {![catch {close $ofs}] && !$writefailed}] +} +proc test_access {fname read writ} { + set problem {} + foreach type {read writ} { + if {[set $type] != [file ${type}able $fname]} { + lappend problem "[set $type] != \[file ${type}able $fname\]" + } + if {[set $type] != [test_${type} $fname]} { + lappend problem "[set $type] != \[test_${type} $fname\]" + } + } + if {[llength $problem]} { + return "Problem [join $problem \n]\nActual rights are: [cacls $fname]" + } else { + return "" + } +} +if {[testConstraint win]} { + # Create the test file + # NOTE: [tcltest::makeFile] not used. Presumably to force file + # creation in a particular filesystem? If not, try [makeFile] + # in a -setup script. + set fname test.dat + file delete $fname + close [open $fname w] +} +test winFile-4.0 { + Enhanced NTFS user/group permissions: test no acccess +} -constraints { + win nt notNTFS win2000 +} -setup { + set owner [getuser $fname] + set user $::env(USERDOMAIN)\\$::env(USERNAME) +} -body { + # Clean out all well-known ACLs + catch {cacls $fname /E /R "Everyone"} result + catch {cacls $fname /E /R $user} result + catch {cacls $fname /E /R $owner} result + cacls $fname /E /P $user:N + test_access $fname 0 0 +} -result {} +test winFile-4.1 { + Enhanced NTFS user/group permissions: test readable only +} -constraints { + win nt notNTFS +} -setup { + set user $::env(USERDOMAIN)\\$::env(USERNAME) +} -body { + cacls $fname /E /P $user:N + cacls $fname /E /G $user:R + test_access $fname 1 0 +} -result {} +test winFile-4.2 { + Enhanced NTFS user/group permissions: test writable only +} -constraints { + win nt notNTFS +} -setup { + set user $::env(USERDOMAIN)\\$::env(USERNAME) +} -body { + catch {cacls $fname /E /R $user} result + cacls $fname /E /P $user:N + cacls $fname /E /G $user:W + test_access $fname 0 1 +} -result {} +test winFile-4.3 { + Enhanced NTFS user/group permissions: test read+write +} -constraints { + win nt notNTFS +} -setup { + set user $::env(USERDOMAIN)\\$::env(USERNAME) +} -body { + catch {cacls $fname /E /R $user} result + cacls $fname /E /P $user:N + cacls $fname /E /G $user:R + cacls $fname /E /G $user:W + test_access $fname 1 1 +} -result {} +test winFile-4.4 { + Enhanced NTFS user/group permissions: test full access +} -constraints { + win nt notNTFS +} -setup { + set user $::env(USERDOMAIN)\\$::env(USERNAME) +} -body { + catch {cacls $fname /E /R $user} result + cacls $fname /E /P $user:N + cacls $fname /E /G $user:F + test_access $fname 1 1 +} -result {} + +if {[testConstraint win]} { + file delete $fname +} +# cleanup +cleanupTests +return |