extra/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 : redirect-fd ( oldfd fd -- )
  34     2dup = [ 2drop ] [ dupd dup2 io-error close-file ] if ;
  35
  36 : reset-fd ( fd -- )
  37     #! We drop the error code because on *BSD, fcntl of
  38     #! /dev/null fails.
  39     [ F_SETFL 0 fcntl drop ]
  40     [ F_SETFD 0 fcntl drop ] bi ;
  41
  42 : redirect-inherit ( obj mode fd -- )
  43     2nip reset-fd ;
  44
  45 : redirect-file ( obj mode fd -- )
  46     >r >r normalize-path r> file-mode
  47     open-file r> redirect-fd ;
  48
  49 : redirect-file-append ( obj mode fd -- )
  50     >r drop path>> normalize-path open-append r> redirect-fd ;
  51
  52 : redirect-closed ( obj mode fd -- )
  53     >r >r drop "/dev/null" r> r> redirect-file ;
  54
  55 : redirect ( obj mode fd -- )
  56     {
  57         { [ pick not ] [ redirect-inherit ] }
  58         { [ pick string? ] [ redirect-file ] }
  59         { [ pick appender? ] [ redirect-file-append ] }
  60         { [ pick +closed+ eq? ] [ redirect-closed ] }
  61         { [ pick fd? ] [ >r drop fd>> dup reset-fd r> redirect-fd ] }
  62         [ >r >r underlying-handle r> r> redirect ]
  63     } cond ;
  64
  65 : ?closed dup +closed+ eq? [ drop "/dev/null" ] when ;
  66
  67 : setup-redirection ( process -- process )
  68     dup stdin>> ?closed read-flags 0 redirect
  69     dup stdout>> ?closed write-flags 1 redirect
  70     dup stderr>> dup +stdout+ eq? [
  71         drop 1 2 dup2 io-error
  72     ] [
  73         ?closed write-flags 2 redirect
  74     ] if ;
  75
  76 : setup-environment ( process -- process )
  77     dup pass-environment? [
  78         dup get-environment set-os-envs
  79     ] when ;
  80
  81 : spawn-process ( process -- * )
  82     [ setup-priority ] [ 250 _exit ] recover
  83     [ setup-redirection ] [ 251 _exit ] recover
  84     [ current-directory get (normalize-path) cd ] [ 252 _exit ] recover
  85     [ setup-environment ] [ 253 _exit ] recover
  86     [ get-arguments exec-args-with-path ] [ 254 _exit ] recover
  87     255 _exit ;
  88
  89 M: unix current-process-handle ( -- handle ) getpid ;
  90
  91 M: unix run-process* ( process -- pid )
  92     [ spawn-process ] curry [ ] with-fork ;
  93
  94 M: unix kill-process* ( pid -- )
  95     SIGTERM kill io-error ;
  96
  97 : find-process ( handle -- process )
  98     processes get swap [ nip swap handle>> = ] curry
  99     assoc-find 2drop ;
 100
 101 M: unix wait-for-processes ( -- ? )
 102     -1 0 <int> tuck WNOHANG waitpid
 103     dup 0 <= [
 104         2drop t
 105     ] [
 106         find-process dup [
 107             swap *int WEXITSTATUS notify-exit f
 108         ] [
 109             2drop f
 110         ] if
 111     ] if ;