10 let tempfailureretry f
a =
12 try f
a with Unix.Unix_error
(Unix.EINTR
, _
, _
) -> g ()
15 external spawn
: string -> (Unix.file_descr
* int) list
-> int = "ml_spawn"
16 external hasdata
: Unix.file_descr
-> bool = "ml_hasdata"
18 let now = Unix.gettimeofday
19 let dologf = ref prerr_endline
20 let dolog fmt
= Printf.ksprintf
!dologf fmt
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
27 let onoffs = function | true -> "on" | false -> "off"
29 let error fmt
= Printf.kprintf failwith fmt
31 module IntSet
= Set.Make
(struct type t
= int let compare = (-) end)
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
)
38 type t
= private string
39 val of_string
: string -> t
40 val to_string
: t
-> string
47 let int_of_string_with_suffix s =
48 let l = String.length
s in
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
60 let n = int_of_string
s1 in
61 let m = n lsl shift
in
63 then error "value too large"
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
74 if n = 0 then "0" else find [(30, 'G'
); (20, 'M'
); (10, 'K'
)]
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)
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)
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)
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)
94 if Filename.is_relative path
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
)
103 let index s c = try String.index s c with Not_found
-> -1
105 try tempfailureretry Unix.close fd
106 with exn
-> f
@@ exntos exn
109 let getenvdef name def
=
110 match Sys.getenv name
with
112 | exception Not_found
-> def
115 let crlf = Str.regexp
"[\r\n]"
116 let percent = Str.regexp
"%s"
117 let whitespace = Str.regexp
"[ \t]"
121 let b = Buffer.create
(String.length
s + 1) in
122 Buffer.add_string
b s;
126 let btod b = if b then 1 else 0
128 let splitatchar s c = let open String
in
130 | pos
-> sub
s 0 pos
, sub
s (pos
+1) (length
s - pos
- 1)
131 | exception Not_found
-> s, E.s
133 let boundastep h step
=
135 then bound step ~
-h
0
138 let withoutlastutf8 s =
139 let len = String.length
s in
147 let b = Char.code
s.[pos
] in
148 if b land 0b11000000 = 0b11000000
153 if Char.code
s.[len-1] land 0x80 = 0
161 let b = Buffer.create
l in
162 let s = Bytes.create
l in
164 let n = tempfailureretry (Unix.read fd
s 0) l in
166 then Buffer.contents
b
168 Buffer.add_subbytes
b s 0 n;
174 let filecontents path
=
175 let fd = Unix.openfile path
[Unix.O_RDONLY
] 0o0
in
176 match fdcontents fd with
178 error "failed to read contents of %s: %s" path
@@ exntos exn
180 Ne.clo fd @@ error "failed to close descriptor for %s: %s" path
;
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
188 reperror "pipe failed: %s" @@ exntos exn
;
191 match spawn cmd
[r
, -1; w
, 1] with
193 reperror "failed to execute %S: %s" cmd
@@ exntos exn
;
196 Ne.clo w
@@ clofail "write end of the pipe";
198 match Unix.waitpid
[] pid
with
200 reperror "waitpid on %S %d failed: %s" cmd pid
@@ exntos exn
;
202 | _pid
, Unix.WEXITED
0 ->
204 match fdcontents r
with
206 reperror "failed to read output of %S: %s" cmd
@@ exntos exn
;
209 let l = String.length
s in
210 if l > 0 && s.[l-1] = '
\n'
211 then String.sub
s 0 (l-1)
214 | _pid
, Unix.WEXITED
n ->
215 reperror "%S exited with error code %d" cmd
n;
217 | _pid
, Unix.WSIGNALED
n ->
218 reperror "%S was killed with signal %d" cmd
n;
220 | _pid
, Unix.WSTOPPED
n ->
221 reperror "%S was stopped by signal %d" cmd
n;
224 Ne.clo r
@@ clofail "read end of the pipe";
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
233 let substratis s pos subs
=
234 let subslen = String.length subs
in
235 if String.length
s - pos
>= subslen
237 let rec cmp i
= i
= subslen || (s.[pos
+i
] = subs
.[i
]) && cmp (i
+1)
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
250 let vlogf = ref ignore
251 let vlog fmt
= Printf.kprintf
!vlogf fmt
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
257 begin match spawn cmd
[r
, 0; w
, -1] with
258 | exception exn
-> dolog "%s: cannot execute %S: %s" cap cmd
@@ exntos exn
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
)
264 let selstring selcmd
s =
265 pipef "selstring" (fun w
->
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
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