(* Util *)
(* $Id: util.ml,v 1.2 2004/10/26 09:44:54 berke Exp $ *)

let sf = Printf.sprintf;;

(*** first_line *)
let first_line =
  let b = Buffer.create 256 in
  fun w ->
    Buffer.clear b;
    let rec loop i =
      if i = String.length w or w.[i] = '\n' then
        Buffer.contents b
      else
        begin
          Buffer.add_char b w.[i];
          loop (i + 1)
        end
    in
    loop 0
;;
(* ***)
(*** limit *)
let limit m w =
  let n = String.length w in
  if n <= m then
    w
  else
    if m < 3 then
      String.make m '.'
    else
      (String.sub w 0 (min (m - 3) n))^"..."
;;
(* ***)
(*** for_all_chars *)
let for_all_chars f w =
  let m = String.length w in
  let rec loop i =
    if i = m then
      true
    else
      f w.[i] && loop (i + 1)
  in
  loop 0
;;
(* ***)
(*** split_once_at *)
let split_once_at f s =
  let m = String.length s in
  let rec loop1 i =
    if i = m then
      raise Not_found
    else
      if f s.[i] then
        loop2 i (i + 1)
      else
        loop1 (i + 1)
  and loop2 i j =
    if j = m or not (f s.[j]) then
      (i,j)
    else
      loop2 i (j + 1)
  in
  try
    let (i,j) = loop1 0 in
    (String.sub s 0 i,
     String.sub s j (m - j))
  with
  | Not_found -> (s, "")
;;
(* ***)
(*** is_digit *)
let is_digit = function
  | '0'..'9' -> true
  | _ -> false
;;
(* ***)
(*** is_space *)
let is_space = function
  | ' '|'\t'|'\n' -> true
  | _ -> false
;;
(* ***)
(*** parse_strings *)
let parse_strings u =
  let m = String.length u in
  let b = Buffer.create m in
  let rec loop0 r i =
    if i >= m then
      List.rev r
    else
      match u.[i] with
      | ' '|'\t'|'\n' -> loop0 r (i + 1)
      | '"' ->
          Buffer.clear b;
          loop2 r (i + 1)
      | _ -> loop1 r i
  and loop1 r i =
    if i = m or is_space u.[i] or u.[i] = '"' then
      begin
        let x = Buffer.contents b in
        Buffer.clear b;
        loop0 (x::r) i
      end
    else
      begin
        Buffer.add_char b u.[i];
        loop1 r (i + 1)
      end
  and loop2 r i =
    if i = m then
      invalid_arg "Unterminated double quote"
    else
      if u.[i] = '"' then
        begin
          let x = Buffer.contents b in
          Buffer.clear b;
          loop0 (x::r) (i + 1)
        end
      else
        if u.[i] = '\\' then
          if i + 1 < m then
            match u.[i + 1] with
            | '\\' -> Buffer.add_char b '\\'; loop2 r (i + 2)
            | 'n' -> Buffer.add_char b '\n'; loop2 r (i + 2)
            | 'r' -> Buffer.add_char b 'r'; loop2 r (i + 2)
            | '"' -> Buffer.add_char b '"'; loop2 r (i + 2)
            | 't' -> Buffer.add_char b 't'; loop2 r (i + 2)
            | '0'..'9' ->
                if i + 3 < m then
                  let x = int_of_string (String.sub u (i + 1) 3) in
                  if 0 < x && x < 256 then
                    begin
                      Buffer.add_char b (Char.chr x);
                      loop2 r (i + 4)
                    end
                  else
                    invalid_arg "Bad or null character code in backslash code"
                else
                  invalid_arg "Unterminated decimal backslash code"
            | _ -> invalid_arg "Unknown backslash code"
          else
            invalid_arg "Unterminated backslash sequence"
        else
          begin
            Buffer.add_char b u.[i];
            loop2 r (i + 1)
          end
  in
  loop0 [] 0
