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 assocs combinators
   4 continuations environment fry io.backend io.backend.unix
   5 io.files.private io.files.unix io.launcher io.launcher.private
   6 io.pathnames io.ports kernel libc math namespaces sequences
   7 simple-tokenizer strings system unix unix.ffi unix.process ;
   8 QUALIFIED-WITH: unix.signals sig
   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-process-group ( process -- process )
  18     dup group>> {
  19         { +same-group+ [ ] }
  20         { +new-group+ [ 0 0 setpgid io-error ] }
  21         { +new-session+ [ setsid io-error ] }
  22     } case ;
  23
  24 : setup-priority ( process -- process )
  25     dup priority>> [
  26         {
  27             { +lowest-priority+ [ 20 ] }
  28             { +low-priority+ [ 10 ] }
  29             { +normal-priority+ [ 0 ] }
  30             { +high-priority+ [ -10 ] }
  31             { +highest-priority+ [ -20 ] }
  32             { +realtime-priority+ [ -20 ] }
  33         } case set-priority
  34     ] when* ;
  35
  36 : reset-fd ( fd -- )
  37     [ F_SETFL 0 fcntl io-error ] [ F_SETFD 0 fcntl io-error ] bi ;
  38
  39 : redirect-fd ( oldfd fd -- )
  40     2dup = [ 2drop ] [ dup2 io-error ] if ;
  41
  42 : redirect-file ( obj mode fd -- )
  43     [ [ normalize-path ] dip file-mode open-file ] dip redirect-fd ;
  44
  45 : redirect-file-append ( obj mode fd -- )
  46     [ drop path>> normalize-path open-append ] dip redirect-fd ;
  47
  48 : redirect-closed ( obj mode fd -- )
  49     [ drop "/dev/null" ] 2dip redirect-file ;
  50
  51 : redirect ( obj mode fd -- )
  52     {
  53         { [ pick not ] [ 3drop ] }
  54         { [ pick string? ] [ redirect-file ] }
  55         { [ pick appender? ] [ redirect-file-append ] }
  56         { [ pick +closed+ eq? ] [ redirect-closed ] }
  57         { [ pick fd? ] [ [ drop fd>> dup reset-fd ] dip redirect-fd ] }
  58         [ [ underlying-handle ] 2dip redirect ]
  59     } cond ;
  60
  61 : ?closed ( obj -- obj' )
  62     dup +closed+ eq? [ drop "/dev/null" ] when ;
  63
  64 : setup-redirection ( process -- process )
  65     dup stdin>> ?closed read-flags 0 redirect
  66     dup stdout>> ?closed write-flags 1 redirect
  67     dup stderr>> dup +stdout+ eq? [
  68         drop 1 2 dup2 io-error
  69     ] [
  70         ?closed write-flags 2 redirect
  71     ] if ;
  72
  73 : setup-environment ( process -- process )
  74     dup pass-environment? [
  75         dup get-environment set-os-envs
  76     ] when ;
  77
  78 ! Ignored signals are not reset to the default handler.
  79 : reset-ignored-signals ( process -- process )
  80     SIGPIPE SIG_DFL signal drop ;
  81
  82 : fork-process ( process -- pid )
  83     [ reset-ignored-signals ] [ 2drop 248 _exit ] recover
  84     [ setup-process-group ] [ 2drop 249 _exit ] recover
  85     [ setup-priority ] [ 2drop 250 _exit ] recover
  86     [ setup-redirection ] [ 2drop 251 _exit ] recover
  87     [ current-directory get cd ] [ 2drop 252 _exit ] recover
  88     [ setup-environment ] [ 2drop 253 _exit ] recover
  89     [ get-arguments exec-args-with-path ] [ 2drop 254 _exit ] recover
  90     255 _exit
  91     f throw ;
  92
  93 : spawn-process ( process -- pid )
  94     [ reset-ignored-signals ] [ 2drop 248 _exit ] recover
  95     [ setup-process-group ] [ 2drop 249 _exit ] recover
  96     [ setup-priority ] [ 2drop 250 _exit ] recover
  97     [ setup-redirection ] [ 2drop 251 _exit ] recover
  98     [ current-directory get cd ] [ 2drop 252 _exit ] recover
  99     [ setup-environment ] [ 2drop 253 _exit ] recover
 100     [ get-arguments posix-spawn ] [ drop ] recover ;
 101
 102 M: unix (current-process) getpid ;
 103
 104 M: unix (run-process)
 105     '[ _ fork-process ] [ ] with-fork ;
 106
 107 M: unix (kill-process)
 108     [ handle>> SIGTERM ] [ group>> ] bi {
 109         { +same-group+ [ kill ] }
 110         { +new-group+ [ killpg ] }
 111         { +new-session+ [ killpg ] }
 112     } case io-error ;
 113
 114 : find-process ( handle -- process )
 115     processes get keys [ handle>> = ] with find nip ;
 116
 117 : code>status ( code -- obj )
 118     dup WIFSIGNALED [ WTERMSIG sig:signal boa ] [ WEXITSTATUS ] if ;
 119
 120 M: unix (wait-for-processes)
 121     { int } [ -1 swap WNOHANG waitpid ] with-out-parameters
 122     swap dup 0 <= [
 123         2drop t
 124     ] [
 125         find-process dup
 126         [ swap code>status notify-exit f ] [ 2drop f ] if
 127     ] if ;