Merge pull request #1599 from dra27/win-env-tests

Ensure env vars don't exist prior to win-env test

Changes

@@ -64,6 +64,10 @@ Working version
 
 ### Internal/compiler-libs changes:
 
+- #1599: add unset directive to ocamltest to clear environment variables before
+  running tests.
+  (David Allsopp, review by Damien Doligez and Sébastien Hinderer)
+
 - #10433: Remove the distinction between 32-bit aligned and 64-bit aligned
   64-bit floats in Cmm.memory_chunk.
   (Greta Yorsh, review by Xavier Leroy)

ocamltest/actions_helpers.ml

@@ -160,9 +160,9 @@ let run_cmd
   log_redirection "stdout" stdout_filename;
   log_redirection "stderr" stderr_filename;
   let systemenv =
-    Array.append
+    Environments.append_to_system_env
       environment
-      (Environments.to_system_env env)
+      env
   in
   let timeout =
     match timeout with

ocamltest/environments.ml

@@ -19,12 +19,14 @@ open Ocamltest_stdlib
 
 module VariableMap = Map.Make (Variables)
 
-type t = string VariableMap.t
+type t = string option VariableMap.t
 
 let empty = VariableMap.empty
 
 let to_bindings env =
-  let f variable value lst = (variable, value) :: lst in
+  let f variable value lst =
+    Option.fold ~none:lst ~some:(fun value -> (variable, value) :: lst) value
+  in
   VariableMap.fold f env []
 
 let expand_aux env value =
@@ -39,16 +41,48 @@ let rec expand env value =
   let expanded = expand_aux env value in
   if expanded=value then value else expand env expanded
 
-let to_system_env env =
+let expand env = function
+  | None -> raise Not_found
+  | Some value -> expand env value
+
+let append_to_system_env environment env =
+  (* Augment env with any bindings which are only in environment. This must be
+     done here as the Windows C implementation doesn't process multiple values
+     in settings.envp. *)
+  let env =
+    let update env binding =
+      let name, value =
+        match String.index binding '=' with
+        | c ->
+            let name = String.sub binding 0 c in
+            let value =
+              String.sub binding (c + 1) (String.length binding - c - 1) in
+            (name, Some value)
+        | exception Not_found ->
+            (binding, None)
+      in
+      let var = Variables.make (name, "system env var") in
+        if not (VariableMap.mem var env) then
+          VariableMap.add var value env
+        else
+          env
+    in
+      Array.fold_left update env environment
+  in
   let system_env = Array.make (VariableMap.cardinal env) "" in
   let i = ref 0 in
   let store variable value =
+    let some value =
+      Variables.string_of_binding variable (expand env (Some value)) in
     system_env.(!i) <-
-      Variables.string_of_binding variable (expand env value);
+      Option.fold ~none:(Variables.name_of_variable variable) ~some value;
     incr i in
   VariableMap.iter store env;
   system_env
 
+let to_system_env env =
+  append_to_system_env [||] env
+
 let lookup variable env =
   try Some (expand env (VariableMap.find variable env)) with Not_found -> None
 
@@ -75,26 +109,32 @@ let safe_lookup variable env = match lookup variable env with
 let is_variable_defined variable env =
   VariableMap.mem variable env
 
-let add variable value env = VariableMap.add variable value env
+let add variable value env = VariableMap.add variable (Some value) env
 
 let add_if_undefined variable value env =
   if VariableMap.mem variable env then env else add variable value env
 
 let append variable appened_value environment =
   let previous_value = safe_lookup variable environment in
   let new_value = previous_value ^ appened_value in
-  VariableMap.add variable new_value environment
+  VariableMap.add variable (Some new_value) environment
 
 let remove = VariableMap.remove
 
+let unsetenv variable environment =
+  VariableMap.add variable None environment
+
 let add_bindings bindings env =
   let f env (variable, value) = add variable value env in
   List.fold_left f env bindings
 
 let from_bindings bindings = add_bindings bindings empty
 
-let dump_assignment log (variable, value) =
-  Printf.fprintf log "%s = %s\n%!" (Variables.name_of_variable variable) value
+let dump_assignment log = function
+  | (variable, Some value) ->
+    Printf.fprintf log "%s = %s\n%!" (Variables.name_of_variable variable) value
+  | (variable, None) ->
+    Printf.fprintf log "unsetenv %s\n%!" (Variables.name_of_variable variable)
 
 let dump log environment =
   List.iter (dump_assignment log) (VariableMap.bindings environment)

ocamltest/environments.mli

@@ -22,6 +22,7 @@ val empty : t
 val from_bindings : (Variables.t * string) list -> t
 val to_bindings : t -> (Variables.t * string) list
 val to_system_env : t -> string array
+val append_to_system_env : string array -> t -> string array
 
 val lookup : Variables.t -> t -> string option
 val lookup_nonempty : Variables.t -> t -> string option
