basis/io/launcher/unix/unix.factor

   1 ! Copyright (C) 2007, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types alien.data arrays assocs
   4 combinators continuations environment io io.backend
   5 io.backend.unix io.files io.files.private io.files.unix
   6 io.launcher io.pathnames io.ports kernel math namespaces
   7 sequences strings system threads unix unix.process unix.ffi
   8 simple-tokenizer ;
   9 IN: io.launcher.unix
  10
  11 : get-arguments ( process -- seq )
  12     command>> dup string? [ tokenize ] when ;
  13
  14 : assoc>env ( assoc -- env )
  15     [ "=" glue ] { } assoc>map ;
  16
  17 : setup-priority ( process -- process )
  18     dup priority>> [
  19         H{
  20             { +lowest-priority+ 20 }
  21             { +low-priority+ 10 }
  22             { +normal-priority+ 0 }
  23             { +high-priority+ -10 }
  24             { +highest-priority+ -20 }
  25             { +realtime-priority+ -20 }
  26         } at set-priority
  27     ] when* ;
  28
  29 : reset-fd ( fd -- )
  30     [ F_SETFL 0 fcntl io-error ] [ F_SETFD 0 fcntl io-error ] bi ;
  31
  32 : redirect-fd ( oldfd fd -- )
  33     2dup = [ 2drop ] [ dup2 io-error ] if ;
  34
  35 : redirect-file ( obj mode fd -- )
  36     [ [ normalize-path ] dip file-mode open-file ] dip redirect-fd ;
  37
  38 : redirect-file-append ( obj mode fd -- )
  39     [ drop path>> normalize-path open-append ] dip redirect-fd ;
  40
  41 : redirect-closed ( obj mode fd -- )
  42     [ drop "/dev/null" ] 2dip redirect-file ;
  43
  44 : redirect ( obj mode fd -- )
  45     {
  46         { [ pick not ] [ 3drop ] }
  47         { [ pick string? ] [ redirect-file ] }
  48         { [ pick appender? ] [ redirect-file-append ] }
  49         { [ pick +closed+ eq? ] [ redirect-closed ] }
  50         { [ pick fd? ] [ [ drop fd>> dup reset-fd ] dip redirect-fd ] }
  51         [ [ underlying-handle ] 2dip redirect ]
  52     } cond ;
  53
  54 : ?closed ( obj -- obj' )
  55     dup +closed+ eq? [ drop "/dev/null" ] when ;
  56
  57 : setup-redirection ( process -- process )
  58     dup stdin>> ?closed read-flags 0 redirect
  59     dup stdout>> ?closed write-flags 1 redirect
  60     dup stderr>> dup +stdout+ eq? [
  61         drop 1 2 dup2 io-error
  62     ] [
  63         ?closed write-flags 2 redirect
  64     ] if ;
  65
  66 : setup-environment ( process -- process )
  67     dup pass-environment? [
  68         dup get-environment set-os-envs
  69     ] when ;
  70
  71 : spawn-process ( process -- * )
  72     [ setup-priority ] [ 2drop 250 _exit ] recover
  73     [ setup-redirection ] [ 2drop 251 _exit ] recover
  74     [ current-directory get absolute-path cd ] [ 2drop 252 _exit ] recover
  75     [ setup-environment ] [ 2drop 253 _exit ] recover
  76     [ get-arguments exec-args-with-path ] [ 2drop 254 _exit ] recover
  77     255 _exit
  78     f throw ;
  79
  80 M: unix current-process-handle ( -- handle ) getpid ;
  81
  82 M: unix run-process* ( process -- pid )
  83     [ spawn-process ] curry [ ] with-fork ;
  84
  85 M: unix kill-process* ( pid -- )
  86     SIGTERM kill io-error ;
  87
  88 : find-process ( handle -- process )
  89     processes get swap [ nip swap handle>> = ] curry
  90     assoc-find 2drop ;
  91
  92 TUPLE: signal n ;
  93
  94 : code>status ( code -- obj )
  95     dup WIFSIGNALED [ WTERMSIG signal boa ] [ WEXITSTATUS ] if ;
  96
  97 M: unix wait-for-processes ( -- ? )
  98     { int } [ -1 swap WNOHANG waitpid ] [ ] with-out-parameters
  99     swap dup 0 <= [
 100         2drop t
 101     ] [
 102         find-process dup
 103         [ swap code>status notify-exit f ] [ 2drop f ] if
 104     ] if ;