125 lines
3.3 KiB
Factor
Executable File
125 lines
3.3 KiB
Factor
Executable File
! Copyright (C) 2007, 2008 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: io io.backend io.launcher io.unix.backend io.unix.files
|
|
io.nonblocking sequences kernel namespaces math system
|
|
alien.c-types debugger continuations arrays assocs
|
|
combinators unix.process parser-combinators memoize
|
|
promises strings threads ;
|
|
IN: io.unix.launcher
|
|
|
|
! Search unix first
|
|
USE: unix
|
|
|
|
! Our command line parser. Supported syntax:
|
|
! foo bar baz -- simple tokens
|
|
! foo\ bar -- escaping the space
|
|
! 'foo bar' -- quotation
|
|
! "foo bar" -- quotation
|
|
LAZY: 'escaped-char' "\\" token any-char-parser &> ;
|
|
|
|
LAZY: 'quoted-char' ( delimiter -- parser' )
|
|
'escaped-char'
|
|
swap [ member? not ] curry satisfy
|
|
<|> ; inline
|
|
|
|
LAZY: 'quoted' ( delimiter -- parser )
|
|
dup 'quoted-char' <!*> swap dup surrounded-by ;
|
|
|
|
LAZY: 'unquoted' ( -- parser ) " '\"" 'quoted-char' <!+> ;
|
|
|
|
LAZY: 'argument' ( -- parser )
|
|
"\"" 'quoted' "'" 'quoted' 'unquoted' <|> <|>
|
|
[ >string ] <@ ;
|
|
|
|
MEMO: 'arguments' ( -- parser )
|
|
'argument' " " token <!+> nonempty-list-of ;
|
|
|
|
: tokenize-command ( command -- arguments )
|
|
'arguments' just parse-1 ;
|
|
|
|
: get-arguments ( -- seq )
|
|
+command+ get [ tokenize-command ] [ +arguments+ get ] if* ;
|
|
|
|
: assoc>env ( assoc -- env )
|
|
[ "=" swap 3append ] { } assoc>map ;
|
|
|
|
: (redirect) ( path mode fd -- )
|
|
>r file-mode open dup io-error dup
|
|
r> dup2 io-error close ;
|
|
|
|
: redirect ( obj mode fd -- )
|
|
{
|
|
{ [ pick not ] [ 2nip F_SETFL 0 fcntl io-error ] }
|
|
{ [ pick +closed+ eq? ] [ close 2drop ] }
|
|
{ [ pick string? ] [ (redirect) ] }
|
|
} cond ;
|
|
|
|
: setup-redirection ( -- )
|
|
+stdin+ get read-flags 0 redirect
|
|
+stdout+ get write-flags 1 redirect
|
|
+stderr+ get dup +stdout+ eq?
|
|
[ drop 1 2 dup2 io-error ] [ write-flags 2 redirect ] if ;
|
|
|
|
: spawn-process ( -- )
|
|
[
|
|
setup-redirection
|
|
get-arguments
|
|
pass-environment?
|
|
[ get-environment assoc>env exec-args-with-env ]
|
|
[ exec-args-with-path ] if
|
|
io-error
|
|
] [ error. :c flush ] recover 1 exit ;
|
|
|
|
M: unix-io run-process* ( desc -- pid )
|
|
[
|
|
[ spawn-process ] [ ] with-fork <process>
|
|
] with-descriptor ;
|
|
|
|
M: unix-io kill-process* ( pid -- )
|
|
SIGTERM kill io-error ;
|
|
|
|
: open-pipe ( -- pair )
|
|
2 "int" <c-array> dup pipe zero?
|
|
[ 2 c-int-array> ] [ drop f ] if ;
|
|
|
|
: setup-stdio-pipe ( stdin stdout -- )
|
|
2dup first close second close
|
|
>r first 0 dup2 drop r> second 1 dup2 drop ;
|
|
|
|
: spawn-process-stream ( -- in out pid )
|
|
open-pipe open-pipe [
|
|
setup-stdio-pipe
|
|
spawn-process
|
|
] [
|
|
-rot 2dup second close first close
|
|
] with-fork first swap second rot <process> ;
|
|
|
|
M: unix-io process-stream*
|
|
[
|
|
spawn-process-stream >r handle>duplex-stream r>
|
|
] with-descriptor ;
|
|
|
|
: find-process ( handle -- process )
|
|
processes get swap [ nip swap process-handle = ] curry
|
|
assoc-find 2drop ;
|
|
|
|
! Inefficient process wait polling, used on Linux and Solaris.
|
|
! On BSD and Mac OS X, we use kqueue() which scales better.
|
|
: wait-for-processes ( -- ? )
|
|
-1 0 <int> tuck WNOHANG waitpid
|
|
dup 0 <= [
|
|
2drop t
|
|
] [
|
|
find-process dup [
|
|
>r *int WEXITSTATUS r> notify-exit f
|
|
] [
|
|
2drop f
|
|
] if
|
|
] if ;
|
|
|
|
: wait-loop ( -- )
|
|
wait-for-processes [ 250 sleep ] when wait-loop ;
|
|
|
|
: start-wait-thread ( -- )
|
|
[ wait-loop ] in-thread ;
|