unikernel/duniverse/cmdliner/test/testing_cmdliner.ml

@@ -0,0 +1,199 @@
+(*---------------------------------------------------------------------------
+   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]