From 6cb6b7ede2d178e03fa817bc28474c175f5a93b9 Mon Sep 17 00:00:00 2001 From: beware Date: Sun, 30 Mar 2008 00:16:07 +0000 Subject: [PATCH 1/1] the big lot of changes by beware git-svn-id: file:///svnroot/lcore/trunk@2 b1de8a11-f9be-4011-bde0-cc7ace90066a --- binipstuff.pas | 183 ++++++++++++++++++ btime.pas | 363 ++++++++++++++++++++++++++++------- dnscore.pas | 79 ++++++-- dnssync.pas | 415 +++++++++++++++++++++++++++++----------- dnswin.pas | 130 ++++++++----- fd_utils.pas | 2 - lcore.pas | 12 +- lcoreselect.pas | 18 +- lcorewsaasyncselect.pas | 23 ++- lsocket.pas | 294 +++++++++++----------------- 10 files changed, 1064 insertions(+), 455 deletions(-) diff --git a/binipstuff.pas b/binipstuff.pas index ebb9f9c..0c23533 100755 --- a/binipstuff.pas +++ b/binipstuff.pas @@ -6,6 +6,8 @@ unit binipstuff; interface +{$include lcoreconfig.inc} + {$ifndef win32} {$ifdef ipv6} uses sockets; @@ -82,10 +84,52 @@ type {$endif} {$endif} + + + {$ifdef ipv6} + {$ifdef ver1_0} + cuint16=word; + cuint32=dword; + sa_family_t=word; + + {$endif} + {$endif} + TinetSockAddrv = packed record + case integer of + 0: (InAddr:TInetSockAddr); + {$ifdef ipv6} + 1: (InAddr6:TInetSockAddr6); + {$endif} + end; + Pinetsockaddrv = ^Tinetsockaddrv; + + type + tsockaddrin=TInetSockAddr; + + + +{ +bin IP list code, by beware +while this is really just a string, on the interface side it must be treated +as an opaque var which is passed as "var" when it needs to be modified} + + tbiniplist=string; + +function biniplist_new:tbiniplist; +procedure biniplist_add(var l:tbiniplist;ip:tbinip); +function biniplist_getcount(const l:tbiniplist):integer; +function biniplist_get(const l:tbiniplist;index:integer):tbinip; +procedure biniplist_set(var l:tbiniplist;index:integer;ip:tbinip); +procedure biniplist_setcount(var l:tbiniplist;newlen:integer); +procedure biniplist_free(var l:tbiniplist); +procedure biniplist_addlist(var l:tbiniplist;const l2:tbiniplist); +function biniplist_tostr(const l:tbiniplist):string; + function htons(w:word):word; function htonl(i:uint32):uint32; function ipstrtobin(const s:string;var binip:tbinip):boolean; +function ipstrtobinf(const s:string):tbinip; function ipbintostr(const binip:tbinip):string; {$ifdef ipv6} function ip6bintostr(const bin:tin6_addr):string; @@ -93,12 +137,18 @@ function ip6strtobin(const s:string;var bin:tin6_addr):boolean; {$endif} function comparebinip(const ip1,ip2:tbinip):boolean; +procedure maskbits(var binip:tbinip;bits:integer); +function comparebinipmask(ip1,ip2:tbinip;bits:integer):boolean; {deprecated} function longip(s:string):longint; procedure converttov4(var ip:tbinip); +function inaddrvtobinip(inaddrv:tinetsockaddrv):tbinip; +function makeinaddrv(addr:tbinip;port:string;var inaddr:tinetsockaddrv):integer; +function inaddrsize(inaddr:tinetsockaddrv):integer; + implementation uses sysutils; @@ -121,6 +171,46 @@ begin {$endif} end; + +function inaddrvtobinip(inaddrv:tinetsockaddrv):tbinip; +begin + result.family := inaddrv.inaddr.family; + if result.family = AF_INET then result.ip := inaddrv.inaddr.addr; + {$ifdef ipv6} + if result.family = AF_INET6 then result.ip6 := inaddrv.inaddr6.sin6_addr; + {$endif} +end; + +function makeinaddrv(addr:tbinip;port:string;var inaddr:tinetsockaddrv):integer; +begin + result := 0; +{ biniptemp := forwardlookup(addr,10);} + fillchar(inaddr,sizeof(inaddr),0); + //writeln('converted address '+addr+' to binip '+ipbintostr(biniptemp)); + if addr.family = AF_INET then begin + inAddr.InAddr.family:=AF_INET; + inAddr.InAddr.port:=htons(strtointdef(port,0)); + inAddr.InAddr.addr:=addr.ip; + result := sizeof(tinetsockaddr); + end else + {$ifdef ipv6} + if addr.family = AF_INET6 then begin + inAddr.InAddr6.sin6_family:=AF_INET6; + inAddr.InAddr6.sin6_port:=htons(strtointdef(port,0)); + inAddr.InAddr6.sin6_addr:=addr.ip6; + result := sizeof(tinetsockaddr6); + end; + {$endif} +end; + +function inaddrsize(inaddr:tinetsockaddrv):integer; +begin + {$ifdef ipv6} + if inaddr.inaddr.family = AF_INET6 then result := sizeof(tinetsockaddr6) else + {$endif} + result := sizeof(tinetsockaddr); +end; + {internal} {converts dotted v4 IP to longint. returns host endian order} function longip(s:string):longint; @@ -173,6 +263,11 @@ begin end; +function ipstrtobinf; +begin + ipstrtobin(s,result); +end; + function ipstrtobin(const s:string;var binip:tbinip):boolean; begin binip.family := 0; @@ -378,6 +473,31 @@ begin result := (ip1.family = ip2.family); end; +procedure maskbits(var binip:tbinip;bits:integer); +const + ipmax={$ifdef ipv6}15{$else}3{$endif}; +type tarr=array[0..ipmax] of byte; +var + arr:^tarr; + a,b:integer; +begin + arr := @binip.ip; + if bits = 0 then b := 0 else b := ((bits-1) div 8)+1; + for a := b to ipmax do begin + arr[a] := 0; + end; + if (bits and 7 <> 0) then begin + arr[bits shr 3] := arr[bits div 8] and not ($ff shr (bits and 7)) + end; +end; + +function comparebinipmask; +begin + maskbits(ip1,bits); + maskbits(ip2,bits); + result := comparebinip(ip1,ip2); +end; + {converts a binary IP to v4 if it is a v6 IP in the v4 range} procedure converttov4(var ip:tbinip); begin @@ -392,4 +512,67 @@ begin {$endif} end; +{------------------------------------------------------------------------------} + +function biniplist_new:tbiniplist; +begin + result := ''; +end; + +procedure biniplist_add(var l:tbiniplist;ip:tbinip); +var + a:integer; +begin + a := biniplist_getcount(l); + biniplist_setcount(l,a+1); + biniplist_set(l,a,ip); +end; + +function biniplist_getcount(const l:tbiniplist):integer; +begin + result := length(l) div sizeof(tbinip); +end; + +function biniplist_get(const l:tbiniplist;index:integer):tbinip; +begin + if (index >= biniplist_getcount(l)) then begin + fillchar(result,sizeof(result),0); + exit; + end; + move(l[index*sizeof(tbinip)+1],result,sizeof(result)); +end; + +procedure biniplist_set(var l:tbiniplist;index:integer;ip:tbinip); +begin + uniquestring(l); + move(ip,l[index*sizeof(tbinip)+1],sizeof(ip)); +end; + +procedure biniplist_setcount(var l:tbiniplist;newlen:integer); +begin + setlength(l,sizeof(tbinip)*newlen); +end; + +procedure biniplist_free(var l:tbiniplist); +begin + l := ''; +end; + +procedure biniplist_addlist; +begin + l := l + l2; +end; + +function biniplist_tostr(const l:tbiniplist):string; +var + a:integer; +begin + result := '('; + for a := 0 to biniplist_getcount(l)-1 do begin + if result <> '(' then result := result + ', '; + result := result + ipbintostr(biniplist_get(l,a)); + end; + result := result + ')'; +end; + end. diff --git a/btime.pas b/btime.pas index 3d672c4..4636a9b 100755 --- a/btime.pas +++ b/btime.pas @@ -7,6 +7,7 @@ this unit returns unix timestamp with seconds and microseconds (as float) works on windows/delphi, and on freepascal on unix. } + unit btime; interface @@ -14,13 +15,15 @@ interface type float=extended; +const + colorburst=39375000/11; {3579545.4545....} + var timezone:integer; timezonestr:string; irctime,unixtime:integer; tickcount:integer; settimebias:integer; - qpcjump:float; {can be read out and reset for debug purpose} performancecountfreq:extended; function irctimefloat:float; @@ -39,13 +42,48 @@ procedure init; function timestring(i:integer):string; function timestrshort(i:integer):string; +{$ifdef win32} +function unixtimefloat_systemtime:float; +{$endif} + function oletounixfloat(t:float):float; function oletounix(t:tdatetime):integer; function unixtoole(i:integer):tdatetime; +{$ifdef win32} +function mmtimefloat:float; +function qpctimefloat:float; +{$endif} + +const + mmtime_driftavgsize=32; + mmtime_warmupnum=4; + mmtime_warmupcyclelength=15; var + //this flag is to be set when btime has been running long enough to stabilise + warmup_finished:boolean; + timefloatbias:float; + ticks_freq:float=0; + ticks_freq2:float=0; + ticks_freq_known:boolean=false; lastunixtimefloat:float=0; + lastsynctime:float=0; + lastsyncbias:float=0; + + mmtime_last:integer=0; + mmtime_wrapadd:float; + mmtime_lastsyncmm:float=0; + mmtime_lastsyncqpc:float=0; + mmtime_drift:float=1; + mmtime_lastresult:float; + mmtime_nextdriftcorrection:float; + mmtime_driftavg:array[0..mmtime_driftavgsize] of float; + mmtime_synchedqpc:boolean; + + mmtime_prev_drift:float; + mmtime_prev_lastsyncmm:float; + mmtime_prev_lastsyncqpc:float; implementation @@ -58,10 +96,10 @@ uses {$ifdef VER1_0} linux, {$else} - baseunix,unix,unixutil,{needed for 2.0.2} + baseunix,unix,unixutil, {needed for 2.0.2} {$endif} {$else} - windows, + windows,unitsettc,mmsystem, {$endif} sysutils; @@ -87,6 +125,23 @@ begin result := ((i)/86400)+daysdifference; end; +const + highdwordconst=65536.0 * 65536.0; + +function utrunc(f:float):integer; +{converts float to integer, in 32 bits unsigned range} +begin + if f >= (highdwordconst/2) then f := f - highdwordconst; + result := trunc(f); +end; + +function uinttofloat(i:integer):float; +{converts 32 bits unsigned integer to float} +begin + result := i; + if result < 0 then result := result + highdwordconst; +end; + {$ifdef unix} {-----------------------------------------*nix/freepascal code to read time } @@ -114,6 +169,224 @@ end; {$else} {delphi 3} {------------------------------ windows/delphi code to read time} +{ +time float: gettickcount +resolution: 9x: ~55 ms NT: 1/64th of a second +guarantees: continuous without any jumps +frequency base: same as system clock. +epoch: system boot +note: if called more than once per 49.7 days, 32 bits wrapping is compensated for and it keeps going on. +note: i handle the timestamp as signed integer, but with the wrap compensation that works as well, and is faster +} + +function mmtimefloat:float; +const + wrapduration=highdwordconst * 0.001; +var + i:integer; +begin + i := gettickcount; {timegettime} + if i < mmtime_last then begin + mmtime_wrapadd := mmtime_wrapadd + wrapduration; + end; + mmtime_last := i; + result := mmtime_wrapadd + i * 0.001; + + if (ticks_freq <> 0) and ticks_freq_known then result := int((result / ticks_freq)+0.5) * ticks_freq; //turn the float into an exact multiple of 1/64th sec to improve accuracy of things using this +end; + +procedure measure_ticks_freq; +var + f,g:float; + o:tosversioninfo; + isnt:boolean; + is9x:boolean; +begin + if (performancecountfreq = 0) then qpctimefloat; + ticks_freq_known := false; + settc; + f := mmtimefloat; + repeat g := mmtimefloat until g > f; + unsettc; + f := g - f; + fillchar(o,sizeof(o),0); + o.dwOSVersionInfoSize := sizeof(o); + getversionex(o); + isnt := o.dwPlatformId = VER_PLATFORM_WIN32_NT; + is9x := o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS; + + ticks_freq2 := f; + mmtime_synchedqpc := false; + { + NT 64 Hz + identify mode as: nt64 + QPC rate: either 3579545 or TSC freq + QPC synched to gettickcount: no + duration between 2 ticks is constant: yes + gettickcount tick duration: 64 Hz + } + if (f >= 0.014) and (f <= 0.018) and isnt then begin + ticks_freq_known := true; + ticks_freq := 1/64; + mmtime_synchedqpc := false; + end; + + { + NT 100 Hz + identify mode as: nt100 + QPC rate: 1193182 + QPC synched to gettickcount: yes + duration between 2 ticks is constant: no? + gettickcount tick duration: ~99.85 Hz + } + if (performancecountfreq = 1193182) and (f >= 0.008) and (f <= 0.012) and isnt then begin + ticks_freq_known := true; + ticks_freq2 := 11949 / (colorburst / 3); + // ticks_freq2 := 11949 / 1193182; + ticks_freq := 0; + {the ticks freq should be very close to the real one but if it's not exact, it will cause drift and correction jumps} + mmtime_synchedqpc := true; + end; + + {9x} + if (performancecountfreq = 1193182) and (g >= 0.050) and (g <= 0.060) then begin + ticks_freq_known := true; + ticks_freq := 65536 / (colorburst / 3); + mmtime_synchedqpc := true; + end; + ticks_freq_known := true; + if ticks_freq <> 0 then ticks_freq2 := ticks_freq; +// writeln(formatfloat('0.000000',ticks_freq)); +end; + +{ +time float: QueryPerformanceCounter +resolution: <1us +guarantees: can have forward jumps depending on hardware. can have forward and backwards jitter on dual core. +frequency base: on NT, not the system clock, drifts compared to it. +epoch: system boot +} +function qpctimefloat:extended; +var + p:packed record + lowpart:longint; + highpart:longint + end; + p2:tlargeinteger absolute p; + e:extended; +begin + if performancecountfreq = 0 then begin + QueryPerformancefrequency(p2); + e := p.lowpart; + if e < 0 then e := e + highdwordconst; + performancecountfreq := ((p.highpart*highdwordconst)+e); + end; + queryperformancecounter(p2); + e := p.lowpart; + if e < 0 then e := e + highdwordconst; + + result := ((p.highpart*highdwordconst)+e)/performancecountfreq; +end; + +{ +time float: QPC locked to gettickcount +resolution: <1us +guarantees: continuous without any jumps +frequency base: same as system clock. +epoch: system boot +} + +function mmqpctimefloat:float; +const + maxretries=5; + margin=0.002; +var + jump:float; + mm,f,qpc,newdrift,f1,f2:float; + qpcjumped:boolean; + a,b,c:integer; + retrycount:integer; +begin + if not ticks_freq_known then measure_ticks_freq; + retrycount := maxretries; + + qpc := qpctimefloat; + mm := mmtimefloat; + f := (qpc - mmtime_lastsyncqpc) * mmtime_drift + mmtime_lastsyncmm; + //writeln('XXXX ',formatfloat('0.000000',qpc-mm)); + qpcjumped := ((f-mm) > ticks_freq2+margin) or ((f-mm) < -margin); +// if qpcjumped then writeln('qpc jumped ',(f-mm)); + if ((qpc > mmtime_nextdriftcorrection) and not mmtime_synchedqpc) or qpcjumped then begin + + mmtime_nextdriftcorrection := qpc + 1; + repeat + mmtime_prev_drift := mmtime_drift; + mmtime_prev_lastsyncmm := mmtime_lastsyncmm; + mmtime_prev_lastsyncqpc := mmtime_lastsyncqpc; + + mm := mmtimefloat; + dec(retrycount); + settc; + result := qpctimefloat; + f := mmtimefloat; + repeat + if f = mm then result := qpctimefloat; + f := mmtimefloat + until f > mm; + qpc := qpctimefloat; + + unsettc; + if (qpc > result + 0.0001) then begin + continue; + end; + mm := f; + + if (mmtime_lastsyncqpc <> 0) and not qpcjumped then begin + newdrift := (mm - mmtime_lastsyncmm) / (qpc - mmtime_lastsyncqpc); + mmtime_drift := newdrift; + { writeln('raw drift: ',formatfloat('0.00000000',mmtime_drift));} + move(mmtime_driftavg[0],mmtime_driftavg[1],sizeof(mmtime_driftavg[0])*high(mmtime_driftavg)); + mmtime_driftavg[0] := mmtime_drift; + +{ write('averaging drift ',formatfloat('0.00000000',mmtime_drift),' -> ');} +{ mmtime_drift := 0;} + b := 0; + for a := 0 to high(mmtime_driftavg) do begin + if mmtime_driftavg[a] <> 0 then inc(b); +{ mmtime_drift := mmtime_drift + mmtime_driftavg[a];} + end; +{ mmtime_drift := mmtime_drift / b;} + if (b = 1) then a := 5 else if (b = 2) then a := 15 else if (b = 3) then a := 30 else if (b = 4) then a := 60 else if (b = 5) then a := 120 else if (b >= 5) then a := 120; + mmtime_nextdriftcorrection := qpc + a; + if (b >= 2) then warmup_finished := true; +{ writeln(formatfloat('0.00000000',mmtime_drift));} + if mmtime_synchedqpc then mmtime_drift := 1; + end; + + mmtime_lastsyncqpc := qpc; + mmtime_lastsyncmm := mm; + { writeln(formatfloat('0.00000000',mmtime_drift));} + break; + until false; + + + qpc := qpctimefloat; + + result := (qpc - mmtime_lastsyncqpc) * mmtime_drift + mmtime_lastsyncmm; + f := (qpc - mmtime_prev_lastsyncqpc) * mmtime_prev_drift + mmtime_prev_lastsyncmm; + + jump := result-f; + {writeln('jump ',formatfloat('0.000000',jump),' drift ',formatfloat('0.00000000',mmtime_drift),' duration ',formatfloat('0.000',(mmtime_lastsyncqpc-mmtime_prev_lastsyncqpc)),' ',formatfloat('0.00000000',jump/(mmtime_lastsyncqpc-mmtime_prev_lastsyncqpc)));} + + f := result; + end; + + result := f; + + if (result < mmtime_lastresult) then result := mmtime_lastresult + 0.000001; + mmtime_lastresult := result; +end; + { free pascals tsystemtime is incomaptible with windows api calls so we declare it ourselves - plugwash } @@ -160,84 +433,39 @@ begin Result := round(Date_utc) + Time_utc; end; -const - highdwordconst=4294967296.0; - -function wintimefloat:extended; -var - p:packed record - lowpart:longint; - highpart:longint - end; - p2:tlargeinteger absolute p; - e:extended; -begin - if performancecountfreq = 0 then begin - QueryPerformancefrequency(p2); - e := p.lowpart; - if e < 0 then e := e + highdwordconst; - performancecountfreq := ((p.highpart*highdwordconst)+e); - end; - queryperformancecounter(p2); - e := p.lowpart; - if e < 0 then e := e + highdwordconst; - result := ((p.highpart*highdwordconst)+e)/performancecountfreq; -end; - -var - classpriority,threadpriority:integer; - -procedure settc; -var - hprocess,hthread:integer; +function unixtimefloat_systemtime:float; begin - hProcess := GetCurrentProcess; - hThread := GetCurrentThread; - - ClassPriority := GetPriorityClass(hProcess); - ThreadPriority := GetThreadPriority(hThread); + {result := oletounixfloat(now_utc);} - SetPriorityClass(hProcess, REALTIME_PRIORITY_CLASS); - SetThreadPriority(hThread, THREAD_PRIORITY_TIME_CRITICAL); + {this method gives exactly the same result with extended precision, but is less sensitive to float rounding in theory} + result := oletounixfloat(int(date_utc+0.5))+time_utc*86400; end; -procedure unsettc; -var - hprocess,hthread:integer; +function wintimefloat:extended; begin - hProcess := GetCurrentProcess; - hThread := GetCurrentThread; - - SetPriorityClass(hProcess, ClassPriority); - SetThreadPriority(hThread, ThreadPriority); + result := mmqpctimefloat; end; function unixtimefloat:float; +const + margin = 0.0012; var f,g,h:float; begin - if timefloatbias = 0 then begin + result := wintimefloat+timefloatbias; + f := result-unixtimefloat_systemtime; + if ((f > ticks_freq2+margin) or (f < -margin)) or (timefloatbias = 0) then begin +// writeln('unixtimefloat init'); + f := unixtimefloat_systemtime; settc; - f := now_utc; - repeat g := now_utc; h := wintimefloat until g > f; - timefloatbias := oletounixfloat(g)-h; + repeat g := unixtimefloat_systemtime; h := wintimefloat until g > f; unsettc; - end; - result := wintimefloat+timefloatbias; - - { - workaround for QPC jumps - (approach 2: always check "hi res" QPC unixtime against the "guaranteed" systemtime one) - } - f := result-(oletounixfloat(now_utc)); - if abs(f) > 0.02 then begin - f := timefloatbias; - timefloatbias := 0; + timefloatbias := g-h; result := unixtimefloat; - qpcjump := qpcjump + f - timefloatbias; end; - if (result <= lastunixtimefloat) then result := lastunixtimefloat + 0.0000001; + {for small changes backwards, guarantee no steps backwards} + if (result <= lastunixtimefloat) and (result > lastunixtimefloat-1.5) then result := lastunixtimefloat + 0.0000001; lastunixtimefloat := result; end; @@ -352,11 +580,14 @@ end; procedure init; begin - qpcjump := 0; + {$ifdef win32}timebeginperiod(1);{$endif} //ensure stable unchanging clock + fillchar(mmtime_driftavg,sizeof(mmtime_driftavg),0); settimebias := 0; gettimezone; unixtime := unixtimeint; irctime := irctimeint; end; +initialization init; + end. diff --git a/dnscore.pas b/dnscore.pas index bb4fab4..ef4c2f1 100755 --- a/dnscore.pas +++ b/dnscore.pas @@ -54,25 +54,33 @@ } unit dnscore; - - {$ifdef fpc}{$mode delphi}{$endif} - - - +{$include lcoreconfig.inc} interface uses binipstuff,classes,pgtypes; 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). +{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). -//note: this unit will not be able to self populate it's dns server list on -//older versions of windows. +note: this unit will not be able to self populate it's dns server list on +older versions of windows.} + +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; const maxnamelength=127; @@ -115,6 +123,7 @@ type parsepacket:boolean; resultstr:string; resultbin:tbinip; + resultlist:tbiniplist; resultaction:integer; numrr1:array[0..3] of integer; numrr2:integer; @@ -147,7 +156,9 @@ type //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; + +//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):string; procedure setstate_request_init(const name:string;var state:tdnsstate); @@ -337,25 +348,37 @@ end; {==============================================================================} -procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate); -var - a:integer; +function getipfromrr(const rrp:trrpointer;len:integer):tbinip; begin - state.resultaction := action_done; - state.resultstr := ''; + 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; 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); @@ -456,6 +479,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)]; @@ -587,6 +623,7 @@ begin {$ifdef win32} if iphlpapi=0 then iphlpapi := loadlibrary('iphlpapi.dll'); if not assigned(getnetworkparams) then @getnetworkparams := getprocaddress(iphlpapi,'GetNetworkParams'); + if not assigned(getnetworkparams) then exit; fixed_info_len := 0; if GetNetworkParams(nil,@fixed_info_len)<>ERROR_BUFFER_OVERFLOW then exit; //fixed_info_len :=sizeof(tfixed_info); @@ -635,7 +672,7 @@ begin end; function getcurrentsystemnameserver(var id:integer):string; -var +var counter : integer; begin diff --git a/dnssync.pas b/dnssync.pas index 379aa05..3632b29 100755 --- a/dnssync.pas +++ b/dnssync.pas @@ -7,6 +7,8 @@ unit dnssync; {$mode delphi} {$endif} +{$include lcoreconfig.inc} + interface uses dnscore, @@ -26,54 +28,95 @@ interface sysutils; //convert a name to an IP -//IPV4 is preffered if availible, if not IPV6 will be returned (if ipv6 support -//compiled in) +//will return v4 or v6 depending on what seems favorable, or manual preference setting //on error the binip will have a family of 0 (other fiels are also currently //zeroed out but may be used for further error information in future) -//timeout is in seconds, it is ignored when using windows dns +//timeout is in miliseconds, it is ignored when using windows dns function forwardlookup(name:string;timeout:integer):tbinip; +//convert a name to a list of all IP's returned +//this returns both v4 and v6 IP's, or possibly only v4 or v6, depending on settings +//on error, returns an empty list +function forwardlookuplist(name:string;timeout:integer):tbiniplist; + -//convert an IP to a name, on error a null string will be returned, other +//convert an IP to a name, on error a null string will be returned, other //details as above function reverselookup(ip:tbinip;timeout:integer):string; +{$ifdef linux}{$ifdef ipv6} +function getv6localips:tbiniplist; +procedure initpreferredmode; + +var + preferredmodeinited:boolean; + +{$endif}{$endif} + +const + tswrap=$4000; + tsmask=tswrap-1; + + numsock=1{$ifdef ipv6}+1{$endif}; + defaulttimeout=10000; + const mintimeout=16; var dnssyncserver:string; - id : integer; - {$ifdef win32} - sendquerytime : integer; - {$else} - sendquerytime : ttimeval; - {$endif} + id:integer; + + sendquerytime:array[0..numsock-1] of integer; implementation + {$ifdef win32} uses dnswin; {$endif} + +{$ifndef win32} +{$define syncdnscore} +{$endif} + {$i unixstuff.inc} {$i ltimevalstuff.inc} var - fd:integer; - state:tdnsstate; + numsockused:integer; + fd:array[0..numsock-1] of integer; + state:array[0..numsock-1] of tdnsstate; + +{$ifdef syncdnscore} + {$ifdef win32} const winsocket = 'wsock32.dll'; - function sendto(s: TSocket; const Buf; len, flags: Integer; var addrto: TinetSockAddr; tolen: Integer): Integer; stdcall; external winsocket name 'sendto'; - function bind(s: TSocket; var addr: TinetSockAddr; namelen: Integer): Longbool; stdcall; external winsocket name 'bind'; + function sendto(s: TSocket; const Buf; len, flags: Integer; var addrto: TinetSockAddrV; tolen: Integer): Integer; stdcall; external winsocket name 'sendto'; + function bind(s: TSocket; var addr: TinetSockAddrV; namelen: Integer): Longbool; stdcall; external winsocket name 'bind'; type fdset=tfdset; {$endif} -function sendquery(const packet:tdnspacket;len:integer):boolean; + +function getts:integer; +{$ifdef win32} +begin + result := GetTickCount and tsmask; +{$else} +var + temp:ttimeval; +begin + gettimeofday(temp); + result := ((temp.tv_usec div 1000) + (temp.tv_sec * 1000)) and tsmask; +{$endif} +end; + + +function sendquery(socknum:integer;const packet:tdnspacket;len:integer):boolean; var a:integer; addr : string; port : string; - inaddr : TInetSockAddr; - + inaddr : TInetSockAddrV; begin { writeln('sendquery ',decodename(state.packet,state.packetlen,12,0,a),' ',state.requesttype);} result := false; @@ -82,35 +125,42 @@ begin if dnssyncserver <> '' then addr := dnssyncserver else addr := getcurrentsystemnameserver(id); port := '53'; - inAddr.family:=AF_INET; - inAddr.port:=htons(strtointdef(port,0)); - inAddr.addr:=htonl(longip(addr)); + makeinaddrv(ipstrtobinf(addr),port,inaddr); - sendto(fd,packet,len,0,inaddr,sizeof(inaddr)); - {$ifdef win32} - sendquerytime := GetTickCount and $3fff; - {$else} - gettimeofday(sendquerytime); - {$endif} + sendto(fd[socknum],packet,len,0,inaddr,inaddrsize(inaddr)); + sendquerytime[socknum] := getts; result := true; end; procedure setupsocket; var - inAddrtemp : TInetSockAddr; + inAddrtemp : TInetSockAddrV; + a:integer; + biniptemp:tbinip; + addr:string; begin - if fd > 0 then exit; + //init both sockets smultaneously, always, so they get succesive fd's + if fd[0] > 0 then exit; - fd := Socket(AF_INET,SOCK_DGRAM,0); - inAddrtemp.family:=AF_INET; - inAddrtemp.port:=0; - inAddrtemp.addr:=0;{htonl(longip('0.0.0.0'));} - If {$ifndef win32}Not{$endif} Bind(fd,inAddrtemp,SizeOf(inAddrtemp)) Then begin - {$ifdef win32} - raise Exception.create('unable to bind '+inttostr(WSAGetLastError)); - {$else} - raise Exception.create('unable to bind '+inttostr(socketError)); - {$endif} + if dnssyncserver <> '' then addr := dnssyncserver else addr := getcurrentsystemnameserver(id); + //must get the DNS server here so we know to init v4 or v6 + + fillchar(inaddrtemp,sizeof(inaddrtemp),0); + ipstrtobin(addr,biniptemp); + if biniptemp.family = 0 then biniptemp.family := AF_INET; + + inaddrtemp.inaddr.family := biniptemp.family; + + for a := 0 to numsockused-1 do begin + fd[a] := Socket(biniptemp.family,SOCK_DGRAM,0); + + If {$ifndef win32}Not{$endif} Bind(fd[a],inAddrtemp,inaddrsize(inaddrtemp)) Then begin + {$ifdef win32} + raise Exception.create('unable to bind '+inttostr(WSAGetLastError)); + {$else} + raise Exception.create('unable to bind '+inttostr(socketError)); + {$endif} + end; end; end; @@ -118,119 +168,201 @@ procedure resolveloop(timeout:integer); var selectresult : integer; fds : fdset; - {$ifdef win32} - endtime : longint; - starttime : longint; - wrapmode : boolean; - currenttime : integer; - {$else} - endtime : ttimeval; - currenttime : ttimeval; - {$endif} + endtime : longint; + starttime : longint; + wrapmode : boolean; + currenttime : integer; + lag : ttimeval; currenttimeout : ttimeval; selecttimeout : ttimeval; - + socknum:integer; + needprocessing:array[0..numsock-1] of boolean; + finished:array[0..numsock-1] of boolean; + a,b:integer; begin - {$ifdef win32} - starttime := GetTickCount and $3fff; - endtime := starttime +(timeout*1000); - if (endtime and $4000)=0 then begin + if timeout < mintimeout then timeout := defaulttimeout; + + starttime := getts; + endtime := starttime + timeout; + if (endtime and tswrap)=0 then begin wrapmode := false; end else begin wrapmode := true; end; - endtime := endtime and $3fff; - {$else} - gettimeofday(endtime); - endtime.tv_sec := endtime.tv_sec + timeout; - {$endif} + endtime := endtime and tsmask; setupsocket; + for socknum := 0 to numsockused-1 do begin + needprocessing[socknum] := true; + finished[socknum] := false; + end; + repeat - state_process(state); - case state.resultaction of - action_ignore: begin -{ writeln('ignore');} - {do nothing} - end; - action_done: begin -{ writeln('done');} - exit; - //onrequestdone(self,0); - end; - action_sendquery:begin + for socknum := numsockused-1 downto 0 do if needprocessing[socknum] then begin + state_process(state[socknum]); + case state[socknum].resultaction of + action_ignore: begin + {do nothing} + end; + action_done: begin + finished[socknum] := true; + //exit if all resolvers are finished + b := 0; + for a := 0 to numsockused-1 do begin + if finished[a] then inc(b); + end; + if (b = numsockused) then begin + exit; + end; + //onrequestdone(self,0); + end; + action_sendquery:begin { writeln('send query');} - sendquery(state.sendpacket,state.sendpacketlen); + sendquery(socknum,state[socknum].sendpacket,state[socknum].sendpacketlen); + end; end; + needprocessing[socknum] := false; end; - {$ifdef win32} - currenttime := GetTickCount and $3fff; - msectotimeval(selecttimeout, (endtime-currenttime)and$3fff); - {$else} - gettimeofday(currenttime); - selecttimeout := endtime; - tv_substract(selecttimeout,currenttime); - {$endif} + + currenttime := getts; + msectotimeval(selecttimeout, (endtime-currenttime) and tsmask); + fd_zero(fds); - fd_set(fd,fds); + for socknum := numsockused-1 downto 0 do if not finished[socknum] then fd_set(fd[socknum],fds); if (selecttimeout.tv_sec > 0) or (selecttimeout.tv_usec > retryafter) then begin selecttimeout.tv_sec := 0; selecttimeout.tv_usec := retryafter; end; - selectresult := select(fd+1,@fds,nil,nil,@selecttimeout); + //find the highest of the used fd's + b := 0; + for socknum := numsockused-1 downto 0 do if fd[socknum] > b then b := fd[socknum]; + selectresult := select(b+1,@fds,nil,nil,@selecttimeout); if selectresult > 0 then begin -{ writeln('selectresult>0');} - //why the hell are we zeroing out the packet buffer before reading into it?! --plugwash - fillchar(state.recvpacket,sizeof(state.recvpacket),0); - {$ifdef win32} - msectotimeval(lag,(currenttime-sendquerytime)and$3fff); - {$else} - lag := currenttime; - tv_substract(lag,sendquerytime); + currenttime := getts; + for socknum := numsockused-1 downto 0 do if fd_isset(fd[socknum],fds) then begin + { writeln('selectresult>0');} + //why the hell are we zeroing out the packet buffer before reading into it?! --plugwash - {$endif} + fillchar(state[socknum].recvpacket,sizeof(state[socknum].recvpacket),0); + msectotimeval(lag,(currenttime-sendquerytime[socknum]) and tsmask); - reportlag(id,(lag.tv_sec*1000000)+lag.tv_usec); - state.recvpacketlen := recv(fd,state.recvpacket, SizeOf(state.recvpacket),0); - state.parsepacket := true; + if dnssyncserver = '' then reportlag(id,(lag.tv_sec*1000000)+lag.tv_usec); + state[socknum].recvpacketlen := recv(fd[socknum],state[socknum].recvpacket, SizeOf(state[socknum].recvpacket),0); + state[socknum].parsepacket := true; + needprocessing[socknum] := true; + end; end; if selectresult < 0 then exit; if selectresult = 0 then begin - {$ifdef win32} - currenttime := GetTickCount; - {$else} - gettimeofday(currenttime); - {$endif} - reportlag(id,-1); - if {$ifdef win32}(currenttime >= endtime)and ((not wrapmode) or (currenttime < starttime)) {$else}tv_compare(currenttime,endtime){$endif} {currenttime >= endtime } then begin + + currenttime := getts; + + if dnssyncserver = '' then reportlag(id,-1); + if (currenttime >= endtime) and ((not wrapmode) or (currenttime < starttime)) then begin exit; end else begin //resend - sendquery(state.sendpacket,state.sendpacketlen); + for socknum := numsockused-1 downto 0 do begin + sendquery(socknum,state[socknum].sendpacket,state[socknum].sendpacketlen); + end; end; end; until false; end; +{$endif} -function forwardlookup(name:string;timeout:integer):tbinip; +procedure addipsoffamily(var l:tbiniplist;const l2:tbiniplist;family:integer); +var + a:integer; + biniptemp:tbinip; +begin + for a := biniplist_getcount(l2)-1 downto 0 do begin + biniptemp := biniplist_get(l2,a); + if (biniptemp.family = family) then biniplist_add(l,biniptemp); + end; +end; + + +function forwardlookuplist(name:string;timeout:integer):tbiniplist; var dummy : integer; + a,b:integer; + biniptemp:tbinip; + l:tbiniplist; begin - ipstrtobin(name,result); - if result.family <> 0 then exit; //it was an IP address, no need for dns - //lookup + ipstrtobin(name,biniptemp); + if biniptemp.family <> 0 then begin + result := biniplist_new; + biniplist_add(result,biniptemp); + exit; //it was an IP address, no need for dns + end; + {$ifdef win32} - if usewindns then begin - result := winforwardlookup(name,false,dummy); - exit; + if usewindns then begin + if (useaf = useaf_v4) then a := af_inet else if (useaf = useaf_v6) then a := af_inet6 else a := 0; + result := winforwardlookuplist(name,a,dummy); + {$ifdef ipv6} + if (useaf = useaf_preferv4) then begin + {prefer mode: sort the IP's} + l := biniplist_new; + addipsoffamily(l,result,af_inet); + addipsoffamily(l,result,af_inet6); + result := l; + end; + if (useaf = useaf_preferv6) then begin + {prefer mode: sort the IP's} + l := biniplist_new; + addipsoffamily(l,result,af_inet6); + addipsoffamily(l,result,af_inet); + result := l; end; + {$endif} + end else {$endif} - setstate_forward(name,state,0); - resolveloop(timeout); - result := state.resultbin; + begin + {$ifdef syncdnscore} + {$ifdef linux}{$ifdef ipv6}initpreferredmode;{$endif}{$endif} + + numsockused := 0; + + result := biniplist_new; + if (useaf <> useaf_v6) then begin + setstate_forward(name,state[numsockused],af_inet); + inc(numsockused); + end; + {$ifdef ipv6} + if (useaf <> useaf_v4) then begin + setstate_forward(name,state[numsockused],af_inet6); + inc(numsockused); + end; + {$endif} + + resolveloop(timeout); + + if (numsockused = 1) then begin + biniplist_addlist(result,state[0].resultlist); + {$ifdef ipv6} + end else if (useaf = useaf_preferv6) then begin + biniplist_addlist(result,state[1].resultlist); + biniplist_addlist(result,state[0].resultlist); + end else begin + biniplist_addlist(result,state[0].resultlist); + biniplist_addlist(result,state[1].resultlist); + {$endif} + end; + {$endif} + end; +end; + +function forwardlookup(name:string;timeout:integer):tbinip; +var + listtemp:tbiniplist; +begin + listtemp := forwardlookuplist(name,timeout); + result := biniplist_get(listtemp,0); end; function reverselookup(ip:tbinip;timeout:integer):string; @@ -243,11 +375,70 @@ begin exit; end; {$endif} - setstate_reverse(ip,state); + {$ifdef syncdnscore} + setstate_reverse(ip,state[0]); + numsockused := 1; resolveloop(timeout); - result := state.resultstr; + result := state[0].resultstr; + {$endif} end; +{$ifdef linux}{$ifdef ipv6}{$ifdef syncdnscore} +function getv6localips:tbiniplist; +var + t:textfile; + s,s2:string; + ip:tbinip; + a:integer; +begin + result := biniplist_new; + + assignfile(t,'/proc/net/if_inet6'); + {$i-}reset(t);{$i+} + if ioresult <> 0 then exit; {none found, return empty list} + + while not eof(t) do begin + readln(t,s); + s2 := ''; + for a := 0 to 7 do begin + if (s2 <> '') then s2 := s2 + ':'; + s2 := s2 + copy(s,(a shl 2)+1,4); + end; + ipstrtobin(s2,ip); + if ip.family <> 0 then biniplist_add(result,ip); + end; + closefile(t); +end; + +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; + useaf := useaf_preferv4; + l := getv6localips; + 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}{$endif}{$endif} + {$ifdef win32} var wsadata : twsadata; diff --git a/dnswin.pas b/dnswin.pas index 7d986d1..ffe472b 100755 --- a/dnswin.pas +++ b/dnswin.pas @@ -1,12 +1,15 @@ unit dnswin; interface + uses binipstuff,classes,lcore; +{$include lcoreconfig.inc} + //on failure a null string or zeroed out binip will be retuned and error will be //set to a windows error code (error will be left untouched under non error //conditions). -function winforwardlookup(name : string;ipv6preffered : boolean;var error:integer) : tbinip; +function winforwardlookuplist(name : string;familyhint:integer;var error : integer) : tbiniplist; function winreverselookup(ip:tbinip;var error:integer):string; @@ -64,9 +67,15 @@ var freeaddrinfo : tfreeaddrinfo; getnameinfo : tgetnameinfo; procedure v4onlyfreeaddrinfo(ai : paddrinfo); stdcall; +var + next:paddrinfo; begin - freemem(ai.ai_addr); - freemem(ai); + while assigned(ai) do begin + freemem(ai.ai_addr); + next := ai.ai_next; + freemem(ai); + ai := next; + end; end; type @@ -75,31 +84,45 @@ type function v4onlygetaddrinfo(nodename : pchar; servname : pchar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall; var - output : paddrinfo; + output,prev,first : paddrinfo; hostent : phostent; + addrlist:^pointer; begin - if hints.ai_family = af_inet then begin + if hints.ai_family <> af_inet6 then begin result := 0; - getmem(output,sizeof(taddrinfo)); - getmem(output.ai_addr,sizeof(tinetsockaddr)); - output.ai_addr.InAddr.family := af_inet; - if servname <> nil then output.ai_addr.InAddr.port := htons(strtoint(servname)) else output.ai_addr.InAddr.port := 0; + + hostent := gethostbyname(nodename); if hostent = nil then begin result := wsagetlasterror; v4onlyfreeaddrinfo(output); exit; end; - output.ai_addr.InAddr.addr := pplongint(hostent.h_addr_list)^^; - output.ai_flags := 0; - output.ai_family := af_inet; - output.ai_socktype := 0; - output.ai_protocol := 0; - output.ai_addrlen := sizeof(tinetsockaddr); - output.ai_canonname := nil; - output.ai_next := nil; - - res^ := output; + addrlist := pointer(hostent.h_addr_list); + + //ipint := pplongint(hostent.h_addr_list)^^; + prev := nil; + first := nil; + repeat + if not assigned(addrlist^) then break; + + getmem(output,sizeof(taddrinfo)); + if assigned(prev) then prev.ai_next := output; + getmem(output.ai_addr,sizeof(tinetsockaddr)); + if servname <> nil then output.ai_addr.InAddr.port := htons(strtoint(servname)) else output.ai_addr.InAddr.port := 0; + output.ai_addr.InAddr.addr := longint(addrlist^^); + inc(integer(addrlist),4); + output.ai_flags := 0; + output.ai_family := af_inet; + output.ai_socktype := 0; + output.ai_protocol := 0; + output.ai_addrlen := sizeof(tinetsockaddr); + output.ai_canonname := nil; + output.ai_next := nil; + prev := output; + if not assigned(first) then first := output; + until false; + res^ := first; end else begin result := WSANO_RECOVERY; end; @@ -159,44 +182,46 @@ begin end; -function winforwardlookup(name : string;ipv6preffered : boolean;var error : integer) : tbinip; +function winforwardlookuplist(name : string;familyhint:integer;var error : integer) : tbiniplist; var hints: taddrinfo; - res : paddrinfo; - pass : boolean; - ipv6 : boolean; + res0,res : paddrinfo; getaddrinforesult : integer; + biniptemp:tbinip; begin populateprocvars; - for pass := false to true do begin - ipv6 := ipv6preffered xor pass; - hints.ai_flags := 0; - if ipv6 then begin - hints.ai_family := AF_INET6; - end else begin - hints.ai_family := AF_INET; - end; - hints.ai_socktype := 0; - hints.ai_protocol := 0; - hints.ai_addrlen := 0; - hints.ai_canonname := nil; - hints.ai_addr := nil; - hints.ai_next := nil; - getaddrinforesult := getaddrinfo(pchar(name),'1',@hints,@res); - if getaddrinforesult = 0 then begin + hints.ai_flags := 0; + hints.ai_family := familyhint; + hints.ai_socktype := 0; + hints.ai_protocol := 0; + hints.ai_addrlen := 0; + hints.ai_canonname := nil; + hints.ai_addr := nil; + hints.ai_next := nil; + getaddrinforesult := getaddrinfo(pchar(name),'1',@hints,@res); + res0 := res; + result := biniplist_new; + if getaddrinforesult = 0 then begin + + while assigned(res) do begin if res.ai_family = af_inet then begin - result.family := af_inet; - result.ip := res.ai_addr.InAddr.addr; - end else {$ifdef ipv6}if res.ai_family = af_inet6 then begin - result.family := af_inet6; - result.ip6 := res.ai_addr.InAddr6.sin6_addr; - end;{$endif}; - - freeaddrinfo(res); - exit; + biniptemp.family := af_inet; + biniptemp.ip := res.ai_addr.InAddr.addr; + biniplist_add(result,biniptemp); + {$ifdef ipv6} + end else if res.ai_family = af_inet6 then begin + biniptemp.family := af_inet6; + biniptemp.ip6 := res.ai_addr.InAddr6.sin6_addr; + biniplist_add(result,biniptemp); + {$endif} + end; + res := res.ai_next; end; + freeaddrinfo(res0); + exit; end; + if getaddrinforesult <> 0 then begin fillchar(result,0,sizeof(result)); error := getaddrinforesult; @@ -269,22 +294,23 @@ begin freverse := true; resume; end; + procedure tdnswinasync.execute; var error : integer; + l:tbiniplist; begin error := 0; if reverse then begin name := winreverselookup(ip,error); end else begin - ip := winforwardlookup(name,ipv6preffered,error); - + l := winforwardlookuplist(name,0,error); + ip := biniplist_get(l,0); end; - postmessage(hwnddnswin,wm_user,error,taddrint(self)); end; -destructor tdnswinasync.destroy; +destructor tdnswinasync.destroy; begin WaitFor; inherited destroy; diff --git a/fd_utils.pas b/fd_utils.pas index ea6e833..b07a110 100755 --- a/fd_utils.pas +++ b/fd_utils.pas @@ -26,8 +26,6 @@ interface type FDSet= Array [0..255] of longint; {31} PFDSet= ^FDSet; -const - absoloutemaxs=(sizeof(fdset)*8)-1; Procedure FD_Clr(fd:longint;var fds:fdSet); Procedure FD_Zero(var fds:fdSet); diff --git a/lcore.pas b/lcore.pas index 900bc96..30e9c09 100755 --- a/lcore.pas +++ b/lcore.pas @@ -37,6 +37,9 @@ interface const receivebufsize=1460; + var + absoloutemaxs:integer=0; + type {$ifdef ver1_0} sigset= array[0..31] of longint; @@ -326,6 +329,7 @@ end; constructor tlasio.create; begin inherited create(AOwner); + if not assigned(eventcore) then raise exception.create('no event core'); sendq := tfifo.create; recvq := tfifo.create; state := wsclosed; @@ -351,8 +355,8 @@ begin if nextasin <> nil then begin nextasin.prevasin := prevasin; end; - recvq.destroy; - sendq.destroy; + recvq.free; + sendq.free; inherited destroy; end; @@ -392,7 +396,7 @@ end; procedure tlasio.internalclose(error:word); begin - if state<>wsclosed then begin + if (state<>wsclosed) and (state<>wsinvalidstate) then begin if (fdhandlein < 0) or (fdhandleout < 0) then raise exception.create('internalclose called with invalid fd handles'); eventcore.rmasterclr(fdhandlein);//fd_clr(fdhandlein,fdsrmaster); eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster); @@ -419,7 +423,7 @@ begin if assigned(onsessionclosed) then if not destroying then onsessionclosed(self,error); end; - sendq.del(maxlongint); + if assigned(sendq) then sendq.del(maxlongint); end; diff --git a/lcoreselect.pas b/lcoreselect.pas index e0351eb..bae8fe4 100755 --- a/lcoreselect.pas +++ b/lcoreselect.pas @@ -7,11 +7,11 @@ which is included in the package ----------------------------------------------------------------------------- } -{$ifdef fpc} - {$ifndef ver1_0} - {$define useinline} - {$endif} -{$endif} +{$ifdef fpc} + {$ifndef ver1_0} + {$define useinline} + {$endif} +{$endif} unit lcoreselect; @@ -41,8 +41,12 @@ uses {$include unixstuff.inc} {$include ltimevalstuff.inc} + +const + absoloutemaxs_select = (sizeof(fdset)*8)-1; + var - fdreverse:array[0..absoloutemaxs] of tlasio; + fdreverse:array[0..absoloutemaxs_select] of tlasio; type tselecteventcore=class(teventcore) public @@ -393,6 +397,8 @@ end; begin eventcore := tselecteventcore.create; + absoloutemaxs := absoloutemaxs_select; + maxs := 0; fd_zero(fdsrmaster); fd_zero(fdswmaster); diff --git a/lcorewsaasyncselect.pas b/lcorewsaasyncselect.pas index a978c23..3f55f1a 100755 --- a/lcorewsaasyncselect.pas +++ b/lcorewsaasyncselect.pas @@ -2,8 +2,9 @@ unit lcorewsaasyncselect; interface + implementation -uses wcore,lcore,bsearchtree,sysutils,windows,winsock,pgtypes,messages,classes; +uses wcore,lcore,bsearchtree,sysutils,windows,winsock,pgtypes,messages,classes,lsocket; type twineventcore=class(teventcore) public @@ -78,10 +79,10 @@ end; procedure twineventcore.rmasterset(fd : integer;islistensocket : boolean); begin if islistensocket then begin - //writeln('setting accept watch for socket number ',fd); +// writeln('setting accept watch for socket number ',fd); dowsaasyncselect(fd,FD_ACCEPT or FD_CLOSE,0); end else begin - //writeln('setting read watch for socket number',fd); +// writeln('setting read watch for socket number',fd); dowsaasyncselect(fd,FD_READ or FD_CLOSE,0); end; end; @@ -116,23 +117,24 @@ var writetrigger : boolean; lasio : tlasio; begin - //writeln('got a message'); +// writeln('got a message'); Result := 0; // This means we handled the message if (ahwnd=hwndlcore) and (aumsg=wm_user) then begin - //writeln('it appears to be a response to our wsaasyncselect'); +// writeln('it appears to be a response to our wsaasyncselect'); socket := awparam; event := alparam and $FFFF; error := alparam shr 16; - //writeln('socket=',socket,' event=',event,' error=',error); +// writeln('socket=',socket,' event=',event,' error=',error); readtrigger := false; writetrigger := false; lasio := findtree(@fdreverse,inttostr(socket)); if assigned(lasio) then begin if (error <> 0) or ((event and FD_CLOSE) <> 0) then begin - if lasio.state = wsconnecting then begin - lasio.onsessionconnected(lasio,error); + if (lasio.state = wsconnecting) and (error <> 0) then begin + if lasio is tlsocket then tlsocket(lasio).connectionfailedhandler(error) + end else begin + lasio.internalclose(error); end; - lasio.internalclose(error); end else begin if (event and (FD_READ or FD_ACCEPT)) <> 0 then readtrigger := true; if (event and (FD_WRITE)) <> 0 then writetrigger := true; @@ -195,7 +197,7 @@ var begin eventcore := twineventcore.create; - if Windows.RegisterClass(MyWindowClass) = 0 then halt; + if Windows.RegisterClass(MyWindowClass) = 0 then halt; //writeln('about to create lcore handle, hinstance=',hinstance); hwndlcore := CreateWindowEx(WS_EX_TOOLWINDOW, MyWindowClass.lpszClassName, @@ -213,4 +215,5 @@ begin timerwrapperinterface := twintimerwrapperinterface.create(nil); WSAStartup($200, GInitData); + absoloutemaxs := maxlongint; end. diff --git a/lsocket.pas b/lsocket.pas index 58f157d..e56a25d 100755 --- a/lsocket.pas +++ b/lsocket.pas @@ -36,6 +36,9 @@ unit lsocket; {$ifdef fpc} {$mode delphi} {$endif} + +{$include lcoreconfig.inc} + interface uses sysutils, @@ -66,34 +69,6 @@ type 1: (S_un_w: SunW); 2: (S_addr: cardinal); end; - {$ifdef ipv6} - {$ifdef ver1_0} - cuint16=word; - cuint32=dword; - sa_family_t=word; - - - TInetSockAddr6 = packed Record - sin6_family : sa_family_t; - sin6_port : cuint16; - sin6_flowinfo : cuint32; - sin6_addr : Tin6_addr; - sin6_scope_id : cuint32; - end; - {$endif} - {$endif} - TinetSockAddrv = packed record - case integer of - 0: (InAddr:TInetSockAddr); - {$ifdef ipv6} - 1: (InAddr6:TInetSockAddr6); - {$endif} - end; - Pinetsockaddrv = ^Tinetsockaddrv; - - - type - tsockaddrin=TInetSockAddr; type TLsocket = class(tlasio) @@ -101,6 +76,12 @@ type //a: string; inAddr : TInetSockAddrV; + + biniplist:tbiniplist; + trymoreips:boolean; + currentip:integer; + connecttimeout:tltimer; + { inAddrSize:integer;} //host : THostentry ; @@ -113,13 +94,17 @@ type proto:string; udp:boolean; listenqueue:integer; + procedure connectionfailedhandler(error:word); + procedure connecttimeouthandler(sender:tobject); + procedure connectsuccesshandler; function getaddrsize:integer; procedure connect; virtual; + procedure realconnect; procedure bindsocket; procedure listen; function accept : longint; - function sendto(dest:TInetSockAddr;destlen:integer;data:pointer;len:integer):integer; virtual; - function receivefrom(data:pointer;len:integer;var src:TInetSockAddr;var srclen:integer):integer; virtual; + function sendto(dest:TInetSockAddrV;destlen:integer;data:pointer;len:integer):integer; virtual; + function receivefrom(data:pointer;len:integer;var src:TInetSockAddrV;var srclen:integer):integer; virtual; //procedure internalclose(error:word);override; procedure handlefdtrigger(readtrigger,writetrigger:boolean); override; function send(data:pointer;len:integer):integer;override; @@ -143,8 +128,7 @@ type twsocket=tlsocket; {easy} -function htons(w:word):word; -function htonl(i:integer):integer; + {!!!function longipdns(s:string):longint;} {$ifdef ipv6} @@ -160,141 +144,25 @@ const implementation {$include unixstuff.inc} -function longip(s:string):longint;{$ifdef fpc}inline;{$endif} -var - l:longint; - a,b:integer; - -function convertbyte(const s:string):integer;{$ifdef fpc}inline;{$endif} -begin - result := strtointdef(s,-1); - if result < 0 then exit; - if result > 255 then exit; - - {01 exception} - if (result <> 0) and (s[1] = '0') then begin - result := -1; - exit; - end; - - {+1 exception} - if not (s[1] in ['0'..'9']) then begin - result := -1; - exit - end; -end; - -begin - result := 0; - a := pos('.',s); - if a = 0 then exit; - b := convertbyte(copy(s,1,a-1));if (b < 0) then exit; - l := b shl 24; - s := copy(s,a+1,256); - a := pos('.',s); - if a = 0 then exit; - b := convertbyte(copy(s,1,a-1));if (b < 0) then exit; - l := l or b shl 16; - s := copy(s,a+1,256); - a := pos('.',s); - if a = 0 then exit; - b := convertbyte(copy(s,1,a-1));if (b < 0) then exit; - l := l or b shl 8; - s := copy(s,a+1,256); - b := convertbyte(copy(s,1,256));if (b < 0) then exit; - l := l or b; - result := l; -end; - -(*!!! -function longipdns(s:string):longint; -var - host : thostentry; -begin - if s = '0.0.0.0' then begin - result := 0; - end else begin - result := longip(s); - if result = 0 then begin - if gethostbyname(s,host) then begin; - result := htonl(Longint(Host.Addr)); - end; - //writeln(inttohex(longint(host.addr),8)) - end; - if result = 0 then begin - if resolvehostbyname(s,host) then begin; - result := htonl(Longint(Host.Addr)); - end; - //writeln(inttohex(longint(host.addr),8)) - end; - end; -end; -*) - - -function htons(w:word):word; -begin - {$ifndef ENDIAN_BIG} - result := ((w and $ff00) shr 8) or ((w and $ff) shl 8); - {$else} - result := w; - {$endif} -end; - -function htonl(i:integer):integer; -begin - {$ifndef ENDIAN_BIG} - result := (i shr 24) or (i shr 8 and $ff00) or (i shl 8 and $ff0000) or (i shl 24 and $ff000000); - {$else} - result := i; - {$endif} -end; function tlsocket.getaddrsize:integer; begin - {$ifdef ipv6} - if inaddr.inaddr.family = AF_INET6 then result := sizeof(tinetsockaddr6) else - {$endif} - result := sizeof(tinetsockaddr); + result := inaddrsize(inaddr); end; -function makeinaddrv(addr,port:string;var inaddr:tinetsockaddrv):integer; -var - biniptemp:tbinip; -begin - result := 0; - biniptemp := forwardlookup(addr,10); - fillchar(inaddr,sizeof(inaddr),0); - //writeln('converted address '+addr+' to binip '+ipbintostr(biniptemp)); - if biniptemp.family = AF_INET then begin - inAddr.InAddr.family:=AF_INET; - inAddr.InAddr.port:=htons(strtointdef(port,0)); - inAddr.InAddr.addr:=biniptemp.ip; - result := sizeof(tinetsockaddr); - end else - {$ifdef ipv6} - if biniptemp.family = AF_INET6 then begin - inAddr.InAddr6.sin6_family:=AF_INET6; - inAddr.InAddr6.sin6_port:=htons(strtointdef(port,0)); - inAddr.InAddr6.sin6_addr:=biniptemp.ip6; - result := sizeof(tinetsockaddr6); - end else - {$endif} - raise esocketexception.create('unable to resolve address: '+addr); -end; -procedure tlsocket.connect; +procedure tlsocket.realconnect; var a:integer; -begin - if state <> wsclosed then close; - //prevtime := 0; - makeinaddrv(addr,port,inaddr); +begin +// writeln('trying to connect to ',ipbintostr(biniplist_get(biniplist,currentip)),'#',port); + makeinaddrv(biniplist_get(biniplist,currentip),port,inaddr); + inc(currentip); + if (currentip >= biniplist_getcount(biniplist)) then trymoreips := false; udp := uppercase(proto) = 'UDP'; if udp then a := SOCK_DGRAM else a := SOCK_STREAM; a := Socket(inaddr.inaddr.family,a,0); - //writeln(ord(inaddr.inaddr.family)); if a = -1 then begin lasterror := {$ifdef win32}getlasterror{$else}socketerror{$endif}; @@ -309,6 +177,9 @@ begin {$endif} state := wsconnected; if assigned(onsessionconnected) then onsessionconnected(self,0); + + eventcore.rmasterset(fdhandlein,false); + eventcore.wmasterclr(fdhandleout); end else begin state :=wsconnecting; {$ifdef win32} @@ -317,12 +188,9 @@ begin {$else} sockets.Connect(fdhandlein,inADDR,getaddrsize); {$endif} - end; - eventcore.rmasterset(fdhandlein,false); - if udp then begin - eventcore.wmasterclr(fdhandleout); - end else begin + eventcore.rmasterset(fdhandlein,false); eventcore.wmasterset(fdhandleout); + if trymoreips then connecttimeout.enabled := true; end; //sendq := ''; except @@ -331,6 +199,40 @@ begin raise; //reraise the exception end; end; + +end; + +procedure tlsocket.connecttimeouthandler(sender:tobject); +begin + connecttimeout.enabled := false; + destroying := true; //hack to not cause handler to trigger + internalclose(0); + destroying := false; + realconnect; +end; + +procedure tlsocket.connect; +var + a:integer; + ip:tbinip; +begin + if state <> wsclosed then close; + //prevtime := 0; + + biniplist := forwardlookuplist(addr,0); + if biniplist_getcount(biniplist) = 0 then raise exception.create('unable to resolve '+addr); + + //makeinaddrv(addr,port,inaddr); + + currentip := 0; + if not assigned(connecttimeout) then begin + connecttimeout := tltimer.create(self); + connecttimeout.Tag := integer(self); + connecttimeout.ontimer := connecttimeouthandler; + connecttimeout.interval := 2500; + connecttimeout.enabled := false; + end; + realconnect; end; procedure tlsocket.sendstr(const str : string); @@ -345,11 +247,11 @@ end; function tlsocket.send(data:pointer;len:integer):integer; begin if udp then begin - //writeln('sending to '+inttohex(inaddr.inaddr.addr,8)); - result := sendto(inaddr.inaddr,getaddrsize,data,len) -; - //writeln('send result',result); - //writeln('errno',errno); +// writeln('sending to '+ipbintostr(inaddrvtobinip(inaddr)),' ',htons(inaddr.inaddr.port),' ',len,' bytes'); + result := sendto(inaddr,getaddrsize,data,len); + +// writeln('send result ',result); +// writeln('errno',errno); end else begin result := inherited send(data,len); end; @@ -382,7 +284,7 @@ begin end; //gethostbyname(localaddr,host); - inaddrtempsize := makeinaddrv(localaddr,localport,inaddrtemp); + inaddrtempsize := makeinaddrv(forwardlookup(localaddr,0),localport,inaddrtemp); If Bind(fdhandlein,inaddrtempx,inaddrtempsize)<> {$ifdef win32}0{$else}true{$endif} Then begin state := wsclosed; @@ -466,17 +368,18 @@ begin fdhandlein := -1; end; end else begin - eventcore.rmasterset(fdhandlein,true); + eventcore.rmasterset(fdhandlein,not udp); end; if fdhandleout >= 0 then eventcore.wmasterclr(fdhandleout); end; - //writeln('listened on addr '+addr+':'+port+' '+proto+' using socket number ',fdhandlein); + //writeln('listened on addr '+addr+':'+port+' '+proto+' using socket number ',fdhandlein); end; function tlsocket.accept : longint; var FromAddrSize : LongInt; // i don't realy know what to do with these at this FromAddr : TInetSockAddrV; // at this point time will tell :) + a:integer; begin FromAddrSize := Sizeof(FromAddr); @@ -488,33 +391,62 @@ begin //now we have accepted one request start monitoring for more again eventcore.rmasterset(fdhandlein,true); - if result = -1 then raise esocketexception.create('error '+inttostr({$ifdef win32}getlasterror{$else}socketerror{$endif})+' while accepting'); + if result = -1 then begin + raise esocketexception.create('error '+inttostr({$ifdef win32}getlasterror{$else}socketerror{$endif})+' while accepting'); + end; if result > absoloutemaxs then begin myfdclose(result); + a := result; result := -1; - raise esocketexception.create('file discriptor out of range'); + raise esocketexception.create('file discriptor out of range: '+inttostr(a)); end; end; -function tlsocket.sendto(dest:TInetSockAddr;destlen:integer;data:pointer;len:integer):integer; +function tlsocket.sendto(dest:TInetSockAddrV;destlen:integer;data:pointer;len:integer):integer; var - destx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddr{$endif} absolute dest; + destx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddrV{$endif} absolute dest; begin result := {$ifdef win32}winsock{$else}sockets{$endif}.sendto(self.fdhandleout,data^,len,0,destx,destlen); end; -function tlsocket.receivefrom(data:pointer;len:integer;var src:TInetSockAddr;var srclen:integer):integer; +function tlsocket.receivefrom(data:pointer;len:integer;var src:TInetSockAddrV;var srclen:integer):integer; var - srcx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddr{$endif} absolute src; + srcx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddrV{$endif} absolute src; begin result := {$ifdef win32}winsock{$else}sockets{$endif}.recvfrom(self.fdhandlein,data^,len,0,srcx,srclen); end; +procedure tlsocket.connectionfailedhandler(error:word); +begin + if trymoreips then begin +// writeln('failed with error ',error); + connecttimeout.enabled := false; + destroying := true; + state := wsconnected; + self.internalclose(0); + destroying := false; + realconnect; + end else begin + state := wsconnected; + if assigned(onsessionconnected) then onsessionconnected(self,error); + self.internalclose(0); + recvq.del(maxlongint); + end; +end; + +procedure tlsocket.connectsuccesshandler; +begin + trymoreips := false; + connecttimeout.enabled := false; + if assigned(onsessionconnected) then onsessionconnected(self,0); +end; + + procedure tlsocket.handlefdtrigger(readtrigger,writetrigger:boolean); var tempbuf:array[0..receivebufsize-1] of byte; begin - //writeln('got a fd trigger, readtrigger=',readtrigger,' writetrigger=',writetrigger); +// writeln('got a fd trigger, readtrigger=',readtrigger,' writetrigger=',writetrigger,' state=',integer(state)); if (state =wslistening) and readtrigger then begin { debugout('listening socket triggered on read');} eventcore.rmasterclr(fdhandlein); @@ -537,20 +469,17 @@ begin // the read event if not readtrigger then begin state := wsconnected; - if assigned(onsessionconnected) then onsessionconnected(self,0); + connectsuccesshandler; end else begin numread := myfdread(fdhandlein,tempbuf,sizeof(tempbuf)); if numread <> -1 then begin state := wsconnected; - if assigned(onsessionconnected) then onsessionconnected(self,0); + connectsuccesshandler; //connectread := true; recvq.add(@tempbuf,numread); end else begin - state := wsconnected; - if assigned(onsessionconnected) then onsessionconnected(self,{$ifdef win32}wsagetlasterror{$else}linuxerror{$endif}); -{ debugout('connect fail');} - self.internalclose(0); - recvq.del(maxlongint); + connectionfailedhandler({$ifdef win32}wsagetlasterror{$else}linuxerror{$endif}); + exit; end; // if things went well here we are now in the state wsconnected with data sitting in our receive buffer // so we drop down into the processing for data availible @@ -577,6 +506,7 @@ constructor tlsocket.Create(AOwner: TComponent); begin inherited create(aowner); closehandles := true; + trymoreips := true; end; -- 2.30.2