diff options
Diffstat (limited to 'lib/system.ml')
-rw-r--r-- | lib/system.ml | 82 |
1 files changed, 51 insertions, 31 deletions
diff --git a/lib/system.ml b/lib/system.ml index 3fa32ef8..6eb4e751 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: system.ml 13175 2010-06-22 06:28:37Z herbelin $ *) +(* $Id$ *) open Pp open Util @@ -15,7 +15,7 @@ open Unix (* Expanding shell variables and home-directories *) let safe_getenv_def var def = - try + try Sys.getenv var with Not_found -> warning ("Environment variable "^var^" not found: using '"^def^"' ."); @@ -38,7 +38,7 @@ let rec expand_macros s i = let l = String.length s in if i=l then s else match s.[i] with - | '$' -> + | '$' -> let n = expand_atom s (i+1) in let v = safe_getenv (String.sub s (i+1) (n-i-1)) in let s = (String.sub s 0 i)^v^(String.sub s n (l-n)) in @@ -64,7 +64,7 @@ let physical_path_of_string s = s let string_of_physical_path p = p (* Hints to partially detects if two paths refer to the same repertory *) -let rec remove_path_dot p = +let rec remove_path_dot p = let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *) let n = String.length curdir in if String.length p > n && String.sub p 0 n = curdir then @@ -82,7 +82,7 @@ let strip_path p = let canonical_path_name p = let current = Sys.getcwd () in - try + try Sys.chdir p; let p' = Sys.getcwd () in Sys.chdir current; @@ -100,7 +100,7 @@ let skipped_dirnames = ref ["CVS"; "_darcs"] let exclude_search_in_dirname f = skipped_dirnames := f :: !skipped_dirnames -let ok_dirname f = +let ok_dirname f = f <> "" && f.[0] <> '.' && not (List.mem f !skipped_dirnames) && try ignore (check_ident f); true with _ -> false @@ -114,7 +114,7 @@ let all_subdirs ~unix_path:root = let f = readdir dirh in if ok_dirname f then let file = Filename.concat dir f in - try + try if (stat file).st_kind = S_DIR then begin let newrel = rel@[f] in add file newrel; @@ -132,14 +132,14 @@ let where_in_path ?(warn=true) path filename = let rec search = function | lpe :: rem -> let f = Filename.concat lpe filename in - if Sys.file_exists f + if Sys.file_exists f then (lpe,f) :: search rem else search rem | [] -> [] in let rec check_and_warn l = match l with | [] -> raise Not_found - | (lpe, f) :: l' -> + | (lpe, f) :: l' -> if warn & l' <> [] then msg_warning (str filename ++ str " has been found in" ++ spc () ++ @@ -159,11 +159,11 @@ let find_file_in_path ?(warn=true) paths filename = else errorlabstrm "System.find_file_in_path" (hov 0 (str "Can't find file" ++ spc () ++ str filename)) - else + else try where_in_path ~warn paths filename with Not_found -> errorlabstrm "System.find_file_in_path" - (hov 0 (str "Can't find file" ++ spc () ++ str filename ++ spc () ++ + (hov 0 (str "Can't find file" ++ spc () ++ str filename ++ spc () ++ str "on loadpath")) let is_in_path lpath filename = @@ -192,40 +192,40 @@ let marshal_in ch = exception Bad_magic_number of string let raw_extern_intern magic suffix = - let extern_state name = + let extern_state name = let filename = make_suffix name suffix in let channel = open_trapping_failure filename in output_binary_int channel magic; filename,channel - and intern_state filename = + and intern_state filename = let channel = open_in_bin filename in if input_binary_int channel <> magic then raise (Bad_magic_number filename); channel - in + in (extern_state,intern_state) let extern_intern ?(warn=true) magic suffix = let (raw_extern,raw_intern) = raw_extern_intern magic suffix in - let extern_state name val_0 = + let extern_state name val_0 = try let (filename,channel) = raw_extern name in try marshal_out channel val_0; close_out channel - with e -> + with e -> begin try_remove filename; raise e end with Sys_error s -> error ("System error: " ^ s) - and intern_state paths name = + and intern_state paths name = try let _,filename = find_file_in_path ~warn paths (make_suffix name suffix) in let channel = raw_intern filename in let v = marshal_in channel in - close_in channel; + close_in channel; v - with Sys_error s -> + with Sys_error s -> error("System error: " ^ s) - in + in (extern_state,intern_state) let with_magic_number_check f a = @@ -244,14 +244,14 @@ let connect writefun readfun com = let ch_to_in,ch_to_out = try open_in tmp_to, open_out tmp_to with Sys_error s -> error ("Cannot set connection to "^com^"("^s^")") in - let ch_from_in,ch_from_out = + let ch_from_in,ch_from_out = try open_in tmp_from, open_out tmp_from with Sys_error s -> - close_out ch_to_out; close_in ch_to_in; + close_out ch_to_out; close_in ch_to_in; error ("Cannot set connection from "^com^"("^s^")") in writefun ch_to_out; close_out ch_to_out; - let pid = + let pid = let ch_to' = Unix.descr_of_in_channel ch_to_in in let ch_from' = Unix.descr_of_out_channel ch_from_out in try Unix.create_process com [|com|] ch_to' ch_from' Unix.stdout @@ -279,32 +279,52 @@ let run_command converter f c = let n = ref 0 in let ne = ref 0 in - while n:= input cin buff 0 127 ; ne := input cerr buffe 0 127 ; + while n:= input cin buff 0 127 ; ne := input cerr buffe 0 127 ; !n+ !ne <> 0 - do - let r = converter (String.sub buff 0 !n) in + do + let r = converter (String.sub buff 0 !n) in f r; Buffer.add_string result r; - let r = converter (String.sub buffe 0 !ne) in + let r = converter (String.sub buffe 0 !ne) in f r; - Buffer.add_string result r + Buffer.add_string result r done; (Unix.close_process_full (cin,cout,cerr), Buffer.contents result) +let path_separator = if Sys.os_type = "Unix" then ':' else ';' + +let search_exe_in_path exe = + try + let path = Sys.getenv "PATH" in + let n = String.length path in + let rec aux i = + if i < n then + let j = + try String.index_from path i path_separator + with Not_found -> n + in + let dir = String.sub path i (j-i) in + let exe = Filename.concat dir exe in + if Sys.file_exists exe then Some exe else aux (i+1) + else + None + in aux 0 + with Not_found -> None + (* Time stamps. *) type time = float * float * float -let process_time () = +let process_time () = let t = times () in (t.tms_utime, t.tms_stime) -let get_time () = +let get_time () = let t = times () in (time(), t.tms_utime, t.tms_stime) let time_difference (t1,_,_) (t2,_,_) = t2 -. t1 - + let fmt_time_difference (startreal,ustart,sstart) (stopreal,ustop,sstop) = real (stopreal -. startreal) ++ str " secs " ++ str "(" ++ |