9 type platform
= | Punknown
| Plinux
| Pmacos
| 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 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
;;
36 | Unix.Unix_error
(e
, s, a) ->
37 Printf.sprintf
"%s(%s) : %s (%d)" 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
);;
50 type t
= private string
51 val of_string
: string -> t
52 val to_string
: t
-> string
60 let (~
<) = Opaque.of_string;;
61 let (~
>) = Opaque.to_string;;
63 let int_of_string_with_suffix s =
64 let l = String.length
s in
70 | 'k'
| 'K'
-> String.sub
s 0 p, 10
71 | 'm'
| 'M'
-> String.sub
s 0 p, 20
72 | '
g'
| 'G'
-> String.sub
s 0 p, 30
76 let n = int_of_string
s1 in
77 let m = n lsl shift
in
79 then error "value too large"
83 let string_with_suffix_of_int n =
87 let units = [(30, "G"); (20, "M"); (10, "K")] in
93 then string_of_int
h ^
s
94 else loop (Printf.sprintf
"_%03d%s" h s) n
98 let rec find = function
100 | (shift
, suffix
) :: rest
->
101 if (n land ((1 lsl shift
) - 1)) = 0
102 then prettyint (n lsr shift
) ^ suffix
108 let color_of_string s =
109 Scanf.sscanf
s "%d/%d/%d" (fun r
g b ->
110 (float r
/. 255.0, float g /. 255.0, float b /. 255.0)
114 let rgba_of_string s =
116 s "%d/%d/%d/%d" (fun r
g b a ->
117 (float r
/. 255.0, float g /. 255.0, float b /. 255.0, float a /. 255.0)
121 let color_to_string (r
, g, b) =
122 let r = truncate
(r *. 255.0)
123 and g = truncate
(g *. 255.0)
124 and b = truncate
(b *. 255.0) in
125 Printf.sprintf
"%d/%d/%d" r g b
128 let rgba_to_string (r, g, b, a) =
129 let r = truncate
(r *. 255.0)
130 and g = truncate
(g *. 255.0)
131 and b = truncate
(b *. 255.0)
132 and a = truncate
(a *. 255.0) in
133 Printf.sprintf
"%d/%d/%d/%d" r g b a
137 if Filename.is_relative path
139 let cwd = Sys.getcwd
() in
140 if Filename.is_implicit path
141 then Filename.concat
cwd path
142 else Filename.concat
cwd (Filename.basename path
)
147 let index s c
= try String.index s c
with Not_found
-> -1;;
149 try tempfailureretry Unix.close fd
150 with exn
-> f
@@ exntos exn
154 let getoptdef def
= function
159 let getenvdef name def
=
160 match Sys.getenv name
with
162 | exception Not_found
-> def
166 let crlf = Str.regexp
"[\r\n]";;
167 let percent = Str.regexp
"%s";;
168 let whitespace = Str.regexp
"[ \t]";;
174 let b = Buffer.create
(String.length
s + 1) in
175 Buffer.add_string
b s;
180 let btod b = if b then 1 else 0;;
182 let splitatchar s c
= let open String
in
184 | pos
-> sub
s 0 pos
, sub
s (pos
+1) (length
s - pos
- 1)
185 | exception Not_found
-> s, E.s
188 let boundastep h step
=
190 then bound step ~
-h 0
194 let withoutlastutf8 s =
195 let len = String.length
s in
203 let b = Char.code
s.[pos
] in
204 if b land 0b11000000 = 0b11000000
209 if Char.code
s.[len-1] land 0x80 = 0
213 String.sub
s 0 first;
218 let b = Buffer.create
l in
219 let s = Bytes.create
l in
221 let n = tempfailureretry (Unix.read fd
s 0) l in
223 then Buffer.contents
b
225 Buffer.add_subbytes
b s 0 n;
232 let filecontents path
=
233 let fd = Unix.openfile path
[Unix.O_RDONLY
] 0o0
in
234 match fdcontents fd with
236 error "failed to read contents of %s: %s" path
@@ exntos exn
238 Ne.clo fd @@ error "failed to close descriptor for %s: %s" path
;
242 let getcmdoutput errfun cmd
=
243 let reperror fmt
= Printf.kprintf errfun fmt
in
244 let clofail s e
= error "failed to close %s: %s" s e
in
245 match Unix.pipe
() with
247 reperror "pipe failed: %s" @@ exntos exn
;
250 match spawn cmd
[r, -1; w
, 1] with
252 reperror "failed to execute %S: %s" cmd
@@ exntos exn
;
255 Ne.clo w
@@ clofail "write end of the pipe";
257 match Unix.waitpid
[] pid
with
259 reperror "waitpid on %S %d failed: %s" cmd pid
@@ exntos exn
;
261 | _pid
, Unix.WEXITED
0 ->
263 match fdcontents r with
265 reperror "failed to read output of %S: %s" cmd
@@ exntos exn
;
268 let l = String.length
s in
269 if l > 0 && s.[l-1] = '
\n'
270 then String.sub
s 0 (l-1)
273 | _pid
, Unix.WEXITED
n ->
274 reperror "%S exited with error code %d" cmd
n;
276 | _pid
, Unix.WSIGNALED
n ->
277 reperror "%S was killed with signal %d" cmd
n;
279 | _pid
, Unix.WSTOPPED
n ->
280 reperror "%S was stopped by signal %d" cmd
n;
283 Ne.clo r @@ clofail "read end of the pipe";
288 let re = Str.regexp
{|.*\
(\
(https?\
|ftp\
|mailto\
|file\
)://[^
]+\
).*|} in
289 fun s -> if Str.string_match
re s 0
290 then Str.matched_group
1 s
294 let substratis s pos subs
=
295 let subslen = String.length subs
in
296 if String.length
s - pos
>= subslen
298 let rec cmp i
= i
= subslen || (s.[pos
+i
] = subs
.[i
]) && cmp (i
+1)
303 let w8 s pos i
= Bytes.set
s pos
(Char.chr
(i
land 0xff));;
304 let r8 s pos
= Char.code
(Bytes.get
s pos
);;
308 w8 s (pos
+1) (i
lsr 8)
313 w16 s (pos
+2) (i
lsr 16)
317 let rb pos1
= Char.code
(Bytes.get
s (pos
+ pos1
)) in
318 (rb 0) lor ((rb 1) lsl 8)
323 i - ((i land 0x8000) lsl 1)
327 let rb pos1
= Char.code
(Bytes.get
s (pos
+ pos1
)) in
328 let l = (rb 0) lor ((rb 1) lsl 8)
329 and u
= (rb 2) lor ((rb 3) lsl 8) in
334 if Sys.word_size
> 32
336 let rb pos1
= Char.code
(Bytes.get
s (pos
+ pos1
)) in
337 let v0 = rb 0 and v1
= rb 1 and v2
= rb 2 and v3
= rb 3 in
338 let v = v0 lor (v1
lsl 8) lor (v2
lsl 16) lor (v3
lsl 24) in
341 else (v - (1 lsl 32))
342 else fun _ _
-> error "r32s: not implemented for word_size <= 32"
345 let vlog fmt
= Format.ksprintf ignore fmt
;;
347 let pipef ?
(closew
=true) cap f cmd
=
348 match Unix.pipe
() with
349 | exception exn
-> dolog "%s cannot create pipe: %S" cap
@@ exntos exn
351 begin match spawn cmd
[r, 0; w
, -1] with
352 | exception exn
-> dolog "%s: cannot execute %S: %s" cap cmd
@@ exntos exn
355 Ne.clo r (dolog "%s failed to close r: %s" cap
);
356 if closew
then Ne.clo w
(dolog "%s failed to close w: %s" cap
);
359 let selstring selcmd
s =
360 pipef "selstring" (fun w
->
362 let l = String.length
s in
363 let bytes = Bytes.unsafe_of_string
s in
364 let n = tempfailureretry (Unix.write w
bytes 0) l in
366 then dolog "failed to write %d characters to sel pipe, wrote %d" l n;
367 with exn
-> dolog "failed to write to sel pipe: %s" @@ exntos exn