utils.ml

   1 exception Quit
   2
   3 module E = struct
   4   let s = ""
   5   let b = Bytes.empty
   6   let a = [||]
   7   let j = (0, 0.0, 0.0)
   8 end
   9
  10 let tempfailureretry f a =
  11   let rec g () =
  12     try f a with Unix.Unix_error (Unix.EINTR, _, _) -> g ()
  13   in g ()
  14
  15 external spawn : string -> (Unix.file_descr * int) list -> int = "ml_spawn"
  16 external hasdata : Unix.file_descr -> bool = "ml_hasdata"
  17
  18 let now = Unix.gettimeofday
  19 let dologf = ref prerr_endline
  20 let dolog fmt = Printf.ksprintf !dologf fmt
  21
  22 let exntos = function
  23   | Unix.Unix_error (e, s, a) ->
  24      Printf.sprintf "%s(%s) : %s (%d)" s a (Unix.error_message e) (Obj.magic e)
  25   | exn -> Printexc.to_string exn
  26
  27 let onoffs = function | true -> "on" | false -> "off"
  28
  29 let error fmt = Printf.ksprintf 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 module Opaque : sig
  38   type t = private string
  39   val of_string : string -> t
  40   val to_string : t -> string
  41 end = struct
  42   type t = string
  43   let of_string s = s
  44   let to_string t = t
  45 end
  46
  47 let int_of_string_with_suffix s =
  48   let l = String.length s in
  49   let s1, shift =
  50     if l > 1
  51     then
  52       let p = l-1 in
  53       match s.[p] with
  54       | 'k' | 'K' -> String.sub s 0 p, 10
  55       | 'm' | 'M' -> String.sub s 0 p, 20
  56       | 'g' | 'G' -> String.sub s 0 p, 30
  57       | _ -> s, 0
  58     else s, 0
  59   in
  60   let n = int_of_string s1 in
  61   let m = n lsl shift in
  62   if m < 0 || m < n
  63   then error "value too large"
  64   else m
  65
  66 let string_with_suffix_of_int n =
  67   let rec find = function
  68     | [] -> Printf.sprintf "%#d" n
  69     | (shift, suffix) :: rest ->
  70        if (n land ((1 lsl shift) - 1)) = 0
  71        then Printf.sprintf "%#d%c" (n lsr shift) suffix
  72        else find rest
  73   in
  74   if n = 0 then "0" else find [(30, 'G'); (20, 'M'); (10, 'K')]
  75
  76 let color_of_string s =
  77   Scanf.sscanf s "%d/%d/%d" (fun r g b ->
  78       (float r /. 255.0, float g /. 255.0, float b /. 255.0)
  79     )
  80
  81 let rgba_of_string s =
  82   let c c = float c /. 255.0 in
  83   Scanf.sscanf s "%d/%d/%d/%d" (fun r g b a -> c r, c g, c b, c a)
  84
  85 let color_to_string (r, g, b) =
  86   let c c = c *. 255.0 |> truncate in
  87   Printf.sprintf "%d/%d/%d" (c r) (c g) (c b)
  88
  89 let rgba_to_string (r, g, b, a) =
  90   let c c = c *. 255.0 |> truncate in
  91   Printf.sprintf "%d/%d/%d/%d" (c r) (c g) (c b) (c a)
  92
  93 let abspath path =
  94   if Filename.is_relative path
  95   then
  96     let cwd = Sys.getcwd () in
  97     if Filename.is_implicit path
  98     then Filename.concat cwd path
  99     else Filename.concat cwd (Filename.basename path)
 100   else path
 101
 102 module Ne = struct
 103   let index s c = try String.index s c with Not_found -> -1
 104   let clo fd f =
 105     try tempfailureretry Unix.close fd
 106     with exn -> f @@ exntos exn
 107 end
 108
 109 let getenvdef name def =
 110   match Sys.getenv name with
 111   | env -> env
 112   | exception Not_found -> def
 113
 114 module Re = struct
 115   let crlf = Str.regexp "[\r\n]"
 116   let percents = Str.regexp "%s"
 117   let percentp = Str.regexp "%p"
 118   let whitespace = Str.regexp "[ \t]"
 119 end
 120
 121 let addchar s c =
 122   let b = Buffer.create (String.length s + 1) in
 123   Buffer.add_string b s;
 124   Buffer.add_char b c;
 125   Buffer.contents b
 126
 127 let btod b = if b then 1 else 0
 128
 129 let splitatchar s c = let open String in
 130                       match index s c with
 131                       | pos -> sub s 0 pos, sub s (pos+1) (length s - pos - 1)
 132                       | exception Not_found -> s, E.s
 133
 134 let boundastep h step =
 135   if step < 0
 136   then bound step ~-h 0
 137   else bound step 0 h
 138
 139 let withoutlastutf8 s =
 140   let len = String.length s in
 141   if len = 0
 142   then s
 143   else
 144     let rec find pos =
 145       if pos = 0
 146       then pos
 147       else
 148         let b = Char.code s.[pos] in
 149         if b land 0b11000000 = 0b11000000
 150         then pos
 151         else find (pos-1)
 152     in
 153     let first =
 154       if Char.code s.[len-1] land 0x80 = 0
 155       then len-1
 156       else find (len-1)
 157     in
 158     String.sub s 0 first
 159
 160 let fdcontents fd =
 161   let l = 4096 in
 162   let b = Buffer.create l in
 163   let s = Bytes.create l in
 164   let rec loop () =
 165     let n = tempfailureretry (Unix.read fd s 0) l in
 166     if n = 0
 167     then Buffer.contents b
 168     else (
 169       Buffer.add_subbytes b s 0 n;
 170       loop ()
 171     )
 172   in
 173   loop ()
 174
 175 let filecontents path =
 176   let fd = Unix.openfile path [Unix.O_RDONLY] 0o0 in
 177   match fdcontents fd with
 178   | exception exn ->
 179      error "failed to read contents of %s: %s" path @@ exntos exn
 180   | s ->
 181      Ne.clo fd @@ error "failed to close descriptor for %s: %s" path;
 182      s
 183
 184 let getcmdoutput errfun cmd =
 185   let reperror fmt = Printf.ksprintf errfun fmt in
 186   let clofail s e = error "failed to close %s: %s" s e in
 187   match Unix.pipe () with
 188   | exception exn ->
 189      reperror "pipe failed: %s" @@ exntos exn;
 190      E.s
 191   | (r, w) ->
 192      match spawn cmd [r, -1; w, 1] with
 193      | exception exn ->
 194         reperror "failed to execute %S: %s" cmd @@ exntos exn;
 195         E.s
 196      | pid ->
 197         Ne.clo w @@ clofail "write end of the pipe";
 198         let s =
 199           match Unix.waitpid [] pid with
 200           | exception exn ->
 201              reperror "waitpid on %S %d failed: %s" cmd pid @@ exntos exn;
 202              E.s
 203           | _pid, Unix.WEXITED 0 ->
 204              begin
 205                match fdcontents r with
 206                | exception exn ->
 207                   reperror "failed to read output of %S: %s" cmd @@ exntos exn;
 208                   E.s
 209                | s ->
 210                   let l = String.length s in
 211                   if l > 0 && s.[l-1] = '\n'
 212                   then String.sub s 0 (l-1)
 213                   else s
 214              end;
 215           | _pid, Unix.WEXITED n ->
 216              reperror "%S exited with error code %d" cmd n;
 217              E.s
 218           | _pid, Unix.WSIGNALED n ->
 219              reperror "%S was killed with signal %d" cmd n;
 220              E.s
 221           | _pid, Unix.WSTOPPED n ->
 222              reperror "%S was stopped by signal %d" cmd n;
 223              E.s
 224         in
 225         Ne.clo r @@ clofail "read end of the pipe";
 226         s
 227
 228 let geturl =
 229   let re = Str.regexp {|.*\(\(https?\|ftp\|mailto\|file\)://[^ ]+\).*|} in
 230   fun s -> if Str.string_match re s 0
 231            then Str.matched_group 1 s
 232            else E.s
 233
 234 let substratis s pos subs =
 235   let subslen = String.length subs in
 236   if String.length s - pos >= subslen
 237   then
 238     let rec cmp i = i = subslen || (s.[pos+i] = subs.[i]) && cmp (i+1)
 239     in cmp 0
 240   else false
 241
 242 let w8 = Bytes.set_uint8
 243 let r8 = Bytes.get_uint8
 244 let w16 = Bytes.set_uint16_le
 245 let r16 = Bytes.get_uint16_le
 246 let r16s = Bytes.get_int16_le
 247 let w32 s pos i = w16 s pos i; w16 s (pos+2) (i lsr 16)
 248 let r32 s pos = ((r16 s (pos+2)) lsl 16) lor (r16 s pos)
 249 let r32s s pos = Bytes.get_int32_le s pos |> Int32.to_int
 250
 251 let vlogf = ref ignore
 252 let vlog fmt = Printf.ksprintf !vlogf fmt
 253
 254 let pipef ?(closew=true) cap f cmd =
 255   match Unix.pipe () with
 256   | exception exn -> dolog "%s cannot create pipe: %S" cap @@ exntos exn
 257   | (r, w) ->
 258      begin match spawn cmd [r, 0; w, -1] with
 259      | exception exn -> dolog "%s: cannot execute %S: %s" cap cmd @@ exntos exn
 260      | _pid -> f w
 261      end;
 262      Ne.clo r (dolog "%s failed to close r: %s" cap);
 263      if closew then Ne.clo w (dolog "%s failed to close w: %s" cap)
 264
 265 let selstring selcmd s =
 266   pipef "selstring" (fun w ->
 267       try
 268         let l = String.length s in
 269         let bytes = Bytes.unsafe_of_string s in
 270         let n = tempfailureretry (Unix.write w bytes 0) l in
 271         if n != l
 272         then dolog "failed to write %d characters to sel pipe, wrote %d" l n;
 273       with exn -> dolog "failed to write to sel pipe: %s" @@ exntos exn
 274     ) selcmd