X-Git-Url: http://www.lcore.org/git/lcore.git/blobdiff_plain/4782a5c5afee47721cc617daa40dd29828342c2b..2ba734680253339d8b27208a1dfec5e2f220f3d8:/dnscore.pas?ds=inline

diff --git a/dnscore.pas b/dnscore.pas
old mode 100755
new mode 100644
index bb4fab4..e38f35f
--- a/dnscore.pas
+++ b/dnscore.pas
@@ -6,12 +6,12 @@
 {
 
   code wanting to use this dns system should act as follows (note: app
-  developers will probablly want to use dnsasync or dnssync or write a similar
-  wrapper unit of thier own).
+  developers will probably want to use dnsasync or dnssync or write a similar
+  wrapper unit of their own).
 
   for normal lookups call setstate_forward or setstate_reverse to set up the
   state, for more obscure lookups use setstate_request_init and fill in other
-  relavent state manually.
+  relevant state manually.
 
   call state_process which will do processing on the information in the state
   and return an action
@@ -20,7 +20,7 @@
   action_sendpacket means that dnscore wants the code that calls it to send
   the packet in sendpacket/sendpacketlen and then start (or go back to) listening
   for
-  action_done means the request has completed (either suceeded or failed)
+  action_done means the request has completed (either succeeded or failed)
 
   callers should resend the last packet they tried to send if they have not
   been asked to send a new packet for more than some timeout value they choose.
@@ -28,51 +28,64 @@
   when a packet is received the application should put the packet in
   recvbuf/recvbuflen , set state.parsepacket and call state_process again
 
-  once the app gets action_done it can determine sucess or failure in the
+  once the app gets action_done it can determine success or failure in the
   following ways.
 
   on failure state.resultstr will be an empty string and state.resultbin will
-  be zeroed out (easilly detected by the fact that it will have a family of 0)
+  be zeroed out (easily detected by the fact that it will have a family of 0)
 
   on success for a A or AAAA lookup state.resultstr will be an empty string
-  and state.resultbin will contain the result (note: AAAA lookups require IPV6
+  and state.resultbin will contain the result (note: AAAA lookups require IPv6
   enabled).
 
-  if an A lookup fails and the code is built with ipv6 enabled then the code
+  if an A lookup fails and the code is built with IPv6 enabled then the code
   will return any AAAA records with the same name. The reverse does not apply
-  so if an application preffers IPV6 but wants IPV4 results as well it must
-  check them seperately.
+  so if an application prefers IPv6 but wants IPv4 results as well it must
+  check them separately.
 
   on success for any other type of lookup state.resultstr will be an empty
 
   note the state contains ansistrings, setstate_init with a null name parameter
-  can be used to clean theese up if required.
+  can be used to clean these up if required.
 
-  callers may use setstate_failure to mark the state as failed themseleves
+  callers may use setstate_failure to mark the state as failed themselves
   before passing it on to other code, for example this may be done in the event
   of a timeout.
 }
 unit dnscore;
 
-
-
 {$ifdef fpc}{$mode delphi}{$endif}
 
+{$include lcoreconfig.inc}
 
+interface
 
+uses binipstuff,classes,pgtypes,lcorernd;
 
+var usewindns : boolean = {$ifdef mswindows}true{$else}false{$endif};
+{hint to users of this unit that they should use windows dns instead.
+May be disabled by applications if desired. (e.g. if setting a custom
+dnsserverlist).
 
-interface
-
-uses binipstuff,classes,pgtypes;
+note: this unit will not be able to self populate it's dns server list on
+older versions of windows.}
 
-var usewindns : boolean = {$ifdef win32}true{$else}false{$endif};
-//hint to users of this unit that they should use windows dns instead.
-//May be disabled by applications if desired. (e.g. if setting a custom
-//dnsserverlist).
+const
+  useaf_default=0;
+  useaf_preferv4=1;
+  useaf_preferv6=2;
+  useaf_v4=3;
+  useaf_v6=4;
+{
+hint to users of this unit to how to deal with connecting to hostnames regarding ipv4 or ipv6 usage
+can be set by apps as desired
+}
+var useaf:integer = useaf_default;
 
