Something went wrong. Try again.
How a command-line program ends
Something went wrong. Try again.
10 kB · 235 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236(* Read out of the C library rather than written here, so a platform that words EPIPE differently is still recognised. *)let broken_pipe = Unix.error_message Unix.EPIPE
let closed_reader = function | Sys_error m -> String.equal m broken_pipe | Unix.Unix_error (EPIPE, _, _) -> true | _ -> false
(* [Unix._exit] rather than [exit]: what is buffered for a reader that has gone cannot be written, and the flush [exit] runs would meet the same closed pipe and raise out of [exit]. stderr may hold a line the caller can still read, so it is flushed first. *)let leave_quietly code = (try flush stderr with Sys_error _ -> ()); Unix._exit code
let writing_output f = try f () with | e when closed_reader e -> leave_quietly 0 (* Eio reports a closed pipe as a reset connection and hides the errno in the backend error, so a reset is read as the reader leaving. That holds only because the caller says this write went to the program's own output. *) | Eio.Io (Eio.Net.E (Connection_reset _), _) -> leave_quietly 0
(* Cmdliner's own report for an exception nothing expected, which [~catch:false] hands over with the status. Same sentence and status, no terminal styling, and no trailing newline on the backtrace, as cmdliner's report has none. *)let internal_error name e bt = let bt = Printexc.raw_backtrace_to_string bt in let bt = match String.length bt with 0 -> bt | n -> String.sub bt 0 (n - 1) in Fmt.epr "@[%s: @[internal error, uncaught exception:@\n%a@]@]@." name Fmt.lines (String.concat "\n" [ Printexc.to_string e; bt ]); Cmdliner.Cmd.Exit.internal_error
let refused = Cmdliner.Cmd.Exit.some_errorlet cli_error = Cmdliner.Cmd.Exit.cli_error
let refusal_report name message = Fmt.epr "%s: %s@." name message; refused
(* Help is written, never paged. Cmdliner's [`Auto] format is [`Pager] for every TERM but "dumb", and a pager spawned by a script or a supervisor has nobody to press q; the pager path also formats the page with groff, so [--help | grep] reads overstrike rather than text. Answering "dumb" is cmdliner's own spelling for "do not page"; an explicit [--help=pager] still pages, and styling is not decided here. PAGER and MANPAGER are not read: a page written in this process spawns no pager child whose broken pipe would need silencing. *)let cmdliner_environment = function | "TERM" -> Some "dumb" | variable -> Sys.getenv_opt variable
(* Cmdliner writes the manual's own item for [--help], stating the paging rule the lookup above overrides, and offers no hook for the string. [Manpage.s_none] is dropped from the page, so [sdocs] sends cmdliner's items nowhere and [standard_options] puts true ones back in the section they were in. *)let sdocs = Cmdliner.Manpage.s_none
let standard_options ~version : Cmdliner.Manpage.block list = let help = `I ( "$(b,--help)[=$(i,FMT)] (default=$(b,auto))", "Show this help in format $(i,FMT). The value $(i,FMT) must be one of \ $(b,auto), $(b,pager), $(b,groff) or $(b,plain). This program writes \ its manual to standard output and never opens a pager, so $(b,auto) \ is $(b,plain) here whatever $(b,TERM) is set to. $(b,--help=pager) \ still pages." ) in let version_option = `I ("$(b,--version)", "Show version information.") in let options = if version then [ help; version_option ] else [ help ] in `S Cmdliner.Manpage.s_common_options :: options
(* The one call that builds a command's whole [Cmd.info], so [sdocs] and [standard_options] are applied together and cannot be separated. *)(* What a command's EXIT STATUS section says; cmdliner generates it from this list, {!refused} among its entries, so the page and the status the program exits by are one value. The sentences are cmdliner's defaults rewritten for a script author deciding what to branch on. *)let exits = [ Cmdliner.Cmd.Exit.info ~doc:"on success." Cmdliner.Cmd.Exit.ok; Cmdliner.Cmd.Exit.info ~doc:"on a refusal, printed on standard error with what to do about it." refused; Cmdliner.Cmd.Exit.info ~doc: "on a command line this command could not read: an option, a value \ or an argument it does not have." cli_error; Cmdliner.Cmd.Exit.info ~doc: "on a defect in this program, printed \ on standard error." Cmdliner.Cmd.Exit.internal_error; ]
let info ?deprecated ?man_xrefs ?man ?envs ?(exits = exits) ?docs ?doc ?version ?(with_version = true) name = let man = Option.value man ~default:[] @ standard_options ~version:with_version in Cmdliner.Cmd.info name ?deprecated ?man_xrefs ~man ?envs ~exits ~sdocs ?docs ?doc ?version
(* How an exception that reached the top of the program ends it. The runtime calls this once the exception has unwound every frame, finaliser and switch of the run, and after it has run [at_exit] and flushed what it could, so the process ends with [Unix._exit] rather than running [at_exit] twice. A cancellation that reaches the top keeps the runtime's own report. *)let ending ~name ~refusal e bt = match e with | Eio.Cancel.Cancelled _ -> Printexc.default_uncaught_exception_handler e bt | e when closed_reader e -> leave_quietly 0 | e -> ( match refusal e with | Some message -> leave_quietly (refusal_report name message) | None -> leave_quietly (internal_error name e bt))
(* The whole run of a program whose command line [eval] evaluates, [name] being its command's name. An exception [eval] raises propagates to the top of the program, where {!ending} reports it. *)let evaluate ~name ?(refusal = fun _ -> None) eval = (* Before anything is written: the first write may be the help cmdliner prints, and under SIGPIPE's default disposition that write ends the process at 141 before any handler sees the failure. Windows has no SIGPIPE. *) if not Sys.win32 then Sys.set_signal Sys.sigpipe Sys.Signal_ignore; Printexc.set_uncaught_exception_handler (ending ~name ~refusal); let code = eval () in (* [exit] flushes what the run left buffered, so it is the last place the reader can turn out to be gone. *) try exit code with e when closed_reader e -> leave_quietly code
(* [~catch:false]: cmdliner's own catch turns a term exception into "internal error" and exit 125, and a closed pipe reaches this program as that verdict rather than as the exception. *)let run ?argv ?refusal cmd = evaluate ~name:(Cmdliner.Cmd.name cmd) ?refusal (fun () -> Cmdliner.Cmd.eval ~catch:false ~env:cmdliner_environment ?argv cmd)
(* What cmdliner writes on its error formatter, one message per flush, the last first. Cmdliner ends each message with a flush, and reports a command line it refuses as its usage line, if any, then [NAME: MESSAGE]. *)type report = { ppf : Format.formatter; messages : unit -> string list }
(* Wide enough that cmdliner breaks no line of its report. *)let unbounded = 1_000_000
let report () = let message = Buffer.create 256 and messages = ref [] in let flush () = messages := Buffer.contents message :: !messages; Buffer.clear message in let ppf = Format.make_formatter (Buffer.add_substring message) flush in Format.pp_set_margin ppf unbounded; let messages () = Format.pp_print_flush ppf (); List.filter (fun m -> m <> "") !messages in { ppf; messages }
(* [plain ~quote s] is [s] without the SGR sequences ([ESC \[ ... m]) that cmdliner's ANSI styler writes, which cmdliner chooses from TERM and NO_COLOR when it is initialised, whatever [~env] answers. With [quote], a bold span is quoted: in a message, bold is how that styler marks a name its plain styler quotes. *)let plain ~quote s = let b = Buffer.create (String.length s) and n = String.length s in let rec sgr_end i = if i < n && s.[i] <> 'm' then sgr_end (i + 1) else i in let rec copy ~bold i = if i >= n then () else if s.[i] = '\x1b' && i + 1 < n && s.[i + 1] = '[' then let j = sgr_end (i + 2) in let bold = match String.sub s (i + 2) (j - i - 2) with | "01" when quote -> Buffer.add_char b '\''; true | "" when bold -> Buffer.add_char b '\''; false | _ -> bold in copy ~bold (j + 1) else ( Buffer.add_char b s.[i]; copy ~bold (i + 1)) in copy ~bold:false 0; Buffer.contents b
let message ~name text = let text = String.trim (plain ~quote:true text) in let prefix = name ^ ": " in if String.starts_with ~prefix text then let n = String.length prefix in String.sub text n (String.length text - n) else text
(* Cmdliner answers {!cli_error} for an error of the term's own as for a command line it cannot parse, and classifies an unknown option as the former, so both are ends of a command line that does not parse. *)let parse_error_status ~name ~parse_error ?argv cmd = let report = report () in let result = Cmdliner.Cmd.eval_value ~catch:false ~env:cmdliner_environment ~err:report.ppf ?argv cmd in let write = if Unix.isatty Unix.stderr then List.iter prerr_string else List.iter (fun m -> prerr_string (plain ~quote:false m)) in match (result, report.messages ()) with | Error (`Parse | `Term), last :: before -> write (List.rev before); parse_error (message ~name last) | result, messages -> ( write (List.rev messages); match result with | Ok (`Ok code) -> code | Ok (`Help | `Version) -> Cmdliner.Cmd.Exit.ok | Error (`Parse | `Term) -> cli_error | Error `Exn -> Cmdliner.Cmd.Exit.internal_error)
let run' ?argv ?refusal ?parse_error cmd = let name = Cmdliner.Cmd.name cmd in evaluate ~name ?refusal (fun () -> match parse_error with | None -> Cmdliner.Cmd.eval' ~catch:false ~env:cmdliner_environment ?argv cmd | Some parse_error -> parse_error_status ~name ~parse_error ?argv cmd)