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
|
(* 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
|
