Use cmd_
[llpp.git] / utils.ml
blob33f1390e82db7c7464e9b138085ef37928a7271d
1 module E = struct
2 let s = "";;
3 let b = Bytes.empty;;
4 let a = [||];;
5 end;;
7 type platform = | Punknown | Plinux | Posx | Psun | Pbsd | Pcygwin;;
9 let asciilower = let auld = Char.code 'A' - Char.code 'a' in
10 function
11 | ('A'..'Z') as c -> Char.code c - auld |> Char.chr
12 | c -> c
15 let tempfailureretry f a =
16 let rec g () =
17 try f a with Unix.Unix_error (Unix.EINTR, _, _) -> g ()
18 in g ()
21 external cloexec : Unix.file_descr -> unit = "ml_cloexec";;
22 external hasdata : Unix.file_descr -> bool = "ml_hasdata";;
23 external toutf8 : int -> string = "ml_keysymtoutf8";;
24 external mbtoutf8 : string -> string = "ml_mbtoutf8";;
25 external spawn : string -> (Unix.file_descr * int) list -> int = "ml_spawn";;
26 external platform : unit -> (platform * string array) = "ml_platform";;
28 let now = Unix.gettimeofday;;
29 let platform, uname = platform ();;
30 let dolog fmt = Format.ksprintf prerr_endline fmt;;
32 let exntos = function
33 | Unix.Unix_error (e, s, a) ->
34 Printf.sprintf "%s(%s) : %s (%d)"
35 s a (Unix.error_message e) (Obj.magic e)
36 | exn -> Printexc.to_string exn
39 let error fmt = Printf.kprintf (fun s -> failwith s) fmt;;
41 module IntSet = Set.Make (struct type t = int let compare = (-) end);;
43 let emptystr s = String.length s = 0;;
44 let nonemptystr s = String.length s > 0;;
45 let bound v minv maxv = max minv (min maxv v);;
47 let spawn cmd fda =
48 if platform = Pcygwin
49 then failwith "spawn not implemented under cygwin yet"
50 else spawn cmd fda;
53 module Opaque :
54 sig
55 type t = private string
56 val of_string : string -> t
57 val to_string : t -> string
58 end
60 struct
61 type t = string
62 let of_string s = s
63 let to_string t = t
64 end
67 let (~<) = Opaque.of_string;;
68 let (~>) = Opaque.to_string;;
70 let int_of_string_with_suffix s =
71 let l = String.length s in
72 let s1, shift =
73 if l > 1
74 then
75 let p = l-1 in
76 match s.[p] with
77 | 'k' | 'K' -> String.sub s 0 p, 10
78 | 'm' | 'M' -> String.sub s 0 p, 20
79 | 'g' | 'G' -> String.sub s 0 p, 30
80 | _ -> s, 0
81 else s, 0
83 let n = int_of_string s1 in
84 let m = n lsl shift in
85 if m < 0 || m < n
86 then error "value too large"
87 else m
90 let string_with_suffix_of_int n =
91 if n = 0
92 then "0"
93 else
94 let units = [(30, "G"); (20, "M"); (10, "K")] in
95 let prettyint n =
96 let rec loop s n =
97 let h = n mod 1000 in
98 let n = n / 1000 in
99 if n = 0
100 then string_of_int h ^ s
101 else (
102 let s = Printf.sprintf "_%03d%s" h s in
103 loop s n
106 loop E.s n
108 let rec find = function
109 | [] -> prettyint n
110 | (shift, suffix) :: rest ->
111 if (n land ((1 lsl shift) - 1)) = 0
112 then prettyint (n lsr shift) ^ suffix
113 else find rest
115 find units
118 let color_of_string s =
119 Scanf.sscanf s "%d/%d/%d" (fun r g b ->
120 (float r /. 255.0, float g /. 255.0, float b /. 255.0)
124 let color_to_string (r, g, b) =
125 let r = truncate (r *. 255.0)
126 and g = truncate (g *. 255.0)
127 and b = truncate (b *. 255.0) in
128 Printf.sprintf "%d/%d/%d" r g b
131 let abspath path =
132 if Filename.is_relative path
133 then
134 let cwd = Sys.getcwd () in
135 if Filename.is_implicit path
136 then Filename.concat cwd path
137 else Filename.concat cwd (Filename.basename path)
138 else
139 path
142 let nindex s c =
143 try String.index s c
144 with Not_found -> -1
147 module Ne = struct
148 let clo fd f =
149 try tempfailureretry Unix.close fd
150 with exn -> f @@ exntos exn
152 end;;
154 let getenvwithdef name def =
155 match Sys.getenv name with
156 | env -> env
157 | exception Not_found -> def
160 let newlinere = Str.regexp "[\r\n]";;
161 let percentsre = Str.regexp "%s";;
162 let whitere = Str.regexp "[ \t]";;
164 let unit () = ();;
166 let addchar s c =
167 let b = Buffer.create (String.length s + 1) in
168 Buffer.add_string b s;
169 Buffer.add_char b c;
170 Buffer.contents b;
173 let btod b = if b then 1 else 0;;
175 let splitatchar s c = let open String in
176 match index s c with
177 | pos -> sub s 0 pos, sub s (pos+1) (length s - pos - 1)
178 | exception Not_found -> s, E.s
181 let boundastep h step =
182 if step < 0
183 then bound step ~-h 0
184 else bound step 0 h
187 let withoutlastutf8 s =
188 let len = String.length s in
189 if len = 0
190 then s
191 else
192 let rec find pos =
193 if pos = 0
194 then pos
195 else
196 let b = Char.code s.[pos] in
197 if b land 0b11000000 = 0b11000000
198 then pos
199 else find (pos-1)
201 let first =
202 if Char.code s.[len-1] land 0x80 = 0
203 then len-1
204 else find (len-1)
206 String.sub s 0 first;
209 let fdcontents fd =
210 let l = 4096 in
211 let b = Buffer.create l in
212 let s = Bytes.create l in
213 let rec loop () =
214 let n = tempfailureretry (Unix.read fd s 0) l in
215 if n = 0
216 then Buffer.contents b
217 else (
218 Buffer.add_subbytes b s 0 n;
219 loop ()
222 loop ()
225 let filecontents path =
226 let fd = Unix.openfile path [Unix.O_RDONLY] 0o0 in
227 match fdcontents fd with
228 | exception exn ->
229 error "failed to read contents of %s: %s" path @@ exntos exn
230 | s ->
231 Ne.clo fd @@ error "failed to close descriptor for %s: %s" path;
235 let getcmdoutput errfun cmd =
236 let reperror fmt = Printf.kprintf errfun fmt in
237 let clofail s e = error "failed to close %s: %s" s e in
238 match Unix.pipe () with
239 | exception exn ->
240 reperror "pipe failed: %s" @@ exntos exn;
242 | (r, w) ->
243 match spawn cmd [r, -1; w, 1] with
244 | exception exn ->
245 reperror "failed to execute %S: %s" cmd @@ exntos exn;
247 | pid ->
248 Ne.clo w @@ clofail "write end of the pipe";
249 let s =
250 match Unix.waitpid [] pid with
251 | exception exn ->
252 reperror "waitpid on %S %d failed: %s" cmd pid @@ exntos exn;
254 | _pid, Unix.WEXITED 0 ->
255 begin
256 match fdcontents r with
257 | exception exn ->
258 reperror "failed to read output of %S: %s" cmd @@ exntos exn;
260 | s ->
261 let l = String.length s in
262 if l > 0 && s.[l-1] = '\n'
263 then String.sub s 0 (l-1)
264 else s
265 end;
266 | _pid, Unix.WEXITED n ->
267 reperror "%S exited with error code %d" cmd n;
269 | _pid, Unix.WSIGNALED n ->
270 reperror "%S was killed with signal %d" cmd n;
272 | _pid, Unix.WSTOPPED n ->
273 reperror "%S was stopped by signal %d" cmd n;
276 Ne.clo r @@ clofail "read end of the pipe";
280 let geturl =
281 let re = Str.regexp {|.*\(\(https?\|ftp\|mailto\|file\)://[^ ]+\).*|} in
282 fun s ->
283 if Str.string_match re s 0
284 then Str.matched_group 1 s
285 else E.s
288 let substratis s pos subs =
289 let subslen = String.length subs in
290 if String.length s - pos >= subslen
291 then
292 let rec cmp i = i = subslen || (s.[pos+i] = subs.[i]) && cmp (i+1)
293 in cmp 0
294 else false
297 let w8 s pos i = Bytes.set s pos (Char.chr (i land 0xff));;
298 let r8 s pos = Char.code (Bytes.get s pos);;
300 let w16 s pos i =
301 w8 s pos i;
302 w8 s (pos+1) (i lsr 8)
305 let w32 s pos i =
306 w16 s pos i;
307 w16 s (pos+2) (i lsr 16)
310 let r16 s pos =
311 let rb pos1 = Char.code (Bytes.get s (pos + pos1)) in
312 (rb 0) lor ((rb 1) lsl 8)
315 let r16s s pos =
316 let i = r16 s pos in
317 i - ((i land 0x8000) lsl 1)
320 let r32 s pos =
321 let rb pos1 = Char.code (Bytes.get s (pos + pos1)) in
322 let l = (rb 0) lor ((rb 1) lsl 8)
323 and u = (rb 2) lor ((rb 3) lsl 8) in
324 (u lsl 16) lor l
327 let r32s s pos =
328 let rb pos1 = Char.code (Bytes.get s (pos + pos1)) in
329 let v0 = rb 0 and v1 = rb 1 and v2 = rb 2 and v3 = rb 3 in
330 let v = v0 lor (v1 lsl 8) lor (v2 lsl 16) lor (v3 lsl 24) in
331 if v3 land 0x80 = 0 then
333 else
334 (v - (1 lsl 32))
337 let vlog fmt = Format.ksprintf ignore fmt;;