You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
836 lines
34 KiB
836 lines
34 KiB
(*
|
|
* 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! IStd
|
|
|
|
module F = Format
|
|
module YBU = Yojson.Basic.Util
|
|
|
|
let (=) = String.equal
|
|
|
|
let is_env_var_set v =
|
|
Option.value (Option.map (Sys.getenv v) ~f:((=) "1")) ~default:false
|
|
|
|
(** The working directory of the initial invocation of infer, to which paths passed as command line
|
|
options are relative. *)
|
|
let init_work_dir, is_originator =
|
|
match Sys.getenv "INFER_CWD" with
|
|
| Some dir ->
|
|
(dir, false)
|
|
| None ->
|
|
let real_cwd = Utils.realpath (Sys.getcwd ()) in
|
|
Unix.putenv ~key:"INFER_CWD" ~data:real_cwd;
|
|
(real_cwd, true)
|
|
|
|
let strict_mode = is_env_var_set "INFER_STRICT_MODE"
|
|
|
|
let warnf =
|
|
if strict_mode then failwithf
|
|
else if not is_originator then fun fmt -> F.ifprintf F.err_formatter fmt
|
|
else F.eprintf
|
|
|
|
let terminal_width = lazy (
|
|
let open Ctypes in
|
|
let module T = IOCtl.Types(IOCtl_types) in
|
|
let winsize = make IOCtl.winsize in
|
|
let return =
|
|
ExternStubs.ioctl_stub_1_ioctl 0 T.Request.request_TIOCGWINSZ
|
|
(ExternStubs.CI.cptr (addr winsize)) in
|
|
if return >= 0 then
|
|
Ok (Unsigned.UShort.to_int (getf winsize IOCtl.ws_col))
|
|
else
|
|
Error return
|
|
)
|
|
|
|
(** This is the subset of Arg.spec that we actually use. What's important is that all these specs
|
|
call back functions. We use this to mark deprecated arguments. What's not important is that, eg,
|
|
Arg.Float is missing. *)
|
|
type spec =
|
|
| Unit of (unit -> unit)
|
|
| String of (string -> unit)
|
|
| Symbol of string list * (string -> unit)
|
|
| Rest of (string -> unit)
|
|
|
|
let to_arg_spec = function
|
|
| Unit f -> Arg.Unit f
|
|
| String f -> Arg.String f
|
|
| Symbol (symbols, f) -> Arg.Symbol (symbols, f)
|
|
| Rest f -> Arg.Rest f
|
|
|
|
let to_arg_spec_triple (x, spec, y) = (x, to_arg_spec spec, y)
|
|
let to_arg_speclist = List.map ~f:to_arg_spec_triple
|
|
|
|
type section =
|
|
Analysis | BufferOverrun | Checkers | Clang | Crashcontext | Driver | Java | Print | Quandary
|
|
[@@deriving compare]
|
|
|
|
let equal_section = [%compare.equal : section ]
|
|
let all_sections =
|
|
[ Analysis; BufferOverrun; Checkers; Clang; Crashcontext; Driver; Java; Print; Quandary ]
|
|
|
|
(* NOTE: All variants must be also added to `all_parse_tags` below *)
|
|
type 'a parse = Differential | Infer of 'a | Javac | NoParse [@@deriving compare]
|
|
|
|
type parse_mode = section list parse [@@deriving compare]
|
|
|
|
type parse_action = section parse [@@deriving compare]
|
|
|
|
let equal_parse_action = [%compare.equal : parse_action ]
|
|
|
|
(* NOTE: All variants must be also added to `all_parse_tags` below *)
|
|
type parse_tag = AllInferTags | OneTag of unit parse [@@deriving compare]
|
|
|
|
let equal_parse_tag = [%compare.equal : parse_tag ]
|
|
let all_parse_tags = [
|
|
AllInferTags; OneTag Differential; OneTag (Infer ()); OneTag Javac; OneTag NoParse
|
|
]
|
|
|
|
let to_parse_tag parse =
|
|
match parse with
|
|
| Differential -> OneTag Differential
|
|
| Infer _ -> OneTag (Infer ())
|
|
| Javac -> OneTag Javac
|
|
| NoParse -> OneTag NoParse
|
|
|
|
let accept_unknown_args = function
|
|
| Infer Print | Javac | NoParse -> true
|
|
| Infer (Analysis | BufferOverrun | Checkers | Clang | Crashcontext | Driver | Java | Quandary)
|
|
| Differential -> false
|
|
|
|
type desc = {
|
|
long: string; short: string; meta: string; doc: string; spec: spec;
|
|
(** how to go from an option in the json config file to a list of command-line options *)
|
|
decode_json: inferconfig_dir:string -> Yojson.Basic.json -> string list ;
|
|
}
|
|
|
|
let dashdash long =
|
|
match long with
|
|
| "" | "--" -> long
|
|
| _ -> "--" ^ long
|
|
|
|
let short_meta {short; meta; spec} =
|
|
String.concat ~sep:" "
|
|
((if short = "" then [] else ["| -" ^ short]) @
|
|
(match spec with
|
|
| Symbol (symbols, _) ->
|
|
["{ " ^ (String.concat ~sep:" | " 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
|
|
| Symbol _ -> short_meta {desc with spec = 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 *)
|
|
| Symbol (symbols, action) ->
|
|
String (fun arg ->
|
|
if List.mem ~equal:String.equal symbols arg then
|
|
action arg
|
|
else
|
|
raise (Arg.Bad (F.sprintf "wrong argument '%s'; option '%s' expects one of: %s"
|
|
arg (dashdash long) (String.concat ~sep:" | " 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 Int.equal 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, _) =
|
|
List.fold ~f:add_word_to_paragraph ~init:([], false, "", 0) words in
|
|
List.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
|
|
List.map ~f:wrap_line lines in
|
|
let doc = indent_doc (String.concat ~sep:"\n" (List.concat wrapped_lines)) in
|
|
xdesc {desc with doc}
|
|
|
|
let align desc_list =
|
|
let min_term_width = 80 in
|
|
let cur_term_width =
|
|
match Lazy.force terminal_width with
|
|
| Ok width -> width
|
|
| Error _ -> 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 =
|
|
List.fold ~f:(max_left_length max_left_width) ~init: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
|
|
(List.map ~f:(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_ (List.sort ~cmp:(fun (x, _, _) (y, _, _) -> String.compare x y) desc_list)
|
|
|
|
|
|
let parse_tag_desc_lists = List.map ~f:(fun parse_tag -> (parse_tag, ref [])) all_parse_tags
|
|
|
|
let infer_section_desc_lists = List.map ~f:(fun section -> (section, ref [])) all_sections
|
|
|
|
(** add [desc] to the one relevant parse_tag_desc_lists for the purposes of parsing, and, in the
|
|
case of Infer, include [desc] in --help only for the relevant sections. *)
|
|
let add parse_mode desc =
|
|
let add_to_tag tag =
|
|
let desc_list = List.Assoc.find_exn parse_tag_desc_lists tag in
|
|
desc_list := desc :: !desc_list in
|
|
(match parse_mode with
|
|
| Javac | NoParse -> ()
|
|
| Differential | Infer _ -> add_to_tag AllInferTags
|
|
);
|
|
add_to_tag (to_parse_tag parse_mode);
|
|
match parse_mode with
|
|
| Differential | Javac | NoParse -> ()
|
|
| Infer sections ->
|
|
List.iter infer_section_desc_lists ~f:(fun (section, desc_list) ->
|
|
let desc = if List.mem ~equal:equal_section sections section then
|
|
desc
|
|
else
|
|
{desc with meta = ""; doc = ""} in
|
|
desc_list := desc :: !desc_list)
|
|
|
|
let deprecate_desc parse_mode ~long ~short ~deprecated desc =
|
|
let warn () = match parse_mode with
|
|
| Javac | NoParse -> ()
|
|
| Differential | Infer _ ->
|
|
warnf "WARNING: '-%s' is deprecated. Use '--%s'%s instead.@."
|
|
deprecated long (if short = "" then "" else Printf.sprintf " or '-%s'" short) in
|
|
let warn_then_f f x = warn (); f x in
|
|
let deprecated_spec = match desc.spec with
|
|
| Unit f -> Unit (warn_then_f f)
|
|
| String f -> String (warn_then_f f)
|
|
| Symbol (symbols, f) -> Symbol (symbols, warn_then_f f)
|
|
| Rest _ as spec -> spec in
|
|
let deprecated_decode_json ~inferconfig_dir j =
|
|
warnf "WARNING: in .inferconfig: '%s' is deprecated. Use '%s' instead.@." deprecated long;
|
|
desc.decode_json ~inferconfig_dir j in
|
|
{ long = ""; short = deprecated; meta = ""; doc = "";
|
|
spec = deprecated_spec; decode_json = deprecated_decode_json }
|
|
|
|
let mk ?(deprecated=[]) ?(parse_mode=Infer [])
|
|
~long ?short:short0 ~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
|
|
^ " (" ^ (Exn.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 short = match short0 with Some c -> String.of_char c | None -> "" in
|
|
let desc = {long; short=short; meta; doc; spec; decode_json} in
|
|
(* add desc for long option, with documentation (which includes any short option) for exes *)
|
|
if long <> "" then add parse_mode desc ;
|
|
(* add desc for short option only for parsing, without documentation *)
|
|
let parse_mode_no_sections = match parse_mode with
|
|
| Infer _ -> Infer []
|
|
| Differential | Javac | NoParse -> parse_mode in
|
|
if short <> "" then
|
|
add parse_mode_no_sections {desc with long = ""; meta = ""; doc = ""} ;
|
|
(* add desc for deprecated options only for parsing, without documentation *)
|
|
List.iter deprecated ~f:(fun deprecated ->
|
|
deprecate_desc parse_mode ~long ~short:short ~deprecated desc
|
|
|> add parse_mode_no_sections) ;
|
|
variable
|
|
|
|
(* begin parsing state *)
|
|
|
|
(* 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
|
|
|
|
(* list of arg specifications currently being used by Arg.parse_argv_dynamic *)
|
|
let curr_speclist : (Arg.key * Arg.spec * Arg.doc) list ref = ref []
|
|
|
|
let unknown_args_action = ref `Reject
|
|
|
|
let rev_anon_args = ref []
|
|
let anon_fun arg = match !unknown_args_action with
|
|
| `Skip ->
|
|
()
|
|
| `Add ->
|
|
rev_anon_args := arg::!rev_anon_args
|
|
| `Reject ->
|
|
raise (Arg.Bad ("unexpected anonymous argument: " ^ arg))
|
|
|
|
(* keep track of the final parse action to drive the remainder of the program *)
|
|
let final_parse_action = ref (Infer Driver)
|
|
|
|
(* end parsing state *)
|
|
|
|
type 'a t =
|
|
?deprecated:string list -> long:Arg.key -> ?short:char ->
|
|
?parse_mode:parse_mode -> ?meta:string -> Arg.doc ->
|
|
'a
|
|
|
|
let string_json_decoder ~long ~inferconfig_dir:_ json =
|
|
[dashdash long; YBU.to_string json]
|
|
|
|
let path_json_decoder ~long ~inferconfig_dir json =
|
|
let abs_path =
|
|
let path = YBU.to_string json in
|
|
if Filename.is_relative path then inferconfig_dir ^/ path
|
|
else path in
|
|
[dashdash long; abs_path]
|
|
|
|
let list_json_decoder json_decoder ~inferconfig_dir json =
|
|
List.concat (YBU.convert_each (json_decoder ~inferconfig_dir) json)
|
|
|
|
let mk_set var value ?(deprecated=[]) ~long ?short ?parse_mode ?(meta="") doc =
|
|
let setter () = var := value in
|
|
ignore(
|
|
mk ~deprecated ~long ?short ~default:() ?parse_mode ~meta doc
|
|
~default_to_string:(fun () -> "")
|
|
~decode_json:(string_json_decoder ~long)
|
|
~mk_setter:(fun _ _ -> setter ())
|
|
~mk_spec:(fun _ -> Unit setter) )
|
|
|
|
let mk_option ?(default=None) ?(default_to_string=fun _ -> "") ~f
|
|
?(deprecated=[]) ~long ?short ?parse_mode ?(meta="") doc =
|
|
mk ~deprecated ~long ?short ~default ?parse_mode ~meta doc
|
|
~default_to_string
|
|
~decode_json:(string_json_decoder ~long)
|
|
~mk_setter:(fun var str -> var := f str)
|
|
~mk_spec:(fun set -> String set)
|
|
|
|
let mk_bool ?(deprecated_no=[]) ?(default=false) ?(f=fun b -> b)
|
|
?(deprecated=[]) ~long ?short ?parse_mode ?(meta="") doc =
|
|
let nolong =
|
|
let len = String.length long in
|
|
if len > 3 && String.sub long ~pos:0 ~len:3 = "no-" then
|
|
String.sub long ~pos:3 ~len:(len - 3)
|
|
else
|
|
"no-" ^ long
|
|
and noshort =
|
|
Option.map ~f:(fun short ->
|
|
if Char.is_lowercase short then Char.uppercase short
|
|
else Char.lowercase short
|
|
) short
|
|
in
|
|
let doc long short =
|
|
match short with
|
|
| Some short -> doc ^ " (Conversely: --" ^ long ^ " | -" ^ String.of_char short ^ ")"
|
|
| None -> doc ^ " (Conversely: --" ^ long ^ ")"
|
|
in
|
|
let doc, nodoc =
|
|
if not default then
|
|
("Activates: " ^ doc nolong noshort, "")
|
|
else
|
|
("", "Deactivates: " ^ doc long short) in
|
|
let default_to_string _ = "" in
|
|
let mk_spec set = Unit (fun () -> set "") in
|
|
let var =
|
|
mk ~long ?short ~deprecated ~default ?parse_mode
|
|
~meta doc ~default_to_string ~mk_setter:(fun var _ -> var := f true)
|
|
~decode_json:(fun ~inferconfig_dir:_ 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) ?parse_mode
|
|
~meta nodoc ~default_to_string ~mk_setter:(fun _ _ -> var := f false)
|
|
~decode_json:(fun ~inferconfig_dir:_ 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 ?parse_mode ?(meta="") doc children no_children =
|
|
let f b =
|
|
List.iter ~f:(fun child -> child := b) children ;
|
|
List.iter ~f:(fun child -> child := not b) no_children ;
|
|
b
|
|
in
|
|
mk_bool ~deprecated ~deprecated_no ~default ~long ?short ~f ?parse_mode ~meta doc
|
|
|
|
let mk_int ~default ?(deprecated=[]) ~long ?short ?parse_mode ?(meta="") doc =
|
|
mk ~deprecated ~long ?short ~default ?parse_mode ~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 -> String set)
|
|
|
|
let mk_int_opt ?default ?(deprecated=[]) ~long ?short ?parse_mode ?(meta="") doc =
|
|
let default_to_string = function Some f -> string_of_int f | None -> "" in
|
|
let f s = Some (int_of_string s) in
|
|
mk_option ~deprecated ~long ?short ~default ~default_to_string ~f ?parse_mode ~meta doc
|
|
|
|
let mk_float ~default ?(deprecated=[]) ~long ?short ?parse_mode ?(meta="") doc =
|
|
mk ~deprecated ~long ?short ~default ?parse_mode ~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 -> String set)
|
|
|
|
let mk_float_opt ?default ?(deprecated=[]) ~long ?short ?parse_mode ?(meta="") doc =
|
|
let default_to_string = function Some f -> string_of_float f | None -> "" in
|
|
let f s = Some (float_of_string s) in
|
|
mk_option ~deprecated ~long ?short ~default ~default_to_string ~f ?parse_mode ~meta doc
|
|
|
|
let mk_string ~default ?(f=fun s -> s) ?(deprecated=[]) ~long ?short ?parse_mode ?(meta="") doc =
|
|
mk ~deprecated ~long ?short ~default ?parse_mode ~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 -> String set)
|
|
|
|
let mk_string_opt ?default ?(f=fun s -> s) ?(deprecated=[]) ~long ?short ?parse_mode
|
|
?(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 ?parse_mode ~meta doc
|
|
|
|
let mk_string_list ?(default=[]) ?(f=fun s -> s)
|
|
?(deprecated=[]) ~long ?short ?parse_mode ?(meta="") doc =
|
|
mk ~deprecated ~long ?short ~default ?parse_mode ~meta doc
|
|
~default_to_string:(String.concat ~sep:", ")
|
|
~mk_setter:(fun var str -> var := (f str) :: !var)
|
|
~decode_json:(list_json_decoder (string_json_decoder ~long))
|
|
~mk_spec:(fun set -> String set)
|
|
|
|
let mk_path_helper ~setter ~default_to_string
|
|
~default ~deprecated ~long ~short ~parse_mode ~meta ~decode_json doc =
|
|
let normalize_path_in_args_being_parsed 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 root = Unix.getcwd () in
|
|
let abs_path = Utils.filename_to_absolute ~root str in
|
|
(!args_to_parse).(!arg_being_parsed + 1) <- abs_path;
|
|
abs_path
|
|
) else
|
|
str in
|
|
mk ~deprecated ~long ?short ~default ?parse_mode ~meta doc
|
|
~decode_json ~default_to_string
|
|
~mk_setter:(fun var str ->
|
|
let abs_path = normalize_path_in_args_being_parsed str in
|
|
setter var abs_path)
|
|
~mk_spec:(fun set -> String set)
|
|
|
|
let mk_path ~default ?(deprecated=[]) ~long ?short ?parse_mode ?(meta="path") =
|
|
mk_path_helper
|
|
~setter:(fun var x -> var := x)
|
|
~decode_json:(path_json_decoder ~long)
|
|
~default_to_string:(fun s -> s)
|
|
~default ~deprecated ~long ~short ~parse_mode ~meta
|
|
|
|
let mk_path_opt ?default ?(deprecated=[]) ~long ?short ?parse_mode ?(meta="path") =
|
|
mk_path_helper
|
|
~setter:(fun var x -> var := Some x)
|
|
~decode_json:(path_json_decoder ~long)
|
|
~default_to_string:(function Some s -> s | None -> "")
|
|
~default ~deprecated ~long ~short ~parse_mode ~meta
|
|
|
|
let mk_path_list ?(default=[]) ?(deprecated=[]) ~long ?short ?parse_mode ?(meta="path") =
|
|
mk_path_helper
|
|
~setter:(fun var x -> var := x :: !var)
|
|
~decode_json:(list_json_decoder (path_json_decoder ~long))
|
|
~default_to_string:(String.concat ~sep:", ")
|
|
~default ~deprecated ~long ~short ~parse_mode ~meta
|
|
|
|
let mk_symbol ~default ~symbols ~eq ?(deprecated=[]) ~long ?short ?parse_mode ?(meta="") doc =
|
|
let strings = List.map ~f:fst symbols in
|
|
let sym_to_str = List.map ~f:(fun (x,y) -> (y,x)) symbols in
|
|
let of_string str = List.Assoc.find_exn ~equal:String.equal symbols str in
|
|
let to_string sym = List.Assoc.find_exn ~equal:eq sym_to_str sym in
|
|
mk ~deprecated ~long ?short ~default ?parse_mode ~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 -> Symbol (strings, set))
|
|
|
|
let mk_symbol_opt ~symbols ?(deprecated=[]) ~long ?short ?parse_mode ?(meta="") doc =
|
|
let strings = List.map ~f:fst symbols in
|
|
let of_string str = List.Assoc.find_exn ~equal:String.equal symbols str in
|
|
mk ~deprecated ~long ?short ~default:None ?parse_mode ~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 -> Symbol (strings, set))
|
|
|
|
let mk_symbol_seq ?(default=[]) ~symbols ~eq ?(deprecated=[]) ~long ?short ?parse_mode
|
|
?(meta="") doc =
|
|
let sym_to_str = List.map ~f:(fun (x,y) -> (y,x)) symbols in
|
|
let of_string str = List.Assoc.find_exn ~equal:String.equal symbols str in
|
|
let to_string sym = List.Assoc.find_exn ~equal:eq sym_to_str sym in
|
|
mk ~deprecated ~long ?short ~default ?parse_mode ~meta:(",-separated sequence" ^ meta) doc
|
|
~default_to_string:(fun syms -> String.concat ~sep:" " (List.map ~f:to_string syms))
|
|
~mk_setter:(fun var str_seq ->
|
|
var := List.map ~f:of_string (Str.split (Str.regexp_string ",") str_seq))
|
|
~decode_json:(fun ~inferconfig_dir:_ json ->
|
|
[dashdash long;
|
|
String.concat ~sep:"," (YBU.convert_each YBU.to_string json)])
|
|
~mk_spec:(fun set -> String set)
|
|
|
|
let mk_set_from_json ~default ~default_to_string ~f
|
|
?(deprecated=[]) ~long ?short ?parse_mode ?(meta="json") doc =
|
|
mk ~deprecated ~long ?short ?parse_mode ~meta doc
|
|
~default ~default_to_string
|
|
~mk_setter:(fun var json -> var := f (Yojson.Basic.from_string json))
|
|
~decode_json:(fun ~inferconfig_dir:_ json -> [dashdash long; Yojson.Basic.to_string json])
|
|
~mk_spec:(fun set -> String set)
|
|
|
|
let mk_json ?(deprecated=[]) ~long ?short ?parse_mode ?(meta="json") doc =
|
|
mk ~deprecated ~long ?short ?parse_mode ~meta doc
|
|
~default:(`List []) ~default_to_string:Yojson.Basic.to_string
|
|
~mk_setter:(fun var json -> var := Yojson.Basic.from_string json)
|
|
~decode_json:(fun ~inferconfig_dir:_ json -> [dashdash long; Yojson.Basic.to_string json])
|
|
~mk_spec:(fun set -> String set)
|
|
|
|
(** [mk_anon] always return the same ref. Anonymous arguments are only accepted if
|
|
[parse_action_accept_unknown_args] is true. *)
|
|
let mk_anon () = rev_anon_args
|
|
|
|
let mk_rest ?(parse_mode=Infer []) doc =
|
|
let rest = ref [] in
|
|
let spec = Rest (fun arg -> rest := arg :: !rest) in
|
|
add parse_mode {long = "--"; short = ""; meta = ""; doc; spec;
|
|
decode_json = fun ~inferconfig_dir:_ _ -> []} ;
|
|
rest
|
|
|
|
let set_curr_speclist_for_parse_action ~usage ?(parse_all=false) parse_action =
|
|
let full_speclist = ref [] in
|
|
|
|
let curr_usage status =
|
|
prerr_endline (String.concat_array ~sep:" " !args_to_parse) ;
|
|
Arg.usage !curr_speclist usage ;
|
|
exit status
|
|
and full_usage status =
|
|
Arg.usage (to_arg_speclist !full_speclist) usage ;
|
|
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, 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 ~inferconfig_dir:_ _ -> raise (Arg.Bad long);
|
|
} in
|
|
speclist @ [
|
|
mk_spec ~long:"help" ~short:"h"
|
|
(Unit (fun () -> curr_usage 0))
|
|
"Display this list of options";
|
|
mk_spec ~long:"help-full"
|
|
(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 ~pos:0 ~len:3 = "no-"
|
|
then String.sub s ~pos:3 ~len:(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 = List.sort ~cmp:compare_specs speclist in
|
|
align (sort speclist)
|
|
in
|
|
let add_to_curr_speclist ?(add_help=false) ?header parse_action =
|
|
let mk_header_spec heading =
|
|
("", Unit (fun () -> ()), "\n## " ^ heading ^ "\n") in
|
|
let exe_descs = match parse_all, parse_action with
|
|
| true, _ ->
|
|
List.Assoc.find_exn ~equal:equal_parse_tag parse_tag_desc_lists AllInferTags
|
|
| false, Infer section ->
|
|
List.Assoc.find_exn ~equal:equal_section infer_section_desc_lists section
|
|
| false, (Differential | Javac | NoParse) ->
|
|
to_parse_tag parse_action
|
|
|> List.Assoc.find_exn ~equal:equal_parse_tag parse_tag_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
|
|
let exe_speclist = to_arg_speclist 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 = "" ||
|
|
List.for_all ~f:(fun (opt', _, doc') ->
|
|
(doc <> "" && doc' = "") || (not (String.equal opt opt'))) speclist in
|
|
let unique_exe_speclist = List.filter ~f:(is_not_dup_with_doc !curr_speclist) exe_speclist in
|
|
curr_speclist := List.filter ~f:(is_not_dup_with_doc unique_exe_speclist) !curr_speclist @
|
|
(match header with
|
|
| Some s -> (to_arg_spec_triple (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 *)
|
|
(* reset the speclist between calls to this function *)
|
|
curr_speclist := [];
|
|
if equal_parse_action parse_action (Infer Driver) then (
|
|
add_to_curr_speclist ~add_help:true ~header:"Driver options" (Infer Driver);
|
|
add_to_curr_speclist ~header:"Checkers options" (Infer Checkers);
|
|
add_to_curr_speclist ~header:"Clang-specific options" (Infer Clang);
|
|
add_to_curr_speclist ~header:"Java-specific options" (Infer Java);
|
|
add_to_curr_speclist ~header:"Quandary checker options" (Infer Quandary)
|
|
) else
|
|
add_to_curr_speclist ~add_help:true parse_action
|
|
;
|
|
assert( check_no_duplicates !curr_speclist )
|
|
;
|
|
let full_desc_list =
|
|
let parse_tag = if parse_all then AllInferTags else to_parse_tag parse_action in
|
|
List.Assoc.find_exn ~equal:equal_parse_tag parse_tag_desc_lists parse_tag in
|
|
full_speclist := add_or_suppress_help (normalize !full_desc_list)
|
|
;
|
|
curr_usage
|
|
|
|
|
|
let select_parse_action ~usage ?parse_all action =
|
|
let usage = set_curr_speclist_for_parse_action ~usage ?parse_all action in
|
|
unknown_args_action := if accept_unknown_args action then `Add else `Reject;
|
|
final_parse_action := action;
|
|
usage
|
|
|
|
let mk_rest_actions ?(parse_mode=Infer []) doc ~usage decode_action =
|
|
let rest = ref [] in
|
|
let spec = String (fun arg ->
|
|
rest := List.rev (Array.to_list (Array.slice !args_to_parse (!arg_being_parsed + 1) 0)) ;
|
|
select_parse_action ~usage (decode_action arg) |> ignore;
|
|
(* stop accepting new anonymous arguments *)
|
|
unknown_args_action := `Skip) in
|
|
add parse_mode {long = "--"; short = ""; meta = ""; doc; spec;
|
|
decode_json = fun ~inferconfig_dir:_ _ -> []} ;
|
|
rest
|
|
|
|
let mk_switch_parse_action
|
|
parse_action ~usage ?(deprecated=[]) ~long ?short ?parse_mode ?(meta="") doc =
|
|
let switch () =
|
|
select_parse_action ~usage parse_action |> ignore in
|
|
ignore(
|
|
mk ~deprecated ~long ?short ~default:() ?parse_mode ~meta doc
|
|
~default_to_string:(fun () -> "")
|
|
~decode_json:(string_json_decoder ~long)
|
|
~mk_setter:(fun _ _ -> switch ())
|
|
~mk_spec:(fun _ -> Unit switch))
|
|
|
|
let decode_inferconfig_to_argv path =
|
|
let json = match Utils.read_json_file path with
|
|
| Ok json ->
|
|
json
|
|
| Error msg ->
|
|
warnf "WARNING: Could not read or parse Infer config in %s:@\n%s@." path msg ;
|
|
`Assoc [] in
|
|
let desc_list = List.Assoc.find_exn ~equal:equal_parse_tag parse_tag_desc_lists AllInferTags in
|
|
let json_config = YBU.to_assoc json in
|
|
let inferconfig_dir = Filename.dirname path in
|
|
let one_config_item result (key, json_val) =
|
|
try
|
|
let {decode_json} =
|
|
List.find_exn
|
|
~f:(fun {long; short} ->
|
|
String.equal key long
|
|
|| (* for deprecated options *) String.equal key short)
|
|
!desc_list in
|
|
decode_json ~inferconfig_dir json_val @ result
|
|
with
|
|
| Not_found ->
|
|
warnf "WARNING: while reading config file %s:@\nUnknown option %s@." path key ;
|
|
result
|
|
| YBU.Type_error (msg, json) ->
|
|
warnf "WARNING: while reading config file %s:@\nIll-formed value %s for option %s: %s@."
|
|
path (Yojson.Basic.to_string json) key msg ;
|
|
result in
|
|
List.fold ~f:one_config_item ~init:[] json_config
|
|
|
|
|
|
(** separator of argv elements when encoded into environment variables *)
|
|
let env_var_sep = '^'
|
|
|
|
let encode_argv_to_env argv =
|
|
String.concat ~sep:(String.make 1 env_var_sep)
|
|
(List.filter ~f:(fun arg ->
|
|
not (String.contains arg env_var_sep)
|
|
|| (
|
|
warnf "Ignoring unsupported option containing '%c' character: %s@\n"
|
|
env_var_sep arg ;
|
|
false
|
|
)
|
|
) argv)
|
|
|
|
let decode_env_to_argv env =
|
|
Str.split (Str.regexp_string (String.make 1 env_var_sep)) env
|
|
|
|
(** [prefix_before_rest (prefix @ ["--" :: rest])] is [prefix] where "--" is not in [prefix]. *)
|
|
let rev_prefix_before_rest args =
|
|
let rec rev_prefix_before_rest_ rev_keep = function
|
|
| [] | "--" :: _ -> rev_keep
|
|
| keep :: args -> rev_prefix_before_rest_ (keep :: rev_keep) args in
|
|
rev_prefix_before_rest_ [] args
|
|
|
|
|
|
(** environment variable use to pass arguments from parent to child processes *)
|
|
let args_env_var = "INFER_ARGS"
|
|
|
|
let extra_env_args = ref []
|
|
|
|
let extend_env_args args =
|
|
extra_env_args := List.rev_append args !extra_env_args
|
|
|
|
let parse_args ~usage ?parse_all action args =
|
|
let exe_name = Sys.executable_name in
|
|
args_to_parse := Array.of_list (exe_name :: args);
|
|
arg_being_parsed := 0;
|
|
let curr_usage = select_parse_action ~usage ?parse_all action in
|
|
(* tests if msg indicates an unknown option, as opposed to a known option with bad argument *)
|
|
let is_unknown msg = String.is_substring msg ~substring:": unknown option" in
|
|
let rec parse_loop () =
|
|
try
|
|
Arg.parse_argv_dynamic ~current:arg_being_parsed !args_to_parse curr_speclist
|
|
anon_fun usage
|
|
with
|
|
| Arg.Bad usage_msg ->
|
|
if !unknown_args_action <> `Reject && is_unknown usage_msg then (
|
|
anon_fun !args_to_parse.(!arg_being_parsed);
|
|
parse_loop ()
|
|
) else (
|
|
Pervasives.prerr_string usage_msg;
|
|
exit 2
|
|
)
|
|
| Arg.Help usage_msg -> Pervasives.print_string usage_msg; exit 0
|
|
in
|
|
parse_loop ();
|
|
curr_usage
|
|
|
|
let parse ?config_file ~usage action =
|
|
let env_args = decode_env_to_argv (Option.value (Sys.getenv args_env_var) ~default:"") in
|
|
let inferconfig_args =
|
|
Option.map ~f:decode_inferconfig_to_argv config_file |> Option.value ~default:[] in
|
|
let args_to_export = ref "" in
|
|
let add_parsed_args_to_args_to_export () =
|
|
(* reread args_to_parse instead of using all_args since mk_path_helper may have modified them *)
|
|
let prog_args =
|
|
List.rev_append
|
|
(rev_prefix_before_rest (Array.to_list !args_to_parse))
|
|
(List.rev !extra_env_args) in
|
|
(* do not include program path in args passed via env var *)
|
|
let args = Option.value (List.tl prog_args) ~default:[] in
|
|
if not (List.is_empty args) then
|
|
let arg_string =
|
|
if String.equal !args_to_export "" then encode_argv_to_env args
|
|
else !args_to_export ^ String.of_char env_var_sep ^ encode_argv_to_env args in
|
|
args_to_export := arg_string in
|
|
(* read .inferconfig first, then env vars, then command-line options *)
|
|
parse_args ~usage ~parse_all:true (Infer Driver) inferconfig_args |> ignore;
|
|
(* NOTE: do not add the contents of .inferconfig to INFER_ARGS. This helps avoid hitting the
|
|
command line size limit. *)
|
|
parse_args ~usage ~parse_all:true (Infer Driver) env_args |> ignore;
|
|
add_parsed_args_to_args_to_export ();
|
|
let curr_usage =
|
|
let cl_args = match Array.to_list Sys.argv with _ :: tl -> tl | [] -> [] in
|
|
let curr_usage = parse_args ~usage action cl_args in
|
|
add_parsed_args_to_args_to_export ();
|
|
curr_usage in
|
|
Unix.putenv ~key:args_env_var ~data:!args_to_export;
|
|
!final_parse_action, curr_usage
|