9 type platform
= | Punknown
| Plinux
| Posx
| Psun
| Pbsd
;;
11 let asciilower = let auld = Char.code 'A'
- Char.code '
a'
in
13 | ('A'
..'Z'
) as c
-> Char.code c
- auld |> Char.chr
17 let tempfailureretry f
a =
19 try f
a with Unix.Unix_error
(Unix.EINTR
, _
, _
) -> g ()
23 external cloexec
: Unix.file_descr
-> unit = "ml_cloexec";;
24 external hasdata
: Unix.file_descr
-> bool = "ml_hasdata";;
25 external toutf8
: int -> string = "ml_keysymtoutf8";;
26 external mbtoutf8
: string -> string = "ml_mbtoutf8";;
27 external spawn
: string -> (Unix.file_descr
* int) list
-> int = "ml_spawn";;
28 external platform
: unit -> (platform
* string array
) = "ml_platform";;
30 let now = Unix.gettimeofday
;;
31 let platform, uname
= platform ();;
32 let dolog fmt
= Format.ksprintf prerr_endline fmt
;;
35 | Unix.Unix_error
(e
, s, a) ->
36 Printf.sprintf
"%s(%s) : %s (%d)"
37 s a (Unix.error_message e
) (Obj.magic e
)
38 | exn
-> Printexc.to_string exn
41 let error fmt
= Printf.kprintf
(fun s -> failwith
s) fmt
;;
43 module IntSet
= Set.Make
(struct type t
= int let compare = (-) end);;
45 let emptystr s = String.length
s = 0;;
46 let nonemptystr s = String.length
s > 0;;
47 let bound v minv maxv
= max minv
(min maxv v
);;
51 type t
= private string
52 val of_string
: string -> t
53 val to_string
: t
-> string
63 let (~
<) = Opaque.of_string;;
64 let (~
>) = Opaque.to_string;;
66 let int_of_string_with_suffix s =
67 let l = String.length
s in
73 | 'k'
| 'K'
-> String.sub
s 0 p, 10
74 | 'm'
| 'M'
-> String.sub
s 0 p, 20
75 | '
g'
| 'G'
-> String.sub
s 0 p, 30
79 let n = int_of_string
s1 in
80 let m = n lsl shift
in
82 then error "value too large"
86 let string_with_suffix_of_int n =
90 let units = [(30, "G"); (20, "M"); (10, "K")] in
96 then string_of_int
h ^
s
98 let s = Printf.sprintf
"_%03d%s" h s in
104 let rec find = function
106 | (shift
, suffix
) :: rest
->
107 if (n land ((1 lsl shift
) - 1)) = 0
108 then prettyint (n lsr shift
) ^ suffix
114 let color_of_string s =
115 Scanf.sscanf
s "%d/%d/%d" (fun r
g b ->
116 (float r
/. 255.0, float g /. 255.0, float b /. 255.0)
120 let rgba_of_string s =
122 s "%d/%d/%d/%d" (fun r
g b a ->
123 (float r
/. 255.0, float g /. 255.0, float b /. 255.0, float a /. 255.0)
127 let color_to_string (r
, g, b) =
128 let r = truncate
(r *. 255.0)
129 and g = truncate
(g *. 255.0)
130 and b = truncate
(b *. 255.0) in
131 Printf.sprintf
"%d/%d/%d" r g b
134 let rgba_to_string (r, g, b, a) =
135 let r = truncate
(r *. 255.0)
136 and g = truncate
(g *. 255.0)
137 and b = truncate
(b *. 255.0)
138 and a = truncate
(a *. 255.0) in
139 Printf.sprintf
"%d/%d/%d/%d" r g b a
143 if Filename.is_relative path
145 let cwd = Sys.getcwd
() in
146 if Filename.is_implicit path
147 then Filename.concat
cwd path
148 else Filename.concat
cwd (Filename.basename path
)
160 try tempfailureretry Unix.close fd
161 with exn
-> f
@@ exntos exn
165 let getenvwithdef name def
=
166 match Sys.getenv name
with
168 | exception Not_found
-> def
171 let newlinere = Str.regexp
"[\r\n]";;
172 let percentsre = Str.regexp
"%s";;
173 let whitere = Str.regexp
"[ \t]";;
178 let b = Buffer.create
(String.length
s + 1) in
179 Buffer.add_string
b s;
184 let btod b = if b then 1 else 0;;
186 let splitatchar s c
= let open String
in
188 | pos
-> sub
s 0 pos
, sub
s (pos
+1) (length
s - pos
- 1)
189 | exception Not_found
-> s, E.s
192 let boundastep h step
=
194 then bound step ~
-h 0
198 let withoutlastutf8 s =
199 let len = String.length
s in
207 let b = Char.code
s.[pos
] in
208 if b land 0b11000000 = 0b11000000
213 if Char.code
s.[len-1] land 0x80 = 0
217 String.sub
s 0 first;
222 let b = Buffer.create
l in
223 let s = Bytes.create
l in
225 let n = tempfailureretry (Unix.read fd
s 0) l in
227 then Buffer.contents
b
229 Buffer.add_subbytes
b s 0 n;
236 let filecontents path
=
237 let fd = Unix.openfile path
[Unix.O_RDONLY
] 0o0
in
238 match fdcontents fd with
240 error "failed to read contents of %s: %s" path
@@ exntos exn
242 Ne.clo fd @@ error "failed to close descriptor for %s: %s" path
;
246 let getcmdoutput errfun cmd
=
247 let reperror fmt
= Printf.kprintf errfun fmt
in
248 let clofail s e
= error "failed to close %s: %s" s e
in
249 match Unix.pipe
() with
251 reperror "pipe failed: %s" @@ exntos exn
;
254 match spawn cmd
[r, -1; w
, 1] with
256 reperror "failed to execute %S: %s" cmd
@@ exntos exn
;
259 Ne.clo w
@@ clofail "write end of the pipe";
261 match Unix.waitpid
[] pid
with
263 reperror "waitpid on %S %d failed: %s" cmd pid
@@ exntos exn
;
265 | _pid
, Unix.WEXITED
0 ->
267 match fdcontents r with
269 reperror "failed to read output of %S: %s" cmd
@@ exntos exn
;
272 let l = String.length
s in
273 if l > 0 && s.[l-1] = '
\n'
274 then String.sub
s 0 (l-1)
277 | _pid
, Unix.WEXITED
n ->
278 reperror "%S exited with error code %d" cmd
n;
280 | _pid
, Unix.WSIGNALED
n ->
281 reperror "%S was killed with signal %d" cmd
n;
283 | _pid
, Unix.WSTOPPED
n ->
284 reperror "%S was stopped by signal %d" cmd
n;
287 Ne.clo r @@ clofail "read end of the pipe";
292 let re = Str.regexp
{|.*\
(\
(https?\
|ftp\
|mailto\
|file\
)://[^
]+\
).*|} in
294 if Str.string_match
re s 0
295 then Str.matched_group
1 s
299 let substratis s pos subs
=
300 let subslen = String.length subs
in
301 if String.length
s - pos
>= subslen
303 let rec cmp i
= i
= subslen || (s.[pos
+i
] = subs
.[i
]) && cmp (i
+1)
308 let w8 s pos i
= Bytes.set
s pos
(Char.chr
(i
land 0xff));;
309 let r8 s pos
= Char.code
(Bytes.get
s pos
);;
313 w8 s (pos
+1) (i
lsr 8)
318 w16 s (pos
+2) (i
lsr 16)
322 let rb pos1
= Char.code
(Bytes.get
s (pos
+ pos1
)) in
323 (rb 0) lor ((rb 1) lsl 8)
328 i - ((i land 0x8000) lsl 1)
332 let rb pos1
= Char.code
(Bytes.get
s (pos
+ pos1
)) in
333 let l = (rb 0) lor ((rb 1) lsl 8)
334 and u
= (rb 2) lor ((rb 3) lsl 8) in
339 let rb pos1
= Char.code
(Bytes.get
s (pos
+ pos1
)) in
340 let v0 = rb 0 and v1
= rb 1 and v2
= rb 2 and v3
= rb 3 in
341 let v = v0 lor (v1
lsl 8) lor (v2
lsl 16) lor (v3
lsl 24) in
345 (* XXX This is broken on 32bit platforms *)
349 let vlog fmt
= Format.ksprintf ignore fmt
;;
351 let pipef ?
(closew
=true) cap f cmd
=
352 match Unix.pipe
() with
353 | exception exn
-> dolog "%s cannot create pipe: %S" cap
@@ exntos exn
355 begin match spawn cmd
[r, 0; w
, -1] with
356 | exception exn
-> dolog "%s: cannot execute %S: %s" cap cmd
@@ exntos exn
359 Ne.clo r (dolog "%s failed to close r: %s" cap
);
360 if closew
then Ne.clo w
(dolog "%s failed to close w: %s" cap
);
363 let selstring selcmd
s =
365 "selstring" (fun w
->
367 let l = String.length
s in
368 let bytes = Bytes.unsafe_of_string
s in
369 let n = tempfailureretry (Unix.write w
bytes 0) l in
371 then dolog "failed to write %d characters to sel pipe, wrote %d" l n;
372 with exn
-> dolog "failed to write to sel pipe: %s" @@ exntos exn