io.launcher updates and destructors cleanup
Slava Pestov
parent
1382d9d045
commit
5262801398
|
|
@ -3,3 +3,4 @@ IN: temporary
|
|||
|
||||
[ t ] [ cell integer? ] unit-test
|
||||
[ t ] [ bootstrap-cell integer? ] unit-test
|
||||
[ ] [ os-env . ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,22 +3,20 @@ IN: temporary
|
|||
|
||||
TUPLE: dummy-obj destroyed? ;
|
||||
|
||||
TUPLE: dummy-destructor ;
|
||||
: <dummy-obj> dummy-obj construct-empty ;
|
||||
|
||||
: <dummy-destructor> ( obj ? -- newobj )
|
||||
<destructor> dummy-destructor construct-delegate ;
|
||||
TUPLE: dummy-destructor obj ;
|
||||
|
||||
M: dummy-destructor (destruct) ( obj -- )
|
||||
destructor-obj t swap set-dummy-obj-destroyed? ;
|
||||
C: <dummy-destructor> dummy-destructor
|
||||
|
||||
: <dummy-obj>
|
||||
\ dummy-obj construct-empty ;
|
||||
M: dummy-destructor destruct ( obj -- )
|
||||
dummy-destructor-obj t swap set-dummy-obj-destroyed? ;
|
||||
|
||||
: destroy-always
|
||||
t <dummy-destructor> push-destructor ;
|
||||
<dummy-destructor> add-always-destructor ;
|
||||
|
||||
: destroy-later
|
||||
f <dummy-destructor> push-destructor ;
|
||||
<dummy-destructor> add-error-destructor ;
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
|
|
|
|||
|
|
@ -4,124 +4,86 @@ USING: continuations io.backend libc kernel namespaces
|
|||
sequences system vectors ;
|
||||
IN: destructors
|
||||
|
||||
SYMBOL: destructors
|
||||
GENERIC: destruct ( obj -- )
|
||||
|
||||
TUPLE: destructor obj always? destroyed? ;
|
||||
SYMBOL: error-destructors
|
||||
SYMBOL: always-destructors
|
||||
|
||||
: <destructor> ( obj always? -- newobj )
|
||||
{
|
||||
set-destructor-obj
|
||||
set-destructor-always?
|
||||
} destructor construct ;
|
||||
TUPLE: destructor object destroyed? ;
|
||||
|
||||
: push-destructor ( obj -- )
|
||||
destructors [ ?push ] change ;
|
||||
|
||||
GENERIC: (destruct) ( obj -- )
|
||||
|
||||
: destruct ( obj -- )
|
||||
M: destructor destruct
|
||||
dup destructor-destroyed? [
|
||||
drop
|
||||
] [
|
||||
[ (destruct) t ] keep set-destructor-destroyed?
|
||||
dup destructor-object destruct
|
||||
t swap set-destructor-destroyed?
|
||||
] if ;
|
||||
|
||||
: destruct-always ( destructor -- )
|
||||
dup destructor-always? [
|
||||
destruct
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
: <destructor> ( obj -- newobj )
|
||||
f destructor construct-boa ;
|
||||
|
||||
: add-error-destructor ( obj -- )
|
||||
<destructor> error-destructors get push ;
|
||||
|
||||
: add-always-destructor ( obj -- )
|
||||
<destructor> always-destructors get push ;
|
||||
|
||||
: do-always-destructors ( -- )
|
||||
always-destructors get [ destruct ] each ;
|
||||
|
||||
: do-error-destructors ( -- )
|
||||
error-destructors get [ destruct ] each ;
|
||||
|
||||
: with-destructors ( quot -- )
|
||||
[
|
||||
[ call ]
|
||||
[ destructors get [ destruct-always ] each ]
|
||||
[ destructors get [ destruct ] each ] cleanup
|
||||
V{ } clone always-destructors set
|
||||
V{ } clone error-destructors set
|
||||
[ do-always-destructors ]
|
||||
[ do-error-destructors ] cleanup
|
||||
] with-scope ; inline
|
||||
|
||||
! Memory allocations
|
||||
TUPLE: memory-destructor alien ;
|
||||
|
||||
C: <memory-destructor> memory-destructor
|
||||
|
||||
TUPLE: memory-destructor ;
|
||||
|
||||
: <memory-destructor> ( obj ? -- newobj )
|
||||
<destructor> memory-destructor construct-delegate ;
|
||||
|
||||
TUPLE: handle-destructor ;
|
||||
|
||||
: <handle-destructor> ( obj ? -- newobj )
|
||||
<destructor> handle-destructor construct-delegate ;
|
||||
|
||||
TUPLE: socket-destructor ;
|
||||
|
||||
: <socket-destructor> ( obj ? -- newobj )
|
||||
<destructor> socket-destructor construct-delegate ;
|
||||
|
||||
M: memory-destructor (destruct) ( obj -- )
|
||||
destructor-obj free ;
|
||||
|
||||
HOOK: (handle-destructor) io-backend ( obj -- )
|
||||
HOOK: (socket-destructor) io-backend ( obj -- )
|
||||
|
||||
M: handle-destructor (destruct) ( obj -- ) (handle-destructor) ;
|
||||
M: socket-destructor (destruct) ( obj -- ) (socket-destructor) ;
|
||||
M: memory-destructor destruct ( obj -- )
|
||||
memory-destructor-alien free ;
|
||||
|
||||
: free-always ( alien -- )
|
||||
t <memory-destructor> push-destructor ;
|
||||
<memory-destructor> add-always-destructor ;
|
||||
|
||||
: free-later ( alien -- )
|
||||
f <memory-destructor> push-destructor ;
|
||||
<memory-destructor> add-error-destructor ;
|
||||
|
||||
! Handles
|
||||
TUPLE: handle-destructor alien ;
|
||||
|
||||
C: <handle-destructor> handle-destructor
|
||||
|
||||
HOOK: destruct-handle io-backend ( obj -- )
|
||||
|
||||
M: handle-destructor destruct ( obj -- )
|
||||
handle-destructor-alien destruct-handle ;
|
||||
|
||||
: close-always ( handle -- )
|
||||
t <handle-destructor> push-destructor ;
|
||||
<handle-destructor> add-always-destructor ;
|
||||
|
||||
: close-later ( handle -- )
|
||||
f <handle-destructor> push-destructor ;
|
||||
<handle-destructor> add-error-destructor ;
|
||||
|
||||
! Sockets
|
||||
TUPLE: socket-destructor alien ;
|
||||
|
||||
C: <socket-destructor> socket-destructor
|
||||
|
||||
HOOK: destruct-socket io-backend ( obj -- )
|
||||
|
||||
M: socket-destructor destruct ( obj -- )
|
||||
socket-destructor-alien destruct-socket ;
|
||||
|
||||
: close-socket-always ( handle -- )
|
||||
t <socket-destructor> push-destructor ;
|
||||
<socket-destructor> add-always-destructor ;
|
||||
|
||||
: close-socket-later ( handle -- )
|
||||
f <socket-destructor> push-destructor ;
|
||||
|
||||
|
||||
! : add-destructor ( word quot -- )
|
||||
! >quotation
|
||||
! "slot-destructor" set-word-prop ;
|
||||
|
||||
! MACRO: destruct ( class -- )
|
||||
! "slots" word-prop
|
||||
! [ slot-spec-reader "slot-destructor" word-prop ] subset
|
||||
! [
|
||||
! [
|
||||
! slot-spec-reader [ 1quotation ] keep
|
||||
! "slot-destructor" word-prop [ when* ] curry compose
|
||||
! [ keep f swap ] curry
|
||||
! ] keep slot-spec-writer 1quotation compose
|
||||
! dupd curry
|
||||
! ] map concat nip ;
|
||||
|
||||
! : DTOR: scan-word parse-definition add-destructor ; parsing
|
||||
|
||||
! : free-destructor ( word -- )
|
||||
! [ free ] add-destructor ;
|
||||
|
||||
! : stream-destructor ( word -- )
|
||||
! [ stream-close ] add-destructor ;
|
||||
|
||||
|
||||
! TUPLE: foo a b c ;
|
||||
! C: <foo> foo
|
||||
|
||||
! DTOR: foo-a "lol, a destructor" print drop ;
|
||||
! DTOR: foo-b "lol, b destructor" print drop ;
|
||||
|
||||
! TUPLE: stuff mem stream ;
|
||||
! : <stuff>
|
||||
! 100 malloc
|
||||
! "license.txt" resource-path <file-reader>
|
||||
! \ stuff construct-boa ;
|
||||
|
||||
! DTOR: stuff-mem free-destructor ;
|
||||
! DTOR: stuff-stream stream-destructor ;
|
||||
|
||||
<socket-destructor> add-error-destructor ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.backend system kernel namespaces strings hashtables
|
||||
sequences assocs ;
|
||||
sequences assocs combinators ;
|
||||
IN: io.launcher
|
||||
|
||||
SYMBOL: +command+
|
||||
|
|
@ -26,6 +26,18 @@ SYMBOL: append-environment
|
|||
: with-descriptor ( desc quot -- )
|
||||
default-descriptor [ >r clone r> bind ] bind ; inline
|
||||
|
||||
: pass-environment? ( -- ? )
|
||||
+environment+ get assoc-empty? not
|
||||
+environment-mode+ get replace-environment eq? or ;
|
||||
|
||||
: get-environment ( -- env )
|
||||
+environment+ get
|
||||
+environment-mode+ get {
|
||||
{ prepend-environment [ os-envs union ] }
|
||||
{ append-environment [ os-envs swap union ] }
|
||||
{ replace-environment [ ] }
|
||||
} case ;
|
||||
|
||||
GENERIC: >descriptor ( obj -- desc )
|
||||
|
||||
M: string >descriptor +command+ associate ;
|
||||
|
|
|
|||
|
|
@ -15,19 +15,6 @@ USE: unix
|
|||
+command+ get
|
||||
[ "/bin/sh" "-c" rot 3array ] [ +arguments+ get ] if* ;
|
||||
|
||||
: execve? ( -- ? )
|
||||
+environment+ get assoc-empty?
|
||||
[ +environment-mode+ get replace-environment eq? ]
|
||||
[ t ] if ;
|
||||
|
||||
: get-environment ( -- env )
|
||||
+environment+ get
|
||||
+environment-mode+ get {
|
||||
{ prepend-environment [ os-envs union ] }
|
||||
{ append-environment [ os-envs swap union ] }
|
||||
{ replace-environment [ ] }
|
||||
} case ;
|
||||
|
||||
: >null-term-array f add >c-void*-array ;
|
||||
|
||||
: prepare-execvp ( -- cmd args )
|
||||
|
|
@ -47,7 +34,7 @@ USE: unix
|
|||
|
||||
: (spawn-process) ( -- )
|
||||
[
|
||||
execve? [
|
||||
pass-environment? [
|
||||
prepare-execve execve
|
||||
] [
|
||||
prepare-execvp execvp
|
||||
|
|
|
|||
|
|
@ -1,35 +1,37 @@
|
|||
USING: alien alien.c-types arrays continuations
|
||||
destructors io.windows libc
|
||||
destructors io io.windows libc
|
||||
io.nonblocking io.streams.duplex windows.types math
|
||||
windows.kernel32 windows namespaces io.launcher kernel
|
||||
sequences io.windows.nt.backend windows.errors ;
|
||||
USE: io
|
||||
USE: prettyprint
|
||||
sequences io.windows.nt.backend windows.errors assocs ;
|
||||
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
|
||||
lpProcessAttributes
|
||||
lpThreadAttributes
|
||||
bInheritHandles
|
||||
dwCreateFlags
|
||||
lpEnvironment
|
||||
lpCurrentDirectory
|
||||
lpStartupInfo
|
||||
lpProcessInformation
|
||||
stdout-pipe stdin-pipe ;
|
||||
lpApplicationName
|
||||
lpCommandLine
|
||||
lpProcessAttributes
|
||||
lpThreadAttributes
|
||||
bInheritHandles
|
||||
dwCreateFlags
|
||||
lpEnvironment
|
||||
lpCurrentDirectory
|
||||
lpStartupInfo
|
||||
lpProcessInformation
|
||||
stdout-pipe stdin-pipe ;
|
||||
|
||||
: default-CreateProcess-args ( lpCommandLine -- obj )
|
||||
: dispose-CreateProcess-args ( args -- )
|
||||
CreateProcess-args-lpProcessInformation dup
|
||||
PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when*
|
||||
PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ;
|
||||
|
||||
: default-CreateProcess-args ( -- obj )
|
||||
0
|
||||
0
|
||||
"STARTUPINFO" <c-object>
|
||||
"STARTUPINFO" heap-size over set-STARTUPINFO-cb
|
||||
"PROCESS_INFORMATION" <c-object>
|
||||
{
|
||||
set-CreateProcess-args-lpCommandLine
|
||||
set-CreateProcess-args-bInheritHandles
|
||||
set-CreateProcess-args-dwCreateFlags
|
||||
set-CreateProcess-args-lpStartupInfo
|
||||
|
|
@ -50,130 +52,164 @@ TUPLE: CreateProcess-args
|
|||
CreateProcess-args-lpProcessInformation
|
||||
} get-slots CreateProcess win32-error=0/f ;
|
||||
|
||||
M: windows-io run-process ( string -- )
|
||||
default-CreateProcess-args
|
||||
call-CreateProcess ;
|
||||
: fill-lpCommandLine
|
||||
+command+ get [
|
||||
[
|
||||
+arguments+ get [ CHAR: \s , ] [
|
||||
CHAR: " ,
|
||||
[ dup CHAR: " = [ CHAR: \\ , ] when , ] each
|
||||
CHAR: " ,
|
||||
] interleave
|
||||
] "" make
|
||||
] unless* over set-CreateProcess-args-lpCommandLine ;
|
||||
|
||||
M: windows-io run-detached ( string -- )
|
||||
default-CreateProcess-args
|
||||
DETACHED_PROCESS over set-CreateProcess-args-dwCreateFlags
|
||||
call-CreateProcess ;
|
||||
: fill-dwCreateFlags
|
||||
CREATE_UNICODE_ENVIRONMENT
|
||||
+detached+ get [ DETACHED_PROCESS bitor ] when
|
||||
over set-CreateProcess-args-dwCreateFlags ;
|
||||
|
||||
: default-security-attributes ( -- obj )
|
||||
"SECURITY_ATTRIBUTES" <c-object>
|
||||
"SECURITY_ATTRIBUTES" heap-size over set-SECURITY_ATTRIBUTES-nLength ;
|
||||
: fill-lpEnvironment
|
||||
pass-environment? [
|
||||
[
|
||||
get-environment
|
||||
[ swap % "=" % % "\0" % ] assoc-each
|
||||
"\0" %
|
||||
] "" make >c-ushort-array
|
||||
over set-CreateProcess-args-lpEnvironment
|
||||
] when ;
|
||||
|
||||
: security-attributes-inherit ( -- obj )
|
||||
default-security-attributes
|
||||
TRUE over set-SECURITY_ATTRIBUTES-bInheritHandle ;
|
||||
: wait-for-process ( args -- )
|
||||
CreateProcess-args-lpProcessInformation
|
||||
PROCESS_INFORMATION-hProcess INFINITE
|
||||
WaitForSingleObject drop ;
|
||||
|
||||
: 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 )
|
||||
M: windows-io run-process* ( desc -- )
|
||||
[
|
||||
|
||||
break
|
||||
default-CreateProcess-args
|
||||
TRUE over set-CreateProcess-args-bInheritHandles
|
||||
fill-lpCommandLine
|
||||
fill-dwCreateFlags
|
||||
fill-lpEnvironment
|
||||
dup call-CreateProcess
|
||||
+detached+ get [ dup wait-for-process ] unless
|
||||
dispose-CreateProcess-args
|
||||
] with-descriptor ;
|
||||
|
||||
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
|
||||
! : 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 ;
|
||||
!
|
||||
[ call-CreateProcess ] keep
|
||||
[ CreateProcess-args-stdin-pipe f <win32-file> dup handle>duplex-stream ] keep
|
||||
drop ! TODO: close handles instead of drop
|
||||
] with-destructors ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,32 +1,31 @@
|
|||
! Copyright (C) 2004, 2007 Mackenzie Straight, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types arrays destructors io io.backend
|
||||
io.buffers io.files io.nonblocking io.sockets io.binary
|
||||
io.sockets.impl windows.errors strings io.streams.duplex kernel
|
||||
math namespaces sequences windows windows.kernel32
|
||||
windows.winsock windows.winsock.private ;
|
||||
windows.winsock splitting ;
|
||||
IN: io.windows
|
||||
|
||||
TUPLE: windows-nt-io ;
|
||||
TUPLE: windows-ce-io ;
|
||||
UNION: windows-io windows-nt-io windows-ce-io ;
|
||||
|
||||
M: windows-io (handle-destructor) ( obj -- )
|
||||
destructor-obj CloseHandle drop ;
|
||||
M: windows-io destruct-handle CloseHandle drop ;
|
||||
|
||||
M: windows-io (socket-destructor) ( obj -- )
|
||||
destructor-obj closesocket drop ;
|
||||
M: windows-io destruct-socket closesocket drop ;
|
||||
|
||||
TUPLE: win32-file handle ptr overlapped ;
|
||||
|
||||
: <win32-file> ( handle ptr -- obj )
|
||||
{ set-win32-file-handle set-win32-file-ptr }
|
||||
\ win32-file construct ;
|
||||
: <win32-file> ( handle ptr -- obj )
|
||||
f win32-file construct-boa ;
|
||||
|
||||
HOOK: CreateFile-flags io-backend ( -- DWORD )
|
||||
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
|
||||
HOOK: add-completion io-backend ( port -- )
|
||||
|
||||
M: windows-io normalize-directory ( string -- string )
|
||||
dup peek CHAR: \\ = "*" "\\*" ? append ;
|
||||
"\\" ?tail drop "\\*" append ;
|
||||
|
||||
: share-mode ( -- fixnum )
|
||||
FILE_SHARE_READ FILE_SHARE_WRITE bitor ; inline
|
||||
|
|
|
|||
|
|
@ -135,8 +135,6 @@ TYPEDEF: FILE_NOTIFY_INFORMATION* PFILE_NOTIFY_INFORMATION
|
|||
: TIME_ZONE_ID_INVALID HEX: FFFFFFFF ; inline
|
||||
|
||||
|
||||
: CREATE_DEFAULT_ERROR_MODE HEX: 4000000 ; inline
|
||||
: DETACHED_PROCESS 8 ; inline
|
||||
: PF_XMMI64_INSTRUCTIONS_AVAILABLE 10 ; inline
|
||||
: PF_SSE3_INSTRUCTIONS_AVAILABLE 13 ; inline
|
||||
|
||||
|
|
@ -614,6 +612,31 @@ FUNCTION: HANDLE CreateNamedPipeW ( LPCTSTR lpName, DWORD dwOpenMode, DWORD dwPi
|
|||
|
||||
! FUNCTION: CreateNlsSecurityDescriptor
|
||||
FUNCTION: BOOL CreatePipe ( PHANDLE hReadPipe, PHANDLE hWritePipe, LPSECURITY_ATTRIBUTES lpPipeAttributes, DWORD nSize ) ;
|
||||
|
||||
: DEBUG_PROCESS HEX: 00000001 ;
|
||||
: DEBUG_ONLY_THIS_PROCESS HEX: 00000002 ;
|
||||
: CREATE_SUSPENDED HEX: 00000004 ;
|
||||
: DETACHED_PROCESS HEX: 00000008 ;
|
||||
: CREATE_NEW_CONSOLE HEX: 00000010 ;
|
||||
: NORMAL_PRIORITY_CLASS HEX: 00000020 ;
|
||||
: IDLE_PRIORITY_CLASS HEX: 00000040 ;
|
||||
: HIGH_PRIORITY_CLASS HEX: 00000080 ;
|
||||
: REALTIME_PRIORITY_CLASS HEX: 00000100 ;
|
||||
: CREATE_NEW_PROCESS_GROUP HEX: 00000200 ;
|
||||
: CREATE_UNICODE_ENVIRONMENT HEX: 00000400 ;
|
||||
: CREATE_SEPARATE_WOW_VDM HEX: 00000800 ;
|
||||
: CREATE_SHARED_WOW_VDM HEX: 00001000 ;
|
||||
: CREATE_FORCEDOS HEX: 00002000 ;
|
||||
: BELOW_NORMAL_PRIORITY_CLASS HEX: 00004000 ;
|
||||
: ABOVE_NORMAL_PRIORITY_CLASS HEX: 00008000 ;
|
||||
: CREATE_BREAKAWAY_FROM_JOB HEX: 01000000 ;
|
||||
: CREATE_WITH_USERPROFILE HEX: 02000000 ;
|
||||
: CREATE_DEFAULT_ERROR_MODE HEX: 04000000 ;
|
||||
: CREATE_NO_WINDOW HEX: 08000000 ;
|
||||
: PROFILE_USER HEX: 10000000 ;
|
||||
: PROFILE_KERNEL HEX: 20000000 ;
|
||||
: PROFILE_SERVER HEX: 40000000 ;
|
||||
|
||||
FUNCTION: BOOL CreateProcessW ( LPCTSTR lpApplicationname,
|
||||
LPTSTR lpCommandLine,
|
||||
LPSECURITY_ATTRIBUTES lpProcessAttributes,
|
||||
|
|
@ -1471,7 +1494,7 @@ FUNCTION: BOOL VirtualQueryEx ( HANDLE hProcess, void* lpAddress, MEMORY_BASIC_I
|
|||
! FUNCTION: WaitForDebugEvent
|
||||
! FUNCTION: WaitForMultipleObjects
|
||||
! FUNCTION: WaitForMultipleObjectsEx
|
||||
! FUNCTION: WaitForSingleObject
|
||||
FUNCTION: BOOL WaitForSingleObject ( HANDLE hHandle, DWORD dwMilliseconds ) ;
|
||||
! FUNCTION: WaitForSingleObjectEx
|
||||
! FUNCTION: WaitNamedPipeA
|
||||
! FUNCTION: WaitNamedPipeW
|
||||
|
|
|
|||
|
|
@ -147,11 +147,9 @@ FUNCTION: int setsockopt ( SOCKET s, int level, int optname, char* optval, int o
|
|||
|
||||
FUNCTION: ushort htons ( ushort n ) ;
|
||||
FUNCTION: ushort ntohs ( ushort n ) ;
|
||||
<PRIVATE
|
||||
FUNCTION: int bind ( void* socket, sockaddr_in* sockaddr, int len ) ;
|
||||
FUNCTION: int listen ( void* socket, int backlog ) ;
|
||||
FUNCTION: char* inet_ntoa ( int in-addr ) ;
|
||||
PRIVATE>
|
||||
FUNCTION: int getaddrinfo ( char* nodename,
|
||||
char* servername,
|
||||
addrinfo* hints,
|
||||
|
|
|
|||
Loading…
Reference in New Issue