Don't on side-effects for setting up the environment

Instead of making sure we set global variables and call Unix.putenv in
the right order, pass the environment explicitely everywhere.

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"

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

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
+  match Env.get Env.initial "PATH" with
-  | exception Not_found -> []
+  | None   -> []
-  | s -> parse_path s
+  | Some s -> parse_path s
 
 let exe = if Sys.win32 then ".exe" else ""
 

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
+  match Env.get Env.initial "TERM" with
-  | exception Not_found -> false
+  | None        -> false
-  | "dumb" -> false
+  | Some "dumb" -> false
-  | _ -> true
+  | 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(
+let setup_env_for_colors env =
-  if !Clflags.capture_outputs && Lazy.force stderr_supports_colors then begin
+  let set env var value =
-    let set var value =
+    Env.update env ~var ~f:(function
-      match Sys.getenv var with
+      | None   -> Some value
-      | exception Not_found -> Unix.putenv var value
+      | Some s -> Some s)
-      | (_ : string) -> ()
+  in
-    in
+  let env = set env "OPAMCOLOR"   "always" in
-    set "OPAMCOLOR" "always";
+  let env = set env "OCAML_COLOR" "always" in
-    set "OCAML_COLOR" "always";
+  env
-  end
-)
 
 module Style = struct
   open Ansi_color.Style

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

src/config.ml

@@ -87,9 +87,9 @@ let load_user_config_file () =
     default
 
 let inside_emacs =
-  match Sys.getenv "INSIDE_EMACS" with
+  match Env.get Env.initial "INSIDE_EMACS" with
-  | (_ : string) -> true
+  | Some _ -> true
-  | exception Not_found -> false
+  | None   -> false
 
 let adapt_display config ~output_is_a_tty =
   if config.display = Progress &&

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
+      (* When OCAMLFIND_CONF is set, "ocamlfind printconf" does print
-         variable, but "ocamlfind printconf conf" still prints the configuration file set
+         the contents of the variable, but "ocamlfind printconf conf"
-         at the configuration time of ocamlfind, sigh... *)
+         still prints the configuration file set at the configuration
-      match Sys.getenv "OCAMLFIND_CONF" with
+         time of ocamlfind, sigh... *)
-      | s -> Fiber.return (Path.absolute s)
+      match Env.get env "OCAMLFIND_CONF" with
-      | exception Not_found ->
+      | 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 () =
+let default ?(merlin=true) ~env ~targets () =
-  create ~kind:Default ~path:Bin.path ~env:(Env.initial ())
+  create ~kind:Default ~path:Bin.path ~env ~name:"default" ~merlin ~targets ()
-    ~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
 

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
 

src/env.ml

@@ -49,14 +49,7 @@ let of_unix arr =
     | [] -> assert false
     | x::_ -> x)
 
-let initial =
+let initial = make (of_unix (Unix.environment ()))
-  let i =
-    lazy (
-      make (Lazy.force Colors.setup_env_for_colors;
-            Unix.environment ()
-            |> of_unix)
-    ) in
-  fun () -> Lazy.force i
 
 let add t ~var ~value =
   make (Map.add t.vars var value)

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
 

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
+    (match Env.get Env.initial "OCAMLPARAM" with
-     | s -> Printf.sprintf "%S" s
+     | Some s -> Printf.sprintf "%S" s
-     | exception Not_found -> "unset");
+     | None   -> "unset");
   let buf = Buffer.create 1024 in
   let ppf = Format.formatter_of_buffer buf in
   Some { oc; buf; ppf; display }

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 =

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. *)

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

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
+    Unix.create_process_env prog argv (Env.to_unix env)
-    | None ->
+      Unix.stdin stdout stderr
-      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
   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 =
+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 ->
+  run_capture_gen ?dir ~env ~purpose fail_mode prog args ~f:(fun fn ->
     match Io.lines_of_file fn with
     | [x] -> x
     | l ->

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

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

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