@@ -42,6 +43,10 @@ val add : Variables.t -> string -> t -> t
 val add_if_undefined : Variables.t -> string -> t -> t
 val add_bindings : (Variables.t * string) list -> t -> t
 
+val unsetenv : Variables.t -> t -> t
+(** [unsetenv env name] causes [name] to be ignored from the underlying system
+    environment *)
+
 val append : Variables.t -> string -> t -> t
 
 val dump : out_channel -> t -> unit

ocamltest/main.ml

@@ -86,7 +86,7 @@ let rec run_test log common_prefix path behavior = function
   let (msg, children_behavior, summary) = match behavior with
     | Skip_all_tests -> "n/a", Skip_all_tests, No_failure
     | Run env ->
-      let testenv0 = interprete_environment_statements env testenvspec in
+      let testenv0 = interpret_environment_statements env testenvspec in
       let testenv = List.fold_left apply_modifiers testenv0 env_modifiers in
       let (result, newenv) = Tests.run log testenv test in
       let msg = Result.string_of_result result in
@@ -193,8 +193,7 @@ let test_file test_filename =
        let rootenv =
          Environments.initialize Environments.Pre log initial_environment in
        let rootenv =
-         interprete_environment_statements
-           rootenv rootenv_statements in
+         interpret_environment_statements rootenv rootenv_statements in
        let rootenv = Environments.initialize Environments.Post log rootenv in
        let common_prefix = " ... testing '" ^ test_basename ^ "' with" in
        let initial_status =

ocamltest/ocaml_actions.ml

@@ -533,9 +533,9 @@ let debug log env =
     program
   ] in
   let systemenv =
-    Array.append
+    Environments.append_to_system_env
       default_ocaml_env
-      (Environments.to_system_env (env_with_lib_unix env))
+      (env_with_lib_unix env)
   in
   let expected_exit_status = 0 in
   let exit_status =
@@ -570,12 +570,13 @@ let objinfo log env =
   ] in
   let ocamllib = [| (Printf.sprintf "OCAMLLIB=%s" tools_directory) |] in
   let systemenv =
-    Array.concat
-    [
-      default_ocaml_env;
-      ocamllib;
-      (Environments.to_system_env (env_with_lib_unix env))
-    ]
+    Environments.append_to_system_env
+      (Array.concat
+       [
+         default_ocaml_env;
+         ocamllib;
+       ])
+      (env_with_lib_unix env)
   in
   let expected_exit_status = 0 in
   let exit_status =

ocamltest/ocaml_variables.ml

@@ -54,7 +54,7 @@ let export_caml_ld_library_path value =
     if local_value="" then current_value else
     if current_value="" then local_value else
     String.concat Filename.path_sep [local_value; current_value] in
-  Printf.sprintf "%s=%s" caml_ld_library_path_name new_value
+  (caml_ld_library_path_name, new_value)
 
 let caml_ld_library_path =
   make_with_exporter
@@ -183,7 +183,7 @@ let ocamlopt_opt_exit_status = make ("ocamlopt_opt_exit_status",
   "Expected exit status of ocamlopt.opt")
 
 let export_ocamlrunparam value =
-  Printf.sprintf "%s=%s" "OCAMLRUNPARAM" value
+  ("OCAMLRUNPARAM", value)
 
 let ocamlrunparam =
   make_with_exporter

ocamltest/run_unix.c

@@ -149,6 +149,8 @@ static void update_environment(array local_env)
       setenv(name, value, 1); /* 1 means overwrite */
       free(name);
       free(value);
+    } else {
+      unsetenv(*envp);
     }
   }
 }

ocamltest/run_win32.c

@@ -163,10 +163,8 @@ static LPVOID prepare_environment(WCHAR **localenv)
 
   /* Compute length of local environment */
   localenv_length = 0;
-  q = localenv;
-  while (*q != NULL) {
+  for (q = localenv; *q != NULL; q++) {
     localenv_length += wcslen(*q) + 1;
-    q++;
   }
 
   /* Build new env that contains both process and local env */
@@ -178,19 +176,37 @@ static LPVOID prepare_environment(WCHAR **localenv)
   }
   r = env;
   p = process_env;
+  /* Copy process_env to env only if the given names are not in localenv */
   while (*p != L'\0') {
+    wchar_t *pos_eq = wcschr(p, L'=');
+    int copy = 1;
     l = wcslen(p) + 1; /* also count terminating '\0' */
-    memcpy(r, p, l * sizeof(WCHAR));
+    /* Temporarily change the = to \0 for wcscmp */
+    *pos_eq = L'\0';
+    for (q = localenv; *q != NULL; q++) {
+      wchar_t *pos_eq2 = wcschr(*q, L'=');
+      /* Compare this name in localenv with the current one in processenv */
+      if (pos_eq2) *pos_eq2 = L'\0';
+      if (!wcscmp(*q, p)) copy = 0;
+      if (pos_eq2) *pos_eq2 = L'=';
+    }
+    *pos_eq = L'=';
+    if (copy) {
+      /* This name is not marked for deletion/update in localenv, so copy */
+      memcpy(r, p, l * sizeof(WCHAR));
+      r += l;
+    }
     p += l;
-    r += l;
   }
   FreeEnvironmentStrings(process_env);
