Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2009 Matthew Fluet. |
2 | * Copyright (C) 2002-2008 Henry Cejtin, Matthew Fluet, Suresh | |
3 | * Jagannathan, and Stephen Weeks. | |
4 | * | |
5 | * MLton is released under a BSD-style license. | |
6 | * See the file MLton-LICENSE for details. | |
7 | *) | |
8 | ||
9 | structure MLtonProcess = | |
10 | struct | |
11 | structure Prim = PrimitiveFFI.MLton.Process | |
12 | structure MLton = Primitive.MLton | |
13 | local | |
14 | open Posix | |
15 | in | |
16 | structure FileSys = FileSys | |
17 | structure IO = IO | |
18 | structure ProcEnv = ProcEnv | |
19 | structure Process = Process | |
20 | structure FileDesc = PrePosix.FileDesc | |
21 | structure PId = PrePosix.PId | |
22 | structure Signal = PrePosix.Signal | |
23 | end | |
24 | structure Mask = MLtonSignal.Mask | |
25 | structure SysCall = PosixError.SysCall | |
26 | ||
27 | type pid = PId.t | |
28 | ||
29 | exception MisuseOfForget | |
30 | exception DoublyRedirected | |
31 | ||
32 | type input = unit | |
33 | type output = unit | |
34 | ||
35 | type none = unit | |
36 | type chain = unit | |
37 | type any = unit | |
38 | ||
39 | val useWindowsProcess = MLton.Platform.OS.useWindowsProcess | |
40 | ||
41 | val readWrite = | |
42 | let | |
43 | open FileSys.S | |
44 | in | |
45 | flags [irusr, iwusr, irgrp, iwgrp, iroth, iwoth] | |
46 | end | |
47 | ||
48 | structure Child = | |
49 | struct | |
50 | datatype 'use childt = | |
51 | FileDesc of FileSys.file_desc | |
52 | | Stream of 'use * ('use -> unit) | |
53 | | Term | |
54 | type ('use, 'dir) t = 'use childt ref | |
55 | ||
56 | (* This is _not_ the identity; by rebuilding it we get type | |
57 | * ('a, 'b) t -> ('c, 'd) t | |
58 | *) | |
59 | fun remember x = | |
60 | case !x of | |
61 | FileDesc f => | |
62 | (x := Stream ((), fn () => ()) | |
63 | ; ref (FileDesc f)) | |
64 | | Stream _ => raise MisuseOfForget (* remember twice = bad *) | |
65 | | Term => ref Term | |
66 | ||
67 | local | |
68 | fun convert (new, close) p = | |
69 | case !p of | |
70 | FileDesc fd => | |
71 | let | |
72 | val str = new (fd, "<process>") | |
73 | val () = p := Stream (str, close) | |
74 | in | |
75 | str | |
76 | end | |
77 | | Stream (str, _) => str | |
78 | | Term => raise MisuseOfForget | |
79 | in | |
80 | val binIn = convert (BinIO.newIn, BinIO.closeIn) | |
81 | val binOut = convert (BinIO.newOut, BinIO.closeOut) | |
82 | val textIn = convert (TextIO.newIn, TextIO.closeIn) | |
83 | val textOut = convert (TextIO.newOut, TextIO.closeOut) | |
84 | end | |
85 | ||
86 | fun fd p = | |
87 | case !p of | |
88 | FileDesc fd => fd | |
89 | | _ => raise MisuseOfForget | |
90 | ||
91 | fun close ch = | |
92 | case ch of | |
93 | FileDesc fd => IO.close fd | |
94 | | Stream (str, close) => close str | |
95 | | Term => () | |
96 | ||
97 | val close = | |
98 | fn (stdin, stdout, stderr) => | |
99 | (close stdin; close stdout; close stderr) | |
100 | end | |
101 | ||
102 | structure Param = | |
103 | struct | |
104 | datatype ('use, 'dir) t = | |
105 | File of string | |
106 | | FileDesc of FileSys.file_desc | |
107 | | Pipe | |
108 | | Self | |
109 | ||
110 | (* This is _not_ the identity; by rebuilding it we get type | |
111 | * ('a, 'b) t -> ('c, 'd) t | |
112 | *) | |
113 | val forget = fn | |
114 | File x => File x | |
115 | | FileDesc f => FileDesc f | |
116 | | Pipe => Pipe | |
117 | | Self => Self | |
118 | ||
119 | val pipe = Pipe | |
120 | local | |
121 | val null = if useWindowsProcess then "nul" else "/dev/null" | |
122 | in | |
123 | val null = File null | |
124 | end | |
125 | val self = Self | |
126 | fun file f = File f | |
127 | fun fd f = FileDesc f | |
128 | ||
129 | fun child c = | |
130 | FileDesc | |
131 | (case !c of | |
132 | Child.FileDesc f => (c := Child.Stream ((), fn () => ()); f) | |
133 | | Child.Stream _ => raise DoublyRedirected | |
134 | | Child.Term => raise MisuseOfForget) | |
135 | ||
136 | fun setCloseExec fd = | |
137 | if useWindowsProcess | |
138 | then () | |
139 | else IO.setfd (fd, IO.FD.flags [IO.FD.cloexec]) | |
140 | ||
141 | local | |
142 | fun openOut std p = | |
143 | case p of | |
144 | File s => (FileSys.creat (s, readWrite), Child.Term) | |
145 | | FileDesc f => (f, Child.Term) | |
146 | | Pipe => | |
147 | let | |
148 | val {infd, outfd} = IO.pipe () | |
149 | val () = setCloseExec infd | |
150 | in | |
151 | (outfd, Child.FileDesc infd) | |
152 | end | |
153 | | Self => (std, Child.Term) | |
154 | in | |
155 | fun openStdout p = openOut FileSys.stdout p | |
156 | fun openStderr p = openOut FileSys.stderr p | |
157 | end | |
158 | ||
159 | fun openStdin p = | |
160 | case p of | |
161 | File s => | |
162 | (FileSys.openf (s, FileSys.O_RDONLY, FileSys.O.flags []), | |
163 | Child.Term) | |
164 | | FileDesc f => (f, Child.Term) | |
165 | | Pipe => | |
166 | let | |
167 | val {infd, outfd} = IO.pipe () | |
168 | val () = setCloseExec outfd | |
169 | in | |
170 | (infd, Child.FileDesc outfd) | |
171 | end | |
172 | | Self => (FileSys.stdin, Child.Term) | |
173 | ||
174 | fun close p fd = | |
175 | case p of | |
176 | File _ => IO.close fd | |
177 | | FileDesc _ => IO.close fd | |
178 | | Pipe => IO.close fd | |
179 | | _ => () | |
180 | end | |
181 | ||
182 | datatype ('stdin, 'stdout, 'stderr) t = | |
183 | T of {pid: Process.pid, (* if useWindowsProcess, | |
184 | * then this is a Windows process handle | |
185 | * and can't be passed to | |
186 | * Posix.Process.* functions. | |
187 | *) | |
188 | status: Posix.Process.exit_status option ref, | |
189 | stderr: ('stderr, input) Child.t, | |
190 | stdin: ('stdin, output) Child.t, | |
191 | stdout: ('stdout, input) Child.t} | |
192 | ||
193 | local | |
194 | fun make f (T r) = f r | |
195 | in | |
196 | val getStderr = fn z => make #stderr z | |
197 | val getStdin = fn z => make #stdin z | |
198 | val getStdout = fn z => make #stdout z | |
199 | end | |
200 | ||
201 | fun ('a, 'b) protect (f: 'a -> 'b, x: 'a): 'b = | |
202 | let | |
203 | val () = Mask.block Mask.all | |
204 | in | |
205 | DynamicWind.wind (fn () => f x, fn () => Mask.unblock Mask.all) | |
206 | end | |
207 | ||
208 | local | |
209 | fun reap reapFn (T {pid, status, stderr, stdin, stdout, ...}) = | |
210 | case !status of | |
211 | NONE => | |
212 | let | |
213 | val _ = Child.close (!stdin, !stdout, !stderr) | |
214 | val st = reapFn pid | |
215 | in | |
216 | status := SOME st | |
217 | ; st | |
218 | end | |
219 | | SOME st => st | |
220 | in | |
221 | fun reapForFork p = | |
222 | reap (fn pid => | |
223 | let | |
224 | (* protect is probably too much; typically, one | |
225 | * would only mask SIGINT, SIGQUIT and SIGHUP. | |
226 | *) | |
227 | val (_, st) = | |
228 | protect (Process.waitpid, (Process.W_CHILD pid, [])) | |
229 | in | |
230 | st | |
231 | end) | |
232 | p | |
233 | fun reapForCreate p = | |
234 | reap (fn pid => | |
235 | let | |
236 | val pid' = PId.toRep pid | |
237 | val status' = ref (C_Status.fromInt 0) | |
238 | val () = | |
239 | SysCall.simple | |
240 | (fn () => | |
241 | PrimitiveFFI.Windows.Process.getexitcode | |
242 | (pid', status')) | |
243 | in | |
244 | Process.fromStatus' (!status') | |
245 | end) | |
246 | p | |
247 | end | |
248 | val reap = fn p => | |
249 | (if useWindowsProcess then reapForCreate else reapForFork) p | |
250 | ||
251 | local | |
252 | fun kill killFn (p as T {pid, status, ...}, signal) = | |
253 | case !status of | |
254 | NONE => | |
255 | let | |
256 | val () = killFn (pid, signal) | |
257 | in | |
258 | ignore (reap p) | |
259 | end | |
260 | | SOME _ => () | |
261 | in | |
262 | fun killForFork p = | |
263 | kill (fn (pid, signal) => | |
264 | Process.kill (Process.K_PROC pid, signal)) | |
265 | p | |
266 | fun killForCreate p = | |
267 | kill (fn (pid, signal) => | |
268 | SysCall.simple | |
269 | (fn () => | |
270 | PrimitiveFFI.Windows.Process.terminate | |
271 | (PId.toRep pid, Signal.toRep signal))) | |
272 | p | |
273 | end | |
274 | val kill = fn (p, signal) => | |
275 | (if useWindowsProcess then killForCreate else killForFork) (p, signal) | |
276 | ||
277 | fun launchWithFork (path, args, env, stdin, stdout, stderr) = | |
278 | case protect (Process.fork, ()) of | |
279 | NONE => (* child *) | |
280 | let | |
281 | fun dup2 (old, new) = | |
282 | if old = new | |
283 | then () | |
284 | else (IO.dup2 {old = old, new = new}; IO.close old) | |
285 | val args = path :: args | |
286 | val execTh = | |
287 | case env of | |
288 | NONE => | |
289 | (fn () => Process.exec (path, args)) | |
290 | | SOME env => | |
291 | (fn () => Process.exece (path, args, env)) | |
292 | in | |
293 | dup2 (stdin, FileSys.stdin) | |
294 | ; dup2 (stdout, FileSys.stdout) | |
295 | ; dup2 (stderr, FileSys.stderr) | |
296 | ; ignore (execTh ()) | |
297 | ; Process.exit 0w127 (* just in case *) | |
298 | end | |
299 | | SOME pid => pid (* parent *) | |
300 | ||
301 | fun strContains seps s = | |
302 | CharVector.exists (Char.contains seps) s | |
303 | (* In MinGW, a string must be escaped if it contains " \t" or is "". | |
304 | * Escaping means adds "s on the front and end. Any quotes inside | |
305 | * must be escaped with \. Any \s already in the string must be | |
306 | * doubled ONLY when they precede a " or the end of string. | |
307 | *) | |
308 | fun mingwEscape (l, 0) = l | |
309 | | mingwEscape (l, i) = mingwEscape (#"\\"::l, i-1) | |
310 | fun mingwFold (#"\\", (l, escapeCount)) = (#"\\"::l, escapeCount+1) | |
311 | | mingwFold (#"\"", (l, escapeCount)) = | |
312 | (#"\"" :: mingwEscape (#"\\"::l, escapeCount), 0) | |
313 | | mingwFold (x, (l, _)) = (x :: l, 0) | |
314 | val mingwQuote = mingwEscape o CharVector.foldl mingwFold ([#"\""], 0) | |
315 | fun mingwEscape y = | |
316 | if not (strContains " \t\"" y) andalso y<>"" then y else | |
317 | String.implode (List.rev (#"\"" :: mingwQuote y)) | |
318 | ||
319 | fun cygwinEscape y = | |
320 | if not (strContains " \t\"\r\n\f'" y) andalso y<>"" then y else | |
321 | concat ["\"", | |
322 | String.translate | |
323 | (fn #"\"" => "\\\"" | #"\\" => "\\\\" | x => String.str x) y, | |
324 | "\""] | |
325 | ||
326 | val cmdEscapeCreate = | |
327 | if MLton.Platform.OS.host = MLton.Platform.OS.MinGW | |
328 | then mingwEscape else cygwinEscape | |
329 | ||
330 | val cmdEscapeSpawn = | |
331 | if MLton.Platform.OS.host = MLton.Platform.OS.MinGW | |
332 | then mingwEscape else (fn s => s) | |
333 | ||
334 | fun launchWithCreate (path, args, env, stdin, stdout, stderr) = | |
335 | let | |
336 | val path' = | |
337 | NullString.nullTerm | |
338 | (let | |
339 | open MLton.Platform.OS | |
340 | in | |
341 | case host of | |
342 | Cygwin => Cygwin.toFullWindowsPath path | |
343 | | MinGW => path | |
344 | | _ => raise Fail "MLton.Process.launchWithCreate: path'" | |
345 | end) | |
346 | val args' = | |
347 | NullString.nullTerm | |
348 | (String.concatWith " " (List.map cmdEscapeCreate (path :: args))) | |
349 | val env' = | |
350 | Option.map | |
351 | (fn env => | |
352 | NullString.nullTerm | |
353 | ((String.concatWith "\000" env) ^ "\000")) | |
354 | env | |
355 | val stdin' = FileDesc.toRep stdin | |
356 | val stdout' = FileDesc.toRep stdout | |
357 | val stderr' = FileDesc.toRep stderr | |
358 | val createTh = | |
359 | case env' of | |
360 | NONE => | |
361 | (fn () => | |
362 | PrimitiveFFI.Windows.Process.createNull | |
363 | (path', args', stdin', stdout', stderr')) | |
364 | | SOME env' => | |
365 | (fn () => | |
366 | PrimitiveFFI.Windows.Process.create | |
367 | (path', args', env', stdin', stdout', stderr')) | |
368 | val pid' = | |
369 | SysCall.simpleResult' | |
370 | ({errVal = C_PId.castFromFixedInt ~1}, fn () => | |
371 | createTh ()) | |
372 | val pid = PId.fromRep pid' | |
373 | in | |
374 | pid | |
375 | end | |
376 | ||
377 | val launch = | |
378 | fn z => | |
379 | (if useWindowsProcess then launchWithCreate else launchWithFork) z | |
380 | ||
381 | fun create {args, env, path, stderr, stdin, stdout} = | |
382 | if not (FileSys.access (path, [FileSys.A_EXEC])) | |
383 | then PosixError.raiseSys PosixError.noent | |
384 | else | |
385 | let | |
386 | val () = TextIO.flushOut TextIO.stdOut | |
387 | val (fstdin, cstdin) = Param.openStdin stdin | |
388 | val (fstdout, cstdout) = Param.openStdout stdout | |
389 | val (fstderr, cstderr) = Param.openStderr stderr | |
390 | val closeStdio = | |
391 | fn () => (Param.close stdin fstdin | |
392 | ; Param.close stdout fstdout | |
393 | ; Param.close stderr fstderr) | |
394 | val pid = | |
395 | launch (path, args, env, fstdin, fstdout, fstderr) | |
396 | handle ex => (closeStdio () | |
397 | ; Child.close (cstdin, cstdout, cstderr) | |
398 | ; raise ex) | |
399 | val () = closeStdio () | |
400 | in | |
401 | T {pid = pid, | |
402 | status = ref NONE, | |
403 | stderr = ref cstderr, | |
404 | stdin = ref cstdin, | |
405 | stdout = ref cstdout} | |
406 | end | |
407 | ||
408 | fun spawne {path, args, env} = | |
409 | if useWindowsProcess | |
410 | then | |
411 | let | |
412 | val args = List.map cmdEscapeSpawn args | |
413 | val path = NullString.nullTerm path | |
414 | val args = CUtil.C_StringArray.fromList args | |
415 | val env = CUtil.C_StringArray.fromList env | |
416 | in | |
417 | (PId.fromRep o SysCall.simpleResult') | |
418 | ({errVal = C_PId.castFromFixedInt ~1}, fn () => | |
419 | Prim.spawne (path, args, env)) | |
420 | end | |
421 | else | |
422 | case Posix.Process.fork () of | |
423 | NONE => (Posix.Process.exece (path, args, env) handle _ => () | |
424 | ; Posix.Process.exit 0w127) | |
425 | | SOME pid => pid | |
426 | ||
427 | fun spawn {args, path}= | |
428 | spawne {args = args, | |
429 | env = ProcEnv.environ (), | |
430 | path = path} | |
431 | ||
432 | fun spawnp {args, file} = | |
433 | if useWindowsProcess | |
434 | then | |
435 | let | |
436 | val file = NullString.nullTerm file | |
437 | val args = List.map cmdEscapeSpawn args | |
438 | val args = CUtil.C_StringArray.fromList args | |
439 | in | |
440 | (PId.fromRep o SysCall.simpleResult') | |
441 | ({errVal = C_PId.castFromFixedInt ~1}, fn () => | |
442 | Prim.spawnp (file, args)) | |
443 | end | |
444 | else | |
445 | case Posix.Process.fork () of | |
446 | NONE => (Posix.Process.execp (file, args) handle _ => () | |
447 | ; Posix.Process.exit 0w127) | |
448 | | SOME pid => pid | |
449 | ||
450 | open Exit | |
451 | end |