(* * 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. *) (** Definition and parsing of command line arguments *) open! Utils module F = Format module YBU = Yojson.Basic.Util (** Each command line option may appear in the --help list of any executable, these tags are used to specify which executables for which an option will be documented. *) type exe = Analyze | BuckCompilationDatabase | Clang | Interactive | Java | Print | StatsAggregator | Toplevel let exes = [ ("InferBuckCompilationDatabase", BuckCompilationDatabase); ("InferAnalyze", Analyze); ("InferClang", Clang); ("InferJava", Java); ("InferPrint", Print); ("InferStatsAggregator", StatsAggregator); ("infer", Toplevel); ("interactive", Interactive); ] let all_exes = IList.map snd exes let frontend_exes = [Clang; Java] let current_exe = if !Sys.interactive then Interactive else try IList.assoc string_equal (Filename.basename Sys.executable_name) exes with Not_found -> Toplevel type desc = { long: string; short: string; meta: string; doc: string; spec: Arg.spec; (** how to go from an option in the json config file to a list of command-line options *) decode_json: Yojson.Basic.json -> string list ; } let dashdash long = match long with | "" | "--" -> long | _ -> "--" ^ long let short_meta {short; meta; spec} = String.concat " " ((if short = "" then [] else ["| -" ^ short]) @ (match spec with | Arg.Symbol (symbols, _) -> ["{ " ^ (String.concat " | " symbols) ^ " }" ^ meta] | _ -> if meta = "" then [] else ["<" ^ meta ^ ">"])) let left_length long short_meta = (String.length (dashdash long)) + (String.length short_meta) let max_left_length limit current ({long; spec} as desc) = let short_meta = match spec with | Arg.Symbol _ -> short_meta {desc with spec = Arg.Unit (fun () -> ())} | _ -> short_meta desc in let length = left_length long short_meta in if length > limit then current else max current length let xdesc {long; short; spec; doc} = let key long short = match long, short with | "", "" -> "" | "--", _ -> "--" | "", _ -> "-" ^ short | _ -> "--" ^ long in let xspec long spec = match spec with (* translate Symbol to String for better formatting of --help messages *) | Arg.Symbol (symbols, action) -> Arg.String (fun arg -> if IList.mem ( = ) arg symbols then action arg else raise (Arg.Bad (F.sprintf "wrong argument '%s'; option '%s' expects one of: %s" arg (dashdash long) (String.concat " | " symbols))) ) | _ -> spec in (key long short, xspec long spec, doc) let wrap_line indent_string wrap_length line = let indent_length = String.length indent_string in let word_sep = " " in let words = Str.split (Str.regexp_string word_sep) line in let add_word_to_paragraph (rev_lines, non_empty, line, line_length) word = let word_length = String.length word in let new_length = line_length + (String.length word_sep) + word_length in let new_non_empty = non_empty || word <> "" in if new_length > wrap_length && non_empty then (line::rev_lines, true, indent_string ^ word, indent_length + word_length) else let sep = if line_length = indent_length then "" else word_sep in let new_line = line ^ sep ^ word in if new_length > wrap_length && new_non_empty then (new_line::rev_lines, false, indent_string, indent_length) else (rev_lines, new_non_empty, new_line, String.length new_line) in let (rev_lines, _, line, _) = IList.fold_left add_word_to_paragraph ([], false, "", 0) words in IList.rev (line::rev_lines) let pad_and_xform doc_width left_width desc = match desc with | {doc = ""} -> xdesc desc | {long; doc} -> let indent_doc doc = (* 2 blank columns before option + 2 columns of gap between flag and doc *) let left_indent = 4 + left_width in (* align every line after the first one of [doc] *) let doc = Str.global_replace (Str.regexp_string "\n") ("\n" ^ String.make left_indent ' ') doc in (* align the first line of [doc] *) let short_meta = short_meta desc in let gap = left_width - (left_length long short_meta) in if gap < 0 then short_meta ^ "\n" ^ (String.make left_indent ' ') ^ doc else short_meta ^ (String.make (gap + 1) ' ') ^ doc in let wrapped_lines = let lines = Str.split (Str.regexp_string "\n") doc in let wrap_line s = if String.length s > doc_width then wrap_line "" doc_width s else [s] in IList.map wrap_line lines in let doc = indent_doc (String.concat "\n" (IList.flatten wrapped_lines)) in xdesc {desc with doc} let align desc_list = let min_term_width = 80 in let cur_term_width = (* `CStubs.term_width ()` return 0 in case of failure *) max (CStubs.term_width ()) min_term_width in (* 2 blank columns before option + 2 columns of gap between flag and doc *) let extra_space = 4 in let min_left_width = 15 in let max_left_width = 49 in let doc_width term_width left_width = term_width - extra_space - left_width in let term_width doc_width left_width = left_width + extra_space + doc_width in let max_doc_width = 100 in let max_term_width = term_width max_left_width max_doc_width in (* how many columns to reserve for the option names NOTE: this doesn't take into account "--help | -h" nor "--help-full", but fortunately these have short names *) let left_width = let opt_left_width = IList.fold_left (max_left_length max_left_width) 0 desc_list in let (--) a b = float_of_int a -. float_of_int b in let multiplier = (max_left_width -- min_left_width) /. (max_term_width -- min_term_width) in (* at 80 columns use min_left_width then use extra columns until opt_left_width *) let cols_after_min_width = float_of_int (max 0 (cur_term_width - min_term_width)) in min (int_of_float (cols_after_min_width *. multiplier) + min_left_width) opt_left_width in let doc_width = min max_doc_width (doc_width cur_term_width left_width) in (IList.map (pad_and_xform doc_width left_width) desc_list, (doc_width, left_width)) let check_no_duplicates desc_list = let rec check_for_duplicates_ = function | [] | [_] -> true | (x, _, _) :: (y, _, _) :: _ when x <> "" && x = y -> failwith ("Multiple definitions of command line option: " ^ x) | _ :: tl -> check_for_duplicates_ tl in check_for_duplicates_ (IList.sort (fun (x, _, _) (y, _, _) -> String.compare x y) desc_list) let full_desc_list = ref [] let exe_desc_lists = IList.map (fun (_, exe) -> (exe, ref [])) exes (** add desc to all desc_lists for the purposes of parsing, include desc in --help only for exes *) let add exes desc = full_desc_list := desc :: !full_desc_list ; IList.iter (fun (exe, desc_list) -> let desc = if IList.mem ( = ) exe exes then desc else {desc with meta = ""; doc = ""} in desc_list := desc :: !desc_list ) exe_desc_lists let mk ?(deprecated=[]) ?(exes=[]) ~long ?(short="") ~default ~meta doc ~default_to_string ~decode_json ~mk_setter ~mk_spec = let variable = ref default in let closure = mk_setter variable in let setter str = try closure str with exc -> raise (Arg.Bad ("bad value " ^ str ^ " for flag " ^ long ^ " (" ^ (Printexc.to_string exc) ^ ")")) in let spec = mk_spec setter in let doc = let default_string = default_to_string default in if default_string = "" then doc else doc ^ " (default: " ^ default_string ^ ")" in let desc = {long; short; meta; doc; spec; decode_json} in (* add desc for long option, with documentation (which includes any short option) for exes *) add exes desc ; (* add desc for short option only for parsing, without documentation *) if short <> "" then add [] {desc with long = ""; meta = ""; doc = ""} ; (* add desc for deprecated options only for parsing, without documentation *) IList.iter (fun deprecated -> add [] {desc with long = ""; short = deprecated; meta = ""; doc = ""} ) deprecated ; variable (* arguments passed to Arg.parse_argv_dynamic, susceptible to be modified on the fly when parsing *) let args_to_parse : string array ref = ref (Array.of_list []) (* reference used by Arg.parse_argv_dynamic to track the index of the argument being parsed *) let arg_being_parsed : int ref = ref 0 type 'a t = ?deprecated:string list -> long:Arg.key -> ?short:Arg.key -> ?exes:exe list -> ?meta:string -> Arg.doc -> 'a let string_json_decoder ~long json = [dashdash long; YBU.to_string json] let list_json_decoder json_decoder json = IList.flatten (YBU.convert_each json_decoder json) let mk_set var value ?(deprecated=[]) ~long ?short ?exes ?(meta="") doc = let setter () = var := value in ignore( mk ~deprecated ~long ?short ~default:() ?exes ~meta doc ~default_to_string:(fun () -> "") ~decode_json:(string_json_decoder ~long) ~mk_setter:(fun _ _ -> setter ()) ~mk_spec:(fun _ -> Arg.Unit setter) ) let mk_option ?(default=None) ?(default_to_string=fun _ -> "") ~f ?(deprecated=[]) ~long ?short ?exes ?(meta="") doc = mk ~deprecated ~long ?short ~default ?exes ~meta doc ~default_to_string ~decode_json:(string_json_decoder ~long) ~mk_setter:(fun var str -> var := f str) ~mk_spec:(fun set -> Arg.String set) let mk_bool ?(deprecated_no=[]) ?(default=false) ?(f=fun b -> b) ?(deprecated=[]) ~long ?short ?exes ?(meta="") doc = let nolong = let len = String.length long in if len > 3 && String.sub long 0 3 = "no-" then String.sub long 3 (len - 3) else "no-" ^ long and noshort = Option.map (fun short -> let len = String.length short in if len > 1 && String.sub short 0 1 = "n" then String.sub short 1 (len - 1) else "n" ^ short ) short in let doc nolong = match noshort with | Some noshort -> doc ^ " (Conversely: --" ^ nolong ^ " | -" ^ noshort ^ ")" | None -> doc ^ " (Conversely: --" ^ nolong ^ ")" in let doc, nodoc = if not default then ("Activates: " ^ doc nolong, "") else ("", "Deactivates: " ^ doc long) in let default_to_string _ = "" in let mk_spec set = Arg.Unit (fun () -> set "") in let var = mk ~long ?short ~deprecated ~default ?exes ~meta doc ~default_to_string ~mk_setter:(fun var _ -> var := f true) ~decode_json:(fun json -> [dashdash (if YBU.to_bool json then long else nolong)]) ~mk_spec in ignore( mk ~long:nolong ?short:noshort ~deprecated:deprecated_no ~default:(not default) ?exes ~meta nodoc ~default_to_string ~mk_setter:(fun _ _ -> var := f false) ~decode_json:(fun json -> [dashdash (if YBU.to_bool json then nolong else long)]) ~mk_spec ); var let mk_bool_group ?(deprecated_no=[]) ?(default=false) ?(deprecated=[]) ~long ?short ?exes ?(meta="") doc children = let f b = IList.iter (fun child -> child := b) children ; b in mk_bool ~deprecated ~deprecated_no ~default ~long ?short ~f ?exes ~meta doc let mk_int ~default ?(deprecated=[]) ~long ?short ?exes ?(meta="") doc = mk ~deprecated ~long ?short ~default ?exes ~meta doc ~default_to_string:string_of_int ~mk_setter:(fun var str -> var := (int_of_string str)) ~decode_json:(string_json_decoder ~long) ~mk_spec:(fun set -> Arg.String set) let mk_float ~default ?(deprecated=[]) ~long ?short ?exes ?(meta="") doc = mk ~deprecated ~long ?short ~default ?exes ~meta doc ~default_to_string:string_of_float ~mk_setter:(fun var str -> var := (float_of_string str)) ~decode_json:(string_json_decoder ~long) ~mk_spec:(fun set -> Arg.String set) let mk_string ~default ?(f=fun s -> s) ?(deprecated=[]) ~long ?short ?exes ?(meta="") doc = mk ~deprecated ~long ?short ~default ?exes ~meta doc ~default_to_string:(fun s -> s) ~mk_setter:(fun var str -> var := f str) ~decode_json:(string_json_decoder ~long) ~mk_spec:(fun set -> Arg.String set) let mk_path ~default ?(deprecated=[]) ~long ?short ?exes ?(meta="") doc = mk ~deprecated ~long ?short ~default ?exes ~meta doc ~default_to_string:(fun s -> s) ~mk_setter:(fun var str -> if Filename.is_relative str then ( (* Replace relative paths with absolute ones on the fly in the args being parsed. This assumes that [!arg_being_parsed] points at the option name position in [!args_to_parse], as is the case e.g. when calling [Arg.parse_argv_dynamic ~current:arg_being_parsed !args_to_parse ...]. *) let abs_path = Sys.getcwd () // str in var := abs_path; (!args_to_parse).(!arg_being_parsed + 1) <- abs_path; ) else var := str) ~decode_json:(string_json_decoder ~long) ~mk_spec:(fun set -> Arg.String set) let mk_string_opt ?default ?(f=fun s -> s) ?(deprecated=[]) ~long ?short ?exes ?(meta="") doc = let default_to_string = function Some s -> s | None -> "" in let f s = Some (f s) in mk_option ~deprecated ~long ?short ~default ~default_to_string ~f ?exes ~meta doc let mk_string_list ?(default=[]) ?(f=fun s -> s) ?(deprecated=[]) ~long ?short ?exes ?(meta="") doc = mk ~deprecated ~long ?short ~default ?exes ~meta doc ~default_to_string:(String.concat ", ") ~mk_setter:(fun var str -> var := (f str) :: !var) ~decode_json:(list_json_decoder (string_json_decoder ~long)) ~mk_spec:(fun set -> Arg.String set) let mk_symbol ~default ~symbols ?(deprecated=[]) ~long ?short ?exes ?(meta="") doc = let strings = IList.map fst symbols in let sym_to_str = IList.map (fun (x,y) -> (y,x)) symbols in let of_string str = IList.assoc string_equal str symbols in let to_string sym = IList.assoc ( = ) sym sym_to_str in mk ~deprecated ~long ?short ~default ?exes ~meta doc ~default_to_string:(fun s -> to_string s) ~mk_setter:(fun var str -> var := of_string str) ~decode_json:(string_json_decoder ~long) ~mk_spec:(fun set -> Arg.Symbol (strings, set)) let mk_symbol_opt ~symbols ?(deprecated=[]) ~long ?short ?exes ?(meta="") doc = let strings = IList.map fst symbols in let of_string str = IList.assoc string_equal str symbols in mk ~deprecated ~long ?short ~default:None ?exes ~meta doc ~default_to_string:(fun _ -> "") ~mk_setter:(fun var str -> var := Some (of_string str)) ~decode_json:(string_json_decoder ~long) ~mk_spec:(fun set -> Arg.Symbol (strings, set)) let mk_symbol_seq ?(default=[]) ~symbols ?(deprecated=[]) ~long ?short ?exes ?(meta="") doc = let sym_to_str = IList.map (fun (x,y) -> (y,x)) symbols in let of_string str = IList.assoc string_equal str symbols in let to_string sym = IList.assoc ( = ) sym sym_to_str in mk ~deprecated ~long ?short ~default ?exes ~meta:(",-separated sequence" ^ meta) doc ~default_to_string:(fun syms -> String.concat " " (IList.map to_string syms)) ~mk_setter:(fun var str_seq -> var := IList.map of_string (Str.split (Str.regexp_string ",") str_seq)) ~decode_json:(fun json -> [dashdash long; String.concat "," (YBU.convert_each YBU.to_string json)]) ~mk_spec:(fun set -> Arg.String set) let mk_set_from_json ~default ~default_to_string ~f ?(deprecated=[]) ~long ?short ?exes ?(meta="json") doc = mk ~deprecated ~long ?short ?exes ~meta doc ~default ~default_to_string ~mk_setter:(fun var json -> var := f (Yojson.Basic.from_string json)) ~decode_json:(fun json -> [dashdash long; Yojson.Basic.to_string json]) ~mk_spec:(fun set -> Arg.String set) (** A ref to a function used during argument parsing to process anonymous arguments. By default, anonymous arguments are rejected. *) let anon_fun = ref (fun arg -> raise (Arg.Bad ("unexpected anonymous argument: " ^ arg))) (** Clients declare that anonymous arguments are acceptable by calling [mk_anon], which returns a ref storing the anonymous arguments. *) let mk_anon () = let anon = ref [] in anon_fun := (fun arg -> anon := arg :: !anon) ; anon let mk_rest ?(exes=[]) doc = let rest = ref [] in let spec = Arg.Rest (fun arg -> rest := arg :: !rest) in add exes {long = "--"; short = ""; meta = ""; doc; spec; decode_json = fun _ -> []} ; rest let decode_inferconfig_to_argv path = let json = match read_optional_json_file path with | Ok json -> json | Error msg -> F.eprintf "WARNING: Could not read or parse Infer config in %s:@\n%s@." path msg ; `Assoc [] in let desc_list = !(IList.assoc ( = ) current_exe exe_desc_lists) in let json_config = YBU.to_assoc json in let one_config_item result (key, json_val) = try let {decode_json} = IList.find (fun {long; short} -> string_equal key long || (* for deprecated options *) string_equal key short) desc_list in decode_json json_val @ result with | Not_found -> F.eprintf "WARNING: while reading config file %s:@\nUnknown option %s@." path key ; result | YBU.Type_error (msg, json) -> F.eprintf "WARNING: while reading config file %s:@\nIll-formed value %s for option %s: %s@." path (Yojson.Basic.to_string json) key msg ; result in IList.fold_left one_config_item [] json_config (** [sep_char] is used to separate elements of argv when encoded into environment variables *) let sep_char = '^' let encode_argv_to_env argv = String.concat (String.make 1 sep_char) (IList.filter (fun arg -> not (String.contains arg sep_char) || ( F.eprintf "Ignoring unsupported option containing '%c' character: %s@\n" sep_char arg ; false ) ) argv) let decode_env_to_argv env = Str.split (Str.regexp_string (String.make 1 sep_char)) env let prepend_to_argv args = let cl_args = match Array.to_list Sys.argv with _ :: tl -> tl | [] -> [] in args @ cl_args (** [prefix_before_rest (prefix @ ["--" :: rest])] is [prefix] where "--" is not in [prefix]. *) let prefix_before_rest args = let rec prefix_before_rest_ rev_keep = function | [] | "--" :: _ -> IList.rev rev_keep | keep :: args -> prefix_before_rest_ (keep :: rev_keep) args in prefix_before_rest_ [] args let parse ?(incomplete=false) ?(accept_unknown=false) ?config_file env_var exe_usage = let curr_speclist = ref [] and full_speclist = ref [] in let usage_msg = exe_usage current_exe in let curr_usage status = Arg.usage !curr_speclist usage_msg ; exit status and full_usage status = Arg.usage !full_speclist usage_msg ; exit status in (* "-help" and "--help" are automatically recognized by Arg.parse, so we have to give them special treatment *) let add_or_suppress_help (speclist, (doc_width,left_width)) = let unknown opt = (opt, Arg.Unit (fun () -> raise (Arg.Bad ("unknown option '" ^ opt ^ "'"))), "") in let mk_spec ~long ?(short="") spec doc = pad_and_xform doc_width left_width { long; short; meta=""; spec; doc; decode_json=fun _ -> raise (Arg.Bad long)} in if incomplete then speclist @ [ (unknown "--help") ; (unknown "-help") ] else speclist @ [ mk_spec ~long:"help" ~short:"h" (Arg.Unit (fun () -> curr_usage 0)) "Display this list of options"; mk_spec ~long:"help-full" (Arg.Unit (fun () -> full_usage 0)) "Display the full list of options, including internal and experimental options"; (unknown "-help") ] in let normalize speclist = let norm k = let remove_no s = let len = String.length k in if len > 3 && String.sub s 0 3 = "no-" then String.sub s 3 (len - 3) else s in let remove_weird_chars = Str.global_replace (Str.regexp "[^a-z0-9-]") "" in remove_weird_chars @@ String.lowercase @@ remove_no k in let compare_specs {long = x} {long = y} = match x, y with | "--", "--" -> 0 | "--", _ -> 1 | _, "--" -> -1 | _ -> let lower_norm s = String.lowercase @@ norm s in String.compare (lower_norm x) (lower_norm y) in let sort speclist = IList.sort compare_specs speclist in align (sort speclist) in let add_to_curr_speclist ?(add_help=false) ?header exe = let mk_header_spec heading = ("", Arg.Unit (fun () -> ()), "\n " ^ heading ^ "\n") in let exe_descs = IList.assoc ( = ) exe exe_desc_lists in let (exe_speclist, widths) = normalize !exe_descs in let exe_speclist = if add_help then add_or_suppress_help (exe_speclist, widths) else exe_speclist in (* Return false if the same option appears in [speclist], unless [doc] is non-empty and the documentation in [speclist] is empty. The goal is to keep only one instance of each option, and that instance is the one that has a non-empty docstring if there is one. *) let is_not_dup_with_doc speclist (opt, _, doc) = opt = "" || IList.for_all (fun (opt', _, doc') -> (doc <> "" && doc' = "") || (not (string_equal opt opt'))) speclist in let unique_exe_speclist = IList.filter (is_not_dup_with_doc !curr_speclist) exe_speclist in curr_speclist := IList.filter (is_not_dup_with_doc unique_exe_speclist) !curr_speclist @ (match header with | Some s -> mk_header_spec s:: unique_exe_speclist | None -> unique_exe_speclist) in (* speclist includes args for current exe with docs, and all other args without docs, so that all args can be parsed, but --help and parse failures only show external args for current exe *) if current_exe = Toplevel then add_to_curr_speclist ~add_help:true ~header:"Toplevel options" current_exe else add_to_curr_speclist ~add_help:true current_exe ; if current_exe = Toplevel then ( add_to_curr_speclist ~header:"Analysis (backend) options" Analyze; add_to_curr_speclist ~header:"Clang frontend options" Clang; add_to_curr_speclist ~header:"Java frontend options" Java; ) ; assert( check_no_duplicates !curr_speclist ) ; full_speclist := add_or_suppress_help (normalize !full_desc_list) ; let env_args = decode_env_to_argv (try Unix.getenv env_var with Not_found -> "") in (* begin transitional support for INFERCLANG_ARGS *) let c_args = Str.split (Str.regexp_string (String.make 1 ':')) (try Unix.getenv "INFERCLANG_ARGS" with Not_found -> "") in let env_args = c_args @ env_args in (* end transitional support for INFERCLANG_ARGS *) let exe_name = Sys.executable_name in let should_parse_cl_args = match current_exe with | Clang | Interactive -> false | Analyze | BuckCompilationDatabase | Java | Print | StatsAggregator | Toplevel -> true in let env_cl_args = if should_parse_cl_args then prepend_to_argv env_args else env_args in let all_args = match config_file with | None -> env_cl_args | Some path -> let json_args = decode_inferconfig_to_argv path in (* read .inferconfig first, as both env vars and command-line options overwrite it *) json_args @ env_cl_args in args_to_parse := Array.of_list (exe_name :: all_args); arg_being_parsed := 0; (* tests if msg indicates an unknown option, as opposed to a known option with bad argument *) let is_unknown msg = let prefix = exe_name ^ ": unknown option" in prefix = (String.sub msg 0 (String.length prefix)) in let rec parse_loop () = try Arg.parse_argv_dynamic ~current:arg_being_parsed !args_to_parse curr_speclist !anon_fun usage_msg with | Arg.Bad _ when incomplete -> parse_loop () | Arg.Bad msg when accept_unknown && is_unknown msg -> !anon_fun !args_to_parse.(!arg_being_parsed); parse_loop () | Arg.Bad usage_msg -> Pervasives.prerr_string usage_msg; exit 2 | Arg.Help usage_msg -> Pervasives.print_string usage_msg; exit 0 in parse_loop (); if not incomplete then Unix.putenv env_var (encode_argv_to_env (prefix_before_rest (IList.tl (Array.to_list !args_to_parse)))) ; curr_usage