{deprecated}\r
function longip(s:string):longint;\r
\r
+function needconverttov4(const ip:tbinip):boolean;\r
procedure converttov4(var ip:tbinip);\r
\r
function inaddrvtobinip(inaddrv:tinetsockaddrv):tbinip;\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
+function needconverttov4(const ip:tbinip):boolean;\r
begin\r
{$ifdef ipv6}\r
if ip.family = AF_INET6 then begin\r
if (ip.ip6.u6_addr32[0] = 0) and (ip.ip6.u6_addr32[1] = 0) and\r
(ip.ip6.u6_addr16[4] = 0) and (ip.ip6.u6_addr16[5] = $ffff) then begin\r
- ip.family := AF_INET;\r
- ip.ip := ip.ip6.s6_addr32[3];\r
+ result := true;\r
+ exit;\r
end;\r
end;\r
{$endif}\r
+\r
+ result := false;\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
+ {$ifdef ipv6}\r
+ if needconverttov4(ip) then begin\r
+ ip.family := AF_INET;\r
+ ip.ip := ip.ip6.s6_addr32[3];\r
+ end;\r
+ {$endif}\r
end;\r
\r
{-----------biniplist stuff--------------------------------------------------}\r
dnswin,\r
{$endif}\r
lsocket,lcore,\r
- classes,binipstuff,dnscore,btime;\r
+ classes,binipstuff,dnscore,btime,lcorernd;\r
+\r
+{$include lcoreconfig.inc}\r
\r
const\r
numsock=1{$ifdef ipv6}+1{$endif};\r
\r
states: array[0..numsock-1] of tdnsstate;\r
\r
+ destinations: array[0..numsock-1] of tbinip;\r
+\r
dnsserverids : array[0..numsock-1] of integer;\r
startts:double;\r
{$ifdef win32}\r
\r
overrideaf : integer;\r
\r
- //A family value of AF_INET6 will give only\r
- //ipv6 results. Any other value will give ipv4 results in preference and ipv6\r
- //results if ipv4 results are not available;\r
- forwardfamily:integer;\r
-\r
procedure cancel;//cancel an outstanding dns request\r
function dnsresult:string; //get result of dnslookup as a string\r
procedure dnsresultbin(var binip:tbinip); //get result of dnslookup as a tbinip\r
procedure forwardlookup(const name:string); //start forward lookup,\r
//preffering ipv4\r
procedure reverselookup(const binip:tbinip); //start reverse lookup\r
+ procedure customlookup(const name:string;querytype:integer); //start custom type lookup\r
\r
constructor create(aowner:tcomponent); override;\r
destructor destroy; override;\r
procedure tdnsasync.receivehandler(sender:tobject;error:word);\r
var\r
socketno : integer;\r
+ Src : TInetSockAddrV;\r
+ SrcLen : Integer;\r
+ fromip:tbinip;\r
+ fromport:string;\r
begin\r
socketno := tlsocket(sender).tag;\r
//writeln('got a reply on socket number ',socketno);\r
fillchar(states[socketno].recvpacket,sizeof(states[socketno].recvpacket),0);\r
- states[socketno].recvpacketlen := twsocket(sender).Receive(@(states[socketno].recvpacket), SizeOf(states[socketno].recvpacket));\r
+\r
+ SrcLen := SizeOf(Src);\r
+ states[socketno].recvpacketlen := twsocket(sender).ReceiveFrom(@(states[socketno].recvpacket), SizeOf(states[socketno].recvpacket), Src, SrcLen);\r
+\r
+ fromip := inaddrvtobinip(Src);\r
+ fromport := inttostr(htons(src.InAddr.port));\r
+\r
+ if ((not comparebinip(fromip,destinations[socketno])) or (fromport <> port)) then begin\r
+ // writeln('dnsasync received from wrong IP:port ',ipbintostr(fromip),'#',fromport,', expected ',ipbintostr(destinations[socketno]),'#',port);\r
+ exit;\r
+ end;\r
+\r
states[socketno].parsepacket := true;\r
if states[socketno].resultaction <> action_done then begin\r
//we ignore packets that come after we are done\r
if dnsserverids[socketno] >= 0 then begin\r
- reportlag(dnsserverids[socketno],trunc((unixtimefloat-startts)*1000));\r
+ reportlag(dnsserverids[socketno],trunc((unixtimefloat-startts)*1000000));\r
dnsserverids[socketno] := -1;\r
end;\r
{ writeln('received reply');}\r
var\r
destination : string;\r
inaddr : tinetsockaddrv;\r
+ trytolisten:integer;\r
begin\r
{ writeln('sendquery ',decodename(state.packet,state.packetlen,12,0,a),' ',state.requesttype);}\r
//writeln('trying to send query on socket number ',socketno);\r
if port = '' then port := '53';\r
sockets[socketno].Proto := 'udp';\r
sockets[socketno].ondataavailable := receivehandler;\r
- try\r
- sockets[socketno].listen;\r
- except\r
- result := false;\r
- exit;\r
+\r
+ {we are going to bind on a random local port for the DNS request, against the kaminsky attack\r
+ there is a small chance that we're trying to bind on an already used port, so retry a few times}\r
+ for trytolisten := 3 downto 0 do begin\r
+ try\r
+ sockets[socketno].port := inttostr(1024 + randominteger(65536 - 1024));\r
+ sockets[socketno].listen;\r
+ except\r
+ {writeln('failed to listen ',sockets[socketno].localport,' ',trytolisten);}\r
+ if (trytolisten = 0) then begin\r
+ result := false;\r
+ exit;\r
+ end;\r
+ end;\r
end;\r
\r
end;\r
end else begin\r
destination := getcurrentsystemnameserver(dnsserverids[socketno]);\r
end;\r
- makeinaddrv(ipstrtobinf(destination),port,inaddr);\r
+ destinations[socketno] := ipstrtobinf(destination);\r
+\r
+ {$ifdef ipv6}{$ifdef win32}\r
+ if destinations[socketno].family = AF_INET6 then if (requestaf = useaf_default) then requestaf := useaf_preferv6;\r
+ {$endif}{$endif}\r
+\r
+ makeinaddrv(destinations[socketno],port,inaddr);\r
sockets[socketno].sendto(inaddr,sizeof(inaddr), @packet,len);\r
result := true;\r
\r
bip : tbinip;\r
i : integer;\r
begin\r
-\r
ipstrtobin(name,bip);\r
\r
if bip.family <> 0 then begin\r
exit;\r
end;\r
\r
+ if (overridednsserver <> '') and (addr = '') then addr := overridednsserver;\r
+\r
if overrideaf = useaf_default then begin\r
- {$ifdef linux}{$ifdef ipv6}initpreferredmode;{$endif}{$endif}\r
+ {$ifdef ipv6}\r
+ {$ifdef win32}if not (usewindns and (addr = '')) then{$endif}\r
+ initpreferredmode;\r
+ {$endif}\r
requestaf := useaf;\r
end else begin\r
requestaf := overrideaf;\r
end;\r
\r
{$ifdef win32}\r
- if usewindns or (addr = '') then begin\r
+ if usewindns and (addr = '') then begin\r
dwas := tdnswinasync.create;\r
dwas.onrequestdone := winrequestdone;\r
- if forwardfamily = AF_INET6 then begin\r
- dwas.forwardlookup(name,true);\r
- end else begin\r
- dwas.forwardlookup(name,false);\r
- end;\r
+\r
+ dwas.forwardlookup(name);\r
+\r
exit;\r
end;\r
{$endif}\r
end;\r
\r
procedure tdnsasync.reverselookup;\r
-\r
begin\r
+ if (overridednsserver <> '') and (addr = '') then addr := overridednsserver;\r
{$ifdef win32}\r
- if usewindns or (addr = '') then begin\r
+ if usewindns and (addr = '') then begin\r
dwas := tdnswinasync.create;\r
dwas.onrequestdone := winrequestdone;\r
dwas.reverselookup(binip);\r
asyncprocess(0);\r
end;\r
\r
+procedure tdnsasync.customlookup;\r
+begin\r
+ if (overridednsserver <> '') and (addr = '') then addr := overridednsserver;\r
+ setstate_custom(name,querytype,states[0]);\r
+ numsockused := 1;\r
+ asyncprocess(0);\r
+end;\r
+\r
function tdnsasync.dnsresult;\r
begin\r
if states[0].resultstr <> '' then result := states[0].resultstr else begin\r
procedure tdnsasync.winrequestdone(sender:tobject;error:word);\r
\r
begin\r
- if dwas.reverse then begin \r
+ if dwas.reverse then begin\r
states[0].resultstr := dwas.name;\r
end else begin \r
\r
\r
interface\r
\r
-uses binipstuff,classes,pgtypes;\r
+uses binipstuff,classes,pgtypes,lcorernd;\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
}\r
var useaf:integer = useaf_default;\r
\r
+{\r
+(temporarily) use a different nameserver, regardless of the dnsserverlist\r
+}\r
+var overridednsserver:string;\r
+\r
const\r
maxnamelength=127;\r
maxnamefieldlen=63;\r
querytype_a=1;\r
querytype_cname=5;\r
querytype_aaaa=28;\r
+ querytype_a6=38;\r
querytype_ptr=12;\r
querytype_ns=2;\r
querytype_soa=6;\r
querytype_mx=15;\r
-\r
- maxrecursion=10;\r
+ querytype_txt=16;\r
+ querytype_spf=99;\r
+ maxrecursion=50;\r
maxrrofakind=20;\r
\r
retryafter=300000; //microseconds must be less than one second;\r
procedure setstate_failure(var state:tdnsstate);\r
//procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);\r
\r
+//for custom raw lookups such as TXT, as desired by the user\r
+procedure setstate_custom(const name:string; requesttype:integer; var state:tdnsstate);\r
\r
procedure state_process(var state:tdnsstate);\r
\r
//function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):string;\r
\r
-//presumablly this is exported to allow more secure random functions\r
-//to be substituted?\r
-var randomfunction:function:integer;\r
-\r
-\r
procedure populatednsserverlist;\r
procedure cleardnsservercache;\r
\r
{ $endif}\r
\r
\r
-{$ifdef linux}{$ifdef ipv6}\r
+{$ifdef ipv6}\r
function getv6localips:tbiniplist;\r
procedure initpreferredmode;\r
\r
var\r
preferredmodeinited:boolean;\r
\r
-{$endif}{$endif}\r
+{$endif}\r
\r
var\r
failurereason:string;\r
\r
+function getquerytype(s:string):integer;\r
+\r
implementation\r
\r
uses\r
\r
sysutils;\r
\r
+\r
+\r
+function getquerytype(s:string):integer;\r
+begin\r
+ s := uppercase(s);\r
+ result := 0;\r
+ if (s = 'A') then result := querytype_a else\r
+ if (s = 'CNAME') then result := querytype_cname else\r
+ if (s = 'AAAA') then result := querytype_aaaa else\r
+ if (s = 'PTR') then result := querytype_ptr else\r
+ if (s = 'NS') then result := querytype_ns else\r
+ if (s = 'MX') then result := querytype_mx else\r
+ if (s = 'A6') then result := querytype_a6 else\r
+ if (s = 'TXT') then result := querytype_txt else\r
+ if (s = 'SOA') then result := querytype_soa else\r
+ if (s = 'SPF') then result := querytype_spf;\r
+end;\r
+\r
function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer;\r
var\r
a,b:integer;\r
{ writeln('buildrequest: name: ',name);}\r
result := 0;\r
fillchar(packet,sizeof(packet),0);\r
- if assigned(randomfunction) then packet.id := (randomfunction and $ffff) else packet.id := random(65536);\r
+ packet.id := randominteger($10000);\r
+\r
packet.flags := htons($0100);\r
packet.rrcount[0] := htons($0001);\r
\r
\r
{==============================================================================}\r
\r
+function getrawfromrr(const rrp:trrpointer;len:integer):string;\r
+begin\r
+ setlength(result,htons(trr(rrp.p^).datalen));\r
+ uniquestring(result);\r
+ move(trr(rrp.p^).data,result[1],length(result));\r
+end;\r
+\r
+\r
function getipfromrr(const rrp:trrpointer;len:integer):tbinip;\r
begin\r
fillchar(result,sizeof(result),0);\r
querytype_a{$ifdef ipv6},querytype_aaaa{$endif}: begin\r
state.resultbin := getipfromrr(rrp,len);\r
end;\r
+ querytype_txt:begin\r
+ {TXT returns a raw string}\r
+ state.resultstr := copy(getrawfromrr(rrp,len),2,9999);\r
+ fillchar(state.resultbin,sizeof(state.resultbin),0);\r
+ end;\r
+ querytype_mx:begin\r
+ {MX is a name after a 16 bits word}\r
+ state.resultstr := decodename(state.recvpacket,state.recvpacketlen,taddrint(rrp.p)-taddrint(@state.recvpacket)+12,0,a);\r
+ fillchar(state.resultbin,sizeof(state.resultbin),0);\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
state.requesttype := querytype_ptr;\r
end;\r
\r
+procedure setstate_custom(const name:string; requesttype:integer; var state:tdnsstate);\r
+begin\r
+ setstate_request_init(name,state);\r
+ state.requesttype := requesttype;\r
+end;\r
+\r
+\r
procedure setstate_failure(var state:tdnsstate);\r
begin\r
state.resultstr := '';\r
\r
\r
\r
-{$ifdef linux}{$ifdef ipv6}\r
+{$ifdef ipv6}\r
+\r
+{$ifdef linux}\r
function getv6localips:tbiniplist;\r
var\r
t:textfile;\r
closefile(t);\r
end;\r
\r
+{$else}\r
+function getv6localips:tbiniplist;\r
+begin\r
+ result := biniplist_new;\r
+end;\r
+{$endif}\r
+\r
procedure initpreferredmode;\r
var\r
l:tbiniplist;\r
begin\r
if preferredmodeinited then exit;\r
if useaf <> useaf_default then exit;\r
- useaf := useaf_preferv4;\r
l := getv6localips;\r
+ if biniplist_getcount(l) = 0 then exit;\r
+ useaf := useaf_preferv4;\r
ipstrtobin('2000::',ipmask_global);\r
ipstrtobin('2001::',ipmask_teredo);\r
ipstrtobin('2002::',ipmask_6to4);\r
end;\r
end;\r
\r
-{$endif}{$endif}\r
+{$endif}\r
\r
\r
{ quick and dirty description of dns packet structure to aid writing and\r
sockets,\r
fd_utils,\r
{$endif}\r
+ lcorernd,\r
sysutils;\r
\r
//convert a name to an IP\r
defaulttimeout=10000;\r
const mintimeout=16;\r
\r
+ toport='53';\r
+\r
var\r
- dnssyncserver:string;\r
id:integer;\r
\r
sendquerytime:array[0..numsock-1] of integer;\r
numsockused:integer;\r
fd:array[0..numsock-1] of integer;\r
state:array[0..numsock-1] of tdnsstate;\r
+ toaddr:array[0..numsock-1] of tbinip;\r
\r
{$ifdef syncdnscore}\r
\r
result := false;\r
if len = 0 then exit; {no packet}\r
\r
- if dnssyncserver <> '' then addr := dnssyncserver else addr := getcurrentsystemnameserver(id);\r
- port := '53';\r
+ if overridednsserver <> '' then addr := overridednsserver else addr := getcurrentsystemnameserver(id);\r
+\r
+ {$ifdef ipv6}{$ifdef win32}\r
+ if toaddr[socknum].family = AF_INET6 then if (useaf = 0) then useaf := useaf_preferv6;\r
+ {$endif}{$endif}\r
\r
- makeinaddrv(ipstrtobinf(addr),port,inaddr);\r
+ port := toport;\r
+ toaddr[socknum] := ipstrtobinf(addr);\r
+ makeinaddrv(toaddr[socknum],port,inaddr);\r
\r
sendto(fd[socknum],packet,len,0,inaddr,inaddrsize(inaddr));\r
sendquerytime[socknum] := getts;\r
//init both sockets smultaneously, always, so they get succesive fd's\r
if fd[0] > 0 then exit;\r
\r
- if dnssyncserver <> '' then addr := dnssyncserver else addr := getcurrentsystemnameserver(id);\r
+ if overridednsserver <> '' then addr := overridednsserver 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
+ if biniptemp.family = AF_INET6 then biniptemp := ipstrtobinf('::') else biniptemp := ipstrtobinf('0.0.0.0');\r
+\r
\r
for a := 0 to numsockused-1 do begin\r
+ makeinaddrv(biniptemp,inttostr( 1024 + randominteger(65536 - 1024) ),inaddrtemp);\r
+\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
finished:array[0..numsock-1] of boolean;\r
a,b:integer;\r
\r
+ Src : TInetSockAddrV;\r
+ Srcx : {$ifdef win32}sockaddr_in{$else}TInetSockAddrV{$endif} absolute Src;\r
+ SrcLen : Integer;\r
+ fromip:tbinip;\r
+ fromport:string;\r
+\r
begin\r
if timeout < mintimeout then timeout := defaulttimeout;\r
\r
fillchar(state[socknum].recvpacket,sizeof(state[socknum].recvpacket),0);\r
msectotimeval(lag,(currenttime-sendquerytime[socknum]) and tsmask);\r
\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
+ if overridednsserver = '' then reportlag(id,(lag.tv_sec*1000000)+lag.tv_usec);\r
+\r
+ SrcLen := SizeOf(Src);\r
+ state[socknum].recvpacketlen := recvfrom(fd[socknum],state[socknum].recvpacket, SizeOf(state[socknum].recvpacket),0,Srcx,SrcLen);\r
+\r
+ if (state[socknum].recvpacketlen > 0) then begin\r
+ fromip := inaddrvtobinip(Src);\r
+ fromport := inttostr(htons(src.InAddr.port));\r
+ if ((not comparebinip(toaddr[socknum],fromip)) or (fromport <> toport)) then begin\r
+// writeln('dnssync received from wrong IP:port ',ipbintostr(fromip),'#',fromport);\r
+ state[socknum].recvpacketlen := 0;\r
+ end else begin\r
+ state[socknum].parsepacket := true;\r
+ needprocessing[socknum] := true;\r
+ end;\r
+ end;\r
end;\r
end;\r
if selectresult < 0 then exit;\r
\r
currenttime := getts;\r
\r
- if dnssyncserver = '' then reportlag(id,-1);\r
+ if overridednsserver = '' then reportlag(id,-1);\r
if (currenttime >= endtime) and ((not wrapmode) or (currenttime < starttime)) then begin\r
exit;\r
end else begin\r
{$endif}\r
begin\r
{$ifdef syncdnscore}\r
- {$ifdef linux}{$ifdef ipv6}initpreferredmode;{$endif}{$endif}\r
+ {$ifdef ipv6}initpreferredmode;{$endif}\r
\r
numsockused := 0;\r
\r
end else begin\r
biniplist_addlist(result,state[0].resultlist);\r
biniplist_addlist(result,state[1].resultlist);\r
- {$endif} \r
+ {$endif}\r
end;\r
{$endif}\r
end;\r
//release should only be called from the main thread\r
tdnswinasync=class(tthread)\r
private\r
- ipv6preffered : boolean;\r
freverse : boolean;\r
error : integer;\r
freewhendone : boolean;\r
name : string;\r
iplist : tbiniplist;\r
\r
- procedure forwardlookup(name:string;ipv6preffered:boolean);\r
+ procedure forwardlookup(name:string);\r
procedure reverselookup(ip:tbinip);\r
destructor destroy; override;\r
procedure release;\r
end;\r
end;\r
\r
-procedure tdnswinasync.forwardlookup(name:string;ipv6preffered:boolean);\r
+procedure tdnswinasync.forwardlookup(name:string);\r
begin\r
self.name := name;\r
- self.ipv6preffered := ipv6preffered;\r
freverse := false;\r
resume;\r
end;\r
--- /dev/null
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+ For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+ Which is included in the package\r
+ ----------------------------------------------------------------------------- }\r
+\r
+unit fastmd5;\r
+\r
+{\r
+pascal implementation of MD5\r
+\r
+written by Bas Steendijk - steendijk@xs4all.nl\r
+\r
+based on RFC1321 - The MD5 Message-Digest Algorithm\r
+\r
+optimized for speed: saved on copying and sub calls in the core routine\r
+\r
+verified on:\r
+- Borland Delphi 3\r
+- Borland Turbo Pascal 7\r
+- Free Pascal 1.0.6 for i386 (on *nix)\r
+- various other versions of freepascal on windows and linux i386\r
+- various other versions of delphi\r
+- free pascal 1.9.5 on powerpc darwin\r
+\r
+this unit is endian portable but is likely to be significantly slower on big endian systems\r
+}\r
+\r
+{$Q-,R-}\r
+\r
+interface\r
+\r
+\r
+\r
+\r
+\r
+type\r
+ Tmd5=array[0..15] of byte;\r
+\r
+{$i uint32.inc}\r
+\r
+type\r
+ dvar=array[0..0] of byte;\r
+ Tmd5state=record\r
+ buf:array[0..63] of byte;\r
+ H:array[0..3] of uint32;\r
+ msglen:longint;\r
+ msglenhi:longint;\r
+ end;\r
+\r
+procedure md5processblock(var h:array of uint32;const data);\r
+\r
+procedure md5init(var state:tmd5state);\r
+procedure md5process(var state:tmd5state;const data;len:longint);\r
+procedure md5finish(var state:tmd5state;var result);\r
+\r
+procedure getmd5(const data;len:longint;var result);\r
+\r
+function md5tostr(const md5:tmd5):string;\r
+\r
+implementation\r
+\r
+function inttohex(val,bits:integer):string;\r
+const\r
+ hexchar:array[0..15] of char='0123456789abcdef';\r
+begin\r
+ inttohex := hexchar[val shr 4]+hexchar[val and $f];\r
+end;\r
+\r
+{$ifdef cpu386}\r
+function rol(w,bits:uint32): uint32; assembler;\r
+asm\r
+ {cpu386 is not defined on freepascal. but fpc assembler is incompatible, uses different code}\r
+ {inline($89/$d1/$d3/$c0);}\r
+ mov ecx,edx\r
+ rol eax,cl\r
+end;\r
+{$else}\r
+function rol(w,bits:uint32):uint32;\r
+begin\r
+ rol := (w shl bits) or (w shr (32-bits));\r
+end;\r
+{$endif}\r
+\r
+\r
+{function swapbytes(invalue:uint32):uint32;\r
+var\r
+ inbytes : array[0..3] of byte absolute invalue;\r
+ outbytes : array[0..3] of byte absolute result;\r
+\r
+\r
+begin\r
+ outbytes[0] := inbytes[3];\r
+ outbytes[1] := inbytes[2];\r
+ outbytes[2] := inbytes[1];\r
+ outbytes[3] := inbytes[0];\r
+end;}\r
+\r
+procedure md5processblock(var h:array of uint32;const data);\r
+const\r
+ S11=7; S12=12; S13=17; S14=22;\r
+ S21=5; S22=9; S23=14; S24=20;\r
+ S31=4; S32=11; S33=16; S34=23;\r
+ S41=6; S42=10; S43=15; S44=21;\r
+\r
+var\r
+ A,B,C,D:uint32;\r
+ w:array[0..63] of byte absolute data;\r
+ x:array[0..15] of uint32 {$ifndef ENDIAN_BIG} absolute data{$endif} ;\r
+ y:array[0..63] of byte absolute x;\r
+ {$ifdef ENDIAN_BIG}counter : integer;{$endif}\r
+begin\r
+ A := h[0];\r
+ B := h[1];\r
+ C := h[2];\r
+ D := h[3];\r
+ {$ifdef ENDIAN_BIG}\r
+ for counter := 0 to 63 do begin\r
+ y[counter] := w[counter xor 3];\r
+ end;\r
+ {$endif}\r
+ a := rol(a + ((b and c) or ((not b) and d)) + x[ 0] + $d76aa478, S11) + b;\r
+ d := rol(d + ((a and b) or ((not a) and c)) + x[ 1] + $e8c7b756, S12) + a;\r
+ c := rol(c + ((d and a) or ((not d) and b)) + x[ 2] + $242070db, S13) + d;\r
+ b := rol(b + ((c and d) or ((not c) and a)) + x[ 3] + $c1bdceee, S14) + c;\r
+ a := rol(a + ((b and c) or ((not b) and d)) + x[ 4] + $f57c0faf, S11) + b;\r
+ d := rol(d + ((a and b) or ((not a) and c)) + x[ 5] + $4787c62a, S12) + a;\r
+ c := rol(c + ((d and a) or ((not d) and b)) + x[ 6] + $a8304613, S13) + d;\r
+ b := rol(b + ((c and d) or ((not c) and a)) + x[ 7] + $fd469501, S14) + c;\r
+ a := rol(a + ((b and c) or ((not b) and d)) + x[ 8] + $698098d8, S11) + b;\r
+ d := rol(d + ((a and b) or ((not a) and c)) + x[ 9] + $8b44f7af, S12) + a;\r
+ c := rol(c + ((d and a) or ((not d) and b)) + x[10] + $ffff5bb1, S13) + d;\r
+ b := rol(b + ((c and d) or ((not c) and a)) + x[11] + $895cd7be, S14) + c;\r
+ a := rol(a + ((b and c) or ((not b) and d)) + x[12] + $6b901122, S11) + b;\r
+ d := rol(d + ((a and b) or ((not a) and c)) + x[13] + $fd987193, S12) + a;\r
+ c := rol(c + ((d and a) or ((not d) and b)) + x[14] + $a679438e, S13) + d;\r
+ b := rol(b + ((c and d) or ((not c) and a)) + x[15] + $49b40821, S14) + c;\r
+\r
+ a := rol(a + ((b and d) or (c and (not d))) + x[ 1] + $f61e2562, S21) + b;\r
+ d := rol(d + ((a and c) or (b and (not c))) + x[ 6] + $c040b340, S22) + a;\r
+ c := rol(c + ((d and b) or (a and (not b))) + x[11] + $265e5a51, S23) + d;\r
+ b := rol(b + ((c and a) or (d and (not a))) + x[ 0] + $e9b6c7aa, S24) + c;\r
+ a := rol(a + ((b and d) or (c and (not d))) + x[ 5] + $d62f105d, S21) + b;\r
+ d := rol(d + ((a and c) or (b and (not c))) + x[10] + $02441453, S22) + a;\r
+ c := rol(c + ((d and b) or (a and (not b))) + x[15] + $d8a1e681, S23) + d;\r
+ b := rol(b + ((c and a) or (d and (not a))) + x[ 4] + $e7d3fbc8, S24) + c;\r
+ a := rol(a + ((b and d) or (c and (not d))) + x[ 9] + $21e1cde6, S21) + b;\r
+ d := rol(d + ((a and c) or (b and (not c))) + x[14] + $c33707d6, S22) + a;\r
+ c := rol(c + ((d and b) or (a and (not b))) + x[ 3] + $f4d50d87, S23) + d;\r
+ b := rol(b + ((c and a) or (d and (not a))) + x[ 8] + $455a14ed, S24) + c;\r
+ a := rol(a + ((b and d) or (c and (not d))) + x[13] + $a9e3e905, S21) + b;\r
+ d := rol(d + ((a and c) or (b and (not c))) + x[ 2] + $fcefa3f8, S22) + a;\r
+ c := rol(c + ((d and b) or (a and (not b))) + x[ 7] + $676f02d9, S23) + d;\r
+ b := rol(b + ((c and a) or (d and (not a))) + x[12] + $8d2a4c8a, S24) + c;\r
+\r
+ a := rol(a + (b xor c xor d) + x[ 5] + $fffa3942, S31) + b;\r
+ d := rol(d + (a xor b xor c) + x[ 8] + $8771f681, S32) + a;\r
+ c := rol(c + (d xor a xor b) + x[11] + $6d9d6122, S33) + d;\r
+ b := rol(b + (c xor d xor a) + x[14] + $fde5380c, S34) + c;\r
+ a := rol(a + (b xor c xor d) + x[ 1] + $a4beea44, S31) + b;\r
+ d := rol(d + (a xor b xor c) + x[ 4] + $4bdecfa9, S32) + a;\r
+ c := rol(c + (d xor a xor b) + x[ 7] + $f6bb4b60, S33) + d;\r
+ b := rol(b + (c xor d xor a) + x[10] + $bebfbc70, S34) + c;\r
+ a := rol(a + (b xor c xor d) + x[13] + $289b7ec6, S31) + b;\r
+ d := rol(d + (a xor b xor c) + x[ 0] + $eaa127fa, S32) + a;\r
+ c := rol(c + (d xor a xor b) + x[ 3] + $d4ef3085, S33) + d;\r
+ b := rol(b + (c xor d xor a) + x[ 6] + $04881d05, S34) + c;\r
+ a := rol(a + (b xor c xor d) + x[ 9] + $d9d4d039, S31) + b;\r
+ d := rol(d + (a xor b xor c) + x[12] + $e6db99e5, S32) + a;\r
+ c := rol(c + (d xor a xor b) + x[15] + $1fa27cf8, S33) + d;\r
+ b := rol(b + (c xor d xor a) + x[ 2] + $c4ac5665, S34) + c;\r
+\r
+ a := rol(a + (c xor (b or (not d))) + x[ 0] + $f4292244, S41) + b;\r
+ d := rol(d + (b xor (a or (not c))) + x[ 7] + $432aff97, S42) + a;\r
+ c := rol(c + (a xor (d or (not b))) + x[14] + $ab9423a7, S43) + d;\r
+ b := rol(b + (d xor (c or (not a))) + x[ 5] + $fc93a039, S44) + c;\r
+ a := rol(a + (c xor (b or (not d))) + x[12] + $655b59c3, S41) + b;\r
+ d := rol(d + (b xor (a or (not c))) + x[ 3] + $8f0ccc92, S42) + a;\r
+ c := rol(c + (a xor (d or (not b))) + x[10] + $ffeff47d, S43) + d;\r
+ b := rol(b + (d xor (c or (not a))) + x[ 1] + $85845dd1, S44) + c;\r
+ a := rol(a + (c xor (b or (not d))) + x[ 8] + $6fa87e4f, S41) + b;\r
+ d := rol(d + (b xor (a or (not c))) + x[15] + $fe2ce6e0, S42) + a;\r
+ c := rol(c + (a xor (d or (not b))) + x[ 6] + $a3014314, S43) + d;\r
+ b := rol(b + (d xor (c or (not a))) + x[13] + $4e0811a1, S44) + c;\r
+ a := rol(a + (c xor (b or (not d))) + x[ 4] + $f7537e82, S41) + b;\r
+ d := rol(d + (b xor (a or (not c))) + x[11] + $bd3af235, S42) + a;\r
+ c := rol(c + (a xor (d or (not b))) + x[ 2] + $2ad7d2bb, S43) + d;\r
+ b := rol(b + (d xor (c or (not a))) + x[ 9] + $eb86d391, S44) + c;\r
+\r
+ inc(h[0],A);\r
+ inc(h[1],B);\r
+ inc(h[2],C);\r
+ inc(h[3],D);\r
+end;\r
+\r
+procedure md5init(var state:tmd5state);\r
+begin\r
+ state.h[0] := $67452301;\r
+ state.h[1] := $EFCDAB89;\r
+ state.h[2] := $98BADCFE;\r
+ state.h[3] := $10325476;\r
+ state.msglen := 0;\r
+ state.msglenhi := 0;\r
+end;\r
+\r
+procedure md5process(var state:tmd5state;const data;len:longint);\r
+var\r
+ a,b:longint;\r
+ ofs:longint;\r
+ p:dvar absolute data;\r
+begin\r
+ b := state.msglen and 63;\r
+\r
+ inc(state.msglen,len);\r
+ while (state.msglen > $20000000) do begin\r
+ dec(state.msglen,$20000000);\r
+ inc(state.msglenhi);\r
+ end;\r
+ ofs := 0;\r
+ if b > 0 then begin\r
+ a := 64-b;\r
+ if a > len then a := len;\r
+ move(p[0],state.buf[b],a);\r
+ inc(ofs,a);\r
+ dec(len,a);\r
+ if b+a = 64 then md5processblock(state.h,state.buf);\r
+ if len = 0 then exit;\r
+ end;\r
+ while len >= 64 do begin\r
+ md5processblock(state.h,p[ofs]);\r
+ inc(ofs,64);\r
+ dec(len,64);\r
+ end;\r
+ if len > 0 then move(p[ofs],state.buf[0],len);\r
+end;\r
+\r
+procedure md5finish(var state:tmd5state;var result);\r
+var\r
+ b :integer;\r
+ {$ifdef endian_big}\r
+ h :tmd5 absolute state.h;\r
+ r :tmd5 absolute result;\r
+ counter :integer ;\r
+ {$endif}\r
+begin\r
+ b := state.msglen and 63;\r
+ state.buf[b] := $80;\r
+ if b >= 56 then begin\r
+ {-- for a := b+1 to 63 do state.buf[a] := 0; }\r
+ fillchar(state.buf[b+1],63-b,0);\r
+ md5processblock(state.h,state.buf);\r
+ fillchar(state.buf,56,0);\r
+ end else begin\r
+ {-- for a := b+1 to 55 do state.buf[a] := 0; }\r
+ fillchar(state.buf[b+1],55-b,0);\r
+ end;\r
+ state.msglen := state.msglen shl 3;\r
+\r
+ state.buf[56] := state.msglen;\r
+ state.buf[57] := state.msglen shr 8;\r
+ state.buf[58] := state.msglen shr 16;\r
+ state.buf[59] := state.msglen shr 24;\r
+ state.buf[60] := state.msglenhi;\r
+ state.buf[61] := state.msglenhi shr 8;\r
+ state.buf[62] := state.msglenhi shr 16;\r
+ state.buf[63] := state.msglenhi shr 24;\r
+\r
+ md5processblock(state.h,state.buf);\r
+ {$ifdef ENDIAN_BIG}\r
+ for counter := 0 to 15 do begin\r
+ r[counter] := h[counter xor 3];\r
+ end;\r
+ {$else} \r
+ move(state.h,result,16);\r
+ {$endif}\r
+ fillchar(state,sizeof(state),0);\r
+end;\r
+\r
+procedure getmd5(const data;len:longint;var result);\r
+var\r
+ t:tmd5state;\r
+begin\r
+ md5init(t);\r
+ md5process(t,data,len);\r
+ md5finish(t,result);\r
+end;\r
+\r
+function md5tostr(const md5:tmd5):string;\r
+var\r
+ a:integer;\r
+ s:string;\r
+begin\r
+ s := '';\r
+ for a := 0 to 15 do s := s + inttohex(md5[a],2);\r
+ md5tostr := s;\r
+end;\r
+\r
+end.\r
{$define ipv6}\r
{$endif}\r
\r
+{-------------------------------------------------------------------------------------}\r
{there are 2 ways to use DNS in lcore: dnscore, which an entire built in DNS client, and getaddrinfo.\r
dnscore is always included on *nix to avoid libc dependency problems, but getaddrinfo is used on windows.\r
when getaddrinfo is used, there is no reason to include dnscore, and it increases the exe size,\r
\r
{-$define syncdnscore}\r
\r
+{-------------------------------------------------------------------------------------}\r
+{lcore contains a built in general purpose secure random number generator, which is used elsewhere in lcore, for\r
+example by the DNS resolver. the used random function can be hooked to point to one's own RNG as desired.\r
+it is then also possible to not include the built in RNG in the exe, which reduces code size}\r
+\r
+{-$define nolcorernd}\r
+\r
+{-------------------------------------------------------------------------------------}\r
{on windows up to XP, listening on ipv6 will not listen on ipv4, while on other platforms it does, \r
so a single listener cant get all connections for a port number, only those for one address family.\r
also it means a portable app would gave to deal with inconsistent behavior.\r
{$ifdef win32}{$ifdef ipv6}\r
{$define secondlistener}\r
{$endif}{$endif}\r
+\r
+{-------------------------------------------------------------------------------------}
\ No newline at end of file
--- /dev/null
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+ For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+ which is included in the package\r
+ ----------------------------------------------------------------------------- }\r
+\r
+unit lcorernd;\r
+\r
+interface\r
+\r
+{$include lcoreconfig.inc}\r
+\r
+{\r
+written by Bas Steendijk (beware)\r
+\r
+the aim of this unit is to provide randomness in a consistent way, using OS specific methods for seeding\r
+\r
+this unit uses MD5 for performance and code size, but it is made so it is easy to use a different hash,\r
+as long as it is atleat 128 bits, and a multiple of the "word size" (32 bits)\r
+\r
+goals:\r
+\r
+- for the code to be:\r
+ - relatively simple and small\r
+ - reasonably fast\r
+\r
+- for the numbers to be\r
+ - random: pass diehard and similar tests\r
+ - unique: generate UUID's\r
+ - secure: difficult for a remote attacker to guess the internal state, even\r
+ when given some output\r
+\r
+typical intended uses:\r
+ - anything that needs random numbers without extreme demands on security or\r
+ speed should be able to use this\r
+ - seeding other (faster) RNG's\r
+ - generation of passwords, UUID's, cookies, and session keys\r
+ - randomizing protocol fields to protect against spoofing attacks\r
+ - randomness for games\r
+\r
+this is not intended to be directly used for:\r
+- high securirity purposes (generating RSA root keys etc)\r
+- needing random numbers at very high rates (disk wiping, some simulations, etc)\r
+\r
+performance:\r
+- 24 MB/s on 2.2 GHz athlon64 core on windows XP 32 bits\r
+- 6.4 MB/s on 1 GHz p3 on linux\r
+\r
+exe size:\r
+- fpc 2.2, linux: fastmd5: 12 kb; lcorernd: 6 kb.\r
+- delphi 6: fastmd5: 3 kb; lcorernd: 2 kb\r
+\r
+reasoning behind the security of this RNG:\r
+\r
+- seeding:\r
+1: i assume that any attacker has no local access to the machine. if one gained\r
+ this, then there are more seriousness weaknesses to consider.\r
+2: i attempt to use enough seeding to be difficult to guess.\r
+ on windows: GUID, various readouts of hi res timestamps, heap stats, cursor\r
+ position\r
+ on *nix: i assume /dev/(u)random output is secure and difficult to guess. if\r
+ it misses, i use /dev/wtmp, which typically has as lot of entropy in it. i also use hi res timestamps.\r
+3: on a state compromise, one can easily get up to the hash size worth of previous output, beyond that one has\r
+ to invert the hash operation.\r
+\r
+- mixing/expansion: a secure hash random walk on a buffer with a constant secret and a changing exposed part,\r
+ the big secret part serves to make it difficult for an attacker to predict next and previous output.\r
+ the secret part is changed during a reseed.\r
+\r
+\r
+ OS randomness\r
+ v\r
+ <wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww>\r
+ ____________________________ ________________________________________________\r
+[ pool ][ seed ]\r
+[hashsize][hashsize][hashsize]\r
+ <rrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr>\r
+ bighash() seeding\r
+ v\r
+ <wwwwwwwwwwwwwwwwww>\r
+<rrrrrrrrrrrrrrrrrrrrrrrrrrrr>\r
+ hash() random walk\r
+ v\r
+<wwwwwwww>\r
+[ output ][ secret ]\r
+\r
+\r
+this needs testing on platforms other than i386\r
+\r
+\r
+these routines are called by everything else in lcore, and if the app coder desires, by the app.\r
+because one may want to use their own random number source, the PRNG here can be excluded from linking,\r
+and the routines here can be hooked.\r
+}\r
+\r
+{$include uint32.inc}\r
+\r
+{return a dword with 32 random bits}\r
+type\r
+ wordtype=uint32;\r
+\r
+var\r
+ randomdword:function:wordtype;\r
+\r
+{fill a buffer with random bytes}\r
+procedure fillrandom(var buf;length:integer);\r
+\r
+{generate an integer of 0 <= N < i}\r
+function randominteger(i:longint):longint;\r
+\r
+{generate an integer with the lowest b bits being random}\r
+function randombits(b:integer):longint;\r
+\r
+{generate a version 4 random uuid}\r
+function generate_uuid:string;\r
+\r
+{$ifndef nolcorernd}\r
+\r
+{call this to mix seeding into the pool. is normally done automatically and does not have to be called\r
+but can be done if one desires more security, for example for key generation}\r
+procedure seedpool;\r
+\r
+{get some raw OS specific randomness. the output is not mixed so it should not be used directly as random numbers}\r
+function collect_seeding(var output;const bufsize:integer):integer;\r
+\r
+function internalrandomdword:wordtype;\r
+\r
+var\r
+ reseedinterval:integer=64;\r
+{$endif}\r
+\r
+implementation\r
+\r
+{$ifndef nolcorernd}\r
+uses\r
+ {$ifdef win32}windows,activex,types,{$endif}\r
+ {$ifdef unix}baseunix,unix,unixutil,{$endif}\r
+ fastmd5,sysutils;\r
+\r
+{$ifdef unix}{$include unixstuff.inc}{$endif}\r
+\r
+type\r
+ {hashtype must be array of bytes}\r
+ hashtype=tmd5;\r
+\r
+const\r
+ wordsizeshift=2;\r
+ wordsize=1 shl wordsizeshift;\r
+\r
+ {$if (wordsize <> sizeof(wordtype))}'wordsizeshift must be setcorrectly'{$ifend}\r
+\r
+ hashsize=sizeof(hashtype);\r
+ halfhashsize=hashsize div 2;\r
+ hashdwords=hashsize div wordsize;\r
+ pooldwords=3*hashdwords;\r
+ seeddwords=32;\r
+ hashpasssize=48; {this number has to be small enough that hashing this size uses only one block transform}\r
+\r
+var\r
+ {the seed part of this buffer must be atleast as big as the OS seed (windows: 104 bytes, unix: 36 bytes)}\r
+ pool:array[0..(pooldwords+seeddwords-1)] of wordtype;\r
+ reseedcountdown:integer;\r
+\r
+{$ifdef win32}\r
+function collect_seeding(var output;const bufsize:integer):integer;\r
+var\r
+ l:packed record\r
+ guid:array[0..3] of longint;\r
+ qpcbuf:array[0..1] of longint;\r
+ rdtscbuf:array[0..1] of longint;\r
+ systemtimebuf:array[0..3] of longint;\r
+ pid:longint;\r
+ tid:longint;\r
+ cursor:tpoint;\r
+ hs:theapstatus;\r
+ end absolute output;\r
+ rdtsc_0,rdtsc_1:integer;\r
+begin\r
+ result := 0;\r
+ if (bufsize < sizeof(l)) then exit;\r
+ result := sizeof(l);\r
+ {PID}\r
+ l.pid := GetCurrentProcessId;\r
+ l.tid := GetCurrentThreadId;\r
+\r
+ {COCREATEGUID}\r
+ cocreateguid(tguid(l.guid));\r
+\r
+ {QUERYPERFORMANCECOUNTER}\r
+ queryperformancecounter(tlargeinteger(l.qpcbuf));\r
+\r
+ {RDTSC}\r
+ {$ifdef cpu386}\r
+ asm\r
+ db $0F; db $31\r
+ mov rdtsc_0,eax\r
+ mov rdtsc_1,edx\r
+ end;\r
+ l.rdtscbuf[0] := rdtsc_0;\r
+ l.rdtscbuf[1] := rdtsc_1;\r
+ {$endif}\r
+ {GETSYSTEMTIME}\r
+ getsystemtime(tsystemtime(l.systemtimebuf));\r
+\r
+ {cursor position}\r
+ getcursorpos(l.cursor);\r
+\r
+ l.hs := getheapstatus;\r
+end;\r
+{$endif}\r
+\r
+{$ifdef unix}\r
+\r
+var\r
+ wtmpinited:boolean;\r
+ wtmpcached:hashtype;\r
+\r
+procedure wtmphash;\r
+var\r
+ f:file;\r
+ buf:array[0..4095] of byte;\r
+ numread:integer;\r
+ state:tmd5state;\r
+begin\r
+ if wtmpinited then exit;\r
+\r
+ assignfile(f,'/var/log/wtmp');\r
+ filemode := 0;\r
+ {$i-}reset(f,1);{$i+}\r
+ if (ioresult <> 0) then exit;\r
+ md5init(state);\r
+ while not eof(f) do begin\r
+ blockread(f,buf,sizeof(buf),numread);\r
+ md5process(state,buf,numread);\r
+ end;\r
+ closefile(f);\r
+ md5finish(state,wtmpcached);\r
+ wtmpinited := true;\r
+end;\r
+\r
+\r
+function collect_seeding(var output;const bufsize:integer):integer;\r
+var\r
+ f:file;\r
+ a:integer;\r
+ l:packed record\r
+ devrnd:array[0..3] of integer;\r
+ rdtscbuf:array[0..1] of integer;\r
+ tv:ttimeval;\r
+ pid:integer;\r
+ end absolute output;\r
+ rdtsc_0,rdtsc_1:integer;\r
+\r
+begin\r
+ result := 0;\r
+ if (bufsize < sizeof(l)) then exit;\r
+ result := sizeof(l);\r
+\r
+ {/DEV/URANDOM}\r
+ a := 1;\r
+ assignfile(f,'/dev/urandom');\r
+ filemode := 0;\r
+ {$i-}reset(f,1);{$i+}\r
+ a := ioresult;\r
+ if (a <> 0) then begin\r
+ assignfile(f,'/dev/random');\r
+ {$i-}reset(f,1);{$i+}\r
+ a := ioresult;\r
+ end;\r
+ if (a = 0) then begin\r
+ blockread(f,l.devrnd,sizeof(l.devrnd));\r
+ closefile(f);\r
+ end else begin\r
+ {the OS we are on has no /dev/random or /dev/urandom, get a hash from /var/log/wtmp}\r
+ wtmphash;\r
+ move(wtmpcached,l.devrnd,sizeof(l.devrnd));\r
+ end;\r
+ {get more randomness in case there's no /dev/random}\r
+ {$ifdef cpu386}{$ASMMODE intel}\r
+ asm\r
+ db $0F; db $31\r
+ mov rdtsc_0,eax\r
+ mov rdtsc_1,edx\r
+ end;\r
+ l.rdtscbuf[0] := rdtsc_0;\r
+ l.rdtscbuf[1] := rdtsc_1;\r
+ {$endif}\r
+\r
+ gettimeofday(l.tv);\r
+ l.pid := getpid;\r
+end;\r
+{$endif}\r
+\r
+{this produces a hash which is twice the native hash size (32 bytes for MD5)}\r
+procedure bighash(const input;len:integer;var output);\r
+var\r
+ inarr:array[0..65535] of byte absolute input;\r
+ outarr:array[0..65535] of byte absolute output;\r
+\r
+ h1,h2,h3,h4:hashtype;\r
+ a:integer;\r
+begin\r
+ a := len div 2;\r
+ {first hash round}\r
+ getmd5(inarr[0],a,h1);\r
+ getmd5(inarr[a],len-a,h2);\r
+\r
+ move(h1[0],h3[0],halfhashsize);\r
+ move(h2[0],h3[halfhashsize],halfhashsize);\r
+ move(h1[halfhashsize],h4[0],halfhashsize);\r
+ move(h2[halfhashsize],h4[halfhashsize],halfhashsize);\r
+\r
+ getmd5(h3,hashsize,outarr[0]);\r
+ getmd5(h4,hashsize,outarr[hashsize]);\r
+end;\r
+\r
+procedure seedpool;\r
+var\r
+ a:integer;\r
+begin\r
+ a := collect_seeding(pool[pooldwords],seeddwords*wordsize);\r
+ if (a = 0) then halt;\r
+ bighash(pool[hashdwords],(2*hashsize)+a,pool[hashdwords]);\r
+ getmd5(pool[0],hashpasssize,pool[0]);\r
+end;\r
+\r
+function internalrandomdword;\r
+begin\r
+ if (reseedcountdown <= 0) then begin\r
+ seedpool;\r
+ reseedcountdown := reseedinterval * hashdwords;\r
+ end else if ((reseedcountdown mod hashdwords) = 0) then begin;\r
+ getmd5(pool[0],hashpasssize,pool[0]);\r
+ end;\r
+ dec(reseedcountdown);\r
+\r
+ result := pool[reseedcountdown mod hashdwords];\r
+end;\r
+{$endif}\r
+\r
+procedure fillrandom(var buf;length:integer);\r
+var\r
+ a,b:integer;\r
+ buf_:array[0..16383] of uint32 absolute buf;\r
+\r
+begin\r
+ b := 0;\r
+ for a := (length shr wordsizeshift)-1 downto 0 do begin\r
+ buf_[b] := randomdword;\r
+ inc(b);\r
+ end;\r
+ length := length and (wordsize-1);\r
+ if length <> 0 then begin\r
+ a := randomdword;\r
+ move(a,buf_[b],length);\r
+ end;\r
+end;\r
+\r
+const\r
+ wordsizebits=32;\r
+\r
+function randombits(b:integer):longint;\r
+begin\r
+ result := randomdword;\r
+ result := result and (-1 shr (wordsizebits-b));\r
+ if (b = 0) then result := 0;\r
+end;\r
+\r
+function randominteger(i:longint):longint;\r
+var\r
+ a,b:integer;\r
+ j:integer;\r
+begin\r
+ //bitscounter := bitscounter + numofbitsininteger(i);\r
+ if (i = 0) then begin\r
+ result := 0;\r
+ exit;\r
+ end;\r
+ {find number of bits needed}\r
+ j := i-1;\r
+ if (j < 0) then begin\r
+ result := randombits(wordsizebits);\r
+ exit\r
+ end else if (j >= (1 shl (wordsizebits-2))) then begin\r
+ b := wordsizebits-1\r
+ end else begin\r
+ b := -1;\r
+ for a := 0 to (wordsizebits-2) do begin\r
+ if j < 1 shl a then begin\r
+ b := a;\r
+ break;\r
+ end;\r
+ end;\r
+ end;\r
+ repeat\r
+ result := randombits(b);\r
+ until result < i;\r
+end;\r
+\r
+const\r
+ ch:array[0..15] of char='0123456789abcdef';\r
+\r
+function generate_uuid:string;\r
+var\r
+ buf:array[0..7] of word;\r
+function inttohex(w:word):string;\r
+begin\r
+ result := ch[w shr 12] + ch[(w shr 8) and $f] + ch[(w shr 4) and $f] + ch[w and $f];\r
+end;\r
+begin\r
+ fillrandom(buf,sizeof(buf));\r
+\r
+ {uuid version 4}\r
+ buf[3] := (buf[3] and $fff) or $4000;\r
+\r
+ {uuid version 4}\r
+ buf[4] := (buf[4] and $3fff) or $8000;\r
+\r
+ result := inttohex(buf[0]) + inttohex(buf[1]) + '-' + inttohex(buf[2]) +'-'+ inttohex(buf[3]) + '-' + inttohex(buf[4])\r
+ + '-' + inttohex(buf[5]) + inttohex(buf[6]) + inttohex(buf[7]);\r
+end;\r
+\r
+{$ifndef nolcorernd}\r
+initialization randomdword := @internalrandomdword;\r
+{$endif}\r
+\r
+end.\r
+\r
function getfdsrmaster : fdset; {$ifdef useinline}inline;{$endif}\r
function getfdswmaster : fdset; {$ifdef useinline}inline;{$endif}\r
\r
+procedure lcoreinit;\r
+\r
implementation\r
uses\r
lcore,sysutils,\r
fdreverse[fd] := reverseto;\r
end;\r
\r
+var\r
+ inited:boolean;\r
\r
-\r
+procedure lcoreinit;\r
begin\r
+ if inited then exit;\r
+ inited := true;\r
eventcore := tselecteventcore.create;\r
\r
absoloutemaxs := absoloutemaxs_select;\r
maxs := 0;\r
fd_zero(fdsrmaster);\r
fd_zero(fdswmaster);\r
+end;\r
+\r
end.\r
\r
interface\r
\r
+procedure lcoreinit;\r
\r
implementation\r
+\r
uses wcore,lcore,bsearchtree,sysutils,windows,winsock,pgtypes,messages,classes,lsocket;\r
type\r
twineventcore=class(teventcore)\r
lpszClassName : 'lcoreClass');\r
GInitData: TWSAData;\r
\r
+var\r
+ inited:boolean;\r
+procedure lcoreinit;\r
begin\r
+ if (inited) then exit;\r
+\r
eventcore := twineventcore.create;\r
if Windows.RegisterClass(MyWindowClass) = 0 then halt;\r
//writeln('about to create lcore handle, hinstance=',hinstance);\r
onaddtask := winaddtask;\r
timerwrapperinterface := twintimerwrapperinterface.create(nil);\r
\r
- WSAStartup($200, GInitData);\r
+ WSAStartup(2, GInitData);\r
absoloutemaxs := maxlongint;\r
+\r
+\r
+ inited := true;\r
+end;\r
+\r
end.\r
If Bind(fdhandlein,inaddrtempx,inaddrtempsize)<> {$ifdef win32}0{$else}true{$endif} Then begin\r
state := wsclosed;\r
lasterror := {$ifdef win32}getlasterror{$else}socketerror{$endif};\r
- raise ESocketException.create('unable to bind, error '+inttostr(lasterror));\r
+ raise ESocketException.create('unable to bind on address '+localaddr+'#'+localport+', error '+inttostr(lasterror));\r
end;\r
state := wsbound;\r
end;\r
\r
function tlsocket.receivefrom(data:pointer;len:integer;var src:TInetSockAddrV;var srclen:integer):integer;\r
var\r
- srcx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddrV{$endif} absolute src;\r
+ tempsrc:TInetSockAddrV;\r
+ tempsrclen:integer;\r
+ srcx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddrV{$endif} absolute tempsrc;\r
+ biniptemp:tbinip;\r
begin\r
{$ifdef secondlistener}\r
if assigned(secondlistener) then if lastsessionfromsecond then begin\r
exit;\r
end;\r
{$endif}\r
- result := {$ifdef win32}winsock{$else}sockets{$endif}.recvfrom(self.fdhandlein,data^,len,0,srcx,srclen);\r
+ tempsrclen := sizeof(tempsrc);\r
+ result := {$ifdef win32}winsock{$else}sockets{$endif}.recvfrom(self.fdhandlein,data^,len,0,srcx,tempsrclen);\r
+\r
+ {$ifdef ipv6}\r
+ biniptemp := inaddrvtobinip(tempsrc);\r
+ if needconverttov4(biniptemp) then begin\r
+ converttov4(biniptemp);\r
+ tempsrclen := makeinaddrv(biniptemp,inttostr(ntohs(tempsrc.InAddr.port)),tempsrc);\r
+ end;\r
+ {$endif}\r
+\r
+ move(tempsrc,src,srclen);\r
+ srclen := tempsrclen;\r
end;\r
\r
procedure tlsocket.connectionfailedhandler(error:word);\r
{$else}\r
sockets.getsocketname(self.fdhandlein,addr,i);\r
{$endif}\r
- binip.family := addr.inaddr.family;\r
- {$ifdef ipv6}\r
- if addr.inaddr6.sin6_family = AF_INET6 then begin\r
- binip.ip6 := addr.inaddr6.sin6_addr;\r
- end else\r
- {$endif}\r
- begin\r
- binip.ip := addr.inaddr.addr;\r
- end;\r
+ binip := inaddrvtobinip(addr);\r
converttov4(binip);\r
end;\r
\r
sockets.getpeername(self.fdhandlein,addr,i);\r
{$endif}\r
\r
- binip.family := addr.inaddr.family;\r
- {$ifdef ipv6}\r
- if addr.inaddr6.sin6_family = AF_INET6 then begin\r
- binip.ip6 := addr.inaddr6.sin6_addr;\r
- end else\r
- {$endif}\r
- begin\r
- binip.ip := addr.inaddr.addr;\r
- end;\r
+ binip := inaddrvtobinip(addr);\r
converttov4(binip);\r
end;\r
\r
-* add multilistener support so that a single tlsocket can be used for both\r
-ipv4 and ipv6 on windows XP\r
-* fixup dnsasync to support multi-ip responses\r
* fixup dnsasync to perform retries and use multiple dns servers
\ No newline at end of file
lcore.org gitweb / lcore.git / commitdiff