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 getenvwithdef name def
=
155 match Sys.getenv name
with
157 | exception Not_found
-> def
161 let crlf = Str.regexp
"[\r\n]";;
162 let percent = Str.regexp
"%s";;
163 let whitespace = Str.regexp
"[ \t]";;
169 let b = Buffer.create
(String.length
s + 1) in
170 Buffer.add_string
b s;
175 let btod b = if b then 1 else 0;;
177 let splitatchar s c
= let open String
in
179 | pos
-> sub
s 0 pos
, sub
s (pos
+1) (length
s - pos
- 1)
180 | exception Not_found
-> s, E.s
183 let boundastep h step
=
185 then bound step ~
-h 0
189 let withoutlastutf8 s =
190 let len = String.length
s in
198 let b = Char.code
s.[pos
] in
199 if b land 0b11000000 = 0b11000000
204 if Char.code
s.[len-1] land 0x80 = 0
208 String.sub
s 0 first;
213 let b = Buffer.create
l in
214 let s = Bytes.create
l in
216 let n = tempfailureretry (Unix.read fd
s 0) l in
218 then Buffer.contents
b
220 Buffer.add_subbytes
b s 0 n;
227 let filecontents path
=
228 let fd = Unix.openfile path
[Unix.O_RDONLY
] 0o0
in
229 match fdcontents fd with
231 error "failed to read contents of %s: %s" path
@@ exntos exn
233 Ne.clo fd @@ error "failed to close descriptor for %s: %s" path
;
237 let getcmdoutput errfun cmd
=
238 let reperror fmt
= Printf.kprintf errfun fmt
in
239 let clofail s e
= error "failed to close %s: %s" s e
in
240 match Unix.pipe
() with
242 reperror "pipe failed: %s" @@ exntos exn
;
245 match spawn cmd
[r, -1; w
, 1] with
247 reperror "failed to execute %S: %s" cmd
@@ exntos exn
;
250 Ne.clo w
@@ clofail "write end of the pipe";
252 match Unix.waitpid
[] pid
with
254 reperror "waitpid on %S %d failed: %s" cmd pid
@@ exntos exn
;
256 | _pid
, Unix.WEXITED
0 ->
258 match fdcontents r with
260 reperror "failed to read output of %S: %s" cmd
@@ exntos exn
;
263 let l = String.length
s in
264 if l > 0 && s.[l-1] = '
\n'
265 then String.sub
s 0 (l-1)
268 | _pid
, Unix.WEXITED
n ->
269 reperror "%S exited with error code %d" cmd
n;
271 | _pid
, Unix.WSIGNALED
n ->
272 reperror "%S was killed with signal %d" cmd
n;
274 | _pid
, Unix.WSTOPPED
n ->
275 reperror "%S was stopped by signal %d" cmd
n;
278 Ne.clo r @@ clofail "read end of the pipe";
283 let re = Str.regexp
{|.*\
(\
(https?\
|ftp\
|mailto\
|file\
)://[^
]+\
).*|} in
284 fun s -> if Str.string_match
re s 0
285 then Str.matched_group
1 s
289 let substratis s pos subs
=
290 let subslen = String.length subs
in
291 if String.length
s - pos
>= subslen
293 let rec cmp i
= i
= subslen || (s.[pos
+i
] = subs
.[i
]) && cmp (i
+1)
298 let w8 s pos i
= Bytes.set
s pos
(Char.chr
(i
land 0xff));;
299 let r8 s pos
= Char.code
(Bytes.get
s pos
);;
303 w8 s (pos
+1) (i
lsr 8)
308 w16 s (pos
+2) (i
lsr 16)
312 let rb pos1
= Char.code
(Bytes.get
s (pos
+ pos1
)) in
313 (rb 0) lor ((rb 1) lsl 8)
318 i - ((i land 0x8000) lsl 1)
322 let rb pos1
= Char.code
(Bytes.get
s (pos
+ pos1
)) in
323 let l = (rb 0) lor ((rb 1) lsl 8)
324 and u
= (rb 2) lor ((rb 3) lsl 8) in
329 if Sys.word_size
> 32
331 let rb pos1
= Char.code
(Bytes.get
s (pos
+ pos1
)) in
332 let v0 = rb 0 and v1
= rb 1 and v2
= rb 2 and v3
= rb 3 in
333 let v = v0 lor (v1
lsl 8) lor (v2
lsl 16) lor (v3
lsl 24) in
336 else (v - (1 lsl 32))
337 else fun _ _
-> error "r32s: not implemented for word_size <= 32"
340 let vlog fmt
= Format.ksprintf ignore fmt
;;
342 let pipef ?
(closew
=true) cap f cmd
=
343 match Unix.pipe
() with
344 | exception exn
-> dolog "%s cannot create pipe: %S" cap
@@ exntos exn
346 begin match spawn cmd
[r, 0; w
, -1] with
347 | exception exn
-> dolog "%s: cannot execute %S: %s" cap cmd
@@ exntos exn
350 Ne.clo r (dolog "%s failed to close r: %s" cap
);
351 if closew
then Ne.clo w
(dolog "%s failed to close w: %s" cap
);
354 let selstring selcmd
s =
355 pipef "selstring" (fun w
->
357 let l = String.length
s in
358 let bytes = Bytes.unsafe_of_string
s in
359 let n = tempfailureretry (Unix.write w
bytes 0) l in
361 then dolog "failed to write %d characters to sel pipe, wrote %d" l n;
362 with exn
-> dolog "failed to write to sel pipe: %s" @@ exntos exn