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 io.files.windows.nt kernel windows.kernel32
   5 windows.time windows.types windows accessors alien.c-types
   6 combinators generalizations system alien.strings
   7 io.encodings.utf16n sequences splitting windows.errors fry
   8 continuations destructors calendar ascii
   9 combinators.short-circuit locals classes.struct
  10 specialized-arrays alien.data ;
  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 attributes ;
  22
  23 : get-compressed-file-size ( path -- n )
  24     DWORD <c-object> [ GetCompressedFileSize ] keep
  25     over INVALID_FILE_SIZE = [
  26         win32-error-string throw
  27     ] [
  28         *uint >64bit
  29     ] if ;
  30
  31 : set-windows-size-on-disk ( file-info path -- file-info )
  32     over attributes>> +compressed+ swap member? [
  33         get-compressed-file-size
  34     ] [
  35         drop dup size>> 4096 round-up-to
  36     ] if >>size-on-disk ;
  37
  38 : WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
  39     [ \ windows-file-info new ] dip
  40     {
  41         [ dwFileAttributes>> win32-file-type >>type ]
  42         [ dwFileAttributes>> win32-file-attributes >>attributes ]
  43         [ [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit >>size ]
  44         [ dwFileAttributes>> >>permissions ]
  45         [ ftCreationTime>> FILETIME>timestamp >>created ]
  46         [ ftLastWriteTime>> FILETIME>timestamp >>modified ]
  47         [ ftLastAccessTime>> FILETIME>timestamp >>accessed ]
  48     } cleave ;
  49
  50 : find-first-file-stat ( path -- WIN32_FIND_DATA )
  51     WIN32_FIND_DATA <struct> [
  52         FindFirstFile
  53         [ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep
  54         FindClose win32-error=0/f
  55     ] keep ;
  56
  57 : BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info )
  58     [ \ windows-file-info new ] dip
  59     {
  60         [ dwFileAttributes>> win32-file-type >>type ]
  61         [ dwFileAttributes>> win32-file-attributes >>attributes ]
  62         [
  63             [ nFileSizeLow>> ]
  64             [ nFileSizeHigh>> ] bi >64bit >>size
  65         ]
  66         [ dwFileAttributes>> >>permissions ]
  67         [ ftCreationTime>> FILETIME>timestamp >>created ]
  68         [ ftLastWriteTime>> FILETIME>timestamp >>modified ]
  69         [ ftLastAccessTime>> FILETIME>timestamp >>accessed ]
  70         ! [ nNumberOfLinks>> ]
  71         ! [
  72           ! [ nFileIndexLow>> ]
  73           ! [ nFileIndexHigh>> ] bi >64bit
  74         ! ]
  75     } cleave ;
  76
  77 : get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
  78     [
  79         BY_HANDLE_FILE_INFORMATION <struct>
  80         [ GetFileInformationByHandle win32-error=0/f ] keep
  81     ] keep CloseHandle win32-error=0/f ;
  82
  83 : get-file-information-stat ( path -- BY_HANDLE_FILE_INFORMATION )
  84     dup
  85     GENERIC_READ FILE_SHARE_READ f
  86     OPEN_EXISTING FILE_FLAG_BACKUP_SEMANTICS f
  87     CreateFileW dup INVALID_HANDLE_VALUE = [
  88         drop find-first-file-stat WIN32_FIND_DATA>file-info
  89     ] [
  90         nip
  91         get-file-information BY_HANDLE_FILE_INFORMATION>file-info
  92     ] if ;
  93
  94 M: windows file-info ( path -- info )
  95     normalize-path
  96     [ get-file-information-stat ]
  97     [ set-windows-size-on-disk ] bi ;
  98
  99 M: windows link-info ( path -- info )
 100     file-info ;
 101
 102 : volume-information ( normalized-path -- volume-name volume-serial max-component flags type )
 103     MAX_PATH 1 + [ <ushort-array> ] keep
 104     DWORD <c-object>
 105     DWORD <c-object>
 106     DWORD <c-object>
 107     MAX_PATH 1 + [ <ushort-array> ] keep
 108     [ GetVolumeInformation win32-error=0/f ] 7 nkeep
 109     drop 5 nrot drop
 110     [ utf16n alien>string ] 4 ndip
 111     utf16n alien>string ;
 112
 113 : file-system-space ( normalized-path -- available-space total-space free-space )
 114     ULARGE_INTEGER <c-object>
 115     ULARGE_INTEGER <c-object>
 116     ULARGE_INTEGER <c-object>
 117     [ GetDiskFreeSpaceEx win32-error=0/f ] 3keep ;
 118
 119 : calculate-file-system-info ( file-system-info -- file-system-info' )
 120     [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ] keep ;
 121
 122 TUPLE: win32-file-system-info < file-system-info max-component flags device-serial ;
 123
 124 ERROR: not-absolute-path ;
 125
 126 : root-directory ( string -- string' )
 127     unicode-prefix ?head drop
 128     dup {
 129         [ length 2 >= ]
 130         [ second CHAR: : = ]
 131         [ first Letter? ]
 132     } 1&& [ 2 head "\\" append ] [ not-absolute-path ] if ;
 133
 134 <PRIVATE
 135
 136 : (file-system-info) ( path -- file-system-info )
 137     dup [ volume-information ] [ file-system-space ] bi
 138     \ win32-file-system-info new
 139         swap *ulonglong >>free-space
 140         swap *ulonglong >>total-space
 141         swap *ulonglong >>available-space
 142         swap >>type
 143         swap *uint >>flags
 144         swap *uint >>max-component
 145         swap *uint >>device-serial
 146         swap >>device-name
 147         swap >>mount-point
 148     calculate-file-system-info ;
 149
 150 PRIVATE>
 151
 152 M: winnt file-system-info ( path -- file-system-info )
 153     normalize-path root-directory (file-system-info) ;
 154
 155 :: volume>paths ( string -- array )
 156     16384 :> names-buf-length
 157     names-buf-length <ushort-array> :> names
 158     0 <uint> :> names-length
 159
 160     string names names-buf-length names-length GetVolumePathNamesForVolumeName :> ret
 161     ret 0 = [
 162         ret win32-error-string throw
 163     ] [
 164         names names-length *uint ushort heap-size * head
 165         utf16n alien>string { CHAR: \0 } split
 166     ] if ;
 167
 168 : find-first-volume ( -- string handle )
 169     MAX_PATH 1 + [ <ushort-array> ] keep
 170     dupd
 171     FindFirstVolume dup win32-error=0/f
 172     [ utf16n alien>string ] dip ;
 173
 174 :: find-next-volume ( handle -- string/f )
 175     MAX_PATH 1 + :> buf-length
 176     buf-length <ushort-array> :> buf
 177
 178     handle buf buf-length FindNextVolume :> ret
 179     ret 0 = [
 180         GetLastError ERROR_NO_MORE_FILES =
 181         [ f ] [ win32-error-string throw ] if
 182     ] [
 183         buf utf16n alien>string
 184     ] if ;
 185
 186 : find-volumes ( -- array )
 187     find-first-volume
 188     [
 189         '[
 190             [ _ find-next-volume dup ] [ ] produce nip
 191             swap prefix
 192         ]
 193     ] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup ;
 194
 195 M: winnt file-systems ( -- array )
 196     find-volumes [ volume>paths ] map
 197     concat [
 198         [ (file-system-info) ]
 199         [ drop \ file-system-info new swap >>mount-point ] recover
 200     ] map ;
 201
 202 : file-times ( path -- timestamp timestamp timestamp )
 203     [
 204         normalize-path open-read &dispose handle>>
 205         FILETIME <struct>
 206         FILETIME <struct>
 207         FILETIME <struct>
 208         [ GetFileTime win32-error=0/f ] 3keep
 209         [ FILETIME>timestamp >local-time ] tri@
 210     ] with-destructors ;
 211
 212 : set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
 213     #! timestamp order: creation access write
 214     [
 215         [
 216             normalize-path open-existing &dispose handle>>
 217         ] 3dip (set-file-times)
 218     ] with-destructors ;
 219
 220 : set-file-create-time ( path timestamp -- )
 221     f f set-file-times ;
 222
 223 : set-file-access-time ( path timestamp -- )
 224     [ f ] dip f set-file-times ;
 225
 226 : set-file-write-time ( path timestamp -- )
 227     [ f f ] dip set-file-times ;