summaryrefslogtreecommitdiffstats
path: root/tests/winFile.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/winFile.test')
-rw-r--r--tests/winFile.test198
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
generated by cgit v0.12 at 2024-08-20 09:48:43 (GMT)