7 type platform
= | Punknown
| Plinux
| Posx
| Psun
| Pbsd
| Pcygwin
;;
9 let asciilower = let auld = Char.code 'A'
- Char.code '
a'
in
11 | ('A'
..'Z'
) as c
-> Char.code c
- auld |> Char.chr
15 let tempfailureretry f
a =
17 try f
a with Unix.Unix_error
(Unix.EINTR
, _
, _
) -> 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
;;
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
);;
49 then failwith
"spawn not implemented under cygwin yet"
55 type t
= private string
56 val of_string
: string -> t
57 val to_string
: t
-> string
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
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
83 let n = int_of_string
s1 in
84 let m = n lsl shift
in
86 then error "value too large"
90 let string_with_suffix_of_int n =
94 let units = [(30, "G"); (20, "M"); (10, "K")] in
100 then string_of_int
h ^
s
102 let s = Printf.sprintf
"_%03d%s" h s in
108 let rec find = function
110 | (shift
, suffix
) :: rest
->
111 if (n land ((1 lsl shift
) - 1)) = 0
112 then prettyint (n lsr shift
) ^ suffix
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 rgba_of_string s =
126 s "%d/%d/%d/%d" (fun r
g b a ->
127 (float r
/. 255.0, float g /. 255.0, float b /. 255.0, float a /. 255.0)
131 let color_to_string (r
, g, b) =
132 let r = truncate
(r *. 255.0)
133 and g = truncate
(g *. 255.0)
134 and b = truncate
(b *. 255.0) in
135 Printf.sprintf
"%d/%d/%d" r g b
138 let rgba_to_string (r, g, b, a) =
139 let r = truncate
(r *. 255.0)
140 and g = truncate
(g *. 255.0)
141 and b = truncate
(b *. 255.0)
142 and a = truncate
(a *. 255.0) in
143 Printf.sprintf
"%d/%d/%d/%d" r g b a
147 if Filename.is_relative path
149 let cwd = Sys.getcwd
() in
150 if Filename.is_implicit path
151 then Filename.concat
cwd path
152 else Filename.concat
cwd (Filename.basename path
)
164 try tempfailureretry Unix.close fd
165 with exn
-> f
@@ exntos exn
169 let getenvwithdef name def
=
170 match Sys.getenv name
with
172 | exception Not_found
-> def
175 let newlinere = Str.regexp
"[\r\n]";;
176 let percentsre = Str.regexp
"%s";;
177 let whitere = Str.regexp
"[ \t]";;
182 let b = Buffer.create
(String.length
s + 1) in
183 Buffer.add_string
b s;
188 let btod b = if b then 1 else 0;;
190 let splitatchar s c
= let open String
in
192 | pos
-> sub
s 0 pos
, sub
s (pos
+1) (length
s - pos
- 1)
193 | exception Not_found
-> s, E.s
196 let boundastep h step
=
198 then bound step ~
-h 0
202 let withoutlastutf8 s =
203 let len = String.length
s in
211 let b = Char.code
s.[pos
] in
212 if b land 0b11000000 = 0b11000000
217 if Char.code
s.[len-1] land 0x80 = 0
221 String.sub
s 0 first;
226 let b = Buffer.create
l in
227 let s = Bytes.create
l in
229 let n = tempfailureretry (Unix.read fd
s 0) l in
231 then Buffer.contents
b
233 Buffer.add_subbytes
b s 0 n;
240 let filecontents path
=
241 let fd = Unix.openfile path
[Unix.O_RDONLY
] 0o0
in
242 match fdcontents fd with
244 error "failed to read contents of %s: %s" path
@@ exntos exn
246 Ne.clo fd @@ error "failed to close descriptor for %s: %s" path
;
250 let getcmdoutput errfun cmd
=
251 let reperror fmt
= Printf.kprintf errfun fmt
in
252 let clofail s e
= error "failed to close %s: %s" s e
in
253 match Unix.pipe
() with
255 reperror "pipe failed: %s" @@ exntos exn
;
258 match spawn cmd
[r, -1; w
, 1] with
260 reperror "failed to execute %S: %s" cmd
@@ exntos exn
;
263 Ne.clo w
@@ clofail "write end of the pipe";
265 match Unix.waitpid
[] pid
with
267 reperror "waitpid on %S %d failed: %s" cmd pid
@@ exntos exn
;
269 | _pid
, Unix.WEXITED
0 ->
271 match fdcontents r with
273 reperror "failed to read output of %S: %s" cmd
@@ exntos exn
;
276 let l = String.length
s in
277 if l > 0 && s.[l-1] = '
\n'
278 then String.sub
s 0 (l-1)
281 | _pid
, Unix.WEXITED
n ->
282 reperror "%S exited with error code %d" cmd
n;
284 | _pid
, Unix.WSIGNALED
n ->
285 reperror "%S was killed with signal %d" cmd
n;
287 | _pid
, Unix.WSTOPPED
n ->
288 reperror "%S was stopped by signal %d" cmd
n;
291 Ne.clo r @@ clofail "read end of the pipe";
296 let re = Str.regexp
{|.*\
(\
(https?\
|ftp\
|mailto\
|file\
)://[^
]+\
).*|} in
298 if Str.string_match
re s 0
299 then Str.matched_group
1 s
303 let substratis s pos subs
=
304 let subslen = String.length subs
in
305 if String.length
s - pos
>= subslen
307 let rec cmp i
= i
= subslen || (s.[pos
+i
] = subs
.[i
]) && cmp (i
+1)
312 let w8 s pos i
= Bytes.set
s pos
(Char.chr
(i
land 0xff));;
313 let r8 s pos
= Char.code
(Bytes.get
s pos
);;
317 w8 s (pos
+1) (i
lsr 8)
322 w16 s (pos
+2) (i
lsr 16)
326 let rb pos1
= Char.code
(Bytes.get
s (pos
+ pos1
)) in
327 (rb 0) lor ((rb 1) lsl 8)
332 i - ((i land 0x8000) lsl 1)
336 let rb pos1
= Char.code
(Bytes.get
s (pos
+ pos1
)) in
337 let l = (rb 0) lor ((rb 1) lsl 8)
338 and u
= (rb 2) lor ((rb 3) lsl 8) in
343 let rb pos1
= Char.code
(Bytes.get
s (pos
+ pos1
)) in
344 let v0 = rb 0 and v1
= rb 1 and v2
= rb 2 and v3
= rb 3 in
345 let v = v0 lor (v1
lsl 8) lor (v2
lsl 16) lor (v3
lsl 24) in
346 if v3
land 0x80 = 0 then
352 let vlog fmt
= Format.ksprintf ignore fmt
;;