Permalink
Newer
Older
100644 184 lines (164 sloc) 5.58 KB
1
(***********************************************************************)
2
(* *)
3
(* Copyright 2011-2012 OCamlPro *)
4
(* Copyright 2011-2012 INRIA *)
5
(* *)
6
(* All rights reserved. This file is distributed under the terms of *)
7
(* the GNU Public License version 3.0. *)
8
(* *)
9
(* OPAM is distributed in the hope that it will be useful, *)
10
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
11
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
12
(* GNU General Public License for more details. *)
13
(* *)
14
(***********************************************************************)
15
16
type t = {
17
p_name : string; (* Command name *)
18
p_args : string list; (* Command args *)
19
p_pid : int; (* Process PID *)
20
p_time : float; (* Process start time *)
21
p_stdout : string option; (* stdout dump file *)
22
p_stderr : string option; (* stderr dump file *)
23
p_info : string option; (* dump info file *)
24
}
25
26
let open_flags = [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC]
27
28
let create ?info ?stdout ?stderr ?env ~verbose cmd args =
29
let nothing () = () in
30
let tee f =
31
let fd = Unix.openfile f open_flags 0o644 in
32
let close_fd () = Unix.close fd in
34
let chan = Unix.open_process_out ("tee " ^ Filename.quote f) in
35
let close () =
36
match Unix.close_process_out chan with
37
| _ -> close_fd () in
38
Unix.descr_of_out_channel chan, close
39
) else
40
fd, close_fd in
41
let stdout_fd, close_stdout = match stdout with
42
| None -> Unix.stdout, nothing
43
| Some f -> tee f in
44
let stderr_fd, close_stderr = match stderr with
45
| None -> Unix.stderr, nothing
46
| Some f -> tee f in
47
let env = match env with
48
| None -> Unix.environment ()
49
| Some e -> e in
50
let time = Unix.gettimeofday () in
51
let pid =
52
Unix.create_process_env
53
cmd
54
(Array.of_list (cmd :: args))
55
env
56
Unix.stdin stdout_fd stderr_fd in
57
close_stdout ();
58
close_stderr ();
59
{
60
p_name = cmd;
61
p_args = args;
62
p_pid = pid;
63
p_time = time;
64
p_stdout = stdout;
65
p_stderr = stderr;
66
p_info = info;
67
}
68
69
type result = {
70
r_proc : t; (* Process *)
71
r_code : int; (* Process exit code *)
72
r_duration : float; (* Process duration *)
Aug 20, 2012
73
r_info : string list; (* Env variables *)
74
r_stdout : string list; (* Content of stdout dump file *)
75
r_stderr : string list; (* Content of stderr dump file *)
76
}
77
78
(* XXX: the function might block for ever for some channels kinds *)
79
let read_lines f =
80
try
81
let ic = open_in f in
82
let lines = ref [] in
83
begin
84
try
85
while true do
86
let line = input_line ic in
87
lines := line :: !lines;
88
done
89
with _ -> ()
90
end;
91
close_in ic;
92
List.rev !lines
93
with _ -> []
94
95
let option_map fn = function
96
| None -> None
97
| Some o -> Some (fn o)
98
99
let option_default d = function
100
| None -> d
101
| Some v -> v
102
103
let wait p =
104
try
105
let rec iter () =
106
let _, status = Unix.waitpid [] p.p_pid in
107
match status with
108
| Unix.WEXITED code ->
109
let duration = Unix.gettimeofday () -. p.p_time in
Aug 20, 2012
110
let info =
111
option_default [] (option_map read_lines p.p_info) in
112
let stdout =
113
option_default [] (option_map read_lines p.p_stdout) in
114
let stderr =
115
option_default [] (option_map read_lines p.p_stderr) in
116
{
117
r_proc = p;
118
r_code = code;
119
r_duration = duration;
Aug 20, 2012
120
r_info = info;
121
r_stdout = stdout;
122
r_stderr = stderr;
123
}
124
| _ -> iter () in
125
iter ()
126
with e ->
127
OpamGlobals.error "Exception %s in waitpid" (Printexc.to_string e);
128
OpamGlobals.exit 2
129
130
let output_lines oc lines =
131
List.iter (fun line ->
132
output_string oc line;
133
output_string oc "\n";
134
flush oc;
135
) lines;
136
output_string oc "\n";
137
flush oc
138
139
let run ?env ~verbose ~name cmd args =
Sep 18, 2012
140
try
141
let stdout = Printf.sprintf "%s.out" name in
142
let stderr = Printf.sprintf "%s.err" name in
143
let info = Printf.sprintf "%s.info" name in
Sep 18, 2012
144
145
let env = match env with Some e -> e | None -> Unix.environment () in
Sep 18, 2012
146
147
(* Write info file *)
148
let chan = open_out info in
149
output_lines chan
150
[ Printf.sprintf "[RUN] %S" (String.concat " " (cmd :: args)) ;
151
Printf.sprintf "[CWD] %S" (Unix.getcwd ()) ;
152
String.concat "\n" (Array.to_list env)
153
];
154
close_out chan;
Sep 18, 2012
155
156
let p = create ~env ~info ~stdout ~stderr ~verbose cmd args in
159
OpamGlobals.error "Exception %s in run" (Printexc.to_string e);
160
OpamGlobals.exit 2
Sep 18, 2012
161
162
let is_success r = r.r_code = 0
163
164
let is_failure r = r.r_code <> 0
165
166
let option_iter fn = function
167
| None -> ()
168
| Some v -> fn v
169
170
let safe_unlink f =
171
try Unix.unlink f with _ -> ()
172
174
option_iter safe_unlink r.r_proc.p_stdout;
175
option_iter safe_unlink r.r_proc.p_stderr;
176
option_iter safe_unlink r.r_proc.p_info
177
178
let display_error_message r =
179
if is_failure r then (
180
List.iter (OpamGlobals.error "= %s") r.r_info;
181
List.iter (OpamGlobals.error ". %s") r.r_stdout;
182
List.iter (OpamGlobals.error "* %s") r.r_stderr;