steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

io.launcher: cleanup public interface, make some things private or internal.

db4
John Benediktsson 2014-12-30 10:04:09 -08:00
parent e68c0ae8bd
commit 83f7b31910
7 changed files with 93 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
basis/io/launcher/launcher-docs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: calendar help.markup help.syntax io io.files kernel literals math
quotations sequences ;
USING: assocs calendar help.markup help.syntax io io.files
io.launcher.private kernel literals quotations sequences ;
IN: io.launcher
ARTICLE: "io.launcher.command" "Specifying a command"
@ -93,21 +93,21 @@ ARTICLE: "io.launcher.timeouts" "Process run-time timeouts"
"The " { $snippet "timeout" } " slot of a " { $link process } " can be set to a " { $link duration } " specifying a maximum running time for the process. If " { $link wait-for-process } " is called and the process does not exit before the duration expires, it will be killed." ;
HELP: get-environment
{ $values { "process" process } { "env" "an association" } }
{ $values { "process" process } { "env" assoc } }
{ $description "Combines the current environment with the value of the " { $snippet "environment" } " slot of the " { $link process } " using the " { $snippet "environment-mode" } " slot." } ;
HELP: current-process-handle
HELP: (current-process)
{ $values { "handle" "a process handle" } }
{ $description "Returns the handle of the current process." }
{ $examples
{ $example
"USING: io.launcher math prettyprint ;"
"current-process-handle number? ."
"(current-process) number? ."
"t"
}
} ;
HELP: run-process*
HELP: (run-process)
{ $values { "process" process } { "handle" "a process handle" } }
{ $contract "Launches a process." }
{ $notes "User code should call " { $link run-process } " instead." } ;
@ -176,7 +176,7 @@ HELP: kill-process
}
} ;
HELP: kill-process*
HELP: (kill-process)
{ $values { "process" "process" } }
{ $contract "Kills a running process." }
{ $notes "User code should call " { $link kill-process } " instead." } ;

105
basis/io/launcher/launcher.factor
View File

