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