diff --git a/bin/main.ml b/bin/main.ml index 68afeee3..77347898 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -80,6 +80,7 @@ module Main = struct ?filter_out_optional_stanzas_with_missing_deps ?x:common.x ~ignore_promoted_rules:common.ignore_promoted_rules + ~capture_outputs:common.capture_outputs () end @@ -491,8 +492,9 @@ let installed_libraries = let doc = "Print out libraries installed on the system." in let go common na = set_common common ~targets:[]; + let env = Main.setup_env ~capture_outputs:common.capture_outputs in Scheduler.go ~log:(Log.create common) ~common - (Context.create (Default [Native]) >>= fun ctxs -> + (Context.create (Default [Native]) ~env >>= fun ctxs -> let ctx = List.hd ctxs in let findlib = ctx.findlib in if na then begin @@ -996,7 +998,8 @@ let install_uninstall ~what = >>= fun libdir -> Fiber.parallel_iter install_files ~f:(fun path -> let purpose = Process.Build_job install_files in - Process.run ~purpose Strict (Path.to_string opam_installer) + Process.run ~purpose ~env:setup.env Strict + (Path.to_string opam_installer) ([ sprintf "-%c" what.[0] ; Path.to_string path ; "--prefix" diff --git a/src/action.ml b/src/action.ml index f91ac157..e5ae3cf4 100644 --- a/src/action.ml +++ b/src/action.ml @@ -891,7 +891,7 @@ and exec_list l ~ectx ~dir ~env ~stdout_to ~stderr_to = let exec ~targets ~context t = let env = match (context : Context.t option) with - | None -> Env.initial () + | None -> Env.initial | Some c -> c.env in let targets = Path.Set.to_list targets in diff --git a/src/bin.ml b/src/bin.ml index 7b1d5adc..0af2d307 100644 --- a/src/bin.ml +++ b/src/bin.ml @@ -10,9 +10,9 @@ let parse_path ?(sep=path_sep) s = List.map (String.split s ~on:sep) ~f:Path.absolute let path = - match Sys.getenv "PATH" with - | exception Not_found -> [] - | s -> parse_path s + match Env.get Env.initial "PATH" with + | None -> [] + | Some s -> parse_path s let exe = if Sys.win32 then ".exe" else "" diff --git a/src/colors.ml b/src/colors.ml index 7eeb3951..f91eeff8 100644 --- a/src/colors.ml +++ b/src/colors.ml @@ -29,10 +29,10 @@ let colorize = let stderr_supports_colors = lazy( not Sys.win32 && Unix.(isatty stderr) && - match Sys.getenv "TERM" with - | exception Not_found -> false - | "dumb" -> false - | _ -> true + match Env.get Env.initial "TERM" with + | None -> false + | Some "dumb" -> false + | Some _ -> true ) let strip_colors_for_stderr s = @@ -45,17 +45,15 @@ let strip_colors_for_stderr s = tools will disable colors. Since we support colors in the output of commands, we force it via specific environment variables if stderr supports colors. *) -let setup_env_for_colors = lazy( - if !Clflags.capture_outputs && Lazy.force stderr_supports_colors then begin - let set var value = - match Sys.getenv var with - | exception Not_found -> Unix.putenv var value - | (_ : string) -> () - in - set "OPAMCOLOR" "always"; - set "OCAML_COLOR" "always"; - end -) +let setup_env_for_colors env = + let set env var value = + Env.update env ~var ~f:(function + | None -> Some value + | Some s -> Some s) + in + let env = set env "OPAMCOLOR" "always" in + let env = set env "OCAML_COLOR" "always" in + env module Style = struct open Ansi_color.Style diff --git a/src/colors.mli b/src/colors.mli index 078487ec..0e6bee3e 100644 --- a/src/colors.mli +++ b/src/colors.mli @@ -3,7 +3,10 @@ open Stdune val colorize : key:string -> string -> string val stderr_supports_colors : bool Lazy.t -val setup_env_for_colors : unit Lazy.t + +(** [Env.initial] extended with variables to force a few tools to + print colors *) +val setup_env_for_colors : Env.t -> Env.t (** Strip colors in [not (Lazy.force stderr_supports_colors)] *) val strip_colors_for_stderr : string -> string diff --git a/src/config.ml b/src/config.ml index 65731155..72392e32 100644 --- a/src/config.ml +++ b/src/config.ml @@ -87,9 +87,9 @@ let load_user_config_file () = default let inside_emacs = - match Sys.getenv "INSIDE_EMACS" with - | (_ : string) -> true - | exception Not_found -> false + match Env.get Env.initial "INSIDE_EMACS" with + | Some _ -> true + | None -> false let adapt_display config ~output_is_a_tty = if config.display = Progress && diff --git a/src/context.ml b/src/context.ml index cda1caec..4d0a90d8 100644 --- a/src/context.ml +++ b/src/context.ml @@ -91,7 +91,7 @@ let sexp_of_t t = ; "ocamlopt", option path t.ocamlopt ; "ocamldep", path t.ocamldep ; "ocamlmklib", path t.ocamlmklib - ; "env", Env.sexp_of_t (Env.diff t.env (Env.initial ())) + ; "env", Env.sexp_of_t (Env.diff t.env Env.initial) ; "findlib_path", list path (Findlib.path t.findlib) ; "arch_sixtyfour", bool t.arch_sixtyfour ; "natdynlink_supported", bool t.natdynlink_supported @@ -143,12 +143,13 @@ let create ~(kind : Kind.t) ~path ~env ~name ~merlin ~targets () = match which "ocamlfind" with | None -> prog_not_found_in_path "ocamlfind" | Some fn -> - (* When OCAMLFIND_CONF is set, "ocamlfind printconf" does print the contents of the - variable, but "ocamlfind printconf conf" still prints the configuration file set - at the configuration time of ocamlfind, sigh... *) - match Sys.getenv "OCAMLFIND_CONF" with - | s -> Fiber.return (Path.absolute s) - | exception Not_found -> + (* When OCAMLFIND_CONF is set, "ocamlfind printconf" does print + the contents of the variable, but "ocamlfind printconf conf" + still prints the configuration file set at the configuration + time of ocamlfind, sigh... *) + match Env.get env "OCAMLFIND_CONF" with + | Some s -> Fiber.return (Path.absolute s) + | None -> Process.run_capture_line ~env Strict (Path.to_string fn) ["printconf"; "conf"] >>| Path.absolute) @@ -208,7 +209,7 @@ let create ~(kind : Kind.t) ~path ~env ~name ~merlin ~targets () = context *) (* CR-someday diml: maybe we should actually clear OCAMLPATH in other build contexts *) - match Env.get env var, Env.get (Env.initial ()) var with + match Env.get env var, Env.get Env.initial var with | None , None -> None | Some s, None -> Some s | None , Some _ -> None @@ -399,20 +400,20 @@ let create ~(kind : Kind.t) ~path ~env ~name ~merlin ~targets () = let opam_config_var t var = opam_config_var ~env:t.env ~cache:t.opam_var_cache var -let default ?(merlin=true) ~targets () = - create ~kind:Default ~path:Bin.path ~env:(Env.initial ()) - ~name:"default" ~merlin ~targets () +let default ?(merlin=true) ~env ~targets () = + create ~kind:Default ~path:Bin.path ~env ~name:"default" ~merlin ~targets () -let create_for_opam ?root ~targets ~switch ~name ?(merlin=false) () = +let create_for_opam ?root ~env ~targets ~switch ~name ?(merlin=false) () = match Bin.opam with | None -> Utils.program_not_found "opam" | Some fn -> (match root with | Some root -> Fiber.return root | None -> - Process.run_capture_line Strict (Path.to_string fn) ["config"; "var"; "root"]) + Process.run_capture_line Strict ~env + (Path.to_string fn) ["config"; "var"; "root"]) >>= fun root -> - Process.run_capture Strict (Path.to_string fn) + Process.run_capture ~env Strict (Path.to_string fn) ["config"; "env"; "--root"; root; "--switch"; switch; "--sexp"] >>= fun s -> let vars = @@ -439,14 +440,14 @@ let create_for_opam ?root ~targets ~switch ~name ?(merlin=false) () = | None -> Bin.path | Some s -> Bin.parse_path s in - let env = Env.extend (Env.initial ()) ~vars in + let env = Env.extend env ~vars in create ~kind:(Opam { root; switch }) ~targets ~path ~env ~name ~merlin () -let create ?merlin def = +let create ?merlin ~env def = match (def : Workspace.Context.t) with - | Default targets -> default ~targets ?merlin () + | Default targets -> default ~env ~targets ?merlin () | Opam { name; switch; root; targets; _ } -> - create_for_opam ?root ~switch ~name ?merlin ~targets () + create_for_opam ?root ~env ~switch ~name ?merlin ~targets () let which t s = which ~cache:t.which_cache ~path:t.path s diff --git a/src/context.mli b/src/context.mli index 0513d3f7..461bba23 100644 --- a/src/context.mli +++ b/src/context.mli @@ -120,6 +120,7 @@ val compare : t -> t -> Ordering.t val create : ?merlin:bool + -> env:Env.t -> Workspace.Context.t -> t list Fiber.t diff --git a/src/env.ml b/src/env.ml index 4546584f..e5510ac7 100644 --- a/src/env.ml +++ b/src/env.ml @@ -49,14 +49,7 @@ let of_unix arr = | [] -> assert false | x::_ -> x) -let initial = - let i = - lazy ( - make (Lazy.force Colors.setup_env_for_colors; - Unix.environment () - |> of_unix) - ) in - fun () -> Lazy.force i +let initial = make (of_unix (Unix.environment ())) let add t ~var ~value = make (Map.add t.vars var value) diff --git a/src/env.mli b/src/env.mli index 904a8d15..25763588 100644 --- a/src/env.mli +++ b/src/env.mli @@ -9,7 +9,8 @@ type t module Map : Map.S with type key = Var.t -val initial : unit -> t +(** The environment when the process started *) +val initial : t val to_unix : t -> string array diff --git a/src/log.ml b/src/log.ml index 55697230..3297b850 100644 --- a/src/log.ml +++ b/src/log.ml @@ -17,9 +17,9 @@ let create ?(display=Config.default.display) () = let oc = Io.open_out "_build/log" in Printf.fprintf oc "# %s\n# OCAMLPARAM: %s\n%!" (String.concat (List.map (Array.to_list Sys.argv) ~f:quote_for_shell) ~sep:" ") - (match Sys.getenv "OCAMLPARAM" with - | s -> Printf.sprintf "%S" s - | exception Not_found -> "unset"); + (match Env.get Env.initial "OCAMLPARAM" with + | Some s -> Printf.sprintf "%S" s + | None -> "unset"); let buf = Buffer.create 1024 in let ppf = Format.formatter_of_buffer buf in Some { oc; buf; ppf; display } diff --git a/src/main.ml b/src/main.ml index 379adf8c..9e1ab887 100644 --- a/src/main.ml +++ b/src/main.ml @@ -9,6 +9,7 @@ type setup = ; contexts : Context.t list ; packages : Package.t Package.Name.Map.t ; file_tree : File_tree.t + ; env : Env.t } let package_install_file { packages; _ } pkg = @@ -18,6 +19,12 @@ let package_install_file { packages; _ } pkg = Ok (Path.relative p.path (Utils.install_file ~package:p.name ~findlib_toolchain:None)) +let setup_env ~capture_outputs = + if capture_outputs || not (Lazy.force Colors.stderr_supports_colors) then + Env.initial + else + Colors.setup_env_for_colors Env.initial + let setup ?(log=Log.no_log) ?filter_out_optional_stanzas_with_missing_deps ?workspace ?(workspace_file="jbuild-workspace") @@ -25,8 +32,12 @@ let setup ?(log=Log.no_log) ?extra_ignored_subtrees ?x ?ignore_promoted_rules + ?(capture_outputs=true) () = - let conf = Jbuild_load.load ?extra_ignored_subtrees ?ignore_promoted_rules () in + let env = setup_env ~capture_outputs in + let conf = + Jbuild_load.load ?extra_ignored_subtrees ?ignore_promoted_rules () + in Option.iter only_packages ~f:(fun set -> Package.Name.Set.iter set ~f:(fun pkg -> if not (Package.Name.Map.mem conf.packages pkg) then @@ -55,7 +66,7 @@ let setup ?(log=Log.no_log) Fiber.parallel_map workspace.contexts ~f:(fun ctx_def -> let name = Workspace.Context.name ctx_def in - Context.create ctx_def ~merlin:(workspace.merlin_context = Some name)) + Context.create ctx_def ~env ~merlin:(workspace.merlin_context = Some name)) >>= fun contexts -> let contexts = List.concat contexts in List.iter contexts ~f:(fun (ctx : Context.t) -> @@ -88,6 +99,7 @@ let setup ?(log=Log.no_log) ; contexts ; packages = conf.packages ; file_tree = conf.file_tree + ; env } let find_context_exn t ~name = diff --git a/src/main.mli b/src/main.mli index 3d474269..bd5fc74a 100644 --- a/src/main.mli +++ b/src/main.mli @@ -8,6 +8,7 @@ type setup = ; contexts : Context.t list ; packages : Package.t Package.Name.Map.t ; file_tree : File_tree.t + ; env : Env.t } (* Returns [Error ()] if [pkg] is unknown *) @@ -23,6 +24,7 @@ val setup -> ?only_packages:Package.Name.Set.t -> ?x:string -> ?ignore_promoted_rules:bool + -> ?capture_outputs:bool -> unit -> setup Fiber.t val external_lib_deps @@ -33,6 +35,9 @@ val external_lib_deps val find_context_exn : setup -> name:string -> Context.t +(** Setup the environment *) +val setup_env : capture_outputs:bool -> Env.t + (**/**) (* This is used to bootstrap jbuilder itself. It is not part of the public API. *) diff --git a/src/print_diff.ml b/src/print_diff.ml index f9715d6a..8a1639a4 100644 --- a/src/print_diff.ml +++ b/src/print_diff.ml @@ -24,7 +24,7 @@ let print path1 path2 = | None -> fallback () | Some prog -> Format.eprintf "%a@?" Loc.print loc; - Process.run ~dir Strict (Path.to_string prog) + Process.run ~dir ~env:Env.initial Strict (Path.to_string prog) ["-u"; file1; file2] >>= fun () -> fallback () @@ -35,7 +35,7 @@ let print path1 path2 = let cmd = sprintf "%s %s %s" cmd (quote_for_shell file1) (quote_for_shell file2) in - Process.run ~dir Strict (Path.to_string sh) [arg; cmd] + Process.run ~dir ~env:Env.initial Strict (Path.to_string sh) [arg; cmd] >>= fun () -> die "command reported no differences: %s" (if dir = "." then @@ -46,7 +46,7 @@ let print path1 path2 = match Bin.which "patdiff" with | None -> normal_diff () | Some prog -> - Process.run ~dir Strict (Path.to_string prog) + Process.run ~dir ~env:Env.initial Strict (Path.to_string prog) [ "-keep-whitespace" ; "-location-style"; "omake" ; if Lazy.force Colors.stderr_supports_colors then diff --git a/src/process.ml b/src/process.ml index a4dce485..5fee4593 100644 --- a/src/process.ml +++ b/src/process.ml @@ -209,7 +209,7 @@ let gen_id = let next = ref (-1) in fun () -> incr next; !next -let run_internal ?dir ?(stdout_to=Terminal) ?(stderr_to=Terminal) ?env ~purpose +let run_internal ?dir ?(stdout_to=Terminal) ?(stderr_to=Terminal) ~env ~purpose fail_mode prog args = Scheduler.wait_for_available_job () >>= fun scheduler -> @@ -238,13 +238,8 @@ let run_internal ?dir ?(stdout_to=Terminal) ?(stderr_to=Terminal) ?env ~purpose let stdout, close_stdout = get_std_output stdout_to ~default:stdout_fd in let stderr, close_stderr = get_std_output stderr_to ~default:stderr_fd in let run () = - match env with - | None -> - Unix.create_process prog argv - Unix.stdin stdout stderr - | Some env -> - Unix.create_process_env prog argv (Env.to_unix env) - Unix.stdin stdout stderr + Unix.create_process_env prog argv (Env.to_unix env) + Unix.stdin stdout stderr in let pid = match dir with @@ -319,16 +314,16 @@ let run_internal ?dir ?(stdout_to=Terminal) ?(stderr_to=Terminal) ?env ~purpose output | WSTOPPED _ -> assert false -let run ?dir ?stdout_to ?stderr_to ?env ?(purpose=Internal_job) fail_mode +let run ?dir ?stdout_to ?stderr_to ~env ?(purpose=Internal_job) fail_mode prog args = map_result fail_mode - (run_internal ?dir ?stdout_to ?stderr_to ?env ~purpose fail_mode prog args) + (run_internal ?dir ?stdout_to ?stderr_to ~env ~purpose fail_mode prog args) ~f:ignore -let run_capture_gen ?dir ?env ?(purpose=Internal_job) fail_mode prog args ~f = +let run_capture_gen ?dir ~env ?(purpose=Internal_job) fail_mode prog args ~f = let fn = Temp.create "jbuild" ".output" in map_result fail_mode - (run_internal ?dir ~stdout_to:(File fn) ?env ~purpose fail_mode prog args) + (run_internal ?dir ~stdout_to:(File fn) ~env ~purpose fail_mode prog args) ~f:(fun () -> let x = f fn in Temp.destroy fn; @@ -337,8 +332,8 @@ let run_capture_gen ?dir ?env ?(purpose=Internal_job) fail_mode prog args ~f = let run_capture = run_capture_gen ~f:Io.read_file let run_capture_lines = run_capture_gen ~f:Io.lines_of_file -let run_capture_line ?dir ?env ?(purpose=Internal_job) fail_mode prog args = - run_capture_gen ?dir ?env ~purpose fail_mode prog args ~f:(fun fn -> +let run_capture_line ?dir ~env ?(purpose=Internal_job) fail_mode prog args = + run_capture_gen ?dir ~env ~purpose fail_mode prog args ~f:(fun fn -> match Io.lines_of_file fn with | [x] -> x | l -> diff --git a/src/process.mli b/src/process.mli index ad406f8c..a83d7e2c 100644 --- a/src/process.mli +++ b/src/process.mli @@ -41,7 +41,7 @@ val run : ?dir:string -> ?stdout_to:std_output_to -> ?stderr_to:std_output_to - -> ?env:Env.t + -> env:Env.t -> ?purpose:purpose -> (unit, 'a) failure_mode -> string @@ -51,7 +51,7 @@ val run (** Run a command and capture its output *) val run_capture : ?dir:string - -> ?env:Env.t + -> env:Env.t -> ?purpose:purpose -> (string, 'a) failure_mode -> string @@ -59,7 +59,7 @@ val run_capture -> 'a Fiber.t val run_capture_line : ?dir:string - -> ?env:Env.t + -> env:Env.t -> ?purpose:purpose -> (string, 'a) failure_mode -> string @@ -67,7 +67,7 @@ val run_capture_line -> 'a Fiber.t val run_capture_lines : ?dir:string - -> ?env:Env.t + -> env:Env.t -> ?purpose:purpose -> (string list, 'a) failure_mode -> string diff --git a/src/scheduler.ml b/src/scheduler.ml index ad6a395e..065b9938 100644 --- a/src/scheduler.ml +++ b/src/scheduler.ml @@ -153,7 +153,6 @@ let rec go_rec t = let go ?(log=Log.no_log) ?(config=Config.default) ?(gen_status_line=fun () -> None) fiber = - Lazy.force Colors.setup_env_for_colors; Log.info log ("Workspace root: " ^ !Clflags.workspace_root); let cwd = Sys.getcwd () in if cwd <> initial_cwd then diff --git a/src/watermarks.ml b/src/watermarks.ml index 702d86dc..95d0ae1e 100644 --- a/src/watermarks.ml +++ b/src/watermarks.ml @@ -205,15 +205,19 @@ let subst_git ?name () = | Some x -> Path.to_string x | None -> Utils.program_not_found "git" in + let env = Env.initial in Fiber.fork_and_join (fun () -> Fiber.fork_and_join (fun () -> - Process.run_capture Strict git ["describe"; "--always"; "--dirty"]) + Process.run_capture Strict git ["describe"; "--always"; "--dirty"] + ~env) (fun () -> - Process.run_capture Strict git ["rev-parse"; rev])) + Process.run_capture Strict git ["rev-parse"; rev] + ~env)) (fun () -> - Process.run_capture_lines Strict git ["ls-tree"; "-r"; "--name-only"; rev]) + Process.run_capture_lines Strict git ["ls-tree"; "-r"; "--name-only"; rev] + ~env) >>= fun ((version, commit), files) -> let version = String.trim version in let commit = String.trim commit in