Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 236 lines (194 sloc) 12.06 kb
cbec25f @nrs135 [feature] libbase: Added Bson module.
nrs135 authored
1 (*
2 Copyright © 2011 MLstate
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
19
20 (* Stuff data in buffers *)
21
22 (* These might be more efficient written as C externals. *)
23
24 (* Naming convention:
25 - (l|b) little/big endian
26 - (e|d) encode/decode
27 - (i32|i64|d|i32l) int32/int64/float/Int32.t
28 *)
29
30 module type STUFF =
31 sig
32 type t
33 val get : t -> int -> char
34 val set : t -> int -> char -> unit
35 end
36
37 module StuffF (S : STUFF) =
38 struct
39
40 let lei32 s pos i =
41 S.set s (pos+3) (Char.chr ((i lsr 24) land 0xff));
42 S.set s (pos+2) (Char.chr ((i lsr 16) land 0xff));
43 S.set s (pos+1) (Char.chr ((i lsr 8 ) land 0xff));
44 S.set s (pos+0) (Char.chr ( i land 0xff))
45
46 let bei32 s pos i =
47 S.set s (pos+0) (Char.chr ((i lsr 24) land 0xff));
48 S.set s (pos+1) (Char.chr ((i lsr 16) land 0xff));
49 S.set s (pos+2) (Char.chr ((i lsr 8 ) land 0xff));
50 S.set s (pos+3) (Char.chr ( i land 0xff))
51
52 let lei64 s pos i =
53 S.set s (pos+7) (Char.chr ((i lsr 56) land 0xff));
54 S.set s (pos+6) (Char.chr ((i lsr 48) land 0xff));
55 S.set s (pos+5) (Char.chr ((i lsr 40) land 0xff));
56 S.set s (pos+4) (Char.chr ((i lsr 32) land 0xff));
57 S.set s (pos+3) (Char.chr ((i lsr 24) land 0xff));
58 S.set s (pos+2) (Char.chr ((i lsr 16) land 0xff));
59 S.set s (pos+1) (Char.chr ((i lsr 8 ) land 0xff));
60 S.set s (pos+0) (Char.chr ( i land 0xff))
61
62 let bei64 s pos i =
63 S.set s (pos+0) (Char.chr ((i lsr 56) land 0xff));
64 S.set s (pos+1) (Char.chr ((i lsr 48) land 0xff));
65 S.set s (pos+2) (Char.chr ((i lsr 40) land 0xff));
66 S.set s (pos+3) (Char.chr ((i lsr 32) land 0xff));
67 S.set s (pos+4) (Char.chr ((i lsr 24) land 0xff));
68 S.set s (pos+5) (Char.chr ((i lsr 16) land 0xff));
69 S.set s (pos+6) (Char.chr ((i lsr 8 ) land 0xff));
70 S.set s (pos+7) (Char.chr ( i land 0xff))
71
72 let led s pos f =
73 let b = Int64.bits_of_float f in
74 S.set s (pos+7) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 56) 0xffL)));
75 S.set s (pos+6) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 48) 0xffL)));
76 S.set s (pos+5) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 40) 0xffL)));
77 S.set s (pos+4) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 32) 0xffL)));
78 S.set s (pos+3) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 24) 0xffL)));
79 S.set s (pos+2) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 16) 0xffL)));
80 S.set s (pos+1) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 8 ) 0xffL)));
81 S.set s (pos+0) (Char.chr (Int64.to_int (Int64.logand ( b ) 0xffL)))
82
83 let bed s pos f =
84 let b = Int64.bits_of_float f in
85 S.set s (pos+0) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 56) 0xffL)));
86 S.set s (pos+1) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 48) 0xffL)));
87 S.set s (pos+2) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 40) 0xffL)));
88 S.set s (pos+3) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 32) 0xffL)));
89 S.set s (pos+4) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 24) 0xffL)));
90 S.set s (pos+5) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 16) 0xffL)));
91 S.set s (pos+6) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical b 8 ) 0xffL)));
92 S.set s (pos+7) (Char.chr (Int64.to_int (Int64.logand ( b ) 0xffL)))
93
94 let lei32l s pos i32 =
95 S.set s (pos+3) (Char.chr (Int32.to_int (Int32.logand (Int32.shift_right_logical i32 24) 0xffl)));
96 S.set s (pos+2) (Char.chr (Int32.to_int (Int32.logand (Int32.shift_right_logical i32 16) 0xffl)));
97 S.set s (pos+1) (Char.chr (Int32.to_int (Int32.logand (Int32.shift_right_logical i32 8 ) 0xffl)));
98 S.set s (pos+0) (Char.chr (Int32.to_int (Int32.logand ( i32 ) 0xffl)))
99
100 let bei32l s pos i32 =
101 S.set s (pos+0) (Char.chr (Int32.to_int (Int32.logand (Int32.shift_right_logical i32 24) 0xffl)));
102 S.set s (pos+1) (Char.chr (Int32.to_int (Int32.logand (Int32.shift_right_logical i32 16) 0xffl)));
103 S.set s (pos+2) (Char.chr (Int32.to_int (Int32.logand (Int32.shift_right_logical i32 8 ) 0xffl)));
104 S.set s (pos+3) (Char.chr (Int32.to_int (Int32.logand ( i32 ) 0xffl)))
105
68933f7 @nrs135 [feature] mongo: Partial version of mongo wire protocol.
nrs135 authored
106 let lei64L s pos i64 =
107 S.set s (pos+7) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 56) 0xffL)));
108 S.set s (pos+6) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 48) 0xffL)));
109 S.set s (pos+5) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 40) 0xffL)));
110 S.set s (pos+4) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 32) 0xffL)));
111 S.set s (pos+3) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 24) 0xffL)));
112 S.set s (pos+2) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 16) 0xffL)));
113 S.set s (pos+1) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 8 ) 0xffL)));
114 S.set s (pos+0) (Char.chr (Int64.to_int (Int64.logand ( i64 ) 0xffL)))
115
116 let bei64L s pos i64 =
117 S.set s (pos+0) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 56) 0xffL)));
118 S.set s (pos+1) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 48) 0xffL)));
119 S.set s (pos+2) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 40) 0xffL)));
120 S.set s (pos+3) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 32) 0xffL)));
121 S.set s (pos+4) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 24) 0xffL)));
122 S.set s (pos+5) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 16) 0xffL)));
123 S.set s (pos+6) (Char.chr (Int64.to_int (Int64.logand (Int64.shift_right_logical i64 8 ) 0xffL)));
124 S.set s (pos+7) (Char.chr (Int64.to_int (Int64.logand ( i64 ) 0xffL)))
125
cbec25f @nrs135 [feature] libbase: Added Bson module.
nrs135 authored
126 let ldi32 s i =
127 (((Char.code (S.get (s) (i+3))) lsl 24) land 0xff000000) lor
128 (((Char.code (S.get (s) (i+2))) lsl 16) land 0x00ff0000) lor
129 (((Char.code (S.get (s) (i+1))) lsl 8) land 0x0000ff00) lor
130 (((Char.code (S.get (s) (i+0))) ) land 0x000000ff)
131
132 let bdi32 s i =
133 (((Char.code (S.get (s) (i+0))) lsl 24) land 0xff000000) lor
134 (((Char.code (S.get (s) (i+1))) lsl 16) land 0x00ff0000) lor
135 (((Char.code (S.get (s) (i+2))) lsl 8) land 0x0000ff00) lor
136 (((Char.code (S.get (s) (i+3))) ) land 0x000000ff)
137
138 let ldi64 s i =
139 (((Char.code (S.get (s) (i+7))) lsl 56) land 0x7f00000000000000) lor
140 (((Char.code (S.get (s) (i+6))) lsl 48) land 0x00ff000000000000) lor
141 (((Char.code (S.get (s) (i+5))) lsl 40) land 0x0000ff0000000000) lor
142 (((Char.code (S.get (s) (i+4))) lsl 32) land 0x000000ff00000000) lor
143 (((Char.code (S.get (s) (i+3))) lsl 24) land 0x00000000ff000000) lor
144 (((Char.code (S.get (s) (i+2))) lsl 16) land 0x0000000000ff0000) lor
145 (((Char.code (S.get (s) (i+1))) lsl 8) land 0x000000000000ff00) lor
146 (((Char.code (S.get (s) (i+0))) ) land 0x00000000000000ff)
147
148
149 let bdi64 s i =
150 (((Char.code (S.get (s) (i+0))) lsl 56) land 0x7f00000000000000) lor
151 (((Char.code (S.get (s) (i+1))) lsl 48) land 0x00ff000000000000) lor
152 (((Char.code (S.get (s) (i+2))) lsl 40) land 0x0000ff0000000000) lor
153 (((Char.code (S.get (s) (i+3))) lsl 32) land 0x000000ff00000000) lor
154 (((Char.code (S.get (s) (i+4))) lsl 24) land 0x00000000ff000000) lor
155 (((Char.code (S.get (s) (i+5))) lsl 16) land 0x0000000000ff0000) lor
156 (((Char.code (S.get (s) (i+6))) lsl 8) land 0x000000000000ff00) lor
157 (((Char.code (S.get (s) (i+7))) ) land 0x00000000000000ff)
158
0e04090 @nrs135 [feature] libbase: Added i64L to Stuff.
nrs135 authored
159 let ldi64L s i =
cbec25f @nrs135 [feature] libbase: Added Bson module.
nrs135 authored
160 (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+7)))) 56) 0xff00000000000000L)
161 (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+6)))) 48) 0x00ff000000000000L)
162 (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+5)))) 40) 0x0000ff0000000000L)
163 (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+4)))) 32) 0x000000ff00000000L)
164 (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+3)))) 24) 0x00000000ff000000L)
165 (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+2)))) 16) 0x0000000000ff0000L)
166 (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+1)))) 8) 0x000000000000ff00L)
167 (Int64.logand ( (Int64.of_int (Char.code (S.get (s) (i+0)))) ) 0x00000000000000ffL))))))))
168
0e04090 @nrs135 [feature] libbase: Added i64L to Stuff.
nrs135 authored
169 let bdi64L s i =
cbec25f @nrs135 [feature] libbase: Added Bson module.
nrs135 authored
170 (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+0)))) 56) 0xff00000000000000L)
171 (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+1)))) 48) 0x00ff000000000000L)
172 (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+2)))) 40) 0x0000ff0000000000L)
173 (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+3)))) 32) 0x000000ff00000000L)
174 (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+4)))) 24) 0x00000000ff000000L)
175 (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+5)))) 16) 0x0000000000ff0000L)
176 (Int64.logor (Int64.logand (Int64.shift_left (Int64.of_int (Char.code (S.get (s) (i+6)))) 8) 0x000000000000ff00L)
177 (Int64.logand ( (Int64.of_int (Char.code (S.get (s) (i+7)))) ) 0x00000000000000ffL))))))))
178
0e04090 @nrs135 [feature] libbase: Added i64L to Stuff.
nrs135 authored
179 let ldd s i = Int64.float_of_bits (ldi64L s i)
180 let bdd s i = Int64.float_of_bits (bdi64L s i)
181
68933f7 @nrs135 [feature] mongo: Partial version of mongo wire protocol.
nrs135 authored
182 end (* module StuffF *)
183
184 module StuffString = StuffF(String)
185
186 let add_le_int32 b i =
187 if Buf.spare b <= 4 then raise (Failure "add_le_int32");
188 StuffString.lei32 b.Buf.str b.Buf.i i;
189 b.Buf.i <- b.Buf.i + 4
190
191 let add_be_int32 b i =
192 if Buf.spare b <= 4 then raise (Failure "add_be_int32");
193 StuffString.bei32 b.Buf.str b.Buf.i i;
194 b.Buf.i <- b.Buf.i + 4
195
196 let add_le_int64 b i =
197 if Buf.spare b <= 8 then raise (Failure "add_le_int64");
198 StuffString.lei64 b.Buf.str b.Buf.i i;
199 b.Buf.i <- b.Buf.i + 8
200
201 let add_be_int64 b i =
202 if Buf.spare b <= 8 then raise (Failure "add_be_int64");
203 StuffString.bei64 b.Buf.str b.Buf.i i;
204 b.Buf.i <- b.Buf.i + 8
205
206 let add_le_d b i =
207 if Buf.spare b <= 8 then raise (Failure "add_le_d");
208 StuffString.led b.Buf.str b.Buf.i i;
209 b.Buf.i <- b.Buf.i + 8
210
211 let add_be_d b i =
212 if Buf.spare b <= 8 then raise (Failure "add_be_d");
213 StuffString.bed b.Buf.str b.Buf.i i;
214 b.Buf.i <- b.Buf.i + 8
215
216 let add_le_int32l b i =
217 if Buf.spare b <= 4 then raise (Failure "add_le_i32l");
218 StuffString.lei32l b.Buf.str b.Buf.i i;
219 b.Buf.i <- b.Buf.i + 4
220
221 let add_be_int32l b i =
222 if Buf.spare b <= 4 then raise (Failure "add_be_i32l");
223 StuffString.bei32l b.Buf.str b.Buf.i i;
224 b.Buf.i <- b.Buf.i + 4
225
226 let add_le_int64L b i =
227 if Buf.spare b <= 4 then raise (Failure "add_le_i64L");
228 StuffString.lei64L b.Buf.str b.Buf.i i;
229 b.Buf.i <- b.Buf.i + 8
230
231 let add_be_int64L b i =
232 if Buf.spare b <= 4 then raise (Failure "add_be_i64L");
233 StuffString.bei64L b.Buf.str b.Buf.i i;
234 b.Buf.i <- b.Buf.i + 8
cbec25f @nrs135 [feature] libbase: Added Bson module.
nrs135 authored
235
Something went wrong with that request. Please try again.