Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 647 lines (578 sloc) 20.289 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (* depends *)
19 module Format = BaseFormat
20 module List = BaseList
21 module String = BaseString
22
23 (* -- *)
24
25 let default_rights = 0o600
26
27 let path_sep =
28 if Base.is_windows then "\\"
29 else "/"
30
31 let exists = Sys.file_exists
32
33 let extension name =
34 let l = String.length name in
35 let rec search_dot i =
36 if i < 0 then ""
37 else if String.unsafe_get name i = '.' then String.sub name (i + 1) (l - i - 1)
38 else search_dot (pred i) in
39 search_dot (pred l)
40
41 let chop_extension t = try Filename.chop_extension t with Invalid_argument _ -> t
42
43 let module_name t = String.capitalize (chop_extension (Filename.basename t))
44
45 (** OCaml-specific is_relative for -I **)
46 let is_relative_include_path dir =
47 dir = "" || (dir.[0] <> '+' && Filename.is_relative dir)
48
49 let subst sl =
50 fun s ->
51 let ext = extension s in
52 let chop = chop_extension s in
53 match List.assoc_opt ext sl with
54 | Some "" -> chop
55 | Some e2 -> chop^"."^e2
56 | None -> s
57
58 let from_pattern pat =
59 fun s ->
60 let e = extension s in
61 let f = chop_extension s in
62 let _f = String.replace f "." "_" in
63 let b = Filename.basename f in
64 let _b = String.replace b "." "_" in
65 let d = Filename.dirname s in
66 let fold acc (pat, rep) = String.replace acc pat rep in
67 List.fold_left fold pat [("%b", b); ("%_b", _b); ("%d", d); ("%e", e); ("%_", _f); ("%", f)]
68
69
70 let content f =
71 let stat = Unix.stat f in
72 match stat.Unix.st_kind with
73 | Unix.S_DIR -> failwith (Printf.sprintf "Base.File.content: %S is a directory" f)
74 | Unix.S_LNK -> assert false (* stat goes through symbolic links *)
75 | Unix.S_CHR (* Character device *)
76 | Unix.S_BLK (* Block device *)
77 | Unix.S_FIFO (* Named pipe *)
78 | Unix.S_SOCK (* Socket *) ->
79 (* for these kind of files, the size information is meaningless *)
80 let ic = open_in_bin f in
81 let len = 10000 in
82 let str = String.create len in
83 let buf = Buffer.create 10000 in
84 let rec aux () =
85 let read = input ic str 0 len in
86 if read <> 0 then (
87 Buffer.add_substring buf str 0 read;
88 aux ()
89 ) in
90 aux ();
91 close_in ic;
92 Buffer.contents buf
93 | Unix.S_REG (* Regular file *) ->
94 let size = stat.Unix.st_size in
95 assert (size <= Sys.max_string_length) ;
96 let ic = open_in_bin f
97 and buf = String.create size in
98 really_input ic buf 0 size ;
99 close_in ic ;
100 buf
101
102 let is_relative = Filename.is_relative
103
104 let normalize_relative_path path =
105 (*Get rid of absolute paths*)
106 if not (is_relative path) then None
107 else
108 let split = Str.split (Str.regexp path_sep) path in
109 let rec aux ~acc = function
110 | [] -> Some acc
111 | "."::t -> aux ~acc t
112 | ".."::t ->
113 begin
114 match acc with
115 | [] -> None (*Can't climb any higher*)
116 | _::t' -> aux ~acc:t' t
117 end
118 | ""::t-> aux ~acc t
119 | h::t -> aux ~acc:(h::acc) t
120 in
121 match aux ~acc:[] split with
122 | None -> None
123 | Some result -> Some (String.concat "/" (List.rev result))
124
125 let explicit_path fpath pre =
126 let path =
127 if not(Filename.is_relative fpath) then
128 fpath
129 else
130 match pre with
131 | None -> fpath
132 | Some "./" -> Filename.concat (Sys.getcwd ()) fpath
133 | Some pr ->
134 if (Filename.is_relative pr) then
135 Filename.concat (Sys.getcwd ()) (Filename.concat pr fpath)
136 else
137 Filename.concat pr fpath
138
139 in
140 let split = (Str.split (Str.regexp "/") path) in
141 let revsplit = List.rev split in
142 let rec parcours torm acc lst =
143 match lst with
144 | [] -> acc
145 | x::y ->
146 if x = "." || x = "" then
147 parcours torm acc y
148 else
149 if x = ".." then
150 parcours (torm + 1) acc y
151 else
152 if torm > 0 then
153 parcours (torm -1) acc y
154 else
155 parcours torm (x::acc) y
156 in
157 let res = (parcours 0 [] revsplit) in
158 String.concat "/" (""::res )
159
160 let clean_beginning_path path =
161 let split = (Str.split (Str.regexp "/") path) in
162 let rec parcours lock acc lst =
163 match lock,lst with
164 | _,[] -> acc
165 | false,(x::y) ->
166 if x = "." || x = "" || x = ".." then
167 parcours false acc y
168 else
169 parcours true (x::acc) y
170 | true,(x::y) ->
171 if x = "." || x = ".." then
172 failwith ("\""^path^"\" : End of path is not clean")
173 else
174 if x = "" then
175 parcours true acc y
176 else
177 parcours true (x::acc) y
178 in
179 String.concat "/" (""::(List.rev (parcours false [] split)))
180
181
182 let last_modification f =
183 let t = (Unix.stat f).Unix.st_mtime in
184 Time.of_unix_time t
185
186 (* files like /proc/cpuinfo have a 0kb size *)
187 (* this function is used for logs, /proc/*, etc.,
188 where we really want to limit reading to max_size *)
189 (* TODO : progressive log allocation *)
190 (* FIXME: if the input stream is shorter than max_size,
191 there can be garbage at the end of the buffer *)
192 let virtual_content max_size f =
193 assert (max_size <= Sys.max_string_length) ;
194 let ic = open_in f
195 and buf = String.create max_size in
196 (try
197 really_input ic buf 0 max_size ;
198 with End_of_file -> ()) ;
199 close_in ic ;
200 buf
201
202 (**FIXME : Catch another exception? *)
203 let content_opt f =
204 try Some (content f)
205 with Unix.Unix_error(_, ("opendir"|"stat"), _) -> None
206
207 (* FIXME: the file won't be closed if f raised an exception *)
208 let lines_fold f acc name =
209 let ic = open_in name in
210 let rec aux acc = match try Some (Pervasives.input_line ic) with End_of_file -> None with
211 | Some line -> aux (f acc line)
212 | None -> acc
213 in
214 let acc = aux acc in
215 let _ = close_in ic in
216 acc
217
218 (* FIXME: the file won't be closed if f raised an exception *)
219 let lines_foldi f acc name =
220 let ic = open_in name in
221 let rec aux nr acc = match try Some (Pervasives.input_line ic) with End_of_file -> None with
222 | Some line -> aux (nr + 1) (f acc line nr)
223 | None -> acc
224 in
225 let acc = aux 1 acc in
226 let _ = close_in ic in
227 acc
228
229 let lines_foldi_offset f acc name =
230 let acc, _ =
231 lines_foldi (fun (acc,offset) line i ->
232 let acc = f acc line i offset in
233 (acc, offset + String.length line)) (acc,0) name in
234 acc
235
236 let lines_rev_mapi f name =
237 let aux acc line i = (f line i)::acc in
238 lines_foldi aux [] name
239
240 let lines_mapi f name =
241 List.rev (lines_rev_mapi f name)
242
243 let lines_map_and_fold_i f acc name =
244 let aux (acc_fold, acc_map) line i =
245 let acc_fold, elt_map = f acc_fold line i in
246 acc_fold, elt_map::acc_map
247 in
248 let acc_fold, acc_map = lines_foldi aux (acc, []) name in
249 acc_fold, (List.rev acc_map)
250
251 (* FIXME: workaround for Filename.concat *)
252 let concat dir f =
253 Filename.concat dir (
254 match Sys.os_type with
255 | "Unix"| "Cygwin" ->
256 let lf = String.length f in
257 if lf > 0 && f.[0] = '/' then String.sub f 1 (pred lf) else f
258
259 | "Win32" | "Windows" ->
260 let lf = String.length f in
261 if lf > 1 && f.[1] = ':' then String.sub f 2 (pred lf) else f
262
263 | _ -> failwith ("Base.File.concat : unknown system "^Sys.os_type)
264 )
265
266 let output f s =
267 try
268 let oc = open_out f in
269 output_string oc s ;
270 close_out oc ;
271 true
272 with Sys_error _ -> false
273
274 let oc_output filename printer data =
275 try
276 let oc = open_out filename in
277 printer oc data ;
278 close_out oc ;
279 None
280 with
281 | Sys_error msg -> Some msg
282
283 let pp_output filename printer data =
284 let printer oc data =
285 let fmt = Format.formatter_of_out_channel oc in
286 printer fmt data ;
287 Format.pp_print_flush fmt ()
288 in
289 oc_output filename printer data
290
291 (* Create a temporary directory with a random unique name *)
292 (* ex: mkdtemp "/tmp" *)
293 let rec mkdtemp path =
294 try
295 (* N.B: on Mac, the path_sep may be duplicated,
296 especially if path = Filename.temp_dir_name *)
297 let dirname = path ^ path_sep ^ String.random 10 in
298 Unix.mkdir dirname 0o700;
299 dirname
300 with
301 Unix.Unix_error (Unix.EEXIST, _, _) -> mkdtemp path
302
303 (* doesn't remove symlinks everywhere in the path, it just guarantees that
304 * the file pointed to by the returned path is not a symlink *)
305 let rec remove_symlinks path =
306 (* BEWARE: if you make loops with symlinks, then this function will loop *)
307 let path' =
308 try
309 let link = Unix.readlink path in
310 Filename.concat (Filename.dirname path) link
311 with Unix.Unix_error _ | Invalid_argument _ -> path in
312 if path' = path
313 then path'
314 else remove_symlinks path'
315
316 (** crée tous les répertoires nécessaires pour accéder à path *)
317 let check_create_path ?(rights=0o755) path =
318 let path =
319 if Filename.basename path = "." then path
320 else path ^ "/"
321 in
322 let path = remove_symlinks path in
323 let rec aux1 = function
324 [] -> aux1 [Filename.dirname path]
325 | (hd::tl) as l ->
326 let d = Filename.dirname hd in
327 if d <> hd then aux1 (d::l)
328 else tl (* car hd = C:\ ou / *) in
329 let mkdir d = try Unix.mkdir d rights ; true with Unix.Unix_error _ -> false in
330 List.fold_left (
331 fun acc x ->
332 acc && (Sys.file_exists x or mkdir (remove_symlinks x))
333 ) true (aux1 [])
334
335 (** hopefully, this is the ultimate and portable version of cp *)
336 let copy ?(force=false) src tgt =
337 if not (Sys.file_exists src) then 1
338 else
339 if src = tgt then 0
340 (* FIXME if you have symbolic links, this check is not enough
341 * and if [force] is set, then you will end up deleting your file *)
342 else
343 begin
344 if force && (Sys.file_exists tgt) then Sys.remove tgt;
345 if Sys.file_exists tgt then 1
346 else
347 let dir = Filename.dirname tgt in
348 if check_create_path dir then
349 let command = (if Base.is_windows then Format.sprintf "copy \"%s\" \"%s\"" else Format.sprintf "cp \"%s\" \"%s\"") src tgt in
350 Sys.command command
351 else 1
352 end
353
354 (** hopefully, this is the ultimate and portable version of mv *)
355 let mv ?(force=false) src tgt =
356 if not (Sys.file_exists src) then 1
357 else
358 if src = tgt then 0
359 (* FIXME if you have symbolic links, this check is not enough
360 * and if [force] is set, then you will end up deleting your file *)
361 else
362 begin
363 if force && (Sys.file_exists tgt) then Sys.remove tgt;
364 if Sys.file_exists tgt then 1
365 else
366 let dir = Filename.dirname tgt in
367 if check_create_path dir then
368 let command = (if Base.is_windows then Format.sprintf "rename \"%s\" \"%s\"" else Format.sprintf "mv \"%s\" \"%s\"") src tgt in
369 Sys.command command
370 else 1
371 end
372
373 exception NoMLstateDir
374
375 (* In case of failure, mlstate_dir is in the same place as the program.
376 Make this lazy? *)
377 let mlstate_dir = lazy (
378 try
379 let path = match Sys.os_type with
380 | "Unix"
381 | "Cygwin" -> Filename.concat (Sys.getenv "HOME") ".mlstate/"
382 | "Win32" -> Filename.concat (Sys.getenv "USERPROFILE") "AppData\\Local\\MLstate\\"
383 | s -> failwith (Printf.sprintf "Base.ml_state_dir : this platform (%s) is yet unsupported" s) in
384 (* assert (check_create_path ~rights:0o700 path) ; *)
385 if check_create_path ~rights:0o700 path then path
386 else ".mlstate/" (* raise NoMLstateDir *)
387 with Not_found -> ".mlstate/"
388 )
389
390 let mlstatelibs =
391 lazy (
392 try
393 let path = Sys.getenv "MLSTATELIBS" in
394 PathTransform.string_to_mysys path
395 with Not_found -> failwith "Environnement variable MLSTATELIBS not defined." )
396
397
398 let is_regular file =
399 (* Jounral.Interface.jlog (Printf.sprintf "file=%s" file) ; *)
400 try
401 let st = Unix.stat file in
402 st.Unix.st_kind = Unix.S_REG
403 with Unix.Unix_error _ -> false
404
405 let is_directory path =
406 (* Jounral.Interface.jlog (Printf.sprintf "file=%s" file) ; *)
407 try
408 let st = Unix.stat path in
409 st.Unix.st_kind = Unix.S_DIR
410 with Unix.Unix_error _ -> false
411
412 let mimetype ?magic_file file =
413 let database =
414 match magic_file with
415 | Some s -> File_mimetype.get_mimetype_database s
416 | None -> File_mimetype.mimetype_database mlstatelibs in
417 try
418 File_mimetype.get_mimetype file database
419 with File_mimetype.MimeType_NotFound -> (
420 (* Journal.Interface.warning (Printf.sprintf "\"%s\" : error, don't find the mimetype !! replace by default, i.e 'text/plain'\n" file); *)
421 "text/plain"
422 )
423
424
425 let rec iter_dir_rec ?(showdir=false) f d =
426 let dh = Unix.opendir d in
427 try
428 while true do
429 let x = Unix.readdir dh in
430 let path = Filename.concat d x in
431 let st = Unix.stat path in
432 match st.Unix.st_kind with
433 | Unix.S_REG -> f ~name:x ~path
434 | Unix.S_DIR ->
435 if showdir && x="." then f ~name:x ~path:d
436 else if x="." or x=".." then ()
437 else iter_dir_rec f path ~showdir
438 | _ -> ()
439 done
440 with
441 End_of_file -> Unix.closedir dh
442
443 (* FIXME: tester les iter/fold rec ou non *)
444 let fold_dir_rec f i d =
445 let rec aux d dh r =
446 try
447 let x = Unix.readdir dh in
448 let path = Filename.concat d x in
449 let st = Unix.stat path in
450 match st.Unix.st_kind with
451 | Unix.S_REG -> aux d dh (f r ~name:x ~path)
452 | Unix.S_DIR ->
453 if x="." or x=".." then aux d dh r
454 else aux d dh (aux path (Unix.opendir path) r)
455 | _ -> aux d dh r
456 with
457 End_of_file -> Unix.closedir dh ; r
458 | Unix.Unix_error _ -> aux d dh r
459 in
460 aux d (Unix.opendir d) i
461
462 let rec remove_rec file =
463 let sto = try Some (Unix.stat file) with Unix.Unix_error _ -> None in
464 match sto with
465 | None -> ()
466 | Some st ->
467 match st.Unix.st_kind with
468 | Unix.S_REG
469 | Unix.S_LNK
470 | Unix.S_FIFO
471 | Unix.S_SOCK ->
472 Unix.unlink file
473 | Unix.S_CHR
474 | Unix.S_BLK ->
475 Base.invalid_argf "File.remove_rec: %s" file
476 | Unix.S_DIR ->
477 let dir = file in
478 let handle = Unix.opendir dir in
479 try
480 while true do
481 match Unix.readdir handle with
482 | "." | ".." -> ()
483 | file ->
484 let path = Filename.concat dir file in
485 remove_rec path
486 done;
487 with End_of_file ->
488 Unix.closedir handle;
489 Unix.rmdir dir
490
491 (** itère une fonction sur un répertoire / non récursif, ignore les répertoires ! *)
492 let iter_dir f d =
493 let dh = Unix.opendir d in
494 try
495 while true do
496 let x = Unix.readdir dh in
497 let y = concat d x in
498 if is_regular y then f ~name:x ~path:y
499 done
500 with
501 End_of_file -> Unix.closedir dh
502
503 (** itère une fonction sur un répertoire / non récursif, ignore les répertoires ! *)
504 (* FIXME: remplacer ici . par getcwd ? *)
505 let fold_dir f i d =
506 let dh = Unix.opendir d in
507 let rec aux r =
508 try
509 let x = Unix.readdir dh in
510 let y = concat d x in
511 aux (if is_regular y then f r ~name:x ~path:y else r)
512 with
513 End_of_file -> Unix.closedir dh ; r
514 in
515 aux i
516
517 (* FIXME: optimiser si le dir n'a pas changé (lors d'une saisie lettre par lettre)... *)
518 (* FIXME: Glib.Convert.filename_to_utf8 ! *)
519 let completion path =
520 let dir = Filename.dirname path (* FIXME: tenir compte de ~ *)
521 and base = Filename.basename path in
522 let f_comp acc ~name ~path =
523 if String.is_substring base name 0 then (if dir="." then name else path)::acc
524 else acc in
525 fold_dir f_comp [] (if dir = "." then Unix.getcwd () else dir)
526
527 let backup_path name =
528 let path = concat (Lazy.force mlstate_dir) (name ^ path_sep) in
529 (* Journal.Interface.jlog (Printf.sprintf "backup_path = %s" path) ; *)
530 if check_create_path path then Some path
531 else (
532 (* Journal.Interface.warning "backup path could not be created. NO automatic backups!" ; *)
533 None
534 )
535
536
537 let append_or_create name =
538 let f = if Sys.file_exists name then
539 open_out_gen [Open_wronly; Open_binary; Open_append] default_rights
540 else
541 open_out_gen [Open_wronly; Open_binary; Open_creat; Open_trunc] default_rights
542 in f name
543
544 let channel_contents chan =
545 let rec aux b = (* FIXME: recursion might stack overflow *)
546 try aux (FBuffer.add b (input_line chan ^ "\n"))
547 with End_of_file -> b
548 in
549 FBuffer.contents (aux (FBuffer.create ~name:"channel_contents" 256))
550
551 (** highly non portable (especially the cmd itself)
552 please do not abuse or else you will be responsible of the Windows port :p *)
553 type filter = { process: string -> string;
554 close : unit -> unit }
555
556 let new_filter cmd =
557 let (inchan,outchan) as chans = Unix.open_process cmd in
558 let process s =
559 Pervasives.output_string outchan s;
560 Pervasives.output_char outchan '\n';
561 Pervasives.flush outchan;
562 Pervasives.input_line inchan
563 and close () =
564 ignore (Unix.close_process chans)
565 in
566 { process = process;
567 close = close }
568 (** examples:
569 let sed = new_filter "sed -u 's/foo/bar/'";;
570 List.map sed.process ["bar";"foo";"foobar";"foofoo"] returns ["bar";"bar";"barbar";"barfoo"]
571 sed.close() when the filter is not needed anymore *)
572
573 exception Process_error of string
574 let process_output cmd =
575 let chan = Unix.open_process_in cmd in
576 let lines = channel_contents chan in
577 match Unix.close_process_in chan with
578 | Unix.WEXITED 0 -> lines
579 | Unix.WEXITED i -> raise (Process_error (Printf.sprintf "command failed with code %d" i))
580 | Unix.WSIGNALED i -> raise (Process_error (Printf.sprintf "command killed by signal %d" i))
581 | Unix.WSTOPPED i -> raise (Process_error (Printf.sprintf "command stopped by signal %d" i))
582
583 let simplify_path =
584 let rec aux void = function
585 | [] -> []
586 | ".."::l -> ".."::(aux false l)
587 | "."::l
588 | _::".."::l ->
589 begin match l with
590 | _::_ -> aux void l
591 | _ when not void -> aux void l
592 | [] -> ["."]
593 end
594 | d::l ->
595 let l = aux false l in
596 begin match l with
597 | ".."::_ -> aux void (d::l)
598 | _ -> d::l
599 end
600 in
601 fun path ->
602 let len = String.length path in
603 if len <= 1 then
604 path
605 else
606 let b = path.[len-1] = path_sep.[0] in
607 let l = String.split ((=) path_sep.[0]) path in (* warning : "" are eliminated by split *)
608 let b2 = path.[0] = path_sep.[0] in
609 let l = aux (not b2) l in
610 let path = String.concat path_sep l in
611 let path = if b2 then path_sep ^ path else path in
612 let path = if b && l <> [] then path ^ path_sep else path in
613 path
614
615
616 let get_locations_regexp ?(dir=false) directories regexp =
617 let regexp = Str.regexp (regexp^"$") in
618 List.concat_map (
619 fun p ->
620 let files = Array.to_list (Sys.readdir p) in
621 let matching_files = List.filter (fun s -> Str.string_match regexp s 0) files in
622 let fullnames = List.map (Filename.concat p) matching_files in
623 List.filter (if dir then is_directory else is_regular) fullnames
624 ) directories
625
626 let get_locations ?(dir=false) directories filename =
627 List.filter_map (
628 fun p ->
629 let fullname = Filename.concat p filename in
630 if (if dir then is_directory else is_regular) fullname
631 then Some fullname
632 else None
633 ) directories
634
635 let get_one_location ?dir
636 ?(missing_file=fun _dirs fname -> failwith (Printf.sprintf "get_one_location : missing file %s" fname))
637 ?(many_files=fun _dirs fname l ->
638 let fullname = List.hd l in
639 Printf.printf "get_one_location : \"%s\" found in several places. I will use \"%s\"" fname fullname; fullname
640 )
641 directories filename =
642 let found_files = get_locations ?dir directories filename in
643 match found_files with
644 | [fullname] -> fullname
645 | [] -> missing_file directories filename
646 | _ -> many_files directories filename found_files
Something went wrong with that request. Please try again.