367 lines
12 KiB
Factor
Executable File
367 lines
12 KiB
Factor
Executable File
! Copyright (C) 2008 Doug Coleman.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: alien.c-types io.binary io.backend io.files io.buffers
|
|
io.windows kernel math splitting fry alien.strings
|
|
windows windows.kernel32 windows.time calendar combinators
|
|
math.functions sequences namespaces make words symbols system
|
|
io.ports destructors accessors math.bitwise continuations
|
|
windows.errors arrays byte-arrays ;
|
|
IN: io.windows.files
|
|
|
|
: open-file ( path access-mode create-mode flags -- handle )
|
|
[
|
|
>r >r share-mode default-security-attributes r> r>
|
|
CreateFile-flags f CreateFile opened-file
|
|
] with-destructors ;
|
|
|
|
: open-pipe-r/w ( path -- win32-file )
|
|
{ GENERIC_READ GENERIC_WRITE } flags
|
|
OPEN_EXISTING 0 open-file ;
|
|
|
|
: open-read ( path -- win32-file )
|
|
GENERIC_READ OPEN_EXISTING 0 open-file 0 >>ptr ;
|
|
|
|
: open-write ( path -- win32-file )
|
|
GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 >>ptr ;
|
|
|
|
: (open-append) ( path -- win32-file )
|
|
GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
|
|
|
|
: open-existing ( path -- win32-file )
|
|
{ GENERIC_READ GENERIC_WRITE } flags
|
|
share-mode
|
|
f
|
|
OPEN_EXISTING
|
|
FILE_FLAG_BACKUP_SEMANTICS
|
|
f CreateFileW dup win32-error=0/f <win32-file> ;
|
|
|
|
: maybe-create-file ( path -- win32-file ? )
|
|
#! return true if file was just created
|
|
{ GENERIC_READ GENERIC_WRITE } flags
|
|
share-mode
|
|
f
|
|
OPEN_ALWAYS
|
|
0 CreateFile-flags
|
|
f CreateFileW dup win32-error=0/f <win32-file>
|
|
GetLastError ERROR_ALREADY_EXISTS = not ;
|
|
|
|
: set-file-pointer ( handle length method -- )
|
|
>r dupd d>w/w <uint> r> SetFilePointer
|
|
INVALID_SET_FILE_POINTER = [
|
|
CloseHandle "SetFilePointer failed" throw
|
|
] when drop ;
|
|
|
|
HOOK: open-append os ( path -- win32-file )
|
|
|
|
TUPLE: FileArgs
|
|
hFile lpBuffer nNumberOfBytesToRead
|
|
lpNumberOfBytesRet lpOverlapped ;
|
|
|
|
C: <FileArgs> FileArgs
|
|
|
|
: make-FileArgs ( port -- <FileArgs> )
|
|
{
|
|
[ handle>> check-disposed ]
|
|
[ handle>> handle>> ]
|
|
[ buffer>> ]
|
|
[ buffer>> buffer-length ]
|
|
[ drop "DWORD" <c-object> ]
|
|
[ FileArgs-overlapped ]
|
|
} cleave <FileArgs> ;
|
|
|
|
: setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
|
|
{
|
|
[ hFile>> ]
|
|
[ lpBuffer>> buffer-end ]
|
|
[ lpBuffer>> buffer-capacity ]
|
|
[ lpNumberOfBytesRet>> ]
|
|
[ lpOverlapped>> ]
|
|
} cleave ;
|
|
|
|
: setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
|
|
{
|
|
[ hFile>> ]
|
|
[ lpBuffer>> buffer@ ]
|
|
[ lpBuffer>> buffer-length ]
|
|
[ lpNumberOfBytesRet>> ]
|
|
[ lpOverlapped>> ]
|
|
} cleave ;
|
|
|
|
M: windows (file-reader) ( path -- stream )
|
|
open-read <input-port> ;
|
|
|
|
M: windows (file-writer) ( path -- stream )
|
|
open-write <output-port> ;
|
|
|
|
M: windows (file-appender) ( path -- stream )
|
|
open-append <output-port> ;
|
|
|
|
M: windows move-file ( from to -- )
|
|
[ normalize-path ] bi@ MoveFile win32-error=0/f ;
|
|
|
|
M: windows delete-file ( path -- )
|
|
normalize-path DeleteFile win32-error=0/f ;
|
|
|
|
M: windows copy-file ( from to -- )
|
|
dup parent-directory make-directories
|
|
[ normalize-path ] bi@ 0 CopyFile win32-error=0/f ;
|
|
|
|
M: windows make-directory ( path -- )
|
|
normalize-path
|
|
f CreateDirectory win32-error=0/f ;
|
|
|
|
M: windows delete-directory ( path -- )
|
|
normalize-path
|
|
RemoveDirectory win32-error=0/f ;
|
|
|
|
: find-first-file ( path -- WIN32_FIND_DATA handle )
|
|
"WIN32_FIND_DATA" <c-object> tuck
|
|
FindFirstFile
|
|
[ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep ;
|
|
|
|
: find-next-file ( path -- WIN32_FIND_DATA/f )
|
|
"WIN32_FIND_DATA" <c-object> tuck
|
|
FindNextFile 0 = [
|
|
GetLastError ERROR_NO_MORE_FILES = [
|
|
win32-error
|
|
] unless drop f
|
|
] when ;
|
|
|
|
M: windows (directory-entries) ( path -- seq )
|
|
"\\" ?tail drop "\\*" append
|
|
find-first-file [ >directory-entry ] dip
|
|
[
|
|
'[
|
|
[ _ find-next-file dup ]
|
|
[ >directory-entry ]
|
|
[ drop ] produce
|
|
over name>> "." = [ nip ] [ swap prefix ] if
|
|
]
|
|
] [ '[ _ FindClose win32-error=0/f ] ] bi [ ] cleanup ;
|
|
|
|
SYMBOLS: +read-only+ +hidden+ +system+
|
|
+archive+ +device+ +normal+ +temporary+
|
|
+sparse-file+ +reparse-point+ +compressed+ +offline+
|
|
+not-content-indexed+ +encrypted+ ;
|
|
|
|
TUPLE: windows-file-info < file-info attributes ;
|
|
|
|
: win32-file-attribute ( n attr symbol -- )
|
|
rot mask? [ , ] [ drop ] if ;
|
|
|
|
: win32-file-attributes ( n -- seq )
|
|
[
|
|
{
|
|
[ +read-only+ FILE_ATTRIBUTE_READONLY win32-file-attribute ]
|
|
[ +hidden+ FILE_ATTRIBUTE_HIDDEN win32-file-attribute ]
|
|
[ +system+ FILE_ATTRIBUTE_SYSTEM win32-file-attribute ]
|
|
[ +directory+ FILE_ATTRIBUTE_DIRECTORY win32-file-attribute ]
|
|
[ +archive+ FILE_ATTRIBUTE_ARCHIVE win32-file-attribute ]
|
|
[ +device+ FILE_ATTRIBUTE_DEVICE win32-file-attribute ]
|
|
[ +normal+ FILE_ATTRIBUTE_NORMAL win32-file-attribute ]
|
|
[ +temporary+ FILE_ATTRIBUTE_TEMPORARY win32-file-attribute ]
|
|
[ +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE win32-file-attribute ]
|
|
[ +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT win32-file-attribute ]
|
|
[ +compressed+ FILE_ATTRIBUTE_COMPRESSED win32-file-attribute ]
|
|
[ +offline+ FILE_ATTRIBUTE_OFFLINE win32-file-attribute ]
|
|
[ +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED win32-file-attribute ]
|
|
[ +encrypted+ FILE_ATTRIBUTE_ENCRYPTED win32-file-attribute ]
|
|
} cleave
|
|
] { } make ;
|
|
|
|
: win32-file-type ( n -- symbol )
|
|
FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
|
|
|
|
TUPLE: windows-directory-entry < directory-entry attributes ;
|
|
|
|
M: windows >directory-entry ( byte-array -- directory-entry )
|
|
[ WIN32_FIND_DATA-cFileName utf16n alien>string ]
|
|
[ WIN32_FIND_DATA-dwFileAttributes win32-file-type ]
|
|
[ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ]
|
|
tri
|
|
dupd remove windows-directory-entry boa ;
|
|
|
|
: 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 ]
|
|
} cleave ;
|
|
|
|
: find-first-file-stat ( path -- WIN32_FIND_DATA )
|
|
"WIN32_FIND_DATA" <c-object> [
|
|
FindFirstFile
|
|
[ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep
|
|
FindClose win32-error=0/f
|
|
] keep ;
|
|
|
|
: 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
|
|
]
|
|
[
|
|
BY_HANDLE_FILE_INFORMATION-ftLastAccessTime
|
|
FILETIME>timestamp >>accessed
|
|
]
|
|
! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ]
|
|
! [
|
|
! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ]
|
|
! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit
|
|
! ]
|
|
} cleave ;
|
|
|
|
: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
|
|
[
|
|
"BY_HANDLE_FILE_INFORMATION" <c-object>
|
|
[ GetFileInformationByHandle win32-error=0/f ] keep
|
|
] keep CloseHandle win32-error=0/f ;
|
|
|
|
: get-file-information-stat ( path -- BY_HANDLE_FILE_INFORMATION )
|
|
dup
|
|
GENERIC_READ FILE_SHARE_READ f
|
|
OPEN_EXISTING FILE_FLAG_BACKUP_SEMANTICS f
|
|
CreateFileW dup INVALID_HANDLE_VALUE = [
|
|
drop find-first-file-stat WIN32_FIND_DATA>file-info
|
|
] [
|
|
nip
|
|
get-file-information BY_HANDLE_FILE_INFORMATION>file-info
|
|
] if ;
|
|
|
|
M: winnt file-info ( path -- info )
|
|
normalize-path get-file-information-stat ;
|
|
|
|
M: winnt link-info ( path -- info )
|
|
file-info ;
|
|
|
|
HOOK: root-directory os ( string -- string' )
|
|
|
|
TUPLE: winnt-file-system-info < file-system-info
|
|
total-bytes total-free-bytes ;
|
|
|
|
: file-system-type ( normalized-path -- str )
|
|
MAX_PATH 1+ <byte-array>
|
|
MAX_PATH 1+
|
|
"DWORD" <c-object> "DWORD" <c-object> "DWORD" <c-object>
|
|
MAX_PATH 1+ <byte-array>
|
|
MAX_PATH 1+
|
|
[ GetVolumeInformation win32-error=0/f ] 2keep drop
|
|
utf16n alien>string ;
|
|
|
|
: file-system-space ( normalized-path -- free-space total-bytes total-free-bytes )
|
|
"ULARGE_INTEGER" <c-object>
|
|
"ULARGE_INTEGER" <c-object>
|
|
"ULARGE_INTEGER" <c-object>
|
|
[ GetDiskFreeSpaceEx win32-error=0/f ] 3keep ;
|
|
|
|
M: winnt file-system-info ( path -- file-system-info )
|
|
normalize-path root-directory
|
|
dup [ file-system-type ] [ file-system-space ] bi
|
|
\ winnt-file-system-info new
|
|
swap *ulonglong >>total-free-bytes
|
|
swap *ulonglong >>total-bytes
|
|
swap *ulonglong >>free-space
|
|
swap >>type
|
|
swap >>mount-point ;
|
|
|
|
: 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 ;
|
|
|
|
: find-first-volume ( -- string handle )
|
|
MAX_PATH 1+ <byte-array> dup length
|
|
dupd
|
|
FindFirstVolume dup win32-error=0/f
|
|
[ utf16n alien>string ] dip ;
|
|
|
|
: find-next-volume ( handle -- string/f )
|
|
MAX_PATH 1+ <byte-array> dup length
|
|
over [ FindNextVolume ] dip swap 0 = [
|
|
GetLastError ERROR_NO_MORE_FILES =
|
|
[ drop f ] [ win32-error ] if
|
|
] [
|
|
utf16n alien>string
|
|
] if ;
|
|
|
|
: find-volumes ( -- array )
|
|
find-first-volume
|
|
[
|
|
'[
|
|
[ _ find-next-volume dup ]
|
|
[ ]
|
|
[ drop ] produce
|
|
swap prefix
|
|
]
|
|
] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup ;
|
|
|
|
M: winnt file-systems ( -- array )
|
|
find-volumes [ volume>paths ] map
|
|
concat [
|
|
[ file-system-info ]
|
|
[ drop winnt-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@
|
|
] with-destructors ;
|
|
|
|
: (set-file-times) ( handle timestamp/f timestamp/f timestamp/f -- )
|
|
[ timestamp>FILETIME ] tri@
|
|
SetFileTime win32-error=0/f ;
|
|
|
|
: set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
|
|
#! timestamp order: creation access write
|
|
[
|
|
>r >r >r
|
|
normalize-path open-existing &dispose handle>>
|
|
r> r> r> (set-file-times)
|
|
] with-destructors ;
|
|
|
|
: set-file-create-time ( path timestamp -- )
|
|
f f set-file-times ;
|
|
|
|
: set-file-access-time ( path timestamp -- )
|
|
>r f r> f set-file-times ;
|
|
|
|
: set-file-write-time ( path timestamp -- )
|
|
>r f f r> set-file-times ;
|
|
|
|
M: winnt touch-file ( path -- )
|
|
[
|
|
normalize-path
|
|
maybe-create-file >r &dispose r>
|
|
[ drop ] [ handle>> f now dup (set-file-times) ] if
|
|
] with-destructors ;
|