package crs

  1. Overview
  2. Docs
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file crs_parser.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
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
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
(********************************************************************************)
(*  crs - A tool for managing code review comments embedded in source code      *)
(*  Copyright (C) 2024-2025 Mathieu Barbin <mathieu.barbin@gmail.com>           *)
(*                                                                              *)
(*  This file is part of crs.                                                   *)
(*                                                                              *)
(*  crs is free software; you can redistribute it and/or modify it under the    *)
(*  terms of the GNU Lesser General Public License as published by the Free     *)
(*  Software Foundation either version 3 of the License, or any later version,  *)
(*  with the LGPL-3.0 Linking Exception.                                        *)
(*                                                                              *)
(*  crs is distributed in the hope that it will be useful, but WITHOUT ANY      *)
(*  WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS   *)
(*  FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License and     *)
(*  the file `NOTICE.md` at the root of this repository for more details.       *)
(*                                                                              *)
(*  You should have received a copy of the GNU Lesser General Public License    *)
(*  and the LGPL-3.0 Linking Exception along with this library. If not, see     *)
(*  <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.        *)
(********************************************************************************)

(* This module is derived from Iron (v0.9.114.44+47), file
   * [./hg/cr_comment.ml], which is released under Apache 2.0:
   *
   * Copyright (c) 2016-2017 Jane Street Group, LLC <opensource-contacts@janestreet.com>
   *
   * Licensed under the Apache License, Version 2.0 (the "License"); you may not
   * use this file except in compliance with the License. You may obtain a copy
   * of the License at:
   *
   *     http://www.apache.org/licenses/LICENSE-2.0
   *
   * Unless required by applicable law or agreed to in writing, software
   * distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
   * WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
   * License for the specific language governing permissions and limitations
   * under the License.
   *
   * See the file `NOTICE.md` at the root of this repository for more details.
   *
   * Changes:
   *
   * - Migrate to this file only the part that relates to grepping versioned files.
   * - Remove dependency to [Core] - make small adjustments to use [Base] instead.
   * - Remove dependency to [Async] - replace by [Spawn] and [Stdio].
   * - Use [Vcs] instead of [Hg].
*)

module Unix = UnixLabels

let cr_pattern_egrep = File_parser.cr_pattern_egrep
let parse_file = File_parser.parse_file

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

let read_all_from_fd fd =
  let out = In_channel.input_all (Unix.in_channel_of_descr fd) in
  Unix.close fd;
  out
;;

let find_executable ~path ~executable_basename =
  let rec loop = function
    | [] -> (None [@coverage off])
    | path :: rest ->
      let fn = Stdlib.Filename.concat path executable_basename in
      if Stdlib.Sys.file_exists fn then Some fn else loop rest
  in
  loop (String.split path ~on:':')
;;

let find_xargs =
  lazy
    (match Stdlib.Sys.getenv_opt "PATH" with
     | None -> None [@coverage off]
     | Some path -> find_executable ~path ~executable_basename:"xargs")
;;

