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

Contents of /trunk/binipstuff.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 94 - (show annotations)
Mon Feb 21 21:40:05 2011 UTC (8 years, 8 months ago) by beware
File size: 17343 byte(s)
eliminated a lot of hints and warnings
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 {$ifdef fpc}
8 {$mode delphi}
9 {$endif}
10
11 interface
12
13 {$include lcoreconfig.inc}
14
15 uses
16 {$ifndef win32}
17 sockets,
18 {$endif}
19 pgtypes;
20
21 {$ifdef cpu386}{$define i386}{$endif}
22 {$ifdef i386}{$define ENDIAN_LITTLE}{$endif}
23
24 {$include uint32.inc}
25
26 const
27 hexchars:array[0..15] of ansichar='0123456789abcdef';
28 {$ifdef win32}
29 AF_INET=2;
30 AF_INET6=23;
31 {$else}
32 //redeclare these constants so units that use us can use them
33 //without using sockets directly
34 AF_INET=AF_INET;
35 AF_INET6=AF_INET6;
36 //AF_INET6=10;
37 {$endif}
38
39 type
40 {$ifdef ipv6}
41
42 {$ifdef win32}
43 {$define want_Tin6_addr}
44 {$endif}
45 {$ifdef ver1_0}
46 {$define want_Tin6_addr}
47 {$endif}
48 {$ifdef want_Tin6_addr}
49 Tin6_addr = packed record
50 case byte of
51 0: (u6_addr8 : array[0..15] of byte);
52 1: (u6_addr16 : array[0..7] of Word);
53 2: (u6_addr32 : array[0..3] of uint32);
54 3: (s6_addr8 : array[0..15] of shortint);
55 4: (s6_addr : array[0..15] of shortint);
56 5: (s6_addr16 : array[0..7] of smallint);
57 6: (s6_addr32 : array[0..3] of LongInt);
58 end;
59 {$endif}
60 {$endif}
61
62 tbinip=record
63 family:integer;
64 {$ifdef ipv6}
65 case integer of
66 0: (ip:longint);
67 1: (ip6:tin6_addr);
68 {$else}
69 ip:longint;
70 {$endif}
71 end;
72
73 {$ifdef win32}
74 TInetSockAddr = packed Record
75 family:Word;
76 port :Word;
77 addr :uint32;
78 pad :array [1..8] of byte;
79 end;
80 {$ifdef ipv6}
81
82 TInetSockAddr6 = packed record
83 sin6_family: word;
84 sin6_port: word;
85 sin6_flowinfo: uint32;
86 sin6_addr: tin6_addr;
87 sin6_scope_id: uint32;
88 end;
89 {$endif}
90 {$endif}
91
92
93
94 {$ifdef ipv6}
95 {$ifdef ver1_0}
96 cuint16=word;
97 cuint32=dword;
98 sa_family_t=word;
99
100 TInetSockAddr6 = packed record
101 sin6_family: word;
102 sin6_port: word;
103 sin6_flowinfo: uint32;
104 sin6_addr: tin6_addr;
105 sin6_scope_id: uint32;
106 end;
107 {$endif}
108 {$endif}
109 TinetSockAddrv = packed record
110 case integer of
111 0: (InAddr:TInetSockAddr);
112 {$ifdef ipv6}
113 1: (InAddr6:TInetSockAddr6);
114 {$endif}
115 end;
116 Pinetsockaddrv = ^Tinetsockaddrv;
117
118 type
119 tsockaddrin=TInetSockAddr;
120
121
122
123 {
124 bin IP list code, by beware
125 while this is really just a string, on the interface side it must be treated
126 as an opaque var which is passed as "var" when it needs to be modified}
127
128 tbiniplist=tbufferstring;
129
130 function biniplist_new:tbiniplist;
131 procedure biniplist_add(var l:tbiniplist;ip:tbinip);
132 function biniplist_getcount(const l:tbiniplist):integer;
133 function biniplist_get(const l:tbiniplist;index:integer):tbinip;
134 procedure biniplist_set(var l:tbiniplist;index:integer;ip:tbinip);
135 procedure biniplist_setcount(var l:tbiniplist;newlen:integer);
136 procedure biniplist_free(var l:tbiniplist);
137 procedure biniplist_addlist(var l:tbiniplist;const l2:tbiniplist);
138 function biniplist_tostr(const l:tbiniplist):thostname;
139 function isbiniplist(const l:tbiniplist):boolean;
140
141 function htons(w:word):word;
142 function htonl(i:uint32):uint32;
143
144 function ipstrtobin(const s:thostname;var binip:tbinip):boolean;
145 function ipstrtobinf(const s:thostname):tbinip;
146 function ipbintostr(const binip:tbinip):thostname;
147 {$ifdef ipv6}
148 function ip6bintostr(const bin:tin6_addr):thostname;
149 function ip6strtobin(const s:thostname;var bin:tin6_addr):boolean;
150 {$endif}
151
152 function comparebinip(const ip1,ip2:tbinip):boolean;
153 procedure maskbits(var binip:tbinip;bits:integer);
154 function comparebinipmask(ip1,ip2:tbinip;bits:integer):boolean;
155
156 procedure addipsoffamily(var l:tbiniplist;const l2:tbiniplist;family:integer);
157
158 {deprecated}
159 function longip(s:thostname):longint;
160
161 function needconverttov4(const ip:tbinip):boolean;
162 procedure converttov4(var ip:tbinip);
163 procedure converttov6(var ip:tbinip);
164
165 function inaddrvtobinip(inaddrv:tinetsockaddrv):tbinip;
166 function makeinaddrv(addr:tbinip;port:ansistring;var inaddr:tinetsockaddrv):integer;
167 function inaddrsize(inaddr:tinetsockaddrv):integer;
168
169 implementation
170
171 uses sysutils;
172
173 function htons(w:word):word;
174 begin
175 {$ifdef ENDIAN_LITTLE}
176 result := ((w and $ff00) shr 8) or ((w and $ff) shl 8);
177 {$else}
178 result := w;
179 {$endif}
180 end;
181
182 function htonl(i:uint32):uint32;
183 begin
184 {$ifdef ENDIAN_LITTLE}
185 result := (i shr 24) or (i shr 8 and $ff00) or (i shl 8 and $ff0000) or (i shl 24 and $ff000000);
186 {$else}
187 result := i;
188 {$endif}
189 end;
190
191
192 function inaddrvtobinip(inaddrv:tinetsockaddrv):tbinip;
193 begin
194 result.family := inaddrv.inaddr.family;
195 if result.family = AF_INET then result.ip := inaddrv.inaddr.addr;
196 {$ifdef ipv6}
197 if result.family = AF_INET6 then result.ip6 := inaddrv.inaddr6.sin6_addr;
198 {$endif}
199 end;
200
201 function makeinaddrv(addr:tbinip;port:ansistring;var inaddr:tinetsockaddrv):integer;
202 begin
203 result := 0;
204 { biniptemp := forwardlookup(addr,10);}
205 fillchar(inaddr,sizeof(inaddr),0);
206 //writeln('converted address '+addr+' to binip '+ipbintostr(biniptemp));
207 if addr.family = AF_INET then begin
208 inAddr.InAddr.family:=AF_INET;
209 inAddr.InAddr.port:=htons(strtointdef(port,0));
210 inAddr.InAddr.addr:=addr.ip;
211 result := sizeof(tinetsockaddr);
212 end else
213 {$ifdef ipv6}
214 if addr.family = AF_INET6 then begin
215 inAddr.InAddr6.sin6_family:=AF_INET6;
216 inAddr.InAddr6.sin6_port:=htons(strtointdef(port,0));
217 inAddr.InAddr6.sin6_addr:=addr.ip6;
218 result := sizeof(tinetsockaddr6);
219 end;
220 {$endif}
221 end;
222
223 function inaddrsize(inaddr:tinetsockaddrv):integer;
224 begin
225 {$ifdef ipv6}
226 if inaddr.inaddr.family = AF_INET6 then result := sizeof(tinetsockaddr6) else
227 {$endif}
228 result := sizeof(tinetsockaddr);
229 end;
230
231 {internal}
232 {converts dotted v4 IP to longint. returns host endian order}
233 function longip(s:thostname):longint;
234 var
235 l:longint;
236 a,b:integer;
237 function convertbyte(const s:ansistring):integer;
238 begin
239 result := strtointdef(s,-1);
240 if result < 0 then begin
241 result := -1;
242 exit;
243 end;
244 if result > 255 then begin
245 result := -1;
246 exit;
247 end;
248 {01 exception}
249 if (result <> 0) and (s[1] = '0') then begin
250 result := -1;
251 exit;
252 end;
253 {+1 exception}
254 if not (s[1] in ['0'..'9']) then begin
255 result := -1;
256 exit
257 end;
258 end;
259
260 begin
261 result := 0;
262 a := pos('.',s);
263 if a = 0 then exit;
264 b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;
265 l := b shl 24;
266 s := copy(s,a+1,256);
267 a := pos('.',s);
268 if a = 0 then exit;
269 b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;
270 l := l or b shl 16;
271 s := copy(s,a+1,256);
272 a := pos('.',s);
273 if a = 0 then exit;
274 b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;
275 l := l or b shl 8;
276 s := copy(s,a+1,256);
277 b := convertbyte(copy(s,1,256));if (b < 0) then exit;
278 l := l or b;
279 result := l;
280 end;
281
282
283 function ipstrtobinf;
284 begin
285 ipstrtobin(s,result);
286 end;
287
288 function ipstrtobin(const s:thostname;var binip:tbinip):boolean;
289 begin
290 binip.family := 0;
291 result := false;
292 {$ifdef ipv6}
293 if pos(':',s) <> 0 then begin
294 {try ipv6. use builtin routine}
295 result := ip6strtobin(s,binip.ip6);
296 if result then binip.family := AF_INET6;
297 exit;
298 end;
299 {$endif}
300
301 {try v4}
302 binip.ip := htonl(longip(s));
303 if (binip.ip <> 0) or (s = '0.0.0.0') then begin
304 result := true;
305 binip.family := AF_INET;
306 exit;
307 end;
308 end;
309
310 function ipbintostr(const binip:tbinip):thostname;
311 var
312 a:integer;
313 begin
314 result := '';
315 {$ifdef ipv6}
316 if binip.family = AF_INET6 then begin
317 result := ip6bintostr(binip.ip6);
318 end else
319 {$endif}
320 if binip.family = AF_INET then begin
321 a := htonl(binip.ip);
322 result := inttostr(a shr 24)+'.'+inttostr((a shr 16) and $ff)+'.'+inttostr((a shr 8) and $ff)+'.'+inttostr(a and $ff);
323 end;
324 end;
325
326
327 {------------------------------------------------------------------------------}
328
329 {$ifdef ipv6}
330
331 {
332 IPv6 address binary to/from string conversion routines
333 written by beware
334
335 - implementation does not depend on other ipv6 code such as the tin6_addr type,
336 the parameter can also be untyped.
337 - it is host endian neutral - binary format is aways network order
338 - it supports compression of zeroes
339 - it supports ::ffff:192.168.12.34 style addresses
340 - they are made to do the Right Thing, more efficient implementations are possible
341 }
342
343 {fpc has hostaddrtostr6 and strtohostaddr6 but the later isnt implemented yet}
344
345
346 function ip6bintostr(const bin:tin6_addr):thostname;
347 {base16 with lowercase output}
348 function makehex(w:word):ansistring;
349 begin
350 result := '';
351 if w >= 4096 then result := result + hexchars[w shr 12];
352 if w >= 256 then result := result + hexchars[w shr 8 and $f];
353 if w >= 16 then result := result + hexchars[w shr 4 and $f];
354 result := result + hexchars[w and $f];
355 end;
356
357 var
358 a,b,c,addrlen:integer;
359 runbegin,runlength:integer;
360 bytes:array[0..15] of byte absolute bin;
361 words:array[0..7] of word;
362 dwords:array[0..3] of integer absolute words;
363 begin
364 for a := 0 to 7 do begin
365 words[a] := bytes[a shl 1] shl 8 or bytes[a shl 1 or 1];
366 end;
367 if (dwords[0] = 0) and (dwords[1] = 0) and (words[4] = 0) and (words[5] = $ffff) then begin
368 {::ffff:/96 exception: v4 IP}
369 addrlen := 6;
370 end else begin
371 addrlen := 8;
372 end;
373 {find longest run of zeroes}
374 runbegin := 0;
375 runlength := 0;
376 for a := 0 to addrlen-1 do begin
377 if words[a] = 0 then begin
378 c := 0;
379 for b := a to addrlen-1 do if words[b] = 0 then begin
380 inc(c);
381 end else break;
382 if (c > runlength) then begin
383 runlength := c;
384 runbegin := a;
385 end;
386 end;
387 end;
388
389 {run length atleast 2 0 words}
390 if (runlength = 1) then begin
391 runlength := 0;
392 runbegin := 0;
393 end;
394
395 result := '';
396 for a := 0 to runbegin-1 do begin
397 if (a <> 0) then result := result + ':';
398 result := result + makehex(words[a]);
399 end;
400 if runlength > 0 then result := result + '::';
401 c := runbegin+runlength;
402 for a := c to addrlen-1 do begin
403 if (a > c) then result := result + ':';
404 result := result + makehex(words[a]);
405 end;
406 if addrlen = 6 then begin
407 result := result + ':'+inttostr(bytes[12])+'.'+inttostr(bytes[13])+'.'+inttostr(bytes[14])+'.'+inttostr(bytes[15]);
408 end;
409 end;
410
411 function ip6strtobin(const s:thostname;var bin:tin6_addr):boolean;
412 var
413 a,b:integer;
414 fields:array[0..7] of ansistring;
415 fieldcount:integer;
416 emptyfield:integer;
417 wordcount:integer;
418 words:array[0..7] of word;
419 bytes:array[0..15] of byte absolute bin;
420 begin
421 result := false;
422 for a := 0 to 7 do fields[a] := '';
423 fieldcount := 0;
424 for a := 1 to length(s) do begin
425 if s[a] = ':' then inc(fieldcount) else fields[fieldcount] := fields[fieldcount] + s[a];
426 if fieldcount > 7 then exit;
427 end;
428 if fieldcount < 2 then exit;
429
430 {find the empty field (compressed zeroes), not counting the first and last there may be at most 1}
431 emptyfield := -1;
432 for a := 1 to fieldcount-1 do begin
433 if fields[a] = '' then begin
434 if emptyfield = -1 then emptyfield := a else exit;
435 end;
436 end;
437
438 {check if last field is a valid v4 IP}
439 a := longip(fields[fieldcount]);
440 if (a <> 0) or (fields[fieldcount] = '0.0.0.0') then wordcount := 6 else wordcount := 8;
441 {0:1:2:3:4:5:6.6.6.6
442 0:1:2:3:4:5:6:7}
443 fillchar(words,sizeof(words),0);
444 if wordcount = 6 then begin
445 if fieldcount > 6 then exit;
446 words[6] := a shr 16;
447 words[7] := a and $ffff;
448 end;
449 if emptyfield = -1 then begin
450 {no run length: must be an exact number of fields}
451 if wordcount = 6 then begin
452 if fieldcount <> 6 then exit;
453 emptyfield := 5;
454 end else if wordcount = 8 then begin
455 if fieldcount <> 7 then exit;
456 emptyfield := 7;
457 end else exit;
458 end;
459 for a := 0 to emptyfield do begin
460 if fields[a] = '' then b := 0 else b := strtointdef('$'+fields[a],-1);
461 if (b < 0) or (b > $ffff) then exit;
462 words[a] := b;
463 end;
464 if wordcount = 6 then dec(fieldcount);
465 for a := wordcount-1 downto wordcount-(fieldcount-emptyfield) do begin
466 b := a+fieldcount-wordcount+1;
467 if fields[b] = '' then b := 0 else b := strtointdef('$'+fields[b],-1);
468 if (b < 0) or (b > $ffff) then exit;
469 words[a] := b;
470 end;
471 for a := 0 to 7 do begin
472 bytes[a shl 1] := words[a] shr 8;
473 bytes[a shl 1 or 1] := words[a] and $ff;
474 end;
475 result := true;
476 end;
477 {$endif}
478
479 function comparebinip(const ip1,ip2:tbinip):boolean;
480 begin
481 if (ip1.ip <> ip2.ip) then begin
482 result := false;
483 exit;
484 end;
485
486 {$ifdef ipv6}
487 if ip1.family = AF_INET6 then begin
488 if (ip1.ip6.s6_addr32[1] <> ip2.ip6.s6_addr32[1])
489 or (ip1.ip6.s6_addr32[2] <> ip2.ip6.s6_addr32[2])
490 or (ip1.ip6.s6_addr32[3] <> ip2.ip6.s6_addr32[3]) then begin
491 result := false;
492 exit;
493 end;
494 end;
495 {$endif}
496
497 result := (ip1.family = ip2.family);
498 end;
499
500 procedure maskbits(var binip:tbinip;bits:integer);
501 const
502 ipmax={$ifdef ipv6}15{$else}3{$endif};
503 type tarr=array[0..ipmax] of byte;
504 var
505 arr:^tarr;
506 a,b:integer;
507 begin
508 arr := @binip.ip;
509 if bits = 0 then b := 0 else b := ((bits-1) div 8)+1;
510 for a := b to ipmax do begin
511 arr[a] := 0;
512 end;
513 if (bits and 7 <> 0) then begin
514 arr[bits shr 3] := arr[bits div 8] and not ($ff shr (bits and 7))
515 end;
516 end;
517
518 function comparebinipmask;
519 begin
520 maskbits(ip1,bits);
521 maskbits(ip2,bits);
522 result := comparebinip(ip1,ip2);
523 end;
524
525 function needconverttov4(const ip:tbinip):boolean;
526 begin
527 {$ifdef ipv6}
528 if ip.family = AF_INET6 then begin
529 if (ip.ip6.u6_addr32[0] = 0) and (ip.ip6.u6_addr32[1] = 0) and
530 (ip.ip6.u6_addr16[4] = 0) and (ip.ip6.u6_addr16[5] = $ffff) then begin
531 result := true;
532 exit;
533 end;
534 end;
535 {$endif}
536
537 result := false;
538 end;
539
540 {converts a binary IP to v4 if it is a v6 IP in the v4 range}
541 procedure converttov4(var ip:tbinip);
542 begin
543 {$ifdef ipv6}
544 if needconverttov4(ip) then begin
545 ip.family := AF_INET;
546 ip.ip := ip.ip6.s6_addr32[3];
547 end;
548 {$endif}
549 end;
550
551
552 {converts a binary IP to v6 if it is a v4 IP}
553 procedure converttov6(var ip:tbinip);
554 begin
555 {$ifdef ipv6}
556 if ip.family = AF_INET then begin
557 ip.family := AF_INET6;
558 ip.ip6.s6_addr32[3] := ip.ip;
559 ip.ip6.u6_addr32[0] := 0;
560 ip.ip6.u6_addr32[1] := 0;
561 ip.ip6.u6_addr16[4] := 0;
562 ip.ip6.u6_addr16[5] := $ffff;
563 end;
564 {$endif}
565 end;
566
567
568 {-----------biniplist stuff--------------------------------------------------}
569
570 const
571 biniplist_prefix: ansistring = 'bipl'#0;
572 //fpc 1.0.x doesn't seem to like use of length function in a constant
573 //definition
574 //biniplist_prefixlen=length(biniplist_prefix);
575
576 biniplist_prefixlen=5;
577
578 function biniplist_new:tbiniplist;
579 begin
580 result := biniplist_prefix;
581 end;
582
583 procedure biniplist_add(var l:tbiniplist;ip:tbinip);
584 var
585 a:integer;
586 begin
587 a := biniplist_getcount(l);
588 biniplist_setcount(l,a+1);
589 biniplist_set(l,a,ip);
590 end;
591
592 function biniplist_getcount(const l:tbiniplist):integer;
593 begin
594 result := (length(l)-biniplist_prefixlen) div sizeof(tbinip);
595 end;
596
597 function biniplist_get(const l:tbiniplist;index:integer):tbinip;
598 begin
599 if (index >= biniplist_getcount(l)) then begin
600 fillchar(result,sizeof(result),0);
601 exit;
602 end;
603 move(l[index*sizeof(tbinip)+1+biniplist_prefixlen],result,sizeof(result));
604 end;
605
606 procedure biniplist_set(var l:tbiniplist;index:integer;ip:tbinip);
607 begin
608 uniquestring(l);
609 move(ip,l[index*sizeof(tbinip)+1+biniplist_prefixlen],sizeof(ip));
610 end;
611
612 procedure biniplist_setcount(var l:tbiniplist;newlen:integer);
613 begin
614 setlength(l,(sizeof(tbinip)*newlen)+biniplist_prefixlen);
615 end;
616
617 procedure biniplist_free(var l:tbiniplist);
618 begin
619 l := '';
620 end;
621
622 procedure biniplist_addlist;
623 begin
624 l := l + copy(l2,biniplist_prefixlen+1,maxlongint);
625 end;
626
627 function biniplist_tostr(const l:tbiniplist):thostname;
628 var
629 a:integer;
630 begin
631 result := '(';
632 for a := 0 to biniplist_getcount(l)-1 do begin
633 if result <> '(' then result := result + ', ';
634 result := result + ipbintostr(biniplist_get(l,a));
635 end;
636 result := result + ')';
637 end;
638
639 function isbiniplist(const l:tbiniplist):boolean;
640 var
641 i : integer;
642 begin
643 for i := 1 to biniplist_prefixlen do begin
644 if biniplist_prefix[i] <> l[i] then begin
645 result := false;
646 exit;
647 end;
648 end;
649 result := true;
650 end;
651
652 procedure addipsoffamily(var l:tbiniplist;const l2:tbiniplist;family:integer);
653 var
654 a:integer;
655 biniptemp:tbinip;
656 begin
657 for a := biniplist_getcount(l2)-1 downto 0 do begin
658 biniptemp := biniplist_get(l2,a);
659 if (biniptemp.family = family) then biniplist_add(l,biniptemp);
660 end;
661 end;
662
663
664 end.

Properties

Name Value
svn:eol-style CRLF

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