;;
(* ***)
(*** split_at *)
let split_at c u =
  let m = String.length u in
  let b = Buffer.create m in
  let rec loop0 r i =
    if i >= m then
      List.rev r
    else
      if u.[i] = c then
        loop0 r (i + 1)
      else
        loop1 r i
  and loop1 r i =
    if i = m or u.[i] = c then
      begin
        let x = Buffer.contents b in
        Buffer.clear b;
        loop0 (x::r) (i + 1)
      end
    else
      begin
        Buffer.add_char b u.[i];
        loop1 r (i + 1)
      end
  in
  loop0 [] 0
;;
(* ***)
(*** list_intersect *)
let list_intersect l1 l2 =
  let rec loop r = function
    | [] -> r
    | x::y -> loop (if List.mem x l2 then x::r else r) y
  in
  loop [] l1
;;
(* ***)
(*** once *)
let once f =
  let x = ref true in
  fun () ->
    if !x then
      begin
        x := false;
        f ()
      end
    else
      ()
;;
(* ***)
(*** list_has_more_than_one_element *)
let list_has_more_than_one_element = function
  | []|[_] -> false
  | _ -> true
;;
(* ***)
(*** count_lines *)
let count_lines w =
  let m = String.length w in
  let rec loop x i =
    if i = m then
      x
    else
      loop (if w.[i] = '\n' then x + 1 else x) (i + 1)
  in
  loop 1 0
;;
(* ***)
(*** first_matching_char_from *)
let first_matching_char_from i f w =
  let m = String.length w in
  let rec loop i =
    if i = m then
      raise Not_found
    else
      if f w.[i] then
        i
      else
        loop (i + 1)
  in
  loop i
;;
(* ***)
(*** first_matching_char *)
let first_matching_char = first_matching_char_from 0;;
(* ***)
(*** longest_matching_prefix *)
let longest_matching_prefix f w =
  try
    let i = first_matching_char (fun c -> not (f c)) w in
    String.sub w 0 i, String.sub w i (String.length w - i)
  with
  | Not_found -> (w,"")
;;
(* ***)
(*** remove_leading_spaces *)
let remove_leading_spaces w =
  try
    let i = first_matching_char (fun c -> not (is_space c)) w in
    String.sub w i (String.length w - i)
  with
  | Not_found -> w
;;
(* ***)
(*** delete_first_chars *)
let delete_first_chars n w =
  let m = String.length w in
  if m > n then
    String.sub w n (m - n)
  else
    ""
;;
(* ***)
(*** hierarchical *)
let hierarchical x y =
  let m = String.length x
  and n = String.length y
  in
  if m < n then
    -1
  else if m > n then
    1
  else
    compare x y
;;
(* ***)
(*** wind *)
let wind f x g y =
  begin
    try
      let r = f x in
      g y;
      r
    with
    | z ->
        g y;
        raise z
  end
;;
(* ***)
(*** list_change_nth *)
let rec list_change_nth l n z =
  match l,n with
  | [],_ -> raise Not_found
  | x::y,0 -> z::y
  | x::y,_ -> x::(list_change_nth y (n - 1) z)
;;
(* ***)
(*** list_remove_nth *)
let rec list_remove_nth l n =
  match l,n with
  | [],_ -> raise Not_found
  | x::y,0 -> y
  | x::y,_ -> x::(list_remove_nth y (n - 1))
