utils.ml

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