From 64570654def1a9f262a25c847103ca27655d1c8d Mon Sep 17 00:00:00 2001 From: Kate Date: Tue, 29 Oct 2024 18:50:40 +0000 Subject: [PATCH 1/2] Add OpamProcess.equal and compare --- src/core/opamProcess.ml | 6 ++++++ src/core/opamProcess.mli | 3 +++ 2 files changed, 9 insertions(+) diff --git a/src/core/opamProcess.ml b/src/core/opamProcess.ml index 2d810728ed2..8c18e8f61a3 100644 --- a/src/core/opamProcess.ml +++ b/src/core/opamProcess.ml @@ -254,6 +254,12 @@ type t = { p_tmp_files: string list; } +let equal p1 p2 = + (p1.p_pid : int) = (p2.p_pid : int) + +let compare p1 p2 = + Int.compare p1.p_pid p2.p_pid + let output_lines oc lines = List.iter (fun line -> output_string oc line; diff --git a/src/core/opamProcess.mli b/src/core/opamProcess.mli index 8455369e534..f38a3997af6 100644 --- a/src/core/opamProcess.mli +++ b/src/core/opamProcess.mli @@ -78,6 +78,9 @@ type t = { completion *) } +val equal : t -> t -> bool +val compare : t -> t -> int + (** Process results *) type result = { r_code : int; (** Process exit code, or 256 on error *) From c73333fd465723ec0dd57cbf8da647c9282b9cd6 Mon Sep 17 00:00:00 2001 From: Kate Date: Tue, 29 Oct 2024 18:50:47 +0000 Subject: [PATCH 2/2] Delay the creation of the context used when a package failed to build up until the package failed --- src/client/opamAction.ml | 4 ++-- src/client/opamCliMain.ml | 3 ++- src/client/opamSolution.ml | 3 ++- src/core/opamFilename.mli | 3 ++- src/core/opamParallel.ml | 2 +- src/core/opamProcess.ml | 31 ++++++++++++++++++------------- src/core/opamProcess.mli | 8 ++++---- src/core/opamSystem.mli | 11 ++++++----- 8 files changed, 37 insertions(+), 28 deletions(-) diff --git a/src/client/opamAction.ml b/src/client/opamAction.ml index 9fc844efd29..285aa0d940c 100644 --- a/src/client/opamAction.ml +++ b/src/client/opamAction.ml @@ -643,7 +643,7 @@ let make_command st opam ?dir ?text_command (cmd, args) = let cmd, args = OpamStd.Option.default (cmd, args) text_command in OpamProcess.make_command_text name ~args cmd in - let context = + let context () = let open OpamStd.Option.Op in String.concat " | " [ OpamVersion.(to_string current); @@ -687,7 +687,7 @@ let make_command st opam ?dir ?text_command (cmd, args) = in OpamSystem.make_command ~env ~name ?dir ~text ~resolve_path:OpamStateConfig.(not !r.dryrun) - ~metadata:["context", context] + ~metadata:(lazy ["context", context ()]) ~verbose:(OpamConsole.verbose () || OpamPackage.Name.Set.mem (OpamPackage.name nv) OpamClientConfig.(!r.verbose_on)) diff --git a/src/client/opamCliMain.ml b/src/client/opamCliMain.ml index cabdb6322ca..2889034ef21 100644 --- a/src/client/opamCliMain.ml +++ b/src/client/opamCliMain.ml @@ -385,7 +385,8 @@ let rec main_catch_all f = OpamConsole.errmsg "%s Command %S failed:\n%s\n" (OpamConsole.colorise `red "[ERROR]") (try - OpamStd.List.assoc String.equal "command" result.OpamProcess.r_info + OpamStd.List.assoc String.equal "command" + (Lazy.force result.OpamProcess.r_info) with Not_found -> "") (Printexc.to_string e); OpamConsole.errmsg "%s" (OpamStd.Exn.pretty_backtrace e); diff --git a/src/client/opamSolution.ml b/src/client/opamSolution.ml index 60280adf916..947e70b80c7 100644 --- a/src/client/opamSolution.ml +++ b/src/client/opamSolution.ml @@ -294,7 +294,8 @@ module Json = struct `O [ ("process-error", `O ([ ("code", `String (string_of_int r_code)); ("duration", `Float r_duration); - ("info", `O (lmap (fun (k,v) -> (k, `String v)) r_info)); ] + ("info", `O (lmap (fun (k,v) -> (k, `String v)) + (Lazy.force r_info))); ] @ if OpamCoreConfig.(!r.merged_output) then [("output", `A (lmap (fun s -> `String s) r_stdout))] else diff --git a/src/core/opamFilename.mli b/src/core/opamFilename.mli index c9b2589ff4f..4b31f40b491 100644 --- a/src/core/opamFilename.mli +++ b/src/core/opamFilename.mli @@ -63,7 +63,8 @@ val env_of_list: (string * string) list -> string array (** Execute a list of commands in a given directory *) val exec: Dir.t -> ?env:(string * string) list -> ?name:string -> - ?metadata:(string * string) list -> ?keep_going:bool -> string list list -> unit + ?metadata:(string * string) list Lazy.t -> ?keep_going:bool -> + string list list -> unit (** Move a directory *) val move_dir: src:Dir.t -> dst:Dir.t -> unit diff --git a/src/core/opamParallel.ml b/src/core/opamParallel.ml index 6a288253ed3..2f17e24f894 100644 --- a/src/core/opamParallel.ml +++ b/src/core/opamParallel.ml @@ -292,7 +292,7 @@ module Make (G : G) = struct | _ -> OpamProcess.wait_one (List.map fst processes) with e -> fail (fst (snd (List.hd processes))) e in - let n,cont = OpamStd.(List.assoc Compare.equal process processes) in + let n,cont = OpamStd.List.assoc OpamProcess.equal process processes in log "Collected task for job %a (ret:%d)" (slog (string_of_int @* V.hash)) n result.OpamProcess.r_code; let next = diff --git a/src/core/opamProcess.ml b/src/core/opamProcess.ml index 8c18e8f61a3..b2dc69d5ce6 100644 --- a/src/core/opamProcess.ml +++ b/src/core/opamProcess.ml @@ -208,7 +208,7 @@ type command = { cmd_stdout: string option; cmd_verbose: bool option; cmd_name: string option; - cmd_metadata: (string * string) list option; + cmd_metadata: (string * string) list Lazy.t option; } let string_of_command c = String.concat " " (c.cmd::c.args) @@ -249,7 +249,7 @@ type t = { p_stderr : string option; p_env : string option; p_info : string option; - p_metadata: (string * string) list; + p_metadata: (string * string) list Lazy.t; p_verbose: bool; p_tmp_files: string list; } @@ -334,7 +334,8 @@ let create_process_env = environment can also be overridden if [env] is set. The environment which is used to run the process is recorded into [env_file] (if set). *) -let create ?info_file ?env_file ?(allow_stdin=not Sys.win32) ?stdout_file ?stderr_file ?env ?(metadata=[]) ?dir +let create ?info_file ?env_file ?(allow_stdin=not Sys.win32) + ?stdout_file ?stderr_file ?env ?(metadata=Lazy.from_val []) ?dir ~verbose ~tmp_files cmd args = let nothing () = () in let tee f = @@ -394,7 +395,9 @@ let create ?info_file ?env_file ?(allow_stdin=not Sys.win32) ?stdout_file ?stder | Some f -> let chan = open_out f in let info = - make_info ~cmd ~args ~cwd ~env_file ~stdout_file ~stderr_file ~metadata () in + make_info ~cmd ~args ~cwd ~env_file ~stdout_file ~stderr_file + ~metadata:(Lazy.force metadata) () + in output_string chan (string_of_info info); close_out chan in @@ -484,7 +487,7 @@ type result = { r_code : int; r_signal : int option; r_duration : float; - r_info : (string * string) list; + r_info : (string * string) list Lazy.t; r_stdout : string list; r_stderr : string list; r_cleanup : string list; @@ -494,7 +497,7 @@ let empty_result = { r_code = 0; r_signal = None; r_duration = 0.; - r_info = []; + r_info = Lazy.from_val []; r_stdout = []; r_stderr = []; r_cleanup = []; @@ -580,7 +583,7 @@ let dry_run_background c = { p_stderr = None; p_env = None; p_info = None; - p_metadata = OpamStd.Option.default [] c.cmd_metadata; + p_metadata = OpamStd.Option.default (Lazy.from_val []) c.cmd_metadata; p_verbose = is_verbose_command c; p_tmp_files = []; } @@ -612,7 +615,7 @@ let set_verbose_f, print_verbose_f, isset_verbose_f, stop_verbose_f = (* implem relies on sigalrm, not implemented on win32. This will fall back to buffered output. *) if Sys.win32 then () else - let files = OpamStd.List.sort_nodup compare files in + let files = OpamStd.List.sort_nodup String.compare files in let ics = List.map (open_in_gen [Open_nonblock;Open_rdonly;Open_text;Open_creat] 0o600) @@ -658,10 +661,12 @@ let exit_status p return = if p.p_stdout <> p.p_stderr then List.iter verbose_print_out stderr; flush Stdlib.stdout); - let info = + let info = lazy begin make_info ?code ?signal - ~cmd:p.p_name ~args:p.p_args ~cwd:p.p_cwd ~metadata:p.p_metadata - ~env_file:p.p_env ~stdout_file:p.p_stdout ~stderr_file:p.p_stderr () in + ~cmd:p.p_name ~args:p.p_args ~cwd:p.p_cwd + ~metadata:(Lazy.force p.p_metadata) ~env_file:p.p_env + ~stdout_file:p.p_stdout ~stderr_file:p.p_stderr () + end in { r_code = OpamStd.Option.default 256 code; r_signal = signal; @@ -825,7 +830,7 @@ let string_of_result ?(color=`yellow) r = print str; Buffer.add_char b '\n' in - print (string_of_info ~color r.r_info); + print (string_of_info ~color (Lazy.force r.r_info)); if r.r_stdout <> [] then if r.r_stderr = r.r_stdout then @@ -849,7 +854,7 @@ let string_of_result ?(color=`yellow) r = let result_summary r = Printf.sprintf "%S exited with code %d%s" - (try OpamStd.List.assoc String.equal "command" r.r_info + (try OpamStd.List.assoc String.equal "command" (Lazy.force r.r_info) with Not_found -> "command") r.r_code (if r.r_code = 0 then "" else diff --git a/src/core/opamProcess.mli b/src/core/opamProcess.mli index f38a3997af6..6871eafaaf2 100644 --- a/src/core/opamProcess.mli +++ b/src/core/opamProcess.mli @@ -22,7 +22,7 @@ type command = private { cmd_stdout: string option; cmd_verbose: bool option; cmd_name: string option; - cmd_metadata: (string * string) list option; + cmd_metadata: (string * string) list Lazy.t option; } (** Builds a shell command for later execution. @@ -40,7 +40,7 @@ val command: ?env:string array -> ?verbose:bool -> ?name:string -> - ?metadata:(string*string) list -> + ?metadata:(string * string) list Lazy.t -> ?dir:string -> ?allow_stdin:bool -> ?stdout:string -> @@ -71,7 +71,7 @@ type t = { p_stderr : string option; (** stderr dump file *) p_env : string option; (** dump environment variables *) p_info : string option; (** dump process info *) - p_metadata: (string * string) list; (** Metadata associated to the process *) + p_metadata: (string * string) list Lazy.t; (** Metadata associated to the process *) p_verbose: bool; (** whether output of the process should be displayed *) p_tmp_files: string list; (** temporary files that should be cleaned up upon @@ -86,7 +86,7 @@ type result = { r_code : int; (** Process exit code, or 256 on error *) r_signal : int option; (** Signal received if the processed was killed *) r_duration : float; (** Process duration *) - r_info : (string * string) list; (** Process info *) + r_info : (string * string) list Lazy.t; (** Process info *) r_stdout : string list; (** Content of stdout dump file *) r_stderr : string list; (** Content of stderr dump file *) r_cleanup : string list; (** List of files to clean-up *) diff --git a/src/core/opamSystem.mli b/src/core/opamSystem.mli index 9f8e3de2a9d..a4800f8dc0a 100644 --- a/src/core/opamSystem.mli +++ b/src/core/opamSystem.mli @@ -186,8 +186,8 @@ val directories_with_links: string -> string list case you can end up with a process error instead) *) val make_command: ?verbose:bool -> ?env:string array -> ?name:string -> ?text:string -> - ?metadata:(string * string) list -> ?allow_stdin:bool -> ?stdout:string -> - ?dir:string -> ?resolve_path:bool -> + ?metadata:(string * string) list Lazy.t -> ?allow_stdin:bool -> + ?stdout:string -> ?dir:string -> ?resolve_path:bool -> string -> string list -> OpamProcess.command (** OLD COMMAND API, DEPRECATED *) @@ -222,14 +222,15 @@ val apply_cygpath: string -> string (** [command cmd] executes the command [cmd] in the correct OPAM environment. *) val command: ?verbose:bool -> ?env:string array -> ?name:string -> - ?metadata:(string * string) list -> ?allow_stdin:bool -> + ?metadata:(string * string) list Lazy.t -> ?allow_stdin:bool -> command -> unit (** [commands cmds] executes the commands [cmds] in the correct OPAM environment. It stops whenever one command fails unless [keep_going] is set to [true]. In this case, the first error is re-raised at the end. *) val commands: ?verbose:bool -> ?env:string array -> ?name:string -> - ?metadata:(string * string) list -> ?keep_going:bool -> command list -> unit + ?metadata:(string * string) list Lazy.t -> ?keep_going:bool -> + command list -> unit (** [read_command_output cmd] executes the command [cmd] in the correct OPAM environment and return the lines from output if the command @@ -238,7 +239,7 @@ val commands: ?verbose:bool -> ?env:string array -> ?name:string -> It returns stdout and stder combiend, unless [ignore_stderr] is st to true. *) val read_command_output: ?verbose:bool -> ?env:string array -> - ?metadata:(string * string) list -> ?allow_stdin:bool -> + ?metadata:(string * string) list Lazy.t -> ?allow_stdin:bool -> ?ignore_stderr:bool -> command -> string list (** END *)