utils.ml

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