summaryrefslogtreecommitdiffstats
path: root/tests/winFile.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/winFile.test')
-rw-r--r--tests/winFile.test162
1 files changed, 76 insertions, 86 deletions
diff --git a/tests/winFile.test b/tests/winFile.test
index ffbb776..2c47f5f 100644
--- a/tests/winFile.test
+++ b/tests/winFile.test
@@ -1,16 +1,14 @@
# 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.16 2004/11/08 19:19:27 davygrvy Exp $
+# 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."
@@ -18,81 +16,59 @@ if {[catch {package require tcltest 2.0.2}]} {
}
namespace import -force ::tcltest::*
-if {[info commands ::testvolumetype] == ""} {
- tcltest::testConstraint notNTFS 0
-} else {
- if {![string equal "NTFS" [testvolumetype]]} {
- tcltest::testConstraint notNTFS 0
- } else {
- tcltest::testConstraint notNTFS 1
- }
+::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 {[string equal $::tcl_platform(os) "Windows NT"] &&
- $::tcl_platform(osVersion) >= 5.0} {
- tcltest::testConstraint win2000 1
-} else {
- tcltest::testConstraint win2000 0
+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} {win nt nonPortable} {
+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.
-
- catch {glob ~administrator}
-} {0}
-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]
- 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}
+ 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} {win} {
+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} {win} {
+} -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} {win} {
- 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}
+} -result {}
proc cacls {fname args} {
string trim [eval [list exec cacls [file nativename $fname]] $args <<y]
@@ -100,30 +76,41 @@ proc cacls {fname args} {
# 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 tail [file tail $tryname]
- set dirtext [exec cmd /c dir /q [file nativename $fname]]
set owner ""
- foreach line [split $dirtext "\n"] {
- if {[string match -nocase "* $tail" $line]} {
- set attrs [string range $line \
- 0 end-[string length $tail]]
- regexp { [A-Z]+\\.*$} $attrs owner
- set owner [string trim $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"} {
+ if {$owner eq ""} {
error "getuser: Owner not found in output of dir/q"
}
return $owner
}
proc test_read {fname} {
- if {[catch {set ifs [open $fname r]}]} {
+ if {[catch {open $fname r} ifs]} {
return 0
}
set readfailed [catch {read $ifs}]
@@ -131,7 +118,7 @@ proc test_read {fname} {
}
proc test_writ {fname} {
- if {[catch {set ofs [open $fname w]}]} {
+ if {[catch {open $fname w} ofs]} {
return 0
}
set writefailed [catch {puts $ofs "Hello"}]
@@ -148,20 +135,21 @@ proc test_access {fname read writ} {
lappend problem "[set $type] != \[test_${type} $fname\]"
}
}
- if {[llength $problem]} {
- return "Problem [join $problem \n]\nActual rights are: [cacls $fname]"
- } else {
- return ""
+ if {![llength $problem]} {
+ return
}
+ return "Problem [join $problem \n]\nActual rights are: [cacls $fname]"
}
-# 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]
+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
@@ -227,8 +215,10 @@ test winFile-4.4 {
test_access $fname 1 1
} -result {}
-file delete $fname
+if {[testConstraint win]} {
+ file delete $fname
+}
# cleanup
-::tcltest::cleanupTests
+cleanupTests
return
generated by cgit v0.12 at 2025-10-21 20:35:17 (GMT)