--- /dev/null
+all: lcoretest
+
+lcoretest: *.pas *.inc lcoretest.dpr
+ fpc -Sd -dipv6 lcoretest.dpr
+
+clean:
+ -rm *.o
+ -rm *.ppu
+ -rm *.exe
+ -rm *.dcu
+ -rm lcoretest
+
+date := $(shell date +%Y%m%d)
+
+zip:
+ mkdir -p lcorewin32_$(date)
+ cp -a *.pas lcorewin32_$(date)
+ cp -a *.inc lcorewin32_$(date)
+ cp -a *.dpr lcorewin32_$(date)
+ cp -a Makefile lcorewin32_$(date)
+ -rm ../lcorewin32_$(date).zip
+ zip -r ../lcorewin32_$(date).zip lcorewin32_$(date)
+ rm -rf lcorewin32_$(date)
\ 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
+unit bfifo;\r
+{$ifdef fpc}\r
+ {$mode delphi}\r
+{$endif}\r
+\r
+interface\r
+\r
+uses blinklist,pgtypes;\r
+\r
+const\r
+ pagesize=1420;\r
+\r
+type\r
+ tfifo=class(tobject)\r
+ private\r
+ l:tlinklist; {add to}\r
+ getl:tlinklist; {remove from}\r
+ ofs:integer;\r
+ getofs:integer;\r
+ public\r
+ size:integer;\r
+ procedure add(data:pointer;len:integer);\r
+ function get(var resultptr:pointer;len:integer):integer;\r
+ procedure del(len:integer);\r
+ constructor create;\r
+ destructor destroy; override;\r
+ end;\r
+\r
+\r
+implementation\r
+\r
+var\r
+ testcount:integer;\r
+\r
+{\r
+\r
+xx1..... add\r
+xxxxxxxx\r
+....2xxx delete\r
+\r
+1 ofs\r
+2 getofs\r
+\r
+}\r
+\r
+procedure tfifo.add;\r
+var\r
+ a:integer;\r
+ p:tlinklist;\r
+begin\r
+ if len <= 0 then exit;\r
+ inc(size,len);\r
+ while len > 0 do begin\r
+ p := l;\r
+ if ofs = pagesize then begin\r
+ p := tplinklist.create;\r
+ if getl = nil then getl := p;\r
+ getmem(tplinklist(p).p,pagesize);\r
+ inc(testcount);\r
+ linklistadd(l,p);\r
+ ofs := 0;\r
+ end;\r
+ a := pagesize - ofs;\r
+ if len < a then a := len;\r
+ move(data^,pointer(taddrint(tplinklist(p).p)+ofs)^,a);\r
+ inc(taddrint(data),a);\r
+ dec(len,a);\r
+ inc(ofs,a);\r
+ end;\r
+end;\r
+\r
+function tfifo.get;\r
+var\r
+ p:tlinklist;\r
+ a:integer;\r
+begin\r
+ if len > size then len := size;\r
+ if len <= 0 then begin\r
+ result := 0;\r
+ resultptr := nil;\r
+ exit;\r
+ end;\r
+ p := getl;\r
+ resultptr := pointer(taddrint(tplinklist(p).p)+getofs);\r
+ result := pagesize-getofs;\r
+ if result > len then result := len;\r
+end;\r
+\r
+procedure tfifo.del;\r
+var\r
+ a:integer;\r
+ p,p2:tlinklist;\r
+begin\r
+ if len <= 0 then exit;\r
+ p := getl;\r
+ if len > size then len := size;\r
+ dec(size,len);\r
+\r
+ if len = 0 then exit;\r
+\r
+ while len > 0 do begin\r
+ a := pagesize-getofs;\r
+ if a > len then a := len;\r
+ inc(getofs,a);\r
+ dec(len,a);\r
+ if getofs = pagesize then begin\r
+ p2 := p.prev;\r
+ freemem(tplinklist(p).p);\r
+ dec(testcount);\r
+ linklistdel(l,p);\r
+ p.destroy;\r
+ p := p2;\r
+ getl := p;\r
+ getofs := 0;\r
+ end;\r
+ end;\r
+\r
+ if size = 0 then begin\r
+ if assigned(l) then begin\r
+ p := l;\r
+ freemem(tplinklist(p).p);\r
+ dec(testcount);\r
+ linklistdel(l,p);\r
+ p.destroy;\r
+ getl := nil;\r
+ end;\r
+ ofs := pagesize;\r
+ getofs := 0;\r
+ end;\r
+end;\r
+\r
+constructor tfifo.create;\r
+begin\r
+ ofs := pagesize;\r
+ inherited create;\r
+end;\r
+\r
+destructor tfifo.destroy;\r
+begin\r
+ del(size);\r
+ inherited destroy;\r
+end;\r
+\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
+unit binipstuff;\r
+\r
+interface\r
+\r
+{$ifndef win32}\r
+{$ifdef ipv6}\r
+uses sockets;\r
+{$endif}\r
+{$endif}\r
+\r
+{$ifdef fpc}\r
+ {$mode delphi}\r
+{$endif}\r
+{$ifdef cpu386}{$define i386}{$endif}\r
+{$ifdef i386}{$define ENDIAN_LITTLE}{$endif}\r
+\r
+{$include uint32.inc}\r
+\r
+const\r
+ hexchars:array[0..15] of char='0123456789abcdef';\r
+ AF_INET=2;\r
+ {$ifdef win32}\r
+ AF_INET6=23;\r
+ {$else}\r
+ AF_INET6=10;\r
+ {$endif}\r
+\r
+type\r
+ {$ifdef ipv6}\r
+ \r
+ {$ifdef win32}\r
+ {$define want_Tin6_addr}\r
+ {$endif}\r
+ {$ifdef ver1_0}\r
+ {$define want_Tin6_addr}\r
+ {$endif}\r
+ {$ifdef want_Tin6_addr}\r
+ Tin6_addr = packed record\r
+ case byte of\r
+ 0: (u6_addr8 : array[0..15] of byte);\r
+ 1: (u6_addr16 : array[0..7] of Word);\r
+ 2: (u6_addr32 : array[0..3] of uint32);\r
+ 3: (s6_addr8 : array[0..15] of shortint);\r
+ 4: (s6_addr : array[0..15] of shortint);\r
+ 5: (s6_addr16 : array[0..7] of smallint);\r
+ 6: (s6_addr32 : array[0..3] of LongInt);\r
+ end;\r
+ {$endif}\r
+ {$endif}\r
+\r
+ tbinip=record\r
+ family:integer;\r
+ {$ifdef ipv6}\r
+ case integer of\r
+ 0: (ip:longint);\r
+ 1: (ip6:tin6_addr);\r
+ {$else}\r
+ ip:longint;\r
+ {$endif}\r
+ end;\r
+\r
+ {$ifdef win32}\r
+ TInetSockAddr = packed Record\r
+ family:Word;\r
+ port :Word;\r
+ addr :uint32;\r
+ pad :array [1..8] of byte;\r
+ end;\r
+ {$ifdef ipv6}\r
+\r
+ TInetSockAddr6 = packed record\r
+ sin6_family: word;\r
+ sin6_port: word;\r
+ sin6_flowinfo: uint32;\r
+ sin6_addr: tin6_addr;\r
+ sin6_scope_id: uint32;\r
+ end;\r
+ {$endif}\r
+ {$endif}\r
+\r
+function htons(w:word):word;\r
+function htonl(i:uint32):uint32;\r
+\r
+function ipstrtobin(const s:string;var binip:tbinip):boolean;\r
+function ipbintostr(const binip:tbinip):string;\r
+{$ifdef ipv6}\r
+function ip6bintostr(const bin:tin6_addr):string;\r
+function ip6strtobin(const s:string;var bin:tin6_addr):boolean;\r
+{$endif}\r
+\r
+function comparebinip(const ip1,ip2:tbinip):boolean;\r
+\r
+{deprecated}\r
+function longip(s:string):longint;\r
+\r
+procedure converttov4(var ip:tbinip);\r
+\r
+implementation\r
+\r
+uses sysutils;\r
+\r
+function htons(w:word):word;\r
+begin\r
+ {$ifdef ENDIAN_LITTLE}\r
+ result := ((w and $ff00) shr 8) or ((w and $ff) shl 8);\r
+ {$else}\r
+ result := w;\r
+ {$endif}\r
+end;\r
+\r
+function htonl(i:uint32):uint32;\r
+begin\r
+ {$ifdef ENDIAN_LITTLE}\r
+ result := (i shr 24) or (i shr 8 and $ff00) or (i shl 8 and $ff0000) or (i shl 24 and $ff000000);\r
+ {$else}\r
+ result := i;\r
+ {$endif}\r
+end;\r
+\r
+{internal}\r
+{converts dotted v4 IP to longint. returns host endian order}\r
+function longip(s:string):longint;\r
+var\r
+ l:longint;\r
+ a,b:integer;\r
+function convertbyte(const s:string):integer;\r
+begin\r
+ result := strtointdef(s,-1);\r
+ if result < 0 then begin\r
+ result := -1;\r
+ exit;\r
+ end;\r
+ if result > 255 then begin\r
+ result := -1;\r
+ exit;\r
+ end;\r
+ {01 exception}\r
+ if (result <> 0) and (s[1] = '0') then begin\r
+ result := -1;\r
+ exit;\r
+ end;\r
+ {+1 exception}\r
+ if not (s[1] in ['0'..'9']) then begin\r
+ result := -1;\r
+ exit\r
+ end;\r
+end;\r
+\r
+begin\r
+ result := 0;\r
+ a := pos('.',s);\r
+ if a = 0 then exit;\r
+ b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+ l := b shl 24;\r
+ s := copy(s,a+1,256);\r
+ a := pos('.',s);\r
+ if a = 0 then exit;\r
+ b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+ l := l or b shl 16;\r
+ s := copy(s,a+1,256);\r
+ a := pos('.',s);\r
+ if a = 0 then exit;\r
+ b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+ l := l or b shl 8;\r
+ s := copy(s,a+1,256);\r
+ b := convertbyte(copy(s,1,256));if (b < 0) then exit;\r
+ l := l or b;\r
+ result := l;\r
+end;\r
+\r
+\r
+function ipstrtobin(const s:string;var binip:tbinip):boolean;\r
+begin\r
+ binip.family := 0;\r
+ result := false;\r
+ {$ifdef ipv6}\r
+ if pos(':',s) <> 0 then begin\r
+ {try ipv6. use builtin routine}\r
+ result := ip6strtobin(s,binip.ip6);\r
+ if result then binip.family := AF_INET6;\r
+ exit;\r
+ end;\r
+ {$endif}\r
+\r
+ {try v4}\r
+ binip.ip := htonl(longip(s));\r
+ if (binip.ip <> 0) or (s = '0.0.0.0') then begin\r
+ result := true;\r
+ binip.family := AF_INET;\r
+ exit;\r
+ end;\r
+end;\r
+\r
+function ipbintostr(const binip:tbinip):string;\r
+var\r
+ a:integer;\r
+begin\r
+ result := '';\r
+ {$ifdef ipv6}\r
+ if binip.family = AF_INET6 then begin\r
+ result := ip6bintostr(binip.ip6);\r
+ end else\r
+ {$endif}\r
+ if binip.family = AF_INET then begin\r
+ a := htonl(binip.ip);\r
+ result := inttostr(a shr 24)+'.'+inttostr((a shr 16) and $ff)+'.'+inttostr((a shr 8) and $ff)+'.'+inttostr(a and $ff);\r
+ end;\r
+end;\r
+\r
+\r
+{------------------------------------------------------------------------------}\r
+\r
+{$ifdef ipv6}\r
+\r
+{\r
+IPv6 address binary to/from string conversion routines\r
+written by beware (steendijk at xs4all dot nl)\r
+\r
+- implementation does not depend on other ipv6 code such as the tin6_addr type,\r
+ the parameter can also be untyped.\r
+- it is host endian neutral - binary format is aways network order\r
+- it supports compression of zeroes\r
+- it supports ::ffff:192.168.12.34 style addresses\r
+- they are made to do the Right Thing, more efficient implementations are possible\r
+}\r
+\r
+{fpc has hostaddrtostr6 and strtohostaddr6 but the later isnt implemented yet}\r
+\r
+\r
+function ip6bintostr(const bin:tin6_addr):string;\r
+{base16 with lowercase output}\r
+function makehex(w:word):string;\r
+begin\r
+ result := '';\r
+ if w >= 4096 then result := result + hexchars[w shr 12];\r
+ if w >= 256 then result := result + hexchars[w shr 8 and $f];\r
+ if w >= 16 then result := result + hexchars[w shr 4 and $f];\r
+ result := result + hexchars[w and $f];\r
+end;\r
+\r
+var\r
+ a,b,c,addrlen:integer;\r
+ runbegin,runlength:integer;\r
+ bytes:array[0..15] of byte absolute bin;\r
+ words:array[0..7] of word;\r
+ dwords:array[0..3] of integer absolute words;\r
+begin\r
+ for a := 0 to 7 do begin\r
+ words[a] := bytes[a shl 1] shl 8 or bytes[a shl 1 or 1];\r
+ end;\r
+ if (dwords[0] = 0) and (dwords[1] = 0) and (words[4] = 0) and (words[5] = $ffff) then begin\r
+ {::ffff:/96 exception: v4 IP}\r
+ addrlen := 6;\r
+ end else begin\r
+ addrlen := 8;\r
+ end;\r
+ {find longest run of zeroes}\r
+ runbegin := 0;\r
+ runlength := 0;\r
+ for a := 0 to addrlen-1 do begin\r
+ if words[a] = 0 then begin\r
+ c := 0;\r
+ for b := a to addrlen-1 do if words[b] = 0 then begin\r
+ inc(c);\r
+ end else break;\r
+ if (c > runlength) then begin\r
+ runlength := c;\r
+ runbegin := a;\r
+ end;\r
+ end;\r
+ end;\r
+ result := '';\r
+ for a := 0 to runbegin-1 do begin\r
+ if (a <> 0) then result := result + ':';\r
+ result := result + makehex(words[a]);\r
+ end;\r
+ if runlength > 0 then result := result + '::';\r
+ c := runbegin+runlength;\r
+ for a := c to addrlen-1 do begin\r
+ if (a > c) then result := result + ':';\r
+ result := result + makehex(words[a]);\r
+ end;\r
+ if addrlen = 6 then begin\r
+ result := result + ':'+inttostr(bytes[12])+'.'+inttostr(bytes[13])+'.'+inttostr(bytes[14])+'.'+inttostr(bytes[15]);\r
+ end;\r
+end;\r
+\r
+function ip6strtobin(const s:string;var bin:tin6_addr):boolean;\r
+var\r
+ a,b:integer;\r
+ fields:array[0..7] of string;\r
+ fieldcount:integer;\r
+ emptyfield:integer;\r
+ wordcount:integer;\r
+ words:array[0..7] of word;\r
+ bytes:array[0..15] of byte absolute bin;\r
+begin\r
+ result := false;\r
+ for a := 0 to 7 do fields[a] := '';\r
+ fieldcount := 0;\r
+ for a := 1 to length(s) do begin\r
+ if s[a] = ':' then inc(fieldcount) else fields[fieldcount] := fields[fieldcount] + s[a];\r
+ if fieldcount > 7 then exit;\r
+ end;\r
+ if fieldcount < 2 then exit;\r
+\r
+ {find the empty field (compressed zeroes), not counting the first and last there may be at most 1}\r
+ emptyfield := -1;\r
+ for a := 1 to fieldcount-1 do begin\r
+ if fields[a] = '' then begin\r
+ if emptyfield = -1 then emptyfield := a else exit;\r
+ end;\r
+ end;\r
+\r
+ {check if last field is a valid v4 IP}\r
+ a := longip(fields[fieldcount]);\r
+ if (a <> 0) or (fields[fieldcount] = '0.0.0.0') then wordcount := 6 else wordcount := 8;\r
+ {0:1:2:3:4:5:6.6.6.6\r
+ 0:1:2:3:4:5:6:7}\r
+ fillchar(words,sizeof(words),0);\r
+ if wordcount = 6 then begin\r
+ if fieldcount > 6 then exit;\r
+ words[6] := a shr 16;\r
+ words[7] := a and $ffff;\r
+ end;\r
+ if emptyfield = -1 then begin\r
+ {no run length: must be an exact number of fields}\r
+ if wordcount = 6 then begin\r
+ if fieldcount <> 6 then exit;\r
+ emptyfield := 5;\r
+ end else if wordcount = 8 then begin\r
+ if fieldcount <> 7 then exit;\r
+ emptyfield := 7;\r
+ end else exit;\r
+ end;\r
+ for a := 0 to emptyfield do begin\r
+ if fields[a] = '' then b := 0 else b := strtointdef('$'+fields[a],-1);\r
+ if (b < 0) or (b > $ffff) then exit;\r
+ words[a] := b;\r
+ end;\r
+ if wordcount = 6 then dec(fieldcount);\r
+ for a := wordcount-1 downto wordcount-(fieldcount-emptyfield) do begin\r
+ b := a+fieldcount-wordcount+1;\r
+ if fields[b] = '' then b := 0 else b := strtointdef('$'+fields[b],-1);\r
+ if (b < 0) or (b > $ffff) then exit;\r
+ words[a] := b;\r
+ end;\r
+ for a := 0 to 7 do begin\r
+ bytes[a shl 1] := words[a] shr 8;\r
+ bytes[a shl 1 or 1] := words[a] and $ff;\r
+ end;\r
+ result := true;\r
+end;\r
+{$endif}\r
+\r
+function comparebinip(const ip1,ip2:tbinip):boolean;\r
+begin\r
+ if (ip1.ip <> ip2.ip) then begin\r
+ result := false;\r
+ exit;\r
+ end;\r
+\r
+ {$ifdef ipv6}\r
+ if ip1.family = AF_INET6 then begin\r
+ if (ip1.ip6.s6_addr32[1] <> ip2.ip6.s6_addr32[1])\r
+ or (ip1.ip6.s6_addr32[2] <> ip2.ip6.s6_addr32[2])\r
+ or (ip1.ip6.s6_addr32[3] <> ip2.ip6.s6_addr32[3]) then begin\r
+ result := false;\r
+ exit;\r
+ end;\r
+ end;\r
+ {$endif}\r
+\r
+ result := (ip1.family = ip2.family);\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 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
+ end;\r
+ end;\r
+ {$endif}\r
+end;\r
+\r
+end.\r
--- /dev/null
+(*\r
+ * beware IRC services, blinklist.pas\r
+ * Copyright (C) 2002 Bas Steendijk\r
+ *\r
+ * This program is free software; you can redistribute it and/or modify\r
+ * it under the terms of the GNU General Public License as published by\r
+ * the Free Software Foundation; either version 2 of the License, or\r
+ * (at your option) any later version.\r
+ *\r
+ * This program is distributed in the hope that it will be useful,\r
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ * GNU General Public License for more details.\r
+ *\r
+ * You should have received a copy of the GNU General Public License\r
+ * along with this program; if not, write to the Free Software\r
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA\r
+ *)\r
+unit blinklist;\r
+{$ifdef fpc}\r
+ {$mode delphi}\r
+{$endif}\r
+\r
+\r
+interface\r
+\r
+type\r
+ tlinklist=class(tobject)\r
+ next:tlinklist;\r
+ prev:tlinklist;\r
+ constructor create;\r
+ destructor destroy; override;\r
+ end;\r
+\r
+ {linklist with 2 links}\r
+ tlinklist2=class(tlinklist)\r
+ next2:tlinklist2;\r
+ prev2:tlinklist2;\r
+ end;\r
+\r
+ {linklist with one pointer}\r
+ tplinklist=class(tlinklist)\r
+ p:pointer\r
+ end;\r
+\r
+ tstringlinklist=class(tlinklist)\r
+ s:string;\r
+ end;\r
+\r
+ tthing=class(tlinklist)\r
+ name:string; {name/nick}\r
+ hashname:integer; {hash of name}\r
+ end;\r
+\r
+{\r
+adding new block to list (baseptr)\r
+}\r
+procedure linklistadd(var baseptr:tlinklist;newptr:tlinklist);\r
+procedure linklistdel(var baseptr:tlinklist;item:tlinklist);\r
+\r
+\r
+procedure linklist2add(var baseptr,newptr:tlinklist2);\r
+procedure linklist2del(var baseptr:tlinklist2;item:tlinklist2);\r
+\r
+var\r
+ linklistdebug:integer;\r
+\r
+implementation\r
+\r
+procedure linklistadd(var baseptr:tlinklist;newptr:tlinklist);\r
+var\r
+ p:tlinklist;\r
+begin\r
+ p := baseptr;\r
+ baseptr := newptr;\r
+ baseptr.prev := nil;\r
+ baseptr.next := p;\r
+ if p <> nil then p.prev := baseptr;\r
+end;\r
+\r
+procedure linklistdel(var baseptr:tlinklist;item:tlinklist);\r
+begin\r
+ if item = baseptr then baseptr := item.next;\r
+ if item.prev <> nil then item.prev.next := item.next;\r
+ if item.next <> nil then item.next.prev := item.prev;\r
+end;\r
+\r
+procedure linklist2add(var baseptr,newptr:tlinklist2);\r
+var\r
+ p:tlinklist2;\r
+begin\r
+ p := baseptr;\r
+ baseptr := newptr;\r
+ baseptr.prev2 := nil;\r
+ baseptr.next2 := p;\r
+ if p <> nil then p.prev2 := baseptr;\r
+end;\r
+\r
+procedure linklist2del(var baseptr:tlinklist2;item:tlinklist2);\r
+begin\r
+ if item = baseptr then baseptr := item.next2;\r
+ if item.prev2 <> nil then item.prev2.next2 := item.next2;\r
+ if item.next2 <> nil then item.next2.prev2 := item.prev2;\r
+end;\r
+\r
+constructor tlinklist.create;\r
+begin\r
+ inherited create;\r
+ inc(linklistdebug);\r
+end;\r
+\r
+destructor tlinklist.destroy;\r
+begin\r
+ dec(linklistdebug);\r
+ inherited destroy;\r
+end;\r
+\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
+{actually a hashtable. it was a tree in earlier versions}\r
+\r
+unit bsearchtree;\r
+\r
+interface\r
+\r
+uses blinklist;\r
+\r
+const\r
+ hashtable_size=$4000;\r
+\r
+type\r
+ thashitem=class(tlinklist)\r
+ hash:integer;\r
+ s:string;\r
+ p:pointer;\r
+ end;\r
+ thashtable=array[0..hashtable_size-1] of thashitem;\r
+ phashtable=^thashtable;\r
+\r
+{adds "item" to the tree for name "s". the name must not exist (no checking done)}\r
+procedure addtree(t:phashtable;s:string;item:pointer);\r
+\r
+{removes name "s" from the tree. the name must exist (no checking done)}\r
+procedure deltree(t:phashtable;s:string);\r
+\r
+{returns the item pointer for s, or nil if not found}\r
+function findtree(t:phashtable;s:string):pointer;\r
+\r
+implementation\r
+\r
+function makehash(s:string):integer;\r
+const\r
+ shifter=6;\r
+var\r
+ a,b:integer;\r
+begin\r
+ result := 0;\r
+ b := length(s);\r
+ for a := 1 to b do begin\r
+ result := (result shl shifter) xor byte(s[a]);\r
+ end;\r
+ result := (result xor result shr 16) and (hashtable_size-1);\r
+end;\r
+\r
+procedure addtree(t:phashtable;s:string;item:pointer);\r
+var\r
+ hash:integer;\r
+ p:thashitem;\r
+begin\r
+ hash := makehash(s);\r
+ p := thashitem.create;\r
+ p.hash := hash;\r
+ p.s := s;\r
+ p.p := item;\r
+ linklistadd(tlinklist(t[hash]),tlinklist(p));\r
+end;\r
+\r
+procedure deltree(t:phashtable;s:string);\r
+var\r
+ p,p2:thashitem;\r
+ hash:integer;\r
+begin\r
+ hash := makehash(s);\r
+ p := t[hash];\r
+ p2 := nil;\r
+ while p <> nil do begin\r
+ if p.s = s then begin\r
+ p2 := p;\r
+ break;\r
+ end;\r
+ p := thashitem(p.next);\r
+ end;\r
+ linklistdel(tlinklist(t[hash]),tlinklist(p2));\r
+ p2.destroy;\r
+end;\r
+\r
+\r
+function findtree(t:phashtable;s:string):pointer;\r
+var\r
+ p:thashitem;\r
+ hash:integer;\r
+begin\r
+ result := nil;\r
+ hash := makehash(s);\r
+ p := t[hash];\r
+ while p <> nil do begin\r
+ if p.s = s then begin\r
+ result := p.p;\r
+ exit;\r
+ end;\r
+ p := thashitem(p.next);\r
+ end;\r
+end;\r
+\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
+this unit returns unix timestamp with seconds and microseconds (as float)\r
+works on windows/delphi, and on freepascal on unix.\r
+}\r
+\r
+unit btime;\r
+\r
+interface\r
+\r
+type\r
+ float=extended;\r
+\r
+var\r
+ timezone:integer;\r
+ timezonestr:string;\r
+ irctime,unixtime:integer;\r
+ tickcount:integer;\r
+ settimebias:integer;\r
+ qpcjump:float; {can be read out and reset for debug purpose}\r
+ performancecountfreq:extended;\r
+\r
+function irctimefloat:float;\r
+function irctimeint:integer;\r
+\r
+function unixtimefloat:float;\r
+function unixtimeint:integer;\r
+\r
+function wintimefloat:float;\r
+\r
+procedure settime(newtime:integer);\r
+procedure gettimezone;\r
+procedure timehandler;\r
+procedure init;\r
+\r
+function timestring(i:integer):string;\r
+function timestrshort(i:integer):string;\r
+\r
+function oletounixfloat(t:float):float;\r
+function oletounix(t:tdatetime):integer;\r
+function unixtoole(i:integer):tdatetime;\r
+\r
+var\r
+ timefloatbias:float;\r
+ lastunixtimefloat:float=0;\r
+\r
+implementation\r
+\r
+{$ifdef fpc}\r
+ {$mode delphi}\r
+{$endif}\r
+\r
+uses\r
+ {$ifdef UNIX}\r
+ {$ifdef VER1_0}\r
+ linux,\r
+ {$else}\r
+ baseunix,unix,unixutil,{needed for 2.0.2}\r
+ {$endif}\r
+ {$else}\r
+ windows,\r
+ {$endif}\r
+ sysutils;\r
+\r
+ {$include unixstuff.inc}\r
+\r
+\r
+const\r
+ daysdifference=25569;\r
+\r
+function oletounixfloat(t:float):float;\r
+begin\r
+ t := (t - daysdifference) * 86400;\r
+ result := t;\r
+end;\r
+\r
+function oletounix(t:tdatetime):integer;\r
+begin\r
+ result := trunc(oletounixfloat(t));\r
+end;\r
+\r
+function unixtoole(i:integer):tdatetime;\r
+begin\r
+ result := ((i)/86400)+daysdifference;\r
+end;\r
+\r
+{$ifdef unix}\r
+{-----------------------------------------*nix/freepascal code to read time }\r
+\r
+function unixtimefloat:float;\r
+var\r
+ tv:ttimeval;\r
+begin\r
+ gettimeofday(tv);\r
+ result := tv.tv_sec+(tv.tv_usec/1000000);\r
+end;\r
+\r
+function wintimefloat:extended;\r
+begin\r
+ result := unixtimefloat;\r
+end;\r
+\r
+function unixtimeint:integer;\r
+var\r
+ tv:ttimeval;\r
+begin\r
+ gettimeofday(tv);\r
+ result := tv.tv_sec;\r
+end;\r
+\r
+{$else} {delphi 3}\r
+{------------------------------ windows/delphi code to read time}\r
+\r
+{ free pascals tsystemtime is incomaptible with windows api calls\r
+ so we declare it ourselves - plugwash\r
+}\r
+{$ifdef fpc}\r
+type\r
+ TSystemTime = record\r
+ wYear: Word;\r
+ wMonth: Word;\r
+ wDayOfWeek: Word;\r
+ wDay: Word;\r
+ wHour: Word;\r
+ wMinute: Word;\r
+ wSecond: Word;\r
+ wMilliseconds: Word;\r
+ end;\r
+ {$endif}\r
+function Date_utc: extended;\r
+var\r
+ SystemTime: TSystemTime;\r
+begin\r
+ {$ifdef fpc}\r
+ GetsystemTime(@SystemTime);\r
+ {$else}\r
+ GetsystemTime(SystemTime);\r
+ {$endif}\r
+ with SystemTime do Result := EncodeDate(wYear, wMonth, wDay);\r
+end;\r
+\r
+function Time_utc: extended;\r
+var\r
+ SystemTime: TSystemTime;\r
+begin\r
+ {$ifdef fpc}\r
+ GetsystemTime(@SystemTime);\r
+ {$else}\r
+ GetsystemTime(SystemTime);\r
+ {$endif}\r
+ with SystemTime do\r
+ Result := EncodeTime(wHour, wMinute, wSecond, wMilliSeconds);\r
+end;\r
+\r
+function Now_utc: extended;\r
+begin\r
+ Result := round(Date_utc) + Time_utc;\r
+end;\r
+\r
+const\r
+ highdwordconst=4294967296.0;\r
+\r
+function wintimefloat:extended;\r
+var\r
+ p:packed record\r
+ lowpart:longint;\r
+ highpart:longint\r
+ end;\r
+ p2:tlargeinteger absolute p;\r
+ e:extended;\r
+begin\r
+ if performancecountfreq = 0 then begin\r
+ QueryPerformancefrequency(p2);\r
+ e := p.lowpart;\r
+ if e < 0 then e := e + highdwordconst;\r
+ performancecountfreq := ((p.highpart*highdwordconst)+e);\r
+ end;\r
+ queryperformancecounter(p2);\r
+ e := p.lowpart;\r
+ if e < 0 then e := e + highdwordconst;\r
+ result := ((p.highpart*highdwordconst)+e)/performancecountfreq;\r
+end;\r
+\r
+var\r
+ classpriority,threadpriority:integer;\r
+\r
+procedure settc;\r
+var\r
+ hprocess,hthread:integer;\r
+begin\r
+ hProcess := GetCurrentProcess;\r
+ hThread := GetCurrentThread;\r
+\r
+ ClassPriority := GetPriorityClass(hProcess);\r
+ ThreadPriority := GetThreadPriority(hThread);\r
+\r
+ SetPriorityClass(hProcess, REALTIME_PRIORITY_CLASS);\r
+ SetThreadPriority(hThread, THREAD_PRIORITY_TIME_CRITICAL);\r
+end;\r
+\r
+procedure unsettc;\r
+var\r
+ hprocess,hthread:integer;\r
+begin\r
+ hProcess := GetCurrentProcess;\r
+ hThread := GetCurrentThread;\r
+\r
+ SetPriorityClass(hProcess, ClassPriority);\r
+ SetThreadPriority(hThread, ThreadPriority);\r
+end;\r
+\r
+function unixtimefloat:float;\r
+var\r
+ f,g,h:float;\r
+begin\r
+ if timefloatbias = 0 then begin\r
+ settc;\r
+ f := now_utc;\r
+ repeat g := now_utc; h := wintimefloat until g > f;\r
+ timefloatbias := oletounixfloat(g)-h;\r
+ unsettc;\r
+ end;\r
+ result := wintimefloat+timefloatbias;\r
+\r
+ {\r
+ workaround for QPC jumps\r
+ (approach 2: always check "hi res" QPC unixtime against the "guaranteed" systemtime one)\r
+ }\r
+ f := result-(oletounixfloat(now_utc));\r
+ if abs(f) > 0.02 then begin\r
+ f := timefloatbias;\r
+ timefloatbias := 0;\r
+ result := unixtimefloat;\r
+ qpcjump := qpcjump + f - timefloatbias;\r
+ end;\r
+\r
+ if (result <= lastunixtimefloat) then result := lastunixtimefloat + 0.0000001;\r
+ lastunixtimefloat := result;\r
+end;\r
+\r
+function unixtimeint:integer;\r
+begin\r
+ result := trunc(unixtimefloat);\r
+end;\r
+\r
+{$endif}\r
+{-----------------------------------------------end of platform specific}\r
+\r
+function irctimefloat:float;\r
+begin\r
+ result := unixtimefloat+settimebias;\r
+end;\r
+\r
+function irctimeint:integer;\r
+begin\r
+ result := unixtimeint+settimebias;\r
+end;\r
+\r
+\r
+procedure settime(newtime:integer);\r
+var\r
+ a:integer;\r
+begin\r
+ a := irctimeint-settimebias;\r
+ if newtime = 0 then settimebias := 0 else settimebias := newtime-a;\r
+\r
+ irctime := irctimeint;\r
+end;\r
+\r
+procedure timehandler;\r
+begin\r
+ if unixtime = 0 then init;\r
+ unixtime := unixtimeint;\r
+ irctime := irctimeint;\r
+ if unixtime and 63 = 0 then begin\r
+ {update everything, apply timezone changes, clock changes, etc}\r
+ gettimezone;\r
+ timefloatbias := 0;\r
+ unixtime := unixtimeint;\r
+ irctime := irctimeint;\r
+ end;\r
+end;\r
+\r
+\r
+procedure gettimezone;\r
+var\r
+ {$ifdef UNIX}\r
+ {$ifndef ver1_9_4}\r
+ {$ifndef ver1_0}\r
+ {$define above194}\r
+ {$endif}\r
+ {$endif}\r
+ {$ifndef above194}\r
+ hh,mm,ss:word;\r
+ {$endif}\r
+ {$endif}\r
+ l:integer;\r
+begin\r
+ {$ifdef UNIX}\r
+ {$ifdef above194}\r
+ timezone := tzseconds;\r
+ {$else}\r
+ gettime(hh,mm,ss);\r
+ timezone := (longint(hh) * 3600 + mm * 60 + ss) - (unixtimeint mod 86400);\r
+ {$endif}\r
+ {$else}\r
+ timezone := round((now-now_utc)*86400);\r
+ {$endif}\r
+\r
+ while timezone > 43200 do dec(timezone,86400);\r
+ while timezone < -43200 do inc(timezone,86400);\r
+\r
+ if timezone >= 0 then timezonestr := '+' else timezonestr := '-';\r
+ l := abs(timezone) div 60;\r
+ timezonestr := timezonestr + char(l div 600 mod 10+48)+char(l div 60 mod 10+48)+':'+char(l div 10 mod 6+48)+char(l mod 10+48);\r
+end;\r
+\r
+function timestrshort(i:integer):string;\r
+const\r
+ weekday:array[0..6] of string[4]=('Thu','Fri','Sat','Sun','Mon','Tue','Wed');\r
+ month:array[0..11] of string[4]=('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');\r
+var\r
+ y,m,d,h,min,sec,ms:word;\r
+ t:tdatetime;\r
+begin\r
+ t := unixtoole(i+timezone);\r
+ decodedate(t,y,m,d);\r
+ decodetime(t,h,min,sec,ms);\r
+ result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+\r
+ inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10)+' '+\r
+ inttostr(y);\r
+end;\r
+\r
+function timestring(i:integer):string;\r
+const\r
+ weekday:array[0..6] of string[10]=('Thursday','Friday','Saturday','Sunday','Monday','Tuesday','Wednesday');\r
+ month:array[0..11] of string[10]=('January','February','March','April','May','June','July','August','September','October','November','December');\r
+var\r
+ y,m,d,h,min,sec,ms:word;\r
+ t:tdatetime;\r
+begin\r
+ t := unixtoole(i+timezone);\r
+ decodedate(t,y,m,d);\r
+ decodetime(t,h,min,sec,ms);\r
+ result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+inttostr(y)+' -- '+\r
+ inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10)+' '+\r
+ timezonestr;\r
+end;\r
+\r
+procedure init;\r
+begin\r
+ qpcjump := 0;\r
+ settimebias := 0;\r
+ gettimezone;\r
+ unixtime := unixtimeint;\r
+ irctime := irctimeint;\r
+end;\r
+\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
+//FIXME: this code only ever seems to use one dns server for a request and does\r
+//not seem to have any form of retry code.\r
+\r
+unit dnsasync;\r
+\r
+interface\r
+\r
+uses\r
+ {$ifdef win32}\r
+ dnswin,\r
+ {$endif}\r
+ lsocket,lcore,\r
+ classes,binipstuff,dnscore,btime;\r
+\r
+\r
+type\r
+ //after completion or cancelation a dnswinasync may be reused\r
+ tdnsasync=class(tcomponent)\r
+\r
+ private\r
+ //made a load of stuff private that does not appear to be part of the main\r
+ //public interface. If you make any of it public again please consider the\r
+ //consequences when using windows dns. --plugwash.\r
+ sock:twsocket;\r
+\r
+ sockopen:boolean;\r
+\r
+\r
+ state:tdnsstate;\r
+\r
+ dnsserverid:integer;\r
+ startts:double;\r
+ {$ifdef win32}\r
+ dwas : tdnswinasync;\r
+ {$endif}\r
+\r
+\r
+ procedure asyncprocess;\r
+ procedure receivehandler(sender:tobject;error:word);\r
+ function sendquery(const packet:tdnspacket;len:integer):boolean;\r
+ {$ifdef win32}\r
+ procedure winrequestdone(sender:tobject;error:word);\r
+ {$endif}\r
+ public\r
+ onrequestdone:tsocketevent;\r
+\r
+ //addr and port allow the application to specify a dns server specifically\r
+ //for this dnsasync object. This is not a reccomended mode of operation\r
+ //because it limits the app to one dns server but is kept for compatibility\r
+ //and special uses.\r
+ addr,port:string;\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
+\r
+ constructor create(aowner:tcomponent); override;\r
+ destructor destroy; override;\r
+\r
+ end;\r
+\r
+implementation\r
+\r
+uses sysutils;\r
+\r
+constructor tdnsasync.create;\r
+begin\r
+ inherited create(aowner);\r
+ dnsserverid := -1;\r
+ sock := twsocket.create(self);\r
+end;\r
+\r
+destructor tdnsasync.destroy;\r
+begin\r
+ if dnsserverid >= 0 then begin\r
+ reportlag(dnsserverid,-1);\r
+ dnsserverid := -1;\r
+ end;\r
+ sock.release;\r
+ setstate_request_init('',state);\r
+ inherited destroy;\r
+end;\r
+\r
+procedure tdnsasync.receivehandler;\r
+begin\r
+ if dnsserverid >= 0 then begin\r
+ reportlag(dnsserverid,trunc((unixtimefloat-startts)*1000));\r
+ dnsserverid := -1;\r
+ end;\r
+{ writeln('received reply');}\r
+ fillchar(state.recvpacket,sizeof(state.recvpacket),0);\r
+ state.recvpacketlen := twsocket(sender).Receive(@state.recvpacket, SizeOf(state.recvpacket));\r
+ state.parsepacket := true;\r
+ asyncprocess;\r
+end;\r
+\r
+function tdnsasync.sendquery;\r
+begin\r
+{ writeln('sendquery ',decodename(state.packet,state.packetlen,12,0,a),' ',state.requesttype);}\r
+ result := false;\r
+ if len = 0 then exit; {no packet}\r
+ if not sockopen then begin\r
+ if addr <> '' then sock.addr := addr else sock.addr := getcurrentsystemnameserver(dnsserverid);//getunixnameservercached;\r
+ startts := unixtimefloat;\r
+ if port = '' then port := '53';\r
+ sock.port := port;\r
+ sock.Proto := 'udp';\r
+ sock.ondataavailable := receivehandler;\r
+ try\r
+ sock.connect;\r
+ except\r
+ on e:exception do begin\r
+ //writeln('exception '+e.message);\r
+ exit;\r
+ end;\r
+ end;\r
+ sockopen := true;\r
+ end;\r
+ sock.send(@packet,len);\r
+ result := true;\r
+end;\r
+\r
+procedure tdnsasync.asyncprocess;\r
+begin\r
+ state_process(state);\r
+ case state.resultaction of\r
+ action_ignore: begin {do nothing} end;\r
+ action_done: begin\r
+ onrequestdone(self,0);\r
+ end;\r
+ action_sendquery:begin\r
+ sendquery(state.sendpacket,state.sendpacketlen);\r
+ end;\r
+ end;\r
+end;\r
+\r
+procedure tdnsasync.forwardlookup;\r
+begin\r
+\r
+ ipstrtobin(name,state.resultbin);\r
+\r
+ {$ifdef win32}\r
+ if usewindns or (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
+ exit;\r
+ end;\r
+ {$endif}\r
+\r
+\r
+ if state.resultbin.family <> 0 then begin\r
+ onrequestdone(self,0);\r
+ exit;\r
+ end;\r
+\r
+\r
+ setstate_forward(name,state,forwardfamily);\r
+ asyncprocess;\r
+\r
+end;\r
+\r
+procedure tdnsasync.reverselookup;\r
+\r
+begin\r
+ {$ifdef win32}\r
+ if usewindns or (addr = '') then begin\r
+ dwas := tdnswinasync.create;\r
+ dwas.onrequestdone := winrequestdone;\r
+ dwas.reverselookup(binip);\r
+ exit;\r
+ end;\r
+ {$endif}\r
+\r
+ setstate_reverse(binip,state);\r
+ asyncprocess;\r
+end;\r
+\r
+function tdnsasync.dnsresult;\r
+begin\r
+ if state.resultstr <> '' then result := state.resultstr else begin\r
+ result := ipbintostr(state.resultbin);\r
+ end;\r
+end;\r
+\r
+procedure tdnsasync.dnsresultbin(var binip:tbinip);\r
+begin\r
+ move(state.resultbin,binip,sizeof(binip));\r
+end;\r
+\r
+procedure tdnsasync.cancel;\r
+begin\r
+ {$ifdef win32}\r
+ if assigned(dwas) then begin\r
+ dwas.release;\r
+ dwas := nil;\r
+ end else \r
+ {$endif}\r
+ begin\r
+\r
+ if dnsserverid >= 0 then begin\r
+ reportlag(dnsserverid,-1);\r
+ dnsserverid := -1;\r
+ end;\r
+ if sockopen then begin\r
+ sock.close;\r
+ sockopen := false;\r
+ end;\r
+ end;\r
+ setstate_failure(state);\r
+ onrequestdone(self,0);\r
+end;\r
+\r
+{$ifdef win32}\r
+ procedure tdnsasync.winrequestdone(sender:tobject;error:word);\r
+ \r
+ begin\r
+ if dwas.reverse then begin \r
+ state.resultstr := dwas.name;\r
+ end else begin \r
+ state.resultbin := dwas.ip;\r
+ if (forwardfamily = AF_INET6) and (state.resultbin.family = AF_INET) then begin\r
+ fillchar(state.resultbin,sizeof(tbinip),0);\r
+ end;\r
+ end;\r
+ dwas.release;\r
+ onrequestdone(self,error);\r
+ end;\r
+{$endif}\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
+{\r
+\r
+ code wanting to use this dns system should act as follows (note: app\r
+ developers will probablly want to use dnsasync or dnssync or write a similar\r
+ wrapper unit of thier own).\r
+\r
+ for normal lookups call setstate_forward or setstate_reverse to set up the\r
+ state, for more obscure lookups use setstate_request_init and fill in other\r
+ relavent state manually.\r
+\r
+ call state_process which will do processing on the information in the state\r
+ and return an action\r
+ action_ignore means that dnscore wants the code that calls it to go\r
+ back to waiting for packets\r
+ action_sendpacket means that dnscore wants the code that calls it to send\r
+ the packet in sendpacket/sendpacketlen and then start (or go back to) listening\r
+ for\r
+ action_done means the request has completed (either suceeded or failed)\r
+\r
+ callers should resend the last packet they tried to send if they have not\r
+ been asked to send a new packet for more than some timeout value they choose.\r
+\r
+ when a packet is received the application should put the packet in\r
+ recvbuf/recvbuflen , set state.parsepacket and call state_process again\r
+\r
+ once the app gets action_done it can determine sucess or failure in the\r
+ following ways.\r
+\r
+ on failure state.resultstr will be an empty string and state.resultbin will\r
+ be zeroed out (easilly detected by the fact that it will have a family of 0)\r
+\r
+ on success for a A or AAAA lookup state.resultstr will be an empty string\r
+ and state.resultbin will contain the result (note: AAAA lookups require IPV6\r
+ enabled).\r
+\r
+ if an A lookup fails and the code is built with ipv6 enabled then the code\r
+ will return any AAAA records with the same name. The reverse does not apply\r
+ so if an application preffers IPV6 but wants IPV4 results as well it must\r
+ check them seperately.\r
+\r
+ on success for any other type of lookup state.resultstr will be an empty\r
+\r
+ note the state contains ansistrings, setstate_init with a null name parameter\r
+ can be used to clean theese up if required.\r
+\r
+ callers may use setstate_failure to mark the state as failed themseleves\r
+ before passing it on to other code, for example this may be done in the event\r
+ of a timeout.\r
+}\r
+unit dnscore;\r
+\r
+\r
+\r
+{$ifdef fpc}{$mode delphi}{$endif}\r
+\r
+\r
+\r
+\r
+\r
+interface\r
+\r
+uses binipstuff,classes,pgtypes;\r
+\r
+var usewindns : boolean = {$ifdef win32}true{$else}false{$endif};\r
+//hint to users of this unit that they should use windows dns instead.\r
+//May be disabled by applications if desired. (e.g. if setting a custom\r
+//dnsserverlist).\r
+\r
+//note: this unit will not be able to self populate it's dns server list on\r
+//older versions of windows.\r
+\r
+const\r
+ maxnamelength=127;\r
+ maxnamefieldlen=63;\r
+ //note: when using action_ignore the dnscore code *must* preserve the contents of state.sendpacket to allow for retries\r
+ //note: action_ignore must not be used in response to the original request but there is no valid reason for doing this anyway\r
+ action_ignore=0;\r
+ action_done=1;\r
+ action_sendquery=2;\r
+ querytype_a=1;\r
+ querytype_cname=5;\r
+ querytype_aaaa=28;\r
+ querytype_ptr=12;\r
+ querytype_ns=2;\r
+ querytype_soa=6;\r
+ querytype_mx=15;\r
+\r
+ maxrecursion=10;\r
+ maxrrofakind=20;\r
+\r
+ retryafter=300000; //microseconds must be less than one second;\r
+ timeoutlag=1000000000; // penalty value to be treated as lag in the event of a timeout (microseconds)\r
+type\r
+ dvar=array[0..0] of byte;\r
+ pdvar=^dvar;\r
+ tdnspacket=packed record\r
+ id:word;\r
+ flags:word;\r
+ rrcount:array[0..3] of word;\r
+ payload:array[0..511-12] of byte;\r
+ end;\r
+\r
+\r
+\r
+ tdnsstate=record\r
+ id:word;\r
+ recursioncount:integer;\r
+ queryname:string;\r
+ requesttype:word;\r
+ parsepacket:boolean;\r
+ resultstr:string;\r
+ resultbin:tbinip;\r
+ resultaction:integer;\r
+ numrr1:array[0..3] of integer;\r
+ numrr2:integer;\r
+ rrdata:string;\r
+ sendpacketlen:integer;\r
+ sendpacket:tdnspacket;\r
+ recvpacketlen:integer;\r
+ recvpacket:tdnspacket;\r
+ forwardfamily:integer;\r
+ end;\r
+\r
+ trr=packed record\r
+ requesttypehi:byte;\r
+ requesttype:byte;\r
+ clas:word;\r
+ ttl:integer;\r
+ datalen:word;\r
+ data:array[0..511] of byte;\r
+ end;\r
+\r
+ trrpointer=packed record\r
+ p:pointer;\r
+ ofs:integer;\r
+ len:integer;\r
+ namelen:integer;\r
+ end;\r
+\r
+//commenting out functions from interface that do not have documented semantics\r
+//and probablly should not be called from outside this unit, reenable them\r
+//if you must but please document them at the same time --plugwash\r
+\r
+//function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer;\r
+//function makereversename(const binip:tbinip):string;\r
+\r
+procedure setstate_request_init(const name:string;var state:tdnsstate);\r
+\r
+//set up state for a foward lookup. 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
+procedure setstate_forward(const name:string;var state:tdnsstate;family:integer);\r
+\r
+procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);\r
+procedure setstate_failure(var state:tdnsstate);\r
+//procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);\r
+\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
+var\r
+ dnsserverlist : tstringlist;\r
+// currentdnsserverno : integer;\r
+\r
+function getcurrentsystemnameserver(var id:integer) :string;\r
+\r
+//var\r
+// unixnameservercache:string;\r
+{ $endif}\r
+\r
+\r
+procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout\r
+var\r
+ failurereason:string;\r
+\r
+implementation\r
+\r
+uses\r
+ {$ifdef win32}\r
+ windows,\r
+ {$endif}\r
+\r
+ sysutils;\r
+\r
+function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer;\r
+var\r
+ a,b:integer;\r
+ s:string;\r
+ arr:array[0..sizeof(packet)-1] of byte absolute packet;\r
+begin\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.flags := htons($0100);\r
+ packet.rrcount[0] := htons($0001);\r
+\r
+\r
+ s := copy(name,1,maxnamelength);\r
+ if s = '' then exit;\r
+ if s[length(s)] <> '.' then s := s + '.';\r
+ b := 0;\r
+ {encode name}\r
+ if (s = '.') then begin\r
+ packet.payload[0] := 0;\r
+ result := 12+5;\r
+ end else begin\r
+ for a := 1 to length(s) do begin\r
+ if s[a] = '.' then begin\r
+ if b > maxnamefieldlen then exit;\r
+ if (b = 0) then exit;\r
+ packet.payload[a-b-1] := b;\r
+ b := 0;\r
+ end else begin\r
+ packet.payload[a] := byte(s[a]);\r
+ inc(b);\r
+ end;\r
+ end;\r
+ if b > maxnamefieldlen then exit;\r
+ packet.payload[length(s)-b] := b;\r
+ result := length(s) + 12+5;\r
+ end;\r
+\r
+ arr[result-1] := 1;\r
+ arr[result-3] := requesttype and $ff;\r
+ arr[result-4] := requesttype shr 8;\r
+end;\r
+\r
+function makereversename(const binip:tbinip):string;\r
+var\r
+ name:string;\r
+ a,b:integer;\r
+begin\r
+ name := '';\r
+ if binip.family = AF_INET then begin\r
+ b := htonl(binip.ip);\r
+ for a := 0 to 3 do begin\r
+ name := name + inttostr(b shr (a shl 3) and $ff)+'.';\r
+ end;\r
+ name := name + 'in-addr.arpa';\r
+ end else\r
+ {$ifdef ipv6}\r
+ if binip.family = AF_INET6 then begin\r
+ for a := 15 downto 0 do begin\r
+ b := binip.ip6.u6_addr8[a];\r
+ name := name + hexchars[b and $f]+'.'+hexchars[b shr 4]+'.';\r
+ end;\r
+ name := name + 'ip6.arpa';\r
+ end else\r
+ {$endif}\r
+ begin\r
+ {empty name}\r
+ end;\r
+ result := name;\r
+end;\r
+\r
+{\r
+decodes DNS format name to a string. does not includes the root dot.\r
+doesnt read beyond len.\r
+empty result + non null failurereason: failure\r
+empty result + null failurereason: internal use\r
+}\r
+function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):string;\r
+var\r
+ arr:array[0..sizeof(packet)-1] of byte absolute packet;\r
+ s:string;\r
+ a,b:integer;\r
+begin\r
+ numread := 0;\r
+ repeat\r
+ if (start+numread < 0) or (start+numread >= len) then begin\r
+ result := '';\r
+ failurereason := 'decoding name: got out of range1';\r
+ exit;\r
+ end;\r
+ b := arr[start+numread];\r
+ if b >= $c0 then begin\r
+ {recursive sub call}\r
+ if recursion > 10 then begin\r
+ result := '';\r
+ failurereason := 'decoding name: max recursion';\r
+ exit;\r
+ end;\r
+ if ((start+numread+1) >= len) then begin\r
+ result := '';\r
+ failurereason := 'decoding name: got out of range3';\r
+ exit;\r
+ end;\r
+ a := ((b shl 8) or arr[start+numread+1]) and $3fff;\r
+ s := decodename(packet,len,a,recursion+1,a);\r
+ if (s = '') and (failurereason <> '') then begin\r
+ result := '';\r
+ exit;\r
+ end;\r
+ if result <> '' then result := result + '.';\r
+ result := result + s;\r
+ inc(numread,2);\r
+ exit;\r
+ end else if b < 64 then begin\r
+ if (numread <> 0) and (b <> 0) then result := result + '.';\r
+ for a := start+numread+1 to start+numread+b do begin\r
+ if (a >= len) then begin\r
+ result := '';\r
+ failurereason := 'decoding name: got out of range2';\r
+ exit;\r
+ end;\r
+ result := result + char(arr[a]);\r
+ end;\r
+ inc(numread,b+1);\r
+\r
+ if b = 0 then begin\r
+ if (result = '') and (recursion = 0) then result := '.';\r
+ exit; {reached end of name}\r
+ end;\r
+ end else begin\r
+ failurereason := 'decoding name: read invalid char';\r
+ result := '';\r
+ exit; {invalid}\r
+ end;\r
+ until false;\r
+end;\r
+\r
+{==============================================================================}\r
+\r
+procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);\r
+var\r
+ a:integer;\r
+begin\r
+ state.resultaction := action_done;\r
+ state.resultstr := '';\r
+ case trr(rrp.p^).requesttype of\r
+ querytype_a: begin\r
+ if htons(trr(rrp.p^).datalen) <> 4 then exit;\r
+ move(trr(rrp.p^).data,state.resultbin.ip,4);\r
+ state.resultbin.family :=AF_INET;\r
+ end;\r
+ {$ifdef ipv6}\r
+ querytype_aaaa: begin\r
+ if htons(trr(rrp.p^).datalen) <> 16 then exit;\r
+ state.resultbin.family := AF_INET6;\r
+ move(trr(rrp.p^).data,state.resultbin.ip6,16);\r
+ end;\r
+ {$endif}\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
+ fillchar(state.resultbin,sizeof(state.resultbin),0);\r
+ end;\r
+end;\r
+\r
+procedure setstate_request_init(const name:string;var state:tdnsstate);\r
+begin\r
+ {destroy things properly}\r
+ state.resultstr := '';\r
+ state.queryname := '';\r
+ state.rrdata := '';\r
+ fillchar(state,sizeof(state),0);\r
+ state.queryname := name;\r
+ state.parsepacket := false;\r
+end;\r
+\r
+procedure setstate_forward(const name:string;var state:tdnsstate;family:integer);\r
+begin\r
+ setstate_request_init(name,state);\r
+ state.forwardfamily := family;\r
+ {$ifdef ipv6}\r
+ if family = AF_INET6 then state.requesttype := querytype_aaaa else\r
+ {$endif}\r
+ state.requesttype := querytype_a;\r
+end;\r
+\r
+procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);\r
+begin\r
+ setstate_request_init(makereversename(binip),state);\r
+ state.requesttype := querytype_ptr;\r
+end;\r
+\r
+procedure setstate_failure(var state:tdnsstate);\r
+begin\r
+ state.resultstr := '';\r
+ fillchar(state.resultbin,sizeof(state.resultbin),0);\r
+ state.resultaction := action_done;\r
+end;\r
+\r
+procedure state_process(var state:tdnsstate);\r
+label recursed;\r
+label failure;\r
+var\r
+ a,b,ofs:integer;\r
+ rrtemp:^trr;\r
+ rrptemp:^trrpointer;\r
+begin\r
+ if state.parsepacket then begin\r
+ if state.recvpacketlen < 12 then begin\r
+ failurereason := 'Undersized packet';\r
+ state.resultaction := action_ignore;\r
+ exit;\r
+ end;\r
+ if state.id <> state.recvpacket.id then begin\r
+ failurereason := 'ID mismatch';\r
+ state.resultaction := action_ignore;\r
+ exit;\r
+ end;\r
+ state.numrr2 := 0;\r
+ for a := 0 to 3 do begin\r
+ state.numrr1[a] := htons(state.recvpacket.rrcount[a]);\r
+ if state.numrr1[a] > maxrrofakind then goto failure;\r
+ inc(state.numrr2,state.numrr1[a]);\r
+ end;\r
+\r
+ setlength(state.rrdata,state.numrr2*sizeof(trrpointer));\r
+\r
+ {- put all replies into a list}\r
+\r
+ ofs := 12;\r
+ {get all queries}\r
+ for a := 0 to state.numrr1[0]-1 do begin\r
+ if (ofs < 12) or (ofs > state.recvpacketlen-4) then goto failure;\r
+ rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
+ rrptemp.p := @state.recvpacket.payload[ofs-12];\r
+ rrptemp.ofs := ofs;\r
+ decodename(state.recvpacket,state.recvpacketlen,ofs,0,b);\r
+ rrptemp.len := b + 4;\r
+ inc(ofs,rrptemp.len);\r
+ end;\r
+\r
+ for a := state.numrr1[0] to state.numrr2-1 do begin\r
+ if (ofs < 12) or (ofs > state.recvpacketlen-12) then goto failure;\r
+ rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
+ if decodename(state.recvpacket,state.recvpacketlen,ofs,0,b) = '' then goto failure;\r
+ rrtemp := @state.recvpacket.payload[ofs-12+b]; {rrtemp points to values and result, after initial name}\r
+ rrptemp.p := rrtemp;\r
+ rrptemp.ofs := ofs; {ofs is start of RR before initial name from start of packet}\r
+ rrptemp.namelen := b;\r
+ b := htons(rrtemp.datalen);\r
+ rrptemp.len := b + 10 + rrptemp.namelen;\r
+ inc(ofs,rrptemp.len);\r
+ end;\r
+ if (ofs <> state.recvpacketlen) then begin\r
+ failurereason := 'ofs <> state.packetlen';\r
+ goto failure;\r
+ end;\r
+\r
+ {- check for items of the requested type in answer section, if so return success first}\r
+ for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin\r
+ rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
+ rrtemp := rrptemp.p;\r
+ b := rrptemp.len;\r
+ if rrtemp.requesttype = state.requesttype then begin\r
+ setstate_return(rrptemp^,b,state);\r
+ exit;\r
+ end;\r
+ end;\r
+\r
+ {if no items of correct type found, follow first cname in answer section}\r
+ for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin\r
+ rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
+ rrtemp := rrptemp.p;\r
+ b := rrptemp.len;\r
+ if rrtemp.requesttype = querytype_cname then begin\r
+ state.queryname := decodename(state.recvpacket,state.recvpacketlen,rrptemp.ofs+12,0,b);\r
+ goto recursed;\r
+ end;\r
+ end;\r
+\r
+ {no cnames found, no items of correct type found}\r
+ if state.forwardfamily <> 0 then goto failure;\r
+{$ifdef ipv6}\r
+ if (state.requesttype = querytype_a) then begin\r
+ {v6 only: in case of forward, look for AAAA in alternative section}\r
+ for a := state.numrr1[0]+state.numrr1[1]+state.numrr1[2] to (state.numrr2-1) do begin\r
+ rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
+ rrtemp := rrptemp.p;\r
+ b := rrptemp.len;\r
+ if rrtemp.requesttype = querytype_aaaa then begin\r
+ setstate_return(rrptemp^,b,state);\r
+ exit;\r
+ end;\r
+ end;\r
+ {no AAAA's found in alternative, do a recursive lookup for them}\r
+ state.requesttype := querytype_aaaa;\r
+ goto recursed;\r
+ end;\r
+{$endif}\r
+ goto failure;\r
+recursed:\r
+ {here it needs recursed lookup}\r
+ {if needing to follow a cname, change state to do so}\r
+ inc(state.recursioncount);\r
+ if state.recursioncount > maxrecursion then goto failure;\r
+ end;\r
+\r
+ {here, a name needs to be resolved}\r
+ if state.queryname = '' then begin\r
+ failurereason := 'empty query name';\r
+ goto failure;\r
+ end;\r
+\r
+ {do /ets/hosts lookup here}\r
+ state.sendpacketlen := buildrequest(state.queryname,state.sendpacket,state.requesttype);\r
+ if state.sendpacketlen = 0 then begin\r
+ failurereason := 'building request packet failed';\r
+ goto failure;\r
+ end;\r
+ state.id := state.sendpacket.id;\r
+ state.resultaction := action_sendquery;\r
+\r
+ exit;\r
+failure:\r
+ setstate_failure(state);\r
+end;\r
+{$ifdef win32}\r
+ const\r
+ MAX_HOSTNAME_LEN = 132;\r
+ MAX_DOMAIN_NAME_LEN = 132;\r
+ MAX_SCOPE_ID_LEN = 260 ;\r
+ MAX_ADAPTER_NAME_LENGTH = 260;\r
+ MAX_ADAPTER_ADDRESS_LENGTH = 8;\r
+ MAX_ADAPTER_DESCRIPTION_LENGTH = 132;\r
+ ERROR_BUFFER_OVERFLOW = 111;\r
+ MIB_IF_TYPE_ETHERNET = 6;\r
+ MIB_IF_TYPE_TOKENRING = 9;\r
+ MIB_IF_TYPE_FDDI = 15;\r
+ MIB_IF_TYPE_PPP = 23;\r
+ MIB_IF_TYPE_LOOPBACK = 24;\r
+ MIB_IF_TYPE_SLIP = 28;\r
+\r
+\r
+ type\r
+ tip_addr_string=packed record\r
+ Next :pointer;\r
+ IpAddress : array[0..15] of char;\r
+ ipmask : array[0..15] of char;\r
+ context : dword;\r
+ end;\r
+ pip_addr_string=^tip_addr_string;\r
+ tFIXED_INFO=packed record\r
+ HostName : array[0..MAX_HOSTNAME_LEN-1] of char;\r
+ DomainName : array[0..MAX_DOMAIN_NAME_LEN-1] of char;\r
+ currentdnsserver : pip_addr_string;\r
+ dnsserverlist : tip_addr_string;\r
+ nodetype : longint;\r
+ ScopeId : array[0..MAX_SCOPE_ID_LEN + 4] of char;\r
+ enablerouting : longbool;\r
+ enableproxy : longbool;\r
+ enabledns : longbool;\r
+ end;\r
+ pFIXED_INFO=^tFIXED_INFO;\r
+\r
+ var\r
+ iphlpapi : thandle;\r
+ getnetworkparams : function(pFixedInfo : PFIXED_INFO;OutBufLen : plongint) : longint;stdcall;\r
+{$endif}\r
+procedure populatednsserverlist;\r
+var\r
+ {$ifdef win32}\r
+ fixed_info : pfixed_info;\r
+ fixed_info_len : longint;\r
+ currentdnsserver : pip_addr_string;\r
+ {$else}\r
+ t:textfile;\r
+ s:string;\r
+ a:integer;\r
+ {$endif}\r
+begin\r
+ //result := '';\r
+ if assigned(dnsserverlist) then begin\r
+ dnsserverlist.clear;\r
+ end else begin\r
+ dnsserverlist := tstringlist.Create;\r
+ end;\r
+ {$ifdef win32}\r
+ if iphlpapi=0 then iphlpapi := loadlibrary('iphlpapi.dll');\r
+ if not assigned(getnetworkparams) then @getnetworkparams := getprocaddress(iphlpapi,'GetNetworkParams');\r
+ fixed_info_len := 0;\r
+ if GetNetworkParams(nil,@fixed_info_len)<>ERROR_BUFFER_OVERFLOW then exit;\r
+ //fixed_info_len :=sizeof(tfixed_info);\r
+ getmem(fixed_info,fixed_info_len);\r
+ if GetNetworkParams(fixed_info,@fixed_info_len)<>0 then begin\r
+ freemem(fixed_info);\r
+ exit;\r
+ end;\r
+ currentdnsserver := @(fixed_info.dnsserverlist);\r
+ while assigned(currentdnsserver) do begin\r
+ dnsserverlist.Add(currentdnsserver.IpAddress);\r
+ currentdnsserver := currentdnsserver.next;\r
+ end;\r
+ freemem(fixed_info);\r
+ {$else}\r
+ filemode := 0;\r
+ assignfile(t,'/etc/resolv.conf');\r
+ {$i-}reset(t);{$i+}\r
+ if ioresult <> 0 then exit;\r
+\r
+ while not eof(t) do begin\r
+ readln(t,s);\r
+ if not (copy(s,1,10) = 'nameserver') then continue;\r
+ s := copy(s,11,500);\r
+ while s <> '' do begin\r
+ if (s[1] = #32) or (s[1] = #9) then s := copy(s,2,500) else break;\r
+ end;\r
+ a := pos(' ',s);\r
+ if a <> 0 then s := copy(s,1,a-1);\r
+ a := pos(#9,s);\r
+ if a <> 0 then s := copy(s,1,a-1);\r
+ //result := s;\r
+ //if result <> '' then break;\r
+ dnsserverlist.Add(s);\r
+ end;\r
+ close(t);\r
+ {$endif}\r
+end;\r
+\r
+procedure cleardnsservercache;\r
+begin\r
+ if assigned(dnsserverlist) then begin\r
+ dnsserverlist.destroy;\r
+ dnsserverlist := nil;\r
+ end;\r
+end;\r
+\r
+function getcurrentsystemnameserver(var id:integer):string;\r
+var \r
+ counter : integer;\r
+\r
+begin\r
+ if not assigned(dnsserverlist) then populatednsserverlist;\r
+ if dnsserverlist.count=0 then raise exception.create('no dns servers availible');\r
+ id := 0;\r
+ if dnsserverlist.count >1 then begin\r
+\r
+ for counter := 1 to dnsserverlist.count-1 do begin\r
+ if taddrint(dnsserverlist.objects[counter]) < taddrint(dnsserverlist.objects[id]) then id := counter;\r
+ end;\r
+ end;\r
+ result := dnsserverlist[id]\r
+end;\r
+\r
+procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout\r
+var\r
+ counter : integer;\r
+ temp : integer;\r
+begin\r
+ if (id < 0) or (id >= dnsserverlist.count) then exit;\r
+ if lag = -1 then lag := timeoutlag;\r
+ for counter := 0 to dnsserverlist.count-1 do begin\r
+ temp := taddrint(dnsserverlist.objects[counter]) *15;\r
+ if counter=id then temp := temp + lag;\r
+ dnsserverlist.objects[counter] := tobject(temp div 16);\r
+ end;\r
+\r
+end;\r
+\r
+{ quick and dirty description of dns packet structure to aid writing and\r
+ understanding of parser code, refer to appropriate RFCs for proper specs\r
+- all words are network order\r
+\r
+www.google.com A request:\r
+\r
+0, 2: random transaction ID\r
+2, 2: flags: only the "recursion desired" bit set. (bit 8 of word)\r
+4, 2: questions: 1\r
+6, 2: answer RR's: 0.\r
+8, 2: authority RR's: 0.\r
+10, 2: additional RR's: 0.\r
+12, n: payload:\r
+ query:\r
+ #03 "www" #06 "google" #03 "com" #00\r
+ size-4, 2: type: host address (1)\r
+ size-2, 2: class: inet (1)\r
+\r
+reply:\r
+\r
+0,2: random transaction ID\r
+2,2: flags: set: response (bit 15), recursion desired (8), recursion available (7)\r
+4,4: questions: 1\r
+6,4: answer RR's: 2\r
+8,4: authority RR's: 9\r
+10,4: additional RR's: 9\r
+12: payload:\r
+ query:\r
+ ....\r
+ answer: CNAME\r
+ 0,2 "c0 0c" "name: www.google.com"\r
+ 2,2 "00 05" "type: cname for an alias"\r
+ 4,2 "00 01" "class: inet"\r
+ 6,4: TTL\r
+ 10,2: data length "00 17" (23)\r
+ 12: the cname name (www.google.akadns.net)\r
+ answer: A\r
+ 0,2 ..\r
+ 2,2 "00 01" host address\r
+ 4,2 ...\r
+ 6,4 ...\r
+ 10,2: data length (4)\r
+ 12,4: binary IP\r
+ authority - 9 records\r
+ additional - 9 records\r
+\r
+\r
+ ipv6 AAAA reply:\r
+ 0,2: ...\r
+ 2,2: type: 001c\r
+ 4,2: class: inet (0001)\r
+ 6,2: TTL\r
+ 10,2: data size (16)\r
+ 12,16: binary IP\r
+\r
+ ptr request: query type 000c\r
+\r
+name compression: word "cxxx" in the name, xxx points to offset in the packet}\r
+\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
+unit dnssync;\r
+{$ifdef fpc}\r
+ {$mode delphi}\r
+{$endif}\r
+\r
+interface\r
+ uses\r
+ dnscore,\r
+ binipstuff,\r
+ {$ifdef win32}\r
+ winsock,\r
+ windows,\r
+ {$else}\r
+ {$ifdef VER1_0}\r
+ linux,\r
+ {$else}\r
+ baseunix,unix,unixutil,\r
+ {$endif}\r
+ sockets,\r
+ fd_utils,\r
+ {$endif}\r
+ sysutils;\r
+\r
+//convert a name to an IP\r
+//IPV4 is preffered if availible, if not IPV6 will be returned (if ipv6 support\r
+//compiled in)\r
+//on error the binip will have a family of 0 (other fiels are also currently\r
+//zeroed out but may be used for further error information in future)\r
+//timeout is in seconds, it is ignored when using windows dns\r
+function forwardlookup(name:string;timeout:integer):tbinip;\r
+\r
+\r
+//convert an IP to a name, on error a null string will be returned, other \r
+//details as above\r
+function reverselookup(ip:tbinip;timeout:integer):string;\r
+\r
+\r
+var\r
+ dnssyncserver:string;\r
+ id : integer;\r
+ {$ifdef win32}\r
+ sendquerytime : integer;\r
+ {$else}\r
+ sendquerytime : ttimeval;\r
+ {$endif}\r
+implementation\r
+{$ifdef win32}\r
+ uses dnswin;\r
+{$endif}\r
+\r
+{$i unixstuff.inc}\r
+{$i ltimevalstuff.inc}\r
+\r
+var\r
+ fd:integer;\r
+ state:tdnsstate;\r
+{$ifdef win32}\r
+ const\r
+ winsocket = 'wsock32.dll';\r
+ function sendto(s: TSocket; const Buf; len, flags: Integer; var addrto: TinetSockAddr; tolen: Integer): Integer; stdcall; external winsocket name 'sendto';\r
+ function bind(s: TSocket; var addr: TinetSockAddr; namelen: Integer): Longbool; stdcall; external winsocket name 'bind';\r
+ type\r
+ fdset=tfdset;\r
+{$endif}\r
+\r
+function sendquery(const packet:tdnspacket;len:integer):boolean;\r
+var\r
+ a:integer;\r
+ addr : string;\r
+ port : string;\r
+ inaddr : TInetSockAddr;\r
+\r
+begin\r
+{ writeln('sendquery ',decodename(state.packet,state.packetlen,12,0,a),' ',state.requesttype);}\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
+\r
+ inAddr.family:=AF_INET;\r
+ inAddr.port:=htons(strtointdef(port,0));\r
+ inAddr.addr:=htonl(longip(addr));\r
+\r
+ sendto(fd,packet,len,0,inaddr,sizeof(inaddr));\r
+ {$ifdef win32}\r
+ sendquerytime := GetTickCount and $3fff;\r
+ {$else}\r
+ gettimeofday(sendquerytime);\r
+ {$endif}\r
+ result := true;\r
+end;\r
+\r
+procedure setupsocket;\r
+var\r
+ inAddrtemp : TInetSockAddr;\r
+begin\r
+ if fd > 0 then exit;\r
+\r
+ fd := Socket(AF_INET,SOCK_DGRAM,0);\r
+ inAddrtemp.family:=AF_INET;\r
+ inAddrtemp.port:=0;\r
+ inAddrtemp.addr:=0;{htonl(longip('0.0.0.0'));}\r
+ If {$ifndef win32}Not{$endif} Bind(fd,inAddrtemp,SizeOf(inAddrtemp)) Then begin\r
+ {$ifdef win32}\r
+ raise Exception.create('unable to bind '+inttostr(WSAGetLastError));\r
+ {$else}\r
+ raise Exception.create('unable to bind '+inttostr(socketError));\r
+ {$endif}\r
+ end;\r
+end;\r
+\r
+procedure resolveloop(timeout:integer);\r
+var\r
+ selectresult : integer;\r
+ fds : fdset;\r
+ {$ifdef win32}\r
+ endtime : longint;\r
+ starttime : longint;\r
+ wrapmode : boolean;\r
+ currenttime : integer;\r
+ {$else}\r
+ endtime : ttimeval;\r
+ currenttime : ttimeval;\r
+\r
+ {$endif}\r
+ lag : ttimeval;\r
+ currenttimeout : ttimeval;\r
+ selecttimeout : ttimeval;\r
+\r
+\r
+begin\r
+ {$ifdef win32}\r
+ starttime := GetTickCount and $3fff;\r
+ endtime := starttime +(timeout*1000);\r
+ if (endtime and $4000)=0 then begin\r
+ wrapmode := false;\r
+ end else begin\r
+ wrapmode := true;\r
+ end;\r
+ endtime := endtime and $3fff;\r
+ {$else}\r
+ gettimeofday(endtime);\r
+ endtime.tv_sec := endtime.tv_sec + timeout;\r
+ {$endif}\r
+\r
+ setupsocket;\r
+ repeat\r
+ state_process(state);\r
+ case state.resultaction of\r
+ action_ignore: begin\r
+{ writeln('ignore');}\r
+ {do nothing}\r
+ end;\r
+ action_done: begin\r
+{ writeln('done');}\r
+ exit;\r
+ //onrequestdone(self,0);\r
+ end;\r
+ action_sendquery:begin\r
+{ writeln('send query');}\r
+ sendquery(state.sendpacket,state.sendpacketlen);\r
+ end;\r
+ end;\r
+ {$ifdef win32}\r
+ currenttime := GetTickCount and $3fff;\r
+ msectotimeval(selecttimeout, (endtime-currenttime)and$3fff);\r
+ {$else}\r
+ gettimeofday(currenttime);\r
+ selecttimeout := endtime;\r
+ tv_substract(selecttimeout,currenttime);\r
+ {$endif}\r
+ fd_zero(fds);\r
+ fd_set(fd,fds);\r
+ if (selecttimeout.tv_sec > 0) or (selecttimeout.tv_usec > retryafter) then begin\r
+ selecttimeout.tv_sec := 0;\r
+ selecttimeout.tv_usec := retryafter;\r
+ end;\r
+ selectresult := select(fd+1,@fds,nil,nil,@selecttimeout);\r
+ if selectresult > 0 then begin\r
+{ writeln('selectresult>0');}\r
+ //why the hell are we zeroing out the packet buffer before reading into it?! --plugwash\r
+ fillchar(state.recvpacket,sizeof(state.recvpacket),0);\r
+ {$ifdef win32}\r
+ msectotimeval(lag,(currenttime-sendquerytime)and$3fff);\r
+ {$else}\r
+ lag := currenttime;\r
+ tv_substract(lag,sendquerytime);\r
+\r
+ {$endif}\r
+\r
+ reportlag(id,(lag.tv_sec*1000000)+lag.tv_usec);\r
+ state.recvpacketlen := recv(fd,state.recvpacket, SizeOf(state.recvpacket),0);\r
+ state.parsepacket := true;\r
+ end;\r
+ if selectresult < 0 then exit;\r
+ if selectresult = 0 then begin\r
+ {$ifdef win32}\r
+ currenttime := GetTickCount;\r
+ {$else}\r
+ gettimeofday(currenttime);\r
+ {$endif}\r
+ reportlag(id,-1);\r
+ if {$ifdef win32}(currenttime >= endtime)and ((not wrapmode) or (currenttime < starttime)) {$else}tv_compare(currenttime,endtime){$endif} {currenttime >= endtime } then begin\r
+ exit;\r
+ end else begin\r
+ //resend\r
+ sendquery(state.sendpacket,state.sendpacketlen);\r
+ end;\r
+ end;\r
+ until false;\r
+end;\r
+\r
+function forwardlookup(name:string;timeout:integer):tbinip;\r
+var\r
+ dummy : integer;\r
+begin\r
+ ipstrtobin(name,result);\r
+ if result.family <> 0 then exit; //it was an IP address, no need for dns\r
+ //lookup\r
+ {$ifdef win32}\r
+ if usewindns then begin\r
+ result := winforwardlookup(name,false,dummy);\r
+ exit;\r
+ end;\r
+ {$endif}\r
+ setstate_forward(name,state,0);\r
+ resolveloop(timeout);\r
+ result := state.resultbin;\r
+end;\r
+\r
+function reverselookup(ip:tbinip;timeout:integer):string;\r
+var\r
+ dummy : integer;\r
+begin\r
+ {$ifdef win32}\r
+ if usewindns then begin\r
+ result := winreverselookup(ip,dummy);\r
+ exit;\r
+ end;\r
+ {$endif}\r
+ setstate_reverse(ip,state);\r
+ resolveloop(timeout);\r
+ result := state.resultstr;\r
+end;\r
+\r
+{$ifdef win32}\r
+ var\r
+ wsadata : twsadata;\r
+\r
+ initialization\r
+ WSAStartUp($2,wsadata);\r
+ finalization\r
+ WSACleanUp;\r
+{$endif}\r
+end.\r
+\r
+\r
--- /dev/null
+unit dnswin;\r
+\r
+interface\r
+uses binipstuff,classes,lcore;\r
+\r
+//on failure a null string or zeroed out binip will be retuned and error will be\r
+//set to a windows error code (error will be left untouched under non error\r
+//conditions).\r
+function winforwardlookup(name : string;ipv6preffered : boolean;var error:integer) : tbinip;\r
+function winreverselookup(ip:tbinip;var error:integer):string;\r
+\r
+\r
+type\r
+ //do not call destroy on a tdnswinasync instead call release and the\r
+ //dnswinasync will be freed when appropriate. Calling destroy will block\r
+ //the calling thread until the dns lookup completes.\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
+ hadevent : boolean;\r
+ protected\r
+ procedure execute; override;\r
+ public\r
+ onrequestdone:tsocketevent;\r
+ name : string;\r
+ ip : tbinip;\r
+\r
+ procedure forwardlookup(name:string;ipv6preffered:boolean);\r
+ procedure reverselookup(ip:tbinip);\r
+ destructor destroy; override;\r
+ procedure release;\r
+ constructor create;\r
+ property reverse : boolean read freverse;\r
+\r
+ end;\r
+\r
+implementation\r
+uses\r
+ lsocket,pgtypes,sysutils,winsock,windows,messages;\r
+\r
+type\r
+ //taddrinfo = record; //forward declaration\r
+ paddrinfo = ^taddrinfo;\r
+ taddrinfo = packed record\r
+ ai_flags : longint;\r
+ ai_family : longint;\r
+ ai_socktype : longint;\r
+ ai_protocol : longint;\r
+ ai_addrlen : taddrint;\r
+ ai_canonname : pchar;\r
+ ai_addr : pinetsockaddrv;\r
+ ai_next : paddrinfo;\r
+ end;\r
+ ppaddrinfo = ^paddrinfo;\r
+ tgetaddrinfo = function(nodename : pchar; servname : pchar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall;\r
+ tfreeaddrinfo = procedure(ai : paddrinfo); stdcall;\r
+ tgetnameinfo = function(sa:Pinetsockaddrv;salen : longint; host:pchar;hostlen : longint;serv:pchar;servlen:longint;flags:longint) : longint;stdcall;\r
+var\r
+ getaddrinfo : tgetaddrinfo;\r
+ freeaddrinfo : tfreeaddrinfo;\r
+ getnameinfo : tgetnameinfo;\r
+procedure v4onlyfreeaddrinfo(ai : paddrinfo); stdcall;\r
+begin\r
+ freemem(ai.ai_addr);\r
+ freemem(ai);\r
+end;\r
+\r
+type\r
+ plongint = ^longint;\r
+ pplongint = ^plongint;\r
+\r
+function v4onlygetaddrinfo(nodename : pchar; servname : pchar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall;\r
+var\r
+ output : paddrinfo;\r
+ hostent : phostent;\r
+begin\r
+ if hints.ai_family = af_inet then begin\r
+ result := 0;\r
+ getmem(output,sizeof(taddrinfo));\r
+ getmem(output.ai_addr,sizeof(tinetsockaddr));\r
+ output.ai_addr.InAddr.family := af_inet;\r
+ if servname <> nil then output.ai_addr.InAddr.port := htons(strtoint(servname)) else output.ai_addr.InAddr.port := 0;\r
+ hostent := gethostbyname(nodename);\r
+ if hostent = nil then begin\r
+ result := wsagetlasterror;\r
+ v4onlyfreeaddrinfo(output);\r
+ exit;\r
+ end;\r
+ output.ai_addr.InAddr.addr := pplongint(hostent.h_addr_list)^^;\r
+ output.ai_flags := 0;\r
+ output.ai_family := af_inet;\r
+ output.ai_socktype := 0;\r
+ output.ai_protocol := 0;\r
+ output.ai_addrlen := sizeof(tinetsockaddr);\r
+ output.ai_canonname := nil;\r
+ output.ai_next := nil;\r
+\r
+ res^ := output;\r
+ end else begin\r
+ result := WSANO_RECOVERY;\r
+ end;\r
+end;\r
+\r
+function min(a,b : integer):integer;\r
+begin\r
+ if a<b then result := a else result := b;\r
+end;\r
+\r
+function v4onlygetnameinfo(sa:Pinetsockaddrv;salen : longint; host:pchar;hostlen : longint;serv:pchar;servlen:longint;flags:longint) : longint;stdcall;\r
+var\r
+ hostent : phostent;\r
+ bytestocopy : integer;\r
+begin\r
+ if sa.InAddr.family = af_inet then begin\r
+ result := 0;\r
+ hostent := gethostbyaddr(@(sa.inaddr.addr),4,AF_INET);\r
+ if hostent = nil then begin\r
+ result := wsagetlasterror;\r
+ exit;\r
+ end;\r
+ bytestocopy := min(strlen(hostent.h_name)+1,hostlen);\r
+ move((hostent.h_name)^,host^,bytestocopy);\r
+\r
+\r
+ end else begin\r
+ result := WSANO_RECOVERY;\r
+ end;\r
+end;\r
+\r
+\r
+procedure populateprocvars;\r
+var\r
+ libraryhandle : hmodule;\r
+ i : integer;\r
+ dllname : string;\r
+\r
+begin\r
+ if assigned(getaddrinfo) then exit; //procvars already populated\r
+ for i := 0 to 1 do begin\r
+ if i=0 then dllname := 'Ws2_32.dll' else dllname := 'Wship6.dll';\r
+ libraryhandle := LoadLibrary(pchar(dllname));\r
+ getaddrinfo := getprocaddress(libraryhandle,'getaddrinfo');\r
+ freeaddrinfo := getprocaddress(libraryhandle,'freeaddrinfo');\r
+ getnameinfo := getprocaddress(libraryhandle,'getnameinfo');\r
+ if assigned(getaddrinfo) and assigned(freeaddrinfo) and assigned(getnameinfo) then begin\r
+ //writeln('found getaddrinfo and freeaddrinfo in'+dllname);\r
+ exit; //success\r
+ end;\r
+\r
+ end;\r
+ //writeln('could not find getaddrinfo and freeaddrinfo, falling back to ipv4 only lookup');\r
+ getaddrinfo := v4onlygetaddrinfo;\r
+ freeaddrinfo := v4onlyfreeaddrinfo;\r
+ getnameinfo := v4onlygetnameinfo;\r
+end;\r
+\r
+\r
+function winforwardlookup(name : string;ipv6preffered : boolean;var error : integer) : tbinip;\r
+var\r
+ hints: taddrinfo;\r
+ res : paddrinfo;\r
+ pass : boolean;\r
+ ipv6 : boolean;\r
+ getaddrinforesult : integer;\r
+begin\r
+ populateprocvars;\r
+\r
+ for pass := false to true do begin\r
+ ipv6 := ipv6preffered xor pass;\r
+ hints.ai_flags := 0;\r
+ if ipv6 then begin\r
+ hints.ai_family := AF_INET6;\r
+ end else begin\r
+ hints.ai_family := AF_INET;\r
+ end;\r
+ hints.ai_socktype := 0;\r
+ hints.ai_protocol := 0;\r
+ hints.ai_addrlen := 0;\r
+ hints.ai_canonname := nil;\r
+ hints.ai_addr := nil;\r
+ hints.ai_next := nil;\r
+ getaddrinforesult := getaddrinfo(pchar(name),'1',@hints,@res);\r
+ if getaddrinforesult = 0 then begin\r
+ if res.ai_family = af_inet then begin\r
+ result.family := af_inet;\r
+ result.ip := res.ai_addr.InAddr.addr;\r
+ end else {$ifdef ipv6}if res.ai_family = af_inet6 then begin\r
+ result.family := af_inet6;\r
+ result.ip6 := res.ai_addr.InAddr6.sin6_addr;\r
+ end;{$endif};\r
+\r
+ freeaddrinfo(res);\r
+ exit;\r
+ end;\r
+ end;\r
+ if getaddrinforesult <> 0 then begin\r
+ fillchar(result,0,sizeof(result));\r
+ error := getaddrinforesult;\r
+ end;\r
+end;\r
+\r
+function winreverselookup(ip:tbinip;var error : integer):string;\r
+var\r
+ sa : tinetsockaddrv;\r
+ getnameinforesult : integer;\r
+begin\r
+\r
+ if ip.family = AF_INET then begin\r
+ sa.InAddr.family := AF_INET;\r
+ sa.InAddr.port := 1;\r
+ sa.InAddr.addr := ip.ip;\r
+ end else {$ifdef ipv6}if ip.family = AF_INET6 then begin\r
+ sa.InAddr6.sin6_family := AF_INET6;\r
+ sa.InAddr6.sin6_port := 1;\r
+ sa.InAddr6.sin6_addr := ip.ip6;\r
+ end else{$endif} begin\r
+ raise exception.create('unrecognised address family');\r
+ end;\r
+ populateprocvars;\r
+ setlength(result,1025);\r
+ getnameinforesult := getnameinfo(@sa,sizeof(tinetsockaddrv),pchar(result),length(result),nil,0,0);\r
+ if getnameinforesult <> 0 then begin\r
+ error := getnameinforesult;\r
+ result := '';\r
+ exit;\r
+ end;\r
+ if pos(#0,result) >= 0 then begin\r
+ setlength(result,pos(#0,result)-1);\r
+ end;\r
+end;\r
+\r
+var\r
+ hwnddnswin : hwnd;\r
+\r
+function MyWindowProc(\r
+ ahWnd : HWND;\r
+ auMsg : Integer;\r
+ awParam : WPARAM;\r
+ alParam : LPARAM): Integer; stdcall;\r
+var\r
+ dwas : tdnswinasync;\r
+begin\r
+ if (ahwnd=hwnddnswin) and (aumsg=wm_user) then begin\r
+ Dwas := tdnswinasync(alparam);\r
+ if assigned (dwas.onrequestdone) then dwas.onrequestdone(dwas,awparam);\r
+ dwas.hadevent := true;\r
+ if dwas.freewhendone then dwas.free;\r
+ end else begin\r
+ //not passing unknown messages on to defwindowproc will cause window\r
+ //creation to fail! --plugwash\r
+ Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)\r
+ end;\r
+end;\r
+\r
+procedure tdnswinasync.forwardlookup(name:string;ipv6preffered:boolean);\r
+begin\r
+ self.name := name;\r
+ self.ipv6preffered := ipv6preffered;\r
+ freverse := false;\r
+ resume;\r
+end;\r
+procedure tdnswinasync.reverselookup(ip:tbinip);\r
+begin\r
+ self.ip := ip;\r
+ freverse := true;\r
+ resume;\r
+end;\r
+procedure tdnswinasync.execute;\r
+var\r
+ error : integer;\r
+begin\r
+ error := 0;\r
+ if reverse then begin\r
+ name := winreverselookup(ip,error);\r
+ end else begin\r
+ ip := winforwardlookup(name,ipv6preffered,error);\r
+\r
+ end;\r
+\r
+ postmessage(hwnddnswin,wm_user,error,taddrint(self));\r
+end;\r
+\r
+destructor tdnswinasync.destroy; \r
+begin\r
+ WaitFor;\r
+ inherited destroy;\r
+end;\r
+procedure tdnswinasync.release;\r
+begin\r
+ if hadevent then destroy else begin\r
+ onrequestdone := nil;\r
+ freewhendone := true;\r
+ end;\r
+end;\r
+\r
+constructor tdnswinasync.create;\r
+begin\r
+ inherited create(true);\r
+end;\r
+\r
+var\r
+ MyWindowClass : TWndClass = (style : 0;\r
+ lpfnWndProc : @MyWindowProc;\r
+ cbClsExtra : 0;\r
+ cbWndExtra : 0;\r
+ hInstance : 0;\r
+ hIcon : 0;\r
+ hCursor : 0;\r
+ hbrBackground : 0;\r
+ lpszMenuName : nil;\r
+ lpszClassName : 'dnswinClass');\r
+begin\r
+\r
+ if Windows.RegisterClass(MyWindowClass) = 0 then halt;\r
+ //writeln('about to create lcore handle, hinstance=',hinstance);\r
+ hwnddnswin := CreateWindowEx(WS_EX_TOOLWINDOW,\r
+ MyWindowClass.lpszClassName,\r
+ '', { Window name }\r
+ WS_POPUP, { Window Style }\r
+ 0, 0, { X, Y }\r
+ 0, 0, { Width, Height }\r
+ 0, { hWndParent }\r
+ 0, { hMenu }\r
+ HInstance, { hInstance }\r
+ nil); { CreateParam }\r
+ //writeln('dnswin hwnd is ',hwnddnswin);\r
+ //writeln('last error is ',GetLastError);\r
+end.\r
--- /dev/null
+// this file contains code copied from linux.pp in the free pascal rtl\r
+// i had to copy them because i use a different definition of fdset to them\r
+// the copyright block from the file in question is shown below\r
+{\r
+ $Id: fd_utils.pas,v 1.2 2004/08/19 23:12:09 plugwash Exp $\r
+ This file is part of the Free Pascal run time library.\r
+ Copyright (c) 1999-2000 by Michael Van Canneyt,\r
+ BSD parts (c) 2000 by Marco van de Voort\r
+ members of the Free Pascal development team.\r
+\r
+ See the file COPYING.FPC, included in this distribution,\r
+ for details about the copyright.\r
+\r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY;without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\r
+\r
+**********************************************************************}\r
+{$ifdef fpc}\r
+ {$mode delphi}\r
+ {$inlining on}\r
+{$endif}\r
+unit fd_utils;\r
+interface\r
+\r
+type\r
+ FDSet= Array [0..255] of longint; {31}\r
+ PFDSet= ^FDSet;\r
+const\r
+ absoloutemaxs=(sizeof(fdset)*8)-1;\r
+\r
+Procedure FD_Clr(fd:longint;var fds:fdSet);\r
+Procedure FD_Zero(var fds:fdSet);\r
+Procedure FD_Set(fd:longint;var fds:fdSet);\r
+Function FD_IsSet(fd:longint;var fds:fdSet):boolean;\r
+
+{$ifdef fpc}
+ {$ifndef ver1_0}
+ {$define useinline}
+ {$endif}
+{$endif}\r
+\r
+implementation \r
+uses sysutils;\r
+Procedure FD_Clr(fd:longint;var fds:fdSet);{$ifdef useinline}inline;{$endif}\r
+{ Remove fd from the set of filedescriptors}\r
+begin\r
+ if (fd < 0) then raise exception.create('FD_Clr fd out of range: '+inttostr(fd));\r
+ fds[fd shr 5]:=fds[fd shr 5] and (not (1 shl (fd and 31)));\r
+end;\r
+\r
+Procedure FD_Zero(var fds:fdSet);\r
+{ Clear the set of filedescriptors }\r
+begin\r
+ FillChar(fds,sizeof(fdSet),0);\r
+end;\r
+\r
+Procedure FD_Set(fd:longint;var fds:fdSet);{$ifdef useinline}inline;{$endif}\r
+{ Add fd to the set of filedescriptors }\r
+begin\r
+ if (fd < 0) then raise exception.create('FD_set fd out of range: '+inttostr(fd));\r
+ fds[fd shr 5]:=fds[fd shr 5] or (1 shl (fd and 31));\r
+end;\r
+\r
+Function FD_IsSet(fd:longint;var fds:fdSet):boolean;{$ifdef useinline}inline;{$endif}\r
+{ Test if fd is part of the set of filedescriptors }\r
+begin\r
+ if (fd < 0) then begin\r
+ result := false;\r
+ exit;\r
+ end;\r
+ FD_IsSet:=((fds[fd shr 5] and (1 shl (fd and 31)))<>0);\r
+end;\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
+unit bfifo;\r
+{$ifdef fpc}\r
+ {$mode delphi}\r
+{$endif}\r
+\r
+interface\r
+\r
+uses blinklist,pgtypes;\r
+\r
+const\r
+ pagesize=1420;\r
+\r
+type\r
+ tfifo=class(tobject)\r
+ private\r
+ l:tlinklist; {add to}\r
+ getl:tlinklist; {remove from}\r
+ ofs:integer;\r
+ getofs:integer;\r
+ public\r
+ size:integer;\r
+ procedure add(data:pointer;len:integer);\r
+ function get(var resultptr:pointer;len:integer):integer;\r
+ procedure del(len:integer);\r
+ constructor create;\r
+ destructor destroy; override;\r
+ end;\r
+\r
+\r
+implementation\r
+\r
+var\r
+ testcount:integer;\r
+\r
+{\r
+\r
+xx1..... add\r
+xxxxxxxx\r
+....2xxx delete\r
+\r
+1 ofs\r
+2 getofs\r
+\r
+}\r
+\r
+procedure tfifo.add;\r
+var\r
+ a:integer;\r
+ p:tlinklist;\r
+begin\r
+ if len <= 0 then exit;\r
+ inc(size,len);\r
+ while len > 0 do begin\r
+ p := l;\r
+ if ofs = pagesize then begin\r
+ p := tplinklist.create;\r
+ if getl = nil then getl := p;\r
+ getmem(tplinklist(p).p,pagesize);\r
+ inc(testcount);\r
+ linklistadd(l,p);\r
+ ofs := 0;\r
+ end;\r
+ a := pagesize - ofs;\r
+ if len < a then a := len;\r
+ move(data^,pointer(taddrint(tplinklist(p).p)+ofs)^,a);\r
+ inc(taddrint(data),a);\r
+ dec(len,a);\r
+ inc(ofs,a);\r
+ end;\r
+end;\r
+\r
+function tfifo.get;\r
+var\r
+ p:tlinklist;\r
+ a:integer;\r
+begin\r
+ if len > size then len := size;\r
+ if len <= 0 then begin\r
+ result := 0;\r
+ resultptr := nil;\r
+ exit;\r
+ end;\r
+ p := getl;\r
+ resultptr := pointer(taddrint(tplinklist(p).p)+getofs);\r
+ result := pagesize-getofs;\r
+ if result > len then result := len;\r
+end;\r
+\r
+procedure tfifo.del;\r
+var\r
+ a:integer;\r
+ p,p2:tlinklist;\r
+begin\r
+ if len <= 0 then exit;\r
+ p := getl;\r
+ if len > size then len := size;\r
+ dec(size,len);\r
+\r
+ if len = 0 then exit;\r
+\r
+ while len > 0 do begin\r
+ a := pagesize-getofs;\r
+ if a > len then a := len;\r
+ inc(getofs,a);\r
+ dec(len,a);\r
+ if getofs = pagesize then begin\r
+ p2 := p.prev;\r
+ freemem(tplinklist(p).p);\r
+ dec(testcount);\r
+ linklistdel(l,p);\r
+ p.destroy;\r
+ p := p2;\r
+ getl := p;\r
+ getofs := 0;\r
+ end;\r
+ end;\r
+\r
+ if size = 0 then begin\r
+ if assigned(l) then begin\r
+ p := l;\r
+ freemem(tplinklist(p).p);\r
+ dec(testcount);\r
+ linklistdel(l,p);\r
+ p.destroy;\r
+ getl := nil;\r
+ end;\r
+ ofs := pagesize;\r
+ getofs := 0;\r
+ end;\r
+end;\r
+\r
+constructor tfifo.create;\r
+begin\r
+ ofs := pagesize;\r
+ inherited create;\r
+end;\r
+\r
+destructor tfifo.destroy;\r
+begin\r
+ del(size);\r
+ inherited destroy;\r
+end;\r
+\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
+unit binipstuff;\r
+\r
+interface\r
+\r
+{$ifndef win32}\r
+{$ifdef ipv6}\r
+uses sockets;\r
+{$endif}\r
+{$endif}\r
+\r
+{$ifdef fpc}\r
+ {$mode delphi}\r
+{$endif}\r
+{$ifdef cpu386}{$define i386}{$endif}\r
+{$ifdef i386}{$define ENDIAN_LITTLE}{$endif}\r
+\r
+{$include uint32.inc}\r
+\r
+const\r
+ hexchars:array[0..15] of char='0123456789abcdef';\r
+ AF_INET=2;\r
+ {$ifdef win32}\r
+ AF_INET6=23;\r
+ {$else}\r
+ AF_INET6=10;\r
+ {$endif}\r
+\r
+type\r
+ {$ifdef ipv6}\r
+ \r
+ {$ifdef win32}\r
+ {$define want_Tin6_addr}\r
+ {$endif}\r
+ {$ifdef ver1_0}\r
+ {$define want_Tin6_addr}\r
+ {$endif}\r
+ {$ifdef want_Tin6_addr}\r
+ Tin6_addr = packed record\r
+ case byte of\r
+ 0: (u6_addr8 : array[0..15] of byte);\r
+ 1: (u6_addr16 : array[0..7] of Word);\r
+ 2: (u6_addr32 : array[0..3] of uint32);\r
+ 3: (s6_addr8 : array[0..15] of shortint);\r
+ 4: (s6_addr : array[0..15] of shortint);\r
+ 5: (s6_addr16 : array[0..7] of smallint);\r
+ 6: (s6_addr32 : array[0..3] of LongInt);\r
+ end;\r
+ {$endif}\r
+ {$endif}\r
+\r
+ tbinip=record\r
+ family:integer;\r
+ {$ifdef ipv6}\r
+ case integer of\r
+ 0: (ip:longint);\r
+ 1: (ip6:tin6_addr);\r
+ {$else}\r
+ ip:longint;\r
+ {$endif}\r
+ end;\r
+\r
+ {$ifdef win32}\r
+ TInetSockAddr = packed Record\r
+ family:Word;\r
+ port :Word;\r
+ addr :uint32;\r
+ pad :array [1..8] of byte;\r
+ end;\r
+ {$ifdef ipv6}\r
+\r
+ TInetSockAddr6 = packed record\r
+ sin6_family: word;\r
+ sin6_port: word;\r
+ sin6_flowinfo: uint32;\r
+ sin6_addr: tin6_addr;\r
+ sin6_scope_id: uint32;\r
+ end;\r
+ {$endif}\r
+ {$endif}\r
+\r
+function htons(w:word):word;\r
+function htonl(i:uint32):uint32;\r
+\r
+function ipstrtobin(const s:string;var binip:tbinip):boolean;\r
+function ipbintostr(const binip:tbinip):string;\r
+{$ifdef ipv6}\r
+function ip6bintostr(const bin:tin6_addr):string;\r
+function ip6strtobin(const s:string;var bin:tin6_addr):boolean;\r
+{$endif}\r
+\r
+function comparebinip(const ip1,ip2:tbinip):boolean;\r
+\r
+{deprecated}\r
+function longip(s:string):longint;\r
+\r
+procedure converttov4(var ip:tbinip);\r
+\r
+implementation\r
+\r
+uses sysutils;\r
+\r
+function htons(w:word):word;\r
+begin\r
+ {$ifdef ENDIAN_LITTLE}\r
+ result := ((w and $ff00) shr 8) or ((w and $ff) shl 8);\r
+ {$else}\r
+ result := w;\r
+ {$endif}\r
+end;\r
+\r
+function htonl(i:uint32):uint32;\r
+begin\r
+ {$ifdef ENDIAN_LITTLE}\r
+ result := (i shr 24) or (i shr 8 and $ff00) or (i shl 8 and $ff0000) or (i shl 24 and $ff000000);\r
+ {$else}\r
+ result := i;\r
+ {$endif}\r
+end;\r
+\r
+{internal}\r
+{converts dotted v4 IP to longint. returns host endian order}\r
+function longip(s:string):longint;\r
+var\r
+ l:longint;\r
+ a,b:integer;\r
+function convertbyte(const s:string):integer;\r
+begin\r
+ result := strtointdef(s,-1);\r
+ if result < 0 then begin\r
+ result := -1;\r
+ exit;\r
+ end;\r
+ if result > 255 then begin\r
+ result := -1;\r
+ exit;\r
+ end;\r
+ {01 exception}\r
+ if (result <> 0) and (s[1] = '0') then begin\r
+ result := -1;\r
+ exit;\r
+ end;\r
+ {+1 exception}\r
+ if not (s[1] in ['0'..'9']) then begin\r
+ result := -1;\r
+ exit\r
+ end;\r
+end;\r
+\r
+begin\r
+ result := 0;\r
+ a := pos('.',s);\r
+ if a = 0 then exit;\r
+ b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+ l := b shl 24;\r
+ s := copy(s,a+1,256);\r
+ a := pos('.',s);\r
+ if a = 0 then exit;\r
+ b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+ l := l or b shl 16;\r
+ s := copy(s,a+1,256);\r
+ a := pos('.',s);\r
+ if a = 0 then exit;\r
+ b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+ l := l or b shl 8;\r
+ s := copy(s,a+1,256);\r
+ b := convertbyte(copy(s,1,256));if (b < 0) then exit;\r
+ l := l or b;\r
+ result := l;\r
+end;\r
+\r
+\r
+function ipstrtobin(const s:string;var binip:tbinip):boolean;\r
+begin\r
+ binip.family := 0;\r
+ result := false;\r
+ {$ifdef ipv6}\r
+ if pos(':',s) <> 0 then begin\r
+ {try ipv6. use builtin routine}\r
+ result := ip6strtobin(s,binip.ip6);\r
+ if result then binip.family := AF_INET6;\r
+ exit;\r
+ end;\r
+ {$endif}\r
+\r
+ {try v4}\r
+ binip.ip := htonl(longip(s));\r
+ if (binip.ip <> 0) or (s = '0.0.0.0') then begin\r
+ result := true;\r
+ binip.family := AF_INET;\r
+ exit;\r
+ end;\r
+end;\r
+\r
+function ipbintostr(const binip:tbinip):string;\r
+var\r
+ a:integer;\r
+begin\r
+ result := '';\r
+ {$ifdef ipv6}\r
+ if binip.family = AF_INET6 then begin\r
+ result := ip6bintostr(binip.ip6);\r
+ end else\r
+ {$endif}\r
+ if binip.family = AF_INET then begin\r
+ a := htonl(binip.ip);\r
+ result := inttostr(a shr 24)+'.'+inttostr((a shr 16) and $ff)+'.'+inttostr((a shr 8) and $ff)+'.'+inttostr(a and $ff);\r
+ end;\r
+end;\r
+\r
+\r
+{------------------------------------------------------------------------------}\r
+\r
+{$ifdef ipv6}\r
+\r
+{\r
+IPv6 address binary to/from string conversion routines\r
+written by beware (steendijk at xs4all dot nl)\r
+\r
+- implementation does not depend on other ipv6 code such as the tin6_addr type,\r
+ the parameter can also be untyped.\r
+- it is host endian neutral - binary format is aways network order\r
+- it supports compression of zeroes\r
+- it supports ::ffff:192.168.12.34 style addresses\r
+- they are made to do the Right Thing, more efficient implementations are possible\r
+}\r
+\r
+{fpc has hostaddrtostr6 and strtohostaddr6 but the later isnt implemented yet}\r
+\r
+\r
+function ip6bintostr(const bin:tin6_addr):string;\r
+{base16 with lowercase output}\r
+function makehex(w:word):string;\r
+begin\r
+ result := '';\r
+ if w >= 4096 then result := result + hexchars[w shr 12];\r
+ if w >= 256 then result := result + hexchars[w shr 8 and $f];\r
+ if w >= 16 then result := result + hexchars[w shr 4 and $f];\r
+ result := result + hexchars[w and $f];\r
+end;\r
+\r
+var\r
+ a,b,c,addrlen:integer;\r
+ runbegin,runlength:integer;\r
+ bytes:array[0..15] of byte absolute bin;\r
+ words:array[0..7] of word;\r
+ dwords:array[0..3] of integer absolute words;\r
+begin\r
+ for a := 0 to 7 do begin\r
+ words[a] := bytes[a shl 1] shl 8 or bytes[a shl 1 or 1];\r
+ end;\r
+ if (dwords[0] = 0) and (dwords[1] = 0) and (words[4] = 0) and (words[5] = $ffff) then begin\r
+ {::ffff:/96 exception: v4 IP}\r
+ addrlen := 6;\r
+ end else begin\r
+ addrlen := 8;\r
+ end;\r
+ {find longest run of zeroes}\r
+ runbegin := 0;\r
+ runlength := 0;\r
+ for a := 0 to addrlen-1 do begin\r
+ if words[a] = 0 then begin\r
+ c := 0;\r
+ for b := a to addrlen-1 do if words[b] = 0 then begin\r
+ inc(c);\r
+ end else break;\r
+ if (c > runlength) then begin\r
+ runlength := c;\r
+ runbegin := a;\r
+ end;\r
+ end;\r
+ end;\r
+ result := '';\r
+ for a := 0 to runbegin-1 do begin\r
+ if (a <> 0) then result := result + ':';\r
+ result := result + makehex(words[a]);\r
+ end;\r
+ if runlength > 0 then result := result + '::';\r
+ c := runbegin+runlength;\r
+ for a := c to addrlen-1 do begin\r
+ if (a > c) then result := result + ':';\r
+ result := result + makehex(words[a]);\r
+ end;\r
+ if addrlen = 6 then begin\r
+ result := result + ':'+inttostr(bytes[12])+'.'+inttostr(bytes[13])+'.'+inttostr(bytes[14])+'.'+inttostr(bytes[15]);\r
+ end;\r
+end;\r
+\r
+function ip6strtobin(const s:string;var bin:tin6_addr):boolean;\r
+var\r
+ a,b:integer;\r
+ fields:array[0..7] of string;\r
+ fieldcount:integer;\r
+ emptyfield:integer;\r
+ wordcount:integer;\r
+ words:array[0..7] of word;\r
+ bytes:array[0..15] of byte absolute bin;\r
+begin\r
+ result := false;\r
+ for a := 0 to 7 do fields[a] := '';\r
+ fieldcount := 0;\r
+ for a := 1 to length(s) do begin\r
+ if s[a] = ':' then inc(fieldcount) else fields[fieldcount] := fields[fieldcount] + s[a];\r
+ if fieldcount > 7 then exit;\r
+ end;\r
+ if fieldcount < 2 then exit;\r
+\r
+ {find the empty field (compressed zeroes), not counting the first and last there may be at most 1}\r
+ emptyfield := -1;\r
+ for a := 1 to fieldcount-1 do begin\r
+ if fields[a] = '' then begin\r
+ if emptyfield = -1 then emptyfield := a else exit;\r
+ end;\r
+ end;\r
+\r
+ {check if last field is a valid v4 IP}\r
+ a := longip(fields[fieldcount]);\r
+ if (a <> 0) or (fields[fieldcount] = '0.0.0.0') then wordcount := 6 else wordcount := 8;\r
+ {0:1:2:3:4:5:6.6.6.6\r
+ 0:1:2:3:4:5:6:7}\r
+ fillchar(words,sizeof(words),0);\r
+ if wordcount = 6 then begin\r
+ if fieldcount > 6 then exit;\r
+ words[6] := a shr 16;\r
+ words[7] := a and $ffff;\r
+ end;\r
+ if emptyfield = -1 then begin\r
+ {no run length: must be an exact number of fields}\r
+ if wordcount = 6 then begin\r
+ if fieldcount <> 6 then exit;\r
+ emptyfield := 5;\r
+ end else if wordcount = 8 then begin\r
+ if fieldcount <> 7 then exit;\r
+ emptyfield := 7;\r
+ end else exit;\r
+ end;\r
+ for a := 0 to emptyfield do begin\r
+ if fields[a] = '' then b := 0 else b := strtointdef('$'+fields[a],-1);\r
+ if (b < 0) or (b > $ffff) then exit;\r
+ words[a] := b;\r
+ end;\r
+ if wordcount = 6 then dec(fieldcount);\r
+ for a := wordcount-1 downto wordcount-(fieldcount-emptyfield) do begin\r
+ b := a+fieldcount-wordcount+1;\r
+ if fields[b] = '' then b := 0 else b := strtointdef('$'+fields[b],-1);\r
+ if (b < 0) or (b > $ffff) then exit;\r
+ words[a] := b;\r
+ end;\r
+ for a := 0 to 7 do begin\r
+ bytes[a shl 1] := words[a] shr 8;\r
+ bytes[a shl 1 or 1] := words[a] and $ff;\r
+ end;\r
+ result := true;\r
+end;\r
+{$endif}\r
+\r
+function comparebinip(const ip1,ip2:tbinip):boolean;\r
+begin\r
+ if (ip1.ip <> ip2.ip) then begin\r
+ result := false;\r
+ exit;\r
+ end;\r
+\r
+ {$ifdef ipv6}\r
+ if ip1.family = AF_INET6 then begin\r
+ if (ip1.ip6.s6_addr32[1] <> ip2.ip6.s6_addr32[1])\r
+ or (ip1.ip6.s6_addr32[2] <> ip2.ip6.s6_addr32[2])\r
+ or (ip1.ip6.s6_addr32[3] <> ip2.ip6.s6_addr32[3]) then begin\r
+ result := false;\r
+ exit;\r
+ end;\r
+ end;\r
+ {$endif}\r
+\r
+ result := (ip1.family = ip2.family);\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 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
+ end;\r
+ end;\r
+ {$endif}\r
+end;\r
+\r
+end.\r
--- /dev/null
+(*\r
+ * beware IRC services, blinklist.pas\r
+ * Copyright (C) 2002 Bas Steendijk\r
+ *\r
+ * This program is free software; you can redistribute it and/or modify\r
+ * it under the terms of the GNU General Public License as published by\r
+ * the Free Software Foundation; either version 2 of the License, or\r
+ * (at your option) any later version.\r
+ *\r
+ * This program is distributed in the hope that it will be useful,\r
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ * GNU General Public License for more details.\r
+ *\r
+ * You should have received a copy of the GNU General Public License\r
+ * along with this program; if not, write to the Free Software\r
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA\r
+ *)\r
+unit blinklist;\r
+{$ifdef fpc}\r
+ {$mode delphi}\r
+{$endif}\r
+\r
+\r
+interface\r
+\r
+type\r
+ tlinklist=class(tobject)\r
+ next:tlinklist;\r
+ prev:tlinklist;\r
+ constructor create;\r
+ destructor destroy; override;\r
+ end;\r
+\r
+ {linklist with 2 links}\r
+ tlinklist2=class(tlinklist)\r
+ next2:tlinklist2;\r
+ prev2:tlinklist2;\r
+ end;\r
+\r
+ {linklist with one pointer}\r
+ tplinklist=class(tlinklist)\r
+ p:pointer\r
+ end;\r
+\r
+ tstringlinklist=class(tlinklist)\r
+ s:string;\r
+ end;\r
+\r
+ tthing=class(tlinklist)\r
+ name:string; {name/nick}\r
+ hashname:integer; {hash of name}\r
+ end;\r
+\r
+{\r
+adding new block to list (baseptr)\r
+}\r
+procedure linklistadd(var baseptr:tlinklist;newptr:tlinklist);\r
+procedure linklistdel(var baseptr:tlinklist;item:tlinklist);\r
+\r
+\r
+procedure linklist2add(var baseptr,newptr:tlinklist2);\r
+procedure linklist2del(var baseptr:tlinklist2;item:tlinklist2);\r
+\r
+var\r
+ linklistdebug:integer;\r
+\r
+implementation\r
+\r
+procedure linklistadd(var baseptr:tlinklist;newptr:tlinklist);\r
+var\r
+ p:tlinklist;\r
+begin\r
+ p := baseptr;\r
+ baseptr := newptr;\r
+ baseptr.prev := nil;\r
+ baseptr.next := p;\r
+ if p <> nil then p.prev := baseptr;\r
+end;\r
+\r
+procedure linklistdel(var baseptr:tlinklist;item:tlinklist);\r
+begin\r
+ if item = baseptr then baseptr := item.next;\r
+ if item.prev <> nil then item.prev.next := item.next;\r
+ if item.next <> nil then item.next.prev := item.prev;\r
+end;\r
+\r
+procedure linklist2add(var baseptr,newptr:tlinklist2);\r
+var\r
+ p:tlinklist2;\r
+begin\r
+ p := baseptr;\r
+ baseptr := newptr;\r
+ baseptr.prev2 := nil;\r
+ baseptr.next2 := p;\r
+ if p <> nil then p.prev2 := baseptr;\r
+end;\r
+\r
+procedure linklist2del(var baseptr:tlinklist2;item:tlinklist2);\r
+begin\r
+ if item = baseptr then baseptr := item.next2;\r
+ if item.prev2 <> nil then item.prev2.next2 := item.next2;\r
+ if item.next2 <> nil then item.next2.prev2 := item.prev2;\r
+end;\r
+\r
+constructor tlinklist.create;\r
+begin\r
+ inherited create;\r
+ inc(linklistdebug);\r
+end;\r
+\r
+destructor tlinklist.destroy;\r
+begin\r
+ dec(linklistdebug);\r
+ inherited destroy;\r
+end;\r
+\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
+{actually a hashtable. it was a tree in earlier versions}\r
+\r
+unit bsearchtree;\r
+\r
+interface\r
+\r
+uses blinklist;\r
+\r
+const\r
+ hashtable_size=$4000;\r
+\r
+type\r
+ thashitem=class(tlinklist)\r
+ hash:integer;\r
+ s:string;\r
+ p:pointer;\r
+ end;\r
+ thashtable=array[0..hashtable_size-1] of thashitem;\r
+ phashtable=^thashtable;\r
+\r
+{adds "item" to the tree for name "s". the name must not exist (no checking done)}\r
+procedure addtree(t:phashtable;s:string;item:pointer);\r
+\r
+{removes name "s" from the tree. the name must exist (no checking done)}\r
+procedure deltree(t:phashtable;s:string);\r
+\r
+{returns the item pointer for s, or nil if not found}\r
+function findtree(t:phashtable;s:string):pointer;\r
+\r
+implementation\r
+\r
+function makehash(s:string):integer;\r
+const\r
+ shifter=6;\r
+var\r
+ a,b:integer;\r
+begin\r
+ result := 0;\r
+ b := length(s);\r
+ for a := 1 to b do begin\r
+ result := (result shl shifter) xor byte(s[a]);\r
+ end;\r
+ result := (result xor result shr 16) and (hashtable_size-1);\r
+end;\r
+\r
+procedure addtree(t:phashtable;s:string;item:pointer);\r
+var\r
+ hash:integer;\r
+ p:thashitem;\r
+begin\r
+ hash := makehash(s);\r
+ p := thashitem.create;\r
+ p.hash := hash;\r
+ p.s := s;\r
+ p.p := item;\r
+ linklistadd(tlinklist(t[hash]),tlinklist(p));\r
+end;\r
+\r
+procedure deltree(t:phashtable;s:string);\r
+var\r
+ p,p2:thashitem;\r
+ hash:integer;\r
+begin\r
+ hash := makehash(s);\r
+ p := t[hash];\r
+ p2 := nil;\r
+ while p <> nil do begin\r
+ if p.s = s then begin\r
+ p2 := p;\r
+ break;\r
+ end;\r
+ p := thashitem(p.next);\r
+ end;\r
+ linklistdel(tlinklist(t[hash]),tlinklist(p2));\r
+ p2.destroy;\r
+end;\r
+\r
+\r
+function findtree(t:phashtable;s:string):pointer;\r
+var\r
+ p:thashitem;\r
+ hash:integer;\r
+begin\r
+ result := nil;\r
+ hash := makehash(s);\r
+ p := t[hash];\r
+ while p <> nil do begin\r
+ if p.s = s then begin\r
+ result := p.p;\r
+ exit;\r
+ end;\r
+ p := thashitem(p.next);\r
+ end;\r
+end;\r
+\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
+this unit returns unix timestamp with seconds and microseconds (as float)\r
+works on windows/delphi, and on freepascal on unix.\r
+}\r
+\r
+unit btime;\r
+\r
+interface\r
+\r
+type\r
+ float=extended;\r
+\r
+var\r
+ timezone:integer;\r
+ timezonestr:string;\r
+ irctime,unixtime:integer;\r
+ tickcount:integer;\r
+ settimebias:integer;\r
+ qpcjump:float; {can be read out and reset for debug purpose}\r
+ performancecountfreq:extended;\r
+\r
+function irctimefloat:float;\r
+function irctimeint:integer;\r
+\r
+function unixtimefloat:float;\r
+function unixtimeint:integer;\r
+\r
+function wintimefloat:float;\r
+\r
+procedure settime(newtime:integer);\r
+procedure gettimezone;\r
+procedure timehandler;\r
+procedure init;\r
+\r
+function timestring(i:integer):string;\r
+function timestrshort(i:integer):string;\r
+\r
+function oletounixfloat(t:float):float;\r
+function oletounix(t:tdatetime):integer;\r
+function unixtoole(i:integer):tdatetime;\r
+\r
+var\r
+ timefloatbias:float;\r
+ lastunixtimefloat:float=0;\r
+\r
+implementation\r
+\r
+{$ifdef fpc}\r
+ {$mode delphi}\r
+{$endif}\r
+\r
+uses\r
+ {$ifdef UNIX}\r
+ {$ifdef VER1_0}\r
+ linux,\r
+ {$else}\r
+ baseunix,unix,unixutil, {needed for 2.0.2}\r
+ {$endif}\r
+ {$else}\r
+ windows,\r
+ {$endif}\r
+ sysutils;\r
+\r
+ {$include unixstuff.inc}\r
+\r
+\r
+const\r
+ daysdifference=25569;\r
+\r
+function oletounixfloat(t:float):float;\r
+begin\r
+ t := (t - daysdifference) * 86400;\r
+ result := t;\r
+end;\r
+\r
+function oletounix(t:tdatetime):integer;\r
+begin\r
+ result := trunc(oletounixfloat(t));\r
+end;\r
+\r
+function unixtoole(i:integer):tdatetime;\r
+begin\r
+ result := ((i)/86400)+daysdifference;\r
+end;\r
+\r
+{$ifdef unix}\r
+{-----------------------------------------*nix/freepascal code to read time }\r
+\r
+function unixtimefloat:float;\r
+var\r
+ tv:ttimeval;\r
+begin\r
+ gettimeofday(tv);\r
+ result := tv.tv_sec+(tv.tv_usec/1000000);\r
+end;\r
+\r
+function wintimefloat:extended;\r
+begin\r
+ result := unixtimefloat;\r
+end;\r
+\r
+function unixtimeint:integer;\r
+var\r
+ tv:ttimeval;\r
+begin\r
+ gettimeofday(tv);\r
+ result := tv.tv_sec;\r
+end;\r
+\r
+{$else} {delphi 3}\r
+{------------------------------ windows/delphi code to read time}\r
+\r
+{ free pascals tsystemtime is incomaptible with windows api calls\r
+ so we declare it ourselves - plugwash\r
+}\r
+{$ifdef fpc}\r
+type\r
+ TSystemTime = record\r
+ wYear: Word;\r
+ wMonth: Word;\r
+ wDayOfWeek: Word;\r
+ wDay: Word;\r
+ wHour: Word;\r
+ wMinute: Word;\r
+ wSecond: Word;\r
+ wMilliseconds: Word;\r
+ end;\r
+ {$endif}\r
+function Date_utc: extended;\r
+var\r
+ SystemTime: TSystemTime;\r
+begin\r
+ {$ifdef fpc}\r
+ GetsystemTime(@SystemTime);\r
+ {$else}\r
+ GetsystemTime(SystemTime);\r
+ {$endif}\r
+ with SystemTime do Result := EncodeDate(wYear, wMonth, wDay);\r
+end;\r
+\r
+function Time_utc: extended;\r
+var\r
+ SystemTime: TSystemTime;\r
+begin\r
+ {$ifdef fpc}\r
+ GetsystemTime(@SystemTime);\r
+ {$else}\r
+ GetsystemTime(SystemTime);\r
+ {$endif}\r
+ with SystemTime do\r
+ Result := EncodeTime(wHour, wMinute, wSecond, wMilliSeconds);\r
+end;\r
+\r
+function Now_utc: extended;\r
+begin\r
+ Result := round(Date_utc) + Time_utc;\r
+end;\r
+\r
+const\r
+ highdwordconst=4294967296.0;\r
+\r
+function wintimefloat:extended;\r
+var\r
+ p:packed record\r
+ lowpart:longint;\r
+ highpart:longint\r
+ end;\r
+ p2:tlargeinteger absolute p;\r
+ e:extended;\r
+begin\r
+ if performancecountfreq = 0 then begin\r
+ QueryPerformancefrequency(p2);\r
+ e := p.lowpart;\r
+ if e < 0 then e := e + highdwordconst;\r
+ performancecountfreq := ((p.highpart*highdwordconst)+e);\r
+ end;\r
+ queryperformancecounter(p2);\r
+ e := p.lowpart;\r
+ if e < 0 then e := e + highdwordconst;\r
+ result := ((p.highpart*highdwordconst)+e)/performancecountfreq;\r
+end;\r
+\r
+var\r
+ classpriority,threadpriority:integer;\r
+\r
+procedure settc;\r
+var\r
+ hprocess,hthread:integer;\r
+begin\r
+ hProcess := GetCurrentProcess;\r
+ hThread := GetCurrentThread;\r
+\r
+ ClassPriority := GetPriorityClass(hProcess);\r
+ ThreadPriority := GetThreadPriority(hThread);\r
+\r
+ SetPriorityClass(hProcess, REALTIME_PRIORITY_CLASS);\r
+ SetThreadPriority(hThread, THREAD_PRIORITY_TIME_CRITICAL);\r
+end;\r
+\r
+procedure unsettc;\r
+var\r
+ hprocess,hthread:integer;\r
+begin\r
+ hProcess := GetCurrentProcess;\r
+ hThread := GetCurrentThread;\r
+\r
+ SetPriorityClass(hProcess, ClassPriority);\r
+ SetThreadPriority(hThread, ThreadPriority);\r
+end;\r
+\r
+function unixtimefloat:float;\r
+var\r
+ f,g,h:float;\r
+begin\r
+ if timefloatbias = 0 then begin\r
+ settc;\r
+ f := now_utc;\r
+ repeat g := now_utc; h := wintimefloat until g > f;\r
+ timefloatbias := oletounixfloat(g)-h;\r
+ unsettc;\r
+ end;\r
+ result := wintimefloat+timefloatbias;\r
+\r
+ {\r
+ workaround for QPC jumps\r
+ (approach 2: always check "hi res" QPC unixtime against the "guaranteed" systemtime one)\r
+ }\r
+ f := result-(oletounixfloat(now_utc));\r
+ if abs(f) > 0.02 then begin\r
+ f := timefloatbias;\r
+ timefloatbias := 0;\r
+ result := unixtimefloat;\r
+ qpcjump := qpcjump + f - timefloatbias;\r
+ end;\r
+\r
+ if (result <= lastunixtimefloat) then result := lastunixtimefloat + 0.0000001;\r
+ lastunixtimefloat := result;\r
+end;\r
+\r
+function unixtimeint:integer;\r
+begin\r
+ result := trunc(unixtimefloat);\r
+end;\r
+\r
+{$endif}\r
+{-----------------------------------------------end of platform specific}\r
+\r
+function irctimefloat:float;\r
+begin\r
+ result := unixtimefloat+settimebias;\r
+end;\r
+\r
+function irctimeint:integer;\r
+begin\r
+ result := unixtimeint+settimebias;\r
+end;\r
+\r
+\r
+procedure settime(newtime:integer);\r
+var\r
+ a:integer;\r
+begin\r
+ a := irctimeint-settimebias;\r
+ if newtime = 0 then settimebias := 0 else settimebias := newtime-a;\r
+\r
+ irctime := irctimeint;\r
+end;\r
+\r
+procedure timehandler;\r
+begin\r
+ if unixtime = 0 then init;\r
+ unixtime := unixtimeint;\r
+ irctime := irctimeint;\r
+ if unixtime and 63 = 0 then begin\r
+ {update everything, apply timezone changes, clock changes, etc}\r
+ gettimezone;\r
+ timefloatbias := 0;\r
+ unixtime := unixtimeint;\r
+ irctime := irctimeint;\r
+ end;\r
+end;\r
+\r
+\r
+procedure gettimezone;\r
+var\r
+ {$ifdef UNIX}\r
+ {$ifndef ver1_9_4}\r
+ {$ifndef ver1_0}\r
+ {$define above194}\r
+ {$endif}\r
+ {$endif}\r
+ {$ifndef above194}\r
+ hh,mm,ss:word;\r
+ {$endif}\r
+ {$endif}\r
+ l:integer;\r
+begin\r
+ {$ifdef UNIX}\r
+ {$ifdef above194}\r
+ timezone := tzseconds;\r
+ {$else}\r
+ gettime(hh,mm,ss);\r
+ timezone := (longint(hh) * 3600 + mm * 60 + ss) - (unixtimeint mod 86400);\r
+ {$endif}\r
+ {$else}\r
+ timezone := round((now-now_utc)*86400);\r
+ {$endif}\r
+\r
+ while timezone > 43200 do dec(timezone,86400);\r
+ while timezone < -43200 do inc(timezone,86400);\r
+\r
+ if timezone >= 0 then timezonestr := '+' else timezonestr := '-';\r
+ l := abs(timezone) div 60;\r
+ timezonestr := timezonestr + char(l div 600 mod 10+48)+char(l div 60 mod 10+48)+':'+char(l div 10 mod 6+48)+char(l mod 10+48);\r
+end;\r
+\r
+function timestrshort(i:integer):string;\r
+const\r
+ weekday:array[0..6] of string[4]=('Thu','Fri','Sat','Sun','Mon','Tue','Wed');\r
+ month:array[0..11] of string[4]=('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');\r
+var\r
+ y,m,d,h,min,sec,ms:word;\r
+ t:tdatetime;\r
+begin\r
+ t := unixtoole(i+timezone);\r
+ decodedate(t,y,m,d);\r
+ decodetime(t,h,min,sec,ms);\r
+ result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+\r
+ inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10)+' '+\r
+ inttostr(y);\r
+end;\r
+\r
+function timestring(i:integer):string;\r
+const\r
+ weekday:array[0..6] of string[10]=('Thursday','Friday','Saturday','Sunday','Monday','Tuesday','Wednesday');\r
+ month:array[0..11] of string[10]=('January','February','March','April','May','June','July','August','September','October','November','December');\r
+var\r
+ y,m,d,h,min,sec,ms:word;\r
+ t:tdatetime;\r
+begin\r
+ t := unixtoole(i+timezone);\r
+ decodedate(t,y,m,d);\r
+ decodetime(t,h,min,sec,ms);\r
+ result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+inttostr(y)+' -- '+\r
+ inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10)+' '+\r
+ timezonestr;\r
+end;\r
+\r
+procedure init;\r
+begin\r
+ qpcjump := 0;\r
+ settimebias := 0;\r
+ gettimezone;\r
+ unixtime := unixtimeint;\r
+ irctime := irctimeint;\r
+end;\r
+\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
+//FIXME: this code only ever seems to use one dns server for a request and does\r
+//not seem to have any form of retry code.\r
+\r
+unit dnsasync;\r
+\r
+interface\r
+\r
+uses\r
+ {$ifdef win32}\r
+ dnswin,\r
+ {$endif}\r
+ lsocket,lcore,\r
+ classes,binipstuff,dnscore,btime;\r
+\r
+\r
+type\r
+ //after completion or cancelation a dnswinasync may be reused\r
+ tdnsasync=class(tcomponent)\r
+\r
+ private\r
+ //made a load of stuff private that does not appear to be part of the main\r
+ //public interface. If you make any of it public again please consider the\r
+ //consequences when using windows dns. --plugwash.\r
+ sock:twsocket;\r
+\r
+ sockopen:boolean;\r
+\r
+\r
+ state:tdnsstate;\r
+\r
+ dnsserverid:integer;\r
+ startts:double;\r
+ {$ifdef win32}
+ dwas : tdnswinasync;\r
+ {$endif}
+\r
+\r
+ procedure asyncprocess;\r
+ procedure receivehandler(sender:tobject;error:word);\r
+ function sendquery(const packet:tdnspacket;len:integer):boolean;\r
+ {$ifdef win32}
+ procedure winrequestdone(sender:tobject;error:word);\r
+ {$endif}
+ public\r
+ onrequestdone:tsocketevent;\r
+\r
+ //addr and port allow the application to specify a dns server specifically\r
+ //for this dnsasync object. This is not a reccomended mode of operation\r
+ //because it limits the app to one dns server but is kept for compatibility\r
+ //and special uses.\r
+ addr,port:string;\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
+\r
+ constructor create(aowner:tcomponent); override;\r
+ destructor destroy; override;\r
+\r
+ end;\r
+\r
+implementation\r
+\r
+uses sysutils;\r
+\r
+constructor tdnsasync.create;\r
+begin\r
+ inherited create(aowner);\r
+ dnsserverid := -1;\r
+ sock := twsocket.create(self);\r
+end;\r
+\r
+destructor tdnsasync.destroy;\r
+begin\r
+ if dnsserverid >= 0 then begin\r
+ reportlag(dnsserverid,-1);\r
+ dnsserverid := -1;\r
+ end;\r
+ sock.release;\r
+ setstate_request_init('',state);\r
+ inherited destroy;\r
+end;\r
+\r
+procedure tdnsasync.receivehandler;\r
+begin\r
+ if dnsserverid >= 0 then begin\r
+ reportlag(dnsserverid,trunc((unixtimefloat-startts)*1000));\r
+ dnsserverid := -1;\r
+ end;\r
+{ writeln('received reply');}\r
+ fillchar(state.recvpacket,sizeof(state.recvpacket),0);\r
+ state.recvpacketlen := twsocket(sender).Receive(@state.recvpacket, SizeOf(state.recvpacket));\r
+ state.parsepacket := true;\r
+ asyncprocess;\r
+end;\r
+\r
+function tdnsasync.sendquery;\r
+begin\r
+{ writeln('sendquery ',decodename(state.packet,state.packetlen,12,0,a),' ',state.requesttype);}\r
+ result := false;\r
+ if len = 0 then exit; {no packet}\r
+ if not sockopen then begin\r
+ if addr <> '' then sock.addr := addr else sock.addr := getcurrentsystemnameserver(dnsserverid);//getunixnameservercached;\r
+ startts := unixtimefloat;\r
+ if port = '' then port := '53';\r
+ sock.port := port;\r
+ sock.Proto := 'udp';\r
+ sock.ondataavailable := receivehandler;\r
+ try\r
+ sock.connect;\r
+ except\r
+ on e:exception do begin\r
+ //writeln('exception '+e.message);\r
+ exit;\r
+ end;\r
+ end;\r
+ sockopen := true;\r
+ end;\r
+ sock.send(@packet,len);\r
+ result := true;\r
+end;\r
+\r
+procedure tdnsasync.asyncprocess;\r
+begin\r
+ state_process(state);\r
+ case state.resultaction of\r
+ action_ignore: begin {do nothing} end;\r
+ action_done: begin\r
+ onrequestdone(self,0);\r
+ end;\r
+ action_sendquery:begin\r
+ sendquery(state.sendpacket,state.sendpacketlen);\r
+ end;\r
+ end;\r
+end;\r
+\r
+procedure tdnsasync.forwardlookup;\r
+begin\r
+ {$ifdef win32}\r
+ if usewindns or (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
+ end;\r
+ {$endif}\r
+\r
+ ipstrtobin(name,state.resultbin);\r
+ if state.resultbin.family <> 0 then begin\r
+ onrequestdone(self,0);\r
+ exit;\r
+ end;\r
+\r
+\r
+ setstate_forward(name,state,forwardfamily);\r
+ asyncprocess;\r
+\r
+end;\r
+\r
+procedure tdnsasync.reverselookup;\r
+\r
+begin\r
+ {$ifdef win32}\r
+ if usewindns or (addr = '') then begin\r
+ dwas := tdnswinasync.create;\r
+ dwas.onrequestdone := winrequestdone;\r
+ dwas.reverselookup(binip);\r
+ end;\r
+ {$endif}\r
+\r
+ setstate_reverse(binip,state);\r
+ asyncprocess;\r
+end;\r
+\r
+function tdnsasync.dnsresult;\r
+begin\r
+ if state.resultstr <> '' then result := state.resultstr else begin\r
+ result := ipbintostr(state.resultbin);\r
+ end;\r
+end;\r
+\r
+procedure tdnsasync.dnsresultbin(var binip:tbinip);\r
+begin\r
+ move(state.resultbin,binip,sizeof(binip));\r
+end;\r
+\r
+procedure tdnsasync.cancel;\r
+begin\r
+ {$ifdef win32}
+ if assigned(dwas) then begin\r
+ dwas.release;\r
+ dwas := nil;\r
+ end else
+ {$endif}
+ begin\r
+\r
+ if dnsserverid >= 0 then begin\r
+ reportlag(dnsserverid,-1);\r
+ dnsserverid := -1;\r
+ end;\r
+ if sockopen then begin\r
+ sock.close;\r
+ sockopen := false;\r
+ end;\r
+ end;\r
+ setstate_failure(state);\r
+ onrequestdone(self,0);\r
+end;\r
+\r
+{$ifdef win32}
+ procedure tdnsasync.winrequestdone(sender:tobject;error:word);\r
+ begin\r
+ if dwas.reverse then begin \r
+ state.resultstr := dwas.name;\r
+ end else begin \r
+ state.resultbin := dwas.ip;\r
+ if (forwardfamily = AF_INET6) and (state.resultbin.family = AF_INET) then begin\r
+ fillchar(state.resultbin,sizeof(tbinip),0);\r
+ end;\r
+ end;\r
+ dwas.release;\r
+ onrequestdone(self,error);\r
+ end;\r
+{$endif}
+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
+{\r
+\r
+ code wanting to use this dns system should act as follows (note: app\r
+ developers will probablly want to use dnsasync or dnssync or write a similar\r
+ wrapper unit of thier own).\r
+\r
+ for normal lookups call setstate_forward or setstate_reverse to set up the\r
+ state, for more obscure lookups use setstate_request_init and fill in other\r
+ relavent state manually.\r
+\r
+ call state_process which will do processing on the information in the state\r
+ and return an action\r
+ action_ignore means that dnscore wants the code that calls it to go\r
+ back to waiting for packets\r
+ action_sendpacket means that dnscore wants the code that calls it to send\r
+ the packet in sendpacket/sendpacketlen and then start (or go back to) listening\r
+ for\r
+ action_done means the request has completed (either suceeded or failed)\r
+\r
+ callers should resend the last packet they tried to send if they have not\r
+ been asked to send a new packet for more than some timeout value they choose.\r
+\r
+ when a packet is received the application should put the packet in\r
+ recvbuf/recvbuflen , set state.parsepacket and call state_process again\r
+\r
+ once the app gets action_done it can determine sucess or failure in the\r
+ following ways.\r
+\r
+ on failure state.resultstr will be an empty string and state.resultbin will\r
+ be zeroed out (easilly detected by the fact that it will have a family of 0)\r
+\r
+ on success for a A or AAAA lookup state.resultstr will be an empty string\r
+ and state.resultbin will contain the result (note: AAAA lookups require IPV6\r
+ enabled).\r
+\r
+ if an A lookup fails and the code is built with ipv6 enabled then the code\r
+ will return any AAAA records with the same name. The reverse does not apply\r
+ so if an application preffers IPV6 but wants IPV4 results as well it must\r
+ check them seperately.\r
+\r
+ on success for any other type of lookup state.resultstr will be an empty\r
+\r
+ note the state contains ansistrings, setstate_init with a null name parameter\r
+ can be used to clean theese up if required.\r
+\r
+ callers may use setstate_failure to mark the state as failed themseleves\r
+ before passing it on to other code, for example this may be done in the event\r
+ of a timeout.\r
+}\r
+unit dnscore;\r
+\r
+\r
+\r
+{$ifdef fpc}{$mode delphi}{$endif}\r
+\r
+\r
+\r
+\r
+\r
+interface\r
+\r
+uses binipstuff,classes,pgtypes;\r
+\r
+var usewindns : boolean = {$ifdef win32}true{$else}false{$endif};\r
+//hint to users of this unit that they should use windows dns instead.\r
+//May be disabled by applications if desired. (e.g. if setting a custom\r
+//dnsserverlist).\r
+\r
+//note: this unit will not be able to self populate it's dns server list on\r
+//older versions of windows.\r
+\r
+const\r
+ maxnamelength=127;\r
+ maxnamefieldlen=63;\r
+ //note: when using action_ignore the dnscore code *must* preserve the contents of state.sendpacket to allow for retries\r
+ //note: action_ignore must not be used in response to the original request but there is no valid reason for doing this anyway\r
+ action_ignore=0;\r
+ action_done=1;\r
+ action_sendquery=2;\r
+ querytype_a=1;\r
+ querytype_cname=5;\r
+ querytype_aaaa=28;\r
+ querytype_ptr=12;\r
+ querytype_ns=2;\r
+ querytype_soa=6;\r
+ querytype_mx=15;\r
+\r
+ maxrecursion=10;\r
+ maxrrofakind=20;\r
+\r
+ retryafter=300000; //microseconds must be less than one second;\r
+ timeoutlag=1000000000; // penalty value to be treated as lag in the event of a timeout (microseconds)\r
+type\r
+ dvar=array[0..0] of byte;\r
+ pdvar=^dvar;\r
+ tdnspacket=packed record\r
+ id:word;\r
+ flags:word;\r
+ rrcount:array[0..3] of word;\r
+ payload:array[0..511-12] of byte;\r
+ end;\r
+\r
+\r
+\r
+ tdnsstate=record\r
+ id:word;\r
+ recursioncount:integer;\r
+ queryname:string;\r
+ requesttype:word;\r
+ parsepacket:boolean;\r
+ resultstr:string;\r
+ resultbin:tbinip;\r
+ resultaction:integer;\r
+ numrr1:array[0..3] of integer;\r
+ numrr2:integer;\r
+ rrdata:string;\r
+ sendpacketlen:integer;\r
+ sendpacket:tdnspacket;\r
+ recvpacketlen:integer;\r
+ recvpacket:tdnspacket;\r
+ forwardfamily:integer;\r
+ end;\r
+\r
+ trr=packed record\r
+ requesttypehi:byte;\r
+ requesttype:byte;\r
+ clas:word;\r
+ ttl:integer;\r
+ datalen:word;\r
+ data:array[0..511] of byte;\r
+ end;\r
+\r
+ trrpointer=packed record\r
+ p:pointer;\r
+ ofs:integer;\r
+ len:integer;\r
+ namelen:integer;\r
+ end;\r
+\r
+//commenting out functions from interface that do not have documented semantics\r
+//and probablly should not be called from outside this unit, reenable them\r
+//if you must but please document them at the same time --plugwash\r
+\r
+//function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer;\r
+//function makereversename(const binip:tbinip):string;\r
+\r
+procedure setstate_request_init(const name:string;var state:tdnsstate);\r
+\r
+//set up state for a foward lookup. 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
+procedure setstate_forward(const name:string;var state:tdnsstate;family:integer);\r
+\r
+procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);\r
+procedure setstate_failure(var state:tdnsstate);\r
+//procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);\r
+\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
+var\r
+ dnsserverlist : tstringlist;\r
+// currentdnsserverno : integer;\r
+\r
+function getcurrentsystemnameserver(var id:integer) :string;\r
+\r
+//var\r
+// unixnameservercache:string;\r
+{ $endif}\r
+\r
+\r
+procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout\r
+var\r
+ failurereason:string;\r
+\r
+implementation\r
+\r
+uses\r
+ {$ifdef win32}\r
+ windows,\r
+ {$endif}\r
+\r
+ sysutils;\r
+\r
+function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer;\r
+var\r
+ a,b:integer;\r
+ s:string;\r
+ arr:array[0..sizeof(packet)-1] of byte absolute packet;\r
+begin\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.flags := htons($0100);\r
+ packet.rrcount[0] := htons($0001);\r
+\r
+\r
+ s := copy(name,1,maxnamelength);\r
+ if s = '' then exit;\r
+ if s[length(s)] <> '.' then s := s + '.';\r
+ b := 0;\r
+ {encode name}\r
+ if (s = '.') then begin\r
+ packet.payload[0] := 0;\r
+ result := 12+5;\r
+ end else begin\r
+ for a := 1 to length(s) do begin\r
+ if s[a] = '.' then begin\r
+ if b > maxnamefieldlen then exit;\r
+ if (b = 0) then exit;\r
+ packet.payload[a-b-1] := b;\r
+ b := 0;\r
+ end else begin\r
+ packet.payload[a] := byte(s[a]);\r
+ inc(b);\r
+ end;\r
+ end;\r
+ if b > maxnamefieldlen then exit;\r
+ packet.payload[length(s)-b] := b;\r
+ result := length(s) + 12+5;\r
+ end;\r
+\r
+ arr[result-1] := 1;\r
+ arr[result-3] := requesttype and $ff;\r
+ arr[result-4] := requesttype shr 8;\r
+end;\r
+\r
+function makereversename(const binip:tbinip):string;\r
+var\r
+ name:string;\r
+ a,b:integer;\r
+begin\r
+ name := '';\r
+ if binip.family = AF_INET then begin\r
+ b := htonl(binip.ip);\r
+ for a := 0 to 3 do begin\r
+ name := name + inttostr(b shr (a shl 3) and $ff)+'.';\r
+ end;\r
+ name := name + 'in-addr.arpa';\r
+ end else\r
+ {$ifdef ipv6}\r
+ if binip.family = AF_INET6 then begin\r
+ for a := 15 downto 0 do begin\r
+ b := binip.ip6.u6_addr8[a];\r
+ name := name + hexchars[b and $f]+'.'+hexchars[b shr 4]+'.';\r
+ end;\r
+ name := name + 'ip6.arpa';\r
+ end else\r
+ {$endif}\r
+ begin\r
+ {empty name}\r
+ end;\r
+ result := name;\r
+end;\r
+\r
+{\r
+decodes DNS format name to a string. does not includes the root dot.\r
+doesnt read beyond len.\r
+empty result + non null failurereason: failure\r
+empty result + null failurereason: internal use\r
+}\r
+function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):string;\r
+var\r
+ arr:array[0..sizeof(packet)-1] of byte absolute packet;\r
+ s:string;\r
+ a,b:integer;\r
+begin\r
+ numread := 0;\r
+ repeat\r
+ if (start+numread < 0) or (start+numread >= len) then begin\r
+ result := '';\r
+ failurereason := 'decoding name: got out of range1';\r
+ exit;\r
+ end;\r
+ b := arr[start+numread];\r
+ if b >= $c0 then begin\r
+ {recursive sub call}\r
+ if recursion > 10 then begin\r
+ result := '';\r
+ failurereason := 'decoding name: max recursion';\r
+ exit;\r
+ end;\r
+ if ((start+numread+1) >= len) then begin\r
+ result := '';\r
+ failurereason := 'decoding name: got out of range3';\r
+ exit;\r
+ end;\r
+ a := ((b shl 8) or arr[start+numread+1]) and $3fff;\r
+ s := decodename(packet,len,a,recursion+1,a);\r
+ if (s = '') and (failurereason <> '') then begin\r
+ result := '';\r
+ exit;\r
+ end;\r
+ if result <> '' then result := result + '.';\r
+ result := result + s;\r
+ inc(numread,2);\r
+ exit;\r
+ end else if b < 64 then begin\r
+ if (numread <> 0) and (b <> 0) then result := result + '.';\r
+ for a := start+numread+1 to start+numread+b do begin\r
+ if (a >= len) then begin\r
+ result := '';\r
+ failurereason := 'decoding name: got out of range2';\r
+ exit;\r
+ end;\r
+ result := result + char(arr[a]);\r
+ end;\r
+ inc(numread,b+1);\r
+\r
+ if b = 0 then begin\r
+ if (result = '') and (recursion = 0) then result := '.';\r
+ exit; {reached end of name}\r
+ end;\r
+ end else begin\r
+ failurereason := 'decoding name: read invalid char';\r
+ result := '';\r
+ exit; {invalid}\r
+ end;\r
+ until false;\r
+end;\r
+\r
+{==============================================================================}\r
+\r
+procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);\r
+var\r
+ a:integer;\r
+begin\r
+ state.resultaction := action_done;\r
+ state.resultstr := '';\r
+ case trr(rrp.p^).requesttype of\r
+ querytype_a: begin\r
+ if htons(trr(rrp.p^).datalen) <> 4 then exit;\r
+ move(trr(rrp.p^).data,state.resultbin.ip,4);\r
+ state.resultbin.family :=AF_INET;\r
+ end;\r
+ {$ifdef ipv6}\r
+ querytype_aaaa: begin\r
+ if htons(trr(rrp.p^).datalen) <> 16 then exit;\r
+ state.resultbin.family := AF_INET6;\r
+ move(trr(rrp.p^).data,state.resultbin.ip6,16);\r
+ end;\r
+ {$endif}\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
+ fillchar(state.resultbin,sizeof(state.resultbin),0);\r
+ end;\r
+end;\r
+\r
+procedure setstate_request_init(const name:string;var state:tdnsstate);\r
+begin\r
+ {destroy things properly}\r
+ state.resultstr := '';\r
+ state.queryname := '';\r
+ state.rrdata := '';\r
+ fillchar(state,sizeof(state),0);\r
+ state.queryname := name;\r
+ state.parsepacket := false;\r
+end;\r
+\r
+procedure setstate_forward(const name:string;var state:tdnsstate;family:integer);\r
+begin\r
+ setstate_request_init(name,state);\r
+ state.forwardfamily := family;\r
+ {$ifdef ipv6}\r
+ if family = AF_INET6 then state.requesttype := querytype_aaaa else\r
+ {$endif}\r
+ state.requesttype := querytype_a;\r
+end;\r
+\r
+procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);\r
+begin\r
+ setstate_request_init(makereversename(binip),state);\r
+ state.requesttype := querytype_ptr;\r
+end;\r
+\r
+procedure setstate_failure(var state:tdnsstate);\r
+begin\r
+ state.resultstr := '';\r
+ fillchar(state.resultbin,sizeof(state.resultbin),0);\r
+ state.resultaction := action_done;\r
+end;\r
+\r
+procedure state_process(var state:tdnsstate);\r
+label recursed;\r
+label failure;\r
+var\r
+ a,b,ofs:integer;\r
+ rrtemp:^trr;\r
+ rrptemp:^trrpointer;\r
+begin\r
+ if state.parsepacket then begin\r
+ if state.recvpacketlen < 12 then begin\r
+ failurereason := 'Undersized packet';\r
+ state.resultaction := action_ignore;\r
+ exit;\r
+ end;\r
+ if state.id <> state.recvpacket.id then begin\r
+ failurereason := 'ID mismatch';\r
+ state.resultaction := action_ignore;\r
+ exit;\r
+ end;\r
+ state.numrr2 := 0;\r
+ for a := 0 to 3 do begin\r
+ state.numrr1[a] := htons(state.recvpacket.rrcount[a]);\r
+ if state.numrr1[a] > maxrrofakind then goto failure;\r
+ inc(state.numrr2,state.numrr1[a]);\r
+ end;\r
+\r
+ setlength(state.rrdata,state.numrr2*sizeof(trrpointer));\r
+\r
+ {- put all replies into a list}\r
+\r
+ ofs := 12;\r
+ {get all queries}\r
+ for a := 0 to state.numrr1[0]-1 do begin\r
+ if (ofs < 12) or (ofs > state.recvpacketlen-4) then goto failure;\r
+ rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
+ rrptemp.p := @state.recvpacket.payload[ofs-12];\r
+ rrptemp.ofs := ofs;\r
+ decodename(state.recvpacket,state.recvpacketlen,ofs,0,b);\r
+ rrptemp.len := b + 4;\r
+ inc(ofs,rrptemp.len);\r
+ end;\r
+\r
+ for a := state.numrr1[0] to state.numrr2-1 do begin\r
+ if (ofs < 12) or (ofs > state.recvpacketlen-12) then goto failure;\r
+ rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
+ if decodename(state.recvpacket,state.recvpacketlen,ofs,0,b) = '' then goto failure;\r
+ rrtemp := @state.recvpacket.payload[ofs-12+b]; {rrtemp points to values and result, after initial name}\r
+ rrptemp.p := rrtemp;\r
+ rrptemp.ofs := ofs; {ofs is start of RR before initial name from start of packet}\r
+ rrptemp.namelen := b;\r
+ b := htons(rrtemp.datalen);\r
+ rrptemp.len := b + 10 + rrptemp.namelen;\r
+ inc(ofs,rrptemp.len);\r
+ end;\r
+ if (ofs <> state.recvpacketlen) then begin\r
+ failurereason := 'ofs <> state.packetlen';\r
+ goto failure;\r
+ end;\r
+\r
+ {- check for items of the requested type in answer section, if so return success first}\r
+ for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin\r
+ rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
+ rrtemp := rrptemp.p;\r
+ b := rrptemp.len;\r
+ if rrtemp.requesttype = state.requesttype then begin\r
+ setstate_return(rrptemp^,b,state);\r
+ exit;\r
+ end;\r
+ end;\r
+\r
+ {if no items of correct type found, follow first cname in answer section}\r
+ for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin\r
+ rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
+ rrtemp := rrptemp.p;\r
+ b := rrptemp.len;\r
+ if rrtemp.requesttype = querytype_cname then begin\r
+ state.queryname := decodename(state.recvpacket,state.recvpacketlen,rrptemp.ofs+12,0,b);\r
+ goto recursed;\r
+ end;\r
+ end;\r
+\r
+ {no cnames found, no items of correct type found}\r
+ if state.forwardfamily <> 0 then goto failure;\r
+{$ifdef ipv6}\r
+ if (state.requesttype = querytype_a) then begin\r
+ {v6 only: in case of forward, look for AAAA in alternative section}\r
+ for a := state.numrr1[0]+state.numrr1[1]+state.numrr1[2] to (state.numrr2-1) do begin\r
+ rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
+ rrtemp := rrptemp.p;\r
+ b := rrptemp.len;\r
+ if rrtemp.requesttype = querytype_aaaa then begin\r
+ setstate_return(rrptemp^,b,state);\r
+ exit;\r
+ end;\r
+ end;\r
+ {no AAAA's found in alternative, do a recursive lookup for them}\r
+ state.requesttype := querytype_aaaa;\r
+ goto recursed;\r
+ end;\r
+{$endif}\r
+ goto failure;\r
+recursed:\r
+ {here it needs recursed lookup}\r
+ {if needing to follow a cname, change state to do so}\r
+ inc(state.recursioncount);\r
+ if state.recursioncount > maxrecursion then goto failure;\r
+ end;\r
+\r
+ {here, a name needs to be resolved}\r
+ if state.queryname = '' then begin\r
+ failurereason := 'empty query name';\r
+ goto failure;\r
+ end;\r
+\r
+ {do /ets/hosts lookup here}\r
+ state.sendpacketlen := buildrequest(state.queryname,state.sendpacket,state.requesttype);\r
+ if state.sendpacketlen = 0 then begin\r
+ failurereason := 'building request packet failed';\r
+ goto failure;\r
+ end;\r
+ state.id := state.sendpacket.id;\r
+ state.resultaction := action_sendquery;\r
+\r
+ exit;\r
+failure:\r
+ setstate_failure(state);\r
+end;\r
+{$ifdef win32}\r
+ const\r
+ MAX_HOSTNAME_LEN = 132;\r
+ MAX_DOMAIN_NAME_LEN = 132;\r
+ MAX_SCOPE_ID_LEN = 260 ;\r
+ MAX_ADAPTER_NAME_LENGTH = 260;\r
+ MAX_ADAPTER_ADDRESS_LENGTH = 8;\r
+ MAX_ADAPTER_DESCRIPTION_LENGTH = 132;\r
+ ERROR_BUFFER_OVERFLOW = 111;\r
+ MIB_IF_TYPE_ETHERNET = 6;\r
+ MIB_IF_TYPE_TOKENRING = 9;\r
+ MIB_IF_TYPE_FDDI = 15;\r
+ MIB_IF_TYPE_PPP = 23;\r
+ MIB_IF_TYPE_LOOPBACK = 24;\r
+ MIB_IF_TYPE_SLIP = 28;\r
+\r
+\r
+ type\r
+ tip_addr_string=packed record\r
+ Next :pointer;\r
+ IpAddress : array[0..15] of char;\r
+ ipmask : array[0..15] of char;\r
+ context : dword;\r
+ end;\r
+ pip_addr_string=^tip_addr_string;\r
+ tFIXED_INFO=packed record\r
+ HostName : array[0..MAX_HOSTNAME_LEN-1] of char;\r
+ DomainName : array[0..MAX_DOMAIN_NAME_LEN-1] of char;\r
+ currentdnsserver : pip_addr_string;\r
+ dnsserverlist : tip_addr_string;\r
+ nodetype : longint;\r
+ ScopeId : array[0..MAX_SCOPE_ID_LEN + 4] of char;\r
+ enablerouting : longbool;\r
+ enableproxy : longbool;\r
+ enabledns : longbool;\r
+ end;\r
+ pFIXED_INFO=^tFIXED_INFO;\r
+\r
+ var\r
+ iphlpapi : thandle;\r
+ getnetworkparams : function(pFixedInfo : PFIXED_INFO;OutBufLen : plongint) : longint;stdcall;\r
+{$endif}\r
+procedure populatednsserverlist;\r
+var\r
+ {$ifdef win32}\r
+ fixed_info : pfixed_info;\r
+ fixed_info_len : longint;\r
+ currentdnsserver : pip_addr_string;\r
+ {$else}\r
+ t:textfile;\r
+ s:string;\r
+ a:integer;\r
+ {$endif}\r
+begin\r
+ //result := '';\r
+ if assigned(dnsserverlist) then begin\r
+ dnsserverlist.clear;\r
+ end else begin\r
+ dnsserverlist := tstringlist.Create;\r
+ end;\r
+ {$ifdef win32}\r
+ if iphlpapi=0 then iphlpapi := loadlibrary('iphlpapi.dll');\r
+ if not assigned(getnetworkparams) then @getnetworkparams := getprocaddress(iphlpapi,'GetNetworkParams');\r
+ fixed_info_len := 0;\r
+ if GetNetworkParams(nil,@fixed_info_len)<>ERROR_BUFFER_OVERFLOW then exit;\r
+ //fixed_info_len :=sizeof(tfixed_info);\r
+ getmem(fixed_info,fixed_info_len);\r
+ if GetNetworkParams(fixed_info,@fixed_info_len)<>0 then begin\r
+ freemem(fixed_info);\r
+ exit;\r
+ end;\r
+ currentdnsserver := @(fixed_info.dnsserverlist);\r
+ while assigned(currentdnsserver) do begin\r
+ dnsserverlist.Add(currentdnsserver.IpAddress);\r
+ currentdnsserver := currentdnsserver.next;\r
+ end;\r
+ freemem(fixed_info);\r
+ {$else}\r
+ filemode := 0;\r
+ assignfile(t,'/etc/resolv.conf');\r
+ {$i-}reset(t);{$i+}\r
+ if ioresult <> 0 then exit;\r
+\r
+ while not eof(t) do begin\r
+ readln(t,s);\r
+ if not (copy(s,1,10) = 'nameserver') then continue;\r
+ s := copy(s,11,500);\r
+ while s <> '' do begin\r
+ if (s[1] = #32) or (s[1] = #9) then s := copy(s,2,500) else break;\r
+ end;\r
+ a := pos(' ',s);\r
+ if a <> 0 then s := copy(s,1,a-1);\r
+ a := pos(#9,s);\r
+ if a <> 0 then s := copy(s,1,a-1);\r
+ //result := s;\r
+ //if result <> '' then break;\r
+ dnsserverlist.Add(s);\r
+ end;\r
+ close(t);\r
+ {$endif}\r
+end;\r
+\r
+procedure cleardnsservercache;\r
+begin\r
+ if assigned(dnsserverlist) then begin\r
+ dnsserverlist.destroy;\r
+ dnsserverlist := nil;\r
+ end;\r
+end;\r
+\r
+function getcurrentsystemnameserver(var id:integer):string;\r
+var \r
+ counter : integer;\r
+\r
+begin\r
+ if not assigned(dnsserverlist) then populatednsserverlist;\r
+ if dnsserverlist.count=0 then raise exception.create('no dns servers availible');\r
+ id := 0;\r
+ if dnsserverlist.count >1 then begin\r
+\r
+ for counter := 1 to dnsserverlist.count-1 do begin\r
+ if taddrint(dnsserverlist.objects[counter]) < taddrint(dnsserverlist.objects[id]) then id := counter;\r
+ end;\r
+ end;\r
+ result := dnsserverlist[id]\r
+end;\r
+\r
+procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout\r
+var\r
+ counter : integer;\r
+ temp : integer;\r
+begin\r
+ if (id < 0) or (id >= dnsserverlist.count) then exit;\r
+ if lag = -1 then lag := timeoutlag;\r
+ for counter := 0 to dnsserverlist.count-1 do begin\r
+ temp := taddrint(dnsserverlist.objects[counter]) *15;\r
+ if counter=id then temp := temp + lag;\r
+ dnsserverlist.objects[counter] := tobject(temp div 16);\r
+ end;\r
+\r
+end;\r
+\r
+{ quick and dirty description of dns packet structure to aid writing and\r
+ understanding of parser code, refer to appropriate RFCs for proper specs\r
+- all words are network order\r
+\r
+www.google.com A request:\r
+\r
+0, 2: random transaction ID\r
+2, 2: flags: only the "recursion desired" bit set. (bit 8 of word)\r
+4, 2: questions: 1\r
+6, 2: answer RR's: 0.\r
+8, 2: authority RR's: 0.\r
+10, 2: additional RR's: 0.\r
+12, n: payload:\r
+ query:\r
+ #03 "www" #06 "google" #03 "com" #00\r
+ size-4, 2: type: host address (1)\r
+ size-2, 2: class: inet (1)\r
+\r
+reply:\r
+\r
+0,2: random transaction ID\r
+2,2: flags: set: response (bit 15), recursion desired (8), recursion available (7)\r
+4,4: questions: 1\r
+6,4: answer RR's: 2\r
+8,4: authority RR's: 9\r
+10,4: additional RR's: 9\r
+12: payload:\r
+ query:\r
+ ....\r
+ answer: CNAME\r
+ 0,2 "c0 0c" "name: www.google.com"\r
+ 2,2 "00 05" "type: cname for an alias"\r
+ 4,2 "00 01" "class: inet"\r
+ 6,4: TTL\r
+ 10,2: data length "00 17" (23)\r
+ 12: the cname name (www.google.akadns.net)\r
+ answer: A\r
+ 0,2 ..\r
+ 2,2 "00 01" host address\r
+ 4,2 ...\r
+ 6,4 ...\r
+ 10,2: data length (4)\r
+ 12,4: binary IP\r
+ authority - 9 records\r
+ additional - 9 records\r
+\r
+\r
+ ipv6 AAAA reply:\r
+ 0,2: ...\r
+ 2,2: type: 001c\r
+ 4,2: class: inet (0001)\r
+ 6,2: TTL\r
+ 10,2: data size (16)\r
+ 12,16: binary IP\r
+\r
+ ptr request: query type 000c\r
+\r
+name compression: word "cxxx" in the name, xxx points to offset in the packet}\r
+\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
+unit dnssync;\r
+{$ifdef fpc}\r
+ {$mode delphi}\r
+{$endif}\r
+\r
+interface\r
+ uses\r
+ dnscore,\r
+ binipstuff,\r
+ {$ifdef win32}\r
+ winsock,\r
+ windows,\r
+ {$else}\r
+ {$ifdef VER1_0}\r
+ linux,\r
+ {$else}\r
+ baseunix,unix,\r
+ {$endif}\r
+ sockets,\r
+ fd_utils,\r
+ {$endif}\r
+ sysutils;\r
+\r
+//convert a name to an IP\r
+//IPV4 is preffered if availible, if not IPV6 will be returned (if ipv6 support\r
+//compiled in)\r
+//on error the binip will have a family of 0 (other fiels are also currently\r
+//zeroed out but may be used for further error information in future)\r
+//timeout is in seconds, it is ignored when using windows dns\r
+function forwardlookup(name:string;timeout:integer):tbinip;\r
+\r
+\r
+//convert an IP to a name, on error a null string will be returned, other \r
+//details as above\r
+function reverselookup(ip:tbinip;timeout:integer):string;\r
+\r
+\r
+var\r
+ dnssyncserver:string;\r
+ id : integer;\r
+ {$ifdef win32}\r
+ sendquerytime : integer;\r
+ {$else}\r
+ sendquerytime : ttimeval;\r
+ {$endif}\r
+implementation\r
+{$ifdef win32}\r
+ uses dnswin;\r
+{$endif}\r
+\r
+{$i unixstuff.inc}\r
+{$i ltimevalstuff.inc}\r
+\r
+var\r
+ fd:integer;\r
+ state:tdnsstate;\r
+{$ifdef win32}\r
+ const\r
+ winsocket = 'wsock32.dll';\r
+ function sendto(s: TSocket; const Buf; len, flags: Integer; var addrto: TinetSockAddr; tolen: Integer): Integer; stdcall; external winsocket name 'sendto';\r
+ function bind(s: TSocket; var addr: TinetSockAddr; namelen: Integer): Longbool; stdcall; external winsocket name 'bind';\r
+ type\r
+ fdset=tfdset;\r
+{$endif}\r
+\r
+function sendquery(const packet:tdnspacket;len:integer):boolean;\r
+var\r
+ a:integer;\r
+ addr : string;\r
+ port : string;\r
+ inaddr : TInetSockAddr;\r
+\r
+begin\r
+{ writeln('sendquery ',decodename(state.packet,state.packetlen,12,0,a),' ',state.requesttype);}\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
+\r
+ inAddr.family:=AF_INET;\r
+ inAddr.port:=htons(strtointdef(port,0));\r
+ inAddr.addr:=htonl(longip(addr));\r
+\r
+ sendto(fd,packet,len,0,inaddr,sizeof(inaddr));\r
+ {$ifdef win32}\r
+ sendquerytime := GetTickCount and $3fff;\r
+ {$else}\r
+ gettimeofday(sendquerytime);\r
+ {$endif}\r
+ result := true;\r
+end;\r
+\r
+procedure setupsocket;\r
+var\r
+ inAddrtemp : TInetSockAddr;\r
+begin\r
+ if fd > 0 then exit;\r
+\r
+ fd := Socket(AF_INET,SOCK_DGRAM,0);\r
+ inAddrtemp.family:=AF_INET;\r
+ inAddrtemp.port:=0;\r
+ inAddrtemp.addr:=0;{htonl(longip('0.0.0.0'));}\r
+ If {$ifndef win32}Not{$endif} Bind(fd,inAddrtemp,SizeOf(inAddrtemp)) Then begin\r
+ {$ifdef win32}\r
+ raise Exception.create('unable to bind '+inttostr(WSAGetLastError));\r
+ {$else}\r
+ raise Exception.create('unable to bind '+inttostr(socketError));\r
+ {$endif}\r
+ end;\r
+end;\r
+\r
+procedure resolveloop(timeout:integer);\r
+var\r
+ selectresult : integer;\r
+ fds : fdset;\r
+ {$ifdef win32}\r
+ endtime : longint;\r
+ starttime : longint;\r
+ wrapmode : boolean;\r
+ currenttime : integer;\r
+ {$else}\r
+ endtime : ttimeval;\r
+ currenttime : ttimeval;\r
+\r
+ {$endif}\r
+ lag : ttimeval;\r
+ currenttimeout : ttimeval;\r
+ selecttimeout : ttimeval;\r
+\r
+\r
+begin\r
+ {$ifdef win32}\r
+ starttime := GetTickCount and $3fff;\r
+ endtime := starttime +(timeout*1000);\r
+ if (endtime and $4000)=0 then begin\r
+ wrapmode := false;\r
+ end else begin\r
+ wrapmode := true;\r
+ end;\r
+ endtime := endtime and $3fff;\r
+ {$else}\r
+ gettimeofday(endtime);\r
+ endtime.tv_sec := endtime.tv_sec + timeout;\r
+ {$endif}\r
+\r
+ setupsocket;\r
+ repeat\r
+ state_process(state);\r
+ case state.resultaction of\r
+ action_ignore: begin\r
+{ writeln('ignore');}\r
+ {do nothing}\r
+ end;\r
+ action_done: begin\r
+{ writeln('done');}\r
+ exit;\r
+ //onrequestdone(self,0);\r
+ end;\r
+ action_sendquery:begin\r
+{ writeln('send query');}\r
+ sendquery(state.sendpacket,state.sendpacketlen);\r
+ end;\r
+ end;\r
+ {$ifdef win32}\r
+ currenttime := GetTickCount and $3fff;\r
+ msectotimeval(selecttimeout, (endtime-currenttime)and$3fff);\r
+ {$else}\r
+ gettimeofday(currenttime);\r
+ selecttimeout := endtime;\r
+ tv_substract(selecttimeout,currenttime);\r
+ {$endif}\r
+ fd_zero(fds);\r
+ fd_set(fd,fds);\r
+ if (selecttimeout.tv_sec > 0) or (selecttimeout.tv_usec > retryafter) then begin\r
+ selecttimeout.tv_sec := 0;\r
+ selecttimeout.tv_usec := retryafter;\r
+ end;\r
+ selectresult := select(fd+1,@fds,nil,nil,@selecttimeout);\r
+ if selectresult > 0 then begin\r
+{ writeln('selectresult>0');}\r
+ //why the hell are we zeroing out the packet buffer before reading into it?! --plugwash\r
+ fillchar(state.recvpacket,sizeof(state.recvpacket),0);\r
+ {$ifdef win32}\r
+ msectotimeval(lag,(currenttime-sendquerytime)and$3fff);\r
+ {$else}\r
+ lag := currenttime;\r
+ tv_substract(lag,sendquerytime);\r
+\r
+ {$endif}\r
+\r
+ reportlag(id,(lag.tv_sec*1000000)+lag.tv_usec);\r
+ state.recvpacketlen := recv(fd,state.recvpacket, SizeOf(state.recvpacket),0);\r
+ state.parsepacket := true;\r
+ end;\r
+ if selectresult < 0 then exit;\r
+ if selectresult = 0 then begin\r
+ {$ifdef win32}\r
+ currenttime := GetTickCount;\r
+ {$else}\r
+ gettimeofday(currenttime);\r
+ {$endif}\r
+ reportlag(id,-1);\r
+ if {$ifdef win32}(currenttime >= endtime)and ((not wrapmode) or (currenttime < starttime)) {$else}tv_compare(currenttime,endtime){$endif} {currenttime >= endtime } then begin\r
+ exit;\r
+ end else begin\r
+ //resend\r
+ sendquery(state.sendpacket,state.sendpacketlen);\r
+ end;\r
+ end;\r
+ until false;\r
+end;\r
+\r
+function forwardlookup(name:string;timeout:integer):tbinip;\r
+var\r
+ dummy : integer;\r
+begin\r
+ ipstrtobin(name,result);\r
+ if result.family <> 0 then exit; //it was an IP address, no need for dns\r
+ //lookup\r
+ {$ifdef win32}\r
+ if usewindns then begin\r
+ result := winforwardlookup(name,false,dummy);\r
+ exit;\r
+ end;\r
+ {$endif}\r
+ setstate_forward(name,state,0);\r
+ resolveloop(timeout);\r
+ result := state.resultbin;\r
+end;\r
+\r
+function reverselookup(ip:tbinip;timeout:integer):string;\r
+var\r
+ dummy : integer;\r
+begin\r
+ {$ifdef win32}\r
+ if usewindns then begin\r
+ result := winreverselookup(ip,dummy);\r
+ exit;\r
+ end;\r
+ {$endif}\r
+ setstate_reverse(ip,state);\r
+ resolveloop(timeout);\r
+ result := state.resultstr;\r
+end;\r
+\r
+{$ifdef win32}\r
+ var\r
+ wsadata : twsadata;\r
+\r
+ initialization\r
+ WSAStartUp($2,wsadata);\r
+ finalization\r
+ WSACleanUp;\r
+{$endif}\r
+end.\r
+\r
+\r
--- /dev/null
+unit dnswin;\r
+\r
+interface\r
+uses binipstuff,classes,lcore;\r
+\r
+//on failure a null string or zeroed out binip will be retuned and error will be\r
+//set to a windows error code (error will be left untouched under non error\r
+//conditions).\r
+function winforwardlookup(name : string;ipv6preffered : boolean;var error:integer) : tbinip;\r
+function winreverselookup(ip:tbinip;var error:integer):string;\r
+\r
+\r
+type\r
+ //do not call destroy on a tdnswinasync instead call release and the\r
+ //dnswinasync will be freed when appropriate. Calling destroy will block\r
+ //the calling thread until the dns lookup completes.\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
+ hadevent : boolean;\r
+ protected\r
+ procedure execute; override;\r
+ public\r
+ onrequestdone:tsocketevent;\r
+ name : string;\r
+ ip : tbinip;\r
+\r
+ procedure forwardlookup(name:string;ipv6preffered:boolean);\r
+ procedure reverselookup(ip:tbinip);\r
+ destructor destroy; override;\r
+ procedure release;\r
+ constructor create;\r
+ property reverse : boolean read freverse;\r
+\r
+ end;\r
+\r
+implementation\r
+uses\r
+ lsocket,pgtypes,sysutils,winsock,windows,messages;\r
+\r
+type\r
+ //taddrinfo = record; //forward declaration\r
+ paddrinfo = ^taddrinfo;\r
+ taddrinfo = packed record\r
+ ai_flags : longint;\r
+ ai_family : longint;\r
+ ai_socktype : longint;\r
+ ai_protocol : longint;\r
+ ai_addrlen : taddrint;\r
+ ai_canonname : pchar;\r
+ ai_addr : pinetsockaddrv;\r
+ ai_next : paddrinfo;\r
+ end;\r
+ ppaddrinfo = ^paddrinfo;\r
+ tgetaddrinfo = function(nodename : pchar; servname : pchar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall;\r
+ tfreeaddrinfo = procedure(ai : paddrinfo); stdcall;\r
+ tgetnameinfo = function(sa:Pinetsockaddrv;salen : longint; host:pchar;hostlen : longint;serv:pchar;servlen:longint;flags:longint) : longint;stdcall;\r
+var\r
+ getaddrinfo : tgetaddrinfo;\r
+ freeaddrinfo : tfreeaddrinfo;\r
+ getnameinfo : tgetnameinfo;\r
+procedure v4onlyfreeaddrinfo(ai : paddrinfo); stdcall;\r
+begin\r
+ freemem(ai.ai_addr);\r
+ freemem(ai);\r
+end;\r
+\r
+type\r
+ plongint = ^longint;\r
+ pplongint = ^plongint;\r
+\r
+function v4onlygetaddrinfo(nodename : pchar; servname : pchar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall;\r
+var\r
+ output : paddrinfo;\r
+ hostent : phostent;\r
+begin\r
+ if hints.ai_family = af_inet then begin\r
+ result := 0;\r
+ getmem(output,sizeof(taddrinfo));\r
+ getmem(output.ai_addr,sizeof(tinetsockaddr));\r
+ output.ai_addr.InAddr.family := af_inet;\r
+ if servname <> nil then output.ai_addr.InAddr.port := htons(strtoint(servname)) else output.ai_addr.InAddr.port := 0;\r
+ hostent := gethostbyname(nodename);\r
+ if hostent = nil then begin\r
+ result := wsagetlasterror;\r
+ v4onlyfreeaddrinfo(output);\r
+ exit;\r
+ end;\r
+ output.ai_addr.InAddr.addr := pplongint(hostent.h_addr_list)^^;\r
+ output.ai_flags := 0;\r
+ output.ai_family := af_inet;\r
+ output.ai_socktype := 0;\r
+ output.ai_protocol := 0;\r
+ output.ai_addrlen := sizeof(tinetsockaddr);\r
+ output.ai_canonname := nil;\r
+ output.ai_next := nil;\r
+\r
+ res^ := output;\r
+ end else begin\r
+ result := WSANO_RECOVERY;\r
+ end;\r
+end;\r
+\r
+function min(a,b : integer):integer;\r
+begin\r
+ if a<b then result := a else result := b;\r
+end;\r
+\r
+function v4onlygetnameinfo(sa:Pinetsockaddrv;salen : longint; host:pchar;hostlen : longint;serv:pchar;servlen:longint;flags:longint) : longint;stdcall;\r
+var\r
+ hostent : phostent;\r
+ bytestocopy : integer;\r
+begin\r
+ if sa.InAddr.family = af_inet then begin\r
+ result := 0;\r
+ hostent := gethostbyaddr(@(sa.inaddr.addr),4,AF_INET);\r
+ if hostent = nil then begin\r
+ result := wsagetlasterror;\r
+ exit;\r
+ end;\r
+ bytestocopy := min(strlen(hostent.h_name)+1,hostlen);\r
+ move((hostent.h_name)^,host^,bytestocopy);\r
+\r
+\r
+ end else begin\r
+ result := WSANO_RECOVERY;\r
+ end;\r
+end;\r
+\r
+\r
+procedure populateprocvars;\r
+var\r
+ libraryhandle : hmodule;\r
+ i : integer;\r
+ dllname : string;\r
+\r
+begin\r
+ if assigned(getaddrinfo) then exit; //procvars already populated\r
+ for i := 0 to 1 do begin\r
+ if i=0 then dllname := 'Ws2_32.dll' else dllname := 'Wship6.dll';\r
+ libraryhandle := LoadLibrary(pchar(dllname));\r
+ getaddrinfo := getprocaddress(libraryhandle,'getaddrinfo');\r
+ freeaddrinfo := getprocaddress(libraryhandle,'freeaddrinfo');\r
+ getnameinfo := getprocaddress(libraryhandle,'getnameinfo');\r
+ if assigned(getaddrinfo) and assigned(freeaddrinfo) and assigned(getnameinfo) then begin\r
+ //writeln('found getaddrinfo and freeaddrinfo in'+dllname);\r
+ exit; //success\r
+ end;\r
+\r
+ end;\r
+ //writeln('could not find getaddrinfo and freeaddrinfo, falling back to ipv4 only lookup');\r
+ getaddrinfo := v4onlygetaddrinfo;\r
+ freeaddrinfo := v4onlyfreeaddrinfo;\r
+ getnameinfo := v4onlygetnameinfo;\r
+end;\r
+\r
+\r
+function winforwardlookup(name : string;ipv6preffered : boolean;var error : integer) : tbinip;\r
+var\r
+ hints: taddrinfo;\r
+ res : paddrinfo;\r
+ pass : boolean;\r
+ ipv6 : boolean;\r
+ getaddrinforesult : integer;\r
+begin\r
+ populateprocvars;\r
+\r
+ for pass := false to true do begin\r
+ ipv6 := ipv6preffered xor pass;\r
+ hints.ai_flags := 0;\r
+ if ipv6 then begin\r
+ hints.ai_family := AF_INET6;\r
+ end else begin\r
+ hints.ai_family := AF_INET;\r
+ end;\r
+ hints.ai_socktype := 0;\r
+ hints.ai_protocol := 0;\r
+ hints.ai_addrlen := 0;\r
+ hints.ai_canonname := nil;\r
+ hints.ai_addr := nil;\r
+ hints.ai_next := nil;\r
+ getaddrinforesult := getaddrinfo(pchar(name),'1',@hints,@res);\r
+ if getaddrinforesult = 0 then begin\r
+ if res.ai_family = af_inet then begin\r
+ result.family := af_inet;\r
+ result.ip := res.ai_addr.InAddr.addr;\r
+ end else if res.ai_family = af_inet6 then begin\r
+ result.family := af_inet6;\r
+ result.ip6 := res.ai_addr.InAddr6.sin6_addr;\r
+ end;\r
+\r
+ freeaddrinfo(res);\r
+ exit;\r
+ end;\r
+ end;\r
+ if getaddrinforesult <> 0 then begin\r
+ fillchar(result,0,sizeof(result));\r
+ error := getaddrinforesult;\r
+ end;\r
+end;\r
+\r
+function winreverselookup(ip:tbinip;var error : integer):string;\r
+var\r
+ sa : tinetsockaddrv;\r
+ getnameinforesult : integer;\r
+begin\r
+\r
+ if ip.family = AF_INET then begin\r
+ sa.InAddr.family := AF_INET;\r
+ sa.InAddr.port := 1;\r
+ sa.InAddr.addr := ip.ip;\r
+ end else if ip.family = AF_INET6 then begin\r
+ sa.InAddr6.sin6_family := AF_INET6;\r
+ sa.InAddr6.sin6_port := 1;\r
+ sa.InAddr6.sin6_addr := ip.ip6;\r
+ end else begin\r
+ raise exception.create('unrecognised address family');\r
+ end;\r
+ populateprocvars;\r
+ setlength(result,1025);\r
+ getnameinforesult := getnameinfo(@sa,sizeof(tinetsockaddrv),pchar(result),length(result),nil,0,0);\r
+ if getnameinforesult <> 0 then begin\r
+ error := getnameinforesult;\r
+ result := '';\r
+ exit;\r
+ end;\r
+ if pos(#0,result) >= 0 then begin\r
+ setlength(result,pos(#0,result)-1);\r
+ end;\r
+end;\r
+\r
+var\r
+ hwnddnswin : hwnd;\r
+\r
+function MyWindowProc(\r
+ ahWnd : HWND;\r
+ auMsg : Integer;\r
+ awParam : WPARAM;\r
+ alParam : LPARAM): Integer; stdcall;\r
+var\r
+ dwas : tdnswinasync;\r
+begin\r
+ if (ahwnd=hwnddnswin) and (aumsg=wm_user) then begin\r
+ Dwas := tdnswinasync(alparam);\r
+ dwas.hadevent := true;\r
+ if assigned (dwas.onrequestdone) then dwas.onrequestdone(dwas,awparam);\r
+ if dwas.freewhendone then dwas.free;\r
+ end else begin\r
+ //not passing unknown messages on to defwindowproc will cause window\r
+ //creation to fail! --plugwash\r
+ Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)\r
+ end;\r
+end;\r
+\r
+procedure tdnswinasync.forwardlookup(name:string;ipv6preffered:boolean);\r
+begin\r
+ self.name := name;\r
+ self.ipv6preffered := ipv6preffered;\r
+ freverse := false;\r
+ resume;\r
+end;\r
+procedure tdnswinasync.reverselookup(ip:tbinip);\r
+begin\r
+ self.ip := ip;\r
+ freverse := true;\r
+ resume;\r
+end;\r
+procedure tdnswinasync.execute;\r
+var\r
+ error : integer;\r
+begin\r
+ error := 0;\r
+ if reverse then begin\r
+ name := winreverselookup(ip,error);\r
+ end else begin\r
+ ip := winforwardlookup(name,ipv6preffered,error);\r
+\r
+ end;\r
+\r
+ postmessage(hwnddnswin,wm_user,error,taddrint(self));\r
+end;\r
+\r
+destructor tdnswinasync.destroy; \r
+begin\r
+ WaitFor;\r
+ inherited destroy;\r
+end;\r
+procedure tdnswinasync.release;\r
+begin\r
+ if hadevent then destroy else begin\r
+ onrequestdone := nil;\r
+ freewhendone := true;\r
+ end;\r
+end;\r
+\r
+constructor tdnswinasync.create;\r
+begin\r
+ inherited create(true);\r
+end;\r
+\r
+var\r
+ MyWindowClass : TWndClass = (style : 0;\r
+ lpfnWndProc : @MyWindowProc;\r
+ cbClsExtra : 0;\r
+ cbWndExtra : 0;\r
+ hInstance : 0;\r
+ hIcon : 0;\r
+ hCursor : 0;\r
+ hbrBackground : 0;\r
+ lpszMenuName : nil;\r
+ lpszClassName : 'dnswinClass');\r
+begin\r
+\r
+ if Windows.RegisterClass(MyWindowClass) = 0 then halt;\r
+ //writeln('about to create lcore handle, hinstance=',hinstance);\r
+ hwnddnswin := CreateWindowEx(WS_EX_TOOLWINDOW,\r
+ MyWindowClass.lpszClassName,\r
+ '', { Window name }\r
+ WS_POPUP, { Window Style }\r
+ 0, 0, { X, Y }\r
+ 0, 0, { Width, Height }\r
+ 0, { hWndParent }\r
+ 0, { hMenu }\r
+ HInstance, { hInstance }\r
+ nil); { CreateParam }\r
+ //writeln('dnswin hwnd is ',hwnddnswin);\r
+ //writeln('last error is ',GetLastError);\r
+end.\r
--- /dev/null
+// this file contains code copied from linux.pp in the free pascal rtl\r
+// i had to copy them because i use a different definition of fdset to them\r
+// the copyright block from the file in question is shown below\r
+{\r
+ $Id: fd_utils.pas,v 1.2 2004/08/19 23:12:09 plugwash Exp $\r
+ This file is part of the Free Pascal run time library.\r
+ Copyright (c) 1999-2000 by Michael Van Canneyt,\r
+ BSD parts (c) 2000 by Marco van de Voort\r
+ members of the Free Pascal development team.\r
+\r
+ See the file COPYING.FPC, included in this distribution,\r
+ for details about the copyright.\r
+\r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY;without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\r
+\r
+**********************************************************************}\r
+{$ifdef fpc}\r
+ {$mode delphi}\r
+ {$inlining on}\r
+{$endif}\r
+unit fd_utils;\r
+interface\r
+\r
+type\r
+ FDSet= Array [0..255] of longint; {31}\r
+ PFDSet= ^FDSet;\r
+const\r
+ absoloutemaxs=(sizeof(fdset)*8)-1;\r
+\r
+Procedure FD_Clr(fd:longint;var fds:fdSet);\r
+Procedure FD_Zero(var fds:fdSet);\r
+Procedure FD_Set(fd:longint;var fds:fdSet);\r
+Function FD_IsSet(fd:longint;var fds:fdSet):boolean;\r
+\r
+\r
+implementation \r
+uses sysutils;\r
+Procedure FD_Clr(fd:longint;var fds:fdSet);{$ifdef fpc}inline;{$endif}\r
+{ Remove fd from the set of filedescriptors}\r
+begin\r
+ if (fd < 0) then raise exception.create('FD_Clr fd out of range: '+inttostr(fd));\r
+ fds[fd shr 5]:=fds[fd shr 5] and (not (1 shl (fd and 31)));\r
+end;\r
+\r
+Procedure FD_Zero(var fds:fdSet);\r
+{ Clear the set of filedescriptors }\r
+begin\r
+ FillChar(fds,sizeof(fdSet),0);\r
+end;\r
+\r
+Procedure FD_Set(fd:longint;var fds:fdSet);{$ifdef fpc}inline;{$endif}\r
+{ Add fd to the set of filedescriptors }\r
+begin\r
+ if (fd < 0) then raise exception.create('FD_set fd out of range: '+inttostr(fd));\r
+ fds[fd shr 5]:=fds[fd shr 5] or (1 shl (fd and 31));\r
+end;\r
+\r
+Function FD_IsSet(fd:longint;var fds:fdSet):boolean;{$ifdef fpc}inline;{$endif}\r
+{ Test if fd is part of the set of filedescriptors }\r
+begin\r
+ if (fd < 0) then begin\r
+ result := false;\r
+ exit;\r
+ end;\r
+ FD_IsSet:=((fds[fd shr 5] and (1 shl (fd and 31)))<>0);\r
+end;\r
+end.\r
--- /dev/null
+{lsocket.pas}\r
+\r
+{io and timer code by plugwash}\r
+\r
+{ 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
+{note: you must use the @ in the last param to tltask.create not doing so will\r
+ compile without error but will cause an access violation -pg}\r
+\r
+//note: events after release are normal and are the apps responsibility to deal with safely\r
+\r
+unit lcore;\r
+{$ifdef fpc}\r
+ {$mode delphi}\r
+{$endif}\r
+{$ifdef win32}\r
+ {$define nosignal}\r
+{$endif}\r
+interface\r
+ uses\r
+ sysutils,\r
+ {$ifndef win32}\r
+ {$ifdef VER1_0}\r
+ linux,\r
+ {$else}\r
+ baseunix,unix,\r
+ {$endif}\r
+ fd_utils,\r
+ {$endif}\r
+ classes,pgtypes,bfifo;\r
+ procedure processtasks;\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+ const\r
+ receivebufsize=1460;\r
+\r
+ type\r
+ {$ifdef ver1_0}\r
+ sigset= array[0..31] of longint;\r
+ {$endif}\r
+\r
+ ESocketException = class(Exception);\r
+ TBgExceptionEvent = procedure (Sender : TObject;\r
+ E : Exception;\r
+ var CanClose : Boolean) of object;\r
+\r
+ // note : tsocketstate is defined in the same way as it is in François PIETTE's twsocket\r
+ // however tlsocket currently only uses wsClosed wsConnecting wsconnected and wsListening\r
+ TSocketState = (wsInvalidState,\r
+ wsOpened, wsBound,\r
+ wsConnecting, wsConnected,\r
+ wsAccepting, wsListening,\r
+ wsClosed);\r
+\r
+ TWSocketOption = (wsoNoReceiveLoop, wsoTcpNoDelay);\r
+ TWSocketOptions = set of TWSocketOption;\r
+\r
+ TSocketevent = procedure(Sender: TObject; Error: word) of object;\r
+ //Tdataavailevent = procedure(data : string);\r
+ TSendData = procedure (Sender: TObject; BytesSent: Integer) of object;\r
+\r
+ tlcomponent = class(tcomponent)\r
+ public\r
+ released:boolean;\r
+ procedure release; virtual;\r
+ destructor destroy; override;\r
+ end;\r
+\r
+ tlasio = class(tlcomponent)\r
+ public\r
+ state : tsocketstate ;\r
+ ComponentOptions : TWSocketOptions;\r
+ fdhandlein : Longint ; {file discriptor}\r
+ fdhandleout : Longint ; {file discriptor}\r
+\r
+ onsessionclosed : tsocketevent ;\r
+ ondataAvailable : tsocketevent ;\r
+ onsessionAvailable : tsocketevent ;\r
+\r
+ onsessionconnected : tsocketevent ;\r
+ onsenddata : tsenddata ;\r
+ ondatasent : tsocketevent ;\r
+ //connected : boolean ;\r
+ nextasin : tlasio ;\r
+ prevasin : tlasio ;\r
+\r
+ recvq : tfifo;\r
+ OnBgException : TBgExceptionEvent ;\r
+ //connectread : boolean ;\r
+ sendq : tfifo;\r
+ closehandles : boolean ;\r
+ writtenthiscycle : boolean ;\r
+ onfdwrite : procedure (Sender: TObject; Error: word) of object; //added for bewarehttpd\r
+ lasterror:integer;\r
+ destroying:boolean;\r
+ function receivestr:string; virtual;\r
+ procedure close;\r
+ procedure abort;\r
+ procedure internalclose(error:word); virtual;\r
+ constructor Create(AOwner: TComponent); override;\r
+\r
+ destructor destroy; override;\r
+ procedure fdcleanup;\r
+ procedure HandleBackGroundException(E: Exception);\r
+ procedure handlefdtrigger(readtrigger,writetrigger:boolean); virtual;\r
+ procedure dup(invalue:longint);\r
+\r
+ function sendflush : integer;\r
+ procedure sendstr(const str : string);virtual;\r
+ procedure putstringinsendbuffer(const newstring : string);\r
+ function send(data:pointer;len:integer):integer;virtual;\r
+ procedure putdatainsendbuffer(data:pointer;len:integer); virtual;\r
+ procedure deletebuffereddata;\r
+\r
+ //procedure messageloop;\r
+ function Receive(Buf:Pointer;BufSize:integer):integer; virtual;\r
+ procedure flush;virtual;{$ifdef win32} abstract;{$endif}\r
+ procedure dodatasent(wparam,lparam:longint);\r
+ procedure doreceiveloop(wparam,lparam:longint);\r
+ procedure sinkdata(sender:tobject;error:word);\r
+\r
+ procedure release; override; {test -beware}\r
+\r
+ function RealSend(Data : Pointer; Len : Integer) : Integer; //added for bewarehttpd\r
+\r
+ procedure myfdclose(fd : integer); virtual;{$ifdef win32}abstract;{$endif}\r
+ function myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt; virtual;{$ifdef win32}abstract;{$endif}\r
+ function myfdread(fd: LongInt;var buf;size: LongInt):LongInt; virtual;{$ifdef win32}abstract;{$endif}\r
+ protected\r
+ procedure dupnowatch(invalue:longint);\r
+ end;\r
+ ttimerwrapperinterface=class(tlcomponent)\r
+ public\r
+ function createwrappedtimer : tobject;virtual;abstract;\r
+// procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);virtual;abstract;\r
+ procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);virtual;abstract;\r
+ procedure setenabled(wrappedtimer : tobject;newvalue : boolean);virtual;abstract;\r
+ procedure setinterval(wrappedtimer : tobject;newvalue : integer);virtual;abstract;\r
+ end;\r
+\r
+ var\r
+ timerwrapperinterface : ttimerwrapperinterface;\r
+ type\r
+ {$ifdef win32}\r
+ ttimeval = record\r
+ tv_sec : longint;\r
+ tv_usec : longint;\r
+ end;\r
+ {$endif}\r
+ tltimer=class(tlcomponent)\r
+ protected\r
+\r
+\r
+ wrappedtimer : tobject;\r
+\r
+\r
+// finitialevent : boolean ;\r
+ fontimer : tnotifyevent ;\r
+ fenabled : boolean ;\r
+ finterval : integer ; {miliseconds, default 1000}\r
+ {$ifndef win32}\r
+ procedure resettimes;\r
+ {$endif}\r
+// procedure setinitialevent(newvalue : boolean);\r
+ procedure setontimer(newvalue:tnotifyevent);\r
+ procedure setenabled(newvalue : boolean);\r
+ procedure setinterval(newvalue : integer);\r
+ public\r
+ //making theese public for now, this code should probablly be restructured later though\r
+ prevtimer : tltimer ;\r
+ nexttimer : tltimer ;\r
+ nextts : ttimeval ;\r
+\r
+ constructor create(aowner:tcomponent);override;\r
+ destructor destroy;override;\r
+// property initialevent : boolean read finitialevent write setinitialevent;\r
+ property ontimer : tnotifyevent read fontimer write setontimer;\r
+ property enabled : boolean read fenabled write setenabled;\r
+ property interval : integer read finterval write setinterval;\r
+\r
+ end;\r
+\r
+ ttaskevent=procedure(wparam,lparam:longint) of object;\r
+\r
+ tltask=class(tobject)\r
+ public\r
+ handler : ttaskevent;\r
+ obj : tobject;\r
+ wparam : longint;\r
+ lparam : longint;\r
+ nexttask : tltask;\r
+ constructor create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+ end;\r
+\r
+\r
+\r
+ teventcore=class\r
+ public\r
+ procedure processmessages; virtual;abstract;\r
+ procedure messageloop; virtual;abstract;\r
+ procedure exitmessageloop; virtual;abstract;\r
+ procedure setfdreverse(fd : integer;reverseto : tlasio);virtual;abstract;\r
+ procedure rmasterset(fd : integer;islistensocket : boolean); virtual;abstract;\r
+ procedure rmasterclr(fd: integer); virtual;abstract;\r
+ procedure wmasterset(fd : integer); virtual;abstract;\r
+ procedure wmasterclr(fd: integer); virtual;abstract;\r
+ end;\r
+var\r
+ eventcore : teventcore;\r
+\r
+procedure processmessages;\r
+procedure messageloop;\r
+procedure exitmessageloop;\r
+\r
+var\r
+ firstasin : tlasio ;\r
+ firsttimer : tltimer ;\r
+ firsttask , lasttask , currenttask : tltask ;\r
+\r
+ numread : integer ;\r
+ mustrefreshfds : boolean ;\r
+{ lcoretestcount:integer;}\r
+\r
+ asinreleaseflag:boolean;\r
+\r
+\r
+procedure disconnecttasks(aobj:tobject);\r
+procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+type\r
+ tonaddtask = procedure(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+var\r
+ onaddtask : tonaddtask;\r
+\r
+\r
+procedure sleep(i:integer);\r
+{$ifndef nosignal}\r
+ procedure prepsigpipe;inline;\r
+{$endif}\r
+\r
+\r
+implementation\r
+{$ifndef nosignal}\r
+ uses {sockets,}lloopback,lsignal;\r
+{$endif}\r
+{$ifdef win32}\r
+ uses windows;\r
+{$endif}\r
+{$ifndef win32}\r
+ {$include unixstuff.inc}\r
+{$endif}\r
+{$include ltimevalstuff.inc}\r
+\r
+\r
+{!!! added sleep call -beware}\r
+procedure sleep(i:integer);\r
+var\r
+ tv:ttimeval;\r
+begin\r
+ {$ifdef win32}\r
+ windows.sleep(i);\r
+ {$else}\r
+ tv.tv_sec := i div 1000;\r
+ tv.tv_usec := (i mod 1000) * 1000;\r
+ select(0,nil,nil,nil,@tv);\r
+ {$endif}\r
+end;\r
+\r
+destructor tlcomponent.destroy;\r
+begin\r
+ disconnecttasks(self);\r
+ inherited destroy;\r
+end;\r
+\r
+\r
+\r
+\r
+procedure tlcomponent.release;\r
+begin\r
+ released := true;\r
+end;\r
+\r
+procedure tlasio.release;\r
+begin\r
+ asinreleaseflag := true;\r
+ inherited release;\r
+end;\r
+\r
+procedure tlasio.doreceiveloop;\r
+begin\r
+ if recvq.size = 0 then exit;\r
+ if assigned(ondataavailable) then ondataavailable(self,0);\r
+ if not (wsonoreceiveloop in componentoptions) then\r
+ if recvq.size > 0 then tltask.create(self.doreceiveloop,self,0,0);\r
+end;\r
+\r
+function tlasio.receivestr;\r
+begin\r
+ setlength(result,recvq.size);\r
+ receive(@result[1],length(result));\r
+end;\r
+\r
+function tlasio.receive(Buf:Pointer;BufSize:integer):integer;\r
+var\r
+ i,a,b:integer;\r
+ p:pointer;\r
+begin\r
+ i := bufsize;\r
+ if recvq.size < i then i := recvq.size;\r
+ a := 0;\r
+ while (a < i) do begin\r
+ b := recvq.get(p,i-a);\r
+ move(p^,buf^,b);\r
+ inc(taddrint(buf),b);\r
+ recvq.del(b);\r
+ inc(a,b);\r
+ end;\r
+ result := i;\r
+ if wsonoreceiveloop in componentoptions then begin\r
+ if recvq.size = 0 then eventcore.rmasterset(fdhandlein,false);\r
+ end;\r
+end;\r
+\r
+constructor tlasio.create;\r
+begin\r
+ inherited create(AOwner);\r
+ sendq := tfifo.create;\r
+ recvq := tfifo.create;\r
+ state := wsclosed;\r
+ fdhandlein := -1;\r
+ fdhandleout := -1;\r
+ nextasin := firstasin;\r
+ prevasin := nil;\r
+ if assigned(nextasin) then nextasin.prevasin := self;\r
+ firstasin := self;\r
+\r
+ released := false;\r
+end;\r
+\r
+destructor tlasio.destroy;\r
+begin\r
+ destroying := true;\r
+ if state <> wsclosed then close;\r
+ if prevasin <> nil then begin\r
+ prevasin.nextasin := nextasin;\r
+ end else begin\r
+ firstasin := nextasin;\r
+ end;\r
+ if nextasin <> nil then begin\r
+ nextasin.prevasin := prevasin;\r
+ end;\r
+ recvq.destroy;\r
+ sendq.destroy;\r
+ inherited destroy;\r
+end;\r
+\r
+procedure tlasio.close;\r
+begin\r
+ internalclose(0);\r
+end;\r
+\r
+procedure tlasio.abort;\r
+begin\r
+ close;\r
+end;\r
+\r
+procedure tlasio.fdcleanup;\r
+begin\r
+ if fdhandlein <> -1 then begin\r
+ eventcore.rmasterclr(fdhandlein); //fd_clr(fdhandlein,fdsrmaster)\r
+ end;\r
+ if fdhandleout <> -1 then begin\r
+ eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster)\r
+ end;\r
+ if fdhandlein=fdhandleout then begin\r
+ if fdhandlein <> -1 then begin\r
+ myfdclose(fdhandlein);\r
+ end;\r
+ end else begin\r
+ if fdhandlein <> -1 then begin\r
+ myfdclose(fdhandlein);\r
+ end;\r
+ if fdhandleout <> -1 then begin\r
+ myfdclose(fdhandleout);\r
+ end;\r
+ end;\r
+ fdhandlein := -1;\r
+ fdhandleout := -1;\r
+end;\r
+\r
+procedure tlasio.internalclose(error:word);\r
+begin\r
+ if state<>wsclosed then begin\r
+ if (fdhandlein < 0) or (fdhandleout < 0) then raise exception.create('internalclose called with invalid fd handles');\r
+ eventcore.rmasterclr(fdhandlein);//fd_clr(fdhandlein,fdsrmaster);\r
+ eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
+\r
+ if closehandles then begin\r
+ {$ifndef win32}\r
+ //anyone remember why this is here? --plugwash\r
+ fcntl(fdhandlein,F_SETFL,0);\r
+ {$endif}\r
+ myfdclose(fdhandlein);\r
+ if fdhandleout <> fdhandlein then begin\r
+ {$ifndef win32}\r
+ fcntl(fdhandleout,F_SETFL,0);\r
+ {$endif}\r
+ myfdclose(fdhandleout);\r
+ end;\r
+ eventcore.setfdreverse(fdhandlein,nil);\r
+ eventcore.setfdreverse(fdhandleout,nil);\r
+\r
+ fdhandlein := -1;\r
+ fdhandleout := -1;\r
+ end;\r
+ state := wsclosed;\r
+\r
+ if assigned(onsessionclosed) then if not destroying then onsessionclosed(self,error);\r
+ end;\r
+ sendq.del(maxlongint);\r
+end;\r
+\r
+\r
+{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}\r
+{ All exceptions *MUST* be handled. If an exception is not handled, the }\r
+{ application will most likely be shut down ! }\r
+procedure tlasio.HandleBackGroundException(E: Exception);\r
+var\r
+ CanAbort : Boolean;\r
+begin\r
+ CanAbort := TRUE;\r
+ { First call the error event handler, if any }\r
+ if Assigned(OnBgException) then begin\r
+ try\r
+ OnBgException(Self, E, CanAbort);\r
+ except\r
+ end;\r
+ end;\r
+ { Then abort the socket }\r
+ if CanAbort then begin\r
+ try\r
+ close;\r
+ except\r
+ end;\r
+ end;\r
+end;\r
+\r
+procedure tlasio.sendstr(const str : string);\r
+begin\r
+ putstringinsendbuffer(str);\r
+ sendflush;\r
+end;\r
+\r
+procedure tlasio.putstringinsendbuffer(const newstring : string);\r
+begin\r
+ if newstring <> '' then putdatainsendbuffer(@newstring[1],length(newstring));\r
+end;\r
+\r
+function tlasio.send(data:pointer;len:integer):integer;\r
+begin\r
+ if state <> wsconnected then begin\r
+ result := -1;\r
+ exit;\r
+ end;\r
+ if len < 0 then len := 0;\r
+ result := len;\r
+ putdatainsendbuffer(data,len);\r
+ sendflush;\r
+end;\r
+\r
+\r
+procedure tlasio.putdatainsendbuffer(data:pointer;len:integer);\r
+begin\r
+ sendq.add(data,len);\r
+end;\r
+\r
+function tlasio.sendflush : integer;\r
+var\r
+ lensent : integer;\r
+ data:pointer;\r
+// fdstestr : fdset;\r
+// fdstestw : fdset;\r
+begin\r
+ if state <> wsconnected then exit;\r
+\r
+ lensent := sendq.get(data,2920);\r
+ if assigned(data) then result := myfdwrite(fdhandleout,data^,lensent) else result := 0;\r
+\r
+ if result = -1 then lensent := 0 else lensent := result;\r
+\r
+ //sendq := copy(sendq,lensent+1,length(sendq)-lensent);\r
+ sendq.del(lensent);\r
+\r
+ //fd_clr(fdhandleout,fdsw); // this prevents the socket being closed by a write\r
+ // that sends nothing because a previous socket has\r
+ // slready flushed this socket when the message loop\r
+ // reaches it\r
+// if sendq.size > 0 then begin\r
+ eventcore.wmasterset(fdhandleout);//fd_set(fdhandleout,fdswmaster);\r
+// end else begin\r
+// wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
+// end;\r
+ if result > 0 then begin\r
+ if assigned(onsenddata) then onsenddata(self,result);\r
+// if sendq.size=0 then if assigned(ondatasent) then begin\r
+// tltask.create(self.dodatasent,self,0,0);\r
+// //begin test code\r
+// fd_zero(fdstestr);\r
+// fd_zero(fdstestw);\r
+// fd_set(fdhandlein,fdstestr);\r
+// fd_set(fdhandleout,fdstestw);\r
+// select(maxs,@fdstestr,@fdstestw,nil,0);\r
+// writeln(fd_isset(fdhandlein,fdstestr),' ',fd_isset(fdhandleout,fdstestw));\r
+// //end test code\r
+// \r
+// end;\r
+ writtenthiscycle := true;\r
+ end;\r
+end;\r
+\r
+procedure tlasio.dupnowatch(invalue:longint);\r
+begin\r
+ { debugout('invalue='+inttostr(invalue));}\r
+ //readln;\r
+ if state<> wsclosed then close;\r
+ fdhandlein := invalue;\r
+ fdhandleout := invalue;\r
+ eventcore.setfdreverse(fdhandlein,self);\r
+ {$ifndef win32}\r
+ fcntl(fdhandlein,F_SETFL,OPEN_NONBLOCK);\r
+ {$endif}\r
+ state := wsconnected;\r
+\r
+end;\r
+\r
+\r
+procedure tlasio.dup(invalue:longint);\r
+begin\r
+ dupnowatch(invalue);\r
+ eventcore.rmasterset(fdhandlein,false);//fd_set(fdhandlein,fdsrmaster);\r
+ eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
+end;\r
+\r
+\r
+procedure tlasio.handlefdtrigger(readtrigger,writetrigger:boolean);\r
+var\r
+ sendflushresult : integer;\r
+ tempbuf:array[0..receivebufsize-1] of byte;\r
+begin\r
+ if (state=wsconnected) and writetrigger then begin\r
+ //writeln('write trigger');\r
+\r
+ if (sendq.size >0) then begin\r
+\r
+ sendflushresult := sendflush;\r
+ if (sendflushresult <= 0) and (not writtenthiscycle) then begin\r
+ if sendflushresult=0 then begin // linuxerror := 0;\r
+ internalclose(0);\r
+\r
+ end else begin\r
+ internalclose({$ifdef win32}getlasterror{$else}linuxerror{$endif});\r
+ end;\r
+ end;\r
+\r
+ end else begin\r
+ //everything is sent fire off ondatasent event\r
+ if fdhandleout >= 0 then eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
+ if assigned(ondatasent) then tltask.create(self.dodatasent,self,0,0);\r
+ end;\r
+ if assigned(onfdwrite) then onfdwrite(self,0);\r
+ end;\r
+ writtenthiscycle := false;\r
+ if (state =wsconnected) and readtrigger then begin\r
+ if recvq.size=0 then begin\r
+ numread := myfdread(fdhandlein,tempbuf,sizeof(tempbuf));\r
+ if (numread=0) and (not mustrefreshfds) then begin\r
+ {if i remember correctly numread=0 is caused by eof\r
+ if this isn't dealt with then you get a cpu eating infinite loop\r
+ however if onsessionconencted has called processmessages that could\r
+ cause us to drop to here with an empty recvq and nothing left to read\r
+ and we don't want that to cause the socket to close}\r
+\r
+ internalclose(0);\r
+ end else if (numread=-1) then begin\r
+ numread := 0;\r
+ internalclose({$ifdef win32}getlasterror{$else}linuxerror{$endif});\r
+ end else if numread > 0 then recvq.add(@tempbuf,numread);\r
+ end;\r
+\r
+ if recvq.size > 0 then begin\r
+ if wsonoreceiveloop in componentoptions then eventcore.rmasterclr(fdhandlein); //fd_clr(fdhandlein,fdsrmaster);\r
+ if assigned(ondataavailable) then ondataAvailable(self,0);\r
+ if not (wsonoreceiveloop in componentoptions) then if recvq.size > 0 then\r
+ tltask.create(self.doreceiveloop,self,0,0);\r
+ end;\r
+ //until (numread = 0) or (currentsocket.state<>wsconnected);\r
+{ debugout('inner loop complete');}\r
+ end;\r
+end;\r
+\r
+{$ifndef win32}\r
+ procedure tlasio.flush;\r
+ var\r
+ fds : fdset;\r
+ begin\r
+ fd_zero(fds);\r
+ fd_set(fdhandleout,fds);\r
+ while sendq.size>0 do begin\r
+ select(fdhandleout+1,nil,@fds,nil,nil);\r
+ if sendflush <= 0 then exit;\r
+ end;\r
+ end;\r
+{$endif}\r
+\r
+procedure tlasio.dodatasent(wparam,lparam:longint);\r
+begin\r
+ if assigned(ondatasent) then ondatasent(self,lparam);\r
+end;\r
+\r
+procedure tlasio.deletebuffereddata;\r
+begin\r
+ sendq.del(maxlongint);\r
+end;\r
+\r
+procedure tlasio.sinkdata(sender:tobject;error:word);\r
+begin\r
+ tlasio(sender).recvq.del(maxlongint);\r
+end;\r
+\r
+{$ifndef win32}\r
+ procedure tltimer.resettimes;\r
+ begin\r
+ gettimeofday(nextts);\r
+ {if not initialevent then} tv_add(nextts,interval);\r
+ end;\r
+{$endif}\r
+\r
+{procedure tltimer.setinitialevent(newvalue : boolean);\r
+begin\r
+ if newvalue <> finitialevent then begin\r
+ finitialevent := newvalue;\r
+ if assigned(timerwrapperinterface) then begin\r
+ timerwrapperinterface.setinitialevent(wrappedtimer,newvalue);\r
+ end else begin\r
+ resettimes;\r
+ end;\r
+ end;\r
+end;}\r
+\r
+procedure tltimer.setontimer(newvalue:tnotifyevent);\r
+begin\r
+ if @newvalue <> @fontimer then begin\r
+ fontimer := newvalue;\r
+ if assigned(timerwrapperinterface) then begin\r
+ timerwrapperinterface.setontimer(wrappedtimer,newvalue);\r
+ end else begin\r
+\r
+ end;\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure tltimer.setenabled(newvalue : boolean);\r
+begin\r
+ if newvalue <> fenabled then begin\r
+ fenabled := newvalue;\r
+ if assigned(timerwrapperinterface) then begin\r
+ timerwrapperinterface.setenabled(wrappedtimer,newvalue);\r
+ end else begin\r
+ {$ifdef win32}\r
+ raise exception.create('non wrapper timers are not permitted on windows');\r
+ {$else}\r
+ resettimes;\r
+ {$endif}\r
+ end;\r
+ end;\r
+end;\r
+\r
+procedure tltimer.setinterval(newvalue:integer);\r
+begin\r
+ if newvalue <> finterval then begin\r
+ finterval := newvalue;\r
+ if assigned(timerwrapperinterface) then begin\r
+ timerwrapperinterface.setinterval(wrappedtimer,newvalue);\r
+ end else begin\r
+ {$ifdef win32}\r
+ raise exception.create('non wrapper timers are not permitted on windows');\r
+ {$else}\r
+ resettimes;\r
+ {$endif}\r
+ end;\r
+ end;\r
+\r
+end;\r
+\r
+\r
+\r
+\r
+constructor tltimer.create;\r
+begin\r
+ inherited create(AOwner);\r
+ if assigned(timerwrapperinterface) then begin\r
+ wrappedtimer := timerwrapperinterface.createwrappedtimer;\r
+ end else begin\r
+\r
+\r
+ nexttimer := firsttimer;\r
+ prevtimer := nil;\r
+\r
+ if assigned(nexttimer) then nexttimer.prevtimer := self;\r
+ firsttimer := self;\r
+ end;\r
+ interval := 1000;\r
+ enabled := true;\r
+ released := false;\r
+\r
+end;\r
+\r
+destructor tltimer.destroy;\r
+begin\r
+ if assigned(timerwrapperinterface) then begin\r
+ wrappedtimer.free;\r
+ end else begin\r
+ if prevtimer <> nil then begin\r
+ prevtimer.nexttimer := nexttimer;\r
+ end else begin\r
+ firsttimer := nexttimer;\r
+ end;\r
+ if nexttimer <> nil then begin\r
+ nexttimer.prevtimer := prevtimer;\r
+ end;\r
+ \r
+ end;\r
+ inherited destroy;\r
+end;\r
+\r
+constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+ inherited create;\r
+ if assigned(onaddtask) then onaddtask(ahandler,aobj,awparam,alparam);\r
+ handler := ahandler;\r
+ obj := aobj;\r
+ wparam := awparam;\r
+ lparam := alparam;\r
+ {nexttask := firsttask;\r
+ firsttask := self;}\r
+ if assigned(lasttask) then begin\r
+ lasttask.nexttask := self;\r
+ end else begin\r
+ firsttask := self;\r
+ end;\r
+ lasttask := self;\r
+ //ahandler(wparam,lparam);\r
+end;\r
+\r
+procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+\r
+ tltask.create(ahandler,aobj,awparam,alparam);\r
+end;\r
+\r
+\r
+\r
+\r
+{$ifndef nosignal}\r
+ procedure prepsigpipe;inline;\r
+ begin\r
+ starthandlesignal(sigpipe);\r
+ if not assigned(signalloopback) then begin\r
+ signalloopback := tlloopback.create(nil);\r
+ signalloopback.ondataAvailable := signalloopback.sinkdata;\r
+\r
+ end;\r
+\r
+ end;\r
+{$endif}\r
+\r
+procedure processtasks;//inline;\r
+var\r
+ temptask : tltask ;\r
+\r
+begin\r
+\r
+ if not assigned(currenttask) then begin\r
+ currenttask := firsttask;\r
+ firsttask := nil;\r
+ lasttask := nil;\r
+ end;\r
+ while assigned(currenttask) do begin\r
+\r
+ if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam);\r
+ if assigned(currenttask) then begin\r
+ temptask := currenttask;\r
+ currenttask := currenttask.nexttask;\r
+ temptask.free;\r
+ end;\r
+ //writeln('processed a task');\r
+ end;\r
+\r
+end;\r
+\r
+\r
+\r
+\r
+procedure disconnecttasks(aobj:tobject);\r
+var\r
+ currenttasklocal : tltask ;\r
+ counter : byte ;\r
+begin\r
+ for counter := 0 to 1 do begin\r
+ if counter = 0 then begin\r
+ currenttasklocal := firsttask; //main list of tasks\r
+ end else begin\r
+ currenttasklocal := currenttask; //needed in case called from a task\r
+ end;\r
+ // note i don't bother to sestroy the links here as that will happen when\r
+ // the list of tasks is processed anyway\r
+ while assigned(currenttasklocal) do begin\r
+ if currenttasklocal.obj = aobj then begin\r
+ currenttasklocal.obj := nil;\r
+ currenttasklocal.handler := nil;\r
+ end;\r
+ currenttasklocal := currenttasklocal.nexttask;\r
+ end;\r
+ end;\r
+end;\r
+\r
+\r
+procedure processmessages;\r
+begin\r
+ eventcore.processmessages;\r
+end;\r
+procedure messageloop;\r
+begin\r
+ eventcore.messageloop;\r
+end;\r
+\r
+procedure exitmessageloop;\r
+begin\r
+ eventcore.exitmessageloop;\r
+end;\r
+\r
+function tlasio.RealSend(Data : Pointer; Len : Integer) : Integer;\r
+begin\r
+ result := myfdwrite(fdhandleout,data^,len);\r
+ if (result > 0) and assigned(onsenddata) then onsenddata(self,result);\r
+ eventcore.wmasterset(fdhandleout);\r
+end;\r
+{$ifndef win32}\r
+ procedure tlasio.myfdclose(fd : integer);\r
+ begin\r
+ fdclose(fd);\r
+ end;\r
+ function tlasio.myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt;\r
+ begin\r
+ result := fdwrite(fd,buf,size);\r
+ end;\r
+\r
+ function tlasio.myfdread(fd: LongInt;var buf;size: LongInt):LongInt;\r
+ begin\r
+ result := fdread(fd,buf,size);\r
+ end;\r
+\r
+\r
+{$endif}\r
+\r
+\r
+begin\r
+ firstasin := nil;\r
+ firsttask := nil;\r
+ \r
+\r
+ {$ifndef nosignal}\r
+ signalloopback := nil;\r
+ {$endif}\r
+end.\r
+\r
+\r
+\r
+\r
+\r
--- /dev/null
+{ Copyright (C) 2005 Bas Steendijk and Peter Green
+ For conditions of distribution and use, see copyright notice in zlib_license.txt
+ which is included in the package
+ ----------------------------------------------------------------------------- }
+ \r
+unit lcoregtklaz;\r
+{$mode delphi}\r
+interface\r
+ \r
+uses baseunix,unix,glib, gdk, gtk,lcore,forms,fd_utils,classes;\r
+//procedure lcoregtklazrun;\r
+const\r
+ G_IO_IN=1;\r
+ G_IO_OUT=4;\r
+ G_IO_PRI=2;\r
+ G_IO_ERR=8;\r
+\r
+ G_IO_HUP=16;\r
+ G_IO_NVAL=32;\r
+type\r
+ tlaztimerwrapperinterface=class(ttimerwrapperinterface)\r
+ public\r
+ function createwrappedtimer : tobject;override;\r
+// procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);override;\r
+ procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);override;\r
+ procedure setenabled(wrappedtimer : tobject;newvalue : boolean);override;\r
+ procedure setinterval(wrappedtimer : tobject;newvalue : integer);override;\r
+ end;\r
+\r
+procedure lcoregtklazinit;\r
+implementation\r
+ uses\r
+ ExtCtrls;\r
+{$I unixstuff.inc}\r
+var\r
+ giochannels : array[0..absoloutemaxs] of pgiochannel;\r
+\r
+function iocallback(source:PGIOChannel; condition:TGIOCondition; data:gpointer):gboolean;cdecl;\r
+// return true if we want the callback to stay\r
+var\r
+ fd : integer ;\r
+ fdsrlocal , fdswlocal : fdset ;\r
+ currentasio : tlasio ;\r
+begin\r
+ fd := g_io_channel_unix_get_fd(source);\r
+ fd_zero(fdsrlocal);\r
+ fd_set(fd,fdsrlocal);\r
+ fdswlocal := fdsrlocal;\r
+ select(fd+1,@fdsrlocal,@fdswlocal,nil,0);\r
+ if fd_isset(fd,fdsrlocal) or fd_isset(fd,fdsrlocal) then begin\r
+ currentasio := fdreverse[fd];\r
+ if assigned(currentasio) then begin\r
+ currentasio.handlefdtrigger(fd_isset(currentasio.fdhandlein,fdsrlocal),fd_isset(currentasio.fdhandleout,fdswlocal));\r
+ end else begin\r
+ rmasterclr(fd);\r
+ wmasterclr(fd);\r
+ end;\r
+ end;\r
+ case condition of\r
+ G_IO_IN : begin\r
+ result := rmasterisset(fd);\r
+ end;\r
+ G_IO_OUT : begin\r
+ result := wmasterisset(fd);\r
+ end;\r
+ end;\r
+end;\r
+\r
+procedure gtkrmasterset(fd : integer);\r
+begin\r
+ if not assigned(giochannels[fd]) then giochannels[fd] := g_io_channel_unix_new(fd);\r
+ g_io_add_watch(giochannels[fd],G_IO_IN,iocallback,nil);\r
+end;\r
+\r
+procedure gtkrmasterclr(fd: integer);\r
+begin\r
+end;\r
+ \r
+procedure gtkwmasterset(fd : integer);\r
+begin\r
+ if not assigned(giochannels[fd]) then giochannels[fd] := g_io_channel_unix_new(fd);\r
+ g_io_add_watch(giochannels[fd],G_IO_OUT,iocallback,nil);\r
+end;\r
+\r
+procedure gtkwmasterclr(fd: integer);\r
+begin\r
+end;\r
+\r
+type\r
+ tsc = class\r
+ procedure dotasksandsink(sender:tobject;error:word);\r
+ end;\r
+var\r
+ taskloopback : tlloopback;\r
+ sc : tsc;\r
+procedure tsc.dotasksandsink(sender:tobject;error:word);\r
+begin\r
+ with tlasio(sender) do begin\r
+ sinkdata(sender,error);\r
+ processtasks;\r
+ end;\r
+end;\r
+procedure gtkaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+ taskloopback.sendstr(' ');\r
+ \r
+end;\r
+\r
+procedure lcoregtklazinit;\r
+begin\r
+ onrmasterset := gtkrmasterset;\r
+ onrmasterclr := gtkrmasterclr;\r
+ onwmasterset := gtkwmasterset;\r
+ onwmasterclr := gtkwmasterclr;\r
+ onaddtask := gtkaddtask;\r
+ taskloopback := tlloopback.create(nil);\r
+ taskloopback.ondataavailable := sc.dotasksandsink;\r
+ timerwrapperinterface := tlaztimerwrapperinterface.create(nil);\r
+end;\r
+\r
+function tlaztimerwrapperinterface.createwrappedtimer : tobject;\r
+begin\r
+ result := ttimer.create(nil);\r
+end;\r
+procedure tlaztimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);\r
+begin\r
+ ttimer(wrappedtimer).ontimer := newvalue;\r
+end;\r
+procedure tlaztimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean);\r
+begin\r
+ ttimer(wrappedtimer).enabled := newvalue;\r
+end;\r
+\r
+\r
+procedure tlaztimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer);\r
+begin\r
+ ttimer(wrappedtimer).interval := newvalue;\r
+end;\r
+\r
+\r
+end.\r
+\r
--- /dev/null
+{lsocket.pas}\r
+\r
+{io and timer code by plugwash}\r
+\r
+{ 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
+\r
+unit lcoreselect;\r
+\r
+\r
+interface\r
+uses\r
+ fd_utils;\r
+var\r
+ maxs : longint ;\r
+ exitloopflag : boolean ; {if set by app, exit mainloop}\r
+\r
+function getfdsrmaster : fdset; {$ifdef fpc}inline;{$endif}\r
+function getfdswmaster : fdset; {$ifdef fpc}inline;{$endif}\r
+\r
+implementation\r
+uses\r
+ lcore,sysutils,\r
+ {$ifdef VER1_0}\r
+ linux,\r
+ {$else}\r
+ baseunix,unix,\r
+ {$endif}\r
+ classes,pgtypes,bfifo,\r
+ {$ifndef nosignal}\r
+ lsignal;\r
+ {$endif}\r
+\r
+{$include unixstuff.inc}\r
+{$include ltimevalstuff.inc}\r
+var\r
+ fdreverse:array[0..absoloutemaxs] of tlasio;\r
+type\r
+ tselecteventcore=class(teventcore)\r
+ public\r
+ procedure processmessages; override;\r
+ procedure messageloop; override;\r
+ procedure exitmessageloop;override;\r
+ procedure setfdreverse(fd : integer;reverseto : tlasio); override;\r
+ procedure rmasterset(fd : integer;islistensocket : boolean); override;\r
+ procedure rmasterclr(fd: integer); override;\r
+ procedure wmasterset(fd : integer); override;\r
+ procedure wmasterclr(fd: integer); override;\r
+ end;\r
+\r
+procedure processtimers;inline;\r
+var\r
+ tv ,tvnow : ttimeval ;\r
+ currenttimer : tltimer ;\r
+ temptimer : tltimer ;\r
+\r
+begin\r
+ gettimeofday(tvnow);\r
+ currenttimer := firsttimer;\r
+ while assigned(currenttimer) do begin\r
+ //writeln(currenttimer.enabled);\r
+ if tv_compare(tvnow,ttimeval(currenttimer.nextts)) and currenttimer.enabled then begin\r
+ //if assigned(currenttimer.ontimer) then begin\r
+ // if currenttimer.enabled then if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer);\r
+ // currenttimer.initialdone := true;\r
+ //end;\r
+ if assigned(currenttimer.ontimer) then currenttimer.ontimer(currenttimer);\r
+ currenttimer.nextts := timeval(tvnow);\r
+ tv_add(ttimeval(currenttimer.nextts),currenttimer.interval);\r
+ end;\r
+ temptimer := currenttimer;\r
+ currenttimer := currenttimer.nexttimer;\r
+ if temptimer.released then temptimer.free;\r
+ end;\r
+end;\r
+\r
+procedure processasios(var fdsr,fdsw:fdset);//inline;\r
+var\r
+ currentsocket : tlasio ;\r
+ tempsocket : tlasio ;\r
+ socketcount : integer ; // for debugging perposes :)\r
+ dw,bt:integer;\r
+begin\r
+{ inc(lcoretestcount);}\r
+\r
+ //the message loop will exit if all lasio's and ltimer's and lsignal's are destroyed\r
+ //if (not assigned(firstasin)) and (not assigned(firsttimer)) and (not assigned(firstsignal)) then exit;\r
+\r
+\r
+ {------- test optimised loop}\r
+ socketcount := 0;\r
+ for dw := (maxs shr 5) downto 0 do if (fdsr[dw] or fdsw[dw]) <> 0 then begin\r
+ for bt := 0 to 31 do if (fdsr[dw] or fdsw[dw]) and (1 shl bt) <> 0 then begin\r
+ inc(socketcount);\r
+ currentsocket := fdreverse[dw shl 5 or bt];\r
+ {if not assigned(currentsocket) then raise exception.create('currentsocket not assigned');\r
+ if currentsocket.fdhandlein < 0 then raise exception.create('currentsocket.fdhandlein out of range');}\r
+ {i've seen the out of range case actually happening, so it can happen. test: just close the fd - beware}\r
+ if not assigned(currentsocket) then begin\r
+ fdclose(dw shl 5 or bt);\r
+ continue\r
+ end;\r
+ if currentsocket.fdhandlein < 0 then begin\r
+ fdclose(dw shl 5 or bt);\r
+ continue\r
+ end;\r
+ try\r
+ currentsocket.handlefdtrigger(fd_isset(currentsocket.fdhandlein,fdsr),fd_isset(currentsocket.fdhandleout,fdsw));\r
+ except\r
+ on E: exception do begin\r
+ currentsocket.HandleBackGroundException(e);\r
+ end;\r
+ end;\r
+\r
+ if mustrefreshfds then begin\r
+ if select(maxs+1,@fdsr,@fdsw,nil,0) <= 0 then begin\r
+ fd_zero(fdsr);\r
+ fd_zero(fdsw);\r
+ end;\r
+ end;\r
+ end;\r
+ end;\r
+\r
+ if asinreleaseflag then begin\r
+ asinreleaseflag := false;\r
+ currentsocket := firstasin;\r
+ while assigned(currentsocket) do begin\r
+ tempsocket := currentsocket;\r
+ currentsocket := currentsocket.nextasin;\r
+ if tempsocket.released then begin\r
+ tempsocket.free;\r
+ end;\r
+ end;\r
+ end;\r
+ {\r
+ !!! issues:\r
+ - sockets which are released may not be freed because theyre never processed by the loop\r
+ made new code for handling this, using asinreleaseflag\r
+\r
+ - when/why does the mustrefreshfds select apply, sheck if i did it correctly?\r
+\r
+ - what happens if calling handlefdtrigger for a socket which does not have an event\r
+ }\r
+ {------- original loop}\r
+\r
+ (*\r
+ currentsocket := firstasin;\r
+ socketcount := 0;\r
+ while assigned(currentsocket) do begin\r
+ if mustrefreshfds then begin\r
+ if select(maxs,@fdsr,@fdsw,nil,0) <= 0 then begin\r
+ fd_zero(fdsr);\r
+ fd_zero(fdsw);\r
+ end;\r
+ end;\r
+ try\r
+ if fd_isset(currentsocket.fdhandlein,fdsr) or fd_isset(currentsocket.fdhandleout,fdsw) then begin\r
+ currentsocket.handlefdtrigger(fd_isset(currentsocket.fdhandlein,fdsr),fd_isset(currentsocket.fdhandleout,fdsw));\r
+ end;\r
+ except\r
+ on E: exception do begin\r
+ currentsocket.HandleBackGroundException(e);\r
+ end;\r
+ end;\r
+ tempsocket := currentsocket;\r
+ currentsocket := currentsocket.nextasin;\r
+ inc(socketcount);\r
+ if tempsocket.released then begin\r
+ tempsocket.free;\r
+ end;\r
+ end; *)\r
+{ debugout('socketcount='+inttostr(socketcount));}\r
+end;\r
+\r
+procedure tselecteventcore.processmessages;\r
+var\r
+ fdsr , fdsw : fdset ;\r
+ selectresult : longint ;\r
+begin\r
+ mustrefreshfds := false;\r
+ {$ifndef nosignal}\r
+ prepsigpipe;\r
+ {$endif}\r
+ selectresult := select(maxs+1,@fdsr,@fdsw,nil,0);\r
+ while (selectresult>0) or assigned(firsttask) or assigned(currenttask) do begin;\r
+\r
+ processtasks;\r
+ processtimers;\r
+ if selectresult > 0 then begin\r
+ processasios(fdsr,fdsw);\r
+ end;\r
+ selectresult := select(maxs+1,@fdsr,@fdsw,nil,0);\r
+\r
+ end;\r
+ mustrefreshfds := true;\r
+end;\r
+\r
+\r
+var\r
+ FDSR , FDSW : fdset;\r
+\r
+Function doSelect(timeOut:PTimeVal):longint;//inline;\r
+var\r
+ localtimeval : ttimeval;\r
+ maxslocal : integer;\r
+begin\r
+ //unblock signals\r
+ //zeromemory(@sset,sizeof(sset));\r
+ //sset[0] := ;\r
+ fdsr := getfdsrmaster;\r
+ fdsw := getfdswmaster;\r
+\r
+ if assigned(firsttask) then begin\r
+ localtimeval.tv_sec := 0;\r
+ localtimeval.tv_usec := 0;\r
+ timeout := @localtimeval;\r
+ end;\r
+\r
+ maxslocal := maxs;\r
+ mustrefreshfds := false;\r
+{ debugout('about to call select');}\r
+ {$ifndef nosignal}\r
+ sigprocmask(SIG_UNBLOCK,@blockset,nil);\r
+ {$endif}\r
+ result := select(maxslocal+1,@FDSR,@FDSW,nil,timeout);\r
+ if result <= 0 then begin\r
+ fd_zero(FDSR);\r
+ fd_zero(FDSW);\r
+ if result=-1 then begin\r
+ if linuxerror = SYS_EINTR then begin\r
+ // we received a signal it's not a problem\r
+ end else begin\r
+ raise esocketexception.create('select returned error '+inttostr(linuxerror));\r
+ end;\r
+ end;\r
+ end;\r
+ {$ifndef nosignal}\r
+ sigprocmask(SIG_BLOCK,@blockset,nil);\r
+ {$endif}\r
+{ debugout('select complete');}\r
+end;\r
+\r
+procedure tselecteventcore.exitmessageloop;\r
+begin\r
+ exitloopflag := true\r
+end;\r
+\r
+\r
+\r
+procedure tselecteventcore.messageloop;\r
+var\r
+ tv ,tvnow : ttimeval ;\r
+ currenttimer : tltimer ;\r
+ selectresult:integer;\r
+begin\r
+ {$ifndef nosignal}\r
+ prepsigpipe;\r
+ {$endif}\r
+ {currentsocket := firstasin;\r
+ if not assigned(currentsocket) then exit; //the message loop will exit if all lsockets are destroyed\r
+ repeat\r
+\r
+ if currentsocket.state = wsconnected then currentsocket.sendflush;\r
+ currentsocket := currentsocket.nextasin;\r
+ until not assigned(currentsocket);}\r
+\r
+\r
+ repeat\r
+\r
+ //the message loop will exit if all lasio's and ltimer's and lsignal's are destroyed\r
+ if (not assigned(firstasin)) and (not assigned(firsttimer)) {$ifndef nosignal} and (not assigned(firstsignal)){$endif} then exit;\r
+ {fd_zero(FDSR);\r
+ fd_zero(FDSW);\r
+ currentsocket := firstasin;\r
+ if not assigned(currentsocket) then exit; //the message loop will exit if all lsockets are destroyed\r
+\r
+ repeat\r
+ if (not currentsocket.released) and (currentsocket.state<>wsclosed) then fd_set(currentsocket.fdhandlein,fdsr);\r
+ if (not currentsocket.released) and (currentsocket.state=wsconnecting) then fd_set(currentsocket.fdhandleout,fdsw);\r
+ if currentsocket is tlsocket then begin\r
+ if (not currentsocket.released) and (currentsocket.state=wsconnected) and(tlsocket(currentsocket).sendq <> '') then fd_set(currentsocket.fdhandleout,fdsw);\r
+ end;\r
+ tempsocket := currentsocket;\r
+ currentsocket := currentsocket.nextasin;\r
+ if tempsocket.released then begin\r
+ tempsocket.free;\r
+ end;\r
+ until not assigned(currentsocket);\r
+ }\r
+ processtasks;\r
+ //currenttask := nil;\r
+ {beware}\r
+ //if assigned(firsttimer) then begin\r
+ // tv.tv_sec := maxlongint;\r
+ tv := tv_invalidtimebig;\r
+ currenttimer := firsttimer;\r
+ while assigned(currenttimer) do begin\r
+ if tv_compare(tv,currenttimer.nextts) and currenttimer.enabled then tv := currenttimer.nextts;\r
+ currenttimer := currenttimer.nexttimer;\r
+ end;\r
+\r
+\r
+ if tv_compare(tv,tv_invalidtimebig) then begin \r
+ //writeln('no timers active');\r
+ if exitloopflag then break;\r
+{ sleep(10);}\r
+ selectresult := doselect(nil);\r
+\r
+ end else begin\r
+ gettimeofday(tvnow);\r
+ tv_substract(tv,tvnow);\r
+\r
+ //writeln('timers active');\r
+ if tv.tv_sec < 0 then begin\r
+ tv.tv_sec := 0;\r
+ tv.tv_usec := 0; {0.1 sec}\r
+ end;\r
+ if exitloopflag then break;\r
+{ sleep(10);}\r
+ selectresult := doselect(@tv);\r
+ processtimers;\r
+\r
+ end;\r
+ if selectresult > 0 then processasios(fdsr,fdsw);\r
+ {!!!only call processasios if select has asio events -beware}\r
+\r
+ {artificial delay to throttle the number of processasios per second possible and reduce cpu usage}\r
+ until false;\r
+end;\r
+\r
+var\r
+ fdsrmaster , fdswmaster : fdset ;\r
+\r
+procedure tselecteventcore.rmasterset(fd : integer;islistensocket : boolean);\r
+begin\r
+ if fd > absoloutemaxs then raise esocketexception.create('file discriptor out of range');\r
+ if fd > maxs then maxs := fd;\r
+ if fd_isset(fd,fdsrmaster) then exit;\r
+ fd_set(fd,fdsrmaster);\r
+\r
+end;\r
+\r
+procedure tselecteventcore.rmasterclr(fd: integer);\r
+begin\r
+ if not fd_isset(fd,fdsrmaster) then exit;\r
+ fd_clr(fd,fdsrmaster);\r
+\r
+end;\r
+\r
+\r
+procedure tselecteventcore.wmasterset(fd : integer);\r
+begin\r
+ if fd > absoloutemaxs then raise esocketexception.create('file discriptor out of range');\r
+ if fd > maxs then maxs := fd;\r
+\r
+ if fd_isset(fd,fdswmaster) then exit;\r
+ fd_set(fd,fdswmaster);\r
+\r
+end;\r
+\r
+procedure tselecteventcore.wmasterclr(fd: integer);\r
+begin\r
+ if not fd_isset(fd,fdswmaster) then exit;\r
+ fd_clr(fd,fdswmaster);\r
+end;\r
+\r
+procedure tselecteventcore.setfdreverse(fd : integer;reverseto : tlasio);\r
+begin\r
+ fdreverse[fd] := reverseto;\r
+end;\r
+\r
+function getfdsrmaster : fdset; {$ifdef fpc}inline;{$endif}\r
+begin\r
+ result := fdsrmaster;\r
+end;\r
+function getfdswmaster : fdset; {$ifdef fpc}inline;{$endif}\r
+begin\r
+ result := fdswmaster;\r
+end;\r
+\r
+\r
+begin\r
+ eventcore := tselecteventcore.create;\r
+\r
+ maxs := 0;\r
+ fd_zero(fdsrmaster);\r
+ fd_zero(fdswmaster);\r
+end.\r
--- /dev/null
+program lcoretest;\r
+\r
+uses\r
+ lcore,\r
+ lsocket,\r
+ {$ifdef win32}\r
+ lcorewsaasyncselect in 'lcorewsaasyncselect.pas',\r
+ {$else}\r
+ lcoreselect,\r
+ {$endif}\r
+ dnsasync,\r
+ binipstuff,\r
+ dnssync;\r
+{$ifdef win32}\r
+ {$R *.RES}\r
+{$endif}\r
+\r
+type\r
+ tsc=class\r
+ procedure sessionavailable(sender: tobject;error : word);\r
+ procedure dataavailable(sender: tobject;error : word);\r
+ procedure sessionconnected(sender: tobject;error : word);\r
+ procedure taskrun(wparam,lparam:longint);\r
+ procedure timehandler(sender:tobject);\r
+ procedure dnsrequestdone(sender:tobject;error : word);\r
+ procedure sessionclosed(sender:tobject;error : word);\r
+ end;\r
+var\r
+ listensocket : tlsocket;\r
+ serversocket : tlsocket;\r
+ clientsocket : tlsocket;\r
+ sc : tsc;\r
+ task : tltask;\r
+procedure tsc.sessionavailable(sender: tobject;error : word);\r
+begin\r
+ writeln('received connection');\r
+ serversocket.dup(listensocket.accept);\r
+end;\r
+\r
+var\r
+ receivebuf : string;\r
+ receivecount : integer;\r
+procedure tsc.dataavailable(sender: tobject;error : word);\r
+var\r
+ receiveddata : string;\r
+ receivedon : string;\r
+begin\r
+ receiveddata := tlsocket(sender).receivestr;\r
+ if sender=clientsocket then begin\r
+ receivedon := 'client socket';\r
+ end else begin\r
+ receivedon := 'server socket';\r
+ end;\r
+ writeln('received data '+receiveddata+' on '+receivedon);\r
+ if sender=serversocket then begin\r
+ receivebuf := receivebuf+receiveddata;\r
+ end;\r
+ if receivebuf = 'hello world' then begin\r
+ receivebuf := '';\r
+ writeln('received hello world creating task');\r
+ task := tltask.create(sc.taskrun,nil,0,0);\r
+ end;\r
+ receivecount := receivecount +1;\r
+ if receivecount >50 then begin\r
+ writeln('received over 50 bits of data, pausing to let the operator take a look');\r
+ readln;\r
+ receivecount := 0;\r
+ end;\r
+\r
+end;\r
+\r
+procedure tsc.sessionconnected(sender: tobject;error : word);\r
+begin\r
+ if error=0 then begin\r
+ writeln('session is connected');\r
+ if clientsocket.addr = '127.0.0.1' then begin\r
+ clientsocket.sendstr('hello world');\r
+ end else begin\r
+ clientsocket.sendstr('get /'#13#10#13#10);\r
+ end;\r
+ end else begin\r
+ writeln('connect failed');\r
+ end;\r
+end;\r
+\r
+var\r
+ das : tdnsasync;\r
+\r
+procedure tsc.taskrun(wparam,lparam:longint);\r
+var\r
+ tempbinip : tbinip;\r
+ dummy : integer;\r
+begin\r
+ writeln('task ran');\r
+ writeln('closing client socket');\r
+ clientsocket.close;\r
+\r
+ writeln('looking up www.kame.net using dnsasync');\r
+ das := tdnsasync.Create(nil);\r
+ das.onrequestdone := sc.dnsrequestdone;\r
+ das.forwardfamily := af_inet6;
+ das.forwardlookup('www.kame.net');\r
+end;\r
+\r
+procedure tsc.dnsrequestdone(sender:tobject;error : word);\r
+begin\r
+ writeln('www.kame.net resolved to '+das.dnsresult+' connecting client socket there');\r
+ clientsocket.addr := das.dnsresult;\r
+ clientsocket.port := '80';\r
+ clientsocket.connect;\r
+ das.free;\r
+end;\r
+\r
+procedure tsc.timehandler(sender:tobject);\r
+begin\r
+ //writeln('got timer event');\r
+end;\r
+procedure tsc.sessionclosed(sender:tobject;error : word);\r
+begin\r
+ Writeln('session closed with error ',error);\r
+end;\r
+var\r
+ timer : tltimer;\r
+ ipbin : tbinip;\r
+ dummy : integer;\r
+begin\r
+ ipbin := forwardlookup('invalid.domain',5);\r
+ writeln(ipbintostr(ipbin));\r
+\r
+ ipbin := forwardlookup('p10link.net',5);\r
+ writeln(ipbintostr(ipbin));\r
+\r
+ ipstrtobin('80.68.89.68',ipbin);\r
+ writeln('80.68.89.68 reverses to '+reverselookup(ipbin,5));\r
+\r
+ ipstrtobin('2001:200::8002:203:47ff:fea5:3085',ipbin);\r
+ writeln('2001:200::8002:203:47ff:fea5:3085 reverses to '+reverselookup(ipbin,5));\r
+ writeln('creating and setting up listen socket');\r
+ listensocket := tlsocket.create(nil);\r
+ listensocket.addr := '0.0.0.0';\r
+ listensocket.port := '12345';\r
+ listensocket.onsessionavailable := sc.sessionavailable;\r
+ writeln('listening');\r
+ listensocket.listen;\r
+ writeln('listen socket is number ', listensocket.fdhandlein);\r
+ writeln('creating and setting up server socket');\r
+ serversocket := tlsocket.create(nil);\r
+ serversocket.ondataavailable := sc.dataavailable;\r
+ writeln('creating and setting up client socket');\r
+ clientsocket := tlsocket.create(nil);\r
+ clientsocket.addr := {'::1';}'127.0.0.1';\r
+ clientsocket.port := '12345';\r
+ clientsocket.onsessionconnected := sc.sessionconnected;\r
+ clientsocket.ondataAvailable := sc.dataavailable;\r
+ clientsocket.onsessionclosed := sc.sessionclosed;\r
+ writeln('connecting');\r
+ clientsocket.connect;\r
+ writeln('client socket is number ',clientsocket.fdhandlein);\r
+ writeln('creating and setting up timer');\r
+ timer := tltimer.create(nil);\r
+ timer.interval := 1000;\r
+ timer.ontimer := sc.timehandler;\r
+ timer.enabled := true;\r
+ writeln('entering message loop');\r
+ messageloop;\r
+ writeln('exiting cleanly');\r
+end.\r
--- /dev/null
+unit lcorewsaasyncselect;\r
+\r
+interface\r
+\r
+implementation\r
+uses wcore,lcore,bsearchtree,sysutils,windows,winsock,pgtypes,messages,classes;\r
+type\r
+ twineventcore=class(teventcore)\r
+ public\r
+ procedure processmessages; override;\r
+ procedure messageloop; override;\r
+ procedure exitmessageloop;override;\r
+ procedure setfdreverse(fd : integer;reverseto : tlasio); override;\r
+ procedure rmasterset(fd : integer;islistensocket : boolean); override;\r
+ procedure rmasterclr(fd: integer); override;\r
+ procedure wmasterset(fd : integer); override;\r
+ procedure wmasterclr(fd: integer); override;\r
+ end;\r
+const\r
+ wm_dotasks=wm_user+1;\r
+type\r
+ twintimerwrapperinterface=class(ttimerwrapperinterface)\r
+ public\r
+ function createwrappedtimer : tobject;override;\r
+// procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);override;\r
+ procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);override;\r
+ procedure setenabled(wrappedtimer : tobject;newvalue : boolean);override;\r
+ procedure setinterval(wrappedtimer : tobject;newvalue : integer);override;\r
+ end;\r
+\r
+procedure twineventcore.processmessages;\r
+begin\r
+ wcore.processmessages;//pass off to wcore\r
+end;\r
+procedure twineventcore.messageloop;\r
+begin\r
+ wcore.messageloop; //pass off to wcore\r
+end;\r
+procedure twineventcore.exitmessageloop;\r
+begin\r
+ wcore.exitmessageloop;\r
+end;\r
+var\r
+ fdreverse : thashtable;\r
+ fdwatches : thashtable;\r
+\r
+procedure twineventcore.setfdreverse(fd : integer;reverseto : tlasio);\r
+begin\r
+ if findtree(@fdreverse,inttostr(fd)) <> nil then deltree(@fdreverse,inttostr(fd));\r
+ if reverseto <> nil then addtree(@fdreverse,inttostr(fd),reverseto);\r
+end;\r
+\r
+var\r
+ hwndlcore : hwnd;\r
+procedure dowsaasyncselect(fd:integer; leventadd: integer; leventremove : integer);\r
+var\r
+ leventold : integer;\r
+ leventnew : integer;\r
+ wsaaresult : integer;\r
+begin\r
+ leventold := taddrint(findtree(@fdwatches,inttostr(fd)));\r
+ leventnew := leventold or leventadd;\r
+ leventnew := leventnew and not leventremove;\r
+ if leventold <> leventnew then begin\r
+ if leventold <> 0 then deltree(@fdwatches,inttostr(fd));\r
+ if leventnew <> 0 then addtree(@fdwatches,inttostr(fd),pointer(leventnew));\r
+ end;\r
+ wsaaresult := wsaasyncselect(fd,hwndlcore,wm_user,leventnew);\r
+\r
+end;\r
+\r
+\r
+//to allow detection of errors:\r
+//if we are asked to monitor for read or accept we also monitor for close\r
+//if we are asked to monitor for write we also monitor for connect\r
+\r
+\r
+procedure twineventcore.rmasterset(fd : integer;islistensocket : boolean);\r
+begin\r
+ if islistensocket then begin\r
+ //writeln('setting accept watch for socket number ',fd);\r
+ dowsaasyncselect(fd,FD_ACCEPT or FD_CLOSE,0);\r
+ end else begin\r
+ //writeln('setting read watch for socket number',fd);\r
+ dowsaasyncselect(fd,FD_READ or FD_CLOSE,0);\r
+ end;\r
+end;\r
+procedure twineventcore.rmasterclr(fd: integer);\r
+begin\r
+ //writeln('clearing read of accept watch for socket number ',fd);\r
+ dowsaasyncselect(fd,0,FD_ACCEPT or FD_READ or FD_CLOSE);\r
+end;\r
+procedure twineventcore.wmasterset(fd : integer);\r
+begin\r
+ dowsaasyncselect(fd,FD_WRITE or FD_CONNECT,0);\r
+end;\r
+\r
+procedure twineventcore.wmasterclr(fd: integer);\r
+begin\r
+ dowsaasyncselect(fd,0,FD_WRITE or FD_CONNECT);\r
+end;\r
+\r
+var\r
+ tasksoutstanding : boolean;\r
+\r
+function MyWindowProc(\r
+ ahWnd : HWND;\r
+ auMsg : Integer;\r
+ awParam : WPARAM;\r
+ alParam : LPARAM): Integer; stdcall;\r
+var\r
+ socket : integer;\r
+ event : integer;\r
+ error : integer;\r
+ readtrigger : boolean;\r
+ writetrigger : boolean;\r
+ lasio : tlasio;\r
+begin\r
+ //writeln('got a message');\r
+ Result := 0; // This means we handled the message\r
+ if (ahwnd=hwndlcore) and (aumsg=wm_user) then begin\r
+ //writeln('it appears to be a response to our wsaasyncselect');\r
+ socket := awparam;\r
+ event := alparam and $FFFF;\r
+ error := alparam shr 16;\r
+ //writeln('socket=',socket,' event=',event,' error=',error);\r
+ readtrigger := false;\r
+ writetrigger := false;\r
+ lasio := findtree(@fdreverse,inttostr(socket));\r
+ if assigned(lasio) then begin\r
+ if (error <> 0) or ((event and FD_CLOSE) <> 0) then begin\r
+ if lasio.state = wsconnecting then begin\r
+ lasio.onsessionconnected(lasio,error);\r
+ end;\r
+ lasio.internalclose(error);\r
+ end else begin\r
+ if (event and (FD_READ or FD_ACCEPT)) <> 0 then readtrigger := true;\r
+ if (event and (FD_WRITE)) <> 0 then writetrigger := true;\r
+\r
+ if readtrigger or writetrigger then lasio.handlefdtrigger(readtrigger,writetrigger);\r
+ end;\r
+ dowsaasyncselect(socket,0,0); //reset watches\r
+ end;\r
+ end else if (ahwnd=hwndlcore) and (aumsg=wm_dotasks) then begin\r
+ //writeln('processing tasks');\r
+ tasksoutstanding := false;\r
+ processtasks;\r
+ end else begin\r
+ //writeln('passing unknown message to defwindowproc');\r
+ //not passing unknown messages on to defwindowproc will cause window\r
+ //creation to fail! --plugwash\r
+ Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)\r
+ end;\r
+\r
+end;\r
+\r
+procedure winaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+ if not tasksoutstanding then PostMessage(hwndlcore,wm_dotasks,0,0);\r
+end;\r
+type\r
+ twcoretimer = wcore.tltimer;\r
+\r
+function twintimerwrapperinterface.createwrappedtimer : tobject;\r
+begin\r
+ result := twcoretimer.create(nil);\r
+end;\r
+procedure twintimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);\r
+begin\r
+ twcoretimer(wrappedtimer).ontimer := newvalue;\r
+end;\r
+procedure twintimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean);\r
+begin\r
+ twcoretimer(wrappedtimer).enabled := newvalue;\r
+end;\r
+\r
+\r
+procedure twintimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer);\r
+begin\r
+ twcoretimer(wrappedtimer).interval := newvalue;\r
+end;\r
+\r
+var\r
+ MyWindowClass : TWndClass = (style : 0;\r
+ lpfnWndProc : @MyWindowProc;\r
+ cbClsExtra : 0;\r
+ cbWndExtra : 0;\r
+ hInstance : 0;\r
+ hIcon : 0;\r
+ hCursor : 0;\r
+ hbrBackground : 0;\r
+ lpszMenuName : nil;\r
+ lpszClassName : 'lcoreClass');\r
+ GInitData: TWSAData;\r
+\r
+begin\r
+ eventcore := twineventcore.create;\r
+ if Windows.RegisterClass(MyWindowClass) = 0 then halt;\r
+ //writeln('about to create lcore handle, hinstance=',hinstance);\r
+ hwndlcore := CreateWindowEx(WS_EX_TOOLWINDOW,\r
+ MyWindowClass.lpszClassName,\r
+ '', { Window name }\r
+ WS_POPUP, { Window Style }\r
+ 0, 0, { X, Y }\r
+ 0, 0, { Width, Height }\r
+ 0, { hWndParent }\r
+ 0, { hMenu }\r
+ HInstance, { hInstance }\r
+ nil); { CreateParam }\r
+ //writeln('lcore hwnd is ',hwndlcore);\r
+ //writeln('last error is ',GetLastError);\r
+ onaddtask := winaddtask;\r
+ timerwrapperinterface := twintimerwrapperinterface.create(nil);\r
+\r
+ WSAStartup($200, GInitData);\r
+end.\r
--- /dev/null
+unit lloopback;\r
+\r
+interface\r
+uses lcore,classes;\r
+\r
+type\r
+ tlloopback=class(tlasio)\r
+ public\r
+ constructor create(aowner:tcomponent); override;\r
+ end;\r
+\r
+\r
+implementation\r
+uses
+ baseunix,unix;
+{$i unixstuff.inc}
+
+constructor tlloopback.create(aowner:tcomponent);\r
+begin\r
+ inherited create(aowner);\r
+ closehandles := true;\r
+ assignpipe(fdhandlein,fdhandleout);\r
+\r
+ eventcore.rmasterset(fdhandlein,false);//fd_set(fdhandlein,fdsrmaster);\r
+ eventcore.wmasterclr(fdhandlein);//fd_clr(fdhandleout,fdswmaster);\r
+ eventcore.setfdreverse(fdhandlein,self);\r
+ eventcore.setfdreverse(fdhandleout,self);\r
+ state := wsconnected;\r
+end;\r
+end.\r
--- /dev/null
+unit lmessages;\r
+//windows messages like system based on lcore tasks\r
+interface\r
+\r
+uses pgtypes,sysutils,bsearchtree,strings,syncobjs;\r
+\r
+type\r
+ lparam=taddrint;\r
+ wparam=taddrint;\r
+ thinstance=pointer;\r
+ hicon=pointer;\r
+ hcursor=pointer;\r
+ hbrush=pointer;\r
+ hwnd=qword; //window handles are monotonically increasing 64 bit integers,\r
+ //this should allow for a million windows per second for over half\r
+ //a million years!\r
+\r
+ twndproc=function(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;\r
+\r
+\r
+ twndclass=record\r
+ style : dword;\r
+ lpfnwndproc : twndproc;\r
+ cbclsextra : integer;\r
+ cbwndextra : integer;\r
+ hinstance : thinstance;\r
+ hicon : hicon;\r
+ hcursor : hcursor;\r
+ hbrbackground : hbrush;\r
+ lpszmenuname : pchar;\r
+ lpszclassname : pchar;\r
+ end;\r
+ PWNDCLASS=^twndclass;\r
+ \r
+ UINT=dword;\r
+ WINBOOL = longbool;\r
+ tTIMERPROC = procedure (ahwnd:HWND; umsg:integer; idevent:taddrint;dwtime:taddrint);stdcall;\r
+ ATOM = pointer;\r
+ LPCSTR = pchar;\r
+ LPVOID = pointer;\r
+ HMENU = pointer;\r
+ HINST = pointer;\r
+\r
+ TPOINT = record \r
+ x : LONGint; \r
+ y : LONGint; \r
+ end; \r
+ \r
+ TMSG = record \r
+ hwnd : HWND; \r
+ message : UINT; \r
+ wParam : WPARAM; \r
+ lParam : LPARAM; \r
+ time : DWORD; \r
+ pt : TPOINT;\r
+ end; \r
+ THevent=TEventObject;\r
+const\r
+ WS_EX_TOOLWINDOW = $80;\r
+ WS_POPUP = longint($80000000);\r
+ hinstance=nil;\r
+ PM_REMOVE = 1;\r
+ WM_USER = 1024;\r
+ WM_TIMER = 275;\r
+ INFINITE = syncobjs.infinite;\r
+function getwindowlongptr(ahwnd:hwnd;nindex:integer) : taddrint;\r
+function setwindowlongptr(ahwnd:hwnd;nindex:integer;dwNewLong : taddrint) : taddrint;\r
+function DefWindowProc(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;\r
+function RegisterClass(const lpWndClass:TWNDCLASS):ATOM;\r
+function CreateWindowEx(dwExStyle:DWORD; lpClassName:LPCSTR; lpWindowName:LPCSTR; dwStyle:DWORD; X:longint;Y:longint; nWidth:longint; nHeight:longint; hWndParent:HWND; hMenu:HMENU;hInstance:HINST; lpParam:LPVOID):HWND;\r
+function DestroyWindow(ahWnd:HWND):WINBOOL;\r
+function PostMessage(hWnd:HWND; Msg:UINT; wParam:WPARAM; lParam:LPARAM):WINBOOL;\r
+function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): WINBOOL;\r
+function DispatchMessage(const lpMsg: TMsg): Longint;\r
+function GetMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT): WINBOOL;\r
+function SetEvent(hEvent:THevent):WINBOOL;\r
+function CreateEvent(lpEventAttributes:PSECURITYATTRIBUTES; bManualReset:WINBOOL; bInitialState:WINBOOL; lpName:pchar):tHevent;\r
+function terminatethread(threadhandle : tthreadid;dummy:integer) : boolean;\r
+function waitforsingleevent(event:thevent;timeout:cardinal) : twaitresult;\r
+function SetTimer(ahWnd:HWND; nIDEvent:taddrint; uElapse:UINT; lpTimerFunc:tTIMERPROC):UINT;\r
+function KillTimer(ahWnd:HWND; uIDEvent:taddrint):WINBOOL;\r
+\r
+procedure init;\r
+\r
+implementation\r
+uses\r
+ baseunix,unix,lcore;//,safewriteln;\r
+{$i unixstuff.inc}\r
+\r
+type\r
+ tmessageintransit = class\r
+ msg : tmsg;\r
+ next : tmessageintransit;\r
+ end;\r
+\r
+ tthreaddata = class\r
+ messagequeue : tmessageintransit;\r
+ messageevent : teventobject;\r
+ waiting : boolean;\r
+ lcorethread : boolean;\r
+ nexttimer : ttimeval;\r
+ threadid : integer;\r
+ end;\r
+ twindow=class\r
+ hwnd : hwnd;\r
+ extrawindowmemory : pointer;\r
+ threadid : tthreadid;\r
+ windowproc : twndproc;\r
+ end;\r
+\r
+var\r
+ structurelock : tcriticalsection;\r
+ threaddata : thashtable;\r
+ windowclasses : thashtable;\r
+ lcorelinkpipesend : integer;\r
+ lcorelinkpiperecv : tlasio;\r
+ windows : thashtable;\r
+ //I would rather things crash immediately\r
+ //if they use an insufficiant size type\r
+ //than crash after over four billion\r
+ //windows have been made ;)\r
+ nextwindowhandle : qword = $100000000;\r
+{$i ltimevalstuff.inc}\r
+\r
+//findthreaddata should only be called while holding the structurelock\r
+function findthreaddata(threadid : integer) : tthreaddata;\r
+begin\r
+ result := tthreaddata(findtree(@threaddata,inttostr(threadid)));\r
+ if result = nil then begin\r
+ result := tthreaddata.create;\r
+ result.messageevent := teventobject.create(nil,false,false,inttostr(taddrint(result)));\r
+ result.nexttimer := tv_invalidtimebig;\r
+ result.threadid := threadid;\r
+ addtree(@threaddata,inttostr(threadid),result);\r
+ end;\r
+end;\r
+\r
+//deletethreaddataifunused should only be called while holding the structurelock\r
+procedure deletethreaddataifunused(athreaddata : tthreaddata);\r
+begin\r
+ //writeln('in deletethreaddataifunused');\r
+ if (athreaddata <> nil) then if (athreaddata.waiting=false) and (athreaddata.messagequeue=nil) and (athreaddata.lcorethread=false) and (athreaddata.nexttimer.tv_sec=tv_invalidtimebig.tv_sec) and (athreaddata.nexttimer.tv_usec=tv_invalidtimebig.tv_usec) then begin\r
+ //writeln('threaddata is unused, freeing messageevent');\r
+ athreaddata.messageevent.free;\r
+ //writeln('freeing thread data object');\r
+ athreaddata.free;\r
+ //writeln('deleting thread data object from hashtable');\r
+ deltree(@threaddata,inttostr(athreaddata.threadid));\r
+ //writeln('finished deleting thread data');\r
+ end else begin\r
+ //writeln('thread data is not unused');\r
+ end;\r
+end;\r
+\r
+function getwindowlongptr(ahwnd:hwnd;nindex:integer) : taddrint;\r
+var\r
+ window : twindow;\r
+begin\r
+ structurelock.acquire;\r
+ try\r
+ window := findtree(@windows,inttostr(ahwnd));\r
+ if window <> nil then begin\r
+ result := paddrint(taddrint(window.extrawindowmemory)+nindex)^;\r
+ end else begin\r
+ result := 0;\r
+ end;\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+end;\r
+\r
+function setwindowlongptr(ahwnd:hwnd;nindex:integer;dwNewLong : taddrint) : taddrint;\r
+var\r
+ window : twindow;\r
+begin\r
+ structurelock.acquire;\r
+ try\r
+ window := findtree(@windows,inttostr(ahwnd));\r
+ if window <> nil then begin\r
+ result := paddrint(taddrint(window.extrawindowmemory)+nindex)^;\r
+ paddrint(taddrint(window.extrawindowmemory)+nindex)^ := dwnewlong;\r
+ end else begin\r
+ result := 0;\r
+ end;\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function DefWindowProc(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;\r
+begin\r
+ result := 0;\r
+end;\r
+\r
+function strdup(s:pchar) : pchar;\r
+begin\r
+ //swriteln('in strdup, about to allocate memory');\r
+ result := getmem(strlen(s)+1);\r
+ //swriteln('about to copy string');\r
+ strcopy(s,result);\r
+ //swriteln('leaving strdup');\r
+end;\r
+\r
+function RegisterClass(const lpWndClass:TWNDCLASS):ATOM;\r
+var\r
+ storedwindowclass:pwndclass;\r
+begin\r
+ structurelock.acquire;\r
+ try\r
+ //swriteln('in registerclass, about to check for duplicate window class');\r
+ storedwindowclass := findtree(@windowclasses, lpwndclass.lpszclassname);\r
+ if storedwindowclass <> nil then begin\r
+\r
+ if comparebyte(storedwindowclass^,lpwndclass,sizeof(twndclass)-sizeof(pchar)-sizeof(pchar)) <> 0 then begin\r
+ //swriteln('duplicate window class registered with different settings');\r
+ raise exception.create('duplicate window class registered with different settings');\r
+ end else begin\r
+ //swriteln('duplicate window class registered with same settings, tollerated');\r
+ end;\r
+ end else begin\r
+ //swriteln('about to allocate memory for new windowclass');\r
+ storedwindowclass := getmem(sizeof(twndclass));\r
+ //swriteln('about to copy windowclass from parameter');\r
+ move(lpwndclass,storedwindowclass^,sizeof(twndclass));\r
+ //swriteln('about to copy strings');\r
+ if lpwndclass.lpszmenuname <> nil then storedwindowclass.lpszmenuname := strdup(lpwndclass.lpszmenuname);\r
+ if lpwndclass.lpszclassname <> nil then storedwindowclass.lpszclassname := strdup(lpwndclass.lpszclassname);\r
+ //swriteln('about to add result to list of windowclasses');\r
+ addtree(@windowclasses,lpwndclass.lpszclassname,storedwindowclass);\r
+ end;\r
+ //swriteln('about to return result');\r
+ result := storedwindowclass;\r
+ //swriteln('leaving registerclass');\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+end;\r
+\r
+function CreateWindowEx(dwExStyle:DWORD; lpClassName:LPCSTR; lpWindowName:LPCSTR; dwStyle:DWORD; X:longint;Y:longint; nWidth:longint; nHeight:longint; hWndParent:HWND; hMenu:HMENU;hInstance:HINST; lpParam:LPVOID):HWND;\r
+var\r
+ wndclass : pwndclass;\r
+ tm : tthreadmanager;\r
+ window : twindow;\r
+begin\r
+ structurelock.acquire;\r
+ try\r
+ window := twindow.create;\r
+ window.hwnd := nextwindowhandle;\r
+ result := window.hwnd;\r
+ nextwindowhandle := nextwindowhandle + 1;\r
+ addtree(@windows,inttostr(window.hwnd),window);\r
+ wndclass := findtree(@windowclasses,lpclassname);\r
+ window.extrawindowmemory := getmem(wndclass.cbwndextra);\r
+\r
+ getthreadmanager(tm);\r
+ window.threadid := tm.GetCurrentThreadId;\r
+ window.windowproc := wndclass.lpfnwndproc;\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+end;\r
+function DestroyWindow(ahWnd:HWND):WINBOOL;\r
+var\r
+ window : twindow;\r
+ windowthreaddata : tthreaddata;\r
+ currentmessage : tmessageintransit;\r
+ prevmessage : tmessageintransit;\r
+begin\r
+ //writeln('started to destroy window');\r
+ structurelock.acquire;\r
+ try\r
+ window := twindow(findtree(@windows,inttostr(ahwnd)));\r
+ if window <> nil then begin\r
+ freemem(window.extrawindowmemory);\r
+ //writeln('aboute to delete window from windows structure');\r
+ deltree(@windows,inttostr(ahwnd));\r
+ //writeln('deleted window from windows structure');\r
+ windowthreaddata := tthreaddata(findtree(@threaddata,inttostr(window.threadid)));\r
+\r
+ if windowthreaddata <> nil then begin\r
+ //writeln('found thread data scanning for messages to clean up');\r
+ currentmessage := windowthreaddata.messagequeue;\r
+ prevmessage := nil;\r
+ while currentmessage <> nil do begin\r
+ while (currentmessage <> nil) and (currentmessage.msg.hwnd = ahwnd) do begin\r
+ if prevmessage = nil then begin\r
+ windowthreaddata.messagequeue := currentmessage.next;\r
+ end else begin\r
+ prevmessage.next := currentmessage.next;\r
+ end;\r
+ currentmessage.free;\r
+ if prevmessage = nil then begin\r
+ currentmessage := windowthreaddata.messagequeue;\r
+ end else begin\r
+ currentmessage := prevmessage.next;\r
+ end;\r
+ end;\r
+ if currentmessage <> nil then begin\r
+ prevmessage := currentmessage;\r
+ currentmessage := currentmessage.next;\r
+ end;\r
+ end;\r
+ //writeln('deleting thread data structure if it is unused');\r
+ deletethreaddataifunused(windowthreaddata);\r
+ end else begin\r
+ //writeln('there is no thread data to search for messages to cleanup');\r
+ end;\r
+ //writeln('freeing window');\r
+ window.free;\r
+ result := true;\r
+ end else begin\r
+ result := false;\r
+ end;\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+ //writeln('window destroyed');\r
+end;\r
+\r
+\r
+\r
+function PostMessage(hWnd:HWND; Msg:UINT; wParam:WPARAM; lParam:LPARAM):WINBOOL;\r
+var\r
+ threaddata : tthreaddata;\r
+ message : tmessageintransit;\r
+ messagequeueend : tmessageintransit;\r
+ window : twindow;\r
+begin\r
+ structurelock.acquire;\r
+ try\r
+ window := findtree(@windows,inttostr(hwnd));\r
+ if window <> nil then begin\r
+ threaddata := findthreaddata(window.threadid);\r
+ message := tmessageintransit.create;\r
+ message.msg.hwnd := hwnd;\r
+ message.msg.message := msg;\r
+ message.msg.wparam := wparam;\r
+ message.msg.lparam := lparam;\r
+ if threaddata.lcorethread then begin\r
+ //swriteln('posting message to lcore thread');\r
+ fdwrite(lcorelinkpipesend,message,sizeof(message));\r
+ end else begin\r
+ //writeln('posting message to non lcore thread');\r
+ if threaddata.messagequeue = nil then begin\r
+ threaddata.messagequeue := message;\r
+ end else begin\r
+ messagequeueend := threaddata.messagequeue;\r
+ while messagequeueend.next <> nil do begin\r
+ messagequeueend := messagequeueend.next;\r
+ end;\r
+ messagequeueend.next := message;\r
+ end;\r
+\r
+ //writeln('message added to queue');\r
+ if threaddata.waiting then threaddata.messageevent.setevent;\r
+ end;\r
+ result := true;\r
+ end else begin\r
+ result := false;\r
+ end;\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+\r
+end;\r
+\r
+function gettickcount : dword;\r
+var\r
+ result64: integer;\r
+ tv : ttimeval;\r
+begin\r
+ gettimeofday(tv);\r
+ result64 := (tv.tv_sec*1000)+(tv.tv_usec div 1000);\r
+ result := result64;\r
+end;\r
+\r
+function DispatchMessage(const lpMsg: TMsg): Longint;\r
+var\r
+ timerproc : ttimerproc;\r
+ window : twindow;\r
+ windowproc : twndproc;\r
+begin\r
+ ////swriteln('in dispatchmessage, msg.hwnd='+inttohex(taddrint(lpmsg.hwnd),16));\r
+ if (lpmsg.lparam <> 0) and (lpmsg.message = WM_TIMER) then begin\r
+ timerproc := ttimerproc(lpmsg.lparam);\r
+ timerproc(lpmsg.hwnd,lpmsg.message,lpmsg.wparam,gettickcount);\r
+ result := 0;\r
+ end else begin\r
+ structurelock.acquire;\r
+ try\r
+ window := findtree(@windows,inttostr(lpmsg.hwnd));\r
+ //we have to get the window procedure while the structurelock\r
+ //is still held as the window could be destroyed from another thread\r
+ //otherwise.\r
+ windowproc := window.windowproc;\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+ if window <> nil then begin\r
+ result := windowproc(lpmsg.hwnd,lpmsg.message,lpmsg.wparam,lpmsg.lparam);\r
+ end else begin\r
+ result := -1;\r
+ end;\r
+ end;\r
+end;\r
+\r
+procedure processtimers;\r
+begin\r
+end;\r
+\r
+function GetMessageinternal(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT; wremovemsg : UINT;peek:boolean): WINBOOL;\r
+var\r
+ tm : tthreadmanager;\r
+ threaddata : tthreaddata;\r
+ message : tmessageintransit;\r
+ nowtv : ttimeval;\r
+ timeouttv : ttimeval;\r
+ timeoutms : int64;\r
+\r
+begin\r
+ if hwnd <> 0 then raise exception.create('getting messages for an individual window is not supported');\r
+ if (wmsgfiltermin <> 0) or (wmsgfiltermax <> 0) then raise exception.create('message filtering is not supported');\r
+ structurelock.acquire;\r
+ result := true;\r
+ try\r
+ getthreadmanager(tm);\r
+ threaddata := findthreaddata(tm.GetCurrentThreadId);\r
+ if threaddata.lcorethread then raise exception.create('get/peek message cannot be used in the lcore thread');\r
+ message := threaddata.messagequeue;\r
+ gettimeofday(nowtv);\r
+ while (not peek) and (message=nil) and (not tv_compare(nowtv,threaddata.nexttimer)) do begin\r
+ threaddata.waiting := true;\r
+ structurelock.release;\r
+ if (threaddata.nexttimer.tv_sec = TV_invalidtimebig.tv_sec) and (threaddata.nexttimer.tv_usec = TV_invalidtimebig.tv_usec) then begin\r
+ threaddata.messageevent.waitfor(INFINITE);\r
+ end else begin\r
+\r
+ timeouttv := threaddata.nexttimer;\r
+ timeoutms := (timeouttv.tv_sec * 1000)+(timeouttv.tv_usec div 1000);\r
+ //i'm assuming the timeout is in milliseconds\r
+ if (timeoutms > maxlongint) then timeoutms := maxlongint;\r
+ threaddata.messageevent.waitfor(timeoutms);\r
+\r
+ end;\r
+ structurelock.acquire;\r
+ threaddata.waiting := false;\r
+ message := threaddata.messagequeue;\r
+ gettimeofday(nowtv);\r
+ end;\r
+ if (message=nil) and tv_compare(nowtv,threaddata.nexttimer) then begin\r
+ processtimers;\r
+ end;\r
+ message := threaddata.messagequeue;\r
+ if message <> nil then begin\r
+ lpmsg := message.msg;\r
+ if wremovemsg=PM_REMOVE then begin\r
+ threaddata.messagequeue := message.next;\r
+ message.free;\r
+ end;\r
+ end else begin\r
+ result :=false;\r
+ end;\r
+ deletethreaddataifunused(threaddata);\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+end;\r
+\r
+function GetMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT): WINBOOL;\r
+begin\r
+ result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,PM_REMOVE,false);\r
+end;\r
+\r
+function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): WINBOOL;\r
+begin\r
+ result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,PM_REMOVE,true);\r
+end;\r
+\r
+function SetEvent(hEvent:THevent):WINBOOL;\r
+begin\r
+ hevent.setevent;\r
+ result := true;\r
+end;\r
+\r
+function CreateEvent(lpEventAttributes:PSECURITYATTRIBUTES; bManualReset:WINBOOL; bInitialState:WINBOOL; lpName:pchar):tHevent;\r
+begin\r
+ result := teventobject.create(lpeventattributes,bmanualreset,binitialstate,lpname);\r
+end;\r
+\r
+function terminatethread(threadhandle:tthreadid;dummy : integer) : boolean;\r
+var\r
+ tm : tthreadmanager;\r
+begin\r
+ getthreadmanager(tm);\r
+ tm.killthread(threadhandle);\r
+ result := true;\r
+end;\r
+\r
+function waitforsingleevent(event:thevent;timeout:cardinal) : twaitresult;\r
+begin\r
+ result := event.waitfor(timeout);\r
+end;\r
+\r
+procedure removefrombuffer(n : integer; var buffer:string);\r
+begin\r
+ if n=length(buffer) then begin\r
+ buffer := '';\r
+ end else begin\r
+ uniquestring(buffer);\r
+ move(buffer[n+1],buffer[1],length(buffer)-n);\r
+ setlength(buffer,length(buffer)-n);\r
+ end;\r
+end;\r
+\r
+type\r
+ tsc=class\r
+ procedure available(sender:tobject;error:word);\r
+ end;\r
+\r
+var\r
+ recvbuf : string;\r
+\r
+procedure tsc.available(sender:tobject;error:word);\r
+var\r
+ message : tmessageintransit;\r
+ messagebytes : array[1..sizeof(tmessageintransit)] of char absolute message;\r
+ i : integer;\r
+begin\r
+ //swriteln('received data on lcorelinkpipe');\r
+ recvbuf := recvbuf + lcorelinkpiperecv.receivestr;\r
+ while length(recvbuf) >= sizeof(tmessageintransit) do begin\r
+ for i := 1 to sizeof(tmessageintransit) do begin\r
+ messagebytes[i] := recvbuf[i];\r
+ end;\r
+ dispatchmessage(message.msg);\r
+ message.free;\r
+ removefrombuffer(sizeof(tmessageintransit),recvbuf);\r
+ end;\r
+end;\r
+\r
+procedure init;\r
+var\r
+ tm : tthreadmanager;\r
+ threaddata : tthreaddata;\r
+ pipeends : tfildes;\r
+ sc : tsc;\r
+begin\r
+ structurelock := tcriticalsection.create;\r
+ getthreadmanager(tm);\r
+ threaddata := findthreaddata(tm.GetCurrentThreadId);\r
+ threaddata.lcorethread := true;\r
+ fppipe(pipeends);\r
+ lcorelinkpipesend := pipeends[1];\r
+ lcorelinkpiperecv := tlasio.create(nil);\r
+ lcorelinkpiperecv.dup(pipeends[0]);\r
+ lcorelinkpiperecv.ondataavailable := sc.available;\r
+ recvbuf := '';\r
+end;\r
+\r
+var\r
+ lcorethreadtimers : thashtable;\r
+type\r
+ tltimerformsg = class(tltimer)\r
+ public\r
+ hwnd : hwnd;\r
+ id : taddrint;\r
+ procedure timer(sender : tobject);\r
+ end;\r
+\r
+procedure tltimerformsg.timer(sender : tobject);\r
+var\r
+ msg : tmsg;\r
+begin\r
+ ////swriteln('in tltimerformsg.timer');\r
+ fillchar(msg,sizeof(msg),0);\r
+ msg.message := WM_TIMER;\r
+ msg.hwnd := hwnd;\r
+ msg.wparam := ID;\r
+ msg.lparam := 0;\r
+ dispatchmessage(msg);\r
+end;\r
+\r
+function SetTimer(ahWnd:HWND; nIDEvent:taddrint; uElapse:UINT; lpTimerFunc:tTIMERPROC):UINT;\r
+var\r
+ threaddata : tthreaddata;\r
+ ltimer : tltimerformsg;\r
+ tm : tthreadmanager;\r
+ window : twindow;\r
+begin\r
+ structurelock.acquire;\r
+ try\r
+ window := findtree(@windows,inttostr(ahwnd));\r
+ if window= nil then raise exception.create('invalid window');\r
+ threaddata := findthreaddata(window.threadid);\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+ if threaddata.lcorethread then begin\r
+ getthreadmanager(tm);\r
+ if tm.GetCurrentThreadId <> window.threadid then raise exception.create('timers on the lcore thread may only be added and removed from the lcore thread');\r
+ if ahwnd = 0 then raise exception.create('timers on the lcore thread must be associated with a window handle');\r
+ if @lptimerfunc <> nil then raise exception.create('seperate timer functions are not supported');\r
+\r
+ //remove preexisting timer with same ID\r
+ killtimer(ahwnd,nIDEvent);\r
+\r
+ ltimer := tltimerformsg.create(nil);\r
+ ltimer.interval := uelapse;\r
+ ltimer.id := nidevent;\r
+ ltimer.hwnd := ahwnd;\r
+ ltimer.enabled := true;\r
+ ltimer.ontimer := ltimer.timer;\r
+\r
+ addtree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(nIDEvent),ltimer);\r
+\r
+ result := nidevent;\r
+ end else begin\r
+ raise exception.create('settimer not implemented for threads other than the lcore thread');\r
+ end;\r
+end;\r
+\r
+function KillTimer(ahWnd:HWND; uIDEvent:taddrint):WINBOOL;\r
+var\r
+ threaddata : tthreaddata;\r
+ ltimer : tltimerformsg;\r
+ tm : tthreadmanager;\r
+ window : twindow;\r
+begin\r
+ structurelock.acquire;\r
+ try\r
+ window := findtree(@windows,inttostr(ahwnd));\r
+ if window= nil then raise exception.create('invalid window');\r
+ threaddata := findthreaddata(window.threadid);\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+ if threaddata.lcorethread then begin\r
+ getthreadmanager(tm);\r
+ if tm.GetCurrentThreadId <> window.threadid then raise exception.create('timers on the lcore thread may only be added and remove from the lcore thread');\r
+ if ahwnd = 0 then raise exception.create('timers on the lcore thread must be associated with a window handle');\r
+ ltimer := tltimerformsg(findtree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(uIDEvent)));\r
+ if ltimer <> nil then begin\r
+ deltree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(uIDEvent));\r
+ ltimer.free;\r
+ result := true;\r
+ end else begin\r
+ result := false;\r
+ end;\r
+ end else begin\r
+ raise exception.create('settimer not implemented for threads other than the lcore thread');\r
+ end;\r
+end;\r
+\r
+end.
\ No newline at end of file
--- /dev/null
+{lsocket.pas}\r
+\r
+{signal code by plugwash}\r
+\r
+{ 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 lsignal;\r
+{$mode delphi}\r
+interface\r
+ uses sysutils,\r
+ {$ifdef VER1_0}\r
+ linux,\r
+ {$else}\r
+ baseunix,unix,\r
+ {$endif}\r
+ classes,lcore,lloopback;\r
+\r
+ type\r
+ tsignalevent=procedure(sender:tobject;signal:integer) of object;\r
+ tlsignal=class(tcomponent)\r
+ public\r
+ onsignal : tsignalevent ;\r
+ prevsignal : tlsignal ;\r
+ nextsignal : tlsignal ;\r
+\r
+ constructor create(aowner:tcomponent);override;\r
+ destructor destroy;override;\r
+ end;\r
+\r
+ \r
+ procedure starthandlesignal(signal:integer);\r
+\r
+var\r
+ firstsignal : tlsignal;\r
+ blockset : sigset;\r
+ signalloopback : tlloopback ;\r
+
+implementation\r
+{$include unixstuff.inc}\r
+\r
+constructor tlsignal.create;\r
+begin\r
+ inherited create(AOwner);\r
+ nextsignal := firstsignal;\r
+ prevsignal := nil;\r
+\r
+ if assigned(nextsignal) then nextsignal.prevsignal := self;\r
+ firstsignal := self;\r
+\r
+ //interval := 1000;\r
+ //enabled := true;\r
+ //released := false;\r
+end;\r
+\r
+destructor tlsignal.destroy;\r
+begin\r
+ if prevsignal <> nil then begin\r
+ prevsignal.nextsignal := nextsignal;\r
+ end else begin\r
+ firstsignal := nextsignal;\r
+ end;\r
+ if nextsignal <> nil then begin\r
+ nextsignal.prevsignal := prevsignal;\r
+ end;\r
+ inherited destroy;\r
+end;\r
+{$ifdef linux}\r
+ {$ifdef ver1_9_8}\r
+ {$define needsignalworkaround}\r
+ {$endif}\r
+ {$ifdef ver2_0_0}\r
+ {$define needsignalworkaround}\r
+ {$endif}\r
+ {$ifdef ver2_0_2}\r
+ {$define needsignalworkaround}\r
+ {$endif}\r
+{$endif}\r
+{$ifdef needsignalworkaround}\r
+ //using the 1.9.6 version of this stuff because the 1.9.8 and 2.0.0 versions seem broken\r
+ type\r
+ TSysParam = Longint;\r
+ TSysResult = longint;\r
+ const\r
+ syscall_nr_sigaction = 67;\r
+ //function Do_SysCall(sysnr:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL0';\r
+ //function Do_SysCall(sysnr,param1:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL1';\r
+ //function Do_SysCall(sysnr,param1,param2:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL2';\r
+ function Do_SysCall(sysnr,param1,param2,param3:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL3';\r
+ //function Do_SysCall(sysnr,param1,param2,param3,param4:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL4';\r
+ //function Do_SysCall(sysnr,param1,param2,param3,param4,param5:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL5';\r
+\r
+ function Fpsigaction(sig: cint; act : psigactionrec; oact : psigactionrec): cint;// [public, alias : 'FPC_SYSC_SIGACTION'];\r
+ {\r
+ Change action of process upon receipt of a signal.\r
+ Signum specifies the signal (all except SigKill and SigStop).\r
+ If Act is non-nil, it is used to specify the new action.\r
+ If OldAct is non-nil the previous action is saved there.\r
+ }\r
+ begin\r
+ //writeln('fucking');\r
+ {$ifdef RTSIGACTION}\r
+ {$ifdef cpusparc}\r
+ { Sparc has an extra stub parameter }\r
+ Fpsigaction:=do_syscall(syscall_nr_rt_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact),TSysParam(PtrInt(@Fprt_sigreturn_stub)-8),TSysParam(8));\r
+ {$else cpusparc}\r
+ Fpsigaction:=do_syscall(syscall_nr_rt_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact),TSysParam(8));\r
+ {$endif cpusparc}\r
+ {$else RTSIGACTION}\r
+ //writeln('nice');\r
+ Fpsigaction:=do_syscall(syscall_nr_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact));\r
+ {$endif RTSIGACTION}\r
+ end;\r
+{$endif}\r
+\r
+// cdecl procedures are not name mangled\r
+// so USING something unlikely to cause colliesions in the global namespace\r
+// is a good idea\r
+procedure lsignal_handler( Sig : Integer);cdecl;\r
+var\r
+ currentsignal : tlsignal;\r
+begin\r
+// writeln('in lsignal_hanler');\r
+ currentsignal := firstsignal;\r
+ while assigned(currentsignal) do begin\r
+ if assigned(currentsignal.onsignal) then currentsignal.onsignal(currentsignal,sig);\r
+ currentsignal := currentsignal.nextsignal;\r
+\r
+ end;\r
+// writeln('about to send down signalloopback');\r
+ if assigned(signalloopback) then begin\r
+ signalloopback.sendstr(' ');\r
+ end;\r
+// writeln('left lsignal_hanler');\r
+end;\r
+\r
+{$ifdef freebsd}\r
+\r
+{$if (FPC_VERSION > 2) or ((FPC_VERSION = 2) and (FPC_RELEASE >= 2))}\r
+procedure lsignal_handler2(signal:longint;info:PSigInfo;context:psigcontext); cdecl;\r
+{$else}\r
+procedure lsignal_handler2(signal:longint;var info:TSigInfo_t;var context:SigContextRec); cdecl;\r
+{$endif}\r
+\r
+begin\r
+ lsignal_handler(signal);\r
+end;\r
+{$endif}\r
+\r
+\r
+const\r
+ allbitsset=-1;\r
+ {$ifdef ver1_0}\r
+ saction : sigactionrec = (handler:(sh:lsignal_handler);sa_flags:0);\r
+ {$else}\r
+ {$ifdef darwin}\r
+ saction : sigactionrec = (sa_handler:tsigaction(lsignal_handler);sa_flags:0);\r
+ {$else}\r
+ {$ifdef freebsd}\r
+ //version number is FPC_VERSION.FPC_RELEASE.FPC_PATCH\r
+ {$if (FPC_VERSION>2) or ((FPC_VERSION=2) and (FPC_RELEASE>0)) or ((FPC_VERSION=2) and (fpc_release=0) and (fpc_patch>=2))}\r
+ saction : sigactionrec = (sa_handler:lsignal_handler2;sa_flags:0);\r
+ {$else}\r
+ saction : sigactionrec = (sa_handler:tsigaction(lsignal_handler);sa_flags:0);\r
+ {$endif}\r
+ \r
+ {$else}\r
+ {$ifdef ver1_9_2}\r
+ saction : sigactionrec = (handler:(sh:lsignal_handler);sa_flags:0);\r
+ {$else}\r
+ //version number is FPC_VERSION.FPC_RELEASE.FPC_PATCH\r
+ {$if (FPC_VERSION>2) or ((FPC_VERSION=2) and (FPC_RELEASE>0)) or ((FPC_VERSION=2) and (fpc_release=0) and (fpc_patch>=2))}\r
+ saction : sigactionrec = (sa_handler:{$ifndef ver1_9_6}{$ifndef ver1_9_6}{$ifndef ver1_0}SigActionHandler{$endif}{$endif}{$endif}(lsignal_handler);sa_flags:0;sa_restorer:nil);\r
+ {$else}\r
+ saction : sigactionrec = (sa_handler:{$ifndef ver1_9_6}{$ifndef ver1_9_6}{$ifndef ver1_0}SigActionHandler{$endif}{$endif}{$endif}(lsignal_handler));\r
+ {$endif}\r
+ {$endif}\r
+ {$endif}\r
+ {$endif}\r
+ {$endif}\r
+procedure starthandlesignal(signal:integer);\r
+begin\r
+ if signal in ([0..31]-[sigkill,sigstop]) then begin\r
+ sigprocmask(SIG_BLOCK,@blockset,nil);\r
+ sigaction(signal,@saction,nil)\r
+ end else begin\r
+ raise exception.create('invalid signal number')\r
+ end;\r
+end;\r
+\r
+initialization\r
+ fillchar(blockset,sizeof(blockset),0);\r
+ blockset[0] := $FFFFFFFF - (1 shl sigstop) - (1 shl sigkill) - (1 shl sigsegv);\r
+ saction.sa_mask := blockset;\r
+ \r
+end.\r
--- /dev/null
+{lsocket.pas}\r
+\r
+{socket code by plugwash}\r
+\r
+{ 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
+changes by plugwash (20030728)\r
+* created handlefdtrigger virtual method in tlasio (overridden in tlsocket) and moved a lot of code from messageloop into it\r
+* changed tlasio to tlasio\r
+* split fdhandle into fdhandlein and fdhandleout\r
+* i now use fdsrmaster and fdswmaster instead of rebuilding the lists every loop\r
+* split lsocket.pas into lsocket.pas and lcore.pas\r
+\r
+\r
+changes by beware (20030903)\r
+* added getxaddr, getxport (local addr, port, as string)\r
+* added getpeername, remote addr+port as binary\r
+* added htons and htonl functions (endian swap, same interface as windows API)\r
+\r
+beware (20030905)\r
+* if connect failed (conn refused) set state to connected and call internalclose, to get closed handler (instead of fdclose)\r
+* (lcore) if closing the fd's in internalcose, set fd's to -1 because closing an fd makes it invalid\r
+\r
+beware (20030927)\r
+* fixed: on connect failed, tried to close fdhandle's which were already set to -1, added check\r
+\r
+beware (20031017)\r
+* added getpeeraddr, getpeerport, remote addr+port as string\r
+}\r
+\r
+\r
+unit lsocket;\r
+{$ifdef fpc}\r
+ {$mode delphi}\r
+{$endif}\r
+interface\r
+ uses\r
+ sysutils,\r
+ {$ifdef win32}\r
+ windows,winsock,\r
+ {$else}\r
+\r
+ {$ifdef VER1_0}\r
+ linux,\r
+ {$else}\r
+ baseunix,unix,\r
+ {$endif}\r
+ sockets,\r
+ {$endif}\r
+ classes,{pgdebugout,}pgtypes,lcore,fd_utils,binipstuff,dnssync;\r
+type\r
+ sunB = packed record\r
+ s_b1, s_b2, s_b3, s_b4: byte;\r
+ end;\r
+\r
+ SunW = packed record\r
+ s_w1, s_w2: word;\r
+ end;\r
+\r
+ TInAddr = packed record\r
+ case integer of\r
+ 0: (S_un_b: SunB);\r
+ 1: (S_un_w: SunW);\r
+ 2: (S_addr: cardinal);\r
+ end;\r
+ {$ifdef ipv6}\r
+ {$ifdef ver1_0}\r
+ cuint16=word;\r
+ cuint32=dword;\r
+ sa_family_t=word;\r
+\r
+\r
+ TInetSockAddr6 = packed Record\r
+ sin6_family : sa_family_t;\r
+ sin6_port : cuint16;\r
+ sin6_flowinfo : cuint32;\r
+ sin6_addr : Tin6_addr;\r
+ sin6_scope_id : cuint32;\r
+ end;\r
+ {$endif}\r
+ {$endif}\r
+ TinetSockAddrv = packed record\r
+ case integer of\r
+ 0: (InAddr:TInetSockAddr);\r
+ {$ifdef ipv6}\r
+ 1: (InAddr6:TInetSockAddr6);\r
+ {$endif}\r
+ end;\r
+ Pinetsockaddrv = ^Tinetsockaddrv;\r
+\r
+\r
+ type\r
+ tsockaddrin=TInetSockAddr;\r
+\r
+ type\r
+ TLsocket = class(tlasio)\r
+ public\r
+ //a: string;\r
+\r
+ inAddr : TInetSockAddrV;\r
+{ inAddrSize:integer;}\r
+\r
+ //host : THostentry ;\r
+\r
+ //mainthread : boolean ; //for debuggin only\r
+ addr:string;\r
+ port:string;\r
+ localaddr:string;\r
+ localport:string;\r
+ proto:string;\r
+ udp:boolean;\r
+ listenqueue:integer;\r
+ function getaddrsize:integer;\r
+ procedure connect; virtual;\r
+ procedure bindsocket;\r
+ procedure listen;\r
+ function accept : longint;\r
+ function sendto(dest:TInetSockAddr;destlen:integer;data:pointer;len:integer):integer; virtual;\r
+ function receivefrom(data:pointer;len:integer;var src:TInetSockAddr;var srclen:integer):integer; virtual;\r
+ //procedure internalclose(error:word);override;\r
+ procedure handlefdtrigger(readtrigger,writetrigger:boolean); override;\r
+ function send(data:pointer;len:integer):integer;override;\r
+ procedure sendstr(const str : string);override;\r
+ function Receive(Buf:Pointer;BufSize:integer):integer; override;\r
+ function getpeername(var addr:tsockaddrin;addrlen:integer):integer; virtual;\r
+ procedure getXaddrbin(var binip:tbinip); virtual;\r
+ procedure getpeeraddrbin(var binip:tbinip); virtual;\r
+ function getXaddr:string; virtual;\r
+ function getpeeraddr:string; virtual;\r
+ function getXport:string; virtual;\r
+ function getpeerport:string; virtual;\r
+ constructor Create(AOwner: TComponent); override;\r
+ {$ifdef win32}\r
+ procedure myfdclose(fd : integer); override;\r
+ function myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt; override;\r
+ function myfdread(fd: LongInt;var buf;size: LongInt):LongInt; override;\r
+ {$endif}\r
+ end;\r
+ tsocket=longint; // for compatibility with twsocket\r
+\r
+ twsocket=tlsocket; {easy}\r
+\r
+function htons(w:word):word;\r
+function htonl(i:integer):integer;\r
+{!!!function longipdns(s:string):longint;}\r
+\r
+{$ifdef ipv6}\r
+const\r
+ v4listendefault:boolean=false;\r
+{$endif}\r
+\r
+\r
+const\r
+ TCP_NODELAY=1;\r
+ IPPROTO_TCP=6;\r
+\r
+implementation\r
+{$include unixstuff.inc}\r
+\r
+function longip(s:string):longint;{$ifdef fpc}inline;{$endif}\r
+var\r
+ l:longint;\r
+ a,b:integer;\r
+\r
+function convertbyte(const s:string):integer;{$ifdef fpc}inline;{$endif}\r
+begin\r
+ result := strtointdef(s,-1);\r
+ if result < 0 then exit;\r
+ if result > 255 then exit;\r
+\r
+ {01 exception}\r
+ if (result <> 0) and (s[1] = '0') then begin\r
+ result := -1;\r
+ exit;\r
+ end;\r
+\r
+ {+1 exception}\r
+ if not (s[1] in ['0'..'9']) then begin\r
+ result := -1;\r
+ exit\r
+ end;\r
+end;\r
+\r
+begin\r
+ result := 0;\r
+ a := pos('.',s);\r
+ if a = 0 then exit;\r
+ b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+ l := b shl 24;\r
+ s := copy(s,a+1,256);\r
+ a := pos('.',s);\r
+ if a = 0 then exit;\r
+ b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+ l := l or b shl 16;\r
+ s := copy(s,a+1,256);\r
+ a := pos('.',s);\r
+ if a = 0 then exit;\r
+ b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+ l := l or b shl 8;\r
+ s := copy(s,a+1,256);\r
+ b := convertbyte(copy(s,1,256));if (b < 0) then exit;\r
+ l := l or b;\r
+ result := l;\r
+end;\r
+\r
+(*!!!\r
+function longipdns(s:string):longint;\r
+var\r
+ host : thostentry;\r
+begin\r
+ if s = '0.0.0.0' then begin\r
+ result := 0;\r
+ end else begin\r
+ result := longip(s);\r
+ if result = 0 then begin\r
+ if gethostbyname(s,host) then begin;\r
+ result := htonl(Longint(Host.Addr));\r
+ end;\r
+ //writeln(inttohex(longint(host.addr),8))\r
+ end;\r
+ if result = 0 then begin\r
+ if resolvehostbyname(s,host) then begin;\r
+ result := htonl(Longint(Host.Addr));\r
+ end;\r
+ //writeln(inttohex(longint(host.addr),8))\r
+ end;\r
+ end;\r
+end;\r
+*)\r
+\r
+\r
+function htons(w:word):word;\r
+begin\r
+ {$ifndef ENDIAN_BIG}\r
+ result := ((w and $ff00) shr 8) or ((w and $ff) shl 8);\r
+ {$else}\r
+ result := w;\r
+ {$endif}\r
+end;\r
+\r
+function htonl(i:integer):integer;\r
+begin\r
+ {$ifndef ENDIAN_BIG}\r
+ result := (i shr 24) or (i shr 8 and $ff00) or (i shl 8 and $ff0000) or (i shl 24 and $ff000000);\r
+ {$else}\r
+ result := i;\r
+ {$endif}\r
+end;\r
+\r
+function tlsocket.getaddrsize:integer;\r
+begin\r
+ {$ifdef ipv6}\r
+ if inaddr.inaddr.family = AF_INET6 then result := sizeof(tinetsockaddr6) else\r
+ {$endif}\r
+ result := sizeof(tinetsockaddr);\r
+end;\r
+\r
+function makeinaddrv(addr,port:string;var inaddr:tinetsockaddrv):integer;\r
+var\r
+ biniptemp:tbinip;\r
+begin\r
+ result := 0;\r
+ biniptemp := forwardlookup(addr,10);\r
+ fillchar(inaddr,sizeof(inaddr),0);\r
+ //writeln('converted address '+addr+' to binip '+ipbintostr(biniptemp));\r
+ if biniptemp.family = AF_INET then begin\r
+ inAddr.InAddr.family:=AF_INET;\r
+ inAddr.InAddr.port:=htons(strtointdef(port,0));\r
+ inAddr.InAddr.addr:=biniptemp.ip;\r
+ result := sizeof(tinetsockaddr);\r
+ end else\r
+ {$ifdef ipv6}\r
+ if biniptemp.family = AF_INET6 then begin\r
+ inAddr.InAddr6.sin6_family:=AF_INET6;\r
+ inAddr.InAddr6.sin6_port:=htons(strtointdef(port,0));\r
+ inAddr.InAddr6.sin6_addr:=biniptemp.ip6;\r
+ result := sizeof(tinetsockaddr6);\r
+ end else\r
+ {$endif}\r
+ raise esocketexception.create('unable to resolve address: '+addr);\r
+end;\r
+\r
+procedure tlsocket.connect;\r
+var\r
+ a:integer;\r
+begin\r
+ if state <> wsclosed then close;\r
+ //prevtime := 0;\r
+ makeinaddrv(addr,port,inaddr);\r
+\r
+ udp := uppercase(proto) = 'UDP';\r
+ if udp then a := SOCK_DGRAM else a := SOCK_STREAM;\r
+ a := Socket(inaddr.inaddr.family,a,0);\r
+\r
+ //writeln(ord(inaddr.inaddr.family));\r
+ if a = -1 then begin\r
+ lasterror := {$ifdef win32}getlasterror{$else}socketerror{$endif};\r
+ raise esocketexception.create('unable to create socket');\r
+ end;\r
+ try\r
+ dup(a);\r
+ bindsocket;\r
+ if udp then begin\r
+ {$ifndef win32}\r
+ SetSocketOptions(fdhandleout, SOL_SOCKET, SO_BROADCAST, 'TRUE', Length('TRUE'));\r
+ {$endif}\r
+ state := wsconnected;\r
+ if assigned(onsessionconnected) then onsessionconnected(self,0);\r
+ end else begin\r
+ state :=wsconnecting;\r
+ {$ifdef win32}\r
+ //writeln(inaddr.inaddr.port);\r
+ winsock.Connect(fdhandlein,winsock.psockaddr(@inADDR)^,getaddrsize);\r
+ {$else}\r
+ sockets.Connect(fdhandlein,inADDR,getaddrsize);\r
+ {$endif}\r
+ end;\r
+ eventcore.rmasterset(fdhandlein,false);\r
+ if udp then begin\r
+ eventcore.wmasterclr(fdhandleout);\r
+ end else begin\r
+ eventcore.wmasterset(fdhandleout);\r
+ end;\r
+ //sendq := '';\r
+ except\r
+ on e: exception do begin\r
+ fdcleanup;\r
+ raise; //reraise the exception\r
+ end;\r
+ end;\r
+end;\r
+\r
+procedure tlsocket.sendstr(const str : string);\r
+begin\r
+ if udp then begin\r
+ send(@str[1],length(str))\r
+ end else begin\r
+ inherited sendstr(str);\r
+ end;\r
+end;\r
+\r
+function tlsocket.send(data:pointer;len:integer):integer;\r
+begin\r
+ if udp then begin\r
+ //writeln('sending to '+inttohex(inaddr.inaddr.addr,8));\r
+ result := sendto(inaddr.inaddr,getaddrsize,data,len)\r
+;\r
+ //writeln('send result',result);\r
+ //writeln('errno',errno);\r
+ end else begin\r
+ result := inherited send(data,len);\r
+ end;\r
+end;\r
+\r
+\r
+function tlsocket.receive(Buf:Pointer;BufSize:integer):integer;\r
+begin\r
+ if udp then begin\r
+ result := myfdread(self.fdhandlein,buf^,bufsize);\r
+ end else begin\r
+ result := inherited receive(buf,bufsize);\r
+ end;\r
+end;\r
+\r
+procedure tlsocket.bindsocket;\r
+var\r
+ a:integer;\r
+ inAddrtemp:TInetSockAddrV;\r
+ inAddrtempx:{$ifdef win32}winsock.TSockaddr{$else}TInetSockAddrV{$endif} absolute inaddrtemp;\r
+ inaddrtempsize:integer;\r
+begin\r
+ try\r
+ if (localaddr <> '') or (localport <> '') then begin\r
+ if localaddr = '' then begin\r
+ {$ifdef ipv6}\r
+ if inaddr.inaddr.family = AF_INET6 then localaddr := '::' else\r
+ {$endif}\r
+ localaddr := '0.0.0.0';\r
+ end;\r
+ //gethostbyname(localaddr,host);\r
+\r
+ inaddrtempsize := makeinaddrv(localaddr,localport,inaddrtemp);\r
+\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
+ end;\r
+ state := wsbound;\r
+ end;\r
+ except\r
+ on e: exception do begin\r
+ fdcleanup;\r
+ raise; //reraise the exception\r
+ end;\r
+ end;\r
+end;\r
+\r
+procedure tlsocket.listen;\r
+var\r
+ yes:longint;\r
+ socktype:integer;\r
+ biniptemp:tbinip;\r
+ origaddr:string;\r
+begin\r
+ if state <> wsclosed then close;\r
+ udp := uppercase(proto) = 'UDP';\r
+ if udp then socktype := SOCK_DGRAM else socktype := SOCK_STREAM;\r
+ origaddr := addr;\r
+\r
+ if addr = '' then begin\r
+ {$ifdef ipv6}\r
+ if not v4listendefault then begin\r
+ addr := '::';\r
+ end else\r
+ {$endif}\r
+ addr := '0.0.0.0';\r
+ end;\r
+ biniptemp := forwardlookup(addr,10);\r
+ addr := ipbintostr(biniptemp);\r
+ fdhandlein := socket(biniptemp.family,socktype,0);\r
+ {$ifdef ipv6}\r
+ if (addr = '::') and (origaddr = '') and (fdhandlein < 0) then begin\r
+ addr := '0.0.0.0';\r
+ fdhandlein := socket(AF_INET,socktype,0);\r
+ end;\r
+ {$endif}\r
+ if fdhandlein = -1 then raise ESocketException.create('unable to create socket');\r
+ dupnowatch(fdhandlein); // sets up maxs and copies handle to fdhandleout among other things\r
+ //eventcore.setfdreverse(fdhandlein,self); //already taken care of by dup\r
+ state := wsclosed; // then set this back as it was an undesired side effect of dup\r
+\r
+ try\r
+ yes := $01010101; {Copied this from existing code. Value is empiric,\r
+ but works. (yes=true<>0) }\r
+ {$ifndef win32}\r
+ if SetSocketOptions(fdhandlein, SOL_SOCKET, SO_REUSEADDR,yes,sizeof(yes))=-1 then begin\r
+ raise ESocketException.create('unable to set socket options');\r
+ end;\r
+ {$endif}\r
+ localaddr := addr;\r
+ localport := port;\r
+ bindsocket;\r
+\r
+ if not udp then begin\r
+ {!!! allow custom queue length? default 5}\r
+ if listenqueue = 0 then listenqueue := 5;\r
+ If {$ifdef win32}winsock{$else}sockets{$endif}.Listen(fdhandlein,listenqueue)<>{$ifdef win32}0{$else}true{$endif} Then raise esocketexception.create('unable to listen');\r
+ state := wsListening;\r
+ end else begin\r
+ {$ifndef win32}\r
+ SetSocketOptions(fdhandleout, SOL_SOCKET, SO_BROADCAST, 'TRUE', Length('TRUE'));\r
+ {$endif}\r
+ state := wsconnected;\r
+ end;\r
+ finally\r
+ if state = wsclosed then begin\r
+ if fdhandlein >= 0 then begin\r
+ {one *can* get here without fd -beware}\r
+ eventcore.rmasterclr(fdhandlein);\r
+ myfdclose(fdhandlein); // we musnt leak file discriptors\r
+ eventcore.setfdreverse(fdhandlein,nil);\r
+ fdhandlein := -1;\r
+ end;\r
+ end else begin\r
+ eventcore.rmasterset(fdhandlein,true);\r
+ end;\r
+ if fdhandleout >= 0 then eventcore.wmasterclr(fdhandleout);\r
+ end;\r
+ //writeln('listened on addr '+addr+':'+port+' '+proto+' using socket number ',fdhandlein); \r
+end;\r
+\r
+function tlsocket.accept : longint;\r
+var\r
+ FromAddrSize : LongInt; // i don't realy know what to do with these at this\r
+ FromAddr : TInetSockAddrV; // at this point time will tell :)\r
+begin\r
+\r
+ FromAddrSize := Sizeof(FromAddr);\r
+ {$ifdef win32}\r
+ result := winsock.accept(fdhandlein,@fromaddr,@fromaddrsize);\r
+ {$else}\r
+ result := sockets.accept(fdhandlein,fromaddr,fromaddrsize);\r
+ {$endif}\r
+ //now we have accepted one request start monitoring for more again\r
+ eventcore.rmasterset(fdhandlein,true);\r
+\r
+ if result = -1 then raise esocketexception.create('error '+inttostr({$ifdef win32}getlasterror{$else}socketerror{$endif})+' while accepting');\r
+ if result > absoloutemaxs then begin\r
+ myfdclose(result);\r
+ result := -1;\r
+ raise esocketexception.create('file discriptor out of range');\r
+ end;\r
+end;\r
+\r
+function tlsocket.sendto(dest:TInetSockAddr;destlen:integer;data:pointer;len:integer):integer;\r
+var\r
+ destx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddr{$endif} absolute dest;\r
+begin\r
+ result := {$ifdef win32}winsock{$else}sockets{$endif}.sendto(self.fdhandleout,data^,len,0,destx,destlen);\r
+end;\r
+\r
+function tlsocket.receivefrom(data:pointer;len:integer;var src:TInetSockAddr;var srclen:integer):integer;\r
+var\r
+ srcx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddr{$endif} absolute src;\r
+begin\r
+ result := {$ifdef win32}winsock{$else}sockets{$endif}.recvfrom(self.fdhandlein,data^,len,0,srcx,srclen);\r
+end;\r
+\r
+procedure tlsocket.handlefdtrigger(readtrigger,writetrigger:boolean);\r
+var\r
+ tempbuf:array[0..receivebufsize-1] of byte;\r
+begin\r
+ //writeln('got a fd trigger, readtrigger=',readtrigger,' writetrigger=',writetrigger);\r
+ if (state =wslistening) and readtrigger then begin\r
+{ debugout('listening socket triggered on read');}\r
+ eventcore.rmasterclr(fdhandlein);\r
+ if assigned(onsessionAvailable) then onsessionAvailable(self,0);\r
+ end;\r
+ if udp and readtrigger then begin\r
+ if assigned(ondataAvailable) then ondataAvailable(self,0);\r
+ {!!!test}\r
+ exit;\r
+ end;\r
+ if (state =wsconnecting) and writetrigger then begin\r
+ // code for dealing with the reults of a non-blocking connect is\r
+ // rather complex\r
+ // if just write is triggered it means connect suceeded\r
+ // if both read and write are triggered it can mean 2 things\r
+ // 1: connect ok and data availible\r
+ // 2: connect fail\r
+ // to find out which you must read from the socket and look for errors\r
+ // there if we read successfully we drop through into the code for fireing\r
+ // the read event\r
+ if not readtrigger then begin\r
+ state := wsconnected;\r
+ if assigned(onsessionconnected) then onsessionconnected(self,0);\r
+ end else begin\r
+ numread := myfdread(fdhandlein,tempbuf,sizeof(tempbuf));\r
+ if numread <> -1 then begin\r
+ state := wsconnected;\r
+ if assigned(onsessionconnected) then onsessionconnected(self,0);\r
+ //connectread := true;\r
+ recvq.add(@tempbuf,numread);\r
+ end else begin\r
+ state := wsconnected;\r
+ if assigned(onsessionconnected) then onsessionconnected(self,{$ifdef win32}wsagetlasterror{$else}linuxerror{$endif});\r
+{ debugout('connect fail');}\r
+ self.internalclose(0);\r
+ recvq.del(maxlongint);\r
+ end;\r
+ // if things went well here we are now in the state wsconnected with data sitting in our receive buffer\r
+ // so we drop down into the processing for data availible\r
+ end;\r
+ if fdhandlein >= 0 then begin\r
+ if state = wsconnected then begin\r
+ eventcore.rmasterset(fdhandlein,false);\r
+ end else begin\r
+ eventcore.rmasterclr(fdhandlein);\r
+ end;\r
+ end;\r
+ if fdhandleout >= 0 then begin\r
+ if sendq.size = 0 then begin\r
+ //don't clear the bit in fdswmaster if data is in the sendq\r
+ eventcore.wmasterclr(fdhandleout);\r
+ end;\r
+ end;\r
+\r
+ end;\r
+ inherited handlefdtrigger(readtrigger,writetrigger);\r
+end;\r
+\r
+constructor tlsocket.Create(AOwner: TComponent);\r
+begin\r
+ inherited create(aowner);\r
+ closehandles := true;\r
+end;\r
+\r
+\r
+function tlsocket.getpeername(var addr:tsockaddrin;addrlen:integer):integer;\r
+var\r
+ addrx : {$ifdef win32}winsock.tsockaddr{$else}tsockaddrin{$endif} absolute addr;\r
+begin\r
+ result := {$ifdef win32}winsock{$else}sockets{$endif}.getpeername(self.fdhandlein,addrx,addrlen);\r
+end;\r
+\r
+procedure tlsocket.getxaddrbin(var binip:tbinip);\r
+var\r
+ addr:tinetsockaddrv;\r
+ i:integer;\r
+begin\r
+ i := sizeof(addr);\r
+ fillchar(addr,sizeof(addr),0);\r
+\r
+ {$ifdef win32}\r
+ winsock.getsockname(self.fdhandlein,psockaddr(@addr)^,i);\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
+ converttov4(binip);\r
+end;\r
+\r
+procedure tlsocket.getpeeraddrbin(var binip:tbinip);\r
+var\r
+ addr:tinetsockaddrv;\r
+ i:integer;\r
+begin\r
+ i := sizeof(addr);\r
+ fillchar(addr,sizeof(addr),0);\r
+ {$ifdef win32}\r
+ winsock.getpeername(self.fdhandlein,psockaddr(@addr)^,i);\r
+ {$else}\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
+ converttov4(binip);\r
+end;\r
+\r
+function tlsocket.getXaddr:string;\r
+var\r
+ biniptemp:tbinip;\r
+begin\r
+ getxaddrbin(biniptemp);\r
+ result := ipbintostr(biniptemp);\r
+ if result = '' then result := 'error';\r
+end;\r
+\r
+function tlsocket.getpeeraddr:string;\r
+var\r
+ biniptemp:tbinip;\r
+begin\r
+ getpeeraddrbin(biniptemp);\r
+ result := ipbintostr(biniptemp);\r
+ if result = '' then result := 'error';\r
+end;\r
+\r
+function tlsocket.getXport:string;\r
+var\r
+ addr:{$ifdef win32}winsock.tsockaddr{$else}tinetsockaddr{$endif};\r
+ i:integer;\r
+begin\r
+ i := sizeof(addr);\r
+ {$ifdef win32}\r
+ winsock.getsockname(self.fdhandlein,addr,i);\r
+ i := htons(addr.sin_port);\r
+ {$else}\r
+ sockets.getsocketname(self.fdhandlein,addr,i);\r
+ i := htons(addr.port);\r
+ {$endif}\r
+ result := inttostr(i);\r
+end;\r
+\r
+function tlsocket.getpeerport:string;\r
+var\r
+ addr:{$ifdef win32}winsock.tsockaddr{$else}tinetsockaddr{$endif};\r
+ i:integer;\r
+begin\r
+ i := sizeof(addr);\r
+ {$ifdef win32}\r
+ winsock.getpeername(self.fdhandlein,addr,i);\r
+ i := htons(addr.sin_port);\r
+ {$else}\r
+ sockets.getpeername(self.fdhandlein,addr,i);\r
+ i := htons(addr.port);\r
+ {$endif}\r
+ result := inttostr(i);\r
+end;\r
+\r
+{$ifdef win32}\r
+ procedure tlsocket.myfdclose(fd : integer);\r
+ begin\r
+ closesocket(fd);\r
+ end;\r
+ function tlsocket.myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt;\r
+ begin\r
+ result := winsock.send(fd,(@buf)^,size,0);\r
+ end;\r
+ function tlsocket.myfdread(fd: LongInt;var buf;size: LongInt):LongInt;\r
+ begin\r
+ result := winsock.recv(fd,buf,size,0);\r
+ end;\r
+{$endif}\r
+
+end.\r
+\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
+\r
+\r
+{add nn msec to tv}\r
+const\r
+ tv_invalidtimebig : ttimeval = (tv_sec:maxlongint;tv_usec:maxlongint);\r
+ //tv_invalidtimebig will always compare as greater than any valid timeval\r
+procedure tv_add(var tv:ttimeval;msec:integer);//{ $ifdef fpc}inline;{ $endif}\r
+begin\r
+ inc(tv.tv_usec,msec*1000);\r
+ inc(tv.tv_sec,tv.tv_usec div 1000000);\r
+ tv.tv_usec := tv.tv_usec mod 1000000;\r
+end;\r
+\r
+{tv1 >= tv2}\r
+function tv_compare(const tv1,tv2:ttimeval):boolean;//{ $ifdef fpc}inline;{ $endif}\r
+begin\r
+ if tv1.tv_sec = tv2.tv_sec then begin\r
+ result := tv1.tv_usec >= tv2.tv_usec;\r
+ end else result := tv1.tv_sec > tv2.tv_sec;\r
+end;\r
+\r
+procedure tv_substract(var tv:ttimeval;const tv2:ttimeval);//{ $ifdef fpc}inline;{ $endif}\r
+begin\r
+ dec(tv.tv_usec,tv2.tv_usec);\r
+ if tv.tv_usec < 0 then begin\r
+ inc(tv.tv_usec,1000000);\r
+ dec(tv.tv_sec)\r
+ end;\r
+ dec(tv.tv_sec,tv2.tv_sec);\r
+end;\r
+\r
+procedure msectotimeval(var tv:ttimeval;msec:integer);\r
+begin\r
+ tv.tv_sec := msec div 1000;\r
+ tv.tv_usec := (msec mod 1000)*1000;\r
+end;\r
+\r
--- /dev/null
+{io core originally for linux bworld}\r
+\r
+{ 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 pgtypes;\r
+interface\r
+ type\r
+ {$ifdef cpu386}{$define i386}{$endif}\r
+ {$ifdef i386}\r
+ taddrint=longint;\r
+ {$else}\r
+ taddrint=sizeint;\r
+ {$endif}\r
+ paddrint=^taddrint;\r
+\r
+implementation\r
+end.\r
--- /dev/null
+{ Copyright (C) 2005 Bas Steendijk and Peter Green
+ For conditions of distribution and use, see copyright notice in zlib_license.txt
+ which is included in the package
+ ----------------------------------------------------------------------------- }\r
+type\r
+ {delphi 3 and before do not have a 32 bits unsigned integer type,\r
+ but longint has the correct behavior - it doesn't on newer delphi versions}\r
+ {$ifndef fpc}\r
+ {$ifdef ver70}{$define pred4}{$endif} {tp7}\r
+ {$ifdef ver80}{$define pred4}{$endif} {delphi 1}\r
+ {$ifdef ver90}{$define pred4}{$endif} {delphi 2}\r
+ {$ifdef ver100}{$define pred4}{$endif} {delphi 3}\r
+ {$endif}\r
+ uint32={$ifdef pred4}longint{$else}longword{$endif};\r
--- /dev/null
+{$ifdef UNIX}\r
+ {$macro on}\r
+ {$ifdef VER1_0}\r
+ {$define tv_sec := sec}\r
+ {$define tv_usec := usec}\r
+ function dup(const original:integer):integer;inline;\r
+ begin\r
+ linux.dup(original,result);\r
+ end;\r
+ {$define gettimeofdaysec := gettimeofday}\r
+ {$else}\r
+ \r
+ {$define sigprocmask := fpsigprocmask}\r
+ {$define sigaction := fpsigaction}\r
+ {$define fdclose := fpclose}\r
+ {$define fcntl := fpfcntl}\r
+ {$define fdwrite := fpwrite}\r
+ {$define fdread := fpread}\r
+ {$define fdopen := fpopen}\r
+ {$define select := fpselect}\r
+ {$define linuxerror := fpgeterrno}\r
+ {$define fork := fpfork}\r
+ {$define getpid := fpgetpid}\r
+ {$define getenv := fpgetenv}\r
+ {$define chmod := fpchmod}\r
+ {$define dup2 := fpdup2}\r
+ {$ifndef ver1_9_2}\r
+ {$define flock := fpflock}\r
+ {$endif}\r
+ procedure gettimeofday(var tv:ttimeval);inline;\r
+ begin\r
+ fpgettimeofday(@tv,nil); \r
+ end;\r
+ function gettimeofdaysec : longint;\r
+ var\r
+ tv:ttimeval;\r
+ begin\r
+ gettimeofday(tv);\r
+ result := tv.tv_sec;\r
+ end;\r
+\r
+ //a function is used here rather than a define to prevent issues with tlasio.dup\r
+ function dup(const original:integer):integer;inline;\r
+ begin\r
+ result := fpdup(original);\r
+ end;\r
+ function octal(invalue:longint):longint;\r
+ var\r
+ a : integer;\r
+ i : integer;\r
+ begin\r
+ i := 0;\r
+ result := 0;\r
+ while invalue <> 0 do begin\r
+ a := invalue mod 10;\r
+ result := result + (a shl (i*3));\r
+\r
+ invalue := invalue div 10;\r
+ inc(i);\r
+ end;\r
+ end;\r
+ const\r
+ sys_eintr=esyseintr;\r
+\r
+ {$endif}\r
+{$endif}\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 wcore;\r
+\r
+{\r
+lcore compatible interface for windows\r
+\r
+- messageloop\r
+\r
+- tltimer\r
+\r
+}\r
+//note: events after release are normal and are the apps responsibility to deal with safely\r
+interface\r
+\r
+ uses\r
+ classes,windows,mmsystem;\r
+\r
+ type\r
+ float=double;\r
+\r
+ tlcomponent = class(tcomponent)\r
+ public\r
+ released:boolean;\r
+ procedure release;\r
+ destructor destroy; override;\r
+ end;\r
+\r
+ tltimer=class(tlcomponent)\r
+ public\r
+ ontimer:tnotifyevent;\r
+ initialevent:boolean;\r
+ initialdone:boolean;\r
+ prevtimer:tltimer;\r
+ nexttimer:tltimer;\r
+ interval:integer; {miliseconds, default 1000}\r
+ enabled:boolean;\r
+ nextts:integer;\r
+ constructor create(aowner:tcomponent);override;\r
+ destructor destroy;override;\r
+ end;\r
+\r
+ ttaskevent=procedure(wparam,lparam:longint) of object;\r
+\r
+ tltask=class(tobject)\r
+ public\r
+ handler : ttaskevent;\r
+ obj : tobject;\r
+ wparam : longint;\r
+ lparam : longint;\r
+ nexttask : tltask;\r
+ constructor create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+ end;\r
+\r
+procedure messageloop;\r
+procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+procedure disconnecttasks(aobj:tobject);\r
+procedure exitmessageloop;\r
+procedure processmessages;\r
+\r
+var\r
+ onshutdown:procedure(s:string);\r
+\r
+implementation\r
+\r
+uses\r
+ {$ifdef fpc}\r
+ bmessages;\r
+ {$else}\r
+ messages;\r
+ {$endif}\r
+\r
+\r
+const\r
+ WINMSG_TASK=WM_USER;\r
+\r
+var\r
+ hwndwcore:hwnd;\r
+ firsttimer:tltimer;\r
+ timesubstract:integer;\r
+ firsttask,lasttask,currenttask:tltask;\r
+\r
+procedure tlcomponent.release;\r
+begin\r
+ released := true;\r
+end;\r
+\r
+destructor tlcomponent.destroy;\r
+begin\r
+ disconnecttasks(self);\r
+ inherited destroy;\r
+end;\r
+\r
+{------------------------------------------------------------------------------}\r
+\r
+constructor tltimer.create;\r
+begin\r
+ inherited create(AOwner);\r
+ nexttimer := firsttimer;\r
+ prevtimer := nil;\r
+\r
+ if assigned(nexttimer) then nexttimer.prevtimer := self;\r
+ firsttimer := self;\r
+\r
+ interval := 1000;\r
+ enabled := true;\r
+ released := false;\r
+end;\r
+\r
+destructor tltimer.destroy;\r
+begin\r
+ if prevtimer <> nil then begin\r
+ prevtimer.nexttimer := nexttimer;\r
+ end else begin\r
+ firsttimer := nexttimer;\r
+ end;\r
+ if nexttimer <> nil then begin\r
+ nexttimer.prevtimer := prevtimer;\r
+ end;\r
+ inherited destroy;\r
+end;\r
+\r
+{------------------------------------------------------------------------------}\r
+\r
+function wcore_timehandler:integer;\r
+const\r
+ rollover_bits=30;\r
+var\r
+ tv,tvnow:integer;\r
+ currenttimer,temptimer:tltimer;\r
+begin\r
+ if not assigned(firsttimer) then begin\r
+ result := 1000;\r
+ exit;\r
+ end;\r
+\r
+ tvnow := timegettime;\r
+ if (tvnow and ((-1) shl rollover_bits)) <> timesubstract then begin\r
+ currenttimer := firsttimer;\r
+ while assigned(currenttimer) do begin\r
+ dec(currenttimer.nextts,(1 shl rollover_bits));\r
+ currenttimer := currenttimer.nexttimer;\r
+ end;\r
+ timesubstract := tvnow and ((-1) shl rollover_bits);\r
+ end;\r
+ tvnow := tvnow and ((1 shl rollover_bits)-1);\r
+\r
+ currenttimer := firsttimer;\r
+ while assigned(currenttimer) do begin\r
+ if tvnow >= currenttimer.nextts then begin\r
+ if assigned(currenttimer.ontimer) then begin\r
+ if currenttimer.enabled then begin\r
+ if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer);\r
+ currenttimer.initialdone := true;\r
+ end;\r
+ end;\r
+ currenttimer.nextts := tvnow+currenttimer.interval;\r
+ end;\r
+ temptimer := currenttimer;\r
+ currenttimer := currenttimer.nexttimer;\r
+ if temptimer.released then temptimer.free;\r
+ end;\r
+\r
+ tv := maxlongint;\r
+ currenttimer := firsttimer;\r
+ while assigned(currenttimer) do begin\r
+ if currenttimer.nextts < tv then tv := currenttimer.nextts;\r
+ currenttimer := currenttimer.nexttimer;\r
+ end;\r
+ result := tv-tvnow;\r
+ if result < 15 then result := 15;\r
+end;\r
+\r
+{------------------------------------------------------------------------------}\r
+\r
+constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+ inherited create;\r
+ handler := ahandler;\r
+ obj := aobj;\r
+ wparam := awparam;\r
+ lparam := alparam;\r
+ {nexttask := firsttask;\r
+ firsttask := self;}\r
+ if assigned(lasttask) then begin\r
+ lasttask.nexttask := self;\r
+ end else begin\r
+ firsttask := self;\r
+ postmessage(hwndwcore,WINMSG_TASK,0,0);\r
+ end;\r
+ lasttask := self;\r
+ //ahandler(wparam,lparam);\r
+end;\r
+\r
+procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+ tltask.create(ahandler,aobj,awparam,alparam);\r
+end;\r
+\r
+procedure disconnecttasks(aobj:tobject);\r
+var\r
+ currenttasklocal : tltask ;\r
+ counter : byte ;\r
+begin\r
+ for counter := 0 to 1 do begin\r
+ if counter = 0 then begin\r
+ currenttasklocal := firsttask; //main list of tasks\r
+ end else begin\r
+ currenttasklocal := currenttask; //needed in case called from a task\r
+ end;\r
+ // note i don't bother to sestroy the links here as that will happen when\r
+ // the list of tasks is processed anyway\r
+ while assigned(currenttasklocal) do begin\r
+ if currenttasklocal.obj = aobj then begin\r
+ currenttasklocal.obj := nil;\r
+ currenttasklocal.handler := nil;\r
+ end;\r
+ currenttasklocal := currenttasklocal.nexttask;\r
+ end;\r
+ end;\r
+end;\r
+\r
+procedure dotasks;\r
+var\r
+ temptask:tltask;\r
+begin\r
+ if firsttask = nil then exit;\r
+\r
+ currenttask := firsttask;\r
+ firsttask := nil;\r
+ lasttask := nil;\r
+ while assigned(currenttask) do begin\r
+ if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam);\r
+ temptask := currenttask;\r
+ currenttask := currenttask.nexttask;\r
+ temptask.free;\r
+ end;\r
+ currenttask := nil;\r
+end;\r
+\r
+{------------------------------------------------------------------------------}\r
+\r
+procedure exitmessageloop;\r
+begin\r
+ postmessage(hwndwcore,WM_QUIT,0,0);\r
+end;\r
+\r
+ {$ifdef threadtimer}\r
+ 'thread timer'\r
+ {$else}\r
+const timerid_wcore=$1000;\r
+ {$endif}\r
+\r
+function MyWindowProc(\r
+ ahWnd : HWND;\r
+ auMsg : Integer;\r
+ awParam : WPARAM;\r
+ alParam : LPARAM): Integer; stdcall;\r
+var\r
+ MsgRec : TMessage;\r
+ a:integer;\r
+begin\r
+ Result := 0; // This means we handled the message\r
+\r
+ {MsgRec.hwnd := ahWnd;}\r
+ MsgRec.wParam := awParam;\r
+ MsgRec.lParam := alParam;\r
+\r
+ dotasks;\r
+ case auMsg of\r
+ {$ifndef threadtimer}\r
+ WM_TIMER: begin\r
+ if msgrec.wparam = timerid_wcore then begin\r
+ a := wcore_timehandler;\r
+ killtimer(hwndwcore,timerid_wcore);\r
+ settimer(hwndwcore,timerid_wcore,a,nil);\r
+ end;\r
+ end;\r
+ {$endif}\r
+\r
+ {WINMSG_TASK:dotasks;}\r
+\r
+ WM_CLOSE: begin\r
+ {}\r
+ end;\r
+ WM_DESTROY: begin\r
+ {}\r
+ end;\r
+ else\r
+ Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)\r
+ end;\r
+end;\r
+\r
+\r
+var\r
+ MyWindowClass : TWndClass = (style : 0;\r
+ lpfnWndProc : @MyWindowProc;\r
+ cbClsExtra : 0;\r
+ cbWndExtra : 0;\r
+ hInstance : 0;\r
+ hIcon : 0;\r
+ hCursor : 0;\r
+ hbrBackground : 0;\r
+ lpszMenuName : nil;\r
+ lpszClassName : 'wcoreClass');\r
+\r
+procedure messageloop;\r
+var\r
+ MsgRec : TMsg;\r
+begin\r
+\r
+ if Windows.RegisterClass(MyWindowClass) = 0 then halt;\r
+ //writeln('about to create wcore handle, hinstance=',hinstance);\r
+ hwndwcore := CreateWindowEx(WS_EX_TOOLWINDOW,\r
+ MyWindowClass.lpszClassName,\r
+ '', { Window name }\r
+ WS_POPUP, { Window Style }\r
+ 0, 0, { X, Y }\r
+ 0, 0, { Width, Height }\r
+ 0, { hWndParent }\r
+ 0, { hMenu }\r
+ HInstance, { hInstance }\r
+ nil); { CreateParam }\r
+\r
+ if hwndwcore = 0 then halt;\r
+\r
+ {$ifdef threadtimer}\r
+ 'thread timer'\r
+ {$else}\r
+ if settimer(hwndwcore,timerid_wcore,15,nil) = 0 then halt;\r
+ {$endif}\r
+\r
+\r
+ while GetMessage(MsgRec, 0, 0, 0) do begin\r
+ TranslateMessage(MsgRec);\r
+ DispatchMessage(MsgRec);\r
+ {if not peekmessage(msgrec,0,0,0,PM_NOREMOVE) then onidle}\r
+ end;\r
+\r
+ if hWndwcore <> 0 then begin\r
+ DestroyWindow(hwndwcore);\r
+ hWndwcore := 0;\r
+ end;\r
+\r
+ {$ifdef threadtimer}\r
+ 'thread timer'\r
+ {$else}\r
+ killtimer(hwndwcore,timerid_wcore);\r
+ {$endif}\r
+end;\r
+\r
+function ProcessMessage : Boolean;\r
+var\r
+ Msg : TMsg;\r
+begin\r
+ Result := FALSE;\r
+ if PeekMessage(Msg, hwndwcore, 0, 0, PM_REMOVE) then begin\r
+ Result := TRUE;\r
+ DispatchMessage(Msg);\r
+ end;\r
+end;\r
+\r
+procedure processmessages;\r
+begin\r
+ while processmessage do;\r
+end;\r
+\r
+\r
+end.\r
--- /dev/null
+{lsocket.pas}\r
+\r
+{io and timer code by plugwash}\r
+\r
+{ 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
+{note: you must use the @ in the last param to tltask.create not doing so will\r
+ compile without error but will cause an access violation -pg}\r
+\r
+//note: events after release are normal and are the apps responsibility to deal with safely\r
+\r
+unit lcore;\r
+{$ifdef fpc}\r
+ {$mode delphi}\r
+{$endif}\r
+{$ifdef win32}\r
+ {$define nosignal}\r
+{$endif}\r
+interface\r
+ uses\r
+ sysutils,\r
+ {$ifndef win32}\r
+ {$ifdef VER1_0}\r
+ linux,\r
+ {$else}\r
+ baseunix,unix,unixutil,\r
+ {$endif}\r
+ fd_utils,\r
+ {$endif}\r
+ classes,pgtypes,bfifo;\r
+ procedure processtasks;\r
+\r
+\r
+ const\r
+ receivebufsize=1460;\r
+\r
+ type\r
+ {$ifdef ver1_0}\r
+ sigset= array[0..31] of longint;\r
+ {$endif}\r
+\r
+ ESocketException = class(Exception);\r
+ TBgExceptionEvent = procedure (Sender : TObject;\r
+ E : Exception;\r
+ var CanClose : Boolean) of object;\r
+\r
+ // note : tsocketstate is defined in the same way as it is in François PIETTE's twsocket\r
+ // however tlsocket currently only uses wsClosed wsConnecting wsconnected and wsListening\r
+ TSocketState = (wsInvalidState,\r
+ wsOpened, wsBound,\r
+ wsConnecting, wsConnected,\r
+ wsAccepting, wsListening,\r
+ wsClosed);\r
+\r
+ TWSocketOption = (wsoNoReceiveLoop, wsoTcpNoDelay);\r
+ TWSocketOptions = set of TWSocketOption;\r
+\r
+ TSocketevent = procedure(Sender: TObject; Error: word) of object;\r
+ //Tdataavailevent = procedure(data : string);\r
+ TSendData = procedure (Sender: TObject; BytesSent: Integer) of object;\r
+\r
+ tlcomponent = class(tcomponent)\r
+ public\r
+ released:boolean;\r
+ procedure release; virtual;\r
+ destructor destroy; override;\r
+ end;\r
+\r
+ tlasio = class(tlcomponent)\r
+ public\r
+ state : tsocketstate ;\r
+ ComponentOptions : TWSocketOptions;\r
+ fdhandlein : Longint ; {file discriptor}\r
+ fdhandleout : Longint ; {file discriptor}\r
+\r
+ onsessionclosed : tsocketevent ;\r
+ ondataAvailable : tsocketevent ;\r
+ onsessionAvailable : tsocketevent ;\r
+\r
+ onsessionconnected : tsocketevent ;\r
+ onsenddata : tsenddata ;\r
+ ondatasent : tsocketevent ;\r
+ //connected : boolean ;\r
+ nextasin : tlasio ;\r
+ prevasin : tlasio ;\r
+\r
+ recvq : tfifo;\r
+ OnBgException : TBgExceptionEvent ;\r
+ //connectread : boolean ;\r
+ sendq : tfifo;\r
+ closehandles : boolean ;\r
+ writtenthiscycle : boolean ;\r
+ onfdwrite : procedure (Sender: TObject; Error: word) of object; //added for bewarehttpd\r
+ lasterror:integer;\r
+ destroying:boolean;\r
+ function receivestr:string; virtual;\r
+ procedure close;\r
+ procedure abort;\r
+ procedure internalclose(error:word); virtual;\r
+ constructor Create(AOwner: TComponent); override;\r
+\r
+ destructor destroy; override;\r
+ procedure fdcleanup;\r
+ procedure HandleBackGroundException(E: Exception);\r
+ procedure handlefdtrigger(readtrigger,writetrigger:boolean); virtual;\r
+ procedure dup(invalue:longint);\r
+\r
+ function sendflush : integer;\r
+ procedure sendstr(const str : string);virtual;\r
+ procedure putstringinsendbuffer(const newstring : string);\r
+ function send(data:pointer;len:integer):integer;virtual;\r
+ procedure putdatainsendbuffer(data:pointer;len:integer); virtual;\r
+ procedure deletebuffereddata;\r
+\r
+ //procedure messageloop;\r
+ function Receive(Buf:Pointer;BufSize:integer):integer; virtual;\r
+ procedure flush;virtual;{$ifdef win32} abstract;{$endif}\r
+ procedure dodatasent(wparam,lparam:longint);\r
+ procedure doreceiveloop(wparam,lparam:longint);\r
+ procedure sinkdata(sender:tobject;error:word);\r
+\r
+ procedure release; override; {test -beware}\r
+\r
+ function RealSend(Data : Pointer; Len : Integer) : Integer; //added for bewarehttpd\r
+\r
+ procedure myfdclose(fd : integer); virtual;{$ifdef win32}abstract;{$endif}\r
+ function myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt; virtual;{$ifdef win32}abstract;{$endif}\r
+ function myfdread(fd: LongInt;var buf;size: LongInt):LongInt; virtual;{$ifdef win32}abstract;{$endif}\r
+ protected\r
+ procedure dupnowatch(invalue:longint);\r
+ end;\r
+ ttimerwrapperinterface=class(tlcomponent)\r
+ public\r
+ function createwrappedtimer : tobject;virtual;abstract;\r
+// procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);virtual;abstract;\r
+ procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);virtual;abstract;\r
+ procedure setenabled(wrappedtimer : tobject;newvalue : boolean);virtual;abstract;\r
+ procedure setinterval(wrappedtimer : tobject;newvalue : integer);virtual;abstract;\r
+ end;\r
+\r
+ var\r
+ timerwrapperinterface : ttimerwrapperinterface;\r
+ type\r
+ {$ifdef win32}\r
+ ttimeval = record\r
+ tv_sec : longint;\r
+ tv_usec : longint;\r
+ end;\r
+ {$endif}\r
+ tltimer=class(tlcomponent)\r
+ protected\r
+\r
+\r
+ wrappedtimer : tobject;\r
+\r
+\r
+// finitialevent : boolean ;\r
+ fontimer : tnotifyevent ;\r
+ fenabled : boolean ;\r
+ finterval : integer ; {miliseconds, default 1000}\r
+ {$ifndef win32}\r
+ procedure resettimes;\r
+ {$endif}\r
+// procedure setinitialevent(newvalue : boolean);\r
+ procedure setontimer(newvalue:tnotifyevent);\r
+ procedure setenabled(newvalue : boolean);\r
+ procedure setinterval(newvalue : integer);\r
+ public\r
+ //making theese public for now, this code should probablly be restructured later though\r
+ prevtimer : tltimer ;\r
+ nexttimer : tltimer ;\r
+ nextts : ttimeval ;\r
+\r
+ constructor create(aowner:tcomponent);override;\r
+ destructor destroy;override;\r
+// property initialevent : boolean read finitialevent write setinitialevent;\r
+ property ontimer : tnotifyevent read fontimer write setontimer;\r
+ property enabled : boolean read fenabled write setenabled;\r
+ property interval : integer read finterval write setinterval;\r
+\r
+ end;\r
+\r
+ ttaskevent=procedure(wparam,lparam:longint) of object;\r
+\r
+ tltask=class(tobject)\r
+ public\r
+ handler : ttaskevent;\r
+ obj : tobject;\r
+ wparam : longint;\r
+ lparam : longint;\r
+ nexttask : tltask;\r
+ constructor create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+ end;\r
+\r
+\r
+\r
+ teventcore=class\r
+ public\r
+ procedure processmessages; virtual;abstract;\r
+ procedure messageloop; virtual;abstract;\r
+ procedure exitmessageloop; virtual;abstract;\r
+ procedure setfdreverse(fd : integer;reverseto : tlasio);virtual;abstract;\r
+ procedure rmasterset(fd : integer;islistensocket : boolean); virtual;abstract;\r
+ procedure rmasterclr(fd: integer); virtual;abstract;\r
+ procedure wmasterset(fd : integer); virtual;abstract;\r
+ procedure wmasterclr(fd: integer); virtual;abstract;\r
+ end;\r
+var\r
+ eventcore : teventcore;\r
+\r
+procedure processmessages;\r
+procedure messageloop;\r
+procedure exitmessageloop;\r
+\r
+var\r
+ firstasin : tlasio ;\r
+ firsttimer : tltimer ;\r
+ firsttask , lasttask , currenttask : tltask ;\r
+\r
+ numread : integer ;\r
+ mustrefreshfds : boolean ;\r
+{ lcoretestcount:integer;}\r
+\r
+ asinreleaseflag:boolean;\r
+\r
+\r
+procedure disconnecttasks(aobj:tobject);\r
+procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+type\r
+ tonaddtask = procedure(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+var\r
+ onaddtask : tonaddtask;\r
+\r
+\r
+procedure sleep(i:integer);\r
+{$ifndef nosignal}\r
+ procedure prepsigpipe;{$ifndef ver1_0}inline;{$endif}\r
+{$endif}\r
+\r
+\r
+implementation\r
+{$ifndef nosignal}\r
+ uses {sockets,}lloopback,lsignal;\r
+{$endif}\r
+{$ifdef win32}\r
+ uses windows,winsock;\r
+{$endif}\r
+{$ifndef win32}\r
+ {$include unixstuff.inc}\r
+{$endif}\r
+{$include ltimevalstuff.inc}\r
+\r
+\r
+{!!! added sleep call -beware}\r
+procedure sleep(i:integer);\r
+var\r
+ tv:ttimeval;\r
+begin\r
+ {$ifdef win32}\r
+ windows.sleep(i);\r
+ {$else}\r
+ tv.tv_sec := i div 1000;\r
+ tv.tv_usec := (i mod 1000) * 1000;\r
+ select(0,nil,nil,nil,@tv);\r
+ {$endif}\r
+end;\r
+\r
+destructor tlcomponent.destroy;\r
+begin\r
+ disconnecttasks(self);\r
+ inherited destroy;\r
+end;\r
+\r
+\r
+\r
+\r
+procedure tlcomponent.release;\r
+begin\r
+ released := true;\r
+end;\r
+\r
+procedure tlasio.release;\r
+begin\r
+ asinreleaseflag := true;\r
+ inherited release;\r
+end;\r
+\r
+procedure tlasio.doreceiveloop;\r
+begin\r
+ if recvq.size = 0 then exit;\r
+ if assigned(ondataavailable) then ondataavailable(self,0);\r
+ if not (wsonoreceiveloop in componentoptions) then\r
+ if recvq.size > 0 then tltask.create(self.doreceiveloop,self,0,0);\r
+end;\r
+\r
+function tlasio.receivestr;\r
+begin\r
+ setlength(result,recvq.size);\r
+ receive(@result[1],length(result));\r
+end;\r
+\r
+function tlasio.receive(Buf:Pointer;BufSize:integer):integer;\r
+var\r
+ i,a,b:integer;\r
+ p:pointer;\r
+begin\r
+ i := bufsize;\r
+ if recvq.size < i then i := recvq.size;\r
+ a := 0;\r
+ while (a < i) do begin\r
+ b := recvq.get(p,i-a);\r
+ move(p^,buf^,b);\r
+ inc(taddrint(buf),b);\r
+ recvq.del(b);\r
+ inc(a,b);\r
+ end;\r
+ result := i;\r
+ if wsonoreceiveloop in componentoptions then begin\r
+ if recvq.size = 0 then eventcore.rmasterset(fdhandlein,false);\r
+ end;\r
+end;\r
+\r
+constructor tlasio.create;\r
+begin\r
+ inherited create(AOwner);\r
+ sendq := tfifo.create;\r
+ recvq := tfifo.create;\r
+ state := wsclosed;\r
+ fdhandlein := -1;\r
+ fdhandleout := -1;\r
+ nextasin := firstasin;\r
+ prevasin := nil;\r
+ if assigned(nextasin) then nextasin.prevasin := self;\r
+ firstasin := self;\r
+\r
+ released := false;\r
+end;\r
+\r
+destructor tlasio.destroy;\r
+begin\r
+ destroying := true;\r
+ if state <> wsclosed then close;\r
+ if prevasin <> nil then begin\r
+ prevasin.nextasin := nextasin;\r
+ end else begin\r
+ firstasin := nextasin;\r
+ end;\r
+ if nextasin <> nil then begin\r
+ nextasin.prevasin := prevasin;\r
+ end;\r
+ recvq.destroy;\r
+ sendq.destroy;\r
+ inherited destroy;\r
+end;\r
+\r
+procedure tlasio.close;\r
+begin\r
+ internalclose(0);\r
+end;\r
+\r
+procedure tlasio.abort;\r
+begin\r
+ close;\r
+end;\r
+\r
+procedure tlasio.fdcleanup;\r
+begin\r
+ if fdhandlein <> -1 then begin\r
+ eventcore.rmasterclr(fdhandlein); //fd_clr(fdhandlein,fdsrmaster)\r
+ end;\r
+ if fdhandleout <> -1 then begin\r
+ eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster)\r
+ end;\r
+ if fdhandlein=fdhandleout then begin\r
+ if fdhandlein <> -1 then begin\r
+ myfdclose(fdhandlein);\r
+ end;\r
+ end else begin\r
+ if fdhandlein <> -1 then begin\r
+ myfdclose(fdhandlein);\r
+ end;\r
+ if fdhandleout <> -1 then begin\r
+ myfdclose(fdhandleout);\r
+ end;\r
+ end;\r
+ fdhandlein := -1;\r
+ fdhandleout := -1;\r
+end;\r
+\r
+procedure tlasio.internalclose(error:word);\r
+begin\r
+ if state<>wsclosed then begin\r
+ if (fdhandlein < 0) or (fdhandleout < 0) then raise exception.create('internalclose called with invalid fd handles');\r
+ eventcore.rmasterclr(fdhandlein);//fd_clr(fdhandlein,fdsrmaster);\r
+ eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
+\r
+ if closehandles then begin\r
+ {$ifndef win32}\r
+ //anyone remember why this is here? --plugwash\r
+ fcntl(fdhandlein,F_SETFL,0);\r
+ {$endif}\r
+ myfdclose(fdhandlein);\r
+ if fdhandleout <> fdhandlein then begin\r
+ {$ifndef win32}\r
+ fcntl(fdhandleout,F_SETFL,0);\r
+ {$endif}\r
+ myfdclose(fdhandleout);\r
+ end;\r
+ eventcore.setfdreverse(fdhandlein,nil);\r
+ eventcore.setfdreverse(fdhandleout,nil);\r
+\r
+ fdhandlein := -1;\r
+ fdhandleout := -1;\r
+ end;\r
+ state := wsclosed;\r
+\r
+ if assigned(onsessionclosed) then if not destroying then onsessionclosed(self,error);\r
+ end;\r
+ sendq.del(maxlongint);\r
+end;\r
+\r
+\r
+{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}\r
+{ All exceptions *MUST* be handled. If an exception is not handled, the }\r
+{ application will most likely be shut down ! }\r
+procedure tlasio.HandleBackGroundException(E: Exception);\r
+var\r
+ CanAbort : Boolean;\r
+begin\r
+ CanAbort := TRUE;\r
+ { First call the error event handler, if any }\r
+ if Assigned(OnBgException) then begin\r
+ try\r
+ OnBgException(Self, E, CanAbort);\r
+ except\r
+ end;\r
+ end;\r
+ { Then abort the socket }\r
+ if CanAbort then begin\r
+ try\r
+ close;\r
+ except\r
+ end;\r
+ end;\r
+end;\r
+\r
+procedure tlasio.sendstr(const str : string);\r
+begin\r
+ putstringinsendbuffer(str);\r
+ sendflush;\r
+end;\r
+\r
+procedure tlasio.putstringinsendbuffer(const newstring : string);\r
+begin\r
+ if newstring <> '' then putdatainsendbuffer(@newstring[1],length(newstring));\r
+end;\r
+\r
+function tlasio.send(data:pointer;len:integer):integer;\r
+begin\r
+ if state <> wsconnected then begin\r
+ result := -1;\r
+ exit;\r
+ end;\r
+ if len < 0 then len := 0;\r
+ result := len;\r
+ putdatainsendbuffer(data,len);\r
+ sendflush;\r
+end;\r
+\r
+\r
+procedure tlasio.putdatainsendbuffer(data:pointer;len:integer);\r
+begin\r
+ sendq.add(data,len);\r
+end;\r
+\r
+function tlasio.sendflush : integer;\r
+var\r
+ lensent : integer;\r
+ data:pointer;\r
+// fdstestr : fdset;\r
+// fdstestw : fdset;\r
+begin\r
+ if state <> wsconnected then exit;\r
+\r
+ lensent := sendq.get(data,2920);\r
+ if assigned(data) then result := myfdwrite(fdhandleout,data^,lensent) else result := 0;\r
+\r
+ if result = -1 then lensent := 0 else lensent := result;\r
+\r
+ //sendq := copy(sendq,lensent+1,length(sendq)-lensent);\r
+ sendq.del(lensent);\r
+\r
+ //fd_clr(fdhandleout,fdsw); // this prevents the socket being closed by a write\r
+ // that sends nothing because a previous socket has\r
+ // slready flushed this socket when the message loop\r
+ // reaches it\r
+// if sendq.size > 0 then begin\r
+ eventcore.wmasterset(fdhandleout);//fd_set(fdhandleout,fdswmaster);\r
+// end else begin\r
+// wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
+// end;\r
+ if result > 0 then begin\r
+ if assigned(onsenddata) then onsenddata(self,result);\r
+// if sendq.size=0 then if assigned(ondatasent) then begin\r
+// tltask.create(self.dodatasent,self,0,0);\r
+// //begin test code\r
+// fd_zero(fdstestr);\r
+// fd_zero(fdstestw);\r
+// fd_set(fdhandlein,fdstestr);\r
+// fd_set(fdhandleout,fdstestw);\r
+// select(maxs,@fdstestr,@fdstestw,nil,0);\r
+// writeln(fd_isset(fdhandlein,fdstestr),' ',fd_isset(fdhandleout,fdstestw));\r
+// //end test code\r
+// \r
+// end;\r
+ writtenthiscycle := true;\r
+ end;\r
+end;\r
+\r
+procedure tlasio.dupnowatch(invalue:longint);\r
+begin\r
+ { debugout('invalue='+inttostr(invalue));}\r
+ //readln;\r
+ if state<> wsclosed then close;\r
+ fdhandlein := invalue;\r
+ fdhandleout := invalue;\r
+ eventcore.setfdreverse(fdhandlein,self);\r
+ {$ifndef win32}\r
+ fcntl(fdhandlein,F_SETFL,OPEN_NONBLOCK);\r
+ {$endif}\r
+ state := wsconnected;\r
+\r
+end;\r
+\r
+\r
+procedure tlasio.dup(invalue:longint);\r
+begin\r
+ dupnowatch(invalue);\r
+ eventcore.rmasterset(fdhandlein,false);//fd_set(fdhandlein,fdsrmaster);\r
+ eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
+end;\r
+\r
+\r
+procedure tlasio.handlefdtrigger(readtrigger,writetrigger:boolean);\r
+var\r
+ sendflushresult : integer;\r
+ tempbuf:array[0..receivebufsize-1] of byte;\r
+begin\r
+ if (state=wsconnected) and writetrigger then begin\r
+ //writeln('write trigger');\r
+\r
+ if (sendq.size >0) then begin\r
+\r
+ sendflushresult := sendflush;\r
+ if (sendflushresult <= 0) and (not writtenthiscycle) then begin\r
+ if sendflushresult=0 then begin // linuxerror := 0;\r
+ internalclose(0);\r
+\r
+ end else begin\r
+ internalclose({$ifdef win32}getlasterror{$else}linuxerror{$endif});\r
+ end;\r
+ end;\r
+\r
+ end else begin\r
+ //everything is sent fire off ondatasent event\r
+ if fdhandleout >= 0 then eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
+ if assigned(ondatasent) then tltask.create(self.dodatasent,self,0,0);\r
+ end;\r
+ if assigned(onfdwrite) then onfdwrite(self,0);\r
+ end;\r
+ writtenthiscycle := false;\r
+ if (state =wsconnected) and readtrigger then begin\r
+ if recvq.size=0 then begin\r
+ numread := myfdread(fdhandlein,tempbuf,sizeof(tempbuf));\r
+ if (numread=0) and (not mustrefreshfds) then begin\r
+ {if i remember correctly numread=0 is caused by eof\r
+ if this isn't dealt with then you get a cpu eating infinite loop\r
+ however if onsessionconencted has called processmessages that could\r
+ cause us to drop to here with an empty recvq and nothing left to read\r
+ and we don't want that to cause the socket to close}\r
+\r
+ internalclose(0);\r
+ end else if (numread=-1) then begin\r
+ {$ifdef win32}\r
+ //sometimes on windows we get stale messages due to the inherent delays\r
+ //in the windows message queue\r
+ if WSAGetLastError = wsaewouldblock then begin\r
+ //do nothing\r
+ end else\r
+ {$endif}\r
+ begin\r
+ numread := 0;\r
+ internalclose({$ifdef win32}wsagetlasterror{$else}linuxerror{$endif});\r
+ end;\r
+ end else if numread > 0 then recvq.add(@tempbuf,numread);\r
+ end;\r
+\r
+ if recvq.size > 0 then begin\r
+ if wsonoreceiveloop in componentoptions then eventcore.rmasterclr(fdhandlein); //fd_clr(fdhandlein,fdsrmaster);\r
+ if assigned(ondataavailable) then ondataAvailable(self,0);\r
+ if not (wsonoreceiveloop in componentoptions) then if recvq.size > 0 then\r
+ tltask.create(self.doreceiveloop,self,0,0);\r
+ end;\r
+ //until (numread = 0) or (currentsocket.state<>wsconnected);\r
+{ debugout('inner loop complete');}\r
+ end;\r
+end;\r
+\r
+{$ifndef win32}\r
+ procedure tlasio.flush;\r
+ var\r
+ fds : fdset;\r
+ begin\r
+ fd_zero(fds);\r
+ fd_set(fdhandleout,fds);\r
+ while sendq.size>0 do begin\r
+ select(fdhandleout+1,nil,@fds,nil,nil);\r
+ if sendflush <= 0 then exit;\r
+ end;\r
+ end;\r
+{$endif}\r
+\r
+procedure tlasio.dodatasent(wparam,lparam:longint);\r
+begin\r
+ if assigned(ondatasent) then ondatasent(self,lparam);\r
+end;\r
+\r
+procedure tlasio.deletebuffereddata;\r
+begin\r
+ sendq.del(maxlongint);\r
+end;\r
+\r
+procedure tlasio.sinkdata(sender:tobject;error:word);\r
+begin\r
+ tlasio(sender).recvq.del(maxlongint);\r
+end;\r
+\r
+{$ifndef win32}\r
+ procedure tltimer.resettimes;\r
+ begin\r
+ gettimeofday(nextts);\r
+ {if not initialevent then} tv_add(nextts,interval);\r
+ end;\r
+{$endif}\r
+\r
+{procedure tltimer.setinitialevent(newvalue : boolean);\r
+begin\r
+ if newvalue <> finitialevent then begin\r
+ finitialevent := newvalue;\r
+ if assigned(timerwrapperinterface) then begin\r
+ timerwrapperinterface.setinitialevent(wrappedtimer,newvalue);\r
+ end else begin\r
+ resettimes;\r
+ end;\r
+ end;\r
+end;}\r
+\r
+procedure tltimer.setontimer(newvalue:tnotifyevent);\r
+begin\r
+ if @newvalue <> @fontimer then begin\r
+ fontimer := newvalue;\r
+ if assigned(timerwrapperinterface) then begin\r
+ timerwrapperinterface.setontimer(wrappedtimer,newvalue);\r
+ end else begin\r
+\r
+ end;\r
+ end;\r
+\r
+end;\r
+\r
+\r
+procedure tltimer.setenabled(newvalue : boolean);\r
+begin\r
+ if newvalue <> fenabled then begin\r
+ fenabled := newvalue;\r
+ if assigned(timerwrapperinterface) then begin\r
+ timerwrapperinterface.setenabled(wrappedtimer,newvalue);\r
+ end else begin\r
+ {$ifdef win32}\r
+ raise exception.create('non wrapper timers are not permitted on windows');\r
+ {$else}\r
+ resettimes;\r
+ {$endif}\r
+ end;\r
+ end;\r
+end;\r
+\r
+procedure tltimer.setinterval(newvalue:integer);\r
+begin\r
+ if newvalue <> finterval then begin\r
+ finterval := newvalue;\r
+ if assigned(timerwrapperinterface) then begin\r
+ timerwrapperinterface.setinterval(wrappedtimer,newvalue);\r
+ end else begin\r
+ {$ifdef win32}\r
+ raise exception.create('non wrapper timers are not permitted on windows');\r
+ {$else}\r
+ resettimes;\r
+ {$endif}\r
+ end;\r
+ end;\r
+\r
+end;\r
+\r
+\r
+\r
+\r
+constructor tltimer.create;\r
+begin\r
+ inherited create(AOwner);\r
+ if assigned(timerwrapperinterface) then begin\r
+ wrappedtimer := timerwrapperinterface.createwrappedtimer;\r
+ end else begin\r
+\r
+\r
+ nexttimer := firsttimer;\r
+ prevtimer := nil;\r
+\r
+ if assigned(nexttimer) then nexttimer.prevtimer := self;\r
+ firsttimer := self;\r
+ end;\r
+ interval := 1000;\r
+ enabled := true;\r
+ released := false;\r
+\r
+end;\r
+\r
+destructor tltimer.destroy;\r
+begin\r
+ if assigned(timerwrapperinterface) then begin\r
+ wrappedtimer.free;\r
+ end else begin\r
+ if prevtimer <> nil then begin\r
+ prevtimer.nexttimer := nexttimer;\r
+ end else begin\r
+ firsttimer := nexttimer;\r
+ end;\r
+ if nexttimer <> nil then begin\r
+ nexttimer.prevtimer := prevtimer;\r
+ end;\r
+ \r
+ end;\r
+ inherited destroy;\r
+end;\r
+\r
+constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+ inherited create;\r
+ if assigned(onaddtask) then onaddtask(ahandler,aobj,awparam,alparam);\r
+ handler := ahandler;\r
+ obj := aobj;\r
+ wparam := awparam;\r
+ lparam := alparam;\r
+ {nexttask := firsttask;\r
+ firsttask := self;}\r
+ if assigned(lasttask) then begin\r
+ lasttask.nexttask := self;\r
+ end else begin\r
+ firsttask := self;\r
+ end;\r
+ lasttask := self;\r
+ //ahandler(wparam,lparam);\r
+end;\r
+\r
+procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+\r
+ tltask.create(ahandler,aobj,awparam,alparam);\r
+end;\r
+\r
+{$ifndef nosignal}\r
+ procedure prepsigpipe;{$ifndef ver1_0}inline;\r
+{$endif}\r
+ begin\r
+ starthandlesignal(sigpipe);\r
+ if not assigned(signalloopback) then begin\r
+ signalloopback := tlloopback.create(nil);\r
+ signalloopback.ondataAvailable := signalloopback.sinkdata;\r
+\r
+ end;\r
+\r
+ end;\r
+{$endif}\r
+\r
+procedure processtasks;//inline;\r
+var\r
+ temptask : tltask ;\r
+\r
+begin\r
+\r
+ if not assigned(currenttask) then begin\r
+ currenttask := firsttask;\r
+ firsttask := nil;\r
+ lasttask := nil;\r
+ end;\r
+ while assigned(currenttask) do begin\r
+\r
+ if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam);\r
+ if assigned(currenttask) then begin\r
+ temptask := currenttask;\r
+ currenttask := currenttask.nexttask;\r
+ temptask.free;\r
+ end;\r
+ //writeln('processed a task');\r
+ end;\r
+\r
+end;\r
+\r
+\r
+\r
+\r
+procedure disconnecttasks(aobj:tobject);\r
+var\r
+ currenttasklocal : tltask ;\r
+ counter : byte ;\r
+begin\r
+ for counter := 0 to 1 do begin\r
+ if counter = 0 then begin\r
+ currenttasklocal := firsttask; //main list of tasks\r
+ end else begin\r
+ currenttasklocal := currenttask; //needed in case called from a task\r
+ end;\r
+ // note i don't bother to sestroy the links here as that will happen when\r
+ // the list of tasks is processed anyway\r
+ while assigned(currenttasklocal) do begin\r
+ if currenttasklocal.obj = aobj then begin\r
+ currenttasklocal.obj := nil;\r
+ currenttasklocal.handler := nil;\r
+ end;\r
+ currenttasklocal := currenttasklocal.nexttask;\r
+ end;\r
+ end;\r
+end;\r
+\r
+\r
+procedure processmessages;\r
+begin\r
+ eventcore.processmessages;\r
+end;\r
+procedure messageloop;\r
+begin\r
+ eventcore.messageloop;\r
+end;\r
+\r
+procedure exitmessageloop;\r
+begin\r
+ eventcore.exitmessageloop;\r
+end;\r
+\r
+function tlasio.RealSend(Data : Pointer; Len : Integer) : Integer;\r
+begin\r
+ result := myfdwrite(fdhandleout,data^,len);\r
+ if (result > 0) and assigned(onsenddata) then onsenddata(self,result);\r
+ eventcore.wmasterset(fdhandleout);\r
+end;\r
+{$ifndef win32}\r
+ procedure tlasio.myfdclose(fd : integer);\r
+ begin\r
+ fdclose(fd);\r
+ end;\r
+ function tlasio.myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt;\r
+ begin\r
+ result := fdwrite(fd,buf,size);\r
+ end;\r
+\r
+ function tlasio.myfdread(fd: LongInt;var buf;size: LongInt):LongInt;\r
+ begin\r
+ result := fdread(fd,buf,size);\r
+ end;\r
+\r
+\r
+{$endif}\r
+\r
+\r
+begin\r
+ firstasin := nil;\r
+ firsttask := nil;\r
+ \r
+\r
+ {$ifndef nosignal}\r
+ signalloopback := nil;\r
+ {$endif}\r
+end.\r
+\r
+\r
+\r
+\r
+\r
--- /dev/null
+{ Copyright (C) 2005 Bas Steendijk and Peter Green
+ For conditions of distribution and use, see copyright notice in zlib_license.txt
+ which is included in the package
+ ----------------------------------------------------------------------------- }
+ \r
+unit lcoregtklaz;\r
+{$mode delphi}\r
+interface\r
+ \r
+uses baseunix,unix,glib, gdk, gtk,lcore,forms,fd_utils,classes;\r
+//procedure lcoregtklazrun;\r
+const\r
+ G_IO_IN=1;\r
+ G_IO_OUT=4;\r
+ G_IO_PRI=2;\r
+ G_IO_ERR=8;\r
+\r
+ G_IO_HUP=16;\r
+ G_IO_NVAL=32;\r
+type\r
+ tlaztimerwrapperinterface=class(ttimerwrapperinterface)\r
+ public\r
+ function createwrappedtimer : tobject;override;\r
+// procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);override;\r
+ procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);override;\r
+ procedure setenabled(wrappedtimer : tobject;newvalue : boolean);override;\r
+ procedure setinterval(wrappedtimer : tobject;newvalue : integer);override;\r
+ end;\r
+\r
+procedure lcoregtklazinit;\r
+implementation\r
+ uses\r
+ ExtCtrls;\r
+{$I unixstuff.inc}\r
+var\r
+ giochannels : array[0..absoloutemaxs] of pgiochannel;\r
+\r
+function iocallback(source:PGIOChannel; condition:TGIOCondition; data:gpointer):gboolean;cdecl;\r
+// return true if we want the callback to stay\r
+var\r
+ fd : integer ;\r
+ fdsrlocal , fdswlocal : fdset ;\r
+ currentasio : tlasio ;\r
+begin\r
+ fd := g_io_channel_unix_get_fd(source);\r
+ fd_zero(fdsrlocal);\r
+ fd_set(fd,fdsrlocal);\r
+ fdswlocal := fdsrlocal;\r
+ select(fd+1,@fdsrlocal,@fdswlocal,nil,0);\r
+ if fd_isset(fd,fdsrlocal) or fd_isset(fd,fdsrlocal) then begin\r
+ currentasio := fdreverse[fd];\r
+ if assigned(currentasio) then begin\r
+ currentasio.handlefdtrigger(fd_isset(currentasio.fdhandlein,fdsrlocal),fd_isset(currentasio.fdhandleout,fdswlocal));\r
+ end else begin\r
+ rmasterclr(fd);\r
+ wmasterclr(fd);\r
+ end;\r
+ end;\r
+ case condition of\r
+ G_IO_IN : begin\r
+ result := rmasterisset(fd);\r
+ end;\r
+ G_IO_OUT : begin\r
+ result := wmasterisset(fd);\r
+ end;\r
+ end;\r
+end;\r
+\r
+procedure gtkrmasterset(fd : integer);\r
+begin\r
+ if not assigned(giochannels[fd]) then giochannels[fd] := g_io_channel_unix_new(fd);\r
+ g_io_add_watch(giochannels[fd],G_IO_IN,iocallback,nil);\r
+end;\r
+\r
+procedure gtkrmasterclr(fd: integer);\r
+begin\r
+end;\r
+ \r
+procedure gtkwmasterset(fd : integer);\r
+begin\r
+ if not assigned(giochannels[fd]) then giochannels[fd] := g_io_channel_unix_new(fd);\r
+ g_io_add_watch(giochannels[fd],G_IO_OUT,iocallback,nil);\r
+end;\r
+\r
+procedure gtkwmasterclr(fd: integer);\r
+begin\r
+end;\r
+\r
+type\r
+ tsc = class\r
+ procedure dotasksandsink(sender:tobject;error:word);\r
+ end;\r
+var\r
+ taskloopback : tlloopback;\r
+ sc : tsc;\r
+procedure tsc.dotasksandsink(sender:tobject;error:word);\r
+begin\r
+ with tlasio(sender) do begin\r
+ sinkdata(sender,error);\r
+ processtasks;\r
+ end;\r
+end;\r
+procedure gtkaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+ taskloopback.sendstr(' ');\r
+ \r
+end;\r
+\r
+procedure lcoregtklazinit;\r
+begin\r
+ onrmasterset := gtkrmasterset;\r
+ onrmasterclr := gtkrmasterclr;\r
+ onwmasterset := gtkwmasterset;\r
+ onwmasterclr := gtkwmasterclr;\r
+ onaddtask := gtkaddtask;\r
+ taskloopback := tlloopback.create(nil);\r
+ taskloopback.ondataavailable := sc.dotasksandsink;\r
+ timerwrapperinterface := tlaztimerwrapperinterface.create(nil);\r
+end;\r
+\r
+function tlaztimerwrapperinterface.createwrappedtimer : tobject;\r
+begin\r
+ result := ttimer.create(nil);\r
+end;\r
+procedure tlaztimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);\r
+begin\r
+ ttimer(wrappedtimer).ontimer := newvalue;\r
+end;\r
+procedure tlaztimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean);\r
+begin\r
+ ttimer(wrappedtimer).enabled := newvalue;\r
+end;\r
+\r
+\r
+procedure tlaztimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer);\r
+begin\r
+ ttimer(wrappedtimer).interval := newvalue;\r
+end;\r
+\r
+\r
+end.\r
+\r
--- /dev/null
+{lsocket.pas}\r
+\r
+{io and timer code by plugwash}\r
+\r
+{ 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
+
+{$ifdef fpc}
+ {$ifndef ver1_0}
+ {$define useinline}
+ {$endif}
+{$endif} \r
+\r
+unit lcoreselect;\r
+\r
+\r
+interface\r
+uses\r
+ {$ifdef VER1_0}\r
+ linux,\r
+ {$else}\r
+ baseunix,unix,unixutil,\r
+ {$endif}\r
+ fd_utils;\r
+var\r
+ maxs : longint ;\r
+ exitloopflag : boolean ; {if set by app, exit mainloop}\r
+\r
+function getfdsrmaster : fdset; {$ifdef useinline}inline;{$endif}\r
+function getfdswmaster : fdset; {$ifdef useinline}inline;{$endif}\r
+\r
+implementation\r
+uses\r
+ lcore,sysutils,\r
+ classes,pgtypes,bfifo,\r
+ {$ifndef nosignal}\r
+ lsignal;\r
+ {$endif}\r
+\r
+{$include unixstuff.inc}\r
+{$include ltimevalstuff.inc}\r
+var\r
+ fdreverse:array[0..absoloutemaxs] of tlasio;\r
+type\r
+ tselecteventcore=class(teventcore)\r
+ public\r
+ procedure processmessages; override;\r
+ procedure messageloop; override;\r
+ procedure exitmessageloop;override;\r
+ procedure setfdreverse(fd : integer;reverseto : tlasio); override;\r
+ procedure rmasterset(fd : integer;islistensocket : boolean); override;\r
+ procedure rmasterclr(fd: integer); override;\r
+ procedure wmasterset(fd : integer); override;\r
+ procedure wmasterclr(fd: integer); override;\r
+ end;\r
+\r
+procedure processtimers;inline;\r
+var\r
+ tv ,tvnow : ttimeval ;\r
+ currenttimer : tltimer ;\r
+ temptimer : tltimer ;\r
+\r
+begin\r
+ gettimeofday(tvnow);\r
+ currenttimer := firsttimer;\r
+ while assigned(currenttimer) do begin\r
+ //writeln(currenttimer.enabled);\r
+ if tv_compare(tvnow,ttimeval(currenttimer.nextts)) and currenttimer.enabled then begin\r
+ //if assigned(currenttimer.ontimer) then begin\r
+ // if currenttimer.enabled then if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer);\r
+ // currenttimer.initialdone := true;\r
+ //end;\r
+ if assigned(currenttimer.ontimer) then currenttimer.ontimer(currenttimer);\r
+ currenttimer.nextts := timeval(tvnow);\r
+ tv_add(ttimeval(currenttimer.nextts),currenttimer.interval);\r
+ end;\r
+ temptimer := currenttimer;\r
+ currenttimer := currenttimer.nexttimer;\r
+ if temptimer.released then temptimer.free;\r
+ end;\r
+end;\r
+\r
+procedure processasios(var fdsr,fdsw:fdset);//inline;\r
+var\r
+ currentsocket : tlasio ;\r
+ tempsocket : tlasio ;\r
+ socketcount : integer ; // for debugging perposes :)\r
+ dw,bt:integer;\r
+begin\r
+{ inc(lcoretestcount);}\r
+\r
+ //the message loop will exit if all lasio's and ltimer's and lsignal's are destroyed\r
+ //if (not assigned(firstasin)) and (not assigned(firsttimer)) and (not assigned(firstsignal)) then exit;\r
+\r
+\r
+ {------- test optimised loop}\r
+ socketcount := 0;\r
+ for dw := (maxs shr 5) downto 0 do if (fdsr[dw] or fdsw[dw]) <> 0 then begin\r
+ for bt := 0 to 31 do if (fdsr[dw] or fdsw[dw]) and (1 shl bt) <> 0 then begin\r
+ inc(socketcount);\r
+ currentsocket := fdreverse[dw shl 5 or bt];\r
+ {if not assigned(currentsocket) then raise exception.create('currentsocket not assigned');\r
+ if currentsocket.fdhandlein < 0 then raise exception.create('currentsocket.fdhandlein out of range');}\r
+ {i've seen the out of range case actually happening, so it can happen. test: just close the fd - beware}\r
+ if not assigned(currentsocket) then begin\r
+ fdclose(dw shl 5 or bt);\r
+ continue\r
+ end;\r
+ if currentsocket.fdhandlein < 0 then begin\r
+ fdclose(dw shl 5 or bt);\r
+ continue\r
+ end;\r
+ try\r
+ currentsocket.handlefdtrigger(fd_isset(currentsocket.fdhandlein,fdsr),fd_isset(currentsocket.fdhandleout,fdsw));\r
+ except\r
+ on E: exception do begin\r
+ currentsocket.HandleBackGroundException(e);\r
+ end;\r
+ end;\r
+\r
+ if mustrefreshfds then begin\r
+ if select(maxs+1,@fdsr,@fdsw,nil,0) <= 0 then begin\r
+ fd_zero(fdsr);\r
+ fd_zero(fdsw);\r
+ end;\r
+ end;\r
+ end;\r
+ end;\r
+\r
+ if asinreleaseflag then begin\r
+ asinreleaseflag := false;\r
+ currentsocket := firstasin;\r
+ while assigned(currentsocket) do begin\r
+ tempsocket := currentsocket;\r
+ currentsocket := currentsocket.nextasin;\r
+ if tempsocket.released then begin\r
+ tempsocket.free;\r
+ end;\r
+ end;\r
+ end;\r
+ {\r
+ !!! issues:\r
+ - sockets which are released may not be freed because theyre never processed by the loop\r
+ made new code for handling this, using asinreleaseflag\r
+\r
+ - when/why does the mustrefreshfds select apply, sheck if i did it correctly?\r
+\r
+ - what happens if calling handlefdtrigger for a socket which does not have an event\r
+ }\r
+ {------- original loop}\r
+\r
+ (*\r
+ currentsocket := firstasin;\r
+ socketcount := 0;\r
+ while assigned(currentsocket) do begin\r
+ if mustrefreshfds then begin\r
+ if select(maxs,@fdsr,@fdsw,nil,0) <= 0 then begin\r
+ fd_zero(fdsr);\r
+ fd_zero(fdsw);\r
+ end;\r
+ end;\r
+ try\r
+ if fd_isset(currentsocket.fdhandlein,fdsr) or fd_isset(currentsocket.fdhandleout,fdsw) then begin\r
+ currentsocket.handlefdtrigger(fd_isset(currentsocket.fdhandlein,fdsr),fd_isset(currentsocket.fdhandleout,fdsw));\r
+ end;\r
+ except\r
+ on E: exception do begin\r
+ currentsocket.HandleBackGroundException(e);\r
+ end;\r
+ end;\r
+ tempsocket := currentsocket;\r
+ currentsocket := currentsocket.nextasin;\r
+ inc(socketcount);\r
+ if tempsocket.released then begin\r
+ tempsocket.free;\r
+ end;\r
+ end; *)\r
+{ debugout('socketcount='+inttostr(socketcount));}\r
+end;\r
+\r
+procedure tselecteventcore.processmessages;\r
+var\r
+ fdsr , fdsw : fdset ;\r
+ selectresult : longint ;\r
+begin\r
+ mustrefreshfds := false;\r
+ {$ifndef nosignal}\r
+ prepsigpipe;\r
+ {$endif}\r
+ selectresult := select(maxs+1,@fdsr,@fdsw,nil,0);\r
+ while (selectresult>0) or assigned(firsttask) or assigned(currenttask) do begin;\r
+\r
+ processtasks;\r
+ processtimers;\r
+ if selectresult > 0 then begin\r
+ processasios(fdsr,fdsw);\r
+ end;\r
+ selectresult := select(maxs+1,@fdsr,@fdsw,nil,0);\r
+\r
+ end;\r
+ mustrefreshfds := true;\r
+end;\r
+\r
+\r
+var\r
+ FDSR , FDSW : fdset;\r
+\r
+var\r
+ fdsrmaster , fdswmaster : fdset ;\r
+
+function getfdsrmaster : fdset; {$ifdef fpc}inline;{$endif}\r
+begin\r
+ result := fdsrmaster;\r
+end;\r
+function getfdswmaster : fdset; {$ifdef fpc}inline;{$endif}\r
+begin\r
+ result := fdswmaster;\r
+end;\r
+
+
+Function doSelect(timeOut:PTimeVal):longint;//inline;\r
+var\r
+ localtimeval : ttimeval;\r
+ maxslocal : integer;\r
+begin\r
+ //unblock signals\r
+ //zeromemory(@sset,sizeof(sset));\r
+ //sset[0] := ;\r
+ fdsr := getfdsrmaster;\r
+ fdsw := getfdswmaster;\r
+\r
+ if assigned(firsttask) then begin\r
+ localtimeval.tv_sec := 0;\r
+ localtimeval.tv_usec := 0;\r
+ timeout := @localtimeval;\r
+ end;\r
+\r
+ maxslocal := maxs;\r
+ mustrefreshfds := false;\r
+{ debugout('about to call select');}\r
+ {$ifndef nosignal}\r
+ sigprocmask(SIG_UNBLOCK,@blockset,nil);\r
+ {$endif}\r
+ result := select(maxslocal+1,@FDSR,@FDSW,nil,timeout);\r
+ if result <= 0 then begin\r
+ fd_zero(FDSR);\r
+ fd_zero(FDSW);\r
+ if result=-1 then begin\r
+ if linuxerror = SYS_EINTR then begin\r
+ // we received a signal it's not a problem\r
+ end else begin\r
+ raise esocketexception.create('select returned error '+inttostr(linuxerror));\r
+ end;\r
+ end;\r
+ end;\r
+ {$ifndef nosignal}\r
+ sigprocmask(SIG_BLOCK,@blockset,nil);\r
+ {$endif}\r
+{ debugout('select complete');}\r
+end;\r
+\r
+procedure tselecteventcore.exitmessageloop;\r
+begin\r
+ exitloopflag := true\r
+end;\r
+\r
+\r
+\r
+procedure tselecteventcore.messageloop;\r
+var\r
+ tv ,tvnow : ttimeval ;\r
+ currenttimer : tltimer ;\r
+ selectresult:integer;\r
+begin\r
+ {$ifndef nosignal}\r
+ prepsigpipe;\r
+ {$endif}\r
+ {currentsocket := firstasin;\r
+ if not assigned(currentsocket) then exit; //the message loop will exit if all lsockets are destroyed\r
+ repeat\r
+\r
+ if currentsocket.state = wsconnected then currentsocket.sendflush;\r
+ currentsocket := currentsocket.nextasin;\r
+ until not assigned(currentsocket);}\r
+\r
+\r
+ repeat\r
+\r
+ //the message loop will exit if all lasio's and ltimer's and lsignal's are destroyed\r
+ if (not assigned(firstasin)) and (not assigned(firsttimer)) {$ifndef nosignal} and (not assigned(firstsignal)){$endif} then exit;\r
+ {fd_zero(FDSR);\r
+ fd_zero(FDSW);\r
+ currentsocket := firstasin;\r
+ if not assigned(currentsocket) then exit; //the message loop will exit if all lsockets are destroyed\r
+\r
+ repeat\r
+ if (not currentsocket.released) and (currentsocket.state<>wsclosed) then fd_set(currentsocket.fdhandlein,fdsr);\r
+ if (not currentsocket.released) and (currentsocket.state=wsconnecting) then fd_set(currentsocket.fdhandleout,fdsw);\r
+ if currentsocket is tlsocket then begin\r
+ if (not currentsocket.released) and (currentsocket.state=wsconnected) and(tlsocket(currentsocket).sendq <> '') then fd_set(currentsocket.fdhandleout,fdsw);\r
+ end;\r
+ tempsocket := currentsocket;\r
+ currentsocket := currentsocket.nextasin;\r
+ if tempsocket.released then begin\r
+ tempsocket.free;\r
+ end;\r
+ until not assigned(currentsocket);\r
+ }\r
+ processtasks;\r
+ //currenttask := nil;\r
+ {beware}\r
+ //if assigned(firsttimer) then begin\r
+ // tv.tv_sec := maxlongint;\r
+ tv := tv_invalidtimebig;\r
+ currenttimer := firsttimer;\r
+ while assigned(currenttimer) do begin\r
+ if tv_compare(tv,currenttimer.nextts) and currenttimer.enabled then tv := currenttimer.nextts;\r
+ currenttimer := currenttimer.nexttimer;\r
+ end;\r
+\r
+\r
+ if tv_compare(tv,tv_invalidtimebig) then begin \r
+ //writeln('no timers active');\r
+ if exitloopflag then break;\r
+{ sleep(10);}\r
+ selectresult := doselect(nil);\r
+\r
+ end else begin\r
+ gettimeofday(tvnow);\r
+ tv_substract(tv,tvnow);\r
+\r
+ //writeln('timers active');\r
+ if tv.tv_sec < 0 then begin\r
+ tv.tv_sec := 0;\r
+ tv.tv_usec := 0; {0.1 sec}\r
+ end;\r
+ if exitloopflag then break;\r
+{ sleep(10);}\r
+ selectresult := doselect(@tv);\r
+ processtimers;\r
+\r
+ end;\r
+ if selectresult > 0 then processasios(fdsr,fdsw);\r
+ {!!!only call processasios if select has asio events -beware}\r
+\r
+ {artificial delay to throttle the number of processasios per second possible and reduce cpu usage}\r
+ until false;\r
+end;\r
+\r
+\r
+procedure tselecteventcore.rmasterset(fd : integer;islistensocket : boolean);\r
+begin\r
+ if fd > absoloutemaxs then raise esocketexception.create('file discriptor out of range');\r
+ if fd > maxs then maxs := fd;\r
+ if fd_isset(fd,fdsrmaster) then exit;\r
+ fd_set(fd,fdsrmaster);\r
+\r
+end;\r
+\r
+procedure tselecteventcore.rmasterclr(fd: integer);\r
+begin\r
+ if not fd_isset(fd,fdsrmaster) then exit;\r
+ fd_clr(fd,fdsrmaster);\r
+\r
+end;\r
+\r
+\r
+procedure tselecteventcore.wmasterset(fd : integer);\r
+begin\r
+ if fd > absoloutemaxs then raise esocketexception.create('file discriptor out of range');\r
+ if fd > maxs then maxs := fd;\r
+\r
+ if fd_isset(fd,fdswmaster) then exit;\r
+ fd_set(fd,fdswmaster);\r
+\r
+end;\r
+\r
+procedure tselecteventcore.wmasterclr(fd: integer);\r
+begin\r
+ if not fd_isset(fd,fdswmaster) then exit;\r
+ fd_clr(fd,fdswmaster);\r
+end;\r
+\r
+procedure tselecteventcore.setfdreverse(fd : integer;reverseto : tlasio);\r
+begin\r
+ fdreverse[fd] := reverseto;\r
+end;\r
+\r
+\r
+\r
+begin\r
+ eventcore := tselecteventcore.create;\r
+\r
+ maxs := 0;\r
+ fd_zero(fdsrmaster);\r
+ fd_zero(fdswmaster);\r
+end.\r
--- /dev/null
+[Compiler]\r
+A=1\r
+B=0\r
+C=1\r
+D=1\r
+E=0\r
+F=0\r
+G=1\r
+H=1\r
+I=1\r
+J=1\r
+K=0\r
+L=1\r
+M=0\r
+N=1\r
+O=1\r
+P=1\r
+Q=0\r
+R=0\r
+S=0\r
+T=0\r
+U=0\r
+V=1\r
+W=0\r
+X=1\r
+Y=0\r
+Z=1\r
+ShowHints=1\r
+ShowWarnings=1\r
+UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;\r
+[Linker]\r
+MapFile=0\r
+OutputObjs=0\r
+ConsoleApp=0\r
+DebugInfo=0\r
+MinStackSize=16384\r
+MaxStackSize=1048576\r
+ImageBase=4194304\r
+ExeDescription=\r
+[Directories]\r
+OutputDir=\r
+UnitOutputDir=\r
+SearchPath=\r
+Packages=vclx30;VCL30;vcldb30;vcldbx30;VclSmp30;Qrpt30;teeui30;teedb30;tee30;IBEVNT30\r
+Conditionals=ipv6\r
+DebugSourceDirs=\r
+UsePackages=0\r
+[Parameters]\r
+RunParams=\r
+HostApplication=\r
+[Version Info]\r
+IncludeVerInfo=0\r
+AutoIncBuild=0\r
+MajorVer=1\r
+MinorVer=0\r
+Release=0\r
+Build=0\r
+Debug=0\r
+PreRelease=0\r
+Special=0\r
+Private=0\r
+DLL=0\r
+Locale=2057\r
+CodePage=1252\r
+[Version Info Keys]\r
+CompanyName=\r
+FileDescription=\r
+FileVersion=1.0.0.0\r
+InternalName=\r
+LegalCopyright=\r
+LegalTrademarks=\r
+OriginalFilename=\r
+ProductName=\r
+ProductVersion=1.0.0.0\r
+Comments=\r
--- /dev/null
+program lcoretest;\r
+\r
+uses\r
+ lcore,\r
+ lsocket,\r
+ {$ifdef win32}\r
+ lcorewsaasyncselect in 'lcorewsaasyncselect.pas',\r
+ {$else}\r
+ lcoreselect,\r
+ {$endif}\r
+ dnsasync,\r
+ binipstuff,\r
+ sysutils,\r
+ dnssync;\r
+{$ifdef win32}\r
+ {$R *.RES}\r
+{$endif}\r
+\r
+type\r
+ tsc=class\r
+ procedure sessionavailable(sender: tobject;error : word);\r
+ procedure dataavailable(sender: tobject;error : word);\r
+ procedure sessionconnected(sender: tobject;error : word);\r
+ procedure taskrun(wparam,lparam:longint);\r
+ procedure timehandler(sender:tobject);\r
+ procedure dnsrequestdone(sender:tobject;error : word);\r
+ procedure sessionclosed(sender:tobject;error : word);\r
+ end;\r
+var\r
+ listensocket : tlsocket;\r
+ serversocket : tlsocket;\r
+ clientsocket : tlsocket;\r
+ sc : tsc;\r
+ task : tltask;\r
+procedure tsc.sessionavailable(sender: tobject;error : word);\r
+begin\r
+ writeln('received connection');\r
+ serversocket.dup(listensocket.accept);\r
+end;\r
+\r
+var\r
+ receivebuf : string;\r
+ receivecount : integer;\r
+procedure tsc.dataavailable(sender: tobject;error : word);\r
+var\r
+ receiveddata : string;\r
+ receivedon : string;\r
+ line : string;\r
+begin\r
+ receiveddata := tlsocket(sender).receivestr;\r
+ if sender=clientsocket then begin\r
+ receivedon := 'client socket';\r
+ end else begin\r
+ receivedon := 'server socket';\r
+ end;\r
+ writeln('received data '+receiveddata+' on '+receivedon);\r
+\r
+ receivebuf := receivebuf+receiveddata;\r
+\r
+ if receivebuf = 'hello world' then begin\r
+ receivebuf := '';\r
+ writeln('received hello world creating task');\r
+ task := tltask.create(sc.taskrun,nil,0,0);\r
+ end;\r
+ receivecount := receivecount +1;\r
+ if receivecount >50 then begin\r
+ writeln('received over 50 bits of data, pausing to let the operator take a look');\r
+ readln;\r
+ receivecount := 0;\r
+ end;\r
+ while pos(#10,receivebuf) > 0 do begin\r
+ line := receivebuf;\r
+ setlength(line,pos(#10,receivebuf)-1);\r
+ receivebuf := copy(receivebuf,pos(#10,receivebuf)+1,1000000);\r
+ if uppercase(copy(line,1,4))='PING' then begin\r
+ line[2] := 'o';\r
+ writeln('send pong:'+line);\r
+ clientsocket.sendstr(line+#10);\r
+ end;\r
+ end;\r
+end;\r
+\r
+procedure tsc.sessionconnected(sender: tobject;error : word);\r
+begin\r
+ if error=0 then begin\r
+ writeln('session is connected, local address is'+clientsocket.getxaddr);\r
+\r
+ if (clientsocket.addr = '127.0.0.1') or (clientsocket.addr = '::1') then begin\r
+ clientsocket.sendstr('hello world');\r
+ end else begin\r
+ clientsocket.sendstr('nick test'#13#10'user x x x x'#13#10);\r
+ end;\r
+ end else begin\r
+ writeln('connect failed');\r
+ end;\r
+end;\r
+\r
+var\r
+ das : tdnsasync;\r
+\r
+procedure tsc.taskrun(wparam,lparam:longint);\r
+var\r
+ tempbinip : tbinip;\r
+ dummy : integer;\r
+begin\r
+ writeln('task ran');\r
+ writeln('closing client socket');\r
+ clientsocket.close;\r
+\r
+ writeln('looking up irc.ipv6.p10link.net using dnsasync');\r
+ das := tdnsasync.Create(nil);\r
+ das.onrequestdone := sc.dnsrequestdone;\r
+ //das.forwardfamily := af_inet6;\r
+ das.forwardlookup('irc.ipv6.p10link.net');\r
+end;\r
+\r
+procedure tsc.dnsrequestdone(sender:tobject;error : word);\r
+begin\r
+ writeln('irc.ipv6.p10link.net resolved to '+das.dnsresult+' connecting client socket there');\r
+ clientsocket.addr := das.dnsresult;\r
+ clientsocket.port := '6667';\r
+ clientsocket.connect;\r
+ writeln(clientsocket.getxaddr);\r
+ das.free;\r
+end;\r
+\r
+procedure tsc.timehandler(sender:tobject);\r
+begin\r
+ //writeln('got timer event');\r
+end;\r
+procedure tsc.sessionclosed(sender:tobject;error : word);\r
+begin\r
+ Writeln('session closed with error ',error);\r
+end;\r
+var\r
+ timer : tltimer;\r
+ ipbin : tbinip;\r
+ dummy : integer;\r
+begin\r
+ ipbin := forwardlookup('invalid.domain',5);\r
+ writeln(ipbintostr(ipbin));\r
+\r
+ ipbin := forwardlookup('p10link.net',5);\r
+ writeln(ipbintostr(ipbin));\r
+\r
+ ipstrtobin('80.68.89.68',ipbin);\r
+ writeln('80.68.89.68 reverses to '+reverselookup(ipbin,5));\r
+\r
+ ipstrtobin('2001:200::8002:203:47ff:fea5:3085',ipbin);\r
+ writeln('2001:200::8002:203:47ff:fea5:3085 reverses to '+reverselookup(ipbin,5));\r
+ writeln('creating and setting up listen socket');\r
+ listensocket := tlsocket.create(nil);\r
+ listensocket.addr := '::';\r
+ listensocket.port := '12345';\r
+ listensocket.onsessionavailable := sc.sessionavailable;\r
+ writeln('listening');\r
+ listensocket.listen;\r
+ writeln(listensocket.getxport);\r
+ writeln('listen socket is number ', listensocket.fdhandlein);\r
+ writeln('creating and setting up server socket');\r
+ serversocket := tlsocket.create(nil);\r
+ serversocket.ondataavailable := sc.dataavailable;\r
+ writeln('creating and setting up client socket');\r
+ clientsocket := tlsocket.create(nil);\r
+ clientsocket.addr := '::1';{'127.0.0.1';}\r
+ clientsocket.port := '12345';\r
+ clientsocket.onsessionconnected := sc.sessionconnected;\r
+ clientsocket.ondataAvailable := sc.dataavailable;\r
+ clientsocket.onsessionclosed := sc.sessionclosed;\r
+ writeln('connecting');\r
+ clientsocket.connect;\r
+ writeln('client socket is number ',clientsocket.fdhandlein);\r
+ writeln('creating and setting up timer');\r
+ timer := tltimer.create(nil);\r
+ timer.interval := 1000;\r
+ timer.ontimer := sc.timehandler;\r
+ timer.enabled := true;\r
+ writeln('entering message loop');\r
+ messageloop;\r
+ writeln('exiting cleanly');\r
+end.\r
--- /dev/null
+unit lcorewsaasyncselect;\r
+\r
+interface\r
+\r
+implementation\r
+uses wcore,lcore,bsearchtree,sysutils,windows,winsock,pgtypes,messages,classes;\r
+type\r
+ twineventcore=class(teventcore)\r
+ public\r
+ procedure processmessages; override;\r
+ procedure messageloop; override;\r
+ procedure exitmessageloop;override;\r
+ procedure setfdreverse(fd : integer;reverseto : tlasio); override;\r
+ procedure rmasterset(fd : integer;islistensocket : boolean); override;\r
+ procedure rmasterclr(fd: integer); override;\r
+ procedure wmasterset(fd : integer); override;\r
+ procedure wmasterclr(fd: integer); override;\r
+ end;\r
+const\r
+ wm_dotasks=wm_user+1;\r
+type\r
+ twintimerwrapperinterface=class(ttimerwrapperinterface)\r
+ public\r
+ function createwrappedtimer : tobject;override;\r
+// procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);override;\r
+ procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);override;\r
+ procedure setenabled(wrappedtimer : tobject;newvalue : boolean);override;\r
+ procedure setinterval(wrappedtimer : tobject;newvalue : integer);override;\r
+ end;\r
+\r
+procedure twineventcore.processmessages;\r
+begin\r
+ wcore.processmessages;//pass off to wcore\r
+end;\r
+procedure twineventcore.messageloop;\r
+begin\r
+ wcore.messageloop; //pass off to wcore\r
+end;\r
+procedure twineventcore.exitmessageloop;\r
+begin\r
+ wcore.exitmessageloop;\r
+end;\r
+var\r
+ fdreverse : thashtable;\r
+ fdwatches : thashtable;\r
+\r
+procedure twineventcore.setfdreverse(fd : integer;reverseto : tlasio);\r
+begin\r
+ if findtree(@fdreverse,inttostr(fd)) <> nil then deltree(@fdreverse,inttostr(fd));\r
+ if reverseto <> nil then addtree(@fdreverse,inttostr(fd),reverseto);\r
+end;\r
+\r
+var\r
+ hwndlcore : hwnd;\r
+procedure dowsaasyncselect(fd:integer; leventadd: integer; leventremove : integer);\r
+var\r
+ leventold : integer;\r
+ leventnew : integer;\r
+ wsaaresult : integer;\r
+begin\r
+ leventold := taddrint(findtree(@fdwatches,inttostr(fd)));\r
+ leventnew := leventold or leventadd;\r
+ leventnew := leventnew and not leventremove;\r
+ if leventold <> leventnew then begin\r
+ if leventold <> 0 then deltree(@fdwatches,inttostr(fd));\r
+ if leventnew <> 0 then addtree(@fdwatches,inttostr(fd),pointer(leventnew));\r
+ end;\r
+ wsaaresult := wsaasyncselect(fd,hwndlcore,wm_user,leventnew);\r
+\r
+end;\r
+\r
+\r
+//to allow detection of errors:\r
+//if we are asked to monitor for read or accept we also monitor for close\r
+//if we are asked to monitor for write we also monitor for connect\r
+\r
+\r
+procedure twineventcore.rmasterset(fd : integer;islistensocket : boolean);\r
+begin\r
+ if islistensocket then begin\r
+ //writeln('setting accept watch for socket number ',fd);\r
+ dowsaasyncselect(fd,FD_ACCEPT or FD_CLOSE,0);\r
+ end else begin\r
+ //writeln('setting read watch for socket number',fd);\r
+ dowsaasyncselect(fd,FD_READ or FD_CLOSE,0);\r
+ end;\r
+end;\r
+procedure twineventcore.rmasterclr(fd: integer);\r
+begin\r
+ //writeln('clearing read of accept watch for socket number ',fd);\r
+ dowsaasyncselect(fd,0,FD_ACCEPT or FD_READ or FD_CLOSE);\r
+end;\r
+procedure twineventcore.wmasterset(fd : integer);\r
+begin\r
+ dowsaasyncselect(fd,FD_WRITE or FD_CONNECT,0);\r
+end;\r
+\r
+procedure twineventcore.wmasterclr(fd: integer);\r
+begin\r
+ dowsaasyncselect(fd,0,FD_WRITE or FD_CONNECT);\r
+end;\r
+\r
+var\r
+ tasksoutstanding : boolean;\r
+\r
+function MyWindowProc(\r
+ ahWnd : HWND;\r
+ auMsg : Integer;\r
+ awParam : WPARAM;\r
+ alParam : LPARAM): Integer; stdcall;\r
+var\r
+ socket : integer;\r
+ event : integer;\r
+ error : integer;\r
+ readtrigger : boolean;\r
+ writetrigger : boolean;\r
+ lasio : tlasio;\r
+begin\r
+ //writeln('got a message');\r
+ Result := 0; // This means we handled the message\r
+ if (ahwnd=hwndlcore) and (aumsg=wm_user) then begin\r
+ //writeln('it appears to be a response to our wsaasyncselect');\r
+ socket := awparam;\r
+ event := alparam and $FFFF;\r
+ error := alparam shr 16;\r
+ //writeln('socket=',socket,' event=',event,' error=',error);\r
+ readtrigger := false;\r
+ writetrigger := false;\r
+ lasio := findtree(@fdreverse,inttostr(socket));\r
+ if assigned(lasio) then begin\r
+ if (error <> 0) or ((event and FD_CLOSE) <> 0) then begin\r
+ if lasio.state = wsconnecting then begin\r
+ lasio.onsessionconnected(lasio,error);\r
+ end;\r
+ lasio.internalclose(error);\r
+ end else begin\r
+ if (event and (FD_READ or FD_ACCEPT)) <> 0 then readtrigger := true;\r
+ if (event and (FD_WRITE)) <> 0 then writetrigger := true;\r
+\r
+ if readtrigger or writetrigger then lasio.handlefdtrigger(readtrigger,writetrigger);\r
+ end;\r
+ dowsaasyncselect(socket,0,0); //reset watches\r
+ end;\r
+ end else if (ahwnd=hwndlcore) and (aumsg=wm_dotasks) then begin\r
+ //writeln('processing tasks');\r
+ tasksoutstanding := false;\r
+ processtasks;\r
+ end else begin\r
+ //writeln('passing unknown message to defwindowproc');\r
+ //not passing unknown messages on to defwindowproc will cause window\r
+ //creation to fail! --plugwash\r
+ Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)\r
+ end;\r
+\r
+end;\r
+\r
+procedure winaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+ if not tasksoutstanding then PostMessage(hwndlcore,wm_dotasks,0,0);\r
+end;\r
+type\r
+ twcoretimer = wcore.tltimer;\r
+\r
+function twintimerwrapperinterface.createwrappedtimer : tobject;\r
+begin\r
+ result := twcoretimer.create(nil);\r
+end;\r
+procedure twintimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);\r
+begin\r
+ twcoretimer(wrappedtimer).ontimer := newvalue;\r
+end;\r
+procedure twintimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean);\r
+begin\r
+ twcoretimer(wrappedtimer).enabled := newvalue;\r
+end;\r
+\r
+\r
+procedure twintimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer);\r
+begin\r
+ twcoretimer(wrappedtimer).interval := newvalue;\r
+end;\r
+\r
+var\r
+ MyWindowClass : TWndClass = (style : 0;\r
+ lpfnWndProc : @MyWindowProc;\r
+ cbClsExtra : 0;\r
+ cbWndExtra : 0;\r
+ hInstance : 0;\r
+ hIcon : 0;\r
+ hCursor : 0;\r
+ hbrBackground : 0;\r
+ lpszMenuName : nil;\r
+ lpszClassName : 'lcoreClass');\r
+ GInitData: TWSAData;\r
+\r
+begin\r
+ eventcore := twineventcore.create;\r
+ if Windows.RegisterClass(MyWindowClass) = 0 then halt;\r
+ //writeln('about to create lcore handle, hinstance=',hinstance);\r
+ hwndlcore := CreateWindowEx(WS_EX_TOOLWINDOW,\r
+ MyWindowClass.lpszClassName,\r
+ '', { Window name }\r
+ WS_POPUP, { Window Style }\r
+ 0, 0, { X, Y }\r
+ 0, 0, { Width, Height }\r
+ 0, { hWndParent }\r
+ 0, { hMenu }\r
+ HInstance, { hInstance }\r
+ nil); { CreateParam }\r
+ //writeln('lcore hwnd is ',hwndlcore);\r
+ //writeln('last error is ',GetLastError);\r
+ onaddtask := winaddtask;\r
+ timerwrapperinterface := twintimerwrapperinterface.create(nil);\r
+\r
+ WSAStartup($200, GInitData);\r
+end.\r
--- /dev/null
+unit lloopback;\r
+\r
+interface\r
+uses lcore,classes;\r
+\r
+type\r
+ tlloopback=class(tlasio)\r
+ public\r
+ constructor create(aowner:tcomponent); override;\r
+ end;\r
+\r
+\r
+implementation\r
+uses
+{$ifdef ver1_0}
+ linux;
+{$else}
+ baseunix,unix,unixutil;
+{$endif}
+{$i unixstuff.inc}
+
+constructor tlloopback.create(aowner:tcomponent);\r
+begin\r
+ inherited create(aowner);\r
+ closehandles := true;\r
+ assignpipe(fdhandlein,fdhandleout);\r
+\r
+ eventcore.rmasterset(fdhandlein,false);//fd_set(fdhandlein,fdsrmaster);\r
+ eventcore.wmasterclr(fdhandlein);//fd_clr(fdhandleout,fdswmaster);\r
+ eventcore.setfdreverse(fdhandlein,self);\r
+ eventcore.setfdreverse(fdhandleout,self);\r
+ state := wsconnected;\r
+end;\r
+end.\r
--- /dev/null
+unit lmessages;\r
+//windows messages like system based on lcore tasks\r
+interface\r
+\r
+uses pgtypes,sysutils,bsearchtree,strings,syncobjs;\r
+\r
+type\r
+ lparam=taddrint;\r
+ wparam=taddrint;\r
+ thinstance=pointer;\r
+ hicon=pointer;\r
+ hcursor=pointer;\r
+ hbrush=pointer;\r
+ hwnd=qword; //window handles are monotonically increasing 64 bit integers,\r
+ //this should allow for a million windows per second for over half\r
+ //a million years!\r
+\r
+ twndproc=function(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;\r
+\r
+\r
+ twndclass=record\r
+ style : dword;\r
+ lpfnwndproc : twndproc;\r
+ cbclsextra : integer;\r
+ cbwndextra : integer;\r
+ hinstance : thinstance;\r
+ hicon : hicon;\r
+ hcursor : hcursor;\r
+ hbrbackground : hbrush;\r
+ lpszmenuname : pchar;\r
+ lpszclassname : pchar;\r
+ end;\r
+ PWNDCLASS=^twndclass;\r
+ \r
+ UINT=dword;\r
+ WINBOOL = longbool;\r
+ tTIMERPROC = procedure (ahwnd:HWND; umsg:integer; idevent:taddrint;dwtime:taddrint);stdcall;\r
+ ATOM = pointer;\r
+ LPCSTR = pchar;\r
+ LPVOID = pointer;\r
+ HMENU = pointer;\r
+ HINST = pointer;\r
+\r
+ TPOINT = record \r
+ x : LONGint; \r
+ y : LONGint; \r
+ end; \r
+ \r
+ TMSG = record \r
+ hwnd : HWND; \r
+ message : UINT; \r
+ wParam : WPARAM; \r
+ lParam : LPARAM; \r
+ time : DWORD; \r
+ pt : TPOINT;\r
+ end; \r
+ THevent=TEventObject;\r
+const\r
+ WS_EX_TOOLWINDOW = $80;\r
+ WS_POPUP = longint($80000000);\r
+ hinstance=nil;\r
+ PM_REMOVE = 1;\r
+ WM_USER = 1024;\r
+ WM_TIMER = 275;\r
+ INFINITE = syncobjs.infinite;\r
+function getwindowlongptr(ahwnd:hwnd;nindex:integer) : taddrint;\r
+function setwindowlongptr(ahwnd:hwnd;nindex:integer;dwNewLong : taddrint) : taddrint;\r
+function DefWindowProc(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;\r
+function RegisterClass(const lpWndClass:TWNDCLASS):ATOM;\r
+function CreateWindowEx(dwExStyle:DWORD; lpClassName:LPCSTR; lpWindowName:LPCSTR; dwStyle:DWORD; X:longint;Y:longint; nWidth:longint; nHeight:longint; hWndParent:HWND; hMenu:HMENU;hInstance:HINST; lpParam:LPVOID):HWND;\r
+function DestroyWindow(ahWnd:HWND):WINBOOL;\r
+function PostMessage(hWnd:HWND; Msg:UINT; wParam:WPARAM; lParam:LPARAM):WINBOOL;\r
+function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): WINBOOL;\r
+function DispatchMessage(const lpMsg: TMsg): Longint;\r
+function GetMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT): WINBOOL;\r
+function SetEvent(hEvent:THevent):WINBOOL;\r
+function CreateEvent(lpEventAttributes:PSECURITYATTRIBUTES; bManualReset:WINBOOL; bInitialState:WINBOOL; lpName:pchar):tHevent;\r
+function terminatethread(threadhandle : tthreadid;dummy:integer) : boolean;\r
+function waitforsingleevent(event:thevent;timeout:cardinal) : twaitresult;\r
+function SetTimer(ahWnd:HWND; nIDEvent:taddrint; uElapse:UINT; lpTimerFunc:tTIMERPROC):UINT;\r
+function KillTimer(ahWnd:HWND; uIDEvent:taddrint):WINBOOL;\r
+\r
+procedure init;\r
+\r
+implementation\r
+uses\r
+ baseunix,unix,lcore;//,safewriteln;\r
+{$i unixstuff.inc}\r
+\r
+type\r
+ tmessageintransit = class\r
+ msg : tmsg;\r
+ next : tmessageintransit;\r
+ end;\r
+\r
+ tthreaddata = class\r
+ messagequeue : tmessageintransit;\r
+ messageevent : teventobject;\r
+ waiting : boolean;\r
+ lcorethread : boolean;\r
+ nexttimer : ttimeval;\r
+ threadid : integer;\r
+ end;\r
+ twindow=class\r
+ hwnd : hwnd;\r
+ extrawindowmemory : pointer;\r
+ threadid : tthreadid;\r
+ windowproc : twndproc;\r
+ end;\r
+\r
+var\r
+ structurelock : tcriticalsection;\r
+ threaddata : thashtable;\r
+ windowclasses : thashtable;\r
+ lcorelinkpipesend : integer;\r
+ lcorelinkpiperecv : tlasio;\r
+ windows : thashtable;\r
+ //I would rather things crash immediately\r
+ //if they use an insufficiant size type\r
+ //than crash after over four billion\r
+ //windows have been made ;)\r
+ nextwindowhandle : qword = $100000000;\r
+{$i ltimevalstuff.inc}\r
+\r
+//findthreaddata should only be called while holding the structurelock\r
+function findthreaddata(threadid : integer) : tthreaddata;\r
+begin\r
+ result := tthreaddata(findtree(@threaddata,inttostr(threadid)));\r
+ if result = nil then begin\r
+ result := tthreaddata.create;\r
+ result.messageevent := teventobject.create(nil,false,false,inttostr(taddrint(result)));\r
+ result.nexttimer := tv_invalidtimebig;\r
+ result.threadid := threadid;\r
+ addtree(@threaddata,inttostr(threadid),result);\r
+ end;\r
+end;\r
+\r
+//deletethreaddataifunused should only be called while holding the structurelock\r
+procedure deletethreaddataifunused(athreaddata : tthreaddata);\r
+begin\r
+ //writeln('in deletethreaddataifunused');\r
+ if (athreaddata <> nil) then if (athreaddata.waiting=false) and (athreaddata.messagequeue=nil) and (athreaddata.lcorethread=false) and (athreaddata.nexttimer.tv_sec=tv_invalidtimebig.tv_sec) and (athreaddata.nexttimer.tv_usec=tv_invalidtimebig.tv_usec) then begin\r
+ //writeln('threaddata is unused, freeing messageevent');\r
+ athreaddata.messageevent.free;\r
+ //writeln('freeing thread data object');\r
+ athreaddata.free;\r
+ //writeln('deleting thread data object from hashtable');\r
+ deltree(@threaddata,inttostr(athreaddata.threadid));\r
+ //writeln('finished deleting thread data');\r
+ end else begin\r
+ //writeln('thread data is not unused');\r
+ end;\r
+end;\r
+\r
+function getwindowlongptr(ahwnd:hwnd;nindex:integer) : taddrint;\r
+var\r
+ window : twindow;\r
+begin\r
+ structurelock.acquire;\r
+ try\r
+ window := findtree(@windows,inttostr(ahwnd));\r
+ if window <> nil then begin\r
+ result := paddrint(taddrint(window.extrawindowmemory)+nindex)^;\r
+ end else begin\r
+ result := 0;\r
+ end;\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+end;\r
+\r
+function setwindowlongptr(ahwnd:hwnd;nindex:integer;dwNewLong : taddrint) : taddrint;\r
+var\r
+ window : twindow;\r
+begin\r
+ structurelock.acquire;\r
+ try\r
+ window := findtree(@windows,inttostr(ahwnd));\r
+ if window <> nil then begin\r
+ result := paddrint(taddrint(window.extrawindowmemory)+nindex)^;\r
+ paddrint(taddrint(window.extrawindowmemory)+nindex)^ := dwnewlong;\r
+ end else begin\r
+ result := 0;\r
+ end;\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function DefWindowProc(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;\r
+begin\r
+ result := 0;\r
+end;\r
+\r
+function strdup(s:pchar) : pchar;\r
+begin\r
+ //swriteln('in strdup, about to allocate memory');\r
+ result := getmem(strlen(s)+1);\r
+ //swriteln('about to copy string');\r
+ strcopy(s,result);\r
+ //swriteln('leaving strdup');\r
+end;\r
+\r
+function RegisterClass(const lpWndClass:TWNDCLASS):ATOM;\r
+var\r
+ storedwindowclass:pwndclass;\r
+begin\r
+ structurelock.acquire;\r
+ try\r
+ //swriteln('in registerclass, about to check for duplicate window class');\r
+ storedwindowclass := findtree(@windowclasses, lpwndclass.lpszclassname);\r
+ if storedwindowclass <> nil then begin\r
+\r
+ if comparebyte(storedwindowclass^,lpwndclass,sizeof(twndclass)-sizeof(pchar)-sizeof(pchar)) <> 0 then begin\r
+ //swriteln('duplicate window class registered with different settings');\r
+ raise exception.create('duplicate window class registered with different settings');\r
+ end else begin\r
+ //swriteln('duplicate window class registered with same settings, tollerated');\r
+ end;\r
+ end else begin\r
+ //swriteln('about to allocate memory for new windowclass');\r
+ storedwindowclass := getmem(sizeof(twndclass));\r
+ //swriteln('about to copy windowclass from parameter');\r
+ move(lpwndclass,storedwindowclass^,sizeof(twndclass));\r
+ //swriteln('about to copy strings');\r
+ if lpwndclass.lpszmenuname <> nil then storedwindowclass.lpszmenuname := strdup(lpwndclass.lpszmenuname);\r
+ if lpwndclass.lpszclassname <> nil then storedwindowclass.lpszclassname := strdup(lpwndclass.lpszclassname);\r
+ //swriteln('about to add result to list of windowclasses');\r
+ addtree(@windowclasses,lpwndclass.lpszclassname,storedwindowclass);\r
+ end;\r
+ //swriteln('about to return result');\r
+ result := storedwindowclass;\r
+ //swriteln('leaving registerclass');\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+end;\r
+\r
+function CreateWindowEx(dwExStyle:DWORD; lpClassName:LPCSTR; lpWindowName:LPCSTR; dwStyle:DWORD; X:longint;Y:longint; nWidth:longint; nHeight:longint; hWndParent:HWND; hMenu:HMENU;hInstance:HINST; lpParam:LPVOID):HWND;\r
+var\r
+ wndclass : pwndclass;\r
+ tm : tthreadmanager;\r
+ window : twindow;\r
+begin\r
+ structurelock.acquire;\r
+ try\r
+ window := twindow.create;\r
+ window.hwnd := nextwindowhandle;\r
+ result := window.hwnd;\r
+ nextwindowhandle := nextwindowhandle + 1;\r
+ addtree(@windows,inttostr(window.hwnd),window);\r
+ wndclass := findtree(@windowclasses,lpclassname);\r
+ window.extrawindowmemory := getmem(wndclass.cbwndextra);\r
+\r
+ getthreadmanager(tm);\r
+ window.threadid := tm.GetCurrentThreadId;\r
+ window.windowproc := wndclass.lpfnwndproc;\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+end;\r
+function DestroyWindow(ahWnd:HWND):WINBOOL;\r
+var\r
+ window : twindow;\r
+ windowthreaddata : tthreaddata;\r
+ currentmessage : tmessageintransit;\r
+ prevmessage : tmessageintransit;\r
+begin\r
+ //writeln('started to destroy window');\r
+ structurelock.acquire;\r
+ try\r
+ window := twindow(findtree(@windows,inttostr(ahwnd)));\r
+ if window <> nil then begin\r
+ freemem(window.extrawindowmemory);\r
+ //writeln('aboute to delete window from windows structure');\r
+ deltree(@windows,inttostr(ahwnd));\r
+ //writeln('deleted window from windows structure');\r
+ windowthreaddata := tthreaddata(findtree(@threaddata,inttostr(window.threadid)));\r
+\r
+ if windowthreaddata <> nil then begin\r
+ //writeln('found thread data scanning for messages to clean up');\r
+ currentmessage := windowthreaddata.messagequeue;\r
+ prevmessage := nil;\r
+ while currentmessage <> nil do begin\r
+ while (currentmessage <> nil) and (currentmessage.msg.hwnd = ahwnd) do begin\r
+ if prevmessage = nil then begin\r
+ windowthreaddata.messagequeue := currentmessage.next;\r
+ end else begin\r
+ prevmessage.next := currentmessage.next;\r
+ end;\r
+ currentmessage.free;\r
+ if prevmessage = nil then begin\r
+ currentmessage := windowthreaddata.messagequeue;\r
+ end else begin\r
+ currentmessage := prevmessage.next;\r
+ end;\r
+ end;\r
+ if currentmessage <> nil then begin\r
+ prevmessage := currentmessage;\r
+ currentmessage := currentmessage.next;\r
+ end;\r
+ end;\r
+ //writeln('deleting thread data structure if it is unused');\r
+ deletethreaddataifunused(windowthreaddata);\r
+ end else begin\r
+ //writeln('there is no thread data to search for messages to cleanup');\r
+ end;\r
+ //writeln('freeing window');\r
+ window.free;\r
+ result := true;\r
+ end else begin\r
+ result := false;\r
+ end;\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+ //writeln('window destroyed');\r
+end;\r
+\r
+\r
+\r
+function PostMessage(hWnd:HWND; Msg:UINT; wParam:WPARAM; lParam:LPARAM):WINBOOL;\r
+var\r
+ threaddata : tthreaddata;\r
+ message : tmessageintransit;\r
+ messagequeueend : tmessageintransit;\r
+ window : twindow;\r
+begin\r
+ structurelock.acquire;\r
+ try\r
+ window := findtree(@windows,inttostr(hwnd));\r
+ if window <> nil then begin\r
+ threaddata := findthreaddata(window.threadid);\r
+ message := tmessageintransit.create;\r
+ message.msg.hwnd := hwnd;\r
+ message.msg.message := msg;\r
+ message.msg.wparam := wparam;\r
+ message.msg.lparam := lparam;\r
+ if threaddata.lcorethread then begin\r
+ //swriteln('posting message to lcore thread');\r
+ fdwrite(lcorelinkpipesend,message,sizeof(message));\r
+ end else begin\r
+ //writeln('posting message to non lcore thread');\r
+ if threaddata.messagequeue = nil then begin\r
+ threaddata.messagequeue := message;\r
+ end else begin\r
+ messagequeueend := threaddata.messagequeue;\r
+ while messagequeueend.next <> nil do begin\r
+ messagequeueend := messagequeueend.next;\r
+ end;\r
+ messagequeueend.next := message;\r
+ end;\r
+\r
+ //writeln('message added to queue');\r
+ if threaddata.waiting then threaddata.messageevent.setevent;\r
+ end;\r
+ result := true;\r
+ end else begin\r
+ result := false;\r
+ end;\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+\r
+end;\r
+\r
+function gettickcount : dword;\r
+var\r
+ result64: integer;\r
+ tv : ttimeval;\r
+begin\r
+ gettimeofday(tv);\r
+ result64 := (tv.tv_sec*1000)+(tv.tv_usec div 1000);\r
+ result := result64;\r
+end;\r
+\r
+function DispatchMessage(const lpMsg: TMsg): Longint;\r
+var\r
+ timerproc : ttimerproc;\r
+ window : twindow;\r
+ windowproc : twndproc;\r
+begin\r
+ ////swriteln('in dispatchmessage, msg.hwnd='+inttohex(taddrint(lpmsg.hwnd),16));\r
+ if (lpmsg.lparam <> 0) and (lpmsg.message = WM_TIMER) then begin\r
+ timerproc := ttimerproc(lpmsg.lparam);\r
+ timerproc(lpmsg.hwnd,lpmsg.message,lpmsg.wparam,gettickcount);\r
+ result := 0;\r
+ end else begin\r
+ structurelock.acquire;\r
+ try\r
+ window := findtree(@windows,inttostr(lpmsg.hwnd));\r
+ //we have to get the window procedure while the structurelock\r
+ //is still held as the window could be destroyed from another thread\r
+ //otherwise.\r
+ windowproc := window.windowproc;\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+ if window <> nil then begin\r
+ result := windowproc(lpmsg.hwnd,lpmsg.message,lpmsg.wparam,lpmsg.lparam);\r
+ end else begin\r
+ result := -1;\r
+ end;\r
+ end;\r
+end;\r
+\r
+procedure processtimers;\r
+begin\r
+end;\r
+\r
+function GetMessageinternal(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT; wremovemsg : UINT;peek:boolean): WINBOOL;\r
+var\r
+ tm : tthreadmanager;\r
+ threaddata : tthreaddata;\r
+ message : tmessageintransit;\r
+ nowtv : ttimeval;\r
+ timeouttv : ttimeval;\r
+ timeoutms : int64;\r
+\r
+begin\r
+ if hwnd <> 0 then raise exception.create('getting messages for an individual window is not supported');\r
+ if (wmsgfiltermin <> 0) or (wmsgfiltermax <> 0) then raise exception.create('message filtering is not supported');\r
+ structurelock.acquire;\r
+ result := true;\r
+ try\r
+ getthreadmanager(tm);\r
+ threaddata := findthreaddata(tm.GetCurrentThreadId);\r
+ if threaddata.lcorethread then raise exception.create('get/peek message cannot be used in the lcore thread');\r
+ message := threaddata.messagequeue;\r
+ gettimeofday(nowtv);\r
+ while (not peek) and (message=nil) and (not tv_compare(nowtv,threaddata.nexttimer)) do begin\r
+ threaddata.waiting := true;\r
+ structurelock.release;\r
+ if (threaddata.nexttimer.tv_sec = TV_invalidtimebig.tv_sec) and (threaddata.nexttimer.tv_usec = TV_invalidtimebig.tv_usec) then begin\r
+ threaddata.messageevent.waitfor(INFINITE);\r
+ end else begin\r
+\r
+ timeouttv := threaddata.nexttimer;\r
+ timeoutms := (timeouttv.tv_sec * 1000)+(timeouttv.tv_usec div 1000);\r
+ //i'm assuming the timeout is in milliseconds\r
+ if (timeoutms > maxlongint) then timeoutms := maxlongint;\r
+ threaddata.messageevent.waitfor(timeoutms);\r
+\r
+ end;\r
+ structurelock.acquire;\r
+ threaddata.waiting := false;\r
+ message := threaddata.messagequeue;\r
+ gettimeofday(nowtv);\r
+ end;\r
+ if (message=nil) and tv_compare(nowtv,threaddata.nexttimer) then begin\r
+ processtimers;\r
+ end;\r
+ message := threaddata.messagequeue;\r
+ if message <> nil then begin\r
+ lpmsg := message.msg;\r
+ if wremovemsg=PM_REMOVE then begin\r
+ threaddata.messagequeue := message.next;\r
+ message.free;\r
+ end;\r
+ end else begin\r
+ result :=false;\r
+ end;\r
+ deletethreaddataifunused(threaddata);\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+end;\r
+\r
+function GetMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT): WINBOOL;\r
+begin\r
+ result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,PM_REMOVE,false);\r
+end;\r
+\r
+function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): WINBOOL;\r
+begin\r
+ result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,PM_REMOVE,true);\r
+end;\r
+\r
+function SetEvent(hEvent:THevent):WINBOOL;\r
+begin\r
+ hevent.setevent;\r
+ result := true;\r
+end;\r
+\r
+function CreateEvent(lpEventAttributes:PSECURITYATTRIBUTES; bManualReset:WINBOOL; bInitialState:WINBOOL; lpName:pchar):tHevent;\r
+begin\r
+ result := teventobject.create(lpeventattributes,bmanualreset,binitialstate,lpname);\r
+end;\r
+\r
+function terminatethread(threadhandle:tthreadid;dummy : integer) : boolean;\r
+var\r
+ tm : tthreadmanager;\r
+begin\r
+ getthreadmanager(tm);\r
+ tm.killthread(threadhandle);\r
+ result := true;\r
+end;\r
+\r
+function waitforsingleevent(event:thevent;timeout:cardinal) : twaitresult;\r
+begin\r
+ result := event.waitfor(timeout);\r
+end;\r
+\r
+procedure removefrombuffer(n : integer; var buffer:string);\r
+begin\r
+ if n=length(buffer) then begin\r
+ buffer := '';\r
+ end else begin\r
+ uniquestring(buffer);\r
+ move(buffer[n+1],buffer[1],length(buffer)-n);\r
+ setlength(buffer,length(buffer)-n);\r
+ end;\r
+end;\r
+\r
+type\r
+ tsc=class\r
+ procedure available(sender:tobject;error:word);\r
+ end;\r
+\r
+var\r
+ recvbuf : string;\r
+\r
+procedure tsc.available(sender:tobject;error:word);\r
+var\r
+ message : tmessageintransit;\r
+ messagebytes : array[1..sizeof(tmessageintransit)] of char absolute message;\r
+ i : integer;\r
+begin\r
+ //swriteln('received data on lcorelinkpipe');\r
+ recvbuf := recvbuf + lcorelinkpiperecv.receivestr;\r
+ while length(recvbuf) >= sizeof(tmessageintransit) do begin\r
+ for i := 1 to sizeof(tmessageintransit) do begin\r
+ messagebytes[i] := recvbuf[i];\r
+ end;\r
+ dispatchmessage(message.msg);\r
+ message.free;\r
+ removefrombuffer(sizeof(tmessageintransit),recvbuf);\r
+ end;\r
+end;\r
+\r
+procedure init;\r
+var\r
+ tm : tthreadmanager;\r
+ threaddata : tthreaddata;\r
+ pipeends : tfildes;\r
+ sc : tsc;\r
+begin\r
+ structurelock := tcriticalsection.create;\r
+ getthreadmanager(tm);\r
+ threaddata := findthreaddata(tm.GetCurrentThreadId);\r
+ threaddata.lcorethread := true;\r
+ fppipe(pipeends);\r
+ lcorelinkpipesend := pipeends[1];\r
+ lcorelinkpiperecv := tlasio.create(nil);\r
+ lcorelinkpiperecv.dup(pipeends[0]);\r
+ lcorelinkpiperecv.ondataavailable := sc.available;\r
+ recvbuf := '';\r
+end;\r
+\r
+var\r
+ lcorethreadtimers : thashtable;\r
+type\r
+ tltimerformsg = class(tltimer)\r
+ public\r
+ hwnd : hwnd;\r
+ id : taddrint;\r
+ procedure timer(sender : tobject);\r
+ end;\r
+\r
+procedure tltimerformsg.timer(sender : tobject);\r
+var\r
+ msg : tmsg;\r
+begin\r
+ ////swriteln('in tltimerformsg.timer');\r
+ fillchar(msg,sizeof(msg),0);\r
+ msg.message := WM_TIMER;\r
+ msg.hwnd := hwnd;\r
+ msg.wparam := ID;\r
+ msg.lparam := 0;\r
+ dispatchmessage(msg);\r
+end;\r
+\r
+function SetTimer(ahWnd:HWND; nIDEvent:taddrint; uElapse:UINT; lpTimerFunc:tTIMERPROC):UINT;\r
+var\r
+ threaddata : tthreaddata;\r
+ ltimer : tltimerformsg;\r
+ tm : tthreadmanager;\r
+ window : twindow;\r
+begin\r
+ structurelock.acquire;\r
+ try\r
+ window := findtree(@windows,inttostr(ahwnd));\r
+ if window= nil then raise exception.create('invalid window');\r
+ threaddata := findthreaddata(window.threadid);\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+ if threaddata.lcorethread then begin\r
+ getthreadmanager(tm);\r
+ if tm.GetCurrentThreadId <> window.threadid then raise exception.create('timers on the lcore thread may only be added and removed from the lcore thread');\r
+ if ahwnd = 0 then raise exception.create('timers on the lcore thread must be associated with a window handle');\r
+ if @lptimerfunc <> nil then raise exception.create('seperate timer functions are not supported');\r
+\r
+ //remove preexisting timer with same ID\r
+ killtimer(ahwnd,nIDEvent);\r
+\r
+ ltimer := tltimerformsg.create(nil);\r
+ ltimer.interval := uelapse;\r
+ ltimer.id := nidevent;\r
+ ltimer.hwnd := ahwnd;\r
+ ltimer.enabled := true;\r
+ ltimer.ontimer := ltimer.timer;\r
+\r
+ addtree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(nIDEvent),ltimer);\r
+\r
+ result := nidevent;\r
+ end else begin\r
+ raise exception.create('settimer not implemented for threads other than the lcore thread');\r
+ end;\r
+end;\r
+\r
+function KillTimer(ahWnd:HWND; uIDEvent:taddrint):WINBOOL;\r
+var\r
+ threaddata : tthreaddata;\r
+ ltimer : tltimerformsg;\r
+ tm : tthreadmanager;\r
+ window : twindow;\r
+begin\r
+ structurelock.acquire;\r
+ try\r
+ window := findtree(@windows,inttostr(ahwnd));\r
+ if window= nil then raise exception.create('invalid window');\r
+ threaddata := findthreaddata(window.threadid);\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+ if threaddata.lcorethread then begin\r
+ getthreadmanager(tm);\r
+ if tm.GetCurrentThreadId <> window.threadid then raise exception.create('timers on the lcore thread may only be added and remove from the lcore thread');\r
+ if ahwnd = 0 then raise exception.create('timers on the lcore thread must be associated with a window handle');\r
+ ltimer := tltimerformsg(findtree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(uIDEvent)));\r
+ if ltimer <> nil then begin\r
+ deltree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(uIDEvent));\r
+ ltimer.free;\r
+ result := true;\r
+ end else begin\r
+ result := false;\r
+ end;\r
+ end else begin\r
+ raise exception.create('settimer not implemented for threads other than the lcore thread');\r
+ end;\r
+end;\r
+\r
+end.
\ No newline at end of file
--- /dev/null
+{lsocket.pas}\r
+\r
+{signal code by plugwash}\r
+\r
+{ 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 lsignal;\r
+{$mode delphi}\r
+interface\r
+ uses sysutils,\r
+ {$ifdef VER1_0}\r
+ linux,\r
+ {$else}\r
+ baseunix,unix,unixutil,\r
+ {$endif}\r
+ classes,lcore,lloopback;\r
+\r
+ type\r
+ tsignalevent=procedure(sender:tobject;signal:integer) of object;\r
+ tlsignal=class(tcomponent)\r
+ public\r
+ onsignal : tsignalevent ;\r
+ prevsignal : tlsignal ;\r
+ nextsignal : tlsignal ;\r
+\r
+ constructor create(aowner:tcomponent);override;\r
+ destructor destroy;override;\r
+ end;\r
+\r
+ \r
+ procedure starthandlesignal(signal:integer);\r
+\r
+var\r
+ firstsignal : tlsignal;\r
+ blockset : sigset;\r
+ signalloopback : tlloopback ;\r
+
+implementation\r
+{$include unixstuff.inc}\r
+\r
+constructor tlsignal.create;\r
+begin\r
+ inherited create(AOwner);\r
+ nextsignal := firstsignal;\r
+ prevsignal := nil;\r
+\r
+ if assigned(nextsignal) then nextsignal.prevsignal := self;\r
+ firstsignal := self;\r
+\r
+ //interval := 1000;\r
+ //enabled := true;\r
+ //released := false;\r
+end;\r
+\r
+destructor tlsignal.destroy;\r
+begin\r
+ if prevsignal <> nil then begin\r
+ prevsignal.nextsignal := nextsignal;\r
+ end else begin\r
+ firstsignal := nextsignal;\r
+ end;\r
+ if nextsignal <> nil then begin\r
+ nextsignal.prevsignal := prevsignal;\r
+ end;\r
+ inherited destroy;\r
+end;\r
+{$ifdef linux}\r
+ {$ifdef ver1_9_8}\r
+ {$define needsignalworkaround}\r
+ {$endif}\r
+ {$ifdef ver2_0_0}\r
+ {$define needsignalworkaround}\r
+ {$endif}\r
+ {$ifdef ver2_0_2}\r
+ {$define needsignalworkaround}\r
+ {$endif}\r
+{$endif}\r
+{$ifdef needsignalworkaround}\r
+ //using the 1.9.6 version of this stuff because the 1.9.8 and 2.0.0 versions seem broken\r
+ type\r
+ TSysParam = Longint;\r
+ TSysResult = longint;\r
+ const\r
+ syscall_nr_sigaction = 67;\r
+ //function Do_SysCall(sysnr:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL0';\r
+ //function Do_SysCall(sysnr,param1:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL1';\r
+ //function Do_SysCall(sysnr,param1,param2:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL2';\r
+ function Do_SysCall(sysnr,param1,param2,param3:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL3';\r
+ //function Do_SysCall(sysnr,param1,param2,param3,param4:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL4';\r
+ //function Do_SysCall(sysnr,param1,param2,param3,param4,param5:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL5';\r
+\r
+ function Fpsigaction(sig: cint; act : psigactionrec; oact : psigactionrec): cint;// [public, alias : 'FPC_SYSC_SIGACTION'];\r
+ {\r
+ Change action of process upon receipt of a signal.\r
+ Signum specifies the signal (all except SigKill and SigStop).\r
+ If Act is non-nil, it is used to specify the new action.\r
+ If OldAct is non-nil the previous action is saved there.\r
+ }\r
+ begin\r
+ //writeln('fucking');\r
+ {$ifdef RTSIGACTION}\r
+ {$ifdef cpusparc}\r
+ { Sparc has an extra stub parameter }\r
+ Fpsigaction:=do_syscall(syscall_nr_rt_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact),TSysParam(PtrInt(@Fprt_sigreturn_stub)-8),TSysParam(8));\r
+ {$else cpusparc}\r
+ Fpsigaction:=do_syscall(syscall_nr_rt_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact),TSysParam(8));\r
+ {$endif cpusparc}\r
+ {$else RTSIGACTION}\r
+ //writeln('nice');\r
+ Fpsigaction:=do_syscall(syscall_nr_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact));\r
+ {$endif RTSIGACTION}\r
+ end;\r
+{$endif}\r
+\r
+// cdecl procedures are not name mangled\r
+// so USING something unlikely to cause colliesions in the global namespace\r
+// is a good idea\r
+procedure lsignal_handler( Sig : Integer);cdecl;\r
+var\r
+ currentsignal : tlsignal;\r
+begin\r
+// writeln('in lsignal_hanler');\r
+ currentsignal := firstsignal;\r
+ while assigned(currentsignal) do begin\r
+ if assigned(currentsignal.onsignal) then currentsignal.onsignal(currentsignal,sig);\r
+ currentsignal := currentsignal.nextsignal;\r
+\r
+ end;\r
+// writeln('about to send down signalloopback');\r
+ if assigned(signalloopback) then begin\r
+ signalloopback.sendstr(' ');\r
+ end;\r
+// writeln('left lsignal_hanler');\r
+end;\r
+\r
+{$ifdef freebsd}\r
+\r
+{$if (FPC_VERSION > 2) or ((FPC_VERSION = 2) and (FPC_RELEASE >= 2))}\r
+procedure lsignal_handler2(signal:longint;info:PSigInfo;context:psigcontext); cdecl;\r
+{$else}\r
+procedure lsignal_handler2(signal:longint;var info:TSigInfo_t;var context:SigContextRec); cdecl;\r
+{$endif}\r
+\r
+begin\r
+ lsignal_handler(signal);\r
+end;\r
+{$endif}\r
+\r
+\r
+const\r
+ allbitsset=-1;\r
+ {$ifdef ver1_0}\r
+ saction : sigactionrec = (handler:(sh:lsignal_handler);sa_flags:0);\r
+ {$else}\r
+ {$ifdef darwin}\r
+ saction : sigactionrec = (sa_handler:tsigaction(lsignal_handler);sa_flags:0);\r
+ {$else}\r
+ {$ifdef freebsd}\r
+ //version number is FPC_VERSION.FPC_RELEASE.FPC_PATCH\r
+ {$if (FPC_VERSION>2) or ((FPC_VERSION=2) and (FPC_RELEASE>0)) or ((FPC_VERSION=2) and (fpc_release=0) and (fpc_patch>=2))}\r
+ saction : sigactionrec = (sa_handler:lsignal_handler2;sa_flags:0);\r
+ {$else}\r
+ saction : sigactionrec = (sa_handler:tsigaction(lsignal_handler);sa_flags:0);\r
+ {$endif}\r
+ \r
+ {$else}\r
+ {$ifdef ver1_9_2}\r
+ saction : sigactionrec = (handler:(sh:lsignal_handler);sa_flags:0);\r
+ {$else}\r
+ //version number is FPC_VERSION.FPC_RELEASE.FPC_PATCH\r
+ {$if (FPC_VERSION>2) or ((FPC_VERSION=2) and (FPC_RELEASE>0)) or ((FPC_VERSION=2) and (fpc_release=0) and (fpc_patch>=2))}\r
+ saction : sigactionrec = (sa_handler:{$ifndef ver1_9_6}{$ifndef ver1_9_4}{$ifndef ver1_0}SigActionHandler{$endif}{$endif}{$endif}(lsignal_handler);sa_flags:0;sa_restorer:nil);\r
+ {$else}\r
+ saction : sigactionrec = (sa_handler:{$ifndef ver1_9_6}{$ifndef ver1_9_4}{$ifndef ver1_0}SigActionHandler{$endif}{$endif}{$endif}(lsignal_handler));\r
+ {$endif}\r
+ {$endif}\r
+ {$endif}\r
+ {$endif}\r
+ {$endif}\r
+procedure starthandlesignal(signal:integer);\r
+begin\r
+ if signal in ([0..31]-[sigkill,sigstop]) then begin\r
+ sigprocmask(SIG_BLOCK,@blockset,nil);\r
+ sigaction(signal,@saction,nil)\r
+ end else begin\r
+ raise exception.create('invalid signal number')\r
+ end;\r
+end;\r
+\r
+initialization\r
+ fillchar(blockset,sizeof(blockset),0);\r
+ blockset[0] := $FFFFFFFF - (1 shl sigstop) - (1 shl sigkill) - (1 shl sigsegv);\r
+ {$ifdef ver1_0}
+ saction.sa_mask := blockset[0];
+ {$else}
+ saction.sa_mask := blockset;\r
+ {$endif}\r
+end.\r
--- /dev/null
+{lsocket.pas}\r
+\r
+{socket code by plugwash}\r
+\r
+{ 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
+changes by plugwash (20030728)\r
+* created handlefdtrigger virtual method in tlasio (overridden in tlsocket) and moved a lot of code from messageloop into it\r
+* changed tlasio to tlasio\r
+* split fdhandle into fdhandlein and fdhandleout\r
+* i now use fdsrmaster and fdswmaster instead of rebuilding the lists every loop\r
+* split lsocket.pas into lsocket.pas and lcore.pas\r
+\r
+\r
+changes by beware (20030903)\r
+* added getxaddr, getxport (local addr, port, as string)\r
+* added getpeername, remote addr+port as binary\r
+* added htons and htonl functions (endian swap, same interface as windows API)\r
+\r
+beware (20030905)\r
+* if connect failed (conn refused) set state to connected and call internalclose, to get closed handler (instead of fdclose)\r
+* (lcore) if closing the fd's in internalcose, set fd's to -1 because closing an fd makes it invalid\r
+\r
+beware (20030927)\r
+* fixed: on connect failed, tried to close fdhandle's which were already set to -1, added check\r
+\r
+beware (20031017)\r
+* added getpeeraddr, getpeerport, remote addr+port as string\r
+}\r
+\r
+\r
+unit lsocket;\r
+{$ifdef fpc}\r
+ {$mode delphi}\r
+{$endif}\r
+interface\r
+ uses\r
+ sysutils,\r
+ {$ifdef win32}\r
+ windows,winsock,\r
+ {$else}\r
+\r
+ {$ifdef VER1_0}\r
+ linux,\r
+ {$else}\r
+ baseunix,unix,unixutil,\r
+ {$endif}\r
+ sockets,\r
+ {$endif}\r
+ classes,{pgdebugout,}pgtypes,lcore,fd_utils,binipstuff,dnssync;\r
+type\r
+ sunB = packed record\r
+ s_b1, s_b2, s_b3, s_b4: byte;\r
+ end;\r
+\r
+ SunW = packed record\r
+ s_w1, s_w2: word;\r
+ end;\r
+\r
+ TInAddr = packed record\r
+ case integer of\r
+ 0: (S_un_b: SunB);\r
+ 1: (S_un_w: SunW);\r
+ 2: (S_addr: cardinal);\r
+ end;\r
+ {$ifdef ipv6}\r
+ {$ifdef ver1_0}\r
+ cuint16=word;\r
+ cuint32=dword;\r
+ sa_family_t=word;\r
+\r
+\r
+ TInetSockAddr6 = packed Record\r
+ sin6_family : sa_family_t;\r
+ sin6_port : cuint16;\r
+ sin6_flowinfo : cuint32;\r
+ sin6_addr : Tin6_addr;\r
+ sin6_scope_id : cuint32;\r
+ end;\r
+ {$endif}\r
+ {$endif}\r
+ TinetSockAddrv = packed record\r
+ case integer of\r
+ 0: (InAddr:TInetSockAddr);\r
+ {$ifdef ipv6}\r
+ 1: (InAddr6:TInetSockAddr6);\r
+ {$endif}\r
+ end;\r
+ Pinetsockaddrv = ^Tinetsockaddrv;\r
+\r
+\r
+ type\r
+ tsockaddrin=TInetSockAddr;\r
+\r
+ type\r
+ TLsocket = class(tlasio)\r
+ public\r
+ //a: string;\r
+\r
+ inAddr : TInetSockAddrV;\r
+{ inAddrSize:integer;}\r
+\r
+ //host : THostentry ;\r
+\r
+ //mainthread : boolean ; //for debuggin only\r
+ addr:string;\r
+ port:string;\r
+ localaddr:string;\r
+ localport:string;\r
+ proto:string;\r
+ udp:boolean;\r
+ listenqueue:integer;\r
+ function getaddrsize:integer;\r
+ procedure connect; virtual;\r
+ procedure bindsocket;\r
+ procedure listen;\r
+ function accept : longint;\r
+ function sendto(dest:TInetSockAddr;destlen:integer;data:pointer;len:integer):integer; virtual;\r
+ function receivefrom(data:pointer;len:integer;var src:TInetSockAddr;var srclen:integer):integer; virtual;\r
+ //procedure internalclose(error:word);override;\r
+ procedure handlefdtrigger(readtrigger,writetrigger:boolean); override;\r
+ function send(data:pointer;len:integer):integer;override;\r
+ procedure sendstr(const str : string);override;\r
+ function Receive(Buf:Pointer;BufSize:integer):integer; override;\r
+ function getpeername(var addr:tsockaddrin;addrlen:integer):integer; virtual;\r
+ procedure getXaddrbin(var binip:tbinip); virtual;\r
+ procedure getpeeraddrbin(var binip:tbinip); virtual;\r
+ function getXaddr:string; virtual;\r
+ function getpeeraddr:string; virtual;\r
+ function getXport:string; virtual;\r
+ function getpeerport:string; virtual;\r
+ constructor Create(AOwner: TComponent); override;\r
+ {$ifdef win32}\r
+ procedure myfdclose(fd : integer); override;\r
+ function myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt; override;\r
+ function myfdread(fd: LongInt;var buf;size: LongInt):LongInt; override;\r
+ {$endif}\r
+ end;\r
+ tsocket=longint; // for compatibility with twsocket\r
+\r
+ twsocket=tlsocket; {easy}\r
+\r
+function htons(w:word):word;\r
+function htonl(i:integer):integer;\r
+{!!!function longipdns(s:string):longint;}\r
+\r
+{$ifdef ipv6}\r
+const\r
+ v4listendefault:boolean=false;\r
+{$endif}\r
+\r
+\r
+const\r
+ TCP_NODELAY=1;\r
+ IPPROTO_TCP=6;\r
+\r
+implementation\r
+{$include unixstuff.inc}\r
+\r
+function longip(s:string):longint;{$ifdef fpc}inline;{$endif}\r
+var\r
+ l:longint;\r
+ a,b:integer;\r
+\r
+function convertbyte(const s:string):integer;{$ifdef fpc}inline;{$endif}\r
+begin\r
+ result := strtointdef(s,-1);\r
+ if result < 0 then exit;\r
+ if result > 255 then exit;\r
+\r
+ {01 exception}\r
+ if (result <> 0) and (s[1] = '0') then begin\r
+ result := -1;\r
+ exit;\r
+ end;\r
+\r
+ {+1 exception}\r
+ if not (s[1] in ['0'..'9']) then begin\r
+ result := -1;\r
+ exit\r
+ end;\r
+end;\r
+\r
+begin\r
+ result := 0;\r
+ a := pos('.',s);\r
+ if a = 0 then exit;\r
+ b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+ l := b shl 24;\r
+ s := copy(s,a+1,256);\r
+ a := pos('.',s);\r
+ if a = 0 then exit;\r
+ b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+ l := l or b shl 16;\r
+ s := copy(s,a+1,256);\r
+ a := pos('.',s);\r
+ if a = 0 then exit;\r
+ b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+ l := l or b shl 8;\r
+ s := copy(s,a+1,256);\r
+ b := convertbyte(copy(s,1,256));if (b < 0) then exit;\r
+ l := l or b;\r
+ result := l;\r
+end;\r
+\r
+(*!!!\r
+function longipdns(s:string):longint;\r
+var\r
+ host : thostentry;\r
+begin\r
+ if s = '0.0.0.0' then begin\r
+ result := 0;\r
+ end else begin\r
+ result := longip(s);\r
+ if result = 0 then begin\r
+ if gethostbyname(s,host) then begin;\r
+ result := htonl(Longint(Host.Addr));\r
+ end;\r
+ //writeln(inttohex(longint(host.addr),8))\r
+ end;\r
+ if result = 0 then begin\r
+ if resolvehostbyname(s,host) then begin;\r
+ result := htonl(Longint(Host.Addr));\r
+ end;\r
+ //writeln(inttohex(longint(host.addr),8))\r
+ end;\r
+ end;\r
+end;\r
+*)\r
+\r
+\r
+function htons(w:word):word;\r
+begin\r
+ {$ifndef ENDIAN_BIG}\r
+ result := ((w and $ff00) shr 8) or ((w and $ff) shl 8);\r
+ {$else}\r
+ result := w;\r
+ {$endif}\r
+end;\r
+\r
+function htonl(i:integer):integer;\r
+begin\r
+ {$ifndef ENDIAN_BIG}\r
+ result := (i shr 24) or (i shr 8 and $ff00) or (i shl 8 and $ff0000) or (i shl 24 and $ff000000);\r
+ {$else}\r
+ result := i;\r
+ {$endif}\r
+end;\r
+\r
+function tlsocket.getaddrsize:integer;\r
+begin\r
+ {$ifdef ipv6}\r
+ if inaddr.inaddr.family = AF_INET6 then result := sizeof(tinetsockaddr6) else\r
+ {$endif}\r
+ result := sizeof(tinetsockaddr);\r
+end;\r
+\r
+function makeinaddrv(addr,port:string;var inaddr:tinetsockaddrv):integer;\r
+var\r
+ biniptemp:tbinip;\r
+begin\r
+ result := 0;\r
+ biniptemp := forwardlookup(addr,10);\r
+ fillchar(inaddr,sizeof(inaddr),0);\r
+ //writeln('converted address '+addr+' to binip '+ipbintostr(biniptemp));\r
+ if biniptemp.family = AF_INET then begin\r
+ inAddr.InAddr.family:=AF_INET;\r
+ inAddr.InAddr.port:=htons(strtointdef(port,0));\r
+ inAddr.InAddr.addr:=biniptemp.ip;\r
+ result := sizeof(tinetsockaddr);\r
+ end else\r
+ {$ifdef ipv6}\r
+ if biniptemp.family = AF_INET6 then begin\r
+ inAddr.InAddr6.sin6_family:=AF_INET6;\r
+ inAddr.InAddr6.sin6_port:=htons(strtointdef(port,0));\r
+ inAddr.InAddr6.sin6_addr:=biniptemp.ip6;\r
+ result := sizeof(tinetsockaddr6);\r
+ end else\r
+ {$endif}\r
+ raise esocketexception.create('unable to resolve address: '+addr);\r
+end;\r
+\r
+procedure tlsocket.connect;\r
+var\r
+ a:integer;\r
+begin\r
+ if state <> wsclosed then close;\r
+ //prevtime := 0;\r
+ makeinaddrv(addr,port,inaddr);\r
+\r
+ udp := uppercase(proto) = 'UDP';\r
+ if udp then a := SOCK_DGRAM else a := SOCK_STREAM;\r
+ a := Socket(inaddr.inaddr.family,a,0);\r
+\r
+ //writeln(ord(inaddr.inaddr.family));\r
+ if a = -1 then begin\r
+ lasterror := {$ifdef win32}getlasterror{$else}socketerror{$endif};\r
+ raise esocketexception.create('unable to create socket');\r
+ end;\r
+ try\r
+ dup(a);\r
+ bindsocket;\r
+ if udp then begin\r
+ {$ifndef win32}\r
+ SetSocketOptions(fdhandleout, SOL_SOCKET, SO_BROADCAST, 'TRUE', Length('TRUE'));\r
+ {$endif}\r
+ state := wsconnected;\r
+ if assigned(onsessionconnected) then onsessionconnected(self,0);\r
+ end else begin\r
+ state :=wsconnecting;\r
+ {$ifdef win32}\r
+ //writeln(inaddr.inaddr.port);\r
+ winsock.Connect(fdhandlein,winsock.psockaddr(@inADDR)^,getaddrsize);\r
+ {$else}\r
+ sockets.Connect(fdhandlein,inADDR,getaddrsize);\r
+ {$endif}\r
+ end;\r
+ eventcore.rmasterset(fdhandlein,false);\r
+ if udp then begin\r
+ eventcore.wmasterclr(fdhandleout);\r
+ end else begin\r
+ eventcore.wmasterset(fdhandleout);\r
+ end;\r
+ //sendq := '';\r
+ except\r
+ on e: exception do begin\r
+ fdcleanup;\r
+ raise; //reraise the exception\r
+ end;\r
+ end;\r
+end;\r
+\r
+procedure tlsocket.sendstr(const str : string);\r
+begin\r
+ if udp then begin\r
+ send(@str[1],length(str))\r
+ end else begin\r
+ inherited sendstr(str);\r
+ end;\r
+end;\r
+\r
+function tlsocket.send(data:pointer;len:integer):integer;\r
+begin\r
+ if udp then begin\r
+ //writeln('sending to '+inttohex(inaddr.inaddr.addr,8));\r
+ result := sendto(inaddr.inaddr,getaddrsize,data,len)\r
+;\r
+ //writeln('send result',result);\r
+ //writeln('errno',errno);\r
+ end else begin\r
+ result := inherited send(data,len);\r
+ end;\r
+end;\r
+\r
+\r
+function tlsocket.receive(Buf:Pointer;BufSize:integer):integer;\r
+begin\r
+ if udp then begin\r
+ result := myfdread(self.fdhandlein,buf^,bufsize);\r
+ end else begin\r
+ result := inherited receive(buf,bufsize);\r
+ end;\r
+end;\r
+\r
+procedure tlsocket.bindsocket;\r
+var\r
+ a:integer;\r
+ inAddrtemp:TInetSockAddrV;\r
+ inAddrtempx:{$ifdef win32}winsock.TSockaddr{$else}TInetSockAddrV{$endif} absolute inaddrtemp;\r
+ inaddrtempsize:integer;\r
+begin\r
+ try\r
+ if (localaddr <> '') or (localport <> '') then begin\r
+ if localaddr = '' then begin\r
+ {$ifdef ipv6}\r
+ if inaddr.inaddr.family = AF_INET6 then localaddr := '::' else\r
+ {$endif}\r
+ localaddr := '0.0.0.0';\r
+ end;\r
+ //gethostbyname(localaddr,host);\r
+\r
+ inaddrtempsize := makeinaddrv(localaddr,localport,inaddrtemp);\r
+\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
+ end;\r
+ state := wsbound;\r
+ end;\r
+ except\r
+ on e: exception do begin\r
+ fdcleanup;\r
+ raise; //reraise the exception\r
+ end;\r
+ end;\r
+end;\r
+\r
+procedure tlsocket.listen;\r
+var\r
+ yes:longint;\r
+ socktype:integer;\r
+ biniptemp:tbinip;\r
+ origaddr:string;\r
+begin\r
+ if state <> wsclosed then close;\r
+ udp := uppercase(proto) = 'UDP';\r
+ if udp then socktype := SOCK_DGRAM else socktype := SOCK_STREAM;\r
+ origaddr := addr;\r
+\r
+ if addr = '' then begin\r
+ {$ifdef ipv6}\r
+ if not v4listendefault then begin\r
+ addr := '::';\r
+ end else\r
+ {$endif}\r
+ addr := '0.0.0.0';\r
+ end;\r
+ biniptemp := forwardlookup(addr,10);\r
+ addr := ipbintostr(biniptemp);\r
+ fdhandlein := socket(biniptemp.family,socktype,0);\r
+ {$ifdef ipv6}\r
+ if (addr = '::') and (origaddr = '') and (fdhandlein < 0) then begin\r
+ addr := '0.0.0.0';\r
+ fdhandlein := socket(AF_INET,socktype,0);\r
+ end;\r
+ {$endif}\r
+ if fdhandlein = -1 then raise ESocketException.create('unable to create socket');\r
+ dupnowatch(fdhandlein); // sets up maxs and copies handle to fdhandleout among other things\r
+ //eventcore.setfdreverse(fdhandlein,self); //already taken care of by dup\r
+ state := wsclosed; // then set this back as it was an undesired side effect of dup\r
+\r
+ try\r
+ yes := $01010101; {Copied this from existing code. Value is empiric,\r
+ but works. (yes=true<>0) }\r
+ {$ifndef win32}\r
+ if SetSocketOptions(fdhandlein, SOL_SOCKET, SO_REUSEADDR,yes,sizeof(yes))=-1 then begin\r
+ raise ESocketException.create('unable to set socket options');\r
+ end;\r
+ {$endif}\r
+ localaddr := addr;\r
+ localport := port;\r
+ bindsocket;\r
+\r
+ if not udp then begin\r
+ {!!! allow custom queue length? default 5}\r
+ if listenqueue = 0 then listenqueue := 5;\r
+ If {$ifdef win32}winsock{$else}sockets{$endif}.Listen(fdhandlein,listenqueue)<>{$ifdef win32}0{$else}true{$endif} Then raise esocketexception.create('unable to listen');\r
+ state := wsListening;\r
+ end else begin\r
+ {$ifndef win32}\r
+ SetSocketOptions(fdhandleout, SOL_SOCKET, SO_BROADCAST, 'TRUE', Length('TRUE'));\r
+ {$endif}\r
+ state := wsconnected;\r
+ end;\r
+ finally\r
+ if state = wsclosed then begin\r
+ if fdhandlein >= 0 then begin\r
+ {one *can* get here without fd -beware}\r
+ eventcore.rmasterclr(fdhandlein);\r
+ myfdclose(fdhandlein); // we musnt leak file discriptors\r
+ eventcore.setfdreverse(fdhandlein,nil);\r
+ fdhandlein := -1;\r
+ end;\r
+ end else begin\r
+ eventcore.rmasterset(fdhandlein,true);\r
+ end;\r
+ if fdhandleout >= 0 then eventcore.wmasterclr(fdhandleout);\r
+ end;\r
+ //writeln('listened on addr '+addr+':'+port+' '+proto+' using socket number ',fdhandlein); \r
+end;\r
+\r
+function tlsocket.accept : longint;\r
+var\r
+ FromAddrSize : LongInt; // i don't realy know what to do with these at this\r
+ FromAddr : TInetSockAddrV; // at this point time will tell :)\r
+begin\r
+\r
+ FromAddrSize := Sizeof(FromAddr);\r
+ {$ifdef win32}\r
+ result := winsock.accept(fdhandlein,@fromaddr,@fromaddrsize);\r
+ {$else}\r
+ result := sockets.accept(fdhandlein,fromaddr,fromaddrsize);\r
+ {$endif}\r
+ //now we have accepted one request start monitoring for more again\r
+ eventcore.rmasterset(fdhandlein,true);\r
+\r
+ if result = -1 then raise esocketexception.create('error '+inttostr({$ifdef win32}getlasterror{$else}socketerror{$endif})+' while accepting');\r
+ if result > absoloutemaxs then begin\r
+ myfdclose(result);\r
+ result := -1;\r
+ raise esocketexception.create('file discriptor out of range');\r
+ end;\r
+end;\r
+\r
+function tlsocket.sendto(dest:TInetSockAddr;destlen:integer;data:pointer;len:integer):integer;\r
+var\r
+ destx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddr{$endif} absolute dest;\r
+begin\r
+ result := {$ifdef win32}winsock{$else}sockets{$endif}.sendto(self.fdhandleout,data^,len,0,destx,destlen);\r
+end;\r
+\r
+function tlsocket.receivefrom(data:pointer;len:integer;var src:TInetSockAddr;var srclen:integer):integer;\r
+var\r
+ srcx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddr{$endif} absolute src;\r
+begin\r
+ result := {$ifdef win32}winsock{$else}sockets{$endif}.recvfrom(self.fdhandlein,data^,len,0,srcx,srclen);\r
+end;\r
+\r
+procedure tlsocket.handlefdtrigger(readtrigger,writetrigger:boolean);\r
+var\r
+ tempbuf:array[0..receivebufsize-1] of byte;\r
+begin\r
+ //writeln('got a fd trigger, readtrigger=',readtrigger,' writetrigger=',writetrigger);\r
+ if (state =wslistening) and readtrigger then begin\r
+{ debugout('listening socket triggered on read');}\r
+ eventcore.rmasterclr(fdhandlein);\r
+ if assigned(onsessionAvailable) then onsessionAvailable(self,0);\r
+ end;\r
+ if udp and readtrigger then begin\r
+ if assigned(ondataAvailable) then ondataAvailable(self,0);\r
+ {!!!test}\r
+ exit;\r
+ end;\r
+ if (state =wsconnecting) and writetrigger then begin\r
+ // code for dealing with the reults of a non-blocking connect is\r
+ // rather complex\r
+ // if just write is triggered it means connect suceeded\r
+ // if both read and write are triggered it can mean 2 things\r
+ // 1: connect ok and data availible\r
+ // 2: connect fail\r
+ // to find out which you must read from the socket and look for errors\r
+ // there if we read successfully we drop through into the code for fireing\r
+ // the read event\r
+ if not readtrigger then begin\r
+ state := wsconnected;\r
+ if assigned(onsessionconnected) then onsessionconnected(self,0);\r
+ end else begin\r
+ numread := myfdread(fdhandlein,tempbuf,sizeof(tempbuf));\r
+ if numread <> -1 then begin\r
+ state := wsconnected;\r
+ if assigned(onsessionconnected) then onsessionconnected(self,0);\r
+ //connectread := true;\r
+ recvq.add(@tempbuf,numread);\r
+ end else begin\r
+ state := wsconnected;\r
+ if assigned(onsessionconnected) then onsessionconnected(self,{$ifdef win32}wsagetlasterror{$else}linuxerror{$endif});\r
+{ debugout('connect fail');}\r
+ self.internalclose(0);\r
+ recvq.del(maxlongint);\r
+ end;\r
+ // if things went well here we are now in the state wsconnected with data sitting in our receive buffer\r
+ // so we drop down into the processing for data availible\r
+ end;\r
+ if fdhandlein >= 0 then begin\r
+ if state = wsconnected then begin\r
+ eventcore.rmasterset(fdhandlein,false);\r
+ end else begin\r
+ eventcore.rmasterclr(fdhandlein);\r
+ end;\r
+ end;\r
+ if fdhandleout >= 0 then begin\r
+ if sendq.size = 0 then begin\r
+ //don't clear the bit in fdswmaster if data is in the sendq\r
+ eventcore.wmasterclr(fdhandleout);\r
+ end;\r
+ end;\r
+\r
+ end;\r
+ inherited handlefdtrigger(readtrigger,writetrigger);\r
+end;\r
+\r
+constructor tlsocket.Create(AOwner: TComponent);\r
+begin\r
+ inherited create(aowner);\r
+ closehandles := true;\r
+end;\r
+\r
+\r
+function tlsocket.getpeername(var addr:tsockaddrin;addrlen:integer):integer;\r
+var\r
+ addrx : {$ifdef win32}winsock.tsockaddr{$else}tsockaddrin{$endif} absolute addr;\r
+begin\r
+ result := {$ifdef win32}winsock{$else}sockets{$endif}.getpeername(self.fdhandlein,addrx,addrlen);\r
+end;\r
+\r
+procedure tlsocket.getxaddrbin(var binip:tbinip);\r
+var\r
+ addr:tinetsockaddrv;\r
+ i:integer;\r
+begin\r
+ i := sizeof(addr);\r
+ fillchar(addr,sizeof(addr),0);\r
+\r
+ {$ifdef win32}\r
+ winsock.getsockname(self.fdhandlein,psockaddr(@addr)^,i);\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
+ converttov4(binip);\r
+end;\r
+\r
+procedure tlsocket.getpeeraddrbin(var binip:tbinip);\r
+var\r
+ addr:tinetsockaddrv;\r
+ i:integer;\r
+begin\r
+ i := sizeof(addr);\r
+ fillchar(addr,sizeof(addr),0);\r
+ {$ifdef win32}\r
+ winsock.getpeername(self.fdhandlein,psockaddr(@addr)^,i);\r
+ {$else}\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
+ converttov4(binip);\r
+end;\r
+\r
+function tlsocket.getXaddr:string;\r
+var\r
+ biniptemp:tbinip;\r
+begin\r
+ getxaddrbin(biniptemp);\r
+ result := ipbintostr(biniptemp);\r
+ if result = '' then result := 'error';\r
+end;\r
+\r
+function tlsocket.getpeeraddr:string;\r
+var\r
+ biniptemp:tbinip;\r
+begin\r
+ getpeeraddrbin(biniptemp);\r
+ result := ipbintostr(biniptemp);\r
+ if result = '' then result := 'error';\r
+end;\r
+\r
+function tlsocket.getXport:string;\r
+var\r
+ addr:tinetsockaddrv;\r
+ i:integer;\r
+begin\r
+ i := sizeof(addr);\r
+ {$ifdef win32}\r
+ winsock.getsockname(self.fdhandlein,psockaddrin(@addr)^,i);\r
+\r
+ {$else}\r
+ sockets.getsocketname(self.fdhandlein,addr,i);\r
+\r
+ {$endif}\r
+ result := inttostr(htons(addr.InAddr.port));\r
+end;\r
+\r
+function tlsocket.getpeerport:string;\r
+var\r
+ addr:tinetsockaddrv;\r
+ i:integer;\r
+begin\r
+ i := sizeof(addr);\r
+ {$ifdef win32}\r
+ winsock.getpeername(self.fdhandlein,psockaddrin(@addr)^,i);\r
+\r
+ {$else}\r
+ sockets.getpeername(self.fdhandlein,addr,i);\r
+\r
+ {$endif}\r
+ result := inttostr(htons(addr.InAddr.port));\r
+end;\r
+\r
+{$ifdef win32}\r
+ procedure tlsocket.myfdclose(fd : integer);\r
+ begin\r
+ closesocket(fd);\r
+ end;\r
+ function tlsocket.myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt;\r
+ begin\r
+ result := winsock.send(fd,(@buf)^,size,0);\r
+ end;\r
+ function tlsocket.myfdread(fd: LongInt;var buf;size: LongInt):LongInt;\r
+ begin\r
+ result := winsock.recv(fd,buf,size,0);\r
+ end;\r
+{$endif}\r
+
+end.\r
+\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
+\r
+\r
+{add nn msec to tv}\r
+const\r
+ tv_invalidtimebig : ttimeval = (tv_sec:maxlongint;tv_usec:maxlongint);\r
+ //tv_invalidtimebig will always compare as greater than any valid timeval\r
+procedure tv_add(var tv:ttimeval;msec:integer);//{ $ifdef fpc}inline;{ $endif}\r
+begin\r
+ inc(tv.tv_usec,msec*1000);\r
+ inc(tv.tv_sec,tv.tv_usec div 1000000);\r
+ tv.tv_usec := tv.tv_usec mod 1000000;\r
+end;\r
+\r
+{tv1 >= tv2}\r
+function tv_compare(const tv1,tv2:ttimeval):boolean;//{ $ifdef fpc}inline;{ $endif}\r
+begin\r
+ if tv1.tv_sec = tv2.tv_sec then begin\r
+ result := tv1.tv_usec >= tv2.tv_usec;\r
+ end else result := tv1.tv_sec > tv2.tv_sec;\r
+end;\r
+\r
+procedure tv_substract(var tv:ttimeval;const tv2:ttimeval);//{ $ifdef fpc}inline;{ $endif}\r
+begin\r
+ dec(tv.tv_usec,tv2.tv_usec);\r
+ if tv.tv_usec < 0 then begin\r
+ inc(tv.tv_usec,1000000);\r
+ dec(tv.tv_sec)\r
+ end;\r
+ dec(tv.tv_sec,tv2.tv_sec);\r
+end;\r
+\r
+procedure msectotimeval(var tv:ttimeval;msec:integer);\r
+begin\r
+ tv.tv_sec := msec div 1000;\r
+ tv.tv_usec := (msec mod 1000)*1000;\r
+end;\r
+\r
--- /dev/null
+{io core originally for linux bworld}\r
+\r
+{ 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 pgtypes;\r
+interface\r
+ type\r
+ {$ifdef cpu386}{$define i386}{$endif}\r
+ {$ifdef i386}\r
+ taddrint=longint;\r
+ {$else}\r
+ taddrint=sizeint;\r
+ {$endif}\r
+ paddrint=^taddrint;\r
+\r
+implementation\r
+end.\r
--- /dev/null
+initial import
+--This line, and those below, will be ignored--
+
+A .
--- /dev/null
+initial import
+--This line, and those below, will be ignored--
+
+A .
--- /dev/null
+create directory
+--This line, and those below, will be ignored--
+
+A svn+ssh://p10link/svnroot/lcore/trunk
--- /dev/null
+initial import
+--This line, and those below, will be ignored--
+
+A .
--- /dev/null
+initial import
+--This line, and those below, will be ignored--
+
+A .
--- /dev/null
+{ Copyright (C) 2005 Bas Steendijk and Peter Green
+ For conditions of distribution and use, see copyright notice in zlib_license.txt
+ which is included in the package
+ ----------------------------------------------------------------------------- }\r
+type\r
+ {delphi 3 and before do not have a 32 bits unsigned integer type,\r
+ but longint has the correct behavior - it doesn't on newer delphi versions}\r
+ {$ifndef fpc}\r
+ {$ifdef ver70}{$define pred4}{$endif} {tp7}\r
+ {$ifdef ver80}{$define pred4}{$endif} {delphi 1}\r
+ {$ifdef ver90}{$define pred4}{$endif} {delphi 2}\r
+ {$ifdef ver100}{$define pred4}{$endif} {delphi 3}\r
+ {$endif}\r
+ uint32={$ifdef pred4}longint{$else}longword{$endif};\r
--- /dev/null
+{$ifdef UNIX}\r
+ {$macro on}\r
+ {$ifdef VER1_0}\r
+ {$define tv_sec := sec}\r
+ {$define tv_usec := usec}\r
+ function dup(const original:integer):integer;inline;\r
+ begin\r
+ linux.dup(original,result);\r
+ end;\r
+ {$define gettimeofdaysec := gettimeofday}\r
+ {$else}\r
+ \r
+ {$define sigprocmask := fpsigprocmask}\r
+ {$define sigaction := fpsigaction}\r
+ {$define fdclose := fpclose}\r
+ {$define fcntl := fpfcntl}\r
+ {$define fdwrite := fpwrite}\r
+ {$define fdread := fpread}\r
+ {$define fdopen := fpopen}\r
+ {$define select := fpselect}\r
+ {$define linuxerror := fpgeterrno}\r
+ {$define fork := fpfork}\r
+ {$define getpid := fpgetpid}\r
+ {$define getenv := fpgetenv}\r
+ {$define chmod := fpchmod}\r
+ {$define dup2 := fpdup2}\r
+ {$ifndef ver1_9_2}\r
+ {$define flock := fpflock}\r
+ {$ifndef ver1_9_4}
+ procedure Execl(Todo:string);inline;
+ var
+ p : ppchar;
+ begin
+ p := unixutil.StringToPPChar(Todo,1);
+ if (p=nil) or (p^=nil) then exit;
+ fpexecv(p^,p);
+ end;
+ {$endif}
+ {$endif}\r
+ procedure gettimeofday(var tv:ttimeval);inline;\r
+ begin\r
+ fpgettimeofday(@tv,nil); \r
+ end;\r
+ function gettimeofdaysec : longint;\r
+ var\r
+ tv:ttimeval;\r
+ begin\r
+ gettimeofday(tv);\r
+ result := tv.tv_sec;\r
+ end;\r
+\r
+ //a function is used here rather than a define to prevent issues with tlasio.dup\r
+ function dup(const original:integer):integer;inline;\r
+ begin\r
+ result := fpdup(original);\r
+ end;\r
+ function octal(invalue:longint):longint;\r
+ var\r
+ a : integer;\r
+ i : integer;\r
+ begin\r
+ i := 0;\r
+ result := 0;\r
+ while invalue <> 0 do begin\r
+ a := invalue mod 10;\r
+ result := result + (a shl (i*3));\r
+\r
+ invalue := invalue div 10;\r
+ inc(i);\r
+ end;\r
+ end;\r
+ const\r
+ sys_eintr=esyseintr;\r
+\r
+ {$endif}\r
+{$endif}\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 wcore;\r
+\r
+{\r
+lcore compatible interface for windows\r
+\r
+- messageloop\r
+\r
+- tltimer\r
+\r
+}\r
+//note: events after release are normal and are the apps responsibility to deal with safely\r
+interface\r
+\r
+ uses\r
+ classes,windows,mmsystem;\r
+\r
+ type\r
+ float=double;\r
+\r
+ tlcomponent = class(tcomponent)\r
+ public\r
+ released:boolean;\r
+ procedure release;\r
+ destructor destroy; override;\r
+ end;\r
+\r
+ tltimer=class(tlcomponent)\r
+ public\r
+ ontimer:tnotifyevent;\r
+ initialevent:boolean;\r
+ initialdone:boolean;\r
+ prevtimer:tltimer;\r
+ nexttimer:tltimer;\r
+ interval:integer; {miliseconds, default 1000}\r
+ enabled:boolean;\r
+ nextts:integer;\r
+ constructor create(aowner:tcomponent);override;\r
+ destructor destroy;override;\r
+ end;\r
+\r
+ ttaskevent=procedure(wparam,lparam:longint) of object;\r
+\r
+ tltask=class(tobject)\r
+ public\r
+ handler : ttaskevent;\r
+ obj : tobject;\r
+ wparam : longint;\r
+ lparam : longint;\r
+ nexttask : tltask;\r
+ constructor create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+ end;\r
+\r
+procedure messageloop;\r
+procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+procedure disconnecttasks(aobj:tobject);\r
+procedure exitmessageloop;\r
+procedure processmessages;\r
+\r
+var\r
+ onshutdown:procedure(s:string);\r
+\r
+implementation\r
+\r
+uses\r
+ {$ifdef fpc}\r
+ bmessages;\r
+ {$else}\r
+ messages;\r
+ {$endif}\r
+\r
+\r
+const\r
+ WINMSG_TASK=WM_USER;\r
+\r
+var\r
+ hwndwcore:hwnd;\r
+ firsttimer:tltimer;\r
+ timesubstract:integer;\r
+ firsttask,lasttask,currenttask:tltask;\r
+\r
+procedure tlcomponent.release;\r
+begin\r
+ released := true;\r
+end;\r
+\r
+destructor tlcomponent.destroy;\r
+begin\r
+ disconnecttasks(self);\r
+ inherited destroy;\r
+end;\r
+\r
+{------------------------------------------------------------------------------}\r
+\r
+constructor tltimer.create;\r
+begin\r
+ inherited create(AOwner);\r
+ nexttimer := firsttimer;\r
+ prevtimer := nil;\r
+\r
+ if assigned(nexttimer) then nexttimer.prevtimer := self;\r
+ firsttimer := self;\r
+\r
+ interval := 1000;\r
+ enabled := true;\r
+ released := false;\r
+end;\r
+\r
+destructor tltimer.destroy;\r
+begin\r
+ if prevtimer <> nil then begin\r
+ prevtimer.nexttimer := nexttimer;\r
+ end else begin\r
+ firsttimer := nexttimer;\r
+ end;\r
+ if nexttimer <> nil then begin\r
+ nexttimer.prevtimer := prevtimer;\r
+ end;\r
+ inherited destroy;\r
+end;\r
+\r
+{------------------------------------------------------------------------------}\r
+\r
+function wcore_timehandler:integer;\r
+const\r
+ rollover_bits=30;\r
+var\r
+ tv,tvnow:integer;\r
+ currenttimer,temptimer:tltimer;\r
+begin\r
+ if not assigned(firsttimer) then begin\r
+ result := 1000;\r
+ exit;\r
+ end;\r
+\r
+ tvnow := timegettime;\r
+ if (tvnow and ((-1) shl rollover_bits)) <> timesubstract then begin\r
+ currenttimer := firsttimer;\r
+ while assigned(currenttimer) do begin\r
+ dec(currenttimer.nextts,(1 shl rollover_bits));\r
+ currenttimer := currenttimer.nexttimer;\r
+ end;\r
+ timesubstract := tvnow and ((-1) shl rollover_bits);\r
+ end;\r
+ tvnow := tvnow and ((1 shl rollover_bits)-1);\r
+\r
+ currenttimer := firsttimer;\r
+ while assigned(currenttimer) do begin\r
+ if tvnow >= currenttimer.nextts then begin\r
+ if assigned(currenttimer.ontimer) then begin\r
+ if currenttimer.enabled then begin\r
+ if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer);\r
+ currenttimer.initialdone := true;\r
+ end;\r
+ end;\r
+ currenttimer.nextts := tvnow+currenttimer.interval;\r
+ end;\r
+ temptimer := currenttimer;\r
+ currenttimer := currenttimer.nexttimer;\r
+ if temptimer.released then temptimer.free;\r
+ end;\r
+\r
+ tv := maxlongint;\r
+ currenttimer := firsttimer;\r
+ while assigned(currenttimer) do begin\r
+ if currenttimer.nextts < tv then tv := currenttimer.nextts;\r
+ currenttimer := currenttimer.nexttimer;\r
+ end;\r
+ result := tv-tvnow;\r
+ if result < 15 then result := 15;\r
+end;\r
+\r
+{------------------------------------------------------------------------------}\r
+\r
+constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+ inherited create;\r
+ handler := ahandler;\r
+ obj := aobj;\r
+ wparam := awparam;\r
+ lparam := alparam;\r
+ {nexttask := firsttask;\r
+ firsttask := self;}\r
+ if assigned(lasttask) then begin\r
+ lasttask.nexttask := self;\r
+ end else begin\r
+ firsttask := self;\r
+ postmessage(hwndwcore,WINMSG_TASK,0,0);\r
+ end;\r
+ lasttask := self;\r
+ //ahandler(wparam,lparam);\r
+end;\r
+\r
+procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+ tltask.create(ahandler,aobj,awparam,alparam);\r
+end;\r
+\r
+procedure disconnecttasks(aobj:tobject);\r
+var\r
+ currenttasklocal : tltask ;\r
+ counter : byte ;\r
+begin\r
+ for counter := 0 to 1 do begin\r
+ if counter = 0 then begin\r
+ currenttasklocal := firsttask; //main list of tasks\r
+ end else begin\r
+ currenttasklocal := currenttask; //needed in case called from a task\r
+ end;\r
+ // note i don't bother to sestroy the links here as that will happen when\r
+ // the list of tasks is processed anyway\r
+ while assigned(currenttasklocal) do begin\r
+ if currenttasklocal.obj = aobj then begin\r
+ currenttasklocal.obj := nil;\r
+ currenttasklocal.handler := nil;\r
+ end;\r
+ currenttasklocal := currenttasklocal.nexttask;\r
+ end;\r
+ end;\r
+end;\r
+\r
+procedure dotasks;\r
+var\r
+ temptask:tltask;\r
+begin\r
+ if firsttask = nil then exit;\r
+\r
+ currenttask := firsttask;\r
+ firsttask := nil;\r
+ lasttask := nil;\r
+ while assigned(currenttask) do begin\r
+ if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam);\r
+ temptask := currenttask;\r
+ currenttask := currenttask.nexttask;\r
+ temptask.free;\r
+ end;\r
+ currenttask := nil;\r
+end;\r
+\r
+{------------------------------------------------------------------------------}\r
+\r
+procedure exitmessageloop;\r
+begin\r
+ postmessage(hwndwcore,WM_QUIT,0,0);\r
+end;\r
+\r
+ {$ifdef threadtimer}\r
+ 'thread timer'\r
+ {$else}\r
+const timerid_wcore=$1000;\r
+ {$endif}\r
+\r
+function MyWindowProc(\r
+ ahWnd : HWND;\r
+ auMsg : Integer;\r
+ awParam : WPARAM;\r
+ alParam : LPARAM): Integer; stdcall;\r
+var\r
+ MsgRec : TMessage;\r
+ a:integer;\r
+begin\r
+ Result := 0; // This means we handled the message\r
+\r
+ {MsgRec.hwnd := ahWnd;}\r
+ MsgRec.wParam := awParam;\r
+ MsgRec.lParam := alParam;\r
+\r
+ dotasks;\r
+ case auMsg of\r
+ {$ifndef threadtimer}\r
+ WM_TIMER: begin\r
+ if msgrec.wparam = timerid_wcore then begin\r
+ a := wcore_timehandler;\r
+ killtimer(hwndwcore,timerid_wcore);\r
+ settimer(hwndwcore,timerid_wcore,a,nil);\r
+ end;\r
+ end;\r
+ {$endif}\r
+\r
+ {WINMSG_TASK:dotasks;}\r
+\r
+ WM_CLOSE: begin\r
+ {}\r
+ end;\r
+ WM_DESTROY: begin\r
+ {}\r
+ end;\r
+ else\r
+ Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)\r
+ end;\r
+end;\r
+\r
+\r
+var\r
+ MyWindowClass : TWndClass = (style : 0;\r
+ lpfnWndProc : @MyWindowProc;\r
+ cbClsExtra : 0;\r
+ cbWndExtra : 0;\r
+ hInstance : 0;\r
+ hIcon : 0;\r
+ hCursor : 0;\r
+ hbrBackground : 0;\r
+ lpszMenuName : nil;\r
+ lpszClassName : 'wcoreClass');\r
+\r
+procedure messageloop;\r
+var\r
+ MsgRec : TMsg;\r
+begin\r
+\r
+ if Windows.RegisterClass(MyWindowClass) = 0 then halt;\r
+ //writeln('about to create wcore handle, hinstance=',hinstance);\r
+ hwndwcore := CreateWindowEx(WS_EX_TOOLWINDOW,\r
+ MyWindowClass.lpszClassName,\r
+ '', { Window name }\r
+ WS_POPUP, { Window Style }\r
+ 0, 0, { X, Y }\r
+ 0, 0, { Width, Height }\r
+ 0, { hWndParent }\r
+ 0, { hMenu }\r
+ HInstance, { hInstance }\r
+ nil); { CreateParam }\r
+\r
+ if hwndwcore = 0 then halt;\r
+\r
+ {$ifdef threadtimer}\r
+ 'thread timer'\r
+ {$else}\r
+ if settimer(hwndwcore,timerid_wcore,15,nil) = 0 then halt;\r
+ {$endif}\r
+\r
+\r
+ while GetMessage(MsgRec, 0, 0, 0) do begin\r
+ TranslateMessage(MsgRec);\r
+ DispatchMessage(MsgRec);\r
+ {if not peekmessage(msgrec,0,0,0,PM_NOREMOVE) then onidle}\r
+ end;\r
+\r
+ if hWndwcore <> 0 then begin\r
+ DestroyWindow(hwndwcore);\r
+ hWndwcore := 0;\r
+ end;\r
+\r
+ {$ifdef threadtimer}\r
+ 'thread timer'\r
+ {$else}\r
+ killtimer(hwndwcore,timerid_wcore);\r
+ {$endif}\r
+end;\r
+\r
+function ProcessMessage : Boolean;\r
+var\r
+ Msg : TMsg;\r
+begin\r
+ Result := FALSE;\r
+ if PeekMessage(Msg, hwndwcore, 0, 0, PM_REMOVE) then begin\r
+ Result := TRUE;\r
+ DispatchMessage(Msg);\r
+ end;\r
+end;\r
+\r
+procedure processmessages;\r
+begin\r
+ while processmessage do;\r
+end;\r
+\r
+\r
+end.\r
lcore.org gitweb / lcore.git / commitdiff