1 ! Copyright (C) 2008, 2011 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors assocs calendar combinators concurrency.flags
5 debugger destructors environment fry init io io.backend
6 io.encodings io.encodings.utf8 io.pipes io.pipes.private
7 io.ports io.streams.duplex io.timeouts kernel math math.order
8 namespaces prettyprint sequences strings system threads vocabs ;
12 TUPLE: process < identity-tuple
38 TUPLE: appender path ;
40 C: <appender> appender
42 SYMBOL: +prepend-environment+
43 SYMBOL: +replace-environment+
44 SYMBOL: +append-environment+
46 SYMBOL: +lowest-priority+
47 SYMBOL: +low-priority+
48 SYMBOL: +normal-priority+
49 SYMBOL: +high-priority+
50 SYMBOL: +highest-priority+
51 SYMBOL: +realtime-priority+
57 : <process> ( -- process )
59 H{ } clone >>environment
60 +append-environment+ >>environment-mode
61 +same-group+ >>group ;
63 : process-started? ( process -- ? )
64 [ handle>> ] [ status>> ] bi or ;
66 : process-running? ( process -- ? )
69 ! Non-blocking process exit notification facility
72 HOOK: (wait-for-processes) io-backend ( -- ? )
80 processes get assoc-empty? [
81 5 wait-delay set-global
82 wait-flag get-global lower-flag
84 (wait-for-processes) [
86 [ milliseconds sleep ] [ 5 + 100 max ] bi
91 : start-wait-thread ( -- )
92 <flag> wait-flag set-global
93 5 wait-delay set-global
94 [ wait-loop t ] "Process wait" spawn-server drop ;
97 H{ } clone processes set-global
101 : process-started ( process handle -- )
103 V{ } clone swap processes get set-at
104 wait-flag get-global raise-flag ;
106 : notify-exit ( process status -- )
108 [ processes get delete-at* drop [ resume ] each ] keep
111 : pass-environment? ( process -- ? )
112 dup environment>> assoc-empty? not
113 swap environment-mode>> +replace-environment+ eq? or ;
115 : get-environment ( process -- env )
116 [ environment>> ] [ environment-mode>> ] bi {
117 { +prepend-environment+ [ os-envs assoc-union ] }
118 { +append-environment+ [ os-envs swap assoc-union ] }
119 { +replace-environment+ [ ] }
124 GENERIC: >process ( obj -- process )
126 ERROR: process-already-started process ;
128 M: process-already-started error.
129 "Process has already been started" print nl
130 "Launch descriptor:" print nl
134 dup process-started? [ process-already-started ] when
137 M: object >process <process> swap >>command ;
139 HOOK: (current-process) io-backend ( -- handle )
141 ERROR: process-was-killed process ;
143 M: process-was-killed error.
144 "Process was killed as a result of a call to" print
145 "kill-process, or a timeout" print
147 "Launch descriptor:" print nl
150 : (wait-for-process) ( process -- status )
152 [ self over processes get at push "process" suspend drop ] when
153 dup killed>> [ process-was-killed ] [ status>> ] if ;
155 : wait-for-process ( process -- status )
156 [ (wait-for-process) ] with-timeout ;
158 HOOK: (run-process) io-backend ( process -- handle )
160 : run-detached ( desc -- process )
161 >process [ dup (run-process) process-started ] keep ;
163 : run-process ( desc -- process )
165 dup detached>> [ dup wait-for-process drop ] unless ;
167 ERROR: process-failed process ;
169 M: process-failed error.
171 "Process exited with error code " write process>> status>> . nl
172 "Launch descriptor:" print nl
173 ] [ process>> . ] bi ;
175 : check-success ( process status -- )
176 0 = [ drop ] [ process-failed ] if ;
178 : wait-for-success ( process -- )
179 dup wait-for-process check-success ;
181 : try-process ( desc -- )
182 run-process wait-for-success ;
184 HOOK: (kill-process) io-backend ( process -- )
186 : kill-process ( process -- )
188 [ pipe>> [ dispose ] when* ]
189 [ dup handle>> [ (kill-process) ] [ drop ] if ] bi ;
191 M: process timeout timeout>> ;
193 M: process set-timeout timeout<< ;
195 M: process cancel-operation kill-process ;
197 M: object run-pipeline-element
205 drop [ [ &dispose drop ] when* ] bi@
207 ] 3bi wait-for-process ;
211 : <process-with-pipe> ( desc -- process pipe )
212 >process (pipe) |dispose [ >>pipe ] keep ;
214 : (process-reader) ( desc encoding -- stream process )
217 <process-with-pipe> {
218 [ '[ _ out>> or ] change-stdout ]
219 [ drop run-detached ]
221 [ in>> <input-port> ]
228 : <process-reader> ( desc encoding -- stream )
229 (process-reader) drop ; inline
231 : with-process-reader* ( desc encoding quot -- process status )
232 [ (process-reader) ] dip '[
233 [ _ with-input-stream ] dip dup (wait-for-process)
234 ] with-timeout ; inline
236 : with-process-reader ( desc encoding quot -- )
237 with-process-reader* check-success ; inline
239 : process-lines ( desc -- lines )
240 utf8 <process-reader> stream-lines ;
244 : (process-writer) ( desc encoding -- stream process )
247 <process-with-pipe> {
248 [ '[ _ in>> or ] change-stdin ]
249 [ drop run-detached ]
251 [ out>> <output-port> ]
258 : <process-writer> ( desc encoding -- stream )
259 (process-writer) drop ; inline
261 : with-process-writer* ( desc encoding quot -- process status )
262 [ (process-writer) ] dip '[
263 [ _ with-output-stream ] dip dup (wait-for-process)
264 ] with-timeout ; inline
266 : with-process-writer ( desc encoding quot -- )
267 with-process-writer* check-success ; inline
271 : (process-stream) ( desc encoding -- stream process )
277 rot >process t >>hidden
278 [ swap in>> or ] change-stdin
279 [ swap out>> or ] change-stdout
282 [ [ out>> &dispose drop ] [ in>> &dispose drop ] bi* ]
283 [ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
285 ] dip <encoder-duplex> swap
290 : <process-stream> ( desc encoding -- stream )
291 (process-stream) drop ; inline
293 : with-process-stream* ( desc encoding quot -- process status )
294 [ (process-stream) ] dip '[
295 [ _ with-stream ] dip dup (wait-for-process)
296 ] with-timeout ; inline
298 : with-process-stream ( desc encoding quot -- )
299 with-process-stream* check-success ; inline
301 ERROR: output-process-error { output string } { process process } ;
303 M: output-process-error error.
304 [ "Process:" print process>> . nl ]
305 [ "Output:" print output>> print ]
308 : try-output-process ( command -- )
311 [ +closed+ or ] change-stdin
312 utf8 (process-reader)
313 [ [ stream-contents ] [ dup (wait-for-process) ] bi* ] with-timeout
314 0 = [ 2drop ] [ output-process-error ] if ;
317 { [ os unix? ] [ "io.launcher.unix" require ] }
318 { [ os windows? ] [ "io.launcher.windows" require ] }