1 ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: alien alien.c-types arrays continuations io
4 io.backend.windows io.pipes.windows.nt io.pathnames libc io.ports
5 windows.types math windows.kernel32
6 namespaces make io.launcher kernel sequences windows.errors
7 splitting system threads init strings combinators
8 io.backend accessors concurrency.flags io.files assocs
9 io.files.private windows destructors specialized-arrays.ushort
10 specialized-arrays.alien classes classes.struct ;
11 IN: io.launcher.windows
13 TUPLE: CreateProcess-args
23 lpProcessInformation ;
25 : default-CreateProcess-args ( -- obj )
26 CreateProcess-args new
28 dup class heap-size >>cb
30 PROCESS_INFORMATION <struct> >>lpProcessInformation
31 TRUE >>bInheritHandles
34 : call-CreateProcess ( CreateProcess-args -- )
36 [ lpApplicationName>> ]
38 [ lpProcessAttributes>> ]
39 [ lpThreadAttributes>> ]
43 [ lpCurrentDirectory>> ]
45 [ lpProcessInformation>> ]
47 CreateProcess win32-error=0/f ;
49 : count-trailing-backslashes ( str n -- str n )
50 [ "\\" ?tail ] dip swap [
51 1 + count-trailing-backslashes
54 : fix-trailing-backslashes ( str -- str' )
55 0 count-trailing-backslashes
56 2 * CHAR: \\ <repetition> append ;
58 : escape-argument ( str -- newstr )
59 CHAR: \s over member? [
60 fix-trailing-backslashes "\"" dup surround
63 : join-arguments ( args -- cmd-line )
64 [ escape-argument ] map " " join ;
66 : lookup-priority ( process -- n )
68 { +lowest-priority+ [ IDLE_PRIORITY_CLASS ] }
69 { +low-priority+ [ BELOW_NORMAL_PRIORITY_CLASS ] }
70 { +normal-priority+ [ NORMAL_PRIORITY_CLASS ] }
71 { +high-priority+ [ ABOVE_NORMAL_PRIORITY_CLASS ] }
72 { +highest-priority+ [ HIGH_PRIORITY_CLASS ] }
73 { +realtime-priority+ [ REALTIME_PRIORITY_CLASS ] }
77 : app-name/cmd-line ( process -- app-name cmd-line )
78 command>> dup string? [
81 unclip swap join-arguments
84 : cmd-line ( process -- cmd-line )
85 command>> dup string? [ join-arguments ] unless ;
87 : fill-lpApplicationName ( process args -- process args )
88 over app-name/cmd-line
89 [ >>lpApplicationName ] [ >>lpCommandLine ] bi* ;
91 : fill-lpCommandLine ( process args -- process args )
92 over cmd-line >>lpCommandLine ;
94 : fill-dwCreateFlags ( process args -- process args )
96 pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
97 pick detached>> os winnt? and [ DETACHED_PROCESS bitor ] when
98 pick lookup-priority [ bitor ] when*
101 : fill-lpEnvironment ( process args -- process args )
102 over pass-environment? [
105 [ swap % "=" % % "\0" % ] assoc-each
107 ] ushort-array{ } make
111 : fill-startup-info ( process args -- process args )
112 dup lpStartupInfo>> STARTF_USESTDHANDLES >>dwFlags drop ;
114 HOOK: fill-redirection io-backend ( process args -- )
116 M: wince fill-redirection 2drop ;
118 : make-CreateProcess-args ( process -- args )
119 default-CreateProcess-args
120 os wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
126 M: windows current-process-handle ( -- handle )
127 GetCurrentProcessId ;
129 M: windows run-process* ( process -- handle )
131 current-directory get (normalize-path) cd
133 dup make-CreateProcess-args
134 tuck fill-redirection
135 dup call-CreateProcess
136 lpProcessInformation>>
139 M: windows kill-process* ( handle -- )
140 hProcess>> 255 TerminateProcess win32-error=0/f ;
142 : dispose-process ( process-information -- )
143 #! From MSDN: "Handles in PROCESS_INFORMATION must be closed
144 #! with CloseHandle when they are no longer needed."
145 [ hProcess>> [ CloseHandle drop ] when* ]
146 [ hThread>> [ CloseHandle drop ] when* ] bi ;
148 : exit-code ( process -- n )
150 0 <ulong> [ GetExitCodeProcess ] keep *ulong
151 swap win32-error=0/f ;
153 : process-exited ( process -- )
154 dup handle>> exit-code
155 over handle>> dispose-process
158 M: windows wait-for-processes ( -- ? )
159 processes get keys dup
160 [ handle>> hProcess>> ] void*-array{ } map-as
162 WaitForMultipleObjects
163 dup HEX: ffffffff = [ win32-error ] when
164 dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;