-//note: this unit will not be able to self populate it's dns server list on
-//older versions of windows.
+{
+(temporarily) use a different nameserver, regardless of the dnsserverlist
+}
+var overridednsserver:ansistring;
 
 const
   maxnamelength=127;
@@ -85,13 +98,18 @@ const
   querytype_a=1;
   querytype_cname=5;
   querytype_aaaa=28;
+  querytype_a6=38;
   querytype_ptr=12;
   querytype_ns=2;
   querytype_soa=6;
   querytype_mx=15;
-
-  maxrecursion=10;
-  maxrrofakind=20;
+  querytype_txt=16;
+  querytype_spf=99;
+  maxrecursion=50;
+  maxrrofakind=32;
+  {the maximum number of RR of a kind of purely an extra sanity check and could be omitted.
+  before, i set it to 20, but valid replies can have more. dnscore only does udp requests,
+  and ordinary DNS, so up to 512 bytes. the maximum number of A records that fits seems to be 29}
 
   retryafter=300000; //microseconds must be less than one second;
   timeoutlag=1000000000; // penalty value to be treated as lag in the event of a timeout (microseconds)
@@ -110,15 +128,16 @@ type
   tdnsstate=record
     id:word;
     recursioncount:integer;
-    queryname:string;
+    queryname:ansistring;
     requesttype:word;
     parsepacket:boolean;
-    resultstr:string;
+    resultstr:ansistring;
     resultbin:tbinip;
+    resultlist:tbiniplist;
     resultaction:integer;
     numrr1:array[0..3] of integer;
     numrr2:integer;
-    rrdata:string;
+    rrdata:ansistring;
     sendpacketlen:integer;
     sendpacket:tdnspacket;
     recvpacketlen:integer;
@@ -143,70 +162,100 @@ type
   end;
 
 //commenting out functions from interface that do not have documented semantics
-//and probablly should not be called from outside this unit, reenable them
+//and probably should not be called from outside this unit, reenable them
 //if you must but please document them at the same time --plugwash
 
 //function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer;
-//function makereversename(const binip:tbinip):string;
 
-procedure setstate_request_init(const name:string;var state:tdnsstate);
+//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
+function makereversename(const binip:tbinip):ansistring;
+
+procedure setstate_request_init(const name:ansistring;var state:tdnsstate);
 
-//set up state for a foward lookup. A family value of AF_INET6 will give only
-//ipv6 results. Any other value will give ipv4 results in preference and ipv6
-//results if ipv4 results are not available;
-procedure setstate_forward(const name:string;var state:tdnsstate;family:integer);
+//set up state for a forward lookup. A family value of AF_INET6 will give only
+//ipv6 results. Any other value will give only ipv4 results
+procedure setstate_forward(const name:ansistring;var state:tdnsstate;family:integer);
 
 procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);
 procedure setstate_failure(var state:tdnsstate);
 //procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);
 
+//for custom raw lookups such as TXT, as desired by the user
+procedure setstate_custom(const name:ansistring; requesttype:integer; var state:tdnsstate);
 
 procedure state_process(var state:tdnsstate);
 
 //function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):string;
 
-//presumablly this is exported to allow more secure random functions
-//to be substituted?
-var randomfunction:function:integer;
-
-
 procedure populatednsserverlist;
 procedure cleardnsservercache;
 
 var
-  dnsserverlist : tstringlist;
+  dnsserverlist : tbiniplist;
+  dnsserverlag:tlist;
 //  currentdnsserverno : integer;
 
-function getcurrentsystemnameserver(var id:integer) :string;
+
+//getcurrentsystemnameserver returns the nameserver the app should use and sets
+//id to the id of that nameserver. id should later be used to report how laggy
+//the servers response was and if it was timed out.
+function getcurrentsystemnameserver(var id:integer) :ansistring;
+function getcurrentsystemnameserverbin(var id:integer) :tbinip;
+procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout
 
 //var
 //  unixnameservercache:string;
 { $endif}
 
 
-procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout
+{$ifdef ipv6}
+procedure initpreferredmode;
+
+var
+  preferredmodeinited:boolean;
+
+{$endif}
+
 var
-  failurereason:string;
+  failurereason:ansistring;
+
+function getquerytype(s:ansistring):integer;
 
 implementation
 
 uses
-  {$ifdef win32}
-    windows,
-  {$endif}
-
+  lcorelocalips,
   sysutils;
 