module Exit_status = struct
  [@@@coverage off]

  type t =
    [ `Exited of int
    | `Signaled of int
    | `Stopped of int
    ]
  [@@deriving sexp_of]
end

let null_separator = String.make 1 (Char.of_int_exn 0)

let () =
  (* Something similar is done when you link with [Core_unix] however it is
     preferable to make the rendering of errors deterministic based on code
     present in this module here rather than purely from dependencies, since
     dependencies may change. *)
  Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Unix.Unix_error] (function
    | Unix.Unix_error (error, fn, param) ->
      Sexp.List
        [ Atom "Unix.Unix_error"; Atom (Unix.error_message error); Atom fn; Atom param ]
    | _ -> assert false)
;;

let grep ~vcs ~repo_root ~below =
  match Vcs.ls_files vcs ~repo_root ~below with
  | [] -> []
  | _ :: _ as files_below ->
    let files_to_grep =
      let stdin_text =
        files_below
        |> List.map ~f:Vcs.Path_in_repo.to_string
        |> String.concat ~sep:null_separator
      in
      let stdout_ref = ref "<Unknown>" in
      let stderr_ref = ref "<Unknown>" in
      match
        let prog =
          match Lazy.force find_xargs with
          | Some prog -> prog
          | None -> failwith "Cannot find xargs in PATH" [@coverage off]
        in
        let stdin_reader, stdin_writer = Spawn.safe_pipe () in
        let stdout_reader, stdout_writer = Spawn.safe_pipe () in
        let stderr_reader, stderr_writer = Spawn.safe_pipe () in
        let pid =
          Spawn.spawn
            ~cwd:(Path (Vcs.Repo_root.to_string repo_root))
            ~prog
            ~argv:
              [ "xargs"
              ; "-0"
              ; "grep"
              ; "--no-messages"
              ; "-E"
              ; "-l"
              ; "--binary-files=without-match"
              ; cr_pattern_egrep
              ]
            ~stdin:stdin_reader
            ~stdout:stdout_writer
            ~stderr:stderr_writer
            ()
        in
        Unix.close stdin_reader;
        Unix.close stdout_writer;
        Unix.close stderr_writer;
        let () =
          let stdin_oc = Unix.out_channel_of_descr stdin_writer in
          Out_channel.output_string stdin_oc stdin_text;
          Out_channel.flush stdin_oc;
          Unix.close stdin_writer
        in
        let stdout = read_all_from_fd stdout_reader in
        stdout_ref := stdout;
        let stderr = read_all_from_fd stderr_reader in
        stderr_ref := stderr;
        let pid', process_status = waitpid_non_intr pid in
        assert (pid = pid');
        match process_status with
        | Unix.WEXITED n ->
          (* The exit code of [xargs] is not consistent on all of the platforms
             that we'd like to support. While it always returns [0] in case of
             a match, when the inner [grep] doesn't find a match and returns
             [1], the outer call to [xargs] may return [1] or [123] depending
             on things like the OS. *)
          if
            Int.equal n 0
            || ((Int.equal n 123 || Int.equal n 1 (* On MacOS *))
                && String.is_empty stderr)
          then (
            let files = stdout |> String.split_lines |> List.map ~f:Vcs.Path_in_repo.v in
            `Files files)
          else `Error (`Exited n)
        | Unix.WSIGNALED n -> `Error (`Signaled n) [@coverage off]
        | Unix.WSTOPPED n -> `Error (`Stopped n) [@coverage off]
      with
      | `Files files -> files
      | `Error exit_status ->
        let stdout = !stdout_ref in
        let stderr = !stderr_ref in
        raise
          (Err.E
             (Err.create
                [ Pp.text "Process xargs exited abnormally."
                ; Err.sexp
                    [%sexp
                      { exit_status : Exit_status.t; stdout : string; stderr : string }]
                ]))
      | exception exn ->
        raise
          (Err.E
             (Err.create [ Pp.text "Error while running xargs process."; Err.exn exn ]))
        [@coverage off]
    in
    (match files_to_grep with
     | [] -> []
     | _ :: _ ->
       let crs_ignore_rules =
         let filename = Fsegment.to_string Crs_ignore.filename in
         let crs_ignore_files =
           let files_in_repo =
             if Vcs.Path_in_repo.equal below Vcs.Path_in_repo.root
             then files_below
             else Vcs.ls_files vcs ~repo_root ~below:Vcs.Path_in_repo.root
           in
           List.filter files_in_repo ~f:(fun file ->
             String.equal filename (Fpath.basename (Vcs.Path_in_repo.to_fpath file)))
         in
         List.map crs_ignore_files ~f:(fun path ->
           Crs_ignore.File.load_exn
             ~repo_root
             ~path
             ~invalid_patterns_are_errors:false
             ~emit_github_annotations:false)
         |> Crs_ignore.Rules.create
       in
       List.concat_map files_to_grep ~f:(fun path ->
         if Crs_ignore.Rules.is_file_ignored crs_ignore_rules ~path
         then []
         else (
           let file_contents =
             In_channel.read_all
               (Vcs.Repo_root.append repo_root path |> Absolute_path.to_string)
             |> Vcs.File_contents.create
           in
           parse_file ~path ~file_contents)))
;;

module Private = struct
  module Crs_ignore = Crs_ignore
  module Github_annotation = Github_annotation
  module Invalid_cr_parser = Invalid_cr_parser
  module User_message = User_message
end