Launcher now uses new-slots; fix Windows environment passing bug

extra/io/launcher/authors.txt

@@ -1 +1,2 @@
 Doug Coleman
+Slava Pestov

extra/io/launcher/launcher-docs.factor

@@ -64,7 +64,7 @@ $nl
 "This is used in situations where you want a spawn child process with some overridden environment variables." } ;
 
 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." } ;
+"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" } }
@@ -147,14 +147,17 @@ $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."
+"A freshly instantiated " { $link process } " represents a set of launch parameters."
-{ $link process-started? }
+{ $subsection process }
+{ $subsection <process> }
+"Words for launching processes take a fresh process which has never been started before as input, and output a copy as output."
+{ $subsection 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? }
+{ $subsection process-running? }
 "It is possible to wait for a process to exit:"
-{ $link wait-for-process }
+{ $subsection wait-for-process }
 "A running process can also be killed:"
-{ $link kill-process } ;
+{ $subsection kill-process } ;
 
 ARTICLE: "io.launcher.launch" "Launching processes"
 "Launching processes:"
@@ -164,8 +167,47 @@ ARTICLE: "io.launcher.launch" "Launching processes"
 { $subsection <process-stream> }
 { $subsection with-process-stream } ;
 
+ARTICLE: "io.launcher.examples" "Launcher examples"
+"Starting a command and waiting for it to finish:"
+{ $code
+    "\"ls /etc\" run-process"
+}
+"Starting a program in the background:"
+{ $code
+    "{ \"emacs\" \"foo.txt\" } run-detached"
+}
+"Running a command, throwing an exception if it exits unsuccessfully:"
+{ $code
+    "\"make clean all\" try-process"
+}
+"Running a command, throwing an exception if it exits unsuccessfully or if it takes too long to run:"
+{ $code
+    "<process>"
+    "    \"make test\" >>command"
+    "    5 minutes >>timeout"
+    "try-process"
+}
+"Running a command, throwing an exception if it exits unsuccessfully, and redirecting output and error messages to a log file:"
+{ $code
+    "<process>"
+    "    \"make clean all\" >>command"
+    "    \"log.txt\" >>stdout"
+    "    +stdout+ >>stderr"
+    "try-process"
+}
+"Running a command, appending error messages to a log file, and reading the output for further processing:"
+{ $code
+    "\"log.txt\" <file-appender> ["
+    "    <process>"
+    "        swap >>stderr"
+    "        \"report\" >>command"
+    "    ascii <process-stream> lines sort reverse [ print ] each"
+    "] with-disposal"
+} ;
+
 ARTICLE: "io.launcher" "Operating system processes"
 "The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
+{ $subsection "io.launcher.examples" }
 { $subsection "io.launcher.descriptors" }
 { $subsection "io.launcher.launch" }
 "Advanced topics:"

extra/io/windows/launcher/launcher.factor

@@ -69,27 +69,26 @@ TUPLE: CreateProcess-args
 
 : fill-dwCreateFlags ( process args -- process args )
     0
-    over pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
+    pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
-    over detached>> winnt? and [ DETACHED_PROCESS bitor ] when
+    pick detached>> winnt? and [ DETACHED_PROCESS bitor ] when
     >>dwCreateFlags ;
 
 : fill-lpEnvironment ( process args -- process args )
     over pass-environment? [
         [
             over get-environment
-            [ "=" swap 3append string>u16-alien % ] assoc-each
+            [ swap % "=" % % "\0" % ] assoc-each
             "\0" %
-        ] { } make >c-ushort-array
+        ] "" make >c-ushort-array
         >>lpEnvironment
     ] when ;
 
 : fill-startup-info ( process args -- process args )
-    dup lpStartupInfo>>
+    STARTF_USESTDHANDLES over lpStartupInfo>> set-STARTUPINFO-dwFlags ;
-    STARTF_USESTDHANDLES swap set-STARTUPINFO-dwFlags ;
 
-HOOK: fill-redirection io-backend ( process args -- process args )
+HOOK: fill-redirection io-backend ( process args -- )
 
