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