-function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer;
+
+
+function getquerytype(s:ansistring):integer;
+begin
+  s := uppercase(s);
+  result := 0;
+  if (s = 'A') then result := querytype_a else
+  if (s = 'CNAME') then result := querytype_cname else
+  if (s = 'AAAA') then result := querytype_aaaa else
+  if (s = 'PTR') then result := querytype_ptr else
+  if (s = 'NS') then result := querytype_ns else
+  if (s = 'MX') then result := querytype_mx else
+  if (s = 'A6') then result := querytype_a6 else
+  if (s = 'TXT') then result := querytype_txt else
+  if (s = 'SOA') then result := querytype_soa else
+  if (s = 'SPF') then result := querytype_spf;
+end;
+
+function buildrequest(const name:ansistring;var packet:tdnspacket;requesttype:word):integer;
 var
   a,b:integer;
-  s:string;
+  s:ansistring;
   arr:array[0..sizeof(packet)-1] of byte absolute packet;
 begin
  { writeln('buildrequest: name: ',name);}
   result := 0;
   fillchar(packet,sizeof(packet),0);
-  if assigned(randomfunction) then packet.id := (randomfunction and $ffff) else packet.id := random(65536);
+  packet.id := randominteger($10000);
+
   packet.flags := htons($0100);
   packet.rrcount[0] := htons($0001);
 
@@ -241,9 +290,9 @@ begin
   arr[result-4] := requesttype shr 8;
 end;
 
-function makereversename(const binip:tbinip):string;
+function makereversename(const binip:tbinip):ansistring;
 var
-  name:string;
+  name:ansistring;
   a,b:integer;
 begin
   name := '';
@@ -275,10 +324,10 @@ doesnt read beyond len.
 empty result + non null failurereason: failure
 empty result + null failurereason: internal use
 }
-function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):string;
+function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):ansistring;
 var
   arr:array[0..sizeof(packet)-1] of byte absolute packet;
-  s:string;
+  s:ansistring;
   a,b:integer;
 begin
   numread := 0;
@@ -319,7 +368,7 @@ begin
           failurereason := 'decoding name: got out of range2';
           exit;
         end;
-        result := result + char(arr[a]);
+        result := result + ansichar(arr[a]);
       end;
       inc(numread,b+1);
 
@@ -337,25 +386,55 @@ end;
 
 {==============================================================================}
 
-procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);
-var
-  a:integer;
+function getrawfromrr(const rrp:trrpointer;len:integer):ansistring;
 begin
-  state.resultaction := action_done;
-  state.resultstr := '';
+  setlength(result,htons(trr(rrp.p^).datalen));
+  uniquestring(result);
+  move(trr(rrp.p^).data,result[1],length(result));
+end;
+
+
+function getipfromrr(const rrp:trrpointer;len:integer):tbinip;
+begin
+  fillchar(result,sizeof(result),0);
   case trr(rrp.p^).requesttype of
     querytype_a: begin
       if htons(trr(rrp.p^).datalen) <> 4 then exit;
-      move(trr(rrp.p^).data,state.resultbin.ip,4);
-      state.resultbin.family :=AF_INET;
+      move(trr(rrp.p^).data,result.ip,4);
+      result.family :=AF_INET;
     end;
     {$ifdef ipv6}
     querytype_aaaa: begin
       if htons(trr(rrp.p^).datalen) <> 16 then exit;
-      state.resultbin.family := AF_INET6;
-      move(trr(rrp.p^).data,state.resultbin.ip6,16);
+      result.family := AF_INET6;
+      move(trr(rrp.p^).data,result.ip6,16);
     end;
     {$endif}
