1 (* Copyright (C
) 2009 Matthew Fluet
.
2 * Copyright (C
) 2002-2008 Henry Cejtin
, Matthew Fluet
, Suresh
3 * Jagannathan
, and Stephen Weeks
.
5 * MLton is released under a BSD
-style license
.
6 * See the file MLton
-LICENSE for details
.
9 structure MLtonProcess
=
11 structure Prim
= PrimitiveFFI
.MLton
.Process
12 structure MLton
= Primitive
.MLton
16 structure FileSys
= FileSys
18 structure ProcEnv
= ProcEnv
19 structure Process
= Process
20 structure FileDesc
= PrePosix
.FileDesc
21 structure PId
= PrePosix
.PId
22 structure Signal
= PrePosix
.Signal
24 structure Mask
= MLtonSignal
.Mask
25 structure SysCall
= PosixError
.SysCall
29 exception MisuseOfForget
30 exception DoublyRedirected
39 val useWindowsProcess
= MLton
.Platform
.OS
.useWindowsProcess
45 flags
[irusr
, iwusr
, irgrp
, iwgrp
, iroth
, iwoth
]
50 datatype 'use childt
=
51 FileDesc
of FileSys
.file_desc
52 | Stream
of 'use
* ('use
-> unit
)
54 type ('use
, 'dir
) t
= 'use childt ref
56 (* This is _not_ the identity
; by rebuilding it we get
type
57 * ('a
, 'b
) t
-> ('c
, 'd
) t
62 (x
:= Stream ((), fn () => ())
64 | Stream _
=> raise MisuseOfForget (* remember twice
= bad
*)
68 fun convert (new
, close
) p
=
72 val str
= new (fd
, "<process>")
73 val () = p
:= Stream (str
, close
)
77 |
Stream (str
, _
) => str
78 | Term
=> raise MisuseOfForget
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
)
89 | _
=> raise MisuseOfForget
93 FileDesc fd
=> IO
.close fd
94 |
Stream (str
, close
) => close str
98 fn (stdin
, stdout
, stderr
) =>
99 (close stdin
; close stdout
; close stderr
)
104 datatype ('use
, 'dir
) t
=
106 | FileDesc
of FileSys
.file_desc
110 (* This is _not_ the identity
; by rebuilding it we get
type
111 * ('a
, 'b
) t
-> ('c
, 'd
) t
115 | FileDesc f
=> FileDesc f
121 val null
= if useWindowsProcess
then "nul" else "/dev/null"
127 fun fd f
= FileDesc f
132 Child
.FileDesc f
=> (c
:= Child
.Stream ((), fn () => ()); f
)
133 | Child
.Stream _
=> raise DoublyRedirected
134 | Child
.Term
=> raise MisuseOfForget
)
136 fun setCloseExec fd
=
139 else IO
.setfd (fd
, IO
.FD
.flags
[IO
.FD
.cloexec
])
144 File s
=> (FileSys
.creat (s
, readWrite
), Child
.Term
)
145 | FileDesc f
=> (f
, Child
.Term
)
148 val {infd
, outfd
} = IO
.pipe ()
149 val () = setCloseExec infd
151 (outfd
, Child
.FileDesc infd
)
153 | Self
=> (std
, Child
.Term
)
155 fun openStdout p
= openOut FileSys
.stdout p
156 fun openStderr p
= openOut FileSys
.stderr p
162 (FileSys
.openf (s
, FileSys
.O_RDONLY
, FileSys
.O
.flags
[]),
164 | FileDesc f
=> (f
, Child
.Term
)
167 val {infd
, outfd
} = IO
.pipe ()
168 val () = setCloseExec outfd
170 (infd
, Child
.FileDesc outfd
)
172 | Self
=> (FileSys
.stdin
, Child
.Term
)
176 File _
=> IO
.close fd
177 | FileDesc _
=> IO
.close fd
178 | Pipe
=> IO
.close fd
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
.
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
}
194 fun make
f (T r
) = f r
196 val getStderr
= fn z
=> make #stderr z
197 val getStdin
= fn z
=> make #stdin z
198 val getStdout
= fn z
=> make #stdout z
201 fun ('a
, 'b
) protect (f
: 'a
-> 'b
, x
: 'a
): 'b
=
203 val () = Mask
.block Mask
.all
205 DynamicWind
.wind (fn () => f x
, fn () => Mask
.unblock Mask
.all
)
209 fun reap
reapFn (T
{pid
, status
, stderr
, stdin
, stdout
, ...}) =
213 val _
= Child
.close (!stdin
, !stdout
, !stderr
)
224 (* protect is probably too much
; typically
, one
225 * would only mask SIGINT
, SIGQUIT
and SIGHUP
.
228 protect (Process
.waitpid
, (Process
.W_CHILD pid
, []))
233 fun reapForCreate p
=
236 val pid
' = PId
.toRep pid
237 val status
' = ref (C_Status
.fromInt
0)
241 PrimitiveFFI
.Windows
.Process
.getexitcode
244 Process
.fromStatus
' (!status
')
249 (if useWindowsProcess
then reapForCreate
else reapForFork
) p
252 fun kill
killFn (p
as T
{pid
, status
, ...}, signal
) =
256 val () = killFn (pid
, signal
)
263 kill (fn (pid
, signal
) =>
264 Process
.kill (Process
.K_PROC pid
, signal
))
266 fun killForCreate p
=
267 kill (fn (pid
, signal
) =>
270 PrimitiveFFI
.Windows
.Process
.terminate
271 (PId
.toRep pid
, Signal
.toRep signal
)))
274 val kill
= fn (p
, signal
) =>
275 (if useWindowsProcess
then killForCreate
else killForFork
) (p
, signal
)
277 fun launchWithFork (path
, args
, env
, stdin
, stdout
, stderr
) =
278 case protect (Process
.fork
, ()) of
281 fun dup2 (old
, new
) =
284 else (IO
.dup2
{old
= old
, new
= new
}; IO
.close old
)
285 val args
= path
:: args
289 (fn () => Process
.exec (path
, args
))
291 (fn () => Process
.exece (path
, args
, env
))
293 dup2 (stdin
, FileSys
.stdin
)
294 ; dup2 (stdout
, FileSys
.stdout
)
295 ; dup2 (stderr
, FileSys
.stderr
)
297 ; Process
.exit
0w127 (* just
in case *)
299 | SOME pid
=> pid (* parent
*)
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.
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)
316 if not (strContains
" \t\"" y
) andalso y
<>"" then y
else
317 String.implode (List.rev (#
"\"" :: mingwQuote y
))
320 if not (strContains
" \t\"\r\n\f'" y
) andalso y
<>"" then y
else
323 (fn #
"\"" => "\\\"" | #
"\\" => "\\\\" | x
=> String.str x
) y
,
326 val cmdEscapeCreate
=
327 if MLton
.Platform
.OS
.host
= MLton
.Platform
.OS
.MinGW
328 then mingwEscape
else cygwinEscape
331 if MLton
.Platform
.OS
.host
= MLton
.Platform
.OS
.MinGW
332 then mingwEscape
else (fn s
=> s
)
334 fun launchWithCreate (path
, args
, env
, stdin
, stdout
, stderr
) =
339 open MLton
.Platform
.OS
342 Cygwin
=> Cygwin
.toFullWindowsPath path
344 | _
=> raise Fail
"MLton.Process.launchWithCreate: path'"
348 (String.concatWith
" " (List.map
cmdEscapeCreate (path
:: args
)))
353 ((String.concatWith
"\000" env
) ^
"\000"))
355 val stdin
' = FileDesc
.toRep stdin
356 val stdout
' = FileDesc
.toRep stdout
357 val stderr
' = FileDesc
.toRep stderr
362 PrimitiveFFI
.Windows
.Process
.createNull
363 (path
', args
', stdin
', stdout
', stderr
'))
366 PrimitiveFFI
.Windows
.Process
.create
367 (path
', args
', env
', stdin
', stdout
', stderr
'))
369 SysCall
.simpleResult
'
370 ({errVal
= C_PId
.castFromFixedInt ~
1}, fn () =>
372 val pid
= PId
.fromRep pid
'
379 (if useWindowsProcess
then launchWithCreate
else launchWithFork
) z
381 fun create
{args
, env
, path
, stderr
, stdin
, stdout
} =
382 if not (FileSys
.access (path
, [FileSys
.A_EXEC
]))
383 then PosixError
.raiseSys PosixError
.noent
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
391 fn () => (Param
.close stdin fstdin
392 ; Param
.close stdout fstdout
393 ; Param
.close stderr fstderr
)
395 launch (path
, args
, env
, fstdin
, fstdout
, fstderr
)
396 handle ex
=> (closeStdio ()
397 ; Child
.close (cstdin
, cstdout
, cstderr
)
399 val () = closeStdio ()
403 stderr
= ref cstderr
,
405 stdout
= ref cstdout
}
408 fun spawne
{path
, args
, env
} =
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
417 (PId
.fromRep
o SysCall
.simpleResult
')
418 ({errVal
= C_PId
.castFromFixedInt ~
1}, fn () =>
419 Prim
.spawne (path
, args
, env
))
422 case Posix
.Process
.fork () of
423 NONE
=> (Posix
.Process
.exece (path
, args
, env
) handle _
=> ()
424 ; Posix
.Process
.exit
0w127
)
427 fun spawn
{args
, path
}=
429 env
= ProcEnv
.environ (),
432 fun spawnp
{args
, file
} =
436 val file
= NullString
.nullTerm file
437 val args
= List.map cmdEscapeSpawn args
438 val args
= CUtil
.C_StringArray
.fromList args
440 (PId
.fromRep
o SysCall
.simpleResult
')
441 ({errVal
= C_PId
.castFromFixedInt ~
1}, fn () =>
442 Prim
.spawnp (file
, args
))
445 case Posix
.Process
.fork () of
446 NONE
=> (Posix
.Process
.execp (file
, args
) handle _
=> ()
447 ; Posix
.Process
.exit
0w127
)