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     [ handle>> ] [ status>> ] bi 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 = [ drop ] [ process-failed ] if ;
 163
 164 : try-process ( desc -- )
 165     run-process wait-for-success ;
 166
 167 HOOK: kill-process* io-backend ( process -- )
 168
 169 : kill-process ( process -- )
 170     t >>killed
 171     [ pipe>> [ dispose ] when* ]
 172     [ dup handle>> [ kill-process* ] [ drop ] if ] bi ;
 173
 174 M: process timeout timeout>> ;
 175
 176 M: process set-timeout timeout<< ;
 177
 178 M: process cancel-operation kill-process ;
 179
 180 M: object run-pipeline-element
 181     [ >process swap >>stdout swap >>stdin run-detached ]
 182     [ [ drop [ [ &dispose drop ] when* ] bi@ ] with-destructors ]
 183     3bi
 184     wait-for-process ;
 185
 186 <PRIVATE
 187
 188 : <process-with-pipe> ( desc -- process pipe )
 189     >process (pipe) |dispose [ >>pipe ] keep ;
 190
 191 PRIVATE>
 192
 193 : <process-reader*> ( desc encoding -- stream process )
 194     [
 195         [
 196             <process-with-pipe> {
 197                 [ '[ _ out>> or ] change-stdout ]
 198                 [ drop run-detached ]
 199                 [ out>> dispose ]
 200                 [ in>> <input-port> ]
 201             } cleave
 202         ] dip <decoder> swap
 203     ] with-destructors ;
 204
 205 : <process-reader> ( desc encoding -- stream )
 206     <process-reader*> drop ; inline
 207
 208 : with-process-reader ( desc encoding quot -- )
 209     [ <process-reader*> ] dip
 210     swap [ with-input-stream ] dip
 211     wait-for-success ; inline
 212
 213 : <process-writer*> ( desc encoding -- stream process )
 214     [
 215         [
 216             <process-with-pipe> {
 217                 [ '[ _ in>> or ] change-stdin ]
 218                 [ drop run-detached ]
 219                 [ in>> dispose ]
 220                 [ out>> <output-port> ]
 221             } cleave
 222         ] dip <encoder> swap
 223     ] with-destructors ;
 224
 225 : <process-writer> ( desc encoding -- stream )
 226     <process-writer*> drop ; inline
 227
 228 : with-process-writer ( desc encoding quot -- )
 229     [ <process-writer*> ] dip
 230     swap [ with-output-stream ] dip
 231     wait-for-success ; inline
 232
 233 : <process-stream*> ( desc encoding -- stream process )
 234     [
 235         [
 236             (pipe) |dispose
 237             (pipe) |dispose {
 238                 [
 239                     rot >process
 240                         [ swap in>> or ] change-stdin
 241                         [ swap out>> or ] change-stdout
 242                     run-detached
 243                 ]
 244                 [ [ out>> &dispose drop ] [ in>> &dispose drop ] bi* ]
 245                 [ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
 246             } 2cleave
 247         ] dip <encoder-duplex> swap
 248     ] with-destructors ;
 249
 250 : <process-stream> ( desc encoding -- stream )
 251     <process-stream*> drop ; inline
 252
 253 : with-process-stream ( desc encoding quot -- )
 254     [ <process-stream*> ] dip
 255     swap [ with-stream ] dip
 256     wait-for-success ; inline
 257
 258 ERROR: output-process-error { output string } { process process } ;
 259
 260 M: output-process-error error.
 261     [ "Process:" print process>> . nl ]
 262     [ "Output:" print output>> print ]
 263     bi ;
 264
 265 : try-output-process ( command -- )
 266     >process
 267     +stdout+ >>stderr
 268     [ +closed+ or ] change-stdin
 269     utf8 <process-reader*>
 270     [ [ stream-contents ] [ dup (wait-for-process) ] bi* ] with-timeout
 271     0 = [ 2drop ] [ output-process-error ] if ;
 272
 273 : notify-exit ( process status -- )
 274     >>status
 275     [ processes get delete-at* drop [ resume ] each ] keep
 276     f >>handle
 277     drop ;
 278
 279 {
 280     { [ os unix? ] [ "io.launcher.unix" require ] }
 281     { [ os windows? ] [ "io.launcher.windows" require ] }
 282 } cond