forked from ocaml/opam
-
Notifications
You must be signed in to change notification settings - Fork 4
/
opamFilename.ml
456 lines (358 loc) · 12.5 KB
/
opamFilename.ml
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
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
(**************************************************************************)
(* *)
(* Copyright 2012-2013 OCamlPro *)
(* Copyright 2012 INRIA *)
(* *)
(* All rights reserved.This file is distributed under the terms of the *)
(* GNU Lesser General Public License version 3.0 with linking *)
(* exception. *)
(* *)
(* OPAM is distributed in the hope that it will be useful, but WITHOUT *)
(* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *)
(* or FITNESS FOR A PARTICULAR PURPOSE.See the GNU General Public *)
(* License for more details. *)
(* *)
(**************************************************************************)
module Base = OpamMisc.Base
let log fmt = OpamGlobals.log "FILENAME" fmt
let slog = OpamGlobals.slog
module Dir = struct
include OpamMisc.Base
let of_string dirname =
if (String.length dirname >= 1 && dirname.[0] = '~') then
let home = OpamMisc.getenv "HOME" in
match dirname with
| "~" -> home
| _ ->
let prefix = Filename.concat "~" "" in
let suffix = OpamMisc.remove_prefix ~prefix dirname in
Filename.concat home suffix
else if Filename.is_relative dirname then
OpamSystem.real_path dirname
else
dirname
let to_string dirname = dirname
end
let raw_dir s = s
let with_tmp_dir fn =
OpamSystem.with_tmp_dir (fun dir -> fn (Dir.of_string dir))
let rmdir dirname =
log "rmdir %a" (slog Dir.to_string) dirname;
OpamSystem.remove (Dir.to_string dirname)
let cwd () =
Dir.of_string (Unix.getcwd ())
let mkdir dirname =
OpamSystem.mkdir (Dir.to_string dirname)
let cleandir dirname =
log "cleandir %a" (slog Dir.to_string) dirname;
OpamSystem.remove (Dir.to_string dirname);
mkdir dirname
let rec_dirs d =
let fs = OpamSystem.rec_dirs (Dir.to_string d) in
List.rev (List.rev_map Dir.of_string fs)
let dirs d =
let fs = OpamSystem.dirs (Dir.to_string d) in
List.rev (List.rev_map Dir.of_string fs)
let dir_is_empty d =
OpamSystem.dir_is_empty (Dir.to_string d)
let in_dir dirname fn =
if Sys.file_exists dirname then
OpamSystem.in_dir dirname fn
else
OpamSystem.internal_error "Cannot CD to %s: the directory does not exist!" dirname
let exec dirname ?env ?name ?metadata ?keep_going cmds =
let env = match env with
| None -> None
| Some l -> Some (Array.of_list (List.rev_map (fun (k,v) -> k^"="^v) l)) in
in_dir dirname
(fun () -> OpamSystem.commands ?env ?name ?metadata ?keep_going cmds)
let move_dir ~src ~dst =
OpamSystem.command [ "mv"; Dir.to_string src; Dir.to_string dst ]
let exists_dir dirname =
let f = Dir.to_string dirname in
Sys.file_exists f && Sys.is_directory f
let copy_dir ~src ~dst =
if exists_dir dst then
OpamSystem.internal_error
"Cannot create %s as the directory already exists." (Dir.to_string dst);
OpamSystem.command [ "cp"; "-pPR"; Dir.to_string src; Dir.to_string dst ]
let link_dir ~src ~dst =
if exists_dir dst then
OpamSystem.internal_error "Cannot link: %s already exists." (Dir.to_string dst)
else (
mkdir (Filename.dirname dst);
OpamSystem.link (Dir.to_string src) (Dir.to_string dst)
)
let basename_dir dirname =
Base.of_string (Filename.basename (Dir.to_string dirname))
let dirname_dir dirname =
Dir.to_string (Filename.dirname (Dir.of_string dirname))
let to_list_dir dir =
let base d = Dir.of_string (Filename.basename (Dir.to_string d)) in
let rec aux acc dir =
let d = dirname_dir dir in
if d <> dir then aux (base dir :: acc) d
else base dir :: acc in
aux [] dir
let (/) d1 s2 =
let s1 = Dir.to_string d1 in
raw_dir (Filename.concat s1 s2)
type t = {
dirname: Dir.t;
basename: Base.t;
}
let create dirname basename =
let b1 = Filename.dirname (Base.to_string basename) in
let b2 = Base.of_string (Filename.basename (Base.to_string basename)) in
if basename = b2 then
{ dirname; basename }
else
{ dirname = dirname / b1; basename = b2 }
let of_basename basename =
let dirname = Dir.of_string "." in
{ dirname; basename }
let raw str =
let dirname = raw_dir (Filename.dirname str) in
let basename = Base.of_string (Filename.basename str) in
create dirname basename
let to_string t =
Filename.concat (Dir.to_string t.dirname) (Base.to_string t.basename)
let digest t =
Digest.to_hex (Digest.file (to_string t))
let touch t =
OpamSystem.write (to_string t) ""
let chmod t p =
Unix.chmod (to_string t) p
let of_string s =
let dirname = Filename.dirname s in
let basename = Filename.basename s in
{
dirname = Dir.of_string dirname;
basename = Base.of_string basename;
}
let dirname t = t.dirname
let basename t = t.basename
let read filename =
OpamSystem.read (to_string filename)
let open_in filename =
open_in (to_string filename)
let write filename raw =
OpamSystem.write (to_string filename) raw
let remove filename =
OpamSystem.remove_file (to_string filename)
let exists filename =
let f = to_string filename in
Sys.file_exists f && not (Sys.is_directory f)
let with_contents fn filename =
fn (read filename)
let check_suffix filename s =
Filename.check_suffix (to_string filename) s
let add_extension filename suffix =
of_string ((to_string filename) ^ "." ^ suffix)
let chop_extension filename =
of_string (Filename.chop_extension (to_string filename))
let rec_files d =
let fs = OpamSystem.rec_files (Dir.to_string d) in
List.rev_map of_string fs
let files d =
let fs = OpamSystem.files (Dir.to_string d) in
List.rev_map of_string fs
let copy ~src ~dst =
if src <> dst then OpamSystem.copy (to_string src) (to_string dst)
let install ?exec ~src ~dst () =
if src <> dst then OpamSystem.install ?exec (to_string src) (to_string dst)
let move ~src ~dst =
if src <> dst then OpamSystem.command [ "mv"; to_string src; to_string dst ]
let link ~src ~dst =
if src <> dst then OpamSystem.link (to_string src) (to_string dst)
let readlink src =
if exists src then
try of_string (Unix.readlink (to_string src))
with Unix.Unix_error _ -> src
else
OpamSystem.internal_error "%s does not exist." (to_string src)
let is_symlink src =
try
let s = Unix.lstat (to_string src) in
s.Unix.st_kind = Unix.S_LNK
with Unix.Unix_error _ ->
OpamSystem.internal_error "%s does not exist." (to_string src)
let is_exec file =
try OpamSystem.is_exec (to_string file)
with Unix.Unix_error _ ->
OpamSystem.internal_error "%s does not exist." (to_string file)
let starts_with dirname filename =
OpamMisc.starts_with ~prefix:(Dir.to_string dirname) (to_string filename)
let remove_prefix prefix filename =
let prefix =
let str = Dir.to_string prefix in
if str = "" then "" else Filename.concat str "" in
let filename = to_string filename in
OpamMisc.remove_prefix ~prefix filename
let process_in ?root fn src dst =
let basename = match root with
| None -> basename src
| Some r ->
if starts_with r src then remove_prefix r src
else OpamSystem.internal_error "%s is not a prefix of %s"
(Dir.to_string r) (to_string src) in
let dst = Filename.concat (Dir.to_string dst) basename in
fn ~src ~dst:(of_string dst)
let copy_in ?root = process_in ?root copy
let link_in = process_in link
let extract filename dirname =
OpamSystem.extract (to_string filename) (Dir.to_string dirname)
let extract_in filename dirname =
OpamSystem.extract_in (to_string filename) (Dir.to_string dirname)
type generic_file =
| D of Dir.t
| F of t
let extract_generic_file filename dirname =
match filename with
| F f ->
log "extracting %a to %a"
(slog to_string) f
(slog Dir.to_string) dirname;
extract f dirname
| D d ->
if d <> dirname then (
log "copying %a to %a"
(slog Dir.to_string) d
(slog Dir.to_string) dirname;
copy_dir ~src:d ~dst:dirname
)
let ends_with suffix filename =
OpamMisc.ends_with ~suffix (to_string filename)
let remove_suffix suffix filename =
let suffix = Base.to_string suffix in
let filename = to_string filename in
OpamMisc.remove_suffix ~suffix filename
let download ~overwrite ?compress filename dirname =
mkdir dirname;
let dst = to_string (create dirname (basename filename)) in
let file = OpamSystem.download ~overwrite ?compress
~filename:(to_string filename) ~dst in
of_string file
let download_as ~overwrite ?(compress=false) filename dest =
mkdir (dirname dest);
let file = OpamSystem.download ~overwrite ~compress
~filename:(to_string filename) ~dst:(to_string dest) in
assert (file = to_string dest);
()
let download_iter ~overwrite filenames dirname =
let rec aux = function
| [] ->
let filenames = List.map to_string filenames in
OpamSystem.internal_error "Cannot download %s." (OpamMisc.pretty_list filenames)
| h::t ->
try download ~overwrite h dirname
with e -> OpamMisc.fatal e; aux t in
aux filenames
let patch filename dirname =
in_dir dirname (fun () -> OpamSystem.patch (to_string filename))
let with_flock ?read file f x =
let lock = OpamSystem.flock ?read (to_string file) in
try
let r = f x in
OpamSystem.funlock lock;
r
with e ->
OpamSystem.funlock lock;
raise e
let checksum f =
if exists f then
[digest f]
else
[]
let checksum_dir d =
if exists_dir d then
List.map digest (rec_files d)
else
[]
let prettify_dir d =
OpamMisc.prettify_path (Dir.to_string d)
let prettify s =
OpamMisc.prettify_path (to_string s)
let to_json x = `String (to_string x)
module O = struct
type tmp = t
type t = tmp
let compare = compare
let to_string = to_string
let to_json = to_json
end
module Map = OpamMisc.Map.Make(O)
module Set = OpamMisc.Set.Make(O)
let copy_files ~src ~dst =
let files = rec_files src in
List.iter (fun file ->
if not !OpamGlobals.do_not_copy_files then
let base = remove_prefix src file in
let dst_file = create dst (Base.of_string base) in
if exists dst_file then
OpamGlobals.note
"%s is replaced by the packager's overlay files. \
Set OPAMDONOTCOPYFILES to a non-empty value not to \
copy the overlay files."
(to_string dst_file);
OpamGlobals.msg "Copying %s to %s/\n" (prettify file) (prettify_dir dst);
copy ~src:file ~dst:dst_file
) files
module OP = struct
let (/) = (/)
let (//) d1 s2 =
let d = Filename.dirname s2 in
let b = Filename.basename s2 in
if d <> "." then
create (d1 / d) (Base.of_string b)
else
create d1 (Base.of_string s2)
end
module Attribute = struct
type t = {
base: Base.t;
md5 : string;
perm: int option;
}
let base t = t.base
let md5 t = t.md5
let perm t = t.perm
let create base md5 perm =
{ base; md5; perm=Some perm }
let to_string_list t =
let perm = match t.perm with
| None -> []
| Some p -> [Printf.sprintf "0o%o" p] in
Base.to_string t.base :: t.md5 :: perm
let of_string_list = function
| [base; md5] -> { base=Base.of_string base; md5; perm=None }
| [base;md5; perm] -> { base=Base.of_string base; md5;
perm=Some (int_of_string perm) }
| k -> OpamSystem.internal_error
"remote_file: '%s' is not a valid line."
(String.concat " " k)
let to_string t = String.concat " " (to_string_list t)
let of_string s = of_string_list (OpamMisc.split s ' ')
let to_json x =
`O ([ ("base" , Base.to_json x.base);
("md5" , `String x.md5)]
@ match x. perm with
| None -> []
| Some p -> ["perm", `String (string_of_int p)])
module O = struct
type tmp = t
type t = tmp
let to_string = to_string
let compare = compare
let to_json = to_json
end
module Set = OpamMisc.Set.Make(O)
module Map = OpamMisc.Map.Make(O)
end
let to_attribute root file =
let basename = Base.of_string (remove_prefix root file) in
let perm =
let s = Unix.stat (to_string file) in
s.Unix.st_perm in
let digest = digest file in
Attribute.create basename digest perm