Source file mypervasives.ml

(* Time-stamp: <modified the 14/02/2020 (at 14:08) by Erwan Jahier> *)
(* Should rather be named misc or utils *)


(* [string_to_string_list str] returns the list of substrings of
[str] that are separated by blanks. *)
let (string_to_string_list : string -> string list) =
  fun str ->
    Str.split (Str.regexp "[ \t]+") str



(* Cloned from the OCaml stdlib Arg module: I want it on stdout! (scrogneugneu) *)
let usage_out speclist errmsg =
  Printf.printf "%s" (Arg.usage_string speclist errmsg)

(* Taken from Maxence Guesdon from the Share lib *)
let (readfile: ?verbose:bool ->string -> string) =
  fun ?(verbose=false) file ->
	 if verbose then (Printf.eprintf "Reading %s...\n" file; flush stderr);
    try
      let (readfile_ic : in_channel -> bytes) =
	     fun ic ->
	       let ic_l = in_channel_length ic in
	       let str_buf = Bytes.make ic_l ' ' in
	       let _ = really_input ic str_buf 0 ic_l in
	       str_buf
      in
      let ic = (open_in file) in
      let str = readfile_ic ic  in
	   close_in ic;
	   (Bytes.to_string str)
    with
	     e ->
	       print_string ((Printexc.to_string e) ^ ": ");
	       output_string stdout ("Warning: can not read " ^file^ ".\n");
	       flush stdout;
	       raise Not_found



let mygetenv x = 
  let x = 
    match Sys.os_type with
      | "Win32" -> (x^"_DOS")
      | _ ->  x
  in
    try Unix.getenv x 
    with Not_found -> x^" env var not defined"


(****************************************************************************)
(* a few list utils *)