-M: windows-ce-io fill-redirection ;
+M: windows-ce-io fill-redirection 2drop ;
 
 : make-CreateProcess-args ( process -- args )
     default-CreateProcess-args
@@ -102,14 +101,12 @@ M: windows-ce-io fill-redirection ;
 M: windows-io current-process-handle ( -- handle )
     GetCurrentProcessId ;
 
-M: windows-io run-process* ( desc -- handle )
+M: windows-io run-process* ( process -- handle )
     [
-        [
+        dup make-CreateProcess-args
-            make-CreateProcess-args
+        tuck fill-redirection
-            fill-redirection
+        dup call-CreateProcess
-            dup call-CreateProcess
+        lpProcessInformation>>
-            CreateProcess-args-lpProcessInformation
-        ] with-descriptor
     ] with-destructors ;
 
 M: windows-io kill-process* ( handle -- )

extra/io/windows/nt/launcher/launcher-tests.factor

@@ -0,0 +1,131 @@
+IN: io.windows.launcher.nt.tests
+USING: io.launcher tools.test calendar accessors
+namespaces kernel system arrays io io.files io.encodings.ascii
+sequences parser assocs hashtables ;
+
+[ ] [
+    <process>
+        "notepad" >>command
+        1/2 seconds >>timeout
+    "notepad" set
+] unit-test
+
+[ f ] [ "notepad" get process-running? ] unit-test
+
+[ f ] [ "notepad" get process-started? ] unit-test
+
+[ ] [ "notepad" [ run-detached ] change ] unit-test
+
+[ "notepad" get wait-for-process ] must-fail
+
+[ t ] [ "notepad" get killed>> ] unit-test
+
+[ f ] [ "notepad" get process-running? ] unit-test
+
+[ ] [
+    <process>
+        vm "-quiet" "-run=hello-world" 3array >>command
+        "out.txt" temp-file >>stdout
+    try-process
+] unit-test
+
+[ "Hello world" ] [
+    "out.txt" temp-file ascii file-lines first
+] unit-test
+
+[ ] [
+    <process>
+        vm "-run=listener" 2array >>command
+        +closed+ >>stdin
+    try-process
+] unit-test
+
+[ ] [
+    "extra/io/windows/nt/launcher/test" resource-path [
+        <process>
+            vm "-script" "stderr.factor" 3array >>command
+            "out.txt" temp-file >>stdout
+            "err.txt" temp-file >>stderr
+        try-process
+    ] with-directory
+] unit-test
+
+[ "output" ] [
+    "out.txt" temp-file ascii file-lines first
+] unit-test
+
+[ "error" ] [
+    "err.txt" temp-file ascii file-lines first
+] unit-test
+
+[ ] [
+    "extra/io/windows/nt/launcher/test" resource-path [
+        <process>
+            vm "-script" "stderr.factor" 3array >>command
+            "out.txt" temp-file >>stdout
+            +stdout+ >>stderr
+        try-process
+    ] with-directory
+] unit-test
+
+[ "outputerror" ] [
+    "out.txt" temp-file ascii file-lines first
+] unit-test
+
+[ "output" ] [
+    "extra/io/windows/nt/launcher/test" resource-path [
+        <process>
+            vm "-script" "stderr.factor" 3array >>command
+            "err2.txt" temp-file >>stderr
+        ascii <process-stream> lines first
+    ] with-directory
+] unit-test
+
+[ "error" ] [
+    "err2.txt" temp-file ascii file-lines first
+] unit-test
+
+[ t ] [
+    "extra/io/windows/nt/launcher/test" resource-path [
+        <process>
+            vm "-script" "env.factor" 3array >>command
+        ascii <process-stream> contents
+    ] with-directory eval
+
+    os-envs =
+] unit-test
+
+[ t ] [
+    "extra/io/windows/nt/launcher/test" resource-path [
+        <process>
+            vm "-script" "env.factor" 3array >>command
+            +replace-environment+ >>environment-mode
+            os-envs >>environment
+        ascii <process-stream> contents
+    ] with-directory eval
+    
+    os-envs =
+] unit-test
+
+[ "B" ] [
+    "extra/io/windows/nt/launcher/test" resource-path [
+        <process>
+            vm "-script" "env.factor" 3array >>command
+            { { "A" "B" } } >>environment
+        ascii <process-stream> contents
+    ] with-directory eval
+
+    "A" swap at
+] unit-test
+
+[ f ] [
+    "extra/io/windows/nt/launcher/test" resource-path [
+        <process>
+            vm "-script" "env.factor" 3array >>command
+            { { "HOME" "XXX" } } >>environment
+            +prepend-environment+ >>environment-mode
+        ascii <process-stream> contents
+    ] with-directory eval
+
+    "HOME" swap at "XXX" =
+] unit-test

