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