let rec (list_split7: ('a * 'b * 'c * 'd * 'e * 'f * 'g) list -> 
          'a list * 'b list * 'c list * 'd list * 'e list * 'f list * 'g list) = 
  function
    | [] -> ([], [], [], [], [], [], [])
    | (x,y,z,t,u,v,w)::l ->
        let (rx, ry, rz, rt, ru, rv, rw) = 
          list_split7 l in (x::rx, y::ry, z::rz, t::rt, u::ru, v::rv, w::rw)

(* returns a \ b *)
let list_minus a b =  List.filter (fun v -> not (List.mem v b)) a

(* returns a U b *)
let list_union a b =
  List.fold_left (fun acc x -> if (List.mem x acc) then acc else x::acc) a b

(** Removes duplicates from a list (conserving its order) *)
let (list_rm_dup : 'a list -> 'a list) =
  fun list ->
    let rec aux acc list =
    match list with
	   | [] -> List.rev acc
      | elt::tail ->
	     if List.mem elt acc then aux acc tail
	     else aux (elt::acc) tail
    in
    aux [] list




(****************************************************************************)
(** Map of strings *)
module StringMap = struct
  include Map.Make(struct type t = string let compare = compare end)
end

(****************************************************************************)
(** I define my own version of print_float to turn around a bug of
    sim2chro where it does not understand floats with no digit (e.g.,
    4. instead of 4.0)
*)

(* format_float is not exported in Pervasives.mli. 
   nb: its name changed in ocaml version 3.08 (was "format_float") *)
external format_float: string -> float -> string = "caml_format_float" 

let my_string_of_float f p = format_float ("%." ^ (string_of_int p) ^ "f") f 
let my_print_float f p = output_string stdout (my_string_of_float f p)


let overflow_msg str = 
    Printf.eprintf "Fail to convert into an int the string '%s'.\n" str;
    flush stderr

let int_of_num n =
  try Num.int_of_num n 
  with _  -> 
    let str = Num.string_of_num n in
    let msg = Printf.sprintf "Fail to convert into an int the num '%s'.\n" str in
      overflow_msg msg;
      exit 2


(* for language that does have one-line comments *)
let entete2 comment_open comment_close version sha =
  let time = Unix.localtime (Unix.time ()) in
  let date = ( 
	(string_of_int time.Unix.tm_mday) ^ "/" ^
	  (string_of_int (time.Unix.tm_mon+1)) ^  "/" ^
	  (string_of_int (1900+time.Unix.tm_year))
      )
  and time_str = (
    (string_of_int time.Unix.tm_hour) ^  ":" ^
      (if time.Unix.tm_min < 10 then "0" else "") ^
      (string_of_int time.Unix.tm_min) ^   ":" ^
      (if time.Unix.tm_sec < 10 then "0" else "") ^
      (string_of_int time.Unix.tm_sec) 
  )
  and hostname = Unix.gethostname ()
  in
    (comment_open ^ " Automatically generated by "^ 
     Sys.executable_name^" version \""^version^"\" (\"" ^sha^"\")"^
     comment_close^"\n" ^  comment_open ^ " on " ^ hostname ^ 
       " the " ^ date ^ " at " ^ time_str ^comment_close^"\n" ^
     comment_open^(String.concat " " (Array.to_list Sys.argv))^
     comment_close^"\n\n")

(* for one-line comments *)
let entete comment version sha = entete2 comment "" version sha

(****************************************************************************)
(* use to perform system calls *)  
type my_create_process_result =
    OK
  | KO
  | PID of int (* if called with ~wait:false *)

let (my_create_process :
       ?std_in:(Unix.file_descr) -> ?std_out:(Unix.file_descr) ->
     ?std_err:(Unix.file_descr) ->
     ?wait:(bool) -> string -> string list -> my_create_process_result) =
  fun ?(std_in = Unix.stdin) ?(std_out = Unix.stdout) ?(std_err = Unix.stderr)
    ?(wait = true) prog args -> 
    try
      let pid = 
	List.iter (fun x -> output_string stderr (x ^ " ")) (prog::args);
	output_string stderr "\n";
	flush stderr;
	Unix.create_process
	  prog
	  (Array.of_list (prog::args))
	  (std_in)
	  (std_out)
	  (std_err)
      in
      if not wait then PID pid else 
	let (_,status) = (Unix.waitpid [Unix.WUNTRACED] pid) in
	( match status with 
	    Unix.WEXITED i -> 
	    if i = 0 || i = 1 then
	      (
		output_string stderr ("     ... "^prog^" exited normally.\n");
		flush stderr;
		OK
	      )
	    else
	      (
		output_string stderr (
                  "*** Error: " ^ prog ^ " exited abnormally (return code=" ^ 
                  (string_of_int i)^").\n");
		flush stderr;
		KO
	      )
          | Unix.WSIGNALED i-> 
	    output_string stderr (
              "*** Error: " ^ prog ^ 
              " process was killed by signal "^(string_of_int i)^"\n");
	    flush stderr;
	    KO
          | Unix.WSTOPPED i -> 
	    output_string stderr (
              "*** Error: " ^ prog ^ " process was stopped by signal " ^ 
              (string_of_int i)^"\n");
	    flush stderr;
	    KO
	)
    with 
    | Unix.Unix_error(error, name, arg) -> 
      let msg = ( "*** '" ^
		  (Unix.error_message error) ^
		  "'in the system call: '" ^ name ^ " " ^ arg ^ "'\n")
      in
      output_string stdout msg;
      flush stdout;
      output_string stderr msg;
      flush stderr;
      KO
    | e -> 
      output_string stdout (Printexc.to_string e);
      flush stdout;
      output_string stderr (Printexc.to_string e);
      flush stderr;
      KO

(* run a cmd and collect the stdout lines into a list (requires sed) *)
let (run : string -> (string -> string option) -> string list) =
 fun cmd filter -> 
  let proc = Unix.open_process_in ("("^cmd^" | sed -e 's/^/stdout: /' ) 2>&1") in
  let list = ref [] in
  try
    while true do
      let line = input_line proc in
      if String.length line >= 8 && String.sub line 0 8 = "stdout: " then 
        let str = String.sub line 8 (String.length line - 8) in
        match filter str with
          | None -> ()
          | Some str -> list := str::!list
    done;
    []
  with End_of_file ->
    ignore (Unix.close_process_in proc);
    List.rev !list

let ls path ext = run ("ls "^path^"*."^ext) (fun s -> Some s)