Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 186 lines (149 sloc) 5.513 kb
b2c8070 @nrs135 [feature] mongo: New files for mongo API.
nrs135 authored
1 (*
227e038 @OpaOnWindowsNow [fix] libbase/mongo: using GC finalise to do safe pool handling
OpaOnWindowsNow authored
2 Copyright © 2011, 2012 MLstate
b2c8070 @nrs135 [feature] mongo: New files for mongo API.
nrs135 authored
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18
a78f4f3 @Aqua-Ye [enhance] buf,debug: added a static variable to debug buf
Aqua-Ye authored
19 #<Debugvar:BUF_DEBUG>
20
b2c8070 @nrs135 [feature] mongo: New files for mongo API.
nrs135 authored
21 (* Simple library, like Buffer but fixed size but can also look like String if required *)
22
23 type buf = { mutable str : string; mutable i : int }
24 type t = buf
25
bbb47cb @nrs135 [enhance] libbase: Made Buf module optionally resizable according to gl...
nrs135 authored
26 type resize_mode =
27 | RM_stdout
28 | RM_stderr
29 | RM_custom of (string -> unit)
30 | RM_failwith
31 | RM_exit
32 | RM_noresize
33
34 let auto_resize = ref RM_stderr
35
36 let empty () = { str=""; i=0; }
b2c8070 @nrs135 [feature] mongo: New files for mongo API.
nrs135 authored
37
38 let create size = { str=String.create size; i=0; }
39
40 let make size ch = { str=String.make size ch; i=size; }
41
bbb47cb @nrs135 [enhance] libbase: Made Buf module optionally resizable according to gl...
nrs135 authored
42 (* More conservative than Buffer, we grow more slowly and
43 * we allow shrinkage by giving negative values to extra.
44 *)
45 let resize buf extra =
46 let strlen = String.length buf.str in
47 let target = max 0 (if extra >= 0 then buf.i + extra else strlen + extra) in
48 let newsize =
49 if extra >= 0
50 then
51 let newsize = ref (max strlen 2) in
52 while !newsize < target do
53 newsize := max (!newsize+1) ((!newsize + !newsize + !newsize) / 2)
54 done;
55 if !newsize > Sys.max_string_length
56 then
57 if target <= Sys.max_string_length
58 then Sys.max_string_length
59 else failwith "Buf.resize: cannot increase size of buffer"
60 else !newsize
61 else target
62 in
63 let str = String.create newsize in
64 let newlen = min buf.i newsize in
b2c8070 @nrs135 [feature] mongo: New files for mongo API.
nrs135 authored
65 if buf.i > 0 then String.unsafe_blit buf.str 0 str 0 newlen;
66 buf.str <- str;
bbb47cb @nrs135 [enhance] libbase: Made Buf module optionally resizable according to gl...
nrs135 authored
67 buf.i <- newlen;
68 if newsize > strlen
69 then
70 let msg = Printf.sprintf "Buf.resize called (now %d), please resize your buffers" newsize in
71 match !auto_resize with
a78f4f3 @Aqua-Ye [enhance] buf,debug: added a static variable to debug buf
Aqua-Ye authored
72 | RM_stdout ->
73 #<If> Printf.eprintf "%s\n%!" msg #<Else> () #<End>
74 | RM_stderr ->
75 #<If> Printf.eprintf "%s\n%!" msg #<Else> () #<End>
bbb47cb @nrs135 [enhance] libbase: Made Buf module optionally resizable according to gl...
nrs135 authored
76 | RM_custom f -> f msg
77 | RM_failwith -> failwith msg
78 | RM_exit -> exit 1
79 | RM_noresize -> ()
80
81 let autoresize buf extra msg =
82 if !auto_resize <> RM_noresize
83 then resize buf extra
84 else invalid_arg msg
b2c8070 @nrs135 [feature] mongo: New files for mongo API.
nrs135 authored
85
79660b4 @nrs135 [feature] libbase: Added copy to Buf.
nrs135 authored
86 let copy buf = { str=String.copy buf.str; i=buf.i }
87
227e038 @OpaOnWindowsNow [fix] libbase/mongo: using GC finalise to do safe pool handling
OpaOnWindowsNow authored
88 let finalize buf unused younger =
89 buf.i <- younger.i;
90 buf.str <- younger.str;
91 unused buf
92
93 let mark_as_used ~unused buf =
94 let younger = { str=buf.str; i=buf.i } in
95 Gc.finalise (finalize buf unused) younger;
96 younger
97
b2c8070 @nrs135 [feature] mongo: New files for mongo API.
nrs135 authored
98 let clear buf = buf.i <- 0
99
100 let reset buf = buf.str <- ""; buf.i <- 0
101
102 let length buf = buf.i
103
104 let real_length buf = String.length buf.str
105
106 let get buf i =
107 if i < 0 || i >= buf.i then invalid_arg (Printf.sprintf "Buf.get index out of bounds %d" i);
108 String.get buf.str i
109 let nth = get
110
111 let unsafe_get buf i = String.unsafe_get buf.str i
112
113 let set buf i ch =
114 if i < 0 || i >= buf.i then invalid_arg (Printf.sprintf "Buf.set index out of bounds %d" i);
115 String.set buf.str i ch
116
117 let unsafe_set buf i ch = String.unsafe_set buf.str i ch
118
119 let sub buf base len =
732d845 @nrs135 [feature] libbase: Added add_substring to Buf.
nrs135 authored
120 if base < 0 || base + len > buf.i then invalid_arg (Printf.sprintf "Buf.sub index out of bounds %d %d" base len);
b2c8070 @nrs135 [feature] mongo: New files for mongo API.
nrs135 authored
121 String.sub buf.str base len
122
123 let add_char buf ch =
bbb47cb @nrs135 [enhance] libbase: Made Buf module optionally resizable according to gl...
nrs135 authored
124 if String.length buf.str - buf.i < 1 then autoresize buf 1 (Printf.sprintf "Buf.add_char %c" ch);
b2c8070 @nrs135 [feature] mongo: New files for mongo API.
nrs135 authored
125 buf.str.[buf.i] <- ch;
126 buf.i <- buf.i + 1
127
732d845 @nrs135 [feature] libbase: Added add_substring to Buf.
nrs135 authored
128 let add_substring buf str base len =
bbb47cb @nrs135 [enhance] libbase: Made Buf module optionally resizable according to gl...
nrs135 authored
129 if String.length buf.str - buf.i < len then autoresize buf len (Printf.sprintf "Buf.add_substring %s %d %d" str base len);
732d845 @nrs135 [feature] libbase: Added add_substring to Buf.
nrs135 authored
130 String.unsafe_blit str base buf.str buf.i len;
b2c8070 @nrs135 [feature] mongo: New files for mongo API.
nrs135 authored
131 buf.i <- buf.i + len
132
732d845 @nrs135 [feature] libbase: Added add_substring to Buf.
nrs135 authored
133 let append buf str len = add_substring buf str 0 len
134
b2c8070 @nrs135 [feature] mongo: New files for mongo API.
nrs135 authored
135 let extend buf len =
bbb47cb @nrs135 [enhance] libbase: Made Buf module optionally resizable according to gl...
nrs135 authored
136 if String.length buf.str - buf.i < len then autoresize buf len (Printf.sprintf "Buf.extend %d" len);
b2c8070 @nrs135 [feature] mongo: New files for mongo API.
nrs135 authored
137 buf.i <- buf.i + len
138
139 let add_string buf str =
140 append buf str (String.length str)
141
142 let add_buf buf1 buf2 =
143 append buf1 buf2.str buf2.i
144
145 let of_string str = { str; i=String.length str; }
146
147 let to_string buf = String.sub buf.str 0 buf.i
148 let contents = to_string
149
150 let spare buf = String.length buf.str - buf.i
151
152 (* Test code *)
153 (*
154 let buf = of_string "abc";;
155 let () = set buf 1 'B';;
156 let ch = get buf 0;;
157 let ch = get buf 1;;
158 let ch = get buf 2;;
159 let str = try ignore (get buf 3); "NOT OK" with Invalid_argument str -> "OK: "^str;;
160 let str = try ignore (set buf 4 'x'); "NOT OK" with Invalid_argument str -> "OK: "^str;;
161 let buf = create 5;;
162 let () = add_char buf 'D';;
163 let () = add_string buf "ef";;
164 let len = length buf;;
165 let rlen = real_length buf;;
166 let str = to_string buf;;
167 let () = resize buf 8;;
168 let len = length buf;;
169 let rlen = real_length buf;;
170 let str = to_string buf;;
bbb47cb @nrs135 [enhance] libbase: Made Buf module optionally resizable according to gl...
nrs135 authored
171 let () = resize buf (-2);;
b2c8070 @nrs135 [feature] mongo: New files for mongo API.
nrs135 authored
172 let len = length buf;;
173 let rlen = real_length buf;;
174 let str = to_string buf;;
bbb47cb @nrs135 [enhance] libbase: Made Buf module optionally resizable according to gl...
nrs135 authored
175 let str =
176 try ignore (add_char (empty()) 'x');
177 if !auto_resize <> RM_noresize then "OK: resized" else "NOT OK"
178 with Invalid_argument str ->
179 if !auto_resize <> RM_noresize then "NOT OK" else "OK: "^str;;
b2c8070 @nrs135 [feature] mongo: New files for mongo API.
nrs135 authored
180 let () = resize buf 10;;
181 let () = add_string buf "fghi";;
182 let str = to_string buf;;
183 let str = sub buf 1 3;;
184 let str = try ignore (sub buf 100 100); "NOT OK" with Invalid_argument str -> "OK: "^str;;
185 *)
Something went wrong with that request. Please try again.