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