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