From e7cc5ea6d4656c0422309d900f224eb2bde01390 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 21 Nov 2007 01:18:46 -0500 Subject: [PATCH] Windows IO fixes and work --- extra/io/launcher/launcher.factor | 1 + extra/io/windows/ce/backend/backend.factor | 8 +- extra/io/windows/ce/files/files.factor | 12 +- extra/io/windows/launcher/launcher.factor | 143 ++----------------- extra/io/windows/mmap/mmap.factor | 2 +- extra/io/windows/nt/backend/backend.factor | 83 ++++++----- extra/io/windows/nt/launcher/launcher.factor | 64 +++++++++ extra/io/windows/nt/pipes/pipes.factor | 72 ++++++++++ extra/io/windows/windows.factor | 3 + 9 files changed, 205 insertions(+), 183 deletions(-) mode change 100644 => 100755 extra/io/launcher/launcher.factor create mode 100755 extra/io/windows/nt/launcher/launcher.factor create mode 100755 extra/io/windows/nt/pipes/pipes.factor diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor old mode 100644 new mode 100755 index 92a15bb460..114a50597c --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -59,3 +59,4 @@ HOOK: process-stream* io-backend ( desc -- stream ) USE-IF: unix? io.unix.launcher USE-IF: windows? io.windows.launcher +USE-IF: winnt? io.windows.nt.launcher diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor index 2cd1f6fe99..b9ad30d910 100755 --- a/extra/io/windows/ce/backend/backend.factor +++ b/extra/io/windows/ce/backend/backend.factor @@ -13,7 +13,7 @@ M: windows-ce-io add-completion ( port -- ) drop ; GENERIC: wince-read ( port port-handle -- ) M: input-port (wait-to-read) ( port -- ) - dup port-handle wince-read ; + dup dup port-handle wince-read pending-error ; GENERIC: wince-write ( port port-handle -- ) @@ -41,7 +41,5 @@ M: windows-ce-io init-stdio ( -- ) ] [ 0 _getstdfilex _fileno 1 _getstdfilex _fileno - ] if - >r f - r> f - ] with-variable stdio set ; + ] if + ] with-variable stdio set ; diff --git a/extra/io/windows/ce/files/files.factor b/extra/io/windows/ce/files/files.factor index 0cffcb85f0..df5dc65094 100755 --- a/extra/io/windows/ce/files/files.factor +++ b/extra/io/windows/ce/files/files.factor @@ -10,12 +10,16 @@ IN: windows.ce.files M: windows-ce-io CreateFile-flags ( -- DWORD ) FILE_ATTRIBUTE_NORMAL ; M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ; +: finish-read ( port status bytes-ret -- ) + swap [ drop port-errored ] [ swap n>buffer ] if ; + M: win32-file wince-read - drop dup make-FileArgs dup setup-read ReadFile zero? [ - drop port-errored + drop + dup make-FileArgs dup setup-read ReadFile zero? + swap FileArgs-lpNumberOfBytesRet *uint dup zero? [ + 2drop t swap set-port-eof? ] [ - FileArgs-lpNumberOfBytesRet *uint dup zero? - [ drop t swap set-port-eof? ] [ swap n>buffer ] if + finish-read ] if ; M: win32-file wince-write ( port port-handle -- ) diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index f586976bb6..3caa2c7113 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -1,11 +1,11 @@ +! Copyright (C) 2007 Doug Coleman, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays continuations destructors io io.windows libc io.nonblocking io.streams.duplex windows.types math windows.kernel32 windows namespaces io.launcher kernel sequences windows.errors assocs splitting system ; IN: io.windows.launcher -! From MSDN: "Handles in PROCESS_INFORMATION must be closed with CloseHandle when they are no longer needed." - TUPLE: CreateProcess-args lpApplicationName lpCommandLine @@ -20,6 +20,8 @@ TUPLE: CreateProcess-args stdout-pipe stdin-pipe ; : dispose-CreateProcess-args ( args -- ) + #! From MSDN: "Handles in PROCESS_INFORMATION must be closed + #! with CloseHandle when they are no longer needed." CreateProcess-args-lpProcessInformation dup PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when* PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ; @@ -75,7 +77,7 @@ TUPLE: CreateProcess-args : fill-dwCreateFlags 0 pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when - +detached+ get [ DETACHED_PROCESS bitor ] when + +detached+ get winnt? and [ DETACHED_PROCESS bitor ] when over set-CreateProcess-args-dwCreateFlags ; : fill-lpEnvironment @@ -93,137 +95,16 @@ TUPLE: CreateProcess-args PROCESS_INFORMATION-hProcess INFINITE WaitForSingleObject drop ; +: make-CreateProcess-args ( -- args ) + default-CreateProcess-args + wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if + fill-dwCreateFlags + fill-lpEnvironment ; + M: windows-io run-process* ( desc -- ) [ - default-CreateProcess-args - wince? [ - fill-lpApplicationName - ] [ - fill-lpCommandLine - ] if - fill-dwCreateFlags - fill-lpEnvironment + make-CreateProcess-args dup call-CreateProcess +detached+ get [ dup wait-for-process ] unless dispose-CreateProcess-args ] with-descriptor ; - -! : default-security-attributes ( -- obj ) -! "SECURITY_ATTRIBUTES" -! "SECURITY_ATTRIBUTES" heap-size over set-SECURITY_ATTRIBUTES-nLength ; -! -! : security-attributes-inherit ( -- obj ) -! default-security-attributes -! TRUE over set-SECURITY_ATTRIBUTES-bInheritHandle ; -! -! : set-inherit ( handle ? -- ) -! >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ; -! -! ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx -! -! TUPLE: pipe hRead hWrite ; -! -! C: pipe -! -! : factor-pipe-name -! "\\\\.\\pipe\\Factor" ; -! -! : create-named-pipe ( str -- handle ) -! PIPE_ACCESS_DUPLEX FILE_FLAG_OVERLAPPED bitor -! PIPE_TYPE_BYTE PIPE_READMODE_BYTE PIPE_NOWAIT bitor bitor -! PIPE_UNLIMITED_INSTANCES -! default-buffer-size get -! default-buffer-size get -! 0 -! security-attributes-inherit -! CreateNamedPipe dup invalid-handle? ; -! -! : ERROR_PIPE_CONNECT 535 ; inline -! -! : pipe-connect-error? ( n -- ? ) -! ERROR_SUCCESS ERROR_PIPE_CONNECT 2array member? not ; -! -! clear "ls" contents -! M: windows-nt-io ( command -- stream ) -! [ -! [ -! default-CreateProcess-args -! fill-lpCommandLine -! TRUE over set-CreateProcess-args-bInheritHandles -! -! dup CreateProcess-args-lpStartupInfo -! STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags -! -! factor-pipe-name create-named-pipe -! global [ "Named pipe: " write dup . ] bind -! dup t set-inherit -! [ add-completion ] keep -! -! ! CreateFile -! ! factor-pipe-name open-pipe-r/w -! factor-pipe-name GENERIC_READ GENERIC_WRITE bitor -! 0 f OPEN_EXISTING FILE_FLAG_OVERLAPPED f -! CreateFile -! global [ "Created File: " write dup . ] bind -! dup invalid-handle? dup close-later -! dup add-completion -! -! swap (make-overlapped) ConnectNamedPipe zero? [ -! GetLastError pipe-connect-error? [ -! win32-error-string throw -! ] when -! ] when -! dup t set-inherit -! -! ! ERROR_PIPE_CONNECTED -! [ pick set-CreateProcess-args-stdin-pipe ] keep -! global [ "Setting the stdios to: " write dup . ] bind -! [ over set-STARTUPINFO-hStdOutput ] keep -! [ over set-STARTUPINFO-hStdInput ] keep -! swap set-STARTUPINFO-hStdError -! ! -! [ call-CreateProcess ] keep -! [ CreateProcess-args-stdin-pipe f dup handle>duplex-stream ] keep -! drop ! TODO: close handles instead of drop -! ] with-destructors -! ] with-descriptor ; -! -! : create-pipe ( -- pipe ) -! "HANDLE" -! "HANDLE" -! [ -! security-attributes-inherit -! 0 -! CreatePipe win32-error=0/f -! ] 2keep -! [ *void* dup close-later ] 2apply ; -! -! M: windows-ce-io process-stream* -! [ -! default-CreateProcess-args -! TRUE over set-CreateProcess-args-bInheritHandles -! -! create-pipe ! for child's STDOUT -! dup pipe-hRead f set-inherit -! over set-CreateProcess-args-stdout-pipe -! -! create-pipe ! for child's STDIN -! dup pipe-hWrite f set-inherit -! over set-CreateProcess-args-stdin-pipe -! -! dup CreateProcess-args-lpStartupInfo -! STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags -! -! over CreateProcess-args-stdout-pipe -! pipe-hWrite over set-STARTUPINFO-hStdOutput -! over CreateProcess-args-stdout-pipe -! pipe-hWrite over set-STARTUPINFO-hStdError -! over CreateProcess-args-stdin-pipe -! pipe-hRead swap set-STARTUPINFO-hStdInput -! -! [ call-CreateProcess ] keep -! [ CreateProcess-args-stdin-pipe pipe-hRead f ] keep -! [ CreateProcess-args-stdout-pipe pipe-hWrite f ] keep -! drop ! TODO: close handles instead of drop -! ] with-destructors ; -! diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor index 20c6a6fc22..ca5d2bbd9a 100755 --- a/extra/io/windows/mmap/mmap.factor +++ b/extra/io/windows/mmap/mmap.factor @@ -78,7 +78,7 @@ M: windows-io ( path length -- mmap ) PAGE_READWRITE SEC_COMMIT bitor FILE_MAP_ALL_ACCESS mmap-open -rot 2array - \ mapped-file construct-boa + f \ mapped-file construct-boa ] with-destructors ; M: windows-io (close-mapped-file) ( mapped-file -- ) diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 2c6d152e3d..c475771b5c 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -42,7 +42,8 @@ M: windows-nt-io normalize-pathname ( string -- string ) SYMBOL: io-hash -TUPLE: io-callback port continuation ; +TUPLE: io-callback continuation port ; + C: io-callback : (make-overlapped) ( -- overlapped-ext ) @@ -74,53 +75,55 @@ SYMBOL: master-completion-port M: windows-nt-io add-completion ( handle -- ) master-completion-port get-global drop ; -TUPLE: GetOverlappedResult-args hFile* lpOverlapped* lpNumberOfBytesTransferred* bWait* port ; +: eof? ( error -- ? ) + dup ERROR_HANDLE_EOF = swap ERROR_BROKEN_PIPE = or ; -C: GetOverlappedResult-args +: overlapped-error? ( port n -- ? ) + zero? [ + GetLastError { + { [ dup expected-io-error? ] [ 2drop t ] } + { [ dup eof? ] [ drop t swap set-port-eof? f ] } + { [ t ] [ (win32-error-string) throw ] } + } cond + ] [ + drop t + ] if ; -: get-overlapped-result ( port -- n ) - [ - port-handle dup win32-file-handle - swap win32-file-overlapped 0 0 - ] keep [ - \ GetOverlappedResult-args >tuple< - >r GetOverlappedResult r> swap overlapped-error? drop - ] keep GetOverlappedResult-args-lpNumberOfBytesTransferred* *int ; - -: (save-callback) ( io-callback -- ) - dup io-callback-port port-handle win32-file-overlapped - io-hash get-global set-at ; +: get-overlapped-result ( port -- bytes-transferred ) + dup + port-handle + dup win32-file-handle + swap win32-file-overlapped + 0 [ + 0 + GetOverlappedResult overlapped-error? drop + ] keep *uint ; : save-callback ( port -- ) [ - (save-callback) stop - ] callcc0 drop ; + [ ] keep port-handle win32-file-overlapped + io-hash get-global set-at stop + ] curry callcc0 ; -TUPLE: GetQueuedCompletionStatusParams hCompletionPort* lpNumberOfBytes* lpCompletionKey* lpOverlapped* dwMilliseconds* ; - -C: GetQueuedCompletionStatusParams - -: wait-for-overlapped ( ms -- GetQueuedCompletionStatus-Params ret ) - >r master-completion-port get-global 0 0 0 - r> [ - GetQueuedCompletionStatusParams >tuple*< - GetQueuedCompletionStatus - ] keep swap ; +: wait-for-overlapped ( ms -- overlapped ? ) + >r master-completion-port get-global r> ! port ms + 0 ! bytes + f ! key + f ! overlapped + [ roll GetQueuedCompletionStatus ] keep *void* swap zero? ; : lookup-callback ( GetQueuedCompletion-args -- callback ) - GetQueuedCompletionStatusParams-lpOverlapped* *void* io-hash get-global delete-at* drop ; : wait-for-io ( timeout -- continuation/f ) - wait-for-overlapped - zero? [ - GetLastError dup (expected-io-error?) [ + wait-for-overlapped [ + GetLastError dup expected-io-error? [ 2drop f ] [ - dup ERROR_HANDLE_EOF = [ - drop lookup-callback [ - io-callback-port t swap set-port-eof? - ] keep io-callback-continuation + dup eof? [ + drop lookup-callback + dup io-callback-port t swap set-port-eof? + io-callback-continuation ] [ (win32-error-string) swap lookup-callback [ io-callback-port set-port-error ] keep @@ -146,10 +149,6 @@ M: windows-nt-io io-multiplex ( ms -- ) cancel-timeout wait-for-io [ schedule-thread ] when* ; M: windows-nt-io init-io ( -- ) - #! Should only be called on startup. Calling this at any - #! other time can have unintended consequences. - global [ - master-completion-port set - H{ } clone io-hash set - windows.winsock:init-winsock - ] bind ; + master-completion-port set-global + H{ } clone io-hash set-global + windows.winsock:init-winsock ; diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor new file mode 100755 index 0000000000..3ee0e05e32 --- /dev/null +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -0,0 +1,64 @@ +! Copyright (C) 2007 Doug Coleman, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types arrays continuations destructors io +io.windows libc io.nonblocking io.streams.duplex windows.types +math windows.kernel32 windows namespaces io.launcher kernel +sequences windows.errors assocs splitting system +io.windows.launcher io.windows.nt.pipes ; +IN: io.windows.nt.launcher + +! The below code is based on the example given in +! http://msdn2.microsoft.com/en-us/library/ms682499.aspx + +: set-inherit ( handle ? -- ) + >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ; + +: add-pipe-dtors ( pipe -- ) + dup + pipe-in close-later + pipe-out close-later ; + +: fill-stdout-pipe + + dup add-pipe-dtors + dup pipe-in f set-inherit + over set-CreateProcess-args-stdout-pipe ; + +: fill-stdin-pipe + + dup add-pipe-dtors + dup pipe-out f set-inherit + over set-CreateProcess-args-stdin-pipe ; + +: fill-startup-info + dup CreateProcess-args-lpStartupInfo + STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags + + over CreateProcess-args-stdout-pipe + pipe-out over set-STARTUPINFO-hStdOutput + over CreateProcess-args-stdout-pipe + pipe-out over set-STARTUPINFO-hStdError + over CreateProcess-args-stdin-pipe + pipe-in swap set-STARTUPINFO-hStdInput ; + +M: windows-io process-stream* + [ + [ + make-CreateProcess-args + TRUE over set-CreateProcess-args-bInheritHandles + + fill-stdout-pipe + fill-stdin-pipe + fill-startup-info + + dup call-CreateProcess + + dup CreateProcess-args-stdin-pipe pipe-in CloseHandle drop + dup CreateProcess-args-stdout-pipe pipe-out CloseHandle drop + + dup CreateProcess-args-stdout-pipe pipe-in + over CreateProcess-args-stdin-pipe pipe-out + + swap dispose-CreateProcess-args + ] with-destructors + ] with-descriptor ; diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor new file mode 100755 index 0000000000..2d70085165 --- /dev/null +++ b/extra/io/windows/nt/pipes/pipes.factor @@ -0,0 +1,72 @@ +! Copyright (C) 2007 Doug Coleman, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types arrays destructors io io.windows libc +windows.types math windows.kernel32 windows namespaces kernel +sequences windows.errors assocs math.parser system random ; +IN: io.windows.nt.pipes + +: default-security-attributes ( -- obj ) + "SECURITY_ATTRIBUTES" + "SECURITY_ATTRIBUTES" heap-size over set-SECURITY_ATTRIBUTES-nLength ; + +: security-attributes-inherit ( -- obj ) + default-security-attributes + TRUE over set-SECURITY_ATTRIBUTES-bInheritHandle ; foldable + +: create-named-pipe ( name mode -- handle ) + FILE_FLAG_OVERLAPPED bitor + PIPE_TYPE_BYTE + 1 + 4096 + 4096 + 0 + security-attributes-inherit + CreateNamedPipe + dup win32-error=0/f + dup add-completion ; + +: open-other-end ( name mode -- handle ) + FILE_SHARE_READ FILE_SHARE_WRITE bitor + security-attributes-inherit + OPEN_EXISTING + FILE_FLAG_OVERLAPPED + f + CreateFile + dup win32-error=0/f + dup add-completion ; + +TUPLE: pipe in out ; + +: ( name in-mode out-mode -- pipe ) + [ + >r over >r create-named-pipe dup close-later + r> r> open-other-end dup close-later + pipe construct-boa + ] with-destructors ; + +: close-pipe ( pipe -- ) + dup + pipe-in CloseHandle drop + pipe-out CloseHandle drop ; + +: ( name -- pipe ) + PIPE_ACCESS_INBOUND GENERIC_WRITE ; + +: ( name -- pipe ) + PIPE_ACCESS_DUPLEX GENERIC_READ ; + +: unique-pipe-name ( -- string ) + [ + "\\\\.\\pipe\\factor-" % + pipe counter # + "-" % + (random) # + "-" % + millis # + ] "" make ; + +: ( -- pipe ) + unique-pipe-name ; + +: ( -- pipe ) + unique-pipe-name ; diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index d9a9026d43..ac0ede0e06 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -20,6 +20,9 @@ TUPLE: win32-file handle ptr overlapped ; : ( handle ptr -- obj ) f win32-file construct-boa ; +: ( in out -- stream ) + >r f r> f handle>duplex-stream ; + HOOK: CreateFile-flags io-backend ( -- DWORD ) HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) HOOK: add-completion io-backend ( port -- )