1# This file tests the tclWinFile.c file. 2# 3# This file contains a collection of tests for one or more of the Tcl built-in 4# commands. Sourcing this file into Tcl runs the tests and generates output 5# for errors. No output means no errors were found. 6# 7# Copyright © 1997 Sun Microsystems, Inc. 8# Copyright © 1998-1999 Scriptics Corporation. 9# 10# See the file "license.terms" for information on usage and redistribution of 11# this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 13if {"::tcltest" ni [namespace children]} { 14 package require tcltest 2.5 15 namespace import -force ::tcltest::* 16} 17 18::tcltest::loadTestedCommands 19catch [list package require -exact tcl::test [info patchlevel]] 20 21testConstraint testvolumetype [llength [info commands testvolumetype]] 22testConstraint notNTFS 0 23 24if {[testConstraint testvolumetype]} { 25 testConstraint notNTFS [expr {[testvolumetype] eq "NTFS"}] 26} 27testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] 28 29test winFile-1.1 {TclpGetUserHome} -constraints {win} -body { 30 glob ~nosuchuser 31} -returnCodes error -result {user "nosuchuser" doesn't exist} 32test winFile-1.2 {TclpGetUserHome} -constraints {win nonPortable} -body { 33 # The administrator account should always exist. 34 glob ~administrator 35} -match glob -result * 36test winFile-1.4 {TclpGetUserHome} {win nonPortable} { 37 catch {glob ~stanton@workgroup} 38} {0} 39 40test winFile-2.1 {TclpMatchFiles: case sensitivity} -constraints {win} -body { 41 makeFile {} GlobCapS 42 set args [list -nocomplain -tails -directory [temporaryDirectory]] 43 list [glob {*}$args GlobC*] [glob {*}$args globc*]} -cleanup { 44 removeFile GlobCapS 45} -result {GlobCapS GlobCapS} 46test winFile-2.2 {TclpMatchFiles: case sensitivity} -constraints {win} -body { 47 makeFile {} globlower 48 set args [list -nocomplain -tails -directory [temporaryDirectory]] 49 list [glob {*}$args globl*] [glob {*}$args gLOBl*] 50} -cleanup { 51 removeFile globlower 52} -result {globlower globlower} 53 54test winFile-3.1 {file system} -constraints {win testvolumetype} -setup { 55 set res "" 56} -body { 57 foreach vol [file volumes] { 58 # Have to catch in case there is a removable drive (CDROM, floppy) 59 # with nothing in it. 60 catch { 61 if {[lindex [file system $vol] 1] ne [testvolumetype $vol]} { 62 append res "For $vol, we found [file system $vol]\ 63 and [testvolumetype $vol] are different\n" 64 } 65 } 66 } 67 set res 68} -result {} 69 70proc cacls {fname args} { 71 string trim [eval [list exec cacls [file nativename $fname]] $args <<y] 72} 73 74# dir/q output: 75# 2003-11-03 20:36 598 OCTAVIAN\benny filename.txt 76# Note this output from a german win2k machine: 77# 14.12.2007 14:26 30 VORDEFINIERT\Administratest.dat 78# 79# Modified to cope with Msys environment and use ls -l. 80proc getuser {fname} { 81 global env 82 set tryname $fname 83 if {[file isdirectory $fname]} { 84 set tryname [file dirname $fname] 85 } 86 set owner "" 87 set tail [file tail $tryname] 88 if {[info exists env(OSTYPE)] && $env(OSTYPE) eq "msys"} { 89 set dirtext [exec ls -l $fname] 90 foreach line [split $dirtext "\n"] { 91 set owner [lindex $line 2] 92 } 93 } else { 94 set dirtext [exec cmd /c dir /q [file nativename $fname]] 95 foreach line [split $dirtext "\n"] { 96 if {[string match -nocase "*$tail" $line]} { 97 set attrs [string range $line 0 end-[string length $tail]] 98 regexp { [^ \\]+\\.*$} $attrs owner 99 set owner [string trim $owner] 100 } 101 } 102 } 103 if {$owner eq ""} { 104 error "getuser: Owner not found in output of dir/q" 105 } 106 return $owner 107} 108 109proc test_read {fname} { 110 if {[catch {open $fname r} ifs]} { 111 return 0 112 } 113 set readfailed [catch {read $ifs}] 114 return [expr {![catch {close $ifs}] && !$readfailed}] 115} 116 117proc test_writ {fname} { 118 if {[catch {open $fname w} ofs]} { 119 return 0 120 } 121 set writefailed [catch {puts $ofs "Hello"}] 122 return [expr {![catch {close $ofs}] && !$writefailed}] 123} 124 125proc test_access {fname read writ} { 126 set problem {} 127 foreach type {read writ} { 128 if {[set $type] != [file ${type}able $fname]} { 129 lappend problem "[set $type] != \[file ${type}able $fname\]" 130 } 131 if {[set $type] != [test_${type} $fname]} { 132 lappend problem "[set $type] != \[test_${type} $fname\]" 133 } 134 } 135 if {![llength $problem]} { 136 return 137 } 138 return "Problem [join $problem \n]\nActual rights are: [cacls $fname]" 139} 140 141if {[testConstraint win]} { 142 # Create the test file 143 # NOTE: [tcltest::makeFile] not used. Presumably to force file 144 # creation in a particular filesystem? If not, try [makeFile] 145 # in a -setup script. 146 set fname test.dat 147 file delete $fname 148 close [open $fname w] 149} 150 151test winFile-4.0 { 152 Enhanced NTFS user/group permissions: test no acccess 153} -constraints { 154 win notNTFS notWine 155} -setup { 156 set owner [getuser $fname] 157 set user $::env(USERDOMAIN)\\$::env(USERNAME) 158} -body { 159 # Clean out all well-known ACLs 160 catch {cacls $fname /E /R "Everyone"} result 161 catch {cacls $fname /E /R $user} result 162 catch {cacls $fname /E /R $owner} result 163 cacls $fname /E /P $user:N 164 test_access $fname 0 0 165} -result {} 166test winFile-4.1 { 167 Enhanced NTFS user/group permissions: test readable only 168} -constraints { 169 win notNTFS notWine 170} -setup { 171 set user $::env(USERDOMAIN)\\$::env(USERNAME) 172} -body { 173 cacls $fname /E /P $user:N 174 cacls $fname /E /G $user:R 175 test_access $fname 1 0 176} -result {} 177test winFile-4.2 { 178 Enhanced NTFS user/group permissions: test writable only 179} -constraints { 180 win notNTFS notWine 181} -setup { 182 set user $::env(USERDOMAIN)\\$::env(USERNAME) 183} -body { 184 catch {cacls $fname /E /R $user} result 185 cacls $fname /E /P $user:N 186 cacls $fname /E /G $user:W 187 test_access $fname 0 1 188} -result {} 189test winFile-4.3 { 190 Enhanced NTFS user/group permissions: test read+write 191} -constraints { 192 win notNTFS 193} -setup { 194 set user $::env(USERDOMAIN)\\$::env(USERNAME) 195} -body { 196 catch {cacls $fname /E /R $user} result 197 cacls $fname /E /P $user:N 198 cacls $fname /E /G $user:R 199 cacls $fname /E /G $user:W 200 test_access $fname 1 1 201} -result {} 202test winFile-4.4 { 203 Enhanced NTFS user/group permissions: test full access 204} -constraints { 205 win notNTFS 206} -setup { 207 set user $::env(USERDOMAIN)\\$::env(USERNAME) 208} -body { 209 catch {cacls $fname /E /R $user} result 210 cacls $fname /E /P $user:N 211 cacls $fname /E /G $user:F 212 test_access $fname 1 1 213} -result {} 214 215if {[testConstraint win]} { 216 file delete $fname 217} 218 219# cleanup 220cleanupTests 221return 222