basis/io/windows/files/files.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien.c-types io.binary io.backend io.files io.buffers
   4 io.encodings.utf16n io.ports io.windows kernel math splitting
   5 fry alien.strings windows windows.kernel32 windows.time calendar
   6 combinators math.functions sequences namespaces make words
   7 symbols system destructors accessors math.bitwise continuations
   8 windows.errors arrays byte-arrays generalizations ;
   9 IN: io.windows.files
  10
  11 : open-file ( path access-mode create-mode flags -- handle )
  12     [
  13         [ share-mode default-security-attributes ] 2dip
  14         CreateFile-flags f CreateFile opened-file
  15     ] with-destructors ;
  16
  17 : open-pipe-r/w ( path -- win32-file )
  18     { GENERIC_READ GENERIC_WRITE } flags
  19     OPEN_EXISTING 0 open-file ;
  20
  21 : open-read ( path -- win32-file )
  22     GENERIC_READ OPEN_EXISTING 0 open-file 0 >>ptr ;
  23
  24 : open-write ( path -- win32-file )
  25     GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 >>ptr ;
  26
  27 : (open-append) ( path -- win32-file )
  28     GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
  29
  30 : open-existing ( path -- win32-file )
  31     { GENERIC_READ GENERIC_WRITE } flags
  32     share-mode
  33     f
  34     OPEN_EXISTING
  35     FILE_FLAG_BACKUP_SEMANTICS
  36     f CreateFileW dup win32-error=0/f <win32-file> ;
  37
  38 : maybe-create-file ( path -- win32-file ? )
  39     #! return true if file was just created
  40     { GENERIC_READ GENERIC_WRITE } flags
  41     share-mode
  42     f
  43     OPEN_ALWAYS
  44     0 CreateFile-flags
  45     f CreateFileW dup win32-error=0/f <win32-file>
  46     GetLastError ERROR_ALREADY_EXISTS = not ;
  47
  48 : set-file-pointer ( handle length method -- )
  49     [ dupd d>w/w <uint> ] dip SetFilePointer
  50     INVALID_SET_FILE_POINTER = [
  51         CloseHandle "SetFilePointer failed" throw
  52     ] when drop ;
  53
  54 HOOK: open-append os ( path -- win32-file )
  55
  56 TUPLE: FileArgs
  57     hFile lpBuffer nNumberOfBytesToRead
  58     lpNumberOfBytesRet lpOverlapped ;
  59
  60 C: <FileArgs> FileArgs
  61
  62 : make-FileArgs ( port -- <FileArgs> )
  63     {
  64         [ handle>> check-disposed ]
  65         [ handle>> handle>> ]
  66         [ buffer>> ]
  67         [ buffer>> buffer-length ]
  68         [ drop "DWORD" <c-object> ]
  69         [ FileArgs-overlapped ]
  70     } cleave <FileArgs> ;
  71
  72 : setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
  73     {
  74         [ hFile>> ]
  75         [ lpBuffer>> buffer-end ]
  76         [ lpBuffer>> buffer-capacity ]
  77         [ lpNumberOfBytesRet>> ]
  78         [ lpOverlapped>> ]
  79     } cleave ;
  80
  81 : setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
  82     {
  83         [ hFile>> ]
  84         [ lpBuffer>> buffer@ ]
  85         [ lpBuffer>> buffer-length ]
  86         [ lpNumberOfBytesRet>> ]
  87         [ lpOverlapped>> ]
  88     } cleave ;
  89
  90 M: windows (file-reader) ( path -- stream )
  91     open-read <input-port> ;
  92
  93 M: windows (file-writer) ( path -- stream )
  94     open-write <output-port> ;
  95
  96 M: windows (file-appender) ( path -- stream )
  97     open-append <output-port> ;
  98
  99 M: windows move-file ( from to -- )
 100     [ normalize-path ] bi@ MoveFile win32-error=0/f ;
 101
 102 M: windows delete-file ( path -- )
 103     normalize-path DeleteFile win32-error=0/f ;
 104
 105 M: windows copy-file ( from to -- )
 106     dup parent-directory make-directories
 107     [ normalize-path ] bi@ 0 CopyFile win32-error=0/f ;
 108
 109 M: windows make-directory ( path -- )
 110     normalize-path
 111     f CreateDirectory win32-error=0/f ;
 112
 113 M: windows delete-directory ( path -- )
 114     normalize-path
 115     RemoveDirectory win32-error=0/f ;
 116
 117 : find-first-file ( path -- WIN32_FIND_DATA handle )
 118     "WIN32_FIND_DATA" <c-object> tuck
 119     FindFirstFile
 120     [ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ;
 121
 122 : find-next-file ( path -- WIN32_FIND_DATA/f )
 123     "WIN32_FIND_DATA" <c-object> tuck
 124     FindNextFile 0 = [
 125         GetLastError ERROR_NO_MORE_FILES = [
 126             win32-error
 127         ] unless drop f
 128     ] when ;
 129
 130 M: windows (directory-entries) ( path -- seq )
 131     "\\" ?tail drop "\\*" append
 132     find-first-file [ >directory-entry ] dip
 133     [
 134         '[
 135             [ _ find-next-file dup ]
 136             [ >directory-entry ]
 137             [ drop ] produce
 138             over name>> "." = [ nip ] [ swap prefix ] if
 139         ]
 140     ] [ '[ _ FindClose win32-error=0/f ] ] bi [ ] cleanup ;
 141
 142 SYMBOLS: +read-only+ +hidden+ +system+
 143 +archive+ +device+ +normal+ +temporary+
 144 +sparse-file+ +reparse-point+ +compressed+ +offline+
 145 +not-content-indexed+ +encrypted+ ;
 146
 147 TUPLE: windows-file-info < file-info attributes ;
 148
 149 : win32-file-attribute ( n attr symbol -- )
 150     rot mask? [ , ] [ drop ] if ;
 151
 152 : win32-file-attributes ( n -- seq )
 153     [
 154         {
 155             [ +read-only+ FILE_ATTRIBUTE_READONLY win32-file-attribute ]
 156             [ +hidden+ FILE_ATTRIBUTE_HIDDEN win32-file-attribute ]
 157             [ +system+ FILE_ATTRIBUTE_SYSTEM win32-file-attribute ]
 158             [ +directory+ FILE_ATTRIBUTE_DIRECTORY win32-file-attribute ]
 159             [ +archive+ FILE_ATTRIBUTE_ARCHIVE win32-file-attribute ]
 160             [ +device+ FILE_ATTRIBUTE_DEVICE win32-file-attribute ]
 161             [ +normal+ FILE_ATTRIBUTE_NORMAL win32-file-attribute ]
 162             [ +temporary+ FILE_ATTRIBUTE_TEMPORARY win32-file-attribute ]
 163             [ +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE win32-file-attribute ]
 164             [ +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT win32-file-attribute ]
 165             [ +compressed+ FILE_ATTRIBUTE_COMPRESSED win32-file-attribute ]
 166             [ +offline+ FILE_ATTRIBUTE_OFFLINE win32-file-attribute ]
 167             [ +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED win32-file-attribute ]
 168             [ +encrypted+ FILE_ATTRIBUTE_ENCRYPTED win32-file-attribute ]
 169         } cleave
 170     ] { } make ;
 171
 172 : win32-file-type ( n -- symbol )
 173     FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
 174
 175 TUPLE: windows-directory-entry < directory-entry attributes ;
 176
 177 M: windows >directory-entry ( byte-array -- directory-entry )
 178     [ WIN32_FIND_DATA-cFileName utf16n alien>string ]
 179     [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ]
 180     [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ]
 181     tri
 182     dupd remove windows-directory-entry boa ;
 183
 184 : WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
 185     [ \ windows-file-info new ] dip
 186     {
 187         [ WIN32_FIND_DATA-dwFileAttributes win32-file-type >>type ]
 188         [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes >>attributes ]
 189         [
 190             [ WIN32_FIND_DATA-nFileSizeLow ]
 191             [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit >>size
 192         ]
 193         [ WIN32_FIND_DATA-dwFileAttributes >>permissions ]
 194         [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp >>created ]
 195         [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp >>modified ]
 196         [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp >>accessed ]
 197     } cleave ;
 198
 199 : find-first-file-stat ( path -- WIN32_FIND_DATA )
 200     "WIN32_FIND_DATA" <c-object> [
 201         FindFirstFile
 202         [ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep
 203         FindClose win32-error=0/f
 204     ] keep ;
 205
 206 : BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info )
 207     [ \ windows-file-info new ] dip
 208     {
 209         [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type >>type ]
 210         [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes >>attributes ]
 211         [
 212             [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ]
 213             [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit >>size
 214         ]
 215         [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes >>permissions ]
 216         [
 217             BY_HANDLE_FILE_INFORMATION-ftCreationTime
 218             FILETIME>timestamp >>created
 219         ]
 220         [
 221             BY_HANDLE_FILE_INFORMATION-ftLastWriteTime
 222             FILETIME>timestamp >>modified
 223         ]
 224         [
 225             BY_HANDLE_FILE_INFORMATION-ftLastAccessTime
 226             FILETIME>timestamp >>accessed
 227         ]
 228         ! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ]
 229         ! [
 230           ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ]
 231           ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit
 232         ! ]
 233     } cleave ;
 234
 235 : get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
 236     [
 237         "BY_HANDLE_FILE_INFORMATION" <c-object>
 238         [ GetFileInformationByHandle win32-error=0/f ] keep
 239     ] keep CloseHandle win32-error=0/f ;
 240
 241 : get-file-information-stat ( path -- BY_HANDLE_FILE_INFORMATION )
 242     dup
 243     GENERIC_READ FILE_SHARE_READ f
 244     OPEN_EXISTING FILE_FLAG_BACKUP_SEMANTICS f
 245     CreateFileW dup INVALID_HANDLE_VALUE = [
 246         drop find-first-file-stat WIN32_FIND_DATA>file-info
 247     ] [
 248         nip
 249         get-file-information BY_HANDLE_FILE_INFORMATION>file-info
 250     ] if ;
 251
 252 M: winnt file-info ( path -- info )
 253     normalize-path get-file-information-stat ;
 254
 255 M: winnt link-info ( path -- info )
 256     file-info ;
 257
 258 HOOK: root-directory os ( string -- string' )
 259
 260 : volume-information ( normalized-path -- volume-name volume-serial max-component flags type )
 261     MAX_PATH 1+ [ <byte-array> ] keep
 262     "DWORD" <c-object>
 263     "DWORD" <c-object>
 264     "DWORD" <c-object>
 265     MAX_PATH 1+ [ <byte-array> ] keep
 266     [ GetVolumeInformation win32-error=0/f ] 7 nkeep
 267     drop 5 nrot drop
 268     [ utf16n alien>string ] 4 ndip
 269     utf16n alien>string ;
 270
 271 : file-system-space ( normalized-path -- available-space total-space free-space )
 272     "ULARGE_INTEGER" <c-object>
 273     "ULARGE_INTEGER" <c-object>
 274     "ULARGE_INTEGER" <c-object>
 275     [ GetDiskFreeSpaceEx win32-error=0/f ] 3keep ;
 276
 277 : calculate-file-system-info ( file-system-info -- file-system-info' )
 278     {
 279         [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ]
 280         [ ]
 281     } cleave ;
 282
 283 TUPLE: win32-file-system-info < file-system-info max-component flags device-serial ;
 284
 285 M: winnt file-system-info ( path -- file-system-info )
 286     normalize-path root-directory
 287     dup [ volume-information ] [ file-system-space ] bi
 288     \ win32-file-system-info new
 289         swap *ulonglong >>free-space
 290         swap *ulonglong >>total-space
 291         swap *ulonglong >>available-space
 292         swap >>type
 293         swap *uint >>flags
 294         swap *uint >>max-component
 295         swap *uint >>device-serial
 296         swap >>device-name
 297         swap >>mount-point
 298     calculate-file-system-info ;
 299
 300 : volume>paths ( string -- array )
 301     16384 "ushort" <c-array> tuck dup length
 302     0 <uint> dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [
 303         win32-error-string throw
 304     ] [
 305         *uint "ushort" heap-size * head
 306         utf16n alien>string CHAR: \0 split
 307     ] if ;
 308
 309 : find-first-volume ( -- string handle )
 310     MAX_PATH 1+ [ <byte-array> ] keep
 311     dupd
 312     FindFirstVolume dup win32-error=0/f
 313     [ utf16n alien>string ] dip ;
 314
 315 : find-next-volume ( handle -- string/f )
 316     MAX_PATH 1+ [ <byte-array> tuck ] keep
 317     FindNextVolume 0 = [
 318         GetLastError ERROR_NO_MORE_FILES =
 319         [ drop f ] [ win32-error-string throw ] if
 320     ] [
 321         utf16n alien>string
 322     ] if ;
 323
 324 : find-volumes ( -- array )
 325     find-first-volume
 326     [
 327         '[
 328             [ _ find-next-volume dup ]
 329             [ ]
 330             [ drop ] produce
 331             swap prefix
 332         ]
 333     ] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup ;
 334
 335 M: winnt file-systems ( -- array )
 336     find-volumes [ volume>paths ] map
 337     concat [
 338         [ file-system-info ]
 339         [ drop \ file-system-info new swap >>mount-point ] recover
 340     ] map ;
 341
 342 : file-times ( path -- timestamp timestamp timestamp )
 343     [
 344         normalize-path open-existing &dispose handle>>
 345         "FILETIME" <c-object>
 346         "FILETIME" <c-object>
 347         "FILETIME" <c-object>
 348         [ GetFileTime win32-error=0/f ] 3keep
 349         [ FILETIME>timestamp >local-time ] tri@
 350     ] with-destructors ;
 351
 352 : (set-file-times) ( handle timestamp/f timestamp/f timestamp/f -- )
 353     [ timestamp>FILETIME ] tri@
 354     SetFileTime win32-error=0/f ;
 355
 356 : set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
 357     #! timestamp order: creation access write
 358     [
 359         [
 360             normalize-path open-existing &dispose handle>>
 361         ] 3dip (set-file-times)
 362     ] with-destructors ;
 363
 364 : set-file-create-time ( path timestamp -- )
 365     f f set-file-times ;
 366
 367 : set-file-access-time ( path timestamp -- )
 368     [ f ] dip f set-file-times ;
 369
 370 : set-file-write-time ( path timestamp -- )
 371     [ f f ] dip set-file-times ;
 372
 373 M: winnt touch-file ( path -- )
 374     [
 375         normalize-path
 376         maybe-create-file [ &dispose ] dip
 377         [ drop ] [ handle>> f now dup (set-file-times) ] if
 378     ] with-destructors ;