extra/io/windows/nt/launcher/launcher.factor

@@ -5,7 +5,7 @@ io.windows libc io.nonblocking io.streams.duplex windows.types
 math windows.kernel32 windows namespaces io.launcher kernel
 sequences windows.errors assocs splitting system strings
 io.windows.launcher io.windows.nt.pipes io.backend
-combinators shuffle ;
+combinators shuffle accessors locals ;
 IN: io.windows.nt.launcher
 
 : duplicate-handle ( handle -- handle' )
@@ -31,13 +31,12 @@ IN: io.windows.nt.launcher
 : redirect-closed ( default obj access-mode create-mode -- handle )
     drop 2nip null-pipe ;
 
-: redirect-file ( default path access-mode create-mode -- handle )
+:: redirect-file ( default path access-mode create-mode -- handle )
-    >r >r >r drop r>
+    path normalize-pathname
-    normalize-pathname
+    access-mode
-    r> ! access-mode
     share-mode
     security-attributes-inherit
-    r> ! create-mode
+    create-mode
     FILE_ATTRIBUTE_NORMAL ! flags and attributes
     f ! template file
     CreateFile dup invalid-handle? dup close-later ;
@@ -60,24 +59,25 @@ IN: io.windows.nt.launcher
     } cond ;
 
 : default-stdout ( args -- handle )
-    CreateProcess-args-stdout-pipe dup [ pipe-out ] when ;
+    stdout-pipe>> dup [ pipe-out ] when ;
 
-: redirect-stdout ( args -- handle )
+: redirect-stdout ( process args -- handle )
     default-stdout
-    +stdout+ get
+    swap stdout>>
     GENERIC_WRITE
     CREATE_ALWAYS
     redirect
     STD_OUTPUT_HANDLE GetStdHandle or ;
 
