basis/io/unix/launcher/launcher.factor

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