ocaml/ocamltest/filecompare.ml

(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
(*                                                                        *)
(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* File comparison tools *)

open Ocamltest_stdlib

type result =
  | Same
  | Different
  | Unexpected_output
  | Error of string * int

type ignore = {bytes: int; lines: int}
type tool =
  |  External of {
                   tool_name : string;
                   tool_flags : string;
                   result_of_exitcode : string -> int -> result
                }
  | Internal of ignore

let cmp_result_of_exitcode commandline = function
  | 0 -> Same
  | 1 -> Different
  | exit_code -> (Error (commandline, exit_code))

let make_cmp_tool ~ignore =
  Internal ignore

let make_comparison_tool ?(result_of_exitcode = cmp_result_of_exitcode)
                         name flags =
  External
    {
      tool_name = name;
      tool_flags = flags;
      result_of_exitcode
    }

let default_comparison_tool = make_cmp_tool ~ignore:{bytes=0;lines=0}

type filetype = Binary | Text

type files = {
  filetype : filetype;
  reference_filename : string;
  output_filename : string;
}

let last_is_cr s =
  let l = String.length s in
  l > 0 && s.[l - 1] = '\r'

(* Returns last character of an input file. Fails for an empty file. *)
let last_char ic =
  seek_in ic (in_channel_length ic - 1);
  input_char ic

(* [line_seq_of_in_channel ~normalise ic first_line] constructs a sequence of
   the lines of [ic] where [first_line] is the already read first line of [ic].
   Strings include the line terminator and CRLF is normalised to LF if
   [normalise] is [true]. The sequence raises [Exit] if normalise is [true] and
   a terminated line is encountered which does not end CRLF. The final line of
   the sequence only includes a terminator if it is present in the file (and a
   terminating CR is never normalised if not strictly followed by LF). *)
let line_seq_of_in_channel ~normalise ic =
  let normalise =
    if normalise then
      fun s ->
        if last_is_cr s then
          String.sub s 0 (String.length s - 1)
        else
          raise Exit
    else
      Fun.id
  in
    let rec read_line last () =
      (* Read the next line to determine if the last line ended with LF *)
      match input_line ic with
      | line ->
          Seq.Cons (normalise last ^ "\n", read_line line)
      | exception End_of_file ->
          (* EOF reached - seek the last character to determine if the final
             line ends in LF *)
          let last =
            if last_char ic = '\n' then
              normalise last ^ "\n"
            else
              last
          in
            Seq.Cons (last, Seq.empty)
    in
      read_line

let compare_text_files ignored_lines file1 file2 =
  Sys.with_input_file ~bin:true file2 @@ fun ic2 ->
    (* Get the first non-dropped line of file2 and determine if could be
       CRLF-normalised (it can't be in any of the dropped lines didn't end
       CRLF. *)
    let (crlf_endings2, line2, reached_end_file2) =
      let rec loop crlf_endings2 k =
        match input_line ic2 with
        | line ->
            let crlf_endings2 = crlf_endings2 && last_is_cr line in
            if k = 0 then
              (crlf_endings2, line, false)
            else
              loop crlf_endings2 (pred k)
        | exception End_of_file ->
            (false, "", true)
      in
        loop true ignored_lines
    in
      Sys.with_input_file ~bin:true file1 @@ fun ic1 ->
        if reached_end_file2 then
          (* We reached the end of file2 while ignoring lines, so only an empty
             file can be identical, as in the binary comparison case. *)
          if in_channel_length ic1 = 0 then
            Same
          else
            Different
        else
          (* file2 has at least one non-ignored line *)
          match input_line ic1 with
          | exception End_of_file -> Different
          | line1 ->
              let crlf_endings1 = last_is_cr line1 in
              (* If both files appear to have CRLF endings, then there's no need
                 to attempt to normalise either. *)
              let seq1 =
                let normalise = crlf_endings1 && not crlf_endings2 in
                line_seq_of_in_channel ~normalise ic1 line1 in
              let seq2 =
                let normalise = crlf_endings2 && not crlf_endings1 in
                line_seq_of_in_channel ~normalise ic2 line2 in
              try
                if Seq.equal seq1 seq2 then
                  Same
                else
                  raise Exit
              with Exit ->
                (* Either the lines weren't equal, or the file which was being
                   normalised suddenly had a line which didn't end CRLF. In this
                   case, the files must differ since only one file is ever being
                   normalised, so the earlier lines differed too. *)
                Different

(* Version of Stdlib.really_input which stops at EOF, rather than raising
   an exception. *)
let really_input_up_to ic =
  let block_size = 8192 in
  let buf = Bytes.create block_size in
  let rec read pos =
    let bytes_read = input ic buf pos (block_size - pos) in
    let new_pos = pos + bytes_read in
    if bytes_read = 0 || new_pos = block_size then
      new_pos
    else
      read new_pos
  in
  let bytes_read = read 0 in
  if bytes_read = block_size then
    buf
  else
    Bytes.sub buf 0 bytes_read

let compare_binary_files bytes_to_ignore file1 file2 =
  Sys.with_input_file ~bin:true file1 @@ fun ic1 ->
  Sys.with_input_file ~bin:true file2 @@ fun ic2 ->
  seek_in ic1 bytes_to_ignore;
  seek_in ic2 bytes_to_ignore;
  let rec compare () =
    let block1 = really_input_up_to ic1 in
    let block2 = really_input_up_to ic2 in
    if block1 = block2 then
      if Bytes.length block1 > 0 then
        compare ()
      else
        Same
    else
      Different
  in
  compare ()

let compare_files ?(tool = default_comparison_tool) files =
  match tool with
  | External {tool_name; tool_flags; result_of_exitcode} ->
      let commandline = String.concat " "
      [
        tool_name;
        tool_flags;
        files.reference_filename;
        files.output_filename
      ] in
      let settings = Run_command.settings_of_commandline
        ~stdout_fname:Filename.null ~stderr_fname:Filename.null commandline in
      let status = Run_command.run settings in
      result_of_exitcode commandline status
  | Internal ignore ->
      match files.filetype with
        | Text ->
            (* bytes_to_ignore is silently ignored for text files *)
            compare_text_files ignore.lines
              files.reference_filename files.output_filename
        | Binary ->
            compare_binary_files ignore.bytes
                                 files.reference_filename files.output_filename

let check_file ?(tool = default_comparison_tool) files =
  if Sys.file_exists files.reference_filename
  then compare_files ~tool:tool files
  else begin
    if Sys.file_is_empty files.output_filename
    then Same
    else Unexpected_output
  end

let diff files =
  let temporary_file = Filename.temp_file "ocamltest" "diff" in
  let diff_commandline =
    Filename.quote_command "diff" ~stdout:temporary_file
      [ "--strip-trailing-cr"; "-u";
        files.reference_filename;
        files.output_filename ]
  in
  let result =
    match Sys.command diff_commandline with
    | 0 -> Ok "Inconsistent LF/CRLF line-endings"
    | 2 -> Stdlib.Error "diff"
    | _ -> Ok (Sys.string_of_file temporary_file)
  in
  Sys.force_remove temporary_file;
  result

let promote {filetype; reference_filename; output_filename} ignore_conf =
  match filetype, ignore_conf with
  | Text, {lines = skip_lines; _} ->
      Sys.with_output_file reference_filename @@ fun reference ->
      Sys.with_input_file output_filename @@ fun output ->
      for _ = 1 to skip_lines do
        try ignore (input_line output) with End_of_file -> ()
      done;
      Sys.copy_chan output reference
  | Binary, {bytes = skip_bytes; _} ->
      Sys.with_output_file ~bin:true reference_filename @@ fun reference ->
      Sys.with_input_file ~bin:true output_filename @@ fun output ->
      seek_in output skip_bytes;
      Sys.copy_chan output reference