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