+  else
+    {}
+  end;
+end;
+
+procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);
+var
+  a:integer;
+begin
+  state.resultaction := action_done;
+  state.resultstr := '';
+  case trr(rrp.p^).requesttype of
+    querytype_a{$ifdef ipv6},querytype_aaaa{$endif}: begin
+      state.resultbin := getipfromrr(rrp,len);
+    end;
+    querytype_txt:begin
+      {TXT returns a raw string}
+      state.resultstr := copy(getrawfromrr(rrp,len),2,9999);
+      fillchar(state.resultbin,sizeof(state.resultbin),0);
+    end;
+    querytype_mx:begin
+      {MX is a name after a 16 bits word}
+      state.resultstr := decodename(state.recvpacket,state.recvpacketlen,taddrint(rrp.p)-taddrint(@state.recvpacket)+12,0,a);
+      fillchar(state.resultbin,sizeof(state.resultbin),0);
+    end;
   else
     {other reply types (PTR, MX) return a hostname}
     state.resultstr := decodename(state.recvpacket,state.recvpacketlen,taddrint(rrp.p)-taddrint(@state.recvpacket)+10,0,a);
@@ -363,7 +442,7 @@ begin
   end;
 end;
 
-procedure setstate_request_init(const name:string;var state:tdnsstate);
+procedure setstate_request_init(const name:ansistring;var state:tdnsstate);
 begin
   {destroy things properly}
   state.resultstr := '';
@@ -374,7 +453,7 @@ begin
   state.parsepacket := false;
 end;
 
-procedure setstate_forward(const name:string;var state:tdnsstate;family:integer);
+procedure setstate_forward(const name:ansistring;var state:tdnsstate;family:integer);
 begin
   setstate_request_init(name,state);
   state.forwardfamily := family;
@@ -390,6 +469,13 @@ begin
   state.requesttype := querytype_ptr;
 end;
 
+procedure setstate_custom(const name:ansistring; requesttype:integer; var state:tdnsstate);
+begin
+  setstate_request_init(name,state);
+  state.requesttype := requesttype;
+end;
+
+
 procedure setstate_failure(var state:tdnsstate);
 begin
   state.resultstr := '';
@@ -419,7 +505,10 @@ begin
     state.numrr2 := 0;
     for a := 0 to 3 do begin
       state.numrr1[a] := htons(state.recvpacket.rrcount[a]);
-      if state.numrr1[a] > maxrrofakind then goto failure;
+      if state.numrr1[a] > maxrrofakind then begin
+        failurereason := 'exceeded maximum RR of a kind';
+        goto failure;
+      end;
       inc(state.numrr2,state.numrr1[a]);
     end;
 
@@ -456,6 +545,19 @@ begin
       goto failure;
     end;
 
+    {if we requested A or AAAA build a list of all replies}
+    if (state.requesttype = querytype_a) or (state.requesttype = querytype_aaaa) then begin
+      state.resultlist := biniplist_new;
+      for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin
+        rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
+        rrtemp := rrptemp.p;
+        b := rrptemp.len;
+        if rrtemp.requesttype = state.requesttype then begin
+          biniplist_add(state.resultlist,getipfromrr(rrptemp^,b));
+        end;
+      end;
+    end;
+
     {- check for items of the requested type in answer section, if so return success first}
     for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin
       rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
@@ -480,23 +582,7 @@ begin
 
     {no cnames found, no items of correct type found}
     if state.forwardfamily <> 0 then goto failure;
