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