Add an opatch package and command-line tool

bin/dune

@@ -0,0 +1,9 @@
+(executable
+ (name opatch)
+ (public_name opatch)
+ (package opatch)
+ (modules opatch version)
+ (libraries unix patch))
+
+(rule
+ (write-file version.ml "let v = \"%{version:opatch}\""))

bin/opatch.ml

@@ -0,0 +1,200 @@
+(* Copyright 2024-2025 Kate Deplaix   *)
+(* Copyright 2025 Samuel Hym, Tarides *)
+(* SPDX-License-Identifier: ISC       *)
+
+let errf fmt = Printf.ksprintf invalid_arg fmt
+let read path = In_channel.(with_open_bin path input_all)
+
+let write ~create path content =
+  let flags =
+    Open_wronly :: Open_binary
+    :: (if create then [ Open_creat; Open_excl ] else [ Open_trunc ])
+  in
+  Out_channel.(
+    with_open_gen flags 0o666 path (fun oc -> output_string oc content))
+
+let remove ~bound path =
+  let bound = Filename.concat bound "" in
+  let rec rec_rmdir p =
+    try
+      let p = Filename.dirname p in
+      if String.starts_with ~prefix:bound p then (
+        Sys.rmdir p;
+        rec_rmdir p)
+    with _ -> ()
+  in
+  Unix.unlink path;
+  (* FIXME? Opam's original code makes extra efforts to unlink on Windows if the
+     first attempt fails (namely it retries after enabling read&write access);
+     is that necessary here? *)
+  rec_rmdir path
+
+let patch ~force ~patchname content diff =
+  (* NOTE: The None case returned by [Patch.patch] is only returned
+       if [diff = Patch.Delete _]. This sub-function is not called in
+       this case so we [assert false] instead. *)
+  match Patch.patch ~cleanly:true content diff with
+  | Some x -> x
+  | None -> assert false (* See NOTE above *)
+  | exception _ when not force ->
+      errf "Patch %S does not apply cleanly" patchname
+  | exception _ -> (
+      match Patch.patch ~cleanly:false content diff with
+      | Some x -> x
+      | None -> assert false (* See NOTE above *)
+      | exception _ -> errf "Patch %S does not apply" patchname)
+
+let apply ~force ~dir ~patchname diffs =
+  let ( / ) = Filename.concat in
+  (* NOTE: It is important to keep this `concat dir ""` to ensure the
+     is_prefix_of below doesn't match another similarly named directory *)
+  let basedir = Unix.realpath dir in
+  let dir = basedir / "" in
+  let in_scope orig_path path =
+    if (not (String.starts_with ~prefix:dir path)) && basedir <> path then
+      errf "Patch tried to escape its scope to reach %S, out of %S (%S)"
+        orig_path dir path
+  in
+  let fullpath path =
+    if not (Filename.is_relative path) then errf "Path %S is not relative" path;
+    dir / path
+  and check_and_mkdir path =
+    let rec aux d =
+      if Sys.file_exists d then in_scope path (Unix.realpath d)
+      else (
+        aux (Filename.dirname d);
+        if Sys.file_exists d then
+          (* Note d could already exists if the path is abc/.. and the recursive
+             call just created abc *)
+          in_scope path (Unix.realpath d)
+        else Sys.mkdir d 0o777)
+    in
+    aux path
+  in
+  let get_src path =
+    let fpath = fullpath path in
+    if not (Sys.file_exists fpath) then errf "File %S doesn't exist" path;
+    let fpath = Unix.realpath fpath in
+    in_scope path fpath;
+    fpath
+  and get_dst ~create path =
+    let fpath = fullpath path in
+    if create then (
+      if Sys.file_exists fpath then errf "File %S exists" path
+      else
+        let d = Filename.dirname fpath in
+        check_and_mkdir d;
+        Unix.realpath d / Filename.basename fpath)
+    else Unix.realpath fpath
+  in
+  let apply diff =
+    match diff.Patch.operation with
+    | Patch.Edit (src, dst) ->
+        let create = src <> dst in
+        let src = get_src src in
+        (* see note about [Edit] operations below *)
+        let content = read src in
+        let content = patch ~force ~patchname (Some content) diff in
+        let dst = get_dst ~create dst in
+        write ~create dst content;
+        if create then remove ~bound:dir src
+    | Patch.Delete file | Patch.Git_ext (file, _, Patch.Delete_only) ->
+        let file = get_src file in
+        remove ~bound:dir file
+    | Patch.Create file | Patch.Git_ext (_, file, Patch.Create_only) ->
+        let content = patch ~force ~patchname None diff in
+        let file = get_dst ~create:true file in
+        write ~create:true file content
+    | Patch.Git_ext (_, _, Patch.Rename_only (src, dst)) ->
+        assert (src <> dst);
+        let src = get_src src in
+        let dst = get_dst ~create:true dst in
+        (* see note about [Rename_only] operations below *)
+        Unix.rename src dst;
+        remove ~bound:dir src
+  in
+  List.iter apply diffs
+
+(* NOTE: About [Edit] operations
+   Opam's original code to apply patches can deal with [Edit] operations where
+   the source doesn't exist but the destination does: in that case it patches
+   the destination directly, mimicking GNU patch. That behaviour is not accepted
+   by [get_src], which errors out on non-existing files. My intuition here is
+   that such a patch is erroneous in the first place. opatch is a different
+   position compared to opam: where opam replaced GNU patch with internal
+   patching code, opatch could depart from GNU patch on such weird cases. *)
+
+(* NOTE: About [Rename_only] operations
+   The way [Rename_only] operations are handled will fail on a patch that moves
+   [x] into [x/y], aka when the original file name is becoming a directory on
+   the fly ([get_dst] will try to create the directory while the original file
+   is still in place). While [git apply] can handle such patches, GNU patch
+   rejects them, so we probably can fail too. *)
+
+let apply ~dir ~strip patch =
+  let patchname, content =
+    let open In_channel in
+    match patch with
+    | None -> ("-", input_all stdin)
+    | Some path -> (path, with_open_bin path input_all)
+  in
+  let diffs = Patch.parse ~p:strip content in
+  apply ~force:false ~dir ~patchname diffs
+
+let parse_argv version argv =
+  let open Arg in
+  let strip = ref 1
+  and dir = ref "."
+  and patches = ref []
+  and verbose = ref false in
+  let add_patch special = function
+    | "-" when special -> patches := None :: !patches
+    | x -> patches := Some x :: !patches
+  and show_version () =
+    Printf.printf "opatch %s\n" version;
+    exit 0
+  in
+  let specs =
+    [
+      ( "-p",
+        Arg.Set_int strip,
+        "<NUM>  Strip <NUM> directories from the diff paths (default: 1)" );
+      ( "-C",
+        Arg.Set_string dir,
+        "<DIR>  Locate files to patch as if launched in <DIR> instead of ." );
+      ( "-v",
+        Arg.Set verbose,
+        " Set verbose mode, where applied patches are logged" );
+      ("-version", Arg.Unit show_version, " Print version and exit");
+      ("--version", Arg.Unit show_version, " Print version and exit");
+      ( "--",
+        Arg.Rest (add_patch false),
+        " Process all remaining arguments as patches" );
+    ]
+  and usage = "opatch [-C <DIR>] [-p <NUM>] [PATCH...]: apply a diff file" in
+  try
+    parse_argv ~current:(ref 0) argv specs (add_patch true) usage;
+    ( !strip,
+      !dir,
+      (match !patches with [] -> [ None ] | p -> List.rev p),
+      !verbose )
+  with
+  | Help msg ->
+      Printf.printf "%s" msg;
+      exit 0
+  | Bad msg ->
+      Printf.eprintf "%s" msg;
+      exit 1
+
+let main version =
+  let strip, dir, patches, verbose = parse_argv version Sys.argv in
+  try
+    List.iter
+      (fun patch ->
+        apply ~dir ~strip patch;
+        if verbose then
+          Printf.printf "%S applied.\n%!" (Option.value ~default:"-" patch))
+      patches
+  with Invalid_argument msg -> Printf.eprintf "Fatal error: %s\n" msg
+
+let () = main Version.v

opatch.opam

@@ -0,0 +1,33 @@
+opam-version: "2.0"
+version: "3.0.0"
+synopsis: "Pure OCaml command-line tool to apply a patch"
+description:
+  "Command-line tool to apply a unified diff or git-diff to a directory"
+maintainer: ["Samuel Hym <samuel@tarides.com>"]
+authors: [
+  "Kate Deplaix <kit-ty-kate@exn.st>" "Samuel Hym <samuel@tarides.com>"
+]
+license: "ISC"
+homepage: "https://github.com/hannesm/patch"
+bug-reports: "https://github.com/hannesm/patch/issues"
+depends: [
+  "dune" {>= "3.0"}
+  "ocaml" {>= "4.14"}
+  "patch" {= version}
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]
+dev-repo: "git+https://github.com/hannesm/patch.git"