1 (* Copyright (C
) 2017 Matthew Fluet
.
2 * Copyright (C
) 1999-2006 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 Process
: PROCESS
=
15 val messageStr
= messageStr
20 val status
= OS
.Process
.system s
22 if OS
.Process
.isSuccess status
24 else Error
.bug (concat
["Process.system: command failed: ", s
])
29 type t
= In
.t
* Out
.t
-> unit
31 fun layout _
= Layout
.str
"<command>"
34 type command
= Command
.t
38 structure PosixStatus
=
44 fun toString (s
: t
): string =
47 | W_EXITSTATUS w
=> concat
["exit status ", Word8.toString w
]
48 | W_SIGNALED s
=> concat
["signal ",
49 SysWord
.toString (Posix
.Signal
.toWord s
)]
50 | W_STOPPED s
=> concat
["stop signal ",
51 SysWord
.toString (Posix
.Signal
.toWord s
)]
53 val layout
= Layout
.str
o toString
58 type t
= OS
.Process
.status
66 val succeed
= Trace
.trace ("Process.succeed", Unit
.layout
, Unit
.layout
) succeed
68 (* This song
and dance is so that succeed can have the right
type, unit
-> 'a
,
69 * instead
of unit
-> unit
.
71 val succeed
: unit
-> 'a
= fn () => (succeed (); Error
.bug
"Process.succeed")
73 fun fork (c
: unit
-> unit
): Pid
.t
=
74 case Posix
.Process
.fork () of
75 NONE
=> (Trace
.Immediate
.inChildProcess ()
77 in exit ((c (); success
) handle _
=> failure
)
81 val fork
= Trace
.trace ("Process.fork", Command
.layout
, Pid
.layout
) fork
83 fun closes l
= List.foreach (l
, FileDesc
.close
)
85 val pname
= "<process>"
87 fun forkIn (c
: Out
.t
-> unit
): Pid
.t
* In
.t
=
89 val {infd
, outfd
} = FileDesc
.pipe ()
90 val pid
= fork (fn () =>
92 ; c (MLton
.TextIO.newOut (outfd
, pname
))))
93 val _
= FileDesc
.close outfd
95 (pid
, MLton
.TextIO.newIn (infd
, pname
))
98 fun forkOut (c
: In
.t
-> unit
): Pid
.t
* Out
.t
=
100 val {infd
, outfd
} = FileDesc
.pipe ()
101 val pid
= fork (fn () =>
102 (FileDesc
.close outfd
103 ; c (MLton
.TextIO.newIn (infd
, pname
))))
104 val _
= FileDesc
.close infd
106 (pid
, MLton
.TextIO.newOut (outfd
, pname
))
109 fun forkInOut (c
: In
.t
* Out
.t
-> unit
): Pid
.t
* In
.t
* Out
.t
=
111 val {infd
= in1
, outfd
= out1
} = FileDesc
.pipe ()
112 val {infd
= in2
, outfd
= out2
} = FileDesc
.pipe ()
113 val pid
= fork (fn () =>
115 ; c (MLton
.TextIO.newIn (in2
, pname
),
116 MLton
.TextIO.newOut (out1
, pname
))))
117 val _
= closes
[in2
, out1
]
119 MLton
.TextIO.newIn (in1
, pname
),
120 MLton
.TextIO.newOut (out2
, pname
))
123 fun wait (p
: Pid
.t
): unit
=
124 let val (p
', s
) = Posix
.Process
.waitpid (Posix
.Process
.W_CHILD p
, [])
126 then Error
.bug (concat
["Process.wait: expected pid ",
132 PosixStatus
.W_EXITED
=> ()
133 | _
=> raise Fail (concat
[PosixStatus
.toString s
]))
136 val wait
= Trace
.trace ("Process.wait", Pid
.layout
, Unit
.layout
) wait
138 val run
= wait
o fork
140 (* doubleFork avoids creating zombies
. *)
141 fun doubleFork (c
: unit
-> unit
): unit
=
142 run (fn () => ignore (fork c
))
152 Trace
.trace ("Process.Posix.Process.wait", Unit
.layout
,
153 Layout
.tuple2 (Pid
.layout
, PosixStatus
.layout
))
158 fun waits (pids
: Pid
.t list
): unit
=
163 val (pid
, status
) = Posix
.Process
.wait ()
166 Posix
.Process
.W_EXITED
=>
167 List.keepAll (pids
, fn p
=> p
<> pid
)
168 | _
=> Error
.bug (concat
["Process.waits: child ",
171 PosixStatus
.toString status
])
175 fun pipe (cs
: command list
, ins
: In
.t
, out
: Out
.t
): unit
=
177 fun loop (cs
: command list
,
180 pids
: Pid
.t list
): unit
=
183 |
[c
] => let val pid
= fork (fn () => c (ins
, out
))
184 val _
= maybeClose ()
185 in waits (pid
:: pids
)
188 let val (pid
, ins
) = forkIn (fn out
=> c (ins
, out
))
189 val _
= maybeClose ()
190 in loop (cs
, ins
, fn _
=> In
.close ins
, pid
:: pids
)
192 in loop (cs
, ins
, fn _
=> (), [])
195 fun pipe
' cs
= pipe (cs
, In
.standard
, Out
.standard
)
197 fun exec (c
: string, a
: string list
, ins
: In
.t
, out
: Out
.t
): unit
=
202 then (move
{from
= MLton
.TextIO.inFd ins
,
204 ; move
{from
= MLton
.TextIO.outFd out
,
206 ; move
{from
= MLton
.TextIO.outFd Out
.error
,
209 ; (Posix
.Process
.execp (c
, c
:: a
)
210 handle _
=> (Out
.output (Out
.error
,
211 (concat ("unable to exec "
212 :: List.separate (c
:: a
, " "))))
213 ; OS
.Process
.exit OS
.Process
.failure
))
217 Trace
.trace4 ("Process.exec", String.layout
, List.layout
String.layout
,
218 In
.layout
, Out
.layout
, Unit
.layout
)
221 fun call (c
, a
) (ins
, out
) = run (fn () => exec (c
, a
, ins
, out
))
223 fun call
' ca
= call
ca (In
.standard
, Out
.standard
)
225 fun collect (c
: Command
.t
): string =
226 let val (pid
, ins
) = forkIn (fn out
=> c (In
.standard
, out
))
227 in In
.inputAll ins
before (In
.close ins
; wait pid
)
230 fun doesSucceed c
= (run c
; true) handle Fail _
=> false
233 Trace
.trace ("Process.doesSucceed", Function
.layout
, Bool.layout
)
236 fun makeCommandLine (commandLine
: string list
-> unit
) args
=
237 ((commandLine args
; OS
.Process
.success
)
242 Out
.output (out
, concat
["unhandled exception: ", Exn
.toString e
, "\n"])
243 ; (case Exn
.history e
of
245 | l
=> (Out
.output (out
, "with history: \n")
248 Out
.output (out
, concat
["\t", s
, "\n"]))))
252 fun makeMain
z (): unit
=
253 OS
.Process
.exit (makeCommandLine
z (CommandLine
.arguments ()))
255 fun basename s
= #
file (OS
.Path
.splitDirFile s
)
257 val commandName
= Promise
.lazy (fn () => basename (CommandLine
.name ()))
259 local open Posix
.SysDB Posix
.ProcEnv
261 fun su (name
: string): unit
=
262 let val p
= getpwnam name
263 in setgid (Passwd
.gid p
)
264 ; setuid (Passwd
.uid p
)
266 val su
= Trace
.trace ("Process.su", String.layout
, Unit
.layout
) su
267 fun userName () = Passwd
.name (getpwuid (getuid ()))
270 fun fail x
= raise Fail x
273 val z
= Posix
.ProcEnv
.uname ()
275 case List.peek (z
, fn (s
', _
) => s
= s
') of
276 NONE
=> fail (concat
[s
, " unknown"])
279 fun hostName () = lookup
"nodename"
282 val getEnv
= Posix
.ProcEnv
.getenv
284 fun glob (s
: string): string list
=
285 String.tokens (collect (call ("bash", ["-c", "ls " ^ s
])),
288 fun usage
{usage
: string, msg
: string}: 'a
=
289 fail (concat
[msg
, "\n", "Usage: ", commandName (), " ", usage
])
291 val sleep
= Posix
.Process
.sleep
293 fun watch (f
: unit
-> unit
) =
297 handle _
=> (messageStr
"watcher noticed child failure"
302 fun signal (p
: Pid
.t
, s
: Signal
.t
): unit
=
303 let open Posix
.Process
304 in kill (K_PROC p
, s
)
307 fun signalGroup (p
: Pid
.t
, s
: Signal
.t
): unit
=
308 let open Posix
.Process
309 in kill (K_GROUP p
, s
)
313 val delay
= Time
.fromMilliseconds
1
314 val maxDelay
= Time
.minutes
1
316 fun try (f
: unit
-> 'a
, msg
: string): 'a
=
318 fun loop (delay
: Time
.t
): 'a
=
319 if Time
.> (delay
, maxDelay
)
321 else (f () handle _
=> (ignore (sleep delay
)
322 ; loop (Time
.+ (delay
, delay
))))
329 datatype t
= DiskSleep | Running | Sleeping | Traced | Zombie
333 "D" => SOME DiskSleep
334 |
"R" => SOME Running
335 |
"S" => SOME Sleeping
341 fn DiskSleep
=> "DiskSleep"
342 | Running
=> "Running"
343 | Sleeping
=> "Sleeping"
347 val layout
= Layout
.str
o toString
356 (Dir
.lsDirs
".", [], fn (d
, ac
) =>
357 case Pid
.fromString d
of
360 case String.tokens (hd (File
.lines ("/proc"/d
/"stat")),
362 _
:: name
:: state
:: ppid
:: pgrp
:: _
=>
363 {(* drop
the ( ) around the name
*)
364 name
= String.substring (name
, 1, String.size name
- 2),
365 pgrp
= valOf (Pid
.fromString pgrp
),
367 ppid
= valOf (Pid
.fromString ppid
),
368 state
= valOf (State
.fromString state
)
374 ("Process.ps", Unit
.layout
,
375 List.layout (fn {name
, pid
, state
, ...} =>
376 Layout
.record
[("pid", Pid
.layout pid
),
377 ("name", String.layout name
),
378 ("state", State
.layout state
)]))
381 fun callWithIn (name
, args
, f
: In
.t
-> 'a
) =
383 val pid
= Unix
.execute (name
, args
)
384 val ins
= Unix
.textInstreamOf pid
388 fn () => ignore (Unix
.reap pid
))
391 fun callWithOut (name
, args
, f
: Out
.t
-> 'a
) =
393 val pid
= Unix
.execute (name
, args
)
394 val out
= Unix
.textOutstreamOf pid
398 fn () => ignore (Unix
.reap pid
))
402 * text data bss dec hex filename
403 * 3272995 818052 24120 4115167 3ecadf mlton
405 fun size (f
: File
.t
): {text
: int, data
: int, bss
: int} =
407 val fail
= fn () => fail (concat
["size failed on ", f
])
412 val _
= OS
.Process
.system (concat
["size ", f
, ">", sizeRes
])
418 (case String.tokens (nums
, Char.isSpace
) of
419 text
:: data
:: bss
:: _
=>
420 (case (Int.fromString text
,
422 Int.fromString bss
) of
423 (SOME text
, SOME data
, SOME bss
) =>
424 {text
= text
, data
= data
, bss
= bss
}
431 fun time (f
: unit
-> unit
) =
433 val {children
= {utime
= u
, stime
= s
}, ...} = Time
.times ()
435 val {children
= {utime
= u
', stime
= s
'}, ...} = Time
.times ()
437 {system
= Time
.- (s
', s
), user
= Time
.- (u
', u
)}
440 val setEnv
= MLton
.ProcEnv
.setenv
442 val exec
= fn (c
, a
) => exec (c
, a
, In
.standard
, Out
.standard
)