utils.ml

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