-{$ifdef ipv6}
-    if (state.requesttype = querytype_a) then begin
-      {v6 only: in case of forward, look for AAAA in alternative section}
-      for a := state.numrr1[0]+state.numrr1[1]+state.numrr1[2] to (state.numrr2-1) do begin
-        rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
-        rrtemp := rrptemp.p;
-        b := rrptemp.len;
-        if rrtemp.requesttype = querytype_aaaa then begin
-          setstate_return(rrptemp^,b,state);
-          exit;
-        end;
-      end;
-      {no AAAA's found in alternative, do a recursive lookup for them}
-      state.requesttype := querytype_aaaa;
-      goto recursed;
-    end;
-{$endif}
+
     goto failure;
 recursed:
     {here it needs recursed lookup}
@@ -511,7 +597,7 @@ recursed:
     goto failure;
   end;
 
-  {do /ets/hosts lookup here}
+  {do /etc/hosts lookup here}
   state.sendpacketlen := buildrequest(state.queryname,state.sendpacket,state.requesttype);
   if state.sendpacketlen = 0 then begin
     failurereason := 'building request packet failed';
@@ -524,131 +610,59 @@ recursed:
 failure:
   setstate_failure(state);
 end;
-{$ifdef win32}
-  const
-    MAX_HOSTNAME_LEN = 132;
-    MAX_DOMAIN_NAME_LEN = 132;
-    MAX_SCOPE_ID_LEN = 260    ;
-    MAX_ADAPTER_NAME_LENGTH = 260;
-    MAX_ADAPTER_ADDRESS_LENGTH = 8;
-    MAX_ADAPTER_DESCRIPTION_LENGTH = 132;
-    ERROR_BUFFER_OVERFLOW = 111;
-    MIB_IF_TYPE_ETHERNET = 6;
-    MIB_IF_TYPE_TOKENRING = 9;
-    MIB_IF_TYPE_FDDI = 15;
-    MIB_IF_TYPE_PPP = 23;
-    MIB_IF_TYPE_LOOPBACK = 24;
-    MIB_IF_TYPE_SLIP = 28;
-
-
-  type
-    tip_addr_string=packed record
-      Next :pointer;
-      IpAddress : array[0..15] of char;
-      ipmask    : array[0..15] of char;
-      context   : dword;
-    end;
-    pip_addr_string=^tip_addr_string;
-    tFIXED_INFO=packed record
-       HostName         : array[0..MAX_HOSTNAME_LEN-1] of char;
-       DomainName       : array[0..MAX_DOMAIN_NAME_LEN-1] of char;
-       currentdnsserver : pip_addr_string;
-       dnsserverlist    : tip_addr_string;
-       nodetype         : longint;
-       ScopeId          : array[0..MAX_SCOPE_ID_LEN + 4] of char;
-       enablerouting    : longbool;
-       enableproxy      : longbool;
-       enabledns        : longbool;
-    end;
-    pFIXED_INFO=^tFIXED_INFO;
 
-  var
-    iphlpapi : thandle;
-    getnetworkparams : function(pFixedInfo : PFIXED_INFO;OutBufLen : plongint) : longint;stdcall;
-{$endif}
+
 procedure populatednsserverlist;
 var
-  {$ifdef win32}
-    fixed_info : pfixed_info;
-    fixed_info_len : longint;
-    currentdnsserver : pip_addr_string;
-  {$else}
-    t:textfile;
-    s:string;
-    a:integer;
-  {$endif}
+  a:integer;
 begin
-  //result := '';
-  if assigned(dnsserverlist) then begin
-    dnsserverlist.clear;
+  if assigned(dnsserverlag) then begin
+    dnsserverlag.clear;
   end else begin
-    dnsserverlist := tstringlist.Create;
+    dnsserverlag := tlist.Create;
   end;
-  {$ifdef win32}
-    if iphlpapi=0 then iphlpapi := loadlibrary('iphlpapi.dll');
-    if not assigned(getnetworkparams) then @getnetworkparams := getprocaddress(iphlpapi,'GetNetworkParams');
-    fixed_info_len := 0;
-    if GetNetworkParams(nil,@fixed_info_len)<>ERROR_BUFFER_OVERFLOW then exit;
-    //fixed_info_len :=sizeof(tfixed_info);
-    getmem(fixed_info,fixed_info_len);
-    if GetNetworkParams(fixed_info,@fixed_info_len)<>0 then begin
-      freemem(fixed_info);
-      exit;
-    end;
-    currentdnsserver := @(fixed_info.dnsserverlist);
-    while assigned(currentdnsserver) do begin
-      dnsserverlist.Add(currentdnsserver.IpAddress);
-      currentdnsserver := currentdnsserver.next;
-    end;
-    freemem(fixed_info);
-  {$else}
-    filemode := 0;
-    assignfile(t,'/etc/resolv.conf');
-    {$i-}reset(t);{$i+}
-    if ioresult <> 0 then exit;
-
-    while not eof(t) do begin
-      readln(t,s);
-      if not (copy(s,1,10) = 'nameserver') then continue;
-      s := copy(s,11,500);
-      while s <> '' do begin
-        if (s[1] = #32) or (s[1] = #9) then s := copy(s,2,500) else break;
-      end;
-      a := pos(' ',s);
-      if a <> 0 then s := copy(s,1,a-1);
-      a := pos(#9,s);
-      if a <> 0 then s := copy(s,1,a-1);
-      //result := s;
-      //if result <> '' then break;
-      dnsserverlist.Add(s);
-    end;
-    close(t);
-  {$endif}
+
+  dnsserverlist := getsystemdnsservers;
+  for a := biniplist_getcount(dnsserverlist)-1 downto 0 do dnsserverlag.Add(nil);
 end;
 
 procedure cleardnsservercache;
 begin
-  if assigned(dnsserverlist) then begin
-    dnsserverlist.destroy;
-    dnsserverlist := nil;
+  if assigned(dnsserverlag) then begin
+    dnsserverlag.destroy;
+    dnsserverlag := nil;
+    dnsserverlist := '';
   end;
 end;
 
-function getcurrentsystemnameserver(var id:integer):string;
-var 
+function getcurrentsystemnameserverbin(var id:integer):tbinip;
+var
   counter : integer;
-
 begin
-  if not assigned(dnsserverlist) then populatednsserverlist;
-  if dnsserverlist.count=0 then raise exception.create('no dns servers availible');
-  id := 0;
-  if dnsserverlist.count >1 then begin
+  {override the name server choice here, instead of overriding it wherever it's called
+  setting ID to -1 causes it to be ignored in reportlag}
+  if (overridednsserver <> '') then begin
+    result := ipstrtobinf(overridednsserver);
+    if result.family <> 0 then begin
+      id := -1;
+      exit;
+    end;
+  end;
 
-    for counter := 1 to dnsserverlist.count-1 do begin
-      if taddrint(dnsserverlist.objects[counter]) < taddrint(dnsserverlist.objects[id]) then id := counter;
+  if not assigned(dnsserverlag) then populatednsserverlist;
+  if dnsserverlag.count=0 then raise exception.create('no dns servers available');
+  id := 0;
+  if dnsserverlag.count >1 then begin
+    for counter := dnsserverlag.count-1 downto 1 do begin
+      if taddrint(dnsserverlag[counter]) < taddrint(dnsserverlag[id]) then id := counter;
     end;
   end;
-  result := dnsserverlist[id]
+  result := biniplist_get(dnsserverlist,id);
+end;
+
+function getcurrentsystemnameserver(var id:integer):ansistring;
+begin
+  result := ipbintostr(getcurrentsystemnameserverbin(id));
 end;
 
 procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout
@@ -656,16 +670,50 @@ var
   counter : integer;
   temp : integer;
 begin
-  if (id < 0) or (id >= dnsserverlist.count) then exit;
+  if (id < 0) or (id >= dnsserverlag.count) then exit;
   if lag = -1 then lag := timeoutlag;
-  for counter := 0 to dnsserverlist.count-1 do begin
-    temp := taddrint(dnsserverlist.objects[counter]) *15;
+  for counter := 0 to dnsserverlag.count-1 do begin
+    temp := taddrint(dnsserverlag[counter]) *15;
     if counter=id then temp := temp + lag;
-    dnsserverlist.objects[counter] := tobject(temp div 16);
+    dnsserverlag[counter] := tobject(temp div 16);
   end;
 
 end;
 
+
+{$ifdef ipv6}
+
+procedure initpreferredmode;
+var
+  l:tbiniplist;
+  a:integer;
+  ip:tbinip;
+  ipmask_global,ipmask_6to4,ipmask_teredo:tbinip;
+
+begin
+  if preferredmodeinited then exit;
+  if useaf <> useaf_default then exit;
+  l := getv6localips;
+  if biniplist_getcount(l) = 0 then exit;
+  useaf := useaf_preferv4;
+  ipstrtobin('2000::',ipmask_global);
+  ipstrtobin('2001::',ipmask_teredo);
+  ipstrtobin('2002::',ipmask_6to4);
+  {if there is any v6 IP which is globally routable and not 6to4 and not teredo, prefer v6}
+  for a := biniplist_getcount(l)-1 downto 0 do begin
+    ip := biniplist_get(l,a);
+    if not comparebinipmask(ip,ipmask_global,3) then continue;
+    if comparebinipmask(ip,ipmask_teredo,32) then continue;
+    if comparebinipmask(ip,ipmask_6to4,16) then continue;
+    useaf := useaf_preferv6;
+    preferredmodeinited := true;
+    exit;
+  end;
+end;
+
+{$endif}
+
+
 {  quick and dirty description of dns packet structure to aid writing and
    understanding of parser code, refer to appropriate RFCs for proper specs
 - all words are network order