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