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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
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 ->
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 =
lazy
(match
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 () = 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 = 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 , = Unix.pipe ~cloexec:true () in
let process =
let prog, args =
match String.split_on_char ' ' git_pager with
| [] -> assert false
| [ _ ] -> 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