utils.ml

   1 type intel_mesa_quirks = bool;;
   2
   3 module E = struct
   4   let s = "";;
   5   let b = Bytes.empty;;
   6   let a = [||];;
   7 end;;
   8
   9 type platform = | Punknown | Plinux | Posx | Psun | Pbsd | Pcygwin;;
  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 spawn : string -> (Unix.file_descr * int) list -> int = "ml_spawn";;
  22 external platform : unit -> (platform * string array) = "ml_platform";;
  23
  24 let now = Unix.gettimeofday;;
  25 let platform, uname = platform ();;
  26 let dolog fmt = Format.ksprintf 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 spawn cmd fda =
  43   if platform = Pcygwin
  44   then failwith "spawn not implemented under cygwin yet"
  45   else spawn cmd fda;
  46 ;;
  47
  48 module Opaque :
  49 sig
  50   type t = private string
  51   val of_string : string -> t
  52   val to_string : t -> string
  53 end
  54   =
  55 struct
  56   type t = string
  57   let of_string s = s
  58   let to_string t = t
  59 end
  60 ;;
  61
  62 let (~<) = Opaque.of_string;;
  63 let (~>) = Opaque.to_string;;
  64
  65 let int_of_string_with_suffix s =
  66   let l = String.length s in
  67   let s1, shift =
  68     if l > 1
  69     then
  70       let suffix = Char.lowercase s.[l-1] in
  71       match suffix with
  72       | 'k' -> String.sub s 0 (l-1), 10
  73       | 'm' -> String.sub s 0 (l-1), 20
  74       | 'g' -> String.sub s 0 (l-1), 30
  75       | _ -> s, 0
  76     else s, 0
  77   in
  78   let n = int_of_string s1 in
  79   let m = n lsl shift in
  80   if m < 0 || m < n
  81   then error "value too large"
  82   else m
  83 ;;
  84
  85 let string_with_suffix_of_int n =
  86   if n = 0
  87   then "0"
  88   else
  89     let units = [(30, "G"); (20, "M"); (10, "K")] in
  90     let prettyint n =
  91       let rec loop s n =
  92         let h = n mod 1000 in
  93         let n = n / 1000 in
  94         if n = 0
  95         then string_of_int h ^ s
  96         else (
  97           let s = Printf.sprintf "_%03d%s" h s in
  98           loop s n
  99         )
 100       in
 101       loop E.s n
 102     in
 103     let rec find = function
 104       | [] -> prettyint n
 105       | (shift, suffix) :: rest ->
 106           if (n land ((1 lsl shift) - 1)) = 0
 107           then prettyint (n lsr shift) ^ suffix
 108           else find rest
 109     in
 110     find units
 111 ;;
 112
 113 let color_of_string s =
 114   Scanf.sscanf s "%d/%d/%d" (fun r g b ->
 115     (float r /. 256.0, float g /. 256.0, float b /. 256.0)
 116   )
 117 ;;
 118
 119 let color_to_string (r, g, b) =
 120   let r = truncate (r *. 256.0)
 121   and g = truncate (g *. 256.0)
 122   and b = truncate (b *. 256.0) in
 123   Printf.sprintf "%d/%d/%d" r g b
 124 ;;
 125
 126 let abspath path =
 127   if Filename.is_relative path
 128   then
 129     let cwd = Sys.getcwd () in
 130     if Filename.is_implicit path
 131     then Filename.concat cwd path
 132     else Filename.concat cwd (Filename.basename path)
 133   else
 134     path
 135 ;;
 136
 137 let nindex s c =
 138   try String.index s c
 139   with Not_found -> -1
 140 ;;
 141
 142 module Ne = struct
 143   let clo fd f =
 144     try tempfailureretry Unix.close fd
 145     with exn -> f @@ exntos exn
 146   ;;
 147 end;;
 148
 149 let getenvwithdef name def =
 150   match Sys.getenv name with
 151   | env -> env
 152   | exception Not_found -> def
 153 ;;
 154
 155 let newlinere = Str.regexp "[\r\n]";;
 156 let percentsre = Str.regexp "%s";;
 157 let whitere = Str.regexp "[ \t]";;
 158
 159 let unit () = ();;
 160
 161 let addchar s c =
 162   let b = Buffer.create (String.length s + 1) in
 163   Buffer.add_string b s;
 164   Buffer.add_char b c;
 165   Buffer.contents b;
 166 ;;
 167
 168 let btod b = if b then 1 else 0;;
 169
 170 let splitatspace s = let open String in
 171   match index s ' ' with
 172   | pos -> sub s 0 pos :: sub s (pos+1) (length s - pos - 1) :: []
 173   | exception Not_found -> [s]
 174 ;;
 175
 176 let boundastep h step =
 177   if step < 0
 178   then bound step ~-h 0
 179   else bound step 0 h
 180 ;;
 181
 182 let withoutlastutf8 s =
 183   let len = String.length s in
 184   if len = 0
 185   then s
 186   else
 187     let rec find pos =
 188       if pos = 0
 189       then pos
 190       else
 191         let b = Char.code s.[pos] in
 192         if b land 0b11000000 = 0b11000000
 193         then pos
 194         else find (pos-1)
 195     in
 196     let first =
 197       if Char.code s.[len-1] land 0x80 = 0
 198       then len-1
 199       else find (len-1)
 200     in
 201     String.sub s 0 first;
 202 ;;
 203
 204 let fdcontents fd =
 205   let l = 4096 in
 206   let b = Buffer.create l in
 207   let s = Bytes.create l in
 208   let rec loop () =
 209     let n = tempfailureretry (Unix.read fd s 0) l in
 210     if n = 0
 211     then Buffer.contents b
 212     else (
 213       Buffer.add_subbytes b s 0 n;
 214       loop ()
 215     )
 216   in
 217   loop ()
 218 ;;
 219
 220 let filecontents path =
 221   let fd = Unix.openfile path [Unix.O_RDONLY] 0o0 in
 222   match fdcontents fd with
 223   | (exception exn) ->
 224       error "failed to read contents of %s: %s" path @@ exntos exn
 225   | s ->
 226       Ne.clo fd @@ error "failed to close descriptor for %s: %s" path;
 227       s
 228 ;;
 229
 230 let getcmdoutput errfun cmd =
 231   let reperror fmt = Printf.kprintf errfun fmt in
 232   let clofail s e = error "failed to close %s: %s" s e in
 233   match Unix.pipe () with
 234   | (exception exn) ->
 235      reperror "pipe failed: %s" @@ exntos exn;
 236      E.s
 237   | (r, w) ->
 238      match spawn cmd [r, -1; w, 1] with
 239      | (exception exn) ->
 240         reperror "failed to execute %S: %s" cmd @@ exntos exn;
 241         E.s
 242      | pid ->
 243         Ne.clo w @@ clofail "write end of the pipe";
 244         let s =
 245           match Unix.waitpid [] pid with
 246           | (exception exn) ->
 247              reperror "waitpid on %S %d failed: %s" cmd pid @@ exntos exn;
 248              E.s
 249           | _pid, Unix.WEXITED 0 ->
 250              begin
 251                match fdcontents r with
 252                | (exception exn) ->
 253                   reperror "failed to read output of %S: %s" cmd @@ exntos exn;
 254                   E.s
 255                | s ->
 256                   let l = String.length s in
 257                   if l > 0 && s.[l-1] = '\n'
 258                   then String.sub s 0 (l-1)
 259                   else s
 260              end;
 261           | _pid, Unix.WEXITED n ->
 262              reperror "%S exited with error code %d" cmd n;
 263              E.s
 264           | _pid, Unix.WSIGNALED n ->
 265              reperror "%S was killed with signal %d" cmd n;
 266              E.s
 267           | _pid, Unix.WSTOPPED n ->
 268              reperror "%S was stopped by signal %d" cmd n;
 269              E.s
 270         in
 271         Ne.clo r @@ clofail "read end of the pipe";
 272         s
 273 ;;
 274
 275 let geturl =
 276   let re = Str.regexp {|.*\(\(https?\|ftp\|mailto\|file\)://[^ ]+\).*|} in
 277   fun s ->
 278     if Str.string_match re s 0
 279     then Str.matched_group 1 s
 280     else E.s
 281 ;;