From 4782a5c5afee47721cc617daa40dd29828342c2b Mon Sep 17 00:00:00 2001 From: plugwash Date: Fri, 28 Mar 2008 02:26:58 +0000 Subject: [PATCH 1/1] initial import git-svn-id: file:///svnroot/lcore/trunk@1 b1de8a11-f9be-4011-bde0-cc7ace90066a --- Makefile | 23 + bfifo.pas | 148 ++++ binipstuff.pas | 395 +++++++++ blinklist.pas | 118 +++ bsearchtree.pas | 101 +++ btime.pas | 362 ++++++++ dnsasync.pas | 247 ++++++ dnscore.pas | 728 ++++++++++++++++ dnssync.pas | 262 ++++++ dnswin.pas | 332 ++++++++ fd_utils.pas | 74 ++ httpserver_20080306/bfifo.pas | 148 ++++ httpserver_20080306/binipstuff.pas | 395 +++++++++ httpserver_20080306/blinklist.pas | 118 +++ httpserver_20080306/bsearchtree.pas | 101 +++ httpserver_20080306/btime.pas | 362 ++++++++ httpserver_20080306/dnsasync.pas | 241 ++++++ httpserver_20080306/dnscore.pas | 728 ++++++++++++++++ httpserver_20080306/dnssync.pas | 262 ++++++ httpserver_20080306/dnswin.pas | 332 ++++++++ httpserver_20080306/fd_utils.pas | 69 ++ httpserver_20080306/lcore.pas | 889 +++++++++++++++++++ httpserver_20080306/lcoregtklaz.pas | 142 ++++ httpserver_20080306/lcoreselect.pas | 391 +++++++++ httpserver_20080306/lcoretest.dpr | 167 ++++ httpserver_20080306/lcorewsaasyncselect.pas | 216 +++++ httpserver_20080306/lloopback.pas | 30 + httpserver_20080306/lmessages.pas | 656 ++++++++++++++ httpserver_20080306/lsignal.pas | 198 +++++ httpserver_20080306/lsocket.pas | 706 ++++++++++++++++ httpserver_20080306/ltimevalstuff.inc | 42 + httpserver_20080306/pgtypes.pas | 20 + httpserver_20080306/uint32.inc | 14 + httpserver_20080306/unixstuff.inc | 66 ++ httpserver_20080306/wcore.pas | 372 ++++++++ lcore.pas | 891 ++++++++++++++++++++ lcoregtklaz.pas | 142 ++++ lcoreselect.pas | 399 +++++++++ lcoretest.dof | 75 ++ lcoretest.dpr | 181 ++++ lcoretest.res | Bin 0 -> 876 bytes lcorewsaasyncselect.pas | 216 +++++ lloopback.pas | 34 + lmessages.pas | 656 ++++++++++++++ lsignal.pas | 201 +++++ lsocket.pas | 706 ++++++++++++++++ ltimevalstuff.inc | 42 + pgtypes.pas | 20 + svn-commit.2.tmp | 4 + svn-commit.3.tmp | 4 + svn-commit.4.tmp | 4 + svn-commit.5.tmp | 4 + svn-commit.tmp | 4 + uint32.inc | 14 + unixstuff.inc | 76 ++ wcore.pas | 372 ++++++++ 56 files changed, 13500 insertions(+) create mode 100755 Makefile create mode 100755 bfifo.pas create mode 100755 binipstuff.pas create mode 100755 blinklist.pas create mode 100755 bsearchtree.pas create mode 100755 btime.pas create mode 100755 dnsasync.pas create mode 100755 dnscore.pas create mode 100755 dnssync.pas create mode 100755 dnswin.pas create mode 100755 fd_utils.pas create mode 100755 httpserver_20080306/bfifo.pas create mode 100755 httpserver_20080306/binipstuff.pas create mode 100755 httpserver_20080306/blinklist.pas create mode 100755 httpserver_20080306/bsearchtree.pas create mode 100755 httpserver_20080306/btime.pas create mode 100755 httpserver_20080306/dnsasync.pas create mode 100755 httpserver_20080306/dnscore.pas create mode 100755 httpserver_20080306/dnssync.pas create mode 100755 httpserver_20080306/dnswin.pas create mode 100755 httpserver_20080306/fd_utils.pas create mode 100755 httpserver_20080306/lcore.pas create mode 100755 httpserver_20080306/lcoregtklaz.pas create mode 100755 httpserver_20080306/lcoreselect.pas create mode 100755 httpserver_20080306/lcoretest.dpr create mode 100755 httpserver_20080306/lcorewsaasyncselect.pas create mode 100755 httpserver_20080306/lloopback.pas create mode 100755 httpserver_20080306/lmessages.pas create mode 100755 httpserver_20080306/lsignal.pas create mode 100755 httpserver_20080306/lsocket.pas create mode 100755 httpserver_20080306/ltimevalstuff.inc create mode 100755 httpserver_20080306/pgtypes.pas create mode 100755 httpserver_20080306/uint32.inc create mode 100755 httpserver_20080306/unixstuff.inc create mode 100755 httpserver_20080306/wcore.pas create mode 100755 lcore.pas create mode 100755 lcoregtklaz.pas create mode 100755 lcoreselect.pas create mode 100755 lcoretest.dof create mode 100755 lcoretest.dpr create mode 100755 lcoretest.res create mode 100755 lcorewsaasyncselect.pas create mode 100755 lloopback.pas create mode 100755 lmessages.pas create mode 100755 lsignal.pas create mode 100755 lsocket.pas create mode 100755 ltimevalstuff.inc create mode 100755 pgtypes.pas create mode 100755 svn-commit.2.tmp create mode 100755 svn-commit.3.tmp create mode 100755 svn-commit.4.tmp create mode 100755 svn-commit.5.tmp create mode 100755 svn-commit.tmp create mode 100755 uint32.inc create mode 100755 unixstuff.inc create mode 100755 wcore.pas diff --git a/Makefile b/Makefile new file mode 100755 index 0000000..2926076 --- /dev/null +++ b/Makefile @@ -0,0 +1,23 @@ +all: lcoretest + +lcoretest: *.pas *.inc lcoretest.dpr + fpc -Sd -dipv6 lcoretest.dpr + +clean: + -rm *.o + -rm *.ppu + -rm *.exe + -rm *.dcu + -rm lcoretest + +date := $(shell date +%Y%m%d) + +zip: + mkdir -p lcorewin32_$(date) + cp -a *.pas lcorewin32_$(date) + cp -a *.inc lcorewin32_$(date) + cp -a *.dpr lcorewin32_$(date) + cp -a Makefile lcorewin32_$(date) + -rm ../lcorewin32_$(date).zip + zip -r ../lcorewin32_$(date).zip lcorewin32_$(date) + rm -rf lcorewin32_$(date) \ No newline at end of file diff --git a/bfifo.pas b/bfifo.pas new file mode 100755 index 0000000..55cc24a --- /dev/null +++ b/bfifo.pas @@ -0,0 +1,148 @@ +{ 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 + ----------------------------------------------------------------------------- } +unit bfifo; +{$ifdef fpc} + {$mode delphi} +{$endif} + +interface + +uses blinklist,pgtypes; + +const + pagesize=1420; + +type + tfifo=class(tobject) + private + l:tlinklist; {add to} + getl:tlinklist; {remove from} + ofs:integer; + getofs:integer; + public + size:integer; + procedure add(data:pointer;len:integer); + function get(var resultptr:pointer;len:integer):integer; + procedure del(len:integer); + constructor create; + destructor destroy; override; + end; + + +implementation + +var + testcount:integer; + +{ + +xx1..... add +xxxxxxxx +....2xxx delete + +1 ofs +2 getofs + +} + +procedure tfifo.add; +var + a:integer; + p:tlinklist; +begin + if len <= 0 then exit; + inc(size,len); + while len > 0 do begin + p := l; + if ofs = pagesize then begin + p := tplinklist.create; + if getl = nil then getl := p; + getmem(tplinklist(p).p,pagesize); + inc(testcount); + linklistadd(l,p); + ofs := 0; + end; + a := pagesize - ofs; + if len < a then a := len; + move(data^,pointer(taddrint(tplinklist(p).p)+ofs)^,a); + inc(taddrint(data),a); + dec(len,a); + inc(ofs,a); + end; +end; + +function tfifo.get; +var + p:tlinklist; + a:integer; +begin + if len > size then len := size; + if len <= 0 then begin + result := 0; + resultptr := nil; + exit; + end; + p := getl; + resultptr := pointer(taddrint(tplinklist(p).p)+getofs); + result := pagesize-getofs; + if result > len then result := len; +end; + +procedure tfifo.del; +var + a:integer; + p,p2:tlinklist; +begin + if len <= 0 then exit; + p := getl; + if len > size then len := size; + dec(size,len); + + if len = 0 then exit; + + while len > 0 do begin + a := pagesize-getofs; + if a > len then a := len; + inc(getofs,a); + dec(len,a); + if getofs = pagesize then begin + p2 := p.prev; + freemem(tplinklist(p).p); + dec(testcount); + linklistdel(l,p); + p.destroy; + p := p2; + getl := p; + getofs := 0; + end; + end; + + if size = 0 then begin + if assigned(l) then begin + p := l; + freemem(tplinklist(p).p); + dec(testcount); + linklistdel(l,p); + p.destroy; + getl := nil; + end; + ofs := pagesize; + getofs := 0; + end; +end; + +constructor tfifo.create; +begin + ofs := pagesize; + inherited create; +end; + +destructor tfifo.destroy; +begin + del(size); + inherited destroy; +end; + +end. diff --git a/binipstuff.pas b/binipstuff.pas new file mode 100755 index 0000000..ebb9f9c --- /dev/null +++ b/binipstuff.pas @@ -0,0 +1,395 @@ +{ 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 + ----------------------------------------------------------------------------- } +unit binipstuff; + +interface + +{$ifndef win32} +{$ifdef ipv6} +uses sockets; +{$endif} +{$endif} + +{$ifdef fpc} + {$mode delphi} +{$endif} +{$ifdef cpu386}{$define i386}{$endif} +{$ifdef i386}{$define ENDIAN_LITTLE}{$endif} + +{$include uint32.inc} + +const + hexchars:array[0..15] of char='0123456789abcdef'; + AF_INET=2; + {$ifdef win32} + AF_INET6=23; + {$else} + AF_INET6=10; + {$endif} + +type + {$ifdef ipv6} + + {$ifdef win32} + {$define want_Tin6_addr} + {$endif} + {$ifdef ver1_0} + {$define want_Tin6_addr} + {$endif} + {$ifdef want_Tin6_addr} + Tin6_addr = packed record + case byte of + 0: (u6_addr8 : array[0..15] of byte); + 1: (u6_addr16 : array[0..7] of Word); + 2: (u6_addr32 : array[0..3] of uint32); + 3: (s6_addr8 : array[0..15] of shortint); + 4: (s6_addr : array[0..15] of shortint); + 5: (s6_addr16 : array[0..7] of smallint); + 6: (s6_addr32 : array[0..3] of LongInt); + end; + {$endif} + {$endif} + + tbinip=record + family:integer; + {$ifdef ipv6} + case integer of + 0: (ip:longint); + 1: (ip6:tin6_addr); + {$else} + ip:longint; + {$endif} + end; + + {$ifdef win32} + TInetSockAddr = packed Record + family:Word; + port :Word; + addr :uint32; + pad :array [1..8] of byte; + end; + {$ifdef ipv6} + + TInetSockAddr6 = packed record + sin6_family: word; + sin6_port: word; + sin6_flowinfo: uint32; + sin6_addr: tin6_addr; + sin6_scope_id: uint32; + end; + {$endif} + {$endif} + +function htons(w:word):word; +function htonl(i:uint32):uint32; + +function ipstrtobin(const s:string;var binip:tbinip):boolean; +function ipbintostr(const binip:tbinip):string; +{$ifdef ipv6} +function ip6bintostr(const bin:tin6_addr):string; +function ip6strtobin(const s:string;var bin:tin6_addr):boolean; +{$endif} + +function comparebinip(const ip1,ip2:tbinip):boolean; + +{deprecated} +function longip(s:string):longint; + +procedure converttov4(var ip:tbinip); + +implementation + +uses sysutils; + +function htons(w:word):word; +begin + {$ifdef ENDIAN_LITTLE} + result := ((w and $ff00) shr 8) or ((w and $ff) shl 8); + {$else} + result := w; + {$endif} +end; + +function htonl(i:uint32):uint32; +begin + {$ifdef ENDIAN_LITTLE} + result := (i shr 24) or (i shr 8 and $ff00) or (i shl 8 and $ff0000) or (i shl 24 and $ff000000); + {$else} + result := i; + {$endif} +end; + +{internal} +{converts dotted v4 IP to longint. returns host endian order} +function longip(s:string):longint; +var + l:longint; + a,b:integer; +function convertbyte(const s:string):integer; +begin + result := strtointdef(s,-1); + if result < 0 then begin + result := -1; + exit; + end; + if result > 255 then begin + result := -1; + exit; + end; + {01 exception} + if (result <> 0) and (s[1] = '0') then begin + result := -1; + exit; + end; + {+1 exception} + if not (s[1] in ['0'..'9']) then begin + result := -1; + exit + end; +end; + +begin + result := 0; + a := pos('.',s); + if a = 0 then exit; + b := convertbyte(copy(s,1,a-1));if (b < 0) then exit; + l := b shl 24; + s := copy(s,a+1,256); + a := pos('.',s); + if a = 0 then exit; + b := convertbyte(copy(s,1,a-1));if (b < 0) then exit; + l := l or b shl 16; + s := copy(s,a+1,256); + a := pos('.',s); + if a = 0 then exit; + b := convertbyte(copy(s,1,a-1));if (b < 0) then exit; + l := l or b shl 8; + s := copy(s,a+1,256); + b := convertbyte(copy(s,1,256));if (b < 0) then exit; + l := l or b; + result := l; +end; + + +function ipstrtobin(const s:string;var binip:tbinip):boolean; +begin + binip.family := 0; + result := false; + {$ifdef ipv6} + if pos(':',s) <> 0 then begin + {try ipv6. use builtin routine} + result := ip6strtobin(s,binip.ip6); + if result then binip.family := AF_INET6; + exit; + end; + {$endif} + + {try v4} + binip.ip := htonl(longip(s)); + if (binip.ip <> 0) or (s = '0.0.0.0') then begin + result := true; + binip.family := AF_INET; + exit; + end; +end; + +function ipbintostr(const binip:tbinip):string; +var + a:integer; +begin + result := ''; + {$ifdef ipv6} + if binip.family = AF_INET6 then begin + result := ip6bintostr(binip.ip6); + end else + {$endif} + if binip.family = AF_INET then begin + a := htonl(binip.ip); + result := inttostr(a shr 24)+'.'+inttostr((a shr 16) and $ff)+'.'+inttostr((a shr 8) and $ff)+'.'+inttostr(a and $ff); + end; +end; + + +{------------------------------------------------------------------------------} + +{$ifdef ipv6} + +{ +IPv6 address binary to/from string conversion routines +written by beware (steendijk at xs4all dot nl) + +- implementation does not depend on other ipv6 code such as the tin6_addr type, + the parameter can also be untyped. +- it is host endian neutral - binary format is aways network order +- it supports compression of zeroes +- it supports ::ffff:192.168.12.34 style addresses +- they are made to do the Right Thing, more efficient implementations are possible +} + +{fpc has hostaddrtostr6 and strtohostaddr6 but the later isnt implemented yet} + + +function ip6bintostr(const bin:tin6_addr):string; +{base16 with lowercase output} +function makehex(w:word):string; +begin + result := ''; + if w >= 4096 then result := result + hexchars[w shr 12]; + if w >= 256 then result := result + hexchars[w shr 8 and $f]; + if w >= 16 then result := result + hexchars[w shr 4 and $f]; + result := result + hexchars[w and $f]; +end; + +var + a,b,c,addrlen:integer; + runbegin,runlength:integer; + bytes:array[0..15] of byte absolute bin; + words:array[0..7] of word; + dwords:array[0..3] of integer absolute words; +begin + for a := 0 to 7 do begin + words[a] := bytes[a shl 1] shl 8 or bytes[a shl 1 or 1]; + end; + if (dwords[0] = 0) and (dwords[1] = 0) and (words[4] = 0) and (words[5] = $ffff) then begin + {::ffff:/96 exception: v4 IP} + addrlen := 6; + end else begin + addrlen := 8; + end; + {find longest run of zeroes} + runbegin := 0; + runlength := 0; + for a := 0 to addrlen-1 do begin + if words[a] = 0 then begin + c := 0; + for b := a to addrlen-1 do if words[b] = 0 then begin + inc(c); + end else break; + if (c > runlength) then begin + runlength := c; + runbegin := a; + end; + end; + end; + result := ''; + for a := 0 to runbegin-1 do begin + if (a <> 0) then result := result + ':'; + result := result + makehex(words[a]); + end; + if runlength > 0 then result := result + '::'; + c := runbegin+runlength; + for a := c to addrlen-1 do begin + if (a > c) then result := result + ':'; + result := result + makehex(words[a]); + end; + if addrlen = 6 then begin + result := result + ':'+inttostr(bytes[12])+'.'+inttostr(bytes[13])+'.'+inttostr(bytes[14])+'.'+inttostr(bytes[15]); + end; +end; + +function ip6strtobin(const s:string;var bin:tin6_addr):boolean; +var + a,b:integer; + fields:array[0..7] of string; + fieldcount:integer; + emptyfield:integer; + wordcount:integer; + words:array[0..7] of word; + bytes:array[0..15] of byte absolute bin; +begin + result := false; + for a := 0 to 7 do fields[a] := ''; + fieldcount := 0; + for a := 1 to length(s) do begin + if s[a] = ':' then inc(fieldcount) else fields[fieldcount] := fields[fieldcount] + s[a]; + if fieldcount > 7 then exit; + end; + if fieldcount < 2 then exit; + + {find the empty field (compressed zeroes), not counting the first and last there may be at most 1} + emptyfield := -1; + for a := 1 to fieldcount-1 do begin + if fields[a] = '' then begin + if emptyfield = -1 then emptyfield := a else exit; + end; + end; + + {check if last field is a valid v4 IP} + a := longip(fields[fieldcount]); + if (a <> 0) or (fields[fieldcount] = '0.0.0.0') then wordcount := 6 else wordcount := 8; + {0:1:2:3:4:5:6.6.6.6 + 0:1:2:3:4:5:6:7} + fillchar(words,sizeof(words),0); + if wordcount = 6 then begin + if fieldcount > 6 then exit; + words[6] := a shr 16; + words[7] := a and $ffff; + end; + if emptyfield = -1 then begin + {no run length: must be an exact number of fields} + if wordcount = 6 then begin + if fieldcount <> 6 then exit; + emptyfield := 5; + end else if wordcount = 8 then begin + if fieldcount <> 7 then exit; + emptyfield := 7; + end else exit; + end; + for a := 0 to emptyfield do begin + if fields[a] = '' then b := 0 else b := strtointdef('$'+fields[a],-1); + if (b < 0) or (b > $ffff) then exit; + words[a] := b; + end; + if wordcount = 6 then dec(fieldcount); + for a := wordcount-1 downto wordcount-(fieldcount-emptyfield) do begin + b := a+fieldcount-wordcount+1; + if fields[b] = '' then b := 0 else b := strtointdef('$'+fields[b],-1); + if (b < 0) or (b > $ffff) then exit; + words[a] := b; + end; + for a := 0 to 7 do begin + bytes[a shl 1] := words[a] shr 8; + bytes[a shl 1 or 1] := words[a] and $ff; + end; + result := true; +end; +{$endif} + +function comparebinip(const ip1,ip2:tbinip):boolean; +begin + if (ip1.ip <> ip2.ip) then begin + result := false; + exit; + end; + + {$ifdef ipv6} + if ip1.family = AF_INET6 then begin + if (ip1.ip6.s6_addr32[1] <> ip2.ip6.s6_addr32[1]) + or (ip1.ip6.s6_addr32[2] <> ip2.ip6.s6_addr32[2]) + or (ip1.ip6.s6_addr32[3] <> ip2.ip6.s6_addr32[3]) then begin + result := false; + exit; + end; + end; + {$endif} + + result := (ip1.family = ip2.family); +end; + +{converts a binary IP to v4 if it is a v6 IP in the v4 range} +procedure converttov4(var ip:tbinip); +begin + {$ifdef ipv6} + if ip.family = AF_INET6 then begin + if (ip.ip6.u6_addr32[0] = 0) and (ip.ip6.u6_addr32[1] = 0) and + (ip.ip6.u6_addr16[4] = 0) and (ip.ip6.u6_addr16[5] = $ffff) then begin + ip.family := AF_INET; + ip.ip := ip.ip6.s6_addr32[3]; + end; + end; + {$endif} +end; + +end. diff --git a/blinklist.pas b/blinklist.pas new file mode 100755 index 0000000..2079b75 --- /dev/null +++ b/blinklist.pas @@ -0,0 +1,118 @@ +(* + * beware IRC services, blinklist.pas + * Copyright (C) 2002 Bas Steendijk + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) +unit blinklist; +{$ifdef fpc} + {$mode delphi} +{$endif} + + +interface + +type + tlinklist=class(tobject) + next:tlinklist; + prev:tlinklist; + constructor create; + destructor destroy; override; + end; + + {linklist with 2 links} + tlinklist2=class(tlinklist) + next2:tlinklist2; + prev2:tlinklist2; + end; + + {linklist with one pointer} + tplinklist=class(tlinklist) + p:pointer + end; + + tstringlinklist=class(tlinklist) + s:string; + end; + + tthing=class(tlinklist) + name:string; {name/nick} + hashname:integer; {hash of name} + end; + +{ +adding new block to list (baseptr) +} +procedure linklistadd(var baseptr:tlinklist;newptr:tlinklist); +procedure linklistdel(var baseptr:tlinklist;item:tlinklist); + + +procedure linklist2add(var baseptr,newptr:tlinklist2); +procedure linklist2del(var baseptr:tlinklist2;item:tlinklist2); + +var + linklistdebug:integer; + +implementation + +procedure linklistadd(var baseptr:tlinklist;newptr:tlinklist); +var + p:tlinklist; +begin + p := baseptr; + baseptr := newptr; + baseptr.prev := nil; + baseptr.next := p; + if p <> nil then p.prev := baseptr; +end; + +procedure linklistdel(var baseptr:tlinklist;item:tlinklist); +begin + if item = baseptr then baseptr := item.next; + if item.prev <> nil then item.prev.next := item.next; + if item.next <> nil then item.next.prev := item.prev; +end; + +procedure linklist2add(var baseptr,newptr:tlinklist2); +var + p:tlinklist2; +begin + p := baseptr; + baseptr := newptr; + baseptr.prev2 := nil; + baseptr.next2 := p; + if p <> nil then p.prev2 := baseptr; +end; + +procedure linklist2del(var baseptr:tlinklist2;item:tlinklist2); +begin + if item = baseptr then baseptr := item.next2; + if item.prev2 <> nil then item.prev2.next2 := item.next2; + if item.next2 <> nil then item.next2.prev2 := item.prev2; +end; + +constructor tlinklist.create; +begin + inherited create; + inc(linklistdebug); +end; + +destructor tlinklist.destroy; +begin + dec(linklistdebug); + inherited destroy; +end; + +end. diff --git a/bsearchtree.pas b/bsearchtree.pas new file mode 100755 index 0000000..ad61751 --- /dev/null +++ b/bsearchtree.pas @@ -0,0 +1,101 @@ +{ 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 + ----------------------------------------------------------------------------- } + +{actually a hashtable. it was a tree in earlier versions} + +unit bsearchtree; + +interface + +uses blinklist; + +const + hashtable_size=$4000; + +type + thashitem=class(tlinklist) + hash:integer; + s:string; + p:pointer; + end; + thashtable=array[0..hashtable_size-1] of thashitem; + phashtable=^thashtable; + +{adds "item" to the tree for name "s". the name must not exist (no checking done)} +procedure addtree(t:phashtable;s:string;item:pointer); + +{removes name "s" from the tree. the name must exist (no checking done)} +procedure deltree(t:phashtable;s:string); + +{returns the item pointer for s, or nil if not found} +function findtree(t:phashtable;s:string):pointer; + +implementation + +function makehash(s:string):integer; +const + shifter=6; +var + a,b:integer; +begin + result := 0; + b := length(s); + for a := 1 to b do begin + result := (result shl shifter) xor byte(s[a]); + end; + result := (result xor result shr 16) and (hashtable_size-1); +end; + +procedure addtree(t:phashtable;s:string;item:pointer); +var + hash:integer; + p:thashitem; +begin + hash := makehash(s); + p := thashitem.create; + p.hash := hash; + p.s := s; + p.p := item; + linklistadd(tlinklist(t[hash]),tlinklist(p)); +end; + +procedure deltree(t:phashtable;s:string); +var + p,p2:thashitem; + hash:integer; +begin + hash := makehash(s); + p := t[hash]; + p2 := nil; + while p <> nil do begin + if p.s = s then begin + p2 := p; + break; + end; + p := thashitem(p.next); + end; + linklistdel(tlinklist(t[hash]),tlinklist(p2)); + p2.destroy; +end; + + +function findtree(t:phashtable;s:string):pointer; +var + p:thashitem; + hash:integer; +begin + result := nil; + hash := makehash(s); + p := t[hash]; + while p <> nil do begin + if p.s = s then begin + result := p.p; + exit; + end; + p := thashitem(p.next); + end; +end; + +end. diff --git a/btime.pas b/btime.pas new file mode 100755 index 0000000..3d672c4 --- /dev/null +++ b/btime.pas @@ -0,0 +1,362 @@ +{ 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 + ----------------------------------------------------------------------------- } +{ +this unit returns unix timestamp with seconds and microseconds (as float) +works on windows/delphi, and on freepascal on unix. +} + +unit btime; + +interface + +type + float=extended; + +var + timezone:integer; + timezonestr:string; + irctime,unixtime:integer; + tickcount:integer; + settimebias:integer; + qpcjump:float; {can be read out and reset for debug purpose} + performancecountfreq:extended; + +function irctimefloat:float; +function irctimeint:integer; + +function unixtimefloat:float; +function unixtimeint:integer; + +function wintimefloat:float; + +procedure settime(newtime:integer); +procedure gettimezone; +procedure timehandler; +procedure init; + +function timestring(i:integer):string; +function timestrshort(i:integer):string; + +function oletounixfloat(t:float):float; +function oletounix(t:tdatetime):integer; +function unixtoole(i:integer):tdatetime; + +var + timefloatbias:float; + lastunixtimefloat:float=0; + +implementation + +{$ifdef fpc} + {$mode delphi} +{$endif} + +uses + {$ifdef UNIX} + {$ifdef VER1_0} + linux, + {$else} + baseunix,unix,unixutil,{needed for 2.0.2} + {$endif} + {$else} + windows, + {$endif} + sysutils; + + {$include unixstuff.inc} + + +const + daysdifference=25569; + +function oletounixfloat(t:float):float; +begin + t := (t - daysdifference) * 86400; + result := t; +end; + +function oletounix(t:tdatetime):integer; +begin + result := trunc(oletounixfloat(t)); +end; + +function unixtoole(i:integer):tdatetime; +begin + result := ((i)/86400)+daysdifference; +end; + +{$ifdef unix} +{-----------------------------------------*nix/freepascal code to read time } + +function unixtimefloat:float; +var + tv:ttimeval; +begin + gettimeofday(tv); + result := tv.tv_sec+(tv.tv_usec/1000000); +end; + +function wintimefloat:extended; +begin + result := unixtimefloat; +end; + +function unixtimeint:integer; +var + tv:ttimeval; +begin + gettimeofday(tv); + result := tv.tv_sec; +end; + +{$else} {delphi 3} +{------------------------------ windows/delphi code to read time} + +{ free pascals tsystemtime is incomaptible with windows api calls + so we declare it ourselves - plugwash +} +{$ifdef fpc} +type + TSystemTime = record + wYear: Word; + wMonth: Word; + wDayOfWeek: Word; + wDay: Word; + wHour: Word; + wMinute: Word; + wSecond: Word; + wMilliseconds: Word; + end; + {$endif} +function Date_utc: extended; +var + SystemTime: TSystemTime; +begin + {$ifdef fpc} + GetsystemTime(@SystemTime); + {$else} + GetsystemTime(SystemTime); + {$endif} + with SystemTime do Result := EncodeDate(wYear, wMonth, wDay); +end; + +function Time_utc: extended; +var + SystemTime: TSystemTime; +begin + {$ifdef fpc} + GetsystemTime(@SystemTime); + {$else} + GetsystemTime(SystemTime); + {$endif} + with SystemTime do + Result := EncodeTime(wHour, wMinute, wSecond, wMilliSeconds); +end; + +function Now_utc: extended; +begin + Result := round(Date_utc) + Time_utc; +end; + +const + highdwordconst=4294967296.0; + +function wintimefloat:extended; +var + p:packed record + lowpart:longint; + highpart:longint + end; + p2:tlargeinteger absolute p; + e:extended; +begin + if performancecountfreq = 0 then begin + QueryPerformancefrequency(p2); + e := p.lowpart; + if e < 0 then e := e + highdwordconst; + performancecountfreq := ((p.highpart*highdwordconst)+e); + end; + queryperformancecounter(p2); + e := p.lowpart; + if e < 0 then e := e + highdwordconst; + result := ((p.highpart*highdwordconst)+e)/performancecountfreq; +end; + +var + classpriority,threadpriority:integer; + +procedure settc; +var + hprocess,hthread:integer; +begin + hProcess := GetCurrentProcess; + hThread := GetCurrentThread; + + ClassPriority := GetPriorityClass(hProcess); + ThreadPriority := GetThreadPriority(hThread); + + SetPriorityClass(hProcess, REALTIME_PRIORITY_CLASS); + SetThreadPriority(hThread, THREAD_PRIORITY_TIME_CRITICAL); +end; + +procedure unsettc; +var + hprocess,hthread:integer; +begin + hProcess := GetCurrentProcess; + hThread := GetCurrentThread; + + SetPriorityClass(hProcess, ClassPriority); + SetThreadPriority(hThread, ThreadPriority); +end; + +function unixtimefloat:float; +var + f,g,h:float; +begin + if timefloatbias = 0 then begin + settc; + f := now_utc; + repeat g := now_utc; h := wintimefloat until g > f; + timefloatbias := oletounixfloat(g)-h; + unsettc; + end; + result := wintimefloat+timefloatbias; + + { + workaround for QPC jumps + (approach 2: always check "hi res" QPC unixtime against the "guaranteed" systemtime one) + } + f := result-(oletounixfloat(now_utc)); + if abs(f) > 0.02 then begin + f := timefloatbias; + timefloatbias := 0; + result := unixtimefloat; + qpcjump := qpcjump + f - timefloatbias; + end; + + if (result <= lastunixtimefloat) then result := lastunixtimefloat + 0.0000001; + lastunixtimefloat := result; +end; + +function unixtimeint:integer; +begin + result := trunc(unixtimefloat); +end; + +{$endif} +{-----------------------------------------------end of platform specific} + +function irctimefloat:float; +begin + result := unixtimefloat+settimebias; +end; + +function irctimeint:integer; +begin + result := unixtimeint+settimebias; +end; + + +procedure settime(newtime:integer); +var + a:integer; +begin + a := irctimeint-settimebias; + if newtime = 0 then settimebias := 0 else settimebias := newtime-a; + + irctime := irctimeint; +end; + +procedure timehandler; +begin + if unixtime = 0 then init; + unixtime := unixtimeint; + irctime := irctimeint; + if unixtime and 63 = 0 then begin + {update everything, apply timezone changes, clock changes, etc} + gettimezone; + timefloatbias := 0; + unixtime := unixtimeint; + irctime := irctimeint; + end; +end; + + +procedure gettimezone; +var + {$ifdef UNIX} + {$ifndef ver1_9_4} + {$ifndef ver1_0} + {$define above194} + {$endif} + {$endif} + {$ifndef above194} + hh,mm,ss:word; + {$endif} + {$endif} + l:integer; +begin + {$ifdef UNIX} + {$ifdef above194} + timezone := tzseconds; + {$else} + gettime(hh,mm,ss); + timezone := (longint(hh) * 3600 + mm * 60 + ss) - (unixtimeint mod 86400); + {$endif} + {$else} + timezone := round((now-now_utc)*86400); + {$endif} + + while timezone > 43200 do dec(timezone,86400); + while timezone < -43200 do inc(timezone,86400); + + if timezone >= 0 then timezonestr := '+' else timezonestr := '-'; + l := abs(timezone) div 60; + 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); +end; + +function timestrshort(i:integer):string; +const + weekday:array[0..6] of string[4]=('Thu','Fri','Sat','Sun','Mon','Tue','Wed'); + month:array[0..11] of string[4]=('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'); +var + y,m,d,h,min,sec,ms:word; + t:tdatetime; +begin + t := unixtoole(i+timezone); + decodedate(t,y,m,d); + decodetime(t,h,min,sec,ms); + result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+ + inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10)+' '+ + inttostr(y); +end; + +function timestring(i:integer):string; +const + weekday:array[0..6] of string[10]=('Thursday','Friday','Saturday','Sunday','Monday','Tuesday','Wednesday'); + month:array[0..11] of string[10]=('January','February','March','April','May','June','July','August','September','October','November','December'); +var + y,m,d,h,min,sec,ms:word; + t:tdatetime; +begin + t := unixtoole(i+timezone); + decodedate(t,y,m,d); + decodetime(t,h,min,sec,ms); + result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+inttostr(y)+' -- '+ + inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10)+' '+ + timezonestr; +end; + +procedure init; +begin + qpcjump := 0; + settimebias := 0; + gettimezone; + unixtime := unixtimeint; + irctime := irctimeint; +end; + +end. diff --git a/dnsasync.pas b/dnsasync.pas new file mode 100755 index 0000000..0a32459 --- /dev/null +++ b/dnsasync.pas @@ -0,0 +1,247 @@ +{ 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 + ----------------------------------------------------------------------------- } + +//FIXME: this code only ever seems to use one dns server for a request and does +//not seem to have any form of retry code. + +unit dnsasync; + +interface + +uses + {$ifdef win32} + dnswin, + {$endif} + lsocket,lcore, + classes,binipstuff,dnscore,btime; + + +type + //after completion or cancelation a dnswinasync may be reused + tdnsasync=class(tcomponent) + + private + //made a load of stuff private that does not appear to be part of the main + //public interface. If you make any of it public again please consider the + //consequences when using windows dns. --plugwash. + sock:twsocket; + + sockopen:boolean; + + + state:tdnsstate; + + dnsserverid:integer; + startts:double; + {$ifdef win32} + dwas : tdnswinasync; + {$endif} + + + procedure asyncprocess; + procedure receivehandler(sender:tobject;error:word); + function sendquery(const packet:tdnspacket;len:integer):boolean; + {$ifdef win32} + procedure winrequestdone(sender:tobject;error:word); + {$endif} + public + onrequestdone:tsocketevent; + + //addr and port allow the application to specify a dns server specifically + //for this dnsasync object. This is not a reccomended mode of operation + //because it limits the app to one dns server but is kept for compatibility + //and special uses. + addr,port:string; + + //A family value of AF_INET6 will give only + //ipv6 results. Any other value will give ipv4 results in preference and ipv6 + //results if ipv4 results are not available; + forwardfamily:integer; + + procedure cancel;//cancel an outstanding dns request + function dnsresult:string; //get result of dnslookup as a string + procedure dnsresultbin(var binip:tbinip); //get result of dnslookup as a tbinip + procedure forwardlookup(const name:string); //start forward lookup, + //preffering ipv4 + procedure reverselookup(const binip:tbinip); //start reverse lookup + + constructor create(aowner:tcomponent); override; + destructor destroy; override; + + end; + +implementation + +uses sysutils; + +constructor tdnsasync.create; +begin + inherited create(aowner); + dnsserverid := -1; + sock := twsocket.create(self); +end; + +destructor tdnsasync.destroy; +begin + if dnsserverid >= 0 then begin + reportlag(dnsserverid,-1); + dnsserverid := -1; + end; + sock.release; + setstate_request_init('',state); + inherited destroy; +end; + +procedure tdnsasync.receivehandler; +begin + if dnsserverid >= 0 then begin + reportlag(dnsserverid,trunc((unixtimefloat-startts)*1000)); + dnsserverid := -1; + end; +{ writeln('received reply');} + fillchar(state.recvpacket,sizeof(state.recvpacket),0); + state.recvpacketlen := twsocket(sender).Receive(@state.recvpacket, SizeOf(state.recvpacket)); + state.parsepacket := true; + asyncprocess; +end; + +function tdnsasync.sendquery; +begin +{ writeln('sendquery ',decodename(state.packet,state.packetlen,12,0,a),' ',state.requesttype);} + result := false; + if len = 0 then exit; {no packet} + if not sockopen then begin + if addr <> '' then sock.addr := addr else sock.addr := getcurrentsystemnameserver(dnsserverid);//getunixnameservercached; + startts := unixtimefloat; + if port = '' then port := '53'; + sock.port := port; + sock.Proto := 'udp'; + sock.ondataavailable := receivehandler; + try + sock.connect; + except + on e:exception do begin + //writeln('exception '+e.message); + exit; + end; + end; + sockopen := true; + end; + sock.send(@packet,len); + result := true; +end; + +procedure tdnsasync.asyncprocess; +begin + state_process(state); + case state.resultaction of + action_ignore: begin {do nothing} end; + action_done: begin + onrequestdone(self,0); + end; + action_sendquery:begin + sendquery(state.sendpacket,state.sendpacketlen); + end; + end; +end; + +procedure tdnsasync.forwardlookup; +begin + + ipstrtobin(name,state.resultbin); + + {$ifdef win32} + if usewindns or (addr = '') then begin + dwas := tdnswinasync.create; + dwas.onrequestdone := winrequestdone; + if forwardfamily = AF_INET6 then begin + dwas.forwardlookup(name,true); + end else begin + dwas.forwardlookup(name,false); + end; + exit; + end; + {$endif} + + + if state.resultbin.family <> 0 then begin + onrequestdone(self,0); + exit; + end; + + + setstate_forward(name,state,forwardfamily); + asyncprocess; + +end; + +procedure tdnsasync.reverselookup; + +begin + {$ifdef win32} + if usewindns or (addr = '') then begin + dwas := tdnswinasync.create; + dwas.onrequestdone := winrequestdone; + dwas.reverselookup(binip); + exit; + end; + {$endif} + + setstate_reverse(binip,state); + asyncprocess; +end; + +function tdnsasync.dnsresult; +begin + if state.resultstr <> '' then result := state.resultstr else begin + result := ipbintostr(state.resultbin); + end; +end; + +procedure tdnsasync.dnsresultbin(var binip:tbinip); +begin + move(state.resultbin,binip,sizeof(binip)); +end; + +procedure tdnsasync.cancel; +begin + {$ifdef win32} + if assigned(dwas) then begin + dwas.release; + dwas := nil; + end else + {$endif} + begin + + if dnsserverid >= 0 then begin + reportlag(dnsserverid,-1); + dnsserverid := -1; + end; + if sockopen then begin + sock.close; + sockopen := false; + end; + end; + setstate_failure(state); + onrequestdone(self,0); +end; + +{$ifdef win32} + procedure tdnsasync.winrequestdone(sender:tobject;error:word); + + begin + if dwas.reverse then begin + state.resultstr := dwas.name; + end else begin + state.resultbin := dwas.ip; + if (forwardfamily = AF_INET6) and (state.resultbin.family = AF_INET) then begin + fillchar(state.resultbin,sizeof(tbinip),0); + end; + end; + dwas.release; + onrequestdone(self,error); + end; +{$endif} +end. diff --git a/dnscore.pas b/dnscore.pas new file mode 100755 index 0000000..bb4fab4 --- /dev/null +++ b/dnscore.pas @@ -0,0 +1,728 @@ +{ 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 + ----------------------------------------------------------------------------- } + +{ + + code wanting to use this dns system should act as follows (note: app + developers will probablly want to use dnsasync or dnssync or write a similar + wrapper unit of thier own). + + for normal lookups call setstate_forward or setstate_reverse to set up the + state, for more obscure lookups use setstate_request_init and fill in other + relavent state manually. + + call state_process which will do processing on the information in the state + and return an action + action_ignore means that dnscore wants the code that calls it to go + back to waiting for packets + action_sendpacket means that dnscore wants the code that calls it to send + the packet in sendpacket/sendpacketlen and then start (or go back to) listening + for + action_done means the request has completed (either suceeded or failed) + + callers should resend the last packet they tried to send if they have not + been asked to send a new packet for more than some timeout value they choose. + + when a packet is received the application should put the packet in + recvbuf/recvbuflen , set state.parsepacket and call state_process again + + once the app gets action_done it can determine sucess or failure in the + following ways. + + on failure state.resultstr will be an empty string and state.resultbin will + be zeroed out (easilly detected by the fact that it will have a family of 0) + + on success for a A or AAAA lookup state.resultstr will be an empty string + and state.resultbin will contain the result (note: AAAA lookups require IPV6 + enabled). + + if an A lookup fails and the code is built with ipv6 enabled then the code + will return any AAAA records with the same name. The reverse does not apply + so if an application preffers IPV6 but wants IPV4 results as well it must + check them seperately. + + on success for any other type of lookup state.resultstr will be an empty + + note the state contains ansistrings, setstate_init with a null name parameter + can be used to clean theese up if required. + + callers may use setstate_failure to mark the state as failed themseleves + before passing it on to other code, for example this may be done in the event + of a timeout. +} +unit dnscore; + + + +{$ifdef fpc}{$mode delphi}{$endif} + + + + + +interface + +uses binipstuff,classes,pgtypes; + +var usewindns : boolean = {$ifdef win32}true{$else}false{$endif}; +//hint to users of this unit that they should use windows dns instead. +//May be disabled by applications if desired. (e.g. if setting a custom +//dnsserverlist). + +//note: this unit will not be able to self populate it's dns server list on +//older versions of windows. + +const + maxnamelength=127; + maxnamefieldlen=63; + //note: when using action_ignore the dnscore code *must* preserve the contents of state.sendpacket to allow for retries + //note: action_ignore must not be used in response to the original request but there is no valid reason for doing this anyway + action_ignore=0; + action_done=1; + action_sendquery=2; + querytype_a=1; + querytype_cname=5; + querytype_aaaa=28; + querytype_ptr=12; + querytype_ns=2; + querytype_soa=6; + querytype_mx=15; + + maxrecursion=10; + maxrrofakind=20; + + retryafter=300000; //microseconds must be less than one second; + timeoutlag=1000000000; // penalty value to be treated as lag in the event of a timeout (microseconds) +type + dvar=array[0..0] of byte; + pdvar=^dvar; + tdnspacket=packed record + id:word; + flags:word; + rrcount:array[0..3] of word; + payload:array[0..511-12] of byte; + end; + + + + tdnsstate=record + id:word; + recursioncount:integer; + queryname:string; + requesttype:word; + parsepacket:boolean; + resultstr:string; + resultbin:tbinip; + resultaction:integer; + numrr1:array[0..3] of integer; + numrr2:integer; + rrdata:string; + sendpacketlen:integer; + sendpacket:tdnspacket; + recvpacketlen:integer; + recvpacket:tdnspacket; + forwardfamily:integer; + end; + + trr=packed record + requesttypehi:byte; + requesttype:byte; + clas:word; + ttl:integer; + datalen:word; + data:array[0..511] of byte; + end; + + trrpointer=packed record + p:pointer; + ofs:integer; + len:integer; + namelen:integer; + end; + +//commenting out functions from interface that do not have documented semantics +//and probablly should not be called from outside this unit, reenable them +//if you must but please document them at the same time --plugwash + +//function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer; +//function makereversename(const binip:tbinip):string; + +procedure setstate_request_init(const name:string;var state:tdnsstate); + +//set up state for a foward lookup. A family value of AF_INET6 will give only +//ipv6 results. Any other value will give ipv4 results in preference and ipv6 +//results if ipv4 results are not available; +procedure setstate_forward(const name:string;var state:tdnsstate;family:integer); + +procedure setstate_reverse(const binip:tbinip;var state:tdnsstate); +procedure setstate_failure(var state:tdnsstate); +//procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate); + + +procedure state_process(var state:tdnsstate); + +//function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):string; + +//presumablly this is exported to allow more secure random functions +//to be substituted? +var randomfunction:function:integer; + + +procedure populatednsserverlist; +procedure cleardnsservercache; + +var + dnsserverlist : tstringlist; +// currentdnsserverno : integer; + +function getcurrentsystemnameserver(var id:integer) :string; + +//var +// unixnameservercache:string; +{ $endif} + + +procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout +var + failurereason:string; + +implementation + +uses + {$ifdef win32} + windows, + {$endif} + + sysutils; + +function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer; +var + a,b:integer; + s:string; + arr:array[0..sizeof(packet)-1] of byte absolute packet; +begin + { writeln('buildrequest: name: ',name);} + result := 0; + fillchar(packet,sizeof(packet),0); + if assigned(randomfunction) then packet.id := (randomfunction and $ffff) else packet.id := random(65536); + packet.flags := htons($0100); + packet.rrcount[0] := htons($0001); + + + s := copy(name,1,maxnamelength); + if s = '' then exit; + if s[length(s)] <> '.' then s := s + '.'; + b := 0; + {encode name} + if (s = '.') then begin + packet.payload[0] := 0; + result := 12+5; + end else begin + for a := 1 to length(s) do begin + if s[a] = '.' then begin + if b > maxnamefieldlen then exit; + if (b = 0) then exit; + packet.payload[a-b-1] := b; + b := 0; + end else begin + packet.payload[a] := byte(s[a]); + inc(b); + end; + end; + if b > maxnamefieldlen then exit; + packet.payload[length(s)-b] := b; + result := length(s) + 12+5; + end; + + arr[result-1] := 1; + arr[result-3] := requesttype and $ff; + arr[result-4] := requesttype shr 8; +end; + +function makereversename(const binip:tbinip):string; +var + name:string; + a,b:integer; +begin + name := ''; + if binip.family = AF_INET then begin + b := htonl(binip.ip); + for a := 0 to 3 do begin + name := name + inttostr(b shr (a shl 3) and $ff)+'.'; + end; + name := name + 'in-addr.arpa'; + end else + {$ifdef ipv6} + if binip.family = AF_INET6 then begin + for a := 15 downto 0 do begin + b := binip.ip6.u6_addr8[a]; + name := name + hexchars[b and $f]+'.'+hexchars[b shr 4]+'.'; + end; + name := name + 'ip6.arpa'; + end else + {$endif} + begin + {empty name} + end; + result := name; +end; + +{ +decodes DNS format name to a string. does not includes the root dot. +doesnt read beyond len. +empty result + non null failurereason: failure +empty result + null failurereason: internal use +} +function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):string; +var + arr:array[0..sizeof(packet)-1] of byte absolute packet; + s:string; + a,b:integer; +begin + numread := 0; + repeat + if (start+numread < 0) or (start+numread >= len) then begin + result := ''; + failurereason := 'decoding name: got out of range1'; + exit; + end; + b := arr[start+numread]; + if b >= $c0 then begin + {recursive sub call} + if recursion > 10 then begin + result := ''; + failurereason := 'decoding name: max recursion'; + exit; + end; + if ((start+numread+1) >= len) then begin + result := ''; + failurereason := 'decoding name: got out of range3'; + exit; + end; + a := ((b shl 8) or arr[start+numread+1]) and $3fff; + s := decodename(packet,len,a,recursion+1,a); + if (s = '') and (failurereason <> '') then begin + result := ''; + exit; + end; + if result <> '' then result := result + '.'; + result := result + s; + inc(numread,2); + exit; + end else if b < 64 then begin + if (numread <> 0) and (b <> 0) then result := result + '.'; + for a := start+numread+1 to start+numread+b do begin + if (a >= len) then begin + result := ''; + failurereason := 'decoding name: got out of range2'; + exit; + end; + result := result + char(arr[a]); + end; + inc(numread,b+1); + + if b = 0 then begin + if (result = '') and (recursion = 0) then result := '.'; + exit; {reached end of name} + end; + end else begin + failurereason := 'decoding name: read invalid char'; + result := ''; + exit; {invalid} + end; + until false; +end; + +{==============================================================================} + +procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate); +var + a:integer; +begin + state.resultaction := action_done; + state.resultstr := ''; + case trr(rrp.p^).requesttype of + querytype_a: begin + if htons(trr(rrp.p^).datalen) <> 4 then exit; + move(trr(rrp.p^).data,state.resultbin.ip,4); + state.resultbin.family :=AF_INET; + end; + {$ifdef ipv6} + querytype_aaaa: begin + if htons(trr(rrp.p^).datalen) <> 16 then exit; + state.resultbin.family := AF_INET6; + move(trr(rrp.p^).data,state.resultbin.ip6,16); + end; + {$endif} + else + {other reply types (PTR, MX) return a hostname} + state.resultstr := decodename(state.recvpacket,state.recvpacketlen,taddrint(rrp.p)-taddrint(@state.recvpacket)+10,0,a); + fillchar(state.resultbin,sizeof(state.resultbin),0); + end; +end; + +procedure setstate_request_init(const name:string;var state:tdnsstate); +begin + {destroy things properly} + state.resultstr := ''; + state.queryname := ''; + state.rrdata := ''; + fillchar(state,sizeof(state),0); + state.queryname := name; + state.parsepacket := false; +end; + +procedure setstate_forward(const name:string;var state:tdnsstate;family:integer); +begin + setstate_request_init(name,state); + state.forwardfamily := family; + {$ifdef ipv6} + if family = AF_INET6 then state.requesttype := querytype_aaaa else + {$endif} + state.requesttype := querytype_a; +end; + +procedure setstate_reverse(const binip:tbinip;var state:tdnsstate); +begin + setstate_request_init(makereversename(binip),state); + state.requesttype := querytype_ptr; +end; + +procedure setstate_failure(var state:tdnsstate); +begin + state.resultstr := ''; + fillchar(state.resultbin,sizeof(state.resultbin),0); + state.resultaction := action_done; +end; + +procedure state_process(var state:tdnsstate); +label recursed; +label failure; +var + a,b,ofs:integer; + rrtemp:^trr; + rrptemp:^trrpointer; +begin + if state.parsepacket then begin + if state.recvpacketlen < 12 then begin + failurereason := 'Undersized packet'; + state.resultaction := action_ignore; + exit; + end; + if state.id <> state.recvpacket.id then begin + failurereason := 'ID mismatch'; + state.resultaction := action_ignore; + exit; + end; + state.numrr2 := 0; + for a := 0 to 3 do begin + state.numrr1[a] := htons(state.recvpacket.rrcount[a]); + if state.numrr1[a] > maxrrofakind then goto failure; + inc(state.numrr2,state.numrr1[a]); + end; + + setlength(state.rrdata,state.numrr2*sizeof(trrpointer)); + + {- put all replies into a list} + + ofs := 12; + {get all queries} + for a := 0 to state.numrr1[0]-1 do begin + if (ofs < 12) or (ofs > state.recvpacketlen-4) then goto failure; + rrptemp := @state.rrdata[1+a*sizeof(trrpointer)]; + rrptemp.p := @state.recvpacket.payload[ofs-12]; + rrptemp.ofs := ofs; + decodename(state.recvpacket,state.recvpacketlen,ofs,0,b); + rrptemp.len := b + 4; + inc(ofs,rrptemp.len); + end; + + for a := state.numrr1[0] to state.numrr2-1 do begin + if (ofs < 12) or (ofs > state.recvpacketlen-12) then goto failure; + rrptemp := @state.rrdata[1+a*sizeof(trrpointer)]; + if decodename(state.recvpacket,state.recvpacketlen,ofs,0,b) = '' then goto failure; + rrtemp := @state.recvpacket.payload[ofs-12+b]; {rrtemp points to values and result, after initial name} + rrptemp.p := rrtemp; + rrptemp.ofs := ofs; {ofs is start of RR before initial name from start of packet} + rrptemp.namelen := b; + b := htons(rrtemp.datalen); + rrptemp.len := b + 10 + rrptemp.namelen; + inc(ofs,rrptemp.len); + end; + if (ofs <> state.recvpacketlen) then begin + failurereason := 'ofs <> state.packetlen'; + goto failure; + end; + + {- check for items of the requested type in answer section, if so return success first} + for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin + rrptemp := @state.rrdata[1+a*sizeof(trrpointer)]; + rrtemp := rrptemp.p; + b := rrptemp.len; + if rrtemp.requesttype = state.requesttype then begin + setstate_return(rrptemp^,b,state); + exit; + end; + end; + + {if no items of correct type found, follow first cname in answer section} + for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin + rrptemp := @state.rrdata[1+a*sizeof(trrpointer)]; + rrtemp := rrptemp.p; + b := rrptemp.len; + if rrtemp.requesttype = querytype_cname then begin + state.queryname := decodename(state.recvpacket,state.recvpacketlen,rrptemp.ofs+12,0,b); + goto recursed; + end; + end; + + {no cnames found, no items of correct type found} + if state.forwardfamily <> 0 then goto failure; +{$ifdef ipv6} + if (state.requesttype = querytype_a) then begin + {v6 only: in case of forward, look for AAAA in alternative section} + for a := state.numrr1[0]+state.numrr1[1]+state.numrr1[2] to (state.numrr2-1) do begin + rrptemp := @state.rrdata[1+a*sizeof(trrpointer)]; + rrtemp := rrptemp.p; + b := rrptemp.len; + if rrtemp.requesttype = querytype_aaaa then begin + setstate_return(rrptemp^,b,state); + exit; + end; + end; + {no AAAA's found in alternative, do a recursive lookup for them} + state.requesttype := querytype_aaaa; + goto recursed; + end; +{$endif} + goto failure; +recursed: + {here it needs recursed lookup} + {if needing to follow a cname, change state to do so} + inc(state.recursioncount); + if state.recursioncount > maxrecursion then goto failure; + end; + + {here, a name needs to be resolved} + if state.queryname = '' then begin + failurereason := 'empty query name'; + goto failure; + end; + + {do /ets/hosts lookup here} + state.sendpacketlen := buildrequest(state.queryname,state.sendpacket,state.requesttype); + if state.sendpacketlen = 0 then begin + failurereason := 'building request packet failed'; + goto failure; + end; + state.id := state.sendpacket.id; + state.resultaction := action_sendquery; + + exit; +failure: + setstate_failure(state); +end; +{$ifdef win32} + const + MAX_HOSTNAME_LEN = 132; + MAX_DOMAIN_NAME_LEN = 132; + MAX_SCOPE_ID_LEN = 260 ; + MAX_ADAPTER_NAME_LENGTH = 260; + MAX_ADAPTER_ADDRESS_LENGTH = 8; + MAX_ADAPTER_DESCRIPTION_LENGTH = 132; + ERROR_BUFFER_OVERFLOW = 111; + MIB_IF_TYPE_ETHERNET = 6; + MIB_IF_TYPE_TOKENRING = 9; + MIB_IF_TYPE_FDDI = 15; + MIB_IF_TYPE_PPP = 23; + MIB_IF_TYPE_LOOPBACK = 24; + MIB_IF_TYPE_SLIP = 28; + + + type + tip_addr_string=packed record + Next :pointer; + IpAddress : array[0..15] of char; + ipmask : array[0..15] of char; + context : dword; + end; + pip_addr_string=^tip_addr_string; + tFIXED_INFO=packed record + HostName : array[0..MAX_HOSTNAME_LEN-1] of char; + DomainName : array[0..MAX_DOMAIN_NAME_LEN-1] of char; + currentdnsserver : pip_addr_string; + dnsserverlist : tip_addr_string; + nodetype : longint; + ScopeId : array[0..MAX_SCOPE_ID_LEN + 4] of char; + enablerouting : longbool; + enableproxy : longbool; + enabledns : longbool; + end; + pFIXED_INFO=^tFIXED_INFO; + + var + iphlpapi : thandle; + getnetworkparams : function(pFixedInfo : PFIXED_INFO;OutBufLen : plongint) : longint;stdcall; +{$endif} +procedure populatednsserverlist; +var + {$ifdef win32} + fixed_info : pfixed_info; + fixed_info_len : longint; + currentdnsserver : pip_addr_string; + {$else} + t:textfile; + s:string; + a:integer; + {$endif} +begin + //result := ''; + if assigned(dnsserverlist) then begin + dnsserverlist.clear; + end else begin + dnsserverlist := tstringlist.Create; + end; + {$ifdef win32} + if iphlpapi=0 then iphlpapi := loadlibrary('iphlpapi.dll'); + if not assigned(getnetworkparams) then @getnetworkparams := getprocaddress(iphlpapi,'GetNetworkParams'); + fixed_info_len := 0; + if GetNetworkParams(nil,@fixed_info_len)<>ERROR_BUFFER_OVERFLOW then exit; + //fixed_info_len :=sizeof(tfixed_info); + getmem(fixed_info,fixed_info_len); + if GetNetworkParams(fixed_info,@fixed_info_len)<>0 then begin + freemem(fixed_info); + exit; + end; + currentdnsserver := @(fixed_info.dnsserverlist); + while assigned(currentdnsserver) do begin + dnsserverlist.Add(currentdnsserver.IpAddress); + currentdnsserver := currentdnsserver.next; + end; + freemem(fixed_info); + {$else} + filemode := 0; + assignfile(t,'/etc/resolv.conf'); + {$i-}reset(t);{$i+} + if ioresult <> 0 then exit; + + while not eof(t) do begin + readln(t,s); + if not (copy(s,1,10) = 'nameserver') then continue; + s := copy(s,11,500); + while s <> '' do begin + if (s[1] = #32) or (s[1] = #9) then s := copy(s,2,500) else break; + end; + a := pos(' ',s); + if a <> 0 then s := copy(s,1,a-1); + a := pos(#9,s); + if a <> 0 then s := copy(s,1,a-1); + //result := s; + //if result <> '' then break; + dnsserverlist.Add(s); + end; + close(t); + {$endif} +end; + +procedure cleardnsservercache; +begin + if assigned(dnsserverlist) then begin + dnsserverlist.destroy; + dnsserverlist := nil; + end; +end; + +function getcurrentsystemnameserver(var id:integer):string; +var + counter : integer; + +begin + if not assigned(dnsserverlist) then populatednsserverlist; + if dnsserverlist.count=0 then raise exception.create('no dns servers availible'); + id := 0; + if dnsserverlist.count >1 then begin + + for counter := 1 to dnsserverlist.count-1 do begin + if taddrint(dnsserverlist.objects[counter]) < taddrint(dnsserverlist.objects[id]) then id := counter; + end; + end; + result := dnsserverlist[id] +end; + +procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout +var + counter : integer; + temp : integer; +begin + if (id < 0) or (id >= dnsserverlist.count) then exit; + if lag = -1 then lag := timeoutlag; + for counter := 0 to dnsserverlist.count-1 do begin + temp := taddrint(dnsserverlist.objects[counter]) *15; + if counter=id then temp := temp + lag; + dnsserverlist.objects[counter] := tobject(temp div 16); + end; + +end; + +{ quick and dirty description of dns packet structure to aid writing and + understanding of parser code, refer to appropriate RFCs for proper specs +- all words are network order + +www.google.com A request: + +0, 2: random transaction ID +2, 2: flags: only the "recursion desired" bit set. (bit 8 of word) +4, 2: questions: 1 +6, 2: answer RR's: 0. +8, 2: authority RR's: 0. +10, 2: additional RR's: 0. +12, n: payload: + query: + #03 "www" #06 "google" #03 "com" #00 + size-4, 2: type: host address (1) + size-2, 2: class: inet (1) + +reply: + +0,2: random transaction ID +2,2: flags: set: response (bit 15), recursion desired (8), recursion available (7) +4,4: questions: 1 +6,4: answer RR's: 2 +8,4: authority RR's: 9 +10,4: additional RR's: 9 +12: payload: + query: + .... + answer: CNAME + 0,2 "c0 0c" "name: www.google.com" + 2,2 "00 05" "type: cname for an alias" + 4,2 "00 01" "class: inet" + 6,4: TTL + 10,2: data length "00 17" (23) + 12: the cname name (www.google.akadns.net) + answer: A + 0,2 .. + 2,2 "00 01" host address + 4,2 ... + 6,4 ... + 10,2: data length (4) + 12,4: binary IP + authority - 9 records + additional - 9 records + + + ipv6 AAAA reply: + 0,2: ... + 2,2: type: 001c + 4,2: class: inet (0001) + 6,2: TTL + 10,2: data size (16) + 12,16: binary IP + + ptr request: query type 000c + +name compression: word "cxxx" in the name, xxx points to offset in the packet} + +end. diff --git a/dnssync.pas b/dnssync.pas new file mode 100755 index 0000000..379aa05 --- /dev/null +++ b/dnssync.pas @@ -0,0 +1,262 @@ +{ 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 + ----------------------------------------------------------------------------- } +unit dnssync; +{$ifdef fpc} + {$mode delphi} +{$endif} + +interface + uses + dnscore, + binipstuff, + {$ifdef win32} + winsock, + windows, + {$else} + {$ifdef VER1_0} + linux, + {$else} + baseunix,unix,unixutil, + {$endif} + sockets, + fd_utils, + {$endif} + sysutils; + +//convert a name to an IP +//IPV4 is preffered if availible, if not IPV6 will be returned (if ipv6 support +//compiled in) +//on error the binip will have a family of 0 (other fiels are also currently +//zeroed out but may be used for further error information in future) +//timeout is in seconds, it is ignored when using windows dns +function forwardlookup(name:string;timeout:integer):tbinip; + + +//convert an IP to a name, on error a null string will be returned, other +//details as above +function reverselookup(ip:tbinip;timeout:integer):string; + + +var + dnssyncserver:string; + id : integer; + {$ifdef win32} + sendquerytime : integer; + {$else} + sendquerytime : ttimeval; + {$endif} +implementation +{$ifdef win32} + uses dnswin; +{$endif} + +{$i unixstuff.inc} +{$i ltimevalstuff.inc} + +var + fd:integer; + state:tdnsstate; +{$ifdef win32} + const + winsocket = 'wsock32.dll'; + function sendto(s: TSocket; const Buf; len, flags: Integer; var addrto: TinetSockAddr; tolen: Integer): Integer; stdcall; external winsocket name 'sendto'; + function bind(s: TSocket; var addr: TinetSockAddr; namelen: Integer): Longbool; stdcall; external winsocket name 'bind'; + type + fdset=tfdset; +{$endif} + +function sendquery(const packet:tdnspacket;len:integer):boolean; +var + a:integer; + addr : string; + port : string; + inaddr : TInetSockAddr; + +begin +{ writeln('sendquery ',decodename(state.packet,state.packetlen,12,0,a),' ',state.requesttype);} + result := false; + if len = 0 then exit; {no packet} + + if dnssyncserver <> '' then addr := dnssyncserver else addr := getcurrentsystemnameserver(id); + port := '53'; + + inAddr.family:=AF_INET; + inAddr.port:=htons(strtointdef(port,0)); + inAddr.addr:=htonl(longip(addr)); + + sendto(fd,packet,len,0,inaddr,sizeof(inaddr)); + {$ifdef win32} + sendquerytime := GetTickCount and $3fff; + {$else} + gettimeofday(sendquerytime); + {$endif} + result := true; +end; + +procedure setupsocket; +var + inAddrtemp : TInetSockAddr; +begin + if fd > 0 then exit; + + fd := Socket(AF_INET,SOCK_DGRAM,0); + inAddrtemp.family:=AF_INET; + inAddrtemp.port:=0; + inAddrtemp.addr:=0;{htonl(longip('0.0.0.0'));} + If {$ifndef win32}Not{$endif} Bind(fd,inAddrtemp,SizeOf(inAddrtemp)) Then begin + {$ifdef win32} + raise Exception.create('unable to bind '+inttostr(WSAGetLastError)); + {$else} + raise Exception.create('unable to bind '+inttostr(socketError)); + {$endif} + end; +end; + +procedure resolveloop(timeout:integer); +var + selectresult : integer; + fds : fdset; + {$ifdef win32} + endtime : longint; + starttime : longint; + wrapmode : boolean; + currenttime : integer; + {$else} + endtime : ttimeval; + currenttime : ttimeval; + + {$endif} + lag : ttimeval; + currenttimeout : ttimeval; + selecttimeout : ttimeval; + + +begin + {$ifdef win32} + starttime := GetTickCount and $3fff; + endtime := starttime +(timeout*1000); + if (endtime and $4000)=0 then begin + wrapmode := false; + end else begin + wrapmode := true; + end; + endtime := endtime and $3fff; + {$else} + gettimeofday(endtime); + endtime.tv_sec := endtime.tv_sec + timeout; + {$endif} + + setupsocket; + repeat + state_process(state); + case state.resultaction of + action_ignore: begin +{ writeln('ignore');} + {do nothing} + end; + action_done: begin +{ writeln('done');} + exit; + //onrequestdone(self,0); + end; + action_sendquery:begin +{ writeln('send query');} + sendquery(state.sendpacket,state.sendpacketlen); + end; + end; + {$ifdef win32} + currenttime := GetTickCount and $3fff; + msectotimeval(selecttimeout, (endtime-currenttime)and$3fff); + {$else} + gettimeofday(currenttime); + selecttimeout := endtime; + tv_substract(selecttimeout,currenttime); + {$endif} + fd_zero(fds); + fd_set(fd,fds); + if (selecttimeout.tv_sec > 0) or (selecttimeout.tv_usec > retryafter) then begin + selecttimeout.tv_sec := 0; + selecttimeout.tv_usec := retryafter; + end; + selectresult := select(fd+1,@fds,nil,nil,@selecttimeout); + if selectresult > 0 then begin +{ writeln('selectresult>0');} + //why the hell are we zeroing out the packet buffer before reading into it?! --plugwash + fillchar(state.recvpacket,sizeof(state.recvpacket),0); + {$ifdef win32} + msectotimeval(lag,(currenttime-sendquerytime)and$3fff); + {$else} + lag := currenttime; + tv_substract(lag,sendquerytime); + + {$endif} + + reportlag(id,(lag.tv_sec*1000000)+lag.tv_usec); + state.recvpacketlen := recv(fd,state.recvpacket, SizeOf(state.recvpacket),0); + state.parsepacket := true; + end; + if selectresult < 0 then exit; + if selectresult = 0 then begin + {$ifdef win32} + currenttime := GetTickCount; + {$else} + gettimeofday(currenttime); + {$endif} + reportlag(id,-1); + if {$ifdef win32}(currenttime >= endtime)and ((not wrapmode) or (currenttime < starttime)) {$else}tv_compare(currenttime,endtime){$endif} {currenttime >= endtime } then begin + exit; + end else begin + //resend + sendquery(state.sendpacket,state.sendpacketlen); + end; + end; + until false; +end; + +function forwardlookup(name:string;timeout:integer):tbinip; +var + dummy : integer; +begin + ipstrtobin(name,result); + if result.family <> 0 then exit; //it was an IP address, no need for dns + //lookup + {$ifdef win32} + if usewindns then begin + result := winforwardlookup(name,false,dummy); + exit; + end; + {$endif} + setstate_forward(name,state,0); + resolveloop(timeout); + result := state.resultbin; +end; + +function reverselookup(ip:tbinip;timeout:integer):string; +var + dummy : integer; +begin + {$ifdef win32} + if usewindns then begin + result := winreverselookup(ip,dummy); + exit; + end; + {$endif} + setstate_reverse(ip,state); + resolveloop(timeout); + result := state.resultstr; +end; + +{$ifdef win32} + var + wsadata : twsadata; + + initialization + WSAStartUp($2,wsadata); + finalization + WSACleanUp; +{$endif} +end. + + diff --git a/dnswin.pas b/dnswin.pas new file mode 100755 index 0000000..7d986d1 --- /dev/null +++ b/dnswin.pas @@ -0,0 +1,332 @@ +unit dnswin; + +interface +uses binipstuff,classes,lcore; + +//on failure a null string or zeroed out binip will be retuned and error will be +//set to a windows error code (error will be left untouched under non error +//conditions). +function winforwardlookup(name : string;ipv6preffered : boolean;var error:integer) : tbinip; +function winreverselookup(ip:tbinip;var error:integer):string; + + +type + //do not call destroy on a tdnswinasync instead call release and the + //dnswinasync will be freed when appropriate. Calling destroy will block + //the calling thread until the dns lookup completes. + //release should only be called from the main thread + tdnswinasync=class(tthread) + private + ipv6preffered : boolean; + freverse : boolean; + error : integer; + freewhendone : boolean; + hadevent : boolean; + protected + procedure execute; override; + public + onrequestdone:tsocketevent; + name : string; + ip : tbinip; + + procedure forwardlookup(name:string;ipv6preffered:boolean); + procedure reverselookup(ip:tbinip); + destructor destroy; override; + procedure release; + constructor create; + property reverse : boolean read freverse; + + end; + +implementation +uses + lsocket,pgtypes,sysutils,winsock,windows,messages; + +type + //taddrinfo = record; //forward declaration + paddrinfo = ^taddrinfo; + taddrinfo = packed record + ai_flags : longint; + ai_family : longint; + ai_socktype : longint; + ai_protocol : longint; + ai_addrlen : taddrint; + ai_canonname : pchar; + ai_addr : pinetsockaddrv; + ai_next : paddrinfo; + end; + ppaddrinfo = ^paddrinfo; + tgetaddrinfo = function(nodename : pchar; servname : pchar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall; + tfreeaddrinfo = procedure(ai : paddrinfo); stdcall; + tgetnameinfo = function(sa:Pinetsockaddrv;salen : longint; host:pchar;hostlen : longint;serv:pchar;servlen:longint;flags:longint) : longint;stdcall; +var + getaddrinfo : tgetaddrinfo; + freeaddrinfo : tfreeaddrinfo; + getnameinfo : tgetnameinfo; +procedure v4onlyfreeaddrinfo(ai : paddrinfo); stdcall; +begin + freemem(ai.ai_addr); + freemem(ai); +end; + +type + plongint = ^longint; + pplongint = ^plongint; + +function v4onlygetaddrinfo(nodename : pchar; servname : pchar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall; +var + output : paddrinfo; + hostent : phostent; +begin + if hints.ai_family = af_inet then begin + result := 0; + getmem(output,sizeof(taddrinfo)); + getmem(output.ai_addr,sizeof(tinetsockaddr)); + output.ai_addr.InAddr.family := af_inet; + if servname <> nil then output.ai_addr.InAddr.port := htons(strtoint(servname)) else output.ai_addr.InAddr.port := 0; + hostent := gethostbyname(nodename); + if hostent = nil then begin + result := wsagetlasterror; + v4onlyfreeaddrinfo(output); + exit; + end; + output.ai_addr.InAddr.addr := pplongint(hostent.h_addr_list)^^; + output.ai_flags := 0; + output.ai_family := af_inet; + output.ai_socktype := 0; + output.ai_protocol := 0; + output.ai_addrlen := sizeof(tinetsockaddr); + output.ai_canonname := nil; + output.ai_next := nil; + + res^ := output; + end else begin + result := WSANO_RECOVERY; + end; +end; + +function min(a,b : integer):integer; +begin + if a 0 then begin + fillchar(result,0,sizeof(result)); + error := getaddrinforesult; + end; +end; + +function winreverselookup(ip:tbinip;var error : integer):string; +var + sa : tinetsockaddrv; + getnameinforesult : integer; +begin + + if ip.family = AF_INET then begin + sa.InAddr.family := AF_INET; + sa.InAddr.port := 1; + sa.InAddr.addr := ip.ip; + end else {$ifdef ipv6}if ip.family = AF_INET6 then begin + sa.InAddr6.sin6_family := AF_INET6; + sa.InAddr6.sin6_port := 1; + sa.InAddr6.sin6_addr := ip.ip6; + end else{$endif} begin + raise exception.create('unrecognised address family'); + end; + populateprocvars; + setlength(result,1025); + getnameinforesult := getnameinfo(@sa,sizeof(tinetsockaddrv),pchar(result),length(result),nil,0,0); + if getnameinforesult <> 0 then begin + error := getnameinforesult; + result := ''; + exit; + end; + if pos(#0,result) >= 0 then begin + setlength(result,pos(#0,result)-1); + end; +end; + +var + hwnddnswin : hwnd; + +function MyWindowProc( + ahWnd : HWND; + auMsg : Integer; + awParam : WPARAM; + alParam : LPARAM): Integer; stdcall; +var + dwas : tdnswinasync; +begin + if (ahwnd=hwnddnswin) and (aumsg=wm_user) then begin + Dwas := tdnswinasync(alparam); + if assigned (dwas.onrequestdone) then dwas.onrequestdone(dwas,awparam); + dwas.hadevent := true; + if dwas.freewhendone then dwas.free; + end else begin + //not passing unknown messages on to defwindowproc will cause window + //creation to fail! --plugwash + Result := DefWindowProc(ahWnd, auMsg, awParam, alParam) + end; +end; + +procedure tdnswinasync.forwardlookup(name:string;ipv6preffered:boolean); +begin + self.name := name; + self.ipv6preffered := ipv6preffered; + freverse := false; + resume; +end; +procedure tdnswinasync.reverselookup(ip:tbinip); +begin + self.ip := ip; + freverse := true; + resume; +end; +procedure tdnswinasync.execute; +var + error : integer; +begin + error := 0; + if reverse then begin + name := winreverselookup(ip,error); + end else begin + ip := winforwardlookup(name,ipv6preffered,error); + + end; + + postmessage(hwnddnswin,wm_user,error,taddrint(self)); +end; + +destructor tdnswinasync.destroy; +begin + WaitFor; + inherited destroy; +end; +procedure tdnswinasync.release; +begin + if hadevent then destroy else begin + onrequestdone := nil; + freewhendone := true; + end; +end; + +constructor tdnswinasync.create; +begin + inherited create(true); +end; + +var + MyWindowClass : TWndClass = (style : 0; + lpfnWndProc : @MyWindowProc; + cbClsExtra : 0; + cbWndExtra : 0; + hInstance : 0; + hIcon : 0; + hCursor : 0; + hbrBackground : 0; + lpszMenuName : nil; + lpszClassName : 'dnswinClass'); +begin + + if Windows.RegisterClass(MyWindowClass) = 0 then halt; + //writeln('about to create lcore handle, hinstance=',hinstance); + hwnddnswin := CreateWindowEx(WS_EX_TOOLWINDOW, + MyWindowClass.lpszClassName, + '', { Window name } + WS_POPUP, { Window Style } + 0, 0, { X, Y } + 0, 0, { Width, Height } + 0, { hWndParent } + 0, { hMenu } + HInstance, { hInstance } + nil); { CreateParam } + //writeln('dnswin hwnd is ',hwnddnswin); + //writeln('last error is ',GetLastError); +end. diff --git a/fd_utils.pas b/fd_utils.pas new file mode 100755 index 0000000..ea6e833 --- /dev/null +++ b/fd_utils.pas @@ -0,0 +1,74 @@ +// this file contains code copied from linux.pp in the free pascal rtl +// i had to copy them because i use a different definition of fdset to them +// the copyright block from the file in question is shown below +{ + $Id: fd_utils.pas,v 1.2 2004/08/19 23:12:09 plugwash Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Michael Van Canneyt, + BSD parts (c) 2000 by Marco van de Voort + members of the Free Pascal development team. + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY;without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +**********************************************************************} +{$ifdef fpc} + {$mode delphi} + {$inlining on} +{$endif} +unit fd_utils; +interface + +type + FDSet= Array [0..255] of longint; {31} + PFDSet= ^FDSet; +const + absoloutemaxs=(sizeof(fdset)*8)-1; + +Procedure FD_Clr(fd:longint;var fds:fdSet); +Procedure FD_Zero(var fds:fdSet); +Procedure FD_Set(fd:longint;var fds:fdSet); +Function FD_IsSet(fd:longint;var fds:fdSet):boolean; + +{$ifdef fpc} + {$ifndef ver1_0} + {$define useinline} + {$endif} +{$endif} + +implementation +uses sysutils; +Procedure FD_Clr(fd:longint;var fds:fdSet);{$ifdef useinline}inline;{$endif} +{ Remove fd from the set of filedescriptors} +begin + if (fd < 0) then raise exception.create('FD_Clr fd out of range: '+inttostr(fd)); + fds[fd shr 5]:=fds[fd shr 5] and (not (1 shl (fd and 31))); +end; + +Procedure FD_Zero(var fds:fdSet); +{ Clear the set of filedescriptors } +begin + FillChar(fds,sizeof(fdSet),0); +end; + +Procedure FD_Set(fd:longint;var fds:fdSet);{$ifdef useinline}inline;{$endif} +{ Add fd to the set of filedescriptors } +begin + if (fd < 0) then raise exception.create('FD_set fd out of range: '+inttostr(fd)); + fds[fd shr 5]:=fds[fd shr 5] or (1 shl (fd and 31)); +end; + +Function FD_IsSet(fd:longint;var fds:fdSet):boolean;{$ifdef useinline}inline;{$endif} +{ Test if fd is part of the set of filedescriptors } +begin + if (fd < 0) then begin + result := false; + exit; + end; + FD_IsSet:=((fds[fd shr 5] and (1 shl (fd and 31)))<>0); +end; +end. diff --git a/httpserver_20080306/bfifo.pas b/httpserver_20080306/bfifo.pas new file mode 100755 index 0000000..55cc24a --- /dev/null +++ b/httpserver_20080306/bfifo.pas @@ -0,0 +1,148 @@ +{ 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 + ----------------------------------------------------------------------------- } +unit bfifo; +{$ifdef fpc} + {$mode delphi} +{$endif} + +interface + +uses blinklist,pgtypes; + +const + pagesize=1420; + +type + tfifo=class(tobject) + private + l:tlinklist; {add to} + getl:tlinklist; {remove from} + ofs:integer; + getofs:integer; + public + size:integer; + procedure add(data:pointer;len:integer); + function get(var resultptr:pointer;len:integer):integer; + procedure del(len:integer); + constructor create; + destructor destroy; override; + end; + + +implementation + +var + testcount:integer; + +{ + +xx1..... add +xxxxxxxx +....2xxx delete + +1 ofs +2 getofs + +} + +procedure tfifo.add; +var + a:integer; + p:tlinklist; +begin + if len <= 0 then exit; + inc(size,len); + while len > 0 do begin + p := l; + if ofs = pagesize then begin + p := tplinklist.create; + if getl = nil then getl := p; + getmem(tplinklist(p).p,pagesize); + inc(testcount); + linklistadd(l,p); + ofs := 0; + end; + a := pagesize - ofs; + if len < a then a := len; + move(data^,pointer(taddrint(tplinklist(p).p)+ofs)^,a); + inc(taddrint(data),a); + dec(len,a); + inc(ofs,a); + end; +end; + +function tfifo.get; +var + p:tlinklist; + a:integer; +begin + if len > size then len := size; + if len <= 0 then begin + result := 0; + resultptr := nil; + exit; + end; + p := getl; + resultptr := pointer(taddrint(tplinklist(p).p)+getofs); + result := pagesize-getofs; + if result > len then result := len; +end; + +procedure tfifo.del; +var + a:integer; + p,p2:tlinklist; +begin + if len <= 0 then exit; + p := getl; + if len > size then len := size; + dec(size,len); + + if len = 0 then exit; + + while len > 0 do begin + a := pagesize-getofs; + if a > len then a := len; + inc(getofs,a); + dec(len,a); + if getofs = pagesize then begin + p2 := p.prev; + freemem(tplinklist(p).p); + dec(testcount); + linklistdel(l,p); + p.destroy; + p := p2; + getl := p; + getofs := 0; + end; + end; + + if size = 0 then begin + if assigned(l) then begin + p := l; + freemem(tplinklist(p).p); + dec(testcount); + linklistdel(l,p); + p.destroy; + getl := nil; + end; + ofs := pagesize; + getofs := 0; + end; +end; + +constructor tfifo.create; +begin + ofs := pagesize; + inherited create; +end; + +destructor tfifo.destroy; +begin + del(size); + inherited destroy; +end; + +end. diff --git a/httpserver_20080306/binipstuff.pas b/httpserver_20080306/binipstuff.pas new file mode 100755 index 0000000..ebb9f9c --- /dev/null +++ b/httpserver_20080306/binipstuff.pas @@ -0,0 +1,395 @@ +{ 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 + ----------------------------------------------------------------------------- } +unit binipstuff; + +interface + +{$ifndef win32} +{$ifdef ipv6} +uses sockets; +{$endif} +{$endif} + +{$ifdef fpc} + {$mode delphi} +{$endif} +{$ifdef cpu386}{$define i386}{$endif} +{$ifdef i386}{$define ENDIAN_LITTLE}{$endif} + +{$include uint32.inc} + +const + hexchars:array[0..15] of char='0123456789abcdef'; + AF_INET=2; + {$ifdef win32} + AF_INET6=23; + {$else} + AF_INET6=10; + {$endif} + +type + {$ifdef ipv6} + + {$ifdef win32} + {$define want_Tin6_addr} + {$endif} + {$ifdef ver1_0} + {$define want_Tin6_addr} + {$endif} + {$ifdef want_Tin6_addr} + Tin6_addr = packed record + case byte of + 0: (u6_addr8 : array[0..15] of byte); + 1: (u6_addr16 : array[0..7] of Word); + 2: (u6_addr32 : array[0..3] of uint32); + 3: (s6_addr8 : array[0..15] of shortint); + 4: (s6_addr : array[0..15] of shortint); + 5: (s6_addr16 : array[0..7] of smallint); + 6: (s6_addr32 : array[0..3] of LongInt); + end; + {$endif} + {$endif} + + tbinip=record + family:integer; + {$ifdef ipv6} + case integer of + 0: (ip:longint); + 1: (ip6:tin6_addr); + {$else} + ip:longint; + {$endif} + end; + + {$ifdef win32} + TInetSockAddr = packed Record + family:Word; + port :Word; + addr :uint32; + pad :array [1..8] of byte; + end; + {$ifdef ipv6} + + TInetSockAddr6 = packed record + sin6_family: word; + sin6_port: word; + sin6_flowinfo: uint32; + sin6_addr: tin6_addr; + sin6_scope_id: uint32; + end; + {$endif} + {$endif} + +function htons(w:word):word; +function htonl(i:uint32):uint32; + +function ipstrtobin(const s:string;var binip:tbinip):boolean; +function ipbintostr(const binip:tbinip):string; +{$ifdef ipv6} +function ip6bintostr(const bin:tin6_addr):string; +function ip6strtobin(const s:string;var bin:tin6_addr):boolean; +{$endif} + +function comparebinip(const ip1,ip2:tbinip):boolean; + +{deprecated} +function longip(s:string):longint; + +procedure converttov4(var ip:tbinip); + +implementation + +uses sysutils; + +function htons(w:word):word; +begin + {$ifdef ENDIAN_LITTLE} + result := ((w and $ff00) shr 8) or ((w and $ff) shl 8); + {$else} + result := w; + {$endif} +end; + +function htonl(i:uint32):uint32; +begin + {$ifdef ENDIAN_LITTLE} + result := (i shr 24) or (i shr 8 and $ff00) or (i shl 8 and $ff0000) or (i shl 24 and $ff000000); + {$else} + result := i; + {$endif} +end; + +{internal} +{converts dotted v4 IP to longint. returns host endian order} +function longip(s:string):longint; +var + l:longint; + a,b:integer; +function convertbyte(const s:string):integer; +begin + result := strtointdef(s,-1); + if result < 0 then begin + result := -1; + exit; + end; + if result > 255 then begin + result := -1; + exit; + end; + {01 exception} + if (result <> 0) and (s[1] = '0') then begin + result := -1; + exit; + end; + {+1 exception} + if not (s[1] in ['0'..'9']) then begin + result := -1; + exit + end; +end; + +begin + result := 0; + a := pos('.',s); + if a = 0 then exit; + b := convertbyte(copy(s,1,a-1));if (b < 0) then exit; + l := b shl 24; + s := copy(s,a+1,256); + a := pos('.',s); + if a = 0 then exit; + b := convertbyte(copy(s,1,a-1));if (b < 0) then exit; + l := l or b shl 16; + s := copy(s,a+1,256); + a := pos('.',s); + if a = 0 then exit; + b := convertbyte(copy(s,1,a-1));if (b < 0) then exit; + l := l or b shl 8; + s := copy(s,a+1,256); + b := convertbyte(copy(s,1,256));if (b < 0) then exit; + l := l or b; + result := l; +end; + + +function ipstrtobin(const s:string;var binip:tbinip):boolean; +begin + binip.family := 0; + result := false; + {$ifdef ipv6} + if pos(':',s) <> 0 then begin + {try ipv6. use builtin routine} + result := ip6strtobin(s,binip.ip6); + if result then binip.family := AF_INET6; + exit; + end; + {$endif} + + {try v4} + binip.ip := htonl(longip(s)); + if (binip.ip <> 0) or (s = '0.0.0.0') then begin + result := true; + binip.family := AF_INET; + exit; + end; +end; + +function ipbintostr(const binip:tbinip):string; +var + a:integer; +begin + result := ''; + {$ifdef ipv6} + if binip.family = AF_INET6 then begin + result := ip6bintostr(binip.ip6); + end else + {$endif} + if binip.family = AF_INET then begin + a := htonl(binip.ip); + result := inttostr(a shr 24)+'.'+inttostr((a shr 16) and $ff)+'.'+inttostr((a shr 8) and $ff)+'.'+inttostr(a and $ff); + end; +end; + + +{------------------------------------------------------------------------------} + +{$ifdef ipv6} + +{ +IPv6 address binary to/from string conversion routines +written by beware (steendijk at xs4all dot nl) + +- implementation does not depend on other ipv6 code such as the tin6_addr type, + the parameter can also be untyped. +- it is host endian neutral - binary format is aways network order +- it supports compression of zeroes +- it supports ::ffff:192.168.12.34 style addresses +- they are made to do the Right Thing, more efficient implementations are possible +} + +{fpc has hostaddrtostr6 and strtohostaddr6 but the later isnt implemented yet} + + +function ip6bintostr(const bin:tin6_addr):string; +{base16 with lowercase output} +function makehex(w:word):string; +begin + result := ''; + if w >= 4096 then result := result + hexchars[w shr 12]; + if w >= 256 then result := result + hexchars[w shr 8 and $f]; + if w >= 16 then result := result + hexchars[w shr 4 and $f]; + result := result + hexchars[w and $f]; +end; + +var + a,b,c,addrlen:integer; + runbegin,runlength:integer; + bytes:array[0..15] of byte absolute bin; + words:array[0..7] of word; + dwords:array[0..3] of integer absolute words; +begin + for a := 0 to 7 do begin + words[a] := bytes[a shl 1] shl 8 or bytes[a shl 1 or 1]; + end; + if (dwords[0] = 0) and (dwords[1] = 0) and (words[4] = 0) and (words[5] = $ffff) then begin + {::ffff:/96 exception: v4 IP} + addrlen := 6; + end else begin + addrlen := 8; + end; + {find longest run of zeroes} + runbegin := 0; + runlength := 0; + for a := 0 to addrlen-1 do begin + if words[a] = 0 then begin + c := 0; + for b := a to addrlen-1 do if words[b] = 0 then begin + inc(c); + end else break; + if (c > runlength) then begin + runlength := c; + runbegin := a; + end; + end; + end; + result := ''; + for a := 0 to runbegin-1 do begin + if (a <> 0) then result := result + ':'; + result := result + makehex(words[a]); + end; + if runlength > 0 then result := result + '::'; + c := runbegin+runlength; + for a := c to addrlen-1 do begin + if (a > c) then result := result + ':'; + result := result + makehex(words[a]); + end; + if addrlen = 6 then begin + result := result + ':'+inttostr(bytes[12])+'.'+inttostr(bytes[13])+'.'+inttostr(bytes[14])+'.'+inttostr(bytes[15]); + end; +end; + +function ip6strtobin(const s:string;var bin:tin6_addr):boolean; +var + a,b:integer; + fields:array[0..7] of string; + fieldcount:integer; + emptyfield:integer; + wordcount:integer; + words:array[0..7] of word; + bytes:array[0..15] of byte absolute bin; +begin + result := false; + for a := 0 to 7 do fields[a] := ''; + fieldcount := 0; + for a := 1 to length(s) do begin + if s[a] = ':' then inc(fieldcount) else fields[fieldcount] := fields[fieldcount] + s[a]; + if fieldcount > 7 then exit; + end; + if fieldcount < 2 then exit; + + {find the empty field (compressed zeroes), not counting the first and last there may be at most 1} + emptyfield := -1; + for a := 1 to fieldcount-1 do begin + if fields[a] = '' then begin + if emptyfield = -1 then emptyfield := a else exit; + end; + end; + + {check if last field is a valid v4 IP} + a := longip(fields[fieldcount]); + if (a <> 0) or (fields[fieldcount] = '0.0.0.0') then wordcount := 6 else wordcount := 8; + {0:1:2:3:4:5:6.6.6.6 + 0:1:2:3:4:5:6:7} + fillchar(words,sizeof(words),0); + if wordcount = 6 then begin + if fieldcount > 6 then exit; + words[6] := a shr 16; + words[7] := a and $ffff; + end; + if emptyfield = -1 then begin + {no run length: must be an exact number of fields} + if wordcount = 6 then begin + if fieldcount <> 6 then exit; + emptyfield := 5; + end else if wordcount = 8 then begin + if fieldcount <> 7 then exit; + emptyfield := 7; + end else exit; + end; + for a := 0 to emptyfield do begin + if fields[a] = '' then b := 0 else b := strtointdef('$'+fields[a],-1); + if (b < 0) or (b > $ffff) then exit; + words[a] := b; + end; + if wordcount = 6 then dec(fieldcount); + for a := wordcount-1 downto wordcount-(fieldcount-emptyfield) do begin + b := a+fieldcount-wordcount+1; + if fields[b] = '' then b := 0 else b := strtointdef('$'+fields[b],-1); + if (b < 0) or (b > $ffff) then exit; + words[a] := b; + end; + for a := 0 to 7 do begin + bytes[a shl 1] := words[a] shr 8; + bytes[a shl 1 or 1] := words[a] and $ff; + end; + result := true; +end; +{$endif} + +function comparebinip(const ip1,ip2:tbinip):boolean; +begin + if (ip1.ip <> ip2.ip) then begin + result := false; + exit; + end; + + {$ifdef ipv6} + if ip1.family = AF_INET6 then begin + if (ip1.ip6.s6_addr32[1] <> ip2.ip6.s6_addr32[1]) + or (ip1.ip6.s6_addr32[2] <> ip2.ip6.s6_addr32[2]) + or (ip1.ip6.s6_addr32[3] <> ip2.ip6.s6_addr32[3]) then begin + result := false; + exit; + end; + end; + {$endif} + + result := (ip1.family = ip2.family); +end; + +{converts a binary IP to v4 if it is a v6 IP in the v4 range} +procedure converttov4(var ip:tbinip); +begin + {$ifdef ipv6} + if ip.family = AF_INET6 then begin + if (ip.ip6.u6_addr32[0] = 0) and (ip.ip6.u6_addr32[1] = 0) and + (ip.ip6.u6_addr16[4] = 0) and (ip.ip6.u6_addr16[5] = $ffff) then begin + ip.family := AF_INET; + ip.ip := ip.ip6.s6_addr32[3]; + end; + end; + {$endif} +end; + +end. diff --git a/httpserver_20080306/blinklist.pas b/httpserver_20080306/blinklist.pas new file mode 100755 index 0000000..2079b75 --- /dev/null +++ b/httpserver_20080306/blinklist.pas @@ -0,0 +1,118 @@ +(* + * beware IRC services, blinklist.pas + * Copyright (C) 2002 Bas Steendijk + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) +unit blinklist; +{$ifdef fpc} + {$mode delphi} +{$endif} + + +interface + +type + tlinklist=class(tobject) + next:tlinklist; + prev:tlinklist; + constructor create; + destructor destroy; override; + end; + + {linklist with 2 links} + tlinklist2=class(tlinklist) + next2:tlinklist2; + prev2:tlinklist2; + end; + + {linklist with one pointer} + tplinklist=class(tlinklist) + p:pointer + end; + + tstringlinklist=class(tlinklist) + s:string; + end; + + tthing=class(tlinklist) + name:string; {name/nick} + hashname:integer; {hash of name} + end; + +{ +adding new block to list (baseptr) +} +procedure linklistadd(var baseptr:tlinklist;newptr:tlinklist); +procedure linklistdel(var baseptr:tlinklist;item:tlinklist); + + +procedure linklist2add(var baseptr,newptr:tlinklist2); +procedure linklist2del(var baseptr:tlinklist2;item:tlinklist2); + +var + linklistdebug:integer; + +implementation + +procedure linklistadd(var baseptr:tlinklist;newptr:tlinklist); +var + p:tlinklist; +begin + p := baseptr; + baseptr := newptr; + baseptr.prev := nil; + baseptr.next := p; + if p <> nil then p.prev := baseptr; +end; + +procedure linklistdel(var baseptr:tlinklist;item:tlinklist); +begin + if item = baseptr then baseptr := item.next; + if item.prev <> nil then item.prev.next := item.next; + if item.next <> nil then item.next.prev := item.prev; +end; + +procedure linklist2add(var baseptr,newptr:tlinklist2); +var + p:tlinklist2; +begin + p := baseptr; + baseptr := newptr; + baseptr.prev2 := nil; + baseptr.next2 := p; + if p <> nil then p.prev2 := baseptr; +end; + +procedure linklist2del(var baseptr:tlinklist2;item:tlinklist2); +begin + if item = baseptr then baseptr := item.next2; + if item.prev2 <> nil then item.prev2.next2 := item.next2; + if item.next2 <> nil then item.next2.prev2 := item.prev2; +end; + +constructor tlinklist.create; +begin + inherited create; + inc(linklistdebug); +end; + +destructor tlinklist.destroy; +begin + dec(linklistdebug); + inherited destroy; +end; + +end. diff --git a/httpserver_20080306/bsearchtree.pas b/httpserver_20080306/bsearchtree.pas new file mode 100755 index 0000000..ad61751 --- /dev/null +++ b/httpserver_20080306/bsearchtree.pas @@ -0,0 +1,101 @@ +{ 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 + ----------------------------------------------------------------------------- } + +{actually a hashtable. it was a tree in earlier versions} + +unit bsearchtree; + +interface + +uses blinklist; + +const + hashtable_size=$4000; + +type + thashitem=class(tlinklist) + hash:integer; + s:string; + p:pointer; + end; + thashtable=array[0..hashtable_size-1] of thashitem; + phashtable=^thashtable; + +{adds "item" to the tree for name "s". the name must not exist (no checking done)} +procedure addtree(t:phashtable;s:string;item:pointer); + +{removes name "s" from the tree. the name must exist (no checking done)} +procedure deltree(t:phashtable;s:string); + +{returns the item pointer for s, or nil if not found} +function findtree(t:phashtable;s:string):pointer; + +implementation + +function makehash(s:string):integer; +const + shifter=6; +var + a,b:integer; +begin + result := 0; + b := length(s); + for a := 1 to b do begin + result := (result shl shifter) xor byte(s[a]); + end; + result := (result xor result shr 16) and (hashtable_size-1); +end; + +procedure addtree(t:phashtable;s:string;item:pointer); +var + hash:integer; + p:thashitem; +begin + hash := makehash(s); + p := thashitem.create; + p.hash := hash; + p.s := s; + p.p := item; + linklistadd(tlinklist(t[hash]),tlinklist(p)); +end; + +procedure deltree(t:phashtable;s:string); +var + p,p2:thashitem; + hash:integer; +begin + hash := makehash(s); + p := t[hash]; + p2 := nil; + while p <> nil do begin + if p.s = s then begin + p2 := p; + break; + end; + p := thashitem(p.next); + end; + linklistdel(tlinklist(t[hash]),tlinklist(p2)); + p2.destroy; +end; + + +function findtree(t:phashtable;s:string):pointer; +var + p:thashitem; + hash:integer; +begin + result := nil; + hash := makehash(s); + p := t[hash]; + while p <> nil do begin + if p.s = s then begin + result := p.p; + exit; + end; + p := thashitem(p.next); + end; +end; + +end. diff --git a/httpserver_20080306/btime.pas b/httpserver_20080306/btime.pas new file mode 100755 index 0000000..127839e --- /dev/null +++ b/httpserver_20080306/btime.pas @@ -0,0 +1,362 @@ +{ 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 + ----------------------------------------------------------------------------- } +{ +this unit returns unix timestamp with seconds and microseconds (as float) +works on windows/delphi, and on freepascal on unix. +} + +unit btime; + +interface + +type + float=extended; + +var + timezone:integer; + timezonestr:string; + irctime,unixtime:integer; + tickcount:integer; + settimebias:integer; + qpcjump:float; {can be read out and reset for debug purpose} + performancecountfreq:extended; + +function irctimefloat:float; +function irctimeint:integer; + +function unixtimefloat:float; +function unixtimeint:integer; + +function wintimefloat:float; + +procedure settime(newtime:integer); +procedure gettimezone; +procedure timehandler; +procedure init; + +function timestring(i:integer):string; +function timestrshort(i:integer):string; + +function oletounixfloat(t:float):float; +function oletounix(t:tdatetime):integer; +function unixtoole(i:integer):tdatetime; + +var + timefloatbias:float; + lastunixtimefloat:float=0; + +implementation + +{$ifdef fpc} + {$mode delphi} +{$endif} + +uses + {$ifdef UNIX} + {$ifdef VER1_0} + linux, + {$else} + baseunix,unix,unixutil, {needed for 2.0.2} + {$endif} + {$else} + windows, + {$endif} + sysutils; + + {$include unixstuff.inc} + + +const + daysdifference=25569; + +function oletounixfloat(t:float):float; +begin + t := (t - daysdifference) * 86400; + result := t; +end; + +function oletounix(t:tdatetime):integer; +begin + result := trunc(oletounixfloat(t)); +end; + +function unixtoole(i:integer):tdatetime; +begin + result := ((i)/86400)+daysdifference; +end; + +{$ifdef unix} +{-----------------------------------------*nix/freepascal code to read time } + +function unixtimefloat:float; +var + tv:ttimeval; +begin + gettimeofday(tv); + result := tv.tv_sec+(tv.tv_usec/1000000); +end; + +function wintimefloat:extended; +begin + result := unixtimefloat; +end; + +function unixtimeint:integer; +var + tv:ttimeval; +begin + gettimeofday(tv); + result := tv.tv_sec; +end; + +{$else} {delphi 3} +{------------------------------ windows/delphi code to read time} + +{ free pascals tsystemtime is incomaptible with windows api calls + so we declare it ourselves - plugwash +} +{$ifdef fpc} +type + TSystemTime = record + wYear: Word; + wMonth: Word; + wDayOfWeek: Word; + wDay: Word; + wHour: Word; + wMinute: Word; + wSecond: Word; + wMilliseconds: Word; + end; + {$endif} +function Date_utc: extended; +var + SystemTime: TSystemTime; +begin + {$ifdef fpc} + GetsystemTime(@SystemTime); + {$else} + GetsystemTime(SystemTime); + {$endif} + with SystemTime do Result := EncodeDate(wYear, wMonth, wDay); +end; + +function Time_utc: extended; +var + SystemTime: TSystemTime; +begin + {$ifdef fpc} + GetsystemTime(@SystemTime); + {$else} + GetsystemTime(SystemTime); + {$endif} + with SystemTime do + Result := EncodeTime(wHour, wMinute, wSecond, wMilliSeconds); +end; + +function Now_utc: extended; +begin + Result := round(Date_utc) + Time_utc; +end; + +const + highdwordconst=4294967296.0; + +function wintimefloat:extended; +var + p:packed record + lowpart:longint; + highpart:longint + end; + p2:tlargeinteger absolute p; + e:extended; +begin + if performancecountfreq = 0 then begin + QueryPerformancefrequency(p2); + e := p.lowpart; + if e < 0 then e := e + highdwordconst; + performancecountfreq := ((p.highpart*highdwordconst)+e); + end; + queryperformancecounter(p2); + e := p.lowpart; + if e < 0 then e := e + highdwordconst; + result := ((p.highpart*highdwordconst)+e)/performancecountfreq; +end; + +var + classpriority,threadpriority:integer; + +procedure settc; +var + hprocess,hthread:integer; +begin + hProcess := GetCurrentProcess; + hThread := GetCurrentThread; + + ClassPriority := GetPriorityClass(hProcess); + ThreadPriority := GetThreadPriority(hThread); + + SetPriorityClass(hProcess, REALTIME_PRIORITY_CLASS); + SetThreadPriority(hThread, THREAD_PRIORITY_TIME_CRITICAL); +end; + +procedure unsettc; +var + hprocess,hthread:integer; +begin + hProcess := GetCurrentProcess; + hThread := GetCurrentThread; + + SetPriorityClass(hProcess, ClassPriority); + SetThreadPriority(hThread, ThreadPriority); +end; + +function unixtimefloat:float; +var + f,g,h:float; +begin + if timefloatbias = 0 then begin + settc; + f := now_utc; + repeat g := now_utc; h := wintimefloat until g > f; + timefloatbias := oletounixfloat(g)-h; + unsettc; + end; + result := wintimefloat+timefloatbias; + + { + workaround for QPC jumps + (approach 2: always check "hi res" QPC unixtime against the "guaranteed" systemtime one) + } + f := result-(oletounixfloat(now_utc)); + if abs(f) > 0.02 then begin + f := timefloatbias; + timefloatbias := 0; + result := unixtimefloat; + qpcjump := qpcjump + f - timefloatbias; + end; + + if (result <= lastunixtimefloat) then result := lastunixtimefloat + 0.0000001; + lastunixtimefloat := result; +end; + +function unixtimeint:integer; +begin + result := trunc(unixtimefloat); +end; + +{$endif} +{-----------------------------------------------end of platform specific} + +function irctimefloat:float; +begin + result := unixtimefloat+settimebias; +end; + +function irctimeint:integer; +begin + result := unixtimeint+settimebias; +end; + + +procedure settime(newtime:integer); +var + a:integer; +begin + a := irctimeint-settimebias; + if newtime = 0 then settimebias := 0 else settimebias := newtime-a; + + irctime := irctimeint; +end; + +procedure timehandler; +begin + if unixtime = 0 then init; + unixtime := unixtimeint; + irctime := irctimeint; + if unixtime and 63 = 0 then begin + {update everything, apply timezone changes, clock changes, etc} + gettimezone; + timefloatbias := 0; + unixtime := unixtimeint; + irctime := irctimeint; + end; +end; + + +procedure gettimezone; +var + {$ifdef UNIX} + {$ifndef ver1_9_4} + {$ifndef ver1_0} + {$define above194} + {$endif} + {$endif} + {$ifndef above194} + hh,mm,ss:word; + {$endif} + {$endif} + l:integer; +begin + {$ifdef UNIX} + {$ifdef above194} + timezone := tzseconds; + {$else} + gettime(hh,mm,ss); + timezone := (longint(hh) * 3600 + mm * 60 + ss) - (unixtimeint mod 86400); + {$endif} + {$else} + timezone := round((now-now_utc)*86400); + {$endif} + + while timezone > 43200 do dec(timezone,86400); + while timezone < -43200 do inc(timezone,86400); + + if timezone >= 0 then timezonestr := '+' else timezonestr := '-'; + l := abs(timezone) div 60; + 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); +end; + +function timestrshort(i:integer):string; +const + weekday:array[0..6] of string[4]=('Thu','Fri','Sat','Sun','Mon','Tue','Wed'); + month:array[0..11] of string[4]=('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'); +var + y,m,d,h,min,sec,ms:word; + t:tdatetime; +begin + t := unixtoole(i+timezone); + decodedate(t,y,m,d); + decodetime(t,h,min,sec,ms); + result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+ + inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10)+' '+ + inttostr(y); +end; + +function timestring(i:integer):string; +const + weekday:array[0..6] of string[10]=('Thursday','Friday','Saturday','Sunday','Monday','Tuesday','Wednesday'); + month:array[0..11] of string[10]=('January','February','March','April','May','June','July','August','September','October','November','December'); +var + y,m,d,h,min,sec,ms:word; + t:tdatetime; +begin + t := unixtoole(i+timezone); + decodedate(t,y,m,d); + decodetime(t,h,min,sec,ms); + result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+inttostr(y)+' -- '+ + inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10)+' '+ + timezonestr; +end; + +procedure init; +begin + qpcjump := 0; + settimebias := 0; + gettimezone; + unixtime := unixtimeint; + irctime := irctimeint; +end; + +end. diff --git a/httpserver_20080306/dnsasync.pas b/httpserver_20080306/dnsasync.pas new file mode 100755 index 0000000..682f95f --- /dev/null +++ b/httpserver_20080306/dnsasync.pas @@ -0,0 +1,241 @@ +{ 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 + ----------------------------------------------------------------------------- } + +//FIXME: this code only ever seems to use one dns server for a request and does +//not seem to have any form of retry code. + +unit dnsasync; + +interface + +uses + {$ifdef win32} + dnswin, + {$endif} + lsocket,lcore, + classes,binipstuff,dnscore,btime; + + +type + //after completion or cancelation a dnswinasync may be reused + tdnsasync=class(tcomponent) + + private + //made a load of stuff private that does not appear to be part of the main + //public interface. If you make any of it public again please consider the + //consequences when using windows dns. --plugwash. + sock:twsocket; + + sockopen:boolean; + + + state:tdnsstate; + + dnsserverid:integer; + startts:double; + {$ifdef win32} + dwas : tdnswinasync; + {$endif} + + + procedure asyncprocess; + procedure receivehandler(sender:tobject;error:word); + function sendquery(const packet:tdnspacket;len:integer):boolean; + {$ifdef win32} + procedure winrequestdone(sender:tobject;error:word); + {$endif} + public + onrequestdone:tsocketevent; + + //addr and port allow the application to specify a dns server specifically + //for this dnsasync object. This is not a reccomended mode of operation + //because it limits the app to one dns server but is kept for compatibility + //and special uses. + addr,port:string; + + //A family value of AF_INET6 will give only + //ipv6 results. Any other value will give ipv4 results in preference and ipv6 + //results if ipv4 results are not available; + forwardfamily:integer; + + procedure cancel;//cancel an outstanding dns request + function dnsresult:string; //get result of dnslookup as a string + procedure dnsresultbin(var binip:tbinip); //get result of dnslookup as a tbinip + procedure forwardlookup(const name:string); //start forward lookup, + //preffering ipv4 + procedure reverselookup(const binip:tbinip); //start reverse lookup + + constructor create(aowner:tcomponent); override; + destructor destroy; override; + + end; + +implementation + +uses sysutils; + +constructor tdnsasync.create; +begin + inherited create(aowner); + dnsserverid := -1; + sock := twsocket.create(self); +end; + +destructor tdnsasync.destroy; +begin + if dnsserverid >= 0 then begin + reportlag(dnsserverid,-1); + dnsserverid := -1; + end; + sock.release; + setstate_request_init('',state); + inherited destroy; +end; + +procedure tdnsasync.receivehandler; +begin + if dnsserverid >= 0 then begin + reportlag(dnsserverid,trunc((unixtimefloat-startts)*1000)); + dnsserverid := -1; + end; +{ writeln('received reply');} + fillchar(state.recvpacket,sizeof(state.recvpacket),0); + state.recvpacketlen := twsocket(sender).Receive(@state.recvpacket, SizeOf(state.recvpacket)); + state.parsepacket := true; + asyncprocess; +end; + +function tdnsasync.sendquery; +begin +{ writeln('sendquery ',decodename(state.packet,state.packetlen,12,0,a),' ',state.requesttype);} + result := false; + if len = 0 then exit; {no packet} + if not sockopen then begin + if addr <> '' then sock.addr := addr else sock.addr := getcurrentsystemnameserver(dnsserverid);//getunixnameservercached; + startts := unixtimefloat; + if port = '' then port := '53'; + sock.port := port; + sock.Proto := 'udp'; + sock.ondataavailable := receivehandler; + try + sock.connect; + except + on e:exception do begin + //writeln('exception '+e.message); + exit; + end; + end; + sockopen := true; + end; + sock.send(@packet,len); + result := true; +end; + +procedure tdnsasync.asyncprocess; +begin + state_process(state); + case state.resultaction of + action_ignore: begin {do nothing} end; + action_done: begin + onrequestdone(self,0); + end; + action_sendquery:begin + sendquery(state.sendpacket,state.sendpacketlen); + end; + end; +end; + +procedure tdnsasync.forwardlookup; +begin + {$ifdef win32} + if usewindns or (addr = '') then begin + dwas := tdnswinasync.create; + dwas.onrequestdone := winrequestdone; + if forwardfamily = AF_INET6 then begin + dwas.forwardlookup(name,true); + end else begin + dwas.forwardlookup(name,false); + end; + end; + {$endif} + + ipstrtobin(name,state.resultbin); + if state.resultbin.family <> 0 then begin + onrequestdone(self,0); + exit; + end; + + + setstate_forward(name,state,forwardfamily); + asyncprocess; + +end; + +procedure tdnsasync.reverselookup; + +begin + {$ifdef win32} + if usewindns or (addr = '') then begin + dwas := tdnswinasync.create; + dwas.onrequestdone := winrequestdone; + dwas.reverselookup(binip); + end; + {$endif} + + setstate_reverse(binip,state); + asyncprocess; +end; + +function tdnsasync.dnsresult; +begin + if state.resultstr <> '' then result := state.resultstr else begin + result := ipbintostr(state.resultbin); + end; +end; + +procedure tdnsasync.dnsresultbin(var binip:tbinip); +begin + move(state.resultbin,binip,sizeof(binip)); +end; + +procedure tdnsasync.cancel; +begin + {$ifdef win32} + if assigned(dwas) then begin + dwas.release; + dwas := nil; + end else + {$endif} + begin + + if dnsserverid >= 0 then begin + reportlag(dnsserverid,-1); + dnsserverid := -1; + end; + if sockopen then begin + sock.close; + sockopen := false; + end; + end; + setstate_failure(state); + onrequestdone(self,0); +end; + +{$ifdef win32} + procedure tdnsasync.winrequestdone(sender:tobject;error:word); + begin + if dwas.reverse then begin + state.resultstr := dwas.name; + end else begin + state.resultbin := dwas.ip; + if (forwardfamily = AF_INET6) and (state.resultbin.family = AF_INET) then begin + fillchar(state.resultbin,sizeof(tbinip),0); + end; + end; + dwas.release; + onrequestdone(self,error); + end; +{$endif} +end. diff --git a/httpserver_20080306/dnscore.pas b/httpserver_20080306/dnscore.pas new file mode 100755 index 0000000..bb4fab4 --- /dev/null +++ b/httpserver_20080306/dnscore.pas @@ -0,0 +1,728 @@ +{ 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 + ----------------------------------------------------------------------------- } + +{ + + code wanting to use this dns system should act as follows (note: app + developers will probablly want to use dnsasync or dnssync or write a similar + wrapper unit of thier own). + + for normal lookups call setstate_forward or setstate_reverse to set up the + state, for more obscure lookups use setstate_request_init and fill in other + relavent state manually. + + call state_process which will do processing on the information in the state + and return an action + action_ignore means that dnscore wants the code that calls it to go + back to waiting for packets + action_sendpacket means that dnscore wants the code that calls it to send + the packet in sendpacket/sendpacketlen and then start (or go back to) listening + for + action_done means the request has completed (either suceeded or failed) + + callers should resend the last packet they tried to send if they have not + been asked to send a new packet for more than some timeout value they choose. + + when a packet is received the application should put the packet in + recvbuf/recvbuflen , set state.parsepacket and call state_process again + + once the app gets action_done it can determine sucess or failure in the + following ways. + + on failure state.resultstr will be an empty string and state.resultbin will + be zeroed out (easilly detected by the fact that it will have a family of 0) + + on success for a A or AAAA lookup state.resultstr will be an empty string + and state.resultbin will contain the result (note: AAAA lookups require IPV6 + enabled). + + if an A lookup fails and the code is built with ipv6 enabled then the code + will return any AAAA records with the same name. The reverse does not apply + so if an application preffers IPV6 but wants IPV4 results as well it must + check them seperately. + + on success for any other type of lookup state.resultstr will be an empty + + note the state contains ansistrings, setstate_init with a null name parameter + can be used to clean theese up if required. + + callers may use setstate_failure to mark the state as failed themseleves + before passing it on to other code, for example this may be done in the event + of a timeout. +} +unit dnscore; + + + +{$ifdef fpc}{$mode delphi}{$endif} + + + + + +interface + +uses binipstuff,classes,pgtypes; + +var usewindns : boolean = {$ifdef win32}true{$else}false{$endif}; +//hint to users of this unit that they should use windows dns instead. +//May be disabled by applications if desired. (e.g. if setting a custom +//dnsserverlist). + +//note: this unit will not be able to self populate it's dns server list on +//older versions of windows. + +const + maxnamelength=127; + maxnamefieldlen=63; + //note: when using action_ignore the dnscore code *must* preserve the contents of state.sendpacket to allow for retries + //note: action_ignore must not be used in response to the original request but there is no valid reason for doing this anyway + action_ignore=0; + action_done=1; + action_sendquery=2; + querytype_a=1; + querytype_cname=5; + querytype_aaaa=28; + querytype_ptr=12; + querytype_ns=2; + querytype_soa=6; + querytype_mx=15; + + maxrecursion=10; + maxrrofakind=20; + + retryafter=300000; //microseconds must be less than one second; + timeoutlag=1000000000; // penalty value to be treated as lag in the event of a timeout (microseconds) +type + dvar=array[0..0] of byte; + pdvar=^dvar; + tdnspacket=packed record + id:word; + flags:word; + rrcount:array[0..3] of word; + payload:array[0..511-12] of byte; + end; + + + + tdnsstate=record + id:word; + recursioncount:integer; + queryname:string; + requesttype:word; + parsepacket:boolean; + resultstr:string; + resultbin:tbinip; + resultaction:integer; + numrr1:array[0..3] of integer; + numrr2:integer; + rrdata:string; + sendpacketlen:integer; + sendpacket:tdnspacket; + recvpacketlen:integer; + recvpacket:tdnspacket; + forwardfamily:integer; + end; + + trr=packed record + requesttypehi:byte; + requesttype:byte; + clas:word; + ttl:integer; + datalen:word; + data:array[0..511] of byte; + end; + + trrpointer=packed record + p:pointer; + ofs:integer; + len:integer; + namelen:integer; + end; + +//commenting out functions from interface that do not have documented semantics +//and probablly should not be called from outside this unit, reenable them +//if you must but please document them at the same time --plugwash + +//function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer; +//function makereversename(const binip:tbinip):string; + +procedure setstate_request_init(const name:string;var state:tdnsstate); + +//set up state for a foward lookup. A family value of AF_INET6 will give only +//ipv6 results. Any other value will give ipv4 results in preference and ipv6 +//results if ipv4 results are not available; +procedure setstate_forward(const name:string;var state:tdnsstate;family:integer); + +procedure setstate_reverse(const binip:tbinip;var state:tdnsstate); +procedure setstate_failure(var state:tdnsstate); +//procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate); + + +procedure state_process(var state:tdnsstate); + +//function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):string; + +//presumablly this is exported to allow more secure random functions +//to be substituted? +var randomfunction:function:integer; + + +procedure populatednsserverlist; +procedure cleardnsservercache; + +var + dnsserverlist : tstringlist; +// currentdnsserverno : integer; + +function getcurrentsystemnameserver(var id:integer) :string; + +//var +// unixnameservercache:string; +{ $endif} + + +procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout +var + failurereason:string; + +implementation + +uses + {$ifdef win32} + windows, + {$endif} + + sysutils; + +function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer; +var + a,b:integer; + s:string; + arr:array[0..sizeof(packet)-1] of byte absolute packet; +begin + { writeln('buildrequest: name: ',name);} + result := 0; + fillchar(packet,sizeof(packet),0); + if assigned(randomfunction) then packet.id := (randomfunction and $ffff) else packet.id := random(65536); + packet.flags := htons($0100); + packet.rrcount[0] := htons($0001); + + + s := copy(name,1,maxnamelength); + if s = '' then exit; + if s[length(s)] <> '.' then s := s + '.'; + b := 0; + {encode name} + if (s = '.') then begin + packet.payload[0] := 0; + result := 12+5; + end else begin + for a := 1 to length(s) do begin + if s[a] = '.' then begin + if b > maxnamefieldlen then exit; + if (b = 0) then exit; + packet.payload[a-b-1] := b; + b := 0; + end else begin + packet.payload[a] := byte(s[a]); + inc(b); + end; + end; + if b > maxnamefieldlen then exit; + packet.payload[length(s)-b] := b; + result := length(s) + 12+5; + end; + + arr[result-1] := 1; + arr[result-3] := requesttype and $ff; + arr[result-4] := requesttype shr 8; +end; + +function makereversename(const binip:tbinip):string; +var + name:string; + a,b:integer; +begin + name := ''; + if binip.family = AF_INET then begin + b := htonl(binip.ip); + for a := 0 to 3 do begin + name := name + inttostr(b shr (a shl 3) and $ff)+'.'; + end; + name := name + 'in-addr.arpa'; + end else + {$ifdef ipv6} + if binip.family = AF_INET6 then begin + for a := 15 downto 0 do begin + b := binip.ip6.u6_addr8[a]; + name := name + hexchars[b and $f]+'.'+hexchars[b shr 4]+'.'; + end; + name := name + 'ip6.arpa'; + end else + {$endif} + begin + {empty name} + end; + result := name; +end; + +{ +decodes DNS format name to a string. does not includes the root dot. +doesnt read beyond len. +empty result + non null failurereason: failure +empty result + null failurereason: internal use +} +function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):string; +var + arr:array[0..sizeof(packet)-1] of byte absolute packet; + s:string; + a,b:integer; +begin + numread := 0; + repeat + if (start+numread < 0) or (start+numread >= len) then begin + result := ''; + failurereason := 'decoding name: got out of range1'; + exit; + end; + b := arr[start+numread]; + if b >= $c0 then begin + {recursive sub call} + if recursion > 10 then begin + result := ''; + failurereason := 'decoding name: max recursion'; + exit; + end; + if ((start+numread+1) >= len) then begin + result := ''; + failurereason := 'decoding name: got out of range3'; + exit; + end; + a := ((b shl 8) or arr[start+numread+1]) and $3fff; + s := decodename(packet,len,a,recursion+1,a); + if (s = '') and (failurereason <> '') then begin + result := ''; + exit; + end; + if result <> '' then result := result + '.'; + result := result + s; + inc(numread,2); + exit; + end else if b < 64 then begin + if (numread <> 0) and (b <> 0) then result := result + '.'; + for a := start+numread+1 to start+numread+b do begin + if (a >= len) then begin + result := ''; + failurereason := 'decoding name: got out of range2'; + exit; + end; + result := result + char(arr[a]); + end; + inc(numread,b+1); + + if b = 0 then begin + if (result = '') and (recursion = 0) then result := '.'; + exit; {reached end of name} + end; + end else begin + failurereason := 'decoding name: read invalid char'; + result := ''; + exit; {invalid} + end; + until false; +end; + +{==============================================================================} + +procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate); +var + a:integer; +begin + state.resultaction := action_done; + state.resultstr := ''; + case trr(rrp.p^).requesttype of + querytype_a: begin + if htons(trr(rrp.p^).datalen) <> 4 then exit; + move(trr(rrp.p^).data,state.resultbin.ip,4); + state.resultbin.family :=AF_INET; + end; + {$ifdef ipv6} + querytype_aaaa: begin + if htons(trr(rrp.p^).datalen) <> 16 then exit; + state.resultbin.family := AF_INET6; + move(trr(rrp.p^).data,state.resultbin.ip6,16); + end; + {$endif} + else + {other reply types (PTR, MX) return a hostname} + state.resultstr := decodename(state.recvpacket,state.recvpacketlen,taddrint(rrp.p)-taddrint(@state.recvpacket)+10,0,a); + fillchar(state.resultbin,sizeof(state.resultbin),0); + end; +end; + +procedure setstate_request_init(const name:string;var state:tdnsstate); +begin + {destroy things properly} + state.resultstr := ''; + state.queryname := ''; + state.rrdata := ''; + fillchar(state,sizeof(state),0); + state.queryname := name; + state.parsepacket := false; +end; + +procedure setstate_forward(const name:string;var state:tdnsstate;family:integer); +begin + setstate_request_init(name,state); + state.forwardfamily := family; + {$ifdef ipv6} + if family = AF_INET6 then state.requesttype := querytype_aaaa else + {$endif} + state.requesttype := querytype_a; +end; + +procedure setstate_reverse(const binip:tbinip;var state:tdnsstate); +begin + setstate_request_init(makereversename(binip),state); + state.requesttype := querytype_ptr; +end; + +procedure setstate_failure(var state:tdnsstate); +begin + state.resultstr := ''; + fillchar(state.resultbin,sizeof(state.resultbin),0); + state.resultaction := action_done; +end; + +procedure state_process(var state:tdnsstate); +label recursed; +label failure; +var + a,b,ofs:integer; + rrtemp:^trr; + rrptemp:^trrpointer; +begin + if state.parsepacket then begin + if state.recvpacketlen < 12 then begin + failurereason := 'Undersized packet'; + state.resultaction := action_ignore; + exit; + end; + if state.id <> state.recvpacket.id then begin + failurereason := 'ID mismatch'; + state.resultaction := action_ignore; + exit; + end; + state.numrr2 := 0; + for a := 0 to 3 do begin + state.numrr1[a] := htons(state.recvpacket.rrcount[a]); + if state.numrr1[a] > maxrrofakind then goto failure; + inc(state.numrr2,state.numrr1[a]); + end; + + setlength(state.rrdata,state.numrr2*sizeof(trrpointer)); + + {- put all replies into a list} + + ofs := 12; + {get all queries} + for a := 0 to state.numrr1[0]-1 do begin + if (ofs < 12) or (ofs > state.recvpacketlen-4) then goto failure; + rrptemp := @state.rrdata[1+a*sizeof(trrpointer)]; + rrptemp.p := @state.recvpacket.payload[ofs-12]; + rrptemp.ofs := ofs; + decodename(state.recvpacket,state.recvpacketlen,ofs,0,b); + rrptemp.len := b + 4; + inc(ofs,rrptemp.len); + end; + + for a := state.numrr1[0] to state.numrr2-1 do begin + if (ofs < 12) or (ofs > state.recvpacketlen-12) then goto failure; + rrptemp := @state.rrdata[1+a*sizeof(trrpointer)]; + if decodename(state.recvpacket,state.recvpacketlen,ofs,0,b) = '' then goto failure; + rrtemp := @state.recvpacket.payload[ofs-12+b]; {rrtemp points to values and result, after initial name} + rrptemp.p := rrtemp; + rrptemp.ofs := ofs; {ofs is start of RR before initial name from start of packet} + rrptemp.namelen := b; + b := htons(rrtemp.datalen); + rrptemp.len := b + 10 + rrptemp.namelen; + inc(ofs,rrptemp.len); + end; + if (ofs <> state.recvpacketlen) then begin + failurereason := 'ofs <> state.packetlen'; + goto failure; + end; + + {- check for items of the requested type in answer section, if so return success first} + for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin + rrptemp := @state.rrdata[1+a*sizeof(trrpointer)]; + rrtemp := rrptemp.p; + b := rrptemp.len; + if rrtemp.requesttype = state.requesttype then begin + setstate_return(rrptemp^,b,state); + exit; + end; + end; + + {if no items of correct type found, follow first cname in answer section} + for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin + rrptemp := @state.rrdata[1+a*sizeof(trrpointer)]; + rrtemp := rrptemp.p; + b := rrptemp.len; + if rrtemp.requesttype = querytype_cname then begin + state.queryname := decodename(state.recvpacket,state.recvpacketlen,rrptemp.ofs+12,0,b); + goto recursed; + end; + end; + + {no cnames found, no items of correct type found} + if state.forwardfamily <> 0 then goto failure; +{$ifdef ipv6} + if (state.requesttype = querytype_a) then begin + {v6 only: in case of forward, look for AAAA in alternative section} + for a := state.numrr1[0]+state.numrr1[1]+state.numrr1[2] to (state.numrr2-1) do begin + rrptemp := @state.rrdata[1+a*sizeof(trrpointer)]; + rrtemp := rrptemp.p; + b := rrptemp.len; + if rrtemp.requesttype = querytype_aaaa then begin + setstate_return(rrptemp^,b,state); + exit; + end; + end; + {no AAAA's found in alternative, do a recursive lookup for them} + state.requesttype := querytype_aaaa; + goto recursed; + end; +{$endif} + goto failure; +recursed: + {here it needs recursed lookup} + {if needing to follow a cname, change state to do so} + inc(state.recursioncount); + if state.recursioncount > maxrecursion then goto failure; + end; + + {here, a name needs to be resolved} + if state.queryname = '' then begin + failurereason := 'empty query name'; + goto failure; + end; + + {do /ets/hosts lookup here} + state.sendpacketlen := buildrequest(state.queryname,state.sendpacket,state.requesttype); + if state.sendpacketlen = 0 then begin + failurereason := 'building request packet failed'; + goto failure; + end; + state.id := state.sendpacket.id; + state.resultaction := action_sendquery; + + exit; +failure: + setstate_failure(state); +end; +{$ifdef win32} + const + MAX_HOSTNAME_LEN = 132; + MAX_DOMAIN_NAME_LEN = 132; + MAX_SCOPE_ID_LEN = 260 ; + MAX_ADAPTER_NAME_LENGTH = 260; + MAX_ADAPTER_ADDRESS_LENGTH = 8; + MAX_ADAPTER_DESCRIPTION_LENGTH = 132; + ERROR_BUFFER_OVERFLOW = 111; + MIB_IF_TYPE_ETHERNET = 6; + MIB_IF_TYPE_TOKENRING = 9; + MIB_IF_TYPE_FDDI = 15; + MIB_IF_TYPE_PPP = 23; + MIB_IF_TYPE_LOOPBACK = 24; + MIB_IF_TYPE_SLIP = 28; + + + type + tip_addr_string=packed record + Next :pointer; + IpAddress : array[0..15] of char; + ipmask : array[0..15] of char; + context : dword; + end; + pip_addr_string=^tip_addr_string; + tFIXED_INFO=packed record + HostName : array[0..MAX_HOSTNAME_LEN-1] of char; + DomainName : array[0..MAX_DOMAIN_NAME_LEN-1] of char; + currentdnsserver : pip_addr_string; + dnsserverlist : tip_addr_string; + nodetype : longint; + ScopeId : array[0..MAX_SCOPE_ID_LEN + 4] of char; + enablerouting : longbool; + enableproxy : longbool; + enabledns : longbool; + end; + pFIXED_INFO=^tFIXED_INFO; + + var + iphlpapi : thandle; + getnetworkparams : function(pFixedInfo : PFIXED_INFO;OutBufLen : plongint) : longint;stdcall; +{$endif} +procedure populatednsserverlist; +var + {$ifdef win32} + fixed_info : pfixed_info; + fixed_info_len : longint; + currentdnsserver : pip_addr_string; + {$else} + t:textfile; + s:string; + a:integer; + {$endif} +begin + //result := ''; + if assigned(dnsserverlist) then begin + dnsserverlist.clear; + end else begin + dnsserverlist := tstringlist.Create; + end; + {$ifdef win32} + if iphlpapi=0 then iphlpapi := loadlibrary('iphlpapi.dll'); + if not assigned(getnetworkparams) then @getnetworkparams := getprocaddress(iphlpapi,'GetNetworkParams'); + fixed_info_len := 0; + if GetNetworkParams(nil,@fixed_info_len)<>ERROR_BUFFER_OVERFLOW then exit; + //fixed_info_len :=sizeof(tfixed_info); + getmem(fixed_info,fixed_info_len); + if GetNetworkParams(fixed_info,@fixed_info_len)<>0 then begin + freemem(fixed_info); + exit; + end; + currentdnsserver := @(fixed_info.dnsserverlist); + while assigned(currentdnsserver) do begin + dnsserverlist.Add(currentdnsserver.IpAddress); + currentdnsserver := currentdnsserver.next; + end; + freemem(fixed_info); + {$else} + filemode := 0; + assignfile(t,'/etc/resolv.conf'); + {$i-}reset(t);{$i+} + if ioresult <> 0 then exit; + + while not eof(t) do begin + readln(t,s); + if not (copy(s,1,10) = 'nameserver') then continue; + s := copy(s,11,500); + while s <> '' do begin + if (s[1] = #32) or (s[1] = #9) then s := copy(s,2,500) else break; + end; + a := pos(' ',s); + if a <> 0 then s := copy(s,1,a-1); + a := pos(#9,s); + if a <> 0 then s := copy(s,1,a-1); + //result := s; + //if result <> '' then break; + dnsserverlist.Add(s); + end; + close(t); + {$endif} +end; + +procedure cleardnsservercache; +begin + if assigned(dnsserverlist) then begin + dnsserverlist.destroy; + dnsserverlist := nil; + end; +end; + +function getcurrentsystemnameserver(var id:integer):string; +var + counter : integer; + +begin + if not assigned(dnsserverlist) then populatednsserverlist; + if dnsserverlist.count=0 then raise exception.create('no dns servers availible'); + id := 0; + if dnsserverlist.count >1 then begin + + for counter := 1 to dnsserverlist.count-1 do begin + if taddrint(dnsserverlist.objects[counter]) < taddrint(dnsserverlist.objects[id]) then id := counter; + end; + end; + result := dnsserverlist[id] +end; + +procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout +var + counter : integer; + temp : integer; +begin + if (id < 0) or (id >= dnsserverlist.count) then exit; + if lag = -1 then lag := timeoutlag; + for counter := 0 to dnsserverlist.count-1 do begin + temp := taddrint(dnsserverlist.objects[counter]) *15; + if counter=id then temp := temp + lag; + dnsserverlist.objects[counter] := tobject(temp div 16); + end; + +end; + +{ quick and dirty description of dns packet structure to aid writing and + understanding of parser code, refer to appropriate RFCs for proper specs +- all words are network order + +www.google.com A request: + +0, 2: random transaction ID +2, 2: flags: only the "recursion desired" bit set. (bit 8 of word) +4, 2: questions: 1 +6, 2: answer RR's: 0. +8, 2: authority RR's: 0. +10, 2: additional RR's: 0. +12, n: payload: + query: + #03 "www" #06 "google" #03 "com" #00 + size-4, 2: type: host address (1) + size-2, 2: class: inet (1) + +reply: + +0,2: random transaction ID +2,2: flags: set: response (bit 15), recursion desired (8), recursion available (7) +4,4: questions: 1 +6,4: answer RR's: 2 +8,4: authority RR's: 9 +10,4: additional RR's: 9 +12: payload: + query: + .... + answer: CNAME + 0,2 "c0 0c" "name: www.google.com" + 2,2 "00 05" "type: cname for an alias" + 4,2 "00 01" "class: inet" + 6,4: TTL + 10,2: data length "00 17" (23) + 12: the cname name (www.google.akadns.net) + answer: A + 0,2 .. + 2,2 "00 01" host address + 4,2 ... + 6,4 ... + 10,2: data length (4) + 12,4: binary IP + authority - 9 records + additional - 9 records + + + ipv6 AAAA reply: + 0,2: ... + 2,2: type: 001c + 4,2: class: inet (0001) + 6,2: TTL + 10,2: data size (16) + 12,16: binary IP + + ptr request: query type 000c + +name compression: word "cxxx" in the name, xxx points to offset in the packet} + +end. diff --git a/httpserver_20080306/dnssync.pas b/httpserver_20080306/dnssync.pas new file mode 100755 index 0000000..c64d320 --- /dev/null +++ b/httpserver_20080306/dnssync.pas @@ -0,0 +1,262 @@ +{ 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 + ----------------------------------------------------------------------------- } +unit dnssync; +{$ifdef fpc} + {$mode delphi} +{$endif} + +interface + uses + dnscore, + binipstuff, + {$ifdef win32} + winsock, + windows, + {$else} + {$ifdef VER1_0} + linux, + {$else} + baseunix,unix, + {$endif} + sockets, + fd_utils, + {$endif} + sysutils; + +//convert a name to an IP +//IPV4 is preffered if availible, if not IPV6 will be returned (if ipv6 support +//compiled in) +//on error the binip will have a family of 0 (other fiels are also currently +//zeroed out but may be used for further error information in future) +//timeout is in seconds, it is ignored when using windows dns +function forwardlookup(name:string;timeout:integer):tbinip; + + +//convert an IP to a name, on error a null string will be returned, other +//details as above +function reverselookup(ip:tbinip;timeout:integer):string; + + +var + dnssyncserver:string; + id : integer; + {$ifdef win32} + sendquerytime : integer; + {$else} + sendquerytime : ttimeval; + {$endif} +implementation +{$ifdef win32} + uses dnswin; +{$endif} + +{$i unixstuff.inc} +{$i ltimevalstuff.inc} + +var + fd:integer; + state:tdnsstate; +{$ifdef win32} + const + winsocket = 'wsock32.dll'; + function sendto(s: TSocket; const Buf; len, flags: Integer; var addrto: TinetSockAddr; tolen: Integer): Integer; stdcall; external winsocket name 'sendto'; + function bind(s: TSocket; var addr: TinetSockAddr; namelen: Integer): Longbool; stdcall; external winsocket name 'bind'; + type + fdset=tfdset; +{$endif} + +function sendquery(const packet:tdnspacket;len:integer):boolean; +var + a:integer; + addr : string; + port : string; + inaddr : TInetSockAddr; + +begin +{ writeln('sendquery ',decodename(state.packet,state.packetlen,12,0,a),' ',state.requesttype);} + result := false; + if len = 0 then exit; {no packet} + + if dnssyncserver <> '' then addr := dnssyncserver else addr := getcurrentsystemnameserver(id); + port := '53'; + + inAddr.family:=AF_INET; + inAddr.port:=htons(strtointdef(port,0)); + inAddr.addr:=htonl(longip(addr)); + + sendto(fd,packet,len,0,inaddr,sizeof(inaddr)); + {$ifdef win32} + sendquerytime := GetTickCount and $3fff; + {$else} + gettimeofday(sendquerytime); + {$endif} + result := true; +end; + +procedure setupsocket; +var + inAddrtemp : TInetSockAddr; +begin + if fd > 0 then exit; + + fd := Socket(AF_INET,SOCK_DGRAM,0); + inAddrtemp.family:=AF_INET; + inAddrtemp.port:=0; + inAddrtemp.addr:=0;{htonl(longip('0.0.0.0'));} + If {$ifndef win32}Not{$endif} Bind(fd,inAddrtemp,SizeOf(inAddrtemp)) Then begin + {$ifdef win32} + raise Exception.create('unable to bind '+inttostr(WSAGetLastError)); + {$else} + raise Exception.create('unable to bind '+inttostr(socketError)); + {$endif} + end; +end; + +procedure resolveloop(timeout:integer); +var + selectresult : integer; + fds : fdset; + {$ifdef win32} + endtime : longint; + starttime : longint; + wrapmode : boolean; + currenttime : integer; + {$else} + endtime : ttimeval; + currenttime : ttimeval; + + {$endif} + lag : ttimeval; + currenttimeout : ttimeval; + selecttimeout : ttimeval; + + +begin + {$ifdef win32} + starttime := GetTickCount and $3fff; + endtime := starttime +(timeout*1000); + if (endtime and $4000)=0 then begin + wrapmode := false; + end else begin + wrapmode := true; + end; + endtime := endtime and $3fff; + {$else} + gettimeofday(endtime); + endtime.tv_sec := endtime.tv_sec + timeout; + {$endif} + + setupsocket; + repeat + state_process(state); + case state.resultaction of + action_ignore: begin +{ writeln('ignore');} + {do nothing} + end; + action_done: begin +{ writeln('done');} + exit; + //onrequestdone(self,0); + end; + action_sendquery:begin +{ writeln('send query');} + sendquery(state.sendpacket,state.sendpacketlen); + end; + end; + {$ifdef win32} + currenttime := GetTickCount and $3fff; + msectotimeval(selecttimeout, (endtime-currenttime)and$3fff); + {$else} + gettimeofday(currenttime); + selecttimeout := endtime; + tv_substract(selecttimeout,currenttime); + {$endif} + fd_zero(fds); + fd_set(fd,fds); + if (selecttimeout.tv_sec > 0) or (selecttimeout.tv_usec > retryafter) then begin + selecttimeout.tv_sec := 0; + selecttimeout.tv_usec := retryafter; + end; + selectresult := select(fd+1,@fds,nil,nil,@selecttimeout); + if selectresult > 0 then begin +{ writeln('selectresult>0');} + //why the hell are we zeroing out the packet buffer before reading into it?! --plugwash + fillchar(state.recvpacket,sizeof(state.recvpacket),0); + {$ifdef win32} + msectotimeval(lag,(currenttime-sendquerytime)and$3fff); + {$else} + lag := currenttime; + tv_substract(lag,sendquerytime); + + {$endif} + + reportlag(id,(lag.tv_sec*1000000)+lag.tv_usec); + state.recvpacketlen := recv(fd,state.recvpacket, SizeOf(state.recvpacket),0); + state.parsepacket := true; + end; + if selectresult < 0 then exit; + if selectresult = 0 then begin + {$ifdef win32} + currenttime := GetTickCount; + {$else} + gettimeofday(currenttime); + {$endif} + reportlag(id,-1); + if {$ifdef win32}(currenttime >= endtime)and ((not wrapmode) or (currenttime < starttime)) {$else}tv_compare(currenttime,endtime){$endif} {currenttime >= endtime } then begin + exit; + end else begin + //resend + sendquery(state.sendpacket,state.sendpacketlen); + end; + end; + until false; +end; + +function forwardlookup(name:string;timeout:integer):tbinip; +var + dummy : integer; +begin + ipstrtobin(name,result); + if result.family <> 0 then exit; //it was an IP address, no need for dns + //lookup + {$ifdef win32} + if usewindns then begin + result := winforwardlookup(name,false,dummy); + exit; + end; + {$endif} + setstate_forward(name,state,0); + resolveloop(timeout); + result := state.resultbin; +end; + +function reverselookup(ip:tbinip;timeout:integer):string; +var + dummy : integer; +begin + {$ifdef win32} + if usewindns then begin + result := winreverselookup(ip,dummy); + exit; + end; + {$endif} + setstate_reverse(ip,state); + resolveloop(timeout); + result := state.resultstr; +end; + +{$ifdef win32} + var + wsadata : twsadata; + + initialization + WSAStartUp($2,wsadata); + finalization + WSACleanUp; +{$endif} +end. + + diff --git a/httpserver_20080306/dnswin.pas b/httpserver_20080306/dnswin.pas new file mode 100755 index 0000000..bae0780 --- /dev/null +++ b/httpserver_20080306/dnswin.pas @@ -0,0 +1,332 @@ +unit dnswin; + +interface +uses binipstuff,classes,lcore; + +//on failure a null string or zeroed out binip will be retuned and error will be +//set to a windows error code (error will be left untouched under non error +//conditions). +function winforwardlookup(name : string;ipv6preffered : boolean;var error:integer) : tbinip; +function winreverselookup(ip:tbinip;var error:integer):string; + + +type + //do not call destroy on a tdnswinasync instead call release and the + //dnswinasync will be freed when appropriate. Calling destroy will block + //the calling thread until the dns lookup completes. + //release should only be called from the main thread + tdnswinasync=class(tthread) + private + ipv6preffered : boolean; + freverse : boolean; + error : integer; + freewhendone : boolean; + hadevent : boolean; + protected + procedure execute; override; + public + onrequestdone:tsocketevent; + name : string; + ip : tbinip; + + procedure forwardlookup(name:string;ipv6preffered:boolean); + procedure reverselookup(ip:tbinip); + destructor destroy; override; + procedure release; + constructor create; + property reverse : boolean read freverse; + + end; + +implementation +uses + lsocket,pgtypes,sysutils,winsock,windows,messages; + +type + //taddrinfo = record; //forward declaration + paddrinfo = ^taddrinfo; + taddrinfo = packed record + ai_flags : longint; + ai_family : longint; + ai_socktype : longint; + ai_protocol : longint; + ai_addrlen : taddrint; + ai_canonname : pchar; + ai_addr : pinetsockaddrv; + ai_next : paddrinfo; + end; + ppaddrinfo = ^paddrinfo; + tgetaddrinfo = function(nodename : pchar; servname : pchar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall; + tfreeaddrinfo = procedure(ai : paddrinfo); stdcall; + tgetnameinfo = function(sa:Pinetsockaddrv;salen : longint; host:pchar;hostlen : longint;serv:pchar;servlen:longint;flags:longint) : longint;stdcall; +var + getaddrinfo : tgetaddrinfo; + freeaddrinfo : tfreeaddrinfo; + getnameinfo : tgetnameinfo; +procedure v4onlyfreeaddrinfo(ai : paddrinfo); stdcall; +begin + freemem(ai.ai_addr); + freemem(ai); +end; + +type + plongint = ^longint; + pplongint = ^plongint; + +function v4onlygetaddrinfo(nodename : pchar; servname : pchar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall; +var + output : paddrinfo; + hostent : phostent; +begin + if hints.ai_family = af_inet then begin + result := 0; + getmem(output,sizeof(taddrinfo)); + getmem(output.ai_addr,sizeof(tinetsockaddr)); + output.ai_addr.InAddr.family := af_inet; + if servname <> nil then output.ai_addr.InAddr.port := htons(strtoint(servname)) else output.ai_addr.InAddr.port := 0; + hostent := gethostbyname(nodename); + if hostent = nil then begin + result := wsagetlasterror; + v4onlyfreeaddrinfo(output); + exit; + end; + output.ai_addr.InAddr.addr := pplongint(hostent.h_addr_list)^^; + output.ai_flags := 0; + output.ai_family := af_inet; + output.ai_socktype := 0; + output.ai_protocol := 0; + output.ai_addrlen := sizeof(tinetsockaddr); + output.ai_canonname := nil; + output.ai_next := nil; + + res^ := output; + end else begin + result := WSANO_RECOVERY; + end; +end; + +function min(a,b : integer):integer; +begin + if a 0 then begin + fillchar(result,0,sizeof(result)); + error := getaddrinforesult; + end; +end; + +function winreverselookup(ip:tbinip;var error : integer):string; +var + sa : tinetsockaddrv; + getnameinforesult : integer; +begin + + if ip.family = AF_INET then begin + sa.InAddr.family := AF_INET; + sa.InAddr.port := 1; + sa.InAddr.addr := ip.ip; + end else if ip.family = AF_INET6 then begin + sa.InAddr6.sin6_family := AF_INET6; + sa.InAddr6.sin6_port := 1; + sa.InAddr6.sin6_addr := ip.ip6; + end else begin + raise exception.create('unrecognised address family'); + end; + populateprocvars; + setlength(result,1025); + getnameinforesult := getnameinfo(@sa,sizeof(tinetsockaddrv),pchar(result),length(result),nil,0,0); + if getnameinforesult <> 0 then begin + error := getnameinforesult; + result := ''; + exit; + end; + if pos(#0,result) >= 0 then begin + setlength(result,pos(#0,result)-1); + end; +end; + +var + hwnddnswin : hwnd; + +function MyWindowProc( + ahWnd : HWND; + auMsg : Integer; + awParam : WPARAM; + alParam : LPARAM): Integer; stdcall; +var + dwas : tdnswinasync; +begin + if (ahwnd=hwnddnswin) and (aumsg=wm_user) then begin + Dwas := tdnswinasync(alparam); + dwas.hadevent := true; + if assigned (dwas.onrequestdone) then dwas.onrequestdone(dwas,awparam); + if dwas.freewhendone then dwas.free; + end else begin + //not passing unknown messages on to defwindowproc will cause window + //creation to fail! --plugwash + Result := DefWindowProc(ahWnd, auMsg, awParam, alParam) + end; +end; + +procedure tdnswinasync.forwardlookup(name:string;ipv6preffered:boolean); +begin + self.name := name; + self.ipv6preffered := ipv6preffered; + freverse := false; + resume; +end; +procedure tdnswinasync.reverselookup(ip:tbinip); +begin + self.ip := ip; + freverse := true; + resume; +end; +procedure tdnswinasync.execute; +var + error : integer; +begin + error := 0; + if reverse then begin + name := winreverselookup(ip,error); + end else begin + ip := winforwardlookup(name,ipv6preffered,error); + + end; + + postmessage(hwnddnswin,wm_user,error,taddrint(self)); +end; + +destructor tdnswinasync.destroy; +begin + WaitFor; + inherited destroy; +end; +procedure tdnswinasync.release; +begin + if hadevent then destroy else begin + onrequestdone := nil; + freewhendone := true; + end; +end; + +constructor tdnswinasync.create; +begin + inherited create(true); +end; + +var + MyWindowClass : TWndClass = (style : 0; + lpfnWndProc : @MyWindowProc; + cbClsExtra : 0; + cbWndExtra : 0; + hInstance : 0; + hIcon : 0; + hCursor : 0; + hbrBackground : 0; + lpszMenuName : nil; + lpszClassName : 'dnswinClass'); +begin + + if Windows.RegisterClass(MyWindowClass) = 0 then halt; + //writeln('about to create lcore handle, hinstance=',hinstance); + hwnddnswin := CreateWindowEx(WS_EX_TOOLWINDOW, + MyWindowClass.lpszClassName, + '', { Window name } + WS_POPUP, { Window Style } + 0, 0, { X, Y } + 0, 0, { Width, Height } + 0, { hWndParent } + 0, { hMenu } + HInstance, { hInstance } + nil); { CreateParam } + //writeln('dnswin hwnd is ',hwnddnswin); + //writeln('last error is ',GetLastError); +end. diff --git a/httpserver_20080306/fd_utils.pas b/httpserver_20080306/fd_utils.pas new file mode 100755 index 0000000..9ad93dd --- /dev/null +++ b/httpserver_20080306/fd_utils.pas @@ -0,0 +1,69 @@ +// this file contains code copied from linux.pp in the free pascal rtl +// i had to copy them because i use a different definition of fdset to them +// the copyright block from the file in question is shown below +{ + $Id: fd_utils.pas,v 1.2 2004/08/19 23:12:09 plugwash Exp $ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Michael Van Canneyt, + BSD parts (c) 2000 by Marco van de Voort + members of the Free Pascal development team. + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY;without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +**********************************************************************} +{$ifdef fpc} + {$mode delphi} + {$inlining on} +{$endif} +unit fd_utils; +interface + +type + FDSet= Array [0..255] of longint; {31} + PFDSet= ^FDSet; +const + absoloutemaxs=(sizeof(fdset)*8)-1; + +Procedure FD_Clr(fd:longint;var fds:fdSet); +Procedure FD_Zero(var fds:fdSet); +Procedure FD_Set(fd:longint;var fds:fdSet); +Function FD_IsSet(fd:longint;var fds:fdSet):boolean; + + +implementation +uses sysutils; +Procedure FD_Clr(fd:longint;var fds:fdSet);{$ifdef fpc}inline;{$endif} +{ Remove fd from the set of filedescriptors} +begin + if (fd < 0) then raise exception.create('FD_Clr fd out of range: '+inttostr(fd)); + fds[fd shr 5]:=fds[fd shr 5] and (not (1 shl (fd and 31))); +end; + +Procedure FD_Zero(var fds:fdSet); +{ Clear the set of filedescriptors } +begin + FillChar(fds,sizeof(fdSet),0); +end; + +Procedure FD_Set(fd:longint;var fds:fdSet);{$ifdef fpc}inline;{$endif} +{ Add fd to the set of filedescriptors } +begin + if (fd < 0) then raise exception.create('FD_set fd out of range: '+inttostr(fd)); + fds[fd shr 5]:=fds[fd shr 5] or (1 shl (fd and 31)); +end; + +Function FD_IsSet(fd:longint;var fds:fdSet):boolean;{$ifdef fpc}inline;{$endif} +{ Test if fd is part of the set of filedescriptors } +begin + if (fd < 0) then begin + result := false; + exit; + end; + FD_IsSet:=((fds[fd shr 5] and (1 shl (fd and 31)))<>0); +end; +end. diff --git a/httpserver_20080306/lcore.pas b/httpserver_20080306/lcore.pas new file mode 100755 index 0000000..51fbf78 --- /dev/null +++ b/httpserver_20080306/lcore.pas @@ -0,0 +1,889 @@ +{lsocket.pas} + +{io and timer code by plugwash} + +{ 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 + ----------------------------------------------------------------------------- } + +{note: you must use the @ in the last param to tltask.create not doing so will + compile without error but will cause an access violation -pg} + +//note: events after release are normal and are the apps responsibility to deal with safely + +unit lcore; +{$ifdef fpc} + {$mode delphi} +{$endif} +{$ifdef win32} + {$define nosignal} +{$endif} +interface + uses + sysutils, + {$ifndef win32} + {$ifdef VER1_0} + linux, + {$else} + baseunix,unix, + {$endif} + fd_utils, + {$endif} + classes,pgtypes,bfifo; + procedure processtasks; + + + + + + + + const + receivebufsize=1460; + + type + {$ifdef ver1_0} + sigset= array[0..31] of longint; + {$endif} + + ESocketException = class(Exception); + TBgExceptionEvent = procedure (Sender : TObject; + E : Exception; + var CanClose : Boolean) of object; + + // note : tsocketstate is defined in the same way as it is in François PIETTE's twsocket + // however tlsocket currently only uses wsClosed wsConnecting wsconnected and wsListening + TSocketState = (wsInvalidState, + wsOpened, wsBound, + wsConnecting, wsConnected, + wsAccepting, wsListening, + wsClosed); + + TWSocketOption = (wsoNoReceiveLoop, wsoTcpNoDelay); + TWSocketOptions = set of TWSocketOption; + + TSocketevent = procedure(Sender: TObject; Error: word) of object; + //Tdataavailevent = procedure(data : string); + TSendData = procedure (Sender: TObject; BytesSent: Integer) of object; + + tlcomponent = class(tcomponent) + public + released:boolean; + procedure release; virtual; + destructor destroy; override; + end; + + tlasio = class(tlcomponent) + public + state : tsocketstate ; + ComponentOptions : TWSocketOptions; + fdhandlein : Longint ; {file discriptor} + fdhandleout : Longint ; {file discriptor} + + onsessionclosed : tsocketevent ; + ondataAvailable : tsocketevent ; + onsessionAvailable : tsocketevent ; + + onsessionconnected : tsocketevent ; + onsenddata : tsenddata ; + ondatasent : tsocketevent ; + //connected : boolean ; + nextasin : tlasio ; + prevasin : tlasio ; + + recvq : tfifo; + OnBgException : TBgExceptionEvent ; + //connectread : boolean ; + sendq : tfifo; + closehandles : boolean ; + writtenthiscycle : boolean ; + onfdwrite : procedure (Sender: TObject; Error: word) of object; //added for bewarehttpd + lasterror:integer; + destroying:boolean; + function receivestr:string; virtual; + procedure close; + procedure abort; + procedure internalclose(error:word); virtual; + constructor Create(AOwner: TComponent); override; + + destructor destroy; override; + procedure fdcleanup; + procedure HandleBackGroundException(E: Exception); + procedure handlefdtrigger(readtrigger,writetrigger:boolean); virtual; + procedure dup(invalue:longint); + + function sendflush : integer; + procedure sendstr(const str : string);virtual; + procedure putstringinsendbuffer(const newstring : string); + function send(data:pointer;len:integer):integer;virtual; + procedure putdatainsendbuffer(data:pointer;len:integer); virtual; + procedure deletebuffereddata; + + //procedure messageloop; + function Receive(Buf:Pointer;BufSize:integer):integer; virtual; + procedure flush;virtual;{$ifdef win32} abstract;{$endif} + procedure dodatasent(wparam,lparam:longint); + procedure doreceiveloop(wparam,lparam:longint); + procedure sinkdata(sender:tobject;error:word); + + procedure release; override; {test -beware} + + function RealSend(Data : Pointer; Len : Integer) : Integer; //added for bewarehttpd + + procedure myfdclose(fd : integer); virtual;{$ifdef win32}abstract;{$endif} + function myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt; virtual;{$ifdef win32}abstract;{$endif} + function myfdread(fd: LongInt;var buf;size: LongInt):LongInt; virtual;{$ifdef win32}abstract;{$endif} + protected + procedure dupnowatch(invalue:longint); + end; + ttimerwrapperinterface=class(tlcomponent) + public + function createwrappedtimer : tobject;virtual;abstract; +// procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);virtual;abstract; + procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);virtual;abstract; + procedure setenabled(wrappedtimer : tobject;newvalue : boolean);virtual;abstract; + procedure setinterval(wrappedtimer : tobject;newvalue : integer);virtual;abstract; + end; + + var + timerwrapperinterface : ttimerwrapperinterface; + type + {$ifdef win32} + ttimeval = record + tv_sec : longint; + tv_usec : longint; + end; + {$endif} + tltimer=class(tlcomponent) + protected + + + wrappedtimer : tobject; + + +// finitialevent : boolean ; + fontimer : tnotifyevent ; + fenabled : boolean ; + finterval : integer ; {miliseconds, default 1000} + {$ifndef win32} + procedure resettimes; + {$endif} +// procedure setinitialevent(newvalue : boolean); + procedure setontimer(newvalue:tnotifyevent); + procedure setenabled(newvalue : boolean); + procedure setinterval(newvalue : integer); + public + //making theese public for now, this code should probablly be restructured later though + prevtimer : tltimer ; + nexttimer : tltimer ; + nextts : ttimeval ; + + constructor create(aowner:tcomponent);override; + destructor destroy;override; +// property initialevent : boolean read finitialevent write setinitialevent; + property ontimer : tnotifyevent read fontimer write setontimer; + property enabled : boolean read fenabled write setenabled; + property interval : integer read finterval write setinterval; + + end; + + ttaskevent=procedure(wparam,lparam:longint) of object; + + tltask=class(tobject) + public + handler : ttaskevent; + obj : tobject; + wparam : longint; + lparam : longint; + nexttask : tltask; + constructor create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint); + end; + + + + teventcore=class + public + procedure processmessages; virtual;abstract; + procedure messageloop; virtual;abstract; + procedure exitmessageloop; virtual;abstract; + procedure setfdreverse(fd : integer;reverseto : tlasio);virtual;abstract; + procedure rmasterset(fd : integer;islistensocket : boolean); virtual;abstract; + procedure rmasterclr(fd: integer); virtual;abstract; + procedure wmasterset(fd : integer); virtual;abstract; + procedure wmasterclr(fd: integer); virtual;abstract; + end; +var + eventcore : teventcore; + +procedure processmessages; +procedure messageloop; +procedure exitmessageloop; + +var + firstasin : tlasio ; + firsttimer : tltimer ; + firsttask , lasttask , currenttask : tltask ; + + numread : integer ; + mustrefreshfds : boolean ; +{ lcoretestcount:integer;} + + asinreleaseflag:boolean; + + +procedure disconnecttasks(aobj:tobject); +procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint); +type + tonaddtask = procedure(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint); +var + onaddtask : tonaddtask; + + +procedure sleep(i:integer); +{$ifndef nosignal} + procedure prepsigpipe;inline; +{$endif} + + +implementation +{$ifndef nosignal} + uses {sockets,}lloopback,lsignal; +{$endif} +{$ifdef win32} + uses windows; +{$endif} +{$ifndef win32} + {$include unixstuff.inc} +{$endif} +{$include ltimevalstuff.inc} + + +{!!! added sleep call -beware} +procedure sleep(i:integer); +var + tv:ttimeval; +begin + {$ifdef win32} + windows.sleep(i); + {$else} + tv.tv_sec := i div 1000; + tv.tv_usec := (i mod 1000) * 1000; + select(0,nil,nil,nil,@tv); + {$endif} +end; + +destructor tlcomponent.destroy; +begin + disconnecttasks(self); + inherited destroy; +end; + + + + +procedure tlcomponent.release; +begin + released := true; +end; + +procedure tlasio.release; +begin + asinreleaseflag := true; + inherited release; +end; + +procedure tlasio.doreceiveloop; +begin + if recvq.size = 0 then exit; + if assigned(ondataavailable) then ondataavailable(self,0); + if not (wsonoreceiveloop in componentoptions) then + if recvq.size > 0 then tltask.create(self.doreceiveloop,self,0,0); +end; + +function tlasio.receivestr; +begin + setlength(result,recvq.size); + receive(@result[1],length(result)); +end; + +function tlasio.receive(Buf:Pointer;BufSize:integer):integer; +var + i,a,b:integer; + p:pointer; +begin + i := bufsize; + if recvq.size < i then i := recvq.size; + a := 0; + while (a < i) do begin + b := recvq.get(p,i-a); + move(p^,buf^,b); + inc(taddrint(buf),b); + recvq.del(b); + inc(a,b); + end; + result := i; + if wsonoreceiveloop in componentoptions then begin + if recvq.size = 0 then eventcore.rmasterset(fdhandlein,false); + end; +end; + +constructor tlasio.create; +begin + inherited create(AOwner); + sendq := tfifo.create; + recvq := tfifo.create; + state := wsclosed; + fdhandlein := -1; + fdhandleout := -1; + nextasin := firstasin; + prevasin := nil; + if assigned(nextasin) then nextasin.prevasin := self; + firstasin := self; + + released := false; +end; + +destructor tlasio.destroy; +begin + destroying := true; + if state <> wsclosed then close; + if prevasin <> nil then begin + prevasin.nextasin := nextasin; + end else begin + firstasin := nextasin; + end; + if nextasin <> nil then begin + nextasin.prevasin := prevasin; + end; + recvq.destroy; + sendq.destroy; + inherited destroy; +end; + +procedure tlasio.close; +begin + internalclose(0); +end; + +procedure tlasio.abort; +begin + close; +end; + +procedure tlasio.fdcleanup; +begin + if fdhandlein <> -1 then begin + eventcore.rmasterclr(fdhandlein); //fd_clr(fdhandlein,fdsrmaster) + end; + if fdhandleout <> -1 then begin + eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster) + end; + if fdhandlein=fdhandleout then begin + if fdhandlein <> -1 then begin + myfdclose(fdhandlein); + end; + end else begin + if fdhandlein <> -1 then begin + myfdclose(fdhandlein); + end; + if fdhandleout <> -1 then begin + myfdclose(fdhandleout); + end; + end; + fdhandlein := -1; + fdhandleout := -1; +end; + +procedure tlasio.internalclose(error:word); +begin + if state<>wsclosed then begin + if (fdhandlein < 0) or (fdhandleout < 0) then raise exception.create('internalclose called with invalid fd handles'); + eventcore.rmasterclr(fdhandlein);//fd_clr(fdhandlein,fdsrmaster); + eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster); + + if closehandles then begin + {$ifndef win32} + //anyone remember why this is here? --plugwash + fcntl(fdhandlein,F_SETFL,0); + {$endif} + myfdclose(fdhandlein); + if fdhandleout <> fdhandlein then begin + {$ifndef win32} + fcntl(fdhandleout,F_SETFL,0); + {$endif} + myfdclose(fdhandleout); + end; + eventcore.setfdreverse(fdhandlein,nil); + eventcore.setfdreverse(fdhandleout,nil); + + fdhandlein := -1; + fdhandleout := -1; + end; + state := wsclosed; + + if assigned(onsessionclosed) then if not destroying then onsessionclosed(self,error); + end; + sendq.del(maxlongint); +end; + + +{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} +{ All exceptions *MUST* be handled. If an exception is not handled, the } +{ application will most likely be shut down ! } +procedure tlasio.HandleBackGroundException(E: Exception); +var + CanAbort : Boolean; +begin + CanAbort := TRUE; + { First call the error event handler, if any } + if Assigned(OnBgException) then begin + try + OnBgException(Self, E, CanAbort); + except + end; + end; + { Then abort the socket } + if CanAbort then begin + try + close; + except + end; + end; +end; + +procedure tlasio.sendstr(const str : string); +begin + putstringinsendbuffer(str); + sendflush; +end; + +procedure tlasio.putstringinsendbuffer(const newstring : string); +begin + if newstring <> '' then putdatainsendbuffer(@newstring[1],length(newstring)); +end; + +function tlasio.send(data:pointer;len:integer):integer; +begin + if state <> wsconnected then begin + result := -1; + exit; + end; + if len < 0 then len := 0; + result := len; + putdatainsendbuffer(data,len); + sendflush; +end; + + +procedure tlasio.putdatainsendbuffer(data:pointer;len:integer); +begin + sendq.add(data,len); +end; + +function tlasio.sendflush : integer; +var + lensent : integer; + data:pointer; +// fdstestr : fdset; +// fdstestw : fdset; +begin + if state <> wsconnected then exit; + + lensent := sendq.get(data,2920); + if assigned(data) then result := myfdwrite(fdhandleout,data^,lensent) else result := 0; + + if result = -1 then lensent := 0 else lensent := result; + + //sendq := copy(sendq,lensent+1,length(sendq)-lensent); + sendq.del(lensent); + + //fd_clr(fdhandleout,fdsw); // this prevents the socket being closed by a write + // that sends nothing because a previous socket has + // slready flushed this socket when the message loop + // reaches it +// if sendq.size > 0 then begin + eventcore.wmasterset(fdhandleout);//fd_set(fdhandleout,fdswmaster); +// end else begin +// wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster); +// end; + if result > 0 then begin + if assigned(onsenddata) then onsenddata(self,result); +// if sendq.size=0 then if assigned(ondatasent) then begin +// tltask.create(self.dodatasent,self,0,0); +// //begin test code +// fd_zero(fdstestr); +// fd_zero(fdstestw); +// fd_set(fdhandlein,fdstestr); +// fd_set(fdhandleout,fdstestw); +// select(maxs,@fdstestr,@fdstestw,nil,0); +// writeln(fd_isset(fdhandlein,fdstestr),' ',fd_isset(fdhandleout,fdstestw)); +// //end test code +// +// end; + writtenthiscycle := true; + end; +end; + +procedure tlasio.dupnowatch(invalue:longint); +begin + { debugout('invalue='+inttostr(invalue));} + //readln; + if state<> wsclosed then close; + fdhandlein := invalue; + fdhandleout := invalue; + eventcore.setfdreverse(fdhandlein,self); + {$ifndef win32} + fcntl(fdhandlein,F_SETFL,OPEN_NONBLOCK); + {$endif} + state := wsconnected; + +end; + + +procedure tlasio.dup(invalue:longint); +begin + dupnowatch(invalue); + eventcore.rmasterset(fdhandlein,false);//fd_set(fdhandlein,fdsrmaster); + eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster); +end; + + +procedure tlasio.handlefdtrigger(readtrigger,writetrigger:boolean); +var + sendflushresult : integer; + tempbuf:array[0..receivebufsize-1] of byte; +begin + if (state=wsconnected) and writetrigger then begin + //writeln('write trigger'); + + if (sendq.size >0) then begin + + sendflushresult := sendflush; + if (sendflushresult <= 0) and (not writtenthiscycle) then begin + if sendflushresult=0 then begin // linuxerror := 0; + internalclose(0); + + end else begin + internalclose({$ifdef win32}getlasterror{$else}linuxerror{$endif}); + end; + end; + + end else begin + //everything is sent fire off ondatasent event + if fdhandleout >= 0 then eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster); + if assigned(ondatasent) then tltask.create(self.dodatasent,self,0,0); + end; + if assigned(onfdwrite) then onfdwrite(self,0); + end; + writtenthiscycle := false; + if (state =wsconnected) and readtrigger then begin + if recvq.size=0 then begin + numread := myfdread(fdhandlein,tempbuf,sizeof(tempbuf)); + if (numread=0) and (not mustrefreshfds) then begin + {if i remember correctly numread=0 is caused by eof + if this isn't dealt with then you get a cpu eating infinite loop + however if onsessionconencted has called processmessages that could + cause us to drop to here with an empty recvq and nothing left to read + and we don't want that to cause the socket to close} + + internalclose(0); + end else if (numread=-1) then begin + numread := 0; + internalclose({$ifdef win32}getlasterror{$else}linuxerror{$endif}); + end else if numread > 0 then recvq.add(@tempbuf,numread); + end; + + if recvq.size > 0 then begin + if wsonoreceiveloop in componentoptions then eventcore.rmasterclr(fdhandlein); //fd_clr(fdhandlein,fdsrmaster); + if assigned(ondataavailable) then ondataAvailable(self,0); + if not (wsonoreceiveloop in componentoptions) then if recvq.size > 0 then + tltask.create(self.doreceiveloop,self,0,0); + end; + //until (numread = 0) or (currentsocket.state<>wsconnected); +{ debugout('inner loop complete');} + end; +end; + +{$ifndef win32} + procedure tlasio.flush; + var + fds : fdset; + begin + fd_zero(fds); + fd_set(fdhandleout,fds); + while sendq.size>0 do begin + select(fdhandleout+1,nil,@fds,nil,nil); + if sendflush <= 0 then exit; + end; + end; +{$endif} + +procedure tlasio.dodatasent(wparam,lparam:longint); +begin + if assigned(ondatasent) then ondatasent(self,lparam); +end; + +procedure tlasio.deletebuffereddata; +begin + sendq.del(maxlongint); +end; + +procedure tlasio.sinkdata(sender:tobject;error:word); +begin + tlasio(sender).recvq.del(maxlongint); +end; + +{$ifndef win32} + procedure tltimer.resettimes; + begin + gettimeofday(nextts); + {if not initialevent then} tv_add(nextts,interval); + end; +{$endif} + +{procedure tltimer.setinitialevent(newvalue : boolean); +begin + if newvalue <> finitialevent then begin + finitialevent := newvalue; + if assigned(timerwrapperinterface) then begin + timerwrapperinterface.setinitialevent(wrappedtimer,newvalue); + end else begin + resettimes; + end; + end; +end;} + +procedure tltimer.setontimer(newvalue:tnotifyevent); +begin + if @newvalue <> @fontimer then begin + fontimer := newvalue; + if assigned(timerwrapperinterface) then begin + timerwrapperinterface.setontimer(wrappedtimer,newvalue); + end else begin + + end; + end; + +end; + + +procedure tltimer.setenabled(newvalue : boolean); +begin + if newvalue <> fenabled then begin + fenabled := newvalue; + if assigned(timerwrapperinterface) then begin + timerwrapperinterface.setenabled(wrappedtimer,newvalue); + end else begin + {$ifdef win32} + raise exception.create('non wrapper timers are not permitted on windows'); + {$else} + resettimes; + {$endif} + end; + end; +end; + +procedure tltimer.setinterval(newvalue:integer); +begin + if newvalue <> finterval then begin + finterval := newvalue; + if assigned(timerwrapperinterface) then begin + timerwrapperinterface.setinterval(wrappedtimer,newvalue); + end else begin + {$ifdef win32} + raise exception.create('non wrapper timers are not permitted on windows'); + {$else} + resettimes; + {$endif} + end; + end; + +end; + + + + +constructor tltimer.create; +begin + inherited create(AOwner); + if assigned(timerwrapperinterface) then begin + wrappedtimer := timerwrapperinterface.createwrappedtimer; + end else begin + + + nexttimer := firsttimer; + prevtimer := nil; + + if assigned(nexttimer) then nexttimer.prevtimer := self; + firsttimer := self; + end; + interval := 1000; + enabled := true; + released := false; + +end; + +destructor tltimer.destroy; +begin + if assigned(timerwrapperinterface) then begin + wrappedtimer.free; + end else begin + if prevtimer <> nil then begin + prevtimer.nexttimer := nexttimer; + end else begin + firsttimer := nexttimer; + end; + if nexttimer <> nil then begin + nexttimer.prevtimer := prevtimer; + end; + + end; + inherited destroy; +end; + +constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint); +begin + inherited create; + if assigned(onaddtask) then onaddtask(ahandler,aobj,awparam,alparam); + handler := ahandler; + obj := aobj; + wparam := awparam; + lparam := alparam; + {nexttask := firsttask; + firsttask := self;} + if assigned(lasttask) then begin + lasttask.nexttask := self; + end else begin + firsttask := self; + end; + lasttask := self; + //ahandler(wparam,lparam); +end; + +procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint); +begin + + tltask.create(ahandler,aobj,awparam,alparam); +end; + + + + +{$ifndef nosignal} + procedure prepsigpipe;inline; + begin + starthandlesignal(sigpipe); + if not assigned(signalloopback) then begin + signalloopback := tlloopback.create(nil); + signalloopback.ondataAvailable := signalloopback.sinkdata; + + end; + + end; +{$endif} + +procedure processtasks;//inline; +var + temptask : tltask ; + +begin + + if not assigned(currenttask) then begin + currenttask := firsttask; + firsttask := nil; + lasttask := nil; + end; + while assigned(currenttask) do begin + + if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam); + if assigned(currenttask) then begin + temptask := currenttask; + currenttask := currenttask.nexttask; + temptask.free; + end; + //writeln('processed a task'); + end; + +end; + + + + +procedure disconnecttasks(aobj:tobject); +var + currenttasklocal : tltask ; + counter : byte ; +begin + for counter := 0 to 1 do begin + if counter = 0 then begin + currenttasklocal := firsttask; //main list of tasks + end else begin + currenttasklocal := currenttask; //needed in case called from a task + end; + // note i don't bother to sestroy the links here as that will happen when + // the list of tasks is processed anyway + while assigned(currenttasklocal) do begin + if currenttasklocal.obj = aobj then begin + currenttasklocal.obj := nil; + currenttasklocal.handler := nil; + end; + currenttasklocal := currenttasklocal.nexttask; + end; + end; +end; + + +procedure processmessages; +begin + eventcore.processmessages; +end; +procedure messageloop; +begin + eventcore.messageloop; +end; + +procedure exitmessageloop; +begin + eventcore.exitmessageloop; +end; + +function tlasio.RealSend(Data : Pointer; Len : Integer) : Integer; +begin + result := myfdwrite(fdhandleout,data^,len); + if (result > 0) and assigned(onsenddata) then onsenddata(self,result); + eventcore.wmasterset(fdhandleout); +end; +{$ifndef win32} + procedure tlasio.myfdclose(fd : integer); + begin + fdclose(fd); + end; + function tlasio.myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt; + begin + result := fdwrite(fd,buf,size); + end; + + function tlasio.myfdread(fd: LongInt;var buf;size: LongInt):LongInt; + begin + result := fdread(fd,buf,size); + end; + + +{$endif} + + +begin + firstasin := nil; + firsttask := nil; + + + {$ifndef nosignal} + signalloopback := nil; + {$endif} +end. + + + + + diff --git a/httpserver_20080306/lcoregtklaz.pas b/httpserver_20080306/lcoregtklaz.pas new file mode 100755 index 0000000..bbf4418 --- /dev/null +++ b/httpserver_20080306/lcoregtklaz.pas @@ -0,0 +1,142 @@ +{ 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 + ----------------------------------------------------------------------------- } + +unit lcoregtklaz; +{$mode delphi} +interface + +uses baseunix,unix,glib, gdk, gtk,lcore,forms,fd_utils,classes; +//procedure lcoregtklazrun; +const + G_IO_IN=1; + G_IO_OUT=4; + G_IO_PRI=2; + G_IO_ERR=8; + + G_IO_HUP=16; + G_IO_NVAL=32; +type + tlaztimerwrapperinterface=class(ttimerwrapperinterface) + public + function createwrappedtimer : tobject;override; +// procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);override; + procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);override; + procedure setenabled(wrappedtimer : tobject;newvalue : boolean);override; + procedure setinterval(wrappedtimer : tobject;newvalue : integer);override; + end; + +procedure lcoregtklazinit; +implementation + uses + ExtCtrls; +{$I unixstuff.inc} +var + giochannels : array[0..absoloutemaxs] of pgiochannel; + +function iocallback(source:PGIOChannel; condition:TGIOCondition; data:gpointer):gboolean;cdecl; +// return true if we want the callback to stay +var + fd : integer ; + fdsrlocal , fdswlocal : fdset ; + currentasio : tlasio ; +begin + fd := g_io_channel_unix_get_fd(source); + fd_zero(fdsrlocal); + fd_set(fd,fdsrlocal); + fdswlocal := fdsrlocal; + select(fd+1,@fdsrlocal,@fdswlocal,nil,0); + if fd_isset(fd,fdsrlocal) or fd_isset(fd,fdsrlocal) then begin + currentasio := fdreverse[fd]; + if assigned(currentasio) then begin + currentasio.handlefdtrigger(fd_isset(currentasio.fdhandlein,fdsrlocal),fd_isset(currentasio.fdhandleout,fdswlocal)); + end else begin + rmasterclr(fd); + wmasterclr(fd); + end; + end; + case condition of + G_IO_IN : begin + result := rmasterisset(fd); + end; + G_IO_OUT : begin + result := wmasterisset(fd); + end; + end; +end; + +procedure gtkrmasterset(fd : integer); +begin + if not assigned(giochannels[fd]) then giochannels[fd] := g_io_channel_unix_new(fd); + g_io_add_watch(giochannels[fd],G_IO_IN,iocallback,nil); +end; + +procedure gtkrmasterclr(fd: integer); +begin +end; + +procedure gtkwmasterset(fd : integer); +begin + if not assigned(giochannels[fd]) then giochannels[fd] := g_io_channel_unix_new(fd); + g_io_add_watch(giochannels[fd],G_IO_OUT,iocallback,nil); +end; + +procedure gtkwmasterclr(fd: integer); +begin +end; + +type + tsc = class + procedure dotasksandsink(sender:tobject;error:word); + end; +var + taskloopback : tlloopback; + sc : tsc; +procedure tsc.dotasksandsink(sender:tobject;error:word); +begin + with tlasio(sender) do begin + sinkdata(sender,error); + processtasks; + end; +end; +procedure gtkaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint); +begin + taskloopback.sendstr(' '); + +end; + +procedure lcoregtklazinit; +begin + onrmasterset := gtkrmasterset; + onrmasterclr := gtkrmasterclr; + onwmasterset := gtkwmasterset; + onwmasterclr := gtkwmasterclr; + onaddtask := gtkaddtask; + taskloopback := tlloopback.create(nil); + taskloopback.ondataavailable := sc.dotasksandsink; + timerwrapperinterface := tlaztimerwrapperinterface.create(nil); +end; + +function tlaztimerwrapperinterface.createwrappedtimer : tobject; +begin + result := ttimer.create(nil); +end; +procedure tlaztimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent); +begin + ttimer(wrappedtimer).ontimer := newvalue; +end; +procedure tlaztimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean); +begin + ttimer(wrappedtimer).enabled := newvalue; +end; + + +procedure tlaztimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer); +begin + ttimer(wrappedtimer).interval := newvalue; +end; + + +end. + diff --git a/httpserver_20080306/lcoreselect.pas b/httpserver_20080306/lcoreselect.pas new file mode 100755 index 0000000..0369448 --- /dev/null +++ b/httpserver_20080306/lcoreselect.pas @@ -0,0 +1,391 @@ +{lsocket.pas} + +{io and timer code by plugwash} + +{ 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 + ----------------------------------------------------------------------------- } + + +unit lcoreselect; + + +interface +uses + fd_utils; +var + maxs : longint ; + exitloopflag : boolean ; {if set by app, exit mainloop} + +function getfdsrmaster : fdset; {$ifdef fpc}inline;{$endif} +function getfdswmaster : fdset; {$ifdef fpc}inline;{$endif} + +implementation +uses + lcore,sysutils, + {$ifdef VER1_0} + linux, + {$else} + baseunix,unix, + {$endif} + classes,pgtypes,bfifo, + {$ifndef nosignal} + lsignal; + {$endif} + +{$include unixstuff.inc} +{$include ltimevalstuff.inc} +var + fdreverse:array[0..absoloutemaxs] of tlasio; +type + tselecteventcore=class(teventcore) + public + procedure processmessages; override; + procedure messageloop; override; + procedure exitmessageloop;override; + procedure setfdreverse(fd : integer;reverseto : tlasio); override; + procedure rmasterset(fd : integer;islistensocket : boolean); override; + procedure rmasterclr(fd: integer); override; + procedure wmasterset(fd : integer); override; + procedure wmasterclr(fd: integer); override; + end; + +procedure processtimers;inline; +var + tv ,tvnow : ttimeval ; + currenttimer : tltimer ; + temptimer : tltimer ; + +begin + gettimeofday(tvnow); + currenttimer := firsttimer; + while assigned(currenttimer) do begin + //writeln(currenttimer.enabled); + if tv_compare(tvnow,ttimeval(currenttimer.nextts)) and currenttimer.enabled then begin + //if assigned(currenttimer.ontimer) then begin + // if currenttimer.enabled then if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer); + // currenttimer.initialdone := true; + //end; + if assigned(currenttimer.ontimer) then currenttimer.ontimer(currenttimer); + currenttimer.nextts := timeval(tvnow); + tv_add(ttimeval(currenttimer.nextts),currenttimer.interval); + end; + temptimer := currenttimer; + currenttimer := currenttimer.nexttimer; + if temptimer.released then temptimer.free; + end; +end; + +procedure processasios(var fdsr,fdsw:fdset);//inline; +var + currentsocket : tlasio ; + tempsocket : tlasio ; + socketcount : integer ; // for debugging perposes :) + dw,bt:integer; +begin +{ inc(lcoretestcount);} + + //the message loop will exit if all lasio's and ltimer's and lsignal's are destroyed + //if (not assigned(firstasin)) and (not assigned(firsttimer)) and (not assigned(firstsignal)) then exit; + + + {------- test optimised loop} + socketcount := 0; + for dw := (maxs shr 5) downto 0 do if (fdsr[dw] or fdsw[dw]) <> 0 then begin + for bt := 0 to 31 do if (fdsr[dw] or fdsw[dw]) and (1 shl bt) <> 0 then begin + inc(socketcount); + currentsocket := fdreverse[dw shl 5 or bt]; + {if not assigned(currentsocket) then raise exception.create('currentsocket not assigned'); + if currentsocket.fdhandlein < 0 then raise exception.create('currentsocket.fdhandlein out of range');} + {i've seen the out of range case actually happening, so it can happen. test: just close the fd - beware} + if not assigned(currentsocket) then begin + fdclose(dw shl 5 or bt); + continue + end; + if currentsocket.fdhandlein < 0 then begin + fdclose(dw shl 5 or bt); + continue + end; + try + currentsocket.handlefdtrigger(fd_isset(currentsocket.fdhandlein,fdsr),fd_isset(currentsocket.fdhandleout,fdsw)); + except + on E: exception do begin + currentsocket.HandleBackGroundException(e); + end; + end; + + if mustrefreshfds then begin + if select(maxs+1,@fdsr,@fdsw,nil,0) <= 0 then begin + fd_zero(fdsr); + fd_zero(fdsw); + end; + end; + end; + end; + + if asinreleaseflag then begin + asinreleaseflag := false; + currentsocket := firstasin; + while assigned(currentsocket) do begin + tempsocket := currentsocket; + currentsocket := currentsocket.nextasin; + if tempsocket.released then begin + tempsocket.free; + end; + end; + end; + { + !!! issues: + - sockets which are released may not be freed because theyre never processed by the loop + made new code for handling this, using asinreleaseflag + + - when/why does the mustrefreshfds select apply, sheck if i did it correctly? + + - what happens if calling handlefdtrigger for a socket which does not have an event + } + {------- original loop} + + (* + currentsocket := firstasin; + socketcount := 0; + while assigned(currentsocket) do begin + if mustrefreshfds then begin + if select(maxs,@fdsr,@fdsw,nil,0) <= 0 then begin + fd_zero(fdsr); + fd_zero(fdsw); + end; + end; + try + if fd_isset(currentsocket.fdhandlein,fdsr) or fd_isset(currentsocket.fdhandleout,fdsw) then begin + currentsocket.handlefdtrigger(fd_isset(currentsocket.fdhandlein,fdsr),fd_isset(currentsocket.fdhandleout,fdsw)); + end; + except + on E: exception do begin + currentsocket.HandleBackGroundException(e); + end; + end; + tempsocket := currentsocket; + currentsocket := currentsocket.nextasin; + inc(socketcount); + if tempsocket.released then begin + tempsocket.free; + end; + end; *) +{ debugout('socketcount='+inttostr(socketcount));} +end; + +procedure tselecteventcore.processmessages; +var + fdsr , fdsw : fdset ; + selectresult : longint ; +begin + mustrefreshfds := false; + {$ifndef nosignal} + prepsigpipe; + {$endif} + selectresult := select(maxs+1,@fdsr,@fdsw,nil,0); + while (selectresult>0) or assigned(firsttask) or assigned(currenttask) do begin; + + processtasks; + processtimers; + if selectresult > 0 then begin + processasios(fdsr,fdsw); + end; + selectresult := select(maxs+1,@fdsr,@fdsw,nil,0); + + end; + mustrefreshfds := true; +end; + + +var + FDSR , FDSW : fdset; + +Function doSelect(timeOut:PTimeVal):longint;//inline; +var + localtimeval : ttimeval; + maxslocal : integer; +begin + //unblock signals + //zeromemory(@sset,sizeof(sset)); + //sset[0] := ; + fdsr := getfdsrmaster; + fdsw := getfdswmaster; + + if assigned(firsttask) then begin + localtimeval.tv_sec := 0; + localtimeval.tv_usec := 0; + timeout := @localtimeval; + end; + + maxslocal := maxs; + mustrefreshfds := false; +{ debugout('about to call select');} + {$ifndef nosignal} + sigprocmask(SIG_UNBLOCK,@blockset,nil); + {$endif} + result := select(maxslocal+1,@FDSR,@FDSW,nil,timeout); + if result <= 0 then begin + fd_zero(FDSR); + fd_zero(FDSW); + if result=-1 then begin + if linuxerror = SYS_EINTR then begin + // we received a signal it's not a problem + end else begin + raise esocketexception.create('select returned error '+inttostr(linuxerror)); + end; + end; + end; + {$ifndef nosignal} + sigprocmask(SIG_BLOCK,@blockset,nil); + {$endif} +{ debugout('select complete');} +end; + +procedure tselecteventcore.exitmessageloop; +begin + exitloopflag := true +end; + + + +procedure tselecteventcore.messageloop; +var + tv ,tvnow : ttimeval ; + currenttimer : tltimer ; + selectresult:integer; +begin + {$ifndef nosignal} + prepsigpipe; + {$endif} + {currentsocket := firstasin; + if not assigned(currentsocket) then exit; //the message loop will exit if all lsockets are destroyed + repeat + + if currentsocket.state = wsconnected then currentsocket.sendflush; + currentsocket := currentsocket.nextasin; + until not assigned(currentsocket);} + + + repeat + + //the message loop will exit if all lasio's and ltimer's and lsignal's are destroyed + if (not assigned(firstasin)) and (not assigned(firsttimer)) {$ifndef nosignal} and (not assigned(firstsignal)){$endif} then exit; + {fd_zero(FDSR); + fd_zero(FDSW); + currentsocket := firstasin; + if not assigned(currentsocket) then exit; //the message loop will exit if all lsockets are destroyed + + repeat + if (not currentsocket.released) and (currentsocket.state<>wsclosed) then fd_set(currentsocket.fdhandlein,fdsr); + if (not currentsocket.released) and (currentsocket.state=wsconnecting) then fd_set(currentsocket.fdhandleout,fdsw); + if currentsocket is tlsocket then begin + if (not currentsocket.released) and (currentsocket.state=wsconnected) and(tlsocket(currentsocket).sendq <> '') then fd_set(currentsocket.fdhandleout,fdsw); + end; + tempsocket := currentsocket; + currentsocket := currentsocket.nextasin; + if tempsocket.released then begin + tempsocket.free; + end; + until not assigned(currentsocket); + } + processtasks; + //currenttask := nil; + {beware} + //if assigned(firsttimer) then begin + // tv.tv_sec := maxlongint; + tv := tv_invalidtimebig; + currenttimer := firsttimer; + while assigned(currenttimer) do begin + if tv_compare(tv,currenttimer.nextts) and currenttimer.enabled then tv := currenttimer.nextts; + currenttimer := currenttimer.nexttimer; + end; + + + if tv_compare(tv,tv_invalidtimebig) then begin + //writeln('no timers active'); + if exitloopflag then break; +{ sleep(10);} + selectresult := doselect(nil); + + end else begin + gettimeofday(tvnow); + tv_substract(tv,tvnow); + + //writeln('timers active'); + if tv.tv_sec < 0 then begin + tv.tv_sec := 0; + tv.tv_usec := 0; {0.1 sec} + end; + if exitloopflag then break; +{ sleep(10);} + selectresult := doselect(@tv); + processtimers; + + end; + if selectresult > 0 then processasios(fdsr,fdsw); + {!!!only call processasios if select has asio events -beware} + + {artificial delay to throttle the number of processasios per second possible and reduce cpu usage} + until false; +end; + +var + fdsrmaster , fdswmaster : fdset ; + +procedure tselecteventcore.rmasterset(fd : integer;islistensocket : boolean); +begin + if fd > absoloutemaxs then raise esocketexception.create('file discriptor out of range'); + if fd > maxs then maxs := fd; + if fd_isset(fd,fdsrmaster) then exit; + fd_set(fd,fdsrmaster); + +end; + +procedure tselecteventcore.rmasterclr(fd: integer); +begin + if not fd_isset(fd,fdsrmaster) then exit; + fd_clr(fd,fdsrmaster); + +end; + + +procedure tselecteventcore.wmasterset(fd : integer); +begin + if fd > absoloutemaxs then raise esocketexception.create('file discriptor out of range'); + if fd > maxs then maxs := fd; + + if fd_isset(fd,fdswmaster) then exit; + fd_set(fd,fdswmaster); + +end; + +procedure tselecteventcore.wmasterclr(fd: integer); +begin + if not fd_isset(fd,fdswmaster) then exit; + fd_clr(fd,fdswmaster); +end; + +procedure tselecteventcore.setfdreverse(fd : integer;reverseto : tlasio); +begin + fdreverse[fd] := reverseto; +end; + +function getfdsrmaster : fdset; {$ifdef fpc}inline;{$endif} +begin + result := fdsrmaster; +end; +function getfdswmaster : fdset; {$ifdef fpc}inline;{$endif} +begin + result := fdswmaster; +end; + + +begin + eventcore := tselecteventcore.create; + + maxs := 0; + fd_zero(fdsrmaster); + fd_zero(fdswmaster); +end. diff --git a/httpserver_20080306/lcoretest.dpr b/httpserver_20080306/lcoretest.dpr new file mode 100755 index 0000000..e9d1b0a --- /dev/null +++ b/httpserver_20080306/lcoretest.dpr @@ -0,0 +1,167 @@ +program lcoretest; + +uses + lcore, + lsocket, + {$ifdef win32} + lcorewsaasyncselect in 'lcorewsaasyncselect.pas', + {$else} + lcoreselect, + {$endif} + dnsasync, + binipstuff, + dnssync; +{$ifdef win32} + {$R *.RES} +{$endif} + +type + tsc=class + procedure sessionavailable(sender: tobject;error : word); + procedure dataavailable(sender: tobject;error : word); + procedure sessionconnected(sender: tobject;error : word); + procedure taskrun(wparam,lparam:longint); + procedure timehandler(sender:tobject); + procedure dnsrequestdone(sender:tobject;error : word); + procedure sessionclosed(sender:tobject;error : word); + end; +var + listensocket : tlsocket; + serversocket : tlsocket; + clientsocket : tlsocket; + sc : tsc; + task : tltask; +procedure tsc.sessionavailable(sender: tobject;error : word); +begin + writeln('received connection'); + serversocket.dup(listensocket.accept); +end; + +var + receivebuf : string; + receivecount : integer; +procedure tsc.dataavailable(sender: tobject;error : word); +var + receiveddata : string; + receivedon : string; +begin + receiveddata := tlsocket(sender).receivestr; + if sender=clientsocket then begin + receivedon := 'client socket'; + end else begin + receivedon := 'server socket'; + end; + writeln('received data '+receiveddata+' on '+receivedon); + if sender=serversocket then begin + receivebuf := receivebuf+receiveddata; + end; + if receivebuf = 'hello world' then begin + receivebuf := ''; + writeln('received hello world creating task'); + task := tltask.create(sc.taskrun,nil,0,0); + end; + receivecount := receivecount +1; + if receivecount >50 then begin + writeln('received over 50 bits of data, pausing to let the operator take a look'); + readln; + receivecount := 0; + end; + +end; + +procedure tsc.sessionconnected(sender: tobject;error : word); +begin + if error=0 then begin + writeln('session is connected'); + if clientsocket.addr = '127.0.0.1' then begin + clientsocket.sendstr('hello world'); + end else begin + clientsocket.sendstr('get /'#13#10#13#10); + end; + end else begin + writeln('connect failed'); + end; +end; + +var + das : tdnsasync; + +procedure tsc.taskrun(wparam,lparam:longint); +var + tempbinip : tbinip; + dummy : integer; +begin + writeln('task ran'); + writeln('closing client socket'); + clientsocket.close; + + writeln('looking up www.kame.net using dnsasync'); + das := tdnsasync.Create(nil); + das.onrequestdone := sc.dnsrequestdone; + das.forwardfamily := af_inet6; + das.forwardlookup('www.kame.net'); +end; + +procedure tsc.dnsrequestdone(sender:tobject;error : word); +begin + writeln('www.kame.net resolved to '+das.dnsresult+' connecting client socket there'); + clientsocket.addr := das.dnsresult; + clientsocket.port := '80'; + clientsocket.connect; + das.free; +end; + +procedure tsc.timehandler(sender:tobject); +begin + //writeln('got timer event'); +end; +procedure tsc.sessionclosed(sender:tobject;error : word); +begin + Writeln('session closed with error ',error); +end; +var + timer : tltimer; + ipbin : tbinip; + dummy : integer; +begin + ipbin := forwardlookup('invalid.domain',5); + writeln(ipbintostr(ipbin)); + + ipbin := forwardlookup('p10link.net',5); + writeln(ipbintostr(ipbin)); + + ipstrtobin('80.68.89.68',ipbin); + writeln('80.68.89.68 reverses to '+reverselookup(ipbin,5)); + + ipstrtobin('2001:200::8002:203:47ff:fea5:3085',ipbin); + writeln('2001:200::8002:203:47ff:fea5:3085 reverses to '+reverselookup(ipbin,5)); + writeln('creating and setting up listen socket'); + listensocket := tlsocket.create(nil); + listensocket.addr := '0.0.0.0'; + listensocket.port := '12345'; + listensocket.onsessionavailable := sc.sessionavailable; + writeln('listening'); + listensocket.listen; + writeln('listen socket is number ', listensocket.fdhandlein); + writeln('creating and setting up server socket'); + serversocket := tlsocket.create(nil); + serversocket.ondataavailable := sc.dataavailable; + writeln('creating and setting up client socket'); + clientsocket := tlsocket.create(nil); + clientsocket.addr := {'::1';}'127.0.0.1'; + clientsocket.port := '12345'; + clientsocket.onsessionconnected := sc.sessionconnected; + clientsocket.ondataAvailable := sc.dataavailable; + clientsocket.onsessionclosed := sc.sessionclosed; + writeln('connecting'); + clientsocket.connect; + writeln('client socket is number ',clientsocket.fdhandlein); + writeln('creating and setting up timer'); + timer := tltimer.create(nil); + timer.interval := 1000; + timer.ontimer := sc.timehandler; + timer.enabled := true; + writeln('entering message loop'); + messageloop; + writeln('exiting cleanly'); +end. diff --git a/httpserver_20080306/lcorewsaasyncselect.pas b/httpserver_20080306/lcorewsaasyncselect.pas new file mode 100755 index 0000000..a978c23 --- /dev/null +++ b/httpserver_20080306/lcorewsaasyncselect.pas @@ -0,0 +1,216 @@ +unit lcorewsaasyncselect; + +interface + +implementation +uses wcore,lcore,bsearchtree,sysutils,windows,winsock,pgtypes,messages,classes; +type + twineventcore=class(teventcore) + public + procedure processmessages; override; + procedure messageloop; override; + procedure exitmessageloop;override; + procedure setfdreverse(fd : integer;reverseto : tlasio); override; + procedure rmasterset(fd : integer;islistensocket : boolean); override; + procedure rmasterclr(fd: integer); override; + procedure wmasterset(fd : integer); override; + procedure wmasterclr(fd: integer); override; + end; +const + wm_dotasks=wm_user+1; +type + twintimerwrapperinterface=class(ttimerwrapperinterface) + public + function createwrappedtimer : tobject;override; +// procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);override; + procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);override; + procedure setenabled(wrappedtimer : tobject;newvalue : boolean);override; + procedure setinterval(wrappedtimer : tobject;newvalue : integer);override; + end; + +procedure twineventcore.processmessages; +begin + wcore.processmessages;//pass off to wcore +end; +procedure twineventcore.messageloop; +begin + wcore.messageloop; //pass off to wcore +end; +procedure twineventcore.exitmessageloop; +begin + wcore.exitmessageloop; +end; +var + fdreverse : thashtable; + fdwatches : thashtable; + +procedure twineventcore.setfdreverse(fd : integer;reverseto : tlasio); +begin + if findtree(@fdreverse,inttostr(fd)) <> nil then deltree(@fdreverse,inttostr(fd)); + if reverseto <> nil then addtree(@fdreverse,inttostr(fd),reverseto); +end; + +var + hwndlcore : hwnd; +procedure dowsaasyncselect(fd:integer; leventadd: integer; leventremove : integer); +var + leventold : integer; + leventnew : integer; + wsaaresult : integer; +begin + leventold := taddrint(findtree(@fdwatches,inttostr(fd))); + leventnew := leventold or leventadd; + leventnew := leventnew and not leventremove; + if leventold <> leventnew then begin + if leventold <> 0 then deltree(@fdwatches,inttostr(fd)); + if leventnew <> 0 then addtree(@fdwatches,inttostr(fd),pointer(leventnew)); + end; + wsaaresult := wsaasyncselect(fd,hwndlcore,wm_user,leventnew); + +end; + + +//to allow detection of errors: +//if we are asked to monitor for read or accept we also monitor for close +//if we are asked to monitor for write we also monitor for connect + + +procedure twineventcore.rmasterset(fd : integer;islistensocket : boolean); +begin + if islistensocket then begin + //writeln('setting accept watch for socket number ',fd); + dowsaasyncselect(fd,FD_ACCEPT or FD_CLOSE,0); + end else begin + //writeln('setting read watch for socket number',fd); + dowsaasyncselect(fd,FD_READ or FD_CLOSE,0); + end; +end; +procedure twineventcore.rmasterclr(fd: integer); +begin + //writeln('clearing read of accept watch for socket number ',fd); + dowsaasyncselect(fd,0,FD_ACCEPT or FD_READ or FD_CLOSE); +end; +procedure twineventcore.wmasterset(fd : integer); +begin + dowsaasyncselect(fd,FD_WRITE or FD_CONNECT,0); +end; + +procedure twineventcore.wmasterclr(fd: integer); +begin + dowsaasyncselect(fd,0,FD_WRITE or FD_CONNECT); +end; + +var + tasksoutstanding : boolean; + +function MyWindowProc( + ahWnd : HWND; + auMsg : Integer; + awParam : WPARAM; + alParam : LPARAM): Integer; stdcall; +var + socket : integer; + event : integer; + error : integer; + readtrigger : boolean; + writetrigger : boolean; + lasio : tlasio; +begin + //writeln('got a message'); + Result := 0; // This means we handled the message + if (ahwnd=hwndlcore) and (aumsg=wm_user) then begin + //writeln('it appears to be a response to our wsaasyncselect'); + socket := awparam; + event := alparam and $FFFF; + error := alparam shr 16; + //writeln('socket=',socket,' event=',event,' error=',error); + readtrigger := false; + writetrigger := false; + lasio := findtree(@fdreverse,inttostr(socket)); + if assigned(lasio) then begin + if (error <> 0) or ((event and FD_CLOSE) <> 0) then begin + if lasio.state = wsconnecting then begin + lasio.onsessionconnected(lasio,error); + end; + lasio.internalclose(error); + end else begin + if (event and (FD_READ or FD_ACCEPT)) <> 0 then readtrigger := true; + if (event and (FD_WRITE)) <> 0 then writetrigger := true; + + if readtrigger or writetrigger then lasio.handlefdtrigger(readtrigger,writetrigger); + end; + dowsaasyncselect(socket,0,0); //reset watches + end; + end else if (ahwnd=hwndlcore) and (aumsg=wm_dotasks) then begin + //writeln('processing tasks'); + tasksoutstanding := false; + processtasks; + end else begin + //writeln('passing unknown message to defwindowproc'); + //not passing unknown messages on to defwindowproc will cause window + //creation to fail! --plugwash + Result := DefWindowProc(ahWnd, auMsg, awParam, alParam) + end; + +end; + +procedure winaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint); +begin + if not tasksoutstanding then PostMessage(hwndlcore,wm_dotasks,0,0); +end; +type + twcoretimer = wcore.tltimer; + +function twintimerwrapperinterface.createwrappedtimer : tobject; +begin + result := twcoretimer.create(nil); +end; +procedure twintimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent); +begin + twcoretimer(wrappedtimer).ontimer := newvalue; +end; +procedure twintimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean); +begin + twcoretimer(wrappedtimer).enabled := newvalue; +end; + + +procedure twintimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer); +begin + twcoretimer(wrappedtimer).interval := newvalue; +end; + +var + MyWindowClass : TWndClass = (style : 0; + lpfnWndProc : @MyWindowProc; + cbClsExtra : 0; + cbWndExtra : 0; + hInstance : 0; + hIcon : 0; + hCursor : 0; + hbrBackground : 0; + lpszMenuName : nil; + lpszClassName : 'lcoreClass'); + GInitData: TWSAData; + +begin + eventcore := twineventcore.create; + if Windows.RegisterClass(MyWindowClass) = 0 then halt; + //writeln('about to create lcore handle, hinstance=',hinstance); + hwndlcore := CreateWindowEx(WS_EX_TOOLWINDOW, + MyWindowClass.lpszClassName, + '', { Window name } + WS_POPUP, { Window Style } + 0, 0, { X, Y } + 0, 0, { Width, Height } + 0, { hWndParent } + 0, { hMenu } + HInstance, { hInstance } + nil); { CreateParam } + //writeln('lcore hwnd is ',hwndlcore); + //writeln('last error is ',GetLastError); + onaddtask := winaddtask; + timerwrapperinterface := twintimerwrapperinterface.create(nil); + + WSAStartup($200, GInitData); +end. diff --git a/httpserver_20080306/lloopback.pas b/httpserver_20080306/lloopback.pas new file mode 100755 index 0000000..da26263 --- /dev/null +++ b/httpserver_20080306/lloopback.pas @@ -0,0 +1,30 @@ +unit lloopback; + +interface +uses lcore,classes; + +type + tlloopback=class(tlasio) + public + constructor create(aowner:tcomponent); override; + end; + + +implementation +uses + baseunix,unix; +{$i unixstuff.inc} + +constructor tlloopback.create(aowner:tcomponent); +begin + inherited create(aowner); + closehandles := true; + assignpipe(fdhandlein,fdhandleout); + + eventcore.rmasterset(fdhandlein,false);//fd_set(fdhandlein,fdsrmaster); + eventcore.wmasterclr(fdhandlein);//fd_clr(fdhandleout,fdswmaster); + eventcore.setfdreverse(fdhandlein,self); + eventcore.setfdreverse(fdhandleout,self); + state := wsconnected; +end; +end. diff --git a/httpserver_20080306/lmessages.pas b/httpserver_20080306/lmessages.pas new file mode 100755 index 0000000..7bb73fd --- /dev/null +++ b/httpserver_20080306/lmessages.pas @@ -0,0 +1,656 @@ +unit lmessages; +//windows messages like system based on lcore tasks +interface + +uses pgtypes,sysutils,bsearchtree,strings,syncobjs; + +type + lparam=taddrint; + wparam=taddrint; + thinstance=pointer; + hicon=pointer; + hcursor=pointer; + hbrush=pointer; + hwnd=qword; //window handles are monotonically increasing 64 bit integers, + //this should allow for a million windows per second for over half + //a million years! + + twndproc=function(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall; + + + twndclass=record + style : dword; + lpfnwndproc : twndproc; + cbclsextra : integer; + cbwndextra : integer; + hinstance : thinstance; + hicon : hicon; + hcursor : hcursor; + hbrbackground : hbrush; + lpszmenuname : pchar; + lpszclassname : pchar; + end; + PWNDCLASS=^twndclass; + + UINT=dword; + WINBOOL = longbool; + tTIMERPROC = procedure (ahwnd:HWND; umsg:integer; idevent:taddrint;dwtime:taddrint);stdcall; + ATOM = pointer; + LPCSTR = pchar; + LPVOID = pointer; + HMENU = pointer; + HINST = pointer; + + TPOINT = record + x : LONGint; + y : LONGint; + end; + + TMSG = record + hwnd : HWND; + message : UINT; + wParam : WPARAM; + lParam : LPARAM; + time : DWORD; + pt : TPOINT; + end; + THevent=TEventObject; +const + WS_EX_TOOLWINDOW = $80; + WS_POPUP = longint($80000000); + hinstance=nil; + PM_REMOVE = 1; + WM_USER = 1024; + WM_TIMER = 275; + INFINITE = syncobjs.infinite; +function getwindowlongptr(ahwnd:hwnd;nindex:integer) : taddrint; +function setwindowlongptr(ahwnd:hwnd;nindex:integer;dwNewLong : taddrint) : taddrint; +function DefWindowProc(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall; +function RegisterClass(const lpWndClass:TWNDCLASS):ATOM; +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; +function DestroyWindow(ahWnd:HWND):WINBOOL; +function PostMessage(hWnd:HWND; Msg:UINT; wParam:WPARAM; lParam:LPARAM):WINBOOL; +function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): WINBOOL; +function DispatchMessage(const lpMsg: TMsg): Longint; +function GetMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT): WINBOOL; +function SetEvent(hEvent:THevent):WINBOOL; +function CreateEvent(lpEventAttributes:PSECURITYATTRIBUTES; bManualReset:WINBOOL; bInitialState:WINBOOL; lpName:pchar):tHevent; +function terminatethread(threadhandle : tthreadid;dummy:integer) : boolean; +function waitforsingleevent(event:thevent;timeout:cardinal) : twaitresult; +function SetTimer(ahWnd:HWND; nIDEvent:taddrint; uElapse:UINT; lpTimerFunc:tTIMERPROC):UINT; +function KillTimer(ahWnd:HWND; uIDEvent:taddrint):WINBOOL; + +procedure init; + +implementation +uses + baseunix,unix,lcore;//,safewriteln; +{$i unixstuff.inc} + +type + tmessageintransit = class + msg : tmsg; + next : tmessageintransit; + end; + + tthreaddata = class + messagequeue : tmessageintransit; + messageevent : teventobject; + waiting : boolean; + lcorethread : boolean; + nexttimer : ttimeval; + threadid : integer; + end; + twindow=class + hwnd : hwnd; + extrawindowmemory : pointer; + threadid : tthreadid; + windowproc : twndproc; + end; + +var + structurelock : tcriticalsection; + threaddata : thashtable; + windowclasses : thashtable; + lcorelinkpipesend : integer; + lcorelinkpiperecv : tlasio; + windows : thashtable; + //I would rather things crash immediately + //if they use an insufficiant size type + //than crash after over four billion + //windows have been made ;) + nextwindowhandle : qword = $100000000; +{$i ltimevalstuff.inc} + +//findthreaddata should only be called while holding the structurelock +function findthreaddata(threadid : integer) : tthreaddata; +begin + result := tthreaddata(findtree(@threaddata,inttostr(threadid))); + if result = nil then begin + result := tthreaddata.create; + result.messageevent := teventobject.create(nil,false,false,inttostr(taddrint(result))); + result.nexttimer := tv_invalidtimebig; + result.threadid := threadid; + addtree(@threaddata,inttostr(threadid),result); + end; +end; + +//deletethreaddataifunused should only be called while holding the structurelock +procedure deletethreaddataifunused(athreaddata : tthreaddata); +begin + //writeln('in deletethreaddataifunused'); + 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 + //writeln('threaddata is unused, freeing messageevent'); + athreaddata.messageevent.free; + //writeln('freeing thread data object'); + athreaddata.free; + //writeln('deleting thread data object from hashtable'); + deltree(@threaddata,inttostr(athreaddata.threadid)); + //writeln('finished deleting thread data'); + end else begin + //writeln('thread data is not unused'); + end; +end; + +function getwindowlongptr(ahwnd:hwnd;nindex:integer) : taddrint; +var + window : twindow; +begin + structurelock.acquire; + try + window := findtree(@windows,inttostr(ahwnd)); + if window <> nil then begin + result := paddrint(taddrint(window.extrawindowmemory)+nindex)^; + end else begin + result := 0; + end; + finally + structurelock.release; + end; +end; + +function setwindowlongptr(ahwnd:hwnd;nindex:integer;dwNewLong : taddrint) : taddrint; +var + window : twindow; +begin + structurelock.acquire; + try + window := findtree(@windows,inttostr(ahwnd)); + if window <> nil then begin + result := paddrint(taddrint(window.extrawindowmemory)+nindex)^; + paddrint(taddrint(window.extrawindowmemory)+nindex)^ := dwnewlong; + end else begin + result := 0; + end; + finally + structurelock.release; + end; + +end; + + +function DefWindowProc(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall; +begin + result := 0; +end; + +function strdup(s:pchar) : pchar; +begin + //swriteln('in strdup, about to allocate memory'); + result := getmem(strlen(s)+1); + //swriteln('about to copy string'); + strcopy(s,result); + //swriteln('leaving strdup'); +end; + +function RegisterClass(const lpWndClass:TWNDCLASS):ATOM; +var + storedwindowclass:pwndclass; +begin + structurelock.acquire; + try + //swriteln('in registerclass, about to check for duplicate window class'); + storedwindowclass := findtree(@windowclasses, lpwndclass.lpszclassname); + if storedwindowclass <> nil then begin + + if comparebyte(storedwindowclass^,lpwndclass,sizeof(twndclass)-sizeof(pchar)-sizeof(pchar)) <> 0 then begin + //swriteln('duplicate window class registered with different settings'); + raise exception.create('duplicate window class registered with different settings'); + end else begin + //swriteln('duplicate window class registered with same settings, tollerated'); + end; + end else begin + //swriteln('about to allocate memory for new windowclass'); + storedwindowclass := getmem(sizeof(twndclass)); + //swriteln('about to copy windowclass from parameter'); + move(lpwndclass,storedwindowclass^,sizeof(twndclass)); + //swriteln('about to copy strings'); + if lpwndclass.lpszmenuname <> nil then storedwindowclass.lpszmenuname := strdup(lpwndclass.lpszmenuname); + if lpwndclass.lpszclassname <> nil then storedwindowclass.lpszclassname := strdup(lpwndclass.lpszclassname); + //swriteln('about to add result to list of windowclasses'); + addtree(@windowclasses,lpwndclass.lpszclassname,storedwindowclass); + end; + //swriteln('about to return result'); + result := storedwindowclass; + //swriteln('leaving registerclass'); + finally + structurelock.release; + end; +end; + +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; +var + wndclass : pwndclass; + tm : tthreadmanager; + window : twindow; +begin + structurelock.acquire; + try + window := twindow.create; + window.hwnd := nextwindowhandle; + result := window.hwnd; + nextwindowhandle := nextwindowhandle + 1; + addtree(@windows,inttostr(window.hwnd),window); + wndclass := findtree(@windowclasses,lpclassname); + window.extrawindowmemory := getmem(wndclass.cbwndextra); + + getthreadmanager(tm); + window.threadid := tm.GetCurrentThreadId; + window.windowproc := wndclass.lpfnwndproc; + finally + structurelock.release; + end; +end; +function DestroyWindow(ahWnd:HWND):WINBOOL; +var + window : twindow; + windowthreaddata : tthreaddata; + currentmessage : tmessageintransit; + prevmessage : tmessageintransit; +begin + //writeln('started to destroy window'); + structurelock.acquire; + try + window := twindow(findtree(@windows,inttostr(ahwnd))); + if window <> nil then begin + freemem(window.extrawindowmemory); + //writeln('aboute to delete window from windows structure'); + deltree(@windows,inttostr(ahwnd)); + //writeln('deleted window from windows structure'); + windowthreaddata := tthreaddata(findtree(@threaddata,inttostr(window.threadid))); + + if windowthreaddata <> nil then begin + //writeln('found thread data scanning for messages to clean up'); + currentmessage := windowthreaddata.messagequeue; + prevmessage := nil; + while currentmessage <> nil do begin + while (currentmessage <> nil) and (currentmessage.msg.hwnd = ahwnd) do begin + if prevmessage = nil then begin + windowthreaddata.messagequeue := currentmessage.next; + end else begin + prevmessage.next := currentmessage.next; + end; + currentmessage.free; + if prevmessage = nil then begin + currentmessage := windowthreaddata.messagequeue; + end else begin + currentmessage := prevmessage.next; + end; + end; + if currentmessage <> nil then begin + prevmessage := currentmessage; + currentmessage := currentmessage.next; + end; + end; + //writeln('deleting thread data structure if it is unused'); + deletethreaddataifunused(windowthreaddata); + end else begin + //writeln('there is no thread data to search for messages to cleanup'); + end; + //writeln('freeing window'); + window.free; + result := true; + end else begin + result := false; + end; + finally + structurelock.release; + end; + //writeln('window destroyed'); +end; + + + +function PostMessage(hWnd:HWND; Msg:UINT; wParam:WPARAM; lParam:LPARAM):WINBOOL; +var + threaddata : tthreaddata; + message : tmessageintransit; + messagequeueend : tmessageintransit; + window : twindow; +begin + structurelock.acquire; + try + window := findtree(@windows,inttostr(hwnd)); + if window <> nil then begin + threaddata := findthreaddata(window.threadid); + message := tmessageintransit.create; + message.msg.hwnd := hwnd; + message.msg.message := msg; + message.msg.wparam := wparam; + message.msg.lparam := lparam; + if threaddata.lcorethread then begin + //swriteln('posting message to lcore thread'); + fdwrite(lcorelinkpipesend,message,sizeof(message)); + end else begin + //writeln('posting message to non lcore thread'); + if threaddata.messagequeue = nil then begin + threaddata.messagequeue := message; + end else begin + messagequeueend := threaddata.messagequeue; + while messagequeueend.next <> nil do begin + messagequeueend := messagequeueend.next; + end; + messagequeueend.next := message; + end; + + //writeln('message added to queue'); + if threaddata.waiting then threaddata.messageevent.setevent; + end; + result := true; + end else begin + result := false; + end; + finally + structurelock.release; + end; + +end; + +function gettickcount : dword; +var + result64: integer; + tv : ttimeval; +begin + gettimeofday(tv); + result64 := (tv.tv_sec*1000)+(tv.tv_usec div 1000); + result := result64; +end; + +function DispatchMessage(const lpMsg: TMsg): Longint; +var + timerproc : ttimerproc; + window : twindow; + windowproc : twndproc; +begin + ////swriteln('in dispatchmessage, msg.hwnd='+inttohex(taddrint(lpmsg.hwnd),16)); + if (lpmsg.lparam <> 0) and (lpmsg.message = WM_TIMER) then begin + timerproc := ttimerproc(lpmsg.lparam); + timerproc(lpmsg.hwnd,lpmsg.message,lpmsg.wparam,gettickcount); + result := 0; + end else begin + structurelock.acquire; + try + window := findtree(@windows,inttostr(lpmsg.hwnd)); + //we have to get the window procedure while the structurelock + //is still held as the window could be destroyed from another thread + //otherwise. + windowproc := window.windowproc; + finally + structurelock.release; + end; + if window <> nil then begin + result := windowproc(lpmsg.hwnd,lpmsg.message,lpmsg.wparam,lpmsg.lparam); + end else begin + result := -1; + end; + end; +end; + +procedure processtimers; +begin +end; + +function GetMessageinternal(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT; wremovemsg : UINT;peek:boolean): WINBOOL; +var + tm : tthreadmanager; + threaddata : tthreaddata; + message : tmessageintransit; + nowtv : ttimeval; + timeouttv : ttimeval; + timeoutms : int64; + +begin + if hwnd <> 0 then raise exception.create('getting messages for an individual window is not supported'); + if (wmsgfiltermin <> 0) or (wmsgfiltermax <> 0) then raise exception.create('message filtering is not supported'); + structurelock.acquire; + result := true; + try + getthreadmanager(tm); + threaddata := findthreaddata(tm.GetCurrentThreadId); + if threaddata.lcorethread then raise exception.create('get/peek message cannot be used in the lcore thread'); + message := threaddata.messagequeue; + gettimeofday(nowtv); + while (not peek) and (message=nil) and (not tv_compare(nowtv,threaddata.nexttimer)) do begin + threaddata.waiting := true; + structurelock.release; + if (threaddata.nexttimer.tv_sec = TV_invalidtimebig.tv_sec) and (threaddata.nexttimer.tv_usec = TV_invalidtimebig.tv_usec) then begin + threaddata.messageevent.waitfor(INFINITE); + end else begin + + timeouttv := threaddata.nexttimer; + timeoutms := (timeouttv.tv_sec * 1000)+(timeouttv.tv_usec div 1000); + //i'm assuming the timeout is in milliseconds + if (timeoutms > maxlongint) then timeoutms := maxlongint; + threaddata.messageevent.waitfor(timeoutms); + + end; + structurelock.acquire; + threaddata.waiting := false; + message := threaddata.messagequeue; + gettimeofday(nowtv); + end; + if (message=nil) and tv_compare(nowtv,threaddata.nexttimer) then begin + processtimers; + end; + message := threaddata.messagequeue; + if message <> nil then begin + lpmsg := message.msg; + if wremovemsg=PM_REMOVE then begin + threaddata.messagequeue := message.next; + message.free; + end; + end else begin + result :=false; + end; + deletethreaddataifunused(threaddata); + finally + structurelock.release; + end; +end; + +function GetMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT): WINBOOL; +begin + result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,PM_REMOVE,false); +end; + +function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): WINBOOL; +begin + result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,PM_REMOVE,true); +end; + +function SetEvent(hEvent:THevent):WINBOOL; +begin + hevent.setevent; + result := true; +end; + +function CreateEvent(lpEventAttributes:PSECURITYATTRIBUTES; bManualReset:WINBOOL; bInitialState:WINBOOL; lpName:pchar):tHevent; +begin + result := teventobject.create(lpeventattributes,bmanualreset,binitialstate,lpname); +end; + +function terminatethread(threadhandle:tthreadid;dummy : integer) : boolean; +var + tm : tthreadmanager; +begin + getthreadmanager(tm); + tm.killthread(threadhandle); + result := true; +end; + +function waitforsingleevent(event:thevent;timeout:cardinal) : twaitresult; +begin + result := event.waitfor(timeout); +end; + +procedure removefrombuffer(n : integer; var buffer:string); +begin + if n=length(buffer) then begin + buffer := ''; + end else begin + uniquestring(buffer); + move(buffer[n+1],buffer[1],length(buffer)-n); + setlength(buffer,length(buffer)-n); + end; +end; + +type + tsc=class + procedure available(sender:tobject;error:word); + end; + +var + recvbuf : string; + +procedure tsc.available(sender:tobject;error:word); +var + message : tmessageintransit; + messagebytes : array[1..sizeof(tmessageintransit)] of char absolute message; + i : integer; +begin + //swriteln('received data on lcorelinkpipe'); + recvbuf := recvbuf + lcorelinkpiperecv.receivestr; + while length(recvbuf) >= sizeof(tmessageintransit) do begin + for i := 1 to sizeof(tmessageintransit) do begin + messagebytes[i] := recvbuf[i]; + end; + dispatchmessage(message.msg); + message.free; + removefrombuffer(sizeof(tmessageintransit),recvbuf); + end; +end; + +procedure init; +var + tm : tthreadmanager; + threaddata : tthreaddata; + pipeends : tfildes; + sc : tsc; +begin + structurelock := tcriticalsection.create; + getthreadmanager(tm); + threaddata := findthreaddata(tm.GetCurrentThreadId); + threaddata.lcorethread := true; + fppipe(pipeends); + lcorelinkpipesend := pipeends[1]; + lcorelinkpiperecv := tlasio.create(nil); + lcorelinkpiperecv.dup(pipeends[0]); + lcorelinkpiperecv.ondataavailable := sc.available; + recvbuf := ''; +end; + +var + lcorethreadtimers : thashtable; +type + tltimerformsg = class(tltimer) + public + hwnd : hwnd; + id : taddrint; + procedure timer(sender : tobject); + end; + +procedure tltimerformsg.timer(sender : tobject); +var + msg : tmsg; +begin + ////swriteln('in tltimerformsg.timer'); + fillchar(msg,sizeof(msg),0); + msg.message := WM_TIMER; + msg.hwnd := hwnd; + msg.wparam := ID; + msg.lparam := 0; + dispatchmessage(msg); +end; + +function SetTimer(ahWnd:HWND; nIDEvent:taddrint; uElapse:UINT; lpTimerFunc:tTIMERPROC):UINT; +var + threaddata : tthreaddata; + ltimer : tltimerformsg; + tm : tthreadmanager; + window : twindow; +begin + structurelock.acquire; + try + window := findtree(@windows,inttostr(ahwnd)); + if window= nil then raise exception.create('invalid window'); + threaddata := findthreaddata(window.threadid); + finally + structurelock.release; + end; + if threaddata.lcorethread then begin + getthreadmanager(tm); + if tm.GetCurrentThreadId <> window.threadid then raise exception.create('timers on the lcore thread may only be added and removed from the lcore thread'); + if ahwnd = 0 then raise exception.create('timers on the lcore thread must be associated with a window handle'); + if @lptimerfunc <> nil then raise exception.create('seperate timer functions are not supported'); + + //remove preexisting timer with same ID + killtimer(ahwnd,nIDEvent); + + ltimer := tltimerformsg.create(nil); + ltimer.interval := uelapse; + ltimer.id := nidevent; + ltimer.hwnd := ahwnd; + ltimer.enabled := true; + ltimer.ontimer := ltimer.timer; + + addtree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(nIDEvent),ltimer); + + result := nidevent; + end else begin + raise exception.create('settimer not implemented for threads other than the lcore thread'); + end; +end; + +function KillTimer(ahWnd:HWND; uIDEvent:taddrint):WINBOOL; +var + threaddata : tthreaddata; + ltimer : tltimerformsg; + tm : tthreadmanager; + window : twindow; +begin + structurelock.acquire; + try + window := findtree(@windows,inttostr(ahwnd)); + if window= nil then raise exception.create('invalid window'); + threaddata := findthreaddata(window.threadid); + finally + structurelock.release; + end; + if threaddata.lcorethread then begin + getthreadmanager(tm); + if tm.GetCurrentThreadId <> window.threadid then raise exception.create('timers on the lcore thread may only be added and remove from the lcore thread'); + if ahwnd = 0 then raise exception.create('timers on the lcore thread must be associated with a window handle'); + ltimer := tltimerformsg(findtree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(uIDEvent))); + if ltimer <> nil then begin + deltree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(uIDEvent)); + ltimer.free; + result := true; + end else begin + result := false; + end; + end else begin + raise exception.create('settimer not implemented for threads other than the lcore thread'); + end; +end; + +end. \ No newline at end of file diff --git a/httpserver_20080306/lsignal.pas b/httpserver_20080306/lsignal.pas new file mode 100755 index 0000000..573fe28 --- /dev/null +++ b/httpserver_20080306/lsignal.pas @@ -0,0 +1,198 @@ +{lsocket.pas} + +{signal code by plugwash} + +{ 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 + ----------------------------------------------------------------------------- } + +unit lsignal; +{$mode delphi} +interface + uses sysutils, + {$ifdef VER1_0} + linux, + {$else} + baseunix,unix, + {$endif} + classes,lcore,lloopback; + + type + tsignalevent=procedure(sender:tobject;signal:integer) of object; + tlsignal=class(tcomponent) + public + onsignal : tsignalevent ; + prevsignal : tlsignal ; + nextsignal : tlsignal ; + + constructor create(aowner:tcomponent);override; + destructor destroy;override; + end; + + + procedure starthandlesignal(signal:integer); + +var + firstsignal : tlsignal; + blockset : sigset; + signalloopback : tlloopback ; + +implementation +{$include unixstuff.inc} + +constructor tlsignal.create; +begin + inherited create(AOwner); + nextsignal := firstsignal; + prevsignal := nil; + + if assigned(nextsignal) then nextsignal.prevsignal := self; + firstsignal := self; + + //interval := 1000; + //enabled := true; + //released := false; +end; + +destructor tlsignal.destroy; +begin + if prevsignal <> nil then begin + prevsignal.nextsignal := nextsignal; + end else begin + firstsignal := nextsignal; + end; + if nextsignal <> nil then begin + nextsignal.prevsignal := prevsignal; + end; + inherited destroy; +end; +{$ifdef linux} + {$ifdef ver1_9_8} + {$define needsignalworkaround} + {$endif} + {$ifdef ver2_0_0} + {$define needsignalworkaround} + {$endif} + {$ifdef ver2_0_2} + {$define needsignalworkaround} + {$endif} +{$endif} +{$ifdef needsignalworkaround} + //using the 1.9.6 version of this stuff because the 1.9.8 and 2.0.0 versions seem broken + type + TSysParam = Longint; + TSysResult = longint; + const + syscall_nr_sigaction = 67; + //function Do_SysCall(sysnr:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL0'; + //function Do_SysCall(sysnr,param1:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL1'; + //function Do_SysCall(sysnr,param1,param2:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL2'; + function Do_SysCall(sysnr,param1,param2,param3:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL3'; + //function Do_SysCall(sysnr,param1,param2,param3,param4:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL4'; + //function Do_SysCall(sysnr,param1,param2,param3,param4,param5:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL5'; + + function Fpsigaction(sig: cint; act : psigactionrec; oact : psigactionrec): cint;// [public, alias : 'FPC_SYSC_SIGACTION']; + { + Change action of process upon receipt of a signal. + Signum specifies the signal (all except SigKill and SigStop). + If Act is non-nil, it is used to specify the new action. + If OldAct is non-nil the previous action is saved there. + } + begin + //writeln('fucking'); + {$ifdef RTSIGACTION} + {$ifdef cpusparc} + { Sparc has an extra stub parameter } + Fpsigaction:=do_syscall(syscall_nr_rt_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact),TSysParam(PtrInt(@Fprt_sigreturn_stub)-8),TSysParam(8)); + {$else cpusparc} + Fpsigaction:=do_syscall(syscall_nr_rt_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact),TSysParam(8)); + {$endif cpusparc} + {$else RTSIGACTION} + //writeln('nice'); + Fpsigaction:=do_syscall(syscall_nr_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact)); + {$endif RTSIGACTION} + end; +{$endif} + +// cdecl procedures are not name mangled +// so USING something unlikely to cause colliesions in the global namespace +// is a good idea +procedure lsignal_handler( Sig : Integer);cdecl; +var + currentsignal : tlsignal; +begin +// writeln('in lsignal_hanler'); + currentsignal := firstsignal; + while assigned(currentsignal) do begin + if assigned(currentsignal.onsignal) then currentsignal.onsignal(currentsignal,sig); + currentsignal := currentsignal.nextsignal; + + end; +// writeln('about to send down signalloopback'); + if assigned(signalloopback) then begin + signalloopback.sendstr(' '); + end; +// writeln('left lsignal_hanler'); +end; + +{$ifdef freebsd} + +{$if (FPC_VERSION > 2) or ((FPC_VERSION = 2) and (FPC_RELEASE >= 2))} +procedure lsignal_handler2(signal:longint;info:PSigInfo;context:psigcontext); cdecl; +{$else} +procedure lsignal_handler2(signal:longint;var info:TSigInfo_t;var context:SigContextRec); cdecl; +{$endif} + +begin + lsignal_handler(signal); +end; +{$endif} + + +const + allbitsset=-1; + {$ifdef ver1_0} + saction : sigactionrec = (handler:(sh:lsignal_handler);sa_flags:0); + {$else} + {$ifdef darwin} + saction : sigactionrec = (sa_handler:tsigaction(lsignal_handler);sa_flags:0); + {$else} + {$ifdef freebsd} + //version number is FPC_VERSION.FPC_RELEASE.FPC_PATCH + {$if (FPC_VERSION>2) or ((FPC_VERSION=2) and (FPC_RELEASE>0)) or ((FPC_VERSION=2) and (fpc_release=0) and (fpc_patch>=2))} + saction : sigactionrec = (sa_handler:lsignal_handler2;sa_flags:0); + {$else} + saction : sigactionrec = (sa_handler:tsigaction(lsignal_handler);sa_flags:0); + {$endif} + + {$else} + {$ifdef ver1_9_2} + saction : sigactionrec = (handler:(sh:lsignal_handler);sa_flags:0); + {$else} + //version number is FPC_VERSION.FPC_RELEASE.FPC_PATCH + {$if (FPC_VERSION>2) or ((FPC_VERSION=2) and (FPC_RELEASE>0)) or ((FPC_VERSION=2) and (fpc_release=0) and (fpc_patch>=2))} + 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); + {$else} + saction : sigactionrec = (sa_handler:{$ifndef ver1_9_6}{$ifndef ver1_9_6}{$ifndef ver1_0}SigActionHandler{$endif}{$endif}{$endif}(lsignal_handler)); + {$endif} + {$endif} + {$endif} + {$endif} + {$endif} +procedure starthandlesignal(signal:integer); +begin + if signal in ([0..31]-[sigkill,sigstop]) then begin + sigprocmask(SIG_BLOCK,@blockset,nil); + sigaction(signal,@saction,nil) + end else begin + raise exception.create('invalid signal number') + end; +end; + +initialization + fillchar(blockset,sizeof(blockset),0); + blockset[0] := $FFFFFFFF - (1 shl sigstop) - (1 shl sigkill) - (1 shl sigsegv); + saction.sa_mask := blockset; + +end. diff --git a/httpserver_20080306/lsocket.pas b/httpserver_20080306/lsocket.pas new file mode 100755 index 0000000..617f153 --- /dev/null +++ b/httpserver_20080306/lsocket.pas @@ -0,0 +1,706 @@ +{lsocket.pas} + +{socket code by plugwash} + +{ 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 + ----------------------------------------------------------------------------- } +{ +changes by plugwash (20030728) +* created handlefdtrigger virtual method in tlasio (overridden in tlsocket) and moved a lot of code from messageloop into it +* changed tlasio to tlasio +* split fdhandle into fdhandlein and fdhandleout +* i now use fdsrmaster and fdswmaster instead of rebuilding the lists every loop +* split lsocket.pas into lsocket.pas and lcore.pas + + +changes by beware (20030903) +* added getxaddr, getxport (local addr, port, as string) +* added getpeername, remote addr+port as binary +* added htons and htonl functions (endian swap, same interface as windows API) + +beware (20030905) +* if connect failed (conn refused) set state to connected and call internalclose, to get closed handler (instead of fdclose) +* (lcore) if closing the fd's in internalcose, set fd's to -1 because closing an fd makes it invalid + +beware (20030927) +* fixed: on connect failed, tried to close fdhandle's which were already set to -1, added check + +beware (20031017) +* added getpeeraddr, getpeerport, remote addr+port as string +} + + +unit lsocket; +{$ifdef fpc} + {$mode delphi} +{$endif} +interface + uses + sysutils, + {$ifdef win32} + windows,winsock, + {$else} + + {$ifdef VER1_0} + linux, + {$else} + baseunix,unix, + {$endif} + sockets, + {$endif} + classes,{pgdebugout,}pgtypes,lcore,fd_utils,binipstuff,dnssync; +type + sunB = packed record + s_b1, s_b2, s_b3, s_b4: byte; + end; + + SunW = packed record + s_w1, s_w2: word; + end; + + TInAddr = packed record + case integer of + 0: (S_un_b: SunB); + 1: (S_un_w: SunW); + 2: (S_addr: cardinal); + end; + {$ifdef ipv6} + {$ifdef ver1_0} + cuint16=word; + cuint32=dword; + sa_family_t=word; + + + TInetSockAddr6 = packed Record + sin6_family : sa_family_t; + sin6_port : cuint16; + sin6_flowinfo : cuint32; + sin6_addr : Tin6_addr; + sin6_scope_id : cuint32; + end; + {$endif} + {$endif} + TinetSockAddrv = packed record + case integer of + 0: (InAddr:TInetSockAddr); + {$ifdef ipv6} + 1: (InAddr6:TInetSockAddr6); + {$endif} + end; + Pinetsockaddrv = ^Tinetsockaddrv; + + + type + tsockaddrin=TInetSockAddr; + + type + TLsocket = class(tlasio) + public + //a: string; + + inAddr : TInetSockAddrV; +{ inAddrSize:integer;} + + //host : THostentry ; + + //mainthread : boolean ; //for debuggin only + addr:string; + port:string; + localaddr:string; + localport:string; + proto:string; + udp:boolean; + listenqueue:integer; + function getaddrsize:integer; + procedure connect; virtual; + procedure bindsocket; + procedure listen; + function accept : longint; + function sendto(dest:TInetSockAddr;destlen:integer;data:pointer;len:integer):integer; virtual; + function receivefrom(data:pointer;len:integer;var src:TInetSockAddr;var srclen:integer):integer; virtual; + //procedure internalclose(error:word);override; + procedure handlefdtrigger(readtrigger,writetrigger:boolean); override; + function send(data:pointer;len:integer):integer;override; + procedure sendstr(const str : string);override; + function Receive(Buf:Pointer;BufSize:integer):integer; override; + function getpeername(var addr:tsockaddrin;addrlen:integer):integer; virtual; + procedure getXaddrbin(var binip:tbinip); virtual; + procedure getpeeraddrbin(var binip:tbinip); virtual; + function getXaddr:string; virtual; + function getpeeraddr:string; virtual; + function getXport:string; virtual; + function getpeerport:string; virtual; + constructor Create(AOwner: TComponent); override; + {$ifdef win32} + procedure myfdclose(fd : integer); override; + function myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt; override; + function myfdread(fd: LongInt;var buf;size: LongInt):LongInt; override; + {$endif} + end; + tsocket=longint; // for compatibility with twsocket + + twsocket=tlsocket; {easy} + +function htons(w:word):word; +function htonl(i:integer):integer; +{!!!function longipdns(s:string):longint;} + +{$ifdef ipv6} +const + v4listendefault:boolean=false; +{$endif} + + +const + TCP_NODELAY=1; + IPPROTO_TCP=6; + +implementation +{$include unixstuff.inc} + +function longip(s:string):longint;{$ifdef fpc}inline;{$endif} +var + l:longint; + a,b:integer; + +function convertbyte(const s:string):integer;{$ifdef fpc}inline;{$endif} +begin + result := strtointdef(s,-1); + if result < 0 then exit; + if result > 255 then exit; + + {01 exception} + if (result <> 0) and (s[1] = '0') then begin + result := -1; + exit; + end; + + {+1 exception} + if not (s[1] in ['0'..'9']) then begin + result := -1; + exit + end; +end; + +begin + result := 0; + a := pos('.',s); + if a = 0 then exit; + b := convertbyte(copy(s,1,a-1));if (b < 0) then exit; + l := b shl 24; + s := copy(s,a+1,256); + a := pos('.',s); + if a = 0 then exit; + b := convertbyte(copy(s,1,a-1));if (b < 0) then exit; + l := l or b shl 16; + s := copy(s,a+1,256); + a := pos('.',s); + if a = 0 then exit; + b := convertbyte(copy(s,1,a-1));if (b < 0) then exit; + l := l or b shl 8; + s := copy(s,a+1,256); + b := convertbyte(copy(s,1,256));if (b < 0) then exit; + l := l or b; + result := l; +end; + +(*!!! +function longipdns(s:string):longint; +var + host : thostentry; +begin + if s = '0.0.0.0' then begin + result := 0; + end else begin + result := longip(s); + if result = 0 then begin + if gethostbyname(s,host) then begin; + result := htonl(Longint(Host.Addr)); + end; + //writeln(inttohex(longint(host.addr),8)) + end; + if result = 0 then begin + if resolvehostbyname(s,host) then begin; + result := htonl(Longint(Host.Addr)); + end; + //writeln(inttohex(longint(host.addr),8)) + end; + end; +end; +*) + + +function htons(w:word):word; +begin + {$ifndef ENDIAN_BIG} + result := ((w and $ff00) shr 8) or ((w and $ff) shl 8); + {$else} + result := w; + {$endif} +end; + +function htonl(i:integer):integer; +begin + {$ifndef ENDIAN_BIG} + result := (i shr 24) or (i shr 8 and $ff00) or (i shl 8 and $ff0000) or (i shl 24 and $ff000000); + {$else} + result := i; + {$endif} +end; + +function tlsocket.getaddrsize:integer; +begin + {$ifdef ipv6} + if inaddr.inaddr.family = AF_INET6 then result := sizeof(tinetsockaddr6) else + {$endif} + result := sizeof(tinetsockaddr); +end; + +function makeinaddrv(addr,port:string;var inaddr:tinetsockaddrv):integer; +var + biniptemp:tbinip; +begin + result := 0; + biniptemp := forwardlookup(addr,10); + fillchar(inaddr,sizeof(inaddr),0); + //writeln('converted address '+addr+' to binip '+ipbintostr(biniptemp)); + if biniptemp.family = AF_INET then begin + inAddr.InAddr.family:=AF_INET; + inAddr.InAddr.port:=htons(strtointdef(port,0)); + inAddr.InAddr.addr:=biniptemp.ip; + result := sizeof(tinetsockaddr); + end else + {$ifdef ipv6} + if biniptemp.family = AF_INET6 then begin + inAddr.InAddr6.sin6_family:=AF_INET6; + inAddr.InAddr6.sin6_port:=htons(strtointdef(port,0)); + inAddr.InAddr6.sin6_addr:=biniptemp.ip6; + result := sizeof(tinetsockaddr6); + end else + {$endif} + raise esocketexception.create('unable to resolve address: '+addr); +end; + +procedure tlsocket.connect; +var + a:integer; +begin + if state <> wsclosed then close; + //prevtime := 0; + makeinaddrv(addr,port,inaddr); + + udp := uppercase(proto) = 'UDP'; + if udp then a := SOCK_DGRAM else a := SOCK_STREAM; + a := Socket(inaddr.inaddr.family,a,0); + + //writeln(ord(inaddr.inaddr.family)); + if a = -1 then begin + lasterror := {$ifdef win32}getlasterror{$else}socketerror{$endif}; + raise esocketexception.create('unable to create socket'); + end; + try + dup(a); + bindsocket; + if udp then begin + {$ifndef win32} + SetSocketOptions(fdhandleout, SOL_SOCKET, SO_BROADCAST, 'TRUE', Length('TRUE')); + {$endif} + state := wsconnected; + if assigned(onsessionconnected) then onsessionconnected(self,0); + end else begin + state :=wsconnecting; + {$ifdef win32} + //writeln(inaddr.inaddr.port); + winsock.Connect(fdhandlein,winsock.psockaddr(@inADDR)^,getaddrsize); + {$else} + sockets.Connect(fdhandlein,inADDR,getaddrsize); + {$endif} + end; + eventcore.rmasterset(fdhandlein,false); + if udp then begin + eventcore.wmasterclr(fdhandleout); + end else begin + eventcore.wmasterset(fdhandleout); + end; + //sendq := ''; + except + on e: exception do begin + fdcleanup; + raise; //reraise the exception + end; + end; +end; + +procedure tlsocket.sendstr(const str : string); +begin + if udp then begin + send(@str[1],length(str)) + end else begin + inherited sendstr(str); + end; +end; + +function tlsocket.send(data:pointer;len:integer):integer; +begin + if udp then begin + //writeln('sending to '+inttohex(inaddr.inaddr.addr,8)); + result := sendto(inaddr.inaddr,getaddrsize,data,len) +; + //writeln('send result',result); + //writeln('errno',errno); + end else begin + result := inherited send(data,len); + end; +end; + + +function tlsocket.receive(Buf:Pointer;BufSize:integer):integer; +begin + if udp then begin + result := myfdread(self.fdhandlein,buf^,bufsize); + end else begin + result := inherited receive(buf,bufsize); + end; +end; + +procedure tlsocket.bindsocket; +var + a:integer; + inAddrtemp:TInetSockAddrV; + inAddrtempx:{$ifdef win32}winsock.TSockaddr{$else}TInetSockAddrV{$endif} absolute inaddrtemp; + inaddrtempsize:integer; +begin + try + if (localaddr <> '') or (localport <> '') then begin + if localaddr = '' then begin + {$ifdef ipv6} + if inaddr.inaddr.family = AF_INET6 then localaddr := '::' else + {$endif} + localaddr := '0.0.0.0'; + end; + //gethostbyname(localaddr,host); + + inaddrtempsize := makeinaddrv(localaddr,localport,inaddrtemp); + + If Bind(fdhandlein,inaddrtempx,inaddrtempsize)<> {$ifdef win32}0{$else}true{$endif} Then begin + state := wsclosed; + lasterror := {$ifdef win32}getlasterror{$else}socketerror{$endif}; + raise ESocketException.create('unable to bind, error '+inttostr(lasterror)); + end; + state := wsbound; + end; + except + on e: exception do begin + fdcleanup; + raise; //reraise the exception + end; + end; +end; + +procedure tlsocket.listen; +var + yes:longint; + socktype:integer; + biniptemp:tbinip; + origaddr:string; +begin + if state <> wsclosed then close; + udp := uppercase(proto) = 'UDP'; + if udp then socktype := SOCK_DGRAM else socktype := SOCK_STREAM; + origaddr := addr; + + if addr = '' then begin + {$ifdef ipv6} + if not v4listendefault then begin + addr := '::'; + end else + {$endif} + addr := '0.0.0.0'; + end; + biniptemp := forwardlookup(addr,10); + addr := ipbintostr(biniptemp); + fdhandlein := socket(biniptemp.family,socktype,0); + {$ifdef ipv6} + if (addr = '::') and (origaddr = '') and (fdhandlein < 0) then begin + addr := '0.0.0.0'; + fdhandlein := socket(AF_INET,socktype,0); + end; + {$endif} + if fdhandlein = -1 then raise ESocketException.create('unable to create socket'); + dupnowatch(fdhandlein); // sets up maxs and copies handle to fdhandleout among other things + //eventcore.setfdreverse(fdhandlein,self); //already taken care of by dup + state := wsclosed; // then set this back as it was an undesired side effect of dup + + try + yes := $01010101; {Copied this from existing code. Value is empiric, + but works. (yes=true<>0) } + {$ifndef win32} + if SetSocketOptions(fdhandlein, SOL_SOCKET, SO_REUSEADDR,yes,sizeof(yes))=-1 then begin + raise ESocketException.create('unable to set socket options'); + end; + {$endif} + localaddr := addr; + localport := port; + bindsocket; + + if not udp then begin + {!!! allow custom queue length? default 5} + if listenqueue = 0 then listenqueue := 5; + If {$ifdef win32}winsock{$else}sockets{$endif}.Listen(fdhandlein,listenqueue)<>{$ifdef win32}0{$else}true{$endif} Then raise esocketexception.create('unable to listen'); + state := wsListening; + end else begin + {$ifndef win32} + SetSocketOptions(fdhandleout, SOL_SOCKET, SO_BROADCAST, 'TRUE', Length('TRUE')); + {$endif} + state := wsconnected; + end; + finally + if state = wsclosed then begin + if fdhandlein >= 0 then begin + {one *can* get here without fd -beware} + eventcore.rmasterclr(fdhandlein); + myfdclose(fdhandlein); // we musnt leak file discriptors + eventcore.setfdreverse(fdhandlein,nil); + fdhandlein := -1; + end; + end else begin + eventcore.rmasterset(fdhandlein,true); + end; + if fdhandleout >= 0 then eventcore.wmasterclr(fdhandleout); + end; + //writeln('listened on addr '+addr+':'+port+' '+proto+' using socket number ',fdhandlein); +end; + +function tlsocket.accept : longint; +var + FromAddrSize : LongInt; // i don't realy know what to do with these at this + FromAddr : TInetSockAddrV; // at this point time will tell :) +begin + + FromAddrSize := Sizeof(FromAddr); + {$ifdef win32} + result := winsock.accept(fdhandlein,@fromaddr,@fromaddrsize); + {$else} + result := sockets.accept(fdhandlein,fromaddr,fromaddrsize); + {$endif} + //now we have accepted one request start monitoring for more again + eventcore.rmasterset(fdhandlein,true); + + if result = -1 then raise esocketexception.create('error '+inttostr({$ifdef win32}getlasterror{$else}socketerror{$endif})+' while accepting'); + if result > absoloutemaxs then begin + myfdclose(result); + result := -1; + raise esocketexception.create('file discriptor out of range'); + end; +end; + +function tlsocket.sendto(dest:TInetSockAddr;destlen:integer;data:pointer;len:integer):integer; +var + destx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddr{$endif} absolute dest; +begin + result := {$ifdef win32}winsock{$else}sockets{$endif}.sendto(self.fdhandleout,data^,len,0,destx,destlen); +end; + +function tlsocket.receivefrom(data:pointer;len:integer;var src:TInetSockAddr;var srclen:integer):integer; +var + srcx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddr{$endif} absolute src; +begin + result := {$ifdef win32}winsock{$else}sockets{$endif}.recvfrom(self.fdhandlein,data^,len,0,srcx,srclen); +end; + +procedure tlsocket.handlefdtrigger(readtrigger,writetrigger:boolean); +var + tempbuf:array[0..receivebufsize-1] of byte; +begin + //writeln('got a fd trigger, readtrigger=',readtrigger,' writetrigger=',writetrigger); + if (state =wslistening) and readtrigger then begin +{ debugout('listening socket triggered on read');} + eventcore.rmasterclr(fdhandlein); + if assigned(onsessionAvailable) then onsessionAvailable(self,0); + end; + if udp and readtrigger then begin + if assigned(ondataAvailable) then ondataAvailable(self,0); + {!!!test} + exit; + end; + if (state =wsconnecting) and writetrigger then begin + // code for dealing with the reults of a non-blocking connect is + // rather complex + // if just write is triggered it means connect suceeded + // if both read and write are triggered it can mean 2 things + // 1: connect ok and data availible + // 2: connect fail + // to find out which you must read from the socket and look for errors + // there if we read successfully we drop through into the code for fireing + // the read event + if not readtrigger then begin + state := wsconnected; + if assigned(onsessionconnected) then onsessionconnected(self,0); + end else begin + numread := myfdread(fdhandlein,tempbuf,sizeof(tempbuf)); + if numread <> -1 then begin + state := wsconnected; + if assigned(onsessionconnected) then onsessionconnected(self,0); + //connectread := true; + recvq.add(@tempbuf,numread); + end else begin + state := wsconnected; + if assigned(onsessionconnected) then onsessionconnected(self,{$ifdef win32}wsagetlasterror{$else}linuxerror{$endif}); +{ debugout('connect fail');} + self.internalclose(0); + recvq.del(maxlongint); + end; + // if things went well here we are now in the state wsconnected with data sitting in our receive buffer + // so we drop down into the processing for data availible + end; + if fdhandlein >= 0 then begin + if state = wsconnected then begin + eventcore.rmasterset(fdhandlein,false); + end else begin + eventcore.rmasterclr(fdhandlein); + end; + end; + if fdhandleout >= 0 then begin + if sendq.size = 0 then begin + //don't clear the bit in fdswmaster if data is in the sendq + eventcore.wmasterclr(fdhandleout); + end; + end; + + end; + inherited handlefdtrigger(readtrigger,writetrigger); +end; + +constructor tlsocket.Create(AOwner: TComponent); +begin + inherited create(aowner); + closehandles := true; +end; + + +function tlsocket.getpeername(var addr:tsockaddrin;addrlen:integer):integer; +var + addrx : {$ifdef win32}winsock.tsockaddr{$else}tsockaddrin{$endif} absolute addr; +begin + result := {$ifdef win32}winsock{$else}sockets{$endif}.getpeername(self.fdhandlein,addrx,addrlen); +end; + +procedure tlsocket.getxaddrbin(var binip:tbinip); +var + addr:tinetsockaddrv; + i:integer; +begin + i := sizeof(addr); + fillchar(addr,sizeof(addr),0); + + {$ifdef win32} + winsock.getsockname(self.fdhandlein,psockaddr(@addr)^,i); + {$else} + sockets.getsocketname(self.fdhandlein,addr,i); + {$endif} + binip.family := addr.inaddr.family; + {$ifdef ipv6} + if addr.inaddr6.sin6_family = AF_INET6 then begin + binip.ip6 := addr.inaddr6.sin6_addr; + end else + {$endif} + begin + binip.ip := addr.inaddr.addr; + end; + converttov4(binip); +end; + +procedure tlsocket.getpeeraddrbin(var binip:tbinip); +var + addr:tinetsockaddrv; + i:integer; +begin + i := sizeof(addr); + fillchar(addr,sizeof(addr),0); + {$ifdef win32} + winsock.getpeername(self.fdhandlein,psockaddr(@addr)^,i); + {$else} + sockets.getpeername(self.fdhandlein,addr,i); + {$endif} + + binip.family := addr.inaddr.family; + {$ifdef ipv6} + if addr.inaddr6.sin6_family = AF_INET6 then begin + binip.ip6 := addr.inaddr6.sin6_addr; + end else + {$endif} + begin + binip.ip := addr.inaddr.addr; + end; + converttov4(binip); +end; + +function tlsocket.getXaddr:string; +var + biniptemp:tbinip; +begin + getxaddrbin(biniptemp); + result := ipbintostr(biniptemp); + if result = '' then result := 'error'; +end; + +function tlsocket.getpeeraddr:string; +var + biniptemp:tbinip; +begin + getpeeraddrbin(biniptemp); + result := ipbintostr(biniptemp); + if result = '' then result := 'error'; +end; + +function tlsocket.getXport:string; +var + addr:{$ifdef win32}winsock.tsockaddr{$else}tinetsockaddr{$endif}; + i:integer; +begin + i := sizeof(addr); + {$ifdef win32} + winsock.getsockname(self.fdhandlein,addr,i); + i := htons(addr.sin_port); + {$else} + sockets.getsocketname(self.fdhandlein,addr,i); + i := htons(addr.port); + {$endif} + result := inttostr(i); +end; + +function tlsocket.getpeerport:string; +var + addr:{$ifdef win32}winsock.tsockaddr{$else}tinetsockaddr{$endif}; + i:integer; +begin + i := sizeof(addr); + {$ifdef win32} + winsock.getpeername(self.fdhandlein,addr,i); + i := htons(addr.sin_port); + {$else} + sockets.getpeername(self.fdhandlein,addr,i); + i := htons(addr.port); + {$endif} + result := inttostr(i); +end; + +{$ifdef win32} + procedure tlsocket.myfdclose(fd : integer); + begin + closesocket(fd); + end; + function tlsocket.myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt; + begin + result := winsock.send(fd,(@buf)^,size,0); + end; + function tlsocket.myfdread(fd: LongInt;var buf;size: LongInt):LongInt; + begin + result := winsock.recv(fd,buf,size,0); + end; +{$endif} + +end. + diff --git a/httpserver_20080306/ltimevalstuff.inc b/httpserver_20080306/ltimevalstuff.inc new file mode 100755 index 0000000..0ac92cb --- /dev/null +++ b/httpserver_20080306/ltimevalstuff.inc @@ -0,0 +1,42 @@ +{ 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 + ----------------------------------------------------------------------------- } + + + +{add nn msec to tv} +const + tv_invalidtimebig : ttimeval = (tv_sec:maxlongint;tv_usec:maxlongint); + //tv_invalidtimebig will always compare as greater than any valid timeval +procedure tv_add(var tv:ttimeval;msec:integer);//{ $ifdef fpc}inline;{ $endif} +begin + inc(tv.tv_usec,msec*1000); + inc(tv.tv_sec,tv.tv_usec div 1000000); + tv.tv_usec := tv.tv_usec mod 1000000; +end; + +{tv1 >= tv2} +function tv_compare(const tv1,tv2:ttimeval):boolean;//{ $ifdef fpc}inline;{ $endif} +begin + if tv1.tv_sec = tv2.tv_sec then begin + result := tv1.tv_usec >= tv2.tv_usec; + end else result := tv1.tv_sec > tv2.tv_sec; +end; + +procedure tv_substract(var tv:ttimeval;const tv2:ttimeval);//{ $ifdef fpc}inline;{ $endif} +begin + dec(tv.tv_usec,tv2.tv_usec); + if tv.tv_usec < 0 then begin + inc(tv.tv_usec,1000000); + dec(tv.tv_sec) + end; + dec(tv.tv_sec,tv2.tv_sec); +end; + +procedure msectotimeval(var tv:ttimeval;msec:integer); +begin + tv.tv_sec := msec div 1000; + tv.tv_usec := (msec mod 1000)*1000; +end; + diff --git a/httpserver_20080306/pgtypes.pas b/httpserver_20080306/pgtypes.pas new file mode 100755 index 0000000..3c48e26 --- /dev/null +++ b/httpserver_20080306/pgtypes.pas @@ -0,0 +1,20 @@ +{io core originally for linux bworld} + +{ 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 + ----------------------------------------------------------------------------- } + +unit pgtypes; +interface + type + {$ifdef cpu386}{$define i386}{$endif} + {$ifdef i386} + taddrint=longint; + {$else} + taddrint=sizeint; + {$endif} + paddrint=^taddrint; + +implementation +end. diff --git a/httpserver_20080306/uint32.inc b/httpserver_20080306/uint32.inc new file mode 100755 index 0000000..897db79 --- /dev/null +++ b/httpserver_20080306/uint32.inc @@ -0,0 +1,14 @@ +{ 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 + ----------------------------------------------------------------------------- } +type + {delphi 3 and before do not have a 32 bits unsigned integer type, + but longint has the correct behavior - it doesn't on newer delphi versions} + {$ifndef fpc} + {$ifdef ver70}{$define pred4}{$endif} {tp7} + {$ifdef ver80}{$define pred4}{$endif} {delphi 1} + {$ifdef ver90}{$define pred4}{$endif} {delphi 2} + {$ifdef ver100}{$define pred4}{$endif} {delphi 3} + {$endif} + uint32={$ifdef pred4}longint{$else}longword{$endif}; diff --git a/httpserver_20080306/unixstuff.inc b/httpserver_20080306/unixstuff.inc new file mode 100755 index 0000000..92ed308 --- /dev/null +++ b/httpserver_20080306/unixstuff.inc @@ -0,0 +1,66 @@ +{$ifdef UNIX} + {$macro on} + {$ifdef VER1_0} + {$define tv_sec := sec} + {$define tv_usec := usec} + function dup(const original:integer):integer;inline; + begin + linux.dup(original,result); + end; + {$define gettimeofdaysec := gettimeofday} + {$else} + + {$define sigprocmask := fpsigprocmask} + {$define sigaction := fpsigaction} + {$define fdclose := fpclose} + {$define fcntl := fpfcntl} + {$define fdwrite := fpwrite} + {$define fdread := fpread} + {$define fdopen := fpopen} + {$define select := fpselect} + {$define linuxerror := fpgeterrno} + {$define fork := fpfork} + {$define getpid := fpgetpid} + {$define getenv := fpgetenv} + {$define chmod := fpchmod} + {$define dup2 := fpdup2} + {$ifndef ver1_9_2} + {$define flock := fpflock} + {$endif} + procedure gettimeofday(var tv:ttimeval);inline; + begin + fpgettimeofday(@tv,nil); + end; + function gettimeofdaysec : longint; + var + tv:ttimeval; + begin + gettimeofday(tv); + result := tv.tv_sec; + end; + + //a function is used here rather than a define to prevent issues with tlasio.dup + function dup(const original:integer):integer;inline; + begin + result := fpdup(original); + end; + function octal(invalue:longint):longint; + var + a : integer; + i : integer; + begin + i := 0; + result := 0; + while invalue <> 0 do begin + a := invalue mod 10; + result := result + (a shl (i*3)); + + invalue := invalue div 10; + inc(i); + end; + end; + const + sys_eintr=esyseintr; + + {$endif} +{$endif} diff --git a/httpserver_20080306/wcore.pas b/httpserver_20080306/wcore.pas new file mode 100755 index 0000000..40505ef --- /dev/null +++ b/httpserver_20080306/wcore.pas @@ -0,0 +1,372 @@ +{ 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 + ----------------------------------------------------------------------------- } + +unit wcore; + +{ +lcore compatible interface for windows + +- messageloop + +- tltimer + +} +//note: events after release are normal and are the apps responsibility to deal with safely +interface + + uses + classes,windows,mmsystem; + + type + float=double; + + tlcomponent = class(tcomponent) + public + released:boolean; + procedure release; + destructor destroy; override; + end; + + tltimer=class(tlcomponent) + public + ontimer:tnotifyevent; + initialevent:boolean; + initialdone:boolean; + prevtimer:tltimer; + nexttimer:tltimer; + interval:integer; {miliseconds, default 1000} + enabled:boolean; + nextts:integer; + constructor create(aowner:tcomponent);override; + destructor destroy;override; + end; + + ttaskevent=procedure(wparam,lparam:longint) of object; + + tltask=class(tobject) + public + handler : ttaskevent; + obj : tobject; + wparam : longint; + lparam : longint; + nexttask : tltask; + constructor create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint); + end; + +procedure messageloop; +procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint); +procedure disconnecttasks(aobj:tobject); +procedure exitmessageloop; +procedure processmessages; + +var + onshutdown:procedure(s:string); + +implementation + +uses + {$ifdef fpc} + bmessages; + {$else} + messages; + {$endif} + + +const + WINMSG_TASK=WM_USER; + +var + hwndwcore:hwnd; + firsttimer:tltimer; + timesubstract:integer; + firsttask,lasttask,currenttask:tltask; + +procedure tlcomponent.release; +begin + released := true; +end; + +destructor tlcomponent.destroy; +begin + disconnecttasks(self); + inherited destroy; +end; + +{------------------------------------------------------------------------------} + +constructor tltimer.create; +begin + inherited create(AOwner); + nexttimer := firsttimer; + prevtimer := nil; + + if assigned(nexttimer) then nexttimer.prevtimer := self; + firsttimer := self; + + interval := 1000; + enabled := true; + released := false; +end; + +destructor tltimer.destroy; +begin + if prevtimer <> nil then begin + prevtimer.nexttimer := nexttimer; + end else begin + firsttimer := nexttimer; + end; + if nexttimer <> nil then begin + nexttimer.prevtimer := prevtimer; + end; + inherited destroy; +end; + +{------------------------------------------------------------------------------} + +function wcore_timehandler:integer; +const + rollover_bits=30; +var + tv,tvnow:integer; + currenttimer,temptimer:tltimer; +begin + if not assigned(firsttimer) then begin + result := 1000; + exit; + end; + + tvnow := timegettime; + if (tvnow and ((-1) shl rollover_bits)) <> timesubstract then begin + currenttimer := firsttimer; + while assigned(currenttimer) do begin + dec(currenttimer.nextts,(1 shl rollover_bits)); + currenttimer := currenttimer.nexttimer; + end; + timesubstract := tvnow and ((-1) shl rollover_bits); + end; + tvnow := tvnow and ((1 shl rollover_bits)-1); + + currenttimer := firsttimer; + while assigned(currenttimer) do begin + if tvnow >= currenttimer.nextts then begin + if assigned(currenttimer.ontimer) then begin + if currenttimer.enabled then begin + if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer); + currenttimer.initialdone := true; + end; + end; + currenttimer.nextts := tvnow+currenttimer.interval; + end; + temptimer := currenttimer; + currenttimer := currenttimer.nexttimer; + if temptimer.released then temptimer.free; + end; + + tv := maxlongint; + currenttimer := firsttimer; + while assigned(currenttimer) do begin + if currenttimer.nextts < tv then tv := currenttimer.nextts; + currenttimer := currenttimer.nexttimer; + end; + result := tv-tvnow; + if result < 15 then result := 15; +end; + +{------------------------------------------------------------------------------} + +constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint); +begin + inherited create; + handler := ahandler; + obj := aobj; + wparam := awparam; + lparam := alparam; + {nexttask := firsttask; + firsttask := self;} + if assigned(lasttask) then begin + lasttask.nexttask := self; + end else begin + firsttask := self; + postmessage(hwndwcore,WINMSG_TASK,0,0); + end; + lasttask := self; + //ahandler(wparam,lparam); +end; + +procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint); +begin + tltask.create(ahandler,aobj,awparam,alparam); +end; + +procedure disconnecttasks(aobj:tobject); +var + currenttasklocal : tltask ; + counter : byte ; +begin + for counter := 0 to 1 do begin + if counter = 0 then begin + currenttasklocal := firsttask; //main list of tasks + end else begin + currenttasklocal := currenttask; //needed in case called from a task + end; + // note i don't bother to sestroy the links here as that will happen when + // the list of tasks is processed anyway + while assigned(currenttasklocal) do begin + if currenttasklocal.obj = aobj then begin + currenttasklocal.obj := nil; + currenttasklocal.handler := nil; + end; + currenttasklocal := currenttasklocal.nexttask; + end; + end; +end; + +procedure dotasks; +var + temptask:tltask; +begin + if firsttask = nil then exit; + + currenttask := firsttask; + firsttask := nil; + lasttask := nil; + while assigned(currenttask) do begin + if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam); + temptask := currenttask; + currenttask := currenttask.nexttask; + temptask.free; + end; + currenttask := nil; +end; + +{------------------------------------------------------------------------------} + +procedure exitmessageloop; +begin + postmessage(hwndwcore,WM_QUIT,0,0); +end; + + {$ifdef threadtimer} + 'thread timer' + {$else} +const timerid_wcore=$1000; + {$endif} + +function MyWindowProc( + ahWnd : HWND; + auMsg : Integer; + awParam : WPARAM; + alParam : LPARAM): Integer; stdcall; +var + MsgRec : TMessage; + a:integer; +begin + Result := 0; // This means we handled the message + + {MsgRec.hwnd := ahWnd;} + MsgRec.wParam := awParam; + MsgRec.lParam := alParam; + + dotasks; + case auMsg of + {$ifndef threadtimer} + WM_TIMER: begin + if msgrec.wparam = timerid_wcore then begin + a := wcore_timehandler; + killtimer(hwndwcore,timerid_wcore); + settimer(hwndwcore,timerid_wcore,a,nil); + end; + end; + {$endif} + + {WINMSG_TASK:dotasks;} + + WM_CLOSE: begin + {} + end; + WM_DESTROY: begin + {} + end; + else + Result := DefWindowProc(ahWnd, auMsg, awParam, alParam) + end; +end; + + +var + MyWindowClass : TWndClass = (style : 0; + lpfnWndProc : @MyWindowProc; + cbClsExtra : 0; + cbWndExtra : 0; + hInstance : 0; + hIcon : 0; + hCursor : 0; + hbrBackground : 0; + lpszMenuName : nil; + lpszClassName : 'wcoreClass'); + +procedure messageloop; +var + MsgRec : TMsg; +begin + + if Windows.RegisterClass(MyWindowClass) = 0 then halt; + //writeln('about to create wcore handle, hinstance=',hinstance); + hwndwcore := CreateWindowEx(WS_EX_TOOLWINDOW, + MyWindowClass.lpszClassName, + '', { Window name } + WS_POPUP, { Window Style } + 0, 0, { X, Y } + 0, 0, { Width, Height } + 0, { hWndParent } + 0, { hMenu } + HInstance, { hInstance } + nil); { CreateParam } + + if hwndwcore = 0 then halt; + + {$ifdef threadtimer} + 'thread timer' + {$else} + if settimer(hwndwcore,timerid_wcore,15,nil) = 0 then halt; + {$endif} + + + while GetMessage(MsgRec, 0, 0, 0) do begin + TranslateMessage(MsgRec); + DispatchMessage(MsgRec); + {if not peekmessage(msgrec,0,0,0,PM_NOREMOVE) then onidle} + end; + + if hWndwcore <> 0 then begin + DestroyWindow(hwndwcore); + hWndwcore := 0; + end; + + {$ifdef threadtimer} + 'thread timer' + {$else} + killtimer(hwndwcore,timerid_wcore); + {$endif} +end; + +function ProcessMessage : Boolean; +var + Msg : TMsg; +begin + Result := FALSE; + if PeekMessage(Msg, hwndwcore, 0, 0, PM_REMOVE) then begin + Result := TRUE; + DispatchMessage(Msg); + end; +end; + +procedure processmessages; +begin + while processmessage do; +end; + + +end. diff --git a/lcore.pas b/lcore.pas new file mode 100755 index 0000000..900bc96 --- /dev/null +++ b/lcore.pas @@ -0,0 +1,891 @@ +{lsocket.pas} + +{io and timer code by plugwash} + +{ 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 + ----------------------------------------------------------------------------- } + +{note: you must use the @ in the last param to tltask.create not doing so will + compile without error but will cause an access violation -pg} + +//note: events after release are normal and are the apps responsibility to deal with safely + +unit lcore; +{$ifdef fpc} + {$mode delphi} +{$endif} +{$ifdef win32} + {$define nosignal} +{$endif} +interface + uses + sysutils, + {$ifndef win32} + {$ifdef VER1_0} + linux, + {$else} + baseunix,unix,unixutil, + {$endif} + fd_utils, + {$endif} + classes,pgtypes,bfifo; + procedure processtasks; + + + const + receivebufsize=1460; + + type + {$ifdef ver1_0} + sigset= array[0..31] of longint; + {$endif} + + ESocketException = class(Exception); + TBgExceptionEvent = procedure (Sender : TObject; + E : Exception; + var CanClose : Boolean) of object; + + // note : tsocketstate is defined in the same way as it is in François PIETTE's twsocket + // however tlsocket currently only uses wsClosed wsConnecting wsconnected and wsListening + TSocketState = (wsInvalidState, + wsOpened, wsBound, + wsConnecting, wsConnected, + wsAccepting, wsListening, + wsClosed); + + TWSocketOption = (wsoNoReceiveLoop, wsoTcpNoDelay); + TWSocketOptions = set of TWSocketOption; + + TSocketevent = procedure(Sender: TObject; Error: word) of object; + //Tdataavailevent = procedure(data : string); + TSendData = procedure (Sender: TObject; BytesSent: Integer) of object; + + tlcomponent = class(tcomponent) + public + released:boolean; + procedure release; virtual; + destructor destroy; override; + end; + + tlasio = class(tlcomponent) + public + state : tsocketstate ; + ComponentOptions : TWSocketOptions; + fdhandlein : Longint ; {file discriptor} + fdhandleout : Longint ; {file discriptor} + + onsessionclosed : tsocketevent ; + ondataAvailable : tsocketevent ; + onsessionAvailable : tsocketevent ; + + onsessionconnected : tsocketevent ; + onsenddata : tsenddata ; + ondatasent : tsocketevent ; + //connected : boolean ; + nextasin : tlasio ; + prevasin : tlasio ; + + recvq : tfifo; + OnBgException : TBgExceptionEvent ; + //connectread : boolean ; + sendq : tfifo; + closehandles : boolean ; + writtenthiscycle : boolean ; + onfdwrite : procedure (Sender: TObject; Error: word) of object; //added for bewarehttpd + lasterror:integer; + destroying:boolean; + function receivestr:string; virtual; + procedure close; + procedure abort; + procedure internalclose(error:word); virtual; + constructor Create(AOwner: TComponent); override; + + destructor destroy; override; + procedure fdcleanup; + procedure HandleBackGroundException(E: Exception); + procedure handlefdtrigger(readtrigger,writetrigger:boolean); virtual; + procedure dup(invalue:longint); + + function sendflush : integer; + procedure sendstr(const str : string);virtual; + procedure putstringinsendbuffer(const newstring : string); + function send(data:pointer;len:integer):integer;virtual; + procedure putdatainsendbuffer(data:pointer;len:integer); virtual; + procedure deletebuffereddata; + + //procedure messageloop; + function Receive(Buf:Pointer;BufSize:integer):integer; virtual; + procedure flush;virtual;{$ifdef win32} abstract;{$endif} + procedure dodatasent(wparam,lparam:longint); + procedure doreceiveloop(wparam,lparam:longint); + procedure sinkdata(sender:tobject;error:word); + + procedure release; override; {test -beware} + + function RealSend(Data : Pointer; Len : Integer) : Integer; //added for bewarehttpd + + procedure myfdclose(fd : integer); virtual;{$ifdef win32}abstract;{$endif} + function myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt; virtual;{$ifdef win32}abstract;{$endif} + function myfdread(fd: LongInt;var buf;size: LongInt):LongInt; virtual;{$ifdef win32}abstract;{$endif} + protected + procedure dupnowatch(invalue:longint); + end; + ttimerwrapperinterface=class(tlcomponent) + public + function createwrappedtimer : tobject;virtual;abstract; +// procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);virtual;abstract; + procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);virtual;abstract; + procedure setenabled(wrappedtimer : tobject;newvalue : boolean);virtual;abstract; + procedure setinterval(wrappedtimer : tobject;newvalue : integer);virtual;abstract; + end; + + var + timerwrapperinterface : ttimerwrapperinterface; + type + {$ifdef win32} + ttimeval = record + tv_sec : longint; + tv_usec : longint; + end; + {$endif} + tltimer=class(tlcomponent) + protected + + + wrappedtimer : tobject; + + +// finitialevent : boolean ; + fontimer : tnotifyevent ; + fenabled : boolean ; + finterval : integer ; {miliseconds, default 1000} + {$ifndef win32} + procedure resettimes; + {$endif} +// procedure setinitialevent(newvalue : boolean); + procedure setontimer(newvalue:tnotifyevent); + procedure setenabled(newvalue : boolean); + procedure setinterval(newvalue : integer); + public + //making theese public for now, this code should probablly be restructured later though + prevtimer : tltimer ; + nexttimer : tltimer ; + nextts : ttimeval ; + + constructor create(aowner:tcomponent);override; + destructor destroy;override; +// property initialevent : boolean read finitialevent write setinitialevent; + property ontimer : tnotifyevent read fontimer write setontimer; + property enabled : boolean read fenabled write setenabled; + property interval : integer read finterval write setinterval; + + end; + + ttaskevent=procedure(wparam,lparam:longint) of object; + + tltask=class(tobject) + public + handler : ttaskevent; + obj : tobject; + wparam : longint; + lparam : longint; + nexttask : tltask; + constructor create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint); + end; + + + + teventcore=class + public + procedure processmessages; virtual;abstract; + procedure messageloop; virtual;abstract; + procedure exitmessageloop; virtual;abstract; + procedure setfdreverse(fd : integer;reverseto : tlasio);virtual;abstract; + procedure rmasterset(fd : integer;islistensocket : boolean); virtual;abstract; + procedure rmasterclr(fd: integer); virtual;abstract; + procedure wmasterset(fd : integer); virtual;abstract; + procedure wmasterclr(fd: integer); virtual;abstract; + end; +var + eventcore : teventcore; + +procedure processmessages; +procedure messageloop; +procedure exitmessageloop; + +var + firstasin : tlasio ; + firsttimer : tltimer ; + firsttask , lasttask , currenttask : tltask ; + + numread : integer ; + mustrefreshfds : boolean ; +{ lcoretestcount:integer;} + + asinreleaseflag:boolean; + + +procedure disconnecttasks(aobj:tobject); +procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint); +type + tonaddtask = procedure(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint); +var + onaddtask : tonaddtask; + + +procedure sleep(i:integer); +{$ifndef nosignal} + procedure prepsigpipe;{$ifndef ver1_0}inline;{$endif} +{$endif} + + +implementation +{$ifndef nosignal} + uses {sockets,}lloopback,lsignal; +{$endif} +{$ifdef win32} + uses windows,winsock; +{$endif} +{$ifndef win32} + {$include unixstuff.inc} +{$endif} +{$include ltimevalstuff.inc} + + +{!!! added sleep call -beware} +procedure sleep(i:integer); +var + tv:ttimeval; +begin + {$ifdef win32} + windows.sleep(i); + {$else} + tv.tv_sec := i div 1000; + tv.tv_usec := (i mod 1000) * 1000; + select(0,nil,nil,nil,@tv); + {$endif} +end; + +destructor tlcomponent.destroy; +begin + disconnecttasks(self); + inherited destroy; +end; + + + + +procedure tlcomponent.release; +begin + released := true; +end; + +procedure tlasio.release; +begin + asinreleaseflag := true; + inherited release; +end; + +procedure tlasio.doreceiveloop; +begin + if recvq.size = 0 then exit; + if assigned(ondataavailable) then ondataavailable(self,0); + if not (wsonoreceiveloop in componentoptions) then + if recvq.size > 0 then tltask.create(self.doreceiveloop,self,0,0); +end; + +function tlasio.receivestr; +begin + setlength(result,recvq.size); + receive(@result[1],length(result)); +end; + +function tlasio.receive(Buf:Pointer;BufSize:integer):integer; +var + i,a,b:integer; + p:pointer; +begin + i := bufsize; + if recvq.size < i then i := recvq.size; + a := 0; + while (a < i) do begin + b := recvq.get(p,i-a); + move(p^,buf^,b); + inc(taddrint(buf),b); + recvq.del(b); + inc(a,b); + end; + result := i; + if wsonoreceiveloop in componentoptions then begin + if recvq.size = 0 then eventcore.rmasterset(fdhandlein,false); + end; +end; + +constructor tlasio.create; +begin + inherited create(AOwner); + sendq := tfifo.create; + recvq := tfifo.create; + state := wsclosed; + fdhandlein := -1; + fdhandleout := -1; + nextasin := firstasin; + prevasin := nil; + if assigned(nextasin) then nextasin.prevasin := self; + firstasin := self; + + released := false; +end; + +destructor tlasio.destroy; +begin + destroying := true; + if state <> wsclosed then close; + if prevasin <> nil then begin + prevasin.nextasin := nextasin; + end else begin + firstasin := nextasin; + end; + if nextasin <> nil then begin + nextasin.prevasin := prevasin; + end; + recvq.destroy; + sendq.destroy; + inherited destroy; +end; + +procedure tlasio.close; +begin + internalclose(0); +end; + +procedure tlasio.abort; +begin + close; +end; + +procedure tlasio.fdcleanup; +begin + if fdhandlein <> -1 then begin + eventcore.rmasterclr(fdhandlein); //fd_clr(fdhandlein,fdsrmaster) + end; + if fdhandleout <> -1 then begin + eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster) + end; + if fdhandlein=fdhandleout then begin + if fdhandlein <> -1 then begin + myfdclose(fdhandlein); + end; + end else begin + if fdhandlein <> -1 then begin + myfdclose(fdhandlein); + end; + if fdhandleout <> -1 then begin + myfdclose(fdhandleout); + end; + end; + fdhandlein := -1; + fdhandleout := -1; +end; + +procedure tlasio.internalclose(error:word); +begin + if state<>wsclosed then begin + if (fdhandlein < 0) or (fdhandleout < 0) then raise exception.create('internalclose called with invalid fd handles'); + eventcore.rmasterclr(fdhandlein);//fd_clr(fdhandlein,fdsrmaster); + eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster); + + if closehandles then begin + {$ifndef win32} + //anyone remember why this is here? --plugwash + fcntl(fdhandlein,F_SETFL,0); + {$endif} + myfdclose(fdhandlein); + if fdhandleout <> fdhandlein then begin + {$ifndef win32} + fcntl(fdhandleout,F_SETFL,0); + {$endif} + myfdclose(fdhandleout); + end; + eventcore.setfdreverse(fdhandlein,nil); + eventcore.setfdreverse(fdhandleout,nil); + + fdhandlein := -1; + fdhandleout := -1; + end; + state := wsclosed; + + if assigned(onsessionclosed) then if not destroying then onsessionclosed(self,error); + end; + sendq.del(maxlongint); +end; + + +{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} +{ All exceptions *MUST* be handled. If an exception is not handled, the } +{ application will most likely be shut down ! } +procedure tlasio.HandleBackGroundException(E: Exception); +var + CanAbort : Boolean; +begin + CanAbort := TRUE; + { First call the error event handler, if any } + if Assigned(OnBgException) then begin + try + OnBgException(Self, E, CanAbort); + except + end; + end; + { Then abort the socket } + if CanAbort then begin + try + close; + except + end; + end; +end; + +procedure tlasio.sendstr(const str : string); +begin + putstringinsendbuffer(str); + sendflush; +end; + +procedure tlasio.putstringinsendbuffer(const newstring : string); +begin + if newstring <> '' then putdatainsendbuffer(@newstring[1],length(newstring)); +end; + +function tlasio.send(data:pointer;len:integer):integer; +begin + if state <> wsconnected then begin + result := -1; + exit; + end; + if len < 0 then len := 0; + result := len; + putdatainsendbuffer(data,len); + sendflush; +end; + + +procedure tlasio.putdatainsendbuffer(data:pointer;len:integer); +begin + sendq.add(data,len); +end; + +function tlasio.sendflush : integer; +var + lensent : integer; + data:pointer; +// fdstestr : fdset; +// fdstestw : fdset; +begin + if state <> wsconnected then exit; + + lensent := sendq.get(data,2920); + if assigned(data) then result := myfdwrite(fdhandleout,data^,lensent) else result := 0; + + if result = -1 then lensent := 0 else lensent := result; + + //sendq := copy(sendq,lensent+1,length(sendq)-lensent); + sendq.del(lensent); + + //fd_clr(fdhandleout,fdsw); // this prevents the socket being closed by a write + // that sends nothing because a previous socket has + // slready flushed this socket when the message loop + // reaches it +// if sendq.size > 0 then begin + eventcore.wmasterset(fdhandleout);//fd_set(fdhandleout,fdswmaster); +// end else begin +// wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster); +// end; + if result > 0 then begin + if assigned(onsenddata) then onsenddata(self,result); +// if sendq.size=0 then if assigned(ondatasent) then begin +// tltask.create(self.dodatasent,self,0,0); +// //begin test code +// fd_zero(fdstestr); +// fd_zero(fdstestw); +// fd_set(fdhandlein,fdstestr); +// fd_set(fdhandleout,fdstestw); +// select(maxs,@fdstestr,@fdstestw,nil,0); +// writeln(fd_isset(fdhandlein,fdstestr),' ',fd_isset(fdhandleout,fdstestw)); +// //end test code +// +// end; + writtenthiscycle := true; + end; +end; + +procedure tlasio.dupnowatch(invalue:longint); +begin + { debugout('invalue='+inttostr(invalue));} + //readln; + if state<> wsclosed then close; + fdhandlein := invalue; + fdhandleout := invalue; + eventcore.setfdreverse(fdhandlein,self); + {$ifndef win32} + fcntl(fdhandlein,F_SETFL,OPEN_NONBLOCK); + {$endif} + state := wsconnected; + +end; + + +procedure tlasio.dup(invalue:longint); +begin + dupnowatch(invalue); + eventcore.rmasterset(fdhandlein,false);//fd_set(fdhandlein,fdsrmaster); + eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster); +end; + + +procedure tlasio.handlefdtrigger(readtrigger,writetrigger:boolean); +var + sendflushresult : integer; + tempbuf:array[0..receivebufsize-1] of byte; +begin + if (state=wsconnected) and writetrigger then begin + //writeln('write trigger'); + + if (sendq.size >0) then begin + + sendflushresult := sendflush; + if (sendflushresult <= 0) and (not writtenthiscycle) then begin + if sendflushresult=0 then begin // linuxerror := 0; + internalclose(0); + + end else begin + internalclose({$ifdef win32}getlasterror{$else}linuxerror{$endif}); + end; + end; + + end else begin + //everything is sent fire off ondatasent event + if fdhandleout >= 0 then eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster); + if assigned(ondatasent) then tltask.create(self.dodatasent,self,0,0); + end; + if assigned(onfdwrite) then onfdwrite(self,0); + end; + writtenthiscycle := false; + if (state =wsconnected) and readtrigger then begin + if recvq.size=0 then begin + numread := myfdread(fdhandlein,tempbuf,sizeof(tempbuf)); + if (numread=0) and (not mustrefreshfds) then begin + {if i remember correctly numread=0 is caused by eof + if this isn't dealt with then you get a cpu eating infinite loop + however if onsessionconencted has called processmessages that could + cause us to drop to here with an empty recvq and nothing left to read + and we don't want that to cause the socket to close} + + internalclose(0); + end else if (numread=-1) then begin + {$ifdef win32} + //sometimes on windows we get stale messages due to the inherent delays + //in the windows message queue + if WSAGetLastError = wsaewouldblock then begin + //do nothing + end else + {$endif} + begin + numread := 0; + internalclose({$ifdef win32}wsagetlasterror{$else}linuxerror{$endif}); + end; + end else if numread > 0 then recvq.add(@tempbuf,numread); + end; + + if recvq.size > 0 then begin + if wsonoreceiveloop in componentoptions then eventcore.rmasterclr(fdhandlein); //fd_clr(fdhandlein,fdsrmaster); + if assigned(ondataavailable) then ondataAvailable(self,0); + if not (wsonoreceiveloop in componentoptions) then if recvq.size > 0 then + tltask.create(self.doreceiveloop,self,0,0); + end; + //until (numread = 0) or (currentsocket.state<>wsconnected); +{ debugout('inner loop complete');} + end; +end; + +{$ifndef win32} + procedure tlasio.flush; + var + fds : fdset; + begin + fd_zero(fds); + fd_set(fdhandleout,fds); + while sendq.size>0 do begin + select(fdhandleout+1,nil,@fds,nil,nil); + if sendflush <= 0 then exit; + end; + end; +{$endif} + +procedure tlasio.dodatasent(wparam,lparam:longint); +begin + if assigned(ondatasent) then ondatasent(self,lparam); +end; + +procedure tlasio.deletebuffereddata; +begin + sendq.del(maxlongint); +end; + +procedure tlasio.sinkdata(sender:tobject;error:word); +begin + tlasio(sender).recvq.del(maxlongint); +end; + +{$ifndef win32} + procedure tltimer.resettimes; + begin + gettimeofday(nextts); + {if not initialevent then} tv_add(nextts,interval); + end; +{$endif} + +{procedure tltimer.setinitialevent(newvalue : boolean); +begin + if newvalue <> finitialevent then begin + finitialevent := newvalue; + if assigned(timerwrapperinterface) then begin + timerwrapperinterface.setinitialevent(wrappedtimer,newvalue); + end else begin + resettimes; + end; + end; +end;} + +procedure tltimer.setontimer(newvalue:tnotifyevent); +begin + if @newvalue <> @fontimer then begin + fontimer := newvalue; + if assigned(timerwrapperinterface) then begin + timerwrapperinterface.setontimer(wrappedtimer,newvalue); + end else begin + + end; + end; + +end; + + +procedure tltimer.setenabled(newvalue : boolean); +begin + if newvalue <> fenabled then begin + fenabled := newvalue; + if assigned(timerwrapperinterface) then begin + timerwrapperinterface.setenabled(wrappedtimer,newvalue); + end else begin + {$ifdef win32} + raise exception.create('non wrapper timers are not permitted on windows'); + {$else} + resettimes; + {$endif} + end; + end; +end; + +procedure tltimer.setinterval(newvalue:integer); +begin + if newvalue <> finterval then begin + finterval := newvalue; + if assigned(timerwrapperinterface) then begin + timerwrapperinterface.setinterval(wrappedtimer,newvalue); + end else begin + {$ifdef win32} + raise exception.create('non wrapper timers are not permitted on windows'); + {$else} + resettimes; + {$endif} + end; + end; + +end; + + + + +constructor tltimer.create; +begin + inherited create(AOwner); + if assigned(timerwrapperinterface) then begin + wrappedtimer := timerwrapperinterface.createwrappedtimer; + end else begin + + + nexttimer := firsttimer; + prevtimer := nil; + + if assigned(nexttimer) then nexttimer.prevtimer := self; + firsttimer := self; + end; + interval := 1000; + enabled := true; + released := false; + +end; + +destructor tltimer.destroy; +begin + if assigned(timerwrapperinterface) then begin + wrappedtimer.free; + end else begin + if prevtimer <> nil then begin + prevtimer.nexttimer := nexttimer; + end else begin + firsttimer := nexttimer; + end; + if nexttimer <> nil then begin + nexttimer.prevtimer := prevtimer; + end; + + end; + inherited destroy; +end; + +constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint); +begin + inherited create; + if assigned(onaddtask) then onaddtask(ahandler,aobj,awparam,alparam); + handler := ahandler; + obj := aobj; + wparam := awparam; + lparam := alparam; + {nexttask := firsttask; + firsttask := self;} + if assigned(lasttask) then begin + lasttask.nexttask := self; + end else begin + firsttask := self; + end; + lasttask := self; + //ahandler(wparam,lparam); +end; + +procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint); +begin + + tltask.create(ahandler,aobj,awparam,alparam); +end; + +{$ifndef nosignal} + procedure prepsigpipe;{$ifndef ver1_0}inline; +{$endif} + begin + starthandlesignal(sigpipe); + if not assigned(signalloopback) then begin + signalloopback := tlloopback.create(nil); + signalloopback.ondataAvailable := signalloopback.sinkdata; + + end; + + end; +{$endif} + +procedure processtasks;//inline; +var + temptask : tltask ; + +begin + + if not assigned(currenttask) then begin + currenttask := firsttask; + firsttask := nil; + lasttask := nil; + end; + while assigned(currenttask) do begin + + if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam); + if assigned(currenttask) then begin + temptask := currenttask; + currenttask := currenttask.nexttask; + temptask.free; + end; + //writeln('processed a task'); + end; + +end; + + + + +procedure disconnecttasks(aobj:tobject); +var + currenttasklocal : tltask ; + counter : byte ; +begin + for counter := 0 to 1 do begin + if counter = 0 then begin + currenttasklocal := firsttask; //main list of tasks + end else begin + currenttasklocal := currenttask; //needed in case called from a task + end; + // note i don't bother to sestroy the links here as that will happen when + // the list of tasks is processed anyway + while assigned(currenttasklocal) do begin + if currenttasklocal.obj = aobj then begin + currenttasklocal.obj := nil; + currenttasklocal.handler := nil; + end; + currenttasklocal := currenttasklocal.nexttask; + end; + end; +end; + + +procedure processmessages; +begin + eventcore.processmessages; +end; +procedure messageloop; +begin + eventcore.messageloop; +end; + +procedure exitmessageloop; +begin + eventcore.exitmessageloop; +end; + +function tlasio.RealSend(Data : Pointer; Len : Integer) : Integer; +begin + result := myfdwrite(fdhandleout,data^,len); + if (result > 0) and assigned(onsenddata) then onsenddata(self,result); + eventcore.wmasterset(fdhandleout); +end; +{$ifndef win32} + procedure tlasio.myfdclose(fd : integer); + begin + fdclose(fd); + end; + function tlasio.myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt; + begin + result := fdwrite(fd,buf,size); + end; + + function tlasio.myfdread(fd: LongInt;var buf;size: LongInt):LongInt; + begin + result := fdread(fd,buf,size); + end; + + +{$endif} + + +begin + firstasin := nil; + firsttask := nil; + + + {$ifndef nosignal} + signalloopback := nil; + {$endif} +end. + + + + + diff --git a/lcoregtklaz.pas b/lcoregtklaz.pas new file mode 100755 index 0000000..bbf4418 --- /dev/null +++ b/lcoregtklaz.pas @@ -0,0 +1,142 @@ +{ 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 + ----------------------------------------------------------------------------- } + +unit lcoregtklaz; +{$mode delphi} +interface + +uses baseunix,unix,glib, gdk, gtk,lcore,forms,fd_utils,classes; +//procedure lcoregtklazrun; +const + G_IO_IN=1; + G_IO_OUT=4; + G_IO_PRI=2; + G_IO_ERR=8; + + G_IO_HUP=16; + G_IO_NVAL=32; +type + tlaztimerwrapperinterface=class(ttimerwrapperinterface) + public + function createwrappedtimer : tobject;override; +// procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);override; + procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);override; + procedure setenabled(wrappedtimer : tobject;newvalue : boolean);override; + procedure setinterval(wrappedtimer : tobject;newvalue : integer);override; + end; + +procedure lcoregtklazinit; +implementation + uses + ExtCtrls; +{$I unixstuff.inc} +var + giochannels : array[0..absoloutemaxs] of pgiochannel; + +function iocallback(source:PGIOChannel; condition:TGIOCondition; data:gpointer):gboolean;cdecl; +// return true if we want the callback to stay +var + fd : integer ; + fdsrlocal , fdswlocal : fdset ; + currentasio : tlasio ; +begin + fd := g_io_channel_unix_get_fd(source); + fd_zero(fdsrlocal); + fd_set(fd,fdsrlocal); + fdswlocal := fdsrlocal; + select(fd+1,@fdsrlocal,@fdswlocal,nil,0); + if fd_isset(fd,fdsrlocal) or fd_isset(fd,fdsrlocal) then begin + currentasio := fdreverse[fd]; + if assigned(currentasio) then begin + currentasio.handlefdtrigger(fd_isset(currentasio.fdhandlein,fdsrlocal),fd_isset(currentasio.fdhandleout,fdswlocal)); + end else begin + rmasterclr(fd); + wmasterclr(fd); + end; + end; + case condition of + G_IO_IN : begin + result := rmasterisset(fd); + end; + G_IO_OUT : begin + result := wmasterisset(fd); + end; + end; +end; + +procedure gtkrmasterset(fd : integer); +begin + if not assigned(giochannels[fd]) then giochannels[fd] := g_io_channel_unix_new(fd); + g_io_add_watch(giochannels[fd],G_IO_IN,iocallback,nil); +end; + +procedure gtkrmasterclr(fd: integer); +begin +end; + +procedure gtkwmasterset(fd : integer); +begin + if not assigned(giochannels[fd]) then giochannels[fd] := g_io_channel_unix_new(fd); + g_io_add_watch(giochannels[fd],G_IO_OUT,iocallback,nil); +end; + +procedure gtkwmasterclr(fd: integer); +begin +end; + +type + tsc = class + procedure dotasksandsink(sender:tobject;error:word); + end; +var + taskloopback : tlloopback; + sc : tsc; +procedure tsc.dotasksandsink(sender:tobject;error:word); +begin + with tlasio(sender) do begin + sinkdata(sender,error); + processtasks; + end; +end; +procedure gtkaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint); +begin + taskloopback.sendstr(' '); + +end; + +procedure lcoregtklazinit; +begin + onrmasterset := gtkrmasterset; + onrmasterclr := gtkrmasterclr; + onwmasterset := gtkwmasterset; + onwmasterclr := gtkwmasterclr; + onaddtask := gtkaddtask; + taskloopback := tlloopback.create(nil); + taskloopback.ondataavailable := sc.dotasksandsink; + timerwrapperinterface := tlaztimerwrapperinterface.create(nil); +end; + +function tlaztimerwrapperinterface.createwrappedtimer : tobject; +begin + result := ttimer.create(nil); +end; +procedure tlaztimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent); +begin + ttimer(wrappedtimer).ontimer := newvalue; +end; +procedure tlaztimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean); +begin + ttimer(wrappedtimer).enabled := newvalue; +end; + + +procedure tlaztimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer); +begin + ttimer(wrappedtimer).interval := newvalue; +end; + + +end. + diff --git a/lcoreselect.pas b/lcoreselect.pas new file mode 100755 index 0000000..e0351eb --- /dev/null +++ b/lcoreselect.pas @@ -0,0 +1,399 @@ +{lsocket.pas} + +{io and timer code by plugwash} + +{ 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 + ----------------------------------------------------------------------------- } + +{$ifdef fpc} + {$ifndef ver1_0} + {$define useinline} + {$endif} +{$endif} + +unit lcoreselect; + + +interface +uses + {$ifdef VER1_0} + linux, + {$else} + baseunix,unix,unixutil, + {$endif} + fd_utils; +var + maxs : longint ; + exitloopflag : boolean ; {if set by app, exit mainloop} + +function getfdsrmaster : fdset; {$ifdef useinline}inline;{$endif} +function getfdswmaster : fdset; {$ifdef useinline}inline;{$endif} + +implementation +uses + lcore,sysutils, + classes,pgtypes,bfifo, + {$ifndef nosignal} + lsignal; + {$endif} + +{$include unixstuff.inc} +{$include ltimevalstuff.inc} +var + fdreverse:array[0..absoloutemaxs] of tlasio; +type + tselecteventcore=class(teventcore) + public + procedure processmessages; override; + procedure messageloop; override; + procedure exitmessageloop;override; + procedure setfdreverse(fd : integer;reverseto : tlasio); override; + procedure rmasterset(fd : integer;islistensocket : boolean); override; + procedure rmasterclr(fd: integer); override; + procedure wmasterset(fd : integer); override; + procedure wmasterclr(fd: integer); override; + end; + +procedure processtimers;inline; +var + tv ,tvnow : ttimeval ; + currenttimer : tltimer ; + temptimer : tltimer ; + +begin + gettimeofday(tvnow); + currenttimer := firsttimer; + while assigned(currenttimer) do begin + //writeln(currenttimer.enabled); + if tv_compare(tvnow,ttimeval(currenttimer.nextts)) and currenttimer.enabled then begin + //if assigned(currenttimer.ontimer) then begin + // if currenttimer.enabled then if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer); + // currenttimer.initialdone := true; + //end; + if assigned(currenttimer.ontimer) then currenttimer.ontimer(currenttimer); + currenttimer.nextts := timeval(tvnow); + tv_add(ttimeval(currenttimer.nextts),currenttimer.interval); + end; + temptimer := currenttimer; + currenttimer := currenttimer.nexttimer; + if temptimer.released then temptimer.free; + end; +end; + +procedure processasios(var fdsr,fdsw:fdset);//inline; +var + currentsocket : tlasio ; + tempsocket : tlasio ; + socketcount : integer ; // for debugging perposes :) + dw,bt:integer; +begin +{ inc(lcoretestcount);} + + //the message loop will exit if all lasio's and ltimer's and lsignal's are destroyed + //if (not assigned(firstasin)) and (not assigned(firsttimer)) and (not assigned(firstsignal)) then exit; + + + {------- test optimised loop} + socketcount := 0; + for dw := (maxs shr 5) downto 0 do if (fdsr[dw] or fdsw[dw]) <> 0 then begin + for bt := 0 to 31 do if (fdsr[dw] or fdsw[dw]) and (1 shl bt) <> 0 then begin + inc(socketcount); + currentsocket := fdreverse[dw shl 5 or bt]; + {if not assigned(currentsocket) then raise exception.create('currentsocket not assigned'); + if currentsocket.fdhandlein < 0 then raise exception.create('currentsocket.fdhandlein out of range');} + {i've seen the out of range case actually happening, so it can happen. test: just close the fd - beware} + if not assigned(currentsocket) then begin + fdclose(dw shl 5 or bt); + continue + end; + if currentsocket.fdhandlein < 0 then begin + fdclose(dw shl 5 or bt); + continue + end; + try + currentsocket.handlefdtrigger(fd_isset(currentsocket.fdhandlein,fdsr),fd_isset(currentsocket.fdhandleout,fdsw)); + except + on E: exception do begin + currentsocket.HandleBackGroundException(e); + end; + end; + + if mustrefreshfds then begin + if select(maxs+1,@fdsr,@fdsw,nil,0) <= 0 then begin + fd_zero(fdsr); + fd_zero(fdsw); + end; + end; + end; + end; + + if asinreleaseflag then begin + asinreleaseflag := false; + currentsocket := firstasin; + while assigned(currentsocket) do begin + tempsocket := currentsocket; + currentsocket := currentsocket.nextasin; + if tempsocket.released then begin + tempsocket.free; + end; + end; + end; + { + !!! issues: + - sockets which are released may not be freed because theyre never processed by the loop + made new code for handling this, using asinreleaseflag + + - when/why does the mustrefreshfds select apply, sheck if i did it correctly? + + - what happens if calling handlefdtrigger for a socket which does not have an event + } + {------- original loop} + + (* + currentsocket := firstasin; + socketcount := 0; + while assigned(currentsocket) do begin + if mustrefreshfds then begin + if select(maxs,@fdsr,@fdsw,nil,0) <= 0 then begin + fd_zero(fdsr); + fd_zero(fdsw); + end; + end; + try + if fd_isset(currentsocket.fdhandlein,fdsr) or fd_isset(currentsocket.fdhandleout,fdsw) then begin + currentsocket.handlefdtrigger(fd_isset(currentsocket.fdhandlein,fdsr),fd_isset(currentsocket.fdhandleout,fdsw)); + end; + except + on E: exception do begin + currentsocket.HandleBackGroundException(e); + end; + end; + tempsocket := currentsocket; + currentsocket := currentsocket.nextasin; + inc(socketcount); + if tempsocket.released then begin + tempsocket.free; + end; + end; *) +{ debugout('socketcount='+inttostr(socketcount));} +end; + +procedure tselecteventcore.processmessages; +var + fdsr , fdsw : fdset ; + selectresult : longint ; +begin + mustrefreshfds := false; + {$ifndef nosignal} + prepsigpipe; + {$endif} + selectresult := select(maxs+1,@fdsr,@fdsw,nil,0); + while (selectresult>0) or assigned(firsttask) or assigned(currenttask) do begin; + + processtasks; + processtimers; + if selectresult > 0 then begin + processasios(fdsr,fdsw); + end; + selectresult := select(maxs+1,@fdsr,@fdsw,nil,0); + + end; + mustrefreshfds := true; +end; + + +var + FDSR , FDSW : fdset; + +var + fdsrmaster , fdswmaster : fdset ; + +function getfdsrmaster : fdset; {$ifdef fpc}inline;{$endif} +begin + result := fdsrmaster; +end; +function getfdswmaster : fdset; {$ifdef fpc}inline;{$endif} +begin + result := fdswmaster; +end; + + +Function doSelect(timeOut:PTimeVal):longint;//inline; +var + localtimeval : ttimeval; + maxslocal : integer; +begin + //unblock signals + //zeromemory(@sset,sizeof(sset)); + //sset[0] := ; + fdsr := getfdsrmaster; + fdsw := getfdswmaster; + + if assigned(firsttask) then begin + localtimeval.tv_sec := 0; + localtimeval.tv_usec := 0; + timeout := @localtimeval; + end; + + maxslocal := maxs; + mustrefreshfds := false; +{ debugout('about to call select');} + {$ifndef nosignal} + sigprocmask(SIG_UNBLOCK,@blockset,nil); + {$endif} + result := select(maxslocal+1,@FDSR,@FDSW,nil,timeout); + if result <= 0 then begin + fd_zero(FDSR); + fd_zero(FDSW); + if result=-1 then begin + if linuxerror = SYS_EINTR then begin + // we received a signal it's not a problem + end else begin + raise esocketexception.create('select returned error '+inttostr(linuxerror)); + end; + end; + end; + {$ifndef nosignal} + sigprocmask(SIG_BLOCK,@blockset,nil); + {$endif} +{ debugout('select complete');} +end; + +procedure tselecteventcore.exitmessageloop; +begin + exitloopflag := true +end; + + + +procedure tselecteventcore.messageloop; +var + tv ,tvnow : ttimeval ; + currenttimer : tltimer ; + selectresult:integer; +begin + {$ifndef nosignal} + prepsigpipe; + {$endif} + {currentsocket := firstasin; + if not assigned(currentsocket) then exit; //the message loop will exit if all lsockets are destroyed + repeat + + if currentsocket.state = wsconnected then currentsocket.sendflush; + currentsocket := currentsocket.nextasin; + until not assigned(currentsocket);} + + + repeat + + //the message loop will exit if all lasio's and ltimer's and lsignal's are destroyed + if (not assigned(firstasin)) and (not assigned(firsttimer)) {$ifndef nosignal} and (not assigned(firstsignal)){$endif} then exit; + {fd_zero(FDSR); + fd_zero(FDSW); + currentsocket := firstasin; + if not assigned(currentsocket) then exit; //the message loop will exit if all lsockets are destroyed + + repeat + if (not currentsocket.released) and (currentsocket.state<>wsclosed) then fd_set(currentsocket.fdhandlein,fdsr); + if (not currentsocket.released) and (currentsocket.state=wsconnecting) then fd_set(currentsocket.fdhandleout,fdsw); + if currentsocket is tlsocket then begin + if (not currentsocket.released) and (currentsocket.state=wsconnected) and(tlsocket(currentsocket).sendq <> '') then fd_set(currentsocket.fdhandleout,fdsw); + end; + tempsocket := currentsocket; + currentsocket := currentsocket.nextasin; + if tempsocket.released then begin + tempsocket.free; + end; + until not assigned(currentsocket); + } + processtasks; + //currenttask := nil; + {beware} + //if assigned(firsttimer) then begin + // tv.tv_sec := maxlongint; + tv := tv_invalidtimebig; + currenttimer := firsttimer; + while assigned(currenttimer) do begin + if tv_compare(tv,currenttimer.nextts) and currenttimer.enabled then tv := currenttimer.nextts; + currenttimer := currenttimer.nexttimer; + end; + + + if tv_compare(tv,tv_invalidtimebig) then begin + //writeln('no timers active'); + if exitloopflag then break; +{ sleep(10);} + selectresult := doselect(nil); + + end else begin + gettimeofday(tvnow); + tv_substract(tv,tvnow); + + //writeln('timers active'); + if tv.tv_sec < 0 then begin + tv.tv_sec := 0; + tv.tv_usec := 0; {0.1 sec} + end; + if exitloopflag then break; +{ sleep(10);} + selectresult := doselect(@tv); + processtimers; + + end; + if selectresult > 0 then processasios(fdsr,fdsw); + {!!!only call processasios if select has asio events -beware} + + {artificial delay to throttle the number of processasios per second possible and reduce cpu usage} + until false; +end; + + +procedure tselecteventcore.rmasterset(fd : integer;islistensocket : boolean); +begin + if fd > absoloutemaxs then raise esocketexception.create('file discriptor out of range'); + if fd > maxs then maxs := fd; + if fd_isset(fd,fdsrmaster) then exit; + fd_set(fd,fdsrmaster); + +end; + +procedure tselecteventcore.rmasterclr(fd: integer); +begin + if not fd_isset(fd,fdsrmaster) then exit; + fd_clr(fd,fdsrmaster); + +end; + + +procedure tselecteventcore.wmasterset(fd : integer); +begin + if fd > absoloutemaxs then raise esocketexception.create('file discriptor out of range'); + if fd > maxs then maxs := fd; + + if fd_isset(fd,fdswmaster) then exit; + fd_set(fd,fdswmaster); + +end; + +procedure tselecteventcore.wmasterclr(fd: integer); +begin + if not fd_isset(fd,fdswmaster) then exit; + fd_clr(fd,fdswmaster); +end; + +procedure tselecteventcore.setfdreverse(fd : integer;reverseto : tlasio); +begin + fdreverse[fd] := reverseto; +end; + + + +begin + eventcore := tselecteventcore.create; + + maxs := 0; + fd_zero(fdsrmaster); + fd_zero(fdswmaster); +end. diff --git a/lcoretest.dof b/lcoretest.dof new file mode 100755 index 0000000..097f5c8 --- /dev/null +++ b/lcoretest.dof @@ -0,0 +1,75 @@ +[Compiler] +A=1 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=1 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=0 +R=0 +S=0 +T=0 +U=0 +V=1 +W=0 +X=1 +Y=0 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=0 +DebugInfo=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription= +[Directories] +OutputDir= +UnitOutputDir= +SearchPath= +Packages=vclx30;VCL30;vcldb30;vcldbx30;VclSmp30;Qrpt30;teeui30;teedb30;tee30;IBEVNT30 +Conditionals=ipv6 +DebugSourceDirs= +UsePackages=0 +[Parameters] +RunParams= +HostApplication= +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=2057 +CodePage=1252 +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= diff --git a/lcoretest.dpr b/lcoretest.dpr new file mode 100755 index 0000000..f6fe72b --- /dev/null +++ b/lcoretest.dpr @@ -0,0 +1,181 @@ +program lcoretest; + +uses + lcore, + lsocket, + {$ifdef win32} + lcorewsaasyncselect in 'lcorewsaasyncselect.pas', + {$else} + lcoreselect, + {$endif} + dnsasync, + binipstuff, + sysutils, + dnssync; +{$ifdef win32} + {$R *.RES} +{$endif} + +type + tsc=class + procedure sessionavailable(sender: tobject;error : word); + procedure dataavailable(sender: tobject;error : word); + procedure sessionconnected(sender: tobject;error : word); + procedure taskrun(wparam,lparam:longint); + procedure timehandler(sender:tobject); + procedure dnsrequestdone(sender:tobject;error : word); + procedure sessionclosed(sender:tobject;error : word); + end; +var + listensocket : tlsocket; + serversocket : tlsocket; + clientsocket : tlsocket; + sc : tsc; + task : tltask; +procedure tsc.sessionavailable(sender: tobject;error : word); +begin + writeln('received connection'); + serversocket.dup(listensocket.accept); +end; + +var + receivebuf : string; + receivecount : integer; +procedure tsc.dataavailable(sender: tobject;error : word); +var + receiveddata : string; + receivedon : string; + line : string; +begin + receiveddata := tlsocket(sender).receivestr; + if sender=clientsocket then begin + receivedon := 'client socket'; + end else begin + receivedon := 'server socket'; + end; + writeln('received data '+receiveddata+' on '+receivedon); + + receivebuf := receivebuf+receiveddata; + + if receivebuf = 'hello world' then begin + receivebuf := ''; + writeln('received hello world creating task'); + task := tltask.create(sc.taskrun,nil,0,0); + end; + receivecount := receivecount +1; + if receivecount >50 then begin + writeln('received over 50 bits of data, pausing to let the operator take a look'); + readln; + receivecount := 0; + end; + while pos(#10,receivebuf) > 0 do begin + line := receivebuf; + setlength(line,pos(#10,receivebuf)-1); + receivebuf := copy(receivebuf,pos(#10,receivebuf)+1,1000000); + if uppercase(copy(line,1,4))='PING' then begin + line[2] := 'o'; + writeln('send pong:'+line); + clientsocket.sendstr(line+#10); + end; + end; +end; + +procedure tsc.sessionconnected(sender: tobject;error : word); +begin + if error=0 then begin + writeln('session is connected, local address is'+clientsocket.getxaddr); + + if (clientsocket.addr = '127.0.0.1') or (clientsocket.addr = '::1') then begin + clientsocket.sendstr('hello world'); + end else begin + clientsocket.sendstr('nick test'#13#10'user x x x x'#13#10); + end; + end else begin + writeln('connect failed'); + end; +end; + +var + das : tdnsasync; + +procedure tsc.taskrun(wparam,lparam:longint); +var + tempbinip : tbinip; + dummy : integer; +begin + writeln('task ran'); + writeln('closing client socket'); + clientsocket.close; + + writeln('looking up irc.ipv6.p10link.net using dnsasync'); + das := tdnsasync.Create(nil); + das.onrequestdone := sc.dnsrequestdone; + //das.forwardfamily := af_inet6; + das.forwardlookup('irc.ipv6.p10link.net'); +end; + +procedure tsc.dnsrequestdone(sender:tobject;error : word); +begin + writeln('irc.ipv6.p10link.net resolved to '+das.dnsresult+' connecting client socket there'); + clientsocket.addr := das.dnsresult; + clientsocket.port := '6667'; + clientsocket.connect; + writeln(clientsocket.getxaddr); + das.free; +end; + +procedure tsc.timehandler(sender:tobject); +begin + //writeln('got timer event'); +end; +procedure tsc.sessionclosed(sender:tobject;error : word); +begin + Writeln('session closed with error ',error); +end; +var + timer : tltimer; + ipbin : tbinip; + dummy : integer; +begin + ipbin := forwardlookup('invalid.domain',5); + writeln(ipbintostr(ipbin)); + + ipbin := forwardlookup('p10link.net',5); + writeln(ipbintostr(ipbin)); + + ipstrtobin('80.68.89.68',ipbin); + writeln('80.68.89.68 reverses to '+reverselookup(ipbin,5)); + + ipstrtobin('2001:200::8002:203:47ff:fea5:3085',ipbin); + writeln('2001:200::8002:203:47ff:fea5:3085 reverses to '+reverselookup(ipbin,5)); + writeln('creating and setting up listen socket'); + listensocket := tlsocket.create(nil); + listensocket.addr := '::'; + listensocket.port := '12345'; + listensocket.onsessionavailable := sc.sessionavailable; + writeln('listening'); + listensocket.listen; + writeln(listensocket.getxport); + writeln('listen socket is number ', listensocket.fdhandlein); + writeln('creating and setting up server socket'); + serversocket := tlsocket.create(nil); + serversocket.ondataavailable := sc.dataavailable; + writeln('creating and setting up client socket'); + clientsocket := tlsocket.create(nil); + clientsocket.addr := '::1';{'127.0.0.1';} + clientsocket.port := '12345'; + clientsocket.onsessionconnected := sc.sessionconnected; + clientsocket.ondataAvailable := sc.dataavailable; + clientsocket.onsessionclosed := sc.sessionclosed; + writeln('connecting'); + clientsocket.connect; + writeln('client socket is number ',clientsocket.fdhandlein); + writeln('creating and setting up timer'); + timer := tltimer.create(nil); + timer.interval := 1000; + timer.ontimer := sc.timehandler; + timer.enabled := true; + writeln('entering message loop'); + messageloop; + writeln('exiting cleanly'); +end. diff --git a/lcoretest.res b/lcoretest.res new file mode 100755 index 0000000000000000000000000000000000000000..a5286932ae3a9a75033174bf0e5af726d9a86f56 GIT binary patch literal 876 zcmah|v1;Q$6daul@qYeMtT@= zCD`+SWB~ujG8edVOJ=C+nu1(Hf^mVXyO$LIL84gL5Uw7iMP}2!5EPv{+r;)Kj-aDK z>_jbvR1C3$wD<)ti@A zEflgmZ=4>hBq+vrzoK4miXvSUl^*olq)qSl)#IQm)vhc3$bQ@qQL?<>?<>7!F6ZW| zU9H!p%}1iEyY*_N^%Heou*qA!+Lat24WdVyS!s1hL%!1`{Z{V{T31fD9eGDbuS;Pz z50|B0a@>HH^vAwVC?DYm2p>#hRV;;7l$!gzZ{6fgI2CjYs6J9p#888?6?~&d> z*wIIN2gX-Mer3L?8Ml#d%pox5HDsJHUVQ;@Ng8vGANYpv_(@)4&UnP>yO7u5VLBaM K%Bzr9 nil then deltree(@fdreverse,inttostr(fd)); + if reverseto <> nil then addtree(@fdreverse,inttostr(fd),reverseto); +end; + +var + hwndlcore : hwnd; +procedure dowsaasyncselect(fd:integer; leventadd: integer; leventremove : integer); +var + leventold : integer; + leventnew : integer; + wsaaresult : integer; +begin + leventold := taddrint(findtree(@fdwatches,inttostr(fd))); + leventnew := leventold or leventadd; + leventnew := leventnew and not leventremove; + if leventold <> leventnew then begin + if leventold <> 0 then deltree(@fdwatches,inttostr(fd)); + if leventnew <> 0 then addtree(@fdwatches,inttostr(fd),pointer(leventnew)); + end; + wsaaresult := wsaasyncselect(fd,hwndlcore,wm_user,leventnew); + +end; + + +//to allow detection of errors: +//if we are asked to monitor for read or accept we also monitor for close +//if we are asked to monitor for write we also monitor for connect + + +procedure twineventcore.rmasterset(fd : integer;islistensocket : boolean); +begin + if islistensocket then begin + //writeln('setting accept watch for socket number ',fd); + dowsaasyncselect(fd,FD_ACCEPT or FD_CLOSE,0); + end else begin + //writeln('setting read watch for socket number',fd); + dowsaasyncselect(fd,FD_READ or FD_CLOSE,0); + end; +end; +procedure twineventcore.rmasterclr(fd: integer); +begin + //writeln('clearing read of accept watch for socket number ',fd); + dowsaasyncselect(fd,0,FD_ACCEPT or FD_READ or FD_CLOSE); +end; +procedure twineventcore.wmasterset(fd : integer); +begin + dowsaasyncselect(fd,FD_WRITE or FD_CONNECT,0); +end; + +procedure twineventcore.wmasterclr(fd: integer); +begin + dowsaasyncselect(fd,0,FD_WRITE or FD_CONNECT); +end; + +var + tasksoutstanding : boolean; + +function MyWindowProc( + ahWnd : HWND; + auMsg : Integer; + awParam : WPARAM; + alParam : LPARAM): Integer; stdcall; +var + socket : integer; + event : integer; + error : integer; + readtrigger : boolean; + writetrigger : boolean; + lasio : tlasio; +begin + //writeln('got a message'); + Result := 0; // This means we handled the message + if (ahwnd=hwndlcore) and (aumsg=wm_user) then begin + //writeln('it appears to be a response to our wsaasyncselect'); + socket := awparam; + event := alparam and $FFFF; + error := alparam shr 16; + //writeln('socket=',socket,' event=',event,' error=',error); + readtrigger := false; + writetrigger := false; + lasio := findtree(@fdreverse,inttostr(socket)); + if assigned(lasio) then begin + if (error <> 0) or ((event and FD_CLOSE) <> 0) then begin + if lasio.state = wsconnecting then begin + lasio.onsessionconnected(lasio,error); + end; + lasio.internalclose(error); + end else begin + if (event and (FD_READ or FD_ACCEPT)) <> 0 then readtrigger := true; + if (event and (FD_WRITE)) <> 0 then writetrigger := true; + + if readtrigger or writetrigger then lasio.handlefdtrigger(readtrigger,writetrigger); + end; + dowsaasyncselect(socket,0,0); //reset watches + end; + end else if (ahwnd=hwndlcore) and (aumsg=wm_dotasks) then begin + //writeln('processing tasks'); + tasksoutstanding := false; + processtasks; + end else begin + //writeln('passing unknown message to defwindowproc'); + //not passing unknown messages on to defwindowproc will cause window + //creation to fail! --plugwash + Result := DefWindowProc(ahWnd, auMsg, awParam, alParam) + end; + +end; + +procedure winaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint); +begin + if not tasksoutstanding then PostMessage(hwndlcore,wm_dotasks,0,0); +end; +type + twcoretimer = wcore.tltimer; + +function twintimerwrapperinterface.createwrappedtimer : tobject; +begin + result := twcoretimer.create(nil); +end; +procedure twintimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent); +begin + twcoretimer(wrappedtimer).ontimer := newvalue; +end; +procedure twintimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean); +begin + twcoretimer(wrappedtimer).enabled := newvalue; +end; + + +procedure twintimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer); +begin + twcoretimer(wrappedtimer).interval := newvalue; +end; + +var + MyWindowClass : TWndClass = (style : 0; + lpfnWndProc : @MyWindowProc; + cbClsExtra : 0; + cbWndExtra : 0; + hInstance : 0; + hIcon : 0; + hCursor : 0; + hbrBackground : 0; + lpszMenuName : nil; + lpszClassName : 'lcoreClass'); + GInitData: TWSAData; + +begin + eventcore := twineventcore.create; + if Windows.RegisterClass(MyWindowClass) = 0 then halt; + //writeln('about to create lcore handle, hinstance=',hinstance); + hwndlcore := CreateWindowEx(WS_EX_TOOLWINDOW, + MyWindowClass.lpszClassName, + '', { Window name } + WS_POPUP, { Window Style } + 0, 0, { X, Y } + 0, 0, { Width, Height } + 0, { hWndParent } + 0, { hMenu } + HInstance, { hInstance } + nil); { CreateParam } + //writeln('lcore hwnd is ',hwndlcore); + //writeln('last error is ',GetLastError); + onaddtask := winaddtask; + timerwrapperinterface := twintimerwrapperinterface.create(nil); + + WSAStartup($200, GInitData); +end. diff --git a/lloopback.pas b/lloopback.pas new file mode 100755 index 0000000..7e26d7c --- /dev/null +++ b/lloopback.pas @@ -0,0 +1,34 @@ +unit lloopback; + +interface +uses lcore,classes; + +type + tlloopback=class(tlasio) + public + constructor create(aowner:tcomponent); override; + end; + + +implementation +uses +{$ifdef ver1_0} + linux; +{$else} + baseunix,unix,unixutil; +{$endif} +{$i unixstuff.inc} + +constructor tlloopback.create(aowner:tcomponent); +begin + inherited create(aowner); + closehandles := true; + assignpipe(fdhandlein,fdhandleout); + + eventcore.rmasterset(fdhandlein,false);//fd_set(fdhandlein,fdsrmaster); + eventcore.wmasterclr(fdhandlein);//fd_clr(fdhandleout,fdswmaster); + eventcore.setfdreverse(fdhandlein,self); + eventcore.setfdreverse(fdhandleout,self); + state := wsconnected; +end; +end. diff --git a/lmessages.pas b/lmessages.pas new file mode 100755 index 0000000..7bb73fd --- /dev/null +++ b/lmessages.pas @@ -0,0 +1,656 @@ +unit lmessages; +//windows messages like system based on lcore tasks +interface + +uses pgtypes,sysutils,bsearchtree,strings,syncobjs; + +type + lparam=taddrint; + wparam=taddrint; + thinstance=pointer; + hicon=pointer; + hcursor=pointer; + hbrush=pointer; + hwnd=qword; //window handles are monotonically increasing 64 bit integers, + //this should allow for a million windows per second for over half + //a million years! + + twndproc=function(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall; + + + twndclass=record + style : dword; + lpfnwndproc : twndproc; + cbclsextra : integer; + cbwndextra : integer; + hinstance : thinstance; + hicon : hicon; + hcursor : hcursor; + hbrbackground : hbrush; + lpszmenuname : pchar; + lpszclassname : pchar; + end; + PWNDCLASS=^twndclass; + + UINT=dword; + WINBOOL = longbool; + tTIMERPROC = procedure (ahwnd:HWND; umsg:integer; idevent:taddrint;dwtime:taddrint);stdcall; + ATOM = pointer; + LPCSTR = pchar; + LPVOID = pointer; + HMENU = pointer; + HINST = pointer; + + TPOINT = record + x : LONGint; + y : LONGint; + end; + + TMSG = record + hwnd : HWND; + message : UINT; + wParam : WPARAM; + lParam : LPARAM; + time : DWORD; + pt : TPOINT; + end; + THevent=TEventObject; +const + WS_EX_TOOLWINDOW = $80; + WS_POPUP = longint($80000000); + hinstance=nil; + PM_REMOVE = 1; + WM_USER = 1024; + WM_TIMER = 275; + INFINITE = syncobjs.infinite; +function getwindowlongptr(ahwnd:hwnd;nindex:integer) : taddrint; +function setwindowlongptr(ahwnd:hwnd;nindex:integer;dwNewLong : taddrint) : taddrint; +function DefWindowProc(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall; +function RegisterClass(const lpWndClass:TWNDCLASS):ATOM; +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; +function DestroyWindow(ahWnd:HWND):WINBOOL; +function PostMessage(hWnd:HWND; Msg:UINT; wParam:WPARAM; lParam:LPARAM):WINBOOL; +function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): WINBOOL; +function DispatchMessage(const lpMsg: TMsg): Longint; +function GetMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT): WINBOOL; +function SetEvent(hEvent:THevent):WINBOOL; +function CreateEvent(lpEventAttributes:PSECURITYATTRIBUTES; bManualReset:WINBOOL; bInitialState:WINBOOL; lpName:pchar):tHevent; +function terminatethread(threadhandle : tthreadid;dummy:integer) : boolean; +function waitforsingleevent(event:thevent;timeout:cardinal) : twaitresult; +function SetTimer(ahWnd:HWND; nIDEvent:taddrint; uElapse:UINT; lpTimerFunc:tTIMERPROC):UINT; +function KillTimer(ahWnd:HWND; uIDEvent:taddrint):WINBOOL; + +procedure init; + +implementation +uses + baseunix,unix,lcore;//,safewriteln; +{$i unixstuff.inc} + +type + tmessageintransit = class + msg : tmsg; + next : tmessageintransit; + end; + + tthreaddata = class + messagequeue : tmessageintransit; + messageevent : teventobject; + waiting : boolean; + lcorethread : boolean; + nexttimer : ttimeval; + threadid : integer; + end; + twindow=class + hwnd : hwnd; + extrawindowmemory : pointer; + threadid : tthreadid; + windowproc : twndproc; + end; + +var + structurelock : tcriticalsection; + threaddata : thashtable; + windowclasses : thashtable; + lcorelinkpipesend : integer; + lcorelinkpiperecv : tlasio; + windows : thashtable; + //I would rather things crash immediately + //if they use an insufficiant size type + //than crash after over four billion + //windows have been made ;) + nextwindowhandle : qword = $100000000; +{$i ltimevalstuff.inc} + +//findthreaddata should only be called while holding the structurelock +function findthreaddata(threadid : integer) : tthreaddata; +begin + result := tthreaddata(findtree(@threaddata,inttostr(threadid))); + if result = nil then begin + result := tthreaddata.create; + result.messageevent := teventobject.create(nil,false,false,inttostr(taddrint(result))); + result.nexttimer := tv_invalidtimebig; + result.threadid := threadid; + addtree(@threaddata,inttostr(threadid),result); + end; +end; + +//deletethreaddataifunused should only be called while holding the structurelock +procedure deletethreaddataifunused(athreaddata : tthreaddata); +begin + //writeln('in deletethreaddataifunused'); + 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 + //writeln('threaddata is unused, freeing messageevent'); + athreaddata.messageevent.free; + //writeln('freeing thread data object'); + athreaddata.free; + //writeln('deleting thread data object from hashtable'); + deltree(@threaddata,inttostr(athreaddata.threadid)); + //writeln('finished deleting thread data'); + end else begin + //writeln('thread data is not unused'); + end; +end; + +function getwindowlongptr(ahwnd:hwnd;nindex:integer) : taddrint; +var + window : twindow; +begin + structurelock.acquire; + try + window := findtree(@windows,inttostr(ahwnd)); + if window <> nil then begin + result := paddrint(taddrint(window.extrawindowmemory)+nindex)^; + end else begin + result := 0; + end; + finally + structurelock.release; + end; +end; + +function setwindowlongptr(ahwnd:hwnd;nindex:integer;dwNewLong : taddrint) : taddrint; +var + window : twindow; +begin + structurelock.acquire; + try + window := findtree(@windows,inttostr(ahwnd)); + if window <> nil then begin + result := paddrint(taddrint(window.extrawindowmemory)+nindex)^; + paddrint(taddrint(window.extrawindowmemory)+nindex)^ := dwnewlong; + end else begin + result := 0; + end; + finally + structurelock.release; + end; + +end; + + +function DefWindowProc(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall; +begin + result := 0; +end; + +function strdup(s:pchar) : pchar; +begin + //swriteln('in strdup, about to allocate memory'); + result := getmem(strlen(s)+1); + //swriteln('about to copy string'); + strcopy(s,result); + //swriteln('leaving strdup'); +end; + +function RegisterClass(const lpWndClass:TWNDCLASS):ATOM; +var + storedwindowclass:pwndclass; +begin + structurelock.acquire; + try + //swriteln('in registerclass, about to check for duplicate window class'); + storedwindowclass := findtree(@windowclasses, lpwndclass.lpszclassname); + if storedwindowclass <> nil then begin + + if comparebyte(storedwindowclass^,lpwndclass,sizeof(twndclass)-sizeof(pchar)-sizeof(pchar)) <> 0 then begin + //swriteln('duplicate window class registered with different settings'); + raise exception.create('duplicate window class registered with different settings'); + end else begin + //swriteln('duplicate window class registered with same settings, tollerated'); + end; + end else begin + //swriteln('about to allocate memory for new windowclass'); + storedwindowclass := getmem(sizeof(twndclass)); + //swriteln('about to copy windowclass from parameter'); + move(lpwndclass,storedwindowclass^,sizeof(twndclass)); + //swriteln('about to copy strings'); + if lpwndclass.lpszmenuname <> nil then storedwindowclass.lpszmenuname := strdup(lpwndclass.lpszmenuname); + if lpwndclass.lpszclassname <> nil then storedwindowclass.lpszclassname := strdup(lpwndclass.lpszclassname); + //swriteln('about to add result to list of windowclasses'); + addtree(@windowclasses,lpwndclass.lpszclassname,storedwindowclass); + end; + //swriteln('about to return result'); + result := storedwindowclass; + //swriteln('leaving registerclass'); + finally + structurelock.release; + end; +end; + +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; +var + wndclass : pwndclass; + tm : tthreadmanager; + window : twindow; +begin + structurelock.acquire; + try + window := twindow.create; + window.hwnd := nextwindowhandle; + result := window.hwnd; + nextwindowhandle := nextwindowhandle + 1; + addtree(@windows,inttostr(window.hwnd),window); + wndclass := findtree(@windowclasses,lpclassname); + window.extrawindowmemory := getmem(wndclass.cbwndextra); + + getthreadmanager(tm); + window.threadid := tm.GetCurrentThreadId; + window.windowproc := wndclass.lpfnwndproc; + finally + structurelock.release; + end; +end; +function DestroyWindow(ahWnd:HWND):WINBOOL; +var + window : twindow; + windowthreaddata : tthreaddata; + currentmessage : tmessageintransit; + prevmessage : tmessageintransit; +begin + //writeln('started to destroy window'); + structurelock.acquire; + try + window := twindow(findtree(@windows,inttostr(ahwnd))); + if window <> nil then begin + freemem(window.extrawindowmemory); + //writeln('aboute to delete window from windows structure'); + deltree(@windows,inttostr(ahwnd)); + //writeln('deleted window from windows structure'); + windowthreaddata := tthreaddata(findtree(@threaddata,inttostr(window.threadid))); + + if windowthreaddata <> nil then begin + //writeln('found thread data scanning for messages to clean up'); + currentmessage := windowthreaddata.messagequeue; + prevmessage := nil; + while currentmessage <> nil do begin + while (currentmessage <> nil) and (currentmessage.msg.hwnd = ahwnd) do begin + if prevmessage = nil then begin + windowthreaddata.messagequeue := currentmessage.next; + end else begin + prevmessage.next := currentmessage.next; + end; + currentmessage.free; + if prevmessage = nil then begin + currentmessage := windowthreaddata.messagequeue; + end else begin + currentmessage := prevmessage.next; + end; + end; + if currentmessage <> nil then begin + prevmessage := currentmessage; + currentmessage := currentmessage.next; + end; + end; + //writeln('deleting thread data structure if it is unused'); + deletethreaddataifunused(windowthreaddata); + end else begin + //writeln('there is no thread data to search for messages to cleanup'); + end; + //writeln('freeing window'); + window.free; + result := true; + end else begin + result := false; + end; + finally + structurelock.release; + end; + //writeln('window destroyed'); +end; + + + +function PostMessage(hWnd:HWND; Msg:UINT; wParam:WPARAM; lParam:LPARAM):WINBOOL; +var + threaddata : tthreaddata; + message : tmessageintransit; + messagequeueend : tmessageintransit; + window : twindow; +begin + structurelock.acquire; + try + window := findtree(@windows,inttostr(hwnd)); + if window <> nil then begin + threaddata := findthreaddata(window.threadid); + message := tmessageintransit.create; + message.msg.hwnd := hwnd; + message.msg.message := msg; + message.msg.wparam := wparam; + message.msg.lparam := lparam; + if threaddata.lcorethread then begin + //swriteln('posting message to lcore thread'); + fdwrite(lcorelinkpipesend,message,sizeof(message)); + end else begin + //writeln('posting message to non lcore thread'); + if threaddata.messagequeue = nil then begin + threaddata.messagequeue := message; + end else begin + messagequeueend := threaddata.messagequeue; + while messagequeueend.next <> nil do begin + messagequeueend := messagequeueend.next; + end; + messagequeueend.next := message; + end; + + //writeln('message added to queue'); + if threaddata.waiting then threaddata.messageevent.setevent; + end; + result := true; + end else begin + result := false; + end; + finally + structurelock.release; + end; + +end; + +function gettickcount : dword; +var + result64: integer; + tv : ttimeval; +begin + gettimeofday(tv); + result64 := (tv.tv_sec*1000)+(tv.tv_usec div 1000); + result := result64; +end; + +function DispatchMessage(const lpMsg: TMsg): Longint; +var + timerproc : ttimerproc; + window : twindow; + windowproc : twndproc; +begin + ////swriteln('in dispatchmessage, msg.hwnd='+inttohex(taddrint(lpmsg.hwnd),16)); + if (lpmsg.lparam <> 0) and (lpmsg.message = WM_TIMER) then begin + timerproc := ttimerproc(lpmsg.lparam); + timerproc(lpmsg.hwnd,lpmsg.message,lpmsg.wparam,gettickcount); + result := 0; + end else begin + structurelock.acquire; + try + window := findtree(@windows,inttostr(lpmsg.hwnd)); + //we have to get the window procedure while the structurelock + //is still held as the window could be destroyed from another thread + //otherwise. + windowproc := window.windowproc; + finally + structurelock.release; + end; + if window <> nil then begin + result := windowproc(lpmsg.hwnd,lpmsg.message,lpmsg.wparam,lpmsg.lparam); + end else begin + result := -1; + end; + end; +end; + +procedure processtimers; +begin +end; + +function GetMessageinternal(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT; wremovemsg : UINT;peek:boolean): WINBOOL; +var + tm : tthreadmanager; + threaddata : tthreaddata; + message : tmessageintransit; + nowtv : ttimeval; + timeouttv : ttimeval; + timeoutms : int64; + +begin + if hwnd <> 0 then raise exception.create('getting messages for an individual window is not supported'); + if (wmsgfiltermin <> 0) or (wmsgfiltermax <> 0) then raise exception.create('message filtering is not supported'); + structurelock.acquire; + result := true; + try + getthreadmanager(tm); + threaddata := findthreaddata(tm.GetCurrentThreadId); + if threaddata.lcorethread then raise exception.create('get/peek message cannot be used in the lcore thread'); + message := threaddata.messagequeue; + gettimeofday(nowtv); + while (not peek) and (message=nil) and (not tv_compare(nowtv,threaddata.nexttimer)) do begin + threaddata.waiting := true; + structurelock.release; + if (threaddata.nexttimer.tv_sec = TV_invalidtimebig.tv_sec) and (threaddata.nexttimer.tv_usec = TV_invalidtimebig.tv_usec) then begin + threaddata.messageevent.waitfor(INFINITE); + end else begin + + timeouttv := threaddata.nexttimer; + timeoutms := (timeouttv.tv_sec * 1000)+(timeouttv.tv_usec div 1000); + //i'm assuming the timeout is in milliseconds + if (timeoutms > maxlongint) then timeoutms := maxlongint; + threaddata.messageevent.waitfor(timeoutms); + + end; + structurelock.acquire; + threaddata.waiting := false; + message := threaddata.messagequeue; + gettimeofday(nowtv); + end; + if (message=nil) and tv_compare(nowtv,threaddata.nexttimer) then begin + processtimers; + end; + message := threaddata.messagequeue; + if message <> nil then begin + lpmsg := message.msg; + if wremovemsg=PM_REMOVE then begin + threaddata.messagequeue := message.next; + message.free; + end; + end else begin + result :=false; + end; + deletethreaddataifunused(threaddata); + finally + structurelock.release; + end; +end; + +function GetMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT): WINBOOL; +begin + result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,PM_REMOVE,false); +end; + +function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): WINBOOL; +begin + result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,PM_REMOVE,true); +end; + +function SetEvent(hEvent:THevent):WINBOOL; +begin + hevent.setevent; + result := true; +end; + +function CreateEvent(lpEventAttributes:PSECURITYATTRIBUTES; bManualReset:WINBOOL; bInitialState:WINBOOL; lpName:pchar):tHevent; +begin + result := teventobject.create(lpeventattributes,bmanualreset,binitialstate,lpname); +end; + +function terminatethread(threadhandle:tthreadid;dummy : integer) : boolean; +var + tm : tthreadmanager; +begin + getthreadmanager(tm); + tm.killthread(threadhandle); + result := true; +end; + +function waitforsingleevent(event:thevent;timeout:cardinal) : twaitresult; +begin + result := event.waitfor(timeout); +end; + +procedure removefrombuffer(n : integer; var buffer:string); +begin + if n=length(buffer) then begin + buffer := ''; + end else begin + uniquestring(buffer); + move(buffer[n+1],buffer[1],length(buffer)-n); + setlength(buffer,length(buffer)-n); + end; +end; + +type + tsc=class + procedure available(sender:tobject;error:word); + end; + +var + recvbuf : string; + +procedure tsc.available(sender:tobject;error:word); +var + message : tmessageintransit; + messagebytes : array[1..sizeof(tmessageintransit)] of char absolute message; + i : integer; +begin + //swriteln('received data on lcorelinkpipe'); + recvbuf := recvbuf + lcorelinkpiperecv.receivestr; + while length(recvbuf) >= sizeof(tmessageintransit) do begin + for i := 1 to sizeof(tmessageintransit) do begin + messagebytes[i] := recvbuf[i]; + end; + dispatchmessage(message.msg); + message.free; + removefrombuffer(sizeof(tmessageintransit),recvbuf); + end; +end; + +procedure init; +var + tm : tthreadmanager; + threaddata : tthreaddata; + pipeends : tfildes; + sc : tsc; +begin + structurelock := tcriticalsection.create; + getthreadmanager(tm); + threaddata := findthreaddata(tm.GetCurrentThreadId); + threaddata.lcorethread := true; + fppipe(pipeends); + lcorelinkpipesend := pipeends[1]; + lcorelinkpiperecv := tlasio.create(nil); + lcorelinkpiperecv.dup(pipeends[0]); + lcorelinkpiperecv.ondataavailable := sc.available; + recvbuf := ''; +end; + +var + lcorethreadtimers : thashtable; +type + tltimerformsg = class(tltimer) + public + hwnd : hwnd; + id : taddrint; + procedure timer(sender : tobject); + end; + +procedure tltimerformsg.timer(sender : tobject); +var + msg : tmsg; +begin + ////swriteln('in tltimerformsg.timer'); + fillchar(msg,sizeof(msg),0); + msg.message := WM_TIMER; + msg.hwnd := hwnd; + msg.wparam := ID; + msg.lparam := 0; + dispatchmessage(msg); +end; + +function SetTimer(ahWnd:HWND; nIDEvent:taddrint; uElapse:UINT; lpTimerFunc:tTIMERPROC):UINT; +var + threaddata : tthreaddata; + ltimer : tltimerformsg; + tm : tthreadmanager; + window : twindow; +begin + structurelock.acquire; + try + window := findtree(@windows,inttostr(ahwnd)); + if window= nil then raise exception.create('invalid window'); + threaddata := findthreaddata(window.threadid); + finally + structurelock.release; + end; + if threaddata.lcorethread then begin + getthreadmanager(tm); + if tm.GetCurrentThreadId <> window.threadid then raise exception.create('timers on the lcore thread may only be added and removed from the lcore thread'); + if ahwnd = 0 then raise exception.create('timers on the lcore thread must be associated with a window handle'); + if @lptimerfunc <> nil then raise exception.create('seperate timer functions are not supported'); + + //remove preexisting timer with same ID + killtimer(ahwnd,nIDEvent); + + ltimer := tltimerformsg.create(nil); + ltimer.interval := uelapse; + ltimer.id := nidevent; + ltimer.hwnd := ahwnd; + ltimer.enabled := true; + ltimer.ontimer := ltimer.timer; + + addtree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(nIDEvent),ltimer); + + result := nidevent; + end else begin + raise exception.create('settimer not implemented for threads other than the lcore thread'); + end; +end; + +function KillTimer(ahWnd:HWND; uIDEvent:taddrint):WINBOOL; +var + threaddata : tthreaddata; + ltimer : tltimerformsg; + tm : tthreadmanager; + window : twindow; +begin + structurelock.acquire; + try + window := findtree(@windows,inttostr(ahwnd)); + if window= nil then raise exception.create('invalid window'); + threaddata := findthreaddata(window.threadid); + finally + structurelock.release; + end; + if threaddata.lcorethread then begin + getthreadmanager(tm); + if tm.GetCurrentThreadId <> window.threadid then raise exception.create('timers on the lcore thread may only be added and remove from the lcore thread'); + if ahwnd = 0 then raise exception.create('timers on the lcore thread must be associated with a window handle'); + ltimer := tltimerformsg(findtree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(uIDEvent))); + if ltimer <> nil then begin + deltree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(uIDEvent)); + ltimer.free; + result := true; + end else begin + result := false; + end; + end else begin + raise exception.create('settimer not implemented for threads other than the lcore thread'); + end; +end; + +end. \ No newline at end of file diff --git a/lsignal.pas b/lsignal.pas new file mode 100755 index 0000000..49e51b2 --- /dev/null +++ b/lsignal.pas @@ -0,0 +1,201 @@ +{lsocket.pas} + +{signal code by plugwash} + +{ 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 + ----------------------------------------------------------------------------- } + +unit lsignal; +{$mode delphi} +interface + uses sysutils, + {$ifdef VER1_0} + linux, + {$else} + baseunix,unix,unixutil, + {$endif} + classes,lcore,lloopback; + + type + tsignalevent=procedure(sender:tobject;signal:integer) of object; + tlsignal=class(tcomponent) + public + onsignal : tsignalevent ; + prevsignal : tlsignal ; + nextsignal : tlsignal ; + + constructor create(aowner:tcomponent);override; + destructor destroy;override; + end; + + + procedure starthandlesignal(signal:integer); + +var + firstsignal : tlsignal; + blockset : sigset; + signalloopback : tlloopback ; + +implementation +{$include unixstuff.inc} + +constructor tlsignal.create; +begin + inherited create(AOwner); + nextsignal := firstsignal; + prevsignal := nil; + + if assigned(nextsignal) then nextsignal.prevsignal := self; + firstsignal := self; + + //interval := 1000; + //enabled := true; + //released := false; +end; + +destructor tlsignal.destroy; +begin + if prevsignal <> nil then begin + prevsignal.nextsignal := nextsignal; + end else begin + firstsignal := nextsignal; + end; + if nextsignal <> nil then begin + nextsignal.prevsignal := prevsignal; + end; + inherited destroy; +end; +{$ifdef linux} + {$ifdef ver1_9_8} + {$define needsignalworkaround} + {$endif} + {$ifdef ver2_0_0} + {$define needsignalworkaround} + {$endif} + {$ifdef ver2_0_2} + {$define needsignalworkaround} + {$endif} +{$endif} +{$ifdef needsignalworkaround} + //using the 1.9.6 version of this stuff because the 1.9.8 and 2.0.0 versions seem broken + type + TSysParam = Longint; + TSysResult = longint; + const + syscall_nr_sigaction = 67; + //function Do_SysCall(sysnr:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL0'; + //function Do_SysCall(sysnr,param1:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL1'; + //function Do_SysCall(sysnr,param1,param2:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL2'; + function Do_SysCall(sysnr,param1,param2,param3:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL3'; + //function Do_SysCall(sysnr,param1,param2,param3,param4:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL4'; + //function Do_SysCall(sysnr,param1,param2,param3,param4,param5:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL5'; + + function Fpsigaction(sig: cint; act : psigactionrec; oact : psigactionrec): cint;// [public, alias : 'FPC_SYSC_SIGACTION']; + { + Change action of process upon receipt of a signal. + Signum specifies the signal (all except SigKill and SigStop). + If Act is non-nil, it is used to specify the new action. + If OldAct is non-nil the previous action is saved there. + } + begin + //writeln('fucking'); + {$ifdef RTSIGACTION} + {$ifdef cpusparc} + { Sparc has an extra stub parameter } + Fpsigaction:=do_syscall(syscall_nr_rt_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact),TSysParam(PtrInt(@Fprt_sigreturn_stub)-8),TSysParam(8)); + {$else cpusparc} + Fpsigaction:=do_syscall(syscall_nr_rt_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact),TSysParam(8)); + {$endif cpusparc} + {$else RTSIGACTION} + //writeln('nice'); + Fpsigaction:=do_syscall(syscall_nr_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact)); + {$endif RTSIGACTION} + end; +{$endif} + +// cdecl procedures are not name mangled +// so USING something unlikely to cause colliesions in the global namespace +// is a good idea +procedure lsignal_handler( Sig : Integer);cdecl; +var + currentsignal : tlsignal; +begin +// writeln('in lsignal_hanler'); + currentsignal := firstsignal; + while assigned(currentsignal) do begin + if assigned(currentsignal.onsignal) then currentsignal.onsignal(currentsignal,sig); + currentsignal := currentsignal.nextsignal; + + end; +// writeln('about to send down signalloopback'); + if assigned(signalloopback) then begin + signalloopback.sendstr(' '); + end; +// writeln('left lsignal_hanler'); +end; + +{$ifdef freebsd} + +{$if (FPC_VERSION > 2) or ((FPC_VERSION = 2) and (FPC_RELEASE >= 2))} +procedure lsignal_handler2(signal:longint;info:PSigInfo;context:psigcontext); cdecl; +{$else} +procedure lsignal_handler2(signal:longint;var info:TSigInfo_t;var context:SigContextRec); cdecl; +{$endif} + +begin + lsignal_handler(signal); +end; +{$endif} + + +const + allbitsset=-1; + {$ifdef ver1_0} + saction : sigactionrec = (handler:(sh:lsignal_handler);sa_flags:0); + {$else} + {$ifdef darwin} + saction : sigactionrec = (sa_handler:tsigaction(lsignal_handler);sa_flags:0); + {$else} + {$ifdef freebsd} + //version number is FPC_VERSION.FPC_RELEASE.FPC_PATCH + {$if (FPC_VERSION>2) or ((FPC_VERSION=2) and (FPC_RELEASE>0)) or ((FPC_VERSION=2) and (fpc_release=0) and (fpc_patch>=2))} + saction : sigactionrec = (sa_handler:lsignal_handler2;sa_flags:0); + {$else} + saction : sigactionrec = (sa_handler:tsigaction(lsignal_handler);sa_flags:0); + {$endif} + + {$else} + {$ifdef ver1_9_2} + saction : sigactionrec = (handler:(sh:lsignal_handler);sa_flags:0); + {$else} + //version number is FPC_VERSION.FPC_RELEASE.FPC_PATCH + {$if (FPC_VERSION>2) or ((FPC_VERSION=2) and (FPC_RELEASE>0)) or ((FPC_VERSION=2) and (fpc_release=0) and (fpc_patch>=2))} + saction : sigactionrec = (sa_handler:{$ifndef ver1_9_6}{$ifndef ver1_9_4}{$ifndef ver1_0}SigActionHandler{$endif}{$endif}{$endif}(lsignal_handler);sa_flags:0;sa_restorer:nil); + {$else} + saction : sigactionrec = (sa_handler:{$ifndef ver1_9_6}{$ifndef ver1_9_4}{$ifndef ver1_0}SigActionHandler{$endif}{$endif}{$endif}(lsignal_handler)); + {$endif} + {$endif} + {$endif} + {$endif} + {$endif} +procedure starthandlesignal(signal:integer); +begin + if signal in ([0..31]-[sigkill,sigstop]) then begin + sigprocmask(SIG_BLOCK,@blockset,nil); + sigaction(signal,@saction,nil) + end else begin + raise exception.create('invalid signal number') + end; +end; + +initialization + fillchar(blockset,sizeof(blockset),0); + blockset[0] := $FFFFFFFF - (1 shl sigstop) - (1 shl sigkill) - (1 shl sigsegv); + {$ifdef ver1_0} + saction.sa_mask := blockset[0]; + {$else} + saction.sa_mask := blockset; + {$endif} +end. diff --git a/lsocket.pas b/lsocket.pas new file mode 100755 index 0000000..58f157d --- /dev/null +++ b/lsocket.pas @@ -0,0 +1,706 @@ +{lsocket.pas} + +{socket code by plugwash} + +{ 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 + ----------------------------------------------------------------------------- } +{ +changes by plugwash (20030728) +* created handlefdtrigger virtual method in tlasio (overridden in tlsocket) and moved a lot of code from messageloop into it +* changed tlasio to tlasio +* split fdhandle into fdhandlein and fdhandleout +* i now use fdsrmaster and fdswmaster instead of rebuilding the lists every loop +* split lsocket.pas into lsocket.pas and lcore.pas + + +changes by beware (20030903) +* added getxaddr, getxport (local addr, port, as string) +* added getpeername, remote addr+port as binary +* added htons and htonl functions (endian swap, same interface as windows API) + +beware (20030905) +* if connect failed (conn refused) set state to connected and call internalclose, to get closed handler (instead of fdclose) +* (lcore) if closing the fd's in internalcose, set fd's to -1 because closing an fd makes it invalid + +beware (20030927) +* fixed: on connect failed, tried to close fdhandle's which were already set to -1, added check + +beware (20031017) +* added getpeeraddr, getpeerport, remote addr+port as string +} + + +unit lsocket; +{$ifdef fpc} + {$mode delphi} +{$endif} +interface + uses + sysutils, + {$ifdef win32} + windows,winsock, + {$else} + + {$ifdef VER1_0} + linux, + {$else} + baseunix,unix,unixutil, + {$endif} + sockets, + {$endif} + classes,{pgdebugout,}pgtypes,lcore,fd_utils,binipstuff,dnssync; +type + sunB = packed record + s_b1, s_b2, s_b3, s_b4: byte; + end; + + SunW = packed record + s_w1, s_w2: word; + end; + + TInAddr = packed record + case integer of + 0: (S_un_b: SunB); + 1: (S_un_w: SunW); + 2: (S_addr: cardinal); + end; + {$ifdef ipv6} + {$ifdef ver1_0} + cuint16=word; + cuint32=dword; + sa_family_t=word; + + + TInetSockAddr6 = packed Record + sin6_family : sa_family_t; + sin6_port : cuint16; + sin6_flowinfo : cuint32; + sin6_addr : Tin6_addr; + sin6_scope_id : cuint32; + end; + {$endif} + {$endif} + TinetSockAddrv = packed record + case integer of + 0: (InAddr:TInetSockAddr); + {$ifdef ipv6} + 1: (InAddr6:TInetSockAddr6); + {$endif} + end; + Pinetsockaddrv = ^Tinetsockaddrv; + + + type + tsockaddrin=TInetSockAddr; + + type + TLsocket = class(tlasio) + public + //a: string; + + inAddr : TInetSockAddrV; +{ inAddrSize:integer;} + + //host : THostentry ; + + //mainthread : boolean ; //for debuggin only + addr:string; + port:string; + localaddr:string; + localport:string; + proto:string; + udp:boolean; + listenqueue:integer; + function getaddrsize:integer; + procedure connect; virtual; + procedure bindsocket; + procedure listen; + function accept : longint; + function sendto(dest:TInetSockAddr;destlen:integer;data:pointer;len:integer):integer; virtual; + function receivefrom(data:pointer;len:integer;var src:TInetSockAddr;var srclen:integer):integer; virtual; + //procedure internalclose(error:word);override; + procedure handlefdtrigger(readtrigger,writetrigger:boolean); override; + function send(data:pointer;len:integer):integer;override; + procedure sendstr(const str : string);override; + function Receive(Buf:Pointer;BufSize:integer):integer; override; + function getpeername(var addr:tsockaddrin;addrlen:integer):integer; virtual; + procedure getXaddrbin(var binip:tbinip); virtual; + procedure getpeeraddrbin(var binip:tbinip); virtual; + function getXaddr:string; virtual; + function getpeeraddr:string; virtual; + function getXport:string; virtual; + function getpeerport:string; virtual; + constructor Create(AOwner: TComponent); override; + {$ifdef win32} + procedure myfdclose(fd : integer); override; + function myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt; override; + function myfdread(fd: LongInt;var buf;size: LongInt):LongInt; override; + {$endif} + end; + tsocket=longint; // for compatibility with twsocket + + twsocket=tlsocket; {easy} + +function htons(w:word):word; +function htonl(i:integer):integer; +{!!!function longipdns(s:string):longint;} + +{$ifdef ipv6} +const + v4listendefault:boolean=false; +{$endif} + + +const + TCP_NODELAY=1; + IPPROTO_TCP=6; + +implementation +{$include unixstuff.inc} + +function longip(s:string):longint;{$ifdef fpc}inline;{$endif} +var + l:longint; + a,b:integer; + +function convertbyte(const s:string):integer;{$ifdef fpc}inline;{$endif} +begin + result := strtointdef(s,-1); + if result < 0 then exit; + if result > 255 then exit; + + {01 exception} + if (result <> 0) and (s[1] = '0') then begin + result := -1; + exit; + end; + + {+1 exception} + if not (s[1] in ['0'..'9']) then begin + result := -1; + exit + end; +end; + +begin + result := 0; + a := pos('.',s); + if a = 0 then exit; + b := convertbyte(copy(s,1,a-1));if (b < 0) then exit; + l := b shl 24; + s := copy(s,a+1,256); + a := pos('.',s); + if a = 0 then exit; + b := convertbyte(copy(s,1,a-1));if (b < 0) then exit; + l := l or b shl 16; + s := copy(s,a+1,256); + a := pos('.',s); + if a = 0 then exit; + b := convertbyte(copy(s,1,a-1));if (b < 0) then exit; + l := l or b shl 8; + s := copy(s,a+1,256); + b := convertbyte(copy(s,1,256));if (b < 0) then exit; + l := l or b; + result := l; +end; + +(*!!! +function longipdns(s:string):longint; +var + host : thostentry; +begin + if s = '0.0.0.0' then begin + result := 0; + end else begin + result := longip(s); + if result = 0 then begin + if gethostbyname(s,host) then begin; + result := htonl(Longint(Host.Addr)); + end; + //writeln(inttohex(longint(host.addr),8)) + end; + if result = 0 then begin + if resolvehostbyname(s,host) then begin; + result := htonl(Longint(Host.Addr)); + end; + //writeln(inttohex(longint(host.addr),8)) + end; + end; +end; +*) + + +function htons(w:word):word; +begin + {$ifndef ENDIAN_BIG} + result := ((w and $ff00) shr 8) or ((w and $ff) shl 8); + {$else} + result := w; + {$endif} +end; + +function htonl(i:integer):integer; +begin + {$ifndef ENDIAN_BIG} + result := (i shr 24) or (i shr 8 and $ff00) or (i shl 8 and $ff0000) or (i shl 24 and $ff000000); + {$else} + result := i; + {$endif} +end; + +function tlsocket.getaddrsize:integer; +begin + {$ifdef ipv6} + if inaddr.inaddr.family = AF_INET6 then result := sizeof(tinetsockaddr6) else + {$endif} + result := sizeof(tinetsockaddr); +end; + +function makeinaddrv(addr,port:string;var inaddr:tinetsockaddrv):integer; +var + biniptemp:tbinip; +begin + result := 0; + biniptemp := forwardlookup(addr,10); + fillchar(inaddr,sizeof(inaddr),0); + //writeln('converted address '+addr+' to binip '+ipbintostr(biniptemp)); + if biniptemp.family = AF_INET then begin + inAddr.InAddr.family:=AF_INET; + inAddr.InAddr.port:=htons(strtointdef(port,0)); + inAddr.InAddr.addr:=biniptemp.ip; + result := sizeof(tinetsockaddr); + end else + {$ifdef ipv6} + if biniptemp.family = AF_INET6 then begin + inAddr.InAddr6.sin6_family:=AF_INET6; + inAddr.InAddr6.sin6_port:=htons(strtointdef(port,0)); + inAddr.InAddr6.sin6_addr:=biniptemp.ip6; + result := sizeof(tinetsockaddr6); + end else + {$endif} + raise esocketexception.create('unable to resolve address: '+addr); +end; + +procedure tlsocket.connect; +var + a:integer; +begin + if state <> wsclosed then close; + //prevtime := 0; + makeinaddrv(addr,port,inaddr); + + udp := uppercase(proto) = 'UDP'; + if udp then a := SOCK_DGRAM else a := SOCK_STREAM; + a := Socket(inaddr.inaddr.family,a,0); + + //writeln(ord(inaddr.inaddr.family)); + if a = -1 then begin + lasterror := {$ifdef win32}getlasterror{$else}socketerror{$endif}; + raise esocketexception.create('unable to create socket'); + end; + try + dup(a); + bindsocket; + if udp then begin + {$ifndef win32} + SetSocketOptions(fdhandleout, SOL_SOCKET, SO_BROADCAST, 'TRUE', Length('TRUE')); + {$endif} + state := wsconnected; + if assigned(onsessionconnected) then onsessionconnected(self,0); + end else begin + state :=wsconnecting; + {$ifdef win32} + //writeln(inaddr.inaddr.port); + winsock.Connect(fdhandlein,winsock.psockaddr(@inADDR)^,getaddrsize); + {$else} + sockets.Connect(fdhandlein,inADDR,getaddrsize); + {$endif} + end; + eventcore.rmasterset(fdhandlein,false); + if udp then begin + eventcore.wmasterclr(fdhandleout); + end else begin + eventcore.wmasterset(fdhandleout); + end; + //sendq := ''; + except + on e: exception do begin + fdcleanup; + raise; //reraise the exception + end; + end; +end; + +procedure tlsocket.sendstr(const str : string); +begin + if udp then begin + send(@str[1],length(str)) + end else begin + inherited sendstr(str); + end; +end; + +function tlsocket.send(data:pointer;len:integer):integer; +begin + if udp then begin + //writeln('sending to '+inttohex(inaddr.inaddr.addr,8)); + result := sendto(inaddr.inaddr,getaddrsize,data,len) +; + //writeln('send result',result); + //writeln('errno',errno); + end else begin + result := inherited send(data,len); + end; +end; + + +function tlsocket.receive(Buf:Pointer;BufSize:integer):integer; +begin + if udp then begin + result := myfdread(self.fdhandlein,buf^,bufsize); + end else begin + result := inherited receive(buf,bufsize); + end; +end; + +procedure tlsocket.bindsocket; +var + a:integer; + inAddrtemp:TInetSockAddrV; + inAddrtempx:{$ifdef win32}winsock.TSockaddr{$else}TInetSockAddrV{$endif} absolute inaddrtemp; + inaddrtempsize:integer; +begin + try + if (localaddr <> '') or (localport <> '') then begin + if localaddr = '' then begin + {$ifdef ipv6} + if inaddr.inaddr.family = AF_INET6 then localaddr := '::' else + {$endif} + localaddr := '0.0.0.0'; + end; + //gethostbyname(localaddr,host); + + inaddrtempsize := makeinaddrv(localaddr,localport,inaddrtemp); + + If Bind(fdhandlein,inaddrtempx,inaddrtempsize)<> {$ifdef win32}0{$else}true{$endif} Then begin + state := wsclosed; + lasterror := {$ifdef win32}getlasterror{$else}socketerror{$endif}; + raise ESocketException.create('unable to bind, error '+inttostr(lasterror)); + end; + state := wsbound; + end; + except + on e: exception do begin + fdcleanup; + raise; //reraise the exception + end; + end; +end; + +procedure tlsocket.listen; +var + yes:longint; + socktype:integer; + biniptemp:tbinip; + origaddr:string; +begin + if state <> wsclosed then close; + udp := uppercase(proto) = 'UDP'; + if udp then socktype := SOCK_DGRAM else socktype := SOCK_STREAM; + origaddr := addr; + + if addr = '' then begin + {$ifdef ipv6} + if not v4listendefault then begin + addr := '::'; + end else + {$endif} + addr := '0.0.0.0'; + end; + biniptemp := forwardlookup(addr,10); + addr := ipbintostr(biniptemp); + fdhandlein := socket(biniptemp.family,socktype,0); + {$ifdef ipv6} + if (addr = '::') and (origaddr = '') and (fdhandlein < 0) then begin + addr := '0.0.0.0'; + fdhandlein := socket(AF_INET,socktype,0); + end; + {$endif} + if fdhandlein = -1 then raise ESocketException.create('unable to create socket'); + dupnowatch(fdhandlein); // sets up maxs and copies handle to fdhandleout among other things + //eventcore.setfdreverse(fdhandlein,self); //already taken care of by dup + state := wsclosed; // then set this back as it was an undesired side effect of dup + + try + yes := $01010101; {Copied this from existing code. Value is empiric, + but works. (yes=true<>0) } + {$ifndef win32} + if SetSocketOptions(fdhandlein, SOL_SOCKET, SO_REUSEADDR,yes,sizeof(yes))=-1 then begin + raise ESocketException.create('unable to set socket options'); + end; + {$endif} + localaddr := addr; + localport := port; + bindsocket; + + if not udp then begin + {!!! allow custom queue length? default 5} + if listenqueue = 0 then listenqueue := 5; + If {$ifdef win32}winsock{$else}sockets{$endif}.Listen(fdhandlein,listenqueue)<>{$ifdef win32}0{$else}true{$endif} Then raise esocketexception.create('unable to listen'); + state := wsListening; + end else begin + {$ifndef win32} + SetSocketOptions(fdhandleout, SOL_SOCKET, SO_BROADCAST, 'TRUE', Length('TRUE')); + {$endif} + state := wsconnected; + end; + finally + if state = wsclosed then begin + if fdhandlein >= 0 then begin + {one *can* get here without fd -beware} + eventcore.rmasterclr(fdhandlein); + myfdclose(fdhandlein); // we musnt leak file discriptors + eventcore.setfdreverse(fdhandlein,nil); + fdhandlein := -1; + end; + end else begin + eventcore.rmasterset(fdhandlein,true); + end; + if fdhandleout >= 0 then eventcore.wmasterclr(fdhandleout); + end; + //writeln('listened on addr '+addr+':'+port+' '+proto+' using socket number ',fdhandlein); +end; + +function tlsocket.accept : longint; +var + FromAddrSize : LongInt; // i don't realy know what to do with these at this + FromAddr : TInetSockAddrV; // at this point time will tell :) +begin + + FromAddrSize := Sizeof(FromAddr); + {$ifdef win32} + result := winsock.accept(fdhandlein,@fromaddr,@fromaddrsize); + {$else} + result := sockets.accept(fdhandlein,fromaddr,fromaddrsize); + {$endif} + //now we have accepted one request start monitoring for more again + eventcore.rmasterset(fdhandlein,true); + + if result = -1 then raise esocketexception.create('error '+inttostr({$ifdef win32}getlasterror{$else}socketerror{$endif})+' while accepting'); + if result > absoloutemaxs then begin + myfdclose(result); + result := -1; + raise esocketexception.create('file discriptor out of range'); + end; +end; + +function tlsocket.sendto(dest:TInetSockAddr;destlen:integer;data:pointer;len:integer):integer; +var + destx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddr{$endif} absolute dest; +begin + result := {$ifdef win32}winsock{$else}sockets{$endif}.sendto(self.fdhandleout,data^,len,0,destx,destlen); +end; + +function tlsocket.receivefrom(data:pointer;len:integer;var src:TInetSockAddr;var srclen:integer):integer; +var + srcx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddr{$endif} absolute src; +begin + result := {$ifdef win32}winsock{$else}sockets{$endif}.recvfrom(self.fdhandlein,data^,len,0,srcx,srclen); +end; + +procedure tlsocket.handlefdtrigger(readtrigger,writetrigger:boolean); +var + tempbuf:array[0..receivebufsize-1] of byte; +begin + //writeln('got a fd trigger, readtrigger=',readtrigger,' writetrigger=',writetrigger); + if (state =wslistening) and readtrigger then begin +{ debugout('listening socket triggered on read');} + eventcore.rmasterclr(fdhandlein); + if assigned(onsessionAvailable) then onsessionAvailable(self,0); + end; + if udp and readtrigger then begin + if assigned(ondataAvailable) then ondataAvailable(self,0); + {!!!test} + exit; + end; + if (state =wsconnecting) and writetrigger then begin + // code for dealing with the reults of a non-blocking connect is + // rather complex + // if just write is triggered it means connect suceeded + // if both read and write are triggered it can mean 2 things + // 1: connect ok and data availible + // 2: connect fail + // to find out which you must read from the socket and look for errors + // there if we read successfully we drop through into the code for fireing + // the read event + if not readtrigger then begin + state := wsconnected; + if assigned(onsessionconnected) then onsessionconnected(self,0); + end else begin + numread := myfdread(fdhandlein,tempbuf,sizeof(tempbuf)); + if numread <> -1 then begin + state := wsconnected; + if assigned(onsessionconnected) then onsessionconnected(self,0); + //connectread := true; + recvq.add(@tempbuf,numread); + end else begin + state := wsconnected; + if assigned(onsessionconnected) then onsessionconnected(self,{$ifdef win32}wsagetlasterror{$else}linuxerror{$endif}); +{ debugout('connect fail');} + self.internalclose(0); + recvq.del(maxlongint); + end; + // if things went well here we are now in the state wsconnected with data sitting in our receive buffer + // so we drop down into the processing for data availible + end; + if fdhandlein >= 0 then begin + if state = wsconnected then begin + eventcore.rmasterset(fdhandlein,false); + end else begin + eventcore.rmasterclr(fdhandlein); + end; + end; + if fdhandleout >= 0 then begin + if sendq.size = 0 then begin + //don't clear the bit in fdswmaster if data is in the sendq + eventcore.wmasterclr(fdhandleout); + end; + end; + + end; + inherited handlefdtrigger(readtrigger,writetrigger); +end; + +constructor tlsocket.Create(AOwner: TComponent); +begin + inherited create(aowner); + closehandles := true; +end; + + +function tlsocket.getpeername(var addr:tsockaddrin;addrlen:integer):integer; +var + addrx : {$ifdef win32}winsock.tsockaddr{$else}tsockaddrin{$endif} absolute addr; +begin + result := {$ifdef win32}winsock{$else}sockets{$endif}.getpeername(self.fdhandlein,addrx,addrlen); +end; + +procedure tlsocket.getxaddrbin(var binip:tbinip); +var + addr:tinetsockaddrv; + i:integer; +begin + i := sizeof(addr); + fillchar(addr,sizeof(addr),0); + + {$ifdef win32} + winsock.getsockname(self.fdhandlein,psockaddr(@addr)^,i); + {$else} + sockets.getsocketname(self.fdhandlein,addr,i); + {$endif} + binip.family := addr.inaddr.family; + {$ifdef ipv6} + if addr.inaddr6.sin6_family = AF_INET6 then begin + binip.ip6 := addr.inaddr6.sin6_addr; + end else + {$endif} + begin + binip.ip := addr.inaddr.addr; + end; + converttov4(binip); +end; + +procedure tlsocket.getpeeraddrbin(var binip:tbinip); +var + addr:tinetsockaddrv; + i:integer; +begin + i := sizeof(addr); + fillchar(addr,sizeof(addr),0); + {$ifdef win32} + winsock.getpeername(self.fdhandlein,psockaddr(@addr)^,i); + {$else} + sockets.getpeername(self.fdhandlein,addr,i); + {$endif} + + binip.family := addr.inaddr.family; + {$ifdef ipv6} + if addr.inaddr6.sin6_family = AF_INET6 then begin + binip.ip6 := addr.inaddr6.sin6_addr; + end else + {$endif} + begin + binip.ip := addr.inaddr.addr; + end; + converttov4(binip); +end; + +function tlsocket.getXaddr:string; +var + biniptemp:tbinip; +begin + getxaddrbin(biniptemp); + result := ipbintostr(biniptemp); + if result = '' then result := 'error'; +end; + +function tlsocket.getpeeraddr:string; +var + biniptemp:tbinip; +begin + getpeeraddrbin(biniptemp); + result := ipbintostr(biniptemp); + if result = '' then result := 'error'; +end; + +function tlsocket.getXport:string; +var + addr:tinetsockaddrv; + i:integer; +begin + i := sizeof(addr); + {$ifdef win32} + winsock.getsockname(self.fdhandlein,psockaddrin(@addr)^,i); + + {$else} + sockets.getsocketname(self.fdhandlein,addr,i); + + {$endif} + result := inttostr(htons(addr.InAddr.port)); +end; + +function tlsocket.getpeerport:string; +var + addr:tinetsockaddrv; + i:integer; +begin + i := sizeof(addr); + {$ifdef win32} + winsock.getpeername(self.fdhandlein,psockaddrin(@addr)^,i); + + {$else} + sockets.getpeername(self.fdhandlein,addr,i); + + {$endif} + result := inttostr(htons(addr.InAddr.port)); +end; + +{$ifdef win32} + procedure tlsocket.myfdclose(fd : integer); + begin + closesocket(fd); + end; + function tlsocket.myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt; + begin + result := winsock.send(fd,(@buf)^,size,0); + end; + function tlsocket.myfdread(fd: LongInt;var buf;size: LongInt):LongInt; + begin + result := winsock.recv(fd,buf,size,0); + end; +{$endif} + +end. + diff --git a/ltimevalstuff.inc b/ltimevalstuff.inc new file mode 100755 index 0000000..0ac92cb --- /dev/null +++ b/ltimevalstuff.inc @@ -0,0 +1,42 @@ +{ 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 + ----------------------------------------------------------------------------- } + + + +{add nn msec to tv} +const + tv_invalidtimebig : ttimeval = (tv_sec:maxlongint;tv_usec:maxlongint); + //tv_invalidtimebig will always compare as greater than any valid timeval +procedure tv_add(var tv:ttimeval;msec:integer);//{ $ifdef fpc}inline;{ $endif} +begin + inc(tv.tv_usec,msec*1000); + inc(tv.tv_sec,tv.tv_usec div 1000000); + tv.tv_usec := tv.tv_usec mod 1000000; +end; + +{tv1 >= tv2} +function tv_compare(const tv1,tv2:ttimeval):boolean;//{ $ifdef fpc}inline;{ $endif} +begin + if tv1.tv_sec = tv2.tv_sec then begin + result := tv1.tv_usec >= tv2.tv_usec; + end else result := tv1.tv_sec > tv2.tv_sec; +end; + +procedure tv_substract(var tv:ttimeval;const tv2:ttimeval);//{ $ifdef fpc}inline;{ $endif} +begin + dec(tv.tv_usec,tv2.tv_usec); + if tv.tv_usec < 0 then begin + inc(tv.tv_usec,1000000); + dec(tv.tv_sec) + end; + dec(tv.tv_sec,tv2.tv_sec); +end; + +procedure msectotimeval(var tv:ttimeval;msec:integer); +begin + tv.tv_sec := msec div 1000; + tv.tv_usec := (msec mod 1000)*1000; +end; + diff --git a/pgtypes.pas b/pgtypes.pas new file mode 100755 index 0000000..3c48e26 --- /dev/null +++ b/pgtypes.pas @@ -0,0 +1,20 @@ +{io core originally for linux bworld} + +{ 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 + ----------------------------------------------------------------------------- } + +unit pgtypes; +interface + type + {$ifdef cpu386}{$define i386}{$endif} + {$ifdef i386} + taddrint=longint; + {$else} + taddrint=sizeint; + {$endif} + paddrint=^taddrint; + +implementation +end. diff --git a/svn-commit.2.tmp b/svn-commit.2.tmp new file mode 100755 index 0000000..82b4cd3 --- /dev/null +++ b/svn-commit.2.tmp @@ -0,0 +1,4 @@ +initial import +--This line, and those below, will be ignored-- + +A . diff --git a/svn-commit.3.tmp b/svn-commit.3.tmp new file mode 100755 index 0000000..82b4cd3 --- /dev/null +++ b/svn-commit.3.tmp @@ -0,0 +1,4 @@ +initial import +--This line, and those below, will be ignored-- + +A . diff --git a/svn-commit.4.tmp b/svn-commit.4.tmp new file mode 100755 index 0000000..6588c17 --- /dev/null +++ b/svn-commit.4.tmp @@ -0,0 +1,4 @@ +create directory +--This line, and those below, will be ignored-- + +A svn+ssh://p10link/svnroot/lcore/trunk diff --git a/svn-commit.5.tmp b/svn-commit.5.tmp new file mode 100755 index 0000000..82b4cd3 --- /dev/null +++ b/svn-commit.5.tmp @@ -0,0 +1,4 @@ +initial import +--This line, and those below, will be ignored-- + +A . diff --git a/svn-commit.tmp b/svn-commit.tmp new file mode 100755 index 0000000..82b4cd3 --- /dev/null +++ b/svn-commit.tmp @@ -0,0 +1,4 @@ +initial import +--This line, and those below, will be ignored-- + +A . diff --git a/uint32.inc b/uint32.inc new file mode 100755 index 0000000..897db79 --- /dev/null +++ b/uint32.inc @@ -0,0 +1,14 @@ +{ 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 + ----------------------------------------------------------------------------- } +type + {delphi 3 and before do not have a 32 bits unsigned integer type, + but longint has the correct behavior - it doesn't on newer delphi versions} + {$ifndef fpc} + {$ifdef ver70}{$define pred4}{$endif} {tp7} + {$ifdef ver80}{$define pred4}{$endif} {delphi 1} + {$ifdef ver90}{$define pred4}{$endif} {delphi 2} + {$ifdef ver100}{$define pred4}{$endif} {delphi 3} + {$endif} + uint32={$ifdef pred4}longint{$else}longword{$endif}; diff --git a/unixstuff.inc b/unixstuff.inc new file mode 100755 index 0000000..76a7f52 --- /dev/null +++ b/unixstuff.inc @@ -0,0 +1,76 @@ +{$ifdef UNIX} + {$macro on} + {$ifdef VER1_0} + {$define tv_sec := sec} + {$define tv_usec := usec} + function dup(const original:integer):integer;inline; + begin + linux.dup(original,result); + end; + {$define gettimeofdaysec := gettimeofday} + {$else} + + {$define sigprocmask := fpsigprocmask} + {$define sigaction := fpsigaction} + {$define fdclose := fpclose} + {$define fcntl := fpfcntl} + {$define fdwrite := fpwrite} + {$define fdread := fpread} + {$define fdopen := fpopen} + {$define select := fpselect} + {$define linuxerror := fpgeterrno} + {$define fork := fpfork} + {$define getpid := fpgetpid} + {$define getenv := fpgetenv} + {$define chmod := fpchmod} + {$define dup2 := fpdup2} + {$ifndef ver1_9_2} + {$define flock := fpflock} + {$ifndef ver1_9_4} + procedure Execl(Todo:string);inline; + var + p : ppchar; + begin + p := unixutil.StringToPPChar(Todo,1); + if (p=nil) or (p^=nil) then exit; + fpexecv(p^,p); + end; + {$endif} + {$endif} + procedure gettimeofday(var tv:ttimeval);inline; + begin + fpgettimeofday(@tv,nil); + end; + function gettimeofdaysec : longint; + var + tv:ttimeval; + begin + gettimeofday(tv); + result := tv.tv_sec; + end; + + //a function is used here rather than a define to prevent issues with tlasio.dup + function dup(const original:integer):integer;inline; + begin + result := fpdup(original); + end; + function octal(invalue:longint):longint; + var + a : integer; + i : integer; + begin + i := 0; + result := 0; + while invalue <> 0 do begin + a := invalue mod 10; + result := result + (a shl (i*3)); + + invalue := invalue div 10; + inc(i); + end; + end; + const + sys_eintr=esyseintr; + + {$endif} +{$endif} diff --git a/wcore.pas b/wcore.pas new file mode 100755 index 0000000..40505ef --- /dev/null +++ b/wcore.pas @@ -0,0 +1,372 @@ +{ 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 + ----------------------------------------------------------------------------- } + +unit wcore; + +{ +lcore compatible interface for windows + +- messageloop + +- tltimer + +} +//note: events after release are normal and are the apps responsibility to deal with safely +interface + + uses + classes,windows,mmsystem; + + type + float=double; + + tlcomponent = class(tcomponent) + public + released:boolean; + procedure release; + destructor destroy; override; + end; + + tltimer=class(tlcomponent) + public + ontimer:tnotifyevent; + initialevent:boolean; + initialdone:boolean; + prevtimer:tltimer; + nexttimer:tltimer; + interval:integer; {miliseconds, default 1000} + enabled:boolean; + nextts:integer; + constructor create(aowner:tcomponent);override; + destructor destroy;override; + end; + + ttaskevent=procedure(wparam,lparam:longint) of object; + + tltask=class(tobject) + public + handler : ttaskevent; + obj : tobject; + wparam : longint; + lparam : longint; + nexttask : tltask; + constructor create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint); + end; + +procedure messageloop; +procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint); +procedure disconnecttasks(aobj:tobject); +procedure exitmessageloop; +procedure processmessages; + +var + onshutdown:procedure(s:string); + +implementation + +uses + {$ifdef fpc} + bmessages; + {$else} + messages; + {$endif} + + +const + WINMSG_TASK=WM_USER; + +var + hwndwcore:hwnd; + firsttimer:tltimer; + timesubstract:integer; + firsttask,lasttask,currenttask:tltask; + +procedure tlcomponent.release; +begin + released := true; +end; + +destructor tlcomponent.destroy; +begin + disconnecttasks(self); + inherited destroy; +end; + +{------------------------------------------------------------------------------} + +constructor tltimer.create; +begin + inherited create(AOwner); + nexttimer := firsttimer; + prevtimer := nil; + + if assigned(nexttimer) then nexttimer.prevtimer := self; + firsttimer := self; + + interval := 1000; + enabled := true; + released := false; +end; + +destructor tltimer.destroy; +begin + if prevtimer <> nil then begin + prevtimer.nexttimer := nexttimer; + end else begin + firsttimer := nexttimer; + end; + if nexttimer <> nil then begin + nexttimer.prevtimer := prevtimer; + end; + inherited destroy; +end; + +{------------------------------------------------------------------------------} + +function wcore_timehandler:integer; +const + rollover_bits=30; +var + tv,tvnow:integer; + currenttimer,temptimer:tltimer; +begin + if not assigned(firsttimer) then begin + result := 1000; + exit; + end; + + tvnow := timegettime; + if (tvnow and ((-1) shl rollover_bits)) <> timesubstract then begin + currenttimer := firsttimer; + while assigned(currenttimer) do begin + dec(currenttimer.nextts,(1 shl rollover_bits)); + currenttimer := currenttimer.nexttimer; + end; + timesubstract := tvnow and ((-1) shl rollover_bits); + end; + tvnow := tvnow and ((1 shl rollover_bits)-1); + + currenttimer := firsttimer; + while assigned(currenttimer) do begin + if tvnow >= currenttimer.nextts then begin + if assigned(currenttimer.ontimer) then begin + if currenttimer.enabled then begin + if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer); + currenttimer.initialdone := true; + end; + end; + currenttimer.nextts := tvnow+currenttimer.interval; + end; + temptimer := currenttimer; + currenttimer := currenttimer.nexttimer; + if temptimer.released then temptimer.free; + end; + + tv := maxlongint; + currenttimer := firsttimer; + while assigned(currenttimer) do begin + if currenttimer.nextts < tv then tv := currenttimer.nextts; + currenttimer := currenttimer.nexttimer; + end; + result := tv-tvnow; + if result < 15 then result := 15; +end; + +{------------------------------------------------------------------------------} + +constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint); +begin + inherited create; + handler := ahandler; + obj := aobj; + wparam := awparam; + lparam := alparam; + {nexttask := firsttask; + firsttask := self;} + if assigned(lasttask) then begin + lasttask.nexttask := self; + end else begin + firsttask := self; + postmessage(hwndwcore,WINMSG_TASK,0,0); + end; + lasttask := self; + //ahandler(wparam,lparam); +end; + +procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint); +begin + tltask.create(ahandler,aobj,awparam,alparam); +end; + +procedure disconnecttasks(aobj:tobject); +var + currenttasklocal : tltask ; + counter : byte ; +begin + for counter := 0 to 1 do begin + if counter = 0 then begin + currenttasklocal := firsttask; //main list of tasks + end else begin + currenttasklocal := currenttask; //needed in case called from a task + end; + // note i don't bother to sestroy the links here as that will happen when + // the list of tasks is processed anyway + while assigned(currenttasklocal) do begin + if currenttasklocal.obj = aobj then begin + currenttasklocal.obj := nil; + currenttasklocal.handler := nil; + end; + currenttasklocal := currenttasklocal.nexttask; + end; + end; +end; + +procedure dotasks; +var + temptask:tltask; +begin + if firsttask = nil then exit; + + currenttask := firsttask; + firsttask := nil; + lasttask := nil; + while assigned(currenttask) do begin + if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam); + temptask := currenttask; + currenttask := currenttask.nexttask; + temptask.free; + end; + currenttask := nil; +end; + +{------------------------------------------------------------------------------} + +procedure exitmessageloop; +begin + postmessage(hwndwcore,WM_QUIT,0,0); +end; + + {$ifdef threadtimer} + 'thread timer' + {$else} +const timerid_wcore=$1000; + {$endif} + +function MyWindowProc( + ahWnd : HWND; + auMsg : Integer; + awParam : WPARAM; + alParam : LPARAM): Integer; stdcall; +var + MsgRec : TMessage; + a:integer; +begin + Result := 0; // This means we handled the message + + {MsgRec.hwnd := ahWnd;} + MsgRec.wParam := awParam; + MsgRec.lParam := alParam; + + dotasks; + case auMsg of + {$ifndef threadtimer} + WM_TIMER: begin + if msgrec.wparam = timerid_wcore then begin + a := wcore_timehandler; + killtimer(hwndwcore,timerid_wcore); + settimer(hwndwcore,timerid_wcore,a,nil); + end; + end; + {$endif} + + {WINMSG_TASK:dotasks;} + + WM_CLOSE: begin + {} + end; + WM_DESTROY: begin + {} + end; + else + Result := DefWindowProc(ahWnd, auMsg, awParam, alParam) + end; +end; + + +var + MyWindowClass : TWndClass = (style : 0; + lpfnWndProc : @MyWindowProc; + cbClsExtra : 0; + cbWndExtra : 0; + hInstance : 0; + hIcon : 0; + hCursor : 0; + hbrBackground : 0; + lpszMenuName : nil; + lpszClassName : 'wcoreClass'); + +procedure messageloop; +var + MsgRec : TMsg; +begin + + if Windows.RegisterClass(MyWindowClass) = 0 then halt; + //writeln('about to create wcore handle, hinstance=',hinstance); + hwndwcore := CreateWindowEx(WS_EX_TOOLWINDOW, + MyWindowClass.lpszClassName, + '', { Window name } + WS_POPUP, { Window Style } + 0, 0, { X, Y } + 0, 0, { Width, Height } + 0, { hWndParent } + 0, { hMenu } + HInstance, { hInstance } + nil); { CreateParam } + + if hwndwcore = 0 then halt; + + {$ifdef threadtimer} + 'thread timer' + {$else} + if settimer(hwndwcore,timerid_wcore,15,nil) = 0 then halt; + {$endif} + + + while GetMessage(MsgRec, 0, 0, 0) do begin + TranslateMessage(MsgRec); + DispatchMessage(MsgRec); + {if not peekmessage(msgrec,0,0,0,PM_NOREMOVE) then onidle} + end; + + if hWndwcore <> 0 then begin + DestroyWindow(hwndwcore); + hWndwcore := 0; + end; + + {$ifdef threadtimer} + 'thread timer' + {$else} + killtimer(hwndwcore,timerid_wcore); + {$endif} +end; + +function ProcessMessage : Boolean; +var + Msg : TMsg; +begin + Result := FALSE; + if PeekMessage(Msg, hwndwcore, 0, 0, PM_REMOVE) then begin + Result := TRUE; + DispatchMessage(Msg); + end; +end; + +procedure processmessages; +begin + while processmessage do; +end; + + +end. -- 2.30.2