io.files.windows: new generic words drain and refill, like in io.backend.unix
The purpose of these words is to abstract out the pushing of the bytes to the ports so that you can insert the ssl layer in between. Exactly like how drain and refill are specialized on ssl-handle in io.sockets.secure.unix.db4
parent
6ed3a09b5d
commit
8c5ceb8b0c
basis/io/files/windows
|
@ -14,8 +14,6 @@ SPECIALIZED-ARRAY: ushort
|
|||
IN: io.files.windows
|
||||
|
||||
HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
|
||||
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
|
||||
HOOK: add-completion io-backend ( port -- port )
|
||||
HOOK: open-append os ( path -- win32-file )
|
||||
|
||||
TUPLE: win32-file < win32-handle ptr ;
|
||||
|
@ -25,9 +23,6 @@ TUPLE: win32-file < win32-handle ptr ;
|
|||
|
||||
M: win32-file dispose
|
||||
[ cancel-operation ] [ call-next-method ] bi ;
|
||||
|
||||
: opened-file ( handle -- win32-file )
|
||||
check-invalid-handle <win32-file> |dispose add-completion ;
|
||||
|
||||
CONSTANT: share-mode
|
||||
flags{
|
||||
|
@ -35,7 +30,7 @@ CONSTANT: share-mode
|
|||
FILE_SHARE_WRITE
|
||||
FILE_SHARE_DELETE
|
||||
}
|
||||
|
||||
|
||||
: default-security-attributes ( -- obj )
|
||||
SECURITY_ATTRIBUTES <struct>
|
||||
SECURITY_ATTRIBUTES heap-size >>nLength ;
|
||||
|
@ -46,16 +41,6 @@ TUPLE: FileArgs
|
|||
|
||||
C: <FileArgs> FileArgs
|
||||
|
||||
: make-FileArgs ( port -- <FileArgs> )
|
||||
{
|
||||
[ handle>> check-disposed ]
|
||||
[ handle>> handle>> ]
|
||||
[ buffer>> ]
|
||||
[ buffer>> buffer-length ]
|
||||
[ drop 0 DWORD <ref> ]
|
||||
[ FileArgs-overlapped ]
|
||||
} cleave <FileArgs> ;
|
||||
|
||||
! Global variable with assoc mapping overlapped to threads
|
||||
SYMBOL: pending-overlapped
|
||||
|
||||
|
@ -63,30 +48,20 @@ TUPLE: io-callback port thread ;
|
|||
|
||||
C: <io-callback> io-callback
|
||||
|
||||
: (make-overlapped) ( -- overlapped-ext )
|
||||
OVERLAPPED malloc-struct &free ;
|
||||
|
||||
: make-overlapped ( port -- overlapped-ext )
|
||||
[ (make-overlapped) ] dip
|
||||
handle>> ptr>> [
|
||||
[ 32 bits >>offset ]
|
||||
[ -32 shift >>offset-high ] bi
|
||||
] when* ;
|
||||
|
||||
M: windows FileArgs-overlapped ( port -- overlapped )
|
||||
make-overlapped ;
|
||||
|
||||
: <completion-port> ( handle existing -- handle )
|
||||
f 1 CreateIoCompletionPort dup win32-error=0/f ;
|
||||
|
||||
SYMBOL: master-completion-port
|
||||
|
||||
: <master-completion-port> ( -- handle )
|
||||
INVALID_HANDLE_VALUE f <completion-port> ;
|
||||
|
||||
M: windows add-completion ( win32-handle -- win32-handle )
|
||||
SYMBOL: master-completion-port
|
||||
|
||||
: add-completion ( win32-handle -- win32-handle )
|
||||
dup handle>> master-completion-port get-global <completion-port> drop ;
|
||||
|
||||
: opened-file ( handle -- win32-file )
|
||||
check-invalid-handle <win32-file> |dispose add-completion ;
|
||||
|
||||
: eof? ( error -- ? )
|
||||
{ [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] } 1|| ;
|
||||
|
||||
|
@ -143,7 +118,7 @@ ERROR: invalid-file-size n ;
|
|||
GetLastError ERROR_INVALID_FUNCTION =
|
||||
[ f ] [ throw-win32-error ] if
|
||||
] unless* ;
|
||||
|
||||
|
||||
ERROR: seek-before-start n ;
|
||||
|
||||
: set-seek-ptr ( n handle -- )
|
||||
|
@ -182,45 +157,58 @@ M: windows handle-length ( handle -- n/f )
|
|||
: update-file-ptr ( n port -- )
|
||||
handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
|
||||
|
||||
: finish-write ( n port -- )
|
||||
[ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
|
||||
: (make-overlapped) ( -- overlapped-ext )
|
||||
OVERLAPPED malloc-struct &free ;
|
||||
|
||||
: setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
|
||||
{
|
||||
[ hFile>> ]
|
||||
[ lpBuffer>> buffer-end ]
|
||||
[ lpBuffer>> buffer-capacity ]
|
||||
[ lpNumberOfBytesRet>> ]
|
||||
[ lpOverlapped>> ]
|
||||
} cleave ;
|
||||
: make-overlapped ( handle -- overlapped-ext )
|
||||
(make-overlapped) swap
|
||||
ptr>> [ [ 32 bits >>offset ] [ -32 shift >>offset-high ] bi ] when* ;
|
||||
|
||||
: make-FileArgs ( port handle -- <FileArgs> )
|
||||
[ nip dup check-disposed handle>> ]
|
||||
[
|
||||
[ buffer>> dup buffer-length 0 DWORD <ref> ] dip make-overlapped
|
||||
] 2bi <FileArgs> ;
|
||||
|
||||
GENERIC: drain ( port handle -- )
|
||||
|
||||
: setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
|
||||
{
|
||||
[ hFile>> ]
|
||||
[ lpBuffer>> buffer@ ]
|
||||
[ lpBuffer>> buffer-length ]
|
||||
[ lpBuffer>> [ buffer@ ] [ buffer-length ] bi ]
|
||||
[ lpNumberOfBytesRet>> ]
|
||||
[ lpOverlapped>> ]
|
||||
} cleave ;
|
||||
|
||||
: finish-write ( n port -- )
|
||||
[ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
|
||||
|
||||
M: object drain ( port handle -- )
|
||||
[ make-FileArgs dup setup-write WriteFile ]
|
||||
[ drop [ wait-for-file ] [ finish-write ] bi ] 2bi ;
|
||||
|
||||
GENERIC: refill ( port handle -- )
|
||||
|
||||
: setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
|
||||
{
|
||||
[ hFile>> ]
|
||||
[ lpBuffer>> [ buffer-end ] [ buffer-capacity ] bi ]
|
||||
[ lpNumberOfBytesRet>> ]
|
||||
[ lpOverlapped>> ]
|
||||
} cleave ;
|
||||
|
||||
M: windows (wait-to-write)
|
||||
[
|
||||
[ make-FileArgs dup setup-write WriteFile ]
|
||||
[ wait-for-file ]
|
||||
[ finish-write ]
|
||||
tri
|
||||
] with-destructors ;
|
||||
|
||||
: finish-read ( n port -- )
|
||||
[ update-file-ptr ] [ buffer>> n>buffer ] 2bi ;
|
||||
|
||||
M: object refill ( port handle -- )
|
||||
[ make-FileArgs dup setup-read ReadFile ]
|
||||
[ drop [ wait-for-file ] [ finish-read ] bi ] 2bi ;
|
||||
|
||||
M: windows (wait-to-write)
|
||||
[ dup handle>> drain ] with-destructors ;
|
||||
|
||||
M: windows (wait-to-read) ( port -- )
|
||||
[
|
||||
[ make-FileArgs dup setup-read ReadFile ]
|
||||
[ wait-for-file ]
|
||||
[ finish-read ]
|
||||
tri
|
||||
] with-destructors ;
|
||||
[ dup handle>> refill ] with-destructors ;
|
||||
|
||||
: console-app? ( -- ? ) GetConsoleWindow >boolean ;
|
||||
|
||||
|
@ -288,10 +276,10 @@ SLOT: attributes
|
|||
|
||||
: read-only? ( file-info -- ? )
|
||||
attributes>> +read-only+ swap member? ;
|
||||
|
||||
|
||||
: set-file-attributes ( path flags -- )
|
||||
SetFileAttributes win32-error=0/f ;
|
||||
|
||||
|
||||
: set-file-normal-attribute ( path -- )
|
||||
FILE_ATTRIBUTE_NORMAL set-file-attributes ;
|
||||
|
||||
|
|
Loading…
Reference in New Issue