Windows IO fixes and <process-stream> work
Slava Pestov
parent
0740e436d6
commit
e7cc5ea6d4
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 <win32-file> <reader>
|
||||
r> f <win32-file> <writer>
|
||||
] with-variable <duplex-stream> stdio set ;
|
||||
] if <win32-duplex-stream>
|
||||
] with-variable stdio set ;
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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" <c-object>
|
||||
! "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> 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" <process-stream> contents
|
||||
! M: windows-nt-io <process-stream> ( 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 <win32-file> dup handle>duplex-stream ] keep
|
||||
! drop ! TODO: close handles instead of drop
|
||||
! ] with-destructors
|
||||
! ] with-descriptor ;
|
||||
!
|
||||
! : create-pipe ( -- pipe )
|
||||
! "HANDLE" <c-object>
|
||||
! "HANDLE" <c-object>
|
||||
! [
|
||||
! security-attributes-inherit
|
||||
! 0
|
||||
! CreatePipe win32-error=0/f
|
||||
! ] 2keep
|
||||
! [ *void* dup close-later ] 2apply <pipe> ;
|
||||
!
|
||||
! 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 <win32-file> <reader> ] keep
|
||||
! [ CreateProcess-args-stdout-pipe pipe-hWrite f <win32-file> <writer> <duplex-stream> ] keep
|
||||
! drop ! TODO: close handles instead of drop
|
||||
! ] with-destructors ;
|
||||
!
|
||||
|
|
|
|||
|
|
@ -78,7 +78,7 @@ M: windows-io <mapped-file> ( 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 -- )
|
||||
|
|
|
|||
|
|
@ -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> 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 <completion-port> drop ;
|
||||
|
||||
TUPLE: GetOverlappedResult-args hFile* lpOverlapped* lpNumberOfBytesTransferred* bWait* port ;
|
||||
: eof? ( error -- ? )
|
||||
dup ERROR_HANDLE_EOF = swap ERROR_BROKEN_PIPE = or ;
|
||||
|
||||
C: <GetOverlappedResult-args> 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 <int> 0
|
||||
] keep <GetOverlappedResult-args> [
|
||||
\ 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 <uint> [
|
||||
0
|
||||
GetOverlappedResult overlapped-error? drop
|
||||
] keep *uint ;
|
||||
|
||||
: save-callback ( port -- )
|
||||
[
|
||||
<io-callback> (save-callback) stop
|
||||
] callcc0 drop ;
|
||||
[ <io-callback> ] keep port-handle win32-file-overlapped
|
||||
io-hash get-global set-at stop
|
||||
] curry callcc0 ;
|
||||
|
||||
TUPLE: GetQueuedCompletionStatusParams hCompletionPort* lpNumberOfBytes* lpCompletionKey* lpOverlapped* dwMilliseconds* ;
|
||||
|
||||
C: <GetQueuedCompletionStatusParams> GetQueuedCompletionStatusParams
|
||||
|
||||
: wait-for-overlapped ( ms -- GetQueuedCompletionStatus-Params ret )
|
||||
>r master-completion-port get-global 0 <int> 0 <int> 0 <int>
|
||||
r> <GetQueuedCompletionStatusParams> [
|
||||
GetQueuedCompletionStatusParams >tuple*<
|
||||
GetQueuedCompletionStatus
|
||||
] keep swap ;
|
||||
: wait-for-overlapped ( ms -- overlapped ? )
|
||||
>r master-completion-port get-global r> ! port ms
|
||||
0 <int> ! bytes
|
||||
f <void*> ! key
|
||||
f <void*> ! 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> master-completion-port set
|
||||
H{ } clone io-hash set
|
||||
windows.winsock:init-winsock
|
||||
] bind ;
|
||||
<master-completion-port> master-completion-port set-global
|
||||
H{ } clone io-hash set-global
|
||||
windows.winsock:init-winsock ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
<unique-incoming-pipe>
|
||||
dup add-pipe-dtors
|
||||
dup pipe-in f set-inherit
|
||||
over set-CreateProcess-args-stdout-pipe ;
|
||||
|
||||
: fill-stdin-pipe
|
||||
<unique-outgoing-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 <win32-duplex-stream>
|
||||
|
||||
swap dispose-CreateProcess-args
|
||||
] with-destructors
|
||||
] with-descriptor ;
|
||||
|
|
@ -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" <c-object>
|
||||
"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 ;
|
||||
|
||||
: <pipe> ( 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 ;
|
||||
|
||||
: <incoming-pipe> ( name -- pipe )
|
||||
PIPE_ACCESS_INBOUND GENERIC_WRITE <pipe> ;
|
||||
|
||||
: <outgoing-pipe> ( name -- pipe )
|
||||
PIPE_ACCESS_DUPLEX GENERIC_READ <pipe> ;
|
||||
|
||||
: unique-pipe-name ( -- string )
|
||||
[
|
||||
"\\\\.\\pipe\\factor-" %
|
||||
pipe counter #
|
||||
"-" %
|
||||
(random) #
|
||||
"-" %
|
||||
millis #
|
||||
] "" make ;
|
||||
|
||||
: <unique-incoming-pipe> ( -- pipe )
|
||||
unique-pipe-name <incoming-pipe> ;
|
||||
|
||||
: <unique-outgoing-pipe> ( -- pipe )
|
||||
unique-pipe-name <outgoing-pipe> ;
|
||||
|
|
@ -20,6 +20,9 @@ TUPLE: win32-file handle ptr overlapped ;
|
|||
: <win32-file> ( handle ptr -- obj )
|
||||
f win32-file construct-boa ;
|
||||
|
||||
: <win32-duplex-stream> ( in out -- stream )
|
||||
>r f <win32-file> r> f <win32-file> handle>duplex-stream ;
|
||||
|
||||
HOOK: CreateFile-flags io-backend ( -- DWORD )
|
||||
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
|
||||
HOOK: add-completion io-backend ( port -- )
|
||||
|
|
|
|||
Loading…
Reference in New Issue