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

Contents of /trunk/binipstuff.pas

Parent Directory Parent Directory | Revision Log Revision Log


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