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
Björn Lindqvist 2013-10-16 14:11:31 +02:00 committed by Doug Coleman
parent 6ed3a09b5d
commit 8c5ceb8b0c
1 changed files with 49 additions and 61 deletions

View File

@ -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 ;