! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays math io.backend io.files.info
io.files.windows io.files.windows.nt kernel windows.kernel32
-windows.time windows accessors alien.c-types combinators
-generalizations system alien.strings io.encodings.utf16n
-sequences splitting windows.errors fry continuations destructors
-calendar ascii combinators.short-circuit ;
+windows.time windows.types windows accessors alien.c-types
+combinators generalizations system alien.strings
+io.encodings.utf16n sequences splitting windows.errors fry
+continuations destructors calendar ascii
+combinators.short-circuit locals classes.struct
+specialized-arrays alien.data ;
+SPECIALIZED-ARRAY: ushort
IN: io.files.info.windows
+:: round-up-to ( n multiple -- n' )
+ n multiple rem [
+ n
+ ] [
+ multiple swap - n +
+ ] if-zero ;
+
TUPLE: windows-file-info < file-info attributes ;
+: get-compressed-file-size ( path -- n )
+ { DWORD } [ GetCompressedFileSize ] [ ] with-out-parameters
+ over INVALID_FILE_SIZE = [ win32-error-string throw ] [ >64bit ] if ;
+
+: set-windows-size-on-disk ( file-info path -- file-info )
+ over attributes>> +compressed+ swap member? [
+ get-compressed-file-size
+ ] [
+ drop dup size>> 4096 round-up-to
+ ] if >>size-on-disk ;
+
: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
[ \ windows-file-info new ] dip
{
- [ WIN32_FIND_DATA-dwFileAttributes win32-file-type >>type ]
- [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes >>attributes ]
- [
- [ WIN32_FIND_DATA-nFileSizeLow ]
- [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit >>size
- ]
- [ WIN32_FIND_DATA-dwFileAttributes >>permissions ]
- [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp >>created ]
- [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp >>modified ]
- [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp >>accessed ]
+ [ dwFileAttributes>> win32-file-type >>type ]
+ [ dwFileAttributes>> win32-file-attributes >>attributes ]
+ [ [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit >>size ]
+ [ dwFileAttributes>> >>permissions ]
+ [ ftCreationTime>> FILETIME>timestamp >>created ]
+ [ ftLastWriteTime>> FILETIME>timestamp >>modified ]
+ [ ftLastAccessTime>> FILETIME>timestamp >>accessed ]
} cleave ;
: find-first-file-stat ( path -- WIN32_FIND_DATA )
- "WIN32_FIND_DATA" <c-object> [
+ WIN32_FIND_DATA <struct> [
FindFirstFile
[ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep
FindClose win32-error=0/f
: BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info )
[ \ windows-file-info new ] dip
{
- [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type >>type ]
- [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes >>attributes ]
- [
- [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ]
- [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit >>size
- ]
- [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes >>permissions ]
- [
- BY_HANDLE_FILE_INFORMATION-ftCreationTime
- FILETIME>timestamp >>created
- ]
- [
- BY_HANDLE_FILE_INFORMATION-ftLastWriteTime
- FILETIME>timestamp >>modified
- ]
+ [ dwFileAttributes>> win32-file-type >>type ]
+ [ dwFileAttributes>> win32-file-attributes >>attributes ]
[
- BY_HANDLE_FILE_INFORMATION-ftLastAccessTime
- FILETIME>timestamp >>accessed
+ [ nFileSizeLow>> ]
+ [ nFileSizeHigh>> ] bi >64bit >>size
]
- ! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ]
+ [ dwFileAttributes>> >>permissions ]
+ [ ftCreationTime>> FILETIME>timestamp >>created ]
+ [ ftLastWriteTime>> FILETIME>timestamp >>modified ]
+ [ ftLastAccessTime>> FILETIME>timestamp >>accessed ]
+ ! [ nNumberOfLinks>> ]
! [
- ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ]
- ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit
+ ! [ nFileIndexLow>> ]
+ ! [ nFileIndexHigh>> ] bi >64bit
! ]
} cleave ;
: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
[
- "BY_HANDLE_FILE_INFORMATION" <c-object>
+ BY_HANDLE_FILE_INFORMATION <struct>
[ GetFileInformationByHandle win32-error=0/f ] keep
] keep CloseHandle win32-error=0/f ;
] if ;
M: windows file-info ( path -- info )
- normalize-path get-file-information-stat ;
+ normalize-path
+ [ get-file-information-stat ]
+ [ set-windows-size-on-disk ] bi ;
M: windows link-info ( path -- info )
file-info ;
+CONSTANT: path-length $[ MAX_PATH 1 + ]
+
: volume-information ( normalized-path -- volume-name volume-serial max-component flags type )
- MAX_PATH 1+ [ <byte-array> ] keep
- "DWORD" <c-object>
- "DWORD" <c-object>
- "DWORD" <c-object>
- MAX_PATH 1+ [ <byte-array> ] keep
- [ GetVolumeInformation win32-error=0/f ] 7 nkeep
- drop 5 nrot drop
- [ utf16n alien>string ] 4 ndip
- utf16n alien>string ;
+ { { ushort path-length } DWORD DWORD DWORD { ushort path-length } }
+ [ [ path-length ] 4dip path-length GetVolumeInformation win32-error=0/f ]
+ [ [ utf16n alien>string ] 4dip utf16n alien>string ]
+ with-out-parameters ;
: file-system-space ( normalized-path -- available-space total-space free-space )
- "ULARGE_INTEGER" <c-object>
- "ULARGE_INTEGER" <c-object>
- "ULARGE_INTEGER" <c-object>
- [ GetDiskFreeSpaceEx win32-error=0/f ] 3keep ;
+ { ULARGE_INTEGER ULARGE_INTEGER ULARGE_INTEGER }
+ [ GetDiskFreeSpaceEx win32-error=0/f ] [ ]
+ with-out-parameters ;
: calculate-file-system-info ( file-system-info -- file-system-info' )
[ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ] keep ;
[ first Letter? ]
} 1&& [ 2 head "\\" append ] [ not-absolute-path ] if ;
-M: winnt file-system-info ( path -- file-system-info )
- normalize-path root-directory
+<PRIVATE
+
+: (file-system-info) ( path -- file-system-info )
dup [ volume-information ] [ file-system-space ] bi
\ win32-file-system-info new
- swap *ulonglong >>free-space
- swap *ulonglong >>total-space
- swap *ulonglong >>available-space
+ swap >>free-space
+ swap >>total-space
+ swap >>available-space
swap >>type
- swap *uint >>flags
- swap *uint >>max-component
- swap *uint >>device-serial
+ swap >>flags
+ swap >>max-component
+ swap >>device-serial
swap >>device-name
swap >>mount-point
calculate-file-system-info ;
+PRIVATE>
+
+M: winnt file-system-info ( path -- file-system-info )
+ normalize-path root-directory (file-system-info) ;
+
+CONSTANT: names-buf-length 16384
+
: volume>paths ( string -- array )
- 16384 "ushort" <c-array> tuck dup length
- 0 <uint> dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [
- win32-error-string throw
- ] [
- *uint "ushort" heap-size * head
- utf16n alien>string CHAR: \0 split
- ] if ;
+ { { ushort names-buf-length } uint }
+ [ [ names-buf-length ] dip GetVolumePathNamesForVolumeName win32-error=0/f ]
+ [ head utf16n alien>string { CHAR: \0 } split ]
+ with-out-parameters ;
: find-first-volume ( -- string handle )
- MAX_PATH 1+ [ <byte-array> ] keep
- dupd
- FindFirstVolume dup win32-error=0/f
- [ utf16n alien>string ] dip ;
+ { { ushort path-length } }
+ [ path-length FindFirstVolume dup win32-error=0/f ]
+ [ utf16n alien>string ]
+ with-out-parameters swap ;
: find-next-volume ( handle -- string/f )
- MAX_PATH 1+ [ <byte-array> tuck ] keep
- FindNextVolume 0 = [
- GetLastError ERROR_NO_MORE_FILES =
- [ drop f ] [ win32-error-string throw ] if
- ] [
- utf16n alien>string
- ] if ;
+ { { ushort path-length } }
+ [ path-length FindNextVolume ]
+ [
+ swap 0 = [
+ GetLastError ERROR_NO_MORE_FILES =
+ [ drop f ] [ win32-error-string throw ] if
+ ] [ utf16n alien>string ] if
+ ] with-out-parameters ;
: find-volumes ( -- array )
find-first-volume
M: winnt file-systems ( -- array )
find-volumes [ volume>paths ] map
concat [
- [ file-system-info ]
+ [ (file-system-info) ]
[ drop \ file-system-info new swap >>mount-point ] recover
] map ;
: file-times ( path -- timestamp timestamp timestamp )
[
- normalize-path open-existing &dispose handle>>
- "FILETIME" <c-object>
- "FILETIME" <c-object>
- "FILETIME" <c-object>
- [ GetFileTime win32-error=0/f ] 3keep
- [ FILETIME>timestamp >local-time ] tri@
+ normalize-path open-read &dispose handle>>
+ { FILETIME FILETIME FILETIME }
+ [ GetFileTime win32-error=0/f ]
+ [ [ FILETIME>timestamp >local-time ] tri@ ]
+ with-out-parameters
] with-destructors ;
: set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
projects / factor.git / blobdiff