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