(* Copyright 2004-2007 Berke DURAK.

This file is part of Dose2.

Dose2 is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

Dose2 is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>. *)

open Unix;;

let sf = Printf.sprintf;;
exception At of string * exn;;

(*** 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))^"..."
;;
(* ***)
(*** limit_left *)
let limit_left m w =
  let n = String.length w in
  if n <= m then
    w
  else
    if m < 3 then
      String.make m '.'
    else
      let m' = min (m - 3) n in
      "..."^(String.sub w (m - m') m')
;;
(* ***)
(*** 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_alpha *)
let is_alpha = function
	| 'a'..'z' -> true
	| 'A'..'Z' -> true
	| _ -> false
;;
(* ***)
(*** 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
;;
(* ***)

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
;;

let first_matching_char = first_matching_char_from 0;;

let first_matching_char_rev_from i f w =
  let rec loop i =
    if i = -1 then
      raise Not_found
    else
      if f w.[i] then
        i
      else
        loop (i - 1)
  in
  loop i
;;

let first_matching_char_rev f w =
	first_matching_char_rev_from (String.length w - 1) f 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
;;
(* ***)

(*** remove_spaces *)
let remove_spaces w =
	try
		let i = first_matching_char (fun c -> not (is_space c)) w in
		let j = first_matching_char_rev (fun c -> not (is_space c)) w in
		String.sub w i (j - i + 1)
	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
    ""
;;
(* ***)
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,"")
;;

(*** 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" (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
| WEXITED(rc) -> if rc <> 0 then Some(sf "%s failed with code %d" thing rc) else None
| WSIGNALED(sg) -> Some(sf "%s exited with signal %d" thing sg)
| WSTOPPED(sg) -> Some(sf "%s stopped with signal %d" thing sg)
;;
(* ***)
(*** list_sub_rev *)
let list_sub_rev l start length =
  let rec loop r j = function
    | [] -> r (* shall we raise an exception ? *)
    | x::y -> loop (if j < start or j >= start + length then r else x::r) (j + 1) y
  in
  loop [] 0 l
;;
(* ***)
(*** unix_really_read *)
let rec unix_really_read fd u o m =
  let l = read fd u o m in
  if l < m then
    if l = 0 then raise End_of_file
    else
      unix_really_read fd u (o + l) (m - l)
  else
    ()
;;
(* ***)
(*** is_prefix *)
let is_prefix u v =
  let m = String.length u
  and n = String.length v
  in
  m <= n &&
    let rec loop i = i = m or u.[i] = v.[i] && loop (i + 1) in
    loop 0
;;
(* ***)
(*** string_of_sockaddr *)
let string_of_sockaddr =
  function
  | ADDR_UNIX x -> sf "UNIX(%S)" x
  | ADDR_INET (a, p) -> sf "%s:%d" (string_of_inet_addr a) p
;;
(* ***)
(*** sockaddr_of_string *)
let sockaddr_of_string u =
  let m = String.length u in
  if is_prefix "UNIX(" u then
    ADDR_UNIX(String.sub u 5 (m - 6))
  else
    let (a,p) = split_once_at ((=) ':') u in
    ADDR_INET(inet_addr_of_string a, int_of_string p)
;;
(* ***)
(*** int64_of_inet_addr *)
let int64_of_inet_addr ip =
  let w = string_of_inet_addr ip in
  match List.map int_of_string (split_at '.' w) with
  | [a;b;c;d] ->
      Int64.logor
        (Int64.shift_left (Int64.of_int a) 24)
        (Int64.logor
          (Int64.shift_left (Int64.of_int b) 16)
          (Int64.logor
            (Int64.shift_left (Int64.of_int c) 8)
            (Int64.of_int d)))
  | _ -> assert false
;;
(* ***)
(*** lowercase_compare *)
let lowercase_compare u v =
  let m = String.length u
  and n = String.length v
  in
  if m <> n then
    false
  else
    let rec loop i = i = m || (Char.lowercase u.[i] = Char.lowercase v.[i] && loop (i + 1)) in
    loop 0
;;
(* ***)
(*** call_if *)
let call_if f x =
  match f with
  | None -> ()
  | Some g -> g x
(* ***)
(*** wrap *)
let wrap x g f =
  begin
    try
      let r = f x in
      g x;
      r
    with
    | z ->
        g x;
        raise z
  end
;;
(* ***)
(*** string_of_iso_8601 *)
let string_of_iso_8601 (y,m,d) = sf "%04d-%02d-%02d" y m d;;
(* ***)
(*** seconds_of_iso_8601 *)
let seconds_of_iso_8601 (y,m,d) =
  let tm = {
    tm_sec = 0;
    tm_min = 0;
    tm_hour = 0;
    tm_mon = m + 1;
    tm_wday = 0;
    tm_yday = 0;
    tm_year = y - 1900;
    tm_mday = d;
    tm_isdst = false
  }
  in
  let (t,_) = mktime tm in
  t
;;
(* ***)
(*** iso_8601_of_string *)
let iso_8601_of_string date =
  match List.map int_of_string (split_at '-' date) with
  | [y;m;d] -> (y,m,d)
  | _ -> invalid_arg "bad date"
;;
(* ***)
(*** binary_search *)
let binary_search compare a x =
  let m = Array.length a in
  let rec loop i0 m =
    if m = 0 then
      raise Not_found
    else
      begin
        if m < 8 then
          if compare a.(i0) x = 0 then
            i0
          else
            loop (i0 + 1) (m - 1)
        else
          let i = i0 + m / 2 in
          let y = a.(i) in
          let c = compare x y in
          if c = 0 then
            i
          else
            if c < 0 then
              loop i0 (m / 2)
            else
              loop (i + 1) (m - m / 2 - 1)
      end
  in
  loop 0 m
;;
(* ***)
(*** randomize *)
let randomize a =
  let m = Array.length a in
  let swap i j =
    let x = a.(i) in
    a.(i) <- a.(j);
    a.(j) <- x
  in
  for i = 0 to m - 2 do
    let j = i + 1 + Random.int (m - i - 1) in
    swap i j
  done
;;
(* ***)
(*** array_mem_assoc *)
let array_mem_assoc x a =
  let m = Array.length a in
  let rec loop i =
    if i = m then false
    else
      let (y,_) = a.(i) in
      x = y or loop (i + 1)
  in
  loop 0
;;
(* ***)
(*** array_assoc *)
let array_assoc x a =
  let m = Array.length a in
  let rec loop i =
    if i = m then raise Not_found
    else
      let (y,z) = a.(i) in
      if x = y then
        z
      else
        loop (i + 1)
  in
  loop 0
;;
(* ***)
(*** today *)
let today () =
  let tm = Unix.gmtime (Unix.gettimeofday ()) in
  (tm.Unix.tm_year + 1900, tm.Unix.tm_mon + 1, tm.Unix.tm_mday)
;;
(* ***)
(*** mkdirhier *)
let mkdirhier path =
  let exists fn =
    try
      let st = stat fn in
      st.st_kind = S_DIR
    with
    | Unix_error(ENOENT,_,_) -> false
  in
  let l = split_at '/' path in
  let rec loop dir = function
    | [] -> ()
    | x::y ->
        let path = Filename.concat dir x in
        if not (exists path) then mkdir path 0o755;
        loop path y
  in
  let base = if String.length path > 1 && path.[0] = '/' then "/" else "" in
  loop base l
;;
(* ***)
(*** inside *)
let inside msg f x =
  try
    f x
  with
  | x -> raise (At(msg, x))
;;
(* ***)
(*** display_exception *)
let rec display_exception = function
| At(location, x) ->
    Printf.eprintf "  At %s:\n" location;
    display_exception x
| x -> Printf.eprintf "  %s.\n" (Printexc.to_string x)
;;
(* ***)
(*** catch *)
let catch f =
  try
    f ()
  with
  | x ->
      Printf.eprintf "Caught exception:\n";
      display_exception x;
      Printf.eprintf "%!";
      exit 1;
;;
(* ***)
(*** sanitize_filename *)
let sanitize_filename
  ?(is_safe=
    (function
    | ('a'..'z'|'A'..'Z'|'0'..'9'|'-'|'_') -> true
    | _ -> false))
  ?(buffer=Buffer.create 256)
  ?(prefix="") fn =
  let b = buffer in
  Buffer.clear b;
  let m = String.length fn in
  Buffer.add_string b prefix;
  for i = 0 to m - 1 do
    let c = fn.[i] in
    if is_safe c then
      Buffer.add_char b c
    else
      Printf.bprintf b "%%%02x" (Char.code c)
  done;
  Buffer.contents b
;;
(* ***)
(*** unsanitize_filename *)
let unsanitize_filename ?(buffer=Buffer.create 256) ?(prefix="") fn =
  if not (is_prefix prefix fn) then invalid_arg "unsanitize_filename: no prefix";
  let b = buffer in
  Buffer.clear b;
  let m = String.length fn in
  let rec loop i =
    if i = m then
      Buffer.contents b
    else
      begin
        match fn.[i] with
        | ('a'..'z'|'A'..'Z'|'0'..'9'|'-'|'_') as c ->
           Buffer.add_char b c;
           loop (i + 1)
        | '%' ->
            if i + 2 >= m then invalid_arg (sf "unsanitize_filename: short hex escape at %d" i);
            let f c =
              let x = Char.code c in
              match c with
              | 'a'..'f' -> x - 87
              | 'A'..'F' -> x - 55
              | '0'..'9' -> x - 48
              | _ -> invalid_arg (sf "unsanitize_filename: bad hex char %C" c)
            in
            let x = ((f fn.[i+1]) lsl 4) lor (f fn.[i+2]) in
            Buffer.add_char b (Char.chr x);
            loop (i + 3)
        | c -> invalid_arg (sf "unsanitize_filename: bad char %C" c)
      end
  in
  loop (String.length prefix)
;;
(* ***)
(*
(*** under_lock *)
let under_lock mutex f x =
  Mutex.lock mutex;
  try
    let y = f x in
    Mutex.unlock mutex;
    y
  with
  | x ->
      Mutex.unlock mutex;
      raise x
;;
(* ***)
*)
(*** with_output_to_file *)
let with_output_to_file fn f =
  let oc = open_out fn in
  try
    f oc
  with
  | x ->
      close_out oc;
      raise x
;;
(* ***)
let rec uniq2 l r =
	match l with
	| [] -> r
	| [a] -> a::r
	| h::(h'::t) -> if h = h' then uniq2 (h'::t) r else uniq2 (h'::t) (h::r);;

let uniq l =
	uniq2 l [];;

let string_contains haystack needle =
	let rec string_contains_from i k h n =
	begin
		if i - k + String.length needle > String.length haystack then
			false
		else if k == String.length needle then
			true
		else if h.[i] <> n.[k] then
			string_contains_from (i+1) 0 h n
		else
			string_contains_from (i+1) (k+1) h n
	end in
	if String.length needle > String.length haystack then
		false
	else
		string_contains_from 0 0 haystack needle;;