-  q = localenv;
-  while (*q != NULL) {
-    l = wcslen(*q) + 1;
-    memcpy(r, *q, l * sizeof(WCHAR));
-    r += l;
-    q++;
+  for (q = localenv; *q != NULL; q++) {
+    /* A string in localenv without '=' signals deletion, which has been done */
+    wchar_t *pos_eq = wcschr(*q, L'=');
+    if (pos_eq) {
+      l = wcslen(*q) + 1;
+      memcpy(r, *q, l * sizeof(WCHAR));
+      r += l;
+    }
   }
   *r = L'\0';
   return env;

ocamltest/tsl_ast.ml

@@ -24,6 +24,7 @@ type environment_statement =
   | Assignment of bool * string located * string located (* variable = value *)
   | Append of string located * string located
   | Include of string located (* include named environment *)
+  | Unset of string located (* clear environment variable *)
 
 type tsl_item =
   | Environment_statement of environment_statement located

ocamltest/tsl_ast.mli

@@ -24,6 +24,7 @@ type environment_statement =
   | Assignment of bool * string located * string located (* variable = value *)
   | Append of string located * string located (* variable += value *)
   | Include of string located (* include named environment *)
+  | Unset of string located (* clear environment variable *)
 
 type tsl_item =
   | Environment_statement of environment_statement located

ocamltest/tsl_lexer.mll

@@ -47,6 +47,7 @@ rule token = parse
       match s with
         | "include" -> INCLUDE
         | "set" -> SET
+        | "unset" -> UNSET
         | "with" -> WITH
         | _ -> IDENTIFIER s
     }

ocamltest/tsl_parser.mly

@@ -37,7 +37,7 @@ let mkenvstmt envstmt =
 %token <int> TEST_DEPTH
 %token EQUAL PLUSEQUAL
 /* %token COLON */
-%token INCLUDE SET WITH
+%token INCLUDE SET UNSET WITH
 %token <string> IDENTIFIER
 %token <string> STRING
 
@@ -76,6 +76,8 @@ env_item:
     { mkenvstmt (Append ($1, $3)) }
 | SET identifier EQUAL string
     { mkenvstmt (Assignment (true, $2, $4)) }
+| UNSET identifier
+    { mkenvstmt (Unset $2) }
 
 | INCLUDE identifier
   { mkenvstmt (Include $2) }

ocamltest/tsl_semantics.ml

@@ -67,16 +67,23 @@ let append_to_env loc variable_name value env =
   with Variables.No_such_variable name ->
     no_such_variable loc name
 
-let interprete_environment_statement env statement = match statement.node with
+let interpret_environment_statement env statement = match statement.node with
   | Assignment (decl, var, value) ->
       add_to_env decl statement.loc var.node value.node env
   | Append (var, value) ->
       append_to_env statement.loc var.node value.node env
   | Include modifiers_name ->
       apply_modifiers env modifiers_name
-
-let interprete_environment_statements env l =
-  List.fold_left interprete_environment_statement env l
+  | Unset var ->
+      let var =
+        match Variables.find_variable var.node with
+        | None -> Variables.make (var.node,"User variable")
+        | Some var -> var
+      in
+      Environments.unsetenv var env
+
+let interpret_environment_statements env l =
+  List.fold_left interpret_environment_statement env l
 
 type test_tree =
   | Node of

ocamltest/tsl_semantics.mli

@@ -19,11 +19,11 @@ open Tsl_ast
 
 val apply_modifiers : Environments.t -> string located -> Environments.t
 
-val interprete_environment_statement :
+val interpret_environment_statement :
   Environments.t -> Tsl_ast.environment_statement Tsl_ast.located ->
   Environments.t
 
-val interprete_environment_statements :
+val interpret_environment_statements :
   Environments.t -> Tsl_ast.environment_statement Tsl_ast.located list ->
   Environments.t
 

ocamltest/variables.ml

@@ -17,7 +17,7 @@
 
 type value = string
 
-type exporter = value -> string
+type exporter = value -> string * string
 
 type t = {
   variable_name : string;
@@ -33,7 +33,7 @@ exception Variable_already_registered of string
 
 exception No_such_variable of string
 
-let default_exporter varname value = Printf.sprintf "%s=%s" varname value
+let default_exporter varname value = (varname, value)
 
 let make (name, description) =
   if name="" then raise Empty_variable_name else {
@@ -65,7 +65,8 @@ let find_variable variable_name =
   with Not_found -> None
 
 let string_of_binding variable value =
-  variable.variable_exporter value
+  let (varname, value) = variable.variable_exporter value in
+  Printf.sprintf "%s=%s" varname value
 
 let get_registered_variables () =
   let f _variable_name variable variable_list = variable::variable_list in