basis/io/launcher/launcher.factor

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