;;
(* ***)
(*** word_wrap *)
let word_wrap oc ?(columns=75) u =
  let m = String.length u in
  let f c = output_char oc c
  and g u i m = output oc u i m
  in
  (* beginning of line space *)
  (* i: current index *)
  (* j: pending beginning-of-line spaces (i.e., indent) *)
  let rec loop0 i j =
    if i = m then
      if j > 0 then
        f '\n'
      else
        ()
    else match u.[i] with
    | ' ' -> loop0 (i + 1) (j + 1)
    | '\t' -> loop0 (i + 1) (j + (4 - j land 3))
    | '\n' ->
        f '\n';
        loop0 (i + 1) 0
    | _ ->
        if j < columns then
          loop2 i i 0 j
        else
          begin
            f '\n';
            loop2 i i 0 0
          end
  (* inter-word space *)
  (* i: current index *)
  (* j: actual column *)
  and loop1 i j =
    if i = m then
      if j > 0 then
        f '\n'
      else
        ()
    else match u.[i] with
    | ' '|'\t' -> loop1 (i + 1) j
    | '\n' ->
        f '\n';
        loop0 (i + 1) 0
    | _ -> loop2 i i j 1
  (* word *)
  (* i0: index of beginning of word *)
  (* i: current index *)
  (* j: actual cursor column *)
  (* k: number of pending spaces *)
  and loop2 i0 i j k =
    if i = m or u.[i] = ' ' or u.[i] = '\t' or u.[i] = '\n' then
      let l = i - i0 in
      if j + k + l >= columns then
        begin
          f '\n';
          g u i0 l;
          if i < m & u.[i] = '\n' then
            begin
              f '\n';
              loop0 (i + 1) 0
            end
          else
            if l >= columns then
              begin
                f '\n';
                loop1 (i + 1) 0
              end
            else
              loop1 (i + 1) l
        end
      else
        begin
          for h = 1 to k do
            f ' '
          done;
          g u i0 l;
          if u.[i] = '\n' then
            begin
              f '\n';
              loop0 (i + 1) 0
            end
          else
            loop1 (i + 1) (j + k + l)
        end
    else
      loop2 i0 (i + 1) j k
  in
  loop0 0 0
;;
(* ***)
(*** reg_of_string *)
let reg_of_string w =
  let m = String.length w in
  let b = Buffer.create m in
  for i = 0 to m - 1 do
    match w.[i] with
    | ('.'|'+'|'?'|'['|']'|'^'|'$'|'\\') as c -> Buffer.add_char b '\\'; Buffer.add_char b c
    | '*' -> Buffer.add_string b ".*"
    | c -> Buffer.add_char b c
  done;
  Buffer.contents b
;;
(* ***)
(*** flip_array *)
let flip_array a =
  let m = Array.length a in
  for i = 0 to m / 2 - 1 do
    let t = a.(i) in
    a.(i) <- a.(m - 1 - i);
    a.(m - 1 - i) <- t
  done
;;
(* ***)
(*** proc_get_free_mem *)
let proc_get_free_mem () =
  let ic = open_in "/proc/meminfo" in
  wind (fun () -> 
    let tot = ref 0 in
    try
      while true do
        let l = input_line ic in
        match split_at ' ' l with
        | [("MemFree:"|"Cached:");x;"kB"] -> tot :=  (int_of_string x) + !tot
        | _ -> ()
      done;
      assert false
    with
    | End_of_file -> !tot
    | _ -> 16384 (* assumption *)) ()
    (fun () -> close_in ic) ()
;;
(* ***)
(*** proc_get_rsz_vsz *)
let proc_get_rsz_vsz () =
  let ic = open_in (sf "/proc/%d/statm" (Unix.getpid ())) in
  wind (fun () -> 
    Scanf.fscanf ic "%d %d %d %d %d %d %d"
      (fun size resident share trs drs lrs dt ->
        (resident,share))) () (fun () -> close_in ic) ()
;;
(* ***)
(*** substitute_variables *)
let substitute_variables env w =
  let b = Buffer.create (String.length w) in
  Buffer.add_substitute b (fun v -> List.assoc v env) w;
  Buffer.contents b
;;
(* ***)
(*** string_of_process_status *)
let string_of_process_status thing = function
| Unix.WEXITED(rc) -> if rc <> 0 then Some(sf "%s failed with code %d" thing rc) else None
| Unix.WSIGNALED(sg) -> Some(sf "%s exited with signal %d" thing sg)
| Unix.WSTOPPED(sg) -> Some(sf "%s stopped with signal %d" thing sg)
;;
(* ***)
(*** list_sub_rev *)
let list_sub_rev l start stop =
  let rec loop r j = function
    | [] -> r (* shall we raise an exception ? *)
    | x::y -> loop (if j < start or j > stop then r else x::r) (j + 1) y
  in
  loop [] 0 l
;;
(* ***)
