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