Optimize + log + fixes (works now)

Author: kit-ty-kate

src/client/opamInitDefaults.ml

@@ -133,7 +133,6 @@ let recommended_tools () =
 let required_tools ~sandboxing () =
   req_dl_tools () @
   [
-    ["diff"], None, None;
     ["patch"], None, Some patch_filter;
     ["gpatch"], None, Some gpatch_filter;
     ["tar"], None, Some tar_filter;
@@ -148,7 +147,7 @@ let required_tools ~sandboxing () =
 
 let required_packages_for_cygwin =
   [
-    "diffutils";
+    "diffutils"; (* TODO: not used internally anymore but used by many packages *)
     "git"; (* XXX hg & mercurial ? *)
     "make";
     "patch";

src/core/opamFilename.ml

@@ -429,8 +429,12 @@ let link ?(relative=false) ~target ~link =
   OpamSystem.link target (to_string link)
 [@@ocaml.warning "-16"]
 
-let patch ?preprocess ?internal filename dirname =
-  OpamSystem.patch ?preprocess ?internal ~dir:(Dir.to_string dirname) (to_string filename)
+let patch ?preprocess filename dirname =
+  OpamSystem.patch ?preprocess ~dir:(Dir.to_string dirname) (to_string filename)
+
+let internal_patch ~patch_filename diffs dirname =
+  OpamSystem.internal_patch
+    ~patch_filename:(to_string patch_filename) ~dir:(Dir.to_string dirname) diffs
 
 let flock flag ?dontblock file = OpamSystem.flock flag ?dontblock (to_string file)
 

src/core/opamFilename.mli

@@ -259,10 +259,11 @@ val remove_prefix_dir: Dir.t -> Dir.t -> string
 val remove_suffix: Base.t -> t -> string
 
 (** Apply a patch in a directory. If [preprocess] is set to false, there is no
-    CRLF translation. If [internal] is set to true, a pure OCaml version of patch
-    will be used instead of calling the "patch" external command.
+    CRLF translation.
     Returns [None] on success, the process error otherwise *)
-val patch: ?preprocess:bool -> ?internal:bool -> t -> Dir.t -> exn option OpamProcess.job
+val patch: ?preprocess:bool -> t -> Dir.t -> exn option OpamProcess.job
+
+val internal_patch : patch_filename:t -> Patch.t list -> Dir.t -> unit
 
 (** Create an empty file *)
 val touch: t -> unit

src/core/opamSystem.ml

@@ -1635,21 +1635,29 @@ let translate_patch ~dir orig corrected =
 
 exception Internal_patch_error of string
 
-let internal_patch ~dir p =
+let internal_patch ~patch_filename ~dir diffs =
   let fmt = Printf.sprintf in
+  let get_filename ~p full =
+    (* Taken from my code from ocaml-patch *)
+    let rec iter idx = function
+      | 0 -> String.sub full idx (String.length full - idx)
+      | p -> iter (String.index_from full idx '/') (p - 1)
+    in
+    try iter 0 p with Not_found -> failwith "Malformed patch"
+  in
   let get_path file =
     let dir = real_path dir in
-    let file = real_path (Filename.concat dir file) in
+    let file = real_path (Filename.concat dir (get_filename ~p:1 file)) in
     if not (OpamStd.String.is_prefix_of ~from:0 ~full:file dir) then
-      raise (Internal_patch_error (fmt "Patch %S tried to escape its scope." p));
+      raise (Internal_patch_error (fmt "Patch %S tried to escape its scope." patch_filename));
     file
   in
   let patch content diff =
     match Patch.patch content diff with
     | Some x -> x
     | None -> assert false
     | exception _ ->
-      raise (Internal_patch_error (fmt "Patch %S does not apply cleanly." p))
+      raise (Internal_patch_error (fmt "Patch %S does not apply cleanly." patch_filename))
   in
   let apply diff = match diff.Patch.operation with
     | Patch.Edit file ->
@@ -1684,13 +1692,9 @@ let internal_patch ~dir p =
       let dst = get_path dst in
       Unix.rename src dst
   in
-  let content = read p in
-  match Patch.to_diffs content with
-  | diffs -> List.iter apply diffs
-  | exception _ ->
-    raise (Internal_patch_error (fmt "Patch %S failed to parse." p))
+  List.iter apply diffs
 
-let patch ?(preprocess=true) ?(internal=false) ~dir p =
+let patch ?(preprocess=true) ~dir p =
   if not (Sys.file_exists p) then
     (OpamConsole.error "Patch file %S not found." p;
      raise Not_found);
@@ -1706,19 +1710,15 @@ let patch ?(preprocess=true) ?(internal=false) ~dir p =
     if not (OpamConsole.debug ()) then Sys.remove p';
   in
   Fun.protect ~finally:cleanup @@ fun () ->
-  if internal then begin
-    try internal_patch ~dir p; Done None
-    with exn -> Done (Some exn)
-  end else
-    let patch_cmd =
-      match OpamStd.Sys.os () with
-      | OpamStd.Sys.OpenBSD
-      | OpamStd.Sys.FreeBSD -> "gpatch"
-      | _ -> "patch"
-    in
-    make_command ~name:"patch" ~dir patch_cmd ["-p1"; "-i"; p'] @@> fun r ->
-    if OpamProcess.is_success r then Done None
-    else Done (Some (Process_error r))
+  let patch_cmd =
+    match OpamStd.Sys.os () with
+    | OpamStd.Sys.OpenBSD
+    | OpamStd.Sys.FreeBSD -> "gpatch"
+    | _ -> "patch"
+  in
+  make_command ~name:"patch" ~dir patch_cmd ["-p1"; "-i"; p'] @@> fun r ->
+  if OpamProcess.is_success r then Done None
+  else Done (Some (Process_error r))
 
 let register_printer () =
   Printexc.register_printer (function

src/core/opamSystem.mli

@@ -112,6 +112,9 @@ val read: string -> string
     advisory write lock to prevent concurrent reads or writes) *)
 val write: string -> string -> unit
 
+(** [get_files dir] returns the list of files inside the directory [dir]. *)
+val get_files : string -> string list
+
 (** [remove filename] removes [filename]. Works whether [filename] is
     a file or a directory *)
 val remove: string -> unit
@@ -305,10 +308,11 @@ val get_lock_fd: lock -> Unix.file_descr
 (** {2 Misc} *)
 
 (** Apply a patch file in the current directory. If [preprocess] is set to
-    false, there is no CRLF translation. If [internal] is set to true,
-    a pure OCaml version of patch will be used instead of calling the "patch"
-    external command. Returns the error if the patch didn't apply. *)
-val patch: ?preprocess:bool -> ?internal:bool -> dir:string -> string -> exn option OpamProcess.job
+    false, there is no CRLF translation.
+    Returns the error if the patch didn't apply. *)
+val patch: ?preprocess:bool -> dir:string -> string -> exn option OpamProcess.job
+
+val internal_patch : patch_filename:string -> dir:string -> Patch.t list -> unit
 
 (** Returns the end-of-line encoding style for the given file. [None] means that
     either the encoding of line endings is mixed, or the file contains no line

src/repository/opamDarcs.ml

@@ -151,7 +151,7 @@ module VCS = struct
       if OpamSystem.file_is_empty patch_file then
         (finalise (); Done None)
       else
-        Done (Some (OpamFilename.of_string patch_file))
+        Done (Some (OpamFilename.of_string patch_file, Patch.to_diffs ~p:1 (String.concat "\n" r.r_stdout)))
 
   let versioned_files repo_root =
     darcs repo_root [ "show" ; "files" ]

src/repository/opamGit.ml

@@ -205,7 +205,7 @@ module VCS : OpamVCS.VCS = struct
     else if OpamSystem.file_is_empty patch_file then
       (finalise (); Done None)
     else
-      Done (Some (OpamFilename.of_string patch_file))
+      Done (Some (OpamFilename.of_string patch_file, Patch.to_diffs ~p:1 (String.concat "\n" r.r_stdout)))
 
   let is_up_to_date ?subpath repo_root repo_url =
     let rref = remote_ref repo_url in

src/repository/opamHTTP.ml

@@ -57,14 +57,14 @@ module B = struct
       Done (OpamRepositoryBackend.Update_full quarantine)
     else
       OpamProcess.Job.finally finalise @@ fun () ->
-      OpamRepositoryBackend.job_text repo_name "diff"
-        (OpamRepositoryBackend.get_diff
-           (OpamFilename.dirname_dir repo_root)
-           (OpamFilename.basename_dir repo_root)
-           (OpamFilename.basename_dir quarantine))
-      @@| function
-      | None -> OpamRepositoryBackend.Update_empty
-      | Some patch -> OpamRepositoryBackend.Update_patch patch
+      OpamRepositoryBackend.job_text repo_name "diff" @@
+      (OpamRepositoryBackend.get_diff
+         (OpamFilename.dirname_dir repo_root)
+         (OpamFilename.basename_dir repo_root)
+         (OpamFilename.basename_dir quarantine)
+       |> function
+       | None -> Done (OpamRepositoryBackend.Update_empty)
+       | Some patch -> Done (OpamRepositoryBackend.Update_patch patch))
 
   let repo_update_complete _ _ = Done ()
 

src/repository/opamHg.ml

@@ -82,7 +82,7 @@ module VCS = struct
     else if OpamSystem.file_is_empty patch_file then
       (finalise (); Done None)
     else
-      Done (Some (OpamFilename.of_string patch_file))
+      Done (Some (OpamFilename.of_string patch_file, Patch.to_diffs ~p:1 (String.concat "\n" r.r_stdout)))
 
   let is_up_to_date ?subpath:_ repo_root repo_url =
     let mark = mark_from_url repo_url in

src/repository/opamLocal.ml

@@ -180,13 +180,13 @@ module B = struct
       else
         OpamProcess.Job.finally finalise @@ fun () ->
         OpamRepositoryBackend.job_text repo_name "diff" @@
-        OpamRepositoryBackend.get_diff
-          (OpamFilename.dirname_dir repo_root)
-          (OpamFilename.basename_dir repo_root)
-          (OpamFilename.basename_dir quarantine)
-        @@| function
-        | None -> OpamRepositoryBackend.Update_empty
-        | Some p -> OpamRepositoryBackend.Update_patch p
+        (OpamRepositoryBackend.get_diff
+           (OpamFilename.dirname_dir repo_root)
+           (OpamFilename.basename_dir repo_root)
+           (OpamFilename.basename_dir quarantine)
+         |> function
+         | None -> Done (OpamRepositoryBackend.Update_empty)
+         | Some p -> Done (OpamRepositoryBackend.Update_patch p))
 
   let repo_update_complete _ _ = Done ()
 

src/repository/opamRepository.ml

@@ -458,7 +458,7 @@ let validate_repo_update repo repo_root update =
         | "anchors", _ -> Some (S (String.concat "," ta.fingerprints))
         | "quorum", _ -> Some (S (string_of_int ta.quorum))
         | "repo", _ -> Some (S (OpamFilename.Dir.to_string repo_root))
-        | "patch", Update_patch f -> Some (S (OpamFilename.to_string f))
+        | "patch", Update_patch (f, _diff) -> Some (S (OpamFilename.to_string f))
         | "incremental", Update_patch _ -> Some (B true)
         | "incremental", _ -> Some (B false)
         | "dir", Update_full d -> Some (S (OpamFilename.Dir.to_string d))
@@ -493,24 +493,21 @@ let apply_repo_update repo repo_root = function
       (OpamConsole.colorise `green
          (OpamRepositoryName.to_string repo.repo_name));
     Done ()
-  | Update_patch f ->
+  | Update_patch (f, diff) ->
     OpamConsole.msg "[%s] synchronised from %s\n"
       (OpamConsole.colorise `green
          (OpamRepositoryName.to_string repo.repo_name))
       (OpamUrl.to_string repo.repo_url);
     log "%a: applying patch update at %a"
       (slog OpamRepositoryName.to_string) repo.repo_name
       (slog OpamFilename.to_string) f;
-    let preprocess =
-      match repo.repo_url.OpamUrl.backend with
-      | `http | `rsync -> false
-      | _ -> true
-    in
-    (OpamFilename.patch ~preprocess ~internal:true f repo_root @@+ function
-      | Some e ->
-        if not (OpamConsole.debug ()) then OpamFilename.remove f;
-        raise e
-      | None -> OpamFilename.remove f; Done ())
+    (try
+       OpamFilename.internal_patch ~patch_filename:f diff repo_root;
+       OpamFilename.remove f; Done ()
+     with
+     | e ->
+       if not (OpamConsole.debug ()) then OpamFilename.remove f;
+       raise e)
   | Update_empty ->
     OpamConsole.msg "[%s] no changes from %s\n"
       (OpamConsole.colorise `green
@@ -525,7 +522,7 @@ let cleanup_repo_update upd =
   if not (OpamConsole.debug ()) then
     match upd with
     | Update_full d -> OpamFilename.rmdir d
-    | Update_patch f -> OpamFilename.remove f
+    | Update_patch (f, _diff) -> OpamFilename.remove f
     | _ -> ()
 
 let update repo repo_root =