From 83f7b31910b3e8231d7f897e31efb11fa996c2d5 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Tue, 30 Dec 2014 10:04:09 -0800 Subject: [PATCH] io.launcher: cleanup public interface, make some things private or internal. --- basis/io/launcher/launcher-docs.factor | 14 +-- basis/io/launcher/launcher.factor | 105 +++++++++++++---------- basis/io/launcher/unix/unix-tests.factor | 4 +- basis/io/launcher/unix/unix.factor | 19 ++-- basis/io/launcher/windows/windows.factor | 23 ++--- basis/tools/disassembler/gdb/gdb.factor | 2 +- extra/update/util/util.factor | 2 +- 7 files changed, 93 insertions(+), 76 deletions(-) diff --git a/basis/io/launcher/launcher-docs.factor b/basis/io/launcher/launcher-docs.factor index 992da3c981..c145e10b6f 100644 --- a/basis/io/launcher/launcher-docs.factor +++ b/basis/io/launcher/launcher-docs.factor @@ -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." } ; diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index 5b8cb401b3..19fed50307 100755 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -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 ; -: ( path -- appender ) appender boa ; +C: appender SYMBOL: +prepend-environment+ SYMBOL: +replace-environment+ @@ -54,9 +55,9 @@ SYMBOL: +new-session+ : ( -- 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 ( -- ? ) + + 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 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 ; ( desc -- process pipe ) >process (pipe) |dispose [ >>pipe ] keep ; -PRIVATE> - -: ( desc encoding -- stream process ) +: (process-reader) ( desc encoding -- stream process ) [ [ { @@ -202,15 +205,19 @@ PRIVATE> ] dip swap ] with-destructors ; +PRIVATE> + : ( desc encoding -- stream ) - drop ; inline + (process-reader) drop ; inline : with-process-reader ( desc encoding quot -- ) - [ ] dip - swap [ with-input-stream ] dip + [ (process-reader) ] dip + '[ _ with-input-stream ] dip wait-for-success ; inline -: ( desc encoding -- stream process ) + { @@ -222,15 +229,19 @@ PRIVATE> ] dip swap ] with-destructors ; +PRIVATE> + : ( desc encoding -- stream ) - drop ; inline + (process-writer) drop ; inline : with-process-writer ( desc encoding quot -- ) - [ ] dip - swap [ with-output-stream ] dip + [ (process-writer) ] dip + '[ _ with-output-stream ] dip wait-for-success ; inline -: ( desc encoding -- stream process ) + ] dip swap ] with-destructors ; +PRIVATE> + : ( desc encoding -- stream ) - drop ; inline + (process-stream) drop ; inline : with-process-stream ( desc encoding quot -- ) - [ ] 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 + utf8 (process-reader) [ [ stream-contents ] [ dup (wait-for-process) ] bi* ] with-timeout 0 = [ 2drop ] [ output-process-error ] if ; +>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 ] } diff --git a/basis/io/launcher/unix/unix-tests.factor b/basis/io/launcher/unix/unix-tests.factor index 9b685184a0..1717b1a225 100644 --- a/basis/io/launcher/unix/unix-tests.factor +++ b/basis/io/launcher/unix/unix-tests.factor @@ -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 } ] [ diff --git a/basis/io/launcher/unix/unix.factor b/basis/io/launcher/unix/unix.factor index 0f9165a977..cccb91ab1b 100644 --- a/basis/io/launcher/unix/unix.factor +++ b/basis/io/launcher/unix/unix.factor @@ -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 diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor index 1b3c276fcc..a2db855881 100755 --- a/basis/io/launcher/windows/windows.factor +++ b/basis/io/launcher/windows/windows.factor @@ -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 ; diff --git a/basis/tools/disassembler/gdb/gdb.factor b/basis/tools/disassembler/gdb/gdb.factor index 1ccddcc047..84aefb16aa 100644 --- a/basis/tools/disassembler/gdb/gdb.factor +++ b/basis/tools/disassembler/gdb/gdb.factor @@ -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 ; diff --git a/extra/update/util/util.factor b/extra/update/util/util.factor index d5eb337dca..56916cf595 100644 --- a/extra/update/util/util.factor +++ b/extra/update/util/util.factor @@ -51,7 +51,7 @@ DEFER: to-strings ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : git-id ( -- id ) - { "git" "show" } utf8 [ readln ] with-input-stream + { "git" "show" } utf8 [ readln ] with-process-reader " " split second ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!