From: beware <beware@bircd.org>
Date: Sun, 30 Mar 2008 00:16:07 +0000 (+0000)
Subject: the big lot of changes by beware
X-Git-Url: http://www.lcore.org/git/lcore.git/commitdiff_plain/6cb6b7ede2d178e03fa817bc28474c175f5a93b9?ds=sidebyside
the big lot of changes by beware
git-svn-id: file:///svnroot/lcore/trunk@2 b1de8a11-f9be-4011-bde0-cc7ace90066a
---
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;