utils.ml

   1 module E = struct
   2   let s = ""
   3   let a = [||];;
   4 end;;
   5
   6 type platform =
   7   | Punknown | Plinux | Posx | Psun | Pfreebsd
   8   | Pdragonflybsd | Popenbsd | Pnetbsd | Pcygwin
   9 ;;
  10
  11 let tempfailureretry f a =
  12   let rec g () =
  13     try f a with Unix.Unix_error (Unix.EINTR, _, _) -> g ()
  14   in g ()
  15 ;;
  16
  17 external cloexec : Unix.file_descr -> unit = "ml_cloexec";;
  18 external hasdata : Unix.file_descr -> bool = "ml_hasdata";;
  19 external toutf8 : int -> string = "ml_keysymtoutf8";;
  20 external mbtoutf8 : string -> string = "ml_mbtoutf8";;
  21 external popen : string -> (Unix.file_descr * int) list -> unit = "ml_popen";;
  22 external platform : unit -> platform = "ml_platform";;
  23
  24 let now = Unix.gettimeofday;;
  25 let platform = platform ();;
  26 let dolog fmt = Format.kprintf prerr_endline fmt;;
  27
  28 let exntos = function
  29   | Unix.Unix_error (e, s, a) -> Printf.sprintf "%s(%s) : %s (%d)"
  30       s a (Unix.error_message e) (Obj.magic e)
  31   | exn -> Printexc.to_string exn;
  32 ;;
  33
  34 let error fmt = Printf.kprintf failwith fmt;;
  35
  36 module IntSet = Set.Make (struct type t = int let compare = (-) end);;
  37
  38 let emptystr s = String.length s = 0;;
  39 let nonemptystr s = String.length s > 0;;
  40 let bound v minv maxv = max minv (min maxv v);;
  41
  42 let popen cmd fda =
  43   if platform = Pcygwin
  44   then (
  45     let sh = "/bin/sh" in
  46     let args = [|sh; "-c"; cmd|] in
  47     let rec std si so se = function
  48       | [] -> si, so, se
  49       | (fd, 0) :: rest -> std fd so se rest
  50       | (fd, -1) :: rest ->
  51           Unix.set_close_on_exec fd;
  52           std si so se rest
  53       | (_, n) :: _ ->
  54           failwith ("unexpected fdn in cygwin popen " ^ string_of_int n)
  55     in
  56     let si, so, se = std Unix.stdin Unix.stdout Unix.stderr fda in
  57     ignore (Unix.create_process sh args si so se)
  58   )
  59   else popen cmd fda;
  60 ;;
  61
  62 module Opaque :
  63 sig
  64   type t =  private string
  65   val of_string : string -> t
  66   val to_string : t -> string
  67 end
  68   =
  69 struct
  70   type t = string
  71   let of_string s = s
  72   let to_string t = t
  73 end
  74 ;;
  75
  76 let (~<) = Opaque.of_string;;
  77 let (~>) = Opaque.to_string;;
  78
  79 let int_of_string_with_suffix s =
  80   let l = String.length s in
  81   let s1, shift =
  82     if l > 1
  83     then
  84       let suffix = Char.lowercase s.[l-1] in
  85       match suffix with
  86       | 'k' -> String.sub s 0 (l-1), 10
  87       | 'm' -> String.sub s 0 (l-1), 20
  88       | 'g' -> String.sub s 0 (l-1), 30
  89       | _ -> s, 0
  90     else s, 0
  91   in
  92   let n = int_of_string s1 in
  93   let m = n lsl shift in
  94   if m < 0 || m < n
  95   then raise (Failure "value too large")
  96   else m
  97 ;;
  98
  99 let string_with_suffix_of_int n =
 100   if n = 0
 101   then "0"
 102   else
 103     let units = [(30, "G"); (20, "M"); (10, "K")] in
 104     let prettyint n =
 105       let rec loop s n =
 106         let h = n mod 1000 in
 107         let n = n / 1000 in
 108         if n = 0
 109         then string_of_int h ^ s
 110         else (
 111           let s = Printf.sprintf "_%03d%s" h s in
 112           loop s n
 113         )
 114       in
 115       loop E.s n
 116     in
 117     let rec find = function
 118       | [] -> prettyint n
 119       | (shift, suffix) :: rest ->
 120           if (n land ((1 lsl shift) - 1)) = 0
 121           then prettyint (n lsr shift) ^ suffix
 122           else find rest
 123     in
 124     find units
 125 ;;
 126
 127 let color_of_string s =
 128   Scanf.sscanf s "%d/%d/%d" (fun r g b ->
 129     (float r /. 256.0, float g /. 256.0, float b /. 256.0)
 130   )
 131 ;;
 132
 133 let color_to_string (r, g, b) =
 134   let r = truncate (r *. 256.0)
 135   and g = truncate (g *. 256.0)
 136   and b = truncate (b *. 256.0) in
 137   Printf.sprintf "%d/%d/%d" r g b
 138 ;;
 139
 140 let abspath path =
 141   if Filename.is_relative path
 142   then
 143     let cwd = Sys.getcwd () in
 144     if Filename.is_implicit path
 145     then Filename.concat cwd path
 146     else Filename.concat cwd (Filename.basename path)
 147   else
 148     path
 149 ;;
 150
 151 let nindex s c =
 152   try String.index s c
 153   with Not_found -> -1
 154 ;;
 155
 156 module Ne = struct
 157   type 'a t = | Res of 'a | Exn of exn;;
 158
 159   let res f arg =
 160     try Res (f arg)
 161     with exn -> Exn exn
 162   ;;
 163
 164   let clo fd f =
 165     try tempfailureretry Unix.close fd
 166     with exn -> f (exntos exn)
 167   ;;
 168
 169   let dup fd =
 170     try Res (tempfailureretry Unix.dup fd)
 171     with exn -> Exn exn
 172   ;;
 173
 174   let dup2 fd1 fd2 =
 175     try Res (tempfailureretry (Unix.dup2 fd1) fd2)
 176     with exn -> Exn exn
 177   ;;
 178 end;;
 179
 180 let getenvwithdef name def =
 181   try
 182     Sys.getenv name
 183   with Not_found -> def
 184 ;;