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