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 kernel windows.kernel32
   5 windows.time windows.types windows accessors alien.c-types
   6 combinators generalizations system alien.strings
   7 sequences splitting windows.errors fry
   8 continuations destructors calendar ascii
   9 combinators.short-circuit literals locals classes.struct
  10 specialized-arrays alien.data libc windows.shell32 ;
  11 SPECIALIZED-ARRAY: ushort
  12 QUALIFIED: sequences
  13 IN: io.files.info.windows
  14
  15 :: round-up-to ( n multiple -- n' )
  16     n multiple rem [
  17         n
  18     ] [
  19         multiple swap - n +
  20     ] if-zero ;
  21
  22 TUPLE: windows-file-info < file-info-tuple attributes ;
  23
  24 : get-compressed-file-size ( path -- n )
  25     { DWORD } [ GetCompressedFileSize ] with-out-parameters
  26     over INVALID_FILE_SIZE = [ win32-error-string throw ] [ >64bit ] 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 : file-executable-type ( path -- executable/f )
 100     normalize-path dup
 101     0
 102     f
 103     ! hi is zero means old style executable
 104     0 SHGFI_EXETYPE SHGetFileInfoW
 105     [
 106         file-info drop f
 107     ] [
 108         nip >lo-hi first2 zero? [
 109             {
 110                 { 0x5A4D [ +dos-executable+ ] }
 111                 { 0x4550 [ +win32-console-executable+ ] }
 112                 [ drop f ]
 113             } case
 114         ] [
 115             {
 116                 { 0x454C [ +win32-vxd-executable+ ] }
 117                 { 0x454E [ +win32-os2-executable+ ] }
 118                 { 0x4550 [ +win32-nt-executable+ ] }
 119                 [ drop f ]
 120             } case
 121         ] if
 122     ] if-zero ;
 123
 124 CONSTANT: path-length $[ MAX_PATH 1 + ]
 125
 126 : volume-information ( normalized-path -- volume-name volume-serial max-component flags type )
 127     { { ushort path-length } DWORD DWORD DWORD { ushort path-length } }
 128     [ [ path-length ] 4dip path-length GetVolumeInformation win32-error=0/f ]
 129     with-out-parameters
 130     [ alien>native-string ] 4dip alien>native-string ;
 131
 132 : file-system-space ( normalized-path -- available-space total-space free-space )
 133     { ULARGE_INTEGER ULARGE_INTEGER ULARGE_INTEGER }
 134     [ GetDiskFreeSpaceEx win32-error=0/f ]
 135     with-out-parameters ;
 136
 137 : calculate-file-system-info ( file-system-info -- file-system-info' )
 138     [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ] keep ;
 139
 140 TUPLE: win32-file-system-info < file-system-info-tuple max-component flags device-serial ;
 141
 142 ERROR: not-absolute-path ;
 143
 144 : root-directory ( string -- string' )
 145     unicode-prefix ?head drop
 146     dup {
 147         [ length 2 >= ]
 148         [ second CHAR: : = ]
 149         [ first Letter? ]
 150     } 1&& [ 2 head "\\" append ] [ not-absolute-path ] if ;
 151
 152 <PRIVATE
 153
 154 : (file-system-info) ( path -- file-system-info )
 155     dup [ volume-information ] [ file-system-space ] bi
 156     \ win32-file-system-info new
 157         swap >>free-space
 158         swap >>total-space
 159         swap >>available-space
 160         swap >>type
 161         swap >>flags
 162         swap >>max-component
 163         swap >>device-serial
 164         swap >>device-name
 165         swap >>mount-point
 166     calculate-file-system-info ;
 167
 168 PRIVATE>
 169
 170 M: windows file-system-info ( path -- file-system-info )
 171     normalize-path root-directory (file-system-info) ;
 172
 173 CONSTANT: names-buf-length 16384
 174
 175 : find-first-volume ( -- string handle )
 176     { { ushort path-length } }
 177     [ path-length FindFirstVolume dup win32-error=0/f ]
 178     with-out-parameters alien>native-string swap ;
 179
 180 : find-next-volume ( handle -- string/f )
 181     { { ushort path-length } }
 182     [ path-length FindNextVolume ] with-out-parameters
 183     swap 0 = [
 184         GetLastError ERROR_NO_MORE_FILES =
 185         [ drop f ] [ win32-error-string throw ] if
 186     ] [ alien>native-string ] if ;
 187
 188 : find-volumes ( -- array )
 189     find-first-volume
 190     [
 191         '[
 192             [ _ find-next-volume dup ] [ ] produce nip
 193             swap prefix
 194         ]
 195     ] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup ;
 196
 197 ! Windows may return a volume which looks up to path ""
 198 ! For now, treat it like there is not a volume here
 199 : volume>paths ( string -- array )
 200     [
 201         names-buf-length
 202         [ ushort malloc-array &free ] keep
 203         0 uint <ref>
 204         [ GetVolumePathNamesForVolumeName win32-error=0/f ] 3keep nip
 205         uint deref head but-last-slice
 206         { 0 } split-slice harvest
 207         [ { } ] [ [ { 0 } append alien>native-string ] map ] if-empty
 208     ] with-destructors ;
 209
 210 ! Can error with T{ windows-error f 21 "The device is not ready." }
 211 ! if there is a D: that is not ready, for instance. Ignore these drives.
 212 M: windows file-systems ( -- array )
 213     find-volumes [ volume>paths ] map concat [
 214         [ (file-system-info) ] [ 2drop f ] recover
 215     ] map sift ;
 216
 217 : file-times ( path -- timestamp timestamp timestamp )
 218     [
 219         normalize-path open-read &dispose handle>>
 220         { FILETIME FILETIME FILETIME }
 221         [ GetFileTime win32-error=0/f ]
 222         with-out-parameters
 223         [ FILETIME>timestamp >local-time ] tri@
 224     ] with-destructors ;
 225
 226 : set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
 227     ! timestamp order: creation access write
 228     [
 229         [
 230             normalize-path open-existing &dispose handle>>
 231         ] 3dip (set-file-times)
 232     ] with-destructors ;
 233
 234 : set-file-create-time ( path timestamp -- )
 235     f f set-file-times ;
 236
 237 : set-file-access-time ( path timestamp -- )
 238     [ f ] dip f set-file-times ;
 239
 240 : set-file-write-time ( path timestamp -- )
 241     [ f f ] dip set-file-times ;
 242
 243 M: windows file-readable? file-info >boolean ;
 244 M: windows file-writable? file-info attributes>> +read-only+ swap member? not ;
 245 M: windows file-executable? file-executable-type windows-executable? ;