[clang] store args into files for Buck compilation db too

Summary:
Also be more careful when escaping arguments and create a module for shared
functionality between the clang frontend and the buck compilation database.

Reviewed By: jberdine

Differential Revision: D4036627

fbshipit-source-id: c981184

infer/src/base/Process.ml

@@ -83,20 +83,26 @@ let pid_to_program jobsMap pid =
     IntMap.find pid jobsMap
   with Not_found -> ""
 
-(** [run_jobs_in_parallel jobs_stack run_job cmd_to_string ] runs the jobs in
-    the given stack, by spawning the jobs in batches of n, where n is Config.jobs. It
-    then waits for all those jobs and starts a new batch and so on. cmd_to_string
-    is used for printing information about the job's status.   *)
-let run_jobs_in_parallel jobs_stack run_job cmd_to_string =
+(** [run_jobs_in_parallel jobs_stack gen_cmd cmd_to_string] runs the jobs in the given stack, by
+    spawning the jobs in batches of n, where n is [Config.jobs]. It then waits for all those jobs
+    and starts a new batch and so on. [gen_cmd] should return a tuple [(dir_opt, command, args,
+    env)] where [dir_opt] is an optional directory to chdir to before executing the process, and
+    [command], [args], [env] are the same as for [exec_command]. [cmd_to_string] is used for
+    printing information about the job's status. *)
+let run_jobs_in_parallel jobs_stack gen_cmd cmd_to_string =
   let run_job () =
     let jobs_map = ref IntMap.empty in
     let current_jobs_count = start_current_jobs_count () in
     while not (Stack.is_empty jobs_stack) do
       let job_cmd = Stack.pop jobs_stack in
+      let (dir_opt, cmd, args, env) = gen_cmd job_cmd in
       Pervasives.incr current_jobs_count;
       match Unix.fork () with
       | 0 ->
-          run_job job_cmd
+          (match dir_opt with
+           | Some dir -> Unix.chdir dir
+           | None -> ());
+          exec_command cmd args env
       | pid_child ->
           jobs_map := IntMap.add pid_child (cmd_to_string job_cmd) !jobs_map;
           if Stack.length jobs_stack = 0 || !current_jobs_count >= Config.jobs then

infer/src/base/Process.mli

@@ -27,8 +27,11 @@ val print_error_and_exit :
 (** Prints information about a unix error *)
 val print_unix_error : string -> exn -> unit
 
-(** [run_jobs_in_parallel jobs_stack run_job cmd_to_string ] runs the jobs in
-    the given stack, by spawning the jobs in batches of n, where n is Config.jobs. It
-    then waits for all those jobs and starts a new batch and so on. cmd_to_string
-    is used for printing information about the job's status.   *)
-val run_jobs_in_parallel : 'a Stack.t -> ('a -> unit) -> ('a -> string) -> unit
+(** [run_jobs_in_parallel jobs_stack gen_cmd cmd_to_string] runs the jobs in the given stack, by
+    spawning the jobs in batches of n, where n is [Config.jobs]. It then waits for all those jobs
+    and starts a new batch and so on. [gen_cmd] should return a tuple [(dir_opt, command, args,
+    env)] where [dir_opt] is an optional directory to chdir to before executing the process, and
+    [command], [args], [env] are the same as for [exec_command]. [cmd_to_string] is used for
+    printing information about the job's status. *)
+val run_jobs_in_parallel : 'a Stack.t ->
+  ('a -> (string option * string * string array * string array)) -> ('a -> string) -> unit

infer/src/clang/ClangCommand.re

@@ -8,15 +8,11 @@
  */
 open! Utils;
 
-type quoting_style =
-  | DoubleQuotes
-  | SingleQuotes;
-
 type args = {
   exec: string,
   argv: list string,
   orig_argv: list string,
-  quoting_style: quoting_style
+  quoting_style: ClangQuotes.style
 };
 
 type t =
@@ -85,12 +81,6 @@ let value_of_option {orig_argv} => value_of_argv_option orig_argv;
 
 let has_flag {orig_argv} flag => IList.exists (string_equal flag) orig_argv;
 
-let quote quoting_style =>
-  switch quoting_style {
-  | DoubleQuotes => (fun s => "\"" ^ s ^ "\"")
-  | SingleQuotes => (fun s => "'" ^ s ^ "'")
-  };
-
 /* Work around various path or library issues occurring when one tries to substitute Apple's version
    of clang with a different version. Also mitigate version discrepancies in clang's
    fatal warnings. */
@@ -134,11 +124,7 @@ let mk_clang_compat_args args => {
         filter_unsupported_args_and_swap_includes (arg, res') tl
       };
   let clang_arguments = filter_unsupported_args_and_swap_includes ("", []) args.argv;
-  let file = Filename.temp_file "clang_args_" ".txt";
-  let write_args outc =>
-    output_string outc (IList.map (quote args.quoting_style) clang_arguments |> String.concat " ");
-  with_file file f::write_args |> ignore;
-  Logging.out "Clang options stored in file %s@\n" file;
+  let file = ClangQuotes.mk_arg_file "clang_args_" args.quoting_style clang_arguments;
   {...args, argv: [Format.sprintf "@%s" file]}
 };
 
@@ -173,7 +159,8 @@ let mk quoting_style argv => {
 
 let command_to_run args => {
   let {exec, argv, quoting_style} = mk_clang_compat_args args;
-  Printf.sprintf "'%s' %s" exec (IList.map (quote quoting_style) argv |> String.concat " ")
+  Printf.sprintf
+    "'%s' %s" exec (IList.map (ClangQuotes.quote quoting_style) argv |> String.concat " ")
 };
 
 let with_exec exec args => {...args, exec};

infer/src/clang/ClangCommand.rei

@@ -17,14 +17,10 @@ type t =
   | ClangWarning string
   | NonCCCommand args /** other commands (as, ld, ...) */;
 
-type quoting_style =
-  | DoubleQuotes /** the arguments are ready to be enclosed in "double quotes" */
-  | SingleQuotes /** the arguments are ready to be enclodes in 'single quotes' */;
-
 
 /** [mk qs argv] finds the type of command depending on its arguments [argv]. The quoting style of
     the arguments have to be provided, so that the command may be run later on. */
-let mk: quoting_style => array string => t;
+let mk: ClangQuotes.style => array string => t;
 
 
 /** change an args object into a string ready to be passed to a shell to be executed */

infer/src/clang/ClangQuotes.re

@@ -0,0 +1,39 @@
+/*
+ * Copyright (c) 2016 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ */
+open! Utils;
+
+/* module for escaping clang arguments on the command line and put them into files */
+
+/** quoting style of the arguments */
+type style =
+  | EscapedDoubleQuotes /** the arguments should be enclosed in "double quotes" and are already escaped */
+  | SingleQuotes /** the arguments should be enclosed in 'single quotes' and have to be escaped */;
+
+let quote style =>
+  switch style {
+  | EscapedDoubleQuotes => (fun s => "\"" ^ s ^ "\"")
+  | SingleQuotes =>
+    let map = (
+      fun
+      | '\'' => Some "\\'"
+      | '\\' => Some "\\\\"
+      | _ => None
+    );
+    (fun s => "'" ^ Escape.escape_map map s ^ "'")
+  };
+
+let mk_arg_file prefix style args => {
+  let temp_dir = Config.results_dir /\/ "clang";
+  create_dir temp_dir;
+  let file = Filename.temp_file temp_dir::temp_dir prefix ".txt";
+  let write_args outc => output_string outc (IList.map (quote style) args |> String.concat " ");
+  with_file file f::write_args |> ignore;
+  Logging.out "Clang options stored in file %s@\n" file;
+  file
+};

infer/src/clang/ClangQuotes.rei

@@ -0,0 +1,18 @@
+/*
+ * Copyright (c) 2016 - present Facebook, Inc.
+ * All rights reserved.
+ *
+ * This source code is licensed under the BSD style license found in the
+ * LICENSE file in the root directory of this source tree. An additional grant
+ * of patent rights can be found in the PATENTS file in the same directory.
+ */
+/* module for escaping clang arguments on the command line and put them into files */
+
+/** quoting style */
+type style =
+  | EscapedDoubleQuotes /** the arguments should be enclosed in "double quotes" and are already escaped */
+  | SingleQuotes /** the arguments should be enclosed in 'single quotes' and have to be escaped */;
+
+let quote: style => string => string;
+
+let mk_arg_file: string => style => list string => string;

infer/src/clang/InferClang.re

@@ -16,7 +16,7 @@ open! Utils;
     the results of `clang -### [args]`. Assembly commands (eg, clang -cc1as ...) are filtered out,
     although the type cannot reflect that fact. */
 let normalize (args: array string) :list ClangCommand.t =>
-  switch (ClangCommand.mk ClangCommand.SingleQuotes args) {
+  switch (ClangCommand.mk ClangQuotes.SingleQuotes args) {
   | CC1 args =>
     Logging.out "InferClang got toplevel -cc1 command@\n";
     [ClangCommand.CC1 args]
@@ -32,7 +32,7 @@ let normalize (args: array string) :list ClangCommand.t =>
         "\"" ^ line ^ " \"" |>
         /* split by whitespace */
         Str.split (Str.regexp_string "\" \"") |> Array.of_list |>
-        ClangCommand.mk ClangCommand.DoubleQuotes
+        ClangCommand.mk ClangQuotes.EscapedDoubleQuotes
       } else if (
         Str.string_match (Str.regexp "clang[^ :]*: warning: ") line 0
       ) {

infer/src/integration/BuckCompilationDatabase.ml

@@ -98,14 +98,15 @@ let replace_clang_arg arg =
 let run_compilation_file compilation_database file =
   try
     let compilation_data = CompilationDatabase.find compilation_database file in
-    Unix.chdir compilation_data.dir;
     let wrapper_cmd = swap_command compilation_data.command in
     let replaced_args = IList.map replace_clang_arg compilation_data.args |> IList.flatten in
-    let args = Array.of_list (wrapper_cmd::replaced_args) in
+    let arg_file =
+      ClangQuotes.mk_arg_file "buck_clang_args_" ClangQuotes.SingleQuotes replaced_args in
+    let args = Array.of_list [wrapper_cmd; "@" ^ arg_file] in
     let env = Array.append
         (Unix.environment())
         (Array.of_list ["FCP_RUN_SYNTAX_ONLY=1"]) in
-    Process.exec_command wrapper_cmd args env
+    (Some compilation_data.dir, wrapper_cmd, args, env)
   with Not_found ->
     Process.print_error_and_exit "Failed to find compilation data for %s \n%!" file
 
@@ -113,10 +114,10 @@ let run_compilation_database compilation_database =
   let number_of_files = CompilationDatabase.get_size compilation_database in
   Logging.out "Starting %s %d files \n%!" capture_text number_of_files;
   Logging.stdout "Starting %s %d files \n%!" capture_text number_of_files;
-  let jobsStack = create_files_stack compilation_database in
+  let jobs_stack = create_files_stack compilation_database in
   let capture_text_upper = String.capitalize capture_text in
   let job_to_string = fun file -> capture_text_upper ^ " " ^ file in
-  Process.run_jobs_in_parallel jobsStack (run_compilation_file compilation_database) job_to_string
+  Process.run_jobs_in_parallel jobs_stack (run_compilation_file compilation_database) job_to_string
 
 
 (** Computes the compilation database: a map from a file path to info to compile the file, i.e.