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 namespaces
8 prettyprint sequences strings system threads vocabs ;
12 TUPLE: process < identity-tuple
37 TUPLE: appender path ;
39 C: <appender> appender
41 SYMBOL: +prepend-environment+
42 SYMBOL: +replace-environment+
43 SYMBOL: +append-environment+
45 SYMBOL: +lowest-priority+
46 SYMBOL: +low-priority+
47 SYMBOL: +normal-priority+
48 SYMBOL: +high-priority+
49 SYMBOL: +highest-priority+
50 SYMBOL: +realtime-priority+
56 : <process> ( -- process )
58 H{ } clone >>environment
59 +append-environment+ >>environment-mode
60 +same-group+ >>group ;
62 : process-started? ( process -- ? )
63 [ handle>> ] [ status>> ] bi or ;
65 : process-running? ( process -- ? )
68 ! Non-blocking process exit notification facility
71 HOOK: (wait-for-processes) io-backend ( -- ? )
78 processes get assoc-empty?
79 [ wait-flag get-global lower-flag ]
80 [ (wait-for-processes) [ 100 milliseconds sleep ] when ] if ;
82 : start-wait-thread ( -- )
83 <flag> wait-flag set-global
84 [ wait-loop t ] "Process wait" spawn-server drop ;
87 H{ } clone processes set-global
89 ] "io.launcher" add-startup-hook
91 : process-started ( process handle -- )
93 V{ } clone swap processes get set-at
94 wait-flag get-global raise-flag ;
96 : pass-environment? ( process -- ? )
97 dup environment>> assoc-empty? not
98 swap environment-mode>> +replace-environment+ eq? or ;
100 : get-environment ( process -- env )
101 [ environment>> ] [ environment-mode>> ] bi {
102 { +prepend-environment+ [ os-envs assoc-union ] }
103 { +append-environment+ [ os-envs swap assoc-union ] }
104 { +replace-environment+ [ ] }
109 GENERIC: >process ( obj -- process )
111 ERROR: process-already-started process ;
113 M: process-already-started error.
114 "Process has already been started" print nl
115 "Launch descriptor:" print nl
119 dup process-started? [ throw-process-already-started ] when
122 M: object >process <process> swap >>command ;
124 HOOK: (current-process) io-backend ( -- handle )
126 ERROR: process-was-killed process ;
128 M: process-was-killed error.
129 "Process was killed as a result of a call to" print
130 "kill-process, or a timeout" print
132 "Launch descriptor:" print nl
135 : (wait-for-process) ( process -- status )
137 [ self over processes get at push "process" suspend drop ] when
138 dup killed>> [ throw process-was-killed ] [ status>> ] if ;
140 : wait-for-process ( process -- status )
141 [ (wait-for-process) ] with-timeout ;
143 HOOK: (run-process) io-backend ( process -- handle )
145 : run-detached ( desc -- process )
146 >process [ dup (run-process) process-started ] keep ;
148 : run-process ( desc -- process )
150 dup detached>> [ dup wait-for-process drop ] unless ;
152 ERROR: process-failed process ;
154 M: process-failed error.
156 "Process exited with error code " write process>> status>> . nl
157 "Launch descriptor:" print nl
158 ] [ process>> . ] bi ;
160 : check-success ( process status -- )
161 0 = [ drop ] [ throw-process-failed ] if ;
163 : wait-for-success ( process -- )
164 dup wait-for-process check-success ;
166 : try-process ( desc -- )
167 run-process wait-for-success ;
169 HOOK: (kill-process) io-backend ( process -- )
171 : kill-process ( process -- )
173 [ pipe>> [ dispose ] when* ]
174 [ dup handle>> [ (kill-process) ] [ drop ] if ] bi ;
176 M: process timeout timeout>> ;
178 M: process set-timeout timeout<< ;
180 M: process cancel-operation kill-process ;
182 M: object run-pipeline-element
190 drop [ [ &dispose drop ] when* ] bi@
192 ] 3bi wait-for-process ;
196 : <process-with-pipe> ( desc -- process pipe )
197 >process (pipe) |dispose [ >>pipe ] keep ;
199 : (process-reader) ( desc encoding -- stream process )
202 <process-with-pipe> {
203 [ '[ _ out>> or ] change-stdout ]
204 [ drop run-detached ]
206 [ in>> <input-port> ]
213 : <process-reader> ( desc encoding -- stream )
214 (process-reader) drop ; inline
216 : with-process-reader* ( desc encoding quot -- process status )
217 [ (process-reader) ] dip '[ _ with-input-stream ] dip
218 dup wait-for-process ; inline
220 : with-process-reader ( desc encoding quot -- )
221 with-process-reader* check-success ; inline
225 : (process-writer) ( desc encoding -- stream process )
228 <process-with-pipe> {
229 [ '[ _ in>> or ] change-stdin ]
230 [ drop run-detached ]
232 [ out>> <output-port> ]
239 : <process-writer> ( desc encoding -- stream )
240 (process-writer) drop ; inline
242 : with-process-writer* ( desc encoding quot -- process status )
243 [ (process-writer) ] dip '[ _ with-output-stream ] dip
244 dup wait-for-process ; inline
246 : with-process-writer ( desc encoding quot -- )
247 with-process-writer* check-success ; inline
251 : (process-stream) ( desc encoding -- stream process )
258 [ swap in>> or ] change-stdin
259 [ swap out>> or ] change-stdout
262 [ [ out>> &dispose drop ] [ in>> &dispose drop ] bi* ]
263 [ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
265 ] dip <encoder-duplex> swap
270 : <process-stream> ( desc encoding -- stream )
271 (process-stream) drop ; inline
273 : with-process-stream* ( desc encoding quot -- process status )
274 [ (process-stream) ] dip '[ _ with-stream ] dip
275 dup wait-for-process ; inline
277 : with-process-stream ( desc encoding quot -- )
278 with-process-stream* check-success ; inline
280 ERROR: output-process-error { output string } { process process } ;
282 M: output-process-error error.
283 [ "Process:" print process>> . nl ]
284 [ "Output:" print output>> print ]
287 : try-output-process ( command -- )
290 [ +closed+ or ] change-stdin
291 utf8 (process-reader)
292 [ [ stream-contents ] [ dup (wait-for-process) ] bi* ] with-timeout
293 0 = [ 2drop ] [ throw-output-process-error ] if ;
297 : notify-exit ( process status -- )
299 [ processes get delete-at* drop [ resume ] each ] keep
306 { [ os unix? ] [ "io.launcher.unix" require ] }
307 { [ os windows? ] [ "io.launcher.windows" require ] }