1 ! Copyright (C) 2007, 2010 Doug Coleman, Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien alien.c-types alien.data arrays assocs
4 classes classes.struct combinators combinators.short-circuit
5 concurrency.flags continuations debugger destructors init io
6 io.backend io.backend.windows io.files io.files.private
7 io.files.windows io.launcher io.launcher.private io.pathnames
8 io.pipes io.pipes.windows io.ports kernel libc literals locals
9 make math namespaces prettyprint sequences specialized-arrays
10 splitting splitting.monotonic strings system threads windows
11 windows.errors windows.handles windows.kernel32 windows.types
13 SPECIALIZED-ARRAY: ushort
14 SPECIALIZED-ARRAY: void*
15 IN: io.launcher.windows
17 TUPLE: CreateProcess-args
27 lpProcessInformation ;
29 : default-CreateProcess-args ( -- obj )
30 CreateProcess-args new
32 dup class-of heap-size >>cb
34 PROCESS_INFORMATION <struct> >>lpProcessInformation
35 TRUE >>bInheritHandles
38 : call-CreateProcess ( CreateProcess-args -- )
40 [ lpApplicationName>> ]
42 [ lpProcessAttributes>> ]
43 [ lpThreadAttributes>> ]
47 [ lpCurrentDirectory>> ]
49 [ lpProcessInformation>> ]
51 CreateProcess win32-error=0/f ;
53 : count-trailing-backslashes ( str n -- str n )
54 [ "\\" ?tail ] dip swap [
55 1 + count-trailing-backslashes
58 : fix-trailing-backslashes ( str -- str' )
59 0 count-trailing-backslashes
60 2 * CHAR: \\ <repetition> append ;
62 ! Find groups of \, groups of \ followed by ", or naked "
63 : escape-double-quote ( str -- newstr )
65 { [ drop CHAR: \ = ] [ nip "\\\"" member? ] } 2&&
69 ! String of backslashes + double-quote
70 length 1 - 2 * CHAR: \\ <repetition> "\\\"" append
78 ! Naked double-quotes get a backslash before them
79 ! Backslashes before a double-quote get doubled in the output
80 ! If there's a space, double trailing backslashes and surround by quotes
81 ! See http://msdn.microsoft.com/en-us/library/ms647232.aspx
82 : escape-argument ( str -- newstr )
84 CHAR: \s over member? [
85 fix-trailing-backslashes "\"" dup surround
88 : join-arguments ( args -- cmd-line )
89 [ escape-argument ] map join-words ;
91 : lookup-priority ( process -- n )
93 { +lowest-priority+ [ IDLE_PRIORITY_CLASS ] }
94 { +low-priority+ [ BELOW_NORMAL_PRIORITY_CLASS ] }
95 { +normal-priority+ [ NORMAL_PRIORITY_CLASS ] }
96 { +high-priority+ [ ABOVE_NORMAL_PRIORITY_CLASS ] }
97 { +highest-priority+ [ HIGH_PRIORITY_CLASS ] }
98 { +realtime-priority+ [ REALTIME_PRIORITY_CLASS ] }
102 : cmd-line ( process -- cmd-line )
103 command>> dup string? [ join-arguments ] unless ;
105 : fill-lpCommandLine ( process args -- process args )
106 over cmd-line >>lpCommandLine ;
108 : fill-dwCreateFlags ( process args -- process args )
110 pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
114 { +new-session+ [ DETACHED_PROCESS bitor CREATE_NEW_PROCESS_GROUP bitor ] }
115 { +new-group+ [ DETACHED_PROCESS bitor CREATE_NEW_PROCESS_GROUP bitor ] }
119 pick lookup-priority [ bitor ] when*
122 : fill-lpEnvironment ( process args -- process args )
123 over pass-environment? [
126 [ swap % "=" % % "\0" % ] assoc-each
128 ] ushort-array{ } make
132 : fill-startup-info ( process args -- process args )
133 over hidden>> [ dup lpStartupInfo>> ] dip
135 flags{ STARTF_USESTDHANDLES STARTF_USESHOWWINDOW } >>dwFlags
136 SW_HIDE >>wShowWindow
138 STARTF_USESTDHANDLES >>dwFlags
141 : make-CreateProcess-args ( process -- args )
142 default-CreateProcess-args
149 M: windows (current-process)
150 GetCurrentProcessId ;
152 ERROR: launch-error process error ;
154 M: launch-error error.
155 "Launching failed with error:" print
156 dup error>> error. nl
157 "Launch descriptor:" print nl
160 M: windows (kill-process)
161 handle>> hProcess>> 255 TerminateProcess win32-error=0/f ;
163 : dispose-process ( process-information -- )
164 ! From MSDN: "Handles in PROCESS_INFORMATION must be closed
165 ! with CloseHandle when they are no longer needed."
166 [ hProcess>> [ CloseHandle drop ] when* ]
167 [ hThread>> [ CloseHandle drop ] when* ] bi ;
169 : exit-code ( process -- n )
171 { DWORD } [ GetExitCodeProcess ] with-out-parameters
172 swap win32-error=0/f ;
174 : process-exited ( process -- )
175 dup handle>> exit-code
176 over handle>> dispose-process
179 M: windows (wait-for-processes)
180 processes get keys dup
181 [ handle>> hProcess>> ] void*-array{ } map-as
183 WaitForMultipleObjects
184 dup 0xffffffff = [ win32-error ] when
185 dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
187 : duplicate-handle ( handle -- handle' )
188 GetCurrentProcess ! source process
189 swap handle>> ! handle
190 GetCurrentProcess ! target process
191 f void* <ref> [ ! target handle
192 DUPLICATE_SAME_ACCESS ! desired access
193 TRUE ! inherit handle
195 DuplicateHandle win32-error=0/f
196 ] keep void* deref <win32-handle> &dispose ;
198 ! /dev/null simulation
199 : null-input ( -- pipe )
200 (pipe) [ in>> &dispose ] [ out>> dispose ] bi ;
202 : null-output ( -- pipe )
203 (pipe) [ out>> &dispose ] [ in>> dispose ] bi ;
205 : null-pipe ( mode -- pipe )
207 { GENERIC_READ [ null-input ] }
208 { GENERIC_WRITE [ null-output ] }
211 ! The below code is based on the example given in
212 ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
214 : redirect-default ( obj access-mode create-mode -- handle )
217 : redirect-closed ( obj access-mode create-mode -- handle )
220 :: redirect-file ( path access-mode create-mode -- handle )
224 default-security-attributes
226 FILE_ATTRIBUTE_NORMAL ! flags and attributes
228 CreateFile check-invalid-handle <win32-file> &dispose ;
230 : redirect-append ( path access-mode create-mode -- handle )
234 dup 0 FILE_END set-file-pointer ;
236 : redirect-handle ( handle access-mode create-mode -- handle )
239 : redirect-stream ( stream access-mode create-mode -- handle )
240 [ underlying-handle ] 2dip redirect-handle ;
242 : redirect ( obj access-mode create-mode -- handle )
244 { [ pick not ] [ redirect-default ] }
245 { [ pick +closed+ eq? ] [ redirect-closed ] }
246 { [ pick string? ] [ redirect-file ] }
247 { [ pick appender? ] [ redirect-append ] }
248 { [ pick win32-file? ] [ redirect-handle ] }
251 dup [ dup t set-inherit handle>> ] when ;
253 : redirect-stdout ( process args -- handle )
259 STD_OUTPUT_HANDLE GetStdHandle or ;
261 : redirect-stderr ( process args -- handle )
262 over stderr>> +stdout+ eq? [
264 lpStartupInfo>> hStdOutput>>
271 STD_ERROR_HANDLE GetStdHandle or
274 : redirect-stdin ( process args -- handle )
280 STD_INPUT_HANDLE GetStdHandle or ;
282 : fill-redirection ( process args -- )
284 [ [ redirect-stdout ] dip hStdOutput<< ]
285 [ [ redirect-stderr ] dip hStdError<< ]
286 [ [ redirect-stdin ] dip hStdInput<< ] 3tri ;
288 M: windows (run-process)
291 dup make-CreateProcess-args
292 current-directory get absolute-path >>lpCurrentDirectory
293 [ fill-redirection ] keep
294 dup call-CreateProcess
295 lpProcessInformation>>
297 ] [ launch-error ] recover ;