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
6 io io.backend io.timeouts io.pipes io.pipes.private io.encodings
7 io.streams.duplex io.ports debugger prettyprint inspector ;
10 TUPLE: process < identity-tuple
32 TUPLE: appender path ;
34 : <appender> ( path -- appender ) appender boa ;
36 SYMBOL: +prepend-environment+
37 SYMBOL: +replace-environment+
38 SYMBOL: +append-environment+
40 SYMBOL: +lowest-priority+
41 SYMBOL: +low-priority+
42 SYMBOL: +normal-priority+
43 SYMBOL: +high-priority+
44 SYMBOL: +highest-priority+
45 SYMBOL: +realtime-priority+
47 : <process> ( -- process )
49 H{ } clone >>environment
50 +append-environment+ >>environment-mode ;
52 : process-started? ( process -- ? )
53 dup handle>> swap status>> or ;
55 : process-running? ( process -- ? )
56 process-handle >boolean ;
58 ! Non-blocking process exit notification facility
61 [ H{ } clone processes set-global ] "io.launcher" add-init-hook
63 HOOK: wait-for-processes io-backend ( -- ? )
68 processes get assoc-empty?
69 [ wait-flag get-global lower-flag ]
70 [ wait-for-processes [ 100 sleep ] when ] if ;
72 : start-wait-thread ( -- )
73 <flag> wait-flag set-global
74 [ wait-loop t ] "Process wait" spawn-server drop ;
76 [ start-wait-thread ] "io.launcher" add-init-hook
78 : process-started ( process handle -- )
80 V{ } clone swap processes get set-at
81 wait-flag get-global raise-flag ;
83 M: process hashcode* process-handle hashcode* ;
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 )
103 dup process-started? [
104 "Process has already been started once" throw
108 M: object >process <process> swap >>command ;
110 HOOK: current-process-handle io-backend ( -- handle )
112 HOOK: run-process* io-backend ( process -- handle )
114 : wait-for-process ( process -- status )
118 dup [ processes get at push ] curry
119 "process" suspend drop
122 [ "Process was killed" throw ] [ status>> ] if
125 : run-detached ( desc -- process )
127 dup dup run-process* process-started
128 dup timeout>> [ over set-timeout ] when* ;
130 : run-process ( desc -- process )
132 dup detached>> [ dup wait-for-process drop ] unless ;
134 ERROR: process-failed process code ;
136 M: process-failed error.
137 dup "Process exited with error code " write code>> . nl
138 "Launch descriptor:" print nl
141 : try-process ( desc -- )
142 run-process dup wait-for-process dup zero?
143 [ 2drop ] [ process-failed ] if ;
145 HOOK: kill-process* io-backend ( handle -- )
147 : kill-process ( process -- )
149 handle>> [ kill-process* ] when* ;
151 M: process timeout timeout>> ;
153 M: process set-timeout set-process-timeout ;
155 M: process cancel-operation kill-process ;
157 M: object run-pipeline-element
158 [ >process swap >>stdout swap >>stdin run-detached ]
159 [ drop [ [ dispose ] when* ] bi@ ]
163 : <process-reader*> ( process encoding -- process stream )
169 [ swap out>> or ] change-stdout
173 [ in>> <input-port> ]
174 } cleave r> <decoder>
177 : <process-reader> ( desc encoding -- stream )
178 <process-reader*> nip ; inline
180 : <process-writer*> ( process encoding -- process stream )
186 [ swap in>> or ] change-stdout
190 [ out>> <output-port> ]
191 } cleave r> <encoder>
194 : <process-writer> ( desc encoding -- stream )
195 <process-writer*> nip ; inline
197 : <process-stream*> ( process encoding -- process stream )
200 [ [ |dispose drop ] bi@ ]
203 [ swap out>> or ] change-stdout
204 [ swap in>> or ] change-stdin
207 [ [ out>> dispose ] [ in>> dispose ] bi* ]
208 [ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
209 } 2cleave r> <encoder-duplex>
212 : <process-stream> ( desc encoding -- stream )
213 <process-stream*> nip ; inline
215 : notify-exit ( process status -- )
217 [ processes get delete-at* drop [ resume ] each ] keep
221 GENERIC: underlying-handle ( stream -- handle )
223 M: port underlying-handle handle>> ;
225 M: duplex-stream underlying-handle
226 [ in>> underlying-handle ]
227 [ out>> underlying-handle ] bi
228 [ = [ "Invalid duplex stream" throw ] when ] keep ;
230 M: encoder underlying-handle
231 stream>> underlying-handle ;
233 M: decoder underlying-handle
234 stream>> underlying-handle ;