"strings"
"strings.private"
"system"
+ "system.private"
"threads.private"
"tools.profiler.private"
"tuples"
{ "innermost-frame-scan" "kernel.private" }
{ "set-innermost-frame-quot" "kernel.private" }
{ "call-clear" "kernel" }
- { "(os-envs)" "system" }
+ { "(os-envs)" "system.private" }
+ { "(set-os-envs)" "system.private" }
{ "resize-byte-array" "byte-arrays" }
{ "resize-bit-array" "bit-arrays" }
{ "resize-float-array" "float-arrays" }
quotations.private sbufs sbufs.private sequences
sequences.private slots.private strings strings.private system
threads.private tuples tuples.private vectors vectors.private
-words words.private assocs inspector compiler.units ;
+words words.private assocs inspector compiler.units
+system.private ;
IN: inference.known-words
! Shuffle words
\ (os-envs) { } { array } <effect> set-primitive-effect
+\ (set-os-envs) { array } { } <effect> set-primitive-effect
+
\ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop
\ dll-valid? { object } { object } <effect> set-primitive-effect
-USING: math tools.test system prettyprint ;
+USING: math tools.test system prettyprint namespaces kernel ;
IN: system.tests
[ t ] [ cell integer? ] unit-test
[ t ] [ bootstrap-cell integer? ] unit-test
-[ ] [ os-envs . ] unit-test
+
+wince? [
+ [ ] [ os-envs . ] unit-test
+] unless
+
+unix? [
+ [ ] [ os-envs "envs" set ] unit-test
+ [ ] [ { { "A" "B" } } set-os-envs ] unit-test
+ [ "B" ] [ "A" os-env ] unit-test
+ [ ] [ "envs" get set-os-envs ] unit-test
+ [ t ] [ os-envs "envs" get = ] unit-test
+] when
! See http://factorcode.org/license.txt for BSD license.
IN: system
USING: kernel kernel.private sequences math namespaces
-splitting assocs ;
+splitting assocs system.private ;
: cell ( -- n ) 7 getenv ; foldable
: os-envs ( -- assoc )
(os-envs) [ "=" split1 ] H{ } map>assoc ;
+
+: set-os-envs ( assoc -- )
+ [ "=" swap 3append ] { } assoc>map (set-os-envs) ;
calendar ;
IN: io.launcher
-HELP: +command+
-{ $description "Launch descriptor key. A command line string, to be processed by the system's shell." } ;
+ARTICLE: "io.launcher.command" "Specifying a command"
+"The " { $snippet "command" } " slot of a " { $link process } " can contain either a string or a sequence of strings. In the first case, the string is processed in an operating system-specific manner. In the second case, the first element is a program name and the remaining elements are passed to the program as command-line arguments." ;
-HELP: +arguments+
-{ $description "Launch descriptor key. A sequence of command line argument strings. The first element is the program to launch and the remaining arguments are passed to the program without further processing." } ;
+ARTICLE: "io.launcher.detached" "Running processes in the background"
+"By default, " { $link run-process } " waits for the process to complete. To run a process without waiting for it to finish, set the " { $snippet "detached" } " slot of a " { $link process } ", or use the following word:"
+{ $subsection run-detached } ;
-HELP: +detached+
-{ $description "Launch descriptor key. A boolean indicating whether " { $link run-process } " will return immediately, rather than wait for the program to complete."
+ARTICLE: "io.launcher.environment" "Setting environment variables"
+"The " { $snippet "environment" } " slot of a " { $link process } " contains an association mapping environment variable names to values. The interpretation of environment variables is operating system-specific."
$nl
-"Default value is " { $link f } "." }
-{ $notes "Cannot be used with " { $link <process-stream> } "." }
-{ $see-also run-detached } ;
-
-HELP: +environment+
-{ $description "Launch descriptor key. An association mapping strings to strings, specifying environment variables to set for the spawned process. The association is combined with the current environment using the operation specified by the " { $link +environment-mode+ } " launch descriptor key."
+"The " { $snippet "environment-mode" } " slot controls how the environment of the current Factor instance is composed with the value of the " { $snippet "environment" } " slot:"
+{ $subsection +prepend-environment+ }
+{ $subsection +replace-environment+ }
+{ $subsection +append-environment+ }
+"The default value is " { $link +append-environment+ } "." ;
+
+ARTICLE: "io.launcher.redirection" "Input/output redirection"
+"On all operating systems except for Windows CE, the default input/output/error streams can be redirected."
$nl
-"Default value is an empty association." } ;
-
-HELP: +environment-mode+
-{ $description "Launch descriptor key. Must equal of the following:"
- { $list
- { $link +prepend-environment+ }
- { $link +replace-environment+ }
- { $link +append-environment+ }
- }
-"Default value is " { $link +append-environment+ } "."
-} ;
-
-HELP: +stdin+
-{ $description "Launch descriptor key. Must equal one of the following:"
- { $list
- { { $link f } " - standard input is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
- { { $link +inherit+ } " - standard input is inherited from the current process" }
- { { $link +closed+ } " - standard input is closed" }
- { "a path name - standard input is read from the given file, which must exist" }
- { "a file stream or a socket - standard input is read from the given stream, which must be closed after the process has been started" }
- }
-} ;
-
-HELP: +stdout+
-{ $description "Launch descriptor key. Must equal one of the following:"
- { $list
- { { $link f } " - standard output is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
- { { $link +inherit+ } " - standard output is inherited from the current process" }
- { { $link +closed+ } " - standard output is closed" }
- { "a path name - standard output is written to the given file, which is overwritten if it already exists" }
- { "a file stream or a socket - standard output is written to the given stream, which must be closed after the process has been started" }
- }
-} ;
-
-HELP: +stderr+
-{ $description "Launch descriptor key. Must equal one of the following:"
- { $list
- { { $link f } " - standard error is inherited from the current process" }
- { { $link +inherit+ } " - same as above" }
- { { $link +stdout+ } " - standard error is merged with standard output" }
- { { $link +closed+ } " - standard error is closed" }
- { "a path name - standard error is written to the given file, which is overwritten if it already exists" }
- { "a file stream or a socket - standard error is written to the given stream, which must be closed after the process has been started" }
- }
+"To specify redirection, set the " { $snippet "stdin" } ", " { $snippet "stdout" } " and " { $snippet "stderr" } " slots of a " { $link process } " to one of the following values:"
+{ $list
+ { { $link f } " - default value; the stream is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
+ { { $link +inherit+ } " - the stream is inherited from the current process, overriding a " { $link <process-stream> } " pipe" }
+ { { $link +closed+ } " - the stream is closed; reads will return end of file and writes will fails" }
+ { { $link +stdout+ } " - a special value for the " { $snippet "stderr" } " slot only, indicating that the standard output and standard error streams should be merged" }
+ { "a path name - the stream is sent to the given file, which must exist for input and is created automatically on output" }
+ { "a file stream or a socket - the stream is connected to the given Factor stream, which cannot be used again from within Factor and must be closed after the process has been started" }
} ;
HELP: +closed+
-{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
+{ $description "Possible value for the " { $snippet "stdin" } ", " { $snippet "stdout" } ", and " { $snippet "stderr" } " slots of a " { $link process } "." } ;
HELP: +inherit+
-{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
+{ $description "Possible value for the " { $snippet "stdin" } ", " { $snippet "stdout" } ", and " { $snippet "stderr" } " slots of a " { $link process } "." } ;
+
+HELP: +stdout+
+{ $description "Possible value for the " { $snippet "stderr" } " slot of a " { $link process } "." } ;
HELP: +prepend-environment+
-{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence."
+{ $description "Possible value of " { $snippet "environment-mode" } " slot of a " { $link process } "."
+$nl
+"If this value is set, the child process environment consists of the value of the " { $snippet "environment" } " slot together with the current environment, with entries from the current environment taking precedence."
$nl
"This is used in situations where you want to spawn a child process with some default environment variables set, but allowing the user to override these defaults by changing the environment before launching Factor." } ;
HELP: +replace-environment+
-{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key."
+{ $description "Possible value of " { $snippet "environment-mode" } " slot of a " { $link process } "."
+$nl
+"The child process environment consists of the value of the " { $snippet "environment" } " slot."
$nl
"This is used in situations where you want full control over a child process environment, perhaps for security or testing." } ;
HELP: +append-environment+
-{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the current environment together with the value of the " { $link +environment+ } " key, with entries from the " { $link +environment+ } " key taking precedence."
+{ $description "Possible value of " { $snippet "environment-mode" } " slot of a " { $link process } "."
+$nl
+"The child process environment consists of the current environment together with the value of the " { $snippet "environment" } " key, with entries from the " { $snippet "environment" } " key taking precedence."
$nl
"This is used in situations where you want a spawn child process with some overridden environment variables." } ;
-HELP: +timeout+
-{ $description "Launch descriptor key. If set to a " { $link duration } ", specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ;
-
-HELP: default-descriptor
-{ $description "Association storing default values for launch descriptor keys." } ;
-
-HELP: with-descriptor
-{ $values { "desc" "a launch descriptor" } { "quot" quotation } }
-{ $description "Calls the quotation in a dynamic scope where keys from " { $snippet "desc" } " can be read as variables, and any keys not supplied assume their default value as set in " { $link default-descriptor } "." } ;
+ARTICLE: "io.launcher.timeouts" "Process run-time timeouts"
+{ $description "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 { "env" "an association" } }
-{ $description "Combines the current environment with the value of " { $link +environment+ } " using " { $link +environment-mode+ } "." } ;
+{ $values { "process" process } { "env" "an association" } }
+{ $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
{ $values { "handle" "a process handle" } }
{ $contract "Launches a process using the launch descriptor." }
{ $notes "User code should call " { $link run-process } " instead." } ;
-HELP: >descriptor
-{ $values { "desc" "a launch descriptor" } { "desc" "a launch descriptor" } }
-{ $description "Creates a launch descriptor from an object. See " { $link "io.launcher.descriptors" } " for details." } ;
-
HELP: run-process
{ $values { "desc" "a launch descriptor" } { "process" process } }
-{ $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link "io.launcher.descriptors" } " for details." }
+{ $description "Launches a process. The object can either be a string, a sequence of strings or a " { $link process } ". See " { $link "io.launcher.descriptors" } " for details." }
{ $notes "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ;
HELP: run-detached
{ $values { "desc" "a launch descriptor" } { "process" process } }
-{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link "io.launcher.descriptors" } " for details." }
+{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a " { $link process } ". See " { $link "io.launcher.descriptors" } " for details." }
{ $notes
- "This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set."
+ "This word is functionally identical to passing a " { $link process } " to " { $link run-process } " having the " { $snippet "detached" } " slot set."
$nl
"The output value can be passed to " { $link wait-for-process } " to get an exit code."
} ;
{ $notes "User code should call " { $link kill-process } " intead." } ;
HELP: process
-{ $class-description "A class representing an active or finished process."
-$nl
-"Processes are output by " { $link run-process } " and " { $link run-detached } ", and are stored in the " { $link process-stream-process } " slot of " { $link process-stream } " instances."
-$nl
-"Processes can be passed to " { $link wait-for-process } "." } ;
+{ $class-description "A class representing a process. Instances are created by calling " { $link <process> } "." } ;
+
+HELP: <process>
+{ $values { "process" process } }
+{ $description "Creates a new, empty process. It must be filled in before being passed to " { $link run-process } "." } ;
HELP: process-stream
{ $class-description "A bidirectional stream for interacting with a running process. Instances are created by calling " { $link <process-stream> } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ;
{ "desc" "a launch descriptor" }
{ "encoding" "an encoding descriptor" }
{ "stream" "a bidirectional stream" } }
-{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." }
-{ $notes "Closing the stream will block until the process exits." } ;
+{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." } ;
HELP: with-process-stream
{ $values
{ $description "If the process is still running, waits for it to exit, otherwise outputs the exit code immediately. Can be called multiple times on the same process." } ;
ARTICLE: "io.launcher.descriptors" "Launch descriptors"
-"Words which launch processes can take either a command line string, a sequence of command line arguments, or an assoc:"
-{ $list
- { "strings are wrapped in an assoc with a single " { $link +command+ } " key" }
- { "sequences of strings are wrapped in an assoc with a single " { $link +arguments+ } " key" }
- { "associations can be passed in, which allows finer control over launch parameters" }
-}
-"The associations can contain the following keys:"
-{ $subsection +command+ }
-{ $subsection +arguments+ }
-{ $subsection +detached+ }
-{ $subsection +environment+ }
-{ $subsection +environment-mode+ }
-{ $subsection +timeout+ }
-{ $subsection +stdin+ }
-{ $subsection +stdout+ }
-{ $subsection +stderr+ } ;
-
-ARTICLE: "io.launcher" "Launching OS processes"
-"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
-{ $subsection "io.launcher.descriptors" }
-"The following words are used to launch processes:"
+"Words which launch processes can take either a command line string, a sequence of command line arguments, or a " { $link process } "."
+$nl
+"Strings and string arrays are wrapped in a new empty " { $link process } " with the " { $snippet "command" } " slot set. This covers basic use-cases where no launch parameters need to be set."
+$nl
+"A " { $link process } " instance can be created directly and passed to launching words for more control. It must be a fresh instance which has never been spawned before. To spawn a process several times from the same descriptor, " { $link clone } " the descriptor first." ;
+
+ARTICLE: "io.launcher.lifecycle" "The process lifecycle"
+"A freshly instantiated " { $link process } " represents a set of launch parameters. Words for launching processes take a fresh process which has never been started before as input, and output a copy as output."
+{ $link process-started? }
+"The " { $link process } " instance output by launching words contains all original slot values in addition to the " { $snippet "handle" } " slot, which indicates the process is currently running."
+{ $link process-running? }
+"It is possible to wait for a process to exit:"
+{ $link wait-for-process }
+"A running process can also be killed:"
+{ $link kill-process } ;
+
+ARTICLE: "io.launcher.launch" "Launching processes"
+"Launching processes:"
{ $subsection run-process }
-{ $subsection run-detached }
{ $subsection try-process }
-"Stopping processes:"
-{ $subsection kill-process }
-"Finding the current process handle:"
-{ $subsection current-process-handle }
"Redirecting standard input and output to a pipe:"
{ $subsection <process-stream> }
-{ $subsection with-process-stream }
-"A class representing an active or finished process:"
-{ $subsection process }
-"Waiting for a process to end, or getting the exit code of a finished process:"
-{ $subsection wait-for-process }
-"Processes support the " { $link "io.timeouts" } "; the timeout specifies an upper bound on the running time of the process." ;
+{ $subsection with-process-stream } ;
+
+ARTICLE: "io.launcher" "Operating system processes"
+"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
+{ $subsection "io.launcher.descriptors" }
+{ $subsection "io.launcher.launch" }
+"Advanced topics:"
+{ $subsection "io.launcher.lifecycle" }
+{ $subsection "io.launcher.command" }
+{ $subsection "io.launcher.detached" }
+{ $subsection "io.launcher.environment" }
+{ $subsection "io.launcher.redirection" }
+{ $subsection "io.launcher.timeouts" } ;
ABOUT: "io.launcher"
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 ;
+io.nonblocking new-slots accessors ;
IN: io.launcher
+
+TUPLE: process
+
+command
+detached
+
+environment
+environment-mode
+
+stdin
+stdout
+stderr
+
+timeout
+
+handle status
+killed ;
+
+SYMBOL: +closed+
+SYMBOL: +inherit+
+SYMBOL: +stdout+
+
+SYMBOL: +prepend-environment+
+SYMBOL: +replace-environment+
+SYMBOL: +append-environment+
+
+: <process> ( -- process )
+ process construct-empty
+ H{ } clone >>environment
+ +append-environment+ >>environment-mode ;
+
+: process-started? ( process -- ? )
+ dup handle>> swap status>> or ;
+
+: process-running? ( process -- ? )
+ process-handle >boolean ;
+
! 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
+: process-started ( process handle -- )
+ >>handle
V{ } clone over processes get set-at
- dup register-process ;
+ 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+
+: pass-environment? ( process -- ? )
+ dup environment>> assoc-empty? not
+ swap environment-mode>> +replace-environment+ eq? or ;
-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 {
+: get-environment ( process -- env )
+ dup environment>>
+ swap environment-mode>> {
{ +prepend-environment+ [ os-envs union ] }
{ +append-environment+ [ os-envs swap union ] }
{ +replace-environment+ [ ] }
: 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 ;
+GENERIC: >process ( obj -- process )
+
+M: process >process
+ dup process-started? [
+ "Process has already been started once" throw
+ ] when
+ clone ;
+
+M: object >process <process> swap >>command ;
HOOK: current-process-handle io-backend ( -- handle )
-HOOK: run-process* io-backend ( desc -- handle )
+HOOK: run-process* io-backend ( process -- handle )
: wait-for-process ( process -- status )
[
- dup process-handle
+ dup handle>>
[
dup [ processes get at push ] curry
"process" suspend drop
] when
- dup process-killed?
- [ "Process was killed" throw ] [ process-status ] if
+ dup killed>>
+ [ "Process was killed" throw ] [ 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 ;
+ >process
+ dup dup run-process* process-started
+ dup timeout>> [ over set-timeout ] when* ;
+
+: run-process ( desc -- process )
+ run-detached
+ dup detached>> [ dup wait-for-process drop ] unless ;
TUPLE: process-failed code ;
: process-failed ( code -- * )
\ process-failed construct-boa throw ;
-: try-process ( desc -- )
+: try-process ( command/process -- )
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* ;
+ t >>killed
+ handle>> [ kill-process* ] when* ;
-M: process timeout process-timeout ;
+M: process timeout timeout>> ;
M: process set-timeout set-process-timeout ;
M: process timed-out kill-process ;
-HOOK: (process-stream) io-backend ( desc -- in out process )
+HOOK: (process-stream) io-backend ( process -- handle in out )
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 ;
+ >r >process dup dup (process-stream)
+ >r >r process-started process-stream construct-boa
+ r> r> <reader&writer> r> <encoder-duplex>
+ over set-delegate ;
: with-process-stream ( desc quot -- status )
swap <process-stream>
[ swap with-stream ] keep
- process-stream-process wait-for-process ; inline
+ process>> wait-for-process ; inline
-: notify-exit ( status process -- )
- [ set-process-status ] keep
+: notify-exit ( process status -- )
+ >>status
[ processes get delete-at* drop [ resume ] each ] keep
- f swap set-process-handle ;
+ f >>handle
+ drop ;
GENERIC: underlying-handle ( stream -- handle )
: kevent-proc-task ( pid -- )
dup wait-for-pid swap find-process
- dup [ notify-exit ] [ 2drop ] if ;
+ dup [ swap notify-exit ] [ 2drop ] if ;
: handle-kevent ( mx kevent -- )
dup kevent-ident swap kevent-filter {
IN: io.unix.launcher.tests
USING: io.files tools.test io.launcher arrays io namespaces
-continuations math io.encodings.ascii ;
+continuations math io.encodings.ascii io.encodings.latin1
+accessors kernel sequences ;
[ ] [
[ "launcher-test-1" temp-file delete-file ] ignore-errors
] unit-test
[ ] [
- [
- "echo Hello" +command+ set
- "launcher-test-1" temp-file +stdout+ set
- ] { } make-assoc try-process
+ <process>
+ "echo Hello" >>command
+ "launcher-test-1" temp-file >>stdout
+ try-process
] unit-test
[ "Hello\n" ] [
] unit-test
[ "" ] [
- [
+ <process>
"cat"
"launcher-test-1" temp-file
- 2array +arguments+ set
- +inherit+ +stdout+ set
-
] { } make-assoc ascii <process-stream> contents
+ 2array >>command
+ +inherit+ >>stdout
+ ascii <process-stream> contents
] unit-test
[ ] [
] unit-test
[ ] [
- [
- "cat" +command+ set
- +closed+ +stdin+ set
- "launcher-test-1" temp-file +stdout+ set
- ] { } make-assoc try-process
+ <process>
+ "cat" >>command
+ +closed+ >>stdin
+ "launcher-test-1" temp-file >>stdout
+ try-process
] unit-test
[ "" ] [
[ ] [
2 [
"launcher-test-1" temp-file ascii <file-appender> [
- [
- +stdout+ set
- "echo Hello" +command+ set
- ] { } make-assoc try-process
+ <process>
+ swap >>stdout
+ "echo Hello" >>command
+ try-process
] with-disposal
] times
] unit-test
2array
ascii <process-stream> contents
] unit-test
+
+[ t ] [
+ <process>
+ "env" >>command
+ { { "A" "B" } } >>environment
+ latin1 <process-stream> lines
+ "A=B" swap member?
+] unit-test
+
+[ { "A=B" } ] [
+ <process>
+ "env" >>command
+ { { "A" "B" } } >>environment
+ +replace-environment+ >>environment-mode
+ latin1 <process-stream> lines
+] unit-test
io.unix.files io.nonblocking sequences kernel namespaces math
system alien.c-types debugger continuations arrays assocs
combinators unix.process strings threads unix
-io.unix.launcher.parser io.encodings.latin1 ;
+io.unix.launcher.parser io.encodings.latin1 accessors new-slots ;
IN: io.unix.launcher
! Search unix first
USE: unix
-: get-arguments ( -- seq )
- +command+ get [ tokenize-command ] [ +arguments+ get ] if* ;
+: get-arguments ( process -- seq )
+ command>> dup string? [ tokenize-command ] when ;
: assoc>env ( assoc -- env )
[ "=" swap 3append ] { } assoc>map ;
: ?closed dup +closed+ eq? [ drop "/dev/null" ] when ;
-: setup-redirection ( -- )
- +stdin+ get ?closed read-flags 0 redirect
- +stdout+ get ?closed write-flags 1 redirect
- +stderr+ get dup +stdout+ eq?
+: setup-redirection ( process -- process )
+ dup stdin>> ?closed read-flags 0 redirect
+ dup stdout>> ?closed write-flags 1 redirect
+ dup stderr>> dup +stdout+ eq?
[ drop 1 2 dup2 io-error ] [ ?closed write-flags 2 redirect ] if ;
-: spawn-process ( -- )
+: spawn-process ( 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 ;
+ dup pass-environment? [
+ dup get-environment set-os-envs
+ ] when
+
+ get-arguments exec-args-with-path
+ (io-error)
+ ] [ 255 exit ] recover ;
M: unix-io current-process-handle ( -- handle ) getpid ;
-M: unix-io run-process* ( desc -- pid )
- [
- [ spawn-process ] [ ] with-fork <process>
- ] with-descriptor ;
+M: unix-io run-process* ( process -- pid )
+ [ spawn-process ] curry [ ] with-fork ;
M: unix-io kill-process* ( pid -- )
SIGTERM kill io-error ;
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 <reader&writer> r>
- ] with-descriptor ;
+ >r open-pipe open-pipe r>
+ [ >r setup-stdio-pipe r> spawn-process ] curry
+ [ -rot 2dup second close first close ]
+ with-fork
+ first swap second ;
: find-process ( handle -- process )
- processes get swap [ nip swap process-handle = ] curry
+ processes get swap [ nip swap handle>> = ] curry
assoc-find 2drop ;
! Inefficient process wait polling, used on Linux and Solaris.
2drop t
] [
find-process dup [
- >r *int WEXITSTATUS r> notify-exit f
+ swap *int WEXITSTATUS notify-exit f
] [
2drop f
] if
: process-exited ( process -- )
dup process-handle exit-code
over process-handle dispose-process
- swap notify-exit ;
+ notify-exit ;
: wait-for-processes ( processes -- ? )
keys dup
inspector layouts vocabs.loader prettyprint.config prettyprint
debugger io.streams.c io.streams.duplex io.files io.backend
quotations io.launcher words.private tools.deploy.config
-bootstrap.image io.encodings.utf8 ;
+bootstrap.image io.encodings.utf8 accessors ;
IN: tools.deploy.backend
: (copy-lines) ( stream -- )
[ (copy-lines) ] with-disposal ;
: run-with-output ( arguments -- )
- [
- +arguments+ set
- +stdout+ +stderr+ set
- ] H{ } make-assoc utf8 <process-stream>
- dup duplex-stream-out dispose
+ <process>
+ swap >>command
+ +stdout+ >>stderr
+ +closed+ >>stdin
+ utf8 <process-stream>
dup copy-lines
process-stream-process wait-for-process zero? [
"Deployment failed" throw
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io words alien kernel math.parser alien.syntax
io.launcher system assocs arrays sequences namespaces qualified
-system math generator.fixup io.encodings.ascii ;
+system math generator.fixup io.encodings.ascii accessors ;
IN: tools.disassembler
: in-file "gdb-in.txt" temp-file ;
] with-file-writer ;
: run-gdb ( -- lines )
- [
- +closed+ +stdin+ set
- out-file +stdout+ set
- [ "gdb" , "-x" , in-file , "-batch" , ] { } make +arguments+ set
- ] { } make-assoc try-process
+ <process>
+ +closed+ >>stdin
+ out-file >>stdout
+ [ "gdb" , "-x" , in-file , "-batch" , ] { } make >>command
+ try-process
out-file ascii file-lines ;
: tabs>spaces ( str -- str' )
dpush(result);
}
+DEFINE_PRIMITIVE(set_os_envs)
+{
+ F_ARRAY *array = untag_array(dpop());
+ CELL size = array_capacity(array);
+
+ /* Memory leak */
+ char **env = calloc(size + 1,sizeof(CELL));
+
+ CELL i;
+ for(i = 0; i < size; i++)
+ {
+ F_STRING *string = untag_string(array_nth(array,i));
+ CELL length = to_fixnum(string->length);
+
+ char *chars = malloc(length + 1);
+ char_string_to_memory(string,chars);
+ chars[length] = '\0';
+ env[i] = chars;
+ }
+
+ environ = env;
+}
+
F_SEGMENT *alloc_segment(CELL size)
{
int pagesize = getpagesize();
{
Sleep(msec);
}
+
+DECLARE_PRIMITIVE(set_os_envs)
+{
+ not_implemented_error();
+}
primitive_set_innermost_stack_frame_quot,
primitive_call_clear,
primitive_os_envs,
+ primitive_set_os_envs,
primitive_resize_byte_array,
primitive_resize_bit_array,
primitive_resize_float_array,
DECLARE_PRIMITIVE(exit);
DECLARE_PRIMITIVE(os_env);
DECLARE_PRIMITIVE(os_envs);
+DECLARE_PRIMITIVE(set_os_envs);
DECLARE_PRIMITIVE(eq);
DECLARE_PRIMITIVE(millis);
DECLARE_PRIMITIVE(sleep);
projects / factor.git / commitdiff