diff options
Diffstat (limited to 'tests/winFile.test')
| -rw-r--r-- | tests/winFile.test | 251 |
1 files changed, 190 insertions, 61 deletions
diff --git a/tests/winFile.test b/tests/winFile.test index 95816ff..2c47f5f 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -1,95 +1,224 @@ # 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. -# -# RCS: @(#) $Id: winFile.test,v 1.9.2.1 2003/04/14 15:45:58 vincentdarley Exp $ +# 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} { - list [catch {glob ~nosuchuser} msg] $msg -} {1 {user "nosuchuser" doesn't exist}} -test winFile-1.2 {TclpGetUserHome} {pcOnly nt nonPortable} { - # The administrator account should always exist. +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] - catch {glob ~administrator} -} {0} -test winFile-1.3 {TclpGetUserHome} {pcOnly 95} { - # Find some user in system.ini and then see if they have a home. - - set f [open $::env(windir)/system.ini] - set x 0 - while {![eof $f]} { - set line [gets $f] - if {$line == "\[Password Lists]"} { - gets $f - set name [lindex [split [gets $f] =] 0] - if {$name != ""} { - set x [catch {glob ~$name}] - break - } - } - } - close $f - set x -} {0} -test winFile-1.4 {TclpGetUserHome} {pcOnly nt nonPortable} { +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} -constraints {win} -body { + glob ~nosuchuser +} -returnCodes error -result {user "nosuchuser" doesn't exist} +test winFile-1.2 {TclpGetUserHome} -constraints {win nt nonPortable} -body { + # The administrator account should always exist. + glob ~administrator +} -match glob -result * +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} -constraints {win} -body { makeFile {} GlobCapS - set result [list [glob -nocomplain GlobC*] [glob -nocomplain globc*]] + list [glob -nocomplain GlobC*] [glob -nocomplain globc*] +} -cleanup { removeFile GlobCapS - set result -} {GlobCapS GlobCapS} - -test winFile-2.2 {TclpMatchFiles: case sensitivity} {pcOnly} { +} -result {GlobCapS GlobCapS} +test winFile-2.2 {TclpMatchFiles: case sensitivity} -constraints {win} -body { makeFile {} globlower - set result [list [glob -nocomplain globl*] [glob -nocomplain gLOBl*]] + list [glob -nocomplain globl*] [glob -nocomplain gLOBl*] +} -cleanup { removeFile globlower - set result -} {globlower globlower} +} -result {globlower globlower} -test winFile-3.1 {file system} {pcOnly} { - set res "volume types ok" +test winFile-3.1 {file system} -constraints {win testvolumetype} -setup { + set res "" +} -body { foreach vol [file volumes] { # Have to catch in case there is a removable drive (CDROM, floppy) # with nothing in it. catch { - if {![string equal [lindex [file system $vol] 1] [testvolumetype $vol]]} { - set res "For $vol, we found [file system $vol]\ - and [testvolumetype $vol] are different" - break + if {[lindex [file system $vol] 1] ne [testvolumetype $vol]} { + append res "For $vol, we found [file system $vol]\ + and [testvolumetype $vol] are different\n" } } } set res -} {volume types ok} - -# cleanup -::tcltest::cleanupTests -return - - - - +} -result {} +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)] && $env(OSTYPE) eq "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 {$owner eq ""} { + error "getuser: Owner not found in output of dir/q" + } + return $owner +} +proc test_read {fname} { + if {[catch {open $fname r} ifs]} { + return 0 + } + set readfailed [catch {read $ifs}] + return [expr {![catch {close $ifs}] && !$readfailed}] +} +proc test_writ {fname} { + if {[catch {open $fname w} ofs]} { + 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 + } + return "Problem [join $problem \n]\nActual rights are: [cacls $fname]" +} +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 |