+++ /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
-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 .
lcore.org gitweb / lcore.git / commitdiff