httpserver_20080306/dnscore.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 \r
   6 {\r
   7 \r
   8   code wanting to use this dns system should act as follows (note: app\r
   9   developers will probablly want to use dnsasync or dnssync or write a similar\r
  10   wrapper unit of thier own).\r
  11 \r
  12   for normal lookups call setstate_forward or setstate_reverse to set up the\r
  13   state, for more obscure lookups use setstate_request_init and fill in other\r
  14   relavent state manually.\r
  15 \r
  16   call state_process which will do processing on the information in the state\r
  17   and return an action\r
  18   action_ignore means that dnscore wants the code that calls it to go\r
  19   back to waiting for packets\r
  20   action_sendpacket means that dnscore wants the code that calls it to send\r
  21   the packet in sendpacket/sendpacketlen and then start (or go back to) listening\r
  22   for\r
  23   action_done means the request has completed (either suceeded or failed)\r
  24 \r
  25   callers should resend the last packet they tried to send if they have not\r
  26   been asked to send a new packet for more than some timeout value they choose.\r
  27 \r
  28   when a packet is received the application should put the packet in\r
  29   recvbuf/recvbuflen , set state.parsepacket and call state_process again\r
  30 \r
  31   once the app gets action_done it can determine sucess or failure in the\r
  32   following ways.\r
  33 \r
  34   on failure state.resultstr will be an empty string and state.resultbin will\r
  35   be zeroed out (easilly detected by the fact that it will have a family of 0)\r
  36 \r
  37   on success for a A or AAAA lookup state.resultstr will be an empty string\r
  38   and state.resultbin will contain the result (note: AAAA lookups require IPV6\r
  39   enabled).\r
  40 \r
  41   if an A lookup fails and the code is built with ipv6 enabled then the code\r
  42   will return any AAAA records with the same name. The reverse does not apply\r
  43   so if an application preffers IPV6 but wants IPV4 results as well it must\r
  44   check them seperately.\r
  45 \r
  46   on success for any other type of lookup state.resultstr will be an empty\r
  47 \r
  48   note the state contains ansistrings, setstate_init with a null name parameter\r
  49   can be used to clean theese up if required.\r
  50 \r
  51   callers may use setstate_failure to mark the state as failed themseleves\r
  52   before passing it on to other code, for example this may be done in the event\r
  53   of a timeout.\r
  54 }\r
  55 unit dnscore;\r
  56 \r
  57 \r
  58 \r
  59 {$ifdef fpc}{$mode delphi}{$endif}\r
  60 \r
  61 \r
  62 \r
  63 \r
  64 \r
  65 interface\r
  66 \r
  67 uses binipstuff,classes,pgtypes;\r
  68 \r
  69 var usewindns : boolean = {$ifdef win32}true{$else}false{$endif};\r
  70 //hint to users of this unit that they should use windows dns instead.\r
  71 //May be disabled by applications if desired. (e.g. if setting a custom\r
  72 //dnsserverlist).\r
  73 \r
  74 //note: this unit will not be able to self populate it's dns server list on\r
  75 //older versions of windows.\r
  76 \r
  77 const\r
  78   maxnamelength=127;\r
  79   maxnamefieldlen=63;\r
  80   //note: when using action_ignore the dnscore code *must* preserve the contents of state.sendpacket to allow for retries\r
  81   //note: action_ignore must not be used in response to the original request but there is no valid reason for doing this anyway\r
  82   action_ignore=0;\r
  83   action_done=1;\r
  84   action_sendquery=2;\r
  85   querytype_a=1;\r
  86   querytype_cname=5;\r
  87   querytype_aaaa=28;\r
  88   querytype_ptr=12;\r
  89   querytype_ns=2;\r
  90   querytype_soa=6;\r
  91   querytype_mx=15;\r
  92 \r
  93   maxrecursion=10;\r
  94   maxrrofakind=20;\r
  95 \r
  96   retryafter=300000; //microseconds must be less than one second;\r
  97   timeoutlag=1000000000; // penalty value to be treated as lag in the event of a timeout (microseconds)\r
  98 type\r
  99   dvar=array[0..0] of byte;\r
 100   pdvar=^dvar;\r
 101   tdnspacket=packed record\r
 102     id:word;\r
 103     flags:word;\r
 104     rrcount:array[0..3] of word;\r
 105     payload:array[0..511-12] of byte;\r
 106   end;\r
 107 \r
 108 \r
 109 \r
 110   tdnsstate=record\r
 111     id:word;\r
 112     recursioncount:integer;\r
 113     queryname:string;\r
 114     requesttype:word;\r
 115     parsepacket:boolean;\r
 116     resultstr:string;\r
 117     resultbin:tbinip;\r
 118     resultaction:integer;\r
 119     numrr1:array[0..3] of integer;\r
 120     numrr2:integer;\r
 121     rrdata:string;\r
 122     sendpacketlen:integer;\r
 123     sendpacket:tdnspacket;\r
 124     recvpacketlen:integer;\r
 125     recvpacket:tdnspacket;\r
 126     forwardfamily:integer;\r
 127   end;\r
 128 \r
 129   trr=packed record\r
 130     requesttypehi:byte;\r
 131     requesttype:byte;\r
 132     clas:word;\r
 133     ttl:integer;\r
 134     datalen:word;\r
 135     data:array[0..511] of byte;\r
 136   end;\r
 137 \r
 138   trrpointer=packed record\r
 139     p:pointer;\r
 140     ofs:integer;\r
 141     len:integer;\r
 142     namelen:integer;\r
 143   end;\r
 144 \r
 145 //commenting out functions from interface that do not have documented semantics\r
 146 //and probablly should not be called from outside this unit, reenable them\r
 147 //if you must but please document them at the same time --plugwash\r
 148 \r
 149 //function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer;\r
 150 //function makereversename(const binip:tbinip):string;\r
 151 \r
 152 procedure setstate_request_init(const name:string;var state:tdnsstate);\r
 153 \r
 154 //set up state for a foward lookup. A family value of AF_INET6 will give only\r
 155 //ipv6 results. Any other value will give ipv4 results in preference and ipv6\r
 156 //results if ipv4 results are not available;\r
 157 procedure setstate_forward(const name:string;var state:tdnsstate;family:integer);\r
 158 \r
 159 procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);\r
 160 procedure setstate_failure(var state:tdnsstate);\r
 161 //procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);\r
 162 \r
 163 \r
 164 procedure state_process(var state:tdnsstate);\r
 165 \r
 166 //function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):string;\r
 167 \r
 168 //presumablly this is exported to allow more secure random functions\r
 169 //to be substituted?\r
 170 var randomfunction:function:integer;\r
 171 \r
 172 \r
 173 procedure populatednsserverlist;\r
 174 procedure cleardnsservercache;\r
 175 \r
 176 var\r
 177   dnsserverlist : tstringlist;\r
 178 //  currentdnsserverno : integer;\r
 179 \r
 180 function getcurrentsystemnameserver(var id:integer) :string;\r
 181 \r
 182 //var\r
 183 //  unixnameservercache:string;\r
 184 { $endif}\r
 185 \r
 186 \r
 187 procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout\r
 188 var\r
 189   failurereason:string;\r
 190 \r
 191 implementation\r
 192 \r
 193 uses\r
 194   {$ifdef win32}\r
 195     windows,\r
 196   {$endif}\r
 197 \r
 198   sysutils;\r
 199 \r
 200 function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer;\r
 201 var\r
 202   a,b:integer;\r
 203   s:string;\r
 204   arr:array[0..sizeof(packet)-1] of byte absolute packet;\r
 205 begin\r
 206  { writeln('buildrequest: name: ',name);}\r
 207   result := 0;\r
 208   fillchar(packet,sizeof(packet),0);\r
 209   if assigned(randomfunction) then packet.id := (randomfunction and $ffff) else packet.id := random(65536);\r
 210   packet.flags := htons($0100);\r
 211   packet.rrcount[0] := htons($0001);\r
 212 \r
 213 \r
 214   s := copy(name,1,maxnamelength);\r
 215   if s = '' then exit;\r
 216   if s[length(s)] <> '.' then s := s + '.';\r
 217   b := 0;\r
 218   {encode name}\r
 219   if (s = '.') then begin\r
 220     packet.payload[0] := 0;\r
 221     result := 12+5;\r
 222   end else begin\r
 223     for a := 1 to length(s) do begin\r
 224       if s[a] = '.' then begin\r
 225         if b > maxnamefieldlen then exit;\r
 226         if (b = 0) then exit;\r
 227         packet.payload[a-b-1] := b;\r
 228         b := 0;\r
 229       end else begin\r
 230         packet.payload[a] := byte(s[a]);\r
 231         inc(b);\r
 232       end;\r
 233     end;\r
 234     if b > maxnamefieldlen then exit;\r
 235     packet.payload[length(s)-b] := b;\r
 236     result := length(s) + 12+5;\r
 237   end;\r
 238 \r
 239   arr[result-1] := 1;\r
 240   arr[result-3] := requesttype and $ff;\r
 241   arr[result-4] := requesttype shr 8;\r
 242 end;\r
 243 \r
 244 function makereversename(const binip:tbinip):string;\r
 245 var\r
 246   name:string;\r
 247   a,b:integer;\r
 248 begin\r
 249   name := '';\r
 250   if binip.family = AF_INET then begin\r
 251     b := htonl(binip.ip);\r
 252     for a := 0 to 3 do begin\r
 253       name := name + inttostr(b shr (a shl 3) and $ff)+'.';\r
 254     end;\r
 255     name := name + 'in-addr.arpa';\r
 256   end else\r
 257   {$ifdef ipv6}\r
 258   if binip.family = AF_INET6 then begin\r
 259     for a := 15 downto 0 do begin\r
 260       b := binip.ip6.u6_addr8[a];\r
 261       name := name + hexchars[b and $f]+'.'+hexchars[b shr 4]+'.';\r
 262     end;\r
 263     name := name + 'ip6.arpa';\r
 264   end else\r
 265   {$endif}\r
 266   begin\r
 267     {empty name}\r
 268   end;\r
 269   result := name;\r
 270 end;\r
 271 \r
 272 {\r
 273 decodes DNS format name to a string. does not includes the root dot.\r
 274 doesnt read beyond len.\r
 275 empty result + non null failurereason: failure\r
 276 empty result + null failurereason: internal use\r
 277 }\r
 278 function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):string;\r
 279 var\r
 280   arr:array[0..sizeof(packet)-1] of byte absolute packet;\r
 281   s:string;\r
 282   a,b:integer;\r
 283 begin\r
 284   numread := 0;\r
 285   repeat\r
 286     if (start+numread < 0) or (start+numread >= len) then begin\r
 287       result := '';\r
 288       failurereason := 'decoding name: got out of range1';\r
 289       exit;\r
 290     end;\r
 291     b := arr[start+numread];\r
 292     if b >= $c0 then begin\r
 293       {recursive sub call}\r
 294       if recursion > 10 then begin\r
 295         result := '';\r
 296         failurereason := 'decoding name: max recursion';\r
 297         exit;\r
 298       end;\r
 299       if ((start+numread+1) >= len) then begin\r
 300         result := '';\r
 301         failurereason := 'decoding name: got out of range3';\r
 302         exit;\r
 303       end;\r
 304       a := ((b shl 8) or arr[start+numread+1]) and $3fff;\r
 305       s := decodename(packet,len,a,recursion+1,a);\r
 306       if (s = '') and (failurereason <> '') then begin\r
 307         result := '';\r
 308         exit;\r
 309       end;\r
 310       if result <> '' then result := result + '.';\r
 311       result := result + s;\r
 312       inc(numread,2);\r
 313       exit;\r
 314     end else if b < 64 then begin\r
 315       if (numread <> 0) and (b <> 0) then result := result + '.';\r
 316       for a := start+numread+1 to start+numread+b do begin\r
 317         if (a >= len) then begin\r
 318           result := '';\r
 319           failurereason := 'decoding name: got out of range2';\r
 320           exit;\r
 321         end;\r
 322         result := result + char(arr[a]);\r
 323       end;\r
 324       inc(numread,b+1);\r
 325 \r
 326       if b = 0 then begin\r
 327         if (result = '') and (recursion = 0) then result := '.';\r
 328         exit; {reached end of name}\r
 329       end;\r
 330     end else begin\r
 331       failurereason := 'decoding name: read invalid char';\r
 332       result := '';\r
 333       exit; {invalid}\r
 334     end;\r
 335   until false;\r
 336 end;\r
 337 \r
 338 {==============================================================================}\r
 339 \r
 340 procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);\r
 341 var\r
 342   a:integer;\r
 343 begin\r
 344   state.resultaction := action_done;\r
 345   state.resultstr := '';\r
 346   case trr(rrp.p^).requesttype of\r
 347     querytype_a: begin\r
 348       if htons(trr(rrp.p^).datalen) <> 4 then exit;\r
 349       move(trr(rrp.p^).data,state.resultbin.ip,4);\r
 350       state.resultbin.family :=AF_INET;\r
 351     end;\r
 352     {$ifdef ipv6}\r
 353     querytype_aaaa: begin\r
 354       if htons(trr(rrp.p^).datalen) <> 16 then exit;\r
 355       state.resultbin.family := AF_INET6;\r
 356       move(trr(rrp.p^).data,state.resultbin.ip6,16);\r
 357     end;\r
 358     {$endif}\r
 359   else\r
 360     {other reply types (PTR, MX) return a hostname}\r
 361     state.resultstr := decodename(state.recvpacket,state.recvpacketlen,taddrint(rrp.p)-taddrint(@state.recvpacket)+10,0,a);\r
 362     fillchar(state.resultbin,sizeof(state.resultbin),0);\r
 363   end;\r
 364 end;\r
 365 \r
 366 procedure setstate_request_init(const name:string;var state:tdnsstate);\r
 367 begin\r
 368   {destroy things properly}\r
 369   state.resultstr := '';\r
 370   state.queryname := '';\r
 371   state.rrdata := '';\r
 372   fillchar(state,sizeof(state),0);\r
 373   state.queryname := name;\r
 374   state.parsepacket := false;\r
 375 end;\r
 376 \r
 377 procedure setstate_forward(const name:string;var state:tdnsstate;family:integer);\r
 378 begin\r
 379   setstate_request_init(name,state);\r
 380   state.forwardfamily := family;\r
 381   {$ifdef ipv6}\r
 382   if family = AF_INET6 then state.requesttype := querytype_aaaa else\r
 383   {$endif}\r
 384   state.requesttype := querytype_a;\r
 385 end;\r
 386 \r
 387 procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);\r
 388 begin\r
 389   setstate_request_init(makereversename(binip),state);\r
 390   state.requesttype := querytype_ptr;\r
 391 end;\r
 392 \r
 393 procedure setstate_failure(var state:tdnsstate);\r
 394 begin\r
 395   state.resultstr := '';\r
 396   fillchar(state.resultbin,sizeof(state.resultbin),0);\r
 397   state.resultaction := action_done;\r
 398 end;\r
 399 \r
 400 procedure state_process(var state:tdnsstate);\r
 401 label recursed;\r
 402 label failure;\r
 403 var\r
 404   a,b,ofs:integer;\r
 405   rrtemp:^trr;\r
 406   rrptemp:^trrpointer;\r
 407 begin\r
 408   if state.parsepacket then begin\r
 409     if state.recvpacketlen < 12 then begin\r
 410       failurereason := 'Undersized packet';\r
 411       state.resultaction := action_ignore;\r
 412       exit;\r
 413     end;\r
 414     if state.id <> state.recvpacket.id then begin\r
 415       failurereason := 'ID mismatch';\r
 416       state.resultaction := action_ignore;\r
 417       exit;\r
 418     end;\r
 419     state.numrr2 := 0;\r
 420     for a := 0 to 3 do begin\r
 421       state.numrr1[a] := htons(state.recvpacket.rrcount[a]);\r
 422       if state.numrr1[a] > maxrrofakind then goto failure;\r
 423       inc(state.numrr2,state.numrr1[a]);\r
 424     end;\r
 425 \r
 426     setlength(state.rrdata,state.numrr2*sizeof(trrpointer));\r
 427 \r
 428     {- put all replies into a list}\r
 429 \r
 430     ofs := 12;\r
 431     {get all queries}\r
 432     for a := 0 to state.numrr1[0]-1 do begin\r
 433       if (ofs < 12) or (ofs > state.recvpacketlen-4) then goto failure;\r
 434       rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
 435       rrptemp.p := @state.recvpacket.payload[ofs-12];\r
 436       rrptemp.ofs := ofs;\r
 437       decodename(state.recvpacket,state.recvpacketlen,ofs,0,b);\r
 438       rrptemp.len := b + 4;\r
 439       inc(ofs,rrptemp.len);\r
 440     end;\r
 441 \r
 442     for a := state.numrr1[0] to state.numrr2-1 do begin\r
 443       if (ofs < 12) or (ofs > state.recvpacketlen-12) then goto failure;\r
 444       rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
 445       if decodename(state.recvpacket,state.recvpacketlen,ofs,0,b) = '' then goto failure;\r
 446       rrtemp := @state.recvpacket.payload[ofs-12+b]; {rrtemp points to values and result, after initial name}\r
 447       rrptemp.p := rrtemp;\r
 448       rrptemp.ofs := ofs; {ofs is start of RR before initial name from start of packet}\r
 449       rrptemp.namelen := b;\r
 450       b := htons(rrtemp.datalen);\r
 451       rrptemp.len := b + 10 + rrptemp.namelen;\r
 452       inc(ofs,rrptemp.len);\r
 453     end;\r
 454     if (ofs <> state.recvpacketlen) then begin\r
 455       failurereason := 'ofs <> state.packetlen';\r
 456       goto failure;\r
 457     end;\r
 458 \r
 459     {- check for items of the requested type in answer section, if so return success first}\r
 460     for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin\r
 461       rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
 462       rrtemp := rrptemp.p;\r
 463       b := rrptemp.len;\r
 464       if rrtemp.requesttype = state.requesttype then begin\r
 465         setstate_return(rrptemp^,b,state);\r
 466         exit;\r
 467       end;\r
 468     end;\r
 469 \r
 470     {if no items of correct type found, follow first cname in answer section}\r
 471     for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin\r
 472       rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
 473       rrtemp := rrptemp.p;\r
 474       b := rrptemp.len;\r
 475       if rrtemp.requesttype = querytype_cname then begin\r
 476         state.queryname := decodename(state.recvpacket,state.recvpacketlen,rrptemp.ofs+12,0,b);\r
 477         goto recursed;\r
 478       end;\r
 479     end;\r
 480 \r
 481     {no cnames found, no items of correct type found}\r
 482     if state.forwardfamily <> 0 then goto failure;\r
 483 {$ifdef ipv6}\r
 484     if (state.requesttype = querytype_a) then begin\r
 485       {v6 only: in case of forward, look for AAAA in alternative section}\r
 486       for a := state.numrr1[0]+state.numrr1[1]+state.numrr1[2] to (state.numrr2-1) do begin\r
 487         rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
 488         rrtemp := rrptemp.p;\r
 489         b := rrptemp.len;\r
 490         if rrtemp.requesttype = querytype_aaaa then begin\r
 491           setstate_return(rrptemp^,b,state);\r
 492           exit;\r
 493         end;\r
 494       end;\r
 495       {no AAAA's found in alternative, do a recursive lookup for them}\r
 496       state.requesttype := querytype_aaaa;\r
 497       goto recursed;\r
 498     end;\r
 499 {$endif}\r
 500     goto failure;\r
 501 recursed:\r
 502     {here it needs recursed lookup}\r
 503     {if needing to follow a cname, change state to do so}\r
 504     inc(state.recursioncount);\r
 505     if state.recursioncount > maxrecursion then goto failure;\r
 506   end;\r
 507 \r
 508   {here, a name needs to be resolved}\r
 509   if state.queryname = '' then begin\r
 510     failurereason := 'empty query name';\r
 511     goto failure;\r
 512   end;\r
 513 \r
 514   {do /ets/hosts lookup here}\r
 515   state.sendpacketlen := buildrequest(state.queryname,state.sendpacket,state.requesttype);\r
 516   if state.sendpacketlen = 0 then begin\r
 517     failurereason := 'building request packet failed';\r
 518     goto failure;\r
 519   end;\r
 520   state.id := state.sendpacket.id;\r
 521   state.resultaction := action_sendquery;\r
 522 \r
 523   exit;\r
 524 failure:\r
 525   setstate_failure(state);\r
 526 end;\r
 527 {$ifdef win32}\r
 528   const\r
 529     MAX_HOSTNAME_LEN = 132;\r
 530     MAX_DOMAIN_NAME_LEN = 132;\r
 531     MAX_SCOPE_ID_LEN = 260    ;\r
 532     MAX_ADAPTER_NAME_LENGTH = 260;\r
 533     MAX_ADAPTER_ADDRESS_LENGTH = 8;\r
 534     MAX_ADAPTER_DESCRIPTION_LENGTH = 132;\r
 535     ERROR_BUFFER_OVERFLOW = 111;\r
 536     MIB_IF_TYPE_ETHERNET = 6;\r
 537     MIB_IF_TYPE_TOKENRING = 9;\r
 538     MIB_IF_TYPE_FDDI = 15;\r
 539     MIB_IF_TYPE_PPP = 23;\r
 540     MIB_IF_TYPE_LOOPBACK = 24;\r
 541     MIB_IF_TYPE_SLIP = 28;\r
 542 \r
 543 \r
 544   type\r
 545     tip_addr_string=packed record\r
 546       Next :pointer;\r
 547       IpAddress : array[0..15] of char;\r
 548       ipmask    : array[0..15] of char;\r
 549       context   : dword;\r
 550     end;\r
 551     pip_addr_string=^tip_addr_string;\r
 552     tFIXED_INFO=packed record\r
 553        HostName         : array[0..MAX_HOSTNAME_LEN-1] of char;\r
 554        DomainName       : array[0..MAX_DOMAIN_NAME_LEN-1] of char;\r
 555        currentdnsserver : pip_addr_string;\r
 556        dnsserverlist    : tip_addr_string;\r
 557        nodetype         : longint;\r
 558        ScopeId          : array[0..MAX_SCOPE_ID_LEN + 4] of char;\r
 559        enablerouting    : longbool;\r
 560        enableproxy      : longbool;\r
 561        enabledns        : longbool;\r
 562     end;\r
 563     pFIXED_INFO=^tFIXED_INFO;\r
 564 \r
 565   var\r
 566     iphlpapi : thandle;\r
 567     getnetworkparams : function(pFixedInfo : PFIXED_INFO;OutBufLen : plongint) : longint;stdcall;\r
 568 {$endif}\r
 569 procedure populatednsserverlist;\r
 570 var\r
 571   {$ifdef win32}\r
 572     fixed_info : pfixed_info;\r
 573     fixed_info_len : longint;\r
 574     currentdnsserver : pip_addr_string;\r
 575   {$else}\r
 576     t:textfile;\r
 577     s:string;\r
 578     a:integer;\r
 579   {$endif}\r
 580 begin\r
 581   //result := '';\r
 582   if assigned(dnsserverlist) then begin\r
 583     dnsserverlist.clear;\r
 584   end else begin\r
 585     dnsserverlist := tstringlist.Create;\r
 586   end;\r
 587   {$ifdef win32}\r
 588     if iphlpapi=0 then iphlpapi := loadlibrary('iphlpapi.dll');\r
 589     if not assigned(getnetworkparams) then @getnetworkparams := getprocaddress(iphlpapi,'GetNetworkParams');\r
 590     fixed_info_len := 0;\r
 591     if GetNetworkParams(nil,@fixed_info_len)<>ERROR_BUFFER_OVERFLOW then exit;\r
 592     //fixed_info_len :=sizeof(tfixed_info);\r
 593     getmem(fixed_info,fixed_info_len);\r
 594     if GetNetworkParams(fixed_info,@fixed_info_len)<>0 then begin\r
 595       freemem(fixed_info);\r
 596       exit;\r
 597     end;\r
 598     currentdnsserver := @(fixed_info.dnsserverlist);\r
 599     while assigned(currentdnsserver) do begin\r
 600       dnsserverlist.Add(currentdnsserver.IpAddress);\r
 601       currentdnsserver := currentdnsserver.next;\r
 602     end;\r
 603     freemem(fixed_info);\r
 604   {$else}\r
 605     filemode := 0;\r
 606     assignfile(t,'/etc/resolv.conf');\r
 607     {$i-}reset(t);{$i+}\r
 608     if ioresult <> 0 then exit;\r
 609 \r
 610     while not eof(t) do begin\r
 611       readln(t,s);\r
 612       if not (copy(s,1,10) = 'nameserver') then continue;\r
 613       s := copy(s,11,500);\r
 614       while s <> '' do begin\r
 615         if (s[1] = #32) or (s[1] = #9) then s := copy(s,2,500) else break;\r
 616       end;\r
 617       a := pos(' ',s);\r
 618       if a <> 0 then s := copy(s,1,a-1);\r
 619       a := pos(#9,s);\r
 620       if a <> 0 then s := copy(s,1,a-1);\r
 621       //result := s;\r
 622       //if result <> '' then break;\r
 623       dnsserverlist.Add(s);\r
 624     end;\r
 625     close(t);\r
 626   {$endif}\r
 627 end;\r
 628 \r
 629 procedure cleardnsservercache;\r
 630 begin\r
 631   if assigned(dnsserverlist) then begin\r
 632     dnsserverlist.destroy;\r
 633     dnsserverlist := nil;\r
 634   end;\r
 635 end;\r
 636 \r
 637 function getcurrentsystemnameserver(var id:integer):string;\r
 638 var \r
 639   counter : integer;\r
 640 \r
 641 begin\r
 642   if not assigned(dnsserverlist) then populatednsserverlist;\r
 643   if dnsserverlist.count=0 then raise exception.create('no dns servers availible');\r
 644   id := 0;\r
 645   if dnsserverlist.count >1 then begin\r
 646 \r
 647     for counter := 1 to dnsserverlist.count-1 do begin\r
 648       if taddrint(dnsserverlist.objects[counter]) < taddrint(dnsserverlist.objects[id]) then id := counter;\r
 649     end;\r
 650   end;\r
 651   result := dnsserverlist[id]\r
 652 end;\r
 653 \r
 654 procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout\r
 655 var\r
 656   counter : integer;\r
 657   temp : integer;\r
 658 begin\r
 659   if (id < 0) or (id >= dnsserverlist.count) then exit;\r
 660   if lag = -1 then lag := timeoutlag;\r
 661   for counter := 0 to dnsserverlist.count-1 do begin\r
 662     temp := taddrint(dnsserverlist.objects[counter]) *15;\r
 663     if counter=id then temp := temp + lag;\r
 664     dnsserverlist.objects[counter] := tobject(temp div 16);\r
 665   end;\r
 666 \r
 667 end;\r
 668 \r
 669 {  quick and dirty description of dns packet structure to aid writing and\r
 670    understanding of parser code, refer to appropriate RFCs for proper specs\r
 671 - all words are network order\r
 672 \r
 673 www.google.com A request:\r
 674 \r
 675 0, 2: random transaction ID\r
 676 2, 2: flags: only the "recursion desired" bit set. (bit 8 of word)\r
 677 4, 2: questions: 1\r
 678 6, 2: answer RR's: 0.\r
 679 8, 2: authority RR's: 0.\r
 680 10, 2: additional RR's: 0.\r
 681 12, n: payload:\r
 682   query:\r
 683     #03 "www" #06 "google" #03 "com" #00\r
 684     size-4, 2: type: host address (1)\r
 685     size-2, 2: class: inet (1)\r
 686 \r
 687 reply:\r
 688 \r
 689 0,2: random transaction ID\r
 690 2,2: flags: set: response (bit 15), recursion desired (8), recursion available (7)\r
 691 4,4: questions: 1\r
 692 6,4: answer RR's: 2\r
 693 8,4: authority RR's: 9\r
 694 10,4: additional RR's: 9\r
 695 12: payload:\r
 696   query:\r
 697     ....\r
 698   answer: CNAME\r
 699     0,2 "c0 0c" "name: www.google.com"\r
 700     2,2 "00 05" "type: cname for an alias"\r
 701     4,2 "00 01" "class: inet"\r
 702     6,4: TTL\r
 703     10,2: data length "00 17" (23)\r
 704     12: the cname name (www.google.akadns.net)\r
 705   answer: A\r
 706     0,2 ..\r
 707     2,2 "00 01" host address\r
 708     4,2 ...\r
 709     6,4 ...\r
 710     10,2: data length (4)\r
 711     12,4: binary IP\r
 712   authority - 9 records\r
 713   additional - 9 records\r
 714 \r
 715 \r
 716   ipv6 AAAA reply:\r
 717     0,2: ...\r
 718     2,2: type: 001c\r
 719     4,2: class: inet (0001)\r
 720     6,2: TTL\r
 721     10,2: data size (16)\r
 722     12,16: binary IP\r
 723 \r
 724   ptr request: query type 000c\r
 725 \r
 726 name compression: word "cxxx" in the name, xxx points to offset in the packet}\r
 727 \r
 728 end.\r