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 ;