From 901d9acc2ad6aa23d49e3229407cd1e3c6453f0e Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Thu, 23 Feb 2017 11:45:03 +0000 Subject: [PATCH] Don't mangle the output of commands and keep a log file --- bin/main.ml | 11 ++-- src/ansi_color.ml | 20 ++++++ src/ansi_color.mli | 1 + src/future.ml | 151 ++++++++++++++++++++++++++++----------------- src/future.mli | 2 +- src/import.ml | 15 +++++ src/main.ml | 14 ++++- src/main.mli | 7 ++- 8 files changed, 154 insertions(+), 67 deletions(-) diff --git a/bin/main.ml b/bin/main.ml index 69a964a2..d4e18763 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -6,12 +6,14 @@ module Main = Jbuilder.Main let (>>=) = Future.(>>=) +let create_log = Main.create_log + (* TODO: rewrite this when command trees are supported. https://github.com/dbuenzli/cmdliner/issues/24 *) let internal = function | [_; "findlib-packages"] -> - Future.Scheduler.go + Future.Scheduler.go ~log:(create_log ()) (Lazy.force Context.default >>= fun ctx -> let findlib = Findlib.create ctx in let pkgs = Findlib.all_packages findlib in @@ -71,7 +73,7 @@ let common = Term.(const make $ concurrency $ drules $ ddep_path $ dfindlib) let build_package pkg = - Future.Scheduler.go + Future.Scheduler.go ~log:(create_log ()) (Main.setup () >>= fun (bs, _, _) -> 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) let external_lib_deps packages = + let log = create_log () in 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) in 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 go common targets = set_common common; - Future.Scheduler.go + Future.Scheduler.go ~log:(create_log ()) (Main.setup () >>= fun (bs, _, ctx) -> let targets = resolve_targets bs ctx targets in Build_system.do_build_exn bs targets) in diff --git a/src/ansi_color.ml b/src/ansi_color.ml index 496f8c4d..249c29cb 100644 --- a/src/ansi_color.ml +++ b/src/ansi_color.ml @@ -87,3 +87,23 @@ let colorize = let hash = Hashtbl.hash key in let fore, back = color_combos.(hash mod (Array.length color_combos)) in 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 diff --git a/src/ansi_color.mli b/src/ansi_color.mli index 2275b79a..202e7430 100644 --- a/src/ansi_color.mli +++ b/src/ansi_color.mli @@ -1 +1,2 @@ val colorize : key:string -> string -> string +val strip : string -> string diff --git a/src/future.ml b/src/future.ml index bcd0b049..b21e3b74 100644 --- a/src/future.ml +++ b/src/future.ml @@ -192,47 +192,17 @@ let run_capture_line ?dir ?env prog args = cmdline (String.concat l ~sep:"\n") 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 s = Filename.basename prog in match String.lsplit2 s ~on:'.' with | None -> s | Some (s, _) -> s - let err_is_atty = lazy Unix.(isatty stderr) - - 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 command_line { prog; args; dir; stdout_to; _ } = + let quote = quote_for_shell in let prog = let s = quote prog in - if colorize then - Ansi_color.colorize ~key:(key_for_color prog) s - else - s + Ansi_color.colorize ~key:(key_for_color prog) s in let s = String.concat (prog :: List.map args ~f:quote) ~sep:" " in let s = @@ -244,19 +214,70 @@ module Scheduler = struct | None -> s | Some dir -> sprintf "(cd %s && %s)" dir s - let handle_process_status cmd (status : Unix.process_status) = - match status with - | WEXITED 0 -> () - | WEXITED n -> die "Command exited with code %d: %s" n (Lazy.force cmd) - | WSIGNALED n -> die "Command got killed by signal %d: %s" n (Lazy.force cmd) - | WSTOPPED _ -> assert false + let strip_colors_for_stderr = + let strip = lazy ( + Sys.win32 || + not (Unix.(isatty stderr)) || + match Sys.getenv "TERM" with + | 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 = - handle_process_status (lazy (command_line job)) status; - Ivar.fill job.ivar () + type running_job = + { id : int + ; 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 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 finished = Hashtbl.fold running ~init:[] ~f:(fun ~key:pid ~data:job acc -> @@ -272,49 +293,60 @@ module Scheduler = struct wait_win32 () | _ -> List.iter finished ~f:(fun (pid, job, status) -> - Hashtbl.remove running pid; process_done job status) let () = at_exit (fun () -> 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 - List.iter pids ~f:(fun pid -> - ignore (Unix.waitpid [] pid : _ * _); - Hashtbl.remove running pid)) + List.iter pids ~f:(fun job -> + let _, status = Unix.waitpid [] job.pid in + process_done job status ~exiting:true)) - let rec go t = - let cwd = Sys.getcwd () in + let rec go_rec cwd log t = match (repr t).state with | Return v -> v | _ -> while Hashtbl.length running < !Clflags.concurrency && not (Queue.is_empty to_run) do let job = Queue.pop to_run in + let id = gen_id () in + let command_line = command_line job in 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 = match job.stdout_to with - | None -> (Unix.stdout, false) + | None -> (output_fd, false) | Some fn -> let fd = Unix.openfile fn [O_WRONLY; O_CREAT; O_TRUNC] 0o666 in (fd, true) in - Option.iter job.dir ~f:(fun dir -> Sys.chdir dir); - let argv = Array.of_list (job.prog :: job.args) in let pid = match job.env with | None -> Unix.create_process job.prog argv - Unix.stdin stdout Unix.stderr + Unix.stdin stdout output_fd | Some env -> Unix.create_process_env job.prog argv env - Unix.stdin stdout Unix.stderr + Unix.stdin stdout output_fd in + Unix.close output_fd; if close_stdout then Unix.close stdout; 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; if Sys.win32 then wait_win32 () @@ -324,8 +356,11 @@ module Scheduler = struct Hashtbl.find_exn running pid ~string_of_key:(sprintf "") ~table_desc:(fun _ -> "") in - Hashtbl.remove running pid; process_done job status end; - go t + go_rec cwd log t + + let go ?log t = + let cwd = Sys.getcwd () in + go_rec cwd log t end diff --git a/src/future.mli b/src/future.mli index e20230d6..a2f099df 100644 --- a/src/future.mli +++ b/src/future.mli @@ -43,5 +43,5 @@ val run_capture_lines -> string list t module Scheduler : sig - val go : 'a t -> 'a + val go : ?log:out_channel -> 'a t -> 'a end diff --git a/src/import.ml b/src/import.ml index fb2e179b..72cbf5c9 100644 --- a/src/import.ml +++ b/src/import.ml @@ -348,3 +348,18 @@ end = struct end 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 diff --git a/src/main.ml b/src/main.ml index 6d8b5e93..355d3328 100644 --- a/src/main.ml +++ b/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 return (bs, stanzas, ctx) -let external_lib_deps ~packages = - Future.Scheduler.go +let external_lib_deps ?log ~packages = + Future.Scheduler.go ?log (setup () ~filter_out_optional_stanzas_with_missing_deps:false >>| fun (bs, stanzas, _) -> Path.Map.map @@ -63,6 +63,14 @@ let report_error ?map_fname ppf exn = let backtrace = Printexc.get_raw_backtrace () in 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 *) let bootstrap () = 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 Arg.parse [ "-j", Set_int Clflags.concurrency, "JOBS concurrency" ] anon "Usage: boot.exe [-j JOBS]\nOptions are:"; - Future.Scheduler.go + Future.Scheduler.go ~log:(create_log ()) (setup () >>= fun (bs, _, _) -> Build_system.do_build_exn bs [Path.(relative root) (pkg ^ ".install")]) in diff --git a/src/main.mli b/src/main.mli index 0e4e9775..ff9cd8b6 100644 --- a/src/main.mli +++ b/src/main.mli @@ -4,7 +4,12 @@ val setup -> unit -> (Build_system.t * (Path.t * Jbuild_types.Stanza.t list) list * Context.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 bootstrap : unit -> unit + +val create_log : unit -> out_channel