/[lcore]/trunk/httpserver_20080306/binipstuff.pas
ViewVC logotype

Contents of /trunk/httpserver_20080306/binipstuff.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (show annotations)
Fri Mar 28 02:26:58 2008 UTC (11 years, 5 months ago) by plugwash
File size: 10341 byte(s)
initial import

1 { Copyright (C) 2005 Bas Steendijk and Peter Green
2 For conditions of distribution and use, see copyright notice in zlib_license.txt
3 which is included in the package
4 ----------------------------------------------------------------------------- }
5 unit binipstuff;
6
7 interface
8
9 {$ifndef win32}
10 {$ifdef ipv6}
11 uses sockets;
12 {$endif}
13 {$endif}
14
15 {$ifdef fpc}
16 {$mode delphi}
17 {$endif}
18 {$ifdef cpu386}{$define i386}{$endif}
19 {$ifdef i386}{$define ENDIAN_LITTLE}{$endif}
20
21 {$include uint32.inc}
22
23 const
24 hexchars:array[0..15] of char='0123456789abcdef';
25 AF_INET=2;
26 {$ifdef win32}
27 AF_INET6=23;
28 {$else}
29 AF_INET6=10;
30 {$endif}
31
32 type
33 {$ifdef ipv6}
34
35 {$ifdef win32}
36 {$define want_Tin6_addr}
37 {$endif}
38 {$ifdef ver1_0}
39 {$define want_Tin6_addr}
40 {$endif}
41 {$ifdef want_Tin6_addr}
42 Tin6_addr = packed record
43 case byte of
44 0: (u6_addr8 : array[0..15] of byte);
45 1: (u6_addr16 : array[0..7] of Word);
46 2: (u6_addr32 : array[0..3] of uint32);
47 3: (s6_addr8 : array[0..15] of shortint);
48 4: (s6_addr : array[0..15] of shortint);
49 5: (s6_addr16 : array[0..7] of smallint);
50 6: (s6_addr32 : array[0..3] of LongInt);
51 end;
52 {$endif}
53 {$endif}
54
55 tbinip=record
56 family:integer;
57 {$ifdef ipv6}
58 case integer of
59 0: (ip:longint);
60 1: (ip6:tin6_addr);
61 {$else}
62 ip:longint;
63 {$endif}
64 end;
65
66 {$ifdef win32}
67 TInetSockAddr = packed Record
68 family:Word;
69 port :Word;
70 addr :uint32;
71 pad :array [1..8] of byte;
72 end;
73 {$ifdef ipv6}
74
75 TInetSockAddr6 = packed record
76 sin6_family: word;
77 sin6_port: word;
78 sin6_flowinfo: uint32;
79 sin6_addr: tin6_addr;
80 sin6_scope_id: uint32;
81 end;
82 {$endif}
83 {$endif}
84
85 function htons(w:word):word;
86 function htonl(i:uint32):uint32;
87
88 function ipstrtobin(const s:string;var binip:tbinip):boolean;
89 function ipbintostr(const binip:tbinip):string;
90 {$ifdef ipv6}
91 function ip6bintostr(const bin:tin6_addr):string;
92 function ip6strtobin(const s:string;var bin:tin6_addr):boolean;
93 {$endif}
94
95 function comparebinip(const ip1,ip2:tbinip):boolean;
96
97 {deprecated}
98 function longip(s:string):longint;
99
100 procedure converttov4(var ip:tbinip);
101
102 implementation
103
104 uses sysutils;
105
106 function htons(w:word):word;
107 begin
108 {$ifdef ENDIAN_LITTLE}
109 result := ((w and $ff00) shr 8) or ((w and $ff) shl 8);
110 {$else}
111 result := w;
112 {$endif}
113 end;
114
115 function htonl(i:uint32):uint32;
116 begin
117 {$ifdef ENDIAN_LITTLE}
118 result := (i shr 24) or (i shr 8 and $ff00) or (i shl 8 and $ff0000) or (i shl 24 and $ff000000);
119 {$else}
120 result := i;
121 {$endif}
122 end;
123
124 {internal}
125 {converts dotted v4 IP to longint. returns host endian order}
126 function longip(s:string):longint;
127 var
128 l:longint;
129 a,b:integer;
130 function convertbyte(const s:string):integer;
131 begin
132 result := strtointdef(s,-1);
133 if result < 0 then begin
134 result := -1;
135 exit;
136 end;
137 if result > 255 then begin
138 result := -1;
139 exit;
140 end;
141 {01 exception}
142 if (result <> 0) and (s[1] = '0') then begin
143 result := -1;
144 exit;
145 end;
146 {+1 exception}
147 if not (s[1] in ['0'..'9']) then begin
148 result := -1;
149 exit
150 end;
151 end;
152
153 begin
154 result := 0;
155 a := pos('.',s);
156 if a = 0 then exit;
157 b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;
158 l := b shl 24;
159 s := copy(s,a+1,256);
160 a := pos('.',s);
161 if a = 0 then exit;
162 b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;
163 l := l or b shl 16;
164 s := copy(s,a+1,256);
165 a := pos('.',s);
166 if a = 0 then exit;
167 b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;
168 l := l or b shl 8;
169 s := copy(s,a+1,256);
170 b := convertbyte(copy(s,1,256));if (b < 0) then exit;
171 l := l or b;
172 result := l;
173 end;
174
175
176 function ipstrtobin(const s:string;var binip:tbinip):boolean;
177 begin
178 binip.family := 0;
179 result := false;
180 {$ifdef ipv6}
181 if pos(':',s) <> 0 then begin
182 {try ipv6. use builtin routine}
183 result := ip6strtobin(s,binip.ip6);
184 if result then binip.family := AF_INET6;
185 exit;
186 end;
187 {$endif}
188
189 {try v4}
190 binip.ip := htonl(longip(s));
191 if (binip.ip <> 0) or (s = '0.0.0.0') then begin
192 result := true;
193 binip.family := AF_INET;
194 exit;
195 end;
196 end;
197
198 function ipbintostr(const binip:tbinip):string;
199 var
200 a:integer;
201 begin
202 result := '';
203 {$ifdef ipv6}
204 if binip.family = AF_INET6 then begin
205 result := ip6bintostr(binip.ip6);
206 end else
207 {$endif}
208 if binip.family = AF_INET then begin
209 a := htonl(binip.ip);
210 result := inttostr(a shr 24)+'.'+inttostr((a shr 16) and $ff)+'.'+inttostr((a shr 8) and $ff)+'.'+inttostr(a and $ff);
211 end;
212 end;
213
214
215 {------------------------------------------------------------------------------}
216
217 {$ifdef ipv6}
218
219 {
220 IPv6 address binary to/from string conversion routines
221 written by beware (steendijk at xs4all dot nl)
222
223 - implementation does not depend on other ipv6 code such as the tin6_addr type,
224 the parameter can also be untyped.
225 - it is host endian neutral - binary format is aways network order
226 - it supports compression of zeroes
227 - it supports ::ffff:192.168.12.34 style addresses
228 - they are made to do the Right Thing, more efficient implementations are possible
229 }
230
231 {fpc has hostaddrtostr6 and strtohostaddr6 but the later isnt implemented yet}
232
233
234 function ip6bintostr(const bin:tin6_addr):string;
235 {base16 with lowercase output}
236 function makehex(w:word):string;
237 begin
238 result := '';
239 if w >= 4096 then result := result + hexchars[w shr 12];
240 if w >= 256 then result := result + hexchars[w shr 8 and $f];
241 if w >= 16 then result := result + hexchars[w shr 4 and $f];
242 result := result + hexchars[w and $f];
243 end;
244
245 var
246 a,b,c,addrlen:integer;
247 runbegin,runlength:integer;
248 bytes:array[0..15] of byte absolute bin;
249 words:array[0..7] of word;
250 dwords:array[0..3] of integer absolute words;
251 begin
252 for a := 0 to 7 do begin
253 words[a] := bytes[a shl 1] shl 8 or bytes[a shl 1 or 1];
254 end;
255 if (dwords[0] = 0) and (dwords[1] = 0) and (words[4] = 0) and (words[5] = $ffff) then begin
256 {::ffff:/96 exception: v4 IP}
257 addrlen := 6;
258 end else begin
259 addrlen := 8;
260 end;
261 {find longest run of zeroes}
262 runbegin := 0;
263 runlength := 0;
264 for a := 0 to addrlen-1 do begin
265 if words[a] = 0 then begin
266 c := 0;
267 for b := a to addrlen-1 do if words[b] = 0 then begin
268 inc(c);
269 end else break;
270 if (c > runlength) then begin
271 runlength := c;
272 runbegin := a;
273 end;
274 end;
275 end;
276 result := '';
277 for a := 0 to runbegin-1 do begin
278 if (a <> 0) then result := result + ':';
279 result := result + makehex(words[a]);
280 end;
281 if runlength > 0 then result := result + '::';
282 c := runbegin+runlength;
283 for a := c to addrlen-1 do begin
284 if (a > c) then result := result + ':';
285 result := result + makehex(words[a]);
286 end;
287 if addrlen = 6 then begin
288 result := result + ':'+inttostr(bytes[12])+'.'+inttostr(bytes[13])+'.'+inttostr(bytes[14])+'.'+inttostr(bytes[15]);
289 end;
290 end;
291
292 function ip6strtobin(const s:string;var bin:tin6_addr):boolean;
293 var
294 a,b:integer;
295 fields:array[0..7] of string;
296 fieldcount:integer;
297 emptyfield:integer;
298 wordcount:integer;
299 words:array[0..7] of word;
300 bytes:array[0..15] of byte absolute bin;
301 begin
302 result := false;
303 for a := 0 to 7 do fields[a] := '';
304 fieldcount := 0;
305 for a := 1 to length(s) do begin
306 if s[a] = ':' then inc(fieldcount) else fields[fieldcount] := fields[fieldcount] + s[a];
307 if fieldcount > 7 then exit;
308 end;
309 if fieldcount < 2 then exit;
310
311 {find the empty field (compressed zeroes), not counting the first and last there may be at most 1}
312 emptyfield := -1;
313 for a := 1 to fieldcount-1 do begin
314 if fields[a] = '' then begin
315 if emptyfield = -1 then emptyfield := a else exit;
316 end;
317 end;
318
319 {check if last field is a valid v4 IP}
320 a := longip(fields[fieldcount]);
321 if (a <> 0) or (fields[fieldcount] = '0.0.0.0') then wordcount := 6 else wordcount := 8;
322 {0:1:2:3:4:5:6.6.6.6
323 0:1:2:3:4:5:6:7}
324 fillchar(words,sizeof(words),0);
325 if wordcount = 6 then begin
326 if fieldcount > 6 then exit;
327 words[6] := a shr 16;
328 words[7] := a and $ffff;
329 end;
330 if emptyfield = -1 then begin
331 {no run length: must be an exact number of fields}
332 if wordcount = 6 then begin
333 if fieldcount <> 6 then exit;
334 emptyfield := 5;
335 end else if wordcount = 8 then begin
336 if fieldcount <> 7 then exit;
337 emptyfield := 7;
338 end else exit;
339 end;
340 for a := 0 to emptyfield do begin
341 if fields[a] = '' then b := 0 else b := strtointdef('$'+fields[a],-1);
342 if (b < 0) or (b > $ffff) then exit;
343 words[a] := b;
344 end;
345 if wordcount = 6 then dec(fieldcount);
346 for a := wordcount-1 downto wordcount-(fieldcount-emptyfield) do begin
347 b := a+fieldcount-wordcount+1;
348 if fields[b] = '' then b := 0 else b := strtointdef('$'+fields[b],-1);
349 if (b < 0) or (b > $ffff) then exit;
350 words[a] := b;
351 end;
352 for a := 0 to 7 do begin
353 bytes[a shl 1] := words[a] shr 8;
354 bytes[a shl 1 or 1] := words[a] and $ff;
355 end;
356 result := true;
357 end;
358 {$endif}
359
360 function comparebinip(const ip1,ip2:tbinip):boolean;
361 begin
362 if (ip1.ip <> ip2.ip) then begin
363 result := false;
364 exit;
365 end;
366
367 {$ifdef ipv6}
368 if ip1.family = AF_INET6 then begin
369 if (ip1.ip6.s6_addr32[1] <> ip2.ip6.s6_addr32[1])
370 or (ip1.ip6.s6_addr32[2] <> ip2.ip6.s6_addr32[2])
371 or (ip1.ip6.s6_addr32[3] <> ip2.ip6.s6_addr32[3]) then begin
372 result := false;
373 exit;
374 end;
375 end;
376 {$endif}
377
378 result := (ip1.family = ip2.family);
379 end;
380
381 {converts a binary IP to v4 if it is a v6 IP in the v4 range}
382 procedure converttov4(var ip:tbinip);
383 begin
384 {$ifdef ipv6}
385 if ip.family = AF_INET6 then begin
386 if (ip.ip6.u6_addr32[0] = 0) and (ip.ip6.u6_addr32[1] = 0) and
387 (ip.ip6.u6_addr16[4] = 0) and (ip.ip6.u6_addr16[5] = $ffff) then begin
388 ip.family := AF_INET;
389 ip.ip := ip.ip6.s6_addr32[3];
390 end;
391 end;
392 {$endif}
393 end;
394
395 end.

Properties

Name Value
svn:executable

No admin address has been configured">No admin address has been configured
ViewVC Help
Powered by ViewVC 1.1.22