mbarbin / git-pager / 8

Committed 08 May 2025 12:24PM UTC coverage: 90.964% (+0.06%) from 90.909%

Build # 8

Build Type

push

github

Committed by

mbarbin

Commit Message

Add test

Run Details

151 of 166 relevant lines covered (90.96%)

16.16 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

82.76

/lib/git_pager/src/git_pager.ml

(*********************************************************************************)
(*  Git_pager - Run a Git pager to display diffs and other custom outputs        *)
(*  SPDX-FileCopyrightText: 2024-2025 Mathieu Barbin <mathieu.barbin@gmail.com>  *)
(*  SPDX-License-Identifier: MIT                                                 *)
(*********************************************************************************)

module Unix = UnixLabels

type t =
  { output_kind : [ `Tty | `Pager | `Other ]
  ; git_color_mode : [ `Auto | `Always | `Never ]
  ; write_end : Out_channel.t
  }

let output_kind t = t.output_kind
let git_color_mode t = t.git_color_mode
let write_end t = t.write_end

let should_enable_color t =
  match git_color_mode t with
  | `Always -> true
  | `Never -> false
  | `Auto ->
    (match output_kind t with
     | `Tty -> true
     | `Other -> false
     | `Pager ->
       (* That case is unreachable by design. *)
       true
       [@coverage off])
;;

module Process_status = struct
  type t = Unix.process_status =
    | WEXITED of int
    | WSIGNALED of int
    | WSTOPPED of int

  let to_string t =
    match t with
    | WEXITED i -> Printf.sprintf "Exited %d" i
    | WSIGNALED i -> Printf.sprintf "Signaled %d" i [@coverage off]
    | WSTOPPED i -> Printf.sprintf "Stopped %d" i [@coverage off]
  ;;
end

module String_tty = struct
  type t = string

  let to_string t = t
end

let git_pager_value =
  lazy
    (match
       (* We shortcut git entirely when [GIT_PAGER=cat] so we can run this code in
          tests that do not have an actual git environment, such as in the dune
          [.sandbox/.git]. *)
       Stdlib.Sys.getenv_opt "GIT_PAGER"
     with
     | Some ("cat" as cat) -> cat
     | None | Some _ ->
       let ((in_ch, _) as process) =
         Unix.open_process_args "git" [| "git"; "var"; "GIT_PAGER" |]
       in
       let output = In_channel.input_all in_ch in
       (match Unix.close_process process with
        | WEXITED 0 -> output |> String.trim
        | (WEXITED _ | WSIGNALED _ | WSTOPPED _) as process_status ->
          Err.raise
            Pp.O.
              [ Pp.text "Failed to get the value of "
                ++ Pp_tty.kwd (module String_tty) "GIT_PAGER"
                ++ Pp.text "."
              ; Pp_tty.id (module Process_status) process_status
              ]))
;;

