Source file b0_pager.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
(*---------------------------------------------------------------------------
   Copyright (c) 2018 The b0 programmers. All rights reserved.
   SPDX-License-Identifier: ISC
  ---------------------------------------------------------------------------*)

open B0_std
open Result.Syntax

(* Environment variables *)

module Env = struct
  let pager = "PAGER"
  let less = "LESS"
  let term = "TERM"

  let infos =
    let open Cmdliner in
    Cmd.Env.info pager
      ~doc:"The pager used to display content. This is a command invocation \
            given to execvp(3)." ::
    Cmd.Env.info term
      ~doc:"See option $(b,--no-pager)." :: []
end

(* Paging *)

type t = Cmd.t option
let does_page = Option.is_some

let find ?search ?cmd ~no_pager () =
  if no_pager then Ok None else
  match cmd with
  | Some cmd -> Ok (Os.Cmd.find ?search cmd)
  | None ->
      match Os.Env.var ~empty_is_none:true Env.term with
      | Some "dumb" | None -> Ok None
      | Some _ ->
          let cmds = [Cmd.tool "less"; Cmd.tool "more"] in
          let* cmds =
            let empty_is_none = true in
            match Os.Env.var' ~empty_is_none Cmd.of_string Env.pager with
            | Error _ as e -> e
            | Ok None -> Ok cmds
            | Ok (Some cmd) -> Ok (cmd :: cmds)
          in
          Ok (Os.Cmd.find_first ?search cmds)

let pager_env () = match Os.Env.var ~empty_is_none:false Env.less with
| Some _ -> Ok None
| None ->
    Result.bind (Os.Env.current_assignments ()) @@ fun env ->
    Ok (Some ("LESS=FRX" :: env))

let page_stdout = function
| None -> Ok ()
| Some pager ->
    let uerr = Unix.error_message in
    let err fmt = Fmt.error ("page stdout: " ^^ fmt) in
    let rec dup2 fd0 fd1 = match Unix.dup2 fd0 fd1 with
    | () -> Ok ()
    | exception Unix.Unix_error (Unix.EINTR, _, _) -> dup2 fd0 fd1
    | exception Unix.Unix_error (e, _, _) -> err "dup2: %s" (uerr e)
    in
    match pager_env () with
    | Error e -> err "%s" e
    | Ok env ->
        match Unix.pipe () with
        | exception Unix.Unix_error (e, _, _)  -> err "pipe: %s" (uerr e)
        | (pager_read, parent_write) ->
            let stdin = Os.Cmd.in_fd ~close:true pager_read in
            Unix.set_close_on_exec parent_write;
            Os.Fd.apply ~close:Unix.close parent_write @@ fun parent_write ->
            let* pid = Os.Cmd.spawn ?env ~stdin pager in
            let* () = dup2 parent_write Unix.stdout in
            let parent_pid = Unix.getpid () in
            let on_parent_exit () =
              (* We need to be careful here, forked processes will also
                 get to execute this. *)
              if parent_pid = Unix.getpid () then begin
                (* Before closing Unix.stdout it's better to flush
                   formatter and channels. Otherwise it's done later
                   by OCaml's standard shutdown procedure and it
                   raises Sys_error as the fd is no longer valid. *)
                (try Fmt.flush Fmt.stdout () with Sys_error _ -> ());
                (try flush stdout with Sys_error _ -> ());
                (try Unix.close Unix.stdout with Unix.Unix_error _ -> ());
                Log.if_error ~use:() @@ Result.map ignore @@
                Os.Cmd.spawn_wait_status pid
              end
            in
            at_exit on_parent_exit;
            Ok ()

let page_files pager files = match pager with
| Some pager when files = [] -> Ok ()
| Some pager -> Os.Cmd.run Cmd.(pager %% paths files)
| None ->
    let rec loop = function
    | [] -> Ok ()
    | f :: fs ->
        match Os.File.read f with
        | Error _ as e -> e
        | Ok contents ->
            Printf.printf "%s" contents;
            if fs <> [] then Printf.printf "\x1C" (* U+001C FS *);
            flush stdout;
            loop fs
    in
    loop files

(* Cli interaction *)

let no_pager ?(docs = Cmdliner.Manpage.s_common_options) () =
  let open Cmdliner in
  let doc =
    "Do not display the output in a pager. This automatically happens \
     if the $(b,TERM) environment variable is $(b,dumb) or undefined."
  in
  Arg.(value & flag & info ["no-pager"] ~docs ~doc_envs:Env.infos ~doc)