initial import

git-svn-id: file:///svnroot/lcore/trunk@1 b1de8a11-f9be-4011-bde0-cc7ace90066a

diff --git a/Makefile b/Makefile
new file mode 100755 (executable)
index 0000000..2926076
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,23 @@
+all: lcoretest
+
+lcoretest: *.pas *.inc lcoretest.dpr
+       fpc -Sd -dipv6 lcoretest.dpr
+       
+clean:
+       -rm *.o
+       -rm *.ppu
+       -rm *.exe
+       -rm *.dcu
+       -rm lcoretest
+
+date := $(shell date +%Y%m%d)
+
+zip:
+       mkdir -p lcorewin32_$(date)
+       cp -a *.pas lcorewin32_$(date)
+       cp -a *.inc lcorewin32_$(date)
+       cp -a *.dpr lcorewin32_$(date)
+       cp -a Makefile lcorewin32_$(date)
+       -rm ../lcorewin32_$(date).zip
+       zip -r ../lcorewin32_$(date).zip lcorewin32_$(date)
+       rm -rf lcorewin32_$(date)
\ No newline at end of file

diff --git a/bfifo.pas b/bfifo.pas
new file mode 100755 (executable)
index 0000000..55cc24a
--- /dev/null
+++ b/bfifo.pas
@@ -0,0 +1,148 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+unit bfifo;\r
+{$ifdef fpc}\r
+  {$mode delphi}\r
+{$endif}\r
+\r
+interface\r
+\r
+uses blinklist,pgtypes;\r
+\r
+const\r
+  pagesize=1420;\r
+\r
+type\r
+  tfifo=class(tobject)\r
+  private\r
+    l:tlinklist;     {add to}\r
+    getl:tlinklist; {remove from}\r
+    ofs:integer;\r
+    getofs:integer;\r
+  public\r
+    size:integer;\r
+    procedure add(data:pointer;len:integer);\r
+    function get(var resultptr:pointer;len:integer):integer;\r
+    procedure del(len:integer);\r
+    constructor create;\r
+    destructor destroy; override;\r
+  end;\r
+\r
+\r
+implementation\r
+\r
+var\r
+  testcount:integer;\r
+\r
+{\r
+\r
+xx1..... add\r
+xxxxxxxx\r
+....2xxx delete\r
+\r
+1 ofs\r
+2 getofs\r
+\r
+}\r
+\r
+procedure tfifo.add;\r
+var\r
+  a:integer;\r
+  p:tlinklist;\r
+begin\r
+  if len <= 0 then exit;\r
+  inc(size,len);\r
+  while len > 0 do begin\r
+    p := l;\r
+    if ofs = pagesize then begin\r
+      p := tplinklist.create;\r
+      if getl = nil then getl := p;\r
+      getmem(tplinklist(p).p,pagesize);\r
+      inc(testcount);\r
+      linklistadd(l,p);\r
+      ofs := 0;\r
+    end;\r
+    a := pagesize - ofs;\r
+    if len < a then a := len;\r
+    move(data^,pointer(taddrint(tplinklist(p).p)+ofs)^,a);\r
+    inc(taddrint(data),a);\r
+    dec(len,a);\r
+    inc(ofs,a);\r
+  end;\r
+end;\r
+\r
+function tfifo.get;\r
+var\r
+  p:tlinklist;\r
+  a:integer;\r
+begin\r
+  if len > size then len := size;\r
+  if len <= 0 then begin\r
+    result := 0;\r
+    resultptr := nil;\r
+    exit;\r
+  end;\r
+  p := getl;\r
+  resultptr := pointer(taddrint(tplinklist(p).p)+getofs);\r
+  result := pagesize-getofs;\r
+  if result > len then result := len;\r
+end;\r
+\r
+procedure tfifo.del;\r
+var\r
+  a:integer;\r
+  p,p2:tlinklist;\r
+begin\r
+  if len <= 0 then exit;\r
+  p := getl;\r
+  if len > size then len := size;\r
+  dec(size,len);\r
+\r
+  if len = 0 then exit;\r
+\r
+  while len > 0 do begin\r
+    a := pagesize-getofs;\r
+    if a > len then a := len;\r
+    inc(getofs,a);\r
+    dec(len,a);\r
+    if getofs = pagesize then begin\r
+      p2 := p.prev;\r
+      freemem(tplinklist(p).p);\r
+      dec(testcount);\r
+      linklistdel(l,p);\r
+      p.destroy;\r
+      p := p2;\r
+      getl := p;\r
+      getofs := 0;\r
+    end;\r
+  end;\r
+\r
+  if size = 0 then begin\r
+    if assigned(l) then begin\r
+      p := l;\r
+      freemem(tplinklist(p).p);\r
+      dec(testcount);\r
+      linklistdel(l,p);\r
+      p.destroy;\r
+      getl := nil;\r
+    end;\r
+    ofs := pagesize;\r
+    getofs := 0;\r
+  end;\r
+end;\r
+\r
+constructor tfifo.create;\r
+begin\r
+  ofs := pagesize;\r
+  inherited create;\r
+end;\r
+\r
+destructor tfifo.destroy;\r
+begin\r
+  del(size);\r
+  inherited destroy;\r
+end;\r
+\r
+end.\r

diff --git a/binipstuff.pas b/binipstuff.pas
new file mode 100755 (executable)
index 0000000..ebb9f9c
--- /dev/null
+++ b/binipstuff.pas
@@ -0,0 +1,395 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+unit binipstuff;\r
+\r
+interface\r
+\r
+{$ifndef win32}\r
+{$ifdef ipv6}\r
+uses sockets;\r
+{$endif}\r
+{$endif}\r
+\r
+{$ifdef fpc}\r
+  {$mode delphi}\r
+{$endif}\r
+{$ifdef cpu386}{$define i386}{$endif}\r
+{$ifdef i386}{$define ENDIAN_LITTLE}{$endif}\r
+\r
+{$include uint32.inc}\r
+\r
+const\r
+  hexchars:array[0..15] of char='0123456789abcdef';\r
+  AF_INET=2;\r
+  {$ifdef win32}\r
+    AF_INET6=23;\r
+  {$else}\r
+    AF_INET6=10;\r
+  {$endif}\r
+\r
+type\r
+  {$ifdef ipv6}\r
+    \r
+    {$ifdef win32}\r
+      {$define want_Tin6_addr}\r
+    {$endif}\r
+    {$ifdef ver1_0}\r
+      {$define want_Tin6_addr}\r
+    {$endif}\r
+    {$ifdef want_Tin6_addr}\r
+      Tin6_addr = packed record\r
+        case byte of\r
+          0: (u6_addr8  : array[0..15] of byte);\r
+          1: (u6_addr16 : array[0..7] of Word);\r
+          2: (u6_addr32 : array[0..3] of uint32);\r
+          3: (s6_addr8  : array[0..15] of shortint);\r
+          4: (s6_addr   : array[0..15] of shortint);\r
+          5: (s6_addr16 : array[0..7] of smallint);\r
+          6: (s6_addr32 : array[0..3] of LongInt);\r
+      end;\r
+    {$endif}\r
+  {$endif}\r
+\r
+  tbinip=record\r
+    family:integer;\r
+    {$ifdef ipv6}\r
+      case integer of\r
+        0: (ip:longint);\r
+        1: (ip6:tin6_addr);\r
+    {$else}\r
+      ip:longint;\r
+    {$endif}\r
+  end;\r
+\r
+  {$ifdef win32}\r
+    TInetSockAddr = packed Record\r
+      family:Word;\r
+      port  :Word;\r
+      addr  :uint32;\r
+      pad   :array [1..8] of byte;\r
+    end;\r
+    {$ifdef ipv6}\r
+\r
+      TInetSockAddr6 = packed record\r
+        sin6_family: word;\r
+        sin6_port: word;\r
+        sin6_flowinfo: uint32;\r
+        sin6_addr: tin6_addr;\r
+        sin6_scope_id: uint32;\r
+      end;\r
+    {$endif}\r
+  {$endif}\r
+\r
+function htons(w:word):word;\r
+function htonl(i:uint32):uint32;\r
+\r
+function ipstrtobin(const s:string;var binip:tbinip):boolean;\r
+function ipbintostr(const binip:tbinip):string;\r
+{$ifdef ipv6}\r
+function ip6bintostr(const bin:tin6_addr):string;\r
+function ip6strtobin(const s:string;var bin:tin6_addr):boolean;\r
+{$endif}\r
+\r
+function comparebinip(const ip1,ip2:tbinip):boolean;\r
+\r
+{deprecated}\r
+function longip(s:string):longint;\r
+\r
+procedure converttov4(var ip:tbinip);\r
+\r
+implementation\r
+\r
+uses sysutils;\r
+\r
+function htons(w:word):word;\r
+begin\r
+  {$ifdef ENDIAN_LITTLE}\r
+  result := ((w and $ff00) shr 8) or ((w and $ff) shl 8);\r
+  {$else}\r
+  result := w;\r
+  {$endif}\r
+end;\r
+\r
+function htonl(i:uint32):uint32;\r
+begin\r
+  {$ifdef ENDIAN_LITTLE}\r
+  result := (i shr 24) or (i shr 8 and $ff00) or (i shl 8 and $ff0000) or (i shl 24 and $ff000000);\r
+  {$else}\r
+  result := i;\r
+  {$endif}\r
+end;\r
+\r
+{internal}\r
+{converts dotted v4 IP to longint. returns host endian order}\r
+function longip(s:string):longint;\r
+var\r
+  l:longint;\r
+  a,b:integer;\r
+function convertbyte(const s:string):integer;\r
+begin\r
+  result := strtointdef(s,-1);\r
+  if result < 0 then begin\r
+    result := -1;\r
+    exit;\r
+  end;\r
+  if result > 255 then begin\r
+    result := -1;\r
+    exit;\r
+  end;\r
+  {01 exception}\r
+  if (result <> 0) and (s[1] = '0') then begin\r
+    result := -1;\r
+    exit;\r
+  end;\r
+  {+1 exception}\r
+  if not (s[1] in ['0'..'9']) then begin\r
+    result := -1;\r
+    exit\r
+  end;\r
+end;\r
+\r
+begin\r
+  result := 0;\r
+  a := pos('.',s);\r
+  if a = 0 then exit;\r
+  b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+  l := b shl 24;\r
+  s := copy(s,a+1,256);\r
+  a := pos('.',s);\r
+  if a = 0 then exit;\r
+  b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+  l := l or b shl 16;\r
+  s := copy(s,a+1,256);\r
+  a := pos('.',s);\r
+  if a = 0 then exit;\r
+  b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+  l := l or b shl 8;\r
+  s := copy(s,a+1,256);\r
+  b := convertbyte(copy(s,1,256));if (b < 0) then exit;\r
+  l := l or b;\r
+  result := l;\r
+end;\r
+\r
+\r
+function ipstrtobin(const s:string;var binip:tbinip):boolean;\r
+begin\r
+  binip.family := 0;\r
+  result := false;\r
+  {$ifdef ipv6}\r
+  if pos(':',s) <> 0 then begin\r
+    {try ipv6. use builtin routine}\r
+    result := ip6strtobin(s,binip.ip6);\r
+    if result then binip.family := AF_INET6;\r
+    exit;\r
+  end;\r
+  {$endif}\r
+\r
+  {try v4}\r
+  binip.ip := htonl(longip(s));\r
+  if (binip.ip <> 0) or (s = '0.0.0.0') then begin\r
+    result := true;\r
+    binip.family := AF_INET;\r
+    exit;\r
+  end;\r
+end;\r
+\r
+function ipbintostr(const binip:tbinip):string;\r
+var\r
+  a:integer;\r
+begin\r
+  result := '';\r
+  {$ifdef ipv6}\r
+  if binip.family = AF_INET6 then begin\r
+    result := ip6bintostr(binip.ip6);\r
+  end else\r
+  {$endif}\r
+  if binip.family = AF_INET then begin\r
+    a := htonl(binip.ip);\r
+    result := inttostr(a shr 24)+'.'+inttostr((a shr 16) and $ff)+'.'+inttostr((a shr 8) and $ff)+'.'+inttostr(a and $ff);\r
+  end;\r
+end;\r
+\r
+\r
+{------------------------------------------------------------------------------}\r
+\r
+{$ifdef ipv6}\r
+\r
+{\r
+IPv6 address binary to/from string conversion routines\r
+written by beware (steendijk at xs4all dot nl)\r
+\r
+- implementation does not depend on other ipv6 code such as the tin6_addr type,\r
+  the parameter can also be untyped.\r
+- it is host endian neutral - binary format is aways network order\r
+- it supports compression of zeroes\r
+- it supports ::ffff:192.168.12.34 style addresses\r
+- they are made to do the Right Thing, more efficient implementations are possible\r
+}\r
+\r
+{fpc has hostaddrtostr6 and strtohostaddr6 but the later isnt implemented yet}\r
+\r
+\r
+function ip6bintostr(const bin:tin6_addr):string;\r
+{base16 with lowercase output}\r
+function makehex(w:word):string;\r
+begin\r
+  result := '';\r
+  if w >= 4096 then result := result + hexchars[w shr 12];\r
+  if w >= 256 then result := result + hexchars[w shr 8 and $f];\r
+  if w >= 16 then result := result + hexchars[w shr 4 and $f];\r
+  result := result + hexchars[w and $f];\r
+end;\r
+\r
+var\r
+  a,b,c,addrlen:integer;\r
+  runbegin,runlength:integer;\r
+  bytes:array[0..15] of byte absolute bin;\r
+  words:array[0..7] of word;\r
+  dwords:array[0..3] of integer absolute words;\r
+begin\r
+  for a := 0 to 7 do begin\r
+    words[a] := bytes[a shl 1] shl 8 or bytes[a shl 1 or 1];\r
+  end;\r
+  if (dwords[0] = 0) and (dwords[1] = 0) and (words[4] = 0) and (words[5] = $ffff) then begin\r
+    {::ffff:/96 exception: v4 IP}\r
+    addrlen := 6;\r
+  end else begin\r
+    addrlen := 8;\r
+  end;\r
+  {find longest run of zeroes}\r
+  runbegin := 0;\r
+  runlength := 0;\r
+  for a := 0 to addrlen-1 do begin\r
+    if words[a] = 0 then begin\r
+      c := 0;\r
+      for b := a to addrlen-1 do if words[b] = 0 then begin\r
+        inc(c);\r
+      end else break;\r
+      if (c > runlength) then begin\r
+        runlength := c;\r
+        runbegin := a;\r
+      end;\r
+    end;\r
+  end;\r
+  result := '';\r
+  for a := 0 to runbegin-1 do begin\r
+    if (a <> 0) then result := result + ':';\r
+    result := result + makehex(words[a]);\r
+  end;\r
+  if runlength > 0 then result := result + '::';\r
+  c := runbegin+runlength;\r
+  for a := c to addrlen-1 do begin\r
+    if (a > c) then result := result + ':';\r
+    result := result + makehex(words[a]);\r
+  end;\r
+  if addrlen = 6 then begin\r
+    result := result + ':'+inttostr(bytes[12])+'.'+inttostr(bytes[13])+'.'+inttostr(bytes[14])+'.'+inttostr(bytes[15]);\r
+  end;\r
+end;\r
+\r
+function ip6strtobin(const s:string;var bin:tin6_addr):boolean;\r
+var\r
+  a,b:integer;\r
+  fields:array[0..7] of string;\r
+  fieldcount:integer;\r
+  emptyfield:integer;\r
+  wordcount:integer;\r
+  words:array[0..7] of word;\r
+  bytes:array[0..15] of byte absolute bin;\r
+begin\r
+  result := false;\r
+  for a := 0 to 7 do fields[a] := '';\r
+  fieldcount := 0;\r
+  for a := 1 to length(s) do begin\r
+    if s[a] = ':' then inc(fieldcount) else fields[fieldcount] := fields[fieldcount] + s[a];\r
+    if fieldcount > 7 then exit;\r
+  end;\r
+  if fieldcount < 2 then exit;\r
+\r
+  {find the empty field (compressed zeroes), not counting the first and last there may be at most 1}\r
+  emptyfield := -1;\r
+  for a := 1 to fieldcount-1 do begin\r
+    if fields[a] = '' then begin\r
+      if emptyfield = -1 then emptyfield := a else exit;\r
+    end;\r
+  end;\r
+\r
+  {check if last field is a valid v4 IP}\r
+  a := longip(fields[fieldcount]);\r
+  if (a <> 0) or (fields[fieldcount] = '0.0.0.0') then wordcount := 6 else wordcount := 8;\r
+  {0:1:2:3:4:5:6.6.6.6\r
+   0:1:2:3:4:5:6:7}\r
+  fillchar(words,sizeof(words),0);\r
+  if wordcount = 6 then begin\r
+    if fieldcount > 6 then exit;\r
+    words[6] := a shr 16;\r
+    words[7] := a and $ffff;\r
+  end;\r
+  if emptyfield = -1 then begin\r
+    {no run length: must be an exact number of fields}\r
+    if wordcount = 6 then begin\r
+      if fieldcount <> 6 then exit;\r
+      emptyfield := 5;\r
+    end else if wordcount = 8 then begin\r
+      if fieldcount <> 7 then exit;\r
+      emptyfield := 7;\r
+    end else exit;\r
+  end;\r
+  for a := 0 to emptyfield do begin\r
+    if fields[a] = '' then b := 0 else b := strtointdef('$'+fields[a],-1);\r
+    if (b < 0) or (b > $ffff) then exit;\r
+    words[a] := b;\r
+  end;\r
+  if wordcount = 6 then dec(fieldcount);\r
+  for a := wordcount-1 downto wordcount-(fieldcount-emptyfield) do begin\r
+    b := a+fieldcount-wordcount+1;\r
+    if fields[b] = '' then b := 0 else b := strtointdef('$'+fields[b],-1);\r
+    if (b < 0) or (b > $ffff) then exit;\r
+    words[a] := b;\r
+  end;\r
+  for a := 0 to 7 do begin\r
+    bytes[a shl 1] := words[a] shr 8;\r
+    bytes[a shl 1 or 1] := words[a] and $ff;\r
+  end;\r
+  result := true;\r
+end;\r
+{$endif}\r
+\r
+function comparebinip(const ip1,ip2:tbinip):boolean;\r
+begin\r
+  if (ip1.ip <> ip2.ip) then begin\r
+    result := false;\r
+    exit;\r
+  end;\r
+\r
+  {$ifdef ipv6}\r
+  if ip1.family = AF_INET6 then begin\r
+    if (ip1.ip6.s6_addr32[1] <> ip2.ip6.s6_addr32[1])\r
+    or (ip1.ip6.s6_addr32[2] <> ip2.ip6.s6_addr32[2])\r
+    or (ip1.ip6.s6_addr32[3] <> ip2.ip6.s6_addr32[3]) then begin\r
+      result := false;\r
+      exit;\r
+    end;\r
+  end;\r
+  {$endif}\r
+\r
+  result := (ip1.family = ip2.family);\r
+end;\r
+\r
+{converts a binary IP to v4 if it is a v6 IP in the v4 range}\r
+procedure converttov4(var ip:tbinip);\r
+begin\r
+  {$ifdef ipv6}\r
+  if ip.family = AF_INET6 then begin\r
+    if (ip.ip6.u6_addr32[0] = 0) and (ip.ip6.u6_addr32[1] = 0) and\r
+    (ip.ip6.u6_addr16[4] = 0) and (ip.ip6.u6_addr16[5] = $ffff) then begin\r
+      ip.family := AF_INET;\r
+      ip.ip := ip.ip6.s6_addr32[3];\r
+    end;\r
+  end;\r
+  {$endif}\r
+end;\r
+\r
+end.\r

diff --git a/blinklist.pas b/blinklist.pas
new file mode 100755 (executable)
index 0000000..2079b75
--- /dev/null
+++ b/blinklist.pas
@@ -0,0 +1,118 @@
+(*\r
+ *  beware IRC services, blinklist.pas\r
+ *  Copyright (C) 2002 Bas Steendijk\r
+ *\r
+ *  This program is free software; you can redistribute it and/or modify\r
+ *  it under the terms of the GNU General Public License as published by\r
+ *  the Free Software Foundation; either version 2 of the License, or\r
+ *  (at your option) any later version.\r
+ *\r
+ *  This program is distributed in the hope that it will be useful,\r
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\r
+ *  GNU General Public License for more details.\r
+ *\r
+ *  You should have received a copy of the GNU General Public License\r
+ *  along with this program; if not, write to the Free Software\r
+ *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA\r
+ *)\r
+unit blinklist;\r
+{$ifdef fpc}\r
+  {$mode delphi}\r
+{$endif}\r
+\r
+\r
+interface\r
+\r
+type\r
+  tlinklist=class(tobject)\r
+    next:tlinklist;\r
+    prev:tlinklist;\r
+    constructor create;\r
+    destructor destroy; override;\r
+  end;\r
+\r
+  {linklist with 2 links}\r
+  tlinklist2=class(tlinklist)\r
+    next2:tlinklist2;\r
+    prev2:tlinklist2;\r
+  end;\r
+\r
+  {linklist with one pointer}\r
+  tplinklist=class(tlinklist)\r
+    p:pointer\r
+  end;\r
+\r
+  tstringlinklist=class(tlinklist)\r
+    s:string;\r
+  end;\r
+\r
+  tthing=class(tlinklist)\r
+    name:string;      {name/nick}\r
+    hashname:integer; {hash of name}\r
+  end;\r
+\r
+{\r
+adding new block to list (baseptr)\r
+}\r
+procedure linklistadd(var baseptr:tlinklist;newptr:tlinklist);\r
+procedure linklistdel(var baseptr:tlinklist;item:tlinklist);\r
+\r
+\r
+procedure linklist2add(var baseptr,newptr:tlinklist2);\r
+procedure linklist2del(var baseptr:tlinklist2;item:tlinklist2);\r
+\r
+var\r
+  linklistdebug:integer;\r
+\r
+implementation\r
+\r
+procedure linklistadd(var baseptr:tlinklist;newptr:tlinklist);\r
+var\r
+  p:tlinklist;\r
+begin\r
+  p := baseptr;\r
+  baseptr := newptr;\r
+  baseptr.prev := nil;\r
+  baseptr.next := p;\r
+  if p <> nil then p.prev := baseptr;\r
+end;\r
+\r
+procedure linklistdel(var baseptr:tlinklist;item:tlinklist);\r
+begin\r
+  if item = baseptr then baseptr := item.next;\r
+  if item.prev <> nil then item.prev.next := item.next;\r
+  if item.next <> nil then item.next.prev := item.prev;\r
+end;\r
+\r
+procedure linklist2add(var baseptr,newptr:tlinklist2);\r
+var\r
+  p:tlinklist2;\r
+begin\r
+  p := baseptr;\r
+  baseptr := newptr;\r
+  baseptr.prev2 := nil;\r
+  baseptr.next2 := p;\r
+  if p <> nil then p.prev2 := baseptr;\r
+end;\r
+\r
+procedure linklist2del(var baseptr:tlinklist2;item:tlinklist2);\r
+begin\r
+  if item = baseptr then baseptr := item.next2;\r
+  if item.prev2 <> nil then item.prev2.next2 := item.next2;\r
+  if item.next2 <> nil then item.next2.prev2 := item.prev2;\r
+end;\r
+\r
+constructor tlinklist.create;\r
+begin\r
+  inherited create;\r
+  inc(linklistdebug);\r
+end;\r
+\r
+destructor tlinklist.destroy;\r
+begin\r
+  dec(linklistdebug);\r
+  inherited destroy;\r
+end;\r
+\r
+end.\r

diff --git a/bsearchtree.pas b/bsearchtree.pas
new file mode 100755 (executable)
index 0000000..ad61751
--- /dev/null
+++ b/bsearchtree.pas
@@ -0,0 +1,101 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+  \r
+{actually a hashtable. it was a tree in earlier versions}\r
+\r
+unit bsearchtree;\r
+\r
+interface\r
+\r
+uses blinklist;\r
+\r
+const\r
+  hashtable_size=$4000;\r
+\r
+type\r
+  thashitem=class(tlinklist)\r
+    hash:integer;\r
+    s:string;\r
+    p:pointer;\r
+  end;\r
+  thashtable=array[0..hashtable_size-1] of thashitem;\r
+  phashtable=^thashtable;\r
+\r
+{adds "item" to the tree for name "s". the name must not exist (no checking done)}\r
+procedure addtree(t:phashtable;s:string;item:pointer);\r
+\r
+{removes name "s" from the tree. the name must exist (no checking done)}\r
+procedure deltree(t:phashtable;s:string);\r
+\r
+{returns the item pointer for s, or nil if not found}\r
+function findtree(t:phashtable;s:string):pointer;\r
+\r
+implementation\r
+\r
+function makehash(s:string):integer;\r
+const\r
+  shifter=6;\r
+var\r
+  a,b:integer;\r
+begin\r
+  result := 0;\r
+  b := length(s);\r
+  for a := 1 to b do begin\r
+    result := (result shl shifter) xor byte(s[a]);\r
+  end;\r
+  result := (result xor result shr 16) and (hashtable_size-1);\r
+end;\r
+\r
+procedure addtree(t:phashtable;s:string;item:pointer);\r
+var\r
+  hash:integer;\r
+  p:thashitem;\r
+begin\r
+  hash := makehash(s);\r
+  p := thashitem.create;\r
+  p.hash := hash;\r
+  p.s := s;\r
+  p.p := item;\r
+  linklistadd(tlinklist(t[hash]),tlinklist(p));\r
+end;\r
+\r
+procedure deltree(t:phashtable;s:string);\r
+var\r
+  p,p2:thashitem;\r
+  hash:integer;\r
+begin\r
+  hash := makehash(s);\r
+  p := t[hash];\r
+  p2 := nil;\r
+  while p <> nil do begin\r
+    if p.s = s then begin\r
+      p2 := p;\r
+      break;\r
+    end;\r
+    p := thashitem(p.next);\r
+  end;\r
+  linklistdel(tlinklist(t[hash]),tlinklist(p2));\r
+  p2.destroy;\r
+end;\r
+\r
+\r
+function findtree(t:phashtable;s:string):pointer;\r
+var\r
+  p:thashitem;\r
+  hash:integer;\r
+begin\r
+  result := nil;\r
+  hash := makehash(s);\r
+  p := t[hash];\r
+  while p <> nil do begin\r
+    if p.s = s then begin\r
+      result := p.p;\r
+      exit;\r
+    end;\r
+    p := thashitem(p.next);\r
+  end;\r
+end;\r
+\r
+end.\r

diff --git a/btime.pas b/btime.pas
new file mode 100755 (executable)
index 0000000..3d672c4
--- /dev/null
+++ b/btime.pas
@@ -0,0 +1,362 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+{\r
+this unit returns unix timestamp with seconds and microseconds (as float)\r
+works on windows/delphi, and on freepascal on unix.\r
+}\r
+\r
+unit btime;\r
+\r
+interface\r
+\r
+type\r
+  float=extended;\r
+\r
+var\r
+  timezone:integer;\r
+  timezonestr:string;\r
+  irctime,unixtime:integer;\r
+  tickcount:integer;\r
+  settimebias:integer;\r
+  qpcjump:float; {can be read out and reset for debug purpose}\r
+  performancecountfreq:extended;\r
+\r
+function irctimefloat:float;\r
+function irctimeint:integer;\r
+\r
+function unixtimefloat:float;\r
+function unixtimeint:integer;\r
+\r
+function wintimefloat:float;\r
+\r
+procedure settime(newtime:integer);\r
+procedure gettimezone;\r
+procedure timehandler;\r
+procedure init;\r
+\r
+function timestring(i:integer):string;\r
+function timestrshort(i:integer):string;\r
+\r
+function oletounixfloat(t:float):float;\r
+function oletounix(t:tdatetime):integer;\r
+function unixtoole(i:integer):tdatetime;\r
+\r
+var\r
+  timefloatbias:float;\r
+  lastunixtimefloat:float=0;\r
+\r
+implementation\r
+\r
+{$ifdef fpc}\r
+  {$mode delphi}\r
+{$endif}\r
+\r
+uses\r
+  {$ifdef UNIX}\r
+    {$ifdef VER1_0}\r
+      linux,\r
+    {$else}\r
+      baseunix,unix,unixutil,{needed for 2.0.2}\r
+    {$endif}\r
+  {$else}\r
+    windows,\r
+  {$endif}\r
+  sysutils;\r
+\r
+  {$include unixstuff.inc}\r
+\r
+\r
+const\r
+  daysdifference=25569;\r
+\r
+function oletounixfloat(t:float):float;\r
+begin\r
+  t := (t - daysdifference) * 86400;\r
+  result := t;\r
+end;\r
+\r
+function oletounix(t:tdatetime):integer;\r
+begin\r
+  result := trunc(oletounixfloat(t));\r
+end;\r
+\r
+function unixtoole(i:integer):tdatetime;\r
+begin\r
+  result := ((i)/86400)+daysdifference;\r
+end;\r
+\r
+{$ifdef unix}\r
+{-----------------------------------------*nix/freepascal code to read time }\r
+\r
+function unixtimefloat:float;\r
+var\r
+  tv:ttimeval;\r
+begin\r
+  gettimeofday(tv);\r
+  result := tv.tv_sec+(tv.tv_usec/1000000);\r
+end;\r
+\r
+function wintimefloat:extended;\r
+begin\r
+  result := unixtimefloat;\r
+end;\r
+\r
+function unixtimeint:integer;\r
+var\r
+  tv:ttimeval;\r
+begin\r
+  gettimeofday(tv);\r
+  result := tv.tv_sec;\r
+end;\r
+\r
+{$else} {delphi 3}\r
+{------------------------------ windows/delphi code to read time}\r
+\r
+{ free pascals tsystemtime is incomaptible with windows api calls\r
+ so we declare it ourselves - plugwash\r
+}\r
+{$ifdef fpc}\r
+type\r
+  TSystemTime = record\r
+     wYear: Word;\r
+     wMonth: Word;\r
+     wDayOfWeek: Word;\r
+     wDay: Word;\r
+     wHour: Word;\r
+     wMinute: Word;\r
+     wSecond: Word;\r
+     wMilliseconds: Word;\r
+  end;\r
+ {$endif}\r
+function Date_utc: extended;\r
+var\r
+  SystemTime: TSystemTime;\r
+begin\r
+  {$ifdef fpc}\r
+    GetsystemTime(@SystemTime);\r
+  {$else}\r
+    GetsystemTime(SystemTime);\r
+  {$endif}\r
+  with SystemTime do Result := EncodeDate(wYear, wMonth, wDay);\r
+end;\r
+\r
+function Time_utc: extended;\r
+var\r
+  SystemTime: TSystemTime;\r
+begin\r
+  {$ifdef fpc}\r
+    GetsystemTime(@SystemTime);\r
+  {$else}\r
+    GetsystemTime(SystemTime);\r
+  {$endif}\r
+  with SystemTime do\r
+    Result := EncodeTime(wHour, wMinute, wSecond, wMilliSeconds);\r
+end;\r
+\r
+function Now_utc: extended;\r
+begin\r
+  Result := round(Date_utc) + Time_utc;\r
+end;\r
+\r
+const\r
+  highdwordconst=4294967296.0;\r
+\r
+function wintimefloat:extended;\r
+var\r
+  p:packed record\r
+    lowpart:longint;\r
+    highpart:longint\r
+  end;\r
+  p2:tlargeinteger absolute p;\r
+  e:extended;\r
+begin\r
+  if performancecountfreq = 0 then begin\r
+    QueryPerformancefrequency(p2);\r
+    e := p.lowpart;\r
+    if e < 0 then e := e + highdwordconst;\r
+    performancecountfreq := ((p.highpart*highdwordconst)+e);\r
+  end;\r
+  queryperformancecounter(p2);\r
+  e := p.lowpart;\r
+  if e < 0 then e := e + highdwordconst;\r
+  result := ((p.highpart*highdwordconst)+e)/performancecountfreq;\r
+end;\r
+\r
+var\r
+  classpriority,threadpriority:integer;\r
+\r
+procedure settc;\r
+var\r
+  hprocess,hthread:integer;\r
+begin\r
+  hProcess := GetCurrentProcess;\r
+  hThread := GetCurrentThread;\r
+\r
+  ClassPriority := GetPriorityClass(hProcess);\r
+  ThreadPriority := GetThreadPriority(hThread);\r
+\r
+  SetPriorityClass(hProcess, REALTIME_PRIORITY_CLASS);\r
+  SetThreadPriority(hThread, THREAD_PRIORITY_TIME_CRITICAL);\r
+end;\r
+\r
+procedure unsettc;\r
+var\r
+  hprocess,hthread:integer;\r
+begin\r
+  hProcess := GetCurrentProcess;\r
+  hThread := GetCurrentThread;\r
+\r
+  SetPriorityClass(hProcess, ClassPriority);\r
+  SetThreadPriority(hThread,  ThreadPriority);\r
+end;\r
+\r
+function unixtimefloat:float;\r
+var\r
+  f,g,h:float;\r
+begin\r
+  if timefloatbias = 0 then begin\r
+    settc;\r
+    f := now_utc;\r
+    repeat g := now_utc; h := wintimefloat until g > f;\r
+    timefloatbias := oletounixfloat(g)-h;\r
+    unsettc;\r
+  end;\r
+  result := wintimefloat+timefloatbias;\r
+\r
+  {\r
+  workaround for QPC jumps\r
+  (approach 2: always check "hi res" QPC unixtime against the "guaranteed" systemtime one)\r
+  }\r
+  f := result-(oletounixfloat(now_utc));\r
+  if abs(f) > 0.02 then begin\r
+    f := timefloatbias;\r
+    timefloatbias := 0;\r
+    result := unixtimefloat;\r
+    qpcjump := qpcjump + f - timefloatbias;\r
+  end;\r
+\r
+  if (result <= lastunixtimefloat) then result := lastunixtimefloat + 0.0000001;\r
+  lastunixtimefloat := result;\r
+end;\r
+\r
+function unixtimeint:integer;\r
+begin\r
+  result := trunc(unixtimefloat);\r
+end;\r
+\r
+{$endif}\r
+{-----------------------------------------------end of platform specific}\r
+\r
+function irctimefloat:float;\r
+begin\r
+  result := unixtimefloat+settimebias;\r
+end;\r
+\r
+function irctimeint:integer;\r
+begin\r
+  result := unixtimeint+settimebias;\r
+end;\r
+\r
+\r
+procedure settime(newtime:integer);\r
+var\r
+  a:integer;\r
+begin\r
+  a := irctimeint-settimebias;\r
+  if newtime = 0 then settimebias := 0 else settimebias := newtime-a;\r
+\r
+  irctime := irctimeint;\r
+end;\r
+\r
+procedure timehandler;\r
+begin\r
+  if unixtime = 0 then init;\r
+  unixtime := unixtimeint;\r
+  irctime := irctimeint;\r
+  if unixtime and 63 = 0 then begin\r
+    {update everything, apply timezone changes, clock changes, etc}\r
+    gettimezone;\r
+    timefloatbias := 0;\r
+    unixtime := unixtimeint;\r
+    irctime := irctimeint;\r
+  end;\r
+end;\r
+\r
+\r
+procedure gettimezone;\r
+var\r
+  {$ifdef UNIX}\r
+    {$ifndef ver1_9_4}\r
+      {$ifndef ver1_0}\r
+        {$define above194}\r
+      {$endif}\r
+    {$endif}\r
+    {$ifndef above194}\r
+      hh,mm,ss:word;\r
+    {$endif}\r
+  {$endif}\r
+  l:integer;\r
+begin\r
+  {$ifdef UNIX}\r
+    {$ifdef above194}\r
+      timezone := tzseconds;\r
+    {$else}\r
+      gettime(hh,mm,ss);\r
+      timezone := (longint(hh) * 3600 + mm * 60 + ss) - (unixtimeint mod 86400);\r
+    {$endif}\r
+  {$else}\r
+  timezone := round((now-now_utc)*86400);\r
+  {$endif}\r
+\r
+  while timezone > 43200 do dec(timezone,86400);\r
+  while timezone < -43200 do inc(timezone,86400);\r
+\r
+  if timezone >= 0 then timezonestr := '+' else timezonestr := '-';\r
+  l := abs(timezone) div 60;\r
+  timezonestr := timezonestr + char(l div 600 mod 10+48)+char(l div 60 mod 10+48)+':'+char(l div 10 mod 6+48)+char(l mod 10+48);\r
+end;\r
+\r
+function timestrshort(i:integer):string;\r
+const\r
+  weekday:array[0..6] of string[4]=('Thu','Fri','Sat','Sun','Mon','Tue','Wed');\r
+  month:array[0..11] of string[4]=('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');\r
+var\r
+  y,m,d,h,min,sec,ms:word;\r
+  t:tdatetime;\r
+begin\r
+  t := unixtoole(i+timezone);\r
+  decodedate(t,y,m,d);\r
+  decodetime(t,h,min,sec,ms);\r
+  result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+\r
+  inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10)+' '+\r
+  inttostr(y);\r
+end;\r
+\r
+function timestring(i:integer):string;\r
+const\r
+  weekday:array[0..6] of string[10]=('Thursday','Friday','Saturday','Sunday','Monday','Tuesday','Wednesday');\r
+  month:array[0..11] of string[10]=('January','February','March','April','May','June','July','August','September','October','November','December');\r
+var\r
+  y,m,d,h,min,sec,ms:word;\r
+  t:tdatetime;\r
+begin\r
+  t := unixtoole(i+timezone);\r
+  decodedate(t,y,m,d);\r
+  decodetime(t,h,min,sec,ms);\r
+  result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+inttostr(y)+' -- '+\r
+  inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10)+' '+\r
+  timezonestr;\r
+end;\r
+\r
+procedure init;\r
+begin\r
+  qpcjump := 0;\r
+  settimebias := 0;\r
+  gettimezone;\r
+  unixtime := unixtimeint;\r
+  irctime := irctimeint;\r
+end;\r
+\r
+end.\r

diff --git a/dnsasync.pas b/dnsasync.pas
new file mode 100755 (executable)
index 0000000..0a32459
--- /dev/null
+++ b/dnsasync.pas
@@ -0,0 +1,247 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+\r
+//FIXME: this code only ever seems to use one dns server for a request and does\r
+//not seem to have any form of retry code.\r
+\r
+unit dnsasync;\r
+\r
+interface\r
+\r
+uses\r
+  {$ifdef win32}\r
+    dnswin,\r
+  {$endif}\r
+  lsocket,lcore,\r
+  classes,binipstuff,dnscore,btime;\r
+\r
+\r
+type\r
+  //after completion or cancelation a dnswinasync may be reused\r
+  tdnsasync=class(tcomponent)\r
+\r
+  private\r
+    //made a load of stuff private that does not appear to be part of the main\r
+    //public interface. If you make any of it public again please consider the\r
+    //consequences when using windows dns. --plugwash.\r
+    sock:twsocket;\r
+\r
+    sockopen:boolean;\r
+\r
+\r
+    state:tdnsstate;\r
+\r
+    dnsserverid:integer;\r
+    startts:double;\r
+    {$ifdef win32}\r
+      dwas : tdnswinasync;\r
+    {$endif}\r
+\r
+\r
+    procedure asyncprocess;\r
+    procedure receivehandler(sender:tobject;error:word);\r
+    function sendquery(const packet:tdnspacket;len:integer):boolean;\r
+    {$ifdef win32}\r
+      procedure winrequestdone(sender:tobject;error:word);\r
+    {$endif}\r
+  public\r
+    onrequestdone:tsocketevent;\r
+\r
+    //addr and port allow the application to specify a dns server specifically\r
+    //for this dnsasync object. This is not a reccomended mode of operation\r
+    //because it limits the app to one dns server but is kept for compatibility\r
+    //and special uses.\r
+    addr,port:string;\r
+\r
+    //A family value of AF_INET6 will give only\r
+    //ipv6 results. Any other value will give ipv4 results in preference and ipv6\r
+    //results if ipv4 results are not available;\r
+    forwardfamily:integer;\r
+\r
+    procedure cancel;//cancel an outstanding dns request\r
+    function dnsresult:string; //get result of dnslookup as a string\r
+    procedure dnsresultbin(var binip:tbinip); //get result of dnslookup as a tbinip\r
+    procedure forwardlookup(const name:string); //start forward lookup,\r
+                                                //preffering ipv4\r
+    procedure reverselookup(const binip:tbinip); //start reverse lookup\r
+\r
+    constructor create(aowner:tcomponent); override;\r
+    destructor destroy; override;\r
+\r
+  end;\r
+\r
+implementation\r
+\r
+uses sysutils;\r
+\r
+constructor tdnsasync.create;\r
+begin\r
+  inherited create(aowner);\r
+  dnsserverid := -1;\r
+  sock := twsocket.create(self);\r
+end;\r
+\r
+destructor tdnsasync.destroy;\r
+begin\r
+  if dnsserverid >= 0 then begin\r
+    reportlag(dnsserverid,-1);\r
+    dnsserverid := -1;\r
+  end;\r
+  sock.release;\r
+  setstate_request_init('',state);\r
+  inherited destroy;\r
+end;\r
+\r
+procedure tdnsasync.receivehandler;\r
+begin\r
+  if dnsserverid >= 0 then begin\r
+    reportlag(dnsserverid,trunc((unixtimefloat-startts)*1000));\r
+    dnsserverid := -1;\r
+  end;\r
+{  writeln('received reply');}\r
+  fillchar(state.recvpacket,sizeof(state.recvpacket),0);\r
+  state.recvpacketlen := twsocket(sender).Receive(@state.recvpacket, SizeOf(state.recvpacket));\r
+  state.parsepacket := true;\r
+  asyncprocess;\r
+end;\r
+\r
+function tdnsasync.sendquery;\r
+begin\r
+{  writeln('sendquery ',decodename(state.packet,state.packetlen,12,0,a),' ',state.requesttype);}\r
+  result := false;\r
+  if len = 0 then exit; {no packet}\r
+  if not sockopen then begin\r
+    if addr <> '' then sock.addr := addr else sock.addr := getcurrentsystemnameserver(dnsserverid);//getunixnameservercached;\r
+    startts := unixtimefloat;\r
+    if port = '' then port := '53';\r
+    sock.port := port;\r
+    sock.Proto := 'udp';\r
+    sock.ondataavailable := receivehandler;\r
+    try\r
+      sock.connect;\r
+    except\r
+      on e:exception do begin\r
+        //writeln('exception '+e.message);\r
+        exit;\r
+      end;\r
+    end;\r
+    sockopen := true;\r
+  end;\r
+  sock.send(@packet,len);\r
+  result := true;\r
+end;\r
+\r
+procedure tdnsasync.asyncprocess;\r
+begin\r
+  state_process(state);\r
+  case state.resultaction of\r
+    action_ignore: begin {do nothing} end;\r
+    action_done: begin\r
+      onrequestdone(self,0);\r
+    end;\r
+    action_sendquery:begin\r
+      sendquery(state.sendpacket,state.sendpacketlen);\r
+    end;\r
+  end;\r
+end;\r
+\r
+procedure tdnsasync.forwardlookup;\r
+begin\r
+\r
+  ipstrtobin(name,state.resultbin);\r
+\r
+  {$ifdef win32}\r
+    if usewindns or (addr = '') then begin\r
+      dwas := tdnswinasync.create;\r
+      dwas.onrequestdone := winrequestdone;\r
+      if forwardfamily = AF_INET6 then begin\r
+        dwas.forwardlookup(name,true);\r
+      end else begin\r
+        dwas.forwardlookup(name,false);\r
+      end;\r
+      exit;\r
+    end;\r
+  {$endif}\r
+\r
+\r
+  if state.resultbin.family <> 0 then begin\r
+    onrequestdone(self,0);\r
+    exit;\r
+  end;\r
+\r
+\r
+  setstate_forward(name,state,forwardfamily);\r
+  asyncprocess;\r
+\r
+end;\r
+\r
+procedure tdnsasync.reverselookup;\r
+\r
+begin\r
+  {$ifdef win32}\r
+    if usewindns or (addr = '') then begin\r
+      dwas := tdnswinasync.create;\r
+      dwas.onrequestdone := winrequestdone;\r
+      dwas.reverselookup(binip);\r
+      exit;\r
+    end;\r
+  {$endif}\r
+\r
+  setstate_reverse(binip,state);\r
+  asyncprocess;\r
+end;\r
+\r
+function tdnsasync.dnsresult;\r
+begin\r
+  if state.resultstr <> '' then result := state.resultstr else begin\r
+    result := ipbintostr(state.resultbin);\r
+  end;\r
+end;\r
+\r
+procedure tdnsasync.dnsresultbin(var binip:tbinip);\r
+begin\r
+  move(state.resultbin,binip,sizeof(binip));\r
+end;\r
+\r
+procedure tdnsasync.cancel;\r
+begin\r
+  {$ifdef win32}\r
+    if assigned(dwas) then begin\r
+      dwas.release;\r
+      dwas := nil;\r
+    end else \r
+  {$endif}\r
+  begin\r
+\r
+    if dnsserverid >= 0 then begin\r
+      reportlag(dnsserverid,-1);\r
+      dnsserverid := -1;\r
+    end;\r
+    if sockopen then begin\r
+      sock.close;\r
+      sockopen := false;\r
+    end;\r
+  end;\r
+  setstate_failure(state);\r
+  onrequestdone(self,0);\r
+end;\r
+\r
+{$ifdef win32}\r
+  procedure tdnsasync.winrequestdone(sender:tobject;error:word);\r
+ \r
+  begin\r
+    if dwas.reverse then begin \r
+      state.resultstr := dwas.name;\r
+    end else begin \r
+      state.resultbin := dwas.ip;\r
+      if (forwardfamily = AF_INET6) and (state.resultbin.family = AF_INET) then begin\r
+        fillchar(state.resultbin,sizeof(tbinip),0);\r
+      end;\r
+    end;\r
+    dwas.release;\r
+    onrequestdone(self,error);\r
+  end;\r
+{$endif}\r
+end.\r

diff --git a/dnscore.pas b/dnscore.pas
new file mode 100755 (executable)
index 0000000..bb4fab4
--- /dev/null
+++ b/dnscore.pas
@@ -0,0 +1,728 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+\r
+{\r
+\r
+  code wanting to use this dns system should act as follows (note: app\r
+  developers will probablly want to use dnsasync or dnssync or write a similar\r
+  wrapper unit of thier own).\r
+\r
+  for normal lookups call setstate_forward or setstate_reverse to set up the\r
+  state, for more obscure lookups use setstate_request_init and fill in other\r
+  relavent state manually.\r
+\r
+  call state_process which will do processing on the information in the state\r
+  and return an action\r
+  action_ignore means that dnscore wants the code that calls it to go\r
+  back to waiting for packets\r
+  action_sendpacket means that dnscore wants the code that calls it to send\r
+  the packet in sendpacket/sendpacketlen and then start (or go back to) listening\r
+  for\r
+  action_done means the request has completed (either suceeded or failed)\r
+\r
+  callers should resend the last packet they tried to send if they have not\r
+  been asked to send a new packet for more than some timeout value they choose.\r
+\r
+  when a packet is received the application should put the packet in\r
+  recvbuf/recvbuflen , set state.parsepacket and call state_process again\r
+\r
+  once the app gets action_done it can determine sucess or failure in the\r
+  following ways.\r
+\r
+  on failure state.resultstr will be an empty string and state.resultbin will\r
+  be zeroed out (easilly detected by the fact that it will have a family of 0)\r
+\r
+  on success for a A or AAAA lookup state.resultstr will be an empty string\r
+  and state.resultbin will contain the result (note: AAAA lookups require IPV6\r
+  enabled).\r
+\r
+  if an A lookup fails and the code is built with ipv6 enabled then the code\r
+  will return any AAAA records with the same name. The reverse does not apply\r
+  so if an application preffers IPV6 but wants IPV4 results as well it must\r
+  check them seperately.\r
+\r
+  on success for any other type of lookup state.resultstr will be an empty\r
+\r
+  note the state contains ansistrings, setstate_init with a null name parameter\r
+  can be used to clean theese up if required.\r
+\r
+  callers may use setstate_failure to mark the state as failed themseleves\r
+  before passing it on to other code, for example this may be done in the event\r
+  of a timeout.\r
+}\r
+unit dnscore;\r
+\r
+\r
+\r
+{$ifdef fpc}{$mode delphi}{$endif}\r
+\r
+\r
+\r
+\r
+\r
+interface\r
+\r
+uses binipstuff,classes,pgtypes;\r
+\r
+var usewindns : boolean = {$ifdef win32}true{$else}false{$endif};\r
+//hint to users of this unit that they should use windows dns instead.\r
+//May be disabled by applications if desired. (e.g. if setting a custom\r
+//dnsserverlist).\r
+\r
+//note: this unit will not be able to self populate it's dns server list on\r
+//older versions of windows.\r
+\r
+const\r
+  maxnamelength=127;\r
+  maxnamefieldlen=63;\r
+  //note: when using action_ignore the dnscore code *must* preserve the contents of state.sendpacket to allow for retries\r
+  //note: action_ignore must not be used in response to the original request but there is no valid reason for doing this anyway\r
+  action_ignore=0;\r
+  action_done=1;\r
+  action_sendquery=2;\r
+  querytype_a=1;\r
+  querytype_cname=5;\r
+  querytype_aaaa=28;\r
+  querytype_ptr=12;\r
+  querytype_ns=2;\r
+  querytype_soa=6;\r
+  querytype_mx=15;\r
+\r
+  maxrecursion=10;\r
+  maxrrofakind=20;\r
+\r
+  retryafter=300000; //microseconds must be less than one second;\r
+  timeoutlag=1000000000; // penalty value to be treated as lag in the event of a timeout (microseconds)\r
+type\r
+  dvar=array[0..0] of byte;\r
+  pdvar=^dvar;\r
+  tdnspacket=packed record\r
+    id:word;\r
+    flags:word;\r
+    rrcount:array[0..3] of word;\r
+    payload:array[0..511-12] of byte;\r
+  end;\r
+\r
+\r
+\r
+  tdnsstate=record\r
+    id:word;\r
+    recursioncount:integer;\r
+    queryname:string;\r
+    requesttype:word;\r
+    parsepacket:boolean;\r
+    resultstr:string;\r
+    resultbin:tbinip;\r
+    resultaction:integer;\r
+    numrr1:array[0..3] of integer;\r
+    numrr2:integer;\r
+    rrdata:string;\r
+    sendpacketlen:integer;\r
+    sendpacket:tdnspacket;\r
+    recvpacketlen:integer;\r
+    recvpacket:tdnspacket;\r
+    forwardfamily:integer;\r
+  end;\r
+\r
+  trr=packed record\r
+    requesttypehi:byte;\r
+    requesttype:byte;\r
+    clas:word;\r
+    ttl:integer;\r
+    datalen:word;\r
+    data:array[0..511] of byte;\r
+  end;\r
+\r
+  trrpointer=packed record\r
+    p:pointer;\r
+    ofs:integer;\r
+    len:integer;\r
+    namelen:integer;\r
+  end;\r
+\r
+//commenting out functions from interface that do not have documented semantics\r
+//and probablly should not be called from outside this unit, reenable them\r
+//if you must but please document them at the same time --plugwash\r
+\r
+//function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer;\r
+//function makereversename(const binip:tbinip):string;\r
+\r
+procedure setstate_request_init(const name:string;var state:tdnsstate);\r
+\r
+//set up state for a foward lookup. A family value of AF_INET6 will give only\r
+//ipv6 results. Any other value will give ipv4 results in preference and ipv6\r
+//results if ipv4 results are not available;\r
+procedure setstate_forward(const name:string;var state:tdnsstate;family:integer);\r
+\r
+procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);\r
+procedure setstate_failure(var state:tdnsstate);\r
+//procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);\r
+\r
+\r
+procedure state_process(var state:tdnsstate);\r
+\r
+//function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):string;\r
+\r
+//presumablly this is exported to allow more secure random functions\r
+//to be substituted?\r
+var randomfunction:function:integer;\r
+\r
+\r
+procedure populatednsserverlist;\r
+procedure cleardnsservercache;\r
+\r
+var\r
+  dnsserverlist : tstringlist;\r
+//  currentdnsserverno : integer;\r
+\r
+function getcurrentsystemnameserver(var id:integer) :string;\r
+\r
+//var\r
+//  unixnameservercache:string;\r
+{ $endif}\r
+\r
+\r
+procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout\r
+var\r
+  failurereason:string;\r
+\r
+implementation\r
+\r
+uses\r
+  {$ifdef win32}\r
+    windows,\r
+  {$endif}\r
+\r
+  sysutils;\r
+\r
+function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer;\r
+var\r
+  a,b:integer;\r
+  s:string;\r
+  arr:array[0..sizeof(packet)-1] of byte absolute packet;\r
+begin\r
+ { writeln('buildrequest: name: ',name);}\r
+  result := 0;\r
+  fillchar(packet,sizeof(packet),0);\r
+  if assigned(randomfunction) then packet.id := (randomfunction and $ffff) else packet.id := random(65536);\r
+  packet.flags := htons($0100);\r
+  packet.rrcount[0] := htons($0001);\r
+\r
+\r
+  s := copy(name,1,maxnamelength);\r
+  if s = '' then exit;\r
+  if s[length(s)] <> '.' then s := s + '.';\r
+  b := 0;\r
+  {encode name}\r
+  if (s = '.') then begin\r
+    packet.payload[0] := 0;\r
+    result := 12+5;\r
+  end else begin\r
+    for a := 1 to length(s) do begin\r
+      if s[a] = '.' then begin\r
+        if b > maxnamefieldlen then exit;\r
+        if (b = 0) then exit;\r
+        packet.payload[a-b-1] := b;\r
+        b := 0;\r
+      end else begin\r
+        packet.payload[a] := byte(s[a]);\r
+        inc(b);\r
+      end;\r
+    end;\r
+    if b > maxnamefieldlen then exit;\r
+    packet.payload[length(s)-b] := b;\r
+    result := length(s) + 12+5;\r
+  end;\r
+\r
+  arr[result-1] := 1;\r
+  arr[result-3] := requesttype and $ff;\r
+  arr[result-4] := requesttype shr 8;\r
+end;\r
+\r
+function makereversename(const binip:tbinip):string;\r
+var\r
+  name:string;\r
+  a,b:integer;\r
+begin\r
+  name := '';\r
+  if binip.family = AF_INET then begin\r
+    b := htonl(binip.ip);\r
+    for a := 0 to 3 do begin\r
+      name := name + inttostr(b shr (a shl 3) and $ff)+'.';\r
+    end;\r
+    name := name + 'in-addr.arpa';\r
+  end else\r
+  {$ifdef ipv6}\r
+  if binip.family = AF_INET6 then begin\r
+    for a := 15 downto 0 do begin\r
+      b := binip.ip6.u6_addr8[a];\r
+      name := name + hexchars[b and $f]+'.'+hexchars[b shr 4]+'.';\r
+    end;\r
+    name := name + 'ip6.arpa';\r
+  end else\r
+  {$endif}\r
+  begin\r
+    {empty name}\r
+  end;\r
+  result := name;\r
+end;\r
+\r
+{\r
+decodes DNS format name to a string. does not includes the root dot.\r
+doesnt read beyond len.\r
+empty result + non null failurereason: failure\r
+empty result + null failurereason: internal use\r
+}\r
+function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):string;\r
+var\r
+  arr:array[0..sizeof(packet)-1] of byte absolute packet;\r
+  s:string;\r
+  a,b:integer;\r
+begin\r
+  numread := 0;\r
+  repeat\r
+    if (start+numread < 0) or (start+numread >= len) then begin\r
+      result := '';\r
+      failurereason := 'decoding name: got out of range1';\r
+      exit;\r
+    end;\r
+    b := arr[start+numread];\r
+    if b >= $c0 then begin\r
+      {recursive sub call}\r
+      if recursion > 10 then begin\r
+        result := '';\r
+        failurereason := 'decoding name: max recursion';\r
+        exit;\r
+      end;\r
+      if ((start+numread+1) >= len) then begin\r
+        result := '';\r
+        failurereason := 'decoding name: got out of range3';\r
+        exit;\r
+      end;\r
+      a := ((b shl 8) or arr[start+numread+1]) and $3fff;\r
+      s := decodename(packet,len,a,recursion+1,a);\r
+      if (s = '') and (failurereason <> '') then begin\r
+        result := '';\r
+        exit;\r
+      end;\r
+      if result <> '' then result := result + '.';\r
+      result := result + s;\r
+      inc(numread,2);\r
+      exit;\r
+    end else if b < 64 then begin\r
+      if (numread <> 0) and (b <> 0) then result := result + '.';\r
+      for a := start+numread+1 to start+numread+b do begin\r
+        if (a >= len) then begin\r
+          result := '';\r
+          failurereason := 'decoding name: got out of range2';\r
+          exit;\r
+        end;\r
+        result := result + char(arr[a]);\r
+      end;\r
+      inc(numread,b+1);\r
+\r
+      if b = 0 then begin\r
+        if (result = '') and (recursion = 0) then result := '.';\r
+        exit; {reached end of name}\r
+      end;\r
+    end else begin\r
+      failurereason := 'decoding name: read invalid char';\r
+      result := '';\r
+      exit; {invalid}\r
+    end;\r
+  until false;\r
+end;\r
+\r
+{==============================================================================}\r
+\r
+procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);\r
+var\r
+  a:integer;\r
+begin\r
+  state.resultaction := action_done;\r
+  state.resultstr := '';\r
+  case trr(rrp.p^).requesttype of\r
+    querytype_a: begin\r
+      if htons(trr(rrp.p^).datalen) <> 4 then exit;\r
+      move(trr(rrp.p^).data,state.resultbin.ip,4);\r
+      state.resultbin.family :=AF_INET;\r
+    end;\r
+    {$ifdef ipv6}\r
+    querytype_aaaa: begin\r
+      if htons(trr(rrp.p^).datalen) <> 16 then exit;\r
+      state.resultbin.family := AF_INET6;\r
+      move(trr(rrp.p^).data,state.resultbin.ip6,16);\r
+    end;\r
+    {$endif}\r
+  else\r
+    {other reply types (PTR, MX) return a hostname}\r
+    state.resultstr := decodename(state.recvpacket,state.recvpacketlen,taddrint(rrp.p)-taddrint(@state.recvpacket)+10,0,a);\r
+    fillchar(state.resultbin,sizeof(state.resultbin),0);\r
+  end;\r
+end;\r
+\r
+procedure setstate_request_init(const name:string;var state:tdnsstate);\r
+begin\r
+  {destroy things properly}\r
+  state.resultstr := '';\r
+  state.queryname := '';\r
+  state.rrdata := '';\r
+  fillchar(state,sizeof(state),0);\r
+  state.queryname := name;\r
+  state.parsepacket := false;\r
+end;\r
+\r
+procedure setstate_forward(const name:string;var state:tdnsstate;family:integer);\r
+begin\r
+  setstate_request_init(name,state);\r
+  state.forwardfamily := family;\r
+  {$ifdef ipv6}\r
+  if family = AF_INET6 then state.requesttype := querytype_aaaa else\r
+  {$endif}\r
+  state.requesttype := querytype_a;\r
+end;\r
+\r
+procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);\r
+begin\r
+  setstate_request_init(makereversename(binip),state);\r
+  state.requesttype := querytype_ptr;\r
+end;\r
+\r
+procedure setstate_failure(var state:tdnsstate);\r
+begin\r
+  state.resultstr := '';\r
+  fillchar(state.resultbin,sizeof(state.resultbin),0);\r
+  state.resultaction := action_done;\r
+end;\r
+\r
+procedure state_process(var state:tdnsstate);\r
+label recursed;\r
+label failure;\r
+var\r
+  a,b,ofs:integer;\r
+  rrtemp:^trr;\r
+  rrptemp:^trrpointer;\r
+begin\r
+  if state.parsepacket then begin\r
+    if state.recvpacketlen < 12 then begin\r
+      failurereason := 'Undersized packet';\r
+      state.resultaction := action_ignore;\r
+      exit;\r
+    end;\r
+    if state.id <> state.recvpacket.id then begin\r
+      failurereason := 'ID mismatch';\r
+      state.resultaction := action_ignore;\r
+      exit;\r
+    end;\r
+    state.numrr2 := 0;\r
+    for a := 0 to 3 do begin\r
+      state.numrr1[a] := htons(state.recvpacket.rrcount[a]);\r
+      if state.numrr1[a] > maxrrofakind then goto failure;\r
+      inc(state.numrr2,state.numrr1[a]);\r
+    end;\r
+\r
+    setlength(state.rrdata,state.numrr2*sizeof(trrpointer));\r
+\r
+    {- put all replies into a list}\r
+\r
+    ofs := 12;\r
+    {get all queries}\r
+    for a := 0 to state.numrr1[0]-1 do begin\r
+      if (ofs < 12) or (ofs > state.recvpacketlen-4) then goto failure;\r
+      rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
+      rrptemp.p := @state.recvpacket.payload[ofs-12];\r
+      rrptemp.ofs := ofs;\r
+      decodename(state.recvpacket,state.recvpacketlen,ofs,0,b);\r
+      rrptemp.len := b + 4;\r
+      inc(ofs,rrptemp.len);\r
+    end;\r
+\r
+    for a := state.numrr1[0] to state.numrr2-1 do begin\r
+      if (ofs < 12) or (ofs > state.recvpacketlen-12) then goto failure;\r
+      rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
+      if decodename(state.recvpacket,state.recvpacketlen,ofs,0,b) = '' then goto failure;\r
+      rrtemp := @state.recvpacket.payload[ofs-12+b]; {rrtemp points to values and result, after initial name}\r
+      rrptemp.p := rrtemp;\r
+      rrptemp.ofs := ofs; {ofs is start of RR before initial name from start of packet}\r
+      rrptemp.namelen := b;\r
+      b := htons(rrtemp.datalen);\r
+      rrptemp.len := b + 10 + rrptemp.namelen;\r
+      inc(ofs,rrptemp.len);\r
+    end;\r
+    if (ofs <> state.recvpacketlen) then begin\r
+      failurereason := 'ofs <> state.packetlen';\r
+      goto failure;\r
+    end;\r
+\r
+    {- check for items of the requested type in answer section, if so return success first}\r
+    for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin\r
+      rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
+      rrtemp := rrptemp.p;\r
+      b := rrptemp.len;\r
+      if rrtemp.requesttype = state.requesttype then begin\r
+        setstate_return(rrptemp^,b,state);\r
+        exit;\r
+      end;\r
+    end;\r
+\r
+    {if no items of correct type found, follow first cname in answer section}\r
+    for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin\r
+      rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
+      rrtemp := rrptemp.p;\r
+      b := rrptemp.len;\r
+      if rrtemp.requesttype = querytype_cname then begin\r
+        state.queryname := decodename(state.recvpacket,state.recvpacketlen,rrptemp.ofs+12,0,b);\r
+        goto recursed;\r
+      end;\r
+    end;\r
+\r
+    {no cnames found, no items of correct type found}\r
+    if state.forwardfamily <> 0 then goto failure;\r
+{$ifdef ipv6}\r
+    if (state.requesttype = querytype_a) then begin\r
+      {v6 only: in case of forward, look for AAAA in alternative section}\r
+      for a := state.numrr1[0]+state.numrr1[1]+state.numrr1[2] to (state.numrr2-1) do begin\r
+        rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
+        rrtemp := rrptemp.p;\r
+        b := rrptemp.len;\r
+        if rrtemp.requesttype = querytype_aaaa then begin\r
+          setstate_return(rrptemp^,b,state);\r
+          exit;\r
+        end;\r
+      end;\r
+      {no AAAA's found in alternative, do a recursive lookup for them}\r
+      state.requesttype := querytype_aaaa;\r
+      goto recursed;\r
+    end;\r
+{$endif}\r
+    goto failure;\r
+recursed:\r
+    {here it needs recursed lookup}\r
+    {if needing to follow a cname, change state to do so}\r
+    inc(state.recursioncount);\r
+    if state.recursioncount > maxrecursion then goto failure;\r
+  end;\r
+\r
+  {here, a name needs to be resolved}\r
+  if state.queryname = '' then begin\r
+    failurereason := 'empty query name';\r
+    goto failure;\r
+  end;\r
+\r
+  {do /ets/hosts lookup here}\r
+  state.sendpacketlen := buildrequest(state.queryname,state.sendpacket,state.requesttype);\r
+  if state.sendpacketlen = 0 then begin\r
+    failurereason := 'building request packet failed';\r
+    goto failure;\r
+  end;\r
+  state.id := state.sendpacket.id;\r
+  state.resultaction := action_sendquery;\r
+\r
+  exit;\r
+failure:\r
+  setstate_failure(state);\r
+end;\r
+{$ifdef win32}\r
+  const\r
+    MAX_HOSTNAME_LEN = 132;\r
+    MAX_DOMAIN_NAME_LEN = 132;\r
+    MAX_SCOPE_ID_LEN = 260    ;\r
+    MAX_ADAPTER_NAME_LENGTH = 260;\r
+    MAX_ADAPTER_ADDRESS_LENGTH = 8;\r
+    MAX_ADAPTER_DESCRIPTION_LENGTH = 132;\r
+    ERROR_BUFFER_OVERFLOW = 111;\r
+    MIB_IF_TYPE_ETHERNET = 6;\r
+    MIB_IF_TYPE_TOKENRING = 9;\r
+    MIB_IF_TYPE_FDDI = 15;\r
+    MIB_IF_TYPE_PPP = 23;\r
+    MIB_IF_TYPE_LOOPBACK = 24;\r
+    MIB_IF_TYPE_SLIP = 28;\r
+\r
+\r
+  type\r
+    tip_addr_string=packed record\r
+      Next :pointer;\r
+      IpAddress : array[0..15] of char;\r
+      ipmask    : array[0..15] of char;\r
+      context   : dword;\r
+    end;\r
+    pip_addr_string=^tip_addr_string;\r
+    tFIXED_INFO=packed record\r
+       HostName         : array[0..MAX_HOSTNAME_LEN-1] of char;\r
+       DomainName       : array[0..MAX_DOMAIN_NAME_LEN-1] of char;\r
+       currentdnsserver : pip_addr_string;\r
+       dnsserverlist    : tip_addr_string;\r
+       nodetype         : longint;\r
+       ScopeId          : array[0..MAX_SCOPE_ID_LEN + 4] of char;\r
+       enablerouting    : longbool;\r
+       enableproxy      : longbool;\r
+       enabledns        : longbool;\r
+    end;\r
+    pFIXED_INFO=^tFIXED_INFO;\r
+\r
+  var\r
+    iphlpapi : thandle;\r
+    getnetworkparams : function(pFixedInfo : PFIXED_INFO;OutBufLen : plongint) : longint;stdcall;\r
+{$endif}\r
+procedure populatednsserverlist;\r
+var\r
+  {$ifdef win32}\r
+    fixed_info : pfixed_info;\r
+    fixed_info_len : longint;\r
+    currentdnsserver : pip_addr_string;\r
+  {$else}\r
+    t:textfile;\r
+    s:string;\r
+    a:integer;\r
+  {$endif}\r
+begin\r
+  //result := '';\r
+  if assigned(dnsserverlist) then begin\r
+    dnsserverlist.clear;\r
+  end else begin\r
+    dnsserverlist := tstringlist.Create;\r
+  end;\r
+  {$ifdef win32}\r
+    if iphlpapi=0 then iphlpapi := loadlibrary('iphlpapi.dll');\r
+    if not assigned(getnetworkparams) then @getnetworkparams := getprocaddress(iphlpapi,'GetNetworkParams');\r
+    fixed_info_len := 0;\r
+    if GetNetworkParams(nil,@fixed_info_len)<>ERROR_BUFFER_OVERFLOW then exit;\r
+    //fixed_info_len :=sizeof(tfixed_info);\r
+    getmem(fixed_info,fixed_info_len);\r
+    if GetNetworkParams(fixed_info,@fixed_info_len)<>0 then begin\r
+      freemem(fixed_info);\r
+      exit;\r
+    end;\r
+    currentdnsserver := @(fixed_info.dnsserverlist);\r
+    while assigned(currentdnsserver) do begin\r
+      dnsserverlist.Add(currentdnsserver.IpAddress);\r
+      currentdnsserver := currentdnsserver.next;\r
+    end;\r
+    freemem(fixed_info);\r
+  {$else}\r
+    filemode := 0;\r
+    assignfile(t,'/etc/resolv.conf');\r
+    {$i-}reset(t);{$i+}\r
+    if ioresult <> 0 then exit;\r
+\r
+    while not eof(t) do begin\r
+      readln(t,s);\r
+      if not (copy(s,1,10) = 'nameserver') then continue;\r
+      s := copy(s,11,500);\r
+      while s <> '' do begin\r
+        if (s[1] = #32) or (s[1] = #9) then s := copy(s,2,500) else break;\r
+      end;\r
+      a := pos(' ',s);\r
+      if a <> 0 then s := copy(s,1,a-1);\r
+      a := pos(#9,s);\r
+      if a <> 0 then s := copy(s,1,a-1);\r
+      //result := s;\r
+      //if result <> '' then break;\r
+      dnsserverlist.Add(s);\r
+    end;\r
+    close(t);\r
+  {$endif}\r
+end;\r
+\r
+procedure cleardnsservercache;\r
+begin\r
+  if assigned(dnsserverlist) then begin\r
+    dnsserverlist.destroy;\r
+    dnsserverlist := nil;\r
+  end;\r
+end;\r
+\r
+function getcurrentsystemnameserver(var id:integer):string;\r
+var \r
+  counter : integer;\r
+\r
+begin\r
+  if not assigned(dnsserverlist) then populatednsserverlist;\r
+  if dnsserverlist.count=0 then raise exception.create('no dns servers availible');\r
+  id := 0;\r
+  if dnsserverlist.count >1 then begin\r
+\r
+    for counter := 1 to dnsserverlist.count-1 do begin\r
+      if taddrint(dnsserverlist.objects[counter]) < taddrint(dnsserverlist.objects[id]) then id := counter;\r
+    end;\r
+  end;\r
+  result := dnsserverlist[id]\r
+end;\r
+\r
+procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout\r
+var\r
+  counter : integer;\r
+  temp : integer;\r
+begin\r
+  if (id < 0) or (id >= dnsserverlist.count) then exit;\r
+  if lag = -1 then lag := timeoutlag;\r
+  for counter := 0 to dnsserverlist.count-1 do begin\r
+    temp := taddrint(dnsserverlist.objects[counter]) *15;\r
+    if counter=id then temp := temp + lag;\r
+    dnsserverlist.objects[counter] := tobject(temp div 16);\r
+  end;\r
+\r
+end;\r
+\r
+{  quick and dirty description of dns packet structure to aid writing and\r
+   understanding of parser code, refer to appropriate RFCs for proper specs\r
+- all words are network order\r
+\r
+www.google.com A request:\r
+\r
+0, 2: random transaction ID\r
+2, 2: flags: only the "recursion desired" bit set. (bit 8 of word)\r
+4, 2: questions: 1\r
+6, 2: answer RR's: 0.\r
+8, 2: authority RR's: 0.\r
+10, 2: additional RR's: 0.\r
+12, n: payload:\r
+  query:\r
+    #03 "www" #06 "google" #03 "com" #00\r
+    size-4, 2: type: host address (1)\r
+    size-2, 2: class: inet (1)\r
+\r
+reply:\r
+\r
+0,2: random transaction ID\r
+2,2: flags: set: response (bit 15), recursion desired (8), recursion available (7)\r
+4,4: questions: 1\r
+6,4: answer RR's: 2\r
+8,4: authority RR's: 9\r
+10,4: additional RR's: 9\r
+12: payload:\r
+  query:\r
+    ....\r
+  answer: CNAME\r
+    0,2 "c0 0c" "name: www.google.com"\r
+    2,2 "00 05" "type: cname for an alias"\r
+    4,2 "00 01" "class: inet"\r
+    6,4: TTL\r
+    10,2: data length "00 17" (23)\r
+    12: the cname name (www.google.akadns.net)\r
+  answer: A\r
+    0,2 ..\r
+    2,2 "00 01" host address\r
+    4,2 ...\r
+    6,4 ...\r
+    10,2: data length (4)\r
+    12,4: binary IP\r
+  authority - 9 records\r
+  additional - 9 records\r
+\r
+\r
+  ipv6 AAAA reply:\r
+    0,2: ...\r
+    2,2: type: 001c\r
+    4,2: class: inet (0001)\r
+    6,2: TTL\r
+    10,2: data size (16)\r
+    12,16: binary IP\r
+\r
+  ptr request: query type 000c\r
+\r
+name compression: word "cxxx" in the name, xxx points to offset in the packet}\r
+\r
+end.\r

diff --git a/dnssync.pas b/dnssync.pas
new file mode 100755 (executable)
index 0000000..379aa05
--- /dev/null
+++ b/dnssync.pas
@@ -0,0 +1,262 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+unit dnssync;\r
+{$ifdef fpc}\r
+  {$mode delphi}\r
+{$endif}\r
+\r
+interface\r
+  uses\r
+    dnscore,\r
+    binipstuff,\r
+    {$ifdef win32}\r
+      winsock,\r
+      windows,\r
+    {$else}\r
+      {$ifdef VER1_0}\r
+        linux,\r
+      {$else}\r
+        baseunix,unix,unixutil,\r
+      {$endif}\r
+      sockets,\r
+      fd_utils,\r
+    {$endif}\r
+    sysutils;\r
+\r
+//convert a name to an IP\r
+//IPV4 is preffered if availible, if not IPV6 will be returned (if ipv6 support\r
+//compiled in)\r
+//on error the binip will have a family of 0 (other fiels are also currently\r
+//zeroed out but may be used for further error information in future)\r
+//timeout is in seconds, it is ignored when using windows dns\r
+function forwardlookup(name:string;timeout:integer):tbinip;\r
+\r
+\r
+//convert an IP to a name, on error a null string will be returned, other \r
+//details as above\r
+function reverselookup(ip:tbinip;timeout:integer):string;\r
+\r
+\r
+var\r
+  dnssyncserver:string;\r
+  id : integer;\r
+  {$ifdef win32}\r
+    sendquerytime : integer;\r
+  {$else}\r
+    sendquerytime : ttimeval;\r
+  {$endif}\r
+implementation\r
+{$ifdef win32}\r
+  uses dnswin;\r
+{$endif}\r
+\r
+{$i unixstuff.inc}\r
+{$i ltimevalstuff.inc}\r
+\r
+var\r
+  fd:integer;\r
+  state:tdnsstate;\r
+{$ifdef win32}\r
+  const\r
+    winsocket = 'wsock32.dll';\r
+  function sendto(s: TSocket; const Buf; len, flags: Integer; var addrto: TinetSockAddr; tolen: Integer): Integer; stdcall; external    winsocket name 'sendto';\r
+  function bind(s: TSocket; var addr: TinetSockAddr; namelen: Integer): Longbool; stdcall; external    winsocket name 'bind';\r
+  type\r
+    fdset=tfdset;\r
+{$endif}\r
+\r
+function sendquery(const packet:tdnspacket;len:integer):boolean;\r
+var\r
+  a:integer;\r
+  addr       : string;\r
+  port       : string;\r
+  inaddr     : TInetSockAddr;\r
+\r
+begin\r
+{  writeln('sendquery ',decodename(state.packet,state.packetlen,12,0,a),' ',state.requesttype);}\r
+  result := false;\r
+  if len = 0 then exit; {no packet}\r
+\r
+  if dnssyncserver <> '' then addr := dnssyncserver else addr := getcurrentsystemnameserver(id);\r
+  port := '53';\r
+\r
+  inAddr.family:=AF_INET;\r
+  inAddr.port:=htons(strtointdef(port,0));\r
+  inAddr.addr:=htonl(longip(addr));\r
+\r
+  sendto(fd,packet,len,0,inaddr,sizeof(inaddr));\r
+  {$ifdef win32}\r
+    sendquerytime := GetTickCount and $3fff;\r
+  {$else}\r
+    gettimeofday(sendquerytime);\r
+  {$endif}\r
+  result := true;\r
+end;\r
+\r
+procedure setupsocket;\r
+var\r
+  inAddrtemp : TInetSockAddr;\r
+begin\r
+  if fd > 0 then exit;\r
+\r
+  fd := Socket(AF_INET,SOCK_DGRAM,0);\r
+  inAddrtemp.family:=AF_INET;\r
+  inAddrtemp.port:=0;\r
+  inAddrtemp.addr:=0;{htonl(longip('0.0.0.0'));}\r
+  If {$ifndef win32}Not{$endif} Bind(fd,inAddrtemp,SizeOf(inAddrtemp)) Then begin\r
+    {$ifdef win32}\r
+      raise Exception.create('unable to bind '+inttostr(WSAGetLastError));\r
+    {$else}\r
+      raise Exception.create('unable to bind '+inttostr(socketError));\r
+    {$endif}\r
+  end;\r
+end;\r
+\r
+procedure resolveloop(timeout:integer);\r
+var\r
+  selectresult   : integer;\r
+  fds            : fdset;\r
+  {$ifdef win32}\r
+    endtime      : longint;\r
+    starttime    : longint;\r
+    wrapmode     : boolean;\r
+    currenttime  : integer;\r
+  {$else}\r
+    endtime      : ttimeval;\r
+    currenttime    : ttimeval;\r
+\r
+  {$endif}\r
+  lag            : ttimeval;\r
+  currenttimeout : ttimeval;\r
+  selecttimeout         : ttimeval;\r
+\r
+\r
+begin\r
+  {$ifdef win32}\r
+    starttime := GetTickCount and $3fff;\r
+    endtime := starttime +(timeout*1000);\r
+    if (endtime and $4000)=0 then begin\r
+      wrapmode := false;\r
+    end else begin\r
+      wrapmode := true;\r
+    end;\r
+    endtime := endtime and $3fff;\r
+  {$else}\r
+    gettimeofday(endtime);\r
+    endtime.tv_sec := endtime.tv_sec + timeout;\r
+  {$endif}\r
+\r
+  setupsocket;\r
+  repeat\r
+    state_process(state);\r
+    case state.resultaction of\r
+      action_ignore: begin\r
+{        writeln('ignore');}\r
+        {do nothing}\r
+      end;\r
+      action_done: begin\r
+{        writeln('done');}\r
+        exit;\r
+        //onrequestdone(self,0);\r
+      end;\r
+      action_sendquery:begin\r
+{        writeln('send query');}\r
+        sendquery(state.sendpacket,state.sendpacketlen);\r
+      end;\r
+    end;\r
+    {$ifdef win32}\r
+      currenttime := GetTickCount and $3fff;\r
+      msectotimeval(selecttimeout, (endtime-currenttime)and$3fff);\r
+    {$else}\r
+      gettimeofday(currenttime);\r
+      selecttimeout := endtime;\r
+      tv_substract(selecttimeout,currenttime);\r
+    {$endif}\r
+    fd_zero(fds);\r
+    fd_set(fd,fds);\r
+    if (selecttimeout.tv_sec > 0) or (selecttimeout.tv_usec > retryafter) then begin\r
+      selecttimeout.tv_sec := 0;\r
+      selecttimeout.tv_usec := retryafter;\r
+    end;\r
+    selectresult := select(fd+1,@fds,nil,nil,@selecttimeout);\r
+    if selectresult > 0 then begin\r
+{      writeln('selectresult>0');}\r
+      //why the hell are we zeroing out the packet buffer before reading into it?! --plugwash\r
+      fillchar(state.recvpacket,sizeof(state.recvpacket),0);\r
+      {$ifdef win32}\r
+        msectotimeval(lag,(currenttime-sendquerytime)and$3fff);\r
+      {$else}\r
+        lag := currenttime;\r
+        tv_substract(lag,sendquerytime);\r
+\r
+      {$endif}\r
+\r
+      reportlag(id,(lag.tv_sec*1000000)+lag.tv_usec);\r
+      state.recvpacketlen := recv(fd,state.recvpacket, SizeOf(state.recvpacket),0);\r
+      state.parsepacket := true;\r
+    end;\r
+    if selectresult < 0 then exit;\r
+    if selectresult = 0 then begin\r
+      {$ifdef win32}\r
+        currenttime := GetTickCount;\r
+      {$else}\r
+        gettimeofday(currenttime);\r
+      {$endif}\r
+      reportlag(id,-1);\r
+      if {$ifdef win32}(currenttime >= endtime)and ((not wrapmode) or (currenttime < starttime)) {$else}tv_compare(currenttime,endtime){$endif} {currenttime >= endtime } then begin\r
+        exit;\r
+      end else begin\r
+        //resend\r
+        sendquery(state.sendpacket,state.sendpacketlen);\r
+      end;\r
+    end;\r
+  until false;\r
+end;\r
+\r
+function forwardlookup(name:string;timeout:integer):tbinip;\r
+var\r
+  dummy : integer;\r
+begin\r
+  ipstrtobin(name,result);\r
+  if result.family <> 0 then exit; //it was an IP address, no need for dns\r
+                                   //lookup\r
+  {$ifdef win32}\r
+    if usewindns then begin\r
+      result := winforwardlookup(name,false,dummy);\r
+      exit;\r
+    end;\r
+  {$endif}\r
+  setstate_forward(name,state,0);\r
+  resolveloop(timeout);\r
+  result := state.resultbin;\r
+end;\r
+\r
+function reverselookup(ip:tbinip;timeout:integer):string;\r
+var\r
+  dummy : integer;\r
+begin\r
+  {$ifdef win32}\r
+    if usewindns then begin\r
+      result := winreverselookup(ip,dummy);\r
+      exit;\r
+    end;\r
+  {$endif}\r
+  setstate_reverse(ip,state);\r
+  resolveloop(timeout);\r
+  result := state.resultstr;\r
+end;\r
+\r
+{$ifdef win32}\r
+  var\r
+    wsadata : twsadata;\r
+\r
+  initialization\r
+    WSAStartUp($2,wsadata);\r
+  finalization\r
+    WSACleanUp;\r
+{$endif}\r
+end.\r
+\r
+\r

diff --git a/dnswin.pas b/dnswin.pas
new file mode 100755 (executable)
index 0000000..7d986d1
--- /dev/null
+++ b/dnswin.pas
@@ -0,0 +1,332 @@
+unit dnswin;\r
+\r
+interface\r
+uses binipstuff,classes,lcore;\r
+\r
+//on failure a null string or zeroed out binip will be retuned and error will be\r
+//set to a windows error code (error will be left untouched under non error\r
+//conditions).\r
+function winforwardlookup(name : string;ipv6preffered : boolean;var error:integer) : tbinip;\r
+function winreverselookup(ip:tbinip;var error:integer):string;\r
+\r
+\r
+type\r
+  //do not call destroy on a tdnswinasync instead call release and the\r
+  //dnswinasync will be freed when appropriate. Calling destroy will block\r
+  //the calling thread until the dns lookup completes.\r
+  //release should only be called from the main thread\r
+  tdnswinasync=class(tthread)\r
+  private\r
+    ipv6preffered : boolean;\r
+    freverse : boolean;\r
+    error : integer;\r
+    freewhendone : boolean;\r
+    hadevent : boolean;\r
+  protected\r
+    procedure execute; override;\r
+  public\r
+    onrequestdone:tsocketevent;\r
+    name : string;\r
+    ip : tbinip;\r
+\r
+    procedure forwardlookup(name:string;ipv6preffered:boolean);\r
+    procedure reverselookup(ip:tbinip);\r
+    destructor destroy; override;\r
+    procedure release;\r
+    constructor create;\r
+    property reverse : boolean read freverse;\r
+\r
+  end;\r
+\r
+implementation\r
+uses\r
+  lsocket,pgtypes,sysutils,winsock,windows,messages;\r
+\r
+type\r
+  //taddrinfo = record; //forward declaration\r
+  paddrinfo = ^taddrinfo;\r
+  taddrinfo = packed record\r
+    ai_flags : longint;\r
+    ai_family : longint;\r
+    ai_socktype : longint;\r
+    ai_protocol : longint;\r
+    ai_addrlen : taddrint;\r
+    ai_canonname : pchar;\r
+    ai_addr : pinetsockaddrv;\r
+    ai_next : paddrinfo;\r
+  end;\r
+  ppaddrinfo = ^paddrinfo;\r
+  tgetaddrinfo = function(nodename : pchar; servname : pchar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall;\r
+  tfreeaddrinfo = procedure(ai : paddrinfo); stdcall;\r
+  tgetnameinfo = function(sa:Pinetsockaddrv;salen : longint; host:pchar;hostlen : longint;serv:pchar;servlen:longint;flags:longint) : longint;stdcall;\r
+var\r
+  getaddrinfo : tgetaddrinfo;\r
+  freeaddrinfo : tfreeaddrinfo;\r
+  getnameinfo : tgetnameinfo;\r
+procedure v4onlyfreeaddrinfo(ai : paddrinfo); stdcall;\r
+begin\r
+  freemem(ai.ai_addr);\r
+  freemem(ai);\r
+end;\r
+\r
+type\r
+  plongint = ^longint;\r
+  pplongint = ^plongint;\r
+\r
+function v4onlygetaddrinfo(nodename : pchar; servname : pchar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall;\r
+var\r
+  output : paddrinfo;\r
+  hostent : phostent;\r
+begin\r
+  if hints.ai_family = af_inet then begin\r
+    result := 0;\r
+    getmem(output,sizeof(taddrinfo));\r
+    getmem(output.ai_addr,sizeof(tinetsockaddr));\r
+    output.ai_addr.InAddr.family := af_inet;\r
+    if servname <> nil then output.ai_addr.InAddr.port := htons(strtoint(servname)) else output.ai_addr.InAddr.port := 0;\r
+    hostent := gethostbyname(nodename);\r
+    if hostent = nil then begin\r
+      result := wsagetlasterror;\r
+      v4onlyfreeaddrinfo(output);\r
+      exit;\r
+    end;\r
+    output.ai_addr.InAddr.addr := pplongint(hostent.h_addr_list)^^;\r
+    output.ai_flags := 0;\r
+    output.ai_family := af_inet;\r
+    output.ai_socktype := 0;\r
+    output.ai_protocol := 0;\r
+    output.ai_addrlen := sizeof(tinetsockaddr);\r
+    output.ai_canonname := nil;\r
+    output.ai_next := nil;\r
+\r
+    res^ := output;\r
+  end else begin\r
+    result := WSANO_RECOVERY;\r
+  end;\r
+end;\r
+\r
+function min(a,b : integer):integer;\r
+begin\r
+  if a<b then result := a else result := b;\r
+end;\r
+\r
+function v4onlygetnameinfo(sa:Pinetsockaddrv;salen : longint; host:pchar;hostlen : longint;serv:pchar;servlen:longint;flags:longint) : longint;stdcall;\r
+var\r
+  hostent : phostent;\r
+  bytestocopy : integer;\r
+begin\r
+  if sa.InAddr.family = af_inet then begin\r
+    result := 0;\r
+    hostent := gethostbyaddr(@(sa.inaddr.addr),4,AF_INET);\r
+    if hostent = nil then begin\r
+      result := wsagetlasterror;\r
+      exit;\r
+    end;\r
+    bytestocopy := min(strlen(hostent.h_name)+1,hostlen);\r
+    move((hostent.h_name)^,host^,bytestocopy);\r
+\r
+\r
+  end else begin\r
+    result := WSANO_RECOVERY;\r
+  end;\r
+end;\r
+\r
+\r
+procedure populateprocvars;\r
+var\r
+  libraryhandle : hmodule;\r
+  i : integer;\r
+  dllname : string;\r
+\r
+begin\r
+  if assigned(getaddrinfo) then exit; //procvars already populated\r
+  for i := 0 to 1 do begin\r
+    if i=0 then dllname := 'Ws2_32.dll' else dllname := 'Wship6.dll';\r
+    libraryhandle := LoadLibrary(pchar(dllname));\r
+    getaddrinfo := getprocaddress(libraryhandle,'getaddrinfo');\r
+    freeaddrinfo := getprocaddress(libraryhandle,'freeaddrinfo');\r
+    getnameinfo := getprocaddress(libraryhandle,'getnameinfo');\r
+    if assigned(getaddrinfo) and assigned(freeaddrinfo) and assigned(getnameinfo) then begin\r
+      //writeln('found getaddrinfo and freeaddrinfo in'+dllname);\r
+      exit; //success\r
+    end;\r
+\r
+  end;\r
+  //writeln('could not find getaddrinfo and freeaddrinfo, falling back to ipv4 only lookup');\r
+  getaddrinfo := v4onlygetaddrinfo;\r
+  freeaddrinfo := v4onlyfreeaddrinfo;\r
+  getnameinfo := v4onlygetnameinfo;\r
+end;\r
+\r
+\r
+function winforwardlookup(name : string;ipv6preffered : boolean;var error : integer) : tbinip;\r
+var\r
+  hints: taddrinfo;\r
+  res : paddrinfo;\r
+  pass : boolean;\r
+  ipv6 : boolean;\r
+  getaddrinforesult : integer;\r
+begin\r
+  populateprocvars;\r
+\r
+  for pass := false to true do begin\r
+    ipv6 := ipv6preffered xor pass;\r
+    hints.ai_flags := 0;\r
+    if ipv6 then begin\r
+      hints.ai_family := AF_INET6;\r
+    end else begin\r
+      hints.ai_family := AF_INET;\r
+    end;\r
+    hints.ai_socktype := 0;\r
+    hints.ai_protocol := 0;\r
+    hints.ai_addrlen := 0;\r
+    hints.ai_canonname := nil;\r
+    hints.ai_addr := nil;\r
+    hints.ai_next := nil;\r
+    getaddrinforesult := getaddrinfo(pchar(name),'1',@hints,@res);\r
+    if getaddrinforesult = 0 then begin\r
+      if res.ai_family = af_inet then begin\r
+        result.family := af_inet;\r
+        result.ip := res.ai_addr.InAddr.addr;\r
+      end else {$ifdef ipv6}if res.ai_family = af_inet6 then begin\r
+        result.family := af_inet6;\r
+        result.ip6 := res.ai_addr.InAddr6.sin6_addr;\r
+      end;{$endif};\r
+\r
+      freeaddrinfo(res);\r
+      exit;\r
+    end;\r
+  end;\r
+  if getaddrinforesult <> 0 then begin\r
+    fillchar(result,0,sizeof(result));\r
+    error := getaddrinforesult;\r
+  end;\r
+end;\r
+\r
+function winreverselookup(ip:tbinip;var error : integer):string;\r
+var\r
+  sa : tinetsockaddrv;\r
+  getnameinforesult : integer;\r
+begin\r
+\r
+  if ip.family = AF_INET then begin\r
+    sa.InAddr.family := AF_INET;\r
+    sa.InAddr.port := 1;\r
+    sa.InAddr.addr := ip.ip;\r
+  end else {$ifdef ipv6}if ip.family = AF_INET6 then begin\r
+    sa.InAddr6.sin6_family  := AF_INET6;\r
+    sa.InAddr6.sin6_port := 1;\r
+    sa.InAddr6.sin6_addr := ip.ip6;\r
+  end else{$endif} begin\r
+    raise exception.create('unrecognised address family');\r
+  end;\r
+  populateprocvars;\r
+  setlength(result,1025);\r
+  getnameinforesult := getnameinfo(@sa,sizeof(tinetsockaddrv),pchar(result),length(result),nil,0,0);\r
+  if getnameinforesult <> 0 then begin\r
+    error := getnameinforesult;\r
+    result := '';\r
+    exit;\r
+  end;\r
+  if pos(#0,result) >= 0 then begin\r
+    setlength(result,pos(#0,result)-1);\r
+  end;\r
+end;\r
+\r
+var\r
+  hwnddnswin : hwnd;\r
+\r
+function MyWindowProc(\r
+    ahWnd   : HWND;\r
+    auMsg   : Integer;\r
+    awParam : WPARAM;\r
+    alParam : LPARAM): Integer; stdcall;\r
+var\r
+  dwas : tdnswinasync;\r
+begin\r
+  if (ahwnd=hwnddnswin) and (aumsg=wm_user) then begin\r
+    Dwas := tdnswinasync(alparam);\r
+    if assigned (dwas.onrequestdone) then dwas.onrequestdone(dwas,awparam);\r
+    dwas.hadevent := true;\r
+    if dwas.freewhendone then dwas.free;\r
+  end else begin\r
+    //not passing unknown messages on to defwindowproc will cause window\r
+    //creation to fail! --plugwash\r
+    Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)\r
+  end;\r
+end;\r
+\r
+procedure tdnswinasync.forwardlookup(name:string;ipv6preffered:boolean);\r
+begin\r
+  self.name := name;\r
+  self.ipv6preffered := ipv6preffered;\r
+  freverse := false;\r
+  resume;\r
+end;\r
+procedure tdnswinasync.reverselookup(ip:tbinip);\r
+begin\r
+  self.ip := ip;\r
+  freverse := true;\r
+  resume;\r
+end;\r
+procedure tdnswinasync.execute;\r
+var\r
+  error : integer;\r
+begin\r
+  error := 0;\r
+  if reverse then begin\r
+    name := winreverselookup(ip,error);\r
+  end else begin\r
+    ip := winforwardlookup(name,ipv6preffered,error);\r
+\r
+  end;\r
+\r
+  postmessage(hwnddnswin,wm_user,error,taddrint(self));\r
+end;\r
+\r
+destructor tdnswinasync.destroy; \r
+begin\r
+  WaitFor;\r
+  inherited destroy;\r
+end;\r
+procedure tdnswinasync.release;\r
+begin\r
+  if hadevent then destroy else begin\r
+    onrequestdone := nil;\r
+    freewhendone := true;\r
+  end;\r
+end;\r
+\r
+constructor tdnswinasync.create;\r
+begin\r
+  inherited create(true);\r
+end;\r
+\r
+var\r
+  MyWindowClass : TWndClass = (style         : 0;\r
+                                 lpfnWndProc   : @MyWindowProc;\r
+                                 cbClsExtra    : 0;\r
+                                 cbWndExtra    : 0;\r
+                                 hInstance     : 0;\r
+                                 hIcon         : 0;\r
+                                 hCursor       : 0;\r
+                                 hbrBackground : 0;\r
+                                 lpszMenuName  : nil;\r
+                                 lpszClassName : 'dnswinClass');\r
+begin\r
+\r
+    if Windows.RegisterClass(MyWindowClass) = 0 then halt;\r
+  //writeln('about to create lcore handle, hinstance=',hinstance);\r
+  hwnddnswin := CreateWindowEx(WS_EX_TOOLWINDOW,\r
+                               MyWindowClass.lpszClassName,\r
+                               '',        { Window name   }\r
+                               WS_POPUP,  { Window Style  }\r
+                               0, 0,      { X, Y          }\r
+                               0, 0,      { Width, Height }\r
+                               0,         { hWndParent    }\r
+                               0,         { hMenu         }\r
+                               HInstance, { hInstance     }\r
+                               nil);      { CreateParam   }\r
+  //writeln('dnswin hwnd is ',hwnddnswin);\r
+  //writeln('last error is ',GetLastError);\r
+end.\r

diff --git a/fd_utils.pas b/fd_utils.pas
new file mode 100755 (executable)
index 0000000..ea6e833
--- /dev/null
+++ b/fd_utils.pas
@@ -0,0 +1,74 @@
+// this file contains code copied from linux.pp in the free pascal rtl\r
+// i had to copy them because i use a different definition of fdset to them\r
+// the copyright block from the file in question is shown below\r
+{\r
+   $Id: fd_utils.pas,v 1.2 2004/08/19 23:12:09 plugwash Exp $\r
+   This file is part of the Free Pascal run time library.\r
+   Copyright (c) 1999-2000 by Michael Van Canneyt,\r
+   BSD parts (c) 2000 by Marco van de Voort\r
+   members of the Free Pascal development team.\r
+\r
+   See the file COPYING.FPC, included in this distribution,\r
+   for details about the copyright.\r
+\r
+   This program is distributed in the hope that it will be useful,\r
+   but WITHOUT ANY WARRANTY;without even the implied warranty of\r
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\r
+\r
+**********************************************************************}\r
+{$ifdef fpc}\r
+  {$mode delphi}\r
+  {$inlining on}\r
+{$endif}\r
+unit fd_utils;\r
+interface\r
+\r
+type\r
+    FDSet= Array [0..255] of longint; {31}\r
+    PFDSet= ^FDSet;\r
+const\r
+    absoloutemaxs=(sizeof(fdset)*8)-1;\r
+\r
+Procedure FD_Clr(fd:longint;var fds:fdSet);\r
+Procedure FD_Zero(var fds:fdSet);\r
+Procedure FD_Set(fd:longint;var fds:fdSet);\r
+Function FD_IsSet(fd:longint;var fds:fdSet):boolean;\r
+
+{$ifdef fpc}
+  {$ifndef ver1_0}
+    {$define useinline}
+  {$endif}
+{$endif}\r
+\r
+implementation  \r
+uses sysutils;\r
+Procedure FD_Clr(fd:longint;var fds:fdSet);{$ifdef useinline}inline;{$endif}\r
+{ Remove fd from the set of filedescriptors}\r
+begin\r
+  if (fd < 0) then raise exception.create('FD_Clr fd out of range: '+inttostr(fd));\r
+  fds[fd shr 5]:=fds[fd shr 5] and (not (1 shl (fd and 31)));\r
+end;\r
+\r
+Procedure FD_Zero(var fds:fdSet);\r
+{ Clear the set of filedescriptors }\r
+begin\r
+  FillChar(fds,sizeof(fdSet),0);\r
+end;\r
+\r
+Procedure FD_Set(fd:longint;var fds:fdSet);{$ifdef useinline}inline;{$endif}\r
+{ Add fd to the set of filedescriptors }\r
+begin\r
+  if (fd < 0) then raise exception.create('FD_set fd out of range: '+inttostr(fd));\r
+  fds[fd shr 5]:=fds[fd shr 5] or (1 shl (fd and 31));\r
+end;\r
+\r
+Function FD_IsSet(fd:longint;var fds:fdSet):boolean;{$ifdef useinline}inline;{$endif}\r
+{ Test if fd is part of the set of filedescriptors }\r
+begin\r
+  if (fd < 0) then begin\r
+    result := false;\r
+    exit;\r
+  end;\r
+  FD_IsSet:=((fds[fd shr 5] and (1 shl (fd and 31)))<>0);\r
+end;\r
+end.\r

diff --git a/httpserver_20080306/bfifo.pas b/httpserver_20080306/bfifo.pas
new file mode 100755 (executable)
index 0000000..55cc24a
--- /dev/null
+++ b/httpserver_20080306/bfifo.pas
@@ -0,0 +1,148 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+unit bfifo;\r
+{$ifdef fpc}\r
+  {$mode delphi}\r
+{$endif}\r
+\r
+interface\r
+\r
+uses blinklist,pgtypes;\r
+\r
+const\r
+  pagesize=1420;\r
+\r
+type\r
+  tfifo=class(tobject)\r
+  private\r
+    l:tlinklist;     {add to}\r
+    getl:tlinklist; {remove from}\r
+    ofs:integer;\r
+    getofs:integer;\r
+  public\r
+    size:integer;\r
+    procedure add(data:pointer;len:integer);\r
+    function get(var resultptr:pointer;len:integer):integer;\r
+    procedure del(len:integer);\r
+    constructor create;\r
+    destructor destroy; override;\r
+  end;\r
+\r
+\r
+implementation\r
+\r
+var\r
+  testcount:integer;\r
+\r
+{\r
+\r
+xx1..... add\r
+xxxxxxxx\r
+....2xxx delete\r
+\r
+1 ofs\r
+2 getofs\r
+\r
+}\r
+\r
+procedure tfifo.add;\r
+var\r
+  a:integer;\r
+  p:tlinklist;\r
+begin\r
+  if len <= 0 then exit;\r
+  inc(size,len);\r
+  while len > 0 do begin\r
+    p := l;\r
+    if ofs = pagesize then begin\r
+      p := tplinklist.create;\r
+      if getl = nil then getl := p;\r
+      getmem(tplinklist(p).p,pagesize);\r
+      inc(testcount);\r
+      linklistadd(l,p);\r
+      ofs := 0;\r
+    end;\r
+    a := pagesize - ofs;\r
+    if len < a then a := len;\r
+    move(data^,pointer(taddrint(tplinklist(p).p)+ofs)^,a);\r
+    inc(taddrint(data),a);\r
+    dec(len,a);\r
+    inc(ofs,a);\r
+  end;\r
+end;\r
+\r
+function tfifo.get;\r
+var\r
+  p:tlinklist;\r
+  a:integer;\r
+begin\r
+  if len > size then len := size;\r
+  if len <= 0 then begin\r
+    result := 0;\r
+    resultptr := nil;\r
+    exit;\r
+  end;\r
+  p := getl;\r
+  resultptr := pointer(taddrint(tplinklist(p).p)+getofs);\r
+  result := pagesize-getofs;\r
+  if result > len then result := len;\r
+end;\r
+\r
+procedure tfifo.del;\r
+var\r
+  a:integer;\r
+  p,p2:tlinklist;\r
+begin\r
+  if len <= 0 then exit;\r
+  p := getl;\r
+  if len > size then len := size;\r
+  dec(size,len);\r
+\r
+  if len = 0 then exit;\r
+\r
+  while len > 0 do begin\r
+    a := pagesize-getofs;\r
+    if a > len then a := len;\r
+    inc(getofs,a);\r
+    dec(len,a);\r
+    if getofs = pagesize then begin\r
+      p2 := p.prev;\r
+      freemem(tplinklist(p).p);\r
+      dec(testcount);\r
+      linklistdel(l,p);\r
+      p.destroy;\r
+      p := p2;\r
+      getl := p;\r
+      getofs := 0;\r
+    end;\r
+  end;\r
+\r
+  if size = 0 then begin\r
+    if assigned(l) then begin\r
+      p := l;\r
+      freemem(tplinklist(p).p);\r
+      dec(testcount);\r
+      linklistdel(l,p);\r
+      p.destroy;\r
+      getl := nil;\r
+    end;\r
+    ofs := pagesize;\r
+    getofs := 0;\r
+  end;\r
+end;\r
+\r
+constructor tfifo.create;\r
+begin\r
+  ofs := pagesize;\r
+  inherited create;\r
+end;\r
+\r
+destructor tfifo.destroy;\r
+begin\r
+  del(size);\r
+  inherited destroy;\r
+end;\r
+\r
+end.\r

diff --git a/httpserver_20080306/binipstuff.pas b/httpserver_20080306/binipstuff.pas
new file mode 100755 (executable)
index 0000000..ebb9f9c
--- /dev/null
+++ b/httpserver_20080306/binipstuff.pas
@@ -0,0 +1,395 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+unit binipstuff;\r
+\r
+interface\r
+\r
+{$ifndef win32}\r
+{$ifdef ipv6}\r
+uses sockets;\r
+{$endif}\r
+{$endif}\r
+\r
+{$ifdef fpc}\r
+  {$mode delphi}\r
+{$endif}\r
+{$ifdef cpu386}{$define i386}{$endif}\r
+{$ifdef i386}{$define ENDIAN_LITTLE}{$endif}\r
+\r
+{$include uint32.inc}\r
+\r
+const\r
+  hexchars:array[0..15] of char='0123456789abcdef';\r
+  AF_INET=2;\r
+  {$ifdef win32}\r
+    AF_INET6=23;\r
+  {$else}\r
+    AF_INET6=10;\r
+  {$endif}\r
+\r
+type\r
+  {$ifdef ipv6}\r
+    \r
+    {$ifdef win32}\r
+      {$define want_Tin6_addr}\r
+    {$endif}\r
+    {$ifdef ver1_0}\r
+      {$define want_Tin6_addr}\r
+    {$endif}\r
+    {$ifdef want_Tin6_addr}\r
+      Tin6_addr = packed record\r
+        case byte of\r
+          0: (u6_addr8  : array[0..15] of byte);\r
+          1: (u6_addr16 : array[0..7] of Word);\r
+          2: (u6_addr32 : array[0..3] of uint32);\r
+          3: (s6_addr8  : array[0..15] of shortint);\r
+          4: (s6_addr   : array[0..15] of shortint);\r
+          5: (s6_addr16 : array[0..7] of smallint);\r
+          6: (s6_addr32 : array[0..3] of LongInt);\r
+      end;\r
+    {$endif}\r
+  {$endif}\r
+\r
+  tbinip=record\r
+    family:integer;\r
+    {$ifdef ipv6}\r
+      case integer of\r
+        0: (ip:longint);\r
+        1: (ip6:tin6_addr);\r
+    {$else}\r
+      ip:longint;\r
+    {$endif}\r
+  end;\r
+\r
+  {$ifdef win32}\r
+    TInetSockAddr = packed Record\r
+      family:Word;\r
+      port  :Word;\r
+      addr  :uint32;\r
+      pad   :array [1..8] of byte;\r
+    end;\r
+    {$ifdef ipv6}\r
+\r
+      TInetSockAddr6 = packed record\r
+        sin6_family: word;\r
+        sin6_port: word;\r
+        sin6_flowinfo: uint32;\r
+        sin6_addr: tin6_addr;\r
+        sin6_scope_id: uint32;\r
+      end;\r
+    {$endif}\r
+  {$endif}\r
+\r
+function htons(w:word):word;\r
+function htonl(i:uint32):uint32;\r
+\r
+function ipstrtobin(const s:string;var binip:tbinip):boolean;\r
+function ipbintostr(const binip:tbinip):string;\r
+{$ifdef ipv6}\r
+function ip6bintostr(const bin:tin6_addr):string;\r
+function ip6strtobin(const s:string;var bin:tin6_addr):boolean;\r
+{$endif}\r
+\r
+function comparebinip(const ip1,ip2:tbinip):boolean;\r
+\r
+{deprecated}\r
+function longip(s:string):longint;\r
+\r
+procedure converttov4(var ip:tbinip);\r
+\r
+implementation\r
+\r
+uses sysutils;\r
+\r
+function htons(w:word):word;\r
+begin\r
+  {$ifdef ENDIAN_LITTLE}\r
+  result := ((w and $ff00) shr 8) or ((w and $ff) shl 8);\r
+  {$else}\r
+  result := w;\r
+  {$endif}\r
+end;\r
+\r
+function htonl(i:uint32):uint32;\r
+begin\r
+  {$ifdef ENDIAN_LITTLE}\r
+  result := (i shr 24) or (i shr 8 and $ff00) or (i shl 8 and $ff0000) or (i shl 24 and $ff000000);\r
+  {$else}\r
+  result := i;\r
+  {$endif}\r
+end;\r
+\r
+{internal}\r
+{converts dotted v4 IP to longint. returns host endian order}\r
+function longip(s:string):longint;\r
+var\r
+  l:longint;\r
+  a,b:integer;\r
+function convertbyte(const s:string):integer;\r
+begin\r
+  result := strtointdef(s,-1);\r
+  if result < 0 then begin\r
+    result := -1;\r
+    exit;\r
+  end;\r
+  if result > 255 then begin\r
+    result := -1;\r
+    exit;\r
+  end;\r
+  {01 exception}\r
+  if (result <> 0) and (s[1] = '0') then begin\r
+    result := -1;\r
+    exit;\r
+  end;\r
+  {+1 exception}\r
+  if not (s[1] in ['0'..'9']) then begin\r
+    result := -1;\r
+    exit\r
+  end;\r
+end;\r
+\r
+begin\r
+  result := 0;\r
+  a := pos('.',s);\r
+  if a = 0 then exit;\r
+  b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+  l := b shl 24;\r
+  s := copy(s,a+1,256);\r
+  a := pos('.',s);\r
+  if a = 0 then exit;\r
+  b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+  l := l or b shl 16;\r
+  s := copy(s,a+1,256);\r
+  a := pos('.',s);\r
+  if a = 0 then exit;\r
+  b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+  l := l or b shl 8;\r
+  s := copy(s,a+1,256);\r
+  b := convertbyte(copy(s,1,256));if (b < 0) then exit;\r
+  l := l or b;\r
+  result := l;\r
+end;\r
+\r
+\r
+function ipstrtobin(const s:string;var binip:tbinip):boolean;\r
+begin\r
+  binip.family := 0;\r
+  result := false;\r
+  {$ifdef ipv6}\r
+  if pos(':',s) <> 0 then begin\r
+    {try ipv6. use builtin routine}\r
+    result := ip6strtobin(s,binip.ip6);\r
+    if result then binip.family := AF_INET6;\r
+    exit;\r
+  end;\r
+  {$endif}\r
+\r
+  {try v4}\r
+  binip.ip := htonl(longip(s));\r
+  if (binip.ip <> 0) or (s = '0.0.0.0') then begin\r
+    result := true;\r
+    binip.family := AF_INET;\r
+    exit;\r
+  end;\r
+end;\r
+\r
+function ipbintostr(const binip:tbinip):string;\r
+var\r
+  a:integer;\r
+begin\r
+  result := '';\r
+  {$ifdef ipv6}\r
+  if binip.family = AF_INET6 then begin\r
+    result := ip6bintostr(binip.ip6);\r
+  end else\r
+  {$endif}\r
+  if binip.family = AF_INET then begin\r
+    a := htonl(binip.ip);\r
+    result := inttostr(a shr 24)+'.'+inttostr((a shr 16) and $ff)+'.'+inttostr((a shr 8) and $ff)+'.'+inttostr(a and $ff);\r
+  end;\r
+end;\r
+\r
+\r
+{------------------------------------------------------------------------------}\r
+\r
+{$ifdef ipv6}\r
+\r
+{\r
+IPv6 address binary to/from string conversion routines\r
+written by beware (steendijk at xs4all dot nl)\r
+\r
+- implementation does not depend on other ipv6 code such as the tin6_addr type,\r
+  the parameter can also be untyped.\r
+- it is host endian neutral - binary format is aways network order\r
+- it supports compression of zeroes\r
+- it supports ::ffff:192.168.12.34 style addresses\r
+- they are made to do the Right Thing, more efficient implementations are possible\r
+}\r
+\r
+{fpc has hostaddrtostr6 and strtohostaddr6 but the later isnt implemented yet}\r
+\r
+\r
+function ip6bintostr(const bin:tin6_addr):string;\r
+{base16 with lowercase output}\r
+function makehex(w:word):string;\r
+begin\r
+  result := '';\r
+  if w >= 4096 then result := result + hexchars[w shr 12];\r
+  if w >= 256 then result := result + hexchars[w shr 8 and $f];\r
+  if w >= 16 then result := result + hexchars[w shr 4 and $f];\r
+  result := result + hexchars[w and $f];\r
+end;\r
+\r
+var\r
+  a,b,c,addrlen:integer;\r
+  runbegin,runlength:integer;\r
+  bytes:array[0..15] of byte absolute bin;\r
+  words:array[0..7] of word;\r
+  dwords:array[0..3] of integer absolute words;\r
+begin\r
+  for a := 0 to 7 do begin\r
+    words[a] := bytes[a shl 1] shl 8 or bytes[a shl 1 or 1];\r
+  end;\r
+  if (dwords[0] = 0) and (dwords[1] = 0) and (words[4] = 0) and (words[5] = $ffff) then begin\r
+    {::ffff:/96 exception: v4 IP}\r
+    addrlen := 6;\r
+  end else begin\r
+    addrlen := 8;\r
+  end;\r
+  {find longest run of zeroes}\r
+  runbegin := 0;\r
+  runlength := 0;\r
+  for a := 0 to addrlen-1 do begin\r
+    if words[a] = 0 then begin\r
+      c := 0;\r
+      for b := a to addrlen-1 do if words[b] = 0 then begin\r
+        inc(c);\r
+      end else break;\r
+      if (c > runlength) then begin\r
+        runlength := c;\r
+        runbegin := a;\r
+      end;\r
+    end;\r
+  end;\r
+  result := '';\r
+  for a := 0 to runbegin-1 do begin\r
+    if (a <> 0) then result := result + ':';\r
+    result := result + makehex(words[a]);\r
+  end;\r
+  if runlength > 0 then result := result + '::';\r
+  c := runbegin+runlength;\r
+  for a := c to addrlen-1 do begin\r
+    if (a > c) then result := result + ':';\r
+    result := result + makehex(words[a]);\r
+  end;\r
+  if addrlen = 6 then begin\r
+    result := result + ':'+inttostr(bytes[12])+'.'+inttostr(bytes[13])+'.'+inttostr(bytes[14])+'.'+inttostr(bytes[15]);\r
+  end;\r
+end;\r
+\r
+function ip6strtobin(const s:string;var bin:tin6_addr):boolean;\r
+var\r
+  a,b:integer;\r
+  fields:array[0..7] of string;\r
+  fieldcount:integer;\r
+  emptyfield:integer;\r
+  wordcount:integer;\r
+  words:array[0..7] of word;\r
+  bytes:array[0..15] of byte absolute bin;\r
+begin\r
+  result := false;\r
+  for a := 0 to 7 do fields[a] := '';\r
+  fieldcount := 0;\r
+  for a := 1 to length(s) do begin\r
+    if s[a] = ':' then inc(fieldcount) else fields[fieldcount] := fields[fieldcount] + s[a];\r
+    if fieldcount > 7 then exit;\r
+  end;\r
+  if fieldcount < 2 then exit;\r
+\r
+  {find the empty field (compressed zeroes), not counting the first and last there may be at most 1}\r
+  emptyfield := -1;\r
+  for a := 1 to fieldcount-1 do begin\r
+    if fields[a] = '' then begin\r
+      if emptyfield = -1 then emptyfield := a else exit;\r
+    end;\r
+  end;\r
+\r
+  {check if last field is a valid v4 IP}\r
+  a := longip(fields[fieldcount]);\r
+  if (a <> 0) or (fields[fieldcount] = '0.0.0.0') then wordcount := 6 else wordcount := 8;\r
+  {0:1:2:3:4:5:6.6.6.6\r
+   0:1:2:3:4:5:6:7}\r
+  fillchar(words,sizeof(words),0);\r
+  if wordcount = 6 then begin\r
+    if fieldcount > 6 then exit;\r
+    words[6] := a shr 16;\r
+    words[7] := a and $ffff;\r
+  end;\r
+  if emptyfield = -1 then begin\r
+    {no run length: must be an exact number of fields}\r
+    if wordcount = 6 then begin\r
+      if fieldcount <> 6 then exit;\r
+      emptyfield := 5;\r
+    end else if wordcount = 8 then begin\r
+      if fieldcount <> 7 then exit;\r
+      emptyfield := 7;\r
+    end else exit;\r
+  end;\r
+  for a := 0 to emptyfield do begin\r
+    if fields[a] = '' then b := 0 else b := strtointdef('$'+fields[a],-1);\r
+    if (b < 0) or (b > $ffff) then exit;\r
+    words[a] := b;\r
+  end;\r
+  if wordcount = 6 then dec(fieldcount);\r
+  for a := wordcount-1 downto wordcount-(fieldcount-emptyfield) do begin\r
+    b := a+fieldcount-wordcount+1;\r
+    if fields[b] = '' then b := 0 else b := strtointdef('$'+fields[b],-1);\r
+    if (b < 0) or (b > $ffff) then exit;\r
+    words[a] := b;\r
+  end;\r
+  for a := 0 to 7 do begin\r
+    bytes[a shl 1] := words[a] shr 8;\r
+    bytes[a shl 1 or 1] := words[a] and $ff;\r
+  end;\r
+  result := true;\r
+end;\r
+{$endif}\r
+\r
+function comparebinip(const ip1,ip2:tbinip):boolean;\r
+begin\r
+  if (ip1.ip <> ip2.ip) then begin\r
+    result := false;\r
+    exit;\r
+  end;\r
+\r
+  {$ifdef ipv6}\r
+  if ip1.family = AF_INET6 then begin\r
+    if (ip1.ip6.s6_addr32[1] <> ip2.ip6.s6_addr32[1])\r
+    or (ip1.ip6.s6_addr32[2] <> ip2.ip6.s6_addr32[2])\r
+    or (ip1.ip6.s6_addr32[3] <> ip2.ip6.s6_addr32[3]) then begin\r
+      result := false;\r
+      exit;\r
+    end;\r
+  end;\r
+  {$endif}\r
+\r
+  result := (ip1.family = ip2.family);\r
+end;\r
+\r
+{converts a binary IP to v4 if it is a v6 IP in the v4 range}\r
+procedure converttov4(var ip:tbinip);\r
+begin\r
+  {$ifdef ipv6}\r
+  if ip.family = AF_INET6 then begin\r
+    if (ip.ip6.u6_addr32[0] = 0) and (ip.ip6.u6_addr32[1] = 0) and\r
+    (ip.ip6.u6_addr16[4] = 0) and (ip.ip6.u6_addr16[5] = $ffff) then begin\r
+      ip.family := AF_INET;\r
+      ip.ip := ip.ip6.s6_addr32[3];\r
+    end;\r
+  end;\r
+  {$endif}\r
+end;\r
+\r
+end.\r

diff --git a/httpserver_20080306/blinklist.pas b/httpserver_20080306/blinklist.pas
new file mode 100755 (executable)
index 0000000..2079b75
--- /dev/null
+++ b/httpserver_20080306/blinklist.pas
@@ -0,0 +1,118 @@
+(*\r
+ *  beware IRC services, blinklist.pas\r
+ *  Copyright (C) 2002 Bas Steendijk\r
+ *\r
+ *  This program is free software; you can redistribute it and/or modify\r
+ *  it under the terms of the GNU General Public License as published by\r
+ *  the Free Software Foundation; either version 2 of the License, or\r
+ *  (at your option) any later version.\r
+ *\r
+ *  This program is distributed in the hope that it will be useful,\r
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\r
+ *  GNU General Public License for more details.\r
+ *\r
+ *  You should have received a copy of the GNU General Public License\r
+ *  along with this program; if not, write to the Free Software\r
+ *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA\r
+ *)\r
+unit blinklist;\r
+{$ifdef fpc}\r
+  {$mode delphi}\r
+{$endif}\r
+\r
+\r
+interface\r
+\r
+type\r
+  tlinklist=class(tobject)\r
+    next:tlinklist;\r
+    prev:tlinklist;\r
+    constructor create;\r
+    destructor destroy; override;\r
+  end;\r
+\r
+  {linklist with 2 links}\r
+  tlinklist2=class(tlinklist)\r
+    next2:tlinklist2;\r
+    prev2:tlinklist2;\r
+  end;\r
+\r
+  {linklist with one pointer}\r
+  tplinklist=class(tlinklist)\r
+    p:pointer\r
+  end;\r
+\r
+  tstringlinklist=class(tlinklist)\r
+    s:string;\r
+  end;\r
+\r
+  tthing=class(tlinklist)\r
+    name:string;      {name/nick}\r
+    hashname:integer; {hash of name}\r
+  end;\r
+\r
+{\r
+adding new block to list (baseptr)\r
+}\r
+procedure linklistadd(var baseptr:tlinklist;newptr:tlinklist);\r
+procedure linklistdel(var baseptr:tlinklist;item:tlinklist);\r
+\r
+\r
+procedure linklist2add(var baseptr,newptr:tlinklist2);\r
+procedure linklist2del(var baseptr:tlinklist2;item:tlinklist2);\r
+\r
+var\r
+  linklistdebug:integer;\r
+\r
+implementation\r
+\r
+procedure linklistadd(var baseptr:tlinklist;newptr:tlinklist);\r
+var\r
+  p:tlinklist;\r
+begin\r
+  p := baseptr;\r
+  baseptr := newptr;\r
+  baseptr.prev := nil;\r
+  baseptr.next := p;\r
+  if p <> nil then p.prev := baseptr;\r
+end;\r
+\r
+procedure linklistdel(var baseptr:tlinklist;item:tlinklist);\r
+begin\r
+  if item = baseptr then baseptr := item.next;\r
+  if item.prev <> nil then item.prev.next := item.next;\r
+  if item.next <> nil then item.next.prev := item.prev;\r
+end;\r
+\r
+procedure linklist2add(var baseptr,newptr:tlinklist2);\r
+var\r
+  p:tlinklist2;\r
+begin\r
+  p := baseptr;\r
+  baseptr := newptr;\r
+  baseptr.prev2 := nil;\r
+  baseptr.next2 := p;\r
+  if p <> nil then p.prev2 := baseptr;\r
+end;\r
+\r
+procedure linklist2del(var baseptr:tlinklist2;item:tlinklist2);\r
+begin\r
+  if item = baseptr then baseptr := item.next2;\r
+  if item.prev2 <> nil then item.prev2.next2 := item.next2;\r
+  if item.next2 <> nil then item.next2.prev2 := item.prev2;\r
+end;\r
+\r
+constructor tlinklist.create;\r
+begin\r
+  inherited create;\r
+  inc(linklistdebug);\r
+end;\r
+\r
+destructor tlinklist.destroy;\r
+begin\r
+  dec(linklistdebug);\r
+  inherited destroy;\r
+end;\r
+\r
+end.\r

diff --git a/httpserver_20080306/bsearchtree.pas b/httpserver_20080306/bsearchtree.pas
new file mode 100755 (executable)
index 0000000..ad61751
--- /dev/null
+++ b/httpserver_20080306/bsearchtree.pas
@@ -0,0 +1,101 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+  \r
+{actually a hashtable. it was a tree in earlier versions}\r
+\r
+unit bsearchtree;\r
+\r
+interface\r
+\r
+uses blinklist;\r
+\r
+const\r
+  hashtable_size=$4000;\r
+\r
+type\r
+  thashitem=class(tlinklist)\r
+    hash:integer;\r
+    s:string;\r
+    p:pointer;\r
+  end;\r
+  thashtable=array[0..hashtable_size-1] of thashitem;\r
+  phashtable=^thashtable;\r
+\r
+{adds "item" to the tree for name "s". the name must not exist (no checking done)}\r
+procedure addtree(t:phashtable;s:string;item:pointer);\r
+\r
+{removes name "s" from the tree. the name must exist (no checking done)}\r
+procedure deltree(t:phashtable;s:string);\r
+\r
+{returns the item pointer for s, or nil if not found}\r
+function findtree(t:phashtable;s:string):pointer;\r
+\r
+implementation\r
+\r
+function makehash(s:string):integer;\r
+const\r
+  shifter=6;\r
+var\r
+  a,b:integer;\r
+begin\r
+  result := 0;\r
+  b := length(s);\r
+  for a := 1 to b do begin\r
+    result := (result shl shifter) xor byte(s[a]);\r
+  end;\r
+  result := (result xor result shr 16) and (hashtable_size-1);\r
+end;\r
+\r
+procedure addtree(t:phashtable;s:string;item:pointer);\r
+var\r
+  hash:integer;\r
+  p:thashitem;\r
+begin\r
+  hash := makehash(s);\r
+  p := thashitem.create;\r
+  p.hash := hash;\r
+  p.s := s;\r
+  p.p := item;\r
+  linklistadd(tlinklist(t[hash]),tlinklist(p));\r
+end;\r
+\r
+procedure deltree(t:phashtable;s:string);\r
+var\r
+  p,p2:thashitem;\r
+  hash:integer;\r
+begin\r
+  hash := makehash(s);\r
+  p := t[hash];\r
+  p2 := nil;\r
+  while p <> nil do begin\r
+    if p.s = s then begin\r
+      p2 := p;\r
+      break;\r
+    end;\r
+    p := thashitem(p.next);\r
+  end;\r
+  linklistdel(tlinklist(t[hash]),tlinklist(p2));\r
+  p2.destroy;\r
+end;\r
+\r
+\r
+function findtree(t:phashtable;s:string):pointer;\r
+var\r
+  p:thashitem;\r
+  hash:integer;\r
+begin\r
+  result := nil;\r
+  hash := makehash(s);\r
+  p := t[hash];\r
+  while p <> nil do begin\r
+    if p.s = s then begin\r
+      result := p.p;\r
+      exit;\r
+    end;\r
+    p := thashitem(p.next);\r
+  end;\r
+end;\r
+\r
+end.\r

diff --git a/httpserver_20080306/btime.pas b/httpserver_20080306/btime.pas
new file mode 100755 (executable)
index 0000000..127839e
--- /dev/null
+++ b/httpserver_20080306/btime.pas
@@ -0,0 +1,362 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+{\r
+this unit returns unix timestamp with seconds and microseconds (as float)\r
+works on windows/delphi, and on freepascal on unix.\r
+}\r
+\r
+unit btime;\r
+\r
+interface\r
+\r
+type\r
+  float=extended;\r
+\r
+var\r
+  timezone:integer;\r
+  timezonestr:string;\r
+  irctime,unixtime:integer;\r
+  tickcount:integer;\r
+  settimebias:integer;\r
+  qpcjump:float; {can be read out and reset for debug purpose}\r
+  performancecountfreq:extended;\r
+\r
+function irctimefloat:float;\r
+function irctimeint:integer;\r
+\r
+function unixtimefloat:float;\r
+function unixtimeint:integer;\r
+\r
+function wintimefloat:float;\r
+\r
+procedure settime(newtime:integer);\r
+procedure gettimezone;\r
+procedure timehandler;\r
+procedure init;\r
+\r
+function timestring(i:integer):string;\r
+function timestrshort(i:integer):string;\r
+\r
+function oletounixfloat(t:float):float;\r
+function oletounix(t:tdatetime):integer;\r
+function unixtoole(i:integer):tdatetime;\r
+\r
+var\r
+  timefloatbias:float;\r
+  lastunixtimefloat:float=0;\r
+\r
+implementation\r
+\r
+{$ifdef fpc}\r
+  {$mode delphi}\r
+{$endif}\r
+\r
+uses\r
+  {$ifdef UNIX}\r
+    {$ifdef VER1_0}\r
+      linux,\r
+    {$else}\r
+      baseunix,unix,unixutil, {needed for 2.0.2}\r
+    {$endif}\r
+  {$else}\r
+    windows,\r
+  {$endif}\r
+  sysutils;\r
+\r
+  {$include unixstuff.inc}\r
+\r
+\r
+const\r
+  daysdifference=25569;\r
+\r
+function oletounixfloat(t:float):float;\r
+begin\r
+  t := (t - daysdifference) * 86400;\r
+  result := t;\r
+end;\r
+\r
+function oletounix(t:tdatetime):integer;\r
+begin\r
+  result := trunc(oletounixfloat(t));\r
+end;\r
+\r
+function unixtoole(i:integer):tdatetime;\r
+begin\r
+  result := ((i)/86400)+daysdifference;\r
+end;\r
+\r
+{$ifdef unix}\r
+{-----------------------------------------*nix/freepascal code to read time }\r
+\r
+function unixtimefloat:float;\r
+var\r
+  tv:ttimeval;\r
+begin\r
+  gettimeofday(tv);\r
+  result := tv.tv_sec+(tv.tv_usec/1000000);\r
+end;\r
+\r
+function wintimefloat:extended;\r
+begin\r
+  result := unixtimefloat;\r
+end;\r
+\r
+function unixtimeint:integer;\r
+var\r
+  tv:ttimeval;\r
+begin\r
+  gettimeofday(tv);\r
+  result := tv.tv_sec;\r
+end;\r
+\r
+{$else} {delphi 3}\r
+{------------------------------ windows/delphi code to read time}\r
+\r
+{ free pascals tsystemtime is incomaptible with windows api calls\r
+ so we declare it ourselves - plugwash\r
+}\r
+{$ifdef fpc}\r
+type\r
+  TSystemTime = record\r
+     wYear: Word;\r
+     wMonth: Word;\r
+     wDayOfWeek: Word;\r
+     wDay: Word;\r
+     wHour: Word;\r
+     wMinute: Word;\r
+     wSecond: Word;\r
+     wMilliseconds: Word;\r
+  end;\r
+ {$endif}\r
+function Date_utc: extended;\r
+var\r
+  SystemTime: TSystemTime;\r
+begin\r
+  {$ifdef fpc}\r
+    GetsystemTime(@SystemTime);\r
+  {$else}\r
+    GetsystemTime(SystemTime);\r
+  {$endif}\r
+  with SystemTime do Result := EncodeDate(wYear, wMonth, wDay);\r
+end;\r
+\r
+function Time_utc: extended;\r
+var\r
+  SystemTime: TSystemTime;\r
+begin\r
+  {$ifdef fpc}\r
+    GetsystemTime(@SystemTime);\r
+  {$else}\r
+    GetsystemTime(SystemTime);\r
+  {$endif}\r
+  with SystemTime do\r
+    Result := EncodeTime(wHour, wMinute, wSecond, wMilliSeconds);\r
+end;\r
+\r
+function Now_utc: extended;\r
+begin\r
+  Result := round(Date_utc) + Time_utc;\r
+end;\r
+\r
+const\r
+  highdwordconst=4294967296.0;\r
+\r
+function wintimefloat:extended;\r
+var\r
+  p:packed record\r
+    lowpart:longint;\r
+    highpart:longint\r
+  end;\r
+  p2:tlargeinteger absolute p;\r
+  e:extended;\r
+begin\r
+  if performancecountfreq = 0 then begin\r
+    QueryPerformancefrequency(p2);\r
+    e := p.lowpart;\r
+    if e < 0 then e := e + highdwordconst;\r
+    performancecountfreq := ((p.highpart*highdwordconst)+e);\r
+  end;\r
+  queryperformancecounter(p2);\r
+  e := p.lowpart;\r
+  if e < 0 then e := e + highdwordconst;\r
+  result := ((p.highpart*highdwordconst)+e)/performancecountfreq;\r
+end;\r
+\r
+var\r
+  classpriority,threadpriority:integer;\r
+\r
+procedure settc;\r
+var\r
+  hprocess,hthread:integer;\r
+begin\r
+  hProcess := GetCurrentProcess;\r
+  hThread := GetCurrentThread;\r
+\r
+  ClassPriority := GetPriorityClass(hProcess);\r
+  ThreadPriority := GetThreadPriority(hThread);\r
+\r
+  SetPriorityClass(hProcess, REALTIME_PRIORITY_CLASS);\r
+  SetThreadPriority(hThread, THREAD_PRIORITY_TIME_CRITICAL);\r
+end;\r
+\r
+procedure unsettc;\r
+var\r
+  hprocess,hthread:integer;\r
+begin\r
+  hProcess := GetCurrentProcess;\r
+  hThread := GetCurrentThread;\r
+\r
+  SetPriorityClass(hProcess, ClassPriority);\r
+  SetThreadPriority(hThread,  ThreadPriority);\r
+end;\r
+\r
+function unixtimefloat:float;\r
+var\r
+  f,g,h:float;\r
+begin\r
+  if timefloatbias = 0 then begin\r
+    settc;\r
+    f := now_utc;\r
+    repeat g := now_utc; h := wintimefloat until g > f;\r
+    timefloatbias := oletounixfloat(g)-h;\r
+    unsettc;\r
+  end;\r
+  result := wintimefloat+timefloatbias;\r
+\r
+  {\r
+  workaround for QPC jumps\r
+  (approach 2: always check "hi res" QPC unixtime against the "guaranteed" systemtime one)\r
+  }\r
+  f := result-(oletounixfloat(now_utc));\r
+  if abs(f) > 0.02 then begin\r
+    f := timefloatbias;\r
+    timefloatbias := 0;\r
+    result := unixtimefloat;\r
+    qpcjump := qpcjump + f - timefloatbias;\r
+  end;\r
+\r
+  if (result <= lastunixtimefloat) then result := lastunixtimefloat + 0.0000001;\r
+  lastunixtimefloat := result;\r
+end;\r
+\r
+function unixtimeint:integer;\r
+begin\r
+  result := trunc(unixtimefloat);\r
+end;\r
+\r
+{$endif}\r
+{-----------------------------------------------end of platform specific}\r
+\r
+function irctimefloat:float;\r
+begin\r
+  result := unixtimefloat+settimebias;\r
+end;\r
+\r
+function irctimeint:integer;\r
+begin\r
+  result := unixtimeint+settimebias;\r
+end;\r
+\r
+\r
+procedure settime(newtime:integer);\r
+var\r
+  a:integer;\r
+begin\r
+  a := irctimeint-settimebias;\r
+  if newtime = 0 then settimebias := 0 else settimebias := newtime-a;\r
+\r
+  irctime := irctimeint;\r
+end;\r
+\r
+procedure timehandler;\r
+begin\r
+  if unixtime = 0 then init;\r
+  unixtime := unixtimeint;\r
+  irctime := irctimeint;\r
+  if unixtime and 63 = 0 then begin\r
+    {update everything, apply timezone changes, clock changes, etc}\r
+    gettimezone;\r
+    timefloatbias := 0;\r
+    unixtime := unixtimeint;\r
+    irctime := irctimeint;\r
+  end;\r
+end;\r
+\r
+\r
+procedure gettimezone;\r
+var\r
+  {$ifdef UNIX}\r
+    {$ifndef ver1_9_4}\r
+      {$ifndef ver1_0}\r
+        {$define above194}\r
+      {$endif}\r
+    {$endif}\r
+    {$ifndef above194}\r
+      hh,mm,ss:word;\r
+    {$endif}\r
+  {$endif}\r
+  l:integer;\r
+begin\r
+  {$ifdef UNIX}\r
+    {$ifdef above194}\r
+      timezone := tzseconds;\r
+    {$else}\r
+      gettime(hh,mm,ss);\r
+      timezone := (longint(hh) * 3600 + mm * 60 + ss) - (unixtimeint mod 86400);\r
+    {$endif}\r
+  {$else}\r
+  timezone := round((now-now_utc)*86400);\r
+  {$endif}\r
+\r
+  while timezone > 43200 do dec(timezone,86400);\r
+  while timezone < -43200 do inc(timezone,86400);\r
+\r
+  if timezone >= 0 then timezonestr := '+' else timezonestr := '-';\r
+  l := abs(timezone) div 60;\r
+  timezonestr := timezonestr + char(l div 600 mod 10+48)+char(l div 60 mod 10+48)+':'+char(l div 10 mod 6+48)+char(l mod 10+48);\r
+end;\r
+\r
+function timestrshort(i:integer):string;\r
+const\r
+  weekday:array[0..6] of string[4]=('Thu','Fri','Sat','Sun','Mon','Tue','Wed');\r
+  month:array[0..11] of string[4]=('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');\r
+var\r
+  y,m,d,h,min,sec,ms:word;\r
+  t:tdatetime;\r
+begin\r
+  t := unixtoole(i+timezone);\r
+  decodedate(t,y,m,d);\r
+  decodetime(t,h,min,sec,ms);\r
+  result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+\r
+  inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10)+' '+\r
+  inttostr(y);\r
+end;\r
+\r
+function timestring(i:integer):string;\r
+const\r
+  weekday:array[0..6] of string[10]=('Thursday','Friday','Saturday','Sunday','Monday','Tuesday','Wednesday');\r
+  month:array[0..11] of string[10]=('January','February','March','April','May','June','July','August','September','October','November','December');\r
+var\r
+  y,m,d,h,min,sec,ms:word;\r
+  t:tdatetime;\r
+begin\r
+  t := unixtoole(i+timezone);\r
+  decodedate(t,y,m,d);\r
+  decodetime(t,h,min,sec,ms);\r
+  result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+inttostr(y)+' -- '+\r
+  inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10)+' '+\r
+  timezonestr;\r
+end;\r
+\r
+procedure init;\r
+begin\r
+  qpcjump := 0;\r
+  settimebias := 0;\r
+  gettimezone;\r
+  unixtime := unixtimeint;\r
+  irctime := irctimeint;\r
+end;\r
+\r
+end.\r

diff --git a/httpserver_20080306/dnsasync.pas b/httpserver_20080306/dnsasync.pas
new file mode 100755 (executable)
index 0000000..682f95f
--- /dev/null
+++ b/httpserver_20080306/dnsasync.pas
@@ -0,0 +1,241 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+\r
+//FIXME: this code only ever seems to use one dns server for a request and does\r
+//not seem to have any form of retry code.\r
+\r
+unit dnsasync;\r
+\r
+interface\r
+\r
+uses\r
+  {$ifdef win32}\r
+    dnswin,\r
+  {$endif}\r
+  lsocket,lcore,\r
+  classes,binipstuff,dnscore,btime;\r
+\r
+\r
+type\r
+  //after completion or cancelation a dnswinasync may be reused\r
+  tdnsasync=class(tcomponent)\r
+\r
+  private\r
+    //made a load of stuff private that does not appear to be part of the main\r
+    //public interface. If you make any of it public again please consider the\r
+    //consequences when using windows dns. --plugwash.\r
+    sock:twsocket;\r
+\r
+    sockopen:boolean;\r
+\r
+\r
+    state:tdnsstate;\r
+\r
+    dnsserverid:integer;\r
+    startts:double;\r
+    {$ifdef win32}
+      dwas : tdnswinasync;\r
+    {$endif}
+\r
+\r
+    procedure asyncprocess;\r
+    procedure receivehandler(sender:tobject;error:word);\r
+    function sendquery(const packet:tdnspacket;len:integer):boolean;\r
+    {$ifdef win32}
+      procedure winrequestdone(sender:tobject;error:word);\r
+    {$endif}
+  public\r
+    onrequestdone:tsocketevent;\r
+\r
+    //addr and port allow the application to specify a dns server specifically\r
+    //for this dnsasync object. This is not a reccomended mode of operation\r
+    //because it limits the app to one dns server but is kept for compatibility\r
+    //and special uses.\r
+    addr,port:string;\r
+\r
+    //A family value of AF_INET6 will give only\r
+    //ipv6 results. Any other value will give ipv4 results in preference and ipv6\r
+    //results if ipv4 results are not available;\r
+    forwardfamily:integer;\r
+\r
+    procedure cancel;//cancel an outstanding dns request\r
+    function dnsresult:string; //get result of dnslookup as a string\r
+    procedure dnsresultbin(var binip:tbinip); //get result of dnslookup as a tbinip\r
+    procedure forwardlookup(const name:string); //start forward lookup,\r
+                                                //preffering ipv4\r
+    procedure reverselookup(const binip:tbinip); //start reverse lookup\r
+\r
+    constructor create(aowner:tcomponent); override;\r
+    destructor destroy; override;\r
+\r
+  end;\r
+\r
+implementation\r
+\r
+uses sysutils;\r
+\r
+constructor tdnsasync.create;\r
+begin\r
+  inherited create(aowner);\r
+  dnsserverid := -1;\r
+  sock := twsocket.create(self);\r
+end;\r
+\r
+destructor tdnsasync.destroy;\r
+begin\r
+  if dnsserverid >= 0 then begin\r
+    reportlag(dnsserverid,-1);\r
+    dnsserverid := -1;\r
+  end;\r
+  sock.release;\r
+  setstate_request_init('',state);\r
+  inherited destroy;\r
+end;\r
+\r
+procedure tdnsasync.receivehandler;\r
+begin\r
+  if dnsserverid >= 0 then begin\r
+    reportlag(dnsserverid,trunc((unixtimefloat-startts)*1000));\r
+    dnsserverid := -1;\r
+  end;\r
+{  writeln('received reply');}\r
+  fillchar(state.recvpacket,sizeof(state.recvpacket),0);\r
+  state.recvpacketlen := twsocket(sender).Receive(@state.recvpacket, SizeOf(state.recvpacket));\r
+  state.parsepacket := true;\r
+  asyncprocess;\r
+end;\r
+\r
+function tdnsasync.sendquery;\r
+begin\r
+{  writeln('sendquery ',decodename(state.packet,state.packetlen,12,0,a),' ',state.requesttype);}\r
+  result := false;\r
+  if len = 0 then exit; {no packet}\r
+  if not sockopen then begin\r
+    if addr <> '' then sock.addr := addr else sock.addr := getcurrentsystemnameserver(dnsserverid);//getunixnameservercached;\r
+    startts := unixtimefloat;\r
+    if port = '' then port := '53';\r
+    sock.port := port;\r
+    sock.Proto := 'udp';\r
+    sock.ondataavailable := receivehandler;\r
+    try\r
+      sock.connect;\r
+    except\r
+      on e:exception do begin\r
+        //writeln('exception '+e.message);\r
+        exit;\r
+      end;\r
+    end;\r
+    sockopen := true;\r
+  end;\r
+  sock.send(@packet,len);\r
+  result := true;\r
+end;\r
+\r
+procedure tdnsasync.asyncprocess;\r
+begin\r
+  state_process(state);\r
+  case state.resultaction of\r
+    action_ignore: begin {do nothing} end;\r
+    action_done: begin\r
+      onrequestdone(self,0);\r
+    end;\r
+    action_sendquery:begin\r
+      sendquery(state.sendpacket,state.sendpacketlen);\r
+    end;\r
+  end;\r
+end;\r
+\r
+procedure tdnsasync.forwardlookup;\r
+begin\r
+  {$ifdef win32}\r
+    if usewindns or (addr = '') then begin\r
+      dwas := tdnswinasync.create;\r
+      dwas.onrequestdone := winrequestdone;\r
+      if forwardfamily = AF_INET6 then begin\r
+        dwas.forwardlookup(name,true);\r
+      end else begin\r
+        dwas.forwardlookup(name,false);\r
+      end;\r
+    end;\r
+  {$endif}\r
+\r
+  ipstrtobin(name,state.resultbin);\r
+  if state.resultbin.family <> 0 then begin\r
+    onrequestdone(self,0);\r
+    exit;\r
+  end;\r
+\r
+\r
+  setstate_forward(name,state,forwardfamily);\r
+  asyncprocess;\r
+\r
+end;\r
+\r
+procedure tdnsasync.reverselookup;\r
+\r
+begin\r
+  {$ifdef win32}\r
+    if usewindns or (addr = '') then begin\r
+      dwas := tdnswinasync.create;\r
+      dwas.onrequestdone := winrequestdone;\r
+      dwas.reverselookup(binip);\r
+    end;\r
+  {$endif}\r
+\r
+  setstate_reverse(binip,state);\r
+  asyncprocess;\r
+end;\r
+\r
+function tdnsasync.dnsresult;\r
+begin\r
+  if state.resultstr <> '' then result := state.resultstr else begin\r
+    result := ipbintostr(state.resultbin);\r
+  end;\r
+end;\r
+\r
+procedure tdnsasync.dnsresultbin(var binip:tbinip);\r
+begin\r
+  move(state.resultbin,binip,sizeof(binip));\r
+end;\r
+\r
+procedure tdnsasync.cancel;\r
+begin\r
+  {$ifdef win32}
+    if assigned(dwas) then begin\r
+      dwas.release;\r
+      dwas := nil;\r
+    end else 
+  {$endif}
+  begin\r
+\r
+    if dnsserverid >= 0 then begin\r
+      reportlag(dnsserverid,-1);\r
+      dnsserverid := -1;\r
+    end;\r
+    if sockopen then begin\r
+      sock.close;\r
+      sockopen := false;\r
+    end;\r
+  end;\r
+  setstate_failure(state);\r
+  onrequestdone(self,0);\r
+end;\r
+\r
+{$ifdef win32}
+  procedure tdnsasync.winrequestdone(sender:tobject;error:word);\r 
+  begin\r
+    if dwas.reverse then begin \r
+      state.resultstr := dwas.name;\r
+    end else begin \r
+      state.resultbin := dwas.ip;\r
+      if (forwardfamily = AF_INET6) and (state.resultbin.family = AF_INET) then begin\r
+        fillchar(state.resultbin,sizeof(tbinip),0);\r
+      end;\r
+    end;\r
+    dwas.release;\r
+    onrequestdone(self,error);\r
+  end;\r
+{$endif}
+end.\r

diff --git a/httpserver_20080306/dnscore.pas b/httpserver_20080306/dnscore.pas
new file mode 100755 (executable)
index 0000000..bb4fab4
--- /dev/null
+++ b/httpserver_20080306/dnscore.pas
@@ -0,0 +1,728 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+\r
+{\r
+\r
+  code wanting to use this dns system should act as follows (note: app\r
+  developers will probablly want to use dnsasync or dnssync or write a similar\r
+  wrapper unit of thier own).\r
+\r
+  for normal lookups call setstate_forward or setstate_reverse to set up the\r
+  state, for more obscure lookups use setstate_request_init and fill in other\r
+  relavent state manually.\r
+\r
+  call state_process which will do processing on the information in the state\r
+  and return an action\r
+  action_ignore means that dnscore wants the code that calls it to go\r
+  back to waiting for packets\r
+  action_sendpacket means that dnscore wants the code that calls it to send\r
+  the packet in sendpacket/sendpacketlen and then start (or go back to) listening\r
+  for\r
+  action_done means the request has completed (either suceeded or failed)\r
+\r
+  callers should resend the last packet they tried to send if they have not\r
+  been asked to send a new packet for more than some timeout value they choose.\r
+\r
+  when a packet is received the application should put the packet in\r
+  recvbuf/recvbuflen , set state.parsepacket and call state_process again\r
+\r
+  once the app gets action_done it can determine sucess or failure in the\r
+  following ways.\r
+\r
+  on failure state.resultstr will be an empty string and state.resultbin will\r
+  be zeroed out (easilly detected by the fact that it will have a family of 0)\r
+\r
+  on success for a A or AAAA lookup state.resultstr will be an empty string\r
+  and state.resultbin will contain the result (note: AAAA lookups require IPV6\r
+  enabled).\r
+\r
+  if an A lookup fails and the code is built with ipv6 enabled then the code\r
+  will return any AAAA records with the same name. The reverse does not apply\r
+  so if an application preffers IPV6 but wants IPV4 results as well it must\r
+  check them seperately.\r
+\r
+  on success for any other type of lookup state.resultstr will be an empty\r
+\r
+  note the state contains ansistrings, setstate_init with a null name parameter\r
+  can be used to clean theese up if required.\r
+\r
+  callers may use setstate_failure to mark the state as failed themseleves\r
+  before passing it on to other code, for example this may be done in the event\r
+  of a timeout.\r
+}\r
+unit dnscore;\r
+\r
+\r
+\r
+{$ifdef fpc}{$mode delphi}{$endif}\r
+\r
+\r
+\r
+\r
+\r
+interface\r
+\r
+uses binipstuff,classes,pgtypes;\r
+\r
+var usewindns : boolean = {$ifdef win32}true{$else}false{$endif};\r
+//hint to users of this unit that they should use windows dns instead.\r
+//May be disabled by applications if desired. (e.g. if setting a custom\r
+//dnsserverlist).\r
+\r
+//note: this unit will not be able to self populate it's dns server list on\r
+//older versions of windows.\r
+\r
+const\r
+  maxnamelength=127;\r
+  maxnamefieldlen=63;\r
+  //note: when using action_ignore the dnscore code *must* preserve the contents of state.sendpacket to allow for retries\r
+  //note: action_ignore must not be used in response to the original request but there is no valid reason for doing this anyway\r
+  action_ignore=0;\r
+  action_done=1;\r
+  action_sendquery=2;\r
+  querytype_a=1;\r
+  querytype_cname=5;\r
+  querytype_aaaa=28;\r
+  querytype_ptr=12;\r
+  querytype_ns=2;\r
+  querytype_soa=6;\r
+  querytype_mx=15;\r
+\r
+  maxrecursion=10;\r
+  maxrrofakind=20;\r
+\r
+  retryafter=300000; //microseconds must be less than one second;\r
+  timeoutlag=1000000000; // penalty value to be treated as lag in the event of a timeout (microseconds)\r
+type\r
+  dvar=array[0..0] of byte;\r
+  pdvar=^dvar;\r
+  tdnspacket=packed record\r
+    id:word;\r
+    flags:word;\r
+    rrcount:array[0..3] of word;\r
+    payload:array[0..511-12] of byte;\r
+  end;\r
+\r
+\r
+\r
+  tdnsstate=record\r
+    id:word;\r
+    recursioncount:integer;\r
+    queryname:string;\r
+    requesttype:word;\r
+    parsepacket:boolean;\r
+    resultstr:string;\r
+    resultbin:tbinip;\r
+    resultaction:integer;\r
+    numrr1:array[0..3] of integer;\r
+    numrr2:integer;\r
+    rrdata:string;\r
+    sendpacketlen:integer;\r
+    sendpacket:tdnspacket;\r
+    recvpacketlen:integer;\r
+    recvpacket:tdnspacket;\r
+    forwardfamily:integer;\r
+  end;\r
+\r
+  trr=packed record\r
+    requesttypehi:byte;\r
+    requesttype:byte;\r
+    clas:word;\r
+    ttl:integer;\r
+    datalen:word;\r
+    data:array[0..511] of byte;\r
+  end;\r
+\r
+  trrpointer=packed record\r
+    p:pointer;\r
+    ofs:integer;\r
+    len:integer;\r
+    namelen:integer;\r
+  end;\r
+\r
+//commenting out functions from interface that do not have documented semantics\r
+//and probablly should not be called from outside this unit, reenable them\r
+//if you must but please document them at the same time --plugwash\r
+\r
+//function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer;\r
+//function makereversename(const binip:tbinip):string;\r
+\r
+procedure setstate_request_init(const name:string;var state:tdnsstate);\r
+\r
+//set up state for a foward lookup. A family value of AF_INET6 will give only\r
+//ipv6 results. Any other value will give ipv4 results in preference and ipv6\r
+//results if ipv4 results are not available;\r
+procedure setstate_forward(const name:string;var state:tdnsstate;family:integer);\r
+\r
+procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);\r
+procedure setstate_failure(var state:tdnsstate);\r
+//procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);\r
+\r
+\r
+procedure state_process(var state:tdnsstate);\r
+\r
+//function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):string;\r
+\r
+//presumablly this is exported to allow more secure random functions\r
+//to be substituted?\r
+var randomfunction:function:integer;\r
+\r
+\r
+procedure populatednsserverlist;\r
+procedure cleardnsservercache;\r
+\r
+var\r
+  dnsserverlist : tstringlist;\r
+//  currentdnsserverno : integer;\r
+\r
+function getcurrentsystemnameserver(var id:integer) :string;\r
+\r
+//var\r
+//  unixnameservercache:string;\r
+{ $endif}\r
+\r
+\r
+procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout\r
+var\r
+  failurereason:string;\r
+\r
+implementation\r
+\r
+uses\r
+  {$ifdef win32}\r
+    windows,\r
+  {$endif}\r
+\r
+  sysutils;\r
+\r
+function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer;\r
+var\r
+  a,b:integer;\r
+  s:string;\r
+  arr:array[0..sizeof(packet)-1] of byte absolute packet;\r
+begin\r
+ { writeln('buildrequest: name: ',name);}\r
+  result := 0;\r
+  fillchar(packet,sizeof(packet),0);\r
+  if assigned(randomfunction) then packet.id := (randomfunction and $ffff) else packet.id := random(65536);\r
+  packet.flags := htons($0100);\r
+  packet.rrcount[0] := htons($0001);\r
+\r
+\r
+  s := copy(name,1,maxnamelength);\r
+  if s = '' then exit;\r
+  if s[length(s)] <> '.' then s := s + '.';\r
+  b := 0;\r
+  {encode name}\r
+  if (s = '.') then begin\r
+    packet.payload[0] := 0;\r
+    result := 12+5;\r
+  end else begin\r
+    for a := 1 to length(s) do begin\r
+      if s[a] = '.' then begin\r
+        if b > maxnamefieldlen then exit;\r
+        if (b = 0) then exit;\r
+        packet.payload[a-b-1] := b;\r
+        b := 0;\r
+      end else begin\r
+        packet.payload[a] := byte(s[a]);\r
+        inc(b);\r
+      end;\r
+    end;\r
+    if b > maxnamefieldlen then exit;\r
+    packet.payload[length(s)-b] := b;\r
+    result := length(s) + 12+5;\r
+  end;\r
+\r
+  arr[result-1] := 1;\r
+  arr[result-3] := requesttype and $ff;\r
+  arr[result-4] := requesttype shr 8;\r
+end;\r
+\r
+function makereversename(const binip:tbinip):string;\r
+var\r
+  name:string;\r
+  a,b:integer;\r
+begin\r
+  name := '';\r
+  if binip.family = AF_INET then begin\r
+    b := htonl(binip.ip);\r
+    for a := 0 to 3 do begin\r
+      name := name + inttostr(b shr (a shl 3) and $ff)+'.';\r
+    end;\r
+    name := name + 'in-addr.arpa';\r
+  end else\r
+  {$ifdef ipv6}\r
+  if binip.family = AF_INET6 then begin\r
+    for a := 15 downto 0 do begin\r
+      b := binip.ip6.u6_addr8[a];\r
+      name := name + hexchars[b and $f]+'.'+hexchars[b shr 4]+'.';\r
+    end;\r
+    name := name + 'ip6.arpa';\r
+  end else\r
+  {$endif}\r
+  begin\r
+    {empty name}\r
+  end;\r
+  result := name;\r
+end;\r
+\r
+{\r
+decodes DNS format name to a string. does not includes the root dot.\r
+doesnt read beyond len.\r
+empty result + non null failurereason: failure\r
+empty result + null failurereason: internal use\r
+}\r
+function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):string;\r
+var\r
+  arr:array[0..sizeof(packet)-1] of byte absolute packet;\r
+  s:string;\r
+  a,b:integer;\r
+begin\r
+  numread := 0;\r
+  repeat\r
+    if (start+numread < 0) or (start+numread >= len) then begin\r
+      result := '';\r
+      failurereason := 'decoding name: got out of range1';\r
+      exit;\r
+    end;\r
+    b := arr[start+numread];\r
+    if b >= $c0 then begin\r
+      {recursive sub call}\r
+      if recursion > 10 then begin\r
+        result := '';\r
+        failurereason := 'decoding name: max recursion';\r
+        exit;\r
+      end;\r
+      if ((start+numread+1) >= len) then begin\r
+        result := '';\r
+        failurereason := 'decoding name: got out of range3';\r
+        exit;\r
+      end;\r
+      a := ((b shl 8) or arr[start+numread+1]) and $3fff;\r
+      s := decodename(packet,len,a,recursion+1,a);\r
+      if (s = '') and (failurereason <> '') then begin\r
+        result := '';\r
+        exit;\r
+      end;\r
+      if result <> '' then result := result + '.';\r
+      result := result + s;\r
+      inc(numread,2);\r
+      exit;\r
+    end else if b < 64 then begin\r
+      if (numread <> 0) and (b <> 0) then result := result + '.';\r
+      for a := start+numread+1 to start+numread+b do begin\r
+        if (a >= len) then begin\r
+          result := '';\r
+          failurereason := 'decoding name: got out of range2';\r
+          exit;\r
+        end;\r
+        result := result + char(arr[a]);\r
+      end;\r
+      inc(numread,b+1);\r
+\r
+      if b = 0 then begin\r
+        if (result = '') and (recursion = 0) then result := '.';\r
+        exit; {reached end of name}\r
+      end;\r
+    end else begin\r
+      failurereason := 'decoding name: read invalid char';\r
+      result := '';\r
+      exit; {invalid}\r
+    end;\r
+  until false;\r
+end;\r
+\r
+{==============================================================================}\r
+\r
+procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);\r
+var\r
+  a:integer;\r
+begin\r
+  state.resultaction := action_done;\r
+  state.resultstr := '';\r
+  case trr(rrp.p^).requesttype of\r
+    querytype_a: begin\r
+      if htons(trr(rrp.p^).datalen) <> 4 then exit;\r
+      move(trr(rrp.p^).data,state.resultbin.ip,4);\r
+      state.resultbin.family :=AF_INET;\r
+    end;\r
+    {$ifdef ipv6}\r
+    querytype_aaaa: begin\r
+      if htons(trr(rrp.p^).datalen) <> 16 then exit;\r
+      state.resultbin.family := AF_INET6;\r
+      move(trr(rrp.p^).data,state.resultbin.ip6,16);\r
+    end;\r
+    {$endif}\r
+  else\r
+    {other reply types (PTR, MX) return a hostname}\r
+    state.resultstr := decodename(state.recvpacket,state.recvpacketlen,taddrint(rrp.p)-taddrint(@state.recvpacket)+10,0,a);\r
+    fillchar(state.resultbin,sizeof(state.resultbin),0);\r
+  end;\r
+end;\r
+\r
+procedure setstate_request_init(const name:string;var state:tdnsstate);\r
+begin\r
+  {destroy things properly}\r
+  state.resultstr := '';\r
+  state.queryname := '';\r
+  state.rrdata := '';\r
+  fillchar(state,sizeof(state),0);\r
+  state.queryname := name;\r
+  state.parsepacket := false;\r
+end;\r
+\r
+procedure setstate_forward(const name:string;var state:tdnsstate;family:integer);\r
+begin\r
+  setstate_request_init(name,state);\r
+  state.forwardfamily := family;\r
+  {$ifdef ipv6}\r
+  if family = AF_INET6 then state.requesttype := querytype_aaaa else\r
+  {$endif}\r
+  state.requesttype := querytype_a;\r
+end;\r
+\r
+procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);\r
+begin\r
+  setstate_request_init(makereversename(binip),state);\r
+  state.requesttype := querytype_ptr;\r
+end;\r
+\r
+procedure setstate_failure(var state:tdnsstate);\r
+begin\r
+  state.resultstr := '';\r
+  fillchar(state.resultbin,sizeof(state.resultbin),0);\r
+  state.resultaction := action_done;\r
+end;\r
+\r
+procedure state_process(var state:tdnsstate);\r
+label recursed;\r
+label failure;\r
+var\r
+  a,b,ofs:integer;\r
+  rrtemp:^trr;\r
+  rrptemp:^trrpointer;\r
+begin\r
+  if state.parsepacket then begin\r
+    if state.recvpacketlen < 12 then begin\r
+      failurereason := 'Undersized packet';\r
+      state.resultaction := action_ignore;\r
+      exit;\r
+    end;\r
+    if state.id <> state.recvpacket.id then begin\r
+      failurereason := 'ID mismatch';\r
+      state.resultaction := action_ignore;\r
+      exit;\r
+    end;\r
+    state.numrr2 := 0;\r
+    for a := 0 to 3 do begin\r
+      state.numrr1[a] := htons(state.recvpacket.rrcount[a]);\r
+      if state.numrr1[a] > maxrrofakind then goto failure;\r
+      inc(state.numrr2,state.numrr1[a]);\r
+    end;\r
+\r
+    setlength(state.rrdata,state.numrr2*sizeof(trrpointer));\r
+\r
+    {- put all replies into a list}\r
+\r
+    ofs := 12;\r
+    {get all queries}\r
+    for a := 0 to state.numrr1[0]-1 do begin\r
+      if (ofs < 12) or (ofs > state.recvpacketlen-4) then goto failure;\r
+      rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
+      rrptemp.p := @state.recvpacket.payload[ofs-12];\r
+      rrptemp.ofs := ofs;\r
+      decodename(state.recvpacket,state.recvpacketlen,ofs,0,b);\r
+      rrptemp.len := b + 4;\r
+      inc(ofs,rrptemp.len);\r
+    end;\r
+\r
+    for a := state.numrr1[0] to state.numrr2-1 do begin\r
+      if (ofs < 12) or (ofs > state.recvpacketlen-12) then goto failure;\r
+      rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
+      if decodename(state.recvpacket,state.recvpacketlen,ofs,0,b) = '' then goto failure;\r
+      rrtemp := @state.recvpacket.payload[ofs-12+b]; {rrtemp points to values and result, after initial name}\r
+      rrptemp.p := rrtemp;\r
+      rrptemp.ofs := ofs; {ofs is start of RR before initial name from start of packet}\r
+      rrptemp.namelen := b;\r
+      b := htons(rrtemp.datalen);\r
+      rrptemp.len := b + 10 + rrptemp.namelen;\r
+      inc(ofs,rrptemp.len);\r
+    end;\r
+    if (ofs <> state.recvpacketlen) then begin\r
+      failurereason := 'ofs <> state.packetlen';\r
+      goto failure;\r
+    end;\r
+\r
+    {- check for items of the requested type in answer section, if so return success first}\r
+    for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin\r
+      rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
+      rrtemp := rrptemp.p;\r
+      b := rrptemp.len;\r
+      if rrtemp.requesttype = state.requesttype then begin\r
+        setstate_return(rrptemp^,b,state);\r
+        exit;\r
+      end;\r
+    end;\r
+\r
+    {if no items of correct type found, follow first cname in answer section}\r
+    for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin\r
+      rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
+      rrtemp := rrptemp.p;\r
+      b := rrptemp.len;\r
+      if rrtemp.requesttype = querytype_cname then begin\r
+        state.queryname := decodename(state.recvpacket,state.recvpacketlen,rrptemp.ofs+12,0,b);\r
+        goto recursed;\r
+      end;\r
+    end;\r
+\r
+    {no cnames found, no items of correct type found}\r
+    if state.forwardfamily <> 0 then goto failure;\r
+{$ifdef ipv6}\r
+    if (state.requesttype = querytype_a) then begin\r
+      {v6 only: in case of forward, look for AAAA in alternative section}\r
+      for a := state.numrr1[0]+state.numrr1[1]+state.numrr1[2] to (state.numrr2-1) do begin\r
+        rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
+        rrtemp := rrptemp.p;\r
+        b := rrptemp.len;\r
+        if rrtemp.requesttype = querytype_aaaa then begin\r
+          setstate_return(rrptemp^,b,state);\r
+          exit;\r
+        end;\r
+      end;\r
+      {no AAAA's found in alternative, do a recursive lookup for them}\r
+      state.requesttype := querytype_aaaa;\r
+      goto recursed;\r
+    end;\r
+{$endif}\r
+    goto failure;\r
+recursed:\r
+    {here it needs recursed lookup}\r
+    {if needing to follow a cname, change state to do so}\r
+    inc(state.recursioncount);\r
+    if state.recursioncount > maxrecursion then goto failure;\r
+  end;\r
+\r
+  {here, a name needs to be resolved}\r
+  if state.queryname = '' then begin\r
+    failurereason := 'empty query name';\r
+    goto failure;\r
+  end;\r
+\r
+  {do /ets/hosts lookup here}\r
+  state.sendpacketlen := buildrequest(state.queryname,state.sendpacket,state.requesttype);\r
+  if state.sendpacketlen = 0 then begin\r
+    failurereason := 'building request packet failed';\r
+    goto failure;\r
+  end;\r
+  state.id := state.sendpacket.id;\r
+  state.resultaction := action_sendquery;\r
+\r
+  exit;\r
+failure:\r
+  setstate_failure(state);\r
+end;\r
+{$ifdef win32}\r
+  const\r
+    MAX_HOSTNAME_LEN = 132;\r
+    MAX_DOMAIN_NAME_LEN = 132;\r
+    MAX_SCOPE_ID_LEN = 260    ;\r
+    MAX_ADAPTER_NAME_LENGTH = 260;\r
+    MAX_ADAPTER_ADDRESS_LENGTH = 8;\r
+    MAX_ADAPTER_DESCRIPTION_LENGTH = 132;\r
+    ERROR_BUFFER_OVERFLOW = 111;\r
+    MIB_IF_TYPE_ETHERNET = 6;\r
+    MIB_IF_TYPE_TOKENRING = 9;\r
+    MIB_IF_TYPE_FDDI = 15;\r
+    MIB_IF_TYPE_PPP = 23;\r
+    MIB_IF_TYPE_LOOPBACK = 24;\r
+    MIB_IF_TYPE_SLIP = 28;\r
+\r
+\r
+  type\r
+    tip_addr_string=packed record\r
+      Next :pointer;\r
+      IpAddress : array[0..15] of char;\r
+      ipmask    : array[0..15] of char;\r
+      context   : dword;\r
+    end;\r
+    pip_addr_string=^tip_addr_string;\r
+    tFIXED_INFO=packed record\r
+       HostName         : array[0..MAX_HOSTNAME_LEN-1] of char;\r
+       DomainName       : array[0..MAX_DOMAIN_NAME_LEN-1] of char;\r
+       currentdnsserver : pip_addr_string;\r
+       dnsserverlist    : tip_addr_string;\r
+       nodetype         : longint;\r
+       ScopeId          : array[0..MAX_SCOPE_ID_LEN + 4] of char;\r
+       enablerouting    : longbool;\r
+       enableproxy      : longbool;\r
+       enabledns        : longbool;\r
+    end;\r
+    pFIXED_INFO=^tFIXED_INFO;\r
+\r
+  var\r
+    iphlpapi : thandle;\r
+    getnetworkparams : function(pFixedInfo : PFIXED_INFO;OutBufLen : plongint) : longint;stdcall;\r
+{$endif}\r
+procedure populatednsserverlist;\r
+var\r
+  {$ifdef win32}\r
+    fixed_info : pfixed_info;\r
+    fixed_info_len : longint;\r
+    currentdnsserver : pip_addr_string;\r
+  {$else}\r
+    t:textfile;\r
+    s:string;\r
+    a:integer;\r
+  {$endif}\r
+begin\r
+  //result := '';\r
+  if assigned(dnsserverlist) then begin\r
+    dnsserverlist.clear;\r
+  end else begin\r
+    dnsserverlist := tstringlist.Create;\r
+  end;\r
+  {$ifdef win32}\r
+    if iphlpapi=0 then iphlpapi := loadlibrary('iphlpapi.dll');\r
+    if not assigned(getnetworkparams) then @getnetworkparams := getprocaddress(iphlpapi,'GetNetworkParams');\r
+    fixed_info_len := 0;\r
+    if GetNetworkParams(nil,@fixed_info_len)<>ERROR_BUFFER_OVERFLOW then exit;\r
+    //fixed_info_len :=sizeof(tfixed_info);\r
+    getmem(fixed_info,fixed_info_len);\r
+    if GetNetworkParams(fixed_info,@fixed_info_len)<>0 then begin\r
+      freemem(fixed_info);\r
+      exit;\r
+    end;\r
+    currentdnsserver := @(fixed_info.dnsserverlist);\r
+    while assigned(currentdnsserver) do begin\r
+      dnsserverlist.Add(currentdnsserver.IpAddress);\r
+      currentdnsserver := currentdnsserver.next;\r
+    end;\r
+    freemem(fixed_info);\r
+  {$else}\r
+    filemode := 0;\r
+    assignfile(t,'/etc/resolv.conf');\r
+    {$i-}reset(t);{$i+}\r
+    if ioresult <> 0 then exit;\r
+\r
+    while not eof(t) do begin\r
+      readln(t,s);\r
+      if not (copy(s,1,10) = 'nameserver') then continue;\r
+      s := copy(s,11,500);\r
+      while s <> '' do begin\r
+        if (s[1] = #32) or (s[1] = #9) then s := copy(s,2,500) else break;\r
+      end;\r
+      a := pos(' ',s);\r
+      if a <> 0 then s := copy(s,1,a-1);\r
+      a := pos(#9,s);\r
+      if a <> 0 then s := copy(s,1,a-1);\r
+      //result := s;\r
+      //if result <> '' then break;\r
+      dnsserverlist.Add(s);\r
+    end;\r
+    close(t);\r
+  {$endif}\r
+end;\r
+\r
+procedure cleardnsservercache;\r
+begin\r
+  if assigned(dnsserverlist) then begin\r
+    dnsserverlist.destroy;\r
+    dnsserverlist := nil;\r
+  end;\r
+end;\r
+\r
+function getcurrentsystemnameserver(var id:integer):string;\r
+var \r
+  counter : integer;\r
+\r
+begin\r
+  if not assigned(dnsserverlist) then populatednsserverlist;\r
+  if dnsserverlist.count=0 then raise exception.create('no dns servers availible');\r
+  id := 0;\r
+  if dnsserverlist.count >1 then begin\r
+\r
+    for counter := 1 to dnsserverlist.count-1 do begin\r
+      if taddrint(dnsserverlist.objects[counter]) < taddrint(dnsserverlist.objects[id]) then id := counter;\r
+    end;\r
+  end;\r
+  result := dnsserverlist[id]\r
+end;\r
+\r
+procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout\r
+var\r
+  counter : integer;\r
+  temp : integer;\r
+begin\r
+  if (id < 0) or (id >= dnsserverlist.count) then exit;\r
+  if lag = -1 then lag := timeoutlag;\r
+  for counter := 0 to dnsserverlist.count-1 do begin\r
+    temp := taddrint(dnsserverlist.objects[counter]) *15;\r
+    if counter=id then temp := temp + lag;\r
+    dnsserverlist.objects[counter] := tobject(temp div 16);\r
+  end;\r
+\r
+end;\r
+\r
+{  quick and dirty description of dns packet structure to aid writing and\r
+   understanding of parser code, refer to appropriate RFCs for proper specs\r
+- all words are network order\r
+\r
+www.google.com A request:\r
+\r
+0, 2: random transaction ID\r
+2, 2: flags: only the "recursion desired" bit set. (bit 8 of word)\r
+4, 2: questions: 1\r
+6, 2: answer RR's: 0.\r
+8, 2: authority RR's: 0.\r
+10, 2: additional RR's: 0.\r
+12, n: payload:\r
+  query:\r
+    #03 "www" #06 "google" #03 "com" #00\r
+    size-4, 2: type: host address (1)\r
+    size-2, 2: class: inet (1)\r
+\r
+reply:\r
+\r
+0,2: random transaction ID\r
+2,2: flags: set: response (bit 15), recursion desired (8), recursion available (7)\r
+4,4: questions: 1\r
+6,4: answer RR's: 2\r
+8,4: authority RR's: 9\r
+10,4: additional RR's: 9\r
+12: payload:\r
+  query:\r
+    ....\r
+  answer: CNAME\r
+    0,2 "c0 0c" "name: www.google.com"\r
+    2,2 "00 05" "type: cname for an alias"\r
+    4,2 "00 01" "class: inet"\r
+    6,4: TTL\r
+    10,2: data length "00 17" (23)\r
+    12: the cname name (www.google.akadns.net)\r
+  answer: A\r
+    0,2 ..\r
+    2,2 "00 01" host address\r
+    4,2 ...\r
+    6,4 ...\r
+    10,2: data length (4)\r
+    12,4: binary IP\r
+  authority - 9 records\r
+  additional - 9 records\r
+\r
+\r
+  ipv6 AAAA reply:\r
+    0,2: ...\r
+    2,2: type: 001c\r
+    4,2: class: inet (0001)\r
+    6,2: TTL\r
+    10,2: data size (16)\r
+    12,16: binary IP\r
+\r
+  ptr request: query type 000c\r
+\r
+name compression: word "cxxx" in the name, xxx points to offset in the packet}\r
+\r
+end.\r

diff --git a/httpserver_20080306/dnssync.pas b/httpserver_20080306/dnssync.pas
new file mode 100755 (executable)
index 0000000..c64d320
--- /dev/null
+++ b/httpserver_20080306/dnssync.pas
@@ -0,0 +1,262 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+unit dnssync;\r
+{$ifdef fpc}\r
+  {$mode delphi}\r
+{$endif}\r
+\r
+interface\r
+  uses\r
+    dnscore,\r
+    binipstuff,\r
+    {$ifdef win32}\r
+      winsock,\r
+      windows,\r
+    {$else}\r
+      {$ifdef VER1_0}\r
+        linux,\r
+      {$else}\r
+        baseunix,unix,\r
+      {$endif}\r
+      sockets,\r
+      fd_utils,\r
+    {$endif}\r
+    sysutils;\r
+\r
+//convert a name to an IP\r
+//IPV4 is preffered if availible, if not IPV6 will be returned (if ipv6 support\r
+//compiled in)\r
+//on error the binip will have a family of 0 (other fiels are also currently\r
+//zeroed out but may be used for further error information in future)\r
+//timeout is in seconds, it is ignored when using windows dns\r
+function forwardlookup(name:string;timeout:integer):tbinip;\r
+\r
+\r
+//convert an IP to a name, on error a null string will be returned, other \r
+//details as above\r
+function reverselookup(ip:tbinip;timeout:integer):string;\r
+\r
+\r
+var\r
+  dnssyncserver:string;\r
+  id : integer;\r
+  {$ifdef win32}\r
+    sendquerytime : integer;\r
+  {$else}\r
+    sendquerytime : ttimeval;\r
+  {$endif}\r
+implementation\r
+{$ifdef win32}\r
+  uses dnswin;\r
+{$endif}\r
+\r
+{$i unixstuff.inc}\r
+{$i ltimevalstuff.inc}\r
+\r
+var\r
+  fd:integer;\r
+  state:tdnsstate;\r
+{$ifdef win32}\r
+  const\r
+    winsocket = 'wsock32.dll';\r
+  function sendto(s: TSocket; const Buf; len, flags: Integer; var addrto: TinetSockAddr; tolen: Integer): Integer; stdcall; external    winsocket name 'sendto';\r
+  function bind(s: TSocket; var addr: TinetSockAddr; namelen: Integer): Longbool; stdcall; external    winsocket name 'bind';\r
+  type\r
+    fdset=tfdset;\r
+{$endif}\r
+\r
+function sendquery(const packet:tdnspacket;len:integer):boolean;\r
+var\r
+  a:integer;\r
+  addr       : string;\r
+  port       : string;\r
+  inaddr     : TInetSockAddr;\r
+\r
+begin\r
+{  writeln('sendquery ',decodename(state.packet,state.packetlen,12,0,a),' ',state.requesttype);}\r
+  result := false;\r
+  if len = 0 then exit; {no packet}\r
+\r
+  if dnssyncserver <> '' then addr := dnssyncserver else addr := getcurrentsystemnameserver(id);\r
+  port := '53';\r
+\r
+  inAddr.family:=AF_INET;\r
+  inAddr.port:=htons(strtointdef(port,0));\r
+  inAddr.addr:=htonl(longip(addr));\r
+\r
+  sendto(fd,packet,len,0,inaddr,sizeof(inaddr));\r
+  {$ifdef win32}\r
+    sendquerytime := GetTickCount and $3fff;\r
+  {$else}\r
+    gettimeofday(sendquerytime);\r
+  {$endif}\r
+  result := true;\r
+end;\r
+\r
+procedure setupsocket;\r
+var\r
+  inAddrtemp : TInetSockAddr;\r
+begin\r
+  if fd > 0 then exit;\r
+\r
+  fd := Socket(AF_INET,SOCK_DGRAM,0);\r
+  inAddrtemp.family:=AF_INET;\r
+  inAddrtemp.port:=0;\r
+  inAddrtemp.addr:=0;{htonl(longip('0.0.0.0'));}\r
+  If {$ifndef win32}Not{$endif} Bind(fd,inAddrtemp,SizeOf(inAddrtemp)) Then begin\r
+    {$ifdef win32}\r
+      raise Exception.create('unable to bind '+inttostr(WSAGetLastError));\r
+    {$else}\r
+      raise Exception.create('unable to bind '+inttostr(socketError));\r
+    {$endif}\r
+  end;\r
+end;\r
+\r
+procedure resolveloop(timeout:integer);\r
+var\r
+  selectresult   : integer;\r
+  fds            : fdset;\r
+  {$ifdef win32}\r
+    endtime      : longint;\r
+    starttime    : longint;\r
+    wrapmode     : boolean;\r
+    currenttime  : integer;\r
+  {$else}\r
+    endtime      : ttimeval;\r
+    currenttime    : ttimeval;\r
+\r
+  {$endif}\r
+  lag            : ttimeval;\r
+  currenttimeout : ttimeval;\r
+  selecttimeout         : ttimeval;\r
+\r
+\r
+begin\r
+  {$ifdef win32}\r
+    starttime := GetTickCount and $3fff;\r
+    endtime := starttime +(timeout*1000);\r
+    if (endtime and $4000)=0 then begin\r
+      wrapmode := false;\r
+    end else begin\r
+      wrapmode := true;\r
+    end;\r
+    endtime := endtime and $3fff;\r
+  {$else}\r
+    gettimeofday(endtime);\r
+    endtime.tv_sec := endtime.tv_sec + timeout;\r
+  {$endif}\r
+\r
+  setupsocket;\r
+  repeat\r
+    state_process(state);\r
+    case state.resultaction of\r
+      action_ignore: begin\r
+{        writeln('ignore');}\r
+        {do nothing}\r
+      end;\r
+      action_done: begin\r
+{        writeln('done');}\r
+        exit;\r
+        //onrequestdone(self,0);\r
+      end;\r
+      action_sendquery:begin\r
+{        writeln('send query');}\r
+        sendquery(state.sendpacket,state.sendpacketlen);\r
+      end;\r
+    end;\r
+    {$ifdef win32}\r
+      currenttime := GetTickCount and $3fff;\r
+      msectotimeval(selecttimeout, (endtime-currenttime)and$3fff);\r
+    {$else}\r
+      gettimeofday(currenttime);\r
+      selecttimeout := endtime;\r
+      tv_substract(selecttimeout,currenttime);\r
+    {$endif}\r
+    fd_zero(fds);\r
+    fd_set(fd,fds);\r
+    if (selecttimeout.tv_sec > 0) or (selecttimeout.tv_usec > retryafter) then begin\r
+      selecttimeout.tv_sec := 0;\r
+      selecttimeout.tv_usec := retryafter;\r
+    end;\r
+    selectresult := select(fd+1,@fds,nil,nil,@selecttimeout);\r
+    if selectresult > 0 then begin\r
+{      writeln('selectresult>0');}\r
+      //why the hell are we zeroing out the packet buffer before reading into it?! --plugwash\r
+      fillchar(state.recvpacket,sizeof(state.recvpacket),0);\r
+      {$ifdef win32}\r
+        msectotimeval(lag,(currenttime-sendquerytime)and$3fff);\r
+      {$else}\r
+        lag := currenttime;\r
+        tv_substract(lag,sendquerytime);\r
+\r
+      {$endif}\r
+\r
+      reportlag(id,(lag.tv_sec*1000000)+lag.tv_usec);\r
+      state.recvpacketlen := recv(fd,state.recvpacket, SizeOf(state.recvpacket),0);\r
+      state.parsepacket := true;\r
+    end;\r
+    if selectresult < 0 then exit;\r
+    if selectresult = 0 then begin\r
+      {$ifdef win32}\r
+        currenttime := GetTickCount;\r
+      {$else}\r
+        gettimeofday(currenttime);\r
+      {$endif}\r
+      reportlag(id,-1);\r
+      if {$ifdef win32}(currenttime >= endtime)and ((not wrapmode) or (currenttime < starttime)) {$else}tv_compare(currenttime,endtime){$endif} {currenttime >= endtime } then begin\r
+        exit;\r
+      end else begin\r
+        //resend\r
+        sendquery(state.sendpacket,state.sendpacketlen);\r
+      end;\r
+    end;\r
+  until false;\r
+end;\r
+\r
+function forwardlookup(name:string;timeout:integer):tbinip;\r
+var\r
+  dummy : integer;\r
+begin\r
+  ipstrtobin(name,result);\r
+  if result.family <> 0 then exit; //it was an IP address, no need for dns\r
+                                   //lookup\r
+  {$ifdef win32}\r
+    if usewindns then begin\r
+      result := winforwardlookup(name,false,dummy);\r
+      exit;\r
+    end;\r
+  {$endif}\r
+  setstate_forward(name,state,0);\r
+  resolveloop(timeout);\r
+  result := state.resultbin;\r
+end;\r
+\r
+function reverselookup(ip:tbinip;timeout:integer):string;\r
+var\r
+  dummy : integer;\r
+begin\r
+  {$ifdef win32}\r
+    if usewindns then begin\r
+      result := winreverselookup(ip,dummy);\r
+      exit;\r
+    end;\r
+  {$endif}\r
+  setstate_reverse(ip,state);\r
+  resolveloop(timeout);\r
+  result := state.resultstr;\r
+end;\r
+\r
+{$ifdef win32}\r
+  var\r
+    wsadata : twsadata;\r
+\r
+  initialization\r
+    WSAStartUp($2,wsadata);\r
+  finalization\r
+    WSACleanUp;\r
+{$endif}\r
+end.\r
+\r
+\r

diff --git a/httpserver_20080306/dnswin.pas b/httpserver_20080306/dnswin.pas
new file mode 100755 (executable)
index 0000000..bae0780
--- /dev/null
+++ b/httpserver_20080306/dnswin.pas
@@ -0,0 +1,332 @@
+unit dnswin;\r
+\r
+interface\r
+uses binipstuff,classes,lcore;\r
+\r
+//on failure a null string or zeroed out binip will be retuned and error will be\r
+//set to a windows error code (error will be left untouched under non error\r
+//conditions).\r
+function winforwardlookup(name : string;ipv6preffered : boolean;var error:integer) : tbinip;\r
+function winreverselookup(ip:tbinip;var error:integer):string;\r
+\r
+\r
+type\r
+  //do not call destroy on a tdnswinasync instead call release and the\r
+  //dnswinasync will be freed when appropriate. Calling destroy will block\r
+  //the calling thread until the dns lookup completes.\r
+  //release should only be called from the main thread\r
+  tdnswinasync=class(tthread)\r
+  private\r
+    ipv6preffered : boolean;\r
+    freverse : boolean;\r
+    error : integer;\r
+    freewhendone : boolean;\r
+    hadevent : boolean;\r
+  protected\r
+    procedure execute; override;\r
+  public\r
+    onrequestdone:tsocketevent;\r
+    name : string;\r
+    ip : tbinip;\r
+\r
+    procedure forwardlookup(name:string;ipv6preffered:boolean);\r
+    procedure reverselookup(ip:tbinip);\r
+    destructor destroy; override;\r
+    procedure release;\r
+    constructor create;\r
+    property reverse : boolean read freverse;\r
+\r
+  end;\r
+\r
+implementation\r
+uses\r
+  lsocket,pgtypes,sysutils,winsock,windows,messages;\r
+\r
+type\r
+  //taddrinfo = record; //forward declaration\r
+  paddrinfo = ^taddrinfo;\r
+  taddrinfo = packed record\r
+    ai_flags : longint;\r
+    ai_family : longint;\r
+    ai_socktype : longint;\r
+    ai_protocol : longint;\r
+    ai_addrlen : taddrint;\r
+    ai_canonname : pchar;\r
+    ai_addr : pinetsockaddrv;\r
+    ai_next : paddrinfo;\r
+  end;\r
+  ppaddrinfo = ^paddrinfo;\r
+  tgetaddrinfo = function(nodename : pchar; servname : pchar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall;\r
+  tfreeaddrinfo = procedure(ai : paddrinfo); stdcall;\r
+  tgetnameinfo = function(sa:Pinetsockaddrv;salen : longint; host:pchar;hostlen : longint;serv:pchar;servlen:longint;flags:longint) : longint;stdcall;\r
+var\r
+  getaddrinfo : tgetaddrinfo;\r
+  freeaddrinfo : tfreeaddrinfo;\r
+  getnameinfo : tgetnameinfo;\r
+procedure v4onlyfreeaddrinfo(ai : paddrinfo); stdcall;\r
+begin\r
+  freemem(ai.ai_addr);\r
+  freemem(ai);\r
+end;\r
+\r
+type\r
+  plongint = ^longint;\r
+  pplongint = ^plongint;\r
+\r
+function v4onlygetaddrinfo(nodename : pchar; servname : pchar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall;\r
+var\r
+  output : paddrinfo;\r
+  hostent : phostent;\r
+begin\r
+  if hints.ai_family = af_inet then begin\r
+    result := 0;\r
+    getmem(output,sizeof(taddrinfo));\r
+    getmem(output.ai_addr,sizeof(tinetsockaddr));\r
+    output.ai_addr.InAddr.family := af_inet;\r
+    if servname <> nil then output.ai_addr.InAddr.port := htons(strtoint(servname)) else output.ai_addr.InAddr.port := 0;\r
+    hostent := gethostbyname(nodename);\r
+    if hostent = nil then begin\r
+      result := wsagetlasterror;\r
+      v4onlyfreeaddrinfo(output);\r
+      exit;\r
+    end;\r
+    output.ai_addr.InAddr.addr := pplongint(hostent.h_addr_list)^^;\r
+    output.ai_flags := 0;\r
+    output.ai_family := af_inet;\r
+    output.ai_socktype := 0;\r
+    output.ai_protocol := 0;\r
+    output.ai_addrlen := sizeof(tinetsockaddr);\r
+    output.ai_canonname := nil;\r
+    output.ai_next := nil;\r
+\r
+    res^ := output;\r
+  end else begin\r
+    result := WSANO_RECOVERY;\r
+  end;\r
+end;\r
+\r
+function min(a,b : integer):integer;\r
+begin\r
+  if a<b then result := a else result := b;\r
+end;\r
+\r
+function v4onlygetnameinfo(sa:Pinetsockaddrv;salen : longint; host:pchar;hostlen : longint;serv:pchar;servlen:longint;flags:longint) : longint;stdcall;\r
+var\r
+  hostent : phostent;\r
+  bytestocopy : integer;\r
+begin\r
+  if sa.InAddr.family = af_inet then begin\r
+    result := 0;\r
+    hostent := gethostbyaddr(@(sa.inaddr.addr),4,AF_INET);\r
+    if hostent = nil then begin\r
+      result := wsagetlasterror;\r
+      exit;\r
+    end;\r
+    bytestocopy := min(strlen(hostent.h_name)+1,hostlen);\r
+    move((hostent.h_name)^,host^,bytestocopy);\r
+\r
+\r
+  end else begin\r
+    result := WSANO_RECOVERY;\r
+  end;\r
+end;\r
+\r
+\r
+procedure populateprocvars;\r
+var\r
+  libraryhandle : hmodule;\r
+  i : integer;\r
+  dllname : string;\r
+\r
+begin\r
+  if assigned(getaddrinfo) then exit; //procvars already populated\r
+  for i := 0 to 1 do begin\r
+    if i=0 then dllname := 'Ws2_32.dll' else dllname := 'Wship6.dll';\r
+    libraryhandle := LoadLibrary(pchar(dllname));\r
+    getaddrinfo := getprocaddress(libraryhandle,'getaddrinfo');\r
+    freeaddrinfo := getprocaddress(libraryhandle,'freeaddrinfo');\r
+    getnameinfo := getprocaddress(libraryhandle,'getnameinfo');\r
+    if assigned(getaddrinfo) and assigned(freeaddrinfo) and assigned(getnameinfo) then begin\r
+      //writeln('found getaddrinfo and freeaddrinfo in'+dllname);\r
+      exit; //success\r
+    end;\r
+\r
+  end;\r
+  //writeln('could not find getaddrinfo and freeaddrinfo, falling back to ipv4 only lookup');\r
+  getaddrinfo := v4onlygetaddrinfo;\r
+  freeaddrinfo := v4onlyfreeaddrinfo;\r
+  getnameinfo := v4onlygetnameinfo;\r
+end;\r
+\r
+\r
+function winforwardlookup(name : string;ipv6preffered : boolean;var error : integer) : tbinip;\r
+var\r
+  hints: taddrinfo;\r
+  res : paddrinfo;\r
+  pass : boolean;\r
+  ipv6 : boolean;\r
+  getaddrinforesult : integer;\r
+begin\r
+  populateprocvars;\r
+\r
+  for pass := false to true do begin\r
+    ipv6 := ipv6preffered xor pass;\r
+    hints.ai_flags := 0;\r
+    if ipv6 then begin\r
+      hints.ai_family := AF_INET6;\r
+    end else begin\r
+      hints.ai_family := AF_INET;\r
+    end;\r
+    hints.ai_socktype := 0;\r
+    hints.ai_protocol := 0;\r
+    hints.ai_addrlen := 0;\r
+    hints.ai_canonname := nil;\r
+    hints.ai_addr := nil;\r
+    hints.ai_next := nil;\r
+    getaddrinforesult := getaddrinfo(pchar(name),'1',@hints,@res);\r
+    if getaddrinforesult = 0 then begin\r
+      if res.ai_family = af_inet then begin\r
+        result.family := af_inet;\r
+        result.ip := res.ai_addr.InAddr.addr;\r
+      end else if res.ai_family = af_inet6 then begin\r
+        result.family := af_inet6;\r
+        result.ip6 := res.ai_addr.InAddr6.sin6_addr;\r
+      end;\r
+\r
+      freeaddrinfo(res);\r
+      exit;\r
+    end;\r
+  end;\r
+  if getaddrinforesult <> 0 then begin\r
+    fillchar(result,0,sizeof(result));\r
+    error := getaddrinforesult;\r
+  end;\r
+end;\r
+\r
+function winreverselookup(ip:tbinip;var error : integer):string;\r
+var\r
+  sa : tinetsockaddrv;\r
+  getnameinforesult : integer;\r
+begin\r
+\r
+  if ip.family = AF_INET then begin\r
+    sa.InAddr.family := AF_INET;\r
+    sa.InAddr.port := 1;\r
+    sa.InAddr.addr := ip.ip;\r
+  end else if ip.family = AF_INET6 then begin\r
+    sa.InAddr6.sin6_family  := AF_INET6;\r
+    sa.InAddr6.sin6_port := 1;\r
+    sa.InAddr6.sin6_addr := ip.ip6;\r
+  end else begin\r
+    raise exception.create('unrecognised address family');\r
+  end;\r
+  populateprocvars;\r
+  setlength(result,1025);\r
+  getnameinforesult := getnameinfo(@sa,sizeof(tinetsockaddrv),pchar(result),length(result),nil,0,0);\r
+  if getnameinforesult <> 0 then begin\r
+    error := getnameinforesult;\r
+    result := '';\r
+    exit;\r
+  end;\r
+  if pos(#0,result) >= 0 then begin\r
+    setlength(result,pos(#0,result)-1);\r
+  end;\r
+end;\r
+\r
+var\r
+  hwnddnswin : hwnd;\r
+\r
+function MyWindowProc(\r
+    ahWnd   : HWND;\r
+    auMsg   : Integer;\r
+    awParam : WPARAM;\r
+    alParam : LPARAM): Integer; stdcall;\r
+var\r
+  dwas : tdnswinasync;\r
+begin\r
+  if (ahwnd=hwnddnswin) and (aumsg=wm_user) then begin\r
+    Dwas := tdnswinasync(alparam);\r
+    dwas.hadevent := true;\r
+    if assigned (dwas.onrequestdone) then dwas.onrequestdone(dwas,awparam);\r
+    if dwas.freewhendone then dwas.free;\r
+  end else begin\r
+    //not passing unknown messages on to defwindowproc will cause window\r
+    //creation to fail! --plugwash\r
+    Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)\r
+  end;\r
+end;\r
+\r
+procedure tdnswinasync.forwardlookup(name:string;ipv6preffered:boolean);\r
+begin\r
+  self.name := name;\r
+  self.ipv6preffered := ipv6preffered;\r
+  freverse := false;\r
+  resume;\r
+end;\r
+procedure tdnswinasync.reverselookup(ip:tbinip);\r
+begin\r
+  self.ip := ip;\r
+  freverse := true;\r
+  resume;\r
+end;\r
+procedure tdnswinasync.execute;\r
+var\r
+  error : integer;\r
+begin\r
+  error := 0;\r
+  if reverse then begin\r
+    name := winreverselookup(ip,error);\r
+  end else begin\r
+    ip := winforwardlookup(name,ipv6preffered,error);\r
+\r
+  end;\r
+\r
+  postmessage(hwnddnswin,wm_user,error,taddrint(self));\r
+end;\r
+\r
+destructor tdnswinasync.destroy; \r
+begin\r
+  WaitFor;\r
+  inherited destroy;\r
+end;\r
+procedure tdnswinasync.release;\r
+begin\r
+  if hadevent then destroy else begin\r
+    onrequestdone := nil;\r
+    freewhendone := true;\r
+  end;\r
+end;\r
+\r
+constructor tdnswinasync.create;\r
+begin\r
+  inherited create(true);\r
+end;\r
+\r
+var\r
+  MyWindowClass : TWndClass = (style         : 0;\r
+                                 lpfnWndProc   : @MyWindowProc;\r
+                                 cbClsExtra    : 0;\r
+                                 cbWndExtra    : 0;\r
+                                 hInstance     : 0;\r
+                                 hIcon         : 0;\r
+                                 hCursor       : 0;\r
+                                 hbrBackground : 0;\r
+                                 lpszMenuName  : nil;\r
+                                 lpszClassName : 'dnswinClass');\r
+begin\r
+\r
+    if Windows.RegisterClass(MyWindowClass) = 0 then halt;\r
+  //writeln('about to create lcore handle, hinstance=',hinstance);\r
+  hwnddnswin := CreateWindowEx(WS_EX_TOOLWINDOW,\r
+                               MyWindowClass.lpszClassName,\r
+                               '',        { Window name   }\r
+                               WS_POPUP,  { Window Style  }\r
+                               0, 0,      { X, Y          }\r
+                               0, 0,      { Width, Height }\r
+                               0,         { hWndParent    }\r
+                               0,         { hMenu         }\r
+                               HInstance, { hInstance     }\r
+                               nil);      { CreateParam   }\r
+  //writeln('dnswin hwnd is ',hwnddnswin);\r
+  //writeln('last error is ',GetLastError);\r
+end.\r

diff --git a/httpserver_20080306/fd_utils.pas b/httpserver_20080306/fd_utils.pas
new file mode 100755 (executable)
index 0000000..9ad93dd
--- /dev/null
+++ b/httpserver_20080306/fd_utils.pas
@@ -0,0 +1,69 @@
+// this file contains code copied from linux.pp in the free pascal rtl\r
+// i had to copy them because i use a different definition of fdset to them\r
+// the copyright block from the file in question is shown below\r
+{\r
+   $Id: fd_utils.pas,v 1.2 2004/08/19 23:12:09 plugwash Exp $\r
+   This file is part of the Free Pascal run time library.\r
+   Copyright (c) 1999-2000 by Michael Van Canneyt,\r
+   BSD parts (c) 2000 by Marco van de Voort\r
+   members of the Free Pascal development team.\r
+\r
+   See the file COPYING.FPC, included in this distribution,\r
+   for details about the copyright.\r
+\r
+   This program is distributed in the hope that it will be useful,\r
+   but WITHOUT ANY WARRANTY;without even the implied warranty of\r
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\r
+\r
+**********************************************************************}\r
+{$ifdef fpc}\r
+  {$mode delphi}\r
+  {$inlining on}\r
+{$endif}\r
+unit fd_utils;\r
+interface\r
+\r
+type\r
+    FDSet= Array [0..255] of longint; {31}\r
+    PFDSet= ^FDSet;\r
+const\r
+    absoloutemaxs=(sizeof(fdset)*8)-1;\r
+\r
+Procedure FD_Clr(fd:longint;var fds:fdSet);\r
+Procedure FD_Zero(var fds:fdSet);\r
+Procedure FD_Set(fd:longint;var fds:fdSet);\r
+Function FD_IsSet(fd:longint;var fds:fdSet):boolean;\r
+\r
+\r
+implementation  \r
+uses sysutils;\r
+Procedure FD_Clr(fd:longint;var fds:fdSet);{$ifdef fpc}inline;{$endif}\r
+{ Remove fd from the set of filedescriptors}\r
+begin\r
+  if (fd < 0) then raise exception.create('FD_Clr fd out of range: '+inttostr(fd));\r
+  fds[fd shr 5]:=fds[fd shr 5] and (not (1 shl (fd and 31)));\r
+end;\r
+\r
+Procedure FD_Zero(var fds:fdSet);\r
+{ Clear the set of filedescriptors }\r
+begin\r
+  FillChar(fds,sizeof(fdSet),0);\r
+end;\r
+\r
+Procedure FD_Set(fd:longint;var fds:fdSet);{$ifdef fpc}inline;{$endif}\r
+{ Add fd to the set of filedescriptors }\r
+begin\r
+  if (fd < 0) then raise exception.create('FD_set fd out of range: '+inttostr(fd));\r
+  fds[fd shr 5]:=fds[fd shr 5] or (1 shl (fd and 31));\r
+end;\r
+\r
+Function FD_IsSet(fd:longint;var fds:fdSet):boolean;{$ifdef fpc}inline;{$endif}\r
+{ Test if fd is part of the set of filedescriptors }\r
+begin\r
+  if (fd < 0) then begin\r
+    result := false;\r
+    exit;\r
+  end;\r
+  FD_IsSet:=((fds[fd shr 5] and (1 shl (fd and 31)))<>0);\r
+end;\r
+end.\r

diff --git a/httpserver_20080306/lcore.pas b/httpserver_20080306/lcore.pas
new file mode 100755 (executable)
index 0000000..51fbf78
--- /dev/null
+++ b/httpserver_20080306/lcore.pas
@@ -0,0 +1,889 @@
+{lsocket.pas}\r
+\r
+{io and timer code by plugwash}\r
+\r
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+\r
+{note: you must use the @ in the last param to tltask.create not doing so will\r
+ compile without error but will cause an access violation -pg}\r
+\r
+//note: events after release are normal and are the apps responsibility to deal with safely\r
+\r
+unit lcore;\r
+{$ifdef fpc}\r
+  {$mode delphi}\r
+{$endif}\r
+{$ifdef win32}\r
+  {$define nosignal}\r
+{$endif}\r
+interface\r
+  uses\r
+    sysutils,\r
+    {$ifndef win32}\r
+      {$ifdef VER1_0}\r
+        linux,\r
+      {$else}\r
+        baseunix,unix,\r
+      {$endif}\r
+      fd_utils,\r
+    {$endif}\r
+    classes,pgtypes,bfifo;\r
+  procedure processtasks;\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+  const\r
+    receivebufsize=1460;\r
+\r
+  type\r
+    {$ifdef ver1_0}\r
+      sigset= array[0..31] of longint;\r
+    {$endif}\r
+\r
+    ESocketException   = class(Exception);\r
+    TBgExceptionEvent  = procedure (Sender : TObject;\r
+                                  E : Exception;\r
+                                  var CanClose : Boolean) of object;\r
+\r
+    // note : tsocketstate is defined in the same way as it is in François PIETTE's twsocket\r
+    // however tlsocket currently only uses wsClosed wsConnecting wsconnected and wsListening\r
+    TSocketState       = (wsInvalidState,\r
+                        wsOpened,     wsBound,\r
+                        wsConnecting, wsConnected,\r
+                        wsAccepting,  wsListening,\r
+                        wsClosed);\r
+\r
+    TWSocketOption       = (wsoNoReceiveLoop, wsoTcpNoDelay);\r
+    TWSocketOptions      = set of TWSocketOption;\r
+\r
+    TSocketevent     = procedure(Sender: TObject; Error: word) of object;\r
+    //Tdataavailevent  = procedure(data : string);\r
+    TSendData          = procedure (Sender: TObject; BytesSent: Integer) of object;\r
+\r
+    tlcomponent = class(tcomponent)\r
+    public\r
+      released:boolean;\r
+      procedure release; virtual;\r
+      destructor destroy; override;\r
+    end;\r
+\r
+    tlasio = class(tlcomponent)\r
+    public\r
+      state              : tsocketstate      ;\r
+      ComponentOptions   : TWSocketOptions;\r
+      fdhandlein         : Longint           ;  {file discriptor}\r
+      fdhandleout        : Longint           ;  {file discriptor}\r
+\r
+      onsessionclosed    : tsocketevent      ;\r
+      ondataAvailable    : tsocketevent      ;\r
+      onsessionAvailable : tsocketevent      ;\r
+\r
+      onsessionconnected : tsocketevent      ;\r
+      onsenddata         : tsenddata      ;\r
+      ondatasent         : tsocketevent      ;\r
+      //connected          : boolean         ;\r
+      nextasin           : tlasio            ;\r
+      prevasin           : tlasio            ;\r
+\r
+      recvq              : tfifo;\r
+      OnBgException      : TBgExceptionEvent ;\r
+      //connectread        : boolean           ;\r
+      sendq              : tfifo;\r
+      closehandles       : boolean           ;\r
+      writtenthiscycle   : boolean           ;\r
+      onfdwrite           : procedure (Sender: TObject; Error: word) of object; //added for bewarehttpd\r
+      lasterror:integer;\r
+      destroying:boolean;\r
+      function receivestr:string; virtual;\r
+      procedure close;\r
+      procedure abort;\r
+      procedure internalclose(error:word); virtual;\r
+      constructor Create(AOwner: TComponent); override;\r
+\r
+      destructor destroy; override;\r
+      procedure fdcleanup;\r
+      procedure HandleBackGroundException(E: Exception);\r
+      procedure handlefdtrigger(readtrigger,writetrigger:boolean); virtual;\r
+      procedure dup(invalue:longint);\r
+\r
+      function sendflush : integer;\r
+      procedure sendstr(const str : string);virtual;\r
+      procedure putstringinsendbuffer(const newstring : string);\r
+      function send(data:pointer;len:integer):integer;virtual;\r
+      procedure putdatainsendbuffer(data:pointer;len:integer); virtual;\r
+      procedure deletebuffereddata;\r
+\r
+      //procedure messageloop;\r
+      function Receive(Buf:Pointer;BufSize:integer):integer; virtual;\r
+      procedure flush;virtual;{$ifdef win32} abstract;{$endif}\r
+      procedure dodatasent(wparam,lparam:longint);\r
+      procedure doreceiveloop(wparam,lparam:longint);\r
+      procedure sinkdata(sender:tobject;error:word);\r
+\r
+      procedure release; override; {test -beware}\r
+\r
+      function RealSend(Data : Pointer; Len : Integer) : Integer; //added for bewarehttpd\r
+\r
+      procedure myfdclose(fd : integer); virtual;{$ifdef win32}abstract;{$endif}\r
+      function myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt; virtual;{$ifdef win32}abstract;{$endif}\r
+      function myfdread(fd: LongInt;var buf;size: LongInt):LongInt; virtual;{$ifdef win32}abstract;{$endif}\r
+    protected\r
+      procedure dupnowatch(invalue:longint);\r
+    end;\r
+    ttimerwrapperinterface=class(tlcomponent)\r
+    public\r
+      function createwrappedtimer : tobject;virtual;abstract;\r
+//      procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);virtual;abstract;\r
+      procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);virtual;abstract;\r
+      procedure setenabled(wrappedtimer : tobject;newvalue : boolean);virtual;abstract;\r
+      procedure setinterval(wrappedtimer : tobject;newvalue : integer);virtual;abstract;\r
+    end;\r
+\r
+  var\r
+    timerwrapperinterface : ttimerwrapperinterface;\r
+  type\r
+    {$ifdef win32}\r
+      ttimeval = record\r
+        tv_sec : longint;\r
+        tv_usec : longint;\r
+      end;\r
+    {$endif}\r
+    tltimer=class(tlcomponent)\r
+    protected\r
+\r
+\r
+      wrappedtimer : tobject;\r
+\r
+\r
+//      finitialevent       : boolean           ;\r
+      fontimer            : tnotifyevent      ;\r
+      fenabled            : boolean           ;\r
+      finterval                  : integer          ; {miliseconds, default 1000}\r
+      {$ifndef win32}\r
+        procedure resettimes;\r
+      {$endif}\r
+//      procedure setinitialevent(newvalue : boolean);\r
+      procedure setontimer(newvalue:tnotifyevent);\r
+      procedure setenabled(newvalue : boolean);\r
+      procedure setinterval(newvalue : integer);\r
+    public\r
+      //making theese public for now, this code should probablly be restructured later though\r
+      prevtimer          : tltimer           ;\r
+      nexttimer          : tltimer           ;\r
+      nextts            : ttimeval          ;\r
+\r
+      constructor create(aowner:tcomponent);override;\r
+      destructor destroy;override;\r
+//      property initialevent : boolean read finitialevent write setinitialevent;\r
+      property ontimer : tnotifyevent read fontimer write setontimer;\r
+      property enabled : boolean read fenabled write setenabled;\r
+      property interval        : integer read finterval write setinterval;\r
+\r
+    end;\r
+\r
+    ttaskevent=procedure(wparam,lparam:longint) of object;\r
+\r
+    tltask=class(tobject)\r
+    public\r
+      handler  : ttaskevent;\r
+      obj      : tobject;\r
+      wparam   : longint;\r
+      lparam   : longint;\r
+      nexttask : tltask;\r
+      constructor create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+    end;\r
+\r
+\r
+\r
+    teventcore=class\r
+    public\r
+      procedure processmessages; virtual;abstract;\r
+      procedure messageloop; virtual;abstract;\r
+      procedure exitmessageloop; virtual;abstract;\r
+      procedure setfdreverse(fd : integer;reverseto : tlasio);virtual;abstract;\r
+      procedure rmasterset(fd : integer;islistensocket : boolean);  virtual;abstract;\r
+      procedure rmasterclr(fd: integer);  virtual;abstract;\r
+      procedure wmasterset(fd : integer); virtual;abstract;\r
+      procedure wmasterclr(fd: integer);  virtual;abstract;\r
+    end;\r
+var\r
+    eventcore : teventcore;\r
+\r
+procedure processmessages;\r
+procedure messageloop;\r
+procedure exitmessageloop;\r
+\r
+var\r
+  firstasin                             : tlasio     ;\r
+  firsttimer                            : tltimer    ;\r
+  firsttask  , lasttask   , currenttask : tltask     ;\r
+\r
+  numread                               : integer    ;\r
+  mustrefreshfds                        : boolean    ;\r
+{  lcoretestcount:integer;}\r
+\r
+  asinreleaseflag:boolean;\r
+\r
+\r
+procedure disconnecttasks(aobj:tobject);\r
+procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+type\r
+  tonaddtask = procedure(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+var\r
+  onaddtask : tonaddtask;\r
+\r
+\r
+procedure sleep(i:integer);\r
+{$ifndef nosignal}\r
+  procedure prepsigpipe;inline;\r
+{$endif}\r
+\r
+\r
+implementation\r
+{$ifndef nosignal}\r
+  uses {sockets,}lloopback,lsignal;\r
+{$endif}\r
+{$ifdef win32}\r
+  uses windows;\r
+{$endif}\r
+{$ifndef win32}\r
+  {$include unixstuff.inc}\r
+{$endif}\r
+{$include ltimevalstuff.inc}\r
+\r
+\r
+{!!! added sleep call -beware}\r
+procedure sleep(i:integer);\r
+var\r
+  tv:ttimeval;\r
+begin\r
+  {$ifdef win32}\r
+    windows.sleep(i);\r
+  {$else}\r
+    tv.tv_sec := i div 1000;\r
+    tv.tv_usec := (i mod 1000) * 1000;\r
+    select(0,nil,nil,nil,@tv);\r
+  {$endif}\r
+end;\r
+\r
+destructor tlcomponent.destroy;\r
+begin\r
+  disconnecttasks(self);\r
+  inherited destroy;\r
+end;\r
+\r
+\r
+\r
+\r
+procedure tlcomponent.release;\r
+begin\r
+  released := true;\r
+end;\r
+\r
+procedure tlasio.release;\r
+begin\r
+  asinreleaseflag := true;\r
+  inherited release;\r
+end;\r
+\r
+procedure tlasio.doreceiveloop;\r
+begin\r
+  if recvq.size = 0 then exit;\r
+  if assigned(ondataavailable) then ondataavailable(self,0);\r
+  if not (wsonoreceiveloop in componentoptions) then\r
+  if recvq.size > 0 then tltask.create(self.doreceiveloop,self,0,0);\r
+end;\r
+\r
+function tlasio.receivestr;\r
+begin\r
+  setlength(result,recvq.size);\r
+  receive(@result[1],length(result));\r
+end;\r
+\r
+function tlasio.receive(Buf:Pointer;BufSize:integer):integer;\r
+var\r
+  i,a,b:integer;\r
+  p:pointer;\r
+begin\r
+  i := bufsize;\r
+  if recvq.size < i then i := recvq.size;\r
+  a := 0;\r
+  while (a < i) do begin\r
+    b := recvq.get(p,i-a);\r
+    move(p^,buf^,b);\r
+    inc(taddrint(buf),b);\r
+    recvq.del(b);\r
+    inc(a,b);\r
+  end;\r
+  result := i;\r
+  if wsonoreceiveloop in componentoptions then begin\r
+    if recvq.size = 0 then eventcore.rmasterset(fdhandlein,false);\r
+  end;\r
+end;\r
+\r
+constructor tlasio.create;\r
+begin\r
+  inherited create(AOwner);\r
+  sendq := tfifo.create;\r
+  recvq := tfifo.create;\r
+  state := wsclosed;\r
+  fdhandlein := -1;\r
+  fdhandleout := -1;\r
+  nextasin := firstasin;\r
+  prevasin := nil;\r
+  if assigned(nextasin) then nextasin.prevasin := self;\r
+  firstasin := self;\r
+\r
+  released := false;\r
+end;\r
+\r
+destructor tlasio.destroy;\r
+begin\r
+  destroying := true;\r
+  if state <> wsclosed then close;\r
+  if prevasin <> nil then begin\r
+    prevasin.nextasin := nextasin;\r
+  end else begin\r
+    firstasin := nextasin;\r
+  end;\r
+  if nextasin <> nil then begin\r
+    nextasin.prevasin := prevasin;\r
+  end;\r
+  recvq.destroy;\r
+  sendq.destroy;\r
+  inherited destroy;\r
+end;\r
+\r
+procedure tlasio.close;\r
+begin\r
+  internalclose(0);\r
+end;\r
+\r
+procedure tlasio.abort;\r
+begin\r
+  close;\r
+end;\r
+\r
+procedure tlasio.fdcleanup;\r
+begin\r
+  if fdhandlein <> -1 then begin\r
+    eventcore.rmasterclr(fdhandlein); //fd_clr(fdhandlein,fdsrmaster)\r
+  end;\r
+  if fdhandleout <> -1 then begin\r
+    eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster)\r
+  end;\r
+  if fdhandlein=fdhandleout then begin\r
+    if fdhandlein <> -1 then begin\r
+      myfdclose(fdhandlein);\r
+    end;\r
+  end else begin\r
+    if fdhandlein <> -1 then begin\r
+      myfdclose(fdhandlein);\r
+    end;\r
+    if fdhandleout <> -1 then begin\r
+      myfdclose(fdhandleout);\r
+    end;\r
+  end;\r
+  fdhandlein := -1;\r
+  fdhandleout := -1;\r
+end;\r
+\r
+procedure tlasio.internalclose(error:word);\r
+begin\r
+  if state<>wsclosed then begin\r
+    if (fdhandlein < 0) or (fdhandleout < 0) then raise exception.create('internalclose called with invalid fd handles');\r
+    eventcore.rmasterclr(fdhandlein);//fd_clr(fdhandlein,fdsrmaster);\r
+    eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
+\r
+    if closehandles then begin\r
+      {$ifndef win32}\r
+        //anyone remember why this is here? --plugwash\r
+        fcntl(fdhandlein,F_SETFL,0);\r
+      {$endif}\r
+      myfdclose(fdhandlein);\r
+      if fdhandleout <> fdhandlein then begin\r
+        {$ifndef win32}\r
+          fcntl(fdhandleout,F_SETFL,0);\r
+        {$endif}\r
+        myfdclose(fdhandleout);\r
+      end;\r
+      eventcore.setfdreverse(fdhandlein,nil);\r
+      eventcore.setfdreverse(fdhandleout,nil);\r
+\r
+      fdhandlein := -1;\r
+      fdhandleout := -1;\r
+    end;\r
+    state := wsclosed;\r
+\r
+    if assigned(onsessionclosed) then if not destroying then onsessionclosed(self,error);\r
+  end;\r
+  sendq.del(maxlongint);\r
+end;\r
+\r
+\r
+{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}\r
+{ All exceptions *MUST* be handled. If an exception is not handled, the     }\r
+{ application will most likely be shut down !                               }\r
+procedure tlasio.HandleBackGroundException(E: Exception);\r
+var\r
+  CanAbort : Boolean;\r
+begin\r
+  CanAbort := TRUE;\r
+  { First call the error event handler, if any }\r
+  if Assigned(OnBgException) then begin\r
+    try\r
+      OnBgException(Self, E, CanAbort);\r
+    except\r
+    end;\r
+  end;\r
+  { Then abort the socket }\r
+  if CanAbort then begin\r
+    try\r
+      close;\r
+    except\r
+    end;\r
+  end;\r
+end;\r
+\r
+procedure tlasio.sendstr(const str : string);\r
+begin\r
+  putstringinsendbuffer(str);\r
+  sendflush;\r
+end;\r
+\r
+procedure tlasio.putstringinsendbuffer(const newstring : string);\r
+begin\r
+  if newstring <> '' then putdatainsendbuffer(@newstring[1],length(newstring));\r
+end;\r
+\r
+function tlasio.send(data:pointer;len:integer):integer;\r
+begin\r
+  if state <> wsconnected then begin\r
+    result := -1;\r
+    exit;\r
+  end;\r
+  if len < 0 then len := 0;\r
+  result := len;\r
+  putdatainsendbuffer(data,len);\r
+  sendflush;\r
+end;\r
+\r
+\r
+procedure tlasio.putdatainsendbuffer(data:pointer;len:integer);\r
+begin\r
+  sendq.add(data,len);\r
+end;\r
+\r
+function tlasio.sendflush : integer;\r
+var\r
+  lensent : integer;\r
+  data:pointer;\r
+//  fdstestr : fdset;\r
+//  fdstestw : fdset;\r
+begin\r
+  if state <> wsconnected then exit;\r
+\r
+  lensent := sendq.get(data,2920);\r
+  if assigned(data) then result := myfdwrite(fdhandleout,data^,lensent) else result := 0;\r
+\r
+  if result = -1 then lensent := 0 else lensent := result;\r
+\r
+  //sendq := copy(sendq,lensent+1,length(sendq)-lensent);\r
+  sendq.del(lensent);\r
+\r
+  //fd_clr(fdhandleout,fdsw); // this prevents the socket being closed by a write\r
+                            // that sends nothing because a previous socket has\r
+                            // slready flushed this socket when the message loop\r
+                            // reaches it\r
+//  if sendq.size > 0 then begin\r
+    eventcore.wmasterset(fdhandleout);//fd_set(fdhandleout,fdswmaster);\r
+//  end else begin\r
+//    wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
+//  end;\r
+  if result > 0 then begin\r
+    if assigned(onsenddata) then onsenddata(self,result);\r
+//    if sendq.size=0 then if assigned(ondatasent) then begin\r
+//      tltask.create(self.dodatasent,self,0,0);\r
+//      //begin test code\r
+//      fd_zero(fdstestr);\r
+//      fd_zero(fdstestw);\r
+//      fd_set(fdhandlein,fdstestr);\r
+//      fd_set(fdhandleout,fdstestw);\r
+//      select(maxs,@fdstestr,@fdstestw,nil,0);\r
+//      writeln(fd_isset(fdhandlein,fdstestr),' ',fd_isset(fdhandleout,fdstestw));\r
+//      //end test code\r
+//    \r
+//    end;\r
+    writtenthiscycle := true;\r
+  end;\r
+end;\r
+\r
+procedure tlasio.dupnowatch(invalue:longint);\r
+begin\r
+  {  debugout('invalue='+inttostr(invalue));}\r
+  //readln;\r
+  if state<> wsclosed then close;\r
+  fdhandlein := invalue;\r
+  fdhandleout := invalue;\r
+  eventcore.setfdreverse(fdhandlein,self);\r
+  {$ifndef win32}\r
+    fcntl(fdhandlein,F_SETFL,OPEN_NONBLOCK);\r
+  {$endif}\r
+  state := wsconnected;\r
+\r
+end;\r
+\r
+\r
+procedure tlasio.dup(invalue:longint);\r
+begin\r
+  dupnowatch(invalue);\r
+  eventcore.rmasterset(fdhandlein,false);//fd_set(fdhandlein,fdsrmaster);\r
+  eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
+end;\r
+\r
+\r
+procedure tlasio.handlefdtrigger(readtrigger,writetrigger:boolean);\r
+var\r
+  sendflushresult : integer;\r
+  tempbuf:array[0..receivebufsize-1] of byte;\r
+begin\r
+  if (state=wsconnected) and writetrigger then begin\r
+    //writeln('write trigger');\r
+\r
+    if (sendq.size >0) then begin\r
+\r
+      sendflushresult := sendflush;\r
+      if (sendflushresult <= 0) and (not writtenthiscycle) then begin\r
+        if sendflushresult=0 then begin // linuxerror := 0;\r
+          internalclose(0);\r
+\r
+        end else begin\r
+          internalclose({$ifdef win32}getlasterror{$else}linuxerror{$endif});\r
+        end;\r
+      end;\r
+\r
+    end else begin\r
+      //everything is sent fire off ondatasent event\r
+      if fdhandleout >= 0 then eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
+      if assigned(ondatasent) then tltask.create(self.dodatasent,self,0,0);\r
+    end;\r
+    if assigned(onfdwrite) then onfdwrite(self,0);\r
+  end;\r
+  writtenthiscycle := false;\r
+  if (state =wsconnected) and readtrigger then begin\r
+    if recvq.size=0 then begin\r
+      numread := myfdread(fdhandlein,tempbuf,sizeof(tempbuf));\r
+      if (numread=0) and (not mustrefreshfds) then begin\r
+        {if i remember correctly numread=0 is caused by eof\r
+        if this isn't dealt with then you get a cpu eating infinite loop\r
+        however if onsessionconencted has called processmessages that could\r
+        cause us to drop to here with an empty recvq and nothing left to read\r
+        and we don't want that to cause the socket to close}\r
+\r
+        internalclose(0);\r
+      end else if (numread=-1) then begin\r
+        numread := 0;\r
+        internalclose({$ifdef win32}getlasterror{$else}linuxerror{$endif});\r
+      end else if numread > 0 then recvq.add(@tempbuf,numread);\r
+    end;\r
+\r
+    if recvq.size > 0 then begin\r
+      if wsonoreceiveloop in componentoptions then eventcore.rmasterclr(fdhandlein); //fd_clr(fdhandlein,fdsrmaster);\r
+      if assigned(ondataavailable) then ondataAvailable(self,0);\r
+      if not (wsonoreceiveloop in componentoptions) then if recvq.size > 0 then\r
+      tltask.create(self.doreceiveloop,self,0,0);\r
+    end;\r
+    //until (numread = 0) or (currentsocket.state<>wsconnected);\r
+{    debugout('inner loop complete');}\r
+  end;\r
+end;\r
+\r
+{$ifndef win32}\r
+  procedure tlasio.flush;\r
+  var\r
+    fds : fdset;\r
+  begin\r
+    fd_zero(fds);\r
+    fd_set(fdhandleout,fds);\r
+    while sendq.size>0 do begin\r
+      select(fdhandleout+1,nil,@fds,nil,nil);\r
+      if sendflush <= 0 then exit;\r
+    end;\r
+  end;\r
+{$endif}\r
+\r
+procedure tlasio.dodatasent(wparam,lparam:longint);\r
+begin\r
+  if assigned(ondatasent) then ondatasent(self,lparam);\r
+end;\r
+\r
+procedure tlasio.deletebuffereddata;\r
+begin\r
+  sendq.del(maxlongint);\r
+end;\r
+\r
+procedure tlasio.sinkdata(sender:tobject;error:word);\r
+begin\r
+  tlasio(sender).recvq.del(maxlongint);\r
+end;\r
+\r
+{$ifndef win32}\r
+  procedure tltimer.resettimes;\r
+  begin\r
+    gettimeofday(nextts);\r
+    {if not initialevent then} tv_add(nextts,interval);\r
+  end;\r
+{$endif}\r
+\r
+{procedure tltimer.setinitialevent(newvalue : boolean);\r
+begin\r
+  if newvalue <> finitialevent then begin\r
+    finitialevent := newvalue;\r
+    if assigned(timerwrapperinterface) then begin\r
+      timerwrapperinterface.setinitialevent(wrappedtimer,newvalue);\r
+    end else begin\r
+      resettimes;\r
+    end;\r
+  end;\r
+end;}\r
+\r
+procedure tltimer.setontimer(newvalue:tnotifyevent);\r
+begin\r
+  if @newvalue <> @fontimer then begin\r
+    fontimer := newvalue;\r
+    if assigned(timerwrapperinterface) then begin\r
+      timerwrapperinterface.setontimer(wrappedtimer,newvalue);\r
+    end else begin\r
+\r
+    end;\r
+  end;\r
+\r
+end;\r
+\r
+\r
+procedure tltimer.setenabled(newvalue : boolean);\r
+begin\r
+  if newvalue <> fenabled then begin\r
+    fenabled := newvalue;\r
+    if assigned(timerwrapperinterface) then begin\r
+      timerwrapperinterface.setenabled(wrappedtimer,newvalue);\r
+    end else begin\r
+      {$ifdef win32}\r
+        raise exception.create('non wrapper timers are not permitted on windows');\r
+      {$else}\r
+        resettimes;\r
+      {$endif}\r
+    end;\r
+  end;\r
+end;\r
+\r
+procedure tltimer.setinterval(newvalue:integer);\r
+begin\r
+  if newvalue <> finterval then begin\r
+    finterval := newvalue;\r
+    if assigned(timerwrapperinterface) then begin\r
+      timerwrapperinterface.setinterval(wrappedtimer,newvalue);\r
+    end else begin\r
+      {$ifdef win32}\r
+        raise exception.create('non wrapper timers are not permitted on windows');\r
+      {$else}\r
+        resettimes;\r
+      {$endif}\r
+    end;\r
+  end;\r
+\r
+end;\r
+\r
+\r
+\r
+\r
+constructor tltimer.create;\r
+begin\r
+  inherited create(AOwner);\r
+  if assigned(timerwrapperinterface) then begin\r
+    wrappedtimer := timerwrapperinterface.createwrappedtimer;\r
+  end else begin\r
+\r
+\r
+    nexttimer := firsttimer;\r
+    prevtimer := nil;\r
+\r
+    if assigned(nexttimer) then nexttimer.prevtimer := self;\r
+    firsttimer := self;\r
+  end;\r
+  interval := 1000;\r
+  enabled := true;\r
+  released := false;\r
+\r
+end;\r
+\r
+destructor tltimer.destroy;\r
+begin\r
+  if assigned(timerwrapperinterface) then begin\r
+    wrappedtimer.free;\r
+  end else begin\r
+    if prevtimer <> nil then begin\r
+      prevtimer.nexttimer := nexttimer;\r
+    end else begin\r
+      firsttimer := nexttimer;\r
+    end;\r
+    if nexttimer <> nil then begin\r
+      nexttimer.prevtimer := prevtimer;\r
+    end;\r
+    \r
+  end;\r
+  inherited destroy;\r
+end;\r
+\r
+constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+  inherited create;\r
+  if assigned(onaddtask) then onaddtask(ahandler,aobj,awparam,alparam);\r
+  handler   := ahandler;\r
+  obj       := aobj;\r
+  wparam    := awparam;\r
+  lparam    := alparam;\r
+  {nexttask  := firsttask;\r
+  firsttask := self;}\r
+  if assigned(lasttask) then begin\r
+    lasttask.nexttask := self;\r
+  end else begin\r
+    firsttask := self;\r
+  end;\r
+  lasttask := self;\r
+  //ahandler(wparam,lparam);\r
+end;\r
+\r
+procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+\r
+  tltask.create(ahandler,aobj,awparam,alparam);\r
+end;\r
+\r
+\r
+\r
+\r
+{$ifndef nosignal}\r
+  procedure prepsigpipe;inline;\r
+  begin\r
+    starthandlesignal(sigpipe);\r
+    if not assigned(signalloopback) then begin\r
+      signalloopback := tlloopback.create(nil);\r
+      signalloopback.ondataAvailable := signalloopback.sinkdata;\r
+\r
+    end;\r
+\r
+  end;\r
+{$endif}\r
+\r
+procedure processtasks;//inline;\r
+var\r
+  temptask                : tltask   ;\r
+\r
+begin\r
+\r
+  if not assigned(currenttask) then begin\r
+    currenttask := firsttask;\r
+    firsttask := nil;\r
+    lasttask  := nil;\r
+  end;\r
+  while assigned(currenttask) do begin\r
+\r
+    if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam);\r
+    if assigned(currenttask) then begin\r
+      temptask := currenttask;\r
+      currenttask := currenttask.nexttask;\r
+      temptask.free;\r
+    end;\r
+    //writeln('processed a task');\r
+  end;\r
+\r
+end;\r
+\r
+\r
+\r
+\r
+procedure disconnecttasks(aobj:tobject);\r
+var\r
+  currenttasklocal : tltask ;\r
+  counter          : byte   ;\r
+begin\r
+  for counter := 0 to 1 do begin\r
+    if counter = 0 then begin\r
+      currenttasklocal := firsttask; //main list of tasks\r
+    end else begin\r
+      currenttasklocal := currenttask; //needed in case called from a task\r
+    end;\r
+    // note i don't bother to sestroy the links here as that will happen when\r
+    // the list of tasks is processed anyway\r
+    while assigned(currenttasklocal) do begin\r
+      if currenttasklocal.obj = aobj then begin\r
+        currenttasklocal.obj := nil;\r
+        currenttasklocal.handler := nil;\r
+      end;\r
+      currenttasklocal := currenttasklocal.nexttask;\r
+    end;\r
+  end;\r
+end;\r
+\r
+\r
+procedure processmessages;\r
+begin\r
+  eventcore.processmessages;\r
+end;\r
+procedure messageloop;\r
+begin\r
+  eventcore.messageloop;\r
+end;\r
+\r
+procedure exitmessageloop;\r
+begin\r
+  eventcore.exitmessageloop;\r
+end;\r
+\r
+function tlasio.RealSend(Data : Pointer; Len : Integer) : Integer;\r
+begin\r
+  result := myfdwrite(fdhandleout,data^,len);\r
+  if (result > 0) and assigned(onsenddata) then onsenddata(self,result);\r
+  eventcore.wmasterset(fdhandleout);\r
+end;\r
+{$ifndef win32}\r
+  procedure tlasio.myfdclose(fd : integer);\r
+  begin\r
+    fdclose(fd);\r
+  end;\r
+  function tlasio.myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt;\r
+  begin\r
+    result := fdwrite(fd,buf,size);\r
+  end;\r
+\r
+  function tlasio.myfdread(fd: LongInt;var buf;size: LongInt):LongInt;\r
+  begin\r
+    result := fdread(fd,buf,size);\r
+  end;\r
+\r
+\r
+{$endif}\r
+\r
+\r
+begin\r
+  firstasin := nil;\r
+  firsttask := nil;\r
+  \r
+\r
+  {$ifndef nosignal}\r
+    signalloopback := nil;\r
+  {$endif}\r
+end.\r
+\r
+\r
+\r
+\r
+\r

diff --git a/httpserver_20080306/lcoregtklaz.pas b/httpserver_20080306/lcoregtklaz.pas
new file mode 100755 (executable)
index 0000000..bbf4418
--- /dev/null
+++ b/httpserver_20080306/lcoregtklaz.pas
@@ -0,0 +1,142 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green
+  For conditions of distribution and use, see copyright notice in zlib_license.txt
+  which is included in the package
+  ----------------------------------------------------------------------------- }
+      \r
+unit lcoregtklaz;\r
+{$mode delphi}\r
+interface\r
+       \r
+uses baseunix,unix,glib, gdk, gtk,lcore,forms,fd_utils,classes;\r
+//procedure lcoregtklazrun;\r
+const\r
+  G_IO_IN=1;\r
+  G_IO_OUT=4;\r
+  G_IO_PRI=2;\r
+  G_IO_ERR=8;\r
+\r
+  G_IO_HUP=16;\r
+  G_IO_NVAL=32;\r
+type\r
+  tlaztimerwrapperinterface=class(ttimerwrapperinterface)\r
+  public\r
+    function createwrappedtimer : tobject;override;\r
+//    procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);override;\r
+    procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);override;\r
+    procedure setenabled(wrappedtimer : tobject;newvalue : boolean);override;\r
+    procedure setinterval(wrappedtimer : tobject;newvalue : integer);override;\r
+  end;\r
+\r
+procedure lcoregtklazinit;\r
+implementation\r
+  uses\r
+    ExtCtrls;\r
+{$I unixstuff.inc}\r
+var\r
+  giochannels : array[0..absoloutemaxs] of pgiochannel;\r
+\r
+function iocallback(source:PGIOChannel; condition:TGIOCondition; data:gpointer):gboolean;cdecl;\r
+// return true if we want the callback to stay\r
+var\r
+  fd                    : integer ;\r
+  fdsrlocal , fdswlocal : fdset   ;\r
+  currentasio           : tlasio  ;\r
+begin\r
+  fd := g_io_channel_unix_get_fd(source);\r
+  fd_zero(fdsrlocal);\r
+  fd_set(fd,fdsrlocal);\r
+  fdswlocal := fdsrlocal;\r
+  select(fd+1,@fdsrlocal,@fdswlocal,nil,0);\r
+  if fd_isset(fd,fdsrlocal) or fd_isset(fd,fdsrlocal) then begin\r
+    currentasio := fdreverse[fd];\r
+    if assigned(currentasio) then begin\r
+      currentasio.handlefdtrigger(fd_isset(currentasio.fdhandlein,fdsrlocal),fd_isset(currentasio.fdhandleout,fdswlocal));\r
+    end else begin\r
+      rmasterclr(fd);\r
+      wmasterclr(fd);\r
+    end;\r
+  end;\r
+  case condition of\r
+    G_IO_IN : begin\r
+      result := rmasterisset(fd);\r
+    end;\r
+    G_IO_OUT : begin\r
+      result := wmasterisset(fd);\r
+    end;\r
+  end;\r
+end;\r
+\r
+procedure gtkrmasterset(fd : integer);\r
+begin\r
+  if not assigned(giochannels[fd]) then giochannels[fd] := g_io_channel_unix_new(fd);\r
+  g_io_add_watch(giochannels[fd],G_IO_IN,iocallback,nil);\r
+end;\r
+\r
+procedure gtkrmasterclr(fd: integer);\r
+begin\r
+end;\r
+  \r
+procedure gtkwmasterset(fd : integer);\r
+begin\r
+  if not assigned(giochannels[fd]) then giochannels[fd] := g_io_channel_unix_new(fd);\r
+  g_io_add_watch(giochannels[fd],G_IO_OUT,iocallback,nil);\r
+end;\r
+\r
+procedure gtkwmasterclr(fd: integer);\r
+begin\r
+end;\r
+\r
+type\r
+  tsc = class\r
+    procedure dotasksandsink(sender:tobject;error:word);\r
+  end;\r
+var\r
+  taskloopback : tlloopback;\r
+  sc           : tsc;\r
+procedure tsc.dotasksandsink(sender:tobject;error:word);\r
+begin\r
+  with tlasio(sender) do begin\r
+    sinkdata(sender,error);\r
+    processtasks;\r
+  end;\r
+end;\r
+procedure gtkaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+  taskloopback.sendstr(' ');\r
+  \r
+end;\r
+\r
+procedure lcoregtklazinit;\r
+begin\r
+  onrmasterset := gtkrmasterset;\r
+  onrmasterclr := gtkrmasterclr;\r
+  onwmasterset := gtkwmasterset;\r
+  onwmasterclr := gtkwmasterclr;\r
+  onaddtask := gtkaddtask;\r
+  taskloopback := tlloopback.create(nil);\r
+  taskloopback.ondataavailable := sc.dotasksandsink;\r
+  timerwrapperinterface := tlaztimerwrapperinterface.create(nil);\r
+end;\r
+\r
+function tlaztimerwrapperinterface.createwrappedtimer : tobject;\r
+begin\r
+  result := ttimer.create(nil);\r
+end;\r
+procedure tlaztimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);\r
+begin\r
+  ttimer(wrappedtimer).ontimer := newvalue;\r
+end;\r
+procedure tlaztimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean);\r
+begin\r
+  ttimer(wrappedtimer).enabled := newvalue;\r
+end;\r
+\r
+\r
+procedure tlaztimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer);\r
+begin\r
+  ttimer(wrappedtimer).interval := newvalue;\r
+end;\r
+\r
+\r
+end.\r
+\r

diff --git a/httpserver_20080306/lcoreselect.pas b/httpserver_20080306/lcoreselect.pas
new file mode 100755 (executable)
index 0000000..0369448
--- /dev/null
+++ b/httpserver_20080306/lcoreselect.pas
@@ -0,0 +1,391 @@
+{lsocket.pas}\r
+\r
+{io and timer code by plugwash}\r
+\r
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+\r
+\r
+unit lcoreselect;\r
+\r
+\r
+interface\r
+uses\r
+  fd_utils;\r
+var\r
+  maxs                                  : longint    ;\r
+  exitloopflag                          : boolean    ; {if set by app, exit mainloop}\r
+\r
+function getfdsrmaster : fdset; {$ifdef fpc}inline;{$endif}\r
+function getfdswmaster : fdset; {$ifdef fpc}inline;{$endif}\r
+\r
+implementation\r
+uses\r
+  lcore,sysutils,\r
+  {$ifdef VER1_0}\r
+    linux,\r
+  {$else}\r
+    baseunix,unix,\r
+  {$endif}\r
+  classes,pgtypes,bfifo,\r
+  {$ifndef nosignal}\r
+    lsignal;\r
+  {$endif}\r
+\r
+{$include unixstuff.inc}\r
+{$include ltimevalstuff.inc}\r
+var\r
+  fdreverse:array[0..absoloutemaxs] of tlasio;\r
+type\r
+  tselecteventcore=class(teventcore)\r
+    public\r
+      procedure processmessages; override;\r
+      procedure messageloop; override;\r
+      procedure exitmessageloop;override;\r
+      procedure setfdreverse(fd : integer;reverseto : tlasio); override;\r
+      procedure rmasterset(fd : integer;islistensocket : boolean); override;\r
+      procedure rmasterclr(fd: integer); override;\r
+      procedure wmasterset(fd : integer); override;\r
+      procedure wmasterclr(fd: integer); override;\r
+    end;\r
+\r
+procedure processtimers;inline;\r
+var\r
+  tv           ,tvnow     : ttimeval ;\r
+  currenttimer            : tltimer   ;\r
+  temptimer               : tltimer  ;\r
+\r
+begin\r
+  gettimeofday(tvnow);\r
+  currenttimer := firsttimer;\r
+  while assigned(currenttimer) do begin\r
+    //writeln(currenttimer.enabled);\r
+    if tv_compare(tvnow,ttimeval(currenttimer.nextts)) and currenttimer.enabled then begin\r
+      //if assigned(currenttimer.ontimer) then begin\r
+      //  if currenttimer.enabled then if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer);\r
+      //  currenttimer.initialdone := true;\r
+      //end;\r
+      if assigned(currenttimer.ontimer) then currenttimer.ontimer(currenttimer);\r
+      currenttimer.nextts := timeval(tvnow);\r
+      tv_add(ttimeval(currenttimer.nextts),currenttimer.interval);\r
+    end;\r
+    temptimer := currenttimer;\r
+    currenttimer := currenttimer.nexttimer;\r
+    if temptimer.released then temptimer.free;\r
+  end;\r
+end;\r
+\r
+procedure processasios(var fdsr,fdsw:fdset);//inline;\r
+var\r
+  currentsocket : tlasio  ;\r
+  tempsocket    : tlasio  ;\r
+  socketcount   : integer ; // for debugging perposes :)\r
+  dw,bt:integer;\r
+begin\r
+{  inc(lcoretestcount);}\r
+\r
+    //the message loop will exit if all lasio's and ltimer's and lsignal's are destroyed\r
+    //if (not assigned(firstasin)) and (not assigned(firsttimer)) and (not assigned(firstsignal)) then exit;\r
+\r
+\r
+  {------- test optimised loop}\r
+  socketcount := 0;\r
+  for dw := (maxs shr 5) downto 0 do if (fdsr[dw] or fdsw[dw]) <> 0 then begin\r
+    for bt := 0 to 31 do if (fdsr[dw] or fdsw[dw]) and (1 shl bt) <> 0 then begin\r
+      inc(socketcount);\r
+      currentsocket := fdreverse[dw shl 5 or bt];\r
+      {if not assigned(currentsocket) then raise exception.create('currentsocket not assigned');\r
+      if currentsocket.fdhandlein < 0 then raise exception.create('currentsocket.fdhandlein out of range');}\r
+      {i've seen the out of range case actually happening, so it can happen. test: just close the fd - beware}\r
+      if not assigned(currentsocket) then begin\r
+        fdclose(dw shl 5 or bt);\r
+        continue\r
+      end;\r
+      if currentsocket.fdhandlein < 0 then begin\r
+        fdclose(dw shl 5 or bt);\r
+        continue\r
+      end;\r
+      try\r
+        currentsocket.handlefdtrigger(fd_isset(currentsocket.fdhandlein,fdsr),fd_isset(currentsocket.fdhandleout,fdsw));\r
+      except\r
+        on E: exception do begin\r
+          currentsocket.HandleBackGroundException(e);\r
+        end;\r
+      end;\r
+\r
+      if mustrefreshfds then begin\r
+        if select(maxs+1,@fdsr,@fdsw,nil,0) <= 0 then begin\r
+          fd_zero(fdsr);\r
+          fd_zero(fdsw);\r
+        end;\r
+      end;\r
+    end;\r
+  end;\r
+\r
+  if asinreleaseflag then begin\r
+    asinreleaseflag := false;\r
+    currentsocket := firstasin;\r
+    while assigned(currentsocket) do begin\r
+      tempsocket := currentsocket;\r
+      currentsocket := currentsocket.nextasin;\r
+      if tempsocket.released then begin\r
+        tempsocket.free;\r
+      end;\r
+    end;\r
+  end;\r
+  {\r
+  !!! issues:\r
+  - sockets which are released may not be freed because theyre never processed by the loop\r
+  made new code for handling this, using asinreleaseflag\r
+\r
+  - when/why does the mustrefreshfds select apply, sheck if i did it correctly?\r
+\r
+  - what happens if calling handlefdtrigger for a socket which does not have an event\r
+  }\r
+  {------- original loop}\r
+\r
+  (*\r
+  currentsocket := firstasin;\r
+  socketcount := 0;\r
+  while assigned(currentsocket) do begin\r
+    if mustrefreshfds then begin\r
+      if select(maxs,@fdsr,@fdsw,nil,0) <= 0 then begin\r
+        fd_zero(fdsr);\r
+        fd_zero(fdsw);\r
+      end;\r
+    end;\r
+    try\r
+      if fd_isset(currentsocket.fdhandlein,fdsr) or fd_isset(currentsocket.fdhandleout,fdsw) then begin\r
+        currentsocket.handlefdtrigger(fd_isset(currentsocket.fdhandlein,fdsr),fd_isset(currentsocket.fdhandleout,fdsw));\r
+      end;\r
+    except\r
+      on E: exception do begin\r
+        currentsocket.HandleBackGroundException(e);\r
+      end;\r
+    end;\r
+    tempsocket := currentsocket;\r
+    currentsocket := currentsocket.nextasin;\r
+    inc(socketcount);\r
+    if tempsocket.released then begin\r
+      tempsocket.free;\r
+    end;\r
+  end; *)\r
+{  debugout('socketcount='+inttostr(socketcount));}\r
+end;\r
+\r
+procedure tselecteventcore.processmessages;\r
+var\r
+  fdsr         , fdsw : fdset   ;\r
+  selectresult        : longint ;\r
+begin\r
+  mustrefreshfds := false;\r
+  {$ifndef nosignal}\r
+    prepsigpipe;\r
+  {$endif}\r
+  selectresult := select(maxs+1,@fdsr,@fdsw,nil,0);\r
+  while (selectresult>0) or assigned(firsttask) or assigned(currenttask) do begin;\r
+\r
+    processtasks;\r
+    processtimers;\r
+    if selectresult > 0 then begin\r
+      processasios(fdsr,fdsw);\r
+    end;\r
+    selectresult := select(maxs+1,@fdsr,@fdsw,nil,0);\r
+\r
+  end;\r
+  mustrefreshfds := true;\r
+end;\r
+\r
+\r
+var\r
+  FDSR , FDSW : fdset;\r
+\r
+Function  doSelect(timeOut:PTimeVal):longint;//inline;\r
+var\r
+  localtimeval : ttimeval;\r
+  maxslocal    : integer;\r
+begin\r
+  //unblock signals\r
+  //zeromemory(@sset,sizeof(sset));\r
+  //sset[0] := ;\r
+  fdsr := getfdsrmaster;\r
+  fdsw := getfdswmaster;\r
+\r
+  if assigned(firsttask) then begin\r
+    localtimeval.tv_sec  := 0;\r
+    localtimeval.tv_usec := 0;\r
+    timeout := @localtimeval;\r
+  end;\r
+\r
+  maxslocal := maxs;\r
+  mustrefreshfds := false;\r
+{  debugout('about to call select');}\r
+  {$ifndef nosignal}\r
+    sigprocmask(SIG_UNBLOCK,@blockset,nil);\r
+  {$endif}\r
+  result := select(maxslocal+1,@FDSR,@FDSW,nil,timeout);\r
+  if result <= 0 then begin\r
+    fd_zero(FDSR);\r
+    fd_zero(FDSW);\r
+    if result=-1 then begin\r
+      if linuxerror = SYS_EINTR then begin\r
+        // we received a signal it's not a problem\r
+      end else begin\r
+        raise esocketexception.create('select returned error '+inttostr(linuxerror));\r
+      end;\r
+    end;\r
+  end;\r
+  {$ifndef nosignal}\r
+    sigprocmask(SIG_BLOCK,@blockset,nil);\r
+  {$endif}\r
+{  debugout('select complete');}\r
+end;\r
+\r
+procedure tselecteventcore.exitmessageloop;\r
+begin\r
+  exitloopflag := true\r
+end;\r
+\r
+\r
+\r
+procedure tselecteventcore.messageloop;\r
+var\r
+  tv           ,tvnow     : ttimeval ;\r
+  currenttimer            : tltimer  ;\r
+  selectresult:integer;\r
+begin\r
+  {$ifndef nosignal}\r
+    prepsigpipe;\r
+  {$endif}\r
+  {currentsocket := firstasin;\r
+  if not assigned(currentsocket) then exit; //the message loop will exit if all lsockets are destroyed\r
+  repeat\r
+\r
+    if currentsocket.state = wsconnected then currentsocket.sendflush;\r
+    currentsocket := currentsocket.nextasin;\r
+  until not assigned(currentsocket);}\r
+\r
+\r
+  repeat\r
+\r
+    //the message loop will exit if all lasio's and ltimer's and lsignal's are destroyed\r
+    if (not assigned(firstasin)) and (not assigned(firsttimer)) {$ifndef nosignal} and (not assigned(firstsignal)){$endif} then exit;\r
+    {fd_zero(FDSR);\r
+    fd_zero(FDSW);\r
+    currentsocket := firstasin;\r
+    if not assigned(currentsocket) then exit; //the message loop will exit if all lsockets are destroyed\r
+\r
+    repeat\r
+      if (not currentsocket.released) and (currentsocket.state<>wsclosed) then fd_set(currentsocket.fdhandlein,fdsr);\r
+      if (not currentsocket.released) and (currentsocket.state=wsconnecting) then fd_set(currentsocket.fdhandleout,fdsw);\r
+      if currentsocket is tlsocket then begin\r
+         if (not currentsocket.released) and (currentsocket.state=wsconnected) and(tlsocket(currentsocket).sendq <> '') then fd_set(currentsocket.fdhandleout,fdsw);\r
+      end;\r
+      tempsocket := currentsocket;\r
+      currentsocket := currentsocket.nextasin;\r
+      if tempsocket.released then begin\r
+        tempsocket.free;\r
+      end;\r
+    until not assigned(currentsocket);\r
+    }\r
+    processtasks;\r
+    //currenttask := nil;\r
+    {beware}\r
+    //if assigned(firsttimer) then begin\r
+    //  tv.tv_sec := maxlongint;\r
+    tv := tv_invalidtimebig;\r
+    currenttimer := firsttimer;\r
+    while assigned(currenttimer) do begin\r
+      if tv_compare(tv,currenttimer.nextts) and currenttimer.enabled then tv := currenttimer.nextts;\r
+      currenttimer := currenttimer.nexttimer;\r
+    end;\r
+\r
+\r
+    if tv_compare(tv,tv_invalidtimebig) then begin    \r
+      //writeln('no timers active');\r
+      if exitloopflag then break;\r
+{    sleep(10);}\r
+      selectresult := doselect(nil);\r
+\r
+    end else begin\r
+      gettimeofday(tvnow);\r
+      tv_substract(tv,tvnow);\r
+\r
+      //writeln('timers active');\r
+      if tv.tv_sec < 0 then begin\r
+        tv.tv_sec := 0;\r
+        tv.tv_usec := 0; {0.1 sec}\r
+      end;\r
+      if exitloopflag then break;\r
+{    sleep(10);}\r
+      selectresult := doselect(@tv);\r
+      processtimers;\r
+\r
+    end;\r
+    if selectresult > 0 then processasios(fdsr,fdsw);\r
+    {!!!only call processasios if select has asio events -beware}\r
+\r
+    {artificial delay to throttle the number of processasios per second possible and reduce cpu usage}\r
+  until false;\r
+end;\r
+\r
+var\r
+  fdsrmaster , fdswmaster               : fdset      ;\r
+\r
+procedure tselecteventcore.rmasterset(fd : integer;islistensocket : boolean);\r
+begin\r
+  if fd > absoloutemaxs then raise esocketexception.create('file discriptor out of range');\r
+  if fd > maxs then maxs := fd;\r
+  if fd_isset(fd,fdsrmaster) then exit;\r
+  fd_set(fd,fdsrmaster);\r
+\r
+end;\r
+\r
+procedure tselecteventcore.rmasterclr(fd: integer);\r
+begin\r
+  if not fd_isset(fd,fdsrmaster) then exit;\r
+  fd_clr(fd,fdsrmaster);\r
+\r
+end;\r
+\r
+\r
+procedure tselecteventcore.wmasterset(fd : integer);\r
+begin\r
+  if fd > absoloutemaxs then raise esocketexception.create('file discriptor out of range');\r
+  if fd > maxs then maxs := fd;\r
+\r
+  if fd_isset(fd,fdswmaster) then exit;\r
+  fd_set(fd,fdswmaster);\r
+\r
+end;\r
+\r
+procedure tselecteventcore.wmasterclr(fd: integer);\r
+begin\r
+  if not fd_isset(fd,fdswmaster) then exit;\r
+  fd_clr(fd,fdswmaster);\r
+end;\r
+\r
+procedure tselecteventcore.setfdreverse(fd : integer;reverseto : tlasio);\r
+begin\r
+  fdreverse[fd] := reverseto;\r
+end;\r
+\r
+function getfdsrmaster : fdset; {$ifdef fpc}inline;{$endif}\r
+begin\r
+  result := fdsrmaster;\r
+end;\r
+function getfdswmaster : fdset; {$ifdef fpc}inline;{$endif}\r
+begin\r
+  result := fdswmaster;\r
+end;\r
+\r
+\r
+begin\r
+  eventcore := tselecteventcore.create;\r
+\r
+  maxs := 0;\r
+  fd_zero(fdsrmaster);\r
+  fd_zero(fdswmaster);\r
+end.\r

diff --git a/httpserver_20080306/lcoretest.dpr b/httpserver_20080306/lcoretest.dpr
new file mode 100755 (executable)
index 0000000..e9d1b0a
--- /dev/null
+++ b/httpserver_20080306/lcoretest.dpr
@@ -0,0 +1,167 @@
+program lcoretest;\r
+\r
+uses\r
+  lcore,\r
+  lsocket,\r
+  {$ifdef win32}\r
+    lcorewsaasyncselect in 'lcorewsaasyncselect.pas',\r
+  {$else}\r
+    lcoreselect,\r
+  {$endif}\r
+  dnsasync,\r
+  binipstuff,\r
+  dnssync;\r
+{$ifdef win32}\r
+  {$R *.RES}\r
+{$endif}\r
+\r
+type\r
+  tsc=class\r
+    procedure sessionavailable(sender: tobject;error : word);\r
+    procedure dataavailable(sender: tobject;error : word);\r
+    procedure sessionconnected(sender: tobject;error : word);\r
+    procedure taskrun(wparam,lparam:longint);\r
+    procedure timehandler(sender:tobject);\r
+    procedure dnsrequestdone(sender:tobject;error : word);\r
+    procedure sessionclosed(sender:tobject;error : word);\r
+  end;\r
+var\r
+  listensocket : tlsocket;\r
+  serversocket : tlsocket;\r
+  clientsocket : tlsocket;\r
+  sc : tsc;\r
+  task : tltask;\r
+procedure tsc.sessionavailable(sender: tobject;error : word);\r
+begin\r
+  writeln('received connection');\r
+  serversocket.dup(listensocket.accept);\r
+end;\r
+\r
+var\r
+  receivebuf : string;\r
+  receivecount : integer;\r
+procedure tsc.dataavailable(sender: tobject;error : word);\r
+var\r
+  receiveddata : string;\r
+  receivedon : string;\r
+begin\r
+  receiveddata := tlsocket(sender).receivestr;\r
+  if sender=clientsocket then begin\r
+    receivedon := 'client socket';\r
+  end else begin\r
+    receivedon := 'server socket';\r
+  end;\r
+  writeln('received data '+receiveddata+' on '+receivedon);\r
+  if sender=serversocket then begin\r
+    receivebuf := receivebuf+receiveddata;\r
+  end;\r
+  if receivebuf = 'hello world' then begin\r
+    receivebuf := '';\r
+    writeln('received hello world creating task');\r
+    task := tltask.create(sc.taskrun,nil,0,0);\r
+  end;\r
+  receivecount := receivecount +1;\r
+  if receivecount >50 then begin\r
+    writeln('received over 50 bits of data, pausing to let the operator take a look');\r
+    readln;\r
+    receivecount := 0;\r
+  end;\r
+\r
+end;\r
+\r
+procedure tsc.sessionconnected(sender: tobject;error : word);\r
+begin\r
+  if error=0 then begin\r
+    writeln('session is connected');\r
+    if clientsocket.addr = '127.0.0.1' then begin\r
+      clientsocket.sendstr('hello world');\r
+    end else begin\r
+      clientsocket.sendstr('get /'#13#10#13#10);\r
+    end;\r
+  end else begin\r
+    writeln('connect failed');\r
+  end;\r
+end;\r
+\r
+var\r
+  das : tdnsasync;\r
+\r
+procedure tsc.taskrun(wparam,lparam:longint);\r
+var\r
+  tempbinip : tbinip;\r
+  dummy : integer;\r
+begin\r
+  writeln('task ran');\r
+  writeln('closing client socket');\r
+  clientsocket.close;\r
+\r
+  writeln('looking up www.kame.net using dnsasync');\r
+  das := tdnsasync.Create(nil);\r
+  das.onrequestdone := sc.dnsrequestdone;\r
+  das.forwardfamily := af_inet6;
+  das.forwardlookup('www.kame.net');\r
+end;\r
+\r
+procedure tsc.dnsrequestdone(sender:tobject;error : word);\r
+begin\r
+  writeln('www.kame.net resolved to '+das.dnsresult+' connecting client socket there');\r
+  clientsocket.addr := das.dnsresult;\r
+  clientsocket.port := '80';\r
+  clientsocket.connect;\r
+  das.free;\r
+end;\r
+\r
+procedure tsc.timehandler(sender:tobject);\r
+begin\r
+  //writeln('got timer event');\r
+end;\r
+procedure tsc.sessionclosed(sender:tobject;error : word);\r
+begin\r
+  Writeln('session closed with error ',error);\r
+end;\r
+var\r
+  timer : tltimer;\r
+  ipbin : tbinip;\r
+  dummy : integer;\r
+begin\r
+  ipbin := forwardlookup('invalid.domain',5);\r
+  writeln(ipbintostr(ipbin));\r
+\r
+  ipbin := forwardlookup('p10link.net',5);\r
+  writeln(ipbintostr(ipbin));\r
+\r
+  ipstrtobin('80.68.89.68',ipbin);\r
+  writeln('80.68.89.68 reverses to '+reverselookup(ipbin,5));\r
+\r
+  ipstrtobin('2001:200::8002:203:47ff:fea5:3085',ipbin);\r
+  writeln('2001:200::8002:203:47ff:fea5:3085 reverses to '+reverselookup(ipbin,5));\r
+  writeln('creating and setting up listen socket');\r
+  listensocket := tlsocket.create(nil);\r
+  listensocket.addr := '0.0.0.0';\r
+  listensocket.port := '12345';\r
+  listensocket.onsessionavailable := sc.sessionavailable;\r
+  writeln('listening');\r
+  listensocket.listen;\r
+  writeln('listen socket is number ', listensocket.fdhandlein);\r
+  writeln('creating and setting up server socket');\r
+  serversocket := tlsocket.create(nil);\r
+  serversocket.ondataavailable := sc.dataavailable;\r
+  writeln('creating and setting up client socket');\r
+  clientsocket := tlsocket.create(nil);\r
+  clientsocket.addr := {'::1';}'127.0.0.1';\r
+  clientsocket.port := '12345';\r
+  clientsocket.onsessionconnected := sc.sessionconnected;\r
+  clientsocket.ondataAvailable := sc.dataavailable;\r
+  clientsocket.onsessionclosed := sc.sessionclosed;\r
+  writeln('connecting');\r
+  clientsocket.connect;\r
+  writeln('client socket is number ',clientsocket.fdhandlein);\r
+  writeln('creating and setting up timer');\r
+  timer := tltimer.create(nil);\r
+  timer.interval := 1000;\r
+  timer.ontimer := sc.timehandler;\r
+  timer.enabled := true;\r
+  writeln('entering message loop');\r
+  messageloop;\r
+  writeln('exiting cleanly');\r
+end.\r

diff --git a/httpserver_20080306/lcorewsaasyncselect.pas b/httpserver_20080306/lcorewsaasyncselect.pas
new file mode 100755 (executable)
index 0000000..a978c23
--- /dev/null
+++ b/httpserver_20080306/lcorewsaasyncselect.pas
@@ -0,0 +1,216 @@
+unit lcorewsaasyncselect;\r
+\r
+interface\r
+\r
+implementation\r
+uses wcore,lcore,bsearchtree,sysutils,windows,winsock,pgtypes,messages,classes;\r
+type\r
+  twineventcore=class(teventcore)\r
+  public\r
+    procedure processmessages; override;\r
+    procedure messageloop; override;\r
+    procedure exitmessageloop;override;\r
+    procedure setfdreverse(fd : integer;reverseto : tlasio); override;\r
+    procedure rmasterset(fd : integer;islistensocket : boolean); override;\r
+    procedure rmasterclr(fd: integer); override;\r
+    procedure wmasterset(fd : integer); override;\r
+    procedure wmasterclr(fd: integer); override;\r
+  end;\r
+const\r
+  wm_dotasks=wm_user+1;\r
+type\r
+  twintimerwrapperinterface=class(ttimerwrapperinterface)\r
+  public\r
+    function createwrappedtimer : tobject;override;\r
+//    procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);override;\r
+    procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);override;\r
+    procedure setenabled(wrappedtimer : tobject;newvalue : boolean);override;\r
+    procedure setinterval(wrappedtimer : tobject;newvalue : integer);override;\r
+  end;\r
+\r
+procedure twineventcore.processmessages;\r
+begin\r
+  wcore.processmessages;//pass off to wcore\r
+end;\r
+procedure twineventcore.messageloop;\r
+begin\r
+  wcore.messageloop; //pass off to wcore\r
+end;\r
+procedure twineventcore.exitmessageloop;\r
+begin\r
+  wcore.exitmessageloop;\r
+end;\r
+var\r
+  fdreverse : thashtable;\r
+  fdwatches : thashtable;\r
+\r
+procedure twineventcore.setfdreverse(fd : integer;reverseto : tlasio);\r
+begin\r
+  if findtree(@fdreverse,inttostr(fd)) <> nil then deltree(@fdreverse,inttostr(fd));\r
+  if reverseto <> nil then addtree(@fdreverse,inttostr(fd),reverseto);\r
+end;\r
+\r
+var\r
+  hwndlcore : hwnd;\r
+procedure dowsaasyncselect(fd:integer; leventadd: integer; leventremove : integer);\r
+var\r
+  leventold : integer;\r
+  leventnew : integer;\r
+  wsaaresult : integer;\r
+begin\r
+  leventold := taddrint(findtree(@fdwatches,inttostr(fd)));\r
+  leventnew := leventold or leventadd;\r
+  leventnew := leventnew and not leventremove;\r
+  if leventold <> leventnew then begin\r
+    if leventold <> 0 then deltree(@fdwatches,inttostr(fd));\r
+    if leventnew <> 0 then addtree(@fdwatches,inttostr(fd),pointer(leventnew));\r
+  end;\r
+  wsaaresult := wsaasyncselect(fd,hwndlcore,wm_user,leventnew);\r
+\r
+end;\r
+\r
+\r
+//to allow detection of errors:\r
+//if we are asked to monitor for read or accept we also monitor for close\r
+//if we are asked to monitor for write we also monitor for connect\r
+\r
+\r
+procedure twineventcore.rmasterset(fd : integer;islistensocket : boolean);\r
+begin\r
+  if islistensocket then begin\r
+    //writeln('setting accept watch for socket number ',fd);\r
+    dowsaasyncselect(fd,FD_ACCEPT or FD_CLOSE,0);\r
+  end else begin\r
+    //writeln('setting read watch for socket number',fd);\r
+    dowsaasyncselect(fd,FD_READ or FD_CLOSE,0);\r
+  end;\r
+end;\r
+procedure twineventcore.rmasterclr(fd: integer);\r
+begin\r
+  //writeln('clearing read of accept watch for socket number ',fd);\r
+  dowsaasyncselect(fd,0,FD_ACCEPT or FD_READ or FD_CLOSE);\r
+end;\r
+procedure twineventcore.wmasterset(fd : integer);\r
+begin\r
+  dowsaasyncselect(fd,FD_WRITE or FD_CONNECT,0);\r
+end;\r
+\r
+procedure twineventcore.wmasterclr(fd: integer);\r
+begin\r
+  dowsaasyncselect(fd,0,FD_WRITE or FD_CONNECT);\r
+end;\r
+\r
+var\r
+  tasksoutstanding : boolean;\r
+\r
+function MyWindowProc(\r
+    ahWnd   : HWND;\r
+    auMsg   : Integer;\r
+    awParam : WPARAM;\r
+    alParam : LPARAM): Integer; stdcall;\r
+var\r
+  socket : integer;\r
+  event : integer;\r
+  error : integer;\r
+  readtrigger : boolean;\r
+  writetrigger : boolean;\r
+  lasio : tlasio;\r
+begin\r
+  //writeln('got a message');\r
+  Result := 0;  // This means we handled the message\r
+  if (ahwnd=hwndlcore) and (aumsg=wm_user) then begin\r
+    //writeln('it appears to be a response to our wsaasyncselect');\r
+    socket := awparam;\r
+    event := alparam and $FFFF;\r
+    error := alparam shr 16;\r
+    //writeln('socket=',socket,' event=',event,' error=',error);\r
+    readtrigger := false;\r
+    writetrigger := false;\r
+    lasio := findtree(@fdreverse,inttostr(socket));\r
+    if assigned(lasio) then begin\r
+      if (error <> 0) or ((event and FD_CLOSE) <> 0) then begin\r
+        if lasio.state = wsconnecting then begin\r
+          lasio.onsessionconnected(lasio,error);\r
+        end;\r
+        lasio.internalclose(error);\r
+      end else begin\r
+        if (event and (FD_READ or FD_ACCEPT)) <> 0 then readtrigger := true;\r
+        if (event and (FD_WRITE)) <> 0 then writetrigger := true;\r
+\r
+        if readtrigger or writetrigger then lasio.handlefdtrigger(readtrigger,writetrigger);\r
+      end;\r
+      dowsaasyncselect(socket,0,0); //reset watches\r
+    end;\r
+  end else if (ahwnd=hwndlcore) and (aumsg=wm_dotasks) then begin\r
+      //writeln('processing tasks');\r
+      tasksoutstanding := false;\r
+      processtasks;\r
+  end else begin\r
+      //writeln('passing unknown message to defwindowproc');\r
+      //not passing unknown messages on to defwindowproc will cause window\r
+      //creation to fail! --plugwash\r
+      Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)\r
+  end;\r
+\r
+end;\r
+\r
+procedure winaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+  if not tasksoutstanding then PostMessage(hwndlcore,wm_dotasks,0,0);\r
+end;\r
+type\r
+  twcoretimer = wcore.tltimer;\r
+\r
+function twintimerwrapperinterface.createwrappedtimer : tobject;\r
+begin\r
+  result := twcoretimer.create(nil);\r
+end;\r
+procedure twintimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);\r
+begin\r
+  twcoretimer(wrappedtimer).ontimer := newvalue;\r
+end;\r
+procedure twintimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean);\r
+begin\r
+  twcoretimer(wrappedtimer).enabled := newvalue;\r
+end;\r
+\r
+\r
+procedure twintimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer);\r
+begin\r
+  twcoretimer(wrappedtimer).interval := newvalue;\r
+end;\r
+\r
+var\r
+  MyWindowClass : TWndClass = (style         : 0;\r
+                                 lpfnWndProc   : @MyWindowProc;\r
+                                 cbClsExtra    : 0;\r
+                                 cbWndExtra    : 0;\r
+                                 hInstance     : 0;\r
+                                 hIcon         : 0;\r
+                                 hCursor       : 0;\r
+                                 hbrBackground : 0;\r
+                                 lpszMenuName  : nil;\r
+                                 lpszClassName : 'lcoreClass');\r
+  GInitData: TWSAData;\r
+\r
+begin\r
+  eventcore := twineventcore.create;\r
+    if Windows.RegisterClass(MyWindowClass) = 0 then halt;\r
+  //writeln('about to create lcore handle, hinstance=',hinstance);\r
+  hwndlcore := CreateWindowEx(WS_EX_TOOLWINDOW,\r
+                               MyWindowClass.lpszClassName,\r
+                               '',        { Window name   }\r
+                               WS_POPUP,  { Window Style  }\r
+                               0, 0,      { X, Y          }\r
+                               0, 0,      { Width, Height }\r
+                               0,         { hWndParent    }\r
+                               0,         { hMenu         }\r
+                               HInstance, { hInstance     }\r
+                               nil);      { CreateParam   }\r
+  //writeln('lcore hwnd is ',hwndlcore);\r
+  //writeln('last error is ',GetLastError);\r
+  onaddtask := winaddtask;\r
+  timerwrapperinterface := twintimerwrapperinterface.create(nil);\r
+\r
+  WSAStartup($200, GInitData);\r
+end.\r

diff --git a/httpserver_20080306/lloopback.pas b/httpserver_20080306/lloopback.pas
new file mode 100755 (executable)
index 0000000..da26263
--- /dev/null
+++ b/httpserver_20080306/lloopback.pas
@@ -0,0 +1,30 @@
+unit lloopback;\r
+\r
+interface\r
+uses lcore,classes;\r
+\r
+type\r
+  tlloopback=class(tlasio)\r
+  public\r
+    constructor create(aowner:tcomponent); override;\r
+  end;\r
+\r
+\r
+implementation\r
+uses
+  baseunix,unix;
+{$i unixstuff.inc}
+
+constructor tlloopback.create(aowner:tcomponent);\r
+begin\r
+  inherited create(aowner);\r
+  closehandles := true;\r
+  assignpipe(fdhandlein,fdhandleout);\r
+\r
+  eventcore.rmasterset(fdhandlein,false);//fd_set(fdhandlein,fdsrmaster);\r
+  eventcore.wmasterclr(fdhandlein);//fd_clr(fdhandleout,fdswmaster);\r
+  eventcore.setfdreverse(fdhandlein,self);\r
+  eventcore.setfdreverse(fdhandleout,self);\r
+  state := wsconnected;\r
+end;\r
+end.\r

diff --git a/httpserver_20080306/lmessages.pas b/httpserver_20080306/lmessages.pas
new file mode 100755 (executable)
index 0000000..7bb73fd
--- /dev/null
+++ b/httpserver_20080306/lmessages.pas
@@ -0,0 +1,656 @@
+unit lmessages;\r
+//windows messages like system based on lcore tasks\r
+interface\r
+\r
+uses pgtypes,sysutils,bsearchtree,strings,syncobjs;\r
+\r
+type\r
+  lparam=taddrint;\r
+  wparam=taddrint;\r
+  thinstance=pointer;\r
+  hicon=pointer;\r
+  hcursor=pointer;\r
+  hbrush=pointer;\r
+  hwnd=qword; //window handles are monotonically increasing 64 bit integers,\r
+              //this should allow for a million windows per second for over half\r
+              //a million years!\r
+\r
+  twndproc=function(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;\r
+\r
+\r
+  twndclass=record\r
+    style : dword;\r
+    lpfnwndproc : twndproc;\r
+    cbclsextra : integer;\r
+    cbwndextra : integer;\r
+    hinstance : thinstance;\r
+    hicon : hicon;\r
+    hcursor : hcursor;\r
+    hbrbackground : hbrush;\r
+    lpszmenuname : pchar;\r
+    lpszclassname : pchar;\r
+  end;\r
+  PWNDCLASS=^twndclass;\r
+  \r
+  UINT=dword;\r
+  WINBOOL = longbool;\r
+  tTIMERPROC = procedure (ahwnd:HWND; umsg:integer; idevent:taddrint;dwtime:taddrint);stdcall;\r
+  ATOM = pointer;\r
+  LPCSTR = pchar;\r
+  LPVOID = pointer;\r
+  HMENU = pointer;\r
+  HINST = pointer;\r
+\r
+  TPOINT = record \r
+    x : LONGint; \r
+    y : LONGint; \r
+  end; \r
+  \r
+  TMSG = record \r
+    hwnd : HWND; \r
+    message : UINT; \r
+    wParam : WPARAM; \r
+    lParam : LPARAM; \r
+    time : DWORD; \r
+    pt : TPOINT;\r
+  end; \r
+  THevent=TEventObject;\r
+const\r
+  WS_EX_TOOLWINDOW = $80;\r
+  WS_POPUP = longint($80000000);\r
+  hinstance=nil;\r
+  PM_REMOVE = 1;\r
+  WM_USER = 1024;\r
+  WM_TIMER = 275;\r
+  INFINITE = syncobjs.infinite;\r
+function getwindowlongptr(ahwnd:hwnd;nindex:integer) : taddrint;\r
+function setwindowlongptr(ahwnd:hwnd;nindex:integer;dwNewLong : taddrint) : taddrint;\r
+function DefWindowProc(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;\r
+function RegisterClass(const lpWndClass:TWNDCLASS):ATOM;\r
+function CreateWindowEx(dwExStyle:DWORD; lpClassName:LPCSTR; lpWindowName:LPCSTR; dwStyle:DWORD; X:longint;Y:longint; nWidth:longint; nHeight:longint; hWndParent:HWND; hMenu:HMENU;hInstance:HINST; lpParam:LPVOID):HWND;\r
+function DestroyWindow(ahWnd:HWND):WINBOOL;\r
+function PostMessage(hWnd:HWND; Msg:UINT; wParam:WPARAM; lParam:LPARAM):WINBOOL;\r
+function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): WINBOOL;\r
+function DispatchMessage(const lpMsg: TMsg): Longint;\r
+function GetMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT): WINBOOL;\r
+function SetEvent(hEvent:THevent):WINBOOL;\r
+function CreateEvent(lpEventAttributes:PSECURITYATTRIBUTES; bManualReset:WINBOOL; bInitialState:WINBOOL; lpName:pchar):tHevent;\r
+function terminatethread(threadhandle : tthreadid;dummy:integer) : boolean;\r
+function waitforsingleevent(event:thevent;timeout:cardinal) : twaitresult;\r
+function SetTimer(ahWnd:HWND; nIDEvent:taddrint; uElapse:UINT; lpTimerFunc:tTIMERPROC):UINT;\r
+function KillTimer(ahWnd:HWND; uIDEvent:taddrint):WINBOOL;\r
+\r
+procedure init;\r
+\r
+implementation\r
+uses\r
+  baseunix,unix,lcore;//,safewriteln;\r
+{$i unixstuff.inc}\r
+\r
+type\r
+  tmessageintransit = class\r
+    msg : tmsg;\r
+    next : tmessageintransit;\r
+  end;\r
+\r
+  tthreaddata = class\r
+    messagequeue : tmessageintransit;\r
+    messageevent : teventobject;\r
+    waiting : boolean;\r
+    lcorethread : boolean;\r
+    nexttimer : ttimeval;\r
+    threadid : integer;\r
+  end;\r
+  twindow=class\r
+    hwnd : hwnd;\r
+    extrawindowmemory : pointer;\r
+    threadid : tthreadid;\r
+    windowproc : twndproc;\r
+  end;\r
+\r
+var\r
+  structurelock : tcriticalsection;\r
+  threaddata : thashtable;\r
+  windowclasses : thashtable;\r
+  lcorelinkpipesend : integer;\r
+  lcorelinkpiperecv : tlasio;\r
+  windows : thashtable;\r
+  //I would rather things crash immediately\r
+  //if they use an insufficiant size type\r
+  //than crash after over four billion\r
+  //windows have been made ;)\r
+  nextwindowhandle : qword = $100000000;\r
+{$i ltimevalstuff.inc}\r
+\r
+//findthreaddata should only be called while holding the structurelock\r
+function findthreaddata(threadid : integer) : tthreaddata;\r
+begin\r
+  result := tthreaddata(findtree(@threaddata,inttostr(threadid)));\r
+  if result = nil then begin\r
+    result := tthreaddata.create;\r
+    result.messageevent := teventobject.create(nil,false,false,inttostr(taddrint(result)));\r
+    result.nexttimer := tv_invalidtimebig;\r
+    result.threadid := threadid;\r
+    addtree(@threaddata,inttostr(threadid),result);\r
+  end;\r
+end;\r
+\r
+//deletethreaddataifunused should only be called while holding the structurelock\r
+procedure deletethreaddataifunused(athreaddata : tthreaddata);\r
+begin\r
+  //writeln('in deletethreaddataifunused');\r
+  if (athreaddata <> nil) then if (athreaddata.waiting=false) and (athreaddata.messagequeue=nil) and (athreaddata.lcorethread=false) and (athreaddata.nexttimer.tv_sec=tv_invalidtimebig.tv_sec) and (athreaddata.nexttimer.tv_usec=tv_invalidtimebig.tv_usec) then begin\r
+    //writeln('threaddata is unused, freeing messageevent');\r
+    athreaddata.messageevent.free;\r
+    //writeln('freeing thread data object');\r
+    athreaddata.free;\r
+    //writeln('deleting thread data object from hashtable');\r
+    deltree(@threaddata,inttostr(athreaddata.threadid));\r
+    //writeln('finished deleting thread data');\r
+  end else begin\r
+    //writeln('thread data is not unused');\r
+  end;\r
+end;\r
+\r
+function getwindowlongptr(ahwnd:hwnd;nindex:integer) : taddrint;\r
+var\r
+  window : twindow;\r
+begin\r
+  structurelock.acquire;\r
+  try\r
+    window := findtree(@windows,inttostr(ahwnd));\r
+    if window <> nil then begin\r
+      result := paddrint(taddrint(window.extrawindowmemory)+nindex)^;\r
+    end else begin\r
+      result := 0;\r
+    end;\r
+  finally\r
+    structurelock.release;\r
+  end;\r
+end;\r
+\r
+function setwindowlongptr(ahwnd:hwnd;nindex:integer;dwNewLong : taddrint) : taddrint;\r
+var\r
+  window : twindow;\r
+begin\r
+  structurelock.acquire;\r
+  try\r
+    window := findtree(@windows,inttostr(ahwnd));\r
+    if window <> nil then begin\r
+      result := paddrint(taddrint(window.extrawindowmemory)+nindex)^;\r
+      paddrint(taddrint(window.extrawindowmemory)+nindex)^ := dwnewlong;\r
+    end else begin\r
+      result := 0;\r
+    end;\r
+  finally\r
+    structurelock.release;\r
+  end;\r
+\r
+end;\r
+\r
+\r
+function DefWindowProc(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;\r
+begin\r
+  result := 0;\r
+end;\r
+\r
+function strdup(s:pchar) : pchar;\r
+begin\r
+  //swriteln('in strdup, about to allocate memory');\r
+  result := getmem(strlen(s)+1);\r
+  //swriteln('about to copy string');\r
+  strcopy(s,result);\r
+  //swriteln('leaving strdup');\r
+end;\r
+\r
+function RegisterClass(const lpWndClass:TWNDCLASS):ATOM;\r
+var\r
+  storedwindowclass:pwndclass;\r
+begin\r
+  structurelock.acquire;\r
+  try\r
+    //swriteln('in registerclass, about to check for duplicate window class');\r
+    storedwindowclass := findtree(@windowclasses, lpwndclass.lpszclassname);\r
+    if storedwindowclass <> nil then begin\r
+\r
+      if comparebyte(storedwindowclass^,lpwndclass,sizeof(twndclass)-sizeof(pchar)-sizeof(pchar)) <> 0 then begin\r
+        //swriteln('duplicate window class registered with different settings');\r
+        raise exception.create('duplicate window class registered with different settings');\r
+      end else begin\r
+        //swriteln('duplicate window class registered with same settings, tollerated');\r
+      end;\r
+    end else begin\r
+      //swriteln('about to allocate memory for new windowclass');\r
+      storedwindowclass := getmem(sizeof(twndclass));\r
+      //swriteln('about to copy windowclass from parameter');\r
+      move(lpwndclass,storedwindowclass^,sizeof(twndclass));\r
+      //swriteln('about to copy strings');\r
+      if lpwndclass.lpszmenuname <> nil then storedwindowclass.lpszmenuname := strdup(lpwndclass.lpszmenuname);\r
+      if lpwndclass.lpszclassname <> nil then storedwindowclass.lpszclassname := strdup(lpwndclass.lpszclassname);\r
+      //swriteln('about to add result to list of windowclasses');\r
+      addtree(@windowclasses,lpwndclass.lpszclassname,storedwindowclass);\r
+    end;\r
+    //swriteln('about to return result');\r
+    result := storedwindowclass;\r
+    //swriteln('leaving registerclass');\r
+  finally\r
+    structurelock.release;\r
+  end;\r
+end;\r
+\r
+function CreateWindowEx(dwExStyle:DWORD; lpClassName:LPCSTR; lpWindowName:LPCSTR; dwStyle:DWORD; X:longint;Y:longint; nWidth:longint; nHeight:longint; hWndParent:HWND; hMenu:HMENU;hInstance:HINST; lpParam:LPVOID):HWND;\r
+var\r
+  wndclass : pwndclass;\r
+  tm : tthreadmanager;\r
+  window : twindow;\r
+begin\r
+  structurelock.acquire;\r
+  try\r
+    window := twindow.create;\r
+    window.hwnd := nextwindowhandle;\r
+    result := window.hwnd;\r
+    nextwindowhandle := nextwindowhandle + 1;\r
+    addtree(@windows,inttostr(window.hwnd),window);\r
+    wndclass := findtree(@windowclasses,lpclassname);\r
+    window.extrawindowmemory := getmem(wndclass.cbwndextra);\r
+\r
+    getthreadmanager(tm);\r
+    window.threadid := tm.GetCurrentThreadId;\r
+    window.windowproc := wndclass.lpfnwndproc;\r
+  finally\r
+    structurelock.release;\r
+  end;\r
+end;\r
+function DestroyWindow(ahWnd:HWND):WINBOOL;\r
+var\r
+  window : twindow;\r
+  windowthreaddata : tthreaddata;\r
+  currentmessage : tmessageintransit;\r
+  prevmessage : tmessageintransit;\r
+begin\r
+  //writeln('started to destroy window');\r
+  structurelock.acquire;\r
+  try\r
+    window := twindow(findtree(@windows,inttostr(ahwnd)));\r
+    if window <> nil then begin\r
+      freemem(window.extrawindowmemory);\r
+      //writeln('aboute to delete window from windows structure');\r
+      deltree(@windows,inttostr(ahwnd));\r
+      //writeln('deleted window from windows structure');\r
+      windowthreaddata := tthreaddata(findtree(@threaddata,inttostr(window.threadid)));\r
+\r
+      if windowthreaddata <> nil then begin\r
+        //writeln('found thread data scanning for messages to clean up');\r
+        currentmessage := windowthreaddata.messagequeue;\r
+        prevmessage := nil;\r
+        while currentmessage <> nil do begin\r
+          while (currentmessage <> nil) and (currentmessage.msg.hwnd = ahwnd) do begin\r
+            if prevmessage = nil then begin\r
+              windowthreaddata.messagequeue := currentmessage.next;\r
+            end else begin\r
+              prevmessage.next := currentmessage.next;\r
+            end;\r
+            currentmessage.free;\r
+            if prevmessage = nil then begin\r
+              currentmessage := windowthreaddata.messagequeue;\r
+            end else begin\r
+              currentmessage := prevmessage.next;\r
+            end;\r
+          end;\r
+          if currentmessage <> nil then begin\r
+            prevmessage := currentmessage;\r
+            currentmessage := currentmessage.next;\r
+          end;\r
+        end;\r
+        //writeln('deleting thread data structure if it is unused');\r
+        deletethreaddataifunused(windowthreaddata);\r
+      end else begin\r
+        //writeln('there is no thread data to search for messages to cleanup');\r
+      end;\r
+      //writeln('freeing window');\r
+      window.free;\r
+      result := true;\r
+    end else begin\r
+      result := false;\r
+    end;\r
+  finally\r
+    structurelock.release;\r
+  end;\r
+  //writeln('window destroyed');\r
+end;\r
+\r
+\r
+\r
+function PostMessage(hWnd:HWND; Msg:UINT; wParam:WPARAM; lParam:LPARAM):WINBOOL;\r
+var\r
+  threaddata : tthreaddata;\r
+  message : tmessageintransit;\r
+  messagequeueend : tmessageintransit;\r
+  window : twindow;\r
+begin\r
+  structurelock.acquire;\r
+  try\r
+    window := findtree(@windows,inttostr(hwnd));\r
+    if window <> nil then begin\r
+      threaddata := findthreaddata(window.threadid);\r
+      message := tmessageintransit.create;\r
+      message.msg.hwnd := hwnd;\r
+      message.msg.message := msg;\r
+      message.msg.wparam := wparam;\r
+      message.msg.lparam := lparam;\r
+      if threaddata.lcorethread then begin\r
+        //swriteln('posting message to lcore thread');\r
+        fdwrite(lcorelinkpipesend,message,sizeof(message));\r
+      end else begin\r
+        //writeln('posting message to non lcore thread');\r
+        if threaddata.messagequeue = nil then begin\r
+          threaddata.messagequeue := message;\r
+        end else begin\r
+          messagequeueend := threaddata.messagequeue;\r
+          while messagequeueend.next <> nil do begin\r
+            messagequeueend := messagequeueend.next;\r
+          end;\r
+          messagequeueend.next := message;\r
+        end;\r
+\r
+        //writeln('message added to queue');\r
+        if threaddata.waiting then threaddata.messageevent.setevent;\r
+      end;\r
+      result := true;\r
+    end else begin\r
+      result := false;\r
+    end;\r
+  finally\r
+    structurelock.release;\r
+  end;\r
+\r
+end;\r
+\r
+function gettickcount : dword;\r
+var\r
+  result64: integer;\r
+  tv : ttimeval;\r
+begin\r
+  gettimeofday(tv);\r
+  result64 := (tv.tv_sec*1000)+(tv.tv_usec div 1000);\r
+  result := result64;\r
+end;\r
+\r
+function DispatchMessage(const lpMsg: TMsg): Longint;\r
+var\r
+  timerproc : ttimerproc;\r
+  window : twindow;\r
+  windowproc : twndproc;\r
+begin\r
+  ////swriteln('in dispatchmessage, msg.hwnd='+inttohex(taddrint(lpmsg.hwnd),16));\r
+  if (lpmsg.lparam <> 0) and (lpmsg.message = WM_TIMER) then begin\r
+    timerproc := ttimerproc(lpmsg.lparam);\r
+    timerproc(lpmsg.hwnd,lpmsg.message,lpmsg.wparam,gettickcount);\r
+    result := 0;\r
+  end else begin\r
+    structurelock.acquire;\r
+    try\r
+      window := findtree(@windows,inttostr(lpmsg.hwnd));\r
+      //we have to get the window procedure while the structurelock\r
+      //is still held as the window could be destroyed from another thread\r
+      //otherwise.\r
+      windowproc := window.windowproc;\r
+    finally\r
+      structurelock.release;\r
+    end;\r
+    if window <> nil then begin\r
+      result := windowproc(lpmsg.hwnd,lpmsg.message,lpmsg.wparam,lpmsg.lparam);\r
+    end else begin\r
+      result := -1;\r
+    end;\r
+  end;\r
+end;\r
+\r
+procedure processtimers;\r
+begin\r
+end;\r
+\r
+function GetMessageinternal(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT; wremovemsg : UINT;peek:boolean): WINBOOL;\r
+var\r
+  tm : tthreadmanager;\r
+  threaddata : tthreaddata;\r
+  message : tmessageintransit;\r
+  nowtv : ttimeval;\r
+  timeouttv : ttimeval;\r
+  timeoutms : int64;\r
+\r
+begin\r
+  if hwnd <> 0 then raise exception.create('getting messages for an individual window is not supported');\r
+  if (wmsgfiltermin <> 0) or (wmsgfiltermax <> 0) then raise exception.create('message filtering is not supported');\r
+  structurelock.acquire;\r
+  result := true;\r
+  try\r
+    getthreadmanager(tm);\r
+    threaddata := findthreaddata(tm.GetCurrentThreadId);\r
+    if threaddata.lcorethread then raise exception.create('get/peek message cannot be used in the lcore thread');\r
+    message := threaddata.messagequeue;\r
+    gettimeofday(nowtv);\r
+    while (not peek) and (message=nil) and (not tv_compare(nowtv,threaddata.nexttimer)) do begin\r
+      threaddata.waiting := true;\r
+      structurelock.release;\r
+      if (threaddata.nexttimer.tv_sec = TV_invalidtimebig.tv_sec) and (threaddata.nexttimer.tv_usec = TV_invalidtimebig.tv_usec) then begin\r
+        threaddata.messageevent.waitfor(INFINITE);\r
+      end else begin\r
+\r
+        timeouttv := threaddata.nexttimer;\r
+        timeoutms := (timeouttv.tv_sec * 1000)+(timeouttv.tv_usec div 1000);\r
+        //i'm assuming the timeout is in milliseconds\r
+        if (timeoutms > maxlongint) then timeoutms := maxlongint;\r
+        threaddata.messageevent.waitfor(timeoutms);\r
+\r
+      end;\r
+      structurelock.acquire;\r
+      threaddata.waiting := false;\r
+      message := threaddata.messagequeue;\r
+      gettimeofday(nowtv);\r
+    end;\r
+    if (message=nil) and tv_compare(nowtv,threaddata.nexttimer) then begin\r
+      processtimers;\r
+    end;\r
+    message := threaddata.messagequeue;\r
+    if message <> nil then begin\r
+      lpmsg := message.msg;\r
+      if wremovemsg=PM_REMOVE then begin\r
+        threaddata.messagequeue := message.next;\r
+        message.free;\r
+      end;\r
+    end else begin\r
+      result :=false;\r
+    end;\r
+    deletethreaddataifunused(threaddata);\r
+  finally\r
+    structurelock.release;\r
+  end;\r
+end;\r
+\r
+function GetMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT): WINBOOL;\r
+begin\r
+  result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,PM_REMOVE,false);\r
+end;\r
+\r
+function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): WINBOOL;\r
+begin\r
+  result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,PM_REMOVE,true);\r
+end;\r
+\r
+function SetEvent(hEvent:THevent):WINBOOL;\r
+begin\r
+  hevent.setevent;\r
+  result := true;\r
+end;\r
+\r
+function CreateEvent(lpEventAttributes:PSECURITYATTRIBUTES; bManualReset:WINBOOL; bInitialState:WINBOOL; lpName:pchar):tHevent;\r
+begin\r
+  result := teventobject.create(lpeventattributes,bmanualreset,binitialstate,lpname);\r
+end;\r
+\r
+function terminatethread(threadhandle:tthreadid;dummy : integer) : boolean;\r
+var\r
+  tm : tthreadmanager;\r
+begin\r
+  getthreadmanager(tm);\r
+  tm.killthread(threadhandle);\r
+  result := true;\r
+end;\r
+\r
+function waitforsingleevent(event:thevent;timeout:cardinal) : twaitresult;\r
+begin\r
+  result := event.waitfor(timeout);\r
+end;\r
+\r
+procedure removefrombuffer(n : integer; var buffer:string);\r
+begin\r
+  if n=length(buffer) then begin\r
+    buffer := '';\r
+  end else begin\r
+    uniquestring(buffer);\r
+    move(buffer[n+1],buffer[1],length(buffer)-n);\r
+    setlength(buffer,length(buffer)-n);\r
+  end;\r
+end;\r
+\r
+type\r
+  tsc=class\r
+    procedure available(sender:tobject;error:word);\r
+  end;\r
+\r
+var\r
+  recvbuf : string;\r
+\r
+procedure tsc.available(sender:tobject;error:word);\r
+var\r
+  message : tmessageintransit;\r
+  messagebytes : array[1..sizeof(tmessageintransit)] of char absolute  message;\r
+  i : integer;\r
+begin\r
+  //swriteln('received data on lcorelinkpipe');\r
+  recvbuf := recvbuf + lcorelinkpiperecv.receivestr;\r
+  while length(recvbuf) >= sizeof(tmessageintransit) do begin\r
+    for i := 1 to sizeof(tmessageintransit) do begin\r
+      messagebytes[i] := recvbuf[i];\r
+    end;\r
+    dispatchmessage(message.msg);\r
+    message.free;\r
+    removefrombuffer(sizeof(tmessageintransit),recvbuf);\r
+  end;\r
+end;\r
+\r
+procedure init;\r
+var\r
+  tm : tthreadmanager;\r
+  threaddata : tthreaddata;\r
+  pipeends : tfildes;\r
+  sc : tsc;\r
+begin\r
+  structurelock := tcriticalsection.create;\r
+  getthreadmanager(tm);\r
+  threaddata := findthreaddata(tm.GetCurrentThreadId);\r
+  threaddata.lcorethread := true;\r
+  fppipe(pipeends);\r
+  lcorelinkpipesend := pipeends[1];\r
+  lcorelinkpiperecv := tlasio.create(nil);\r
+  lcorelinkpiperecv.dup(pipeends[0]);\r
+  lcorelinkpiperecv.ondataavailable := sc.available;\r
+  recvbuf := '';\r
+end;\r
+\r
+var\r
+  lcorethreadtimers : thashtable;\r
+type\r
+  tltimerformsg = class(tltimer)\r
+  public\r
+    hwnd : hwnd;\r
+    id : taddrint;\r
+    procedure timer(sender : tobject);\r
+  end;\r
+\r
+procedure tltimerformsg.timer(sender : tobject);\r
+var\r
+  msg : tmsg;\r
+begin\r
+  ////swriteln('in tltimerformsg.timer');\r
+  fillchar(msg,sizeof(msg),0);\r
+  msg.message := WM_TIMER;\r
+  msg.hwnd := hwnd;\r
+  msg.wparam := ID;\r
+  msg.lparam := 0;\r
+  dispatchmessage(msg);\r
+end;\r
+\r
+function SetTimer(ahWnd:HWND; nIDEvent:taddrint; uElapse:UINT; lpTimerFunc:tTIMERPROC):UINT;\r
+var\r
+  threaddata : tthreaddata;\r
+  ltimer : tltimerformsg;\r
+  tm : tthreadmanager;\r
+  window : twindow;\r
+begin\r
+  structurelock.acquire;\r
+  try\r
+    window := findtree(@windows,inttostr(ahwnd));\r
+    if window= nil then raise exception.create('invalid window');\r
+    threaddata := findthreaddata(window.threadid);\r
+  finally\r
+    structurelock.release;\r
+  end;\r
+  if threaddata.lcorethread then begin\r
+    getthreadmanager(tm);\r
+    if tm.GetCurrentThreadId <> window.threadid then raise exception.create('timers on the lcore thread may only be added and removed from the lcore thread');\r
+    if ahwnd = 0 then raise exception.create('timers on the lcore thread must be associated with a window handle');\r
+    if @lptimerfunc <> nil then raise exception.create('seperate timer functions are not supported');\r
+\r
+    //remove preexisting timer with same ID\r
+    killtimer(ahwnd,nIDEvent);\r
+\r
+    ltimer := tltimerformsg.create(nil);\r
+    ltimer.interval := uelapse;\r
+    ltimer.id := nidevent;\r
+    ltimer.hwnd := ahwnd;\r
+    ltimer.enabled := true;\r
+    ltimer.ontimer := ltimer.timer;\r
+\r
+    addtree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(nIDEvent),ltimer);\r
+\r
+    result := nidevent;\r
+  end else begin\r
+    raise exception.create('settimer not implemented for threads other than the lcore thread');\r
+  end;\r
+end;\r
+\r
+function KillTimer(ahWnd:HWND; uIDEvent:taddrint):WINBOOL;\r
+var\r
+  threaddata : tthreaddata;\r
+  ltimer : tltimerformsg;\r
+  tm : tthreadmanager;\r
+  window : twindow;\r
+begin\r
+  structurelock.acquire;\r
+  try\r
+    window := findtree(@windows,inttostr(ahwnd));\r
+    if window= nil then raise exception.create('invalid window');\r
+    threaddata := findthreaddata(window.threadid);\r
+  finally\r
+    structurelock.release;\r
+  end;\r
+  if threaddata.lcorethread then begin\r
+    getthreadmanager(tm);\r
+    if tm.GetCurrentThreadId <> window.threadid then raise exception.create('timers on the lcore thread may only be added and remove from the lcore thread');\r
+    if ahwnd = 0 then raise exception.create('timers on the lcore thread must be associated with a window handle');\r
+    ltimer := tltimerformsg(findtree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(uIDEvent)));\r
+    if ltimer <> nil then begin\r
+      deltree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(uIDEvent));\r
+      ltimer.free;\r
+      result := true;\r
+    end else begin\r
+      result := false;\r
+    end;\r
+  end else begin\r
+    raise exception.create('settimer not implemented for threads other than the lcore thread');\r
+  end;\r
+end;\r
+\r
+end.
\ No newline at end of file

diff --git a/httpserver_20080306/lsignal.pas b/httpserver_20080306/lsignal.pas
new file mode 100755 (executable)
index 0000000..573fe28
--- /dev/null
+++ b/httpserver_20080306/lsignal.pas
@@ -0,0 +1,198 @@
+{lsocket.pas}\r
+\r
+{signal code by plugwash}\r
+\r
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+      \r
+unit lsignal;\r
+{$mode delphi}\r
+interface\r
+  uses sysutils,\r
+    {$ifdef VER1_0}\r
+      linux,\r
+    {$else}\r
+      baseunix,unix,\r
+    {$endif}\r
+    classes,lcore,lloopback;\r
+\r
+  type\r
+    tsignalevent=procedure(sender:tobject;signal:integer) of object;\r
+    tlsignal=class(tcomponent)\r
+    public\r
+      onsignal           : tsignalevent      ;\r
+      prevsignal         : tlsignal          ;\r
+      nextsignal         : tlsignal          ;\r
+\r
+      constructor create(aowner:tcomponent);override;\r
+      destructor destroy;override;\r
+    end;\r
+\r
+  \r
+  procedure starthandlesignal(signal:integer);\r
+\r
+var\r
+  firstsignal : tlsignal;\r
+  blockset : sigset;\r
+  signalloopback                        : tlloopback ;\r
+  
+implementation\r
+{$include unixstuff.inc}\r
+\r
+constructor tlsignal.create;\r
+begin\r
+  inherited create(AOwner);\r
+  nextsignal := firstsignal;\r
+  prevsignal := nil;\r
+\r
+  if assigned(nextsignal) then nextsignal.prevsignal := self;\r
+  firstsignal := self;\r
+\r
+  //interval := 1000;\r
+  //enabled := true;\r
+  //released := false;\r
+end;\r
+\r
+destructor tlsignal.destroy;\r
+begin\r
+  if prevsignal <> nil then begin\r
+    prevsignal.nextsignal := nextsignal;\r
+  end else begin\r
+    firstsignal := nextsignal;\r
+  end;\r
+  if nextsignal <> nil then begin\r
+    nextsignal.prevsignal := prevsignal;\r
+  end;\r
+  inherited destroy;\r
+end;\r
+{$ifdef linux}\r
+  {$ifdef ver1_9_8}\r
+    {$define needsignalworkaround}\r
+  {$endif}\r
+  {$ifdef ver2_0_0}\r
+    {$define needsignalworkaround}\r
+  {$endif}\r
+  {$ifdef ver2_0_2}\r
+    {$define needsignalworkaround}\r
+  {$endif}\r
+{$endif}\r
+{$ifdef needsignalworkaround}\r
+  //using the 1.9.6 version of this stuff because the 1.9.8 and 2.0.0 versions seem broken\r
+  type\r
+    TSysParam  = Longint;\r
+    TSysResult = longint;\r
+  const\r
+            syscall_nr_sigaction               = 67;\r
+  //function Do_SysCall(sysnr:TSysParam):TSysResult;  {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL0';\r
+  //function Do_SysCall(sysnr,param1:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL1';\r
+  //function Do_SysCall(sysnr,param1,param2:TSysParam):TSysResult;  {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL2';\r
+  function Do_SysCall(sysnr,param1,param2,param3:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL3';\r
+  //function Do_SysCall(sysnr,param1,param2,param3,param4:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL4';\r
+  //function Do_SysCall(sysnr,param1,param2,param3,param4,param5:TSysParam):TSysResult;  {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL5';\r
+\r
+  function Fpsigaction(sig: cint; act : psigactionrec; oact : psigactionrec): cint;// [public, alias : 'FPC_SYSC_SIGACTION'];\r
+  {\r
+    Change action of process upon receipt of a signal.\r
+    Signum specifies the signal (all except SigKill and SigStop).\r
+    If Act is non-nil, it is used to specify the new action.\r
+    If OldAct is non-nil the previous action is saved there.\r
+  }\r
+  begin\r
+  //writeln('fucking');\r
+  {$ifdef RTSIGACTION}\r
+    {$ifdef cpusparc}\r
+      { Sparc has an extra stub parameter }\r
+      Fpsigaction:=do_syscall(syscall_nr_rt_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact),TSysParam(PtrInt(@Fprt_sigreturn_stub)-8),TSysParam(8));\r
+    {$else cpusparc}\r
+      Fpsigaction:=do_syscall(syscall_nr_rt_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact),TSysParam(8));\r
+    {$endif cpusparc}\r
+  {$else RTSIGACTION}\r
+    //writeln('nice');\r
+    Fpsigaction:=do_syscall(syscall_nr_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact));\r
+  {$endif RTSIGACTION}\r
+  end;\r
+{$endif}\r
+\r
+// cdecl procedures are not name mangled\r
+// so USING something unlikely to cause colliesions in the global namespace\r
+// is a good idea\r
+procedure lsignal_handler( Sig : Integer);cdecl;\r
+var\r
+  currentsignal : tlsignal;\r
+begin\r
+//  writeln('in lsignal_hanler');\r
+  currentsignal := firstsignal;\r
+  while assigned(currentsignal) do begin\r
+    if assigned(currentsignal.onsignal) then currentsignal.onsignal(currentsignal,sig);\r
+    currentsignal := currentsignal.nextsignal;\r
+\r
+  end;\r
+//  writeln('about to send down signalloopback');\r
+  if assigned(signalloopback) then begin\r
+    signalloopback.sendstr(' ');\r
+  end;\r
+//  writeln('left lsignal_hanler');\r
+end;\r
+\r
+{$ifdef freebsd}\r
+\r
+{$if (FPC_VERSION > 2) or ((FPC_VERSION = 2) and (FPC_RELEASE >= 2))}\r
+procedure lsignal_handler2(signal:longint;info:PSigInfo;context:psigcontext); cdecl;\r
+{$else}\r
+procedure lsignal_handler2(signal:longint;var info:TSigInfo_t;var context:SigContextRec); cdecl;\r
+{$endif}\r
+\r
+begin\r
+  lsignal_handler(signal);\r
+end;\r
+{$endif}\r
+\r
+\r
+const\r
+  allbitsset=-1;\r
+  {$ifdef ver1_0}\r
+    saction : sigactionrec = (handler:(sh:lsignal_handler);sa_flags:0);\r
+  {$else}\r
+    {$ifdef darwin}\r
+      saction : sigactionrec = (sa_handler:tsigaction(lsignal_handler);sa_flags:0);\r
+    {$else}\r
+      {$ifdef freebsd}\r
+        //version number is FPC_VERSION.FPC_RELEASE.FPC_PATCH\r
+        {$if (FPC_VERSION>2) or ((FPC_VERSION=2) and (FPC_RELEASE>0)) or ((FPC_VERSION=2) and (fpc_release=0) and (fpc_patch>=2))}\r
+          saction : sigactionrec = (sa_handler:lsignal_handler2;sa_flags:0);\r
+        {$else}\r
+          saction : sigactionrec = (sa_handler:tsigaction(lsignal_handler);sa_flags:0);\r
+        {$endif}\r
+                                                         \r
+      {$else}\r
+        {$ifdef ver1_9_2}\r
+          saction : sigactionrec = (handler:(sh:lsignal_handler);sa_flags:0);\r
+        {$else}\r
+         //version number is FPC_VERSION.FPC_RELEASE.FPC_PATCH\r
+         {$if (FPC_VERSION>2) or ((FPC_VERSION=2) and (FPC_RELEASE>0)) or ((FPC_VERSION=2) and (fpc_release=0) and (fpc_patch>=2))}\r
+           saction : sigactionrec = (sa_handler:{$ifndef ver1_9_6}{$ifndef ver1_9_6}{$ifndef ver1_0}SigActionHandler{$endif}{$endif}{$endif}(lsignal_handler);sa_flags:0;sa_restorer:nil);\r
+         {$else}\r
+            saction : sigactionrec = (sa_handler:{$ifndef ver1_9_6}{$ifndef ver1_9_6}{$ifndef ver1_0}SigActionHandler{$endif}{$endif}{$endif}(lsignal_handler));\r
+         {$endif}\r
+        {$endif}\r
+      {$endif}\r
+    {$endif}\r
+  {$endif}\r
+procedure starthandlesignal(signal:integer);\r
+begin\r
+  if signal in ([0..31]-[sigkill,sigstop]) then begin\r
+    sigprocmask(SIG_BLOCK,@blockset,nil);\r
+    sigaction(signal,@saction,nil)\r
+  end else begin\r
+    raise exception.create('invalid signal number')\r
+  end;\r
+end;\r
+\r
+initialization\r
+  fillchar(blockset,sizeof(blockset),0);\r
+  blockset[0] := $FFFFFFFF - (1 shl sigstop) - (1 shl sigkill) - (1 shl sigsegv);\r
+  saction.sa_mask := blockset;\r
+  \r
+end.\r

diff --git a/httpserver_20080306/lsocket.pas b/httpserver_20080306/lsocket.pas
new file mode 100755 (executable)
index 0000000..617f153
--- /dev/null
+++ b/httpserver_20080306/lsocket.pas
@@ -0,0 +1,706 @@
+{lsocket.pas}\r
+\r
+{socket code by plugwash}\r
+\r
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+{\r
+changes by plugwash (20030728)\r
+* created handlefdtrigger virtual method in tlasio (overridden in tlsocket) and moved a lot of code from messageloop into it\r
+* changed tlasio to tlasio\r
+* split fdhandle into fdhandlein and fdhandleout\r
+* i now use fdsrmaster and fdswmaster instead of rebuilding the lists every loop\r
+* split lsocket.pas into lsocket.pas and lcore.pas\r
+\r
+\r
+changes by beware (20030903)\r
+* added getxaddr, getxport (local addr, port, as string)\r
+* added getpeername, remote addr+port as binary\r
+* added htons and htonl functions (endian swap, same interface as windows API)\r
+\r
+beware (20030905)\r
+* if connect failed (conn refused) set state to connected and call internalclose, to get closed handler (instead of fdclose)\r
+* (lcore) if closing the fd's in internalcose, set fd's to -1 because closing an fd makes it invalid\r
+\r
+beware (20030927)\r
+* fixed: on connect failed, tried to close fdhandle's which were already set to -1, added check\r
+\r
+beware (20031017)\r
+* added getpeeraddr, getpeerport, remote addr+port as string\r
+}\r
+\r
+\r
+unit lsocket;\r
+{$ifdef fpc}\r
+  {$mode delphi}\r
+{$endif}\r
+interface\r
+  uses\r
+    sysutils,\r
+    {$ifdef win32}\r
+      windows,winsock,\r
+    {$else}\r
+\r
+      {$ifdef VER1_0}\r
+        linux,\r
+      {$else}\r
+        baseunix,unix,\r
+      {$endif}\r
+      sockets,\r
+    {$endif}\r
+    classes,{pgdebugout,}pgtypes,lcore,fd_utils,binipstuff,dnssync;\r
+type\r
+  sunB = packed record\r
+    s_b1, s_b2, s_b3, s_b4: byte;\r
+  end;\r
+\r
+  SunW = packed record\r
+    s_w1, s_w2: word;\r
+  end;\r
+\r
+  TInAddr = packed record\r
+    case integer of\r
+      0: (S_un_b: SunB);\r
+      1: (S_un_w: SunW);\r
+      2: (S_addr: cardinal);\r
+  end;\r
+  {$ifdef ipv6}\r
+    {$ifdef ver1_0}\r
+      cuint16=word;\r
+      cuint32=dword;\r
+      sa_family_t=word;\r
+\r
+\r
+      TInetSockAddr6 = packed Record\r
+        sin6_family   : sa_family_t;\r
+        sin6_port     : cuint16;\r
+        sin6_flowinfo : cuint32;\r
+        sin6_addr     : Tin6_addr;\r
+        sin6_scope_id : cuint32;\r
+      end;\r
+    {$endif}\r
+  {$endif}\r
+  TinetSockAddrv = packed record\r
+    case integer of\r
+      0: (InAddr:TInetSockAddr);\r
+      {$ifdef ipv6}\r
+      1: (InAddr6:TInetSockAddr6);\r
+      {$endif}\r
+  end;\r
+  Pinetsockaddrv = ^Tinetsockaddrv;\r
+\r
+\r
+  type\r
+    tsockaddrin=TInetSockAddr;\r
+\r
+  type\r
+    TLsocket = class(tlasio)\r
+    public\r
+      //a: string;\r
+\r
+      inAddr             : TInetSockAddrV;\r
+{      inAddrSize:integer;}\r
+\r
+      //host               : THostentry      ;\r
+\r
+      //mainthread         : boolean         ; //for debuggin only\r
+      addr:string;\r
+      port:string;\r
+      localaddr:string;\r
+      localport:string;\r
+      proto:string;\r
+      udp:boolean;\r
+      listenqueue:integer;\r
+      function getaddrsize:integer;\r
+      procedure connect; virtual;\r
+      procedure bindsocket;\r
+      procedure listen;\r
+      function accept : longint;\r
+      function sendto(dest:TInetSockAddr;destlen:integer;data:pointer;len:integer):integer; virtual;\r
+      function receivefrom(data:pointer;len:integer;var src:TInetSockAddr;var srclen:integer):integer; virtual;\r
+      //procedure internalclose(error:word);override;\r
+      procedure handlefdtrigger(readtrigger,writetrigger:boolean); override;\r
+      function send(data:pointer;len:integer):integer;override;\r
+      procedure sendstr(const str : string);override;\r
+      function Receive(Buf:Pointer;BufSize:integer):integer; override;\r
+      function getpeername(var addr:tsockaddrin;addrlen:integer):integer; virtual;\r
+      procedure getXaddrbin(var binip:tbinip); virtual;\r
+      procedure getpeeraddrbin(var binip:tbinip); virtual;\r
+      function getXaddr:string; virtual;\r
+      function getpeeraddr:string; virtual;\r
+      function getXport:string; virtual;\r
+      function getpeerport:string; virtual;\r
+      constructor Create(AOwner: TComponent); override;\r
+      {$ifdef win32}\r
+        procedure myfdclose(fd : integer); override;\r
+        function myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt; override;\r
+        function myfdread(fd: LongInt;var buf;size: LongInt):LongInt; override;\r
+      {$endif}\r
+    end;\r
+    tsocket=longint; // for compatibility with twsocket\r
+\r
+  twsocket=tlsocket; {easy}\r
+\r
+function htons(w:word):word;\r
+function htonl(i:integer):integer;\r
+{!!!function longipdns(s:string):longint;}\r
+\r
+{$ifdef ipv6}\r
+const\r
+  v4listendefault:boolean=false;\r
+{$endif}\r
+\r
+\r
+const\r
+  TCP_NODELAY=1;\r
+  IPPROTO_TCP=6;\r
+\r
+implementation\r
+{$include unixstuff.inc}\r
+\r
+function longip(s:string):longint;{$ifdef fpc}inline;{$endif}\r
+var\r
+  l:longint;\r
+  a,b:integer;\r
+\r
+function convertbyte(const s:string):integer;{$ifdef fpc}inline;{$endif}\r
+begin\r
+  result := strtointdef(s,-1);\r
+  if result < 0 then exit;\r
+  if result > 255 then exit;\r
+\r
+  {01 exception}\r
+  if (result <> 0) and (s[1] = '0') then begin\r
+    result := -1;\r
+    exit;\r
+  end;\r
+\r
+  {+1 exception}\r
+  if not (s[1] in ['0'..'9']) then begin\r
+    result := -1;\r
+    exit\r
+  end;\r
+end;\r
+\r
+begin\r
+  result := 0;\r
+  a := pos('.',s);\r
+  if a = 0 then exit;\r
+  b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+  l := b shl 24;\r
+  s := copy(s,a+1,256);\r
+  a := pos('.',s);\r
+  if a = 0 then exit;\r
+  b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+  l := l or b shl 16;\r
+  s := copy(s,a+1,256);\r
+  a := pos('.',s);\r
+  if a = 0 then exit;\r
+  b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+  l := l or b shl 8;\r
+  s := copy(s,a+1,256);\r
+  b := convertbyte(copy(s,1,256));if (b < 0) then exit;\r
+  l := l or b;\r
+  result := l;\r
+end;\r
+\r
+(*!!!\r
+function longipdns(s:string):longint;\r
+var\r
+  host : thostentry;\r
+begin\r
+  if s = '0.0.0.0' then begin\r
+    result := 0;\r
+  end else begin\r
+    result := longip(s);\r
+    if result = 0 then begin\r
+      if gethostbyname(s,host) then begin;\r
+        result := htonl(Longint(Host.Addr));\r
+      end;\r
+      //writeln(inttohex(longint(host.addr),8))\r
+    end;\r
+    if result = 0 then begin\r
+      if resolvehostbyname(s,host) then begin;\r
+        result := htonl(Longint(Host.Addr));\r
+      end;\r
+      //writeln(inttohex(longint(host.addr),8))\r
+    end;\r
+  end;\r
+end;\r
+*)\r
+\r
+\r
+function htons(w:word):word;\r
+begin\r
+  {$ifndef ENDIAN_BIG}\r
+  result := ((w and $ff00) shr 8) or ((w and $ff) shl 8);\r
+  {$else}\r
+  result := w;\r
+  {$endif}\r
+end;\r
+\r
+function htonl(i:integer):integer;\r
+begin\r
+  {$ifndef ENDIAN_BIG}\r
+  result := (i shr 24) or (i shr 8 and $ff00) or (i shl 8 and $ff0000) or (i shl 24 and $ff000000);\r
+  {$else}\r
+  result := i;\r
+  {$endif}\r
+end;\r
+\r
+function tlsocket.getaddrsize:integer;\r
+begin\r
+  {$ifdef ipv6}\r
+  if inaddr.inaddr.family = AF_INET6 then result := sizeof(tinetsockaddr6) else\r
+  {$endif}\r
+  result := sizeof(tinetsockaddr);\r
+end;\r
+\r
+function makeinaddrv(addr,port:string;var inaddr:tinetsockaddrv):integer;\r
+var\r
+  biniptemp:tbinip;\r
+begin\r
+  result := 0;\r
+  biniptemp := forwardlookup(addr,10);\r
+  fillchar(inaddr,sizeof(inaddr),0);\r
+  //writeln('converted address '+addr+' to binip '+ipbintostr(biniptemp));\r
+  if biniptemp.family = AF_INET then begin\r
+    inAddr.InAddr.family:=AF_INET;\r
+    inAddr.InAddr.port:=htons(strtointdef(port,0));\r
+    inAddr.InAddr.addr:=biniptemp.ip;\r
+    result := sizeof(tinetsockaddr);\r
+  end else\r
+  {$ifdef ipv6}\r
+  if biniptemp.family = AF_INET6 then begin\r
+    inAddr.InAddr6.sin6_family:=AF_INET6;\r
+    inAddr.InAddr6.sin6_port:=htons(strtointdef(port,0));\r
+    inAddr.InAddr6.sin6_addr:=biniptemp.ip6;\r
+    result := sizeof(tinetsockaddr6);\r
+  end else\r
+  {$endif}\r
+  raise esocketexception.create('unable to resolve address: '+addr);\r
+end;\r
+\r
+procedure tlsocket.connect;\r
+var\r
+  a:integer;\r
+begin\r
+  if state <> wsclosed then close;\r
+  //prevtime := 0;\r
+  makeinaddrv(addr,port,inaddr);\r
+\r
+  udp := uppercase(proto) = 'UDP';\r
+  if udp then a := SOCK_DGRAM else a := SOCK_STREAM;\r
+  a := Socket(inaddr.inaddr.family,a,0);\r
+\r
+  //writeln(ord(inaddr.inaddr.family));\r
+  if a = -1 then begin\r
+    lasterror := {$ifdef win32}getlasterror{$else}socketerror{$endif};\r
+    raise esocketexception.create('unable to create socket');\r
+  end;\r
+  try\r
+    dup(a);\r
+    bindsocket;\r
+    if udp then begin\r
+      {$ifndef win32}\r
+        SetSocketOptions(fdhandleout, SOL_SOCKET, SO_BROADCAST, 'TRUE', Length('TRUE'));\r
+      {$endif}\r
+      state := wsconnected;\r
+      if assigned(onsessionconnected) then onsessionconnected(self,0);\r
+    end else begin\r
+      state :=wsconnecting;\r
+      {$ifdef win32}\r
+        //writeln(inaddr.inaddr.port);\r
+        winsock.Connect(fdhandlein,winsock.psockaddr(@inADDR)^,getaddrsize);\r
+      {$else}\r
+        sockets.Connect(fdhandlein,inADDR,getaddrsize);\r
+      {$endif}\r
+    end;\r
+    eventcore.rmasterset(fdhandlein,false);\r
+    if udp then begin\r
+      eventcore.wmasterclr(fdhandleout);\r
+    end else begin\r
+      eventcore.wmasterset(fdhandleout);\r
+    end;\r
+    //sendq := '';\r
+  except\r
+    on e: exception do begin\r
+      fdcleanup;\r
+      raise; //reraise the exception\r
+    end;\r
+  end;\r
+end;\r
+\r
+procedure tlsocket.sendstr(const str : string);\r
+begin\r
+  if udp then begin\r
+    send(@str[1],length(str))\r
+  end else begin\r
+    inherited sendstr(str);\r
+  end;\r
+end;\r
+\r
+function tlsocket.send(data:pointer;len:integer):integer;\r
+begin\r
+  if udp then begin\r
+    //writeln('sending to '+inttohex(inaddr.inaddr.addr,8));\r
+    result := sendto(inaddr.inaddr,getaddrsize,data,len)\r
+;\r
+    //writeln('send result',result);\r
+    //writeln('errno',errno);\r
+  end else begin\r
+    result := inherited send(data,len);\r
+  end;\r
+end;\r
+\r
+\r
+function tlsocket.receive(Buf:Pointer;BufSize:integer):integer;\r
+begin\r
+  if udp then begin\r
+    result := myfdread(self.fdhandlein,buf^,bufsize);\r
+  end else begin\r
+    result := inherited receive(buf,bufsize);\r
+  end;\r
+end;\r
+\r
+procedure tlsocket.bindsocket;\r
+var\r
+  a:integer;\r
+  inAddrtemp:TInetSockAddrV;\r
+  inAddrtempx:{$ifdef win32}winsock.TSockaddr{$else}TInetSockAddrV{$endif} absolute inaddrtemp;\r
+  inaddrtempsize:integer;\r
+begin\r
+  try\r
+    if (localaddr <> '') or (localport <> '') then begin\r
+      if localaddr = '' then begin\r
+        {$ifdef ipv6}\r
+        if inaddr.inaddr.family = AF_INET6 then localaddr := '::' else\r
+        {$endif}\r
+        localaddr := '0.0.0.0';\r
+      end;\r
+      //gethostbyname(localaddr,host);\r
+\r
+      inaddrtempsize := makeinaddrv(localaddr,localport,inaddrtemp);\r
+\r
+      If Bind(fdhandlein,inaddrtempx,inaddrtempsize)<> {$ifdef win32}0{$else}true{$endif} Then begin\r
+        state := wsclosed;\r
+        lasterror := {$ifdef win32}getlasterror{$else}socketerror{$endif};\r
+        raise ESocketException.create('unable to bind, error '+inttostr(lasterror));\r
+      end;\r
+      state := wsbound;\r
+    end;\r
+  except\r
+    on e: exception do begin\r
+      fdcleanup;\r
+      raise; //reraise the exception\r
+    end;\r
+  end;\r
+end;\r
+\r
+procedure tlsocket.listen;\r
+var\r
+  yes:longint;\r
+  socktype:integer;\r
+  biniptemp:tbinip;\r
+  origaddr:string;\r
+begin\r
+  if state <> wsclosed then close;\r
+  udp := uppercase(proto) = 'UDP';\r
+  if udp then socktype := SOCK_DGRAM else socktype := SOCK_STREAM;\r
+  origaddr := addr;\r
+\r
+  if addr = '' then begin\r
+    {$ifdef ipv6}\r
+    if not v4listendefault then begin\r
+      addr := '::';\r
+    end else\r
+    {$endif}\r
+    addr := '0.0.0.0';\r
+  end;\r
+  biniptemp := forwardlookup(addr,10);\r
+  addr := ipbintostr(biniptemp);\r
+  fdhandlein := socket(biniptemp.family,socktype,0);\r
+  {$ifdef ipv6}\r
+  if (addr = '::') and (origaddr = '') and (fdhandlein < 0) then begin\r
+    addr := '0.0.0.0';\r
+    fdhandlein := socket(AF_INET,socktype,0);\r
+  end;\r
+  {$endif}\r
+  if fdhandlein = -1 then raise ESocketException.create('unable to create socket');\r
+  dupnowatch(fdhandlein); // sets up maxs and copies handle to fdhandleout among other things\r
+  //eventcore.setfdreverse(fdhandlein,self); //already taken care of by dup\r
+  state := wsclosed; // then set this back as it was an undesired side effect of dup\r
+\r
+  try\r
+    yes := $01010101;  {Copied this from existing code. Value is empiric,\r
+                    but works. (yes=true<>0) }\r
+    {$ifndef win32}\r
+      if SetSocketOptions(fdhandlein, SOL_SOCKET, SO_REUSEADDR,yes,sizeof(yes))=-1 then begin\r
+        raise ESocketException.create('unable to set socket options');\r
+      end;\r
+    {$endif}\r
+    localaddr := addr;\r
+    localport := port;\r
+    bindsocket;\r
+\r
+    if not udp then begin\r
+      {!!! allow custom queue length? default 5}\r
+      if listenqueue = 0 then listenqueue := 5;\r
+      If {$ifdef win32}winsock{$else}sockets{$endif}.Listen(fdhandlein,listenqueue)<>{$ifdef win32}0{$else}true{$endif} Then raise esocketexception.create('unable to listen');\r
+      state := wsListening;\r
+    end else begin\r
+      {$ifndef win32}\r
+        SetSocketOptions(fdhandleout, SOL_SOCKET, SO_BROADCAST, 'TRUE', Length('TRUE'));\r
+      {$endif}\r
+      state := wsconnected;\r
+    end;\r
+  finally\r
+    if state = wsclosed then begin\r
+      if fdhandlein >= 0 then begin\r
+        {one *can* get here without fd -beware}\r
+        eventcore.rmasterclr(fdhandlein);\r
+        myfdclose(fdhandlein); // we musnt leak file discriptors\r
+        eventcore.setfdreverse(fdhandlein,nil);\r
+        fdhandlein := -1;\r
+      end;\r
+    end else begin\r
+      eventcore.rmasterset(fdhandlein,true);\r
+    end;\r
+    if fdhandleout >= 0 then eventcore.wmasterclr(fdhandleout);\r
+  end;\r
+  //writeln('listened on addr '+addr+':'+port+' '+proto+' using socket number ',fdhandlein); \r
+end;\r
+\r
+function tlsocket.accept : longint;\r
+var\r
+  FromAddrSize     : LongInt;        // i don't realy know what to do with these at this\r
+  FromAddr         : TInetSockAddrV;  // at this point time will tell :)\r
+begin\r
+\r
+  FromAddrSize := Sizeof(FromAddr);\r
+  {$ifdef win32}\r
+    result := winsock.accept(fdhandlein,@fromaddr,@fromaddrsize);\r
+  {$else}\r
+    result := sockets.accept(fdhandlein,fromaddr,fromaddrsize);\r
+  {$endif}\r
+  //now we have accepted one request start monitoring for more again\r
+  eventcore.rmasterset(fdhandlein,true);\r
+\r
+  if result = -1 then raise esocketexception.create('error '+inttostr({$ifdef win32}getlasterror{$else}socketerror{$endif})+' while accepting');\r
+  if result > absoloutemaxs then begin\r
+    myfdclose(result);\r
+    result := -1;\r
+    raise esocketexception.create('file discriptor out of range');\r
+  end;\r
+end;\r
+\r
+function tlsocket.sendto(dest:TInetSockAddr;destlen:integer;data:pointer;len:integer):integer;\r
+var\r
+  destx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddr{$endif} absolute dest;\r
+begin\r
+  result := {$ifdef win32}winsock{$else}sockets{$endif}.sendto(self.fdhandleout,data^,len,0,destx,destlen);\r
+end;\r
+\r
+function tlsocket.receivefrom(data:pointer;len:integer;var src:TInetSockAddr;var srclen:integer):integer;\r
+var\r
+  srcx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddr{$endif} absolute src;\r
+begin\r
+  result := {$ifdef win32}winsock{$else}sockets{$endif}.recvfrom(self.fdhandlein,data^,len,0,srcx,srclen);\r
+end;\r
+\r
+procedure tlsocket.handlefdtrigger(readtrigger,writetrigger:boolean);\r
+var\r
+  tempbuf:array[0..receivebufsize-1] of byte;\r
+begin\r
+  //writeln('got a fd trigger, readtrigger=',readtrigger,' writetrigger=',writetrigger);\r
+  if (state =wslistening) and readtrigger then begin\r
+{    debugout('listening socket triggered on read');}\r
+    eventcore.rmasterclr(fdhandlein);\r
+    if assigned(onsessionAvailable) then onsessionAvailable(self,0);\r
+  end;\r
+  if udp and readtrigger then begin\r
+    if assigned(ondataAvailable) then ondataAvailable(self,0);\r
+    {!!!test}\r
+    exit;\r
+  end;\r
+  if (state =wsconnecting) and writetrigger then begin\r
+    // code for dealing with the reults of a non-blocking connect is\r
+    // rather complex\r
+    // if just write is triggered it means connect suceeded\r
+    // if both read and write are triggered it can mean 2 things\r
+    // 1: connect ok and data availible\r
+    // 2: connect fail\r
+    // to find out which you must read from the socket and look for errors\r
+    // there if we read successfully we drop through into the code for fireing\r
+    // the read event\r
+    if not readtrigger then begin\r
+      state := wsconnected;\r
+      if assigned(onsessionconnected) then onsessionconnected(self,0);\r
+    end else begin\r
+      numread := myfdread(fdhandlein,tempbuf,sizeof(tempbuf));\r
+      if numread <> -1 then begin\r
+        state := wsconnected;\r
+        if assigned(onsessionconnected) then onsessionconnected(self,0);\r
+        //connectread := true;\r
+        recvq.add(@tempbuf,numread);\r
+      end else begin\r
+        state := wsconnected;\r
+        if assigned(onsessionconnected) then onsessionconnected(self,{$ifdef win32}wsagetlasterror{$else}linuxerror{$endif});\r
+{        debugout('connect fail');}\r
+        self.internalclose(0);\r
+        recvq.del(maxlongint);\r
+      end;\r
+      // if things went well here we are now in the state wsconnected with data sitting in our receive buffer\r
+      // so we drop down into the processing for data availible\r
+    end;\r
+    if fdhandlein >= 0 then begin\r
+      if state = wsconnected then begin\r
+        eventcore.rmasterset(fdhandlein,false);\r
+      end else begin\r
+        eventcore.rmasterclr(fdhandlein);\r
+      end;\r
+    end;\r
+    if fdhandleout >= 0 then begin\r
+      if sendq.size = 0 then begin\r
+        //don't clear the bit in fdswmaster if data is in the sendq\r
+        eventcore.wmasterclr(fdhandleout);\r
+      end;\r
+    end;\r
+\r
+  end;\r
+  inherited handlefdtrigger(readtrigger,writetrigger);\r
+end;\r
+\r
+constructor tlsocket.Create(AOwner: TComponent);\r
+begin\r
+  inherited create(aowner);\r
+  closehandles := true;\r
+end;\r
+\r
+\r
+function tlsocket.getpeername(var addr:tsockaddrin;addrlen:integer):integer;\r
+var\r
+  addrx : {$ifdef win32}winsock.tsockaddr{$else}tsockaddrin{$endif} absolute addr;\r
+begin\r
+  result := {$ifdef win32}winsock{$else}sockets{$endif}.getpeername(self.fdhandlein,addrx,addrlen);\r
+end;\r
+\r
+procedure tlsocket.getxaddrbin(var binip:tbinip);\r
+var\r
+  addr:tinetsockaddrv;\r
+  i:integer;\r
+begin\r
+  i := sizeof(addr);\r
+  fillchar(addr,sizeof(addr),0);\r
+\r
+  {$ifdef win32}\r
+    winsock.getsockname(self.fdhandlein,psockaddr(@addr)^,i);\r
+  {$else}\r
+    sockets.getsocketname(self.fdhandlein,addr,i);\r
+  {$endif}\r
+  binip.family := addr.inaddr.family;\r
+  {$ifdef ipv6}\r
+  if addr.inaddr6.sin6_family = AF_INET6 then begin\r
+    binip.ip6 := addr.inaddr6.sin6_addr;\r
+  end else\r
+  {$endif}\r
+  begin\r
+    binip.ip := addr.inaddr.addr;\r
+  end;\r
+  converttov4(binip);\r
+end;\r
+\r
+procedure tlsocket.getpeeraddrbin(var binip:tbinip);\r
+var\r
+  addr:tinetsockaddrv;\r
+  i:integer;\r
+begin\r
+  i := sizeof(addr);\r
+  fillchar(addr,sizeof(addr),0);\r
+  {$ifdef win32}\r
+    winsock.getpeername(self.fdhandlein,psockaddr(@addr)^,i);\r
+  {$else}\r
+    sockets.getpeername(self.fdhandlein,addr,i);\r
+  {$endif}\r
+\r
+  binip.family := addr.inaddr.family;\r
+  {$ifdef ipv6}\r
+  if addr.inaddr6.sin6_family = AF_INET6 then begin\r
+    binip.ip6 := addr.inaddr6.sin6_addr;\r
+  end else\r
+  {$endif}\r
+  begin\r
+    binip.ip := addr.inaddr.addr;\r
+  end;\r
+  converttov4(binip);\r
+end;\r
+\r
+function tlsocket.getXaddr:string;\r
+var\r
+  biniptemp:tbinip;\r
+begin\r
+  getxaddrbin(biniptemp);\r
+  result := ipbintostr(biniptemp);\r
+  if result = '' then result := 'error';\r
+end;\r
+\r
+function tlsocket.getpeeraddr:string;\r
+var\r
+  biniptemp:tbinip;\r
+begin\r
+  getpeeraddrbin(biniptemp);\r
+  result := ipbintostr(biniptemp);\r
+  if result = '' then result := 'error';\r
+end;\r
+\r
+function tlsocket.getXport:string;\r
+var\r
+  addr:{$ifdef win32}winsock.tsockaddr{$else}tinetsockaddr{$endif};\r
+  i:integer;\r
+begin\r
+  i := sizeof(addr);\r
+  {$ifdef win32}\r
+    winsock.getsockname(self.fdhandlein,addr,i);\r
+    i := htons(addr.sin_port);\r
+  {$else}\r
+    sockets.getsocketname(self.fdhandlein,addr,i);\r
+    i := htons(addr.port);\r
+  {$endif}\r
+  result := inttostr(i);\r
+end;\r
+\r
+function tlsocket.getpeerport:string;\r
+var\r
+  addr:{$ifdef win32}winsock.tsockaddr{$else}tinetsockaddr{$endif};\r
+  i:integer;\r
+begin\r
+  i := sizeof(addr);\r
+  {$ifdef win32}\r
+    winsock.getpeername(self.fdhandlein,addr,i);\r
+    i := htons(addr.sin_port);\r
+  {$else}\r
+    sockets.getpeername(self.fdhandlein,addr,i);\r
+    i := htons(addr.port);\r
+  {$endif}\r
+  result := inttostr(i);\r
+end;\r
+\r
+{$ifdef win32}\r
+  procedure tlsocket.myfdclose(fd : integer);\r
+  begin\r
+    closesocket(fd);\r
+  end;\r
+  function tlsocket.myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt;\r
+  begin\r
+    result := winsock.send(fd,(@buf)^,size,0);\r
+  end;\r
+  function tlsocket.myfdread(fd: LongInt;var buf;size: LongInt):LongInt;\r
+  begin\r
+    result := winsock.recv(fd,buf,size,0);\r
+  end;\r
+{$endif}\r
+
+end.\r
+\r

diff --git a/httpserver_20080306/ltimevalstuff.inc b/httpserver_20080306/ltimevalstuff.inc
new file mode 100755 (executable)
index 0000000..0ac92cb
--- /dev/null
+++ b/httpserver_20080306/ltimevalstuff.inc
@@ -0,0 +1,42 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+\r
+\r
+\r
+{add nn msec to tv}\r
+const\r
+  tv_invalidtimebig : ttimeval = (tv_sec:maxlongint;tv_usec:maxlongint);\r
+  //tv_invalidtimebig will always compare as greater than any valid timeval\r
+procedure tv_add(var tv:ttimeval;msec:integer);//{ $ifdef fpc}inline;{ $endif}\r
+begin\r
+  inc(tv.tv_usec,msec*1000);\r
+  inc(tv.tv_sec,tv.tv_usec div 1000000);\r
+  tv.tv_usec := tv.tv_usec mod 1000000;\r
+end;\r
+\r
+{tv1 >= tv2}\r
+function tv_compare(const tv1,tv2:ttimeval):boolean;//{ $ifdef fpc}inline;{ $endif}\r
+begin\r
+  if tv1.tv_sec = tv2.tv_sec then begin\r
+    result := tv1.tv_usec >= tv2.tv_usec;\r
+  end else result := tv1.tv_sec > tv2.tv_sec;\r
+end;\r
+\r
+procedure tv_substract(var tv:ttimeval;const tv2:ttimeval);//{ $ifdef fpc}inline;{ $endif}\r
+begin\r
+  dec(tv.tv_usec,tv2.tv_usec);\r
+  if tv.tv_usec < 0 then begin\r
+    inc(tv.tv_usec,1000000);\r
+    dec(tv.tv_sec)\r
+  end;\r
+  dec(tv.tv_sec,tv2.tv_sec);\r
+end;\r
+\r
+procedure msectotimeval(var tv:ttimeval;msec:integer);\r
+begin\r
+  tv.tv_sec := msec div 1000;\r
+  tv.tv_usec := (msec mod 1000)*1000;\r
+end;\r
+\r

diff --git a/httpserver_20080306/pgtypes.pas b/httpserver_20080306/pgtypes.pas
new file mode 100755 (executable)
index 0000000..3c48e26
--- /dev/null
+++ b/httpserver_20080306/pgtypes.pas
@@ -0,0 +1,20 @@
+{io core originally for linux bworld}\r
+\r
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+\r
+unit pgtypes;\r
+interface\r
+  type\r
+    {$ifdef cpu386}{$define i386}{$endif}\r
+    {$ifdef i386}\r
+      taddrint=longint;\r
+    {$else}\r
+      taddrint=sizeint;\r
+    {$endif}\r
+    paddrint=^taddrint;\r
+\r
+implementation\r
+end.\r

diff --git a/httpserver_20080306/uint32.inc b/httpserver_20080306/uint32.inc
new file mode 100755 (executable)
index 0000000..897db79
--- /dev/null
+++ b/httpserver_20080306/uint32.inc
@@ -0,0 +1,14 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green
+  For conditions of distribution and use, see copyright notice in zlib_license.txt
+  which is included in the package
+  ----------------------------------------------------------------------------- }\r
+type\r
+  {delphi 3 and before do not have a 32 bits unsigned integer type,\r
+  but longint has the correct behavior - it doesn't on newer delphi versions}\r
+  {$ifndef fpc}\r
+    {$ifdef ver70}{$define pred4}{$endif} {tp7}\r
+    {$ifdef ver80}{$define pred4}{$endif} {delphi 1}\r
+    {$ifdef ver90}{$define pred4}{$endif} {delphi 2}\r
+    {$ifdef ver100}{$define pred4}{$endif} {delphi 3}\r
+  {$endif}\r
+  uint32={$ifdef pred4}longint{$else}longword{$endif};\r

diff --git a/httpserver_20080306/unixstuff.inc b/httpserver_20080306/unixstuff.inc
new file mode 100755 (executable)
index 0000000..92ed308
--- /dev/null
+++ b/httpserver_20080306/unixstuff.inc
@@ -0,0 +1,66 @@
+{$ifdef UNIX}\r
+  {$macro on}\r
+  {$ifdef VER1_0}\r
+    {$define tv_sec := sec}\r
+    {$define tv_usec := usec}\r
+    function dup(const original:integer):integer;inline;\r
+    begin\r
+      linux.dup(original,result);\r
+    end;\r
+    {$define gettimeofdaysec := gettimeofday}\r
+  {$else}\r
+    \r
+    {$define sigprocmask := fpsigprocmask}\r
+    {$define sigaction   := fpsigaction}\r
+    {$define fdclose     := fpclose}\r
+    {$define fcntl       := fpfcntl}\r
+    {$define fdwrite     := fpwrite}\r
+    {$define fdread      := fpread}\r
+    {$define fdopen      := fpopen}\r
+    {$define select      := fpselect}\r
+    {$define linuxerror  := fpgeterrno}\r
+    {$define fork        := fpfork}\r
+    {$define getpid      := fpgetpid}\r
+    {$define getenv      := fpgetenv}\r
+    {$define chmod       := fpchmod}\r
+    {$define dup2        := fpdup2}\r
+    {$ifndef ver1_9_2}\r
+      {$define flock       := fpflock}\r
+    {$endif}\r
+    procedure gettimeofday(var tv:ttimeval);inline;\r
+    begin\r
+      fpgettimeofday(@tv,nil);    \r
+    end;\r
+    function gettimeofdaysec : longint;\r
+    var\r
+      tv:ttimeval;\r
+    begin\r
+      gettimeofday(tv);\r
+      result := tv.tv_sec;\r
+    end;\r
+\r
+    //a function is used here rather than a define to prevent issues with tlasio.dup\r
+    function dup(const original:integer):integer;inline;\r
+    begin\r
+      result := fpdup(original);\r
+    end;\r
+    function octal(invalue:longint):longint;\r
+    var\r
+      a : integer;\r
+      i : integer;\r
+    begin\r
+      i := 0;\r
+      result := 0;\r
+      while invalue <> 0 do begin\r
+        a := invalue mod 10;\r
+        result := result + (a shl (i*3));\r
+\r
+        invalue := invalue div 10;\r
+        inc(i);\r
+      end;\r
+    end;\r
+    const\r
+      sys_eintr=esyseintr;\r
+\r
+  {$endif}\r
+{$endif}\r

diff --git a/httpserver_20080306/wcore.pas b/httpserver_20080306/wcore.pas
new file mode 100755 (executable)
index 0000000..40505ef
--- /dev/null
+++ b/httpserver_20080306/wcore.pas
@@ -0,0 +1,372 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+\r
+unit wcore;\r
+\r
+{\r
+lcore compatible interface for windows\r
+\r
+- messageloop\r
+\r
+- tltimer\r
+\r
+}\r
+//note: events after release are normal and are the apps responsibility to deal with safely\r
+interface\r
+\r
+  uses\r
+    classes,windows,mmsystem;\r
+\r
+  type\r
+    float=double;\r
+\r
+    tlcomponent = class(tcomponent)\r
+    public\r
+      released:boolean;\r
+      procedure release;\r
+      destructor destroy; override;\r
+    end;\r
+\r
+    tltimer=class(tlcomponent)\r
+    public\r
+      ontimer:tnotifyevent;\r
+      initialevent:boolean;\r
+      initialdone:boolean;\r
+      prevtimer:tltimer;\r
+      nexttimer:tltimer;\r
+      interval:integer;        {miliseconds, default 1000}\r
+      enabled:boolean;\r
+      nextts:integer;\r
+      constructor create(aowner:tcomponent);override;\r
+      destructor destroy;override;\r
+    end;\r
+\r
+    ttaskevent=procedure(wparam,lparam:longint) of object;\r
+\r
+    tltask=class(tobject)\r
+    public\r
+      handler  : ttaskevent;\r
+      obj      : tobject;\r
+      wparam   : longint;\r
+      lparam   : longint;\r
+      nexttask : tltask;\r
+      constructor create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+    end;\r
+\r
+procedure messageloop;\r
+procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+procedure disconnecttasks(aobj:tobject);\r
+procedure exitmessageloop;\r
+procedure processmessages;\r
+\r
+var\r
+  onshutdown:procedure(s:string);\r
+\r
+implementation\r
+\r
+uses\r
+  {$ifdef fpc}\r
+  bmessages;\r
+  {$else}\r
+  messages;\r
+  {$endif}\r
+\r
+\r
+const\r
+  WINMSG_TASK=WM_USER;\r
+\r
+var\r
+  hwndwcore:hwnd;\r
+  firsttimer:tltimer;\r
+  timesubstract:integer;\r
+  firsttask,lasttask,currenttask:tltask;\r
+\r
+procedure tlcomponent.release;\r
+begin\r
+  released := true;\r
+end;\r
+\r
+destructor tlcomponent.destroy;\r
+begin\r
+  disconnecttasks(self);\r
+  inherited destroy;\r
+end;\r
+\r
+{------------------------------------------------------------------------------}\r
+\r
+constructor tltimer.create;\r
+begin\r
+  inherited create(AOwner);\r
+  nexttimer := firsttimer;\r
+  prevtimer := nil;\r
+\r
+  if assigned(nexttimer) then nexttimer.prevtimer := self;\r
+  firsttimer := self;\r
+\r
+  interval := 1000;\r
+  enabled := true;\r
+  released := false;\r
+end;\r
+\r
+destructor tltimer.destroy;\r
+begin\r
+  if prevtimer <> nil then begin\r
+    prevtimer.nexttimer := nexttimer;\r
+  end else begin\r
+    firsttimer := nexttimer;\r
+  end;\r
+  if nexttimer <> nil then begin\r
+    nexttimer.prevtimer := prevtimer;\r
+  end;\r
+  inherited destroy;\r
+end;\r
+\r
+{------------------------------------------------------------------------------}\r
+\r
+function wcore_timehandler:integer;\r
+const\r
+  rollover_bits=30;\r
+var\r
+  tv,tvnow:integer;\r
+  currenttimer,temptimer:tltimer;\r
+begin\r
+  if not assigned(firsttimer) then begin\r
+    result := 1000;\r
+    exit;\r
+  end;\r
+\r
+  tvnow := timegettime;\r
+  if (tvnow and ((-1) shl rollover_bits)) <> timesubstract then begin\r
+    currenttimer := firsttimer;\r
+    while assigned(currenttimer) do begin\r
+      dec(currenttimer.nextts,(1 shl rollover_bits));\r
+      currenttimer := currenttimer.nexttimer;\r
+    end;\r
+    timesubstract := tvnow and ((-1) shl rollover_bits);\r
+  end;\r
+  tvnow := tvnow and ((1 shl rollover_bits)-1);\r
+\r
+  currenttimer := firsttimer;\r
+  while assigned(currenttimer) do begin\r
+    if tvnow >= currenttimer.nextts then begin\r
+      if assigned(currenttimer.ontimer) then begin\r
+        if currenttimer.enabled then begin\r
+          if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer);\r
+          currenttimer.initialdone := true;\r
+        end;\r
+      end;\r
+      currenttimer.nextts := tvnow+currenttimer.interval;\r
+    end;\r
+    temptimer := currenttimer;\r
+    currenttimer := currenttimer.nexttimer;\r
+    if temptimer.released then temptimer.free;\r
+  end;\r
+\r
+  tv := maxlongint;\r
+  currenttimer := firsttimer;\r
+  while assigned(currenttimer) do begin\r
+    if currenttimer.nextts < tv then tv := currenttimer.nextts;\r
+    currenttimer := currenttimer.nexttimer;\r
+  end;\r
+  result := tv-tvnow;\r
+  if result < 15 then result := 15;\r
+end;\r
+\r
+{------------------------------------------------------------------------------}\r
+\r
+constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+  inherited create;\r
+  handler   := ahandler;\r
+  obj       := aobj;\r
+  wparam    := awparam;\r
+  lparam    := alparam;\r
+  {nexttask  := firsttask;\r
+  firsttask := self;}\r
+  if assigned(lasttask) then begin\r
+    lasttask.nexttask := self;\r
+  end else begin\r
+    firsttask := self;\r
+    postmessage(hwndwcore,WINMSG_TASK,0,0);\r
+  end;\r
+  lasttask := self;\r
+  //ahandler(wparam,lparam);\r
+end;\r
+\r
+procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+  tltask.create(ahandler,aobj,awparam,alparam);\r
+end;\r
+\r
+procedure disconnecttasks(aobj:tobject);\r
+var\r
+  currenttasklocal : tltask ;\r
+  counter          : byte   ;\r
+begin\r
+  for counter := 0 to 1 do begin\r
+    if counter = 0 then begin\r
+      currenttasklocal := firsttask; //main list of tasks\r
+    end else begin\r
+      currenttasklocal := currenttask; //needed in case called from a task\r
+    end;\r
+    // note i don't bother to sestroy the links here as that will happen when\r
+    // the list of tasks is processed anyway\r
+    while assigned(currenttasklocal) do begin\r
+      if currenttasklocal.obj = aobj then begin\r
+        currenttasklocal.obj := nil;\r
+        currenttasklocal.handler := nil;\r
+      end;\r
+      currenttasklocal := currenttasklocal.nexttask;\r
+    end;\r
+  end;\r
+end;\r
+\r
+procedure dotasks;\r
+var\r
+  temptask:tltask;\r
+begin\r
+  if firsttask = nil then exit;\r
+\r
+  currenttask := firsttask;\r
+  firsttask := nil;\r
+  lasttask  := nil;\r
+  while assigned(currenttask) do begin\r
+    if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam);\r
+    temptask := currenttask;\r
+    currenttask := currenttask.nexttask;\r
+    temptask.free;\r
+  end;\r
+  currenttask := nil;\r
+end;\r
+\r
+{------------------------------------------------------------------------------}\r
+\r
+procedure exitmessageloop;\r
+begin\r
+  postmessage(hwndwcore,WM_QUIT,0,0);\r
+end;\r
+\r
+  {$ifdef threadtimer}\r
+  'thread timer'\r
+  {$else}\r
+const timerid_wcore=$1000;\r
+  {$endif}\r
+\r
+function MyWindowProc(\r
+    ahWnd   : HWND;\r
+    auMsg   : Integer;\r
+    awParam : WPARAM;\r
+    alParam : LPARAM): Integer; stdcall;\r
+var\r
+    MsgRec : TMessage;\r
+    a:integer;\r
+begin\r
+  Result := 0;  // This means we handled the message\r
+\r
+  {MsgRec.hwnd    := ahWnd;}\r
+  MsgRec.wParam  := awParam;\r
+  MsgRec.lParam  := alParam;\r
+\r
+  dotasks;\r
+  case auMsg of\r
+    {$ifndef threadtimer}\r
+    WM_TIMER: begin\r
+      if msgrec.wparam = timerid_wcore then begin\r
+        a := wcore_timehandler;\r
+        killtimer(hwndwcore,timerid_wcore);\r
+        settimer(hwndwcore,timerid_wcore,a,nil);\r
+      end;\r
+    end;\r
+    {$endif}\r
+\r
+    {WINMSG_TASK:dotasks;}\r
+\r
+    WM_CLOSE: begin\r
+      {}\r
+    end;\r
+    WM_DESTROY: begin\r
+      {}\r
+    end;\r
+  else\r
+      Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)\r
+  end;\r
+end;\r
+\r
+\r
+var\r
+  MyWindowClass : TWndClass = (style         : 0;\r
+                                 lpfnWndProc   : @MyWindowProc;\r
+                                 cbClsExtra    : 0;\r
+                                 cbWndExtra    : 0;\r
+                                 hInstance     : 0;\r
+                                 hIcon         : 0;\r
+                                 hCursor       : 0;\r
+                                 hbrBackground : 0;\r
+                                 lpszMenuName  : nil;\r
+                                 lpszClassName : 'wcoreClass');\r
+\r
+procedure messageloop;\r
+var\r
+  MsgRec : TMsg;\r
+begin\r
+\r
+  if Windows.RegisterClass(MyWindowClass) = 0 then halt;\r
+  //writeln('about to create wcore handle, hinstance=',hinstance);\r
+  hwndwcore := CreateWindowEx(WS_EX_TOOLWINDOW,\r
+                               MyWindowClass.lpszClassName,\r
+                               '',        { Window name   }\r
+                               WS_POPUP,  { Window Style  }\r
+                               0, 0,      { X, Y          }\r
+                               0, 0,      { Width, Height }\r
+                               0,         { hWndParent    }\r
+                               0,         { hMenu         }\r
+                               HInstance, { hInstance     }\r
+                               nil);      { CreateParam   }\r
+\r
+  if hwndwcore = 0 then halt;\r
+\r
+  {$ifdef threadtimer}\r
+  'thread timer'\r
+  {$else}\r
+  if settimer(hwndwcore,timerid_wcore,15,nil) = 0 then halt;\r
+  {$endif}\r
+\r
+\r
+  while GetMessage(MsgRec, 0, 0, 0) do begin\r
+    TranslateMessage(MsgRec);\r
+    DispatchMessage(MsgRec);\r
+    {if not peekmessage(msgrec,0,0,0,PM_NOREMOVE) then onidle}\r
+  end;\r
+\r
+  if hWndwcore <> 0 then begin\r
+    DestroyWindow(hwndwcore);\r
+    hWndwcore := 0;\r
+  end;\r
+\r
+  {$ifdef threadtimer}\r
+  'thread timer'\r
+  {$else}\r
+  killtimer(hwndwcore,timerid_wcore);\r
+  {$endif}\r
+end;\r
+\r
+function ProcessMessage : Boolean;\r
+var\r
+    Msg : TMsg;\r
+begin\r
+    Result := FALSE;\r
+    if PeekMessage(Msg, hwndwcore, 0, 0, PM_REMOVE) then begin\r
+      Result := TRUE;\r
+      DispatchMessage(Msg);\r
+    end;\r
+end;\r
+\r
+procedure processmessages;\r
+begin\r
+  while processmessage do;\r
+end;\r
+\r
+\r
+end.\r

diff --git a/lcore.pas b/lcore.pas
new file mode 100755 (executable)
index 0000000..900bc96
--- /dev/null
+++ b/lcore.pas
@@ -0,0 +1,891 @@
+{lsocket.pas}\r
+\r
+{io and timer code by plugwash}\r
+\r
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+\r
+{note: you must use the @ in the last param to tltask.create not doing so will\r
+ compile without error but will cause an access violation -pg}\r
+\r
+//note: events after release are normal and are the apps responsibility to deal with safely\r
+\r
+unit lcore;\r
+{$ifdef fpc}\r
+  {$mode delphi}\r
+{$endif}\r
+{$ifdef win32}\r
+  {$define nosignal}\r
+{$endif}\r
+interface\r
+  uses\r
+    sysutils,\r
+    {$ifndef win32}\r
+      {$ifdef VER1_0}\r
+        linux,\r
+      {$else}\r
+        baseunix,unix,unixutil,\r
+      {$endif}\r
+      fd_utils,\r
+    {$endif}\r
+    classes,pgtypes,bfifo;\r
+  procedure processtasks;\r
+\r
+\r
+  const\r
+    receivebufsize=1460;\r
+\r
+  type\r
+    {$ifdef ver1_0}\r
+      sigset= array[0..31] of longint;\r
+    {$endif}\r
+\r
+    ESocketException   = class(Exception);\r
+    TBgExceptionEvent  = procedure (Sender : TObject;\r
+                                  E : Exception;\r
+                                  var CanClose : Boolean) of object;\r
+\r
+    // note : tsocketstate is defined in the same way as it is in François PIETTE's twsocket\r
+    // however tlsocket currently only uses wsClosed wsConnecting wsconnected and wsListening\r
+    TSocketState       = (wsInvalidState,\r
+                        wsOpened,     wsBound,\r
+                        wsConnecting, wsConnected,\r
+                        wsAccepting,  wsListening,\r
+                        wsClosed);\r
+\r
+    TWSocketOption       = (wsoNoReceiveLoop, wsoTcpNoDelay);\r
+    TWSocketOptions      = set of TWSocketOption;\r
+\r
+    TSocketevent     = procedure(Sender: TObject; Error: word) of object;\r
+    //Tdataavailevent  = procedure(data : string);\r
+    TSendData          = procedure (Sender: TObject; BytesSent: Integer) of object;\r
+\r
+    tlcomponent = class(tcomponent)\r
+    public\r
+      released:boolean;\r
+      procedure release; virtual;\r
+      destructor destroy; override;\r
+    end;\r
+\r
+    tlasio = class(tlcomponent)\r
+    public\r
+      state              : tsocketstate      ;\r
+      ComponentOptions   : TWSocketOptions;\r
+      fdhandlein         : Longint           ;  {file discriptor}\r
+      fdhandleout        : Longint           ;  {file discriptor}\r
+\r
+      onsessionclosed    : tsocketevent      ;\r
+      ondataAvailable    : tsocketevent      ;\r
+      onsessionAvailable : tsocketevent      ;\r
+\r
+      onsessionconnected : tsocketevent      ;\r
+      onsenddata         : tsenddata      ;\r
+      ondatasent         : tsocketevent      ;\r
+      //connected          : boolean         ;\r
+      nextasin           : tlasio            ;\r
+      prevasin           : tlasio            ;\r
+\r
+      recvq              : tfifo;\r
+      OnBgException      : TBgExceptionEvent ;\r
+      //connectread        : boolean           ;\r
+      sendq              : tfifo;\r
+      closehandles       : boolean           ;\r
+      writtenthiscycle   : boolean           ;\r
+      onfdwrite           : procedure (Sender: TObject; Error: word) of object; //added for bewarehttpd\r
+      lasterror:integer;\r
+      destroying:boolean;\r
+      function receivestr:string; virtual;\r
+      procedure close;\r
+      procedure abort;\r
+      procedure internalclose(error:word); virtual;\r
+      constructor Create(AOwner: TComponent); override;\r
+\r
+      destructor destroy; override;\r
+      procedure fdcleanup;\r
+      procedure HandleBackGroundException(E: Exception);\r
+      procedure handlefdtrigger(readtrigger,writetrigger:boolean); virtual;\r
+      procedure dup(invalue:longint);\r
+\r
+      function sendflush : integer;\r
+      procedure sendstr(const str : string);virtual;\r
+      procedure putstringinsendbuffer(const newstring : string);\r
+      function send(data:pointer;len:integer):integer;virtual;\r
+      procedure putdatainsendbuffer(data:pointer;len:integer); virtual;\r
+      procedure deletebuffereddata;\r
+\r
+      //procedure messageloop;\r
+      function Receive(Buf:Pointer;BufSize:integer):integer; virtual;\r
+      procedure flush;virtual;{$ifdef win32} abstract;{$endif}\r
+      procedure dodatasent(wparam,lparam:longint);\r
+      procedure doreceiveloop(wparam,lparam:longint);\r
+      procedure sinkdata(sender:tobject;error:word);\r
+\r
+      procedure release; override; {test -beware}\r
+\r
+      function RealSend(Data : Pointer; Len : Integer) : Integer; //added for bewarehttpd\r
+\r
+      procedure myfdclose(fd : integer); virtual;{$ifdef win32}abstract;{$endif}\r
+      function myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt; virtual;{$ifdef win32}abstract;{$endif}\r
+      function myfdread(fd: LongInt;var buf;size: LongInt):LongInt; virtual;{$ifdef win32}abstract;{$endif}\r
+    protected\r
+      procedure dupnowatch(invalue:longint);\r
+    end;\r
+    ttimerwrapperinterface=class(tlcomponent)\r
+    public\r
+      function createwrappedtimer : tobject;virtual;abstract;\r
+//      procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);virtual;abstract;\r
+      procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);virtual;abstract;\r
+      procedure setenabled(wrappedtimer : tobject;newvalue : boolean);virtual;abstract;\r
+      procedure setinterval(wrappedtimer : tobject;newvalue : integer);virtual;abstract;\r
+    end;\r
+\r
+  var\r
+    timerwrapperinterface : ttimerwrapperinterface;\r
+  type\r
+    {$ifdef win32}\r
+      ttimeval = record\r
+        tv_sec : longint;\r
+        tv_usec : longint;\r
+      end;\r
+    {$endif}\r
+    tltimer=class(tlcomponent)\r
+    protected\r
+\r
+\r
+      wrappedtimer : tobject;\r
+\r
+\r
+//      finitialevent       : boolean           ;\r
+      fontimer            : tnotifyevent      ;\r
+      fenabled            : boolean           ;\r
+      finterval                  : integer          ; {miliseconds, default 1000}\r
+      {$ifndef win32}\r
+        procedure resettimes;\r
+      {$endif}\r
+//      procedure setinitialevent(newvalue : boolean);\r
+      procedure setontimer(newvalue:tnotifyevent);\r
+      procedure setenabled(newvalue : boolean);\r
+      procedure setinterval(newvalue : integer);\r
+    public\r
+      //making theese public for now, this code should probablly be restructured later though\r
+      prevtimer          : tltimer           ;\r
+      nexttimer          : tltimer           ;\r
+      nextts            : ttimeval          ;\r
+\r
+      constructor create(aowner:tcomponent);override;\r
+      destructor destroy;override;\r
+//      property initialevent : boolean read finitialevent write setinitialevent;\r
+      property ontimer : tnotifyevent read fontimer write setontimer;\r
+      property enabled : boolean read fenabled write setenabled;\r
+      property interval        : integer read finterval write setinterval;\r
+\r
+    end;\r
+\r
+    ttaskevent=procedure(wparam,lparam:longint) of object;\r
+\r
+    tltask=class(tobject)\r
+    public\r
+      handler  : ttaskevent;\r
+      obj      : tobject;\r
+      wparam   : longint;\r
+      lparam   : longint;\r
+      nexttask : tltask;\r
+      constructor create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+    end;\r
+\r
+\r
+\r
+    teventcore=class\r
+    public\r
+      procedure processmessages; virtual;abstract;\r
+      procedure messageloop; virtual;abstract;\r
+      procedure exitmessageloop; virtual;abstract;\r
+      procedure setfdreverse(fd : integer;reverseto : tlasio);virtual;abstract;\r
+      procedure rmasterset(fd : integer;islistensocket : boolean);  virtual;abstract;\r
+      procedure rmasterclr(fd: integer);  virtual;abstract;\r
+      procedure wmasterset(fd : integer); virtual;abstract;\r
+      procedure wmasterclr(fd: integer);  virtual;abstract;\r
+    end;\r
+var\r
+    eventcore : teventcore;\r
+\r
+procedure processmessages;\r
+procedure messageloop;\r
+procedure exitmessageloop;\r
+\r
+var\r
+  firstasin                             : tlasio     ;\r
+  firsttimer                            : tltimer    ;\r
+  firsttask  , lasttask   , currenttask : tltask     ;\r
+\r
+  numread                               : integer    ;\r
+  mustrefreshfds                        : boolean    ;\r
+{  lcoretestcount:integer;}\r
+\r
+  asinreleaseflag:boolean;\r
+\r
+\r
+procedure disconnecttasks(aobj:tobject);\r
+procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+type\r
+  tonaddtask = procedure(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+var\r
+  onaddtask : tonaddtask;\r
+\r
+\r
+procedure sleep(i:integer);\r
+{$ifndef nosignal}\r
+  procedure prepsigpipe;{$ifndef ver1_0}inline;{$endif}\r
+{$endif}\r
+\r
+\r
+implementation\r
+{$ifndef nosignal}\r
+  uses {sockets,}lloopback,lsignal;\r
+{$endif}\r
+{$ifdef win32}\r
+  uses windows,winsock;\r
+{$endif}\r
+{$ifndef win32}\r
+  {$include unixstuff.inc}\r
+{$endif}\r
+{$include ltimevalstuff.inc}\r
+\r
+\r
+{!!! added sleep call -beware}\r
+procedure sleep(i:integer);\r
+var\r
+  tv:ttimeval;\r
+begin\r
+  {$ifdef win32}\r
+    windows.sleep(i);\r
+  {$else}\r
+    tv.tv_sec := i div 1000;\r
+    tv.tv_usec := (i mod 1000) * 1000;\r
+    select(0,nil,nil,nil,@tv);\r
+  {$endif}\r
+end;\r
+\r
+destructor tlcomponent.destroy;\r
+begin\r
+  disconnecttasks(self);\r
+  inherited destroy;\r
+end;\r
+\r
+\r
+\r
+\r
+procedure tlcomponent.release;\r
+begin\r
+  released := true;\r
+end;\r
+\r
+procedure tlasio.release;\r
+begin\r
+  asinreleaseflag := true;\r
+  inherited release;\r
+end;\r
+\r
+procedure tlasio.doreceiveloop;\r
+begin\r
+  if recvq.size = 0 then exit;\r
+  if assigned(ondataavailable) then ondataavailable(self,0);\r
+  if not (wsonoreceiveloop in componentoptions) then\r
+  if recvq.size > 0 then tltask.create(self.doreceiveloop,self,0,0);\r
+end;\r
+\r
+function tlasio.receivestr;\r
+begin\r
+  setlength(result,recvq.size);\r
+  receive(@result[1],length(result));\r
+end;\r
+\r
+function tlasio.receive(Buf:Pointer;BufSize:integer):integer;\r
+var\r
+  i,a,b:integer;\r
+  p:pointer;\r
+begin\r
+  i := bufsize;\r
+  if recvq.size < i then i := recvq.size;\r
+  a := 0;\r
+  while (a < i) do begin\r
+    b := recvq.get(p,i-a);\r
+    move(p^,buf^,b);\r
+    inc(taddrint(buf),b);\r
+    recvq.del(b);\r
+    inc(a,b);\r
+  end;\r
+  result := i;\r
+  if wsonoreceiveloop in componentoptions then begin\r
+    if recvq.size = 0 then eventcore.rmasterset(fdhandlein,false);\r
+  end;\r
+end;\r
+\r
+constructor tlasio.create;\r
+begin\r
+  inherited create(AOwner);\r
+  sendq := tfifo.create;\r
+  recvq := tfifo.create;\r
+  state := wsclosed;\r
+  fdhandlein := -1;\r
+  fdhandleout := -1;\r
+  nextasin := firstasin;\r
+  prevasin := nil;\r
+  if assigned(nextasin) then nextasin.prevasin := self;\r
+  firstasin := self;\r
+\r
+  released := false;\r
+end;\r
+\r
+destructor tlasio.destroy;\r
+begin\r
+  destroying := true;\r
+  if state <> wsclosed then close;\r
+  if prevasin <> nil then begin\r
+    prevasin.nextasin := nextasin;\r
+  end else begin\r
+    firstasin := nextasin;\r
+  end;\r
+  if nextasin <> nil then begin\r
+    nextasin.prevasin := prevasin;\r
+  end;\r
+  recvq.destroy;\r
+  sendq.destroy;\r
+  inherited destroy;\r
+end;\r
+\r
+procedure tlasio.close;\r
+begin\r
+  internalclose(0);\r
+end;\r
+\r
+procedure tlasio.abort;\r
+begin\r
+  close;\r
+end;\r
+\r
+procedure tlasio.fdcleanup;\r
+begin\r
+  if fdhandlein <> -1 then begin\r
+    eventcore.rmasterclr(fdhandlein); //fd_clr(fdhandlein,fdsrmaster)\r
+  end;\r
+  if fdhandleout <> -1 then begin\r
+    eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster)\r
+  end;\r
+  if fdhandlein=fdhandleout then begin\r
+    if fdhandlein <> -1 then begin\r
+      myfdclose(fdhandlein);\r
+    end;\r
+  end else begin\r
+    if fdhandlein <> -1 then begin\r
+      myfdclose(fdhandlein);\r
+    end;\r
+    if fdhandleout <> -1 then begin\r
+      myfdclose(fdhandleout);\r
+    end;\r
+  end;\r
+  fdhandlein := -1;\r
+  fdhandleout := -1;\r
+end;\r
+\r
+procedure tlasio.internalclose(error:word);\r
+begin\r
+  if state<>wsclosed then begin\r
+    if (fdhandlein < 0) or (fdhandleout < 0) then raise exception.create('internalclose called with invalid fd handles');\r
+    eventcore.rmasterclr(fdhandlein);//fd_clr(fdhandlein,fdsrmaster);\r
+    eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
+\r
+    if closehandles then begin\r
+      {$ifndef win32}\r
+        //anyone remember why this is here? --plugwash\r
+        fcntl(fdhandlein,F_SETFL,0);\r
+      {$endif}\r
+      myfdclose(fdhandlein);\r
+      if fdhandleout <> fdhandlein then begin\r
+        {$ifndef win32}\r
+          fcntl(fdhandleout,F_SETFL,0);\r
+        {$endif}\r
+        myfdclose(fdhandleout);\r
+      end;\r
+      eventcore.setfdreverse(fdhandlein,nil);\r
+      eventcore.setfdreverse(fdhandleout,nil);\r
+\r
+      fdhandlein := -1;\r
+      fdhandleout := -1;\r
+    end;\r
+    state := wsclosed;\r
+\r
+    if assigned(onsessionclosed) then if not destroying then onsessionclosed(self,error);\r
+  end;\r
+  sendq.del(maxlongint);\r
+end;\r
+\r
+\r
+{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}\r
+{ All exceptions *MUST* be handled. If an exception is not handled, the     }\r
+{ application will most likely be shut down !                               }\r
+procedure tlasio.HandleBackGroundException(E: Exception);\r
+var\r
+  CanAbort : Boolean;\r
+begin\r
+  CanAbort := TRUE;\r
+  { First call the error event handler, if any }\r
+  if Assigned(OnBgException) then begin\r
+    try\r
+      OnBgException(Self, E, CanAbort);\r
+    except\r
+    end;\r
+  end;\r
+  { Then abort the socket }\r
+  if CanAbort then begin\r
+    try\r
+      close;\r
+    except\r
+    end;\r
+  end;\r
+end;\r
+\r
+procedure tlasio.sendstr(const str : string);\r
+begin\r
+  putstringinsendbuffer(str);\r
+  sendflush;\r
+end;\r
+\r
+procedure tlasio.putstringinsendbuffer(const newstring : string);\r
+begin\r
+  if newstring <> '' then putdatainsendbuffer(@newstring[1],length(newstring));\r
+end;\r
+\r
+function tlasio.send(data:pointer;len:integer):integer;\r
+begin\r
+  if state <> wsconnected then begin\r
+    result := -1;\r
+    exit;\r
+  end;\r
+  if len < 0 then len := 0;\r
+  result := len;\r
+  putdatainsendbuffer(data,len);\r
+  sendflush;\r
+end;\r
+\r
+\r
+procedure tlasio.putdatainsendbuffer(data:pointer;len:integer);\r
+begin\r
+  sendq.add(data,len);\r
+end;\r
+\r
+function tlasio.sendflush : integer;\r
+var\r
+  lensent : integer;\r
+  data:pointer;\r
+//  fdstestr : fdset;\r
+//  fdstestw : fdset;\r
+begin\r
+  if state <> wsconnected then exit;\r
+\r
+  lensent := sendq.get(data,2920);\r
+  if assigned(data) then result := myfdwrite(fdhandleout,data^,lensent) else result := 0;\r
+\r
+  if result = -1 then lensent := 0 else lensent := result;\r
+\r
+  //sendq := copy(sendq,lensent+1,length(sendq)-lensent);\r
+  sendq.del(lensent);\r
+\r
+  //fd_clr(fdhandleout,fdsw); // this prevents the socket being closed by a write\r
+                            // that sends nothing because a previous socket has\r
+                            // slready flushed this socket when the message loop\r
+                            // reaches it\r
+//  if sendq.size > 0 then begin\r
+    eventcore.wmasterset(fdhandleout);//fd_set(fdhandleout,fdswmaster);\r
+//  end else begin\r
+//    wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
+//  end;\r
+  if result > 0 then begin\r
+    if assigned(onsenddata) then onsenddata(self,result);\r
+//    if sendq.size=0 then if assigned(ondatasent) then begin\r
+//      tltask.create(self.dodatasent,self,0,0);\r
+//      //begin test code\r
+//      fd_zero(fdstestr);\r
+//      fd_zero(fdstestw);\r
+//      fd_set(fdhandlein,fdstestr);\r
+//      fd_set(fdhandleout,fdstestw);\r
+//      select(maxs,@fdstestr,@fdstestw,nil,0);\r
+//      writeln(fd_isset(fdhandlein,fdstestr),' ',fd_isset(fdhandleout,fdstestw));\r
+//      //end test code\r
+//    \r
+//    end;\r
+    writtenthiscycle := true;\r
+  end;\r
+end;\r
+\r
+procedure tlasio.dupnowatch(invalue:longint);\r
+begin\r
+  {  debugout('invalue='+inttostr(invalue));}\r
+  //readln;\r
+  if state<> wsclosed then close;\r
+  fdhandlein := invalue;\r
+  fdhandleout := invalue;\r
+  eventcore.setfdreverse(fdhandlein,self);\r
+  {$ifndef win32}\r
+    fcntl(fdhandlein,F_SETFL,OPEN_NONBLOCK);\r
+  {$endif}\r
+  state := wsconnected;\r
+\r
+end;\r
+\r
+\r
+procedure tlasio.dup(invalue:longint);\r
+begin\r
+  dupnowatch(invalue);\r
+  eventcore.rmasterset(fdhandlein,false);//fd_set(fdhandlein,fdsrmaster);\r
+  eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
+end;\r
+\r
+\r
+procedure tlasio.handlefdtrigger(readtrigger,writetrigger:boolean);\r
+var\r
+  sendflushresult : integer;\r
+  tempbuf:array[0..receivebufsize-1] of byte;\r
+begin\r
+  if (state=wsconnected) and writetrigger then begin\r
+    //writeln('write trigger');\r
+\r
+    if (sendq.size >0) then begin\r
+\r
+      sendflushresult := sendflush;\r
+      if (sendflushresult <= 0) and (not writtenthiscycle) then begin\r
+        if sendflushresult=0 then begin // linuxerror := 0;\r
+          internalclose(0);\r
+\r
+        end else begin\r
+          internalclose({$ifdef win32}getlasterror{$else}linuxerror{$endif});\r
+        end;\r
+      end;\r
+\r
+    end else begin\r
+      //everything is sent fire off ondatasent event\r
+      if fdhandleout >= 0 then eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
+      if assigned(ondatasent) then tltask.create(self.dodatasent,self,0,0);\r
+    end;\r
+    if assigned(onfdwrite) then onfdwrite(self,0);\r
+  end;\r
+  writtenthiscycle := false;\r
+  if (state =wsconnected) and readtrigger then begin\r
+    if recvq.size=0 then begin\r
+      numread := myfdread(fdhandlein,tempbuf,sizeof(tempbuf));\r
+      if (numread=0) and (not mustrefreshfds) then begin\r
+        {if i remember correctly numread=0 is caused by eof\r
+        if this isn't dealt with then you get a cpu eating infinite loop\r
+        however if onsessionconencted has called processmessages that could\r
+        cause us to drop to here with an empty recvq and nothing left to read\r
+        and we don't want that to cause the socket to close}\r
+\r
+        internalclose(0);\r
+      end else if (numread=-1) then begin\r
+        {$ifdef win32}\r
+          //sometimes on windows we get stale messages due to the inherent delays\r
+          //in the windows message queue\r
+          if WSAGetLastError = wsaewouldblock then begin\r
+            //do nothing\r
+          end else\r
+        {$endif}\r
+        begin\r
+          numread := 0;\r
+          internalclose({$ifdef win32}wsagetlasterror{$else}linuxerror{$endif});\r
+        end;\r
+      end else if numread > 0 then recvq.add(@tempbuf,numread);\r
+    end;\r
+\r
+    if recvq.size > 0 then begin\r
+      if wsonoreceiveloop in componentoptions then eventcore.rmasterclr(fdhandlein); //fd_clr(fdhandlein,fdsrmaster);\r
+      if assigned(ondataavailable) then ondataAvailable(self,0);\r
+      if not (wsonoreceiveloop in componentoptions) then if recvq.size > 0 then\r
+      tltask.create(self.doreceiveloop,self,0,0);\r
+    end;\r
+    //until (numread = 0) or (currentsocket.state<>wsconnected);\r
+{    debugout('inner loop complete');}\r
+  end;\r
+end;\r
+\r
+{$ifndef win32}\r
+  procedure tlasio.flush;\r
+  var\r
+    fds : fdset;\r
+  begin\r
+    fd_zero(fds);\r
+    fd_set(fdhandleout,fds);\r
+    while sendq.size>0 do begin\r
+      select(fdhandleout+1,nil,@fds,nil,nil);\r
+      if sendflush <= 0 then exit;\r
+    end;\r
+  end;\r
+{$endif}\r
+\r
+procedure tlasio.dodatasent(wparam,lparam:longint);\r
+begin\r
+  if assigned(ondatasent) then ondatasent(self,lparam);\r
+end;\r
+\r
+procedure tlasio.deletebuffereddata;\r
+begin\r
+  sendq.del(maxlongint);\r
+end;\r
+\r
+procedure tlasio.sinkdata(sender:tobject;error:word);\r
+begin\r
+  tlasio(sender).recvq.del(maxlongint);\r
+end;\r
+\r
+{$ifndef win32}\r
+  procedure tltimer.resettimes;\r
+  begin\r
+    gettimeofday(nextts);\r
+    {if not initialevent then} tv_add(nextts,interval);\r
+  end;\r
+{$endif}\r
+\r
+{procedure tltimer.setinitialevent(newvalue : boolean);\r
+begin\r
+  if newvalue <> finitialevent then begin\r
+    finitialevent := newvalue;\r
+    if assigned(timerwrapperinterface) then begin\r
+      timerwrapperinterface.setinitialevent(wrappedtimer,newvalue);\r
+    end else begin\r
+      resettimes;\r
+    end;\r
+  end;\r
+end;}\r
+\r
+procedure tltimer.setontimer(newvalue:tnotifyevent);\r
+begin\r
+  if @newvalue <> @fontimer then begin\r
+    fontimer := newvalue;\r
+    if assigned(timerwrapperinterface) then begin\r
+      timerwrapperinterface.setontimer(wrappedtimer,newvalue);\r
+    end else begin\r
+\r
+    end;\r
+  end;\r
+\r
+end;\r
+\r
+\r
+procedure tltimer.setenabled(newvalue : boolean);\r
+begin\r
+  if newvalue <> fenabled then begin\r
+    fenabled := newvalue;\r
+    if assigned(timerwrapperinterface) then begin\r
+      timerwrapperinterface.setenabled(wrappedtimer,newvalue);\r
+    end else begin\r
+      {$ifdef win32}\r
+        raise exception.create('non wrapper timers are not permitted on windows');\r
+      {$else}\r
+        resettimes;\r
+      {$endif}\r
+    end;\r
+  end;\r
+end;\r
+\r
+procedure tltimer.setinterval(newvalue:integer);\r
+begin\r
+  if newvalue <> finterval then begin\r
+    finterval := newvalue;\r
+    if assigned(timerwrapperinterface) then begin\r
+      timerwrapperinterface.setinterval(wrappedtimer,newvalue);\r
+    end else begin\r
+      {$ifdef win32}\r
+        raise exception.create('non wrapper timers are not permitted on windows');\r
+      {$else}\r
+        resettimes;\r
+      {$endif}\r
+    end;\r
+  end;\r
+\r
+end;\r
+\r
+\r
+\r
+\r
+constructor tltimer.create;\r
+begin\r
+  inherited create(AOwner);\r
+  if assigned(timerwrapperinterface) then begin\r
+    wrappedtimer := timerwrapperinterface.createwrappedtimer;\r
+  end else begin\r
+\r
+\r
+    nexttimer := firsttimer;\r
+    prevtimer := nil;\r
+\r
+    if assigned(nexttimer) then nexttimer.prevtimer := self;\r
+    firsttimer := self;\r
+  end;\r
+  interval := 1000;\r
+  enabled := true;\r
+  released := false;\r
+\r
+end;\r
+\r
+destructor tltimer.destroy;\r
+begin\r
+  if assigned(timerwrapperinterface) then begin\r
+    wrappedtimer.free;\r
+  end else begin\r
+    if prevtimer <> nil then begin\r
+      prevtimer.nexttimer := nexttimer;\r
+    end else begin\r
+      firsttimer := nexttimer;\r
+    end;\r
+    if nexttimer <> nil then begin\r
+      nexttimer.prevtimer := prevtimer;\r
+    end;\r
+    \r
+  end;\r
+  inherited destroy;\r
+end;\r
+\r
+constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+  inherited create;\r
+  if assigned(onaddtask) then onaddtask(ahandler,aobj,awparam,alparam);\r
+  handler   := ahandler;\r
+  obj       := aobj;\r
+  wparam    := awparam;\r
+  lparam    := alparam;\r
+  {nexttask  := firsttask;\r
+  firsttask := self;}\r
+  if assigned(lasttask) then begin\r
+    lasttask.nexttask := self;\r
+  end else begin\r
+    firsttask := self;\r
+  end;\r
+  lasttask := self;\r
+  //ahandler(wparam,lparam);\r
+end;\r
+\r
+procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+\r
+  tltask.create(ahandler,aobj,awparam,alparam);\r
+end;\r
+\r
+{$ifndef nosignal}\r
+  procedure prepsigpipe;{$ifndef ver1_0}inline;\r
+{$endif}\r
+  begin\r
+    starthandlesignal(sigpipe);\r
+    if not assigned(signalloopback) then begin\r
+      signalloopback := tlloopback.create(nil);\r
+      signalloopback.ondataAvailable := signalloopback.sinkdata;\r
+\r
+    end;\r
+\r
+  end;\r
+{$endif}\r
+\r
+procedure processtasks;//inline;\r
+var\r
+  temptask                : tltask   ;\r
+\r
+begin\r
+\r
+  if not assigned(currenttask) then begin\r
+    currenttask := firsttask;\r
+    firsttask := nil;\r
+    lasttask  := nil;\r
+  end;\r
+  while assigned(currenttask) do begin\r
+\r
+    if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam);\r
+    if assigned(currenttask) then begin\r
+      temptask := currenttask;\r
+      currenttask := currenttask.nexttask;\r
+      temptask.free;\r
+    end;\r
+    //writeln('processed a task');\r
+  end;\r
+\r
+end;\r
+\r
+\r
+\r
+\r
+procedure disconnecttasks(aobj:tobject);\r
+var\r
+  currenttasklocal : tltask ;\r
+  counter          : byte   ;\r
+begin\r
+  for counter := 0 to 1 do begin\r
+    if counter = 0 then begin\r
+      currenttasklocal := firsttask; //main list of tasks\r
+    end else begin\r
+      currenttasklocal := currenttask; //needed in case called from a task\r
+    end;\r
+    // note i don't bother to sestroy the links here as that will happen when\r
+    // the list of tasks is processed anyway\r
+    while assigned(currenttasklocal) do begin\r
+      if currenttasklocal.obj = aobj then begin\r
+        currenttasklocal.obj := nil;\r
+        currenttasklocal.handler := nil;\r
+      end;\r
+      currenttasklocal := currenttasklocal.nexttask;\r
+    end;\r
+  end;\r
+end;\r
+\r
+\r
+procedure processmessages;\r
+begin\r
+  eventcore.processmessages;\r
+end;\r
+procedure messageloop;\r
+begin\r
+  eventcore.messageloop;\r
+end;\r
+\r
+procedure exitmessageloop;\r
+begin\r
+  eventcore.exitmessageloop;\r
+end;\r
+\r
+function tlasio.RealSend(Data : Pointer; Len : Integer) : Integer;\r
+begin\r
+  result := myfdwrite(fdhandleout,data^,len);\r
+  if (result > 0) and assigned(onsenddata) then onsenddata(self,result);\r
+  eventcore.wmasterset(fdhandleout);\r
+end;\r
+{$ifndef win32}\r
+  procedure tlasio.myfdclose(fd : integer);\r
+  begin\r
+    fdclose(fd);\r
+  end;\r
+  function tlasio.myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt;\r
+  begin\r
+    result := fdwrite(fd,buf,size);\r
+  end;\r
+\r
+  function tlasio.myfdread(fd: LongInt;var buf;size: LongInt):LongInt;\r
+  begin\r
+    result := fdread(fd,buf,size);\r
+  end;\r
+\r
+\r
+{$endif}\r
+\r
+\r
+begin\r
+  firstasin := nil;\r
+  firsttask := nil;\r
+  \r
+\r
+  {$ifndef nosignal}\r
+    signalloopback := nil;\r
+  {$endif}\r
+end.\r
+\r
+\r
+\r
+\r
+\r

diff --git a/lcoregtklaz.pas b/lcoregtklaz.pas
new file mode 100755 (executable)
index 0000000..bbf4418
--- /dev/null
+++ b/lcoregtklaz.pas
@@ -0,0 +1,142 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green
+  For conditions of distribution and use, see copyright notice in zlib_license.txt
+  which is included in the package
+  ----------------------------------------------------------------------------- }
+      \r
+unit lcoregtklaz;\r
+{$mode delphi}\r
+interface\r
+       \r
+uses baseunix,unix,glib, gdk, gtk,lcore,forms,fd_utils,classes;\r
+//procedure lcoregtklazrun;\r
+const\r
+  G_IO_IN=1;\r
+  G_IO_OUT=4;\r
+  G_IO_PRI=2;\r
+  G_IO_ERR=8;\r
+\r
+  G_IO_HUP=16;\r
+  G_IO_NVAL=32;\r
+type\r
+  tlaztimerwrapperinterface=class(ttimerwrapperinterface)\r
+  public\r
+    function createwrappedtimer : tobject;override;\r
+//    procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);override;\r
+    procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);override;\r
+    procedure setenabled(wrappedtimer : tobject;newvalue : boolean);override;\r
+    procedure setinterval(wrappedtimer : tobject;newvalue : integer);override;\r
+  end;\r
+\r
+procedure lcoregtklazinit;\r
+implementation\r
+  uses\r
+    ExtCtrls;\r
+{$I unixstuff.inc}\r
+var\r
+  giochannels : array[0..absoloutemaxs] of pgiochannel;\r
+\r
+function iocallback(source:PGIOChannel; condition:TGIOCondition; data:gpointer):gboolean;cdecl;\r
+// return true if we want the callback to stay\r
+var\r
+  fd                    : integer ;\r
+  fdsrlocal , fdswlocal : fdset   ;\r
+  currentasio           : tlasio  ;\r
+begin\r
+  fd := g_io_channel_unix_get_fd(source);\r
+  fd_zero(fdsrlocal);\r
+  fd_set(fd,fdsrlocal);\r
+  fdswlocal := fdsrlocal;\r
+  select(fd+1,@fdsrlocal,@fdswlocal,nil,0);\r
+  if fd_isset(fd,fdsrlocal) or fd_isset(fd,fdsrlocal) then begin\r
+    currentasio := fdreverse[fd];\r
+    if assigned(currentasio) then begin\r
+      currentasio.handlefdtrigger(fd_isset(currentasio.fdhandlein,fdsrlocal),fd_isset(currentasio.fdhandleout,fdswlocal));\r
+    end else begin\r
+      rmasterclr(fd);\r
+      wmasterclr(fd);\r
+    end;\r
+  end;\r
+  case condition of\r
+    G_IO_IN : begin\r
+      result := rmasterisset(fd);\r
+    end;\r
+    G_IO_OUT : begin\r
+      result := wmasterisset(fd);\r
+    end;\r
+  end;\r
+end;\r
+\r
+procedure gtkrmasterset(fd : integer);\r
+begin\r
+  if not assigned(giochannels[fd]) then giochannels[fd] := g_io_channel_unix_new(fd);\r
+  g_io_add_watch(giochannels[fd],G_IO_IN,iocallback,nil);\r
+end;\r
+\r
+procedure gtkrmasterclr(fd: integer);\r
+begin\r
+end;\r
+  \r
+procedure gtkwmasterset(fd : integer);\r
+begin\r
+  if not assigned(giochannels[fd]) then giochannels[fd] := g_io_channel_unix_new(fd);\r
+  g_io_add_watch(giochannels[fd],G_IO_OUT,iocallback,nil);\r
+end;\r
+\r
+procedure gtkwmasterclr(fd: integer);\r
+begin\r
+end;\r
+\r
+type\r
+  tsc = class\r
+    procedure dotasksandsink(sender:tobject;error:word);\r
+  end;\r
+var\r
+  taskloopback : tlloopback;\r
+  sc           : tsc;\r
+procedure tsc.dotasksandsink(sender:tobject;error:word);\r
+begin\r
+  with tlasio(sender) do begin\r
+    sinkdata(sender,error);\r
+    processtasks;\r
+  end;\r
+end;\r
+procedure gtkaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+  taskloopback.sendstr(' ');\r
+  \r
+end;\r
+\r
+procedure lcoregtklazinit;\r
+begin\r
+  onrmasterset := gtkrmasterset;\r
+  onrmasterclr := gtkrmasterclr;\r
+  onwmasterset := gtkwmasterset;\r
+  onwmasterclr := gtkwmasterclr;\r
+  onaddtask := gtkaddtask;\r
+  taskloopback := tlloopback.create(nil);\r
+  taskloopback.ondataavailable := sc.dotasksandsink;\r
+  timerwrapperinterface := tlaztimerwrapperinterface.create(nil);\r
+end;\r
+\r
+function tlaztimerwrapperinterface.createwrappedtimer : tobject;\r
+begin\r
+  result := ttimer.create(nil);\r
+end;\r
+procedure tlaztimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);\r
+begin\r
+  ttimer(wrappedtimer).ontimer := newvalue;\r
+end;\r
+procedure tlaztimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean);\r
+begin\r
+  ttimer(wrappedtimer).enabled := newvalue;\r
+end;\r
+\r
+\r
+procedure tlaztimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer);\r
+begin\r
+  ttimer(wrappedtimer).interval := newvalue;\r
+end;\r
+\r
+\r
+end.\r
+\r

diff --git a/lcoreselect.pas b/lcoreselect.pas
new file mode 100755 (executable)
index 0000000..e0351eb
--- /dev/null
+++ b/lcoreselect.pas
@@ -0,0 +1,399 @@
+{lsocket.pas}\r
+\r
+{io and timer code by plugwash}\r
+\r
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+
+{$ifdef fpc}                                                                    
+  {$ifndef ver1_0}                                                              
+    {$define useinline}                                                         
+  {$endif}                                                                      
+{$endif}  \r
+\r
+unit lcoreselect;\r
+\r
+\r
+interface\r
+uses\r
+  {$ifdef VER1_0}\r
+    linux,\r
+  {$else}\r
+    baseunix,unix,unixutil,\r
+  {$endif}\r
+  fd_utils;\r
+var\r
+  maxs                                  : longint    ;\r
+  exitloopflag                          : boolean    ; {if set by app, exit mainloop}\r
+\r
+function getfdsrmaster : fdset; {$ifdef useinline}inline;{$endif}\r
+function getfdswmaster : fdset; {$ifdef useinline}inline;{$endif}\r
+\r
+implementation\r
+uses\r
+  lcore,sysutils,\r
+  classes,pgtypes,bfifo,\r
+  {$ifndef nosignal}\r
+    lsignal;\r
+  {$endif}\r
+\r
+{$include unixstuff.inc}\r
+{$include ltimevalstuff.inc}\r
+var\r
+  fdreverse:array[0..absoloutemaxs] of tlasio;\r
+type\r
+  tselecteventcore=class(teventcore)\r
+    public\r
+      procedure processmessages; override;\r
+      procedure messageloop; override;\r
+      procedure exitmessageloop;override;\r
+      procedure setfdreverse(fd : integer;reverseto : tlasio); override;\r
+      procedure rmasterset(fd : integer;islistensocket : boolean); override;\r
+      procedure rmasterclr(fd: integer); override;\r
+      procedure wmasterset(fd : integer); override;\r
+      procedure wmasterclr(fd: integer); override;\r
+    end;\r
+\r
+procedure processtimers;inline;\r
+var\r
+  tv           ,tvnow     : ttimeval ;\r
+  currenttimer            : tltimer   ;\r
+  temptimer               : tltimer  ;\r
+\r
+begin\r
+  gettimeofday(tvnow);\r
+  currenttimer := firsttimer;\r
+  while assigned(currenttimer) do begin\r
+    //writeln(currenttimer.enabled);\r
+    if tv_compare(tvnow,ttimeval(currenttimer.nextts)) and currenttimer.enabled then begin\r
+      //if assigned(currenttimer.ontimer) then begin\r
+      //  if currenttimer.enabled then if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer);\r
+      //  currenttimer.initialdone := true;\r
+      //end;\r
+      if assigned(currenttimer.ontimer) then currenttimer.ontimer(currenttimer);\r
+      currenttimer.nextts := timeval(tvnow);\r
+      tv_add(ttimeval(currenttimer.nextts),currenttimer.interval);\r
+    end;\r
+    temptimer := currenttimer;\r
+    currenttimer := currenttimer.nexttimer;\r
+    if temptimer.released then temptimer.free;\r
+  end;\r
+end;\r
+\r
+procedure processasios(var fdsr,fdsw:fdset);//inline;\r
+var\r
+  currentsocket : tlasio  ;\r
+  tempsocket    : tlasio  ;\r
+  socketcount   : integer ; // for debugging perposes :)\r
+  dw,bt:integer;\r
+begin\r
+{  inc(lcoretestcount);}\r
+\r
+    //the message loop will exit if all lasio's and ltimer's and lsignal's are destroyed\r
+    //if (not assigned(firstasin)) and (not assigned(firsttimer)) and (not assigned(firstsignal)) then exit;\r
+\r
+\r
+  {------- test optimised loop}\r
+  socketcount := 0;\r
+  for dw := (maxs shr 5) downto 0 do if (fdsr[dw] or fdsw[dw]) <> 0 then begin\r
+    for bt := 0 to 31 do if (fdsr[dw] or fdsw[dw]) and (1 shl bt) <> 0 then begin\r
+      inc(socketcount);\r
+      currentsocket := fdreverse[dw shl 5 or bt];\r
+      {if not assigned(currentsocket) then raise exception.create('currentsocket not assigned');\r
+      if currentsocket.fdhandlein < 0 then raise exception.create('currentsocket.fdhandlein out of range');}\r
+      {i've seen the out of range case actually happening, so it can happen. test: just close the fd - beware}\r
+      if not assigned(currentsocket) then begin\r
+        fdclose(dw shl 5 or bt);\r
+        continue\r
+      end;\r
+      if currentsocket.fdhandlein < 0 then begin\r
+        fdclose(dw shl 5 or bt);\r
+        continue\r
+      end;\r
+      try\r
+        currentsocket.handlefdtrigger(fd_isset(currentsocket.fdhandlein,fdsr),fd_isset(currentsocket.fdhandleout,fdsw));\r
+      except\r
+        on E: exception do begin\r
+          currentsocket.HandleBackGroundException(e);\r
+        end;\r
+      end;\r
+\r
+      if mustrefreshfds then begin\r
+        if select(maxs+1,@fdsr,@fdsw,nil,0) <= 0 then begin\r
+          fd_zero(fdsr);\r
+          fd_zero(fdsw);\r
+        end;\r
+      end;\r
+    end;\r
+  end;\r
+\r
+  if asinreleaseflag then begin\r
+    asinreleaseflag := false;\r
+    currentsocket := firstasin;\r
+    while assigned(currentsocket) do begin\r
+      tempsocket := currentsocket;\r
+      currentsocket := currentsocket.nextasin;\r
+      if tempsocket.released then begin\r
+        tempsocket.free;\r
+      end;\r
+    end;\r
+  end;\r
+  {\r
+  !!! issues:\r
+  - sockets which are released may not be freed because theyre never processed by the loop\r
+  made new code for handling this, using asinreleaseflag\r
+\r
+  - when/why does the mustrefreshfds select apply, sheck if i did it correctly?\r
+\r
+  - what happens if calling handlefdtrigger for a socket which does not have an event\r
+  }\r
+  {------- original loop}\r
+\r
+  (*\r
+  currentsocket := firstasin;\r
+  socketcount := 0;\r
+  while assigned(currentsocket) do begin\r
+    if mustrefreshfds then begin\r
+      if select(maxs,@fdsr,@fdsw,nil,0) <= 0 then begin\r
+        fd_zero(fdsr);\r
+        fd_zero(fdsw);\r
+      end;\r
+    end;\r
+    try\r
+      if fd_isset(currentsocket.fdhandlein,fdsr) or fd_isset(currentsocket.fdhandleout,fdsw) then begin\r
+        currentsocket.handlefdtrigger(fd_isset(currentsocket.fdhandlein,fdsr),fd_isset(currentsocket.fdhandleout,fdsw));\r
+      end;\r
+    except\r
+      on E: exception do begin\r
+        currentsocket.HandleBackGroundException(e);\r
+      end;\r
+    end;\r
+    tempsocket := currentsocket;\r
+    currentsocket := currentsocket.nextasin;\r
+    inc(socketcount);\r
+    if tempsocket.released then begin\r
+      tempsocket.free;\r
+    end;\r
+  end; *)\r
+{  debugout('socketcount='+inttostr(socketcount));}\r
+end;\r
+\r
+procedure tselecteventcore.processmessages;\r
+var\r
+  fdsr         , fdsw : fdset   ;\r
+  selectresult        : longint ;\r
+begin\r
+  mustrefreshfds := false;\r
+  {$ifndef nosignal}\r
+    prepsigpipe;\r
+  {$endif}\r
+  selectresult := select(maxs+1,@fdsr,@fdsw,nil,0);\r
+  while (selectresult>0) or assigned(firsttask) or assigned(currenttask) do begin;\r
+\r
+    processtasks;\r
+    processtimers;\r
+    if selectresult > 0 then begin\r
+      processasios(fdsr,fdsw);\r
+    end;\r
+    selectresult := select(maxs+1,@fdsr,@fdsw,nil,0);\r
+\r
+  end;\r
+  mustrefreshfds := true;\r
+end;\r
+\r
+\r
+var\r
+  FDSR , FDSW : fdset;\r
+\r
+var\r
+  fdsrmaster , fdswmaster               : fdset      ;\r
+
+function getfdsrmaster : fdset; {$ifdef fpc}inline;{$endif}\r
+begin\r
+  result := fdsrmaster;\r
+end;\r
+function getfdswmaster : fdset; {$ifdef fpc}inline;{$endif}\r
+begin\r
+  result := fdswmaster;\r
+end;\r
+
+
+Function  doSelect(timeOut:PTimeVal):longint;//inline;\r
+var\r
+  localtimeval : ttimeval;\r
+  maxslocal    : integer;\r
+begin\r
+  //unblock signals\r
+  //zeromemory(@sset,sizeof(sset));\r
+  //sset[0] := ;\r
+  fdsr := getfdsrmaster;\r
+  fdsw := getfdswmaster;\r
+\r
+  if assigned(firsttask) then begin\r
+    localtimeval.tv_sec  := 0;\r
+    localtimeval.tv_usec := 0;\r
+    timeout := @localtimeval;\r
+  end;\r
+\r
+  maxslocal := maxs;\r
+  mustrefreshfds := false;\r
+{  debugout('about to call select');}\r
+  {$ifndef nosignal}\r
+    sigprocmask(SIG_UNBLOCK,@blockset,nil);\r
+  {$endif}\r
+  result := select(maxslocal+1,@FDSR,@FDSW,nil,timeout);\r
+  if result <= 0 then begin\r
+    fd_zero(FDSR);\r
+    fd_zero(FDSW);\r
+    if result=-1 then begin\r
+      if linuxerror = SYS_EINTR then begin\r
+        // we received a signal it's not a problem\r
+      end else begin\r
+        raise esocketexception.create('select returned error '+inttostr(linuxerror));\r
+      end;\r
+    end;\r
+  end;\r
+  {$ifndef nosignal}\r
+    sigprocmask(SIG_BLOCK,@blockset,nil);\r
+  {$endif}\r
+{  debugout('select complete');}\r
+end;\r
+\r
+procedure tselecteventcore.exitmessageloop;\r
+begin\r
+  exitloopflag := true\r
+end;\r
+\r
+\r
+\r
+procedure tselecteventcore.messageloop;\r
+var\r
+  tv           ,tvnow     : ttimeval ;\r
+  currenttimer            : tltimer  ;\r
+  selectresult:integer;\r
+begin\r
+  {$ifndef nosignal}\r
+    prepsigpipe;\r
+  {$endif}\r
+  {currentsocket := firstasin;\r
+  if not assigned(currentsocket) then exit; //the message loop will exit if all lsockets are destroyed\r
+  repeat\r
+\r
+    if currentsocket.state = wsconnected then currentsocket.sendflush;\r
+    currentsocket := currentsocket.nextasin;\r
+  until not assigned(currentsocket);}\r
+\r
+\r
+  repeat\r
+\r
+    //the message loop will exit if all lasio's and ltimer's and lsignal's are destroyed\r
+    if (not assigned(firstasin)) and (not assigned(firsttimer)) {$ifndef nosignal} and (not assigned(firstsignal)){$endif} then exit;\r
+    {fd_zero(FDSR);\r
+    fd_zero(FDSW);\r
+    currentsocket := firstasin;\r
+    if not assigned(currentsocket) then exit; //the message loop will exit if all lsockets are destroyed\r
+\r
+    repeat\r
+      if (not currentsocket.released) and (currentsocket.state<>wsclosed) then fd_set(currentsocket.fdhandlein,fdsr);\r
+      if (not currentsocket.released) and (currentsocket.state=wsconnecting) then fd_set(currentsocket.fdhandleout,fdsw);\r
+      if currentsocket is tlsocket then begin\r
+         if (not currentsocket.released) and (currentsocket.state=wsconnected) and(tlsocket(currentsocket).sendq <> '') then fd_set(currentsocket.fdhandleout,fdsw);\r
+      end;\r
+      tempsocket := currentsocket;\r
+      currentsocket := currentsocket.nextasin;\r
+      if tempsocket.released then begin\r
+        tempsocket.free;\r
+      end;\r
+    until not assigned(currentsocket);\r
+    }\r
+    processtasks;\r
+    //currenttask := nil;\r
+    {beware}\r
+    //if assigned(firsttimer) then begin\r
+    //  tv.tv_sec := maxlongint;\r
+    tv := tv_invalidtimebig;\r
+    currenttimer := firsttimer;\r
+    while assigned(currenttimer) do begin\r
+      if tv_compare(tv,currenttimer.nextts) and currenttimer.enabled then tv := currenttimer.nextts;\r
+      currenttimer := currenttimer.nexttimer;\r
+    end;\r
+\r
+\r
+    if tv_compare(tv,tv_invalidtimebig) then begin    \r
+      //writeln('no timers active');\r
+      if exitloopflag then break;\r
+{    sleep(10);}\r
+      selectresult := doselect(nil);\r
+\r
+    end else begin\r
+      gettimeofday(tvnow);\r
+      tv_substract(tv,tvnow);\r
+\r
+      //writeln('timers active');\r
+      if tv.tv_sec < 0 then begin\r
+        tv.tv_sec := 0;\r
+        tv.tv_usec := 0; {0.1 sec}\r
+      end;\r
+      if exitloopflag then break;\r
+{    sleep(10);}\r
+      selectresult := doselect(@tv);\r
+      processtimers;\r
+\r
+    end;\r
+    if selectresult > 0 then processasios(fdsr,fdsw);\r
+    {!!!only call processasios if select has asio events -beware}\r
+\r
+    {artificial delay to throttle the number of processasios per second possible and reduce cpu usage}\r
+  until false;\r
+end;\r
+\r
+\r
+procedure tselecteventcore.rmasterset(fd : integer;islistensocket : boolean);\r
+begin\r
+  if fd > absoloutemaxs then raise esocketexception.create('file discriptor out of range');\r
+  if fd > maxs then maxs := fd;\r
+  if fd_isset(fd,fdsrmaster) then exit;\r
+  fd_set(fd,fdsrmaster);\r
+\r
+end;\r
+\r
+procedure tselecteventcore.rmasterclr(fd: integer);\r
+begin\r
+  if not fd_isset(fd,fdsrmaster) then exit;\r
+  fd_clr(fd,fdsrmaster);\r
+\r
+end;\r
+\r
+\r
+procedure tselecteventcore.wmasterset(fd : integer);\r
+begin\r
+  if fd > absoloutemaxs then raise esocketexception.create('file discriptor out of range');\r
+  if fd > maxs then maxs := fd;\r
+\r
+  if fd_isset(fd,fdswmaster) then exit;\r
+  fd_set(fd,fdswmaster);\r
+\r
+end;\r
+\r
+procedure tselecteventcore.wmasterclr(fd: integer);\r
+begin\r
+  if not fd_isset(fd,fdswmaster) then exit;\r
+  fd_clr(fd,fdswmaster);\r
+end;\r
+\r
+procedure tselecteventcore.setfdreverse(fd : integer;reverseto : tlasio);\r
+begin\r
+  fdreverse[fd] := reverseto;\r
+end;\r
+\r
+\r
+\r
+begin\r
+  eventcore := tselecteventcore.create;\r
+\r
+  maxs := 0;\r
+  fd_zero(fdsrmaster);\r
+  fd_zero(fdswmaster);\r
+end.\r

diff --git a/lcoretest.dof b/lcoretest.dof
new file mode 100755 (executable)
index 0000000..097f5c8
--- /dev/null
+++ b/lcoretest.dof
@@ -0,0 +1,75 @@
+[Compiler]\r
+A=1\r
+B=0\r
+C=1\r
+D=1\r
+E=0\r
+F=0\r
+G=1\r
+H=1\r
+I=1\r
+J=1\r
+K=0\r
+L=1\r
+M=0\r
+N=1\r
+O=1\r
+P=1\r
+Q=0\r
+R=0\r
+S=0\r
+T=0\r
+U=0\r
+V=1\r
+W=0\r
+X=1\r
+Y=0\r
+Z=1\r
+ShowHints=1\r
+ShowWarnings=1\r
+UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;\r
+[Linker]\r
+MapFile=0\r
+OutputObjs=0\r
+ConsoleApp=0\r
+DebugInfo=0\r
+MinStackSize=16384\r
+MaxStackSize=1048576\r
+ImageBase=4194304\r
+ExeDescription=\r
+[Directories]\r
+OutputDir=\r
+UnitOutputDir=\r
+SearchPath=\r
+Packages=vclx30;VCL30;vcldb30;vcldbx30;VclSmp30;Qrpt30;teeui30;teedb30;tee30;IBEVNT30\r
+Conditionals=ipv6\r
+DebugSourceDirs=\r
+UsePackages=0\r
+[Parameters]\r
+RunParams=\r
+HostApplication=\r
+[Version Info]\r
+IncludeVerInfo=0\r
+AutoIncBuild=0\r
+MajorVer=1\r
+MinorVer=0\r
+Release=0\r
+Build=0\r
+Debug=0\r
+PreRelease=0\r
+Special=0\r
+Private=0\r
+DLL=0\r
+Locale=2057\r
+CodePage=1252\r
+[Version Info Keys]\r
+CompanyName=\r
+FileDescription=\r
+FileVersion=1.0.0.0\r
+InternalName=\r
+LegalCopyright=\r
+LegalTrademarks=\r
+OriginalFilename=\r
+ProductName=\r
+ProductVersion=1.0.0.0\r
+Comments=\r

diff --git a/lcoretest.dpr b/lcoretest.dpr
new file mode 100755 (executable)
index 0000000..f6fe72b
--- /dev/null
+++ b/lcoretest.dpr
@@ -0,0 +1,181 @@
+program lcoretest;\r
+\r
+uses\r
+  lcore,\r
+  lsocket,\r
+  {$ifdef win32}\r
+    lcorewsaasyncselect in 'lcorewsaasyncselect.pas',\r
+  {$else}\r
+    lcoreselect,\r
+  {$endif}\r
+  dnsasync,\r
+  binipstuff,\r
+  sysutils,\r
+  dnssync;\r
+{$ifdef win32}\r
+  {$R *.RES}\r
+{$endif}\r
+\r
+type\r
+  tsc=class\r
+    procedure sessionavailable(sender: tobject;error : word);\r
+    procedure dataavailable(sender: tobject;error : word);\r
+    procedure sessionconnected(sender: tobject;error : word);\r
+    procedure taskrun(wparam,lparam:longint);\r
+    procedure timehandler(sender:tobject);\r
+    procedure dnsrequestdone(sender:tobject;error : word);\r
+    procedure sessionclosed(sender:tobject;error : word);\r
+  end;\r
+var\r
+  listensocket : tlsocket;\r
+  serversocket : tlsocket;\r
+  clientsocket : tlsocket;\r
+  sc : tsc;\r
+  task : tltask;\r
+procedure tsc.sessionavailable(sender: tobject;error : word);\r
+begin\r
+  writeln('received connection');\r
+  serversocket.dup(listensocket.accept);\r
+end;\r
+\r
+var\r
+  receivebuf : string;\r
+  receivecount : integer;\r
+procedure tsc.dataavailable(sender: tobject;error : word);\r
+var\r
+  receiveddata : string;\r
+  receivedon : string;\r
+  line : string;\r
+begin\r
+  receiveddata := tlsocket(sender).receivestr;\r
+  if sender=clientsocket then begin\r
+    receivedon := 'client socket';\r
+  end else begin\r
+    receivedon := 'server socket';\r
+  end;\r
+  writeln('received data '+receiveddata+' on '+receivedon);\r
+\r
+  receivebuf := receivebuf+receiveddata;\r
+\r
+  if receivebuf = 'hello world' then begin\r
+    receivebuf := '';\r
+    writeln('received hello world creating task');\r
+    task := tltask.create(sc.taskrun,nil,0,0);\r
+  end;\r
+  receivecount := receivecount +1;\r
+  if receivecount >50 then begin\r
+    writeln('received over 50 bits of data, pausing to let the operator take a look');\r
+    readln;\r
+    receivecount := 0;\r
+  end;\r
+  while pos(#10,receivebuf) > 0 do begin\r
+    line := receivebuf;\r
+    setlength(line,pos(#10,receivebuf)-1);\r
+    receivebuf := copy(receivebuf,pos(#10,receivebuf)+1,1000000);\r
+    if uppercase(copy(line,1,4))='PING' then begin\r
+      line[2] := 'o';\r
+      writeln('send pong:'+line);\r
+      clientsocket.sendstr(line+#10);\r
+    end;\r
+  end;\r
+end;\r
+\r
+procedure tsc.sessionconnected(sender: tobject;error : word);\r
+begin\r
+  if error=0 then begin\r
+    writeln('session is connected, local address is'+clientsocket.getxaddr);\r
+\r
+    if (clientsocket.addr = '127.0.0.1') or (clientsocket.addr = '::1') then begin\r
+      clientsocket.sendstr('hello world');\r
+    end else begin\r
+      clientsocket.sendstr('nick test'#13#10'user x x x x'#13#10);\r
+    end;\r
+  end else begin\r
+    writeln('connect failed');\r
+  end;\r
+end;\r
+\r
+var\r
+  das : tdnsasync;\r
+\r
+procedure tsc.taskrun(wparam,lparam:longint);\r
+var\r
+  tempbinip : tbinip;\r
+  dummy : integer;\r
+begin\r
+  writeln('task ran');\r
+  writeln('closing client socket');\r
+  clientsocket.close;\r
+\r
+  writeln('looking up irc.ipv6.p10link.net using dnsasync');\r
+  das := tdnsasync.Create(nil);\r
+  das.onrequestdone := sc.dnsrequestdone;\r
+  //das.forwardfamily := af_inet6;\r
+  das.forwardlookup('irc.ipv6.p10link.net');\r
+end;\r
+\r
+procedure tsc.dnsrequestdone(sender:tobject;error : word);\r
+begin\r
+  writeln('irc.ipv6.p10link.net resolved to '+das.dnsresult+' connecting client socket there');\r
+  clientsocket.addr := das.dnsresult;\r
+  clientsocket.port := '6667';\r
+  clientsocket.connect;\r
+  writeln(clientsocket.getxaddr);\r
+  das.free;\r
+end;\r
+\r
+procedure tsc.timehandler(sender:tobject);\r
+begin\r
+  //writeln('got timer event');\r
+end;\r
+procedure tsc.sessionclosed(sender:tobject;error : word);\r
+begin\r
+  Writeln('session closed with error ',error);\r
+end;\r
+var\r
+  timer : tltimer;\r
+  ipbin : tbinip;\r
+  dummy : integer;\r
+begin\r
+  ipbin := forwardlookup('invalid.domain',5);\r
+  writeln(ipbintostr(ipbin));\r
+\r
+  ipbin := forwardlookup('p10link.net',5);\r
+  writeln(ipbintostr(ipbin));\r
+\r
+  ipstrtobin('80.68.89.68',ipbin);\r
+  writeln('80.68.89.68 reverses to '+reverselookup(ipbin,5));\r
+\r
+  ipstrtobin('2001:200::8002:203:47ff:fea5:3085',ipbin);\r
+  writeln('2001:200::8002:203:47ff:fea5:3085 reverses to '+reverselookup(ipbin,5));\r
+  writeln('creating and setting up listen socket');\r
+  listensocket := tlsocket.create(nil);\r
+  listensocket.addr := '::';\r
+  listensocket.port := '12345';\r
+  listensocket.onsessionavailable := sc.sessionavailable;\r
+  writeln('listening');\r
+  listensocket.listen;\r
+  writeln(listensocket.getxport);\r
+  writeln('listen socket is number ', listensocket.fdhandlein);\r
+  writeln('creating and setting up server socket');\r
+  serversocket := tlsocket.create(nil);\r
+  serversocket.ondataavailable := sc.dataavailable;\r
+  writeln('creating and setting up client socket');\r
+  clientsocket := tlsocket.create(nil);\r
+  clientsocket.addr := '::1';{'127.0.0.1';}\r
+  clientsocket.port := '12345';\r
+  clientsocket.onsessionconnected := sc.sessionconnected;\r
+  clientsocket.ondataAvailable := sc.dataavailable;\r
+  clientsocket.onsessionclosed := sc.sessionclosed;\r
+  writeln('connecting');\r
+  clientsocket.connect;\r
+  writeln('client socket is number ',clientsocket.fdhandlein);\r
+  writeln('creating and setting up timer');\r
+  timer := tltimer.create(nil);\r
+  timer.interval := 1000;\r
+  timer.ontimer := sc.timehandler;\r
+  timer.enabled := true;\r
+  writeln('entering message loop');\r
+  messageloop;\r
+  writeln('exiting cleanly');\r
+end.\r

diff --git a/lcoretest.res b/lcoretest.res
new file mode 100755 (executable)
index 0000000..a528693
Binary files /dev/null and b/lcoretest.res differ

diff --git a/lcorewsaasyncselect.pas b/lcorewsaasyncselect.pas
new file mode 100755 (executable)
index 0000000..a978c23
--- /dev/null
+++ b/lcorewsaasyncselect.pas
@@ -0,0 +1,216 @@
+unit lcorewsaasyncselect;\r
+\r
+interface\r
+\r
+implementation\r
+uses wcore,lcore,bsearchtree,sysutils,windows,winsock,pgtypes,messages,classes;\r
+type\r
+  twineventcore=class(teventcore)\r
+  public\r
+    procedure processmessages; override;\r
+    procedure messageloop; override;\r
+    procedure exitmessageloop;override;\r
+    procedure setfdreverse(fd : integer;reverseto : tlasio); override;\r
+    procedure rmasterset(fd : integer;islistensocket : boolean); override;\r
+    procedure rmasterclr(fd: integer); override;\r
+    procedure wmasterset(fd : integer); override;\r
+    procedure wmasterclr(fd: integer); override;\r
+  end;\r
+const\r
+  wm_dotasks=wm_user+1;\r
+type\r
+  twintimerwrapperinterface=class(ttimerwrapperinterface)\r
+  public\r
+    function createwrappedtimer : tobject;override;\r
+//    procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);override;\r
+    procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);override;\r
+    procedure setenabled(wrappedtimer : tobject;newvalue : boolean);override;\r
+    procedure setinterval(wrappedtimer : tobject;newvalue : integer);override;\r
+  end;\r
+\r
+procedure twineventcore.processmessages;\r
+begin\r
+  wcore.processmessages;//pass off to wcore\r
+end;\r
+procedure twineventcore.messageloop;\r
+begin\r
+  wcore.messageloop; //pass off to wcore\r
+end;\r
+procedure twineventcore.exitmessageloop;\r
+begin\r
+  wcore.exitmessageloop;\r
+end;\r
+var\r
+  fdreverse : thashtable;\r
+  fdwatches : thashtable;\r
+\r
+procedure twineventcore.setfdreverse(fd : integer;reverseto : tlasio);\r
+begin\r
+  if findtree(@fdreverse,inttostr(fd)) <> nil then deltree(@fdreverse,inttostr(fd));\r
+  if reverseto <> nil then addtree(@fdreverse,inttostr(fd),reverseto);\r
+end;\r
+\r
+var\r
+  hwndlcore : hwnd;\r
+procedure dowsaasyncselect(fd:integer; leventadd: integer; leventremove : integer);\r
+var\r
+  leventold : integer;\r
+  leventnew : integer;\r
+  wsaaresult : integer;\r
+begin\r
+  leventold := taddrint(findtree(@fdwatches,inttostr(fd)));\r
+  leventnew := leventold or leventadd;\r
+  leventnew := leventnew and not leventremove;\r
+  if leventold <> leventnew then begin\r
+    if leventold <> 0 then deltree(@fdwatches,inttostr(fd));\r
+    if leventnew <> 0 then addtree(@fdwatches,inttostr(fd),pointer(leventnew));\r
+  end;\r
+  wsaaresult := wsaasyncselect(fd,hwndlcore,wm_user,leventnew);\r
+\r
+end;\r
+\r
+\r
+//to allow detection of errors:\r
+//if we are asked to monitor for read or accept we also monitor for close\r
+//if we are asked to monitor for write we also monitor for connect\r
+\r
+\r
+procedure twineventcore.rmasterset(fd : integer;islistensocket : boolean);\r
+begin\r
+  if islistensocket then begin\r
+    //writeln('setting accept watch for socket number ',fd);\r
+    dowsaasyncselect(fd,FD_ACCEPT or FD_CLOSE,0);\r
+  end else begin\r
+    //writeln('setting read watch for socket number',fd);\r
+    dowsaasyncselect(fd,FD_READ or FD_CLOSE,0);\r
+  end;\r
+end;\r
+procedure twineventcore.rmasterclr(fd: integer);\r
+begin\r
+  //writeln('clearing read of accept watch for socket number ',fd);\r
+  dowsaasyncselect(fd,0,FD_ACCEPT or FD_READ or FD_CLOSE);\r
+end;\r
+procedure twineventcore.wmasterset(fd : integer);\r
+begin\r
+  dowsaasyncselect(fd,FD_WRITE or FD_CONNECT,0);\r
+end;\r
+\r
+procedure twineventcore.wmasterclr(fd: integer);\r
+begin\r
+  dowsaasyncselect(fd,0,FD_WRITE or FD_CONNECT);\r
+end;\r
+\r
+var\r
+  tasksoutstanding : boolean;\r
+\r
+function MyWindowProc(\r
+    ahWnd   : HWND;\r
+    auMsg   : Integer;\r
+    awParam : WPARAM;\r
+    alParam : LPARAM): Integer; stdcall;\r
+var\r
+  socket : integer;\r
+  event : integer;\r
+  error : integer;\r
+  readtrigger : boolean;\r
+  writetrigger : boolean;\r
+  lasio : tlasio;\r
+begin\r
+  //writeln('got a message');\r
+  Result := 0;  // This means we handled the message\r
+  if (ahwnd=hwndlcore) and (aumsg=wm_user) then begin\r
+    //writeln('it appears to be a response to our wsaasyncselect');\r
+    socket := awparam;\r
+    event := alparam and $FFFF;\r
+    error := alparam shr 16;\r
+    //writeln('socket=',socket,' event=',event,' error=',error);\r
+    readtrigger := false;\r
+    writetrigger := false;\r
+    lasio := findtree(@fdreverse,inttostr(socket));\r
+    if assigned(lasio) then begin\r
+      if (error <> 0) or ((event and FD_CLOSE) <> 0) then begin\r
+        if lasio.state = wsconnecting then begin\r
+          lasio.onsessionconnected(lasio,error);\r
+        end;\r
+        lasio.internalclose(error);\r
+      end else begin\r
+        if (event and (FD_READ or FD_ACCEPT)) <> 0 then readtrigger := true;\r
+        if (event and (FD_WRITE)) <> 0 then writetrigger := true;\r
+\r
+        if readtrigger or writetrigger then lasio.handlefdtrigger(readtrigger,writetrigger);\r
+      end;\r
+      dowsaasyncselect(socket,0,0); //reset watches\r
+    end;\r
+  end else if (ahwnd=hwndlcore) and (aumsg=wm_dotasks) then begin\r
+      //writeln('processing tasks');\r
+      tasksoutstanding := false;\r
+      processtasks;\r
+  end else begin\r
+      //writeln('passing unknown message to defwindowproc');\r
+      //not passing unknown messages on to defwindowproc will cause window\r
+      //creation to fail! --plugwash\r
+      Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)\r
+  end;\r
+\r
+end;\r
+\r
+procedure winaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+  if not tasksoutstanding then PostMessage(hwndlcore,wm_dotasks,0,0);\r
+end;\r
+type\r
+  twcoretimer = wcore.tltimer;\r
+\r
+function twintimerwrapperinterface.createwrappedtimer : tobject;\r
+begin\r
+  result := twcoretimer.create(nil);\r
+end;\r
+procedure twintimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);\r
+begin\r
+  twcoretimer(wrappedtimer).ontimer := newvalue;\r
+end;\r
+procedure twintimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean);\r
+begin\r
+  twcoretimer(wrappedtimer).enabled := newvalue;\r
+end;\r
+\r
+\r
+procedure twintimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer);\r
+begin\r
+  twcoretimer(wrappedtimer).interval := newvalue;\r
+end;\r
+\r
+var\r
+  MyWindowClass : TWndClass = (style         : 0;\r
+                                 lpfnWndProc   : @MyWindowProc;\r
+                                 cbClsExtra    : 0;\r
+                                 cbWndExtra    : 0;\r
+                                 hInstance     : 0;\r
+                                 hIcon         : 0;\r
+                                 hCursor       : 0;\r
+                                 hbrBackground : 0;\r
+                                 lpszMenuName  : nil;\r
+                                 lpszClassName : 'lcoreClass');\r
+  GInitData: TWSAData;\r
+\r
+begin\r
+  eventcore := twineventcore.create;\r
+    if Windows.RegisterClass(MyWindowClass) = 0 then halt;\r
+  //writeln('about to create lcore handle, hinstance=',hinstance);\r
+  hwndlcore := CreateWindowEx(WS_EX_TOOLWINDOW,\r
+                               MyWindowClass.lpszClassName,\r
+                               '',        { Window name   }\r
+                               WS_POPUP,  { Window Style  }\r
+                               0, 0,      { X, Y          }\r
+                               0, 0,      { Width, Height }\r
+                               0,         { hWndParent    }\r
+                               0,         { hMenu         }\r
+                               HInstance, { hInstance     }\r
+                               nil);      { CreateParam   }\r
+  //writeln('lcore hwnd is ',hwndlcore);\r
+  //writeln('last error is ',GetLastError);\r
+  onaddtask := winaddtask;\r
+  timerwrapperinterface := twintimerwrapperinterface.create(nil);\r
+\r
+  WSAStartup($200, GInitData);\r
+end.\r

diff --git a/lloopback.pas b/lloopback.pas
new file mode 100755 (executable)
index 0000000..7e26d7c
--- /dev/null
+++ b/lloopback.pas
@@ -0,0 +1,34 @@
+unit lloopback;\r
+\r
+interface\r
+uses lcore,classes;\r
+\r
+type\r
+  tlloopback=class(tlasio)\r
+  public\r
+    constructor create(aowner:tcomponent); override;\r
+  end;\r
+\r
+\r
+implementation\r
+uses
+{$ifdef ver1_0}
+  linux;
+{$else}
+  baseunix,unix,unixutil;  
+{$endif}
+{$i unixstuff.inc}
+
+constructor tlloopback.create(aowner:tcomponent);\r
+begin\r
+  inherited create(aowner);\r
+  closehandles := true;\r
+  assignpipe(fdhandlein,fdhandleout);\r
+\r
+  eventcore.rmasterset(fdhandlein,false);//fd_set(fdhandlein,fdsrmaster);\r
+  eventcore.wmasterclr(fdhandlein);//fd_clr(fdhandleout,fdswmaster);\r
+  eventcore.setfdreverse(fdhandlein,self);\r
+  eventcore.setfdreverse(fdhandleout,self);\r
+  state := wsconnected;\r
+end;\r
+end.\r

diff --git a/lmessages.pas b/lmessages.pas
new file mode 100755 (executable)
index 0000000..7bb73fd
--- /dev/null
+++ b/lmessages.pas
@@ -0,0 +1,656 @@
+unit lmessages;\r
+//windows messages like system based on lcore tasks\r
+interface\r
+\r
+uses pgtypes,sysutils,bsearchtree,strings,syncobjs;\r
+\r
+type\r
+  lparam=taddrint;\r
+  wparam=taddrint;\r
+  thinstance=pointer;\r
+  hicon=pointer;\r
+  hcursor=pointer;\r
+  hbrush=pointer;\r
+  hwnd=qword; //window handles are monotonically increasing 64 bit integers,\r
+              //this should allow for a million windows per second for over half\r
+              //a million years!\r
+\r
+  twndproc=function(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;\r
+\r
+\r
+  twndclass=record\r
+    style : dword;\r
+    lpfnwndproc : twndproc;\r
+    cbclsextra : integer;\r
+    cbwndextra : integer;\r
+    hinstance : thinstance;\r
+    hicon : hicon;\r
+    hcursor : hcursor;\r
+    hbrbackground : hbrush;\r
+    lpszmenuname : pchar;\r
+    lpszclassname : pchar;\r
+  end;\r
+  PWNDCLASS=^twndclass;\r
+  \r
+  UINT=dword;\r
+  WINBOOL = longbool;\r
+  tTIMERPROC = procedure (ahwnd:HWND; umsg:integer; idevent:taddrint;dwtime:taddrint);stdcall;\r
+  ATOM = pointer;\r
+  LPCSTR = pchar;\r
+  LPVOID = pointer;\r
+  HMENU = pointer;\r
+  HINST = pointer;\r
+\r
+  TPOINT = record \r
+    x : LONGint; \r
+    y : LONGint; \r
+  end; \r
+  \r
+  TMSG = record \r
+    hwnd : HWND; \r
+    message : UINT; \r
+    wParam : WPARAM; \r
+    lParam : LPARAM; \r
+    time : DWORD; \r
+    pt : TPOINT;\r
+  end; \r
+  THevent=TEventObject;\r
+const\r
+  WS_EX_TOOLWINDOW = $80;\r
+  WS_POPUP = longint($80000000);\r
+  hinstance=nil;\r
+  PM_REMOVE = 1;\r
+  WM_USER = 1024;\r
+  WM_TIMER = 275;\r
+  INFINITE = syncobjs.infinite;\r
+function getwindowlongptr(ahwnd:hwnd;nindex:integer) : taddrint;\r
+function setwindowlongptr(ahwnd:hwnd;nindex:integer;dwNewLong : taddrint) : taddrint;\r
+function DefWindowProc(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;\r
+function RegisterClass(const lpWndClass:TWNDCLASS):ATOM;\r
+function CreateWindowEx(dwExStyle:DWORD; lpClassName:LPCSTR; lpWindowName:LPCSTR; dwStyle:DWORD; X:longint;Y:longint; nWidth:longint; nHeight:longint; hWndParent:HWND; hMenu:HMENU;hInstance:HINST; lpParam:LPVOID):HWND;\r
+function DestroyWindow(ahWnd:HWND):WINBOOL;\r
+function PostMessage(hWnd:HWND; Msg:UINT; wParam:WPARAM; lParam:LPARAM):WINBOOL;\r
+function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): WINBOOL;\r
+function DispatchMessage(const lpMsg: TMsg): Longint;\r
+function GetMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT): WINBOOL;\r
+function SetEvent(hEvent:THevent):WINBOOL;\r
+function CreateEvent(lpEventAttributes:PSECURITYATTRIBUTES; bManualReset:WINBOOL; bInitialState:WINBOOL; lpName:pchar):tHevent;\r
+function terminatethread(threadhandle : tthreadid;dummy:integer) : boolean;\r
+function waitforsingleevent(event:thevent;timeout:cardinal) : twaitresult;\r
+function SetTimer(ahWnd:HWND; nIDEvent:taddrint; uElapse:UINT; lpTimerFunc:tTIMERPROC):UINT;\r
+function KillTimer(ahWnd:HWND; uIDEvent:taddrint):WINBOOL;\r
+\r
+procedure init;\r
+\r
+implementation\r
+uses\r
+  baseunix,unix,lcore;//,safewriteln;\r
+{$i unixstuff.inc}\r
+\r
+type\r
+  tmessageintransit = class\r
+    msg : tmsg;\r
+    next : tmessageintransit;\r
+  end;\r
+\r
+  tthreaddata = class\r
+    messagequeue : tmessageintransit;\r
+    messageevent : teventobject;\r
+    waiting : boolean;\r
+    lcorethread : boolean;\r
+    nexttimer : ttimeval;\r
+    threadid : integer;\r
+  end;\r
+  twindow=class\r
+    hwnd : hwnd;\r
+    extrawindowmemory : pointer;\r
+    threadid : tthreadid;\r
+    windowproc : twndproc;\r
+  end;\r
+\r
+var\r
+  structurelock : tcriticalsection;\r
+  threaddata : thashtable;\r
+  windowclasses : thashtable;\r
+  lcorelinkpipesend : integer;\r
+  lcorelinkpiperecv : tlasio;\r
+  windows : thashtable;\r
+  //I would rather things crash immediately\r
+  //if they use an insufficiant size type\r
+  //than crash after over four billion\r
+  //windows have been made ;)\r
+  nextwindowhandle : qword = $100000000;\r
+{$i ltimevalstuff.inc}\r
+\r
+//findthreaddata should only be called while holding the structurelock\r
+function findthreaddata(threadid : integer) : tthreaddata;\r
+begin\r
+  result := tthreaddata(findtree(@threaddata,inttostr(threadid)));\r
+  if result = nil then begin\r
+    result := tthreaddata.create;\r
+    result.messageevent := teventobject.create(nil,false,false,inttostr(taddrint(result)));\r
+    result.nexttimer := tv_invalidtimebig;\r
+    result.threadid := threadid;\r
+    addtree(@threaddata,inttostr(threadid),result);\r
+  end;\r
+end;\r
+\r
+//deletethreaddataifunused should only be called while holding the structurelock\r
+procedure deletethreaddataifunused(athreaddata : tthreaddata);\r
+begin\r
+  //writeln('in deletethreaddataifunused');\r
+  if (athreaddata <> nil) then if (athreaddata.waiting=false) and (athreaddata.messagequeue=nil) and (athreaddata.lcorethread=false) and (athreaddata.nexttimer.tv_sec=tv_invalidtimebig.tv_sec) and (athreaddata.nexttimer.tv_usec=tv_invalidtimebig.tv_usec) then begin\r
+    //writeln('threaddata is unused, freeing messageevent');\r
+    athreaddata.messageevent.free;\r
+    //writeln('freeing thread data object');\r
+    athreaddata.free;\r
+    //writeln('deleting thread data object from hashtable');\r
+    deltree(@threaddata,inttostr(athreaddata.threadid));\r
+    //writeln('finished deleting thread data');\r
+  end else begin\r
+    //writeln('thread data is not unused');\r
+  end;\r
+end;\r
+\r
+function getwindowlongptr(ahwnd:hwnd;nindex:integer) : taddrint;\r
+var\r
+  window : twindow;\r
+begin\r
+  structurelock.acquire;\r
+  try\r
+    window := findtree(@windows,inttostr(ahwnd));\r
+    if window <> nil then begin\r
+      result := paddrint(taddrint(window.extrawindowmemory)+nindex)^;\r
+    end else begin\r
+      result := 0;\r
+    end;\r
+  finally\r
+    structurelock.release;\r
+  end;\r
+end;\r
+\r
+function setwindowlongptr(ahwnd:hwnd;nindex:integer;dwNewLong : taddrint) : taddrint;\r
+var\r
+  window : twindow;\r
+begin\r
+  structurelock.acquire;\r
+  try\r
+    window := findtree(@windows,inttostr(ahwnd));\r
+    if window <> nil then begin\r
+      result := paddrint(taddrint(window.extrawindowmemory)+nindex)^;\r
+      paddrint(taddrint(window.extrawindowmemory)+nindex)^ := dwnewlong;\r
+    end else begin\r
+      result := 0;\r
+    end;\r
+  finally\r
+    structurelock.release;\r
+  end;\r
+\r
+end;\r
+\r
+\r
+function DefWindowProc(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;\r
+begin\r
+  result := 0;\r
+end;\r
+\r
+function strdup(s:pchar) : pchar;\r
+begin\r
+  //swriteln('in strdup, about to allocate memory');\r
+  result := getmem(strlen(s)+1);\r
+  //swriteln('about to copy string');\r
+  strcopy(s,result);\r
+  //swriteln('leaving strdup');\r
+end;\r
+\r
+function RegisterClass(const lpWndClass:TWNDCLASS):ATOM;\r
+var\r
+  storedwindowclass:pwndclass;\r
+begin\r
+  structurelock.acquire;\r
+  try\r
+    //swriteln('in registerclass, about to check for duplicate window class');\r
+    storedwindowclass := findtree(@windowclasses, lpwndclass.lpszclassname);\r
+    if storedwindowclass <> nil then begin\r
+\r
+      if comparebyte(storedwindowclass^,lpwndclass,sizeof(twndclass)-sizeof(pchar)-sizeof(pchar)) <> 0 then begin\r
+        //swriteln('duplicate window class registered with different settings');\r
+        raise exception.create('duplicate window class registered with different settings');\r
+      end else begin\r
+        //swriteln('duplicate window class registered with same settings, tollerated');\r
+      end;\r
+    end else begin\r
+      //swriteln('about to allocate memory for new windowclass');\r
+      storedwindowclass := getmem(sizeof(twndclass));\r
+      //swriteln('about to copy windowclass from parameter');\r
+      move(lpwndclass,storedwindowclass^,sizeof(twndclass));\r
+      //swriteln('about to copy strings');\r
+      if lpwndclass.lpszmenuname <> nil then storedwindowclass.lpszmenuname := strdup(lpwndclass.lpszmenuname);\r
+      if lpwndclass.lpszclassname <> nil then storedwindowclass.lpszclassname := strdup(lpwndclass.lpszclassname);\r
+      //swriteln('about to add result to list of windowclasses');\r
+      addtree(@windowclasses,lpwndclass.lpszclassname,storedwindowclass);\r
+    end;\r
+    //swriteln('about to return result');\r
+    result := storedwindowclass;\r
+    //swriteln('leaving registerclass');\r
+  finally\r
+    structurelock.release;\r
+  end;\r
+end;\r
+\r
+function CreateWindowEx(dwExStyle:DWORD; lpClassName:LPCSTR; lpWindowName:LPCSTR; dwStyle:DWORD; X:longint;Y:longint; nWidth:longint; nHeight:longint; hWndParent:HWND; hMenu:HMENU;hInstance:HINST; lpParam:LPVOID):HWND;\r
+var\r
+  wndclass : pwndclass;\r
+  tm : tthreadmanager;\r
+  window : twindow;\r
+begin\r
+  structurelock.acquire;\r
+  try\r
+    window := twindow.create;\r
+    window.hwnd := nextwindowhandle;\r
+    result := window.hwnd;\r
+    nextwindowhandle := nextwindowhandle + 1;\r
+    addtree(@windows,inttostr(window.hwnd),window);\r
+    wndclass := findtree(@windowclasses,lpclassname);\r
+    window.extrawindowmemory := getmem(wndclass.cbwndextra);\r
+\r
+    getthreadmanager(tm);\r
+    window.threadid := tm.GetCurrentThreadId;\r
+    window.windowproc := wndclass.lpfnwndproc;\r
+  finally\r
+    structurelock.release;\r
+  end;\r
+end;\r
+function DestroyWindow(ahWnd:HWND):WINBOOL;\r
+var\r
+  window : twindow;\r
+  windowthreaddata : tthreaddata;\r
+  currentmessage : tmessageintransit;\r
+  prevmessage : tmessageintransit;\r
+begin\r
+  //writeln('started to destroy window');\r
+  structurelock.acquire;\r
+  try\r
+    window := twindow(findtree(@windows,inttostr(ahwnd)));\r
+    if window <> nil then begin\r
+      freemem(window.extrawindowmemory);\r
+      //writeln('aboute to delete window from windows structure');\r
+      deltree(@windows,inttostr(ahwnd));\r
+      //writeln('deleted window from windows structure');\r
+      windowthreaddata := tthreaddata(findtree(@threaddata,inttostr(window.threadid)));\r
+\r
+      if windowthreaddata <> nil then begin\r
+        //writeln('found thread data scanning for messages to clean up');\r
+        currentmessage := windowthreaddata.messagequeue;\r
+        prevmessage := nil;\r
+        while currentmessage <> nil do begin\r
+          while (currentmessage <> nil) and (currentmessage.msg.hwnd = ahwnd) do begin\r
+            if prevmessage = nil then begin\r
+              windowthreaddata.messagequeue := currentmessage.next;\r
+            end else begin\r
+              prevmessage.next := currentmessage.next;\r
+            end;\r
+            currentmessage.free;\r
+            if prevmessage = nil then begin\r
+              currentmessage := windowthreaddata.messagequeue;\r
+            end else begin\r
+              currentmessage := prevmessage.next;\r
+            end;\r
+          end;\r
+          if currentmessage <> nil then begin\r
+            prevmessage := currentmessage;\r
+            currentmessage := currentmessage.next;\r
+          end;\r
+        end;\r
+        //writeln('deleting thread data structure if it is unused');\r
+        deletethreaddataifunused(windowthreaddata);\r
+      end else begin\r
+        //writeln('there is no thread data to search for messages to cleanup');\r
+      end;\r
+      //writeln('freeing window');\r
+      window.free;\r
+      result := true;\r
+    end else begin\r
+      result := false;\r
+    end;\r
+  finally\r
+    structurelock.release;\r
+  end;\r
+  //writeln('window destroyed');\r
+end;\r
+\r
+\r
+\r
+function PostMessage(hWnd:HWND; Msg:UINT; wParam:WPARAM; lParam:LPARAM):WINBOOL;\r
+var\r
+  threaddata : tthreaddata;\r
+  message : tmessageintransit;\r
+  messagequeueend : tmessageintransit;\r
+  window : twindow;\r
+begin\r
+  structurelock.acquire;\r
+  try\r
+    window := findtree(@windows,inttostr(hwnd));\r
+    if window <> nil then begin\r
+      threaddata := findthreaddata(window.threadid);\r
+      message := tmessageintransit.create;\r
+      message.msg.hwnd := hwnd;\r
+      message.msg.message := msg;\r
+      message.msg.wparam := wparam;\r
+      message.msg.lparam := lparam;\r
+      if threaddata.lcorethread then begin\r
+        //swriteln('posting message to lcore thread');\r
+        fdwrite(lcorelinkpipesend,message,sizeof(message));\r
+      end else begin\r
+        //writeln('posting message to non lcore thread');\r
+        if threaddata.messagequeue = nil then begin\r
+          threaddata.messagequeue := message;\r
+        end else begin\r
+          messagequeueend := threaddata.messagequeue;\r
+          while messagequeueend.next <> nil do begin\r
+            messagequeueend := messagequeueend.next;\r
+          end;\r
+          messagequeueend.next := message;\r
+        end;\r
+\r
+        //writeln('message added to queue');\r
+        if threaddata.waiting then threaddata.messageevent.setevent;\r
+      end;\r
+      result := true;\r
+    end else begin\r
+      result := false;\r
+    end;\r
+  finally\r
+    structurelock.release;\r
+  end;\r
+\r
+end;\r
+\r
+function gettickcount : dword;\r
+var\r
+  result64: integer;\r
+  tv : ttimeval;\r
+begin\r
+  gettimeofday(tv);\r
+  result64 := (tv.tv_sec*1000)+(tv.tv_usec div 1000);\r
+  result := result64;\r
+end;\r
+\r
+function DispatchMessage(const lpMsg: TMsg): Longint;\r
+var\r
+  timerproc : ttimerproc;\r
+  window : twindow;\r
+  windowproc : twndproc;\r
+begin\r
+  ////swriteln('in dispatchmessage, msg.hwnd='+inttohex(taddrint(lpmsg.hwnd),16));\r
+  if (lpmsg.lparam <> 0) and (lpmsg.message = WM_TIMER) then begin\r
+    timerproc := ttimerproc(lpmsg.lparam);\r
+    timerproc(lpmsg.hwnd,lpmsg.message,lpmsg.wparam,gettickcount);\r
+    result := 0;\r
+  end else begin\r
+    structurelock.acquire;\r
+    try\r
+      window := findtree(@windows,inttostr(lpmsg.hwnd));\r
+      //we have to get the window procedure while the structurelock\r
+      //is still held as the window could be destroyed from another thread\r
+      //otherwise.\r
+      windowproc := window.windowproc;\r
+    finally\r
+      structurelock.release;\r
+    end;\r
+    if window <> nil then begin\r
+      result := windowproc(lpmsg.hwnd,lpmsg.message,lpmsg.wparam,lpmsg.lparam);\r
+    end else begin\r
+      result := -1;\r
+    end;\r
+  end;\r
+end;\r
+\r
+procedure processtimers;\r
+begin\r
+end;\r
+\r
+function GetMessageinternal(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT; wremovemsg : UINT;peek:boolean): WINBOOL;\r
+var\r
+  tm : tthreadmanager;\r
+  threaddata : tthreaddata;\r
+  message : tmessageintransit;\r
+  nowtv : ttimeval;\r
+  timeouttv : ttimeval;\r
+  timeoutms : int64;\r
+\r
+begin\r
+  if hwnd <> 0 then raise exception.create('getting messages for an individual window is not supported');\r
+  if (wmsgfiltermin <> 0) or (wmsgfiltermax <> 0) then raise exception.create('message filtering is not supported');\r
+  structurelock.acquire;\r
+  result := true;\r
+  try\r
+    getthreadmanager(tm);\r
+    threaddata := findthreaddata(tm.GetCurrentThreadId);\r
+    if threaddata.lcorethread then raise exception.create('get/peek message cannot be used in the lcore thread');\r
+    message := threaddata.messagequeue;\r
+    gettimeofday(nowtv);\r
+    while (not peek) and (message=nil) and (not tv_compare(nowtv,threaddata.nexttimer)) do begin\r
+      threaddata.waiting := true;\r
+      structurelock.release;\r
+      if (threaddata.nexttimer.tv_sec = TV_invalidtimebig.tv_sec) and (threaddata.nexttimer.tv_usec = TV_invalidtimebig.tv_usec) then begin\r
+        threaddata.messageevent.waitfor(INFINITE);\r
+      end else begin\r
+\r
+        timeouttv := threaddata.nexttimer;\r
+        timeoutms := (timeouttv.tv_sec * 1000)+(timeouttv.tv_usec div 1000);\r
+        //i'm assuming the timeout is in milliseconds\r
+        if (timeoutms > maxlongint) then timeoutms := maxlongint;\r
+        threaddata.messageevent.waitfor(timeoutms);\r
+\r
+      end;\r
+      structurelock.acquire;\r
+      threaddata.waiting := false;\r
+      message := threaddata.messagequeue;\r
+      gettimeofday(nowtv);\r
+    end;\r
+    if (message=nil) and tv_compare(nowtv,threaddata.nexttimer) then begin\r
+      processtimers;\r
+    end;\r
+    message := threaddata.messagequeue;\r
+    if message <> nil then begin\r
+      lpmsg := message.msg;\r
+      if wremovemsg=PM_REMOVE then begin\r
+        threaddata.messagequeue := message.next;\r
+        message.free;\r
+      end;\r
+    end else begin\r
+      result :=false;\r
+    end;\r
+    deletethreaddataifunused(threaddata);\r
+  finally\r
+    structurelock.release;\r
+  end;\r
+end;\r
+\r
+function GetMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT): WINBOOL;\r
+begin\r
+  result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,PM_REMOVE,false);\r
+end;\r
+\r
+function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): WINBOOL;\r
+begin\r
+  result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,PM_REMOVE,true);\r
+end;\r
+\r
+function SetEvent(hEvent:THevent):WINBOOL;\r
+begin\r
+  hevent.setevent;\r
+  result := true;\r
+end;\r
+\r
+function CreateEvent(lpEventAttributes:PSECURITYATTRIBUTES; bManualReset:WINBOOL; bInitialState:WINBOOL; lpName:pchar):tHevent;\r
+begin\r
+  result := teventobject.create(lpeventattributes,bmanualreset,binitialstate,lpname);\r
+end;\r
+\r
+function terminatethread(threadhandle:tthreadid;dummy : integer) : boolean;\r
+var\r
+  tm : tthreadmanager;\r
+begin\r
+  getthreadmanager(tm);\r
+  tm.killthread(threadhandle);\r
+  result := true;\r
+end;\r
+\r
+function waitforsingleevent(event:thevent;timeout:cardinal) : twaitresult;\r
+begin\r
+  result := event.waitfor(timeout);\r
+end;\r
+\r
+procedure removefrombuffer(n : integer; var buffer:string);\r
+begin\r
+  if n=length(buffer) then begin\r
+    buffer := '';\r
+  end else begin\r
+    uniquestring(buffer);\r
+    move(buffer[n+1],buffer[1],length(buffer)-n);\r
+    setlength(buffer,length(buffer)-n);\r
+  end;\r
+end;\r
+\r
+type\r
+  tsc=class\r
+    procedure available(sender:tobject;error:word);\r
+  end;\r
+\r
+var\r
+  recvbuf : string;\r
+\r
+procedure tsc.available(sender:tobject;error:word);\r
+var\r
+  message : tmessageintransit;\r
+  messagebytes : array[1..sizeof(tmessageintransit)] of char absolute  message;\r
+  i : integer;\r
+begin\r
+  //swriteln('received data on lcorelinkpipe');\r
+  recvbuf := recvbuf + lcorelinkpiperecv.receivestr;\r
+  while length(recvbuf) >= sizeof(tmessageintransit) do begin\r
+    for i := 1 to sizeof(tmessageintransit) do begin\r
+      messagebytes[i] := recvbuf[i];\r
+    end;\r
+    dispatchmessage(message.msg);\r
+    message.free;\r
+    removefrombuffer(sizeof(tmessageintransit),recvbuf);\r
+  end;\r
+end;\r
+\r
+procedure init;\r
+var\r
+  tm : tthreadmanager;\r
+  threaddata : tthreaddata;\r
+  pipeends : tfildes;\r
+  sc : tsc;\r
+begin\r
+  structurelock := tcriticalsection.create;\r
+  getthreadmanager(tm);\r
+  threaddata := findthreaddata(tm.GetCurrentThreadId);\r
+  threaddata.lcorethread := true;\r
+  fppipe(pipeends);\r
+  lcorelinkpipesend := pipeends[1];\r
+  lcorelinkpiperecv := tlasio.create(nil);\r
+  lcorelinkpiperecv.dup(pipeends[0]);\r
+  lcorelinkpiperecv.ondataavailable := sc.available;\r
+  recvbuf := '';\r
+end;\r
+\r
+var\r
+  lcorethreadtimers : thashtable;\r
+type\r
+  tltimerformsg = class(tltimer)\r
+  public\r
+    hwnd : hwnd;\r
+    id : taddrint;\r
+    procedure timer(sender : tobject);\r
+  end;\r
+\r
+procedure tltimerformsg.timer(sender : tobject);\r
+var\r
+  msg : tmsg;\r
+begin\r
+  ////swriteln('in tltimerformsg.timer');\r
+  fillchar(msg,sizeof(msg),0);\r
+  msg.message := WM_TIMER;\r
+  msg.hwnd := hwnd;\r
+  msg.wparam := ID;\r
+  msg.lparam := 0;\r
+  dispatchmessage(msg);\r
+end;\r
+\r
+function SetTimer(ahWnd:HWND; nIDEvent:taddrint; uElapse:UINT; lpTimerFunc:tTIMERPROC):UINT;\r
+var\r
+  threaddata : tthreaddata;\r
+  ltimer : tltimerformsg;\r
+  tm : tthreadmanager;\r
+  window : twindow;\r
+begin\r
+  structurelock.acquire;\r
+  try\r
+    window := findtree(@windows,inttostr(ahwnd));\r
+    if window= nil then raise exception.create('invalid window');\r
+    threaddata := findthreaddata(window.threadid);\r
+  finally\r
+    structurelock.release;\r
+  end;\r
+  if threaddata.lcorethread then begin\r
+    getthreadmanager(tm);\r
+    if tm.GetCurrentThreadId <> window.threadid then raise exception.create('timers on the lcore thread may only be added and removed from the lcore thread');\r
+    if ahwnd = 0 then raise exception.create('timers on the lcore thread must be associated with a window handle');\r
+    if @lptimerfunc <> nil then raise exception.create('seperate timer functions are not supported');\r
+\r
+    //remove preexisting timer with same ID\r
+    killtimer(ahwnd,nIDEvent);\r
+\r
+    ltimer := tltimerformsg.create(nil);\r
+    ltimer.interval := uelapse;\r
+    ltimer.id := nidevent;\r
+    ltimer.hwnd := ahwnd;\r
+    ltimer.enabled := true;\r
+    ltimer.ontimer := ltimer.timer;\r
+\r
+    addtree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(nIDEvent),ltimer);\r
+\r
+    result := nidevent;\r
+  end else begin\r
+    raise exception.create('settimer not implemented for threads other than the lcore thread');\r
+  end;\r
+end;\r
+\r
+function KillTimer(ahWnd:HWND; uIDEvent:taddrint):WINBOOL;\r
+var\r
+  threaddata : tthreaddata;\r
+  ltimer : tltimerformsg;\r
+  tm : tthreadmanager;\r
+  window : twindow;\r
+begin\r
+  structurelock.acquire;\r
+  try\r
+    window := findtree(@windows,inttostr(ahwnd));\r
+    if window= nil then raise exception.create('invalid window');\r
+    threaddata := findthreaddata(window.threadid);\r
+  finally\r
+    structurelock.release;\r
+  end;\r
+  if threaddata.lcorethread then begin\r
+    getthreadmanager(tm);\r
+    if tm.GetCurrentThreadId <> window.threadid then raise exception.create('timers on the lcore thread may only be added and remove from the lcore thread');\r
+    if ahwnd = 0 then raise exception.create('timers on the lcore thread must be associated with a window handle');\r
+    ltimer := tltimerformsg(findtree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(uIDEvent)));\r
+    if ltimer <> nil then begin\r
+      deltree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(uIDEvent));\r
+      ltimer.free;\r
+      result := true;\r
+    end else begin\r
+      result := false;\r
+    end;\r
+  end else begin\r
+    raise exception.create('settimer not implemented for threads other than the lcore thread');\r
+  end;\r
+end;\r
+\r
+end.
\ No newline at end of file

diff --git a/lsignal.pas b/lsignal.pas
new file mode 100755 (executable)
index 0000000..49e51b2
--- /dev/null
+++ b/lsignal.pas
@@ -0,0 +1,201 @@
+{lsocket.pas}\r
+\r
+{signal code by plugwash}\r
+\r
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+      \r
+unit lsignal;\r
+{$mode delphi}\r
+interface\r
+  uses sysutils,\r
+    {$ifdef VER1_0}\r
+      linux,\r
+    {$else}\r
+      baseunix,unix,unixutil,\r
+    {$endif}\r
+    classes,lcore,lloopback;\r
+\r
+  type\r
+    tsignalevent=procedure(sender:tobject;signal:integer) of object;\r
+    tlsignal=class(tcomponent)\r
+    public\r
+      onsignal           : tsignalevent      ;\r
+      prevsignal         : tlsignal          ;\r
+      nextsignal         : tlsignal          ;\r
+\r
+      constructor create(aowner:tcomponent);override;\r
+      destructor destroy;override;\r
+    end;\r
+\r
+  \r
+  procedure starthandlesignal(signal:integer);\r
+\r
+var\r
+  firstsignal : tlsignal;\r
+  blockset : sigset;\r
+  signalloopback                        : tlloopback ;\r
+  
+implementation\r
+{$include unixstuff.inc}\r
+\r
+constructor tlsignal.create;\r
+begin\r
+  inherited create(AOwner);\r
+  nextsignal := firstsignal;\r
+  prevsignal := nil;\r
+\r
+  if assigned(nextsignal) then nextsignal.prevsignal := self;\r
+  firstsignal := self;\r
+\r
+  //interval := 1000;\r
+  //enabled := true;\r
+  //released := false;\r
+end;\r
+\r
+destructor tlsignal.destroy;\r
+begin\r
+  if prevsignal <> nil then begin\r
+    prevsignal.nextsignal := nextsignal;\r
+  end else begin\r
+    firstsignal := nextsignal;\r
+  end;\r
+  if nextsignal <> nil then begin\r
+    nextsignal.prevsignal := prevsignal;\r
+  end;\r
+  inherited destroy;\r
+end;\r
+{$ifdef linux}\r
+  {$ifdef ver1_9_8}\r
+    {$define needsignalworkaround}\r
+  {$endif}\r
+  {$ifdef ver2_0_0}\r
+    {$define needsignalworkaround}\r
+  {$endif}\r
+  {$ifdef ver2_0_2}\r
+    {$define needsignalworkaround}\r
+  {$endif}\r
+{$endif}\r
+{$ifdef needsignalworkaround}\r
+  //using the 1.9.6 version of this stuff because the 1.9.8 and 2.0.0 versions seem broken\r
+  type\r
+    TSysParam  = Longint;\r
+    TSysResult = longint;\r
+  const\r
+            syscall_nr_sigaction               = 67;\r
+  //function Do_SysCall(sysnr:TSysParam):TSysResult;  {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL0';\r
+  //function Do_SysCall(sysnr,param1:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL1';\r
+  //function Do_SysCall(sysnr,param1,param2:TSysParam):TSysResult;  {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL2';\r
+  function Do_SysCall(sysnr,param1,param2,param3:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL3';\r
+  //function Do_SysCall(sysnr,param1,param2,param3,param4:TSysParam):TSysResult; {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL4';\r
+  //function Do_SysCall(sysnr,param1,param2,param3,param4,param5:TSysParam):TSysResult;  {$ifndef VER1_0} oldfpccall; {$endif} external name 'FPC_SYSCALL5';\r
+\r
+  function Fpsigaction(sig: cint; act : psigactionrec; oact : psigactionrec): cint;// [public, alias : 'FPC_SYSC_SIGACTION'];\r
+  {\r
+    Change action of process upon receipt of a signal.\r
+    Signum specifies the signal (all except SigKill and SigStop).\r
+    If Act is non-nil, it is used to specify the new action.\r
+    If OldAct is non-nil the previous action is saved there.\r
+  }\r
+  begin\r
+  //writeln('fucking');\r
+  {$ifdef RTSIGACTION}\r
+    {$ifdef cpusparc}\r
+      { Sparc has an extra stub parameter }\r
+      Fpsigaction:=do_syscall(syscall_nr_rt_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact),TSysParam(PtrInt(@Fprt_sigreturn_stub)-8),TSysParam(8));\r
+    {$else cpusparc}\r
+      Fpsigaction:=do_syscall(syscall_nr_rt_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact),TSysParam(8));\r
+    {$endif cpusparc}\r
+  {$else RTSIGACTION}\r
+    //writeln('nice');\r
+    Fpsigaction:=do_syscall(syscall_nr_sigaction,TSysParam(sig),TSysParam(act),TSysParam(oact));\r
+  {$endif RTSIGACTION}\r
+  end;\r
+{$endif}\r
+\r
+// cdecl procedures are not name mangled\r
+// so USING something unlikely to cause colliesions in the global namespace\r
+// is a good idea\r
+procedure lsignal_handler( Sig : Integer);cdecl;\r
+var\r
+  currentsignal : tlsignal;\r
+begin\r
+//  writeln('in lsignal_hanler');\r
+  currentsignal := firstsignal;\r
+  while assigned(currentsignal) do begin\r
+    if assigned(currentsignal.onsignal) then currentsignal.onsignal(currentsignal,sig);\r
+    currentsignal := currentsignal.nextsignal;\r
+\r
+  end;\r
+//  writeln('about to send down signalloopback');\r
+  if assigned(signalloopback) then begin\r
+    signalloopback.sendstr(' ');\r
+  end;\r
+//  writeln('left lsignal_hanler');\r
+end;\r
+\r
+{$ifdef freebsd}\r
+\r
+{$if (FPC_VERSION > 2) or ((FPC_VERSION = 2) and (FPC_RELEASE >= 2))}\r
+procedure lsignal_handler2(signal:longint;info:PSigInfo;context:psigcontext); cdecl;\r
+{$else}\r
+procedure lsignal_handler2(signal:longint;var info:TSigInfo_t;var context:SigContextRec); cdecl;\r
+{$endif}\r
+\r
+begin\r
+  lsignal_handler(signal);\r
+end;\r
+{$endif}\r
+\r
+\r
+const\r
+  allbitsset=-1;\r
+  {$ifdef ver1_0}\r
+    saction : sigactionrec = (handler:(sh:lsignal_handler);sa_flags:0);\r
+  {$else}\r
+    {$ifdef darwin}\r
+      saction : sigactionrec = (sa_handler:tsigaction(lsignal_handler);sa_flags:0);\r
+    {$else}\r
+      {$ifdef freebsd}\r
+        //version number is FPC_VERSION.FPC_RELEASE.FPC_PATCH\r
+        {$if (FPC_VERSION>2) or ((FPC_VERSION=2) and (FPC_RELEASE>0)) or ((FPC_VERSION=2) and (fpc_release=0) and (fpc_patch>=2))}\r
+          saction : sigactionrec = (sa_handler:lsignal_handler2;sa_flags:0);\r
+        {$else}\r
+          saction : sigactionrec = (sa_handler:tsigaction(lsignal_handler);sa_flags:0);\r
+        {$endif}\r
+                                                         \r
+      {$else}\r
+        {$ifdef ver1_9_2}\r
+          saction : sigactionrec = (handler:(sh:lsignal_handler);sa_flags:0);\r
+        {$else}\r
+         //version number is FPC_VERSION.FPC_RELEASE.FPC_PATCH\r
+         {$if (FPC_VERSION>2) or ((FPC_VERSION=2) and (FPC_RELEASE>0)) or ((FPC_VERSION=2) and (fpc_release=0) and (fpc_patch>=2))}\r
+           saction : sigactionrec = (sa_handler:{$ifndef ver1_9_6}{$ifndef ver1_9_4}{$ifndef ver1_0}SigActionHandler{$endif}{$endif}{$endif}(lsignal_handler);sa_flags:0;sa_restorer:nil);\r
+         {$else}\r
+            saction : sigactionrec = (sa_handler:{$ifndef ver1_9_6}{$ifndef ver1_9_4}{$ifndef ver1_0}SigActionHandler{$endif}{$endif}{$endif}(lsignal_handler));\r
+         {$endif}\r
+        {$endif}\r
+      {$endif}\r
+    {$endif}\r
+  {$endif}\r
+procedure starthandlesignal(signal:integer);\r
+begin\r
+  if signal in ([0..31]-[sigkill,sigstop]) then begin\r
+    sigprocmask(SIG_BLOCK,@blockset,nil);\r
+    sigaction(signal,@saction,nil)\r
+  end else begin\r
+    raise exception.create('invalid signal number')\r
+  end;\r
+end;\r
+\r
+initialization\r
+  fillchar(blockset,sizeof(blockset),0);\r
+  blockset[0] := $FFFFFFFF - (1 shl sigstop) - (1 shl sigkill) - (1 shl sigsegv);\r
+  {$ifdef ver1_0}
+    saction.sa_mask := blockset[0];
+  {$else}
+    saction.sa_mask := blockset;\r
+  {$endif}\r
+end.\r

diff --git a/lsocket.pas b/lsocket.pas
new file mode 100755 (executable)
index 0000000..58f157d
--- /dev/null
+++ b/lsocket.pas
@@ -0,0 +1,706 @@
+{lsocket.pas}\r
+\r
+{socket code by plugwash}\r
+\r
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+{\r
+changes by plugwash (20030728)\r
+* created handlefdtrigger virtual method in tlasio (overridden in tlsocket) and moved a lot of code from messageloop into it\r
+* changed tlasio to tlasio\r
+* split fdhandle into fdhandlein and fdhandleout\r
+* i now use fdsrmaster and fdswmaster instead of rebuilding the lists every loop\r
+* split lsocket.pas into lsocket.pas and lcore.pas\r
+\r
+\r
+changes by beware (20030903)\r
+* added getxaddr, getxport (local addr, port, as string)\r
+* added getpeername, remote addr+port as binary\r
+* added htons and htonl functions (endian swap, same interface as windows API)\r
+\r
+beware (20030905)\r
+* if connect failed (conn refused) set state to connected and call internalclose, to get closed handler (instead of fdclose)\r
+* (lcore) if closing the fd's in internalcose, set fd's to -1 because closing an fd makes it invalid\r
+\r
+beware (20030927)\r
+* fixed: on connect failed, tried to close fdhandle's which were already set to -1, added check\r
+\r
+beware (20031017)\r
+* added getpeeraddr, getpeerport, remote addr+port as string\r
+}\r
+\r
+\r
+unit lsocket;\r
+{$ifdef fpc}\r
+  {$mode delphi}\r
+{$endif}\r
+interface\r
+  uses\r
+    sysutils,\r
+    {$ifdef win32}\r
+      windows,winsock,\r
+    {$else}\r
+\r
+      {$ifdef VER1_0}\r
+        linux,\r
+      {$else}\r
+        baseunix,unix,unixutil,\r
+      {$endif}\r
+      sockets,\r
+    {$endif}\r
+    classes,{pgdebugout,}pgtypes,lcore,fd_utils,binipstuff,dnssync;\r
+type\r
+  sunB = packed record\r
+    s_b1, s_b2, s_b3, s_b4: byte;\r
+  end;\r
+\r
+  SunW = packed record\r
+    s_w1, s_w2: word;\r
+  end;\r
+\r
+  TInAddr = packed record\r
+    case integer of\r
+      0: (S_un_b: SunB);\r
+      1: (S_un_w: SunW);\r
+      2: (S_addr: cardinal);\r
+  end;\r
+  {$ifdef ipv6}\r
+    {$ifdef ver1_0}\r
+      cuint16=word;\r
+      cuint32=dword;\r
+      sa_family_t=word;\r
+\r
+\r
+      TInetSockAddr6 = packed Record\r
+        sin6_family   : sa_family_t;\r
+        sin6_port     : cuint16;\r
+        sin6_flowinfo : cuint32;\r
+        sin6_addr     : Tin6_addr;\r
+        sin6_scope_id : cuint32;\r
+      end;\r
+    {$endif}\r
+  {$endif}\r
+  TinetSockAddrv = packed record\r
+    case integer of\r
+      0: (InAddr:TInetSockAddr);\r
+      {$ifdef ipv6}\r
+      1: (InAddr6:TInetSockAddr6);\r
+      {$endif}\r
+  end;\r
+  Pinetsockaddrv = ^Tinetsockaddrv;\r
+\r
+\r
+  type\r
+    tsockaddrin=TInetSockAddr;\r
+\r
+  type\r
+    TLsocket = class(tlasio)\r
+    public\r
+      //a: string;\r
+\r
+      inAddr             : TInetSockAddrV;\r
+{      inAddrSize:integer;}\r
+\r
+      //host               : THostentry      ;\r
+\r
+      //mainthread         : boolean         ; //for debuggin only\r
+      addr:string;\r
+      port:string;\r
+      localaddr:string;\r
+      localport:string;\r
+      proto:string;\r
+      udp:boolean;\r
+      listenqueue:integer;\r
+      function getaddrsize:integer;\r
+      procedure connect; virtual;\r
+      procedure bindsocket;\r
+      procedure listen;\r
+      function accept : longint;\r
+      function sendto(dest:TInetSockAddr;destlen:integer;data:pointer;len:integer):integer; virtual;\r
+      function receivefrom(data:pointer;len:integer;var src:TInetSockAddr;var srclen:integer):integer; virtual;\r
+      //procedure internalclose(error:word);override;\r
+      procedure handlefdtrigger(readtrigger,writetrigger:boolean); override;\r
+      function send(data:pointer;len:integer):integer;override;\r
+      procedure sendstr(const str : string);override;\r
+      function Receive(Buf:Pointer;BufSize:integer):integer; override;\r
+      function getpeername(var addr:tsockaddrin;addrlen:integer):integer; virtual;\r
+      procedure getXaddrbin(var binip:tbinip); virtual;\r
+      procedure getpeeraddrbin(var binip:tbinip); virtual;\r
+      function getXaddr:string; virtual;\r
+      function getpeeraddr:string; virtual;\r
+      function getXport:string; virtual;\r
+      function getpeerport:string; virtual;\r
+      constructor Create(AOwner: TComponent); override;\r
+      {$ifdef win32}\r
+        procedure myfdclose(fd : integer); override;\r
+        function myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt; override;\r
+        function myfdread(fd: LongInt;var buf;size: LongInt):LongInt; override;\r
+      {$endif}\r
+    end;\r
+    tsocket=longint; // for compatibility with twsocket\r
+\r
+  twsocket=tlsocket; {easy}\r
+\r
+function htons(w:word):word;\r
+function htonl(i:integer):integer;\r
+{!!!function longipdns(s:string):longint;}\r
+\r
+{$ifdef ipv6}\r
+const\r
+  v4listendefault:boolean=false;\r
+{$endif}\r
+\r
+\r
+const\r
+  TCP_NODELAY=1;\r
+  IPPROTO_TCP=6;\r
+\r
+implementation\r
+{$include unixstuff.inc}\r
+\r
+function longip(s:string):longint;{$ifdef fpc}inline;{$endif}\r
+var\r
+  l:longint;\r
+  a,b:integer;\r
+\r
+function convertbyte(const s:string):integer;{$ifdef fpc}inline;{$endif}\r
+begin\r
+  result := strtointdef(s,-1);\r
+  if result < 0 then exit;\r
+  if result > 255 then exit;\r
+\r
+  {01 exception}\r
+  if (result <> 0) and (s[1] = '0') then begin\r
+    result := -1;\r
+    exit;\r
+  end;\r
+\r
+  {+1 exception}\r
+  if not (s[1] in ['0'..'9']) then begin\r
+    result := -1;\r
+    exit\r
+  end;\r
+end;\r
+\r
+begin\r
+  result := 0;\r
+  a := pos('.',s);\r
+  if a = 0 then exit;\r
+  b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+  l := b shl 24;\r
+  s := copy(s,a+1,256);\r
+  a := pos('.',s);\r
+  if a = 0 then exit;\r
+  b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+  l := l or b shl 16;\r
+  s := copy(s,a+1,256);\r
+  a := pos('.',s);\r
+  if a = 0 then exit;\r
+  b := convertbyte(copy(s,1,a-1));if (b < 0) then exit;\r
+  l := l or b shl 8;\r
+  s := copy(s,a+1,256);\r
+  b := convertbyte(copy(s,1,256));if (b < 0) then exit;\r
+  l := l or b;\r
+  result := l;\r
+end;\r
+\r
+(*!!!\r
+function longipdns(s:string):longint;\r
+var\r
+  host : thostentry;\r
+begin\r
+  if s = '0.0.0.0' then begin\r
+    result := 0;\r
+  end else begin\r
+    result := longip(s);\r
+    if result = 0 then begin\r
+      if gethostbyname(s,host) then begin;\r
+        result := htonl(Longint(Host.Addr));\r
+      end;\r
+      //writeln(inttohex(longint(host.addr),8))\r
+    end;\r
+    if result = 0 then begin\r
+      if resolvehostbyname(s,host) then begin;\r
+        result := htonl(Longint(Host.Addr));\r
+      end;\r
+      //writeln(inttohex(longint(host.addr),8))\r
+    end;\r
+  end;\r
+end;\r
+*)\r
+\r
+\r
+function htons(w:word):word;\r
+begin\r
+  {$ifndef ENDIAN_BIG}\r
+  result := ((w and $ff00) shr 8) or ((w and $ff) shl 8);\r
+  {$else}\r
+  result := w;\r
+  {$endif}\r
+end;\r
+\r
+function htonl(i:integer):integer;\r
+begin\r
+  {$ifndef ENDIAN_BIG}\r
+  result := (i shr 24) or (i shr 8 and $ff00) or (i shl 8 and $ff0000) or (i shl 24 and $ff000000);\r
+  {$else}\r
+  result := i;\r
+  {$endif}\r
+end;\r
+\r
+function tlsocket.getaddrsize:integer;\r
+begin\r
+  {$ifdef ipv6}\r
+  if inaddr.inaddr.family = AF_INET6 then result := sizeof(tinetsockaddr6) else\r
+  {$endif}\r
+  result := sizeof(tinetsockaddr);\r
+end;\r
+\r
+function makeinaddrv(addr,port:string;var inaddr:tinetsockaddrv):integer;\r
+var\r
+  biniptemp:tbinip;\r
+begin\r
+  result := 0;\r
+  biniptemp := forwardlookup(addr,10);\r
+  fillchar(inaddr,sizeof(inaddr),0);\r
+  //writeln('converted address '+addr+' to binip '+ipbintostr(biniptemp));\r
+  if biniptemp.family = AF_INET then begin\r
+    inAddr.InAddr.family:=AF_INET;\r
+    inAddr.InAddr.port:=htons(strtointdef(port,0));\r
+    inAddr.InAddr.addr:=biniptemp.ip;\r
+    result := sizeof(tinetsockaddr);\r
+  end else\r
+  {$ifdef ipv6}\r
+  if biniptemp.family = AF_INET6 then begin\r
+    inAddr.InAddr6.sin6_family:=AF_INET6;\r
+    inAddr.InAddr6.sin6_port:=htons(strtointdef(port,0));\r
+    inAddr.InAddr6.sin6_addr:=biniptemp.ip6;\r
+    result := sizeof(tinetsockaddr6);\r
+  end else\r
+  {$endif}\r
+  raise esocketexception.create('unable to resolve address: '+addr);\r
+end;\r
+\r
+procedure tlsocket.connect;\r
+var\r
+  a:integer;\r
+begin\r
+  if state <> wsclosed then close;\r
+  //prevtime := 0;\r
+  makeinaddrv(addr,port,inaddr);\r
+\r
+  udp := uppercase(proto) = 'UDP';\r
+  if udp then a := SOCK_DGRAM else a := SOCK_STREAM;\r
+  a := Socket(inaddr.inaddr.family,a,0);\r
+\r
+  //writeln(ord(inaddr.inaddr.family));\r
+  if a = -1 then begin\r
+    lasterror := {$ifdef win32}getlasterror{$else}socketerror{$endif};\r
+    raise esocketexception.create('unable to create socket');\r
+  end;\r
+  try\r
+    dup(a);\r
+    bindsocket;\r
+    if udp then begin\r
+      {$ifndef win32}\r
+        SetSocketOptions(fdhandleout, SOL_SOCKET, SO_BROADCAST, 'TRUE', Length('TRUE'));\r
+      {$endif}\r
+      state := wsconnected;\r
+      if assigned(onsessionconnected) then onsessionconnected(self,0);\r
+    end else begin\r
+      state :=wsconnecting;\r
+      {$ifdef win32}\r
+        //writeln(inaddr.inaddr.port);\r
+        winsock.Connect(fdhandlein,winsock.psockaddr(@inADDR)^,getaddrsize);\r
+      {$else}\r
+        sockets.Connect(fdhandlein,inADDR,getaddrsize);\r
+      {$endif}\r
+    end;\r
+    eventcore.rmasterset(fdhandlein,false);\r
+    if udp then begin\r
+      eventcore.wmasterclr(fdhandleout);\r
+    end else begin\r
+      eventcore.wmasterset(fdhandleout);\r
+    end;\r
+    //sendq := '';\r
+  except\r
+    on e: exception do begin\r
+      fdcleanup;\r
+      raise; //reraise the exception\r
+    end;\r
+  end;\r
+end;\r
+\r
+procedure tlsocket.sendstr(const str : string);\r
+begin\r
+  if udp then begin\r
+    send(@str[1],length(str))\r
+  end else begin\r
+    inherited sendstr(str);\r
+  end;\r
+end;\r
+\r
+function tlsocket.send(data:pointer;len:integer):integer;\r
+begin\r
+  if udp then begin\r
+    //writeln('sending to '+inttohex(inaddr.inaddr.addr,8));\r
+    result := sendto(inaddr.inaddr,getaddrsize,data,len)\r
+;\r
+    //writeln('send result',result);\r
+    //writeln('errno',errno);\r
+  end else begin\r
+    result := inherited send(data,len);\r
+  end;\r
+end;\r
+\r
+\r
+function tlsocket.receive(Buf:Pointer;BufSize:integer):integer;\r
+begin\r
+  if udp then begin\r
+    result := myfdread(self.fdhandlein,buf^,bufsize);\r
+  end else begin\r
+    result := inherited receive(buf,bufsize);\r
+  end;\r
+end;\r
+\r
+procedure tlsocket.bindsocket;\r
+var\r
+  a:integer;\r
+  inAddrtemp:TInetSockAddrV;\r
+  inAddrtempx:{$ifdef win32}winsock.TSockaddr{$else}TInetSockAddrV{$endif} absolute inaddrtemp;\r
+  inaddrtempsize:integer;\r
+begin\r
+  try\r
+    if (localaddr <> '') or (localport <> '') then begin\r
+      if localaddr = '' then begin\r
+        {$ifdef ipv6}\r
+        if inaddr.inaddr.family = AF_INET6 then localaddr := '::' else\r
+        {$endif}\r
+        localaddr := '0.0.0.0';\r
+      end;\r
+      //gethostbyname(localaddr,host);\r
+\r
+      inaddrtempsize := makeinaddrv(localaddr,localport,inaddrtemp);\r
+\r
+      If Bind(fdhandlein,inaddrtempx,inaddrtempsize)<> {$ifdef win32}0{$else}true{$endif} Then begin\r
+        state := wsclosed;\r
+        lasterror := {$ifdef win32}getlasterror{$else}socketerror{$endif};\r
+        raise ESocketException.create('unable to bind, error '+inttostr(lasterror));\r
+      end;\r
+      state := wsbound;\r
+    end;\r
+  except\r
+    on e: exception do begin\r
+      fdcleanup;\r
+      raise; //reraise the exception\r
+    end;\r
+  end;\r
+end;\r
+\r
+procedure tlsocket.listen;\r
+var\r
+  yes:longint;\r
+  socktype:integer;\r
+  biniptemp:tbinip;\r
+  origaddr:string;\r
+begin\r
+  if state <> wsclosed then close;\r
+  udp := uppercase(proto) = 'UDP';\r
+  if udp then socktype := SOCK_DGRAM else socktype := SOCK_STREAM;\r
+  origaddr := addr;\r
+\r
+  if addr = '' then begin\r
+    {$ifdef ipv6}\r
+    if not v4listendefault then begin\r
+      addr := '::';\r
+    end else\r
+    {$endif}\r
+    addr := '0.0.0.0';\r
+  end;\r
+  biniptemp := forwardlookup(addr,10);\r
+  addr := ipbintostr(biniptemp);\r
+  fdhandlein := socket(biniptemp.family,socktype,0);\r
+  {$ifdef ipv6}\r
+  if (addr = '::') and (origaddr = '') and (fdhandlein < 0) then begin\r
+    addr := '0.0.0.0';\r
+    fdhandlein := socket(AF_INET,socktype,0);\r
+  end;\r
+  {$endif}\r
+  if fdhandlein = -1 then raise ESocketException.create('unable to create socket');\r
+  dupnowatch(fdhandlein); // sets up maxs and copies handle to fdhandleout among other things\r
+  //eventcore.setfdreverse(fdhandlein,self); //already taken care of by dup\r
+  state := wsclosed; // then set this back as it was an undesired side effect of dup\r
+\r
+  try\r
+    yes := $01010101;  {Copied this from existing code. Value is empiric,\r
+                    but works. (yes=true<>0) }\r
+    {$ifndef win32}\r
+      if SetSocketOptions(fdhandlein, SOL_SOCKET, SO_REUSEADDR,yes,sizeof(yes))=-1 then begin\r
+        raise ESocketException.create('unable to set socket options');\r
+      end;\r
+    {$endif}\r
+    localaddr := addr;\r
+    localport := port;\r
+    bindsocket;\r
+\r
+    if not udp then begin\r
+      {!!! allow custom queue length? default 5}\r
+      if listenqueue = 0 then listenqueue := 5;\r
+      If {$ifdef win32}winsock{$else}sockets{$endif}.Listen(fdhandlein,listenqueue)<>{$ifdef win32}0{$else}true{$endif} Then raise esocketexception.create('unable to listen');\r
+      state := wsListening;\r
+    end else begin\r
+      {$ifndef win32}\r
+        SetSocketOptions(fdhandleout, SOL_SOCKET, SO_BROADCAST, 'TRUE', Length('TRUE'));\r
+      {$endif}\r
+      state := wsconnected;\r
+    end;\r
+  finally\r
+    if state = wsclosed then begin\r
+      if fdhandlein >= 0 then begin\r
+        {one *can* get here without fd -beware}\r
+        eventcore.rmasterclr(fdhandlein);\r
+        myfdclose(fdhandlein); // we musnt leak file discriptors\r
+        eventcore.setfdreverse(fdhandlein,nil);\r
+        fdhandlein := -1;\r
+      end;\r
+    end else begin\r
+      eventcore.rmasterset(fdhandlein,true);\r
+    end;\r
+    if fdhandleout >= 0 then eventcore.wmasterclr(fdhandleout);\r
+  end;\r
+  //writeln('listened on addr '+addr+':'+port+' '+proto+' using socket number ',fdhandlein); \r
+end;\r
+\r
+function tlsocket.accept : longint;\r
+var\r
+  FromAddrSize     : LongInt;        // i don't realy know what to do with these at this\r
+  FromAddr         : TInetSockAddrV;  // at this point time will tell :)\r
+begin\r
+\r
+  FromAddrSize := Sizeof(FromAddr);\r
+  {$ifdef win32}\r
+    result := winsock.accept(fdhandlein,@fromaddr,@fromaddrsize);\r
+  {$else}\r
+    result := sockets.accept(fdhandlein,fromaddr,fromaddrsize);\r
+  {$endif}\r
+  //now we have accepted one request start monitoring for more again\r
+  eventcore.rmasterset(fdhandlein,true);\r
+\r
+  if result = -1 then raise esocketexception.create('error '+inttostr({$ifdef win32}getlasterror{$else}socketerror{$endif})+' while accepting');\r
+  if result > absoloutemaxs then begin\r
+    myfdclose(result);\r
+    result := -1;\r
+    raise esocketexception.create('file discriptor out of range');\r
+  end;\r
+end;\r
+\r
+function tlsocket.sendto(dest:TInetSockAddr;destlen:integer;data:pointer;len:integer):integer;\r
+var\r
+  destx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddr{$endif} absolute dest;\r
+begin\r
+  result := {$ifdef win32}winsock{$else}sockets{$endif}.sendto(self.fdhandleout,data^,len,0,destx,destlen);\r
+end;\r
+\r
+function tlsocket.receivefrom(data:pointer;len:integer;var src:TInetSockAddr;var srclen:integer):integer;\r
+var\r
+  srcx : {$ifdef win32}winsock.TSockAddr{$else}TInetSockAddr{$endif} absolute src;\r
+begin\r
+  result := {$ifdef win32}winsock{$else}sockets{$endif}.recvfrom(self.fdhandlein,data^,len,0,srcx,srclen);\r
+end;\r
+\r
+procedure tlsocket.handlefdtrigger(readtrigger,writetrigger:boolean);\r
+var\r
+  tempbuf:array[0..receivebufsize-1] of byte;\r
+begin\r
+  //writeln('got a fd trigger, readtrigger=',readtrigger,' writetrigger=',writetrigger);\r
+  if (state =wslistening) and readtrigger then begin\r
+{    debugout('listening socket triggered on read');}\r
+    eventcore.rmasterclr(fdhandlein);\r
+    if assigned(onsessionAvailable) then onsessionAvailable(self,0);\r
+  end;\r
+  if udp and readtrigger then begin\r
+    if assigned(ondataAvailable) then ondataAvailable(self,0);\r
+    {!!!test}\r
+    exit;\r
+  end;\r
+  if (state =wsconnecting) and writetrigger then begin\r
+    // code for dealing with the reults of a non-blocking connect is\r
+    // rather complex\r
+    // if just write is triggered it means connect suceeded\r
+    // if both read and write are triggered it can mean 2 things\r
+    // 1: connect ok and data availible\r
+    // 2: connect fail\r
+    // to find out which you must read from the socket and look for errors\r
+    // there if we read successfully we drop through into the code for fireing\r
+    // the read event\r
+    if not readtrigger then begin\r
+      state := wsconnected;\r
+      if assigned(onsessionconnected) then onsessionconnected(self,0);\r
+    end else begin\r
+      numread := myfdread(fdhandlein,tempbuf,sizeof(tempbuf));\r
+      if numread <> -1 then begin\r
+        state := wsconnected;\r
+        if assigned(onsessionconnected) then onsessionconnected(self,0);\r
+        //connectread := true;\r
+        recvq.add(@tempbuf,numread);\r
+      end else begin\r
+        state := wsconnected;\r
+        if assigned(onsessionconnected) then onsessionconnected(self,{$ifdef win32}wsagetlasterror{$else}linuxerror{$endif});\r
+{        debugout('connect fail');}\r
+        self.internalclose(0);\r
+        recvq.del(maxlongint);\r
+      end;\r
+      // if things went well here we are now in the state wsconnected with data sitting in our receive buffer\r
+      // so we drop down into the processing for data availible\r
+    end;\r
+    if fdhandlein >= 0 then begin\r
+      if state = wsconnected then begin\r
+        eventcore.rmasterset(fdhandlein,false);\r
+      end else begin\r
+        eventcore.rmasterclr(fdhandlein);\r
+      end;\r
+    end;\r
+    if fdhandleout >= 0 then begin\r
+      if sendq.size = 0 then begin\r
+        //don't clear the bit in fdswmaster if data is in the sendq\r
+        eventcore.wmasterclr(fdhandleout);\r
+      end;\r
+    end;\r
+\r
+  end;\r
+  inherited handlefdtrigger(readtrigger,writetrigger);\r
+end;\r
+\r
+constructor tlsocket.Create(AOwner: TComponent);\r
+begin\r
+  inherited create(aowner);\r
+  closehandles := true;\r
+end;\r
+\r
+\r
+function tlsocket.getpeername(var addr:tsockaddrin;addrlen:integer):integer;\r
+var\r
+  addrx : {$ifdef win32}winsock.tsockaddr{$else}tsockaddrin{$endif} absolute addr;\r
+begin\r
+  result := {$ifdef win32}winsock{$else}sockets{$endif}.getpeername(self.fdhandlein,addrx,addrlen);\r
+end;\r
+\r
+procedure tlsocket.getxaddrbin(var binip:tbinip);\r
+var\r
+  addr:tinetsockaddrv;\r
+  i:integer;\r
+begin\r
+  i := sizeof(addr);\r
+  fillchar(addr,sizeof(addr),0);\r
+\r
+  {$ifdef win32}\r
+    winsock.getsockname(self.fdhandlein,psockaddr(@addr)^,i);\r
+  {$else}\r
+    sockets.getsocketname(self.fdhandlein,addr,i);\r
+  {$endif}\r
+  binip.family := addr.inaddr.family;\r
+  {$ifdef ipv6}\r
+  if addr.inaddr6.sin6_family = AF_INET6 then begin\r
+    binip.ip6 := addr.inaddr6.sin6_addr;\r
+  end else\r
+  {$endif}\r
+  begin\r
+    binip.ip := addr.inaddr.addr;\r
+  end;\r
+  converttov4(binip);\r
+end;\r
+\r
+procedure tlsocket.getpeeraddrbin(var binip:tbinip);\r
+var\r
+  addr:tinetsockaddrv;\r
+  i:integer;\r
+begin\r
+  i := sizeof(addr);\r
+  fillchar(addr,sizeof(addr),0);\r
+  {$ifdef win32}\r
+    winsock.getpeername(self.fdhandlein,psockaddr(@addr)^,i);\r
+  {$else}\r
+    sockets.getpeername(self.fdhandlein,addr,i);\r
+  {$endif}\r
+\r
+  binip.family := addr.inaddr.family;\r
+  {$ifdef ipv6}\r
+  if addr.inaddr6.sin6_family = AF_INET6 then begin\r
+    binip.ip6 := addr.inaddr6.sin6_addr;\r
+  end else\r
+  {$endif}\r
+  begin\r
+    binip.ip := addr.inaddr.addr;\r
+  end;\r
+  converttov4(binip);\r
+end;\r
+\r
+function tlsocket.getXaddr:string;\r
+var\r
+  biniptemp:tbinip;\r
+begin\r
+  getxaddrbin(biniptemp);\r
+  result := ipbintostr(biniptemp);\r
+  if result = '' then result := 'error';\r
+end;\r
+\r
+function tlsocket.getpeeraddr:string;\r
+var\r
+  biniptemp:tbinip;\r
+begin\r
+  getpeeraddrbin(biniptemp);\r
+  result := ipbintostr(biniptemp);\r
+  if result = '' then result := 'error';\r
+end;\r
+\r
+function tlsocket.getXport:string;\r
+var\r
+  addr:tinetsockaddrv;\r
+  i:integer;\r
+begin\r
+  i := sizeof(addr);\r
+  {$ifdef win32}\r
+    winsock.getsockname(self.fdhandlein,psockaddrin(@addr)^,i);\r
+\r
+  {$else}\r
+    sockets.getsocketname(self.fdhandlein,addr,i);\r
+\r
+  {$endif}\r
+  result := inttostr(htons(addr.InAddr.port));\r
+end;\r
+\r
+function tlsocket.getpeerport:string;\r
+var\r
+  addr:tinetsockaddrv;\r
+  i:integer;\r
+begin\r
+  i := sizeof(addr);\r
+  {$ifdef win32}\r
+    winsock.getpeername(self.fdhandlein,psockaddrin(@addr)^,i);\r
+\r
+  {$else}\r
+    sockets.getpeername(self.fdhandlein,addr,i);\r
+\r
+  {$endif}\r
+  result := inttostr(htons(addr.InAddr.port));\r
+end;\r
+\r
+{$ifdef win32}\r
+  procedure tlsocket.myfdclose(fd : integer);\r
+  begin\r
+    closesocket(fd);\r
+  end;\r
+  function tlsocket.myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt;\r
+  begin\r
+    result := winsock.send(fd,(@buf)^,size,0);\r
+  end;\r
+  function tlsocket.myfdread(fd: LongInt;var buf;size: LongInt):LongInt;\r
+  begin\r
+    result := winsock.recv(fd,buf,size,0);\r
+  end;\r
+{$endif}\r
+
+end.\r
+\r

diff --git a/ltimevalstuff.inc b/ltimevalstuff.inc
new file mode 100755 (executable)
index 0000000..0ac92cb
--- /dev/null
+++ b/ltimevalstuff.inc
@@ -0,0 +1,42 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+\r
+\r
+\r
+{add nn msec to tv}\r
+const\r
+  tv_invalidtimebig : ttimeval = (tv_sec:maxlongint;tv_usec:maxlongint);\r
+  //tv_invalidtimebig will always compare as greater than any valid timeval\r
+procedure tv_add(var tv:ttimeval;msec:integer);//{ $ifdef fpc}inline;{ $endif}\r
+begin\r
+  inc(tv.tv_usec,msec*1000);\r
+  inc(tv.tv_sec,tv.tv_usec div 1000000);\r
+  tv.tv_usec := tv.tv_usec mod 1000000;\r
+end;\r
+\r
+{tv1 >= tv2}\r
+function tv_compare(const tv1,tv2:ttimeval):boolean;//{ $ifdef fpc}inline;{ $endif}\r
+begin\r
+  if tv1.tv_sec = tv2.tv_sec then begin\r
+    result := tv1.tv_usec >= tv2.tv_usec;\r
+  end else result := tv1.tv_sec > tv2.tv_sec;\r
+end;\r
+\r
+procedure tv_substract(var tv:ttimeval;const tv2:ttimeval);//{ $ifdef fpc}inline;{ $endif}\r
+begin\r
+  dec(tv.tv_usec,tv2.tv_usec);\r
+  if tv.tv_usec < 0 then begin\r
+    inc(tv.tv_usec,1000000);\r
+    dec(tv.tv_sec)\r
+  end;\r
+  dec(tv.tv_sec,tv2.tv_sec);\r
+end;\r
+\r
+procedure msectotimeval(var tv:ttimeval;msec:integer);\r
+begin\r
+  tv.tv_sec := msec div 1000;\r
+  tv.tv_usec := (msec mod 1000)*1000;\r
+end;\r
+\r

diff --git a/pgtypes.pas b/pgtypes.pas
new file mode 100755 (executable)
index 0000000..3c48e26
--- /dev/null
+++ b/pgtypes.pas
@@ -0,0 +1,20 @@
+{io core originally for linux bworld}\r
+\r
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+\r
+unit pgtypes;\r
+interface\r
+  type\r
+    {$ifdef cpu386}{$define i386}{$endif}\r
+    {$ifdef i386}\r
+      taddrint=longint;\r
+    {$else}\r
+      taddrint=sizeint;\r
+    {$endif}\r
+    paddrint=^taddrint;\r
+\r
+implementation\r
+end.\r

diff --git a/svn-commit.2.tmp b/svn-commit.2.tmp
new file mode 100755 (executable)
index 0000000..82b4cd3
--- /dev/null
+++ b/svn-commit.2.tmp
@@ -0,0 +1,4 @@
+initial import
+--This line, and those below, will be ignored--
+
+A    .

diff --git a/svn-commit.3.tmp b/svn-commit.3.tmp
new file mode 100755 (executable)
index 0000000..82b4cd3
--- /dev/null
+++ b/svn-commit.3.tmp
@@ -0,0 +1,4 @@
+initial import
+--This line, and those below, will be ignored--
+
+A    .

diff --git a/svn-commit.4.tmp b/svn-commit.4.tmp
new file mode 100755 (executable)
index 0000000..6588c17
--- /dev/null
+++ b/svn-commit.4.tmp
@@ -0,0 +1,4 @@
+create directory
+--This line, and those below, will be ignored--
+
+A    svn+ssh://p10link/svnroot/lcore/trunk

diff --git a/svn-commit.5.tmp b/svn-commit.5.tmp
new file mode 100755 (executable)
index 0000000..82b4cd3
--- /dev/null
+++ b/svn-commit.5.tmp
@@ -0,0 +1,4 @@
+initial import
+--This line, and those below, will be ignored--
+
+A    .

diff --git a/svn-commit.tmp b/svn-commit.tmp
new file mode 100755 (executable)
index 0000000..82b4cd3
--- /dev/null
+++ b/svn-commit.tmp
@@ -0,0 +1,4 @@
+initial import
+--This line, and those below, will be ignored--
+
+A    .

diff --git a/uint32.inc b/uint32.inc
new file mode 100755 (executable)
index 0000000..897db79
--- /dev/null
+++ b/uint32.inc
@@ -0,0 +1,14 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green
+  For conditions of distribution and use, see copyright notice in zlib_license.txt
+  which is included in the package
+  ----------------------------------------------------------------------------- }\r
+type\r
+  {delphi 3 and before do not have a 32 bits unsigned integer type,\r
+  but longint has the correct behavior - it doesn't on newer delphi versions}\r
+  {$ifndef fpc}\r
+    {$ifdef ver70}{$define pred4}{$endif} {tp7}\r
+    {$ifdef ver80}{$define pred4}{$endif} {delphi 1}\r
+    {$ifdef ver90}{$define pred4}{$endif} {delphi 2}\r
+    {$ifdef ver100}{$define pred4}{$endif} {delphi 3}\r
+  {$endif}\r
+  uint32={$ifdef pred4}longint{$else}longword{$endif};\r

diff --git a/unixstuff.inc b/unixstuff.inc
new file mode 100755 (executable)
index 0000000..76a7f52
--- /dev/null
+++ b/unixstuff.inc
@@ -0,0 +1,76 @@
+{$ifdef UNIX}\r
+  {$macro on}\r
+  {$ifdef VER1_0}\r
+    {$define tv_sec := sec}\r
+    {$define tv_usec := usec}\r
+    function dup(const original:integer):integer;inline;\r
+    begin\r
+      linux.dup(original,result);\r
+    end;\r
+    {$define gettimeofdaysec := gettimeofday}\r
+  {$else}\r
+    \r
+    {$define sigprocmask := fpsigprocmask}\r
+    {$define sigaction   := fpsigaction}\r
+    {$define fdclose     := fpclose}\r
+    {$define fcntl       := fpfcntl}\r
+    {$define fdwrite     := fpwrite}\r
+    {$define fdread      := fpread}\r
+    {$define fdopen      := fpopen}\r
+    {$define select      := fpselect}\r
+    {$define linuxerror  := fpgeterrno}\r
+    {$define fork        := fpfork}\r
+    {$define getpid      := fpgetpid}\r
+    {$define getenv      := fpgetenv}\r
+    {$define chmod       := fpchmod}\r
+    {$define dup2        := fpdup2}\r
+    {$ifndef ver1_9_2}\r
+      {$define flock     := fpflock}\r
+      {$ifndef ver1_9_4}
+        procedure Execl(Todo:string);inline;
+       var
+         p : ppchar;
+       begin
+         p := unixutil.StringToPPChar(Todo,1);
+         if (p=nil) or (p^=nil) then exit;
+         fpexecv(p^,p);
+       end;
+      {$endif}
+    {$endif}\r
+    procedure gettimeofday(var tv:ttimeval);inline;\r
+    begin\r
+      fpgettimeofday(@tv,nil);    \r
+    end;\r
+    function gettimeofdaysec : longint;\r
+    var\r
+      tv:ttimeval;\r
+    begin\r
+      gettimeofday(tv);\r
+      result := tv.tv_sec;\r
+    end;\r
+\r
+    //a function is used here rather than a define to prevent issues with tlasio.dup\r
+    function dup(const original:integer):integer;inline;\r
+    begin\r
+      result := fpdup(original);\r
+    end;\r
+    function octal(invalue:longint):longint;\r
+    var\r
+      a : integer;\r
+      i : integer;\r
+    begin\r
+      i := 0;\r
+      result := 0;\r
+      while invalue <> 0 do begin\r
+        a := invalue mod 10;\r
+        result := result + (a shl (i*3));\r
+\r
+        invalue := invalue div 10;\r
+        inc(i);\r
+      end;\r
+    end;\r
+    const\r
+      sys_eintr=esyseintr;\r
+\r
+  {$endif}\r
+{$endif}\r

diff --git a/wcore.pas b/wcore.pas
new file mode 100755 (executable)
index 0000000..40505ef
--- /dev/null
+++ b/wcore.pas
@@ -0,0 +1,372 @@
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+  For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+  which is included in the package\r
+  ----------------------------------------------------------------------------- }\r
+\r
+unit wcore;\r
+\r
+{\r
+lcore compatible interface for windows\r
+\r
+- messageloop\r
+\r
+- tltimer\r
+\r
+}\r
+//note: events after release are normal and are the apps responsibility to deal with safely\r
+interface\r
+\r
+  uses\r
+    classes,windows,mmsystem;\r
+\r
+  type\r
+    float=double;\r
+\r
+    tlcomponent = class(tcomponent)\r
+    public\r
+      released:boolean;\r
+      procedure release;\r
+      destructor destroy; override;\r
+    end;\r
+\r
+    tltimer=class(tlcomponent)\r
+    public\r
+      ontimer:tnotifyevent;\r
+      initialevent:boolean;\r
+      initialdone:boolean;\r
+      prevtimer:tltimer;\r
+      nexttimer:tltimer;\r
+      interval:integer;        {miliseconds, default 1000}\r
+      enabled:boolean;\r
+      nextts:integer;\r
+      constructor create(aowner:tcomponent);override;\r
+      destructor destroy;override;\r
+    end;\r
+\r
+    ttaskevent=procedure(wparam,lparam:longint) of object;\r
+\r
+    tltask=class(tobject)\r
+    public\r
+      handler  : ttaskevent;\r
+      obj      : tobject;\r
+      wparam   : longint;\r
+      lparam   : longint;\r
+      nexttask : tltask;\r
+      constructor create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+    end;\r
+\r
+procedure messageloop;\r
+procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+procedure disconnecttasks(aobj:tobject);\r
+procedure exitmessageloop;\r
+procedure processmessages;\r
+\r
+var\r
+  onshutdown:procedure(s:string);\r
+\r
+implementation\r
+\r
+uses\r
+  {$ifdef fpc}\r
+  bmessages;\r
+  {$else}\r
+  messages;\r
+  {$endif}\r
+\r
+\r
+const\r
+  WINMSG_TASK=WM_USER;\r
+\r
+var\r
+  hwndwcore:hwnd;\r
+  firsttimer:tltimer;\r
+  timesubstract:integer;\r
+  firsttask,lasttask,currenttask:tltask;\r
+\r
+procedure tlcomponent.release;\r
+begin\r
+  released := true;\r
+end;\r
+\r
+destructor tlcomponent.destroy;\r
+begin\r
+  disconnecttasks(self);\r
+  inherited destroy;\r
+end;\r
+\r
+{------------------------------------------------------------------------------}\r
+\r
+constructor tltimer.create;\r
+begin\r
+  inherited create(AOwner);\r
+  nexttimer := firsttimer;\r
+  prevtimer := nil;\r
+\r
+  if assigned(nexttimer) then nexttimer.prevtimer := self;\r
+  firsttimer := self;\r
+\r
+  interval := 1000;\r
+  enabled := true;\r
+  released := false;\r
+end;\r
+\r
+destructor tltimer.destroy;\r
+begin\r
+  if prevtimer <> nil then begin\r
+    prevtimer.nexttimer := nexttimer;\r
+  end else begin\r
+    firsttimer := nexttimer;\r
+  end;\r
+  if nexttimer <> nil then begin\r
+    nexttimer.prevtimer := prevtimer;\r
+  end;\r
+  inherited destroy;\r
+end;\r
+\r
+{------------------------------------------------------------------------------}\r
+\r
+function wcore_timehandler:integer;\r
+const\r
+  rollover_bits=30;\r
+var\r
+  tv,tvnow:integer;\r
+  currenttimer,temptimer:tltimer;\r
+begin\r
+  if not assigned(firsttimer) then begin\r
+    result := 1000;\r
+    exit;\r
+  end;\r
+\r
+  tvnow := timegettime;\r
+  if (tvnow and ((-1) shl rollover_bits)) <> timesubstract then begin\r
+    currenttimer := firsttimer;\r
+    while assigned(currenttimer) do begin\r
+      dec(currenttimer.nextts,(1 shl rollover_bits));\r
+      currenttimer := currenttimer.nexttimer;\r
+    end;\r
+    timesubstract := tvnow and ((-1) shl rollover_bits);\r
+  end;\r
+  tvnow := tvnow and ((1 shl rollover_bits)-1);\r
+\r
+  currenttimer := firsttimer;\r
+  while assigned(currenttimer) do begin\r
+    if tvnow >= currenttimer.nextts then begin\r
+      if assigned(currenttimer.ontimer) then begin\r
+        if currenttimer.enabled then begin\r
+          if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer);\r
+          currenttimer.initialdone := true;\r
+        end;\r
+      end;\r
+      currenttimer.nextts := tvnow+currenttimer.interval;\r
+    end;\r
+    temptimer := currenttimer;\r
+    currenttimer := currenttimer.nexttimer;\r
+    if temptimer.released then temptimer.free;\r
+  end;\r
+\r
+  tv := maxlongint;\r
+  currenttimer := firsttimer;\r
+  while assigned(currenttimer) do begin\r
+    if currenttimer.nextts < tv then tv := currenttimer.nextts;\r
+    currenttimer := currenttimer.nexttimer;\r
+  end;\r
+  result := tv-tvnow;\r
+  if result < 15 then result := 15;\r
+end;\r
+\r
+{------------------------------------------------------------------------------}\r
+\r
+constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+  inherited create;\r
+  handler   := ahandler;\r
+  obj       := aobj;\r
+  wparam    := awparam;\r
+  lparam    := alparam;\r
+  {nexttask  := firsttask;\r
+  firsttask := self;}\r
+  if assigned(lasttask) then begin\r
+    lasttask.nexttask := self;\r
+  end else begin\r
+    firsttask := self;\r
+    postmessage(hwndwcore,WINMSG_TASK,0,0);\r
+  end;\r
+  lasttask := self;\r
+  //ahandler(wparam,lparam);\r
+end;\r
+\r
+procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
+begin\r
+  tltask.create(ahandler,aobj,awparam,alparam);\r
+end;\r
+\r
+procedure disconnecttasks(aobj:tobject);\r
+var\r
+  currenttasklocal : tltask ;\r
+  counter          : byte   ;\r
+begin\r
+  for counter := 0 to 1 do begin\r
+    if counter = 0 then begin\r
+      currenttasklocal := firsttask; //main list of tasks\r
+    end else begin\r
+      currenttasklocal := currenttask; //needed in case called from a task\r
+    end;\r
+    // note i don't bother to sestroy the links here as that will happen when\r
+    // the list of tasks is processed anyway\r
+    while assigned(currenttasklocal) do begin\r
+      if currenttasklocal.obj = aobj then begin\r
+        currenttasklocal.obj := nil;\r
+        currenttasklocal.handler := nil;\r
+      end;\r
+      currenttasklocal := currenttasklocal.nexttask;\r
+    end;\r
+  end;\r
+end;\r
+\r
+procedure dotasks;\r
+var\r
+  temptask:tltask;\r
+begin\r
+  if firsttask = nil then exit;\r
+\r
+  currenttask := firsttask;\r
+  firsttask := nil;\r
+  lasttask  := nil;\r
+  while assigned(currenttask) do begin\r
+    if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam);\r
+    temptask := currenttask;\r
+    currenttask := currenttask.nexttask;\r
+    temptask.free;\r
+  end;\r
+  currenttask := nil;\r
+end;\r
+\r
+{------------------------------------------------------------------------------}\r
+\r
+procedure exitmessageloop;\r
+begin\r
+  postmessage(hwndwcore,WM_QUIT,0,0);\r
+end;\r
+\r
+  {$ifdef threadtimer}\r
+  'thread timer'\r
+  {$else}\r
+const timerid_wcore=$1000;\r
+  {$endif}\r
+\r
+function MyWindowProc(\r
+    ahWnd   : HWND;\r
+    auMsg   : Integer;\r
+    awParam : WPARAM;\r
+    alParam : LPARAM): Integer; stdcall;\r
+var\r
+    MsgRec : TMessage;\r
+    a:integer;\r
+begin\r
+  Result := 0;  // This means we handled the message\r
+\r
+  {MsgRec.hwnd    := ahWnd;}\r
+  MsgRec.wParam  := awParam;\r
+  MsgRec.lParam  := alParam;\r
+\r
+  dotasks;\r
+  case auMsg of\r
+    {$ifndef threadtimer}\r
+    WM_TIMER: begin\r
+      if msgrec.wparam = timerid_wcore then begin\r
+        a := wcore_timehandler;\r
+        killtimer(hwndwcore,timerid_wcore);\r
+        settimer(hwndwcore,timerid_wcore,a,nil);\r
+      end;\r
+    end;\r
+    {$endif}\r
+\r
+    {WINMSG_TASK:dotasks;}\r
+\r
+    WM_CLOSE: begin\r
+      {}\r
+    end;\r
+    WM_DESTROY: begin\r
+      {}\r
+    end;\r
+  else\r
+      Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)\r
+  end;\r
+end;\r
+\r
+\r
+var\r
+  MyWindowClass : TWndClass = (style         : 0;\r
+                                 lpfnWndProc   : @MyWindowProc;\r
+                                 cbClsExtra    : 0;\r
+                                 cbWndExtra    : 0;\r
+                                 hInstance     : 0;\r
+                                 hIcon         : 0;\r
+                                 hCursor       : 0;\r
+                                 hbrBackground : 0;\r
+                                 lpszMenuName  : nil;\r
+                                 lpszClassName : 'wcoreClass');\r
+\r
+procedure messageloop;\r
+var\r
+  MsgRec : TMsg;\r
+begin\r
+\r
+  if Windows.RegisterClass(MyWindowClass) = 0 then halt;\r
+  //writeln('about to create wcore handle, hinstance=',hinstance);\r
+  hwndwcore := CreateWindowEx(WS_EX_TOOLWINDOW,\r
+                               MyWindowClass.lpszClassName,\r
+                               '',        { Window name   }\r
+                               WS_POPUP,  { Window Style  }\r
+                               0, 0,      { X, Y          }\r
+                               0, 0,      { Width, Height }\r
+                               0,         { hWndParent    }\r
+                               0,         { hMenu         }\r
+                               HInstance, { hInstance     }\r
+                               nil);      { CreateParam   }\r
+\r
+  if hwndwcore = 0 then halt;\r
+\r
+  {$ifdef threadtimer}\r
+  'thread timer'\r
+  {$else}\r
+  if settimer(hwndwcore,timerid_wcore,15,nil) = 0 then halt;\r
+  {$endif}\r
+\r
+\r
+  while GetMessage(MsgRec, 0, 0, 0) do begin\r
+    TranslateMessage(MsgRec);\r
+    DispatchMessage(MsgRec);\r
+    {if not peekmessage(msgrec,0,0,0,PM_NOREMOVE) then onidle}\r
+  end;\r
+\r
+  if hWndwcore <> 0 then begin\r
+    DestroyWindow(hwndwcore);\r
+    hWndwcore := 0;\r
+  end;\r
+\r
+  {$ifdef threadtimer}\r
+  'thread timer'\r
+  {$else}\r
+  killtimer(hwndwcore,timerid_wcore);\r
+  {$endif}\r
+end;\r
+\r
+function ProcessMessage : Boolean;\r
+var\r
+    Msg : TMsg;\r
+begin\r
+    Result := FALSE;\r
+    if PeekMessage(Msg, hwndwcore, 0, 0, PM_REMOVE) then begin\r
+      Result := TRUE;\r
+      DispatchMessage(Msg);\r
+    end;\r
+end;\r
+\r
+procedure processmessages;\r
+begin\r
+  while processmessage do;\r
+end;\r
+\r
+\r
+end.\r