Source file bigstring.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
include Shexp_bigstring.Std.Bigstring
external unsafe_write : Unix.file_descr -> t -> pos:int -> len:int -> int
= "shexp_bigstring_io_write"
external unsafe_read : Unix.file_descr -> t -> pos:int -> len:int -> int
= "shexp_bigstring_io_read"
let write fd buf ~pos ~len =
check_pos_len_exn ~pos ~len ~length:(length buf);
unsafe_write fd buf ~pos ~len
let read fd buf ~pos ~len =
check_pos_len_exn ~pos ~len ~length:(length buf);
unsafe_read fd buf ~pos ~len
let read_all fd =
fold_temporary ~size:4096 ~init:0 ~f:(fun buf pos ->
match read fd buf ~pos ~len:(length buf - pos) with
| 0 -> Return (sub_string buf ~pos:0 ~len:pos)
| n ->
let pos = pos + n in
let size = length buf in
let new_size =
if pos = size then (
let size = size * 2 in
if size < 0 then max_int else size
) else
size
in
Resize { new_size; state = pos }
| exception Unix.Unix_error (EINTR, _, _) ->
Continue { state = pos })
let write_all fd s =
let len = String.length s in
with_temporary ~size:len ~f:(fun buf ->
blit_string_t ~src:s ~src_pos:0 ~dst:buf ~dst_pos:0 ~len;
let rec loop pos =
if pos = len then
()
else
match write fd buf ~pos ~len:(len - pos) with
| n -> loop (pos + n)
| exception Unix.Unix_error (EINTR, _, _) ->
loop pos
in
loop 0)
let read_exactly fd len =
with_temporary ~size:len ~f:(fun buf ->
let rec loop pos =
if pos = len then
sub_string buf ~pos:0 ~len
else
match read fd buf ~pos ~len:(len - pos) with
| n -> loop (pos + n)
| exception Unix.Unix_error (EINTR, _, _) ->
loop pos
in
loop 0)
type read_all_interruptible_result =
{ interrupted : bool
; collected : string
}
let read_all_interruptible ?(delay=1.0) fd ~stop =
fold_temporary ~size:4096 ~init:0 ~f:(fun buf pos ->
let size = length buf in
match Unix.select [fd] [] [] delay with
| [], [], [] ->
if stop () then
Return { interrupted = true
; collected = sub_string buf ~pos:0 ~len:pos
}
else
Continue { state = pos }
| _ ->
match read fd buf ~pos ~len:(size - pos) with
| 0 -> Return { interrupted = false
; collected = sub_string buf ~pos:0 ~len:pos
}
| n ->
let pos = pos + n in
let new_size =
if pos = size then (
let size = size * 2 in
if size < 0 then max_int else size
) else
size
in
Resize { new_size; state = pos })
type separator =
| End_of_line
| Char of char
let fold_gen fd ~sep ~init ~f =
fold_temporary ~size:4096 ~init:(0, init) ~f:(fun buf (pos, acc) ->
match read fd buf ~pos ~len:(length buf - pos) with
| 0 ->
if pos = 0 then
Return acc
else
Return (f acc (sub_string buf ~pos:0 ~len:pos))
| n ->
let rec loop acc ~start ~pos ~stop : (_, _) fold_temporary_result =
let char =
match sep with
| End_of_line -> '\n'
| Char c -> c
in
match index buf ~pos ~len:(stop - pos) ~char with
| None ->
if start > 0 then
blit ~src:buf ~dst:buf ~src_pos:start ~dst_pos:0
~len:(stop - start);
let pos = stop - start in
let size = length buf in
let new_size =
if pos = size then (
let size = size * 2 in
if size < 0 then max_int else size
) else
size
in
Resize { new_size; state = (pos, acc) }
| Some end_of_chunk ->
let chunk_len =
if sep = End_of_line && end_of_chunk > 0 && buf.{end_of_chunk - 1} = '\r' then
end_of_chunk - 1 - start
else
end_of_chunk - start
in
let chunk = sub_string buf ~pos:start ~len:chunk_len in
let acc = f acc chunk in
loop acc ~start:(end_of_chunk + 1) ~pos:(end_of_chunk + 1) ~stop
in
loop acc ~start:0 ~pos ~stop:(pos + n))
let fold_lines fd ~init ~f = fold_gen fd ~sep:End_of_line ~init ~f
let fold_chunks fd ~sep ~init ~f = fold_gen fd ~sep:(Char sep) ~init ~f