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