basis/io/launcher/launcher.factor

   1 ! Copyright (C) 2008, 2011 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   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 math math.order
   8 namespaces prettyprint sequences strings system threads vocabs ;
   9
  10 IN: io.launcher
  11
  12 TUPLE: process < identity-tuple
  13
  14 command
  15 detached
  16 hidden
  17
  18 environment
  19 environment-mode
  20
  21 stdin
  22 stdout
  23 stderr
  24
  25 priority
  26 group
  27
  28 timeout
  29
  30 handle status
  31 killed
  32
  33 pipe ;
  34
  35 SYMBOL: +closed+
  36 SYMBOL: +stdout+
  37
  38 TUPLE: appender path ;
  39
  40 C: <appender> appender
  41
  42 SYMBOL: +prepend-environment+
  43 SYMBOL: +replace-environment+
  44 SYMBOL: +append-environment+
  45
  46 SYMBOL: +lowest-priority+
  47 SYMBOL: +low-priority+
  48 SYMBOL: +normal-priority+
  49 SYMBOL: +high-priority+
  50 SYMBOL: +highest-priority+
  51 SYMBOL: +realtime-priority+
  52
  53 SYMBOL: +same-group+
  54 SYMBOL: +new-group+
  55 SYMBOL: +new-session+
  56
  57 : <process> ( -- process )
  58     process new
  59         H{ } clone >>environment
  60         +append-environment+ >>environment-mode
  61         +same-group+ >>group ;
  62
  63 : process-started? ( process -- ? )
  64     [ handle>> ] [ status>> ] bi or ;
  65
  66 : process-running? ( process -- ? )
  67     handle>> >boolean ;
  68
  69 ! Non-blocking process exit notification facility
  70 SYMBOL: processes
  71
  72 HOOK: (wait-for-processes) io-backend ( -- ? )
  73
  74 <PRIVATE
  75
  76 SYMBOL: wait-flag
  77 SYMBOL: wait-delay
  78
  79 : wait-loop ( -- )
  80     processes get assoc-empty? [
  81         5 wait-delay set-global
  82         wait-flag get-global lower-flag
  83     ] [
  84         (wait-for-processes) [
  85             wait-delay [
  86                 [ milliseconds sleep ] [ 5 + 100 max ] bi
  87             ] change-global
  88         ] when
  89     ] if ;
  90
  91 : start-wait-thread ( -- )
  92     <flag> wait-flag set-global
  93     5 wait-delay set-global
  94     [ wait-loop t ] "Process wait" spawn-server drop ;
  95
  96 [
  97     H{ } clone processes set-global
  98     start-wait-thread
  99 ] "io.launcher" add-startup-hook
 100
 101 : process-started ( process handle -- )
 102     >>handle
 103     V{ } clone swap processes get set-at
 104     wait-flag get-global raise-flag ;
 105
 106 : notify-exit ( process status -- )
 107     >>status
 108     [ processes get delete-at* drop [ resume ] each ] keep
 109     f >>handle drop ;
 110
 111 : pass-environment? ( process -- ? )
 112     dup environment>> assoc-empty? not
 113     swap environment-mode>> +replace-environment+ eq? or ;
 114
 115 : get-environment ( process -- env )
 116     [ environment>> ] [ environment-mode>> ] bi {
 117         { +prepend-environment+ [ os-envs assoc-union ] }
 118         { +append-environment+ [ os-envs swap assoc-union ] }
 119         { +replace-environment+ [ ] }
 120     } case ;
 121
 122 PRIVATE>
 123
 124 GENERIC: >process ( obj -- process )
 125
 126 ERROR: process-already-started process ;
 127
 128 M: process-already-started error.
 129     "Process has already been started" print nl
 130     "Launch descriptor:" print nl
 131     process>> . ;
 132
 133 M: process >process
 134     dup process-started? [ process-already-started ] when
 135     clone ;
 136
 137 M: object >process <process> swap >>command ;
 138
 139 HOOK: (current-process) io-backend ( -- handle )
 140
 141 ERROR: process-was-killed process ;
 142
 143 M: process-was-killed error.
 144     "Process was killed as a result of a call to" print
 145     "kill-process, or a timeout" print
 146     nl
 147     "Launch descriptor:" print nl
 148     process>> . ;
 149
 150 : (wait-for-process) ( process -- status )
 151     dup handle>>
 152     [ self over processes get at push "process" suspend drop ] when
 153     dup killed>> [ process-was-killed ] [ status>> ] if ;
 154
 155 : wait-for-process ( process -- status )
 156     [ (wait-for-process) ] with-timeout ;
 157
 158 HOOK: (run-process) io-backend ( process -- handle )
 159
 160 : run-detached ( desc -- process )
 161     >process [ dup (run-process) process-started ] keep ;
 162
 163 : run-process ( desc -- process )
 164     run-detached
 165     dup detached>> [ dup wait-for-process drop ] unless ;
 166
 167 ERROR: process-failed process ;
 168
 169 M: process-failed error.
 170     [
 171         "Process exited with error code " write process>> status>> . nl
 172         "Launch descriptor:" print nl
 173     ] [ process>> . ] bi ;
 174
 175 : check-success ( process status -- )
 176     0 = [ drop ] [ process-failed ] if ;
 177
 178 : wait-for-success ( process -- )
 179     dup wait-for-process check-success ;
 180
 181 : try-process ( desc -- )
 182     run-process wait-for-success ;
 183
 184 HOOK: (kill-process) io-backend ( process -- )
 185
 186 : kill-process ( process -- )
 187     t >>killed
 188     [ pipe>> [ dispose ] when* ]
 189     [ dup handle>> [ (kill-process) ] [ drop ] if ] bi ;
 190
 191 M: process timeout timeout>> ;
 192
 193 M: process set-timeout timeout<< ;
 194
 195 M: process cancel-operation kill-process ;
 196
 197 M: object run-pipeline-element
 198     [
 199         >process
 200             swap >>stdout
 201             swap >>stdin
 202         run-detached
 203     ] [
 204         [
 205             drop [ [ &dispose drop ] when* ] bi@
 206         ] with-destructors
 207     ] 3bi wait-for-process ;
 208
 209 <PRIVATE
 210
 211 : <process-with-pipe> ( desc -- process pipe )
 212     >process (pipe) |dispose [ >>pipe ] keep ;
 213
 214 : (process-reader) ( desc encoding -- stream process )
 215     [
 216         [
 217             <process-with-pipe> {
 218                 [ '[ _ out>> or ] change-stdout ]
 219                 [ drop run-detached ]
 220                 [ out>> dispose ]
 221                 [ in>> <input-port> ]
 222             } cleave
 223         ] dip <decoder> swap
 224     ] with-destructors ;
 225
 226 PRIVATE>
 227
 228 : <process-reader> ( desc encoding -- stream )
 229     (process-reader) drop ; inline
 230
 231 : with-process-reader* ( desc encoding quot -- process status )
 232     [ (process-reader) ] dip '[
 233         [ _ with-input-stream ] dip dup (wait-for-process)
 234     ] with-timeout ; inline
 235
 236 : with-process-reader ( desc encoding quot -- )
 237     with-process-reader* check-success ; inline
 238
 239 <PRIVATE
 240
 241 : (process-writer) ( desc encoding -- stream process )
 242     [
 243         [
 244             <process-with-pipe> {
 245                 [ '[ _ in>> or ] change-stdin ]
 246                 [ drop run-detached ]
 247                 [ in>> dispose ]
 248                 [ out>> <output-port> ]
 249             } cleave
 250         ] dip <encoder> swap
 251     ] with-destructors ;
 252
 253 PRIVATE>
 254
 255 : <process-writer> ( desc encoding -- stream )
 256     (process-writer) drop ; inline
 257
 258 : with-process-writer* ( desc encoding quot -- process status )
 259     [ (process-writer) ] dip '[
 260         [ _ with-output-stream ] dip dup (wait-for-process)
 261     ] with-timeout ; inline
 262
 263 : with-process-writer ( desc encoding quot -- )
 264     with-process-writer* check-success ; inline
 265
 266 <PRIVATE
 267
 268 : (process-stream) ( desc encoding -- stream process )
 269     [
 270         [
 271             (pipe) |dispose
 272             (pipe) |dispose {
 273                 [
 274                     rot >process t >>hidden
 275                         [ swap in>> or ] change-stdin
 276                         [ swap out>> or ] change-stdout
 277                     run-detached
 278                 ]
 279                 [ [ out>> &dispose drop ] [ in>> &dispose drop ] bi* ]
 280                 [ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
 281             } 2cleave
 282         ] dip <encoder-duplex> swap
 283     ] with-destructors ;
 284
 285 PRIVATE>
 286
 287 : <process-stream> ( desc encoding -- stream )
 288     (process-stream) drop ; inline
 289
 290 : with-process-stream* ( desc encoding quot -- process status )
 291     [ (process-stream) ] dip '[
 292         [ _ with-stream ] dip dup (wait-for-process)
 293     ] with-timeout ; inline
 294
 295 : with-process-stream ( desc encoding quot -- )
 296     with-process-stream* check-success ; inline
 297
 298 ERROR: output-process-error { output string } { process process } ;
 299
 300 M: output-process-error error.
 301     [ "Process:" print process>> . nl ]
 302     [ "Output:" print output>> print ]
 303     bi ;
 304
 305 : try-output-process ( command -- )
 306     >process
 307     +stdout+ >>stderr
 308     [ +closed+ or ] change-stdin
 309     utf8 (process-reader)
 310     [ [ stream-contents ] [ dup (wait-for-process) ] bi* ] with-timeout
 311     0 = [ 2drop ] [ output-process-error ] if ;
 312
 313 {
 314     { [ os unix? ] [ "io.launcher.unix" require ] }
 315     { [ os windows? ] [ "io.launcher.windows" require ] }
 316 } cond