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.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 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 percent = Str.regexp "%s"
 117   let whitespace = Str.regexp "[ \t]"
 118 end
 119
 120 let addchar s c =
 121   let b = Buffer.create (String.length s + 1) in
 122   Buffer.add_string b s;
 123   Buffer.add_char b c;
 124   Buffer.contents b
 125
 126 let btod b = if b then 1 else 0
 127
 128 let splitatchar s c = let open String in
 129                       match index s c with
 130                       | pos -> sub s 0 pos, sub s (pos+1) (length s - pos - 1)
 131                       | exception Not_found -> s, E.s
 132
 133 let boundastep h step =
 134   if step < 0
 135   then bound step ~-h 0
 136   else bound step 0 h
 137
 138 let withoutlastutf8 s =
 139   let len = String.length s in
 140   if len = 0
 141   then s
 142   else
 143     let rec find pos =
 144       if pos = 0
 145       then pos
 146       else
 147         let b = Char.code s.[pos] in
 148         if b land 0b11000000 = 0b11000000
 149         then pos
 150         else find (pos-1)
 151     in
 152     let first =
 153       if Char.code s.[len-1] land 0x80 = 0
 154       then len-1
 155       else find (len-1)
 156     in
 157     String.sub s 0 first
 158
 159 let fdcontents fd =
 160   let l = 4096 in
 161   let b = Buffer.create l in
 162   let s = Bytes.create l in
 163   let rec loop () =
 164     let n = tempfailureretry (Unix.read fd s 0) l in
 165     if n = 0
 166     then Buffer.contents b
 167     else (
 168       Buffer.add_subbytes b s 0 n;
 169       loop ()
 170     )
 171   in
 172   loop ()
 173
 174 let filecontents path =
 175   let fd = Unix.openfile path [Unix.O_RDONLY] 0o0 in
 176   match fdcontents fd with
 177   | exception exn ->
 178      error "failed to read contents of %s: %s" path @@ exntos exn
 179   | s ->
 180      Ne.clo fd @@ error "failed to close descriptor for %s: %s" path;
 181      s
 182
 183 let getcmdoutput errfun cmd =
 184   let reperror fmt = Printf.kprintf errfun fmt in
 185   let clofail s e = error "failed to close %s: %s" s e in
 186   match Unix.pipe () with
 187   | exception exn ->
 188      reperror "pipe failed: %s" @@ exntos exn;
 189      E.s
 190   | (r, w) ->
 191      match spawn cmd [r, -1; w, 1] with
 192      | exception exn ->
 193         reperror "failed to execute %S: %s" cmd @@ exntos exn;
 194         E.s
 195      | pid ->
 196         Ne.clo w @@ clofail "write end of the pipe";
 197         let s =
 198           match Unix.waitpid [] pid with
 199           | exception exn ->
 200              reperror "waitpid on %S %d failed: %s" cmd pid @@ exntos exn;
 201              E.s
 202           | _pid, Unix.WEXITED 0 ->
 203              begin
 204                match fdcontents r with
 205                | exception exn ->
 206                   reperror "failed to read output of %S: %s" cmd @@ exntos exn;
 207                   E.s
 208                | s ->
 209                   let l = String.length s in
 210                   if l > 0 && s.[l-1] = '\n'
 211                   then String.sub s 0 (l-1)
 212                   else s
 213              end;
 214           | _pid, Unix.WEXITED n ->
 215              reperror "%S exited with error code %d" cmd n;
 216              E.s
 217           | _pid, Unix.WSIGNALED n ->
 218              reperror "%S was killed with signal %d" cmd n;
 219              E.s
 220           | _pid, Unix.WSTOPPED n ->
 221              reperror "%S was stopped by signal %d" cmd n;
 222              E.s
 223         in
 224         Ne.clo r @@ clofail "read end of the pipe";
 225         s
 226
 227 let geturl =
 228   let re = Str.regexp {|.*\(\(https?\|ftp\|mailto\|file\)://[^ ]+\).*|} in
 229   fun s -> if Str.string_match re s 0
 230            then Str.matched_group 1 s
 231            else E.s
 232
 233 let substratis s pos subs =
 234   let subslen = String.length subs in
 235   if String.length s - pos >= subslen
 236   then
 237     let rec cmp i = i = subslen || (s.[pos+i] = subs.[i]) && cmp (i+1)
 238     in cmp 0
 239   else false
 240
 241 let w8 = Bytes.set_uint8
 242 let r8 = Bytes.get_uint8
 243 let w16 = Bytes.set_uint16_le
 244 let r16 = Bytes.get_uint16_le
 245 let r16s = Bytes.get_int16_le
 246 let w32 s pos i = w16 s pos i; w16 s (pos+2) (i lsr 16)
 247 let r32 s pos = ((r16 s (pos+2)) lsl 16) lor (r16 s pos)
 248 let r32s s pos = Bytes.get_int32_le s pos |> Int32.to_int
 249
 250 let vlogf = ref ignore
 251 let vlog fmt = Printf.kprintf !vlogf fmt
 252
 253 let pipef ?(closew=true) cap f cmd =
 254   match Unix.pipe () with
 255   | exception exn -> dolog "%s cannot create pipe: %S" cap @@ exntos exn
 256   | (r, w) ->
 257      begin match spawn cmd [r, 0; w, -1] with
 258      | exception exn -> dolog "%s: cannot execute %S: %s" cap cmd @@ exntos exn
 259      | _pid -> f w
 260      end;
 261      Ne.clo r (dolog "%s failed to close r: %s" cap);
 262      if closew then Ne.clo w (dolog "%s failed to close w: %s" cap)
 263
 264 let selstring selcmd s =
 265   pipef "selstring" (fun w ->
 266       try
 267         let l = String.length s in
 268         let bytes = Bytes.unsafe_of_string s in
 269         let n = tempfailureretry (Unix.write w bytes 0) l in
 270         if n != l
 271         then dolog "failed to write %d characters to sel pipe, wrote %d" l n;
 272       with exn -> dolog "failed to write to sel pipe: %s" @@ exntos exn
 273     ) selcmd