1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: system kernel namespaces strings hashtables sequences assocs
4 combinators vocabs.loader init threads continuations math accessors
5 concurrency.flags destructors environment io io.encodings.ascii
6 io.backend io.timeouts io.pipes io.pipes.private io.encodings
7 io.encodings.utf8 io.streams.duplex io.ports debugger prettyprint
11 TUPLE: process < identity-tuple
33 TUPLE: appender path ;
35 : <appender> ( path -- appender ) appender boa ;
37 SYMBOL: +prepend-environment+
38 SYMBOL: +replace-environment+
39 SYMBOL: +append-environment+
41 SYMBOL: +lowest-priority+
42 SYMBOL: +low-priority+
43 SYMBOL: +normal-priority+
44 SYMBOL: +high-priority+
45 SYMBOL: +highest-priority+
46 SYMBOL: +realtime-priority+
48 : <process> ( -- process )
50 H{ } clone >>environment
51 +append-environment+ >>environment-mode ;
53 : process-started? ( process -- ? )
54 dup handle>> swap status>> or ;
56 : process-running? ( process -- ? )
59 ! Non-blocking process exit notification facility
62 HOOK: wait-for-processes io-backend ( -- ? )
67 processes get assoc-empty?
68 [ wait-flag get-global lower-flag ]
69 [ wait-for-processes [ 100 milliseconds sleep ] when ] if ;
71 : start-wait-thread ( -- )
72 <flag> wait-flag set-global
73 [ wait-loop t ] "Process wait" spawn-server drop ;
76 H{ } clone processes set-global
78 ] "io.launcher" add-startup-hook
80 : process-started ( process handle -- )
82 V{ } clone swap processes get set-at
83 wait-flag get-global raise-flag ;
85 : pass-environment? ( process -- ? )
86 dup environment>> assoc-empty? not
87 swap environment-mode>> +replace-environment+ eq? or ;
89 : get-environment ( process -- env )
91 swap environment-mode>> {
92 { +prepend-environment+ [ os-envs assoc-union ] }
93 { +append-environment+ [ os-envs swap assoc-union ] }
94 { +replace-environment+ [ ] }
97 : string-array? ( obj -- ? )
98 dup sequence? [ [ string? ] all? ] [ drop f ] if ;
100 GENERIC: >process ( obj -- process )
102 ERROR: process-already-started process ;
104 M: process-already-started error.
105 "Process has already been started" print nl
106 "Launch descriptor:" print nl
110 dup process-started? [
111 process-already-started
115 M: object >process <process> swap >>command ;
117 HOOK: current-process-handle io-backend ( -- handle )
119 HOOK: run-process* io-backend ( process -- handle )
121 ERROR: process-was-killed process ;
123 M: process-was-killed error.
124 "Process was killed as a result of a call to" print
125 "kill-process, or a timeout" print
127 "Launch descriptor:" print nl
130 : wait-for-process ( process -- status )
134 dup [ processes get at push ] curry
135 "process" suspend drop
138 [ process-was-killed ] [ status>> ] if
141 : run-detached ( desc -- process )
143 dup dup run-process* process-started
144 dup timeout>> [ over set-timeout ] when* ;
146 : run-process ( desc -- process )
148 dup detached>> [ dup wait-for-process drop ] unless ;
150 ERROR: process-failed process code ;
152 M: process-failed error.
153 dup "Process exited with error code " write code>> . nl
154 "Launch descriptor:" print nl
157 : wait-for-success ( process -- )
158 dup wait-for-process dup 0 =
159 [ 2drop ] [ process-failed ] if ;
161 : try-process ( desc -- )
162 run-process wait-for-success ;
164 HOOK: kill-process* io-backend ( handle -- )
166 : kill-process ( process -- )
168 handle>> [ kill-process* ] when* ;
170 M: process timeout timeout>> ;
172 M: process set-timeout swap >>timeout drop ;
174 M: process cancel-operation kill-process ;
176 M: object run-pipeline-element
177 [ >process swap >>stdout swap >>stdin run-detached ]
178 [ drop [ [ dispose ] when* ] bi@ ]
182 : <process-reader*> ( desc encoding -- stream process )
189 [ swap out>> or ] change-stdout
193 [ in>> <input-port> ]
198 : <process-reader> ( desc encoding -- stream )
199 <process-reader*> drop ; inline
201 : with-process-reader ( desc encoding quot -- )
202 [ <process-reader*> ] dip
203 swap [ with-input-stream ] dip
204 wait-for-success ; inline
206 : <process-writer*> ( desc encoding -- stream process )
213 [ swap in>> or ] change-stdin
217 [ out>> <output-port> ]
222 : <process-writer> ( desc encoding -- stream )
223 <process-writer*> drop ; inline
225 : with-process-writer ( desc encoding quot -- )
226 [ <process-writer*> ] dip
227 swap [ with-output-stream ] dip
228 wait-for-success ; inline
230 : <process-stream*> ( desc encoding -- stream process )
234 [ [ |dispose drop ] bi@ ]
237 [ swap in>> or ] change-stdin
238 [ swap out>> or ] change-stdout
241 [ [ out>> dispose ] [ in>> dispose ] bi* ]
242 [ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
244 ] dip <encoder-duplex> swap
247 : <process-stream> ( desc encoding -- stream )
248 <process-stream*> drop ; inline
250 : with-process-stream ( desc encoding quot -- )
251 [ <process-stream*> ] dip
252 swap [ with-stream ] dip
253 wait-for-success ; inline
255 ERROR: output-process-error { output string } { process process } ;
257 M: output-process-error error.
258 [ "Process:" print process>> . nl ]
259 [ "Output:" print output>> print ]
262 : try-output-process ( command -- )
265 [ +closed+ or ] change-stdin
266 utf8 <process-reader*>
267 [ stream-contents ] [ dup wait-for-process ] bi*
268 0 = [ 2drop ] [ output-process-error ] if ;
270 : notify-exit ( process status -- )
272 [ processes get delete-at* drop [ resume ] each ] keep
277 { [ os unix? ] [ "io.launcher.unix" require ] }
278 { [ os winnt? ] [ "io.launcher.windows.nt" require ] }