157 lines
4.1 KiB
Factor
Executable File
157 lines
4.1 KiB
Factor
Executable File
! Copyright (C) 2008 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: io io.backend io.timeouts system kernel namespaces
|
|
strings hashtables sequences assocs combinators vocabs.loader
|
|
init threads continuations math io.encodings io.streams.duplex
|
|
io.nonblocking ;
|
|
IN: io.launcher
|
|
|
|
! Non-blocking process exit notification facility
|
|
SYMBOL: processes
|
|
|
|
[ H{ } clone processes set-global ] "io.launcher" add-init-hook
|
|
|
|
TUPLE: process handle status killed? timeout ;
|
|
|
|
HOOK: register-process io-backend ( process -- )
|
|
|
|
M: object register-process drop ;
|
|
|
|
: <process> ( handle -- process )
|
|
f f f process construct-boa
|
|
V{ } clone over processes get set-at
|
|
dup register-process ;
|
|
|
|
M: process equal? 2drop f ;
|
|
|
|
M: process hashcode* process-handle hashcode* ;
|
|
|
|
: process-running? ( process -- ? ) process-status not ;
|
|
|
|
SYMBOL: +command+
|
|
SYMBOL: +arguments+
|
|
SYMBOL: +detached+
|
|
SYMBOL: +environment+
|
|
SYMBOL: +environment-mode+
|
|
SYMBOL: +stdin+
|
|
SYMBOL: +stdout+
|
|
SYMBOL: +stderr+
|
|
|
|
SYMBOL: +timeout+
|
|
|
|
SYMBOL: +prepend-environment+
|
|
SYMBOL: +replace-environment+
|
|
SYMBOL: +append-environment+
|
|
|
|
SYMBOL: +closed+
|
|
SYMBOL: +inherit+
|
|
|
|
: default-descriptor
|
|
H{
|
|
{ +command+ f }
|
|
{ +arguments+ f }
|
|
{ +detached+ f }
|
|
{ +environment+ H{ } }
|
|
{ +environment-mode+ +append-environment+ }
|
|
} ;
|
|
|
|
: with-descriptor ( desc quot -- )
|
|
default-descriptor [ >r clone r> bind ] bind ; inline
|
|
|
|
: pass-environment? ( -- ? )
|
|
+environment+ get assoc-empty? not
|
|
+environment-mode+ get +replace-environment+ eq? or ;
|
|
|
|
: get-environment ( -- env )
|
|
+environment+ get
|
|
+environment-mode+ get {
|
|
{ +prepend-environment+ [ os-envs union ] }
|
|
{ +append-environment+ [ os-envs swap union ] }
|
|
{ +replace-environment+ [ ] }
|
|
} case ;
|
|
|
|
: string-array? ( obj -- ? )
|
|
dup sequence? [ [ string? ] all? ] [ drop f ] if ;
|
|
|
|
: >descriptor ( desc -- desc )
|
|
{
|
|
{ [ dup string? ] [ +command+ associate ] }
|
|
{ [ dup string-array? ] [ +arguments+ associate ] }
|
|
{ [ dup assoc? ] [ >hashtable ] }
|
|
} cond ;
|
|
|
|
HOOK: current-process-handle io-backend ( -- handle )
|
|
|
|
HOOK: run-process* io-backend ( desc -- handle )
|
|
|
|
: wait-for-process ( process -- status )
|
|
[
|
|
dup process-handle
|
|
[
|
|
dup [ processes get at push ] curry
|
|
"process" suspend drop
|
|
] when
|
|
dup process-killed?
|
|
[ "Process was killed" throw ] [ process-status ] if
|
|
] with-timeout ;
|
|
|
|
: run-process ( desc -- process )
|
|
>descriptor
|
|
dup run-process*
|
|
+timeout+ pick at [ over set-timeout ] when*
|
|
+detached+ rot at [ dup wait-for-process drop ] unless ;
|
|
|
|
: run-detached ( desc -- process )
|
|
>descriptor H{ { +detached+ t } } union run-process ;
|
|
|
|
TUPLE: process-failed code ;
|
|
|
|
: process-failed ( code -- * )
|
|
\ process-failed construct-boa throw ;
|
|
|
|
: try-process ( desc -- )
|
|
run-process wait-for-process dup zero?
|
|
[ drop ] [ process-failed ] if ;
|
|
|
|
HOOK: kill-process* io-backend ( handle -- )
|
|
|
|
: kill-process ( process -- )
|
|
t over set-process-killed?
|
|
process-handle [ kill-process* ] when* ;
|
|
|
|
M: process timeout process-timeout ;
|
|
|
|
M: process set-timeout set-process-timeout ;
|
|
|
|
M: process timed-out kill-process ;
|
|
|
|
HOOK: (process-stream) io-backend ( desc -- in out process )
|
|
|
|
TUPLE: process-stream process ;
|
|
|
|
: <process-stream> ( desc encoding -- stream )
|
|
swap >descriptor
|
|
[ (process-stream) >r rot <encoder-duplex> r> ] keep
|
|
+timeout+ swap at [ over set-timeout ] when*
|
|
{ set-delegate set-process-stream-process }
|
|
process-stream construct ;
|
|
|
|
: with-process-stream ( desc quot -- status )
|
|
swap <process-stream>
|
|
[ swap with-stream ] keep
|
|
process-stream-process wait-for-process ; inline
|
|
|
|
: notify-exit ( status process -- )
|
|
[ set-process-status ] keep
|
|
[ processes get delete-at* drop [ resume ] each ] keep
|
|
f swap set-process-handle ;
|
|
|
|
GENERIC: underlying-handle ( stream -- handle )
|
|
|
|
M: port underlying-handle port-handle ;
|
|
|
|
M: duplex-stream underlying-handle
|
|
dup duplex-stream-in underlying-handle
|
|
swap duplex-stream-out underlying-handle tuck =
|
|
[ "Invalid duplex stream" throw ] when ;
|