Don't mangle the output of commands and keep a log file
This commit is contained in:
parent
e75f0e4455
commit
901d9acc2a
11
bin/main.ml
11
bin/main.ml
|
@ -6,12 +6,14 @@ module Main = Jbuilder.Main
|
||||||
|
|
||||||
let (>>=) = Future.(>>=)
|
let (>>=) = Future.(>>=)
|
||||||
|
|
||||||
|
let create_log = Main.create_log
|
||||||
|
|
||||||
(* TODO: rewrite this when command trees are supported.
|
(* TODO: rewrite this when command trees are supported.
|
||||||
|
|
||||||
https://github.com/dbuenzli/cmdliner/issues/24 *)
|
https://github.com/dbuenzli/cmdliner/issues/24 *)
|
||||||
let internal = function
|
let internal = function
|
||||||
| [_; "findlib-packages"] ->
|
| [_; "findlib-packages"] ->
|
||||||
Future.Scheduler.go
|
Future.Scheduler.go ~log:(create_log ())
|
||||||
(Lazy.force Context.default >>= fun ctx ->
|
(Lazy.force Context.default >>= fun ctx ->
|
||||||
let findlib = Findlib.create ctx in
|
let findlib = Findlib.create ctx in
|
||||||
let pkgs = Findlib.all_packages findlib in
|
let pkgs = Findlib.all_packages findlib in
|
||||||
|
@ -71,7 +73,7 @@ let common =
|
||||||
Term.(const make $ concurrency $ drules $ ddep_path $ dfindlib)
|
Term.(const make $ concurrency $ drules $ ddep_path $ dfindlib)
|
||||||
|
|
||||||
let build_package pkg =
|
let build_package pkg =
|
||||||
Future.Scheduler.go
|
Future.Scheduler.go ~log:(create_log ())
|
||||||
(Main.setup () >>= fun (bs, _, _) ->
|
(Main.setup () >>= fun (bs, _, _) ->
|
||||||
Build_system.do_build_exn bs [Path.(relative root) (pkg ^ ".install")])
|
Build_system.do_build_exn bs [Path.(relative root) (pkg ^ ".install")])
|
||||||
|
|
||||||
|
@ -88,8 +90,9 @@ let build_package =
|
||||||
, Term.info "build-package" ~doc ~man:help_secs)
|
, Term.info "build-package" ~doc ~man:help_secs)
|
||||||
|
|
||||||
let external_lib_deps packages =
|
let external_lib_deps packages =
|
||||||
|
let log = create_log () in
|
||||||
let deps =
|
let deps =
|
||||||
Path.Map.fold (Main.external_lib_deps ~packages) ~init:String_map.empty
|
Path.Map.fold (Main.external_lib_deps ~log ~packages) ~init:String_map.empty
|
||||||
~f:(fun ~key:_ ~data:deps acc -> Build.merge_lib_deps deps acc)
|
~f:(fun ~key:_ ~data:deps acc -> Build.merge_lib_deps deps acc)
|
||||||
in
|
in
|
||||||
String_map.iter deps ~f:(fun ~key:n ~data ->
|
String_map.iter deps ~f:(fun ~key:n ~data ->
|
||||||
|
@ -136,7 +139,7 @@ let build_targets ~name =
|
||||||
let name_ = Arg.info [] ~docv:"TARGET" in
|
let name_ = Arg.info [] ~docv:"TARGET" in
|
||||||
let go common targets =
|
let go common targets =
|
||||||
set_common common;
|
set_common common;
|
||||||
Future.Scheduler.go
|
Future.Scheduler.go ~log:(create_log ())
|
||||||
(Main.setup () >>= fun (bs, _, ctx) ->
|
(Main.setup () >>= fun (bs, _, ctx) ->
|
||||||
let targets = resolve_targets bs ctx targets in
|
let targets = resolve_targets bs ctx targets in
|
||||||
Build_system.do_build_exn bs targets) in
|
Build_system.do_build_exn bs targets) in
|
||||||
|
|
|
@ -87,3 +87,23 @@ let colorize =
|
||||||
let hash = Hashtbl.hash key in
|
let hash = Hashtbl.hash key in
|
||||||
let fore, back = color_combos.(hash mod (Array.length color_combos)) in
|
let fore, back = color_combos.(hash mod (Array.length color_combos)) in
|
||||||
apply_string [Foreground fore; Background back] str
|
apply_string [Foreground fore; Background back] str
|
||||||
|
|
||||||
|
let strip str =
|
||||||
|
let len = String.length str in
|
||||||
|
let buf = Buffer.create len in
|
||||||
|
let rec loop i =
|
||||||
|
if i = len then
|
||||||
|
Buffer.contents buf
|
||||||
|
else
|
||||||
|
match str.[i] with
|
||||||
|
| '\027' -> skip (i + 1)
|
||||||
|
| c -> Buffer.add_char buf c; loop (i + 1)
|
||||||
|
and skip i =
|
||||||
|
if i = len then
|
||||||
|
Buffer.contents buf
|
||||||
|
else
|
||||||
|
match str.[i] with
|
||||||
|
| 'm' -> loop (i + 1)
|
||||||
|
| _ -> skip (i + 1)
|
||||||
|
in
|
||||||
|
loop 0
|
||||||
|
|
|
@ -1 +1,2 @@
|
||||||
val colorize : key:string -> string -> string
|
val colorize : key:string -> string -> string
|
||||||
|
val strip : string -> string
|
||||||
|
|
151
src/future.ml
151
src/future.ml
|
@ -192,47 +192,17 @@ let run_capture_line ?dir ?env prog args =
|
||||||
cmdline (String.concat l ~sep:"\n")
|
cmdline (String.concat l ~sep:"\n")
|
||||||
|
|
||||||
module Scheduler = struct
|
module Scheduler = struct
|
||||||
let quote s =
|
|
||||||
let len = String.length s in
|
|
||||||
if len = 0 then
|
|
||||||
Filename.quote s
|
|
||||||
else
|
|
||||||
let rec loop i =
|
|
||||||
if i = len then
|
|
||||||
s
|
|
||||||
else
|
|
||||||
match s.[i] with
|
|
||||||
| ' ' | '\"' -> Filename.quote s
|
|
||||||
| _ -> loop (i + 1)
|
|
||||||
in
|
|
||||||
loop 0
|
|
||||||
|
|
||||||
let key_for_color prog =
|
let key_for_color prog =
|
||||||
let s = Filename.basename prog in
|
let s = Filename.basename prog in
|
||||||
match String.lsplit2 s ~on:'.' with
|
match String.lsplit2 s ~on:'.' with
|
||||||
| None -> s
|
| None -> s
|
||||||
| Some (s, _) -> s
|
| Some (s, _) -> s
|
||||||
|
|
||||||
let err_is_atty = lazy Unix.(isatty stderr)
|
let command_line { prog; args; dir; stdout_to; _ } =
|
||||||
|
let quote = quote_for_shell in
|
||||||
let dumb_term =
|
|
||||||
match Sys.getenv "TERM" with
|
|
||||||
| exception Not_found -> true
|
|
||||||
| "dumb" -> true
|
|
||||||
| _ -> false
|
|
||||||
|
|
||||||
let command_line ?colorize { prog; args; dir; stdout_to; _ } =
|
|
||||||
let colorize =
|
|
||||||
match colorize with
|
|
||||||
| Some x -> x
|
|
||||||
| None -> not Sys.win32 && Lazy.force err_is_atty && not dumb_term
|
|
||||||
in
|
|
||||||
let prog =
|
let prog =
|
||||||
let s = quote prog in
|
let s = quote prog in
|
||||||
if colorize then
|
Ansi_color.colorize ~key:(key_for_color prog) s
|
||||||
Ansi_color.colorize ~key:(key_for_color prog) s
|
|
||||||
else
|
|
||||||
s
|
|
||||||
in
|
in
|
||||||
let s = String.concat (prog :: List.map args ~f:quote) ~sep:" " in
|
let s = String.concat (prog :: List.map args ~f:quote) ~sep:" " in
|
||||||
let s =
|
let s =
|
||||||
|
@ -244,19 +214,70 @@ module Scheduler = struct
|
||||||
| None -> s
|
| None -> s
|
||||||
| Some dir -> sprintf "(cd %s && %s)" dir s
|
| Some dir -> sprintf "(cd %s && %s)" dir s
|
||||||
|
|
||||||
let handle_process_status cmd (status : Unix.process_status) =
|
let strip_colors_for_stderr =
|
||||||
match status with
|
let strip = lazy (
|
||||||
| WEXITED 0 -> ()
|
Sys.win32 ||
|
||||||
| WEXITED n -> die "Command exited with code %d: %s" n (Lazy.force cmd)
|
not (Unix.(isatty stderr)) ||
|
||||||
| WSIGNALED n -> die "Command got killed by signal %d: %s" n (Lazy.force cmd)
|
match Sys.getenv "TERM" with
|
||||||
| WSTOPPED _ -> assert false
|
| exception Not_found -> true
|
||||||
|
| "dumb" -> true
|
||||||
|
| _ -> false
|
||||||
|
) in
|
||||||
|
fun s ->
|
||||||
|
if Lazy.force strip then Ansi_color.strip s else s
|
||||||
|
|
||||||
let process_done job status =
|
type running_job =
|
||||||
handle_process_status (lazy (command_line job)) status;
|
{ id : int
|
||||||
Ivar.fill job.ivar ()
|
; job : job
|
||||||
|
; pid : int
|
||||||
|
; output_filename : string
|
||||||
|
; (* for logs, with ansi colors code always included in the string *)
|
||||||
|
command_line : string
|
||||||
|
; log : out_channel option
|
||||||
|
}
|
||||||
|
|
||||||
let running = Hashtbl.create 128
|
let running = Hashtbl.create 128
|
||||||
|
|
||||||
|
let handle_process_status job (status : Unix.process_status) =
|
||||||
|
match status with
|
||||||
|
| WEXITED 0 -> ()
|
||||||
|
| WEXITED n -> die "Command [%d] exited with code %d" job.id n
|
||||||
|
| WSIGNALED n -> die "Command [%d] got killed by signal %d" job.id n
|
||||||
|
| WSTOPPED _ -> assert false
|
||||||
|
|
||||||
|
let process_done ?(exiting=false) job (status : Unix.process_status) =
|
||||||
|
Hashtbl.remove running job.pid;
|
||||||
|
let output =
|
||||||
|
let s = read_file job.output_filename in
|
||||||
|
let len = String.length s in
|
||||||
|
if len > 0 && s.[len - 1] <> '\n' then
|
||||||
|
s ^ "\n"
|
||||||
|
else
|
||||||
|
s
|
||||||
|
in
|
||||||
|
Sys.remove job.output_filename;
|
||||||
|
Option.iter job.log ~f:(fun oc ->
|
||||||
|
Printf.fprintf oc "$ %s\n%s"
|
||||||
|
(Ansi_color.strip job.command_line)
|
||||||
|
(Ansi_color.strip output);
|
||||||
|
(match status with
|
||||||
|
| WEXITED 0 -> ()
|
||||||
|
| WEXITED n -> Printf.fprintf oc "[%d]\n" n
|
||||||
|
| WSIGNALED n -> Printf.fprintf oc "[got signal %d]\n" n
|
||||||
|
| WSTOPPED _ -> assert false);
|
||||||
|
flush oc
|
||||||
|
);
|
||||||
|
if not exiting then begin
|
||||||
|
if output <> "" then
|
||||||
|
Printf.eprintf "Output[%d]:\n%s%!" job.id output;
|
||||||
|
handle_process_status job status;
|
||||||
|
Ivar.fill job.job.ivar ()
|
||||||
|
end
|
||||||
|
|
||||||
|
let gen_id =
|
||||||
|
let next = ref (-1) in
|
||||||
|
fun () -> incr next; !next
|
||||||
|
|
||||||
let rec wait_win32 () =
|
let rec wait_win32 () =
|
||||||
let finished =
|
let finished =
|
||||||
Hashtbl.fold running ~init:[] ~f:(fun ~key:pid ~data:job acc ->
|
Hashtbl.fold running ~init:[] ~f:(fun ~key:pid ~data:job acc ->
|
||||||
|
@ -272,49 +293,60 @@ module Scheduler = struct
|
||||||
wait_win32 ()
|
wait_win32 ()
|
||||||
| _ ->
|
| _ ->
|
||||||
List.iter finished ~f:(fun (pid, job, status) ->
|
List.iter finished ~f:(fun (pid, job, status) ->
|
||||||
Hashtbl.remove running pid;
|
|
||||||
process_done job status)
|
process_done job status)
|
||||||
|
|
||||||
let () =
|
let () =
|
||||||
at_exit (fun () ->
|
at_exit (fun () ->
|
||||||
let pids =
|
let pids =
|
||||||
Hashtbl.fold running ~init:[] ~f:(fun ~key:pid ~data:_ acc -> pid :: acc)
|
Hashtbl.fold running ~init:[] ~f:(fun ~key:_ ~data:job acc -> job :: acc)
|
||||||
in
|
in
|
||||||
List.iter pids ~f:(fun pid ->
|
List.iter pids ~f:(fun job ->
|
||||||
ignore (Unix.waitpid [] pid : _ * _);
|
let _, status = Unix.waitpid [] job.pid in
|
||||||
Hashtbl.remove running pid))
|
process_done job status ~exiting:true))
|
||||||
|
|
||||||
let rec go t =
|
let rec go_rec cwd log t =
|
||||||
let cwd = Sys.getcwd () in
|
|
||||||
match (repr t).state with
|
match (repr t).state with
|
||||||
| Return v -> v
|
| Return v -> v
|
||||||
| _ ->
|
| _ ->
|
||||||
while Hashtbl.length running < !Clflags.concurrency &&
|
while Hashtbl.length running < !Clflags.concurrency &&
|
||||||
not (Queue.is_empty to_run) do
|
not (Queue.is_empty to_run) do
|
||||||
let job = Queue.pop to_run in
|
let job = Queue.pop to_run in
|
||||||
|
let id = gen_id () in
|
||||||
|
let command_line = command_line job in
|
||||||
if !Clflags.debug_run then
|
if !Clflags.debug_run then
|
||||||
Printf.eprintf "Running: %s\n%!" (command_line job);
|
Printf.eprintf "Running[%d]: %s\n%!" id
|
||||||
|
(strip_colors_for_stderr command_line);
|
||||||
|
Option.iter job.dir ~f:(fun dir -> Sys.chdir dir);
|
||||||
|
let argv = Array.of_list (job.prog :: job.args) in
|
||||||
|
let output_filename = Filename.temp_file "jbuilder" ".output" in
|
||||||
|
let output_fd = Unix.openfile output_filename [O_WRONLY] 0 in
|
||||||
let stdout, close_stdout =
|
let stdout, close_stdout =
|
||||||
match job.stdout_to with
|
match job.stdout_to with
|
||||||
| None -> (Unix.stdout, false)
|
| None -> (output_fd, false)
|
||||||
| Some fn ->
|
| Some fn ->
|
||||||
let fd = Unix.openfile fn [O_WRONLY; O_CREAT; O_TRUNC] 0o666 in
|
let fd = Unix.openfile fn [O_WRONLY; O_CREAT; O_TRUNC] 0o666 in
|
||||||
(fd, true)
|
(fd, true)
|
||||||
in
|
in
|
||||||
Option.iter job.dir ~f:(fun dir -> Sys.chdir dir);
|
|
||||||
let argv = Array.of_list (job.prog :: job.args) in
|
|
||||||
let pid =
|
let pid =
|
||||||
match job.env with
|
match job.env with
|
||||||
| None ->
|
| None ->
|
||||||
Unix.create_process job.prog argv
|
Unix.create_process job.prog argv
|
||||||
Unix.stdin stdout Unix.stderr
|
Unix.stdin stdout output_fd
|
||||||
| Some env ->
|
| Some env ->
|
||||||
Unix.create_process_env job.prog argv env
|
Unix.create_process_env job.prog argv env
|
||||||
Unix.stdin stdout Unix.stderr
|
Unix.stdin stdout output_fd
|
||||||
in
|
in
|
||||||
|
Unix.close output_fd;
|
||||||
if close_stdout then Unix.close stdout;
|
if close_stdout then Unix.close stdout;
|
||||||
Option.iter job.dir ~f:(fun _ -> Sys.chdir cwd);
|
Option.iter job.dir ~f:(fun _ -> Sys.chdir cwd);
|
||||||
Hashtbl.add running ~key:pid ~data:job
|
Hashtbl.add running ~key:pid
|
||||||
|
~data:{ id
|
||||||
|
; job
|
||||||
|
; pid
|
||||||
|
; output_filename
|
||||||
|
; command_line
|
||||||
|
; log
|
||||||
|
}
|
||||||
done;
|
done;
|
||||||
if Sys.win32 then
|
if Sys.win32 then
|
||||||
wait_win32 ()
|
wait_win32 ()
|
||||||
|
@ -324,8 +356,11 @@ module Scheduler = struct
|
||||||
Hashtbl.find_exn running pid ~string_of_key:(sprintf "<pid:%d>")
|
Hashtbl.find_exn running pid ~string_of_key:(sprintf "<pid:%d>")
|
||||||
~table_desc:(fun _ -> "<running-jobs>")
|
~table_desc:(fun _ -> "<running-jobs>")
|
||||||
in
|
in
|
||||||
Hashtbl.remove running pid;
|
|
||||||
process_done job status
|
process_done job status
|
||||||
end;
|
end;
|
||||||
go t
|
go_rec cwd log t
|
||||||
|
|
||||||
|
let go ?log t =
|
||||||
|
let cwd = Sys.getcwd () in
|
||||||
|
go_rec cwd log t
|
||||||
end
|
end
|
||||||
|
|
|
@ -43,5 +43,5 @@ val run_capture_lines
|
||||||
-> string list t
|
-> string list t
|
||||||
|
|
||||||
module Scheduler : sig
|
module Scheduler : sig
|
||||||
val go : 'a t -> 'a
|
val go : ?log:out_channel -> 'a t -> 'a
|
||||||
end
|
end
|
||||||
|
|
|
@ -348,3 +348,18 @@ end = struct
|
||||||
end
|
end
|
||||||
|
|
||||||
type fail = { fail : 'a. unit -> 'a }
|
type fail = { fail : 'a. unit -> 'a }
|
||||||
|
|
||||||
|
let quote_for_shell s =
|
||||||
|
let len = String.length s in
|
||||||
|
if len = 0 then
|
||||||
|
Filename.quote s
|
||||||
|
else
|
||||||
|
let rec loop i =
|
||||||
|
if i = len then
|
||||||
|
s
|
||||||
|
else
|
||||||
|
match s.[i] with
|
||||||
|
| ' ' | '\"' -> Filename.quote s
|
||||||
|
| _ -> loop (i + 1)
|
||||||
|
in
|
||||||
|
loop 0
|
||||||
|
|
14
src/main.ml
14
src/main.ml
|
@ -11,8 +11,8 @@ let setup ?filter_out_optional_stanzas_with_missing_deps () =
|
||||||
let bs = Build_system.create ~file_tree ~rules in
|
let bs = Build_system.create ~file_tree ~rules in
|
||||||
return (bs, stanzas, ctx)
|
return (bs, stanzas, ctx)
|
||||||
|
|
||||||
let external_lib_deps ~packages =
|
let external_lib_deps ?log ~packages =
|
||||||
Future.Scheduler.go
|
Future.Scheduler.go ?log
|
||||||
(setup () ~filter_out_optional_stanzas_with_missing_deps:false
|
(setup () ~filter_out_optional_stanzas_with_missing_deps:false
|
||||||
>>| fun (bs, stanzas, _) ->
|
>>| fun (bs, stanzas, _) ->
|
||||||
Path.Map.map
|
Path.Map.map
|
||||||
|
@ -63,6 +63,14 @@ let report_error ?map_fname ppf exn =
|
||||||
let backtrace = Printexc.get_raw_backtrace () in
|
let backtrace = Printexc.get_raw_backtrace () in
|
||||||
report_error ?map_fname ppf exn ~backtrace
|
report_error ?map_fname ppf exn ~backtrace
|
||||||
|
|
||||||
|
let create_log () =
|
||||||
|
if not (Sys.file_exists "_build") then
|
||||||
|
Unix.mkdir "_build" 0o777;
|
||||||
|
let oc = open_out_bin "_build/log" in
|
||||||
|
Printf.fprintf oc "# %s\n%!"
|
||||||
|
(String.concat (List.map (Array.to_list Sys.argv) ~f:quote_for_shell) ~sep:" ");
|
||||||
|
oc
|
||||||
|
|
||||||
(* Called by the script generated by ../build.ml *)
|
(* Called by the script generated by ../build.ml *)
|
||||||
let bootstrap () =
|
let bootstrap () =
|
||||||
let pkg = "jbuilder" in
|
let pkg = "jbuilder" in
|
||||||
|
@ -70,7 +78,7 @@ let bootstrap () =
|
||||||
let anon s = raise (Arg.Bad (Printf.sprintf "don't know what to do with %s\n" s)) in
|
let anon s = raise (Arg.Bad (Printf.sprintf "don't know what to do with %s\n" s)) in
|
||||||
Arg.parse [ "-j", Set_int Clflags.concurrency, "JOBS concurrency" ]
|
Arg.parse [ "-j", Set_int Clflags.concurrency, "JOBS concurrency" ]
|
||||||
anon "Usage: boot.exe [-j JOBS]\nOptions are:";
|
anon "Usage: boot.exe [-j JOBS]\nOptions are:";
|
||||||
Future.Scheduler.go
|
Future.Scheduler.go ~log:(create_log ())
|
||||||
(setup () >>= fun (bs, _, _) ->
|
(setup () >>= fun (bs, _, _) ->
|
||||||
Build_system.do_build_exn bs [Path.(relative root) (pkg ^ ".install")])
|
Build_system.do_build_exn bs [Path.(relative root) (pkg ^ ".install")])
|
||||||
in
|
in
|
||||||
|
|
|
@ -4,7 +4,12 @@ val setup
|
||||||
-> unit
|
-> unit
|
||||||
-> (Build_system.t * (Path.t * Jbuild_types.Stanza.t list) list * Context.t)
|
-> (Build_system.t * (Path.t * Jbuild_types.Stanza.t list) list * Context.t)
|
||||||
Future.t
|
Future.t
|
||||||
val external_lib_deps : packages:string list -> Build.lib_deps Path.Map.t
|
val external_lib_deps
|
||||||
|
: ?log:out_channel
|
||||||
|
-> packages:string list
|
||||||
|
-> Build.lib_deps Path.Map.t
|
||||||
val report_error : ?map_fname:(string -> string) -> Format.formatter -> exn -> unit
|
val report_error : ?map_fname:(string -> string) -> Format.formatter -> exn -> unit
|
||||||
|
|
||||||
val bootstrap : unit -> unit
|
val bootstrap : unit -> unit
|
||||||
|
|
||||||
|
val create_log : unit -> out_channel
|
||||||
|
|
Loading…
Reference in New Issue