1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: system kernel namespaces strings hashtables sequences
4 assocs combinators vocabs.loader init threads continuations
5 math accessors concurrency.flags destructors environment
6 io io.backend io.timeouts io.pipes io.pipes.private io.encodings
7 io.streams.duplex io.ports debugger prettyprint summary
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-init-hook
80 : process-started ( process handle -- )
82 V{ } clone swap processes get set-at
83 wait-flag get-global raise-flag ;
85 M: process hashcode* handle>> hashcode* ;
87 : pass-environment? ( process -- ? )
88 dup environment>> assoc-empty? not
89 swap environment-mode>> +replace-environment+ eq? or ;
91 : get-environment ( process -- env )
93 swap environment-mode>> {
94 { +prepend-environment+ [ os-envs assoc-union ] }
95 { +append-environment+ [ os-envs swap assoc-union ] }
96 { +replace-environment+ [ ] }
99 : string-array? ( obj -- ? )
100 dup sequence? [ [ string? ] all? ] [ drop f ] if ;
102 GENERIC: >process ( obj -- process )
104 ERROR: process-already-started process ;
106 M: process-already-started error.
107 "Process has already been started" print nl
108 "Launch descriptor:" print nl
112 dup process-started? [
113 process-already-started
117 M: object >process <process> swap >>command ;
119 HOOK: current-process-handle io-backend ( -- handle )
121 HOOK: run-process* io-backend ( process -- handle )
123 ERROR: process-was-killed process ;
125 M: process-was-killed error.
126 "Process was killed as a result of a call to" print
127 "kill-process, or a timeout" print
129 "Launch descriptor:" print nl
132 : wait-for-process ( process -- status )
136 dup [ processes get at push ] curry
137 "process" suspend drop
140 [ process-was-killed ] [ status>> ] if
143 : run-detached ( desc -- process )
145 dup dup run-process* process-started
146 dup timeout>> [ over set-timeout ] when* ;
148 : run-process ( desc -- process )
150 dup detached>> [ dup wait-for-process drop ] unless ;
152 ERROR: process-failed process code ;
154 M: process-failed error.
155 dup "Process exited with error code " write code>> . nl
156 "Launch descriptor:" print nl
159 : wait-for-success ( process -- )
160 dup wait-for-process dup 0 =
161 [ 2drop ] [ process-failed ] if ;
163 : try-process ( desc -- )
164 run-process wait-for-success ;
166 HOOK: kill-process* io-backend ( handle -- )
168 : kill-process ( process -- )
170 handle>> [ kill-process* ] when* ;
172 M: process timeout timeout>> ;
174 M: process set-timeout swap >>timeout drop ;
176 M: process cancel-operation kill-process ;
178 M: object run-pipeline-element
179 [ >process swap >>stdout swap >>stdin run-detached ]
180 [ drop [ [ dispose ] when* ] bi@ ]
184 : <process-reader*> ( desc encoding -- stream process )
191 [ swap out>> or ] change-stdout
195 [ in>> <input-port> ]
200 : <process-reader> ( desc encoding -- stream )
201 <process-reader*> drop ; inline
203 : with-process-reader ( desc encoding quot -- )
204 [ <process-reader*> ] dip
205 swap [ with-input-stream ] dip
206 wait-for-success ; inline
208 : <process-writer*> ( desc encoding -- stream process )
215 [ swap in>> or ] change-stdin
219 [ out>> <output-port> ]
224 : <process-writer> ( desc encoding -- stream )
225 <process-writer*> drop ; inline
227 : with-process-writer ( desc encoding quot -- )
228 [ <process-writer*> ] dip
229 swap [ with-output-stream ] dip
230 wait-for-success ; inline
232 : <process-stream*> ( desc encoding -- stream process )
236 [ [ |dispose drop ] bi@ ]
239 [ swap in>> or ] change-stdin
240 [ swap out>> or ] change-stdout
243 [ [ out>> dispose ] [ in>> dispose ] bi* ]
244 [ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
246 ] dip <encoder-duplex> swap
249 : <process-stream> ( desc encoding -- stream )
250 <process-stream*> drop ; inline
252 : with-process-stream ( desc encoding quot -- )
253 [ <process-stream*> ] dip
254 swap [ with-stream ] dip
255 wait-for-success ; inline
257 : notify-exit ( process status -- )
259 [ processes get delete-at* drop [ resume ] each ] keep
264 { [ os unix? ] [ "io.unix.launcher" require ] }
265 { [ os winnt? ] [ "io.windows.nt.launcher" require ] }
266 { [ os wince? ] [ "io.windows.launcher" require ] }