let git_color_ui_value =
  lazy
    (let ((in_ch, _) as process) =
       Unix.open_process_args "git" [| "git"; "config"; "--get"; "color.ui" |]
     in
     let output = In_channel.input_all in_ch in
     match Unix.close_process process with
     | WEXITED (0 | 1) ->
       (match output |> String.trim with
        | "" | "auto" -> `Auto
        | "always" -> `Always
        | "never" -> `Never
        | other ->
          Err.raise
            Pp.O.
              [ Pp.text "Unexpected "
                ++ Pp_tty.kwd (module String_tty) "git color.ui"
                ++ Pp.text " value "
                ++ Pp_tty.id (module String_tty) other
                ++ Pp.text "."
              ])
     | (WEXITED _ | WSIGNALED _ | WSTOPPED _) as process_status ->
       Err.raise
         Pp.O.
           [ Pp.text "Failed to get the value of "
             ++ Pp_tty.kwd (module String_tty) "color.ui"
             ++ Pp.text "."
           ; Pp_tty.id (module Process_status) process_status
           ])
;;

let get_git_pager () = Lazy.force git_pager_value
let get_git_color_ui () = Lazy.force git_color_ui_value

let rec waitpid_non_intr pid =
  try Unix.waitpid ~mode:[] pid with
  | Unix.Unix_error (EINTR, _, _) -> waitpid_non_intr pid
;;

let force_stdout_isatty_test = ref false

let run ~f =
  let git_pager = get_git_pager () in
  let output_kind =
    if (Unix.isatty Unix.stdout [@coverage off]) || !force_stdout_isatty_test
    then if String.equal git_pager "cat" then `Tty else `Pager
    else `Other
  in
  let git_color_mode =
    match Err.color_mode () with
    | (`Always | `Never) as override -> override
    | `Auto as auto ->
      (match output_kind with
       | `Tty | `Other -> auto
       | `Pager ->
         (match get_git_color_ui () with
          | (`Always | `Never) as override -> override
          | `Auto -> `Always))
  in
  match output_kind with
  | `Tty | `Other -> f { output_kind; git_color_mode; write_end = Out_channel.stdout }
  | `Pager ->
    let process_env =
      let env = Unix.environment () in
      if Array.exists (fun s -> String.starts_with ~prefix:"LESS=" s) env
      then env
      else Array.append env [| "LESS=FRX" |]
    in
    let pager_in, pager_out = Unix.pipe ~cloexec:true () in
    let process =
      let prog, args =
        match String.split_on_char ' ' git_pager with
        | [] -> assert false (* By specification of [String.split_on_char]. *)
        | [ _ ] -> git_pager, [| git_pager |]
        | prog :: _ as args -> prog, Array.of_list args
      in
      Unix.create_process_env
        ~prog
        ~args
        ~env:process_env
        ~stdin:pager_in
        ~stdout:Unix.stdout
        ~stderr:Unix.stderr
    in
    Unix.close pager_in;
    let write_end = Unix.out_channel_of_descr pager_out in
    let result =
      match
        let res = f { output_kind; git_color_mode; write_end } in
        Out_channel.flush write_end;
        res
      with
      | res -> Ok res
      | exception e ->
        let bt = Printexc.get_raw_backtrace () in
        Error (bt, e)
    in
    (match
       Out_channel.close write_end;
       waitpid_non_intr process |> snd
     with
     | WEXITED 0 ->
       (match result with
        | Ok res -> res
        | Error (bt, exn) -> Printexc.raise_with_backtrace exn bt)
     | exception finally_exn ->
       Err.raise
         Pp.O.
           [ Pp.text "Call to "
             ++ Pp_tty.kwd (module String_tty) "GIT_PAGER"
             ++ Pp.text " raised."
           ; Pp.text "Writer Status: "
             ++ (match result with
               | Ok _ -> Pp.text "Ok"
               | Error (_, exn) -> Pp.text "Raised " ++ Pp_tty.id (module Printexc) exn)
             ++ Pp.text "."
           ; Pp.text "Pager Exception: "
             ++ Pp_tty.id (module Printexc) finally_exn
             ++ Pp.text "."
           ] [@coverage off]
     | (WEXITED _ | WSIGNALED _ | WSTOPPED _) as process_status ->
       Err.raise
         Pp.O.
           [ Pp.text "Call to "
             ++ Pp_tty.kwd (module String_tty) "GIT_PAGER"
             ++ Pp.text " failed."
           ; Pp.text "Writer Status: "
             ++ (match result with
               | Ok _ -> Pp.text "Ok"
               | Error (_, exn) -> Pp.text "Raised " ++ Pp_tty.id (module Printexc) exn)
             ++ Pp.text "."
           ; Pp.text "Pager Exit Status: "
             ++ Pp_tty.id (module Process_status) process_status
             ++ Pp.text "."
           ])
;;

module Private = struct
  let force_stdout_isatty_test = force_stdout_isatty_test
end

1	(*********************************************************************************)
2	(* Git_pager - Run a Git pager to display diffs and other custom outputs *)
3	(* SPDX-FileCopyrightText: 2024-2025 Mathieu Barbin <mathieu.barbin@gmail.com> *)
4	(* SPDX-License-Identifier: MIT *)
5	(*********************************************************************************)
6
7	module Unix = UnixLabels
8
9	type t =
10	{ output_kind : [ `Tty \| `Pager \| `Other ]
11	; git_color_mode : [ `Auto \| `Always \| `Never ]
12	; write_end : Out_channel.t
13	}
14
15	let output_kind t = t.output_kind	19✔
16	let git_color_mode t = t.git_color_mode	44✔
17	let write_end t = t.write_end	36✔
18
19	let should_enable_color t =
20	match git_color_mode t with	15✔
21	\| `Always -> true	7✔
22	\| `Never -> false	4✔
23	\| `Auto ->	4✔
24	(match output_kind t with
25	\| `Tty -> true	1✔
26	\| `Other -> false	3✔
27	\| `Pager ->
28	(* That case is unreachable by design. *)
29	true
30	[@coverage off])
31	;;
32
33	module Process_status = struct
34	type t = Unix.process_status =
35	\| WEXITED of int
36	\| WSIGNALED of int
37	\| WSTOPPED of int
38
39	let to_string t =
40	match t with	4✔
41	\| WEXITED i -> Printf.sprintf "Exited %d" i	4✔
42	\| WSIGNALED i -> Printf.sprintf "Signaled %d" i [@coverage off]
43	\| WSTOPPED i -> Printf.sprintf "Stopped %d" i [@coverage off]
44	;;
45	end
46
47	module String_tty = struct
48	type t = string
49
50	let to_string t = t	4✔
51	end
52
53	let git_pager_value =
54	lazy
55	(match	36✔
56	(* We shortcut git entirely when [GIT_PAGER=cat] so we can run this code in
57	tests that do not have an actual git environment, such as in the dune
58	[.sandbox/.git]. *)
59	Stdlib.Sys.getenv_opt "GIT_PAGER"
60	with
61	\| Some ("cat" as cat) -> cat	4✔
62	\| None \| Some _ ->	6✔
63	let ((in_ch, _) as process) =
64	Unix.open_process_args "git" [\| "git"; "var"; "GIT_PAGER" \|]
65	in
66	let output = In_channel.input_all in_ch in	32✔
67	(match Unix.close_process process with	32✔
68	\| WEXITED 0 -> output \|> String.trim	30✔
69	\| (WEXITED _ \| WSIGNALED _ \| WSTOPPED _) as process_status ->	×
70	Err.raise
71	Pp.O.
72	[ Pp.text "Failed to get the value of "	2✔
73	++ Pp_tty.kwd (module String_tty) "GIT_PAGER"	2✔
74	++ Pp.text "."	2✔
75	; Pp_tty.id (module Process_status) process_status	2✔
76	]))
77	;;
78
79	let git_color_ui_value =
80	lazy
81	(let ((in_ch, _) as process) =	14✔
82	Unix.open_process_args "git" [\| "git"; "config"; "--get"; "color.ui" \|]
83	in
84	let output = In_channel.input_all in_ch in	14✔
85	match Unix.close_process process with	14✔
86	\| WEXITED (0 \| 1) ->	5✔
87	(match output \|> String.trim with
88	\| "" \| "auto" -> `Auto	1✔
89	\| "always" -> `Always	1✔
90	\| "never" -> `Never	3✔
91	\| other ->	×
92	Err.raise
93	Pp.O.
94	[ Pp.text "Unexpected "	×
95	++ Pp_tty.kwd (module String_tty) "git color.ui"	×
96	++ Pp.text " value "	×
97	++ Pp_tty.id (module String_tty) other	×
98	++ Pp.text "."	×
99	])
100	\| (WEXITED _ \| WSIGNALED _ \| WSTOPPED _) as process_status ->	×
101	Err.raise
102	Pp.O.
103	[ Pp.text "Failed to get the value of "	×
104	++ Pp_tty.kwd (module String_tty) "color.ui"	×
105	++ Pp.text "."	×
106	; Pp_tty.id (module Process_status) process_status	×
107	])
108	;;
109
110	let get_git_pager () = Lazy.force git_pager_value	36✔
111	let get_git_color_ui () = Lazy.force git_color_ui_value	14✔
112
113	let rec waitpid_non_intr pid =
114	try Unix.waitpid ~mode:[] pid with	18✔
115	\| Unix.Unix_error (EINTR, _, _) -> waitpid_non_intr pid	×
116	;;
117
118	let force_stdout_isatty_test = ref false
119
120	let run ~f =
121	let git_pager = get_git_pager () in	36✔
122	let output_kind =	34✔
123	if (Unix.isatty Unix.stdout [@coverage off]) \|\| !force_stdout_isatty_test	20✔
124	then if String.equal git_pager "cat" then `Tty else `Pager	2✔
125	else `Other	14✔
126	in
127	let git_color_mode =
128	match Err.color_mode () with
129	\| (`Always \| `Never) as override -> override	4✔
130	\| `Auto as auto ->	26✔
131	(match output_kind with
132	\| `Tty \| `Other -> auto	2✔
133	\| `Pager ->	14✔
134	(match get_git_color_ui () with
135	\| (`Always \| `Never) as override -> override	1✔
136	\| `Auto -> `Always))	10✔
137	in
138	match output_kind with
139	\| `Tty \| `Other -> f { output_kind; git_color_mode; write_end = Out_channel.stdout }	2✔
140	\| `Pager ->	18✔
141	let process_env =
142	let env = Unix.environment () in
143	if Array.exists (fun s -> String.starts_with ~prefix:"LESS=" s) env	18✔
144	then env	×
145	else Array.append env [\| "LESS=FRX" \|]	18✔
146	in
147	let pager_in, pager_out = Unix.pipe ~cloexec:true () in
148	let process =	18✔
149	let prog, args =
150	match String.split_on_char ' ' git_pager with
151	\| [] -> assert false (* By specification of [String.split_on_char]. *)
152	\| [ _ ] -> git_pager, [\| git_pager \|]	12✔
153	\| prog :: _ as args -> prog, Array.of_list args	6✔
154	in
155	Unix.create_process_env
156	~prog
157	~args
158	~env:process_env
159	~stdin:pager_in
160	~stdout:Unix.stdout
161	~stderr:Unix.stderr
162	in
163	Unix.close pager_in;
164	let write_end = Unix.out_channel_of_descr pager_out in	18✔
165	let result =	18✔
166	match
167	let res = f { output_kind; git_color_mode; write_end } in
168	Out_channel.flush write_end;	16✔
169	res	16✔
170	with
171	\| res -> Ok res	16✔
172	\| exception e ->	2✔
173	let bt = Printexc.get_raw_backtrace () in
174	Error (bt, e)	2✔
175	in
176	(match
177	Out_channel.close write_end;
178	waitpid_non_intr process \|> snd	18✔
179	with
180	\| WEXITED 0 ->	16✔
181	(match result with
182	\| Ok res -> res	15✔
183	\| Error (bt, exn) -> Printexc.raise_with_backtrace exn bt)	1✔
184	\| exception finally_exn ->
185	Err.raise
186	Pp.O.
187	[ Pp.text "Call to "
188	++ Pp_tty.kwd (module String_tty) "GIT_PAGER"
189	++ Pp.text " raised."
190	; Pp.text "Writer Status: "
191	++ (match result with
192	\| Ok _ -> Pp.text "Ok"
193	\| Error (_, exn) -> Pp.text "Raised " ++ Pp_tty.id (module Printexc) exn)
194	++ Pp.text "."
195	; Pp.text "Pager Exception: "
196	++ Pp_tty.id (module Printexc) finally_exn
197	++ Pp.text "."
198	] [@coverage off]
199	\| (WEXITED _ \| WSIGNALED _ \| WSTOPPED _) as process_status ->	×
200	Err.raise
201	Pp.O.
202	[ Pp.text "Call to "	2✔
203	++ Pp_tty.kwd (module String_tty) "GIT_PAGER"	2✔
204	++ Pp.text " failed."	2✔
205	; Pp.text "Writer Status: "	2✔
206	++ (match result with	2✔
207	\| Ok _ -> Pp.text "Ok"	1✔
208	\| Error (_, exn) -> Pp.text "Raised " ++ Pp_tty.id (module Printexc) exn)	1✔
209	++ Pp.text "."	2✔
210	; Pp.text "Pager Exit Status: "	2✔
211	++ Pp_tty.id (module Process_status) process_status	2✔
212	++ Pp.text "."	2✔
213	])
214	;;
215
216	module Private = struct
217	let force_stdout_isatty_test = force_stdout_isatty_test
218	end

mbarbin / git-pager / 8

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous