util/src/TclTk/tcl8.6.12/tests/winFile.test

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