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