diff options
Diffstat (limited to 'lib/system.ml')
| -rw-r--r-- | lib/system.ml | 124 |
1 files changed, 39 insertions, 85 deletions
diff --git a/lib/system.ml b/lib/system.ml index e54109a2f3..74dd224a0a 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -9,73 +9,18 @@ (* $Id$ *) open Pp -open Errors open Util -(** Dealing with directories *) - -type unix_path = string (* path in unix-style, with '/' separator *) - -type file_kind = - | FileDir of unix_path * (* basename of path: *) string - | FileRegular of string (* basename of file *) - -(* Copy of Filename.concat but assuming paths to always be POSIX *) - -let (//) dirname filename = - let l = String.length dirname in - if l = 0 || dirname.[l-1] = '/' - then dirname ^ filename - else dirname ^ "/" ^ filename - -(* Excluding directories; We avoid directories starting with . as well - as CVS and _darcs and any subdirs given via -exclude-dir *) - -let skipped_dirnames = ref ["CVS"; "_darcs"] - -let exclude_directory f = skipped_dirnames := f :: !skipped_dirnames - -let ok_dirname f = - not (f = "") && f.[0] != '.' && - not (List.mem f !skipped_dirnames) (*&& - (match Unicode.ident_refutation f with None -> true | _ -> false)*) - -(* Check directory can be opened *) - -let exists_dir dir = - try Sys.is_directory dir with Sys_error _ -> false - -let check_unix_dir warn dir = - if (Sys.os_type = "Win32" || Sys.os_type = "Cygwin") && - (String.length dir > 2 && dir.[1] = ':' || - String.contains dir '\\' || - String.contains dir ';') - then warn ("assuming " ^ dir ^ - " to be a Unix path even if looking like a Win32 path.") - -let apply_subdir f path name = - (* we avoid all files and subdirs starting by '.' (e.g. .svn) *) - (* as well as skipped files like CVS, ... *) - if ok_dirname name then - let path = if path = "." then name else path//name in - match try (Unix.stat path).Unix.st_kind with Unix.Unix_error _ -> Unix.S_BLK with - | Unix.S_DIR -> f (FileDir (path,name)) - | Unix.S_REG -> f (FileRegular name) - | _ -> () - -let readdir dir = try Sys.readdir dir with any -> [||] - -let process_directory f path = - Array.iter (apply_subdir f path) (readdir path) - -let process_subdirectories f path = - let f = function FileDir (path,base) -> f path base | FileRegular _ -> () in - process_directory f path +include Minisys (** Returns the list of all recursive subdirectories of [root] in depth-first search, with sons ordered as on the file system; warns if [root] does not exist *) +let warn_cannot_open_dir = + CWarnings.create ~name:"cannot-open-dir" ~category:"filesystem" + (fun dir -> str ("Cannot open directory " ^ dir)) + let all_subdirs ~unix_path:root = let l = ref [] in let add f rel = l := (f, rel) :: !l in @@ -88,9 +33,8 @@ let all_subdirs ~unix_path:root = | _ -> () in process_directory f path in - check_unix_dir (fun s -> msg_warning (str s)) root; if exists_dir root then traverse root [] - else msg_warning (str ("Cannot open " ^ root)); + else warn_cannot_open_dir root; List.rev !l (* Caching directory contents for efficient syntactic equality of file @@ -143,19 +87,22 @@ let rec search paths test = | [] -> [] | lpe :: rem -> test lpe @ search rem test +let warn_ambiguous_file_name = + CWarnings.create ~name:"ambiguous-file-name" ~category:"filesystem" + (fun (filename,l,f) -> str filename ++ str " has been found in" ++ spc () ++ + hov 0 (str "[ " ++ + hv 0 (prlist_with_sep (fun () -> str " " ++ pr_semicolon()) + (fun (lpe,_) -> str lpe) l) + ++ str " ];") ++ fnl () ++ + str "loading " ++ str f) + + let where_in_path ?(warn=true) path filename = let check_and_warn l = match l with | [] -> raise Not_found | (lpe, f) :: l' -> let () = match l' with - | _ :: _ when warn -> - msg_warning - (str filename ++ str " has been found in" ++ spc () ++ - hov 0 (str "[ " ++ - hv 0 (prlist_with_sep (fun () -> str " " ++ pr_semicolon()) - (fun (lpe,_) -> str lpe) l) - ++ str " ];") ++ fnl () ++ - str "loading " ++ str f) + | _ :: _ when warn -> warn_ambiguous_file_name (filename,l,f) | _ -> () in (lpe, f) @@ -184,7 +131,7 @@ let find_file_in_path ?(warn=true) paths filename = let root = Filename.dirname filename in root, filename else - errorlabstrm "System.find_file_in_path" + CErrors.user_err ~hdr:"System.find_file_in_path" (hov 0 (str "Can't find file" ++ spc () ++ str filename)) else (* the name is considered to be the transcription as a relative @@ -192,7 +139,7 @@ let find_file_in_path ?(warn=true) paths filename = to be locate respecting case *) try where_in_path ~warn paths filename with Not_found -> - errorlabstrm "System.find_file_in_path" + CErrors.user_err ~hdr:"System.find_file_in_path" (hov 0 (str "Can't find file" ++ spc () ++ str filename ++ spc () ++ str "on loadpath")) @@ -200,27 +147,34 @@ let is_in_path lpath filename = try ignore (where_in_path ~warn:false lpath filename); true with Not_found -> false +let warn_path_not_found = + CWarnings.create ~name:"path-not-found" ~category:"filesystem" + (fun () -> str "system variable PATH not found") + let is_in_system_path filename = try let lpath = CUnix.path_to_list (Sys.getenv "PATH") in is_in_path lpath filename with Not_found -> - msg_warning (str "system variable PATH not found"); + warn_path_not_found (); false let open_trapping_failure name = try open_out_bin name - with e when Errors.noncritical e -> - errorlabstrm "System.open" (str "Can't open " ++ str name) + with e when CErrors.noncritical e -> + CErrors.user_err ~hdr:"System.open" (str "Can't open " ++ str name) + +let warn_cannot_remove_file = + CWarnings.create ~name:"cannot-remove-file" ~category:"filesystem" + (fun filename -> str"Could not remove file " ++ str filename ++ str" which is corrupted!") let try_remove filename = try Sys.remove filename - with e when Errors.noncritical e -> - msg_warning - (str"Could not remove file " ++ str filename ++ str" which is corrupted!") + with e when CErrors.noncritical e -> + warn_cannot_remove_file filename let error_corrupted file s = - errorlabstrm "System" (str file ++ str ": " ++ str s ++ str ". Try to rebuild it.") + CErrors.user_err ~hdr:"System" (str file ++ str ": " ++ str s ++ str ". Try to rebuild it.") let input_binary_int f ch = try input_binary_int ch @@ -293,11 +247,11 @@ let extern_state magic filename val_0 = marshal_out channel val_0; close_out channel with reraise -> - let reraise = Errors.push reraise in + let reraise = CErrors.push reraise in let () = try_remove filename in iraise reraise with Sys_error s -> - errorlabstrm "System.extern_state" (str "System error: " ++ str s) + CErrors.user_err ~hdr:"System.extern_state" (str "System error: " ++ str s) let intern_state magic filename = try @@ -306,12 +260,12 @@ let intern_state magic filename = close_in channel; v with Sys_error s -> - errorlabstrm "System.intern_state" (str "System error: " ++ str s) + CErrors.user_err ~hdr:"System.intern_state" (str "System error: " ++ str s) let with_magic_number_check f a = try f a with Bad_magic_number {filename=fname;actual=actual;expected=expected} -> - errorlabstrm "with_magic_number_check" + CErrors.user_err ~hdr:"with_magic_number_check" (str"File " ++ str fname ++ strbrk" has bad magic number " ++ int actual ++ str" (expected " ++ int expected ++ str")." ++ spc () ++ @@ -345,13 +299,13 @@ let with_time time f x = let y = f x in let tend = get_time() in let msg2 = if time then "" else " (successful)" in - msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2); + Feedback.msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2); y with e -> let tend = get_time() in let msg = if time then "" else "Finished failing transaction in " in let msg2 = if time then "" else " (failure)" in - msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2); + Feedback.msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2); raise e let process_id () = |