utils.ml

   1 module E = struct
   2   let s = "";;
   3   let b = Bytes.empty;;
   4   let a = [||];;
   5 end;;
   6
   7 type platform = | Punknown | Plinux | Posx | Psun | Pbsd | Pcygwin;;
   8
   9 let asciilower = let auld = Char.code 'A' - Char.code 'a' in
  10                  function
  11                  | ('A'..'Z') as c -> Char.code c - auld |> Char.chr
  12                  | c -> c
  13 ;;
  14
  15 let tempfailureretry f a =
  16   let rec g () =
  17     try f a with Unix.Unix_error (Unix.EINTR, _, _) -> g ()
  18   in g ()
  19 ;;
  20
  21 external cloexec : Unix.file_descr -> unit = "ml_cloexec";;
  22 external hasdata : Unix.file_descr -> bool = "ml_hasdata";;
  23 external toutf8 : int -> string = "ml_keysymtoutf8";;
  24 external mbtoutf8 : string -> string = "ml_mbtoutf8";;
  25 external spawn : string -> (Unix.file_descr * int) list -> int = "ml_spawn";;
  26 external platform : unit -> (platform * string array) = "ml_platform";;
  27
  28 let now = Unix.gettimeofday;;
  29 let platform, uname = platform ();;
  30 let dolog fmt = Format.ksprintf prerr_endline fmt;;
  31
  32 let exntos = function
  33   | Unix.Unix_error (e, s, a) ->
  34      Printf.sprintf "%s(%s) : %s (%d)"
  35                     s a (Unix.error_message e) (Obj.magic e)
  36   | exn -> Printexc.to_string exn
  37 ;;
  38
  39 let error fmt = Printf.kprintf (fun s -> failwith s) fmt;;
  40
  41 module IntSet = Set.Make (struct type t = int let compare = (-) end);;
  42
  43 let emptystr s = String.length s = 0;;
  44 let nonemptystr s = String.length s > 0;;
  45 let bound v minv maxv = max minv (min maxv v);;
  46
  47 let spawn cmd fda =
  48   if platform = Pcygwin
  49   then failwith "spawn not implemented under cygwin yet"
  50   else spawn cmd fda;
  51 ;;
  52
  53 module Opaque :
  54 sig
  55   type t = private string
  56   val of_string : string -> t
  57   val to_string : t -> string
  58 end
  59   =
  60   struct
  61     type t = string
  62     let of_string s = s
  63     let to_string t = t
  64   end
  65 ;;
  66
  67 let (~<) = Opaque.of_string;;
  68 let (~>) = Opaque.to_string;;
  69
  70 let int_of_string_with_suffix s =
  71   let l = String.length s in
  72   let s1, shift =
  73     if l > 1
  74     then
  75       let p = l-1 in
  76       match s.[p] with
  77       | 'k' | 'K' -> String.sub s 0 p, 10
  78       | 'm' | 'M' -> String.sub s 0 p, 20
  79       | 'g' | 'G' -> String.sub s 0 p, 30
  80       | _ -> s, 0
  81     else s, 0
  82   in
  83   let n = int_of_string s1 in
  84   let m = n lsl shift in
  85   if m < 0 || m < n
  86   then error "value too large"
  87   else m
  88 ;;
  89
  90 let string_with_suffix_of_int n =
  91   if n = 0
  92   then "0"
  93   else
  94     let units = [(30, "G"); (20, "M"); (10, "K")] in
  95     let prettyint n =
  96       let rec loop s n =
  97         let h = n mod 1000 in
  98         let n = n / 1000 in
  99         if n = 0
 100         then string_of_int h ^ s
 101         else (
 102           let s = Printf.sprintf "_%03d%s" h s in
 103           loop s n
 104         )
 105       in
 106       loop E.s n
 107     in
 108     let rec find = function
 109       | [] -> prettyint n
 110       | (shift, suffix) :: rest ->
 111          if (n land ((1 lsl shift) - 1)) = 0
 112          then prettyint (n lsr shift) ^ suffix
 113          else find rest
 114     in
 115     find units
 116 ;;
 117
 118 let color_of_string s =
 119   Scanf.sscanf s "%d/%d/%d" (fun r g b ->
 120                  (float r /. 255.0, float g /. 255.0, float b /. 255.0)
 121                )
 122 ;;
 123
 124 let rgba_of_string s =
 125   Scanf.sscanf
 126     s "%d/%d/%d/%d" (fun r g b a ->
 127       (float r /. 255.0, float g /. 255.0, float b /. 255.0, float a /. 255.0)
 128     )
 129 ;;
 130
 131 let color_to_string (r, g, b) =
 132   let r = truncate (r *. 255.0)
 133   and g = truncate (g *. 255.0)
 134   and b = truncate (b *. 255.0) in
 135   Printf.sprintf "%d/%d/%d" r g b
 136 ;;
 137
 138 let rgba_to_string (r, g, b, a) =
 139   let r = truncate (r *. 255.0)
 140   and g = truncate (g *. 255.0)
 141   and b = truncate (b *. 255.0)
 142   and a = truncate (a *. 255.0) in
 143   Printf.sprintf "%d/%d/%d/%d" r g b a
 144 ;;
 145
 146 let abspath path =
 147   if Filename.is_relative path
 148   then
 149     let cwd = Sys.getcwd () in
 150     if Filename.is_implicit path
 151     then Filename.concat cwd path
 152     else Filename.concat cwd (Filename.basename path)
 153   else
 154     path
 155 ;;
 156
 157 let nindex s c =
 158   try String.index s c
 159   with Not_found -> -1
 160 ;;
 161
 162 module Ne = struct
 163   let clo fd f =
 164     try tempfailureretry Unix.close fd
 165     with exn -> f @@ exntos exn
 166   ;;
 167 end;;
 168
 169 let getenvwithdef name def =
 170   match Sys.getenv name with
 171   | env -> env
 172   | exception Not_found -> def
 173 ;;
 174
 175 let newlinere = Str.regexp "[\r\n]";;
 176 let percentsre = Str.regexp "%s";;
 177 let whitere = Str.regexp "[ \t]";;
 178
 179 let unit () = ();;
 180
 181 let addchar s c =
 182   let b = Buffer.create (String.length s + 1) in
 183   Buffer.add_string b s;
 184   Buffer.add_char b c;
 185   Buffer.contents b;
 186 ;;
 187
 188 let btod b = if b then 1 else 0;;
 189
 190 let splitatchar s c = let open String in
 191                       match index s c with
 192                       | pos -> sub s 0 pos, sub s (pos+1) (length s - pos - 1)
 193                       | exception Not_found -> s, E.s
 194 ;;
 195
 196 let boundastep h step =
 197   if step < 0
 198   then bound step ~-h 0
 199   else bound step 0 h
 200 ;;
 201
 202 let withoutlastutf8 s =
 203   let len = String.length s in
 204   if len = 0
 205   then s
 206   else
 207     let rec find pos =
 208       if pos = 0
 209       then pos
 210       else
 211         let b = Char.code s.[pos] in
 212         if b land 0b11000000 = 0b11000000
 213         then pos
 214         else find (pos-1)
 215     in
 216     let first =
 217       if Char.code s.[len-1] land 0x80 = 0
 218       then len-1
 219       else find (len-1)
 220     in
 221     String.sub s 0 first;
 222 ;;
 223
 224 let fdcontents fd =
 225   let l = 4096 in
 226   let b = Buffer.create l in
 227   let s = Bytes.create l in
 228   let rec loop () =
 229     let n = tempfailureretry (Unix.read fd s 0) l in
 230     if n = 0
 231     then Buffer.contents b
 232     else (
 233       Buffer.add_subbytes b s 0 n;
 234       loop ()
 235     )
 236   in
 237   loop ()
 238 ;;
 239
 240 let filecontents path =
 241   let fd = Unix.openfile path [Unix.O_RDONLY] 0o0 in
 242   match fdcontents fd with
 243   | exception exn ->
 244      error "failed to read contents of %s: %s" path @@ exntos exn
 245   | s ->
 246      Ne.clo fd @@ error "failed to close descriptor for %s: %s" path;
 247      s
 248 ;;
 249
 250 let getcmdoutput errfun cmd =
 251   let reperror fmt = Printf.kprintf errfun fmt in
 252   let clofail s e = error "failed to close %s: %s" s e in
 253   match Unix.pipe () with
 254   | exception exn ->
 255      reperror "pipe failed: %s" @@ exntos exn;
 256      E.s
 257   | (r, w) ->
 258      match spawn cmd [r, -1; w, 1] with
 259      | exception exn ->
 260         reperror "failed to execute %S: %s" cmd @@ exntos exn;
 261         E.s
 262      | pid ->
 263         Ne.clo w @@ clofail "write end of the pipe";
 264         let s =
 265           match Unix.waitpid [] pid with
 266           | exception exn ->
 267              reperror "waitpid on %S %d failed: %s" cmd pid @@ exntos exn;
 268              E.s
 269           | _pid, Unix.WEXITED 0 ->
 270              begin
 271                match fdcontents r with
 272                | exception exn ->
 273                   reperror "failed to read output of %S: %s" cmd @@ exntos exn;
 274                   E.s
 275                | s ->
 276                   let l = String.length s in
 277                   if l > 0 && s.[l-1] = '\n'
 278                   then String.sub s 0 (l-1)
 279                   else s
 280              end;
 281           | _pid, Unix.WEXITED n ->
 282              reperror "%S exited with error code %d" cmd n;
 283              E.s
 284           | _pid, Unix.WSIGNALED n ->
 285              reperror "%S was killed with signal %d" cmd n;
 286              E.s
 287           | _pid, Unix.WSTOPPED n ->
 288              reperror "%S was stopped by signal %d" cmd n;
 289              E.s
 290         in
 291         Ne.clo r @@ clofail "read end of the pipe";
 292         s
 293 ;;
 294
 295 let geturl =
 296   let re = Str.regexp {|.*\(\(https?\|ftp\|mailto\|file\)://[^ ]+\).*|} in
 297   fun s ->
 298   if Str.string_match re s 0
 299   then Str.matched_group 1 s
 300   else E.s
 301 ;;
 302
 303 let substratis s pos subs =
 304   let subslen = String.length subs in
 305   if String.length s - pos >= subslen
 306   then
 307     let rec cmp i = i = subslen || (s.[pos+i] = subs.[i]) && cmp (i+1)
 308     in cmp 0
 309   else false
 310 ;;
 311
 312 let w8 s pos i = Bytes.set s pos (Char.chr (i land 0xff));;
 313 let r8 s pos = Char.code (Bytes.get s pos);;
 314
 315 let w16 s pos i =
 316   w8 s pos i;
 317   w8 s (pos+1) (i lsr 8)
 318 ;;
 319
 320 let w32 s pos i =
 321   w16 s pos i;
 322   w16 s (pos+2) (i lsr 16)
 323 ;;
 324
 325 let r16 s pos =
 326   let rb pos1 = Char.code (Bytes.get s (pos + pos1)) in
 327   (rb 0) lor ((rb 1) lsl 8)
 328 ;;
 329
 330 let r16s s pos =
 331   let i = r16 s pos in
 332   i - ((i land 0x8000) lsl 1)
 333 ;;
 334
 335 let r32 s pos =
 336   let rb pos1 = Char.code (Bytes.get s (pos + pos1)) in
 337   let l = (rb 0) lor ((rb 1) lsl 8)
 338   and u = (rb 2) lor ((rb 3) lsl 8) in
 339   (u lsl 16) lor l
 340 ;;
 341
 342 let r32s s pos =
 343   let rb pos1 = Char.code (Bytes.get s (pos + pos1)) in
 344   let v0 = rb 0 and v1 = rb 1 and v2 = rb 2 and v3 = rb 3 in
 345   let v = v0 lor (v1 lsl 8) lor (v2 lsl 16) lor (v3 lsl 24) in
 346   if v3 land 0x80 = 0 then
 347     v
 348   else
 349     (v - (1 lsl 32))
 350 ;;
 351
 352 let vlog fmt = Format.ksprintf ignore fmt;;