-: redirect-stderr ( args -- handle )
+: redirect-stderr ( process args -- handle )
-    +stderr+ get +stdout+ eq? [
+    over stderr>> +stdout+ eq? [
-        CreateProcess-args-lpStartupInfo
+        lpStartupInfo>>
         STARTUPINFO-hStdOutput
+        nip
     ] [
         drop
         f
-        +stderr+ get
+        swap stderr>>
         GENERIC_WRITE
         CREATE_ALWAYS
         redirect
@@ -85,11 +85,11 @@ IN: io.windows.nt.launcher
     ] if ;
 
 : default-stdin ( args -- handle )
-    CreateProcess-args-stdin-pipe dup [ pipe-in ] when ;
+    stdin-pipe>> dup [ pipe-in ] when ;
 
-: redirect-stdin ( args -- handle )
+: redirect-stdin ( process args -- handle )
     default-stdin
-    +stdin+ get
+    swap stdin>>
     GENERIC_READ
     OPEN_EXISTING
     redirect
@@ -97,48 +97,42 @@ IN: io.windows.nt.launcher
 
 : add-pipe-dtors ( pipe -- )
     dup
-    pipe-in close-later
+    in>> close-later
-    pipe-out close-later ;
+    out>> close-later ;
 
-: fill-stdout-pipe
+: fill-stdout-pipe ( args -- args )
     <unique-incoming-pipe>
     dup add-pipe-dtors
     dup pipe-in f set-inherit
-    over set-CreateProcess-args-stdout-pipe ;
+    >>stdout-pipe ;
 
-: fill-stdin-pipe
+: fill-stdin-pipe ( args -- args )
     <unique-outgoing-pipe>
     dup add-pipe-dtors
     dup pipe-out f set-inherit
-    over set-CreateProcess-args-stdin-pipe ;
+    >>stdin-pipe ;
 
-M: windows-nt-io fill-redirection
+M: windows-nt-io fill-redirection ( process args -- )
-    dup CreateProcess-args-lpStartupInfo
+    [ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput
-    over redirect-stdout over set-STARTUPINFO-hStdOutput
+    [ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError
-    over redirect-stderr over set-STARTUPINFO-hStdError
+    [ 2dup redirect-stdin  ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput
-    over redirect-stdin over set-STARTUPINFO-hStdInput
+    2drop ;
-    drop ;
 
 M: windows-nt-io (process-stream)
     [
-        [
+        dup make-CreateProcess-args
-            make-CreateProcess-args
 
-            fill-stdout-pipe
+        fill-stdout-pipe
-            fill-stdin-pipe
+        fill-stdin-pipe
 
-            fill-redirection
+        tuck fill-redirection
 
-            dup call-CreateProcess
+        dup call-CreateProcess
 
-            dup CreateProcess-args-stdin-pipe pipe-in CloseHandle drop
+        dup stdin-pipe>> pipe-in CloseHandle drop
-            dup CreateProcess-args-stdout-pipe pipe-out CloseHandle drop
+        dup stdout-pipe>> pipe-out CloseHandle drop
 
-            dup CreateProcess-args-stdout-pipe pipe-in
+        dup lpProcessInformation>>
-            over CreateProcess-args-stdin-pipe pipe-out
+        over stdout-pipe>> in>> f <win32-file>
-
+        rot stdin-pipe>> out>> f <win32-file>
-            [ f <win32-file> ] 2apply <reader&writer>
+    ] with-destructors ;
-
-            rot CreateProcess-args-lpProcessInformation <process>
-        ] with-destructors
-    ] with-descriptor ;

extra/io/windows/nt/launcher/test/env.factor

@@ -0,0 +1,3 @@
+USE: system
+USE: prettyprint
+os-envs .

extra/io/windows/nt/launcher/test/stderr.factor

@@ -0,0 +1,5 @@
+USE: io
+USE: namespaces
+
+"output" write flush
+"error" stderr get stream-write stderr get stream-flush

extra/io/windows/nt/pipes/pipes.factor

@@ -3,7 +3,7 @@
 USING: alien alien.c-types arrays destructors io io.windows libc
 windows.types math windows.kernel32 windows namespaces kernel
 sequences windows.errors assocs math.parser system random
-combinators ;
+combinators new-slots accessors ;
 IN: io.windows.nt.pipes
 
 ! This code is based on
@@ -42,8 +42,8 @@ TUPLE: pipe in out ;
 
 : close-pipe ( pipe -- )
     dup
-    pipe-in CloseHandle drop
+    in>> CloseHandle drop
-    pipe-out CloseHandle drop ;
+    out>> CloseHandle drop ;
 
 : <incoming-pipe> ( name -- pipe )
     PIPE_ACCESS_INBOUND GENERIC_WRITE <pipe> ;
@@ -70,13 +70,13 @@ TUPLE: pipe in out ;
 ! /dev/null simulation
 : null-input ( -- pipe )
     <unique-outgoing-pipe>
-    dup pipe-out CloseHandle drop
+    dup out>> CloseHandle drop
-    pipe-in ;
+    in>> ;
 
 : null-output ( -- pipe )
     <unique-incoming-pipe>
-    dup pipe-in CloseHandle drop
+    dup in>> CloseHandle drop
-    pipe-out ;
+    out>> ;
 
 : null-pipe ( mode -- pipe )
     {