basis/io/files/info/windows/windows.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: byte-arrays math io.backend io.files.info
   4 io.files.windows kernel windows.kernel32
   5 windows.time windows.types windows accessors alien.c-types
   6 combinators generalizations system alien.strings
   7 sequences splitting windows.errors fry
   8 continuations destructors calendar ascii
   9 combinators.short-circuit literals locals classes.struct
  10 specialized-arrays alien.data libc windows.shell32 ;
  11 SPECIALIZED-ARRAY: ushort
  12 IN: io.files.info.windows
  13
  14 :: round-up-to ( n multiple -- n' )
  15     n multiple rem [
  16         n
  17     ] [
  18         multiple swap - n +
  19     ] if-zero ;
  20
  21 TUPLE: windows-file-info < file-info-tuple attributes ;
  22
  23 : get-compressed-file-size ( path -- n )
  24     { DWORD } [ GetCompressedFileSize ] with-out-parameters
  25     over INVALID_FILE_SIZE = [ win32-error-string throw ] [ >64bit ] if ;
  26
  27 : set-windows-size-on-disk ( file-info path -- file-info )
  28     over attributes>> +compressed+ swap member? [
  29         get-compressed-file-size
  30     ] [
  31         drop dup size>> 4096 round-up-to
  32     ] if >>size-on-disk ;
  33
  34 : WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
  35     [ \ windows-file-info new ] dip
  36     {
  37         [ dwFileAttributes>> win32-file-type >>type ]
  38         [ dwFileAttributes>> win32-file-attributes >>attributes ]
  39         [ [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit >>size ]
  40         [ dwFileAttributes>> >>permissions ]
  41         [ ftCreationTime>> FILETIME>timestamp >>created ]
  42         [ ftLastWriteTime>> FILETIME>timestamp >>modified ]
  43         [ ftLastAccessTime>> FILETIME>timestamp >>accessed ]
  44     } cleave ;
  45
  46 : find-first-file-stat ( path -- WIN32_FIND_DATA )
  47     WIN32_FIND_DATA <struct> [
  48         FindFirstFile
  49         [ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep
  50         FindClose win32-error=0/f
  51     ] keep ;
  52
  53 : BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info )
  54     [ \ windows-file-info new ] dip
  55     {
  56         [ dwFileAttributes>> win32-file-type >>type ]
  57         [ dwFileAttributes>> win32-file-attributes >>attributes ]
  58         [
  59             [ nFileSizeLow>> ]
  60             [ nFileSizeHigh>> ] bi >64bit >>size
  61         ]
  62         [ dwFileAttributes>> >>permissions ]
  63         [ ftCreationTime>> FILETIME>timestamp >>created ]
  64         [ ftLastWriteTime>> FILETIME>timestamp >>modified ]
  65         [ ftLastAccessTime>> FILETIME>timestamp >>accessed ]
  66         ! [ nNumberOfLinks>> ]
  67         ! [
  68           ! [ nFileIndexLow>> ]
  69           ! [ nFileIndexHigh>> ] bi >64bit
  70         ! ]
  71     } cleave ;
  72
  73 : get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
  74     [
  75         BY_HANDLE_FILE_INFORMATION <struct>
  76         [ GetFileInformationByHandle win32-error=0/f ] keep
  77     ] keep CloseHandle win32-error=0/f ;
  78
  79 : valid-handle? ( handle -- boolean )
  80     INVALID_HANDLE_VALUE = not ; inline
  81
  82 : open-read-handle ( path -- handle/f )
  83     ! Parameters of CreateFileW here should match those in open-read.
  84     GENERIC_READ share-mode f
  85     OPEN_EXISTING 0 CreateFile-flags f
  86     CreateFileW [ valid-handle? ] keep f ? ;
  87
  88 : get-file-information-stat ( path -- file-info )
  89     dup open-read-handle dup [
  90         nip
  91         get-file-information BY_HANDLE_FILE_INFORMATION>file-info
  92     ] [
  93         drop find-first-file-stat WIN32_FIND_DATA>file-info
  94     ] if ;
  95
  96 M: windows file-info ( path -- info )
  97     normalize-path
  98     [ get-file-information-stat ]
  99     [ set-windows-size-on-disk ] bi ;
 100
 101 M: windows link-info ( path -- info )
 102     file-info ;
 103
 104 : file-executable-type ( path -- executable/f )
 105     normalize-path dup
 106     0
 107     f
 108     ! hi is zero means old style executable
 109     0 SHGFI_EXETYPE SHGetFileInfoW
 110     [
 111         file-info drop f
 112     ] [
 113         nip >lo-hi first2 zero? [
 114             {
 115                 { 0x5A4D [ +dos-executable+ ] }
 116                 { 0x4550 [ +win32-console-executable+ ] }
 117                 [ drop f ]
 118             } case
 119         ] [
 120             {
 121                 { 0x454C [ +win32-vxd-executable+ ] }
 122                 { 0x454E [ +win32-os2-executable+ ] }
 123                 { 0x4550 [ +win32-nt-executable+ ] }
 124                 [ drop f ]
 125             } case
 126         ] if
 127     ] if-zero ;
 128
 129 CONSTANT: path-length $[ MAX_PATH 1 + ]
 130
 131 : volume-information ( normalized-path -- volume-name volume-serial max-component flags type )
 132     { { ushort path-length } DWORD DWORD DWORD { ushort path-length } }
 133     [ [ path-length ] 4dip path-length GetVolumeInformation win32-error=0/f ]
 134     with-out-parameters
 135     [ alien>native-string ] 4dip alien>native-string ;
 136
 137 : file-system-space ( normalized-path -- available-space total-space free-space )
 138     { ULARGE_INTEGER ULARGE_INTEGER ULARGE_INTEGER }
 139     [ GetDiskFreeSpaceEx win32-error=0/f ]
 140     with-out-parameters ;
 141
 142 : calculate-file-system-info ( file-system-info -- file-system-info' )
 143     [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ] keep ;
 144
 145 TUPLE: win32-file-system-info < file-system-info-tuple max-component flags device-serial ;
 146
 147 ERROR: not-absolute-path ;
 148
 149 : root-directory ( string -- string' )
 150     unicode-prefix ?head drop
 151     dup {
 152         [ length 2 >= ]
 153         [ second CHAR: : = ]
 154         [ first Letter? ]
 155     } 1&& [ 2 head "\\" append ] [ not-absolute-path ] if ;
 156
 157 <PRIVATE
 158
 159 : (file-system-info) ( path -- file-system-info )
 160     dup [ volume-information ] [ file-system-space ] bi
 161     \ win32-file-system-info new
 162         swap >>free-space
 163         swap >>total-space
 164         swap >>available-space
 165         swap >>type
 166         swap >>flags
 167         swap >>max-component
 168         swap >>device-serial
 169         swap >>device-name
 170         swap >>mount-point
 171     calculate-file-system-info ;
 172
 173 PRIVATE>
 174
 175 M: windows file-system-info ( path -- file-system-info )
 176     normalize-path root-directory (file-system-info) ;
 177
 178 CONSTANT: names-buf-length 16384
 179
 180 : find-first-volume ( -- string handle )
 181     { { ushort path-length } }
 182     [ path-length FindFirstVolume dup win32-error=0/f ]
 183     with-out-parameters alien>native-string swap ;
 184
 185 : find-next-volume ( handle -- string/f )
 186     { { ushort path-length } }
 187     [ path-length FindNextVolume ] with-out-parameters
 188     swap 0 = [
 189         GetLastError ERROR_NO_MORE_FILES =
 190         [ drop f ] [ win32-error-string throw ] if
 191     ] [ alien>native-string ] if ;
 192
 193 : find-volumes ( -- array )
 194     find-first-volume
 195     [
 196         '[
 197             [ _ find-next-volume dup ] [ ] produce nip
 198             swap prefix
 199         ]
 200     ] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup ;
 201
 202 ! Windows may return a volume which looks up to path ""
 203 ! For now, treat it like there is not a volume here
 204 : (volume>paths) ( string -- array )
 205     [
 206         names-buf-length
 207         [ ushort malloc-array &free ] keep
 208         0 uint <ref>
 209         [ GetVolumePathNamesForVolumeName win32-error=0/f ] 3keep nip
 210         uint deref head but-last-slice
 211         { 0 } split-slice harvest
 212         [ { } ] [ [ { 0 } append alien>native-string ] map ] if-empty
 213     ] with-destructors ;
 214
 215 ! Suppress T{ windows-error f 2 "The system cannot find the file specified." }
 216 : volume>paths ( string -- array )
 217     [ (volume>paths) ] curry
 218     [
 219         dup { [ windows-error? ] [ n>> ERROR_FILE_NOT_FOUND = ] } 1&&
 220         [ drop { } ] [ rethrow ] if
 221     ] recover ;
 222
 223 ! Can error with T{ windows-error f 21 "The device is not ready." }
 224 ! if there is a D: that is not ready, for instance. Ignore these drives.
 225 M: windows file-systems ( -- array )
 226     find-volumes [ volume>paths ] map concat [
 227         [ (file-system-info) ] [ 2drop f ] recover
 228     ] map sift ;
 229
 230 : file-times ( path -- timestamp timestamp timestamp )
 231     [
 232         normalize-path open-read &dispose handle>>
 233         { FILETIME FILETIME FILETIME }
 234         [ GetFileTime win32-error=0/f ]
 235         with-out-parameters
 236         [ FILETIME>timestamp >local-time ] tri@
 237     ] with-destructors ;
 238
 239 : set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
 240     ! timestamp order: creation access write
 241     [
 242         [
 243             normalize-path open-r/w &dispose handle>>
 244         ] 3dip (set-file-times)
 245     ] with-destructors ;
 246
 247 : set-file-create-time ( path timestamp -- )
 248     f f set-file-times ;
 249
 250 : set-file-access-time ( path timestamp -- )
 251     [ f ] dip f set-file-times ;
 252
 253 : set-file-write-time ( path timestamp -- )
 254     [ f f ] dip set-file-times ;
 255
 256 M: windows file-readable?
 257     normalize-path open-read-handle
 258     dup [ CloseHandle win32-error=0/f ] when* >boolean ;
 259
 260 M: windows file-writable? file-info attributes>> +read-only+ swap member? not ;
 261 M: windows file-executable? file-executable-type windows-executable? ;