199 lines
6.6 KiB
OCaml
199 lines
6.6 KiB
OCaml
(*---------------------------------------------------------------------------
|
|
Copyright (c) 2025 The cmdliner programmers. All rights reserved.
|
|
SPDX-License-Identifier: ISC
|
|
---------------------------------------------------------------------------*)
|
|
|
|
open B0_std
|
|
open B0_testing
|
|
open Cmdliner
|
|
|
|
(* Snapshotting command line evaluations *)
|
|
|
|
let capture_fmt f =
|
|
let buf = Buffer.create 255 in
|
|
let fmt = Format.formatter_of_buffer buf in
|
|
let ret = f fmt in
|
|
ret, (Buffer.contents buf)
|
|
|
|
let make_argv cmd args = Array.of_list (Cmd.name cmd :: args)
|
|
let env_dumb_term = function
|
|
| "TERM" -> Some "dumb"
|
|
| var -> Sys.getenv_opt var
|
|
|
|
let t_eval_result ok =
|
|
let test_eval_error : Cmd.eval_error Test.T.t =
|
|
let pp ppf = function
|
|
| `Parse -> Fmt.string ppf "`Parse"
|
|
| `Term -> Fmt.string ppf "`Term"
|
|
| `Exn -> Fmt.string ppf "`Exn"
|
|
in
|
|
Test.T.make ~equal:(=) ~pp ()
|
|
in
|
|
let test_eval_ok ok =
|
|
let pp ppf = function
|
|
| `Ok v -> Test.T.pp ok ppf v
|
|
| `Version -> Fmt.string ppf "`Version"
|
|
| `Help -> Fmt.string ppf "`Help"
|
|
in
|
|
let equal v0 v1 = match v0, v1 with
|
|
| `Ok v0, `Ok v1 -> Test.T.equal ok v0 v1
|
|
| v0, v1 -> v0 = v1
|
|
in
|
|
Test.T.make ~equal ~pp ()
|
|
in
|
|
Test.T.result' ~ok:(test_eval_ok ok) ~error:test_eval_error
|
|
|
|
let get_eval_value ?__POS__ = function
|
|
| Ok (`Ok v) -> v
|
|
| (Error _ | Ok `Version | Ok `Help) as v ->
|
|
Test.failstop ?__POS__ "Unexpected evalution: %a"
|
|
(Test.T.pp (t_eval_result Test.T.any)) v
|
|
|
|
let test_eval_result ?__POS__ ?env t cmd args exp =
|
|
let argv = make_argv cmd args in
|
|
let (ret, _), _ = (* Ignore outputs *)
|
|
capture_fmt @@ fun err ->
|
|
capture_fmt @@ fun help ->
|
|
Cmd.eval_value ?env ~help ~err cmd ~argv
|
|
in
|
|
Test.eq ?__POS__ (t_eval_result t) ret exp
|
|
|
|
let snap_parse ?env t cmd args exp =
|
|
let loc = Test.Snapshot.loc exp in
|
|
let argv = make_argv cmd args in
|
|
let ret = Cmd.eval_value ?env cmd ~argv in
|
|
Test.snap t (get_eval_value ~__POS__:loc ret) exp
|
|
|
|
let snap_parse_warnings ?env cmd args exp =
|
|
let loc = Test.Snapshot.loc exp in
|
|
let argv = make_argv cmd args in
|
|
let ret, err = capture_fmt @@ fun err -> Cmd.eval_value ?env ~err cmd ~argv in
|
|
ignore (get_eval_value ~__POS__:loc ret);
|
|
Snap.lines err exp
|
|
|
|
let snap_eval_error ?env error cmd args exp =
|
|
let loc = Test.Snapshot.loc exp in
|
|
let argv = make_argv cmd args in
|
|
let ret, err = capture_fmt @@ fun err -> Cmd.eval_value ?env ~err cmd ~argv in
|
|
Test.eq (t_eval_result Test.T.any) ret (Error error) ~__POS__:loc ;
|
|
Snap.lines err exp
|
|
|
|
let snap_help ?env retv cmd args exp =
|
|
let loc = Test.Snapshot.loc exp in
|
|
let argv = make_argv cmd args in
|
|
let (ret, help), err =
|
|
capture_fmt @@ fun err ->
|
|
capture_fmt @@ fun help -> Cmd.eval_value ?env ~help ~err cmd ~argv
|
|
in
|
|
Test.string err "";
|
|
Test.eq (t_eval_result Test.T.any) ret retv ~__POS__:loc;
|
|
Snap.lines help exp
|
|
|
|
let snap_completion ?env cmd args exp =
|
|
snap_help ?env (Ok `Help) cmd ("--__complete" :: args) exp
|
|
|
|
let snap_man ?env ?(args = ["--help=plain"]) cmd exp =
|
|
snap_help ?env (Ok `Help) cmd args exp
|
|
|
|
(* Sample commands *)
|
|
|
|
open Cmdliner
|
|
open Cmdliner.Term.Syntax
|
|
|
|
let sample_group_cmd =
|
|
let man = [ `P "Invoke command with $(cmd), the command name is \
|
|
$(cmd.name), the parent is $(cmd.parent) and the tool \
|
|
name is $(tool)." ] in
|
|
let kind =
|
|
let doc = "Kind of entity" in
|
|
Arg.(value & opt (some string) None & info ["k";"kind"] ~doc)
|
|
in
|
|
let speed =
|
|
let doc = "Movement $(docv) in m/s" in
|
|
Arg.(value & opt int 2 & info ["speed"] ~doc ~docv:"SPEED")
|
|
in
|
|
let can_fly =
|
|
let doc = "$(docv) indicates if the entity can fly." in
|
|
Arg.(value & opt bool false & info ["can-fly"] ~doc)
|
|
in
|
|
let birds =
|
|
let bird =
|
|
let doc = "Use $(docv) specie." in
|
|
Arg.(value & pos 0 string "pigeon" & info [] ~doc ~docv:"BIRD")
|
|
in
|
|
let fly =
|
|
Cmd.make (Cmd.info "fly" ~doc:"Fly birds." ~man) @@
|
|
let+ bird and+ speed in ()
|
|
in
|
|
let land' =
|
|
Cmd.make (Cmd.info "land" ~doc:"Land birds." ~man) @@
|
|
let+ bird in ()
|
|
in
|
|
let info = Cmd.info "birds" ~doc:"Operate on birds." ~man in
|
|
Cmd.group ~default:Term.(const (fun _ _-> ()) $ kind $ can_fly) info @@
|
|
[fly; land']
|
|
in
|
|
let mammals =
|
|
let man_xrefs = [`Main; `Cmd "birds" ] and doc = "Operate on mammals." in
|
|
Cmd.make (Cmd.info "mammals" ~doc ~man_xrefs ~man) @@
|
|
Term.(const (fun () -> ()) $ const ())
|
|
in
|
|
let fishs =
|
|
let name' =
|
|
let doc = "Use fish named $(docv)." in
|
|
Arg.(value & pos 0 (some string) None & info [] ~doc ~docv:"NAME")
|
|
in
|
|
Cmd.make (Cmd.info "fishs" ~doc:"Operate on fishs." ~man) @@
|
|
let+ name' in ()
|
|
in
|
|
let camels =
|
|
let herd =
|
|
let doc = "Find in herd $(docv)." and docv = "HERD" in
|
|
let deprecated = "Herds $(docv) are ignored." in
|
|
Arg.(value & pos 0 (some string) None & info [] ~deprecated ~doc ~docv)
|
|
in
|
|
let bactrian =
|
|
let deprecated = "Use nothing instead of $(env), $(b,HA!)." in
|
|
let doc = "Specify a bactrian camel." in
|
|
let env = Cmd.Env.info "BACTRIAN" ~deprecated in
|
|
Arg.(value & flag & info ["bactrian"; "b"] ~deprecated ~env ~doc)
|
|
in
|
|
let deprecated = "Use $(b,mammals) instead." in
|
|
Cmd.make (Cmd.info "camels" ~deprecated ~doc:"Operate on camels." ~man) @@
|
|
let+ bactrian and+ herd in ()
|
|
in
|
|
let lookup =
|
|
let kind_opt =
|
|
let kinds = ["bird", `Bird; "fish", `Fish] in
|
|
let doc =
|
|
"$(docv) restricts the animal kind. Must be " ^ Arg.doc_alts_enum kinds
|
|
in
|
|
Arg.(value & opt (some (enum kinds)) None & info ["k"; "kind"] ~doc)
|
|
in
|
|
let name_conv =
|
|
let bird_names = ["sparrow"; "parrot"; "pigeon"] in
|
|
let fish_names = ["salmon"; "trout"; "piranha"] in
|
|
let completion =
|
|
let select ~token:prefix n =
|
|
if String.starts_with ~prefix n
|
|
then Some (Arg.Completion.string n) else None
|
|
in
|
|
let func kind ~token = match Option.join kind with
|
|
| None -> Ok (List.filter_map (select ~token) (bird_names @ fish_names))
|
|
| Some `Bird -> Ok (List.filter_map (select ~token) bird_names)
|
|
| Some `Fish -> Ok (List.filter_map (select ~token) fish_names)
|
|
in
|
|
Arg.Completion.make ~context:kind_opt func
|
|
in
|
|
Arg.Conv.of_conv Arg.string ~completion
|
|
in
|
|
Cmd.make (Cmd.info "lookup" ~doc:"Lookup animal by name.") @@
|
|
let+ kind_opt
|
|
and+ name =
|
|
let doc = "$(docv) is the animal name to lookup" and docv = "NAME" in
|
|
Arg.(required & pos 0 (some name_conv) None & info [] ~doc ~docv)
|
|
in
|
|
()
|
|
in
|
|
Cmd.group (Cmd.info "test_group" ~version:"X.Y.Z" ~man) @@
|
|
[birds; mammals; fishs; camels; lookup]
|