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