utils.ml

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