matthieu
/
dune
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
This commit is contained in:
Jeremie Dimino 2018-03-29 11:58:41 -04:00 committed by Rudi Grinberg
parent 24de79934b
commit 31858c9680
18 changed files with 97 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
bin/main.ml
View File

@ -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"

2
src/action.ml
View File

@ -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

6
src/bin.ml
View File

@ -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 ""

28
src/colors.ml
View File

@ -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

5
src/colors.mli
View File

@ -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

6
src/config.ml
View File

@ -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 &&

37
src/context.ml
View File

@ -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

1
src/context.mli
View File

@ -120,6 +120,7 @@ val compare : t -> t -> Ordering.t
val create
: ?merlin:bool
-> env:Env.t
-> Workspace.Context.t
-> t list Fiber.t

9
src/env.ml
View File

@ -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)

3
src/env.mli
View File

@ -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

6
src/log.ml
View File

@ -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 }

16
src/main.ml
View File

@ -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 =

5
src/main.mli
View File

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

6
src/print_diff.ml
View File

@ -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

23
src/process.ml
View File

@ -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 ->

8
src/process.mli
View File

@ -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

1
src/scheduler.ml
View File

@ -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

10
src/watermarks.ml
View File

@ -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