From: plugwash Date: Sun, 30 Mar 2008 00:24:32 +0000 (+0000) Subject: rm some cruft that got imported accidently X-Git-Url: http://www.lcore.org/git/lcore.git/commitdiff_plain/42a61c59a81b03130f61e805474198eada033cd8 rm some cruft that got imported accidently git-svn-id: file:///svnroot/lcore/trunk@3 b1de8a11-f9be-4011-bde0-cc7ace90066a --- diff --git a/httpserver_20080306/bfifo.pas b/httpserver_20080306/bfifo.pas deleted file mode 100755 index 55cc24a..0000000 --- a/httpserver_20080306/bfifo.pas +++ /dev/null @@ -1,148 +0,0 @@ -{ 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 deleted file mode 100755 index ebb9f9c..0000000 --- a/httpserver_20080306/binipstuff.pas +++ /dev/null @@ -1,395 +0,0 @@ -{ 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 deleted file mode 100755 index 2079b75..0000000 --- a/httpserver_20080306/blinklist.pas +++ /dev/null @@ -1,118 +0,0 @@ -(* - * 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 deleted file mode 100755 index ad61751..0000000 --- a/httpserver_20080306/bsearchtree.pas +++ /dev/null @@ -1,101 +0,0 @@ -{ 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 deleted file mode 100755 index 127839e..0000000 --- a/httpserver_20080306/btime.pas +++ /dev/null @@ -1,362 +0,0 @@ -{ 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 deleted file mode 100755 index 682f95f..0000000 --- a/httpserver_20080306/dnsasync.pas +++ /dev/null @@ -1,241 +0,0 @@ -{ 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 deleted file mode 100755 index bb4fab4..0000000 --- a/httpserver_20080306/dnscore.pas +++ /dev/null @@ -1,728 +0,0 @@ -{ 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 deleted file mode 100755 index c64d320..0000000 --- a/httpserver_20080306/dnssync.pas +++ /dev/null @@ -1,262 +0,0 @@ -{ 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 deleted file mode 100755 index bae0780..0000000 --- a/httpserver_20080306/dnswin.pas +++ /dev/null @@ -1,332 +0,0 @@ -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 deleted file mode 100755 index 9ad93dd..0000000 --- a/httpserver_20080306/fd_utils.pas +++ /dev/null @@ -1,69 +0,0 @@ -// 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 deleted file mode 100755 index 51fbf78..0000000 --- a/httpserver_20080306/lcore.pas +++ /dev/null @@ -1,889 +0,0 @@ -{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 deleted file mode 100755 index bbf4418..0000000 --- a/httpserver_20080306/lcoregtklaz.pas +++ /dev/null @@ -1,142 +0,0 @@ -{ 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 deleted file mode 100755 index 0369448..0000000 --- a/httpserver_20080306/lcoreselect.pas +++ /dev/null @@ -1,391 +0,0 @@ -{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 deleted file mode 100755 index e9d1b0a..0000000 --- a/httpserver_20080306/lcoretest.dpr +++ /dev/null @@ -1,167 +0,0 @@ -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 deleted file mode 100755 index a978c23..0000000 --- a/httpserver_20080306/lcorewsaasyncselect.pas +++ /dev/null @@ -1,216 +0,0 @@ -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 deleted file mode 100755 index da26263..0000000 --- a/httpserver_20080306/lloopback.pas +++ /dev/null @@ -1,30 +0,0 @@ -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 deleted file mode 100755 index 7bb73fd..0000000 --- a/httpserver_20080306/lmessages.pas +++ /dev/null @@ -1,656 +0,0 @@ -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 deleted file mode 100755 index 573fe28..0000000 --- a/httpserver_20080306/lsignal.pas +++ /dev/null @@ -1,198 +0,0 @@ -{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 deleted file mode 100755 index 617f153..0000000 --- a/httpserver_20080306/lsocket.pas +++ /dev/null @@ -1,706 +0,0 @@ -{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 deleted file mode 100755 index 0ac92cb..0000000 --- a/httpserver_20080306/ltimevalstuff.inc +++ /dev/null @@ -1,42 +0,0 @@ -{ 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 deleted file mode 100755 index 3c48e26..0000000 --- a/httpserver_20080306/pgtypes.pas +++ /dev/null @@ -1,20 +0,0 @@ -{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 deleted file mode 100755 index 897db79..0000000 --- a/httpserver_20080306/uint32.inc +++ /dev/null @@ -1,14 +0,0 @@ -{ 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 deleted file mode 100755 index 92ed308..0000000 --- a/httpserver_20080306/unixstuff.inc +++ /dev/null @@ -1,66 +0,0 @@ -{$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 deleted file mode 100755 index 40505ef..0000000 --- a/httpserver_20080306/wcore.pas +++ /dev/null @@ -1,372 +0,0 @@ -{ 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/svn-commit.2.tmp b/svn-commit.2.tmp deleted file mode 100755 index 82b4cd3..0000000 --- a/svn-commit.2.tmp +++ /dev/null @@ -1,4 +0,0 @@ -initial import ---This line, and those below, will be ignored-- - -A . diff --git a/svn-commit.3.tmp b/svn-commit.3.tmp deleted file mode 100755 index 82b4cd3..0000000 --- a/svn-commit.3.tmp +++ /dev/null @@ -1,4 +0,0 @@ -initial import ---This line, and those below, will be ignored-- - -A . diff --git a/svn-commit.4.tmp b/svn-commit.4.tmp deleted file mode 100755 index 6588c17..0000000 --- a/svn-commit.4.tmp +++ /dev/null @@ -1,4 +0,0 @@ -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 deleted file mode 100755 index 82b4cd3..0000000 --- a/svn-commit.5.tmp +++ /dev/null @@ -1,4 +0,0 @@ -initial import ---This line, and those below, will be ignored-- - -A . diff --git a/svn-commit.tmp b/svn-commit.tmp deleted file mode 100755 index 82b4cd3..0000000 --- a/svn-commit.tmp +++ /dev/null @@ -1,4 +0,0 @@ -initial import ---This line, and those below, will be ignored-- - -A .