basis/io/launcher/launcher.factor

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