1 ! Copyright (C) 2008, 2010 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 )
132 [ self over processes get at push "process" suspend drop ] when
133 dup killed>> [ process-was-killed ] [ status>> ] if ;
135 : wait-for-process ( process -- status )
136 [ (wait-for-process) ] with-timeout ;
138 : run-detached ( desc -- process )
140 dup dup run-process* process-started
141 dup timeout>> [ over set-timeout ] when* ;
143 : run-process ( desc -- process )
145 dup detached>> [ dup wait-for-process drop ] unless ;
147 ERROR: process-failed process code ;
149 M: process-failed error.
150 dup "Process exited with error code " write code>> . nl
151 "Launch descriptor:" print nl
154 : wait-for-success ( process -- )
155 dup wait-for-process dup 0 =
156 [ 2drop ] [ process-failed ] if ;
158 : try-process ( desc -- )
159 run-process wait-for-success ;
161 HOOK: kill-process* io-backend ( handle -- )
163 : kill-process ( process -- )
165 handle>> [ kill-process* ] when* ;
167 M: process timeout timeout>> ;
169 M: process set-timeout swap >>timeout drop ;
171 M: process cancel-operation kill-process ;
173 M: object run-pipeline-element
174 [ >process swap >>stdout swap >>stdin run-detached ]
175 [ drop [ [ dispose ] when* ] bi@ ]
179 : <process-reader*> ( desc encoding -- stream process )
186 [ swap out>> or ] change-stdout
190 [ in>> <input-port> ]
195 : <process-reader> ( desc encoding -- stream )
196 <process-reader*> drop ; inline
198 : with-process-reader ( desc encoding quot -- )
199 [ <process-reader*> ] dip
200 swap [ with-input-stream ] dip
201 wait-for-success ; inline
203 : <process-writer*> ( desc encoding -- stream process )
210 [ swap in>> or ] change-stdin
214 [ out>> <output-port> ]
219 : <process-writer> ( desc encoding -- stream )
220 <process-writer*> drop ; inline
222 : with-process-writer ( desc encoding quot -- )
223 [ <process-writer*> ] dip
224 swap [ with-output-stream ] dip
225 wait-for-success ; inline
227 : <process-stream*> ( desc encoding -- stream process )
231 [ [ |dispose drop ] bi@ ]
234 [ swap in>> or ] change-stdin
235 [ swap out>> or ] change-stdout
238 [ [ out>> dispose ] [ in>> dispose ] bi* ]
239 [ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
241 ] dip <encoder-duplex> swap
244 : <process-stream> ( desc encoding -- stream )
245 <process-stream*> drop ; inline
247 : with-process-stream ( desc encoding quot -- )
248 [ <process-stream*> ] dip
249 swap [ with-stream ] dip
250 wait-for-success ; inline
252 ERROR: output-process-error { output string } { process process } ;
254 M: output-process-error error.
255 [ "Process:" print process>> . nl ]
256 [ "Output:" print output>> print ]
259 : try-output-process ( command -- )
262 [ +closed+ or ] change-stdin
263 utf8 <process-reader*>
264 [ [ stream-contents ] [ dup (wait-for-process) ] bi* ] with-timeout
265 0 = [ 2drop ] [ output-process-error ] if ;
267 : notify-exit ( process status -- )
269 [ processes get delete-at* drop [ resume ] each ] keep
274 { [ os unix? ] [ "io.launcher.unix" require ] }
275 { [ os windows? ] [ "io.launcher.windows" require ] }