use radix literals

[factor.git] / basis / io / launcher / windows / windows.factor

diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor
index 0b58df2e43603fb1777e8a90a18827a8b0831195..012de73be71e39b47bdf5fe54826d5022e97cf5d 100755 (executable)
--- a/basis/io/launcher/windows/windows.factor
+++ b/basis/io/launcher/windows/windows.factor
@@ -6,9 +6,9 @@ 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
+specialized-arrays splitting splitting.monotonic
 strings system threads windows windows.errors windows.handles
-windows.kernel32 windows.types ;
+windows.kernel32 windows.types combinators.short-circuit ;
 SPECIALIZED-ARRAY: ushort
 SPECIALIZED-ARRAY: void*
 IN: io.launcher.windows
@@ -28,7 +28,7 @@ TUPLE: CreateProcess-args
 : default-CreateProcess-args ( -- obj )
     CreateProcess-args new
         STARTUPINFO <struct>
-        dup class heap-size >>cb
+        dup class-of heap-size >>cb
     >>lpStartupInfo
     PROCESS_INFORMATION <struct> >>lpProcessInformation
     TRUE >>bInheritHandles
@@ -58,7 +58,28 @@ TUPLE: CreateProcess-args
     0 count-trailing-backslashes
     2 * CHAR: \\ <repetition> append ;
 
+! Find groups of \, groups of \ followed by ", or naked "
+: escape-double-quote ( str -- newstr )
+    [
+        { [ drop CHAR: \ = ] [ nip "\\\"" member? ] } 2&&
+    ] monotonic-split [
+        dup last CHAR: " = [
+            dup length 1 > [
+                ! String of backslashes + double-quote
+                length 1 - 2 * CHAR: \ <repetition> "\\\"" append
+            ] [
+                ! Single double-quote
+                drop "\\\""
+            ] if
+        ] when
+    ] map "" concat-as ;
+
+! Naked double-quotes get a backslash before them
+! Backslashes before a double-quote get doubled in the output
+! If there's a space, double trailing backslashes and surround by quotes
+! See http://msdn.microsoft.com/en-us/library/ms647232.aspx
 : escape-argument ( str -- newstr )
+    escape-double-quote
     CHAR: \s over member? [
         fix-trailing-backslashes "\"" dup surround
     ] when ;
@@ -77,27 +98,16 @@ TUPLE: CreateProcess-args
         [ drop f ]
     } case ;
 
-: app-name/cmd-line ( process -- app-name cmd-line )
-    command>> dup string? [
-        " " split1
-    ] [
-        unclip swap join-arguments
-    ] if ;
-
 : cmd-line ( process -- cmd-line )
     command>> dup string? [ join-arguments ] unless ;
 
-: fill-lpApplicationName ( process args -- process args )
-    over app-name/cmd-line
-    [ >>lpApplicationName ] [ >>lpCommandLine ] bi* ;
-
 : fill-lpCommandLine ( process args -- process args )
     over cmd-line >>lpCommandLine ;
 
 : fill-dwCreateFlags ( process args -- process args )
     0
     pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
-    pick detached>> os winnt? and [ DETACHED_PROCESS bitor ] when
+    pick detached>> os windows? and [ DETACHED_PROCESS bitor ] when
     pick lookup-priority [ bitor ] when*
     >>dwCreateFlags ;
 
@@ -114,13 +124,9 @@ TUPLE: CreateProcess-args
 : fill-startup-info ( process args -- process args )
     dup lpStartupInfo>> STARTF_USESTDHANDLES >>dwFlags drop ;
 
-HOOK: fill-redirection io-backend ( process args -- )
-
-M: wince fill-redirection 2drop ;
-
 : make-CreateProcess-args ( process -- args )
     default-CreateProcess-args
-    os wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
+    fill-lpCommandLine
     fill-dwCreateFlags
     fill-lpEnvironment
     fill-startup-info
@@ -137,20 +143,8 @@ M: launch-error error.
     "Launch descriptor:" print nl
     process>> . ;
 
-M: windows run-process* ( process -- handle )
-    [
-        [
-            current-directory get absolute-path cd
-    
-            dup make-CreateProcess-args
-            [ fill-redirection ] keep
-            dup call-CreateProcess
-            lpProcessInformation>>
-        ] with-destructors
-    ] [ launch-error ] recover ;
-
-M: windows kill-process* ( handle -- )
-    hProcess>> 255 TerminateProcess win32-error=0/f ;
+M: windows kill-process* ( process -- )
+    handle>> hProcess>> 255 TerminateProcess win32-error=0/f ;
 
 : dispose-process ( process-information -- )
     #! From MSDN: "Handles in PROCESS_INFORMATION must be closed
@@ -173,19 +167,19 @@ M: windows wait-for-processes ( -- ? )
     [ handle>> hProcess>> ] void*-array{ } map-as
     [ length ] keep 0 0
     WaitForMultipleObjects
-    dup HEX: ffffffff = [ win32-error ] when
+    dup 0xffffffff = [ win32-error ] when
     dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
 
 : duplicate-handle ( handle -- handle' )
     GetCurrentProcess ! source process
     swap handle>> ! handle
     GetCurrentProcess ! target process
-    f <void*> [ ! target handle
+    f void* <ref> [ ! target handle
         DUPLICATE_SAME_ACCESS ! desired access
         TRUE ! inherit handle
         0 ! options
         DuplicateHandle win32-error=0/f
-    ] keep *void* <win32-handle> &dispose ;
+    ] keep void* deref <win32-handle> &dispose ;
 
 ! /dev/null simulation
 : null-input ( -- pipe )
@@ -270,9 +264,21 @@ M: windows wait-for-processes ( -- ? )
     OPEN_EXISTING
     redirect
     STD_INPUT_HANDLE GetStdHandle or ;
-
-M: winnt fill-redirection ( process args -- )
+    
+: 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 )
+    [
+        [
+            current-directory get absolute-path cd
+    
+            dup make-CreateProcess-args
+            [ fill-redirection ] keep
+            dup call-CreateProcess
+            lpProcessInformation>>
+        ] with-destructors
+    ] [ launch-error ] recover ;