From e18751c2633a67d6a5ba1b3b733f627c23cd8d51 Mon Sep 17 00:00:00 2001 From: Samuel Hym Date: Fri, 10 Oct 2025 14:49:12 +0200 Subject: [PATCH 1/2] Add an `opatch` package and command-line tool This patch reuses a lot of code written by Kate Deplaix for opam --- bin/dune | 9 +++ bin/opatch.ml | 200 ++++++++++++++++++++++++++++++++++++++++++++++++++ opatch.opam | 33 +++++++++ 3 files changed, 242 insertions(+) create mode 100644 bin/dune create mode 100644 bin/opatch.ml create mode 100644 opatch.opam diff --git a/bin/dune b/bin/dune new file mode 100644 index 0000000..0b6d25d --- /dev/null +++ b/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}\"")) diff --git a/bin/opatch.ml b/bin/opatch.ml new file mode 100644 index 0000000..83bc749 --- /dev/null +++ b/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, + " Strip directories from the diff paths (default: 1)" ); + ( "-C", + Arg.Set_string dir, + " Locate files to patch as if launched in 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 ] [-p ] [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 diff --git a/opatch.opam b/opatch.opam new file mode 100644 index 0000000..b51ac22 --- /dev/null +++ b/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 "] +authors: [ + "Kate Deplaix " "Samuel Hym " +] +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" From 3728de5445a6602d9688cf8cfdea755e724d7789 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 15 Oct 2025 15:10:38 +0200 Subject: [PATCH 2/2] Update opatch.opam --- opatch.opam | 1 - 1 file changed, 1 deletion(-) diff --git a/opatch.opam b/opatch.opam index b51ac22..f006376 100644 --- a/opatch.opam +++ b/opatch.opam @@ -1,5 +1,4 @@ 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"