binipstuff.pas

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