@ -1,11 +1,12 @@
! Copyright (C) 2008, 2011 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: system kernel namespaces strings hashtables sequences
assocs combinators vocabs init threads continuations math
accessors concurrency.flags destructors environment fry io
io.encodings.ascii io.backend io.timeouts io.pipes
io.pipes.private io.encodings io.encodings.utf8
io.streams.duplex io.ports debugger prettyprint summary calendar ;
USING: accessors assocs calendar combinators concurrency.flags
debugger destructors environment fry init io io.backend
io.encodings io.encodings.utf8 io.pipes io.pipes.private
io.ports io.streams.duplex io.timeouts kernel namespaces
prettyprint sequences strings system threads vocabs ;
IN: io.launcher
TUPLE: process < identity-tuple
@ -35,7 +36,7 @@ SYMBOL: +stdout+
TUPLE: appender path ;
: <appender> ( path -- appender ) appender boa ;
C: <appender> appender
SYMBOL: +prepend-environment+
SYMBOL: +replace-environment+
@ -54,9 +55,9 @@ SYMBOL: +new-session+
: <process> ( -- process )
process new
H{ } clone >>environment
+append-environment+ >>environment-mode
+same-group+ >>group ;
H{ } clone >>environment
+append-environment+ >>environment-mode
+same-group+ >>group ;
: process-started? ( process -- ? )
[ handle>> ] [ status>> ] bi or ;
@ -67,14 +68,16 @@ SYMBOL: +new-session+
! Non-blocking process exit notification facility
SYMBOL: processes
HOOK: wait-for-processes io-backend ( -- ? )
HOOK: (wait-for-processes) io-backend ( -- ? )
<PRIVATE
SYMBOL: wait-flag
: wait-loop ( -- )
processes get assoc-empty?
[ wait-flag get-global lower-flag ]
[ wait-for-processes [ 100 milliseconds sleep ] when ] if ;
[ (wait-for-processes) [ 100 milliseconds sleep ] when ] if ;
: start-wait-thread ( -- )
<flag> wait-flag set-global
@ -95,15 +98,13 @@ SYMBOL: wait-flag
swap environment-mode>> +replace-environment+ eq? or ;
: get-environment ( process -- env )
dup environment>>
swap environment-mode>> {
[ environment>> ] [ environment-mode>> ] bi {
{ +prepend-environment+ [ os-envs assoc-union ] }
{ +append-environment+ [ os-envs swap assoc-union ] }
{ +replace-environment+ [ ] }
} case ;
: string-array? ( obj -- ? )
dup sequence? [ [ string? ] all? ] [ drop f ] if ;
PRIVATE>
GENERIC: >process ( obj -- process )
@ -115,16 +116,12 @@ M: process-already-started error.
process>> . ;
M: process >process
dup process-started? [
process-already-started
] when
dup process-started? [ process-already-started ] when
clone ;
M: object >process <process> swap >>command ;
HOOK: current-process-handle io-backend ( -- handle )
HOOK: run-process* io-backend ( process -- handle )
HOOK: (current-process) io-backend ( -- handle )
ERROR: process-was-killed process ;
@ -143,8 +140,10 @@ M: process-was-killed error.
: wait-for-process ( process -- status )
[ (wait-for-process) ] with-timeout ;
HOOK: (run-process) io-backend ( process -- handle )
: run-detached ( desc -- process )
>process [ dup run-process* process-started ] keep ;
>process [ dup (run-process) process-started ] keep ;
: run-process ( desc -- process )
run-detached
@ -164,12 +163,12 @@ M: process-failed error.
: try-process ( desc -- )
run-process wait-for-success ;
HOOK: kill-process* io-backend ( process -- )
HOOK: (kill-process) io-backend ( process -- )
: kill-process ( process -- )
t >>killed
[ pipe>> [ dispose ] when* ]
[ dup handle>> [ kill-process* ] [ drop ] if ] bi ;
[ dup handle>> [ (kill-process) ] [ drop ] if ] bi ;
M: process timeout timeout>> ;
@ -178,19 +177,23 @@ M: process set-timeout timeout<< ;
M: process cancel-operation kill-process ;
M: object run-pipeline-element
[ >process swap >>stdout swap >>stdin run-detached ]
[ [ drop [ [ &dispose drop ] when* ] bi@ ] with-destructors ]
3bi
wait-for-process ;
[
>process
swap >>stdout
swap >>stdin
run-detached
] [
[
drop [ [ &dispose drop ] when* ] bi@
] with-destructors
] 3bi wait-for-process ;
<PRIVATE
: <process-with-pipe> ( desc -- process pipe )
>process (pipe) |dispose [ >>pipe ] keep ;
PRIVATE>
: <process-reader*> ( desc encoding -- stream process )
: (process-reader) ( desc encoding -- stream process )
[
[
<process-with-pipe> {
@ -202,15 +205,19 @@ PRIVATE>
] dip <decoder> swap
] with-destructors ;
PRIVATE>
: <process-reader> ( desc encoding -- stream )
<process-reader*> drop ; inline
(process-reader) drop ; inline
: with-process-reader ( desc encoding quot -- )
[ <process-reader*> ] dip
swap [ with-input-stream ] dip
[ (process-reader) ] dip
'[ _ with-input-stream ] dip
wait-for-success ; inline
: <process-writer*> ( desc encoding -- stream process )
<PRIVATE
: (process-writer) ( desc encoding -- stream process )
[
[
<process-with-pipe> {
@ -222,15 +229,19 @@ PRIVATE>
] dip <encoder> swap
] with-destructors ;
PRIVATE>
: <process-writer> ( desc encoding -- stream )
<process-writer*> drop ; inline
(process-writer) drop ; inline
: with-process-writer ( desc encoding quot -- )
[ <process-writer*> ] dip
swap [ with-output-stream ] dip
[ (process-writer) ] dip
'[ _ with-output-stream ] dip
wait-for-success ; inline
: <process-stream*> ( desc encoding -- stream process )
<PRIVATE
: (process-stream) ( desc encoding -- stream process )
[
[
(pipe) |dispose
@ -247,12 +258,14 @@ PRIVATE>
] dip <encoder-duplex> swap
] with-destructors ;
PRIVATE>
: <process-stream> ( desc encoding -- stream )
<process-stream*> drop ; inline
(process-stream) drop ; inline
: with-process-stream ( desc encoding quot -- )
[ <process-stream*> ] dip
swap [ with-stream ] dip
[ (process-stream) ] dip
'[ _ with-stream ] dip
wait-for-success ; inline
ERROR: output-process-error { output string } { process process } ;
@ -266,16 +279,20 @@ M: output-process-error error.
>process
+stdout+ >>stderr
[ +closed+ or ] change-stdin
utf8 <process-reader*>
utf8 (process-reader)
[ [ stream-contents ] [ dup (wait-for-process) ] bi* ] with-timeout
0 = [ 2drop ] [ output-process-error ] if ;
<PRIVATE
: notify-exit ( process status -- )
>>status
[ processes get delete-at* drop [ resume ] each ] keep
f >>handle
drop ;
PRIVATE>
{
{ [ os unix? ] [ "io.launcher.unix" require ] }
{ [ os windows? ] [ "io.launcher.windows" require ] }

4
basis/io/launcher/unix/unix-tests.factor
View File

@ -161,7 +161,7 @@ IN: io.launcher.unix.tests
[ p fulfill ] [ wait-for-process s fulfill ] bi
] in-thread
p 1 seconds ?promise-timeout kill-process*
p 1 seconds ?promise-timeout (kill-process)
s 3 seconds ?promise-timeout 0 =
]
] unit-test
@ -173,7 +173,7 @@ IN: io.launcher.unix.tests
"SIGPIPE" signal-names index 1 +
kill io-error ;
[ ] [ current-process-handle send-sigpipe ] unit-test
[ ] [ (current-process) send-sigpipe ] unit-test
! Spawn a process
[ T{ signal f 13 } ] [

19
basis/io/launcher/unix/unix.factor
View File

@ -1,11 +1,10 @@
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.data arrays assocs
combinators continuations environment io io.backend
io.backend.unix io.files io.files.private io.files.unix
io.launcher io.pathnames io.ports kernel libc math
namespaces sequences strings system threads unix unix.process
unix.ffi simple-tokenizer ;
USING: accessors alien.c-types alien.data assocs combinators
continuations environment io.backend io.backend.unix
io.files.private io.files.unix io.launcher io.launcher.private
io.pathnames io.ports kernel libc math namespaces sequences
simple-tokenizer strings system unix unix.ffi unix.process ;
IN: io.launcher.unix
: get-arguments ( process -- seq )
@ -90,12 +89,12 @@ IN: io.launcher.unix
255 _exit
f throw ;
M: unix current-process-handle ( -- handle ) getpid ;
M: unix (current-process) ( -- handle ) getpid ;
M: unix run-process* ( process -- pid )
M: unix (run-process) ( process -- pid )
[ spawn-process ] curry [ ] with-fork ;
M: unix kill-process* ( process -- )
M: unix (kill-process) ( process -- )
[ handle>> SIGTERM ] [ group>> ] bi {
{ +same-group+ [ kill ] }
{ +new-group+ [ killpg ] }
@ -111,7 +110,7 @@ TUPLE: signal n ;
: code>status ( code -- obj )
dup WIFSIGNALED [ WTERMSIG signal boa ] [ WEXITSTATUS ] if ;
M: unix wait-for-processes ( -- ? )
M: unix (wait-for-processes) ( -- ? )
{ int } [ -1 swap WNOHANG waitpid ] with-out-parameters
swap dup 0 <= [
2drop t

23
basis/io/launcher/windows/windows.factor
View File

@ -4,11 +4,12 @@ USING: accessors alien alien.c-types alien.data arrays assocs
classes classes.struct combinators concurrency.flags
continuations debugger destructors init io io.backend
io.backend.windows io.files io.files.private io.files.windows
io.launcher io.pathnames io.pipes io.pipes.windows io.ports
kernel libc locals make math namespaces prettyprint sequences
specialized-arrays splitting splitting.monotonic
strings system threads windows windows.errors windows.handles
windows.kernel32 windows.types combinators.short-circuit ;
io.launcher io.launcher.private io.pathnames io.pipes
io.pipes.windows io.ports kernel libc locals make math
namespaces prettyprint sequences specialized-arrays splitting
splitting.monotonic strings system threads windows
windows.errors windows.handles windows.kernel32 windows.types
combinators.short-circuit ;
SPECIALIZED-ARRAY: ushort
SPECIALIZED-ARRAY: void*
IN: io.launcher.windows
@ -132,7 +133,7 @@ TUPLE: CreateProcess-args
fill-startup-info
nip ;
M: windows current-process-handle ( -- handle )
M: windows (current-process) ( -- handle )
GetCurrentProcessId ;
ERROR: launch-error process error ;
@ -143,7 +144,7 @@ M: launch-error error.
"Launch descriptor:" print nl
process>> . ;
M: windows kill-process* ( process -- )
M: windows (kill-process) ( process -- )
handle>> hProcess>> 255 TerminateProcess win32-error=0/f ;
: dispose-process ( process-information -- )
@ -162,7 +163,7 @@ M: windows kill-process* ( process -- )
over handle>> dispose-process
notify-exit ;
M: windows wait-for-processes ( -- ? )
M: windows (wait-for-processes) ( -- ? )
processes get keys dup
[ handle>> hProcess>> ] void*-array{ } map-as
[ length ] keep 0 0
@ -264,14 +265,14 @@ M: windows wait-for-processes ( -- ? )
OPEN_EXISTING
redirect
STD_INPUT_HANDLE GetStdHandle or ;
: fill-redirection ( process args -- )
dup lpStartupInfo>>
[ [ redirect-stdout ] dip hStdOutput<< ]
[ [ redirect-stderr ] dip hStdError<< ]
[ [ redirect-stdin ] dip hStdInput<< ] 3tri ;
M: windows run-process* ( process -- handle )
M: windows (run-process) ( process -- handle )
[
[
dup make-CreateProcess-args
@ -280,4 +281,4 @@ M: windows run-process* ( process -- handle )
dup call-CreateProcess
lpProcessInformation>>
] with-destructors
] [ launch-error ] recover ;
] [ launch-error ] recover ;

2
basis/tools/disassembler/gdb/gdb.factor
View File

@ -15,7 +15,7 @@ SINGLETON: gdb-disassembler
:: make-disassemble-cmd ( from to -- )
in-file ascii [
"attach " write
current-process-handle number>string print
(current-process) number>string print
"x/" write to from - 4 / number>string write
"i" write bl from number>string write
] with-file-writer ;

2
extra/update/util/util.factor
View File

@ -51,7 +51,7 @@ DEFER: to-strings
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: git-id ( -- id )
{ "git" "show" } utf8 <process-reader> [ readln ] with-input-stream
{ "git" "show" } utf8 [ readln ] with-process-reader
" " split second ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!