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