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