From 05466df1e0533d30b838827d37a10f926e8689d2 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Thu, 15 May 2008 00:13:08 -0500 Subject: [PATCH 1/3] Updating Windows I/O code --- extra/io/windows/files/files.factor | 6 +- extra/io/windows/mmap/mmap.factor | 18 +- extra/io/windows/nt/backend/backend.factor | 44 +-- extra/io/windows/nt/files/files.factor | 44 +-- extra/io/windows/nt/launcher/launcher.factor | 2 +- extra/io/windows/nt/monitors/monitors.factor | 8 +- extra/io/windows/nt/pipes/pipes.factor | 4 +- extra/io/windows/nt/sockets/sockets.factor | 289 +++++++++---------- extra/io/windows/windows.factor | 57 ++-- 9 files changed, 219 insertions(+), 253 deletions(-) diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index d83c789d36..520a5dff48 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -96,7 +96,7 @@ M: winnt link-info ( path -- info ) : file-times ( path -- timestamp timestamp timestamp ) [ - normalize-path open-existing dup close-always + normalize-path open-existing &close-handle "FILETIME" "FILETIME" "FILETIME" @@ -112,7 +112,7 @@ M: winnt link-info ( path -- info ) #! timestamp order: creation access write [ >r >r >r - normalize-path open-existing dup close-always + normalize-path open-existing &close-handle r> r> r> (set-file-times) ] with-destructors ; @@ -128,6 +128,6 @@ M: winnt link-info ( path -- info ) M: winnt touch-file ( path -- ) [ normalize-path - maybe-create-file over close-always + maybe-create-file >r &close-handle r> [ drop ] [ f now dup (set-file-times) ] if ] with-destructors ; diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor index b401ed5556..d9944b8510 100755 --- a/extra/io/windows/mmap/mmap.factor +++ b/extra/io/windows/mmap/mmap.factor @@ -30,8 +30,8 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES : make-token-privileges ( name ? -- obj ) "TOKEN_PRIVILEGES" 1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep - "LUID_AND_ATTRIBUTES" malloc-array - dup free-always over set-TOKEN_PRIVILEGES-Privileges + "LUID_AND_ATTRIBUTES" malloc-array &free + over set-TOKEN_PRIVILEGES-Privileges swap [ SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges @@ -63,14 +63,12 @@ M: wince with-privileges : mmap-open ( path access-mode create-mode flProtect access -- handle handle address ) { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [ >r >r 0 open-file dup f r> 0 0 f - CreateFileMapping [ win32-error=0/f ] keep - dup close-later + CreateFileMapping [ win32-error=0/f ] keep |close-handle dup - r> 0 0 0 MapViewOfFile [ win32-error=0/f ] keep - dup close-later + r> 0 0 0 MapViewOfFile [ win32-error=0/f ] keep |close-handle ] with-privileges ; -M: windows (mapped-file) ( path length -- mmap ) +M: windows (mapped-file) [ swap GENERIC_WRITE GENERIC_READ bitor @@ -78,11 +76,11 @@ M: windows (mapped-file) ( path length -- mmap ) PAGE_READWRITE SEC_COMMIT bitor FILE_MAP_ALL_ACCESS mmap-open -rot 2array - f \ mapped-file boa ] with-destructors ; M: windows close-mapped-file ( mapped-file -- ) [ - dup mapped-file-handle [ close-always ] each - mapped-file-address UnmapViewOfFile win32-error=0/f + [ handle>> [ &close-handle drop ] each ] + [ address>> UnmapViewOfFile win32-error=0/f ] + bi ] with-destructors ; diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 99364f832d..bd2b03aad8 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -14,11 +14,11 @@ TUPLE: io-callback port thread ; C: io-callback : (make-overlapped) ( -- overlapped-ext ) - "OVERLAPPED" malloc-object dup free-always ; + "OVERLAPPED" malloc-object &free ; : make-overlapped ( port -- overlapped-ext ) - >r (make-overlapped) r> port-handle win32-file-ptr - [ over set-OVERLAPPED-offset ] when* ; + >r (make-overlapped) + r> handle>> ptr>> [ over set-OVERLAPPED-offset ] when* ; : ( handle existing -- handle ) f 1 CreateIoCompletionPort dup win32-error=0/f ; @@ -56,13 +56,22 @@ M: winnt add-completion ( handle -- ) io-hash get-global set-at ] "I/O" suspend 3drop ; -: wait-for-overlapped ( ms -- overlapped ? ) - >r master-completion-port get-global +: twiddle-thumbs ( overlapped port -- bytes-transferred ) + [ save-callback ] + [ get-overlapped-result ] + [ nip pending-error ] + 2tri ; + +:: wait-for-overlapped ( ms -- overlapped ? ) + master-completion-port get-global r> INFINITE or ! timeout 0 ! bytes f ! key f ! overlapped - [ roll GetQueuedCompletionStatus ] keep *void* swap zero? ; + [ + ms INFINITE or ! timeout + GetQueuedCompletionStatus + ] keep *void* swap zero? ; : lookup-callback ( overlapped -- callback ) io-hash get-global delete-at* drop @@ -70,30 +79,23 @@ M: winnt add-completion ( handle -- ) : handle-overlapped ( timeout -- ? ) wait-for-overlapped [ - GetLastError dup expected-io-error? [ - 2drop t - ] [ - dup eof? [ - drop lookup-callback - dup port>> t >>eof drop - ] [ - (win32-error-string) swap lookup-callback - [ port>> set-port-error ] keep - ] if thread>> resume f + GetLastError dup expected-io-error? [ 2drop f ] [ + >r lookup-callback [ thread>> ] [ port>> ] bi r> + dup eof? + [ drop t >>eof drop ] + [ (win32-error-string) >>error drop ] if + thread>> resume t ] if ] [ lookup-callback - io-callback-thread resume f + thread>> resume t ] if ; -: drain-overlapped ( timeout -- ) - handle-overlapped [ 0 drain-overlapped ] unless ; - M: winnt cancel-io handle>> handle>> CancelIo drop ; M: winnt io-multiplex ( ms -- ) - drain-overlapped ; + handle-overlapped [ 0 io-multiplex ] when ; M: winnt init-io ( -- ) master-completion-port set-global diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 2b3021a3f1..08926cb4f7 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -57,53 +57,39 @@ M: winnt open-append >r (open-append) r> ; : update-file-ptr ( n port -- ) - port-handle - dup win32-file-ptr [ - rot + swap set-win32-file-ptr - ] [ - 2drop - ] if* ; + handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ; -: finish-flush ( overlapped port -- ) - dup pending-error - tuck get-overlapped-result - dup pick update-file-ptr - swap buffer>> buffer-consume ; +: finish-flush ( n port -- ) + [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ; -: (flush-output) ( port -- ) +: ((wait-to-write)) ( port -- ) dup make-FileArgs tuck setup-write WriteFile dupd overlapped-error? [ - >r FileArgs-lpOverlapped r> - [ save-callback ] 2keep + >r lpOverlapped>> r> + [ twiddle-thumbs ] keep [ finish-flush ] keep - dup buffer>> buffer-empty? [ drop ] [ (flush-output) ] if + dup buffer>> buffer-empty? [ drop ] [ ((wait-to-write)) ] if ] [ 2drop ] if ; -: flush-output ( port -- ) - [ [ (flush-output) ] with-timeout ] with-destructors ; +M: winnt (wait-to-write) + [ [ ((wait-to-write)) ] with-timeout ] with-destructors ; -M: winnt flush-port - dup buffer>> buffer-empty? [ dup flush-output ] unless drop ; - -: finish-read ( overlapped port -- ) - dup pending-error - tuck get-overlapped-result dup zero? [ - drop t >>eof drop +: finish-read ( n port -- ) + over zero? [ + t >>eof 2drop ] [ - dup pick buffer>> n>buffer - swap update-file-ptr + [ buffer>> n>buffer ] [ update-file-ptr ] bi ] if ; : ((wait-to-read)) ( port -- ) dup make-FileArgs tuck setup-read ReadFile dupd overlapped-error? [ - >r FileArgs-lpOverlapped r> - [ save-callback ] 2keep - finish-read + >r lpOverlapped>> r> + [ twiddle-thumbs ] [ finish-read ] bi ] [ 2drop ] if ; M: winnt (wait-to-read) ( port -- ) diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index c18523e68d..61ff65fe08 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -49,7 +49,7 @@ IN: io.windows.nt.launcher create-mode FILE_ATTRIBUTE_NORMAL ! flags and attributes f ! template file - CreateFile dup invalid-handle? dup close-always ; + CreateFile dup invalid-handle? &close-handle ; : redirect-append ( default path access-mode create-mode -- handle ) >r >r path>> r> r> diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index ee8c6c60e1..88f082625e 100755 --- a/extra/io/windows/nt/monitors/monitors.factor +++ b/extra/io/windows/nt/monitors/monitors.factor @@ -19,7 +19,7 @@ IN: io.windows.nt.monitors f CreateFile dup invalid-handle? - dup close-later + |close-handle dup add-completion f ; @@ -41,11 +41,7 @@ TUPLE: win32-monitor < monitor port ; : read-changes ( port -- bytes ) [ - dup begin-reading-changes - swap [ save-callback ] 2keep - check-closed ! we may have closed it... - dup eof>> [ "EOF??" throw ] when - get-overlapped-result + [ begin-reading-changes ] [ twiddle-thumbs ] bi ] with-destructors ; : parse-action ( action -- changed ) diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor index 8a0fa05b74..3fd37d6bc3 100755 --- a/extra/io/windows/nt/pipes/pipes.factor +++ b/extra/io/windows/nt/pipes/pipes.factor @@ -47,7 +47,7 @@ IN: io.windows.nt.pipes M: winnt (pipe) ( -- pipe ) [ unique-pipe-name - [ create-named-pipe dup close-later ] - [ open-other-end dup close-later ] + [ create-named-pipe |close-handle ] + [ open-other-end |close-handle ] bi pipe boa ] with-destructors ; diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 5baa0a31e5..657551cdac 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -30,114 +30,118 @@ TUPLE: ConnectEx-args port s* name* namelen* lpSendBuffer* dwSendDataLength* lpdwBytesSent* lpOverlapped* ptr* ; -: init-connect ( sockaddr size ConnectEx -- ) - [ set-ConnectEx-args-namelen* ] keep - [ set-ConnectEx-args-name* ] keep - f over set-ConnectEx-args-lpSendBuffer* - 0 over set-ConnectEx-args-dwSendDataLength* - f over set-ConnectEx-args-lpdwBytesSent* - (make-overlapped) swap set-ConnectEx-args-lpOverlapped* ; +: ( sockaddr size -- ) + ConnectEx-args new + swap >>namelen* + swap >>name* + f >>lpSendBuffer* + 0 >>dwSendDataLength* + f >>lpdwBytesSent* + (make-overlapped) >>lpOverlapped* ; -: (ConnectEx) ( ConnectEx -- ) - \ ConnectEx-args >tuple*< +: call-ConnectEx ( ConnectEx -- ) + ConnectEx-args >tuple*< "int" { "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" } "stdcall" alien-indirect drop winsock-error-string [ throw ] when* ; -: connect-continuation ( overlapped port -- ) - 2dup save-callback - get-overlapped-result drop ; +: (wait-to-connect) ( client-out handle -- ) + overlapped>> swap twiddle-thumbs drop ; -M: win32-socket wait-to-connect ( client-out handle -- ) - [ overlapped>> swap connect-continuation ] - [ drop pending-error ] - 2bi ; +: get-socket-name ( socket addrspec -- sockaddr ) + >r handle>> r> empty-sockaddr/size + [ getsockname socket-error ] 2keep drop ; + +M: win32-socket wait-to-connect ( client-out handle remote -- sockaddr ) + [ + [ drop (wait-to-connect) ] + [ get-socket-name nip ] + 3bi + ] keep parse-sockaddr ; M: object ((client)) ( addrspec -- handle ) - [ - \ ConnectEx-args new - over make-sockaddr/size pick init-connect - over tcp-socket over set-ConnectEx-args-s* - dup ConnectEx-args-s* add-completion - dup ConnectEx-args-s* get-ConnectEx-ptr over set-ConnectEx-args-ptr* - dup ConnectEx-args-s* INADDR_ANY roll bind-socket - dup (ConnectEx) - - dup [ ConnectEx-args-s* ] [ ConnectEx-args-lpOverlapped* ] bi - ] with-destructors ; + dup make-sockaddr/size + over tcp-socket >>s* + dup s*>> add-completion + dup s*>> get-ConnectEx-ptr >>ptr* + dup s*>> INADDR_ANY roll bind-socket + dup call-ConnectEx + dup [ s*>> ] [ lpOverlapped*>> ] bi ; TUPLE: AcceptEx-args port sListenSocket* sAcceptSocket* lpOutputBuffer* dwReceiveDataLength* dwLocalAddressLength* dwRemoteAddressLength* lpdwBytesReceived* lpOverlapped* ; : init-accept-buffer ( server-port AcceptEx -- ) - >r server-port-addr sockaddr-type heap-size 16 + - dup dup 2 * malloc dup free-always r> - [ set-AcceptEx-args-lpOutputBuffer* ] keep - [ set-AcceptEx-args-dwLocalAddressLength* ] keep - set-AcceptEx-args-dwRemoteAddressLength* ; + swap addr>> sockaddr-type heap-size 16 + + [ >>dwLocalAddressLength* ] [ >>dwRemoteAddressLength* ] bi + dup dwLocalAddressLength*>> 2 * malloc &free >>lpOutputBuffer* + drop ; -: init-accept ( server-port AcceptEx -- ) - [ init-accept-buffer ] 2keep - [ set-AcceptEx-args-port ] 2keep - >r port-handle win32-file-handle r> [ set-AcceptEx-args-sListenSocket* ] keep - dup AcceptEx-args-port server-port-addr tcp-socket - over set-AcceptEx-args-sAcceptSocket* - 0 over set-AcceptEx-args-dwReceiveDataLength* - f over set-AcceptEx-args-lpdwBytesReceived* - (make-overlapped) swap set-AcceptEx-args-lpOverlapped* ; +: ( server-port -- AcceptEx ) + AcceptEx-args new + 2dup init-accept-buffer + over >>port + over handle>> handle>> >>sListenSocket* + over addr>> tcp-socket >>sAcceptSocket* + 0 >>dwReceiveDataLength* + f >>lpdwBytesReceived* + (make-overlapped) >>lpOverlapped* + nip ; -: ((accept)) ( AcceptEx -- ) - \ AcceptEx-args >tuple*< +: call-AcceptEx ( AcceptEx -- ) + AcceptEx-args >tuple*< AcceptEx drop winsock-error-string [ throw ] when* ; -: make-accept-continuation ( AcceptEx -- ) - dup AcceptEx-args-lpOverlapped* - swap AcceptEx-args-port save-callback ; - -: check-accept-error ( AcceptEx -- ) - dup AcceptEx-args-lpOverlapped* - swap AcceptEx-args-port get-overlapped-result drop ; - : extract-remote-host ( AcceptEx -- addrspec ) - [ - [ AcceptEx-args-lpOutputBuffer* ] keep - [ AcceptEx-args-dwReceiveDataLength* ] keep - [ AcceptEx-args-dwLocalAddressLength* ] keep - AcceptEx-args-dwRemoteAddressLength* - f - 0 - f [ - 0 GetAcceptExSockaddrs - ] keep *void* - ] keep AcceptEx-args-port server-port-addr parse-sockaddr ; + { + [ lpOutputBuffer*>> ] + [ dwReceiveDataLength*>> ] + [ dwLocalAddressLength*>> ] + [ dwRemoteAddressLength*>> ] + } cleave + f + 0 + f [ + 0 GetAcceptExSockaddrs + ] keep *void* ; -: accept-continuation ( AcceptEx -- addrspec client ) - [ make-accept-continuation ] keep - [ check-accept-error ] keep - [ extract-remote-host ] keep - ! addrspec AcceptEx - [ AcceptEx-args-sAcceptSocket* add-completion ] keep - [ AcceptEx-args-sAcceptSocket* ] [ AcceptEx-args-lpOverlapped* ] bi ; +: finish-accept ( AcceptEx -- client sockaddr ) + [ sAcceptSocket*>> add-completion ] + [ [ sAcceptSocket*>> ] [ lpOverlapped*>> ] bi ] + [ extract-remote-host ] + tri ; -M: winnt (accept) ( server -- addrspec handle ) +: wait-to-accept ( AcceptEx -- ) + [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs drop ; + +M: winnt (accept) ( server -- handle sockaddr ) [ [ - \ AcceptEx-args new - [ init-accept ] keep - [ ((accept)) ] keep - [ accept-continuation ] keep - AcceptEx-args-port pending-error + + { + [ call-AcceptEx ] + [ wait-to-accept ] + [ finish-accept ] + [ port>> pending-error ] + } cleave ] with-timeout ] with-destructors ; -M: winnt (server) ( addrspec -- handle ) +M: winnt (server) ( addrspec -- handle sockaddr ) [ - SOCK_STREAM server-fd dup listen-on-socket - dup add-completion - f + [ SOCK_STREAM server-fd ] keep + [ + drop + [ listen-on-socket ] + [ add-completion ] + [ f ] + tri + ] + [ get-socket-name ] + 2bi ] with-destructors ; M: winnt (datagram) ( addrspec -- handle ) @@ -152,53 +156,43 @@ TUPLE: WSARecvFrom-args port lpFlags* lpFrom* lpFromLen* lpOverlapped* lpCompletionRoutine* ; : make-receive-buffer ( -- WSABUF ) - "WSABUF" malloc-object dup free-always + "WSABUF" malloc-object &free default-buffer-size get over set-WSABUF-len - default-buffer-size get malloc dup free-always over set-WSABUF-buf ; + default-buffer-size get malloc &free over set-WSABUF-buf ; -: init-WSARecvFrom ( datagram WSARecvFrom -- ) - [ set-WSARecvFrom-args-port ] 2keep - [ - >r handle>> handle>> r> - set-WSARecvFrom-args-s* - ] 2keep [ - >r datagram-port-addr sockaddr-type heap-size r> - 2dup >r malloc dup free-always r> set-WSARecvFrom-args-lpFrom* - >r malloc-int dup free-always r> set-WSARecvFrom-args-lpFromLen* - ] keep - make-receive-buffer over set-WSARecvFrom-args-lpBuffers* - 1 over set-WSARecvFrom-args-dwBufferCount* - 0 malloc-int dup free-always over set-WSARecvFrom-args-lpFlags* - 0 malloc-int dup free-always over set-WSARecvFrom-args-lpNumberOfBytesRecvd* - (make-overlapped) swap set-WSARecvFrom-args-lpOverlapped* ; +: ( datagram -- WSARecvFrom ) + WSARecvFrom new + over >>port + over handle>> handle>> >>s* + swap addr>> sockaddr-type heap-size + [ malloc &free >>lpFrom* ] + [ malloc-int &free >>lpFromLen* ] bi + make-receive-buffer >>lpBuffers* + 1 >>dwBufferCount* + 0 malloc-int &free >>lpFlags* + 0 malloc-int &free >>lpNumberOfBytesRecvd* + (make-overlapped) >>lpOverlapped* ; -: WSARecvFrom-continuation ( WSARecvFrom -- n ) - dup WSARecvFrom-args-lpOverlapped* - swap WSARecvFrom-args-port [ save-callback ] 2keep - get-overlapped-result ; +: wait-to-receive ( WSARecvFrom -- n ) + [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ; : call-WSARecvFrom ( WSARecvFrom -- ) - \ WSARecvFrom-args >tuple*< - WSARecvFrom - socket-error* ; + WSARecvFrom-args >tuple*< WSARecvFrom socket-error* ; -: parse-WSARecvFrom ( n WSARecvFrom -- packet addrspec ) - [ - WSARecvFrom-args-lpBuffers* WSABUF-buf - swap memory>byte-array - ] keep - [ WSARecvFrom-args-lpFrom* ] keep - WSARecvFrom-args-port datagram-port-addr parse-sockaddr ; +: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr ) + [ lpBuffers*>> WSABUF-buf swap memory>byte-array ] + [ lpFrom*>> ] + bi ; M: winnt receive ( datagram -- packet addrspec ) [ - check-datagram-port - \ WSARecvFrom-args new - [ init-WSARecvFrom ] keep - [ call-WSARecvFrom ] keep - [ WSARecvFrom-continuation ] keep - [ WSARecvFrom-args-port pending-error ] keep - parse-WSARecvFrom + + { + [ call-WSARecvFrom ] + [ wait-to-receive ] + [ port>> pending-error ] + [ parse-WSARecvFrom ] + } cleave ] with-destructors ; TUPLE: WSASendTo-args port @@ -206,49 +200,38 @@ TUPLE: WSASendTo-args port dwFlags* lpTo* iToLen* lpOverlapped* lpCompletionRoutine* ; : make-send-buffer ( packet -- WSABUF ) - "WSABUF" malloc-object dup free-always - over malloc-byte-array dup free-always over set-WSABUF-buf - swap length over set-WSABUF-len ; + "WSABUF" malloc-object &free + [ >r malloc-byte-array &free r> set-WSABUF-buf ] + [ >r length r> set-WSABUF-len ] + [ nip ] + 2tri ; -: init-WSASendTo ( packet addrspec datagram WSASendTo -- ) - [ set-WSASendTo-args-port ] 2keep - [ - >r port-handle win32-file-handle r> set-WSASendTo-args-s* - ] keep - [ - >r make-sockaddr/size >r - malloc-byte-array dup free-always - r> r> - [ set-WSASendTo-args-iToLen* ] keep - set-WSASendTo-args-lpTo* - ] keep - [ - >r make-send-buffer r> set-WSASendTo-args-lpBuffers* - ] keep - 1 over set-WSASendTo-args-dwBufferCount* - 0 over set-WSASendTo-args-dwFlags* - 0 over set-WSASendTo-args-lpNumberOfBytesSent* - (make-overlapped) swap set-WSASendTo-args-lpOverlapped* ; +: ( packet addrspec datagram -- WSASendTo ) + WSASendTo-args new + over >>port + over handle>> handle>> >>s* + swap make-sockaddr/size + >r malloc-byte-array &free + r> [ >>lpTo* ] [ >>iToLen* ] bi* + swap make-send-buffer >>lpBuffers* + 1 >>dwBufferCount* + 0 >>dwFlags* + 0 >>lpNumberOfBytesSent* + (make-overlapped) >>lpOverlapped* ; -: WSASendTo-continuation ( WSASendTo -- ) - dup WSASendTo-args-lpOverlapped* - swap WSASendTo-args-port - [ save-callback ] 2keep - get-overlapped-result drop ; +: wait-to-send ( WSASendTo -- ) + [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs drop ; : call-WSASendTo ( WSASendTo -- ) - \ WSASendTo-args >tuple*< - WSASendTo socket-error* ; + WSASendTo-args >tuple*< WSASendTo socket-error* ; USE: io.sockets M: winnt send ( packet addrspec datagram -- ) [ - check-datagram-send - \ WSASendTo-args new - [ init-WSASendTo ] keep - [ call-WSASendTo ] keep - [ WSASendTo-continuation ] keep - WSASendTo-args-port pending-error + + [ call-WSASendTo ] + [ wait-to-send ] + [ port>> pending-error ] + tri ] with-destructors ; - diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 5c0a1c8ecf..5b205d0dca 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -8,8 +8,6 @@ windows.shell32 windows.types windows.winsock splitting continuations math.bitfields system accessors ; IN: io.windows -M: windows destruct-socket closesocket drop ; - TUPLE: win32-file handle ptr ; C: win32-file @@ -41,7 +39,7 @@ M: win32-file init-handle ( handle -- ) drop ; M: win32-file close-handle ( handle -- ) - win32-file-handle close-handle ; + handle>> close-handle ; M: alien close-handle ( handle -- ) CloseHandle drop ; @@ -51,7 +49,8 @@ M: alien close-handle ( handle -- ) [ >r >r share-mode security-attributes-inherit r> r> CreateFile-flags f CreateFile - dup invalid-handle? dup close-later + dup invalid-handle? + |close-handle dup add-completion ] with-destructors ; @@ -101,26 +100,31 @@ TUPLE: FileArgs C: FileArgs : make-FileArgs ( port -- ) - [ port-handle win32-file-handle ] keep - [ buffer>> ] keep - [ - buffer>> buffer-length - "DWORD" - ] keep FileArgs-overlapped ; + { + [ handle>> handle>> ] + [ buffer>> ] + [ buffer>> buffer-length ] + [ drop "DWORD" ] + [ FileArgs-overlapped ] + } cleave ; : setup-read ( -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped ) - [ FileArgs-hFile ] keep - [ FileArgs-lpBuffer buffer-end ] keep - [ FileArgs-lpBuffer buffer-capacity ] keep - [ FileArgs-lpNumberOfBytesRet ] keep - FileArgs-lpOverlapped ; + { + [ hFile>> ] + [ lpBuffer>> buffer-end ] + [ lpBuffer>> buffer-capacity ] + [ lpNumberOfBytesRet>> ] + [ lpOverlapped>> ] + } cleave ; : setup-write ( -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped ) - [ FileArgs-hFile ] keep - [ FileArgs-lpBuffer buffer@ ] keep - [ FileArgs-lpBuffer buffer-length ] keep - [ FileArgs-lpNumberOfBytesRet ] keep - FileArgs-lpOverlapped ; + { + [ hFile>> ] + [ lpBuffer>> buffer@ ] + [ lpBuffer>> buffer-length ] + [ lpNumberOfBytesRet>> ] + [ lpOverlapped>> ] + } cleave ; M: windows (file-reader) ( path -- stream ) open-read ; @@ -179,17 +183,14 @@ TUPLE: socket-destructor alien ; C: socket-destructor -HOOK: destruct-socket io-backend ( obj -- ) - M: socket-destructor dispose ( obj -- ) - alien>> destruct-socket ; + alien>> closesocket drop ; -: close-socket-later ( handle -- ) - add-error-destructor ; +: |close-socket ( handle -- handle ) + dup |dispose drop ; : server-fd ( addrspec type -- fd ) - >r dup protocol-family r> open-socket - dup close-socket-later + >r dup protocol-family r> open-socket |close-socket dup rot make-sockaddr/size bind socket-error ; USE: namespaces @@ -202,7 +203,7 @@ USE: namespaces listen-backlog listen winsock-return-check ; M: win32-socket dispose ( stream -- ) - win32-file-handle closesocket drop ; + handle>> closesocket drop ; M: windows addrinfo-error ( n -- ) winsock-return-check ; From 60818847da9f93b08753c4126666ffa175826665 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Thu, 15 May 2008 01:45:32 -0500 Subject: [PATCH 2/3] Further cleanups --- extra/io/windows/files/files.factor | 114 +++++++++++++++++- extra/io/windows/launcher/launcher.factor | 16 +-- extra/io/windows/mmap/mmap.factor | 2 +- extra/io/windows/nt/backend/backend.factor | 36 ++++++ extra/io/windows/nt/files/files.factor | 37 +----- extra/io/windows/nt/launcher/launcher.factor | 22 ++-- extra/io/windows/nt/monitors/monitors.factor | 6 +- extra/io/windows/nt/pipes/pipes.factor | 13 +- extra/io/windows/nt/sockets/sockets.factor | 118 +++++-------------- extra/io/windows/sockets/sockets.factor | 53 +++++++++ 10 files changed, 249 insertions(+), 168 deletions(-) create mode 100755 extra/io/windows/sockets/sockets.factor diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index 759f6d492b..30b69bf40e 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -6,6 +6,118 @@ math.functions sequences namespaces words symbols system combinators.lib io.ports destructors math.bitfields.lib ; IN: io.windows.files +: open-file ( path access-mode create-mode flags -- handle ) + [ + >r >r share-mode security-attributes-inherit r> r> + CreateFile-flags f CreateFile + dup invalid-handle? + + |dispose + dup add-completion + ] 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 ; + +: 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 + GetLastError ERROR_ALREADY_EXISTS = not ; + +: set-file-pointer ( handle length method -- ) + >r dupd d>w/w 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 + +: make-FileArgs ( port -- ) + { + [ handle>> handle>> ] + [ buffer>> ] + [ buffer>> buffer-length ] + [ drop "DWORD" ] + [ FileArgs-overlapped ] + } cleave ; + +: setup-read ( -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped ) + { + [ hFile>> ] + [ lpBuffer>> buffer-end ] + [ lpBuffer>> buffer-capacity ] + [ lpNumberOfBytesRet>> ] + [ lpOverlapped>> ] + } cleave ; + +: setup-write ( -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped ) + { + [ hFile>> ] + [ lpBuffer>> buffer@ ] + [ lpBuffer>> buffer-length ] + [ lpNumberOfBytesRet>> ] + [ lpOverlapped>> ] + } cleave ; + +M: windows (file-reader) ( path -- stream ) + open-read ; + +M: windows (file-writer) ( path -- stream ) + open-write ; + +M: windows (file-appender) ( path -- stream ) + open-append ; + +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 ; + +M: windows normalize-directory ( string -- string ) + normalize-path "\\" ?tail drop "\\*" append ; + SYMBOLS: +read-only+ +hidden+ +system+ +archive+ +device+ +normal+ +temporary+ +sparse-file+ +reparse-point+ +compressed+ +offline+ @@ -133,6 +245,6 @@ M: winnt link-info ( path -- info ) M: winnt touch-file ( path -- ) [ normalize-path - maybe-create-file >r &close-handle r> + maybe-create-file >r &dispose r> [ drop ] [ f now dup (set-file-times) ] if ] with-destructors ; diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 28e7e241e5..6116b635c2 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -19,8 +19,7 @@ TUPLE: CreateProcess-args lpEnvironment lpCurrentDirectory lpStartupInfo - lpProcessInformation - stdout-pipe stdin-pipe ; + lpProcessInformation ; : default-CreateProcess-args ( -- obj ) CreateProcess-args new @@ -31,18 +30,7 @@ TUPLE: CreateProcess-args 0 >>dwCreateFlags ; : call-CreateProcess ( CreateProcess-args -- ) - { - lpApplicationName>> - lpCommandLine>> - lpProcessAttributes>> - lpThreadAttributes>> - bInheritHandles>> - dwCreateFlags>> - lpEnvironment>> - lpCurrentDirectory>> - lpStartupInfo>> - lpProcessInformation>> - } get-slots CreateProcess win32-error=0/f ; + CreateProcess-args >tuple< CreateProcess win32-error=0/f ; : count-trailing-backslashes ( str n -- str n ) >r "\\" ?tail [ diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor index d9944b8510..1e9cb4738c 100755 --- a/extra/io/windows/mmap/mmap.factor +++ b/extra/io/windows/mmap/mmap.factor @@ -10,7 +10,7 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES ! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/ : (open-process-token) ( handle -- handle ) - TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY bitor "PHANDLE" + { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags "PHANDLE" [ OpenProcessToken win32-error=0/f ] keep *void* ; : open-process-token ( -- handle ) diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index bd2b03aad8..42e43d5f42 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -101,3 +101,39 @@ M: winnt init-io ( -- ) master-completion-port set-global H{ } clone io-hash set-global windows.winsock:init-winsock ; + +: finish-flush ( n port -- ) + [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ; + +: ((wait-to-write)) ( port -- ) + dup make-FileArgs + tuck setup-write WriteFile + dupd overlapped-error? [ + >r lpOverlapped>> r> + [ twiddle-thumbs ] keep + [ finish-flush ] keep + dup buffer>> buffer-empty? [ drop ] [ ((wait-to-write)) ] if + ] [ + 2drop + ] if ; + +M: winnt (wait-to-write) + [ [ ((wait-to-write)) ] with-timeout ] with-destructors ; + +: finish-read ( n port -- ) + over zero? [ + t >>eof 2drop + ] [ + [ buffer>> n>buffer ] [ update-file-ptr ] bi + ] if ; + +: ((wait-to-read)) ( port -- ) + dup make-FileArgs + tuck setup-read ReadFile + dupd overlapped-error? [ + >r lpOverlapped>> r> + [ twiddle-thumbs ] [ finish-read ] bi + ] [ 2drop ] if ; + +M: winnt (wait-to-read) ( port -- ) + [ [ ((wait-to-read)) ] with-timeout ] with-destructors ; diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 08926cb4f7..e99aa18196 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -29,6 +29,7 @@ M: winnt root-directory? ( path -- ? ) } cond nip ; ERROR: not-absolute-path ; + : root-directory ( string -- string' ) { [ dup length 2 >= ] @@ -58,39 +59,3 @@ M: winnt open-append : update-file-ptr ( n port -- ) handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ; - -: finish-flush ( n port -- ) - [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ; - -: ((wait-to-write)) ( port -- ) - dup make-FileArgs - tuck setup-write WriteFile - dupd overlapped-error? [ - >r lpOverlapped>> r> - [ twiddle-thumbs ] keep - [ finish-flush ] keep - dup buffer>> buffer-empty? [ drop ] [ ((wait-to-write)) ] if - ] [ - 2drop - ] if ; - -M: winnt (wait-to-write) - [ [ ((wait-to-write)) ] with-timeout ] with-destructors ; - -: finish-read ( n port -- ) - over zero? [ - t >>eof 2drop - ] [ - [ buffer>> n>buffer ] [ update-file-ptr ] bi - ] if ; - -: ((wait-to-read)) ( port -- ) - dup make-FileArgs - tuck setup-read ReadFile - dupd overlapped-error? [ - >r lpOverlapped>> r> - [ twiddle-thumbs ] [ finish-read ] bi - ] [ 2drop ] if ; - -M: winnt (wait-to-read) ( port -- ) - [ [ ((wait-to-read)) ] with-timeout ] with-destructors ; diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index 61ff65fe08..bad70501d7 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -21,10 +21,10 @@ IN: io.windows.nt.launcher ! /dev/null simulation : null-input ( -- pipe ) - (pipe) [ in>> handle>> ] [ out>> close-handle ] bi ; + (pipe) [ in>> handle>> ] [ out>> dispose ] bi ; : null-output ( -- pipe ) - (pipe) [ in>> close-handle ] [ out>> handle>> ] bi ; + (pipe) [ in>> dispose ] [ out>> handle>> ] bi ; : null-pipe ( mode -- pipe ) { @@ -49,7 +49,7 @@ IN: io.windows.nt.launcher create-mode FILE_ATTRIBUTE_NORMAL ! flags and attributes f ! template file - CreateFile dup invalid-handle? &close-handle ; + CreateFile dup invalid-handle? &dispose ; : redirect-append ( default path access-mode create-mode -- handle ) >r >r path>> r> r> @@ -77,16 +77,12 @@ IN: io.windows.nt.launcher [ redirect-stream ] } cond ; -: default-stdout ( args -- handle ) - stdout-pipe>> dup [ out>> ] when ; - : redirect-stdout ( process args -- handle ) - default-stdout - swap stdout>> + stdout>> GENERIC_WRITE CREATE_ALWAYS redirect - STD_OUTPUT_HANDLE GetStdHandle or ; + STD_OUTPUT_HANDLE GetStdHandle ; : redirect-stderr ( process args -- handle ) over stderr>> +stdout+ eq? [ @@ -103,16 +99,12 @@ IN: io.windows.nt.launcher STD_ERROR_HANDLE GetStdHandle or ] if ; -: default-stdin ( args -- handle ) - stdin-pipe>> dup [ in>> ] when ; - : redirect-stdin ( process args -- handle ) - default-stdin - swap stdin>> + stdin>> GENERIC_READ OPEN_EXISTING redirect - STD_INPUT_HANDLE GetStdHandle or ; + STD_INPUT_HANDLE GetStdHandle ; M: winnt fill-redirection ( process args -- ) [ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index 88f082625e..2257c48f99 100755 --- a/extra/io/windows/nt/monitors/monitors.factor +++ b/extra/io/windows/nt/monitors/monitors.factor @@ -19,9 +19,9 @@ IN: io.windows.nt.monitors f CreateFile dup invalid-handle? + |close-handle - dup add-completion - f ; + dup add-completion ; TUPLE: win32-monitor-port < input-port recursive ; @@ -83,7 +83,7 @@ TUPLE: win32-monitor < monitor port ; ] each ; : fill-queue ( monitor -- ) - dup port>> check-closed + dup port>> dup check-disposed [ buffer>> ptr>> ] [ read-changes zero? ] bi [ 2dup parse-notify-records ] unless 2drop ; diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor index 3fd37d6bc3..4a0b8119ba 100755 --- a/extra/io/windows/nt/pipes/pipes.factor +++ b/extra/io/windows/nt/pipes/pipes.factor @@ -19,8 +19,8 @@ IN: io.windows.nt.pipes security-attributes-inherit CreateNamedPipe dup win32-error=0/f - dup add-completion - f ; + |dispose + dup add-completion ; : open-other-end ( name -- handle ) GENERIC_WRITE @@ -31,8 +31,8 @@ IN: io.windows.nt.pipes f CreateFile dup win32-error=0/f - dup add-completion - f ; + |dispose + dup add-completion ; : unique-pipe-name ( -- string ) [ @@ -47,7 +47,6 @@ IN: io.windows.nt.pipes M: winnt (pipe) ( -- pipe ) [ unique-pipe-name - [ create-named-pipe |close-handle ] - [ open-other-end |close-handle ] - bi pipe boa + [ create-named-pipe ] [ open-other-end ] bi + pipe boa ] with-destructors ; diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 657551cdac..0a3dca279e 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -11,6 +11,9 @@ IN: io.windows.nt.sockets M: winnt WSASocket-flags ( -- DWORD ) WSA_FLAG_OVERLAPPED ; +: wait-for-socket ( args -- n ) + [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ; + : get-ConnectEx-ptr ( socket -- void* ) SIO_GET_EXTENSION_FUNCTION_POINTER WSAID_CONNECTEX @@ -46,28 +49,13 @@ TUPLE: ConnectEx-args port "stdcall" alien-indirect drop winsock-error-string [ throw ] when* ; -: (wait-to-connect) ( client-out handle -- ) - overlapped>> swap twiddle-thumbs drop ; - -: get-socket-name ( socket addrspec -- sockaddr ) - >r handle>> r> empty-sockaddr/size - [ getsockname socket-error ] 2keep drop ; - -M: win32-socket wait-to-connect ( client-out handle remote -- sockaddr ) - [ - [ drop (wait-to-connect) ] - [ get-socket-name nip ] - 3bi - ] keep parse-sockaddr ; - -M: object ((client)) ( addrspec -- handle ) - dup make-sockaddr/size - over tcp-socket >>s* - dup s*>> add-completion - dup s*>> get-ConnectEx-ptr >>ptr* - dup s*>> INADDR_ANY roll bind-socket - dup call-ConnectEx - dup [ s*>> ] [ lpOverlapped*>> ] bi ; +M: object establish-connection ( client-out remote -- ) + make-sockaddr/size + swap >>port + dup port>> handle>> handle>> >>s* + dup s*>> get-ConnectEx-ptr >>ptr* + dup call-ConnectEx + wait-for-socket drop ; TUPLE: AcceptEx-args port sListenSocket* sAcceptSocket* lpOutputBuffer* dwReceiveDataLength* @@ -82,75 +70,33 @@ TUPLE: AcceptEx-args port : ( server-port -- AcceptEx ) AcceptEx-args new 2dup init-accept-buffer - over >>port - over handle>> handle>> >>sListenSocket* - over addr>> tcp-socket >>sAcceptSocket* + swap >>port + dup port>> handle>> handle>> >>sListenSocket* + dup port>> addr>> tcp-socket >>sAcceptSocket* 0 >>dwReceiveDataLength* f >>lpdwBytesReceived* - (make-overlapped) >>lpOverlapped* - nip ; + (make-overlapped) >>lpOverlapped* ; : call-AcceptEx ( AcceptEx -- ) - AcceptEx-args >tuple*< - AcceptEx drop + AcceptEx-args >tuple*< AcceptEx drop winsock-error-string [ throw ] when* ; -: extract-remote-host ( AcceptEx -- addrspec ) - { - [ lpOutputBuffer*>> ] - [ dwReceiveDataLength*>> ] - [ dwLocalAddressLength*>> ] - [ dwRemoteAddressLength*>> ] - } cleave - f - 0 - f [ - 0 GetAcceptExSockaddrs - ] keep *void* ; +: finish-accept ( AcceptEx -- client ) + sAcceptSocket*>> [ |dispose ] [ add-completion ] bi ; -: finish-accept ( AcceptEx -- client sockaddr ) - [ sAcceptSocket*>> add-completion ] - [ [ sAcceptSocket*>> ] [ lpOverlapped*>> ] bi ] - [ extract-remote-host ] - tri ; - -: wait-to-accept ( AcceptEx -- ) - [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs drop ; - -M: winnt (accept) ( server -- handle sockaddr ) +M: winnt (accept) ( server -- handle ) [ [ { [ call-AcceptEx ] - [ wait-to-accept ] + [ wait-for-socket drop ] [ finish-accept ] [ port>> pending-error ] } cleave ] with-timeout ] with-destructors ; -M: winnt (server) ( addrspec -- handle sockaddr ) - [ - [ SOCK_STREAM server-fd ] keep - [ - drop - [ listen-on-socket ] - [ add-completion ] - [ f ] - tri - ] - [ get-socket-name ] - 2bi - ] with-destructors ; - -M: winnt (datagram) ( addrspec -- handle ) - [ - SOCK_DGRAM server-fd - dup add-completion - f - ] with-destructors ; - TUPLE: WSARecvFrom-args port s* lpBuffers* dwBufferCount* lpNumberOfBytesRecvd* lpFlags* lpFrom* lpFromLen* lpOverlapped* lpCompletionRoutine* ; @@ -162,9 +108,9 @@ TUPLE: WSARecvFrom-args port : ( datagram -- WSARecvFrom ) WSARecvFrom new - over >>port - over handle>> handle>> >>s* - swap addr>> sockaddr-type heap-size + swap >>port + dup port>> handle>> handle>> >>s* + dup port>> addr>> sockaddr-type heap-size [ malloc &free >>lpFrom* ] [ malloc-int &free >>lpFromLen* ] bi make-receive-buffer >>lpBuffers* @@ -173,23 +119,18 @@ TUPLE: WSARecvFrom-args port 0 malloc-int &free >>lpNumberOfBytesRecvd* (make-overlapped) >>lpOverlapped* ; -: wait-to-receive ( WSARecvFrom -- n ) - [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ; - : call-WSARecvFrom ( WSARecvFrom -- ) WSARecvFrom-args >tuple*< WSARecvFrom socket-error* ; : parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr ) - [ lpBuffers*>> WSABUF-buf swap memory>byte-array ] - [ lpFrom*>> ] - bi ; + [ lpBuffers*>> WSABUF-buf swap memory>byte-array ] [ lpFrom*>> ] bi ; M: winnt receive ( datagram -- packet addrspec ) [ { [ call-WSARecvFrom ] - [ wait-to-receive ] + [ wait-for-socket ] [ port>> pending-error ] [ parse-WSARecvFrom ] } cleave @@ -208,8 +149,8 @@ TUPLE: WSASendTo-args port : ( packet addrspec datagram -- WSASendTo ) WSASendTo-args new - over >>port - over handle>> handle>> >>s* + swap >>port + dup port>> handle>> handle>> >>s* swap make-sockaddr/size >r malloc-byte-array &free r> [ >>lpTo* ] [ >>iToLen* ] bi* @@ -219,19 +160,14 @@ TUPLE: WSASendTo-args port 0 >>lpNumberOfBytesSent* (make-overlapped) >>lpOverlapped* ; -: wait-to-send ( WSASendTo -- ) - [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs drop ; - : call-WSASendTo ( WSASendTo -- ) WSASendTo-args >tuple*< WSASendTo socket-error* ; -USE: io.sockets - M: winnt send ( packet addrspec datagram -- ) [ [ call-WSASendTo ] - [ wait-to-send ] + [ wait-for-socket drop ] [ port>> pending-error ] tri ] with-destructors ; diff --git a/extra/io/windows/sockets/sockets.factor b/extra/io/windows/sockets/sockets.factor new file mode 100755 index 0000000000..52902a88e9 --- /dev/null +++ b/extra/io/windows/sockets/sockets.factor @@ -0,0 +1,53 @@ +USING: kernel accessors io.sockets io.windows +windows.winsock system ; +IN: io.windows.sockets + +HOOK: WSASocket-flags io-backend ( -- DWORD ) + +TUPLE: win32-socket < win32-file ; + +: ( handle -- win32-socket ) + win32-socket new + swap >>handle ; + +M: win32-socket dispose ( stream -- ) + handle>> closesocket drop ; + +: unspecific-sockaddr/size ( addrspec -- sockaddr len ) + [ empty-sockaddr/size ] [ protocol-family ] bi + pick set-sockaddr-in-family ; + +: open-socket ( addrspec type -- win3-socket ) + >r protocol-family r> + 0 f 0 WSASocket-flags WSASocket + dup socket-error + |dispose + dup add-completion ; + +M: object get-local-address ( socket addrspec -- sockaddr ) + >r handle>> r> empty-sockaddr/size + [ getsockname socket-error ] 2keep drop ; + +M: object ((client)) ( addrspec -- handle ) + [ open-socket ] [ drop ] 2bi + [ unspecific-sockaddr/size bind socket-error ] [ drop ] 2bi ; + +: server-socket ( addrspec type -- fd ) + [ open-socket ] [ drop ] 2bi + [ make-sockaddr/size bind socket-error ] [ drop ] 2bi ; + +! http://support.microsoft.com/kb/127144 +! NOTE: Possibly tweak this because of SYN flood attacks +: listen-backlog ( -- n ) HEX: 7fffffff ; inline + +M: object (server) ( addrspec -- handle ) + [ + SOCK_STREAM server-socket + dup handle>> listen-backlog listen winsock-return-check + ] with-destructors ; + +M: windows (datagram) ( addrspec -- handle ) + [ SOCK_DGRAM server-socket ] with-destructors ; + +M: windows addrinfo-error ( n -- ) + winsock-return-check ; From 29556e2a2bd50ab984db8d85e8aa2a082037cb24 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Thu, 15 May 2008 05:20:42 -0500 Subject: [PATCH 3/3] Major overhaul of Windows I/O code: simpler, more readable, more efficient, more robust --- core/libc/libc-tests.factor | 11 +++ core/libc/libc.factor | 6 +- extra/io/mmap/mmap-docs.factor | 5 + extra/io/mmap/mmap-tests.factor | 17 ++-- extra/io/sockets/sockets.factor | 6 +- extra/io/unix/mmap/mmap.factor | 5 +- extra/io/unix/sockets/sockets.factor | 6 +- .../windows/ce/privileges/privileges.factor | 4 + extra/io/windows/files/files.factor | 18 ++-- extra/io/windows/files/unique/unique.factor | 6 +- extra/io/windows/launcher/launcher.factor | 2 +- extra/io/windows/mmap/mmap.factor | 96 ++++++------------- extra/io/windows/nt/backend/backend.factor | 27 +++--- extra/io/windows/nt/files/files.factor | 10 +- extra/io/windows/nt/launcher/launcher.factor | 42 ++++---- extra/io/windows/nt/monitors/monitors.factor | 8 +- extra/io/windows/nt/nt.factor | 1 + extra/io/windows/nt/pipes/pipes.factor | 10 +- .../windows/nt/privileges/privileges.factor | 53 ++++++++++ extra/io/windows/nt/sockets/sockets.factor | 36 ++++--- extra/io/windows/privileges/privileges.factor | 8 ++ extra/io/windows/sockets/sockets.factor | 25 +++-- extra/io/windows/windows.factor | 7 +- extra/windows/winsock/winsock.factor | 2 + 24 files changed, 226 insertions(+), 185 deletions(-) create mode 100755 core/libc/libc-tests.factor mode change 100644 => 100755 extra/io/unix/sockets/sockets.factor create mode 100755 extra/io/windows/ce/privileges/privileges.factor mode change 100644 => 100755 extra/io/windows/files/unique/unique.factor create mode 100755 extra/io/windows/nt/privileges/privileges.factor create mode 100755 extra/io/windows/privileges/privileges.factor mode change 100644 => 100755 extra/windows/winsock/winsock.factor diff --git a/core/libc/libc-tests.factor b/core/libc/libc-tests.factor new file mode 100755 index 0000000000..249399bdd0 --- /dev/null +++ b/core/libc/libc-tests.factor @@ -0,0 +1,11 @@ +IN: libc.tests +USING: libc libc.private tools.test namespaces assocs +destructors kernel ; + +100 malloc "block" set + +[ t ] [ "block" get mallocs get key? ] unit-test + +[ ] [ [ "block" get &free drop ] with-destructors ] unit-test + +[ f ] [ "block" get mallocs get key? ] unit-test diff --git a/core/libc/libc.factor b/core/libc/libc.factor index cba0b9253f..dff6e9e0f1 100755 --- a/core/libc/libc.factor +++ b/core/libc/libc.factor @@ -81,14 +81,14 @@ PRIVATE> > free ; PRIVATE> : &free ( alien -- alien ) - dup memory-destructor boa &dispose drop ; inline + dup f memory-destructor boa &dispose drop ; inline : |free ( alien -- alien ) - dup memory-destructor boa |dispose drop ; inline + dup f memory-destructor boa |dispose drop ; inline diff --git a/extra/io/mmap/mmap-docs.factor b/extra/io/mmap/mmap-docs.factor index 0c8148d6b0..4ac85232b8 100755 --- a/extra/io/mmap/mmap-docs.factor +++ b/extra/io/mmap/mmap-docs.factor @@ -16,6 +16,11 @@ HELP: { $notes "You must call " { $link close-mapped-file } " when you are finished working with the returned object, to reclaim resources. The " { $link with-mapped-file } " provides an abstraction which can close the mapped file for you." } { $errors "Throws an error if a memory mapping could not be established." } ; +HELP: with-mapped-file +{ $values { "path" "a pathname string" } { "length" integer } { "quot" "a quotation with stack effect " { $snippet "( mmap -- )" } } } +{ $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." } +{ $errors "Throws an error if a memory mapping could not be established." } ; + HELP: close-mapped-file { $values { "mmap" mapped-file } } { $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link dispose } " instead." } diff --git a/extra/io/mmap/mmap-tests.factor b/extra/io/mmap/mmap-tests.factor index da3ed38688..d25097e2b0 100755 --- a/extra/io/mmap/mmap-tests.factor +++ b/extra/io/mmap/mmap-tests.factor @@ -2,11 +2,14 @@ USING: io io.mmap io.files kernel tools.test continuations sequences io.encodings.ascii accessors ; IN: io.mmap.tests -[ "resource:mmap-test-file.txt" delete-file ] ignore-errors -[ ] [ "12345" "resource:mmap-test-file.txt" ascii set-file-contents ] unit-test -[ ] [ "resource:mmap-test-file.txt" dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test -[ 5 ] [ "resource:mmap-test-file.txt" dup file-info size>> [ length ] with-mapped-file ] unit-test -[ "22345" ] [ "resource:mmap-test-file.txt" ascii file-contents ] unit-test -[ "resource:mmap-test-file.txt" delete-file ] ignore-errors - +[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors +[ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test +[ ] [ "mmap-test-file.txt" temp-file dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test +[ 5 ] [ "mmap-test-file.txt" temp-file dup file-info size>> [ length ] with-mapped-file ] unit-test +[ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test +[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors +[ ] [ "a" "mmap-grow-test.txt" temp-file ascii set-file-contents ] unit-test +[ 1 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test +[ ] [ "mmap-grow-test.txt" temp-file 100 [ drop ] with-mapped-file ] unit-test +[ 100 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 40f6c22b82..36a0559bdb 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -27,10 +27,10 @@ GENERIC: inet-ntop ( data addrspec -- str ) GENERIC: inet-pton ( str addrspec -- data ) : make-sockaddr/size ( addrspec -- sockaddr size ) - dup make-sockaddr swap sockaddr-type heap-size ; + [ make-sockaddr ] [ sockaddr-type heap-size ] bi ; -: empty-sockaddr/size ( addrspec -- sockaddr len ) - sockaddr-type [ ] [ heap-size ] bi ; +: empty-sockaddr/size ( addrspec -- sockaddr size ) + sockaddr-type [ ] [ heap-size ] bi ; GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec ) diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor index 14ad49a89a..c31e23849e 100755 --- a/extra/io/unix/mmap/mmap.factor +++ b/extra/io/unix/mmap/mmap.factor @@ -6,7 +6,7 @@ IN: io.unix.mmap : open-r/w ( path -- fd ) O_RDWR file-mode open-file ; -:: mmap-open ( length prot flags path -- alien fd ) +:: mmap-open ( path length prot flags -- alien fd ) [ f length prot flags path open-r/w |dispose @@ -14,10 +14,9 @@ IN: io.unix.mmap ] with-destructors ; M: unix (mapped-file) - swap >r { PROT_READ PROT_WRITE } flags { MAP_FILE MAP_SHARED } flags - r> mmap-open ; + mmap-open ; M: unix close-mapped-file ( mmap -- ) [ [ address>> ] [ length>> ] bi munmap io-error ] diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor old mode 100644 new mode 100755 index 910f87a163..0bb0e3405a --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -23,7 +23,7 @@ M: unix addrinfo-error ( n -- ) ! Client sockets - TCP and Unix domain M: object (get-local-address) ( handle remote -- sockaddr ) - >r handle-fd r> empty-sockaddr/size + >r handle-fd r> empty-sockaddr/size [ getsockname io-error ] 2keep drop ; : init-client-socket ( fd -- ) @@ -67,7 +67,7 @@ M: object (server) ( addrspec -- handle ) ] with-destructors ; : do-accept ( server addrspec -- fd ) - [ handle>> handle-fd ] [ empty-sockaddr/size ] bi* accept ; inline + [ handle>> handle-fd ] [ empty-sockaddr/size ] bi* accept ; inline M: object (accept) ( server addrspec -- fd ) 2dup do-accept @@ -100,7 +100,7 @@ packet-size receive-buffer set-global packet-size ! nbytes 0 ! flags sockaddr ! from - len ! fromlen + len ! fromlen recvfrom dup 0 >= [ receive-buffer get-global swap head sockaddr ] [ diff --git a/extra/io/windows/ce/privileges/privileges.factor b/extra/io/windows/ce/privileges/privileges.factor new file mode 100755 index 0000000000..e0aa186b3d --- /dev/null +++ b/extra/io/windows/ce/privileges/privileges.factor @@ -0,0 +1,4 @@ +IN: io.windows.ce.privileges +USING: io.windows.privileges system ; + +M: wince set-privilege 2drop ; diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index 30b69bf40e..ef3db0dcd1 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -1,19 +1,17 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types io.backend io.files io.windows kernel math +USING: alien.c-types io.binary io.backend io.files io.buffers +io.windows kernel math splitting windows windows.kernel32 windows.time calendar combinators math.functions sequences namespaces words symbols system -combinators.lib io.ports destructors math.bitfields.lib ; +combinators.lib io.ports destructors accessors +math.bitfields math.bitfields.lib ; IN: io.windows.files : open-file ( path access-mode create-mode flags -- handle ) [ >r >r share-mode security-attributes-inherit r> r> - CreateFile-flags f CreateFile - dup invalid-handle? - - |dispose - dup add-completion + CreateFile-flags f CreateFile opened-file ] with-destructors ; : open-pipe-r/w ( path -- win32-file ) @@ -213,7 +211,7 @@ M: winnt link-info ( path -- info ) : file-times ( path -- timestamp timestamp timestamp ) [ - normalize-path open-existing &close-handle + normalize-path open-existing &dispose handle>> "FILETIME" "FILETIME" "FILETIME" @@ -229,7 +227,7 @@ M: winnt link-info ( path -- info ) #! timestamp order: creation access write [ >r >r >r - normalize-path open-existing &close-handle + normalize-path open-existing &dispose handle>> r> r> r> (set-file-times) ] with-destructors ; @@ -246,5 +244,5 @@ M: winnt touch-file ( path -- ) [ normalize-path maybe-create-file >r &dispose r> - [ drop ] [ f now dup (set-file-times) ] if + [ drop ] [ handle>> f now dup (set-file-times) ] if ] with-destructors ; diff --git a/extra/io/windows/files/unique/unique.factor b/extra/io/windows/files/unique/unique.factor old mode 100644 new mode 100755 index 2c166373e7..dcb713df7f --- a/extra/io/windows/files/unique/unique.factor +++ b/extra/io/windows/files/unique/unique.factor @@ -1,10 +1,10 @@ USING: kernel system io.files.unique.backend -windows.kernel32 io.windows io.ports windows ; +windows.kernel32 io.windows io.windows.files io.ports windows +destructors ; IN: io.windows.files.unique M: windows (make-unique-file) ( path -- ) - GENERIC_WRITE CREATE_NEW 0 open-file - CloseHandle win32-error=0/f ; + GENERIC_WRITE CREATE_NEW 0 open-file dispose ; M: windows temporary-path ( -- path ) "TEMP" os-env ; diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 6116b635c2..1cfb91d716 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -6,7 +6,7 @@ windows.types math windows.kernel32 namespaces io.launcher kernel sequences windows.errors splitting system threads init strings combinators io.backend accessors concurrency.flags io.files assocs -io.files.private windows destructors ; +io.files.private windows destructors classes.tuple.lib ; IN: io.windows.launcher TUPLE: CreateProcess-args diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor index 1e9cb4738c..72dfca9df3 100755 --- a/extra/io/windows/mmap/mmap.factor +++ b/extra/io/windows/mmap/mmap.factor @@ -1,86 +1,44 @@ -USING: alien alien.c-types alien.syntax arrays continuations -destructors generic io.mmap io.ports io.windows -kernel libc math namespaces quotations sequences windows -windows.advapi32 windows.kernel32 io.backend system ; +USING: alien alien.c-types arrays destructors generic io.mmap +io.ports io.windows io.windows.files io.windows.privileges +kernel libc math math.bitfields namespaces quotations sequences +windows windows.advapi32 windows.kernel32 io.backend system +accessors locals ; IN: io.windows.mmap -TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES +: create-file-mapping + CreateFileMapping [ win32-error=0/f ] keep ; -! Security tokens -! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/ +: map-view-of-file + MapViewOfFile [ win32-error=0/f ] keep ; -: (open-process-token) ( handle -- handle ) - { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags "PHANDLE" - [ OpenProcessToken win32-error=0/f ] keep *void* ; +:: mmap-open ( path length access-mode create-mode protect access -- handle handle address ) + [let | lo [ length HEX: ffffffff bitand ] + hi [ length -32 shift HEX: ffffffff bitand ] | + { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [ + path access-mode create-mode 0 open-file |dispose + dup handle>> f protect hi lo f create-file-mapping |dispose + dup handle>> access 0 0 0 map-view-of-file + ] with-privileges + ] ; -: open-process-token ( -- handle ) - #! remember to handle-close this - GetCurrentProcess (open-process-token) ; +TUPLE: win32-mapped-file file mapping ; -: with-process-token ( quot -- ) - #! quot: ( token-handle -- token-handle ) - >r open-process-token r> - [ keep ] curry - [ CloseHandle drop ] [ ] cleanup ; inline +M: win32-mapped-file dispose + [ file>> dispose ] [ mapping>> dispose ] bi ; -: lookup-privilege ( string -- luid ) - >r f r> "LUID" - [ LookupPrivilegeValue win32-error=0/f ] keep ; +C: win32-mapped-file -: make-token-privileges ( name ? -- obj ) - "TOKEN_PRIVILEGES" - 1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep - "LUID_AND_ATTRIBUTES" malloc-array &free - over set-TOKEN_PRIVILEGES-Privileges - - swap [ - SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges - set-LUID_AND_ATTRIBUTES-Attributes - ] when - - >r lookup-privilege r> - [ - TOKEN_PRIVILEGES-Privileges - >r 0 r> LUID_AND_ATTRIBUTES-nth - set-LUID_AND_ATTRIBUTES-Luid - ] keep ; - -: set-privilege ( name ? -- ) - [ - -rot 0 -rot make-token-privileges - dup length f f AdjustTokenPrivileges win32-error=0/f - ] with-process-token ; - -HOOK: with-privileges io-backend ( seq quot -- ) inline - -M: winnt with-privileges - over [ [ t set-privilege ] each ] curry compose - swap [ [ f set-privilege ] each ] curry [ ] cleanup ; - -M: wince with-privileges - nip call ; - -: mmap-open ( path access-mode create-mode flProtect access -- handle handle address ) - { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [ - >r >r 0 open-file dup f r> 0 0 f - CreateFileMapping [ win32-error=0/f ] keep |close-handle - dup - r> 0 0 0 MapViewOfFile [ win32-error=0/f ] keep |close-handle - ] with-privileges ; - M: windows (mapped-file) [ - swap - GENERIC_WRITE GENERIC_READ bitor + { GENERIC_WRITE GENERIC_READ } flags OPEN_ALWAYS - PAGE_READWRITE SEC_COMMIT bitor + { PAGE_READWRITE SEC_COMMIT } flags FILE_MAP_ALL_ACCESS mmap-open - -rot 2array + -rot ] with-destructors ; M: windows close-mapped-file ( mapped-file -- ) [ - [ handle>> [ &close-handle drop ] each ] - [ address>> UnmapViewOfFile win32-error=0/f ] - bi + [ handle>> &dispose drop ] + [ address>> UnmapViewOfFile win32-error=0/f ] bi ] with-destructors ; diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 42e43d5f42..134a0c024a 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -1,9 +1,10 @@ USING: alien alien.c-types arrays assocs combinators -continuations destructors io io.backend io.ports -io.windows libc kernel math namespaces sequences -threads classes.tuple.lib windows windows.errors -windows.kernel32 strings splitting io.files qualified ascii -combinators.lib system accessors ; +continuations destructors io io.backend io.ports io.timeouts +io.windows io.windows.files libc kernel math namespaces +sequences threads classes.tuple.lib windows windows.errors +windows.kernel32 strings splitting io.files +io.buffers qualified ascii combinators.lib system +accessors locals ; QUALIFIED: windows.winsock IN: io.windows.nt.backend @@ -28,8 +29,8 @@ SYMBOL: master-completion-port : ( -- handle ) INVALID_HANDLE_VALUE f ; -M: winnt add-completion ( handle -- ) - master-completion-port get-global drop ; +M: winnt add-completion ( win32-handle -- ) + handle>> master-completion-port get-global drop ; : eof? ( error -- ? ) dup ERROR_HANDLE_EOF = swap ERROR_BROKEN_PIPE = or ; @@ -64,7 +65,6 @@ M: winnt add-completion ( handle -- ) :: wait-for-overlapped ( ms -- overlapped ? ) master-completion-port get-global - r> INFINITE or ! timeout 0 ! bytes f ! key f ! overlapped @@ -82,9 +82,9 @@ M: winnt add-completion ( handle -- ) GetLastError dup expected-io-error? [ 2drop f ] [ >r lookup-callback [ thread>> ] [ port>> ] bi r> dup eof? - [ drop t >>eof drop ] - [ (win32-error-string) >>error drop ] if - thread>> resume t + [ drop t >>eof ] + [ (win32-error-string) >>error ] if drop + resume t ] if ] [ lookup-callback @@ -102,6 +102,9 @@ M: winnt init-io ( -- ) H{ } clone io-hash set-global windows.winsock:init-winsock ; +: update-file-ptr ( n port -- ) + handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ; + : finish-flush ( n port -- ) [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ; @@ -124,7 +127,7 @@ M: winnt (wait-to-write) over zero? [ t >>eof 2drop ] [ - [ buffer>> n>buffer ] [ update-file-ptr ] bi + [ buffer>> n>buffer ] [ update-file-ptr ] 2bi ] if ; : ((wait-to-read)) ( port -- ) diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index e99aa18196..67161716a3 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -1,6 +1,7 @@ USING: continuations destructors io.buffers io.files io.backend -io.timeouts io.ports io.windows io.windows.nt.backend -kernel libc math threads windows windows.kernel32 system +io.timeouts io.ports io.windows io.windows.files +io.windows.nt.backend windows windows.kernel32 +kernel libc math threads system alien.c-types alien.arrays alien.strings sequences combinators combinators.lib sequences.lib ascii splitting alien strings assocs namespaces io.files.private accessors ; @@ -55,7 +56,4 @@ M: winnt FileArgs-overlapped ( port -- overlapped ) M: winnt open-append [ dup file-info size>> ] [ drop 0 ] recover - >r (open-append) r> ; - -: update-file-ptr ( n port -- ) - handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ; + >r (open-append) r> >>ptr ; diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index bad70501d7..6c86b53049 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -4,8 +4,9 @@ USING: alien alien.c-types arrays continuations destructors io io.windows libc io.ports io.pipes windows.types math windows.kernel32 windows namespaces io.launcher kernel sequences windows.errors assocs splitting system strings -io.windows.launcher io.windows.nt.pipes io.backend io.files -io.files.private combinators shuffle accessors locals ; +io.windows.launcher io.windows.files +io.backend io.files io.files.private combinators shuffle +accessors locals ; IN: io.windows.nt.launcher : duplicate-handle ( handle -- handle' ) @@ -35,13 +36,13 @@ IN: io.windows.nt.launcher ! The below code is based on the example given in ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx -: redirect-default ( default obj access-mode create-mode -- handle ) - 3drop ; +: redirect-default ( obj access-mode create-mode -- handle ) + 3drop f ; -: redirect-closed ( default obj access-mode create-mode -- handle ) - drop 2nip null-pipe ; +: redirect-closed ( obj access-mode create-mode -- handle ) + drop nip null-pipe ; -:: redirect-file ( default path access-mode create-mode -- handle ) +:: redirect-file ( path access-mode create-mode -- handle ) path normalize-path access-mode share-mode @@ -49,9 +50,9 @@ IN: io.windows.nt.launcher create-mode FILE_ATTRIBUTE_NORMAL ! flags and attributes f ! template file - CreateFile dup invalid-handle? &dispose ; + CreateFile dup invalid-handle? &dispose handle>> ; -: redirect-append ( default path access-mode create-mode -- handle ) +: redirect-append ( path access-mode create-mode -- handle ) >r >r path>> r> r> drop OPEN_ALWAYS redirect-file @@ -60,14 +61,13 @@ IN: io.windows.nt.launcher : set-inherit ( handle ? -- ) >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ; -: redirect-handle ( default handle access-mode create-mode -- handle ) - 2drop nip - handle>> duplicate-handle dup t set-inherit ; +: redirect-handle ( handle access-mode create-mode -- handle ) + 2drop handle>> duplicate-handle dup t set-inherit ; -: redirect-stream ( default stream access-mode create-mode -- handle ) - >r >r underlying-handle r> r> redirect-handle ; +: redirect-stream ( stream access-mode create-mode -- handle ) + >r >r underlying-handle handle>> r> r> redirect-handle ; -: redirect ( default obj access-mode create-mode -- handle ) +: redirect ( obj access-mode create-mode -- handle ) { { [ pick not ] [ redirect-default ] } { [ pick +closed+ eq? ] [ redirect-closed ] } @@ -78,21 +78,20 @@ IN: io.windows.nt.launcher } cond ; : redirect-stdout ( process args -- handle ) + drop stdout>> GENERIC_WRITE CREATE_ALWAYS redirect - STD_OUTPUT_HANDLE GetStdHandle ; + STD_OUTPUT_HANDLE GetStdHandle or ; : redirect-stderr ( process args -- handle ) over stderr>> +stdout+ eq? [ - lpStartupInfo>> - STARTUPINFO-hStdOutput nip + lpStartupInfo>> STARTUPINFO-hStdOutput ] [ drop - f - swap stderr>> + stderr>> GENERIC_WRITE CREATE_ALWAYS redirect @@ -100,11 +99,12 @@ IN: io.windows.nt.launcher ] if ; : redirect-stdin ( process args -- handle ) + drop stdin>> GENERIC_READ OPEN_EXISTING redirect - STD_INPUT_HANDLE GetStdHandle ; + STD_INPUT_HANDLE GetStdHandle or ; M: winnt fill-redirection ( process args -- ) [ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index 2257c48f99..a509d1d5e7 100755 --- a/extra/io/windows/nt/monitors/monitors.factor +++ b/extra/io/windows/nt/monitors/monitors.factor @@ -17,11 +17,7 @@ IN: io.windows.nt.monitors OPEN_EXISTING { FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } flags f - CreateFile - dup invalid-handle? - - |close-handle - dup add-completion ; + CreateFile opened-file ; TUPLE: win32-monitor-port < input-port recursive ; @@ -93,7 +89,7 @@ TUPLE: win32-monitor < monitor port ; : fill-queue-thread ( monitor -- ) [ dup fill-queue (fill-queue-thread) ] - [ dup port-closed-error? [ 2drop ] [ rethrow ] if ] recover ; + [ dup already-disposed? [ 2drop ] [ rethrow ] if ] recover ; M:: winnt (monitor) ( path recursive? mailbox -- monitor ) [ diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor index 33bb3a88b9..8e59a4d555 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -7,6 +7,7 @@ USE: io.windows.nt.backend USE: io.windows.nt.files USE: io.windows.nt.launcher USE: io.windows.nt.monitors +USE: io.windows.nt.privileges USE: io.windows.nt.sockets USE: io.windows.mmap USE: io.windows.files diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor index 4a0b8119ba..97c2e49627 100755 --- a/extra/io/windows/nt/pipes/pipes.factor +++ b/extra/io/windows/nt/pipes/pipes.factor @@ -17,10 +17,7 @@ IN: io.windows.nt.pipes 4096 0 security-attributes-inherit - CreateNamedPipe - dup win32-error=0/f - |dispose - dup add-completion ; + CreateNamedPipe opened-file ; : open-other-end ( name -- handle ) GENERIC_WRITE @@ -29,10 +26,7 @@ IN: io.windows.nt.pipes OPEN_EXISTING FILE_FLAG_OVERLAPPED f - CreateFile - dup win32-error=0/f - |dispose - dup add-completion ; + CreateFile opened-file ; : unique-pipe-name ( -- string ) [ diff --git a/extra/io/windows/nt/privileges/privileges.factor b/extra/io/windows/nt/privileges/privileges.factor new file mode 100755 index 0000000000..007d05f9af --- /dev/null +++ b/extra/io/windows/nt/privileges/privileges.factor @@ -0,0 +1,53 @@ +USING: alien alien.c-types alien.syntax arrays continuations +destructors generic io.mmap io.ports io.windows io.windows.files +kernel libc math math.bitfields namespaces quotations sequences windows +windows.advapi32 windows.kernel32 io.backend system accessors +io.windows.privileges ; +IN: io.windows.nt.privileges + +TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES + +! Security tokens +! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/ + +: (open-process-token) ( handle -- handle ) + { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags "PHANDLE" + [ OpenProcessToken win32-error=0/f ] keep *void* ; + +: open-process-token ( -- handle ) + #! remember to CloseHandle + GetCurrentProcess (open-process-token) ; + +: with-process-token ( quot -- ) + #! quot: ( token-handle -- token-handle ) + >r open-process-token r> + [ keep ] curry + [ CloseHandle drop ] [ ] cleanup ; inline + +: lookup-privilege ( string -- luid ) + >r f r> "LUID" + [ LookupPrivilegeValue win32-error=0/f ] keep ; + +: make-token-privileges ( name ? -- obj ) + "TOKEN_PRIVILEGES" + 1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep + "LUID_AND_ATTRIBUTES" malloc-array &free + over set-TOKEN_PRIVILEGES-Privileges + + swap [ + SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges + set-LUID_AND_ATTRIBUTES-Attributes + ] when + + >r lookup-privilege r> + [ + TOKEN_PRIVILEGES-Privileges + >r 0 r> LUID_AND_ATTRIBUTES-nth + set-LUID_AND_ATTRIBUTES-Luid + ] keep ; + +M: winnt set-privilege ( name ? -- ) + [ + -rot 0 -rot make-token-privileges + dup length f f AdjustTokenPrivileges win32-error=0/f + ] with-process-token ; diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 0a3dca279e..75a08a02c4 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -1,8 +1,9 @@ USING: alien alien.accessors alien.c-types byte-arrays continuations destructors io.ports io.timeouts io.sockets io.sockets io namespaces io.streams.duplex io.windows +io.windows.sockets io.windows.nt.backend windows.winsock kernel libc math sequences -threads classes.tuple.lib system accessors ; +threads classes.tuple.lib system combinators accessors ; IN: io.windows.nt.sockets : malloc-int ( object -- object ) @@ -11,9 +12,6 @@ IN: io.windows.nt.sockets M: winnt WSASocket-flags ( -- DWORD ) WSA_FLAG_OVERLAPPED ; -: wait-for-socket ( args -- n ) - [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ; - : get-ConnectEx-ptr ( socket -- void* ) SIO_GET_EXTENSION_FUNCTION_POINTER WSAID_CONNECTEX @@ -33,7 +31,10 @@ TUPLE: ConnectEx-args port s* name* namelen* lpSendBuffer* dwSendDataLength* lpdwBytesSent* lpOverlapped* ptr* ; -: ( sockaddr size -- ) +: wait-for-socket ( args -- n ) + [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ; + +: ( sockaddr size -- ConnectEx ) ConnectEx-args new swap >>namelen* swap >>name* @@ -61,18 +62,18 @@ TUPLE: AcceptEx-args port sListenSocket* sAcceptSocket* lpOutputBuffer* dwReceiveDataLength* dwLocalAddressLength* dwRemoteAddressLength* lpdwBytesReceived* lpOverlapped* ; -: init-accept-buffer ( server-port AcceptEx -- ) - swap addr>> sockaddr-type heap-size 16 + +: init-accept-buffer ( addr AcceptEx -- ) + swap sockaddr-type heap-size 16 + [ >>dwLocalAddressLength* ] [ >>dwRemoteAddressLength* ] bi dup dwLocalAddressLength*>> 2 * malloc &free >>lpOutputBuffer* drop ; -: ( server-port -- AcceptEx ) +: ( server addr -- AcceptEx ) AcceptEx-args new 2dup init-accept-buffer + swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket* + over handle>> handle>> >>sListenSocket* swap >>port - dup port>> handle>> handle>> >>sListenSocket* - dup port>> addr>> tcp-socket >>sAcceptSocket* 0 >>dwReceiveDataLength* f >>lpdwBytesReceived* (make-overlapped) >>lpOverlapped* ; @@ -81,20 +82,17 @@ TUPLE: AcceptEx-args port AcceptEx-args >tuple*< AcceptEx drop winsock-error-string [ throw ] when* ; -: finish-accept ( AcceptEx -- client ) - sAcceptSocket*>> [ |dispose ] [ add-completion ] bi ; - -M: winnt (accept) ( server -- handle ) +M: object (accept) ( server addr -- handle ) [ [ { [ call-AcceptEx ] [ wait-for-socket drop ] - [ finish-accept ] + [ sAcceptSocket*>> opened-socket ] [ port>> pending-error ] } cleave - ] with-timeout + ] curry with-timeout ] with-destructors ; TUPLE: WSARecvFrom-args port @@ -107,7 +105,7 @@ TUPLE: WSARecvFrom-args port default-buffer-size get malloc &free over set-WSABUF-buf ; : ( datagram -- WSARecvFrom ) - WSARecvFrom new + WSARecvFrom-args new swap >>port dup port>> handle>> handle>> >>s* dup port>> addr>> sockaddr-type heap-size @@ -125,7 +123,7 @@ TUPLE: WSARecvFrom-args port : parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr ) [ lpBuffers*>> WSABUF-buf swap memory>byte-array ] [ lpFrom*>> ] bi ; -M: winnt receive ( datagram -- packet addrspec ) +M: winnt (receive) ( datagram -- packet addrspec ) [ { @@ -163,7 +161,7 @@ TUPLE: WSASendTo-args port : call-WSASendTo ( WSASendTo -- ) WSASendTo-args >tuple*< WSASendTo socket-error* ; -M: winnt send ( packet addrspec datagram -- ) +M: winnt (send) ( packet addrspec datagram -- ) [ [ call-WSASendTo ] diff --git a/extra/io/windows/privileges/privileges.factor b/extra/io/windows/privileges/privileges.factor new file mode 100755 index 0000000000..144c799912 --- /dev/null +++ b/extra/io/windows/privileges/privileges.factor @@ -0,0 +1,8 @@ +USING: io.backend kernel continuations sequences ; +IN: io.windows.privileges + +HOOK: set-privilege io-backend ( name ? -- ) inline + +: with-privileges ( seq quot -- ) + over [ [ t set-privilege ] each ] curry compose + swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline diff --git a/extra/io/windows/sockets/sockets.factor b/extra/io/windows/sockets/sockets.factor index 52902a88e9..67d827aa95 100755 --- a/extra/io/windows/sockets/sockets.factor +++ b/extra/io/windows/sockets/sockets.factor @@ -1,5 +1,5 @@ -USING: kernel accessors io.sockets io.windows -windows.winsock system ; +USING: kernel accessors io.sockets io.windows io.backend +windows.winsock system destructors alien.c-types ; IN: io.windows.sockets HOOK: WSASocket-flags io-backend ( -- DWORD ) @@ -17,24 +17,29 @@ M: win32-socket dispose ( stream -- ) [ empty-sockaddr/size ] [ protocol-family ] bi pick set-sockaddr-in-family ; -: open-socket ( addrspec type -- win3-socket ) +: opened-socket ( handle -- win32-socket ) + |dispose dup add-completion ; + +: open-socket ( addrspec type -- win32-socket ) >r protocol-family r> 0 f 0 WSASocket-flags WSASocket dup socket-error - |dispose - dup add-completion ; + opened-socket ; -M: object get-local-address ( socket addrspec -- sockaddr ) - >r handle>> r> empty-sockaddr/size +M: object (get-local-address) ( socket addrspec -- sockaddr ) + >r handle>> r> empty-sockaddr/size [ getsockname socket-error ] 2keep drop ; +: bind-socket ( win32-socket sockaddr len -- ) + >r >r handle>> r> r> bind socket-error ; + M: object ((client)) ( addrspec -- handle ) - [ open-socket ] [ drop ] 2bi - [ unspecific-sockaddr/size bind socket-error ] [ drop ] 2bi ; + [ SOCK_STREAM open-socket ] keep + [ unspecific-sockaddr/size bind-socket ] [ drop ] 2bi ; : server-socket ( addrspec type -- fd ) [ open-socket ] [ drop ] 2bi - [ make-sockaddr/size bind socket-error ] [ drop ] 2bi ; + [ make-sockaddr/size bind-socket ] [ drop ] 2bi ; ! http://support.microsoft.com/kb/127144 ! NOTE: Possibly tweak this because of SYN flood attacks diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 05c55ab5fe..6b6b54ab92 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -19,7 +19,7 @@ TUPLE: win32-handle handle disposed ; M: win32-handle dispose* ( handle -- ) handle>> CloseHandle drop ; -TUPLE: win32-file handle ptr disposed ; +TUPLE: win32-file < win32-handle ptr ; : ( handle -- win32-file ) win32-file new-win32-handle ; @@ -31,6 +31,11 @@ HOOK: CreateFile-flags io-backend ( DWORD -- DWORD ) HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) HOOK: add-completion io-backend ( port -- ) +: opened-file ( handle -- win32-file ) + dup invalid-handle? + |dispose + dup add-completion ; + : share-mode ( -- fixnum ) { FILE_SHARE_READ diff --git a/extra/windows/winsock/winsock.factor b/extra/windows/winsock/winsock.factor old mode 100644 new mode 100755 index 39d11b562b..0699afc682 --- a/extra/windows/winsock/winsock.factor +++ b/extra/windows/winsock/winsock.factor @@ -167,6 +167,8 @@ FUNCTION: int shutdown ( SOCKET s, int how ) ; FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ; FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ; +FUNCTION: int getsockname ( SOCKET s, sockaddr_in* address, int* addrlen ) ; + TYPEDEF: uint SERVICETYPE TYPEDEF: OVERLAPPED WSAOVERLAPPED TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED