diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2016-12-21 22:46:09 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2016-12-21 22:46:09 (GMT) |
commit | 768f87f613cc9789fcf8073018fa02178c8c91df (patch) | |
tree | ec633f5608ef498bee52a5f42c12c49493ec8bf8 /tcl8.6/tests/winFile.test | |
parent | 07e464099b99459d0a37757771791598ef3395d9 (diff) | |
parent | 05fa4c89f20e9769db0e6c0b429cef2590771ace (diff) | |
download | blt-768f87f613cc9789fcf8073018fa02178c8c91df.zip blt-768f87f613cc9789fcf8073018fa02178c8c91df.tar.gz blt-768f87f613cc9789fcf8073018fa02178c8c91df.tar.bz2 |
Merge commit '05fa4c89f20e9769db0e6c0b429cef2590771ace' as 'tcl8.6'
Diffstat (limited to 'tcl8.6/tests/winFile.test')
-rw-r--r-- | tcl8.6/tests/winFile.test | 224 |
1 files changed, 224 insertions, 0 deletions
diff --git a/tcl8.6/tests/winFile.test b/tcl8.6/tests/winFile.test new file mode 100644 index 0000000..2c47f5f --- /dev/null +++ b/tcl8.6/tests/winFile.test @@ -0,0 +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. +# +# 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. + +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::* + +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + +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} -constraints {win} -body { + makeFile {} GlobCapS + list [glob -nocomplain GlobC*] [glob -nocomplain globc*] +} -cleanup { + removeFile GlobCapS +} -result {GlobCapS GlobCapS} +test winFile-2.2 {TclpMatchFiles: case sensitivity} -constraints {win} -body { + makeFile {} globlower + list [glob -nocomplain globl*] [glob -nocomplain gLOBl*] +} -cleanup { + removeFile globlower +} -result {globlower globlower} + +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 {[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 +} -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 |