Consistency
[llpp.git] / utils.ml
bloba7d05aaa38d08f82bf57ea62f4e95772165ba844
1 exception Quit;;
3 module E = struct
4 let s = "";;
5 let b = Bytes.empty;;
6 let a = [||];;
7 end;;
9 type platform = | Punknown | Plinux | Pmacos | Pbsd;;
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
17 let tempfailureretry f a =
18 let rec g () =
19 try f a with Unix.Unix_error (Unix.EINTR, _, _) -> g ()
20 in g ()
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";;
31 let now = Unix.gettimeofday;;
32 let platform, uname = platform ();;
33 let dolog fmt = Format.ksprintf prerr_endline fmt;;
35 let exntos = function
36 | Unix.Unix_error (e, s, a) ->
37 Printf.sprintf "%s(%s) : %s (%d)"
38 s a (Unix.error_message e) (Obj.magic e)
39 | exn -> Printexc.to_string exn
42 let error fmt = Printf.kprintf (fun s -> failwith s) fmt;;
44 module IntSet = Set.Make (struct type t = int let compare = (-) end);;
46 let emptystr s = String.length s = 0;;
47 let nonemptystr s = String.length s > 0;;
48 let bound v minv maxv = max minv (min maxv v);;
50 module Opaque : sig
51 type t = private string
52 val of_string : string -> t
53 val to_string : t -> string
54 end = struct
55 type t = string
56 let of_string s = s
57 let to_string t = t
58 end
61 let (~<) = Opaque.of_string;;
62 let (~>) = Opaque.to_string;;
64 let int_of_string_with_suffix s =
65 let l = String.length s in
66 let s1, shift =
67 if l > 1
68 then
69 let p = l-1 in
70 match s.[p] with
71 | 'k' | 'K' -> String.sub s 0 p, 10
72 | 'm' | 'M' -> String.sub s 0 p, 20
73 | 'g' | 'G' -> String.sub s 0 p, 30
74 | _ -> s, 0
75 else s, 0
77 let n = int_of_string s1 in
78 let m = n lsl shift in
79 if m < 0 || m < n
80 then error "value too large"
81 else m
84 let string_with_suffix_of_int n =
85 if n = 0
86 then "0"
87 else
88 let units = [(30, "G"); (20, "M"); (10, "K")] in
89 let prettyint n =
90 let rec loop s n =
91 let h = n mod 1000 in
92 let n = n / 1000 in
93 if n = 0
94 then string_of_int h ^ s
95 else loop (Printf.sprintf "_%03d%s" h s) n
97 loop E.s n
99 let rec find = function
100 | [] -> prettyint n
101 | (shift, suffix) :: rest ->
102 if (n land ((1 lsl shift) - 1)) = 0
103 then prettyint (n lsr shift) ^ suffix
104 else find rest
106 find units
109 let color_of_string s =
110 Scanf.sscanf s "%d/%d/%d" (fun r g b ->
111 (float r /. 255.0, float g /. 255.0, float b /. 255.0)
115 let rgba_of_string s =
116 Scanf.sscanf
117 s "%d/%d/%d/%d" (fun r g b a ->
118 (float r /. 255.0, float g /. 255.0, float b /. 255.0, float a /. 255.0)
122 let color_to_string (r, g, b) =
123 let r = truncate (r *. 255.0)
124 and g = truncate (g *. 255.0)
125 and b = truncate (b *. 255.0) in
126 Printf.sprintf "%d/%d/%d" r g b
129 let rgba_to_string (r, g, b, a) =
130 let r = truncate (r *. 255.0)
131 and g = truncate (g *. 255.0)
132 and b = truncate (b *. 255.0)
133 and a = truncate (a *. 255.0) in
134 Printf.sprintf "%d/%d/%d/%d" r g b a
137 let abspath path =
138 if Filename.is_relative path
139 then
140 let cwd = Sys.getcwd () in
141 if Filename.is_implicit path
142 then Filename.concat cwd path
143 else Filename.concat cwd (Filename.basename path)
144 else path
147 module Ne = struct
148 let index s c = try String.index s c with Not_found -> -1;;
149 let clo fd f =
150 try tempfailureretry Unix.close fd
151 with exn -> f @@ exntos exn
153 end;;
155 let getenvwithdef name def =
156 match Sys.getenv name with
157 | env -> env
158 | exception Not_found -> def
161 module Re = struct
162 let crlf = Str.regexp "[\r\n]";;
163 let percent = Str.regexp "%s";;
164 let whitespace = Str.regexp "[ \t]";;
165 end;;
167 let unit () = ();;
169 let addchar s c =
170 let b = Buffer.create (String.length s + 1) in
171 Buffer.add_string b s;
172 Buffer.add_char b c;
173 Buffer.contents b;
176 let btod b = if b then 1 else 0;;
178 let splitatchar s c = let open String in
179 match index s c with
180 | pos -> sub s 0 pos, sub s (pos+1) (length s - pos - 1)
181 | exception Not_found -> s, E.s
184 let boundastep h step =
185 if step < 0
186 then bound step ~-h 0
187 else bound step 0 h
190 let withoutlastutf8 s =
191 let len = String.length s in
192 if len = 0
193 then s
194 else
195 let rec find pos =
196 if pos = 0
197 then pos
198 else
199 let b = Char.code s.[pos] in
200 if b land 0b11000000 = 0b11000000
201 then pos
202 else find (pos-1)
204 let first =
205 if Char.code s.[len-1] land 0x80 = 0
206 then len-1
207 else find (len-1)
209 String.sub s 0 first;
212 let fdcontents fd =
213 let l = 4096 in
214 let b = Buffer.create l in
215 let s = Bytes.create l in
216 let rec loop () =
217 let n = tempfailureretry (Unix.read fd s 0) l in
218 if n = 0
219 then Buffer.contents b
220 else (
221 Buffer.add_subbytes b s 0 n;
222 loop ()
225 loop ()
228 let filecontents path =
229 let fd = Unix.openfile path [Unix.O_RDONLY] 0o0 in
230 match fdcontents fd with
231 | exception exn ->
232 error "failed to read contents of %s: %s" path @@ exntos exn
233 | s ->
234 Ne.clo fd @@ error "failed to close descriptor for %s: %s" path;
238 let getcmdoutput errfun cmd =
239 let reperror fmt = Printf.kprintf errfun fmt in
240 let clofail s e = error "failed to close %s: %s" s e in
241 match Unix.pipe () with
242 | exception exn ->
243 reperror "pipe failed: %s" @@ exntos exn;
245 | (r, w) ->
246 match spawn cmd [r, -1; w, 1] with
247 | exception exn ->
248 reperror "failed to execute %S: %s" cmd @@ exntos exn;
250 | pid ->
251 Ne.clo w @@ clofail "write end of the pipe";
252 let s =
253 match Unix.waitpid [] pid with
254 | exception exn ->
255 reperror "waitpid on %S %d failed: %s" cmd pid @@ exntos exn;
257 | _pid, Unix.WEXITED 0 ->
258 begin
259 match fdcontents r with
260 | exception exn ->
261 reperror "failed to read output of %S: %s" cmd @@ exntos exn;
263 | s ->
264 let l = String.length s in
265 if l > 0 && s.[l-1] = '\n'
266 then String.sub s 0 (l-1)
267 else s
268 end;
269 | _pid, Unix.WEXITED n ->
270 reperror "%S exited with error code %d" cmd n;
272 | _pid, Unix.WSIGNALED n ->
273 reperror "%S was killed with signal %d" cmd n;
275 | _pid, Unix.WSTOPPED n ->
276 reperror "%S was stopped by signal %d" cmd n;
279 Ne.clo r @@ clofail "read end of the pipe";
283 let geturl =
284 let re = Str.regexp {|.*\(\(https?\|ftp\|mailto\|file\)://[^ ]+\).*|} in
285 fun s -> if Str.string_match re s 0
286 then Str.matched_group 1 s
287 else E.s
290 let substratis s pos subs =
291 let subslen = String.length subs in
292 if String.length s - pos >= subslen
293 then
294 let rec cmp i = i = subslen || (s.[pos+i] = subs.[i]) && cmp (i+1)
295 in cmp 0
296 else false
299 let w8 s pos i = Bytes.set s pos (Char.chr (i land 0xff));;
300 let r8 s pos = Char.code (Bytes.get s pos);;
302 let w16 s pos i =
303 w8 s pos i;
304 w8 s (pos+1) (i lsr 8)
307 let w32 s pos i =
308 w16 s pos i;
309 w16 s (pos+2) (i lsr 16)
312 let r16 s pos =
313 let rb pos1 = Char.code (Bytes.get s (pos + pos1)) in
314 (rb 0) lor ((rb 1) lsl 8)
317 let r16s s pos =
318 let i = r16 s pos in
319 i - ((i land 0x8000) lsl 1)
322 let r32 s pos =
323 let rb pos1 = Char.code (Bytes.get s (pos + pos1)) in
324 let l = (rb 0) lor ((rb 1) lsl 8)
325 and u = (rb 2) lor ((rb 3) lsl 8) in
326 (u lsl 16) lor l
329 let r32s =
330 if Sys.word_size > 32
331 then fun s pos ->
332 let rb pos1 = Char.code (Bytes.get s (pos + pos1)) in
333 let v0 = rb 0 and v1 = rb 1 and v2 = rb 2 and v3 = rb 3 in
334 let v = v0 lor (v1 lsl 8) lor (v2 lsl 16) lor (v3 lsl 24) in
335 if v3 land 0x80 = 0
336 then v
337 else (v - (1 lsl 32))
338 else fun _ _ -> error "r32s: not implemented for word_size <= 32"
341 let vlog fmt = Format.ksprintf ignore fmt;;
343 let pipef ?(closew=true) cap f cmd =
344 match Unix.pipe () with
345 | exception exn -> dolog "%s cannot create pipe: %S" cap @@ exntos exn
346 | (r, w) ->
347 begin match spawn cmd [r, 0; w, -1] with
348 | exception exn -> dolog "%s: cannot execute %S: %s" cap cmd @@ exntos exn
349 | _pid -> f w
350 end;
351 Ne.clo r (dolog "%s failed to close r: %s" cap);
352 if closew then Ne.clo w (dolog "%s failed to close w: %s" cap);
355 let selstring selcmd s =
356 pipef "selstring" (fun w ->
358 let l = String.length s in
359 let bytes = Bytes.unsafe_of_string s in
360 let n = tempfailureretry (Unix.write w bytes 0) l in
361 if n != l
362 then dolog "failed to write %d characters to sel pipe, wrote %d" l n;
363 with exn -> dolog "failed to write to sel pipe: %s" @@ exntos exn
364 ) selcmd