Skip to content
This repository
Newer
Older
100644 651 lines (582 sloc) 20.544 kb
fccc6851 » MLstate
2011-06-21 Initial open-source release
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
82e7f5cb » Valentin Gatien-Baron
2011-06-29 [fix] libbase: remove_symlinks behaves better when finding symbolic l…
310 if is_relative link then Filename.concat (Filename.dirname path) link
311 else link
fccc6851 » MLstate
2011-06-21 Initial open-source release
312 with Unix.Unix_error _ | Invalid_argument _ -> path in
313 if path' = path
314 then path'
315 else remove_symlinks path'
316
8bee9a80 » Valentin Gatien-Baron
2011-07-11 [fix] libbase: File.check_create_path now goes though all symbolic links
317 (* remove symlinks everywhere in the path *)
318 let rec remove_all_symlinks path =
319 if path = "." || path = "/" then path else
320 let dirname = Filename.dirname path in
321 let dirname = remove_all_symlinks dirname in
322 let path = Filename.concat dirname (Filename.basename path) in
323 remove_symlinks path
324
fccc6851 » MLstate
2011-06-21 Initial open-source release
325 (** crée tous les répertoires nécessaires pour accéder à path *)
326 let check_create_path ?(rights=0o755) path =
327 let path =
328 if Filename.basename path = "." then path
8bee9a80 » Valentin Gatien-Baron
2011-07-11 [fix] libbase: File.check_create_path now goes though all symbolic links
329 else path ^ "/" in
330 let path = remove_all_symlinks path in
fccc6851 » MLstate
2011-06-21 Initial open-source release
331 let rec aux1 = function
332 [] -> aux1 [Filename.dirname path]
8bee9a80 » Valentin Gatien-Baron
2011-07-11 [fix] libbase: File.check_create_path now goes though all symbolic links
333 | (hd :: tl) as l ->
fccc6851 » MLstate
2011-06-21 Initial open-source release
334 let d = Filename.dirname hd in
8bee9a80 » Valentin Gatien-Baron
2011-07-11 [fix] libbase: File.check_create_path now goes though all symbolic links
335 if d <> hd then aux1 (d :: l)
fccc6851 » MLstate
2011-06-21 Initial open-source release
336 else tl (* car hd = C:\ ou / *) in
8bee9a80 » Valentin Gatien-Baron
2011-07-11 [fix] libbase: File.check_create_path now goes though all symbolic links
337 let mkdir d = try Unix.mkdir d rights; true with Unix.Unix_error _ -> false in
338 List.for_all (fun x -> Sys.file_exists x || mkdir x) (aux1 [])
fccc6851 » MLstate
2011-06-21 Initial open-source release
339
340 (** hopefully, this is the ultimate and portable version of cp *)
341 let copy ?(force=false) src tgt =
342 if not (Sys.file_exists src) then 1
343 else
344 if src = tgt then 0
345 (* FIXME if you have symbolic links, this check is not enough
346 * and if [force] is set, then you will end up deleting your file *)
347 else
348 begin
349 if force && (Sys.file_exists tgt) then Sys.remove tgt;
350 if Sys.file_exists tgt then 1
351 else
352 let dir = Filename.dirname tgt in
353 if check_create_path dir then
354 let command = (if Base.is_windows then Format.sprintf "copy \"%s\" \"%s\"" else Format.sprintf "cp \"%s\" \"%s\"") src tgt in
355 Sys.command command
356 else 1
357 end
358
359 (** hopefully, this is the ultimate and portable version of mv *)
360 let mv ?(force=false) src tgt =
361 if not (Sys.file_exists src) then 1
362 else
363 if src = tgt then 0
364 (* FIXME if you have symbolic links, this check is not enough
365 * and if [force] is set, then you will end up deleting your file *)
366 else
367 begin
368 if force && (Sys.file_exists tgt) then Sys.remove tgt;
369 if Sys.file_exists tgt then 1
370 else
371 let dir = Filename.dirname tgt in
372 if check_create_path dir then
373 let command = (if Base.is_windows then Format.sprintf "rename \"%s\" \"%s\"" else Format.sprintf "mv \"%s\" \"%s\"") src tgt in
374 Sys.command command
375 else 1
376 end
377
378 exception NoMLstateDir
379
380 (* In case of failure, mlstate_dir is in the same place as the program.
381 Make this lazy? *)
382 let mlstate_dir = lazy (
383 try
384 let path = match Sys.os_type with
385 | "Unix"
386 | "Cygwin" -> Filename.concat (Sys.getenv "HOME") ".mlstate/"
387 | "Win32" -> Filename.concat (Sys.getenv "USERPROFILE") "AppData\\Local\\MLstate\\"
388 | s -> failwith (Printf.sprintf "Base.ml_state_dir : this platform (%s) is yet unsupported" s) in
389 (* assert (check_create_path ~rights:0o700 path) ; *)
390 if check_create_path ~rights:0o700 path then path
391 else ".mlstate/" (* raise NoMLstateDir *)
392 with Not_found -> ".mlstate/"
393 )
394
395 let mlstatelibs =
396 lazy (
397 try
398 let path = Sys.getenv "MLSTATELIBS" in
399 PathTransform.string_to_mysys path
400 with Not_found -> failwith "Environnement variable MLSTATELIBS not defined." )
401
402
403 let is_regular file =
404 (* Jounral.Interface.jlog (Printf.sprintf "file=%s" file) ; *)
405 try
406 let st = Unix.stat file in
407 st.Unix.st_kind = Unix.S_REG
408 with Unix.Unix_error _ -> false
409
410 let is_directory path =
411 (* Jounral.Interface.jlog (Printf.sprintf "file=%s" file) ; *)
412 try
413 let st = Unix.stat path in
414 st.Unix.st_kind = Unix.S_DIR
415 with Unix.Unix_error _ -> false
416
417 let mimetype ?magic_file file =
418 let database =
419 match magic_file with
420 | Some s -> File_mimetype.get_mimetype_database s
421 | None -> File_mimetype.mimetype_database mlstatelibs in
422 try
423 File_mimetype.get_mimetype file database
424 with File_mimetype.MimeType_NotFound -> (
425 (* Journal.Interface.warning (Printf.sprintf "\"%s\" : error, don't find the mimetype !! replace by default, i.e 'text/plain'\n" file); *)
426 "text/plain"
427 )
428
429
430 let rec iter_dir_rec ?(showdir=false) f d =
431 let dh = Unix.opendir d in
432 try
433 while true do
434 let x = Unix.readdir dh in
435 let path = Filename.concat d x in
436 let st = Unix.stat path in
437 match st.Unix.st_kind with
438 | Unix.S_REG -> f ~name:x ~path
439 | Unix.S_DIR ->
440 if showdir && x="." then f ~name:x ~path:d
441 else if x="." or x=".." then ()
442 else iter_dir_rec f path ~showdir
443 | _ -> ()
444 done
445 with
446 End_of_file -> Unix.closedir dh
447
448 (* FIXME: tester les iter/fold rec ou non *)
449 let fold_dir_rec f i d =
450 let rec aux d dh r =
451 try
452 let x = Unix.readdir dh in
453 let path = Filename.concat d x in
454 let st = Unix.stat path in
455 match st.Unix.st_kind with
456 | Unix.S_REG -> aux d dh (f r ~name:x ~path)
457 | Unix.S_DIR ->
458 if x="." or x=".." then aux d dh r
459 else aux d dh (aux path (Unix.opendir path) r)
460 | _ -> aux d dh r
461 with
462 End_of_file -> Unix.closedir dh ; r
463 | Unix.Unix_error _ -> aux d dh r
464 in
465 aux d (Unix.opendir d) i
466
467 let rec remove_rec file =
468 let sto = try Some (Unix.stat file) with Unix.Unix_error _ -> None in
469 match sto with
470 | None -> ()
471 | Some st ->
472 match st.Unix.st_kind with
473 | Unix.S_REG
474 | Unix.S_LNK
475 | Unix.S_FIFO
476 | Unix.S_SOCK ->
477 Unix.unlink file
478 | Unix.S_CHR
479 | Unix.S_BLK ->
480 Base.invalid_argf "File.remove_rec: %s" file
481 | Unix.S_DIR ->
482 let dir = file in
483 let handle = Unix.opendir dir in
484 try
485 while true do
486 match Unix.readdir handle with
487 | "." | ".." -> ()
488 | file ->
489 let path = Filename.concat dir file in
490 remove_rec path
491 done;
492 with End_of_file ->
493 Unix.closedir handle;
494 Unix.rmdir dir
495
496 (** itère une fonction sur un répertoire / non récursif, ignore les répertoires ! *)
497 let iter_dir f d =
498 let dh = Unix.opendir d in
499 try
500 while true do
501 let x = Unix.readdir dh in
502 let y = concat d x in
503 if is_regular y then f ~name:x ~path:y
504 done
505 with
506 End_of_file -> Unix.closedir dh
507
508 (** itère une fonction sur un répertoire / non récursif, ignore les répertoires ! *)
509 (* FIXME: remplacer ici . par getcwd ? *)
510 let fold_dir f i d =
511 let dh = Unix.opendir d in
512 let rec aux r =
513 try
514 let x = Unix.readdir dh in
515 let y = concat d x in
516 aux (if is_regular y then f r ~name:x ~path:y else r)
517 with
518 End_of_file -> Unix.closedir dh ; r
519 in
520 aux i
521
522 (* FIXME: optimiser si le dir n'a pas changé (lors d'une saisie lettre par lettre)... *)
523 (* FIXME: Glib.Convert.filename_to_utf8 ! *)
524 let completion path =
525 let dir = Filename.dirname path (* FIXME: tenir compte de ~ *)
526 and base = Filename.basename path in
527 let f_comp acc ~name ~path =
528 if String.is_substring base name 0 then (if dir="." then name else path)::acc
529 else acc in
530 fold_dir f_comp [] (if dir = "." then Unix.getcwd () else dir)
531
532 let backup_path name =
533 let path = concat (Lazy.force mlstate_dir) (name ^ path_sep) in
534 (* Journal.Interface.jlog (Printf.sprintf "backup_path = %s" path) ; *)
535 if check_create_path path then Some path
536 else (
537 (* Journal.Interface.warning "backup path could not be created. NO automatic backups!" ; *)
538 None
539 )
540
541
542 let append_or_create name =
543 let f = if Sys.file_exists name then
544 open_out_gen [Open_wronly; Open_binary; Open_append] default_rights
545 else
546 open_out_gen [Open_wronly; Open_binary; Open_creat; Open_trunc] default_rights
547 in f name
548
549 let channel_contents chan =
550 let rec aux b = (* FIXME: recursion might stack overflow *)
551 try aux (FBuffer.add b (input_line chan ^ "\n"))
552 with End_of_file -> b
553 in
554 FBuffer.contents (aux (FBuffer.create ~name:"channel_contents" 256))
555
556 (** highly non portable (especially the cmd itself)
557 please do not abuse or else you will be responsible of the Windows port :p *)
558 type filter = { process: string -> string;
559 close : unit -> unit }
560
561 let new_filter cmd =
562 let (inchan,outchan) as chans = Unix.open_process cmd in
563 let process s =
564 Pervasives.output_string outchan s;
565 Pervasives.output_char outchan '\n';
566 Pervasives.flush outchan;
567 Pervasives.input_line inchan
568 and close () =
569 ignore (Unix.close_process chans)
570 in
571 { process = process;
572 close = close }
573 (** examples:
574 let sed = new_filter "sed -u 's/foo/bar/'";;
575 List.map sed.process ["bar";"foo";"foobar";"foofoo"] returns ["bar";"bar";"barbar";"barfoo"]
576 sed.close() when the filter is not needed anymore *)
577
578 exception Process_error of string
579 let process_output cmd =
580 let chan = Unix.open_process_in cmd in
581 let lines = channel_contents chan in
582 match Unix.close_process_in chan with
583 | Unix.WEXITED 0 -> lines
584 | Unix.WEXITED i -> raise (Process_error (Printf.sprintf "command failed with code %d" i))
585 | Unix.WSIGNALED i -> raise (Process_error (Printf.sprintf "command killed by signal %d" i))
586 | Unix.WSTOPPED i -> raise (Process_error (Printf.sprintf "command stopped by signal %d" i))
587
588 let simplify_path =
589 let rec aux void = function
590 | [] -> []
591 | ".."::l -> ".."::(aux false l)
592 | "."::l
593 | _::".."::l ->
594 begin match l with
595 | _::_ -> aux void l
596 | _ when not void -> aux void l
597 | [] -> ["."]
598 end
599 | d::l ->
600 let l = aux false l in
601 begin match l with
602 | ".."::_ -> aux void (d::l)
603 | _ -> d::l
604 end
605 in
606 fun path ->
607 let len = String.length path in
608 if len <= 1 then
609 path
610 else
611 let b = path.[len-1] = path_sep.[0] in
461365b0 » Louis Gesbert
2011-06-23 [cleanup] Base.String: changed String.split to a much simpler String.…
612 let l = String.slice path_sep.[0] path in
fccc6851 » MLstate
2011-06-21 Initial open-source release
613 let b2 = path.[0] = path_sep.[0] in
614 let l = aux (not b2) l in
615 let path = String.concat path_sep l in
616 let path = if b2 then path_sep ^ path else path in
617 let path = if b && l <> [] then path ^ path_sep else path in
618 path
619
620
621 let get_locations_regexp ?(dir=false) directories regexp =
622 let regexp = Str.regexp (regexp^"$") in
623 List.concat_map (
624 fun p ->
625 let files = Array.to_list (Sys.readdir p) in
626 let matching_files = List.filter (fun s -> Str.string_match regexp s 0) files in
627 let fullnames = List.map (Filename.concat p) matching_files in
628 List.filter (if dir then is_directory else is_regular) fullnames
629 ) directories
630
631 let get_locations ?(dir=false) directories filename =
632 List.filter_map (
633 fun p ->
634 let fullname = Filename.concat p filename in
635 if (if dir then is_directory else is_regular) fullname
636 then Some fullname
637 else None
638 ) directories
639
640 let get_one_location ?dir
641 ?(missing_file=fun _dirs fname -> failwith (Printf.sprintf "get_one_location : missing file %s" fname))
642 ?(many_files=fun _dirs fname l ->
643 let fullname = List.hd l in
644 Printf.printf "get_one_location : \"%s\" found in several places. I will use \"%s\"" fname fullname; fullname
645 )
646 directories filename =
647 let found_files = get_locations ?dir directories filename in
648 match found_files with
649 | [fullname] -> fullname
650 | [] -> missing_file directories filename
651 | _ -> many_files directories filename found_files
Something went wrong with that request. Please try again.