There u go, internet components :-)

git-svn-id: http://www.villavu.com/repositories/merlijn/mufasa@352 3f818213-9676-44b0-a9b4-5e4c4e03d09d

Units/Synapse/asn1util.pas

@@ -0,0 +1,505 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.004.004 |
+|==============================================================================|
+| Content: support for ASN.1 BER coding and decoding                           |
+|==============================================================================|
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c) 1999-2003                |
+| Portions created by Hernan Sanchez are Copyright (c) 2000.                   |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|   Hernan Sanchez (hernan.sanchez@iname.com)                                  |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{: @abstract(Utilities for handling ASN.1 BER encoding)
+By this unit you can parse ASN.1 BER encoded data to elements or build back any
+ elements to ASN.1 BER encoded buffer. You can dump ASN.1 BER encoded data to
+ human readable form for easy debugging, too.
+
+Supported element types are: ASN1_BOOL, ASN1_INT, ASN1_OCTSTR, ASN1_NULL,
+ ASN1_OBJID, ASN1_ENUM, ASN1_SEQ, ASN1_SETOF, ASN1_IPADDR, ASN1_COUNTER,
+ ASN1_GAUGE, ASN1_TIMETICKS, ASN1_OPAQUE
+
+For sample of using, look to @link(TSnmpSend) or @link(TLdapSend)class.
+}
+
+{$Q-}
+{$H+}
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+
+unit asn1util;
+
+interface
+
+uses
+  SysUtils, Classes, synautil;
+
+const
+  ASN1_BOOL = $01;
+  ASN1_INT = $02;
+  ASN1_OCTSTR = $04;
+  ASN1_NULL = $05;
+  ASN1_OBJID = $06;
+  ASN1_ENUM = $0a;
+  ASN1_SEQ = $30;
+  ASN1_SETOF = $31;
+  ASN1_IPADDR = $40;
+  ASN1_COUNTER = $41;
+  ASN1_GAUGE = $42;
+  ASN1_TIMETICKS = $43;
+  ASN1_OPAQUE = $44;
+
+{:Encodes OID item to binary form.}
+function ASNEncOIDItem(Value: Integer): AnsiString;
+
+{:Decodes an OID item of the next element in the "Buffer" from the "Start"
+ position.}
+function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Integer;
+
+{:Encodes the length of ASN.1 element to binary.}
+function ASNEncLen(Len: Integer): AnsiString;
+
+{:Decodes length of next element in "Buffer" from the "Start" position.}
+function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer;
+
+{:Encodes a signed integer to ASN.1 binary}
+function ASNEncInt(Value: Integer): AnsiString;
+
+{:Encodes unsigned integer into ASN.1 binary}
+function ASNEncUInt(Value: Integer): AnsiString;
+
+{:Encodes ASN.1 object to binary form.}
+function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString;
+
+{:Beginning with the "Start" position, decode the ASN.1 item of the next element
+ in "Buffer". Type of item is stored in "ValueType."}
+function ASNItem(var Start: Integer; const Buffer: AnsiString;
+  var ValueType: Integer): AnsiString;
+
+{:Encodes an MIB OID string to binary form.}
+function MibToId(Mib: String): AnsiString;
+
+{:Decodes MIB OID from binary form to string form.}
+function IdToMib(const Id: AnsiString): String;
+
+{:Encodes an one number from MIB OID to binary form. (used internally from
+@link(MibToId))}
+function IntMibToStr(const Value: AnsiString): AnsiString;
+
+{:Convert ASN.1 BER encoded buffer to human readable form for debugging.}
+function ASNdump(const Value: AnsiString): AnsiString;
+
+implementation
+
+{==============================================================================}
+function ASNEncOIDItem(Value: Integer): AnsiString;
+var
+  x, xm: Integer;
+  b: Boolean;
+begin
+  x := Value;
+  b := False;
+  Result := '';
+  repeat
+    xm := x mod 128;
+    x := x div 128;
+    if b then
+      xm := xm or $80;
+    if x > 0 then
+      b := True;
+    Result := AnsiChar(xm) + Result;
+  until x = 0;
+end;
+
+{==============================================================================}
+function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Integer;
+var
+  x: Integer;
+  b: Boolean;
+begin
+  Result := 0;
+  repeat
+    Result := Result * 128;
+    x := Ord(Buffer[Start]);
+    Inc(Start);
+    b := x > $7F;
+    x := x and $7F;
+    Result := Result + x;
+  until not b;
+end;
+
+{==============================================================================}
+function ASNEncLen(Len: Integer): AnsiString;
+var
+  x, y: Integer;
+begin
+  if Len < $80 then
+    Result := AnsiChar(Len)
+  else
+  begin
+    x := Len;
+    Result := '';
+    repeat
+      y := x mod 256;
+      x := x div 256;
+      Result := AnsiChar(y) + Result;
+    until x = 0;
+    y := Length(Result);
+    y := y or $80;
+    Result := AnsiChar(y) + Result;
+  end;
+end;
+
+{==============================================================================}
+function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer;
+var
+  x, n: Integer;
+begin
+  x := Ord(Buffer[Start]);
+  Inc(Start);
+  if x < $80 then
+    Result := x
+  else
+  begin
+    Result := 0;
+    x := x and $7F;
+    for n := 1 to x do
+    begin
+      Result := Result * 256;
+      x := Ord(Buffer[Start]);
+      Inc(Start);
+      Result := Result + x;
+    end;
+  end;
+end;
+
+{==============================================================================}
+function ASNEncInt(Value: Integer): AnsiString;
+var
+  x, y: Cardinal;
+  neg: Boolean;
+begin
+  neg := Value < 0;
+  x := Abs(Value);
+  if neg then
+    x := not (x - 1);
+  Result := '';
+  repeat
+    y := x mod 256;
+    x := x div 256;
+    Result := AnsiChar(y) + Result;
+  until x = 0;
+  if (not neg) and (Result[1] > #$7F) then
+    Result := #0 + Result;
+end;
+
+{==============================================================================}
+function ASNEncUInt(Value: Integer): AnsiString;
+var
+  x, y: Integer;
+  neg: Boolean;
+begin
+  neg := Value < 0;
+  x := Value;
+  if neg then
+    x := x and $7FFFFFFF;
+  Result := '';
+  repeat
+    y := x mod 256;
+    x := x div 256;
+    Result := AnsiChar(y) + Result;
+  until x = 0;
+  if neg then
+    Result[1] := AnsiChar(Ord(Result[1]) or $80);
+end;
+
+{==============================================================================}
+function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString;
+begin
+  Result := AnsiChar(ASNType) + ASNEncLen(Length(Data)) + Data;
+end;
+
+{==============================================================================}
+function ASNItem(var Start: Integer; const Buffer: AnsiString;
+  var ValueType: Integer): AnsiString;
+var
+  ASNType: Integer;
+  ASNSize: Integer;
+  y, n: Integer;
+  x: byte;
+  s: AnsiString;
+  c: AnsiChar;
+  neg: Boolean;
+  l: Integer;
+begin
+  Result := '';
+  ValueType := ASN1_NULL;
+  l := Length(Buffer);
+  if l < (Start + 1) then
+    Exit;
+  ASNType := Ord(Buffer[Start]);
+  ValueType := ASNType;
+  Inc(Start);
+  ASNSize := ASNDecLen(Start, Buffer);
+  if (Start + ASNSize - 1) > l then
+    Exit;
+  if (ASNType and $20) > 0 then
+//    Result := '$' + IntToHex(ASNType, 2)
+    Result := Copy(Buffer, Start, ASNSize)
+  else
+    case ASNType of
+      ASN1_INT, ASN1_ENUM, ASN1_BOOL:
+        begin
+          y := 0;
+          neg := False;
+          for n := 1 to ASNSize do
+          begin
+            x := Ord(Buffer[Start]);
+            if (n = 1) and (x > $7F) then
+              neg := True;
+            if neg then
+              x := not x;
+            y := y * 256 + x;
+            Inc(Start);
+          end;
+          if neg then
+            y := -(y + 1);
+          Result := IntToStr(y);
+        end;
+      ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS:
+        begin
+          y := 0;
+          for n := 1 to ASNSize do
+          begin
+            y := y * 256 + Ord(Buffer[Start]);
+            Inc(Start);
+          end;
+          Result := IntToStr(y);
+        end;
+      ASN1_OCTSTR, ASN1_OPAQUE:
+        begin
+          for n := 1 to ASNSize do
+          begin
+            c := AnsiChar(Buffer[Start]);
+            Inc(Start);
+            s := s + c;
+          end;
+          Result := s;
+        end;
+      ASN1_OBJID:
+        begin
+          for n := 1 to ASNSize do
+          begin
+            c := AnsiChar(Buffer[Start]);
+            Inc(Start);
+            s := s + c;
+          end;
+          Result := IdToMib(s);
+        end;
+      ASN1_IPADDR:
+        begin
+          s := '';
+          for n := 1 to ASNSize do
+          begin
+            if (n <> 1) then
+              s := s + '.';
+            y := Ord(Buffer[Start]);
+            Inc(Start);
+            s := s + IntToStr(y);
+          end;
+          Result := s;
+        end;
+      ASN1_NULL:
+        begin
+          Result := '';
+          Start := Start + ASNSize;
+        end;
+    else // unknown
+      begin
+        for n := 1 to ASNSize do
+        begin
+          c := AnsiChar(Buffer[Start]);
+          Inc(Start);
+          s := s + c;
+        end;
+        Result := s;
+      end;
+    end;
+end;
+
+{==============================================================================}
+function MibToId(Mib: String): AnsiString;
+var
+  x: Integer;
+
+  function WalkInt(var s: String): Integer;
+  var
+    x: Integer;
+    t: AnsiString;
+  begin
+    x := Pos('.', s);
+    if x < 1 then
+    begin
+      t := s;
+      s := '';
+    end
+    else
+    begin
+      t := Copy(s, 1, x - 1);
+      s := Copy(s, x + 1, Length(s) - x);
+    end;
+    Result := StrToIntDef(t, 0);
+  end;
+
+begin
+  Result := '';
+  x := WalkInt(Mib);
+  x := x * 40 + WalkInt(Mib);
+  Result := ASNEncOIDItem(x);
+  while Mib <> '' do
+  begin
+    x := WalkInt(Mib);
+    Result := Result + ASNEncOIDItem(x);
+  end;
+end;
+
+{==============================================================================}
+function IdToMib(const Id: AnsiString): String;
+var
+  x, y, n: Integer;
+begin
+  Result := '';
+  n := 1;
+  while Length(Id) + 1 > n do
+  begin
+    x := ASNDecOIDItem(n, Id);
+    if (n - 1) = 1 then
+    begin
+      y := x div 40;
+      x := x mod 40;
+      Result := IntToStr(y);
+    end;
+    Result := Result + '.' + IntToStr(x);
+  end;
+end;
+
+{==============================================================================}
+function IntMibToStr(const Value: AnsiString): AnsiString;
+var
+  n, y: Integer;
+begin
+  y := 0;
+  for n := 1 to Length(Value) - 1 do
+    y := y * 256 + Ord(Value[n]);
+  Result := IntToStr(y);
+end;
+
+{==============================================================================}
+function ASNdump(const Value: AnsiString): AnsiString;
+var
+  i, at, x, n: integer;
+  s, indent: AnsiString;
+  il: TStringList;
+begin
+  il := TStringList.Create;
+  try
+    Result := '';
+    i := 1;
+    indent := '';
+    while i < Length(Value) do
+    begin
+      for n := il.Count - 1 downto 0 do
+      begin
+        x := StrToIntDef(il[n], 0);
+        if x <= i then
+        begin
+          il.Delete(n);
+          Delete(indent, 1, 2);
+        end;
+      end;
+      s := ASNItem(i, Value, at);
+      Result := Result + indent + '$' + IntToHex(at, 2);
+      if (at and $20) > 0 then
+      begin
+        x := Length(s);
+        Result := Result + ' constructed: length ' + IntToStr(x);
+        indent := indent + '  ';
+        il.Add(IntToStr(x + i - 1));
+      end
+      else
+      begin
+        case at of
+          ASN1_BOOL:
+            Result := Result + ' BOOL: ';
+          ASN1_INT:
+            Result := Result + ' INT: ';
+          ASN1_ENUM:
+            Result := Result + ' ENUM: ';
+          ASN1_COUNTER:
+            Result := Result + ' COUNTER: ';
+          ASN1_GAUGE:
+            Result := Result + ' GAUGE: ';
+          ASN1_TIMETICKS:
+            Result := Result + ' TIMETICKS: ';
+          ASN1_OCTSTR:
+            Result := Result + ' OCTSTR: ';
+          ASN1_OPAQUE:
+            Result := Result + ' OPAQUE: ';
+          ASN1_OBJID:
+            Result := Result + ' OBJID: ';
+          ASN1_IPADDR:
+            Result := Result + ' IPADDR: ';
+          ASN1_NULL:
+            Result := Result + ' NULL: ';
+        else // other
+          Result := Result + ' unknown: ';
+        end;
+        if IsBinaryString(s) then
+          s := DumpExStr(s);
+        Result := Result + s;
+      end;
+      Result := Result + #$0d + #$0a;
+    end;
+  finally
+    il.Free;
+  end;
+end;
+
+{==============================================================================}
+
+end.

Units/Synapse/clamsend.pas

@@ -0,0 +1,271 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.001.000 |
+|==============================================================================|
+| Content: ClamAV-daemon client                                                |
+|==============================================================================|
+| Copyright (c)2005-2009, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2005-2009.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract( ClamAV-daemon client)
+
+This unit is capable to do antivirus scan of your data by TCP channel to ClamD
+daemon from ClamAV. See more about ClamAV on @LINK(http://www.clamav.net)
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$Q-}
+{$H+}
+
+unit clamsend;
+
+interface
+
+uses
+  SysUtils, Classes,
+  synsock, blcksock, synautil;
+
+const
+  cClamProtocol = '3310';
+
+type
+
+  {:@abstract(Implementation of ClamAV-daemon client protocol)
+   By this class you can scan any your data by ClamAV opensource antivirus.
+
+   This class can connect to ClamD by TCP channel, send your data to ClamD
+   and read result.}
+  TClamSend = class(TSynaClient)
+  private
+    FSock: TTCPBlockSocket;
+    FDSock: TTCPBlockSocket;
+    FSession: boolean;
+    function Login: boolean; virtual;
+    function Logout: Boolean; virtual;
+    function OpenStream: Boolean; virtual;
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:Call any command to ClamD. Used internally by other methods.}
+    function DoCommand(const Value: AnsiString): AnsiString; virtual;
+
+    {:Return ClamAV version and version of loaded databases.}
+    function GetVersion: AnsiString; virtual;
+
+    {:Scan content of TStrings.}
+    function ScanStrings(const Value: TStrings): AnsiString; virtual;
+
+    {:Scan content of TStream.}
+    function ScanStream(const Value: TStream): AnsiString; virtual;
+
+    {:Scan content of TStrings by new 0.95 API.}
+    function ScanStrings2(const Value: TStrings): AnsiString; virtual;
+
+    {:Scan content of TStream by new 0.95 API.}
+    function ScanStream2(const Value: TStream): AnsiString; virtual;
+  published
+    {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
+    property Sock: TTCPBlockSocket read FSock;
+
+    {:Socket object used for TCP data transfer operation. Good for seting OnStatus hook, etc.}
+    property DSock: TTCPBlockSocket read FDSock;
+
+    {:Can turn-on session mode of communication with ClamD. Default is @false,
+     because ClamAV developers design their TCP code very badly and session mode
+     is broken now (CVS-20051031). Maybe ClamAV developers fix their bugs
+     and this mode will be possible in future.}
+    property Session: boolean read FSession write FSession;
+  end;
+
+implementation
+
+constructor TClamSend.Create;
+begin
+  inherited Create;
+  FSock := TTCPBlockSocket.Create;
+  FDSock := TTCPBlockSocket.Create;
+  FTimeout := 60000;
+  FTargetPort := cClamProtocol;
+  FSession := false;
+end;
+
+destructor TClamSend.Destroy;
+begin
+  Logout;
+  FDSock.Free;
+  FSock.Free;
+  inherited Destroy;
+end;
+
+function TClamSend.DoCommand(const Value: AnsiString): AnsiString;
+begin
+  Result := '';
+  if not FSession then
+    FSock.CloseSocket
+  else
+    FSock.SendString(Value + LF);
+  if not FSession or (FSock.LastError <> 0) then
+  begin
+    if Login then
+      FSock.SendString(Value + LF)
+    else
+      Exit;
+  end;
+  Result := FSock.RecvTerminated(FTimeout, LF);
+end;
+
+function TClamSend.Login: boolean;
+begin
+  Result := False;
+  Sock.CloseSocket;
+  FSock.Bind(FIPInterface, cAnyPort);
+  if FSock.LastError <> 0 then
+    Exit;
+  FSock.Connect(FTargetHost, FTargetPort);
+  if FSock.LastError <> 0 then
+    Exit;
+  if FSession then
+    FSock.SendString('SESSION' + LF);
+  Result := FSock.LastError = 0;
+end;
+
+function TClamSend.Logout: Boolean;
+begin
+  FSock.SendString('END' + LF);
+  Result := FSock.LastError = 0;
+  FSock.CloseSocket;
+end;
+
+function TClamSend.GetVersion: AnsiString;
+begin
+  Result := DoCommand('nVERSION');
+end;
+
+function TClamSend.OpenStream: Boolean;
+var
+  S: AnsiString;
+begin
+  Result := False;
+  s := DoCommand('nSTREAM');
+  if (s <> '') and (Copy(s, 1, 4) = 'PORT') then
+  begin
+    s := SeparateRight(s, ' ');
+    FDSock.CloseSocket;
+    FDSock.Bind(FIPInterface, cAnyPort);
+    if FDSock.LastError <> 0 then
+      Exit;
+    FDSock.Connect(FTargetHost, s);
+    if FDSock.LastError <> 0 then
+      Exit;
+    Result := True;
+  end;
+end;
+
+function TClamSend.ScanStrings(const Value: TStrings): AnsiString;
+begin
+  Result := '';
+  if OpenStream then
+  begin
+    DSock.SendString(Value.Text);
+    DSock.CloseSocket;
+    Result := FSock.RecvTerminated(FTimeout, LF);
+  end;
+end;
+
+function TClamSend.ScanStream(const Value: TStream): AnsiString;
+begin
+  Result := '';
+  if OpenStream then
+  begin
+    DSock.SendStreamRaw(Value);
+    DSock.CloseSocket;
+    Result := FSock.RecvTerminated(FTimeout, LF);
+  end;
+end;
+
+function TClamSend.ScanStrings2(const Value: TStrings): AnsiString;
+var
+  i: integer;
+  s: AnsiString;
+begin
+  Result := '';
+  if not FSession then
+    FSock.CloseSocket
+  else
+    FSock.sendstring('nINSTREAM' + LF);
+  if not FSession or (FSock.LastError <> 0) then
+  begin
+    if Login then
+      FSock.sendstring('nINSTREAM' + LF)
+    else
+      Exit;
+  end;
+  s := Value.text;
+  i := length(s);
+  FSock.SendString(CodeLongint(i) + s + #0#0#0#0);
+  Result := FSock.RecvTerminated(FTimeout, LF);
+end;
+
+function TClamSend.ScanStream2(const Value: TStream): AnsiString;
+var
+  i: integer;
+  s: AnsiString;
+begin
+  Result := '';
+  if not FSession then
+    FSock.CloseSocket
+  else
+    FSock.sendstring('nINSTREAM' + LF);
+  if not FSession or (FSock.LastError <> 0) then
+  begin
+    if Login then
+      FSock.sendstring('nINSTREAM' + LF)
+    else
+      Exit;
+  end;
+  i := value.Size;
+  FSock.SendString(CodeLongint(i));
+  FSock.SendStreamRaw(Value);
+  FSock.SendString(#0#0#0#0);
+  Result := FSock.RecvTerminated(FTimeout, LF);
+end;
+
+end.

Units/Synapse/dnssend.pas

@@ -0,0 +1,596 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 002.007.004 |
+|==============================================================================|
+| Content: DNS client                                                          |
+|==============================================================================|
+| Copyright (c)1999-2007, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2000-2007.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+{: @abstract(DNS client by UDP or TCP)
+Support for sending DNS queries by UDP or TCP protocol. It can retrieve zone
+ transfers too!
+
+Used RFC: RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$Q-}
+{$H+}
+
+unit dnssend;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synautil, synaip, synsock;
+
+const
+  cDnsProtocol = '53';
+
+  QTYPE_A = 1;
+  QTYPE_NS = 2;
+  QTYPE_MD = 3;
+  QTYPE_MF = 4;
+  QTYPE_CNAME = 5;
+  QTYPE_SOA = 6;
+  QTYPE_MB = 7;
+  QTYPE_MG = 8;
+  QTYPE_MR = 9;
+  QTYPE_NULL = 10;
+  QTYPE_WKS = 11; //
+  QTYPE_PTR = 12;
+  QTYPE_HINFO = 13;
+  QTYPE_MINFO = 14;
+  QTYPE_MX = 15;
+  QTYPE_TXT = 16;
+
+  QTYPE_RP = 17;
+  QTYPE_AFSDB = 18;
+  QTYPE_X25 = 19;
+  QTYPE_ISDN = 20;
+  QTYPE_RT = 21;
+  QTYPE_NSAP = 22;
+  QTYPE_NSAPPTR = 23;
+  QTYPE_SIG = 24; // RFC-2065
+  QTYPE_KEY = 25; // RFC-2065
+  QTYPE_PX = 26;
+  QTYPE_GPOS = 27;
+  QTYPE_AAAA = 28;
+  QTYPE_LOC = 29; // RFC-1876
+  QTYPE_NXT = 30; // RFC-2065
+
+  QTYPE_SRV = 33;
+  QTYPE_NAPTR = 35; // RFC-2168
+  QTYPE_KX = 36;
+  QTYPE_SPF = 99;
+
+  QTYPE_AXFR = 252;
+  QTYPE_MAILB = 253; //
+  QTYPE_MAILA = 254; //
+  QTYPE_ALL = 255;
+
+type
+  {:@abstract(Implementation of DNS protocol by UDP or TCP protocol.)
+
+   Note: Are you missing properties for specify server address and port? Look to
+   parent @link(TSynaClient) too!}
+  TDNSSend = class(TSynaClient)
+  private
+    FID: Word;
+    FRCode: Integer;
+    FBuffer: AnsiString;
+    FSock: TUDPBlockSocket;
+    FTCPSock: TTCPBlockSocket;
+    FUseTCP: Boolean;
+    FAnswerInfo: TStringList;
+    FNameserverInfo: TStringList;
+    FAdditionalInfo: TStringList;
+    FAuthoritative: Boolean;
+    FTruncated: Boolean;
+    function CompressName(const Value: AnsiString): AnsiString;
+    function CodeHeader: AnsiString;
+    function CodeQuery(const Name: AnsiString; QType: Integer): AnsiString;
+    function DecodeLabels(var From: Integer): AnsiString;
+    function DecodeString(var From: Integer): AnsiString;
+    function DecodeResource(var i: Integer; const Info: TStringList;
+      QType: Integer): AnsiString;
+    function RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString;
+    function DecodeResponse(const Buf: AnsiString; const Reply: TStrings;
+      QType: Integer):boolean;
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:Query a DNSHost for QType resources correspond to a name. Supported QType
+     values are: Qtype_A, Qtype_NS, Qtype_MD, Qtype_MF, Qtype_CNAME, Qtype_SOA,
+     Qtype_MB, Qtype_MG, Qtype_MR, Qtype_NULL, Qtype_PTR, Qtype_HINFO,
+     Qtype_MINFO, Qtype_MX, Qtype_TXT, Qtype_RP, Qtype_AFSDB, Qtype_X25,
+     Qtype_ISDN, Qtype_RT, Qtype_NSAP, Qtype_NSAPPTR, Qtype_PX, Qtype_GPOS,
+     Qtype_KX.
+
+     Type for zone transfers QTYPE_AXFR is supported too, but only in TCP mode!
+
+     "Name" is domain name or host name for queried resource. If "name" is
+     IP address, automatically convert to reverse domain form (.in-addr.arpa).
+
+     If result is @true, Reply contains resource records. One record on one line.
+     If Resource record have multiple fields, they are stored on line divided by
+     comma. (example: MX record contains value 'rs.cesnet.cz' with preference
+     number 10, string in Reply is: '10,rs.cesnet.cz'). All numbers or IP address
+     in resource are converted to string form.}
+    function DNSQuery(Name: AnsiString; QType: Integer;
+      const Reply: TStrings): Boolean;
+  published
+
+    {:Socket object used for UDP operation. Good for seting OnStatus hook, etc.}
+    property Sock: TUDPBlockSocket read FSock;
+
+    {:Socket object used for TCP operation. Good for seting OnStatus hook, etc.}
+    property TCPSock: TTCPBlockSocket read FTCPSock;
+
+    {:if @true, then is used TCP protocol instead UDP. It is needed for zone
+     transfers, etc.}
+    property UseTCP: Boolean read FUseTCP Write FUseTCP;
+
+    {:After DNS operation contains ResultCode of DNS operation.
+      Values are: 0-no error, 1-format error, 2-server failure, 3-name error,
+      4-not implemented, 5-refused.}
+    property RCode: Integer read FRCode;
+
+    {:@True, if answer is authoritative.}
+    property Authoritative: Boolean read FAuthoritative;
+
+    {:@True, if answer is truncated to 512 bytes.}
+    property Truncated: Boolean read FTRuncated;
+
+    {:Detailed informations from name server reply. One record per line. Record
+     have comma delimited entries with type number, TTL and data filelds.
+     This information contains detailed information about query reply.}
+    property AnswerInfo: TStringList read FAnswerInfo;
+
+    {:Detailed informations from name server reply. One record per line. Record
+     have comma delimited entries with type number, TTL and data filelds.
+     This information contains detailed information about nameserver.}
+    property NameserverInfo: TStringList read FNameserverInfo;
+
+    {:Detailed informations from name server reply. One record per line. Record
+     have comma delimited entries with type number, TTL and data filelds.
+     This information contains detailed additional information.}
+    property AdditionalInfo: TStringList read FAdditionalInfo;
+  end;
+
+{:A very useful function, and example of it's use is found in the TDNSSend object.
+ This function is used to get mail servers for a domain and sort them by
+ preference numbers. "Servers" contains only the domain names of the mail
+ servers in the right order (without preference number!). The first domain name
+ will always be the highest preferenced mail server. Returns boolean @TRUE if
+ all went well.}
+function GetMailServers(const DNSHost, Domain: AnsiString;
+  const Servers: TStrings): Boolean;
+
+implementation
+
+constructor TDNSSend.Create;
+begin
+  inherited Create;
+  FSock := TUDPBlockSocket.Create;
+  FTCPSock := TTCPBlockSocket.Create;
+  FUseTCP := False;
+  FTimeout := 10000;
+  FTargetPort := cDnsProtocol;
+  FAnswerInfo := TStringList.Create;
+  FNameserverInfo := TStringList.Create;
+  FAdditionalInfo := TStringList.Create;
+  Randomize;
+end;
+
+destructor TDNSSend.Destroy;
+begin
+  FAnswerInfo.Free;
+  FNameserverInfo.Free;
+  FAdditionalInfo.Free;
+  FTCPSock.Free;
+  FSock.Free;
+  inherited Destroy;
+end;
+
+function TDNSSend.CompressName(const Value: AnsiString): AnsiString;
+var
+  n: Integer;
+  s: AnsiString;
+begin
+  Result := '';
+  if Value = '' then
+    Result := #0
+  else
+  begin
+    s := '';
+    for n := 1 to Length(Value) do
+      if Value[n] = '.' then
+      begin
+        Result := Result + Char(Length(s)) + s;
+        s := '';
+      end
+      else
+        s := s + Value[n];
+    if s <> '' then
+      Result := Result + Char(Length(s)) + s;
+    Result := Result + #0;
+  end;
+end;
+
+function TDNSSend.CodeHeader: AnsiString;
+begin
+  FID := Random(32767);
+  Result := CodeInt(FID); // ID
+  Result := Result + CodeInt($0100); // flags
+  Result := Result + CodeInt(1); // QDCount
+  Result := Result + CodeInt(0); // ANCount
+  Result := Result + CodeInt(0); // NSCount
+  Result := Result + CodeInt(0); // ARCount
+end;
+
+function TDNSSend.CodeQuery(const Name: AnsiString; QType: Integer): AnsiString;
+begin
+  Result := CompressName(Name);
+  Result := Result + CodeInt(QType);
+  Result := Result + CodeInt(1); // Type INTERNET
+end;
+
+function TDNSSend.DecodeString(var From: Integer): AnsiString;
+var
+  Len: integer;
+begin
+  Len := Ord(FBuffer[From]);
+  Inc(From);
+  Result := Copy(FBuffer, From, Len);
+  Inc(From, Len);
+end;
+
+function TDNSSend.DecodeLabels(var From: Integer): AnsiString;
+var
+  l, f: Integer;
+begin
+  Result := '';
+  while True do
+  begin
+    if From >= Length(FBuffer) then
+      Break;
+    l := Ord(FBuffer[From]);
+    Inc(From);
+    if l = 0 then
+      Break;
+    if Result <> '' then
+      Result := Result + '.';
+    if (l and $C0) = $C0 then
+    begin
+      f := l and $3F;
+      f := f * 256 + Ord(FBuffer[From]) + 1;
+      Inc(From);
+      Result := Result + DecodeLabels(f);
+      Break;
+    end
+    else
+    begin
+      Result := Result + Copy(FBuffer, From, l);
+      Inc(From, l);
+    end;
+  end;
+end;
+
+function TDNSSend.DecodeResource(var i: Integer; const Info: TStringList;
+  QType: Integer): AnsiString;
+var
+  Rname: AnsiString;
+  RType, Len, j, x, y, z, n: Integer;
+  R: AnsiString;
+  t1, t2, ttl: integer;
+  ip6: TIp6bytes;
+begin
+  Result := '';
+  R := '';
+  Rname := DecodeLabels(i);
+  RType := DecodeInt(FBuffer, i);
+  Inc(i, 4);
+  t1 := DecodeInt(FBuffer, i);
+  Inc(i, 2);
+  t2 := DecodeInt(FBuffer, i);
+  Inc(i, 2);
+  ttl := t1 * 65536 + t2;
+  Len := DecodeInt(FBuffer, i);
+  Inc(i, 2); // i point to begin of data
+  j := i;
+  i := i + len; // i point to next record
+  if Length(FBuffer) >= (i - 1) then
+    case RType of
+      QTYPE_A:
+        begin
+          R := IntToStr(Ord(FBuffer[j]));
+          Inc(j);
+          R := R + '.' + IntToStr(Ord(FBuffer[j]));
+          Inc(j);
+          R := R + '.' + IntToStr(Ord(FBuffer[j]));
+          Inc(j);
+          R := R + '.' + IntToStr(Ord(FBuffer[j]));
+        end;
+      QTYPE_AAAA:
+        begin
+          for n := 0 to 15 do
+            ip6[n] := ord(FBuffer[j + n]);
+          R := IP6ToStr(ip6);
+        end;
+      QTYPE_NS, QTYPE_MD, QTYPE_MF, QTYPE_CNAME, QTYPE_MB,
+        QTYPE_MG, QTYPE_MR, QTYPE_PTR, QTYPE_X25, QTYPE_NSAP,
+        QTYPE_NSAPPTR:
+        R := DecodeLabels(j);
+      QTYPE_SOA:
+        begin
+          R := DecodeLabels(j);
+          R := R + ',' + DecodeLabels(j);
+          for n := 1 to 5 do
+          begin
+            x := DecodeInt(FBuffer, j) * 65536 + DecodeInt(FBuffer, j + 2);
+            Inc(j, 4);
+            R := R + ',' + IntToStr(x);
+          end;
+        end;
+      QTYPE_NULL:
+        begin
+        end;
+      QTYPE_WKS:
+        begin
+        end;
+      QTYPE_HINFO:
+        begin
+          R := DecodeString(j);
+          R := R + ',' + DecodeString(j);
+        end;
+      QTYPE_MINFO, QTYPE_RP, QTYPE_ISDN:
+        begin
+          R := DecodeLabels(j);
+          R := R + ',' + DecodeLabels(j);
+        end;
+      QTYPE_MX, QTYPE_AFSDB, QTYPE_RT, QTYPE_KX:
+        begin
+          x := DecodeInt(FBuffer, j);
+          Inc(j, 2);
+          R := IntToStr(x);
+          R := R + ',' + DecodeLabels(j);
+        end;
+      QTYPE_TXT, QTYPE_SPF:
+        begin
+          R := '';
+          while j < i do
+            R := R + DecodeString(j);
+        end;
+      QTYPE_GPOS:
+        begin
+          R := DecodeLabels(j);
+          R := R + ',' + DecodeLabels(j);
+          R := R + ',' + DecodeLabels(j);
+        end;
+      QTYPE_PX:
+        begin
+          x := DecodeInt(FBuffer, j);
+          Inc(j, 2);
+          R := IntToStr(x);
+          R := R + ',' + DecodeLabels(j);
+          R := R + ',' + DecodeLabels(j);
+        end;
+      QTYPE_SRV:
+      // Author: Dan <ml@mutox.org>
+        begin
+          x := DecodeInt(FBuffer, j);
+          Inc(j, 2);
+          y := DecodeInt(FBuffer, j);
+          Inc(j, 2);
+          z := DecodeInt(FBuffer, j);
+          Inc(j, 2);
+          R := IntToStr(x);                     // Priority
+          R := R + ',' + IntToStr(y);           // Weight
+          R := R + ',' + IntToStr(z);           // Port
+          R := R + ',' + DecodeLabels(j);       // Server DNS Name
+        end;
+    end;
+  if R <> '' then
+    Info.Add(RName + ',' + IntToStr(RType) + ',' + IntToStr(ttl) + ',' + R);
+  if QType = RType then
+    Result := R;
+end;
+
+function TDNSSend.RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString;
+var
+  l: integer;
+begin
+  Result := '';
+  l := WorkSock.recvbyte(FTimeout) * 256 + WorkSock.recvbyte(FTimeout);
+  if l > 0 then
+    Result := WorkSock.RecvBufferStr(l, FTimeout);
+end;
+
+function TDNSSend.DecodeResponse(const Buf: AnsiString; const Reply: TStrings;
+  QType: Integer):boolean;
+var
+  n, i: Integer;
+  flag, qdcount, ancount, nscount, arcount: Integer;
+  s: AnsiString;
+begin
+  Result := False;
+  Reply.Clear;
+  FAnswerInfo.Clear;
+  FNameserverInfo.Clear;
+  FAdditionalInfo.Clear;
+  FAuthoritative := False;
+  if (Length(Buf) > 13) and (FID = DecodeInt(Buf, 1)) then
+  begin
+    Result := True;
+    flag := DecodeInt(Buf, 3);
+    FRCode := Flag and $000F;
+    FAuthoritative := (Flag and $0400) > 0;
+    FTruncated := (Flag and $0200) > 0;
+    if FRCode = 0 then
+    begin
+      qdcount := DecodeInt(Buf, 5);
+      ancount := DecodeInt(Buf, 7);
+      nscount := DecodeInt(Buf, 9);
+      arcount := DecodeInt(Buf, 11);
+      i := 13; //begin of body
+      if (qdcount > 0) and (Length(Buf) > i) then //skip questions
+        for n := 1 to qdcount do
+        begin
+          while (Buf[i] <> #0) and ((Ord(Buf[i]) and $C0) <> $C0) do
+            Inc(i);
+          Inc(i, 5);
+        end;
+      if (ancount > 0) and (Length(Buf) > i) then // decode reply
+        for n := 1 to ancount do
+        begin
+          s := DecodeResource(i, FAnswerInfo, QType);
+          if s <> '' then
+            Reply.Add(s);
+        end;
+      if (nscount > 0) and (Length(Buf) > i) then // decode nameserver info
+        for n := 1 to nscount do
+          DecodeResource(i, FNameserverInfo, QType);
+      if (arcount > 0) and (Length(Buf) > i) then // decode additional info
+        for n := 1 to arcount do
+          DecodeResource(i, FAdditionalInfo, QType);
+    end;
+  end;
+end;
+
+function TDNSSend.DNSQuery(Name: AnsiString; QType: Integer;
+  const Reply: TStrings): Boolean;
+var
+  WorkSock: TBlockSocket;
+  t: TStringList;
+  b: boolean;
+begin
+  Result := False;
+  if IsIP(Name) then
+    Name := ReverseIP(Name) + '.in-addr.arpa';
+  if IsIP6(Name) then
+    Name := ReverseIP6(Name) + '.ip6.arpa';
+  FBuffer := CodeHeader + CodeQuery(Name, QType);
+  if FUseTCP then
+    WorkSock := FTCPSock
+  else
+    WorkSock := FSock;
+  WorkSock.Bind(FIPInterface, cAnyPort);
+  WorkSock.Connect(FTargetHost, FTargetPort);
+  if FUseTCP then
+    FBuffer := Codeint(length(FBuffer)) + FBuffer;
+  WorkSock.SendString(FBuffer);
+  if FUseTCP then
+    FBuffer := RecvTCPResponse(WorkSock)
+  else
+    FBuffer := WorkSock.RecvPacket(FTimeout);
+  if FUseTCP and (QType = QTYPE_AXFR) then //zone transfer
+  begin
+    t := TStringList.Create;
+    try
+      repeat
+        b := DecodeResponse(FBuffer, Reply, QType);
+        if (t.Count > 1) and (AnswerInfo.Count > 0) then  //find end of transfer
+          b := b and (t[0] <> AnswerInfo[AnswerInfo.count - 1]);
+        if b then
+        begin
+          t.AddStrings(AnswerInfo);
+          FBuffer := RecvTCPResponse(WorkSock);
+          if FBuffer = '' then
+            Break;
+          if WorkSock.LastError <> 0 then
+            Break;
+        end;
+      until not b;
+      Reply.Assign(t);
+      Result := True;
+    finally
+      t.free;
+    end;
+  end
+  else //normal query
+    if WorkSock.LastError = 0 then
+      Result := DecodeResponse(FBuffer, Reply, QType);
+end;
+
+{==============================================================================}
+
+function GetMailServers(const DNSHost, Domain: AnsiString;
+  const Servers: TStrings): Boolean;
+var
+  DNS: TDNSSend;
+  t: TStringList;
+  n, m, x: Integer;
+begin
+  Result := False;
+  Servers.Clear;
+  t := TStringList.Create;
+  DNS := TDNSSend.Create;
+  try
+    DNS.TargetHost := DNSHost;
+    if DNS.DNSQuery(Domain, QType_MX, t) then
+    begin
+      { normalize preference number to 5 digits }
+      for n := 0 to t.Count - 1 do
+      begin
+        x := Pos(',', t[n]);
+        if x > 0 then
+          for m := 1 to 6 - x do
+            t[n] := '0' + t[n];
+      end;
+      { sort server list }
+      t.Sorted := True;
+      { result is sorted list without preference numbers }
+      for n := 0 to t.Count - 1 do
+      begin
+        x := Pos(',', t[n]);
+        Servers.Add(Copy(t[n], x + 1, Length(t[n]) - x));
+      end;
+      Result := True;
+    end;
+  finally
+    DNS.Free;
+    t.Free;
+  end;
+end;
+
+end.

Units/Synapse/ftptsend.pas

@@ -0,0 +1,397 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.001.000 |
+|==============================================================================|
+| Content: Trivial FTP (TFTP) client and server                                |
+|==============================================================================|
+| Copyright (c)1999-2004, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2003-2004.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{: @abstract(TFTP client and server protocol)
+
+Used RFC: RFC-1350
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$Q-}
+{$H+}
+
+unit ftptsend;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synautil;
+
+const
+  cTFTPProtocol = '69';
+
+  cTFTP_RRQ = word(1);
+  cTFTP_WRQ = word(2);
+  cTFTP_DTA = word(3);
+  cTFTP_ACK = word(4);
+  cTFTP_ERR = word(5);
+
+type
+  {:@abstract(Implementation of TFTP client and server)
+   Note: Are you missing properties for specify server address and port? Look to
+   parent @link(TSynaClient) too!}
+  TTFTPSend = class(TSynaClient)
+  private
+    FSock: TUDPBlockSocket;
+    FErrorCode: integer;
+    FErrorString: string;
+    FData: TMemoryStream;
+    FRequestIP: string;
+    FRequestPort: string;
+    function SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
+    function RecvPacket(Serial: word; var Value: string): Boolean;
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:Upload @link(data) as file to TFTP server.}
+    function SendFile(const Filename: string): Boolean;
+
+    {:Download file from TFTP server to @link(data).}
+    function RecvFile(const Filename: string): Boolean;
+
+    {:Acts as TFTP server and wait for client request. When some request
+     incoming within Timeout, result is @true and parametres is filled with
+     information from request. You must handle this request, validate it, and
+     call @link(ReplyError), @link(ReplyRecv) or @link(ReplySend) for send reply
+     to TFTP Client.}
+    function WaitForRequest(var Req: word; var filename: string): Boolean;
+
+    {:send error to TFTP client, when you acts as TFTP server.}
+    procedure ReplyError(Error: word; Description: string);
+
+    {:Accept uploaded file from TFTP client to @link(data), when you acts as
+     TFTP server.}
+    function ReplyRecv: Boolean;
+
+    {:Accept download request file from TFTP client and send content of
+     @link(data), when you acts as TFTP server.}
+    function ReplySend: Boolean;
+  published
+    {:Code of TFTP error.}
+    property ErrorCode: integer read FErrorCode;
+
+    {:Human readable decription of TFTP error. (if is sended by remote side)}
+    property ErrorString: string read FErrorString;
+
+    {:MemoryStream with datas for sending or receiving}
+    property Data: TMemoryStream read FData;
+
+    {:Address of TFTP remote side.}
+    property RequestIP: string read FRequestIP write FRequestIP;
+
+    {:Port of TFTP remote side.}
+    property RequestPort: string read FRequestPort write FRequestPort;
+  end;
+
+implementation
+
+constructor TTFTPSend.Create;
+begin
+  inherited Create;
+  FSock := TUDPBlockSocket.Create;
+  FTargetPort := cTFTPProtocol;
+  FData := TMemoryStream.Create;
+  FErrorCode := 0;
+  FErrorString := '';
+end;
+
+destructor TTFTPSend.Destroy;
+begin
+  FSock.Free;
+  FData.Free;
+  inherited Destroy;
+end;
+
+function TTFTPSend.SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
+var
+  s, sh: string;
+begin
+  FErrorCode := 0;
+  FErrorString := '';
+  Result := false;
+  if Cmd <> 2 then
+    s := CodeInt(Cmd) + CodeInt(Serial) + Value
+  else
+    s := CodeInt(Cmd) + Value;
+  FSock.SendString(s);
+  s := FSock.RecvPacket(FTimeout);
+  if FSock.LastError = 0 then
+    if length(s) >= 4 then
+    begin
+      sh := CodeInt(4) + CodeInt(Serial);
+      if Pos(sh, s) = 1 then
+        Result := True
+      else
+        if s[1] = #5 then
+        begin
+          FErrorCode := DecodeInt(s, 3);
+          Delete(s, 1, 4);
+          FErrorString := SeparateLeft(s, #0);
+        end;
+    end;
+end;
+
+function TTFTPSend.RecvPacket(Serial: word; var Value: string): Boolean;
+var
+  s: string;
+  ser: word;
+begin
+  FErrorCode := 0;
+  FErrorString := '';
+  Result := False;
+  Value := '';
+  s := FSock.RecvPacket(FTimeout);
+  if FSock.LastError = 0 then
+    if length(s) >= 4 then
+      if DecodeInt(s, 1) = 3 then
+      begin
+        ser := DecodeInt(s, 3);
+        if ser = Serial then
+        begin
+          Delete(s, 1, 4);
+          Value := s;
+          S := CodeInt(4) + CodeInt(ser);
+          FSock.SendString(s);
+          Result := FSock.LastError = 0;
+        end
+        else
+        begin
+          S := CodeInt(5) + CodeInt(5) + 'Unexcepted serial#' + #0;
+          FSock.SendString(s);
+        end;
+      end;
+      if DecodeInt(s, 1) = 5 then
+      begin
+        FErrorCode := DecodeInt(s, 3);
+        Delete(s, 1, 4);
+        FErrorString := SeparateLeft(s, #0);
+      end;
+end;
+
+function TTFTPSend.SendFile(const Filename: string): Boolean;
+var
+  s: string;
+  ser: word;
+  n, n1, n2: integer;
+begin
+  Result := False;
+  FErrorCode := 0;
+  FErrorString := '';
+  FSock.CloseSocket;
+  FSock.Connect(FTargetHost, FTargetPort);
+  try
+    if FSock.LastError = 0 then
+    begin
+      s := Filename + #0 + 'octet' + #0;
+      if not Sendpacket(2, 0, s) then
+        Exit;
+      ser := 1;
+      FData.Position := 0;
+      n1 := FData.Size div 512;
+      n2 := FData.Size mod 512;
+      for n := 1 to n1 do
+      begin
+        s := ReadStrFromStream(FData, 512);
+//        SetLength(s, 512);
+//        FData.Read(pointer(s)^, 512);
+        if not Sendpacket(3, ser, s) then
+          Exit;
+        inc(ser);
+      end;
+      s := ReadStrFromStream(FData, n2);
+//      SetLength(s, n2);
+//      FData.Read(pointer(s)^, n2);
+      if not Sendpacket(3, ser, s) then
+        Exit;
+      Result := True;
+    end;
+  finally
+    FSock.CloseSocket;
+  end;
+end;
+
+function TTFTPSend.RecvFile(const Filename: string): Boolean;
+var
+  s: string;
+  ser: word;
+begin
+  Result := False;
+  FErrorCode := 0;
+  FErrorString := '';
+  FSock.CloseSocket;
+  FSock.Connect(FTargetHost, FTargetPort);
+  try
+    if FSock.LastError = 0 then
+    begin
+      s := CodeInt(1) + Filename + #0 + 'octet' + #0;
+      FSock.SendString(s);
+      if FSock.LastError <> 0 then
+        Exit;
+      FData.Clear;
+      ser := 1;
+      repeat
+        if not RecvPacket(ser, s) then
+          Exit;
+        inc(ser);
+        WriteStrToStream(FData, s);
+//        FData.Write(pointer(s)^, length(s));
+      until length(s) <> 512;
+      FData.Position := 0;
+      Result := true;
+    end;
+  finally
+    FSock.CloseSocket;
+  end;
+end;
+
+function TTFTPSend.WaitForRequest(var Req: word; var filename: string): Boolean;
+var
+  s: string;
+begin
+  Result := False;
+  FErrorCode := 0;
+  FErrorString := '';
+  FSock.CloseSocket;
+  FSock.Bind('0.0.0.0', FTargetPort);
+  if FSock.LastError = 0 then
+  begin
+    s := FSock.RecvPacket(FTimeout);
+    if FSock.LastError = 0 then
+      if Length(s) >= 4 then
+      begin
+        FRequestIP := FSock.GetRemoteSinIP;
+        FRequestPort := IntToStr(FSock.GetRemoteSinPort);
+        Req := DecodeInt(s, 1);
+        delete(s, 1, 2);
+        filename := Trim(SeparateLeft(s, #0));
+        s := SeparateRight(s, #0);
+        s := SeparateLeft(s, #0);
+        Result := lowercase(trim(s)) = 'octet';
+      end;
+  end;
+end;
+
+procedure TTFTPSend.ReplyError(Error: word; Description: string);
+var
+  s: string;
+begin
+  FSock.CloseSocket;
+  FSock.Connect(FRequestIP, FRequestPort);
+  s := CodeInt(5) + CodeInt(Error) + Description + #0;
+  FSock.SendString(s);
+  FSock.CloseSocket;
+end;
+
+function TTFTPSend.ReplyRecv: Boolean;
+var
+  s: string;
+  ser: integer;
+begin
+  Result := False;
+  FErrorCode := 0;
+  FErrorString := '';
+  FSock.CloseSocket;
+  FSock.Connect(FRequestIP, FRequestPort);
+  try
+    s := CodeInt(4) + CodeInt(0);
+    FSock.SendString(s);
+    FData.Clear;
+    ser := 1;
+    repeat
+      if not RecvPacket(ser, s) then
+        Exit;
+      inc(ser);
+      WriteStrToStream(FData, s);
+//      FData.Write(pointer(s)^, length(s));
+    until length(s) <> 512;
+    FData.Position := 0;
+    Result := true;
+  finally
+    FSock.CloseSocket;
+  end;
+end;
+
+function TTFTPSend.ReplySend: Boolean;
+var
+  s: string;
+  ser: word;
+  n, n1, n2: integer;
+begin
+  Result := False;
+  FErrorCode := 0;
+  FErrorString := '';
+  FSock.CloseSocket;
+  FSock.Connect(FRequestIP, FRequestPort);
+  try
+    ser := 1;
+    FData.Position := 0;
+    n1 := FData.Size div 512;
+    n2 := FData.Size mod 512;
+    for n := 1 to n1 do
+    begin
+      s := ReadStrFromStream(FData, 512);
+//      SetLength(s, 512);
+//      FData.Read(pointer(s)^, 512);
+      if not Sendpacket(3, ser, s) then
+        Exit;
+      inc(ser);
+    end;
+    s := ReadStrFromStream(FData, n2);
+//    SetLength(s, n2);
+//    FData.Read(pointer(s)^, n2);
+    if not Sendpacket(3, ser, s) then
+      Exit;
+    Result := True;
+  finally
+    FSock.CloseSocket;
+  end;
+end;
+
+{==============================================================================}
+
+end.

Units/Synapse/httpsend.pas

@@ -0,0 +1,828 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 003.012.002 |
+|==============================================================================|
+| Content: HTTP client                                                         |
+|==============================================================================|
+| Copyright (c)1999-2008, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c) 1999-2008.               |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(HTTP protocol client)
+
+Used RFC: RFC-1867, RFC-1947, RFC-2388, RFC-2616
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+unit httpsend;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synautil, synaip, synacode, synsock;
+
+const
+  cHttpProtocol = '80';
+
+type
+  {:These encoding types are used internally by the THTTPSend object to identify
+   the transfer data types.}
+  TTransferEncoding = (TE_UNKNOWN, TE_IDENTITY, TE_CHUNKED);
+
+  {:abstract(Implementation of HTTP protocol.)}
+  THTTPSend = class(TSynaClient)
+  protected
+    FSock: TTCPBlockSocket;
+    FTransferEncoding: TTransferEncoding;
+    FAliveHost: string;
+    FAlivePort: string;
+    FHeaders: TStringList;
+    FDocument: TMemoryStream;
+    FMimeType: string;
+    FProtocol: string;
+    FKeepAlive: Boolean;
+    FKeepAliveTimeout: integer;
+    FStatus100: Boolean;
+    FProxyHost: string;
+    FProxyPort: string;
+    FProxyUser: string;
+    FProxyPass: string;
+    FResultCode: Integer;
+    FResultString: string;
+    FUserAgent: string;
+    FCookies: TStringList;
+    FDownloadSize: integer;
+    FUploadSize: integer;
+    FRangeStart: integer;
+    FRangeEnd: integer;
+    FAddPortNumberToHost: Boolean;
+    function ReadUnknown: Boolean;
+    function ReadIdentity(Size: Integer): Boolean;
+    function ReadChunked: Boolean;
+    procedure ParseCookies;
+    function PrepareHeaders: string;
+    function InternalDoConnect(needssl: Boolean): Boolean;
+    function InternalConnect(needssl: Boolean): Boolean;
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:Reset headers and document and Mimetype.}
+    procedure Clear;
+
+    {:Decode ResultCode and ResultString from Value.}
+    procedure DecodeStatus(const Value: string);
+
+    {:Connects to host define in URL and access to resource defined in URL by
+     method. If Document is not empty, send it to server as part of HTTP request.
+     Server response is in Document and headers. Connection may be authorised
+     by username and password in URL. If you define proxy properties, connection
+     is made by this proxy. If all OK, result is @true, else result is @false.
+
+     If you use in URL 'https:' instead only 'http:', then your request is made
+     by SSL/TLS connection (if you not specify port, then port 443 is used
+     instead standard port 80). If you use SSL/TLS request and you have defined
+     HTTP proxy, then HTTP-tunnel mode is automaticly used .}
+    function HTTPMethod(const Method, URL: string): Boolean;
+
+    {:You can call this method from OnStatus event for break current data
+     transfer. (or from another thread.)}
+    procedure Abort;
+  published
+    {:Before HTTP operation you may define any non-standard headers for HTTP
+     request, except of: 'Expect: 100-continue', 'Content-Length', 'Content-Type',
+     'Connection', 'Authorization', 'Proxy-Authorization' and 'Host' headers.
+     After HTTP operation contains full headers of returned document.}
+    property Headers: TStringList read FHeaders;
+
+    {:This is stringlist with name-value stringlist pairs. Each this pair is one
+     cookie. After HTTP request is returned cookies parsed to this stringlist.
+     You can leave this cookies untouched for next HTTP request. You can also
+     save this stringlist for later use.}
+    property Cookies: TStringList read FCookies;
+
+    {:Stream with document to send (before request, or with document received
+     from HTTP server (after request).}
+    property Document: TMemoryStream read FDocument;
+
+    {:If you need download only part of requested document, here specify
+     possition of subpart begin. If here 0, then is requested full document.}
+    property RangeStart: integer read FRangeStart Write FRangeStart;
+
+    {:If you need download only part of requested document, here specify
+     possition of subpart end. If here 0, then is requested document from
+     rangeStart to end of document. (for broken download restoration,
+     for example.)}
+    property RangeEnd: integer read FRangeEnd Write FRangeEnd;
+
+    {:Mime type of sending data. Default is: 'text/html'.}
+    property MimeType: string read FMimeType Write FMimeType;
+
+    {:Define protocol version. Possible values are: '1.1', '1.0' (default)
+     and '0.9'.}
+    property Protocol: string read FProtocol Write FProtocol;
+
+    {:If @true (default value), keepalives in HTTP protocol 1.1 is enabled.}
+    property KeepAlive: Boolean read FKeepAlive Write FKeepAlive;
+
+    {:Define timeout for keepalives in seconds!}
+    property KeepAliveTimeout: integer read FKeepAliveTimeout Write FKeepAliveTimeout;
+
+    {:if @true, then server is requested for 100status capability when uploading
+     data. Default is @false (off).}
+    property Status100: Boolean read FStatus100 Write FStatus100;
+
+    {:Address of proxy server (IP address or domain name) where you want to
+     connect in @link(HTTPMethod) method.}
+    property ProxyHost: string read FProxyHost Write FProxyHost;
+
+    {:Port number for proxy connection. Default value is 8080.}
+    property ProxyPort: string read FProxyPort Write FProxyPort;
+
+    {:Username for connect to proxy server where you want to connect in
+     HTTPMethod method.}
+    property ProxyUser: string read FProxyUser Write FProxyUser;
+
+    {:Password for connect to proxy server where you want to connect in
+     HTTPMethod method.}
+    property ProxyPass: string read FProxyPass Write FProxyPass;
+
+    {:Here you can specify custom User-Agent indentification. By default is
+     used: 'Mozilla/4.0 (compatible; Synapse)'}
+    property UserAgent: string read FUserAgent Write FUserAgent;
+
+    {:After successful @link(HTTPMethod) method contains result code of
+     operation.}
+    property ResultCode: Integer read FResultCode;
+
+    {:After successful @link(HTTPMethod) method contains string after result code.}
+    property ResultString: string read FResultString;
+
+    {:if this value is not 0, then data download pending. In this case you have
+     here total sice of downloaded data. It is good for draw download
+     progressbar from OnStatus event.}
+    property DownloadSize: integer read FDownloadSize;
+
+    {:if this value is not 0, then data upload pending. In this case you have
+     here total sice of uploaded data. It is good for draw upload progressbar
+     from OnStatus event.}
+    property UploadSize: integer read FUploadSize;
+    {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
+    property Sock: TTCPBlockSocket read FSock;
+
+    {:To have possibility to switch off port number in 'Host:' HTTP header, by
+    default @TRUE. Some buggy servers not like port informations in this header.}
+    property AddPortNumberToHost: Boolean read FAddPortNumberToHost write FAddPortNumberToHost;
+  end;
+
+{:A very usefull function, and example of use can be found in the THTTPSend
+ object. It implements the GET method of the HTTP protocol. This function sends
+ the GET method for URL document to an HTTP server. Returned document is in the
+ "Response" stringlist (without any headers). Returns boolean TRUE if all went
+ well.}
+function HttpGetText(const URL: string; const Response: TStrings): Boolean;
+
+{:A very usefull function, and example of use can be found in the THTTPSend
+ object. It implements the GET method of the HTTP protocol. This function sends
+ the GET method for URL document to an HTTP server. Returned document is in the
+ "Response" stream. Returns boolean TRUE if all went well.}
+function HttpGetBinary(const URL: string; const Response: TStream): Boolean;
+
+{:A very useful function, and example of use can be found in the THTTPSend
+ object. It implements the POST method of the HTTP protocol. This function sends
+ the SEND method for a URL document to an HTTP server. The document to be sent
+ is located in "Data" stream. The returned document is in the "Data" stream.
+ Returns boolean TRUE if all went well.}
+function HttpPostBinary(const URL: string; const Data: TStream): Boolean;
+
+{:A very useful function, and example of use can be found in the THTTPSend
+ object. It implements the POST method of the HTTP protocol. This function is
+ good for POSTing form data. It sends the POST method for a URL document to
+ an HTTP server. You must prepare the form data in the same manner as you would
+ the URL data, and pass this prepared data to "URLdata". The following is
+ a sample of how the data would appear: 'name=Lukas&field1=some%20data'.
+ The information in the field must be encoded by EncodeURLElement function.
+ The returned document is in the "Data" stream. Returns boolean TRUE if all
+ went well.}
+function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean;
+
+{:A very useful function, and example of use can be found in the THTTPSend
+ object. It implements the POST method of the HTTP protocol. This function sends
+ the POST method for a URL document to an HTTP server. This function simulate
+ posting of file by HTML form used method 'multipart/form-data'. Posting file
+ is in DATA stream. Its name is Filename string. Fieldname is for name of
+ formular field with file. (simulate HTML INPUT FILE) The returned document is
+ in the ResultData Stringlist. Returns boolean TRUE if all went well.}
+function HttpPostFile(const URL, FieldName, FileName: string;
+  const Data: TStream; const ResultData: TStrings): Boolean;
+
+implementation
+
+constructor THTTPSend.Create;
+begin
+  inherited Create;
+  FHeaders := TStringList.Create;
+  FCookies := TStringList.Create;
+  FDocument := TMemoryStream.Create;
+  FSock := TTCPBlockSocket.Create;
+  FSock.ConvertLineEnd := True;
+  FSock.SizeRecvBuffer := c64k;
+  FSock.SizeSendBuffer := c64k;
+  FTimeout := 90000;
+  FTargetPort := cHttpProtocol;
+  FProxyHost := '';
+  FProxyPort := '8080';
+  FProxyUser := '';
+  FProxyPass := '';
+  FAliveHost := '';
+  FAlivePort := '';
+  FProtocol := '1.0';
+  FKeepAlive := True;
+  FStatus100 := False;
+  FUserAgent := 'Mozilla/4.0 (compatible; Synapse)';
+  FDownloadSize := 0;
+  FUploadSize := 0;
+  FAddPortNumberToHost := true;
+  FKeepAliveTimeout := 300;
+  Clear;
+end;
+
+destructor THTTPSend.Destroy;
+begin
+  FSock.Free;
+  FDocument.Free;
+  FCookies.Free;
+  FHeaders.Free;
+  inherited Destroy;
+end;
+
+procedure THTTPSend.Clear;
+begin
+  FRangeStart := 0;
+  FRangeEnd := 0;
+  FDocument.Clear;
+  FHeaders.Clear;
+  FMimeType := 'text/html';
+end;
+
+procedure THTTPSend.DecodeStatus(const Value: string);
+var
+  s, su: string;
+begin
+  s := Trim(SeparateRight(Value, ' '));
+  su := Trim(SeparateLeft(s, ' '));
+  FResultCode := StrToIntDef(su, 0);
+  FResultString := Trim(SeparateRight(s, ' '));
+  if FResultString = s then
+    FResultString := '';
+end;
+
+function THTTPSend.PrepareHeaders: string;
+begin
+  if FProtocol = '0.9' then
+    Result := FHeaders[0] + CRLF
+  else
+{$IFNDEF WIN32}
+    Result := AdjustLineBreaks(FHeaders.Text, tlbsCRLF);
+{$ELSE}
+    Result := FHeaders.Text;
+{$ENDIF}
+end;
+
+function THTTPSend.InternalDoConnect(needssl: Boolean): Boolean;
+begin
+  Result := False;
+  FSock.CloseSocket;
+  FSock.Bind(FIPInterface, cAnyPort);
+  if FSock.LastError <> 0 then
+    Exit;
+  FSock.Connect(FTargetHost, FTargetPort);
+  if FSock.LastError <> 0 then
+    Exit;
+  if needssl then
+  begin
+    FSock.SSLDoConnect;
+    if FSock.LastError <> 0 then
+      Exit;
+  end;
+  FAliveHost := FTargetHost;
+  FAlivePort := FTargetPort;
+  Result := True;
+end;
+
+function THTTPSend.InternalConnect(needssl: Boolean): Boolean;
+begin
+  if FSock.Socket = INVALID_SOCKET then
+    Result := InternalDoConnect(needssl)
+  else
+    if (FAliveHost <> FTargetHost) or (FAlivePort <> FTargetPort)
+      or FSock.CanRead(0) then
+      Result := InternalDoConnect(needssl)
+    else
+      Result := True;
+end;
+
+function THTTPSend.HTTPMethod(const Method, URL: string): Boolean;
+var
+  Sending, Receiving: Boolean;
+  status100: Boolean;
+  status100error: string;
+  ToClose: Boolean;
+  Size: Integer;
+  Prot, User, Pass, Host, Port, Path, Para, URI: string;
+  s, su: string;
+  HttpTunnel: Boolean;
+  n: integer;
+  pp: string;
+  UsingProxy: boolean;
+  l: TStringList;
+  x: integer;
+begin
+  {initial values}
+  Result := False;
+  FResultCode := 500;
+  FResultString := '';
+  FDownloadSize := 0;
+  FUploadSize := 0;
+
+  URI := ParseURL(URL, Prot, User, Pass, Host, Port, Path, Para);
+  if User = '' then
+  begin
+    User := FUsername;
+    Pass := FPassword;
+  end;
+  if UpperCase(Prot) = 'HTTPS' then
+  begin
+    HttpTunnel := FProxyHost <> '';
+    FSock.HTTPTunnelIP := FProxyHost;
+    FSock.HTTPTunnelPort := FProxyPort;
+    FSock.HTTPTunnelUser := FProxyUser;
+    FSock.HTTPTunnelPass := FProxyPass;
+  end
+  else
+  begin
+    HttpTunnel := False;
+    FSock.HTTPTunnelIP := '';
+    FSock.HTTPTunnelPort := '';
+    FSock.HTTPTunnelUser := '';
+    FSock.HTTPTunnelPass := '';
+  end;
+  UsingProxy := (FProxyHost <> '') and not(HttpTunnel);
+  Sending := FDocument.Size > 0;
+  {Headers for Sending data}
+  status100 := FStatus100 and Sending and (FProtocol = '1.1');
+  if status100 then
+    FHeaders.Insert(0, 'Expect: 100-continue');
+  if Sending then
+  begin
+    FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size));
+    if FMimeType <> '' then
+      FHeaders.Insert(0, 'Content-Type: ' + FMimeType);
+  end;
+  { setting User-agent }
+  if FUserAgent <> '' then
+    FHeaders.Insert(0, 'User-Agent: ' + FUserAgent);
+  { setting Ranges }
+  if (FRangeStart > 0) or (FRangeEnd > 0) then
+  begin
+    if FRangeEnd >= FRangeStart then
+      FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-' + IntToStr(FRangeEnd))
+    else
+      FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-');
+  end;
+  { setting Cookies }
+  s := '';
+  for n := 0 to FCookies.Count - 1 do
+  begin
+    if s <> '' then
+      s := s + '; ';
+    s := s + FCookies[n];
+  end;
+  if s <> '' then
+    FHeaders.Insert(0, 'Cookie: ' + s);
+  { setting KeepAlives }
+  pp := '';
+  if UsingProxy then
+    pp := 'Proxy-';
+  if FKeepAlive then
+  begin
+    FHeaders.Insert(0, pp + 'Connection: keep-alive');
+    FHeaders.Insert(0, 'Keep-Alive: ' + IntToStr(FKeepAliveTimeout));
+  end
+  else
+    FHeaders.Insert(0, pp + 'Connection: close');
+  { set target servers/proxy, authorizations, etc... }
+  if User <> '' then
+    FHeaders.Insert(0, 'Authorization: Basic ' + EncodeBase64(User + ':' + Pass));
+  if UsingProxy and (FProxyUser <> '') then
+    FHeaders.Insert(0, 'Proxy-Authorization: Basic ' +
+      EncodeBase64(FProxyUser + ':' + FProxyPass));
+  if isIP6(Host) then
+    s := '[' + Host + ']'
+  else
+    s := Host;
+  if FAddPortNumberToHost and (Port <> '80') then
+     FHeaders.Insert(0, 'Host: ' + s + ':' + Port)
+  else
+     FHeaders.Insert(0, 'Host: ' + s);
+  if UsingProxy then
+    URI := Prot + '://' + s + ':' + Port + URI;
+  if URI = '/*' then
+    URI := '*';
+  if FProtocol = '0.9' then
+    FHeaders.Insert(0, UpperCase(Method) + ' ' + URI)
+  else
+    FHeaders.Insert(0, UpperCase(Method) + ' ' + URI + ' HTTP/' + FProtocol);
+  if UsingProxy then
+  begin
+    FTargetHost := FProxyHost;
+    FTargetPort := FProxyPort;
+  end
+  else
+  begin
+    FTargetHost := Host;
+    FTargetPort := Port;
+  end;
+  if FHeaders[FHeaders.Count - 1] <> '' then
+    FHeaders.Add('');
+
+  { connect }
+  if not InternalConnect(UpperCase(Prot) = 'HTTPS') then
+  begin
+    FAliveHost := '';
+    FAlivePort := '';
+    Exit;
+  end;
+
+  { reading Status }
+  FDocument.Position := 0;
+  Status100Error := '';
+  if status100 then
+  begin
+    { send Headers }
+    FSock.SendString(PrepareHeaders);
+    if FSock.LastError <> 0 then
+      Exit;
+    repeat
+      s := FSock.RecvString(FTimeout);
+      if s <> '' then
+        Break;
+    until FSock.LastError <> 0;
+    DecodeStatus(s);
+    Status100Error := s;
+    repeat
+      s := FSock.recvstring(FTimeout);
+      if s = '' then
+        Break;
+    until FSock.LastError <> 0;
+    if (FResultCode >= 100) and (FResultCode < 200) then
+    begin
+      { we can upload content }
+      Status100Error := '';
+      FUploadSize := FDocument.Size;
+      FSock.SendBuffer(FDocument.Memory, FDocument.Size);
+    end;
+  end
+  else
+    { upload content }
+    if sending then
+    begin
+      if FDocument.Size >= c64k then
+      begin
+        FSock.SendString(PrepareHeaders);
+        FUploadSize := FDocument.Size;
+        FSock.SendBuffer(FDocument.Memory, FDocument.Size);
+      end
+      else
+      begin
+        s := PrepareHeaders + ReadStrFromStream(FDocument, FDocument.Size);
+        FUploadSize := Length(s);
+        FSock.SendString(s);
+      end;
+    end
+    else
+    begin
+      { we not need to upload document, send headers only }
+      FSock.SendString(PrepareHeaders);
+    end;
+
+  if FSock.LastError <> 0 then
+    Exit;
+
+  Clear;
+  Size := -1;
+  FTransferEncoding := TE_UNKNOWN;
+
+  { read status }
+  if Status100Error = '' then
+  begin
+    repeat
+      repeat
+        s := FSock.RecvString(FTimeout);
+        if s <> '' then
+          Break;
+      until FSock.LastError <> 0;
+      if Pos('HTTP/', UpperCase(s)) = 1 then
+      begin
+        FHeaders.Add(s);
+        DecodeStatus(s);
+      end
+      else
+      begin
+        { old HTTP 0.9 and some buggy servers not send result }
+        s := s + CRLF;
+        WriteStrToStream(FDocument, s);
+        FResultCode := 0;
+      end;
+    until (FSock.LastError <> 0) or (FResultCode <> 100);
+  end
+  else
+    FHeaders.Add(Status100Error);
+
+  { if need receive headers, receive and parse it }
+  ToClose := FProtocol <> '1.1';
+  if FHeaders.Count > 0 then
+  begin
+    l := TStringList.Create;
+    try
+      repeat
+        s := FSock.RecvString(FTimeout);
+        l.Add(s);
+        if s = '' then
+          Break;
+      until FSock.LastError <> 0;
+      x := 0;
+      while l.Count > x do
+      begin
+        s := NormalizeHeader(l, x);
+        FHeaders.Add(s);
+        su := UpperCase(s);
+        if Pos('CONTENT-LENGTH:', su) = 1 then
+        begin
+          Size := StrToIntDef(Trim(SeparateRight(s, ' ')), -1);
+          if (Size <> -1) and (FTransferEncoding = TE_UNKNOWN) then
+            FTransferEncoding := TE_IDENTITY;
+        end;
+        if Pos('CONTENT-TYPE:', su) = 1 then
+          FMimeType := Trim(SeparateRight(s, ' '));
+        if Pos('TRANSFER-ENCODING:', su) = 1 then
+        begin
+          s := Trim(SeparateRight(su, ' '));
+          if Pos('CHUNKED', s) > 0 then
+            FTransferEncoding := TE_CHUNKED;
+        end;
+        if UsingProxy then
+        begin
+          if Pos('PROXY-CONNECTION:', su) = 1 then
+            if Pos('CLOSE', su) > 0 then
+              ToClose := True;
+        end
+        else
+        begin
+          if Pos('CONNECTION:', su) = 1 then
+            if Pos('CLOSE', su) > 0 then
+              ToClose := True;
+        end;
+      end;
+    finally
+      l.free;
+    end;
+  end;
+
+  Result := FSock.LastError = 0;
+  if not Result then
+    Exit;
+
+  {if need receive response body, read it}
+  Receiving := Method <> 'HEAD';
+  Receiving := Receiving and (FResultCode <> 204);
+  Receiving := Receiving and (FResultCode <> 304);
+  if Receiving then
+    case FTransferEncoding of
+      TE_UNKNOWN:
+        Result := ReadUnknown;
+      TE_IDENTITY:
+        Result := ReadIdentity(Size);
+      TE_CHUNKED:
+        Result := ReadChunked;
+    end;
+
+  FDocument.Seek(0, soFromBeginning);
+  if ToClose then
+  begin
+    FSock.CloseSocket;
+    FAliveHost := '';
+    FAlivePort := '';
+  end;
+  ParseCookies;
+end;
+
+function THTTPSend.ReadUnknown: Boolean;
+var
+  s: string;
+begin
+  Result := false;
+  repeat
+    s := FSock.RecvPacket(FTimeout);
+    if FSock.LastError = 0 then
+      WriteStrToStream(FDocument, s);
+  until FSock.LastError <> 0;
+  if FSock.LastError = WSAECONNRESET then
+  begin
+    Result := true;
+    FSock.ResetLastError;
+  end;
+end;
+
+function THTTPSend.ReadIdentity(Size: Integer): Boolean;
+begin
+  if Size > 0 then
+  begin
+    FDownloadSize := Size;
+    FSock.RecvStreamSize(FDocument, FTimeout, Size);
+    FDocument.Position := FDocument.Size;
+    Result := FSock.LastError = 0;
+  end
+  else
+    Result := true;
+end;
+
+function THTTPSend.ReadChunked: Boolean;
+var
+  s: string;
+  Size: Integer;
+begin
+  repeat
+    repeat
+      s := FSock.RecvString(FTimeout);
+    until (s <> '') or (FSock.LastError <> 0);
+    if FSock.LastError <> 0 then
+      Break;
+    s := Trim(SeparateLeft(s, ' '));
+    s := Trim(SeparateLeft(s, ';'));
+    Size := StrToIntDef('$' + s, 0);
+    if Size = 0 then
+      Break;
+    if not ReadIdentity(Size) then
+      break;
+  until False;
+  Result := FSock.LastError = 0;
+end;
+
+procedure THTTPSend.ParseCookies;
+var
+  n: integer;
+  s: string;
+  sn, sv: string;
+begin
+  for n := 0 to FHeaders.Count - 1 do
+    if Pos('set-cookie:', lowercase(FHeaders[n])) = 1 then
+    begin
+      s := SeparateRight(FHeaders[n], ':');
+      s := trim(SeparateLeft(s, ';'));
+      sn := trim(SeparateLeft(s, '='));
+      sv := trim(SeparateRight(s, '='));
+      FCookies.Values[sn] := sv;
+    end;
+end;
+
+procedure THTTPSend.Abort;
+begin
+  FSock.StopFlag := True;
+end;
+
+{==============================================================================}
+
+function HttpGetText(const URL: string; const Response: TStrings): Boolean;
+var
+  HTTP: THTTPSend;
+begin
+  HTTP := THTTPSend.Create;
+  try
+    Result := HTTP.HTTPMethod('GET', URL);
+    if Result then
+      Response.LoadFromStream(HTTP.Document);
+  finally
+    HTTP.Free;
+  end;
+end;
+
+function HttpGetBinary(const URL: string; const Response: TStream): Boolean;
+var
+  HTTP: THTTPSend;
+begin
+  HTTP := THTTPSend.Create;
+  try
+    Result := HTTP.HTTPMethod('GET', URL);
+    if Result then
+    begin
+      Response.Seek(0, soFromBeginning);
+      Response.CopyFrom(HTTP.Document, 0);
+    end;
+  finally
+    HTTP.Free;
+  end;
+end;
+
+function HttpPostBinary(const URL: string; const Data: TStream): Boolean;
+var
+  HTTP: THTTPSend;
+begin
+  HTTP := THTTPSend.Create;
+  try
+    HTTP.Document.CopyFrom(Data, 0);
+    HTTP.MimeType := 'Application/octet-stream';
+    Result := HTTP.HTTPMethod('POST', URL);
+    Data.Size := 0;
+    if Result then
+    begin
+      Data.Seek(0, soFromBeginning);
+      Data.CopyFrom(HTTP.Document, 0);
+    end;
+  finally
+    HTTP.Free;
+  end;
+end;
+
+function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean;
+var
+  HTTP: THTTPSend;
+begin
+  HTTP := THTTPSend.Create;
+  try
+    WriteStrToStream(HTTP.Document, URLData);
+    HTTP.MimeType := 'application/x-www-form-urlencoded';
+    Result := HTTP.HTTPMethod('POST', URL);
+    if Result then
+      Data.CopyFrom(HTTP.Document, 0);
+  finally
+    HTTP.Free;
+  end;
+end;
+
+function HttpPostFile(const URL, FieldName, FileName: string;
+  const Data: TStream; const ResultData: TStrings): Boolean;
+var
+  HTTP: THTTPSend;
+  Bound, s: string;
+begin
+  Bound := IntToHex(Random(MaxInt), 8) + '_Synapse_boundary';
+  HTTP := THTTPSend.Create;
+  try
+    s := '--' + Bound + CRLF;
+    s := s + 'content-disposition: form-data; name="' + FieldName + '";';
+    s := s + ' filename="' + FileName +'"' + CRLF;
+    s := s + 'Content-Type: Application/octet-string' + CRLF + CRLF;
+    WriteStrToStream(HTTP.Document, s);
+    HTTP.Document.CopyFrom(Data, 0);
+    s := CRLF + '--' + Bound + '--' + CRLF;
+    WriteStrToStream(HTTP.Document, s);
+    HTTP.MimeType := 'multipart/form-data; boundary=' + Bound;
+    Result := HTTP.HTTPMethod('POST', URL);
+    if Result then
+      ResultData.LoadFromStream(HTTP.Document);
+  finally
+    HTTP.Free;
+  end;
+end;
+
+end.

Units/Synapse/imapsend.pas

@@ -0,0 +1,863 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 002.005.001 |
+|==============================================================================|
+| Content: IMAP4rev1 client                                                    |
+|==============================================================================|
+| Copyright (c)1999-2004, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2001-2004.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(IMAP4 rev1 protocol client)
+
+Used RFC: RFC-2060, RFC-2595
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+unit imapsend;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synautil;
+
+const
+  cIMAPProtocol = '143';
+
+type
+  {:@abstract(Implementation of IMAP4 protocol.)
+   Note: Are you missing properties for setting Username and Password? Look to
+   parent @link(TSynaClient) object!
+
+   Are you missing properties for specify server address and port? Look to
+   parent @link(TSynaClient) too!}
+  TIMAPSend = class(TSynaClient)
+  protected
+    FSock: TTCPBlockSocket;
+    FTagCommand: integer;
+    FResultString: string;
+    FFullResult: TStringList;
+    FIMAPcap: TStringList;
+    FAuthDone: Boolean;
+    FSelectedFolder: string;
+    FSelectedCount: integer;
+    FSelectedRecent: integer;
+    FSelectedUIDvalidity: integer;
+    FUID: Boolean;
+    FAutoTLS: Boolean;
+    FFullSSL: Boolean;
+    function ReadResult: string;
+    function AuthLogin: Boolean;
+    function Connect: Boolean;
+    procedure ParseMess(Value:TStrings);
+    procedure ParseFolderList(Value:TStrings);
+    procedure ParseSelect;
+    procedure ParseSearch(Value:TStrings);
+    procedure ProcessLiterals;
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:By this function you can call any IMAP command. Result of this command is
+     in adequate properties.}
+    function IMAPcommand(Value: string): string;
+
+    {:By this function you can call any IMAP command what need upload any data.
+     Result of this command is in adequate properties.}
+    function IMAPuploadCommand(Value: string; const Data:TStrings): string;
+
+    {:Call CAPABILITY command and fill IMAPcap property by new values.}
+    function Capability: Boolean;
+
+    {:Connect to IMAP server and do login to this server. This command begin
+     session.}
+    function Login: Boolean;
+
+    {:Disconnect from IMAP server and terminate session session. If exists some
+     deleted and non-purged messages, these messages are not deleted!}
+    function Logout: Boolean;
+
+    {:Do NOOP. It is for prevent disconnect by timeout.}
+    function NoOp: Boolean;
+
+    {:Lists folder names. You may specify level of listing. If you specify
+     FromFolder as empty string, return is all folders in system.}
+    function List(FromFolder: string; const FolderList: TStrings): Boolean;
+
+    {:Lists folder names what match search criteria. You may specify level of
+     listing. If you specify FromFolder as empty string, return is all folders
+     in system.}
+    function ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean;
+
+    {:Lists subscribed folder names. You may specify level of listing. If you
+     specify FromFolder as empty string, return is all subscribed folders in
+     system.}
+    function ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean;
+
+    {:Lists subscribed folder names what matching search criteria. You may
+     specify level of listing. If you specify FromFolder as empty string, return
+     is all subscribed folders in system.}
+    function ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean;
+
+    {:Create a new folder.}
+    function CreateFolder(FolderName: string): Boolean;
+
+    {:Delete a folder.}
+    function DeleteFolder(FolderName: string): Boolean;
+
+    {:Rename folder names.}
+    function RenameFolder(FolderName, NewFolderName: string): Boolean;
+
+    {:Subscribe folder.}
+    function SubscribeFolder(FolderName: string): Boolean;
+
+    {:Unsubscribe folder.}
+    function UnsubscribeFolder(FolderName: string): Boolean;
+
+    {:Select folder.}
+    function SelectFolder(FolderName: string): Boolean;
+
+    {:Select folder, but only for reading. Any changes are not allowed!}
+    function SelectROFolder(FolderName: string): Boolean;
+
+    {:Close a folder. (end of Selected state)}
+    function CloseFolder: Boolean;
+
+    {:Ask for given status of folder. I.e. if you specify as value 'UNSEEN',
+     result is number of unseen messages in folder. For another status
+     indentificator check IMAP documentation and documentation of your IMAP
+     server (each IMAP server can have their own statuses.)}
+    function StatusFolder(FolderName, Value: string): integer;
+
+    {:Hardly delete all messages marked as 'deleted' in current selected folder.}
+    function ExpungeFolder: Boolean;
+
+    {:Touch to folder. (use as update status of folder, etc.)}
+    function CheckFolder: Boolean;
+
+    {:Append given message to specified folder.}
+    function AppendMess(ToFolder: string; const Mess: TStrings): Boolean;
+
+    {:'Delete' message from current selected folder. It mark message as Deleted.
+     Real deleting will be done after sucessfull @link(CloseFolder) or
+     @link(ExpungeFolder)}
+    function DeleteMess(MessID: integer): boolean;
+
+    {:Get full message from specified message in selected folder.}
+    function FetchMess(MessID: integer; const Mess: TStrings): Boolean;
+
+    {:Get message headers only from specified message in selected folder.}
+    function FetchHeader(MessID: integer; const Headers: TStrings): Boolean;
+
+    {:Return message size of specified message from current selected folder.}
+    function MessageSize(MessID: integer): integer;
+
+    {:Copy message from current selected folder to another folder.}
+    function CopyMess(MessID: integer; ToFolder: string): Boolean;
+
+    {:Return message numbers from currently selected folder as result
+     of searching. Search criteria is very complex language (see to IMAP
+     specification) similar to SQL (but not same syntax!).}
+    function SearchMess(Criteria: string; const FoundMess: TStrings): Boolean;
+
+    {:Sets flags of message from current selected folder.}
+    function SetFlagsMess(MessID: integer; Flags: string): Boolean;
+
+    {:Gets flags of message from current selected folder.}
+    function GetFlagsMess(MessID: integer; var Flags: string): Boolean;
+
+    {:Add flags to message's flags.}
+    function AddFlagsMess(MessID: integer; Flags: string): Boolean;
+
+    {:Remove flags from message's flags.}
+    function DelFlagsMess(MessID: integer; Flags: string): Boolean;
+
+    {:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
+    function StartTLS: Boolean;
+
+    {:return UID of requested message ID.}
+    function GetUID(MessID: integer; var UID : Integer): Boolean;
+
+    {:Try to find given capabily in capabilty string returned from IMAP server.}
+    function FindCap(const Value: string): string;
+  published
+    {:Status line with result of last operation.}
+    property ResultString: string read FResultString;
+
+    {:Full result of last IMAP operation.}
+    property FullResult: TStringList read FFullResult;
+
+    {:List of server capabilites.}
+    property IMAPcap: TStringList read FIMAPcap;
+
+    {:Authorization is successful done.}
+    property AuthDone: Boolean read FAuthDone;
+
+    {:Turn on or off usage of UID (unicate identificator) of messages instead
+     only sequence numbers.}
+    property UID: Boolean read FUID Write FUID;
+
+    {:Name of currently selected folder.}
+    property SelectedFolder: string read FSelectedFolder;
+
+    {:Count of messages in currently selected folder.}
+    property SelectedCount: integer read FSelectedCount;
+
+    {:Count of not-visited messages in currently selected folder.}
+    property SelectedRecent: integer read FSelectedRecent;
+
+    {:This number with name of folder is unique indentificator of folder.
+     (If someone delete folder and next create new folder with exactly same name
+     of folder, this number is must be different!)}
+    property SelectedUIDvalidity: integer read FSelectedUIDvalidity;
+
+    {:If is set to true, then upgrade to SSL/TLS mode if remote server support it.}
+    property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
+
+    {:SSL/TLS mode is used from first contact to server. Servers with full
+     SSL/TLS mode usualy using non-standard TCP port!}
+    property FullSSL: Boolean read FFullSSL Write FFullSSL;
+
+    {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
+    property Sock: TTCPBlockSocket read FSock;
+  end;
+
+implementation
+
+constructor TIMAPSend.Create;
+begin
+  inherited Create;
+  FFullResult := TStringList.Create;
+  FIMAPcap := TStringList.Create;
+  FSock := TTCPBlockSocket.Create;
+  FSock.ConvertLineEnd := True;
+  FSock.SizeRecvBuffer := 32768;
+  FSock.SizeSendBuffer := 32768;
+  FTimeout := 60000;
+  FTargetPort := cIMAPProtocol;
+  FTagCommand := 0;
+  FSelectedFolder := '';
+  FSelectedCount := 0;
+  FSelectedRecent := 0;
+  FSelectedUIDvalidity := 0;
+  FUID := False;
+  FAutoTLS := False;
+  FFullSSL := False;
+end;
+
+destructor TIMAPSend.Destroy;
+begin
+  FSock.Free;
+  FIMAPcap.Free;
+  FFullResult.Free;
+  inherited Destroy;
+end;
+
+
+function TIMAPSend.ReadResult: string;
+var
+  s: string;
+  x, l: integer;
+begin
+  Result := '';
+  FFullResult.Clear;
+  FResultString := '';
+  repeat
+    s := FSock.RecvString(FTimeout);
+    if Pos('S' + IntToStr(FTagCommand) + ' ', s) = 1 then
+    begin
+      FResultString := s;
+      break;
+    end
+    else
+      FFullResult.Add(s);
+    if (s <> '') and (s[Length(s)]='}') then
+    begin
+      s := Copy(s, 1, Length(s) - 1);
+      x := RPos('{', s);
+      s := Copy(s, x + 1, Length(s) - x);
+      l := StrToIntDef(s, -1);
+      if l <> -1 then
+      begin
+        s := FSock.RecvBufferStr(l, FTimeout);
+        FFullResult.Add(s);
+      end;
+    end;
+  until FSock.LastError <> 0;
+  s := Trim(separateright(FResultString, ' '));
+  Result:=uppercase(Trim(separateleft(s, ' ')));
+end;
+
+procedure TIMAPSend.ProcessLiterals;
+var
+  l: TStringList;
+  n, x: integer;
+  b: integer;
+  s: string;
+begin
+  l := TStringList.Create;
+  try
+    l.Assign(FFullResult);
+    FFullResult.Clear;
+    b := 0;
+    for n := 0 to l.Count - 1 do
+    begin
+      s := l[n];
+      if b > 0 then
+      begin
+        FFullResult[FFullresult.Count - 1] :=
+          FFullResult[FFullresult.Count - 1] + s;
+        inc(b);
+        if b > 2 then
+          b := 0;
+      end
+      else
+      begin
+        if (s <> '') and (s[Length(s)]='}') then
+        begin
+          x := RPos('{', s);
+          Delete(s, x, Length(s) - x + 1);
+          b := 1;
+        end
+        else
+          b := 0;
+        FFullResult.Add(s);
+      end;
+    end;
+  finally
+    l.Free;
+  end;
+end;
+
+function TIMAPSend.IMAPcommand(Value: string): string;
+begin
+  Inc(FTagCommand);
+  FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + CRLF);
+  Result := ReadResult;
+end;
+
+function TIMAPSend.IMAPuploadCommand(Value: string; const Data:TStrings): string;
+var
+  l: integer;
+begin
+  Inc(FTagCommand);
+  l := Length(Data.Text);
+  FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + ' {'+ IntToStr(l) + '}' + CRLF);
+  FSock.RecvString(FTimeout);
+  FSock.SendString(Data.Text + CRLF);
+  Result := ReadResult;
+end;
+
+procedure TIMAPSend.ParseMess(Value:TStrings);
+var
+  n: integer;
+begin
+  Value.Clear;
+  for n := 0 to FFullResult.Count - 2 do
+    if FFullResult[n][Length(FFullResult[n])] = '}' then
+    begin
+      Value.Text := FFullResult[n + 1];
+      Break;
+    end;
+end;
+
+procedure TIMAPSend.ParseFolderList(Value:TStrings);
+var
+  n, x: integer;
+  s: string;
+begin
+  ProcessLiterals;
+  Value.Clear;
+  for n := 0 to FFullResult.Count - 1 do
+  begin
+    s := FFullResult[n];
+    if (s <> '') and (Pos('\NOSELECT', UpperCase(s)) = 0) then
+    begin
+      if s[Length(s)] = '"' then
+      begin
+        Delete(s, Length(s), 1);
+        x := RPos('"', s);
+      end
+      else
+        x := RPos(' ', s);
+      if (x > 0) then
+        Value.Add(Copy(s, x + 1, Length(s) - x));
+    end;
+  end;
+end;
+
+procedure TIMAPSend.ParseSelect;
+var
+  n: integer;
+  s, t: string;
+begin
+  ProcessLiterals;
+  FSelectedCount := 0;
+  FSelectedRecent := 0;
+  FSelectedUIDvalidity := 0;
+  for n := 0 to FFullResult.Count - 1 do
+  begin
+    s := uppercase(FFullResult[n]);
+    if Pos(' EXISTS', s) > 0 then
+    begin
+      t := Trim(separateleft(s, ' EXISTS'));
+      t := Trim(separateright(t, '* '));
+      FSelectedCount := StrToIntDef(t, 0);
+    end;
+    if Pos(' RECENT', s) > 0 then
+    begin
+      t := Trim(separateleft(s, ' RECENT'));
+      t := Trim(separateright(t, '* '));
+      FSelectedRecent := StrToIntDef(t, 0);
+    end;
+    if Pos('UIDVALIDITY', s) > 0 then
+    begin
+      t := Trim(separateright(s, 'UIDVALIDITY '));
+      t := Trim(separateleft(t, ']'));
+      FSelectedUIDvalidity := StrToIntDef(t, 0);
+    end;
+  end;
+end;
+
+procedure TIMAPSend.ParseSearch(Value:TStrings);
+var
+  n: integer;
+  s: string;
+begin
+  ProcessLiterals;
+  Value.Clear;
+  for n := 0 to FFullResult.Count - 1 do
+  begin
+    s := uppercase(FFullResult[n]);
+    if Pos('* SEARCH', s) = 1 then
+    begin
+      s := Trim(SeparateRight(s, '* SEARCH'));
+      while s <> '' do
+        Value.Add(Fetch(s, ' '));
+    end;
+  end;
+end;
+
+function TIMAPSend.FindCap(const Value: string): string;
+var
+  n: Integer;
+  s: string;
+begin
+  s := UpperCase(Value);
+  Result := '';
+  for n := 0 to FIMAPcap.Count - 1 do
+    if Pos(s, UpperCase(FIMAPcap[n])) = 1 then
+    begin
+      Result := FIMAPcap[n];
+      Break;
+    end;
+end;
+
+function TIMAPSend.AuthLogin: Boolean;
+begin
+  Result := IMAPcommand('LOGIN "' + FUsername + '" "' + FPassword + '"') = 'OK';
+end;
+
+function TIMAPSend.Connect: Boolean;
+begin
+  FSock.CloseSocket;
+  FSock.Bind(FIPInterface, cAnyPort);
+  if FSock.LastError = 0 then
+    FSock.Connect(FTargetHost, FTargetPort);
+  if FSock.LastError = 0 then
+    if FFullSSL then
+      FSock.SSLDoConnect;
+  Result := FSock.LastError = 0;
+end;
+
+function TIMAPSend.Capability: Boolean;
+var
+  n: Integer;
+  s, t: string;
+begin
+  Result := False;
+  FIMAPcap.Clear;
+  s := IMAPcommand('CAPABILITY');
+  if s = 'OK' then
+  begin
+    ProcessLiterals;
+    for n := 0 to FFullResult.Count - 1 do
+      if Pos('* CAPABILITY ', FFullResult[n]) = 1 then
+      begin
+        s := Trim(SeparateRight(FFullResult[n], '* CAPABILITY '));
+        while not (s = '') do
+        begin
+          t := Trim(separateleft(s, ' '));
+          s := Trim(separateright(s, ' '));
+          if s = t then
+            s := '';
+          FIMAPcap.Add(t);
+        end;
+      end;
+    Result := True;
+  end;
+end;
+
+function TIMAPSend.Login: Boolean;
+var
+  s: string;
+begin
+  FSelectedFolder := '';
+  FSelectedCount := 0;
+  FSelectedRecent := 0;
+  FSelectedUIDvalidity := 0;
+  Result := False;
+  FAuthDone := False;
+  if not Connect then
+    Exit;
+  s := FSock.RecvString(FTimeout);
+  if Pos('* PREAUTH', s) = 1 then
+    FAuthDone := True
+  else
+    if Pos('* OK', s) = 1 then
+      FAuthDone := False
+    else
+      Exit;
+  if Capability then
+  begin
+    if Findcap('IMAP4rev1') = '' then
+      Exit;
+    if FAutoTLS and (Findcap('STARTTLS') <> '') then
+      if StartTLS then
+        Capability;
+  end;
+  Result := AuthLogin;
+end;
+
+function TIMAPSend.Logout: Boolean;
+begin
+  Result := IMAPcommand('LOGOUT') = 'OK';
+  FSelectedFolder := '';
+  FSock.CloseSocket;
+end;
+
+function TIMAPSend.NoOp: Boolean;
+begin
+  Result := IMAPcommand('NOOP') = 'OK';
+end;
+
+function TIMAPSend.List(FromFolder: string; const FolderList: TStrings): Boolean;
+begin
+  Result := IMAPcommand('LIST "' + FromFolder + '" *') = 'OK';
+  ParseFolderList(FolderList);
+end;
+
+function TIMAPSend.ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean;
+begin
+  Result := IMAPcommand('LIST "' + FromFolder + '" "' + Search +'"') = 'OK';
+  ParseFolderList(FolderList);
+end;
+
+function TIMAPSend.ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean;
+begin
+  Result := IMAPcommand('LSUB "' + FromFolder + '" *') = 'OK';
+  ParseFolderList(FolderList);
+end;
+
+function TIMAPSend.ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean;
+begin
+  Result := IMAPcommand('LSUB "' + FromFolder + '" "' + Search +'"') = 'OK';
+  ParseFolderList(FolderList);
+end;
+
+function TIMAPSend.CreateFolder(FolderName: string): Boolean;
+begin
+  Result := IMAPcommand('CREATE "' + FolderName + '"') = 'OK';
+end;
+
+function TIMAPSend.DeleteFolder(FolderName: string): Boolean;
+begin
+  Result := IMAPcommand('DELETE "' + FolderName + '"') = 'OK';
+end;
+
+function TIMAPSend.RenameFolder(FolderName, NewFolderName: string): Boolean;
+begin
+  Result := IMAPcommand('RENAME "' + FolderName + '" "' + NewFolderName + '"') = 'OK';
+end;
+
+function TIMAPSend.SubscribeFolder(FolderName: string): Boolean;
+begin
+  Result := IMAPcommand('SUBSCRIBE "' + FolderName + '"') = 'OK';
+end;
+
+function TIMAPSend.UnsubscribeFolder(FolderName: string): Boolean;
+begin
+  Result := IMAPcommand('UNSUBSCRIBE "' + FolderName + '"') = 'OK';
+end;
+
+function TIMAPSend.SelectFolder(FolderName: string): Boolean;
+begin
+  Result := IMAPcommand('SELECT "' + FolderName + '"') = 'OK';
+  FSelectedFolder := FolderName;
+  ParseSelect;
+end;
+
+function TIMAPSend.SelectROFolder(FolderName: string): Boolean;
+begin
+  Result := IMAPcommand('EXAMINE "' + FolderName + '"') = 'OK';
+  FSelectedFolder := FolderName;
+  ParseSelect;
+end;
+
+function TIMAPSend.CloseFolder: Boolean;
+begin
+  Result := IMAPcommand('CLOSE') = 'OK';
+  FSelectedFolder := '';
+end;
+
+function TIMAPSend.StatusFolder(FolderName, Value: string): integer;
+var
+  n: integer;
+  s, t: string;
+begin
+  Result := -1;
+  Value := Uppercase(Value);
+  if IMAPcommand('STATUS "' + FolderName + '" (' + Value + ')' ) = 'OK' then
+  begin
+    ProcessLiterals;
+    for n := 0 to FFullResult.Count - 1 do
+    begin
+      s := FFullResult[n];
+//      s := UpperCase(FFullResult[n]);
+      if (Pos('* ', s) = 1) and (Pos(FolderName, s) >= 1) and (Pos(Value, s) > 0 ) then
+      begin
+        t := SeparateRight(s, Value);
+        t := SeparateLeft(t, ')');
+        t := trim(t);
+        Result := StrToIntDef(t, -1);
+        Break;
+      end;
+    end;
+  end;
+end;
+
+function TIMAPSend.ExpungeFolder: Boolean;
+begin
+  Result := IMAPcommand('EXPUNGE') = 'OK';
+end;
+
+function TIMAPSend.CheckFolder: Boolean;
+begin
+  Result := IMAPcommand('CHECK') = 'OK';
+end;
+
+function TIMAPSend.AppendMess(ToFolder: string; const Mess: TStrings): Boolean;
+begin
+  Result := IMAPuploadCommand('APPEND "' + ToFolder + '"', Mess) = 'OK';
+end;
+
+function TIMAPSend.DeleteMess(MessID: integer): boolean;
+var
+  s: string;
+begin
+  s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (\Deleted)';
+  if FUID then
+    s := 'UID ' + s;
+  Result := IMAPcommand(s) = 'OK';
+end;
+
+function TIMAPSend.FetchMess(MessID: integer; const Mess: TStrings): Boolean;
+var
+  s: string;
+begin
+  s := 'FETCH ' + IntToStr(MessID) + ' (RFC822)';
+  if FUID then
+    s := 'UID ' + s;
+  Result := IMAPcommand(s) = 'OK';
+  ParseMess(Mess);
+end;
+
+function TIMAPSend.FetchHeader(MessID: integer; const Headers: TStrings): Boolean;
+var
+  s: string;
+begin
+  s := 'FETCH ' + IntToStr(MessID) + ' (RFC822.HEADER)';
+  if FUID then
+    s := 'UID ' + s;
+  Result := IMAPcommand(s) = 'OK';
+  ParseMess(Headers);
+end;
+
+function TIMAPSend.MessageSize(MessID: integer): integer;
+var
+  n: integer;
+  s, t: string;
+begin
+  Result := -1;
+  s := 'FETCH ' + IntToStr(MessID) + ' (RFC822.SIZE)';
+  if FUID then
+    s := 'UID ' + s;
+  if IMAPcommand(s) = 'OK' then
+  begin
+    ProcessLiterals;
+    for n := 0 to FFullResult.Count - 1 do
+    begin
+      s := UpperCase(FFullResult[n]);
+      if (Pos('* ', s) = 1) and (Pos('RFC822.SIZE', s) > 0 ) then
+      begin
+        t := SeparateRight(s, 'RFC822.SIZE ');
+        t := Trim(SeparateLeft(t, ')'));
+        t := Trim(SeparateLeft(t, ' '));
+        Result := StrToIntDef(t, -1);
+        Break;
+      end;
+    end;
+  end;
+end;
+
+function TIMAPSend.CopyMess(MessID: integer; ToFolder: string): Boolean;
+var
+  s: string;
+begin
+  s := 'COPY ' + IntToStr(MessID) + ' "' + ToFolder + '"';
+  if FUID then
+    s := 'UID ' + s;
+  Result := IMAPcommand(s) = 'OK';
+end;
+
+function TIMAPSend.SearchMess(Criteria: string; const FoundMess: TStrings): Boolean;
+var
+  s: string;
+begin
+  s := 'SEARCH ' + Criteria;
+  if FUID then
+    s := 'UID ' + s;
+  Result := IMAPcommand(s) = 'OK';
+  ParseSearch(FoundMess);
+end;
+
+function TIMAPSend.SetFlagsMess(MessID: integer; Flags: string): Boolean;
+var
+  s: string;
+begin
+  s := 'STORE ' + IntToStr(MessID) + ' FLAGS.SILENT (' + Flags + ')';
+  if FUID then
+    s := 'UID ' + s;
+  Result := IMAPcommand(s) = 'OK';
+end;
+
+function TIMAPSend.AddFlagsMess(MessID: integer; Flags: string): Boolean;
+var
+  s: string;
+begin
+  s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (' + Flags + ')';
+  if FUID then
+    s := 'UID ' + s;
+  Result := IMAPcommand(s) = 'OK';
+end;
+
+function TIMAPSend.DelFlagsMess(MessID: integer; Flags: string): Boolean;
+var
+  s: string;
+begin
+  s := 'STORE ' + IntToStr(MessID) + ' -FLAGS.SILENT (' + Flags + ')';
+  if FUID then
+    s := 'UID ' + s;
+  Result := IMAPcommand(s) = 'OK';
+end;
+
+function TIMAPSend.GetFlagsMess(MessID: integer; var Flags: string): Boolean;
+var
+  s: string;
+  n: integer;
+begin
+  Flags := '';
+  s := 'FETCH ' + IntToStr(MessID) + ' (FLAGS)';
+  if FUID then
+    s := 'UID ' + s;
+  Result := IMAPcommand(s) = 'OK';
+  ProcessLiterals;
+  for n := 0 to FFullResult.Count - 1 do
+  begin
+    s := uppercase(FFullResult[n]);
+    if (Pos('* ', s) = 1) and (Pos('FLAGS', s) > 0 ) then
+    begin
+      s := SeparateRight(s, 'FLAGS');
+      s := Separateright(s, '(');
+      Flags := Trim(SeparateLeft(s, ')'));
+    end;
+  end;
+end;
+
+function TIMAPSend.StartTLS: Boolean;
+begin
+  Result := False;
+  if FindCap('STARTTLS') <> '' then
+  begin
+    if IMAPcommand('STARTTLS') = 'OK' then
+    begin
+      Fsock.SSLDoConnect;
+      Result := FSock.LastError = 0;
+    end;
+  end;
+end;
+
+//Paul Buskermolen <p.buskermolen@pinkroccade.com>
+function TIMAPSend.GetUID(MessID: integer; var UID : Integer): boolean;
+var
+  s, sUid: string;
+  n: integer;
+begin
+  sUID := '';
+  s := 'FETCH ' + IntToStr(MessID) + ' UID';
+  Result := IMAPcommand(s) = 'OK';
+  ProcessLiterals;
+  for n := 0 to FFullResult.Count - 1 do
+  begin
+    s := uppercase(FFullResult[n]);
+    if Pos('FETCH (UID', s) >= 1 then
+    begin
+      s := Separateright(s, '(UID ');
+      sUID := Trim(SeparateLeft(s, ')'));
+    end;
+  end;
+  UID := StrToIntDef(sUID, 0);
+end;
+
+{==============================================================================}
+
+end.

Units/Synapse/mimeinln.pas

@@ -0,0 +1,258 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.001.011 |
+|==============================================================================|
+| Content: Inline MIME support procedures and functions                        |
+|==============================================================================|
+| Copyright (c)1999-2006, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2000-2006.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(Utilities for inline MIME)
+Support for Inline MIME encoding and decoding.
+
+Used RFC: RFC-2047, RFC-2231
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+unit mimeinln;
+
+interface
+
+uses
+  SysUtils, Classes,
+  synachar, synacode, synautil;
+
+{:Decodes mime inline encoding (i.e. in headers) uses target characterset "CP".}
+function InlineDecode(const Value: string; CP: TMimeChar): string;
+
+{:Encodes string to MIME inline encoding. The source characterset is "CP", and
+ the target charset is "MimeP".}
+function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
+
+{:Returns @true, if "Value" contains characters needed for inline coding.}
+function NeedInline(const Value: AnsiString): boolean;
+
+{:Inline mime encoding similar to @link(InlineEncode), but you can specify
+ source charset, and the target characterset is automatically assigned.}
+function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
+
+{:Inline MIME encoding similar to @link(InlineEncode), but the source charset
+ is automatically set to the system default charset, and the target charset is
+ automatically assigned from set of allowed encoding for MIME.}
+function InlineCode(const Value: string): string;
+
+{:Converts e-mail address to canonical mime form. You can specify source charset.}
+function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
+
+{:Converts e-mail address to canonical mime form. Source charser it system
+ default charset.}
+function InlineEmail(const Value: string): string;
+
+implementation
+
+{==============================================================================}
+
+function InlineDecode(const Value: string; CP: TMimeChar): string;
+var
+  s, su, v: string;
+  x, y, z, n: Integer;
+  ichar: TMimeChar;
+  c: Char;
+
+  function SearchEndInline(const Value: string; be: Integer): Integer;
+  var
+    n, q: Integer;
+  begin
+    q := 0;
+    Result := 0;
+    for n := be + 2 to Length(Value) - 1 do
+      if Value[n] = '?' then
+      begin
+        Inc(q);
+        if (q > 2) and (Value[n + 1] = '=') then
+        begin
+          Result := n;
+          Break;
+        end;
+      end;
+  end;
+
+begin
+  Result := '';
+  v := Value;
+  x := Pos('=?', v);
+  y := SearchEndInline(v, x);
+  //fix for broken coding with begin, but not with end.
+  if (x > 0) and (y <= 0) then
+    y := Length(Result);
+  while (y > x) and (x > 0) do
+  begin
+    s := Copy(v, 1, x - 1);
+    if Trim(s) <> '' then
+      Result := Result + s;
+    s := Copy(v, x, y - x + 2);
+    Delete(v, 1, y + 1);
+    su := Copy(s, 3, Length(s) - 4);
+    z := Pos('?', su);
+    if (Length(su) >= (z + 2)) and (su[z + 2] = '?') then
+    begin
+      ichar := GetCPFromID(SeparateLeft(Copy(su, 1, z - 1), '*'));
+      c := UpperCase(su)[z + 1];
+      su := Copy(su, z + 3, Length(su) - z - 2);
+      if c = 'B' then
+      begin
+        s := DecodeBase64(su);
+        s := CharsetConversion(s, ichar, CP);
+      end;
+      if c = 'Q' then
+      begin
+        s := '';
+        for n := 1 to Length(su) do
+          if su[n] = '_' then
+            s := s + ' '
+          else
+            s := s + su[n];
+        s := DecodeQuotedPrintable(s);
+        s := CharsetConversion(s, ichar, CP);
+      end;
+    end;
+    Result := Result + s;
+    x := Pos('=?', v);
+    y := SearchEndInline(v, x);
+  end;
+  Result := Result + v;
+end;
+
+{==============================================================================}
+
+function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
+var
+  s, s1, e: string;
+  n: Integer;
+begin
+  s := CharsetConversion(Value, CP, MimeP);
+  s := EncodeSafeQuotedPrintable(s);
+  e := GetIdFromCP(MimeP);
+  s1 := '';
+  Result := '';
+  for n := 1 to Length(s) do
+    if s[n] = ' ' then
+    begin
+//      s1 := s1 + '=20';
+      s1 := s1 + '_';
+      if Length(s1) > 32 then
+      begin
+        if Result <> '' then
+          Result := Result + ' ';
+        Result := Result + '=?' + e + '?Q?' + s1 + '?=';
+        s1 := '';
+      end;
+    end
+    else
+      s1 := s1 + s[n];
+  if s1 <> '' then
+  begin
+    if Result <> '' then
+      Result := Result + ' ';
+    Result := Result + '=?' + e + '?Q?' + s1 + '?=';
+  end;
+end;
+
+{==============================================================================}
+
+function NeedInline(const Value: AnsiString): boolean;
+var
+  n: Integer;
+begin
+  Result := False;
+  for n := 1 to Length(Value) do
+    if Value[n] in (SpecialChar + NonAsciiChar - ['_']) then
+    begin
+      Result := True;
+      Break;
+    end;
+end;
+
+{==============================================================================}
+
+function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
+var
+  c: TMimeChar;
+begin
+  if NeedInline(Value) then
+  begin
+    c := IdealCharsetCoding(Value, FromCP, IdealCharsets);
+    Result := InlineEncode(Value, FromCP, c);
+  end
+  else
+    Result := Value;
+end;
+
+{==============================================================================}
+
+function InlineCode(const Value: string): string;
+begin
+  Result := InlineCodeEx(Value, GetCurCP);
+end;
+
+{==============================================================================}
+
+function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
+var
+  sd, se: string;
+begin
+  sd := GetEmailDesc(Value);
+  se := GetEmailAddr(Value);
+  if sd = '' then
+    Result := se
+  else
+    Result := '"' + InlineCodeEx(sd, FromCP) + '" <' + se + '>';
+end;
+
+{==============================================================================}
+
+function InlineEmail(const Value: string): string;
+begin
+  Result := InlineEmailEx(Value, GetCurCP);
+end;
+
+end.

Units/Synapse/mimemess.pas

@@ -0,0 +1,824 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 002.005.002 |
+|==============================================================================|
+| Content: MIME message object                                                 |
+|==============================================================================|
+| Copyright (c)1999-2006, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2000-2006.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM From distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(MIME message handling)
+Classes for easy handling with e-mail message.
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+unit mimemess;
+
+interface
+
+uses
+  Classes, SysUtils,
+  mimepart, synachar, synautil, mimeinln;
+
+type
+
+  {:Possible values for message priority}
+  TMessPriority = (MP_unknown, MP_low, MP_normal, MP_high);
+
+  {:@abstract(Object for basic e-mail header fields.)}
+  TMessHeader = class(TObject)
+  private
+    FFrom: string;
+    FToList: TStringList;
+    FCCList: TStringList;
+    FSubject: string;
+    FOrganization: string;
+    FCustomHeaders: TStringList;
+    FDate: TDateTime;
+    FXMailer: string;
+    FCharsetCode: TMimeChar;
+    FReplyTo: string;
+    FMessageID: string;
+    FPriority: TMessPriority;
+    Fpri: TMessPriority;
+    Fxpri: TMessPriority;
+    Fxmspri: TMessPriority;
+  protected
+    function ParsePriority(value: string): TMessPriority;
+    function DecodeHeader(value: string): boolean; virtual;
+  public
+    constructor Create; virtual;
+    destructor Destroy; override;
+
+    {:Clears all data fields.}
+    procedure Clear; virtual;
+
+    {Add headers from from this object to Value.}
+    procedure EncodeHeaders(const Value: TStrings); virtual;
+
+    {:Parse header from Value to this object.}
+    procedure DecodeHeaders(const Value: TStrings);
+
+    {:Try find specific header in CustomHeader. Search is case insensitive.
+     This is good for reading any non-parsed header.}
+    function FindHeader(Value: string): string;
+
+    {:Try find specific headers in CustomHeader. This metod is for repeatly used
+     headers like 'received' header, etc. Search is case insensitive.
+     This is good for reading ano non-parsed header.}
+    procedure FindHeaderList(Value: string; const HeaderList: TStrings);
+  published
+    {:Sender of message.}
+    property From: string read FFrom Write FFrom;
+
+    {:Stringlist with receivers of message. (one per line)}
+    property ToList: TStringList read FToList;
+
+    {:Stringlist with Carbon Copy receivers of message. (one per line)}
+    property CCList: TStringList read FCCList;
+
+    {:Subject of message.}
+    property Subject: string read FSubject Write FSubject;
+
+    {:Organization string.}
+    property Organization: string read FOrganization Write FOrganization;
+
+    {:After decoding contains all headers lines witch not have parsed to any
+     other structures in this object. It mean: this conatins all other headers
+     except:
+
+     X-MAILER, FROM, SUBJECT, ORGANIZATION, TO, CC, DATE, MIME-VERSION,
+     CONTENT-TYPE, CONTENT-DESCRIPTION, CONTENT-DISPOSITION, CONTENT-ID,
+     CONTENT-TRANSFER-ENCODING, REPLY-TO, MESSAGE-ID, X-MSMAIL-PRIORITY,
+     X-PRIORITY, PRIORITY
+
+     When you encode headers, all this lines is added as headers. Be carefull
+     for duplicites!}
+    property CustomHeaders: TStringList read FCustomHeaders;
+
+    {:Date and time of message.}
+    property Date: TDateTime read FDate Write FDate;
+
+    {:Mailer identification.}
+    property XMailer: string read FXMailer Write FXMailer;
+
+    {:Address for replies}
+    property ReplyTo: string read FReplyTo Write FReplyTo;
+
+    {:message indetifier}
+    property MessageID: string read FMessageID Write FMessageID;
+
+    {:message priority}
+    property Priority: TMessPriority read FPriority Write FPriority;
+
+    {:Specify base charset. By default is used system charset.}
+    property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode;
+  end;
+
+  TMessHeaderClass = class of TMessHeader;
+
+  {:@abstract(Object for handling of e-mail message.)}
+  TMimeMess = class(TObject)
+  private
+    FMessagePart: TMimePart;
+    FLines: TStringList;
+    FHeader: TMessHeader;
+  public
+    constructor Create;
+    {:create this object and assign your own descendant of @link(TMessHeader)
+     object to @link(header) property. So, you can create your own message
+     headers parser and use it by this object.}
+    constructor CreateAltHeaders(HeadClass: TMessHeaderClass);
+    destructor Destroy; override;
+
+    {:Reset component to default state.}
+    procedure Clear; virtual;
+
+    {:Add MIME part as subpart of PartParent. If you need set root MIME part,
+     then set as PartParent @NIL value. If you need set more then one subpart,
+     you must have PartParent of multipart type!}
+    function AddPart(const PartParent: TMimePart): TMimePart;
+
+    {:Add MIME part as subpart of PartParent. If you need set root MIME part,
+     then set as PartParent @NIL value. If you need set more then 1 subpart, you
+     must have PartParent of multipart type!
+
+     This part is marked as multipart with secondary MIME type specified by
+     MultipartType parameter. (typical value is 'mixed')
+
+     This part can be used as PartParent for another parts (include next
+     multipart). If you need only one part, then you not need Multipart part.}
+    function AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart;
+
+    {:Add MIME part as subpart of PartParent. If you need set root MIME part,
+     then set as PartParent @NIL value. If you need set more then 1 subpart, you
+     must have PartParent of multipart type!
+
+     After creation of part set type to text part and set all necessary
+     properties. Content of part is readed from value stringlist.}
+    function AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart;
+
+    {:Add MIME part as subpart of PartParent. If you need set root MIME part,
+     then set as PartParent @NIL value. If you need set more then 1 subpart, you
+     must have PartParent of multipart type!
+
+     After creation of part set type to text part and set all necessary
+     properties. Content of part is readed from value stringlist. You can select
+     your charset and your encoding type. If Raw is @true, then it not doing
+     charset conversion!}
+    function AddPartTextEx(const Value: TStrings; const PartParent: TMimePart;
+      PartCharset: TMimeChar; Raw: Boolean; PartEncoding: TMimeEncoding): TMimepart;
+
+    {:Add MIME part as subpart of PartParent. If you need set root MIME part,
+     then set as PartParent @NIL value. If you need set more then 1 subpart, you
+     must have PartParent of multipart type!
+
+     After creation of part set type to text part to HTML type and set all
+     necessary properties. Content of HTML part is readed from Value stringlist.}
+    function AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart;
+
+    {:Same as @link(AddPartText), but content is readed from file}
+    function AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
+
+    {:Same as @link(AddPartHTML), but content is readed from file}
+    function AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
+
+    {:Add MIME part as subpart of PartParent. If you need set root MIME part,
+     then set as PartParent @NIL value. If you need set more then 1 subpart,
+     you must have PartParent of multipart type!
+
+     After creation of part set type to binary and set all necessary properties.
+     MIME primary and secondary types defined automaticly by filename extension.
+     Content of binary part is readed from Stream. This binary part is encoded
+     as file attachment.}
+    function AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart;
+
+    {:Same as @link(AddPartBinary), but content is readed from file}
+    function AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
+
+    {:Add MIME part as subpart of PartParent. If you need set root MIME part,
+     then set as PartParent @NIL value. If you need set more then 1 subpart, you
+     must have PartParent of multipart type!
+
+     After creation of part set type to binary and set all necessary properties.
+     MIME primary and secondary types defined automaticly by filename extension.
+     Content of binary part is readed from Stream.
+
+     This binary part is encoded as inline data with given Conten ID (cid).
+     Content ID can be used as reference ID in HTML source in HTML part.}
+    function AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
+
+    {:Same as @link(AddPartHTMLBinary), but content is readed from file}
+    function AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
+
+    {:Add MIME part as subpart of PartParent. If you need set root MIME part,
+     then set as PartParent @NIL value. If you need set more then 1 subpart, you
+     must have PartParent of multipart type!
+
+     After creation of part set type to message and set all necessary properties.
+     MIME primary and secondary types are setted to 'message/rfc822'.
+     Content of raw RFC-822 message is readed from Stream.}
+    function AddPartMess(const Value: TStrings; const PartParent: TMimePart): TMimepart;
+
+    {:Same as @link(AddPartMess), but content is readed from file}
+    function AddPartMessFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
+
+    {:Compose message from @link(MessagePart) to @link(Lines). Headers from
+     @link(Header) object is added also.}
+    procedure EncodeMessage;
+
+    {:Decode message from @link(Lines) to @link(MessagePart). Massage headers
+     are parsed into @link(Header) object.}
+    procedure DecodeMessage;
+  published
+    {:@link(TMimePart) object with decoded MIME message. This object can handle
+     any number of nested @link(TMimePart) objects itself. It is used for handle
+     any tree of MIME subparts.}
+    property MessagePart: TMimePart read FMessagePart;
+
+    {:Raw MIME encoded message.}
+    property Lines: TStringList read FLines;
+
+    {:Object for e-mail header fields. This object is created automaticly.
+     Do not free this object!}
+    property Header: TMessHeader read FHeader;
+  end;
+
+implementation
+
+{==============================================================================}
+
+constructor TMessHeader.Create;
+begin
+  inherited Create;
+  FToList := TStringList.Create;
+  FCCList := TStringList.Create;
+  FCustomHeaders := TStringList.Create;
+  FCharsetCode := GetCurCP;
+end;
+
+destructor TMessHeader.Destroy;
+begin
+  FCustomHeaders.Free;
+  FCCList.Free;
+  FToList.Free;
+  inherited Destroy;
+end;
+
+{==============================================================================}
+
+procedure TMessHeader.Clear;
+begin
+  FFrom := '';
+  FToList.Clear;
+  FCCList.Clear;
+  FSubject := '';
+  FOrganization := '';
+  FCustomHeaders.Clear;
+  FDate := 0;
+  FXMailer := '';
+  FReplyTo := '';
+  FMessageID := '';
+  FPriority := MP_unknown;
+end;
+
+procedure TMessHeader.EncodeHeaders(const Value: TStrings);
+var
+  n: Integer;
+  s: string;
+begin
+  if FDate = 0 then
+    FDate := Now;
+  for n := FCustomHeaders.Count - 1 downto 0 do
+    if FCustomHeaders[n] <> '' then
+      Value.Insert(0, FCustomHeaders[n]);
+  if FPriority <> MP_unknown then
+    case FPriority of
+      MP_high:
+        begin
+          Value.Insert(0, 'X-MSMAIL-Priority: High');
+          Value.Insert(0, 'X-Priority: 1');
+          Value.Insert(0, 'Priority: urgent');
+        end;
+      MP_low:
+        begin
+          Value.Insert(0, 'X-MSMAIL-Priority: low');
+          Value.Insert(0, 'X-Priority: 5');
+          Value.Insert(0, 'Priority: non-urgent');
+        end;
+    end;
+  if FReplyTo <> '' then
+    Value.Insert(0, 'Reply-To: ' + GetEmailAddr(FReplyTo));
+  if FMessageID <> '' then
+    Value.Insert(0, 'Message-ID: <' + trim(FMessageID) + '>');
+  if FXMailer = '' then
+    Value.Insert(0, 'X-mailer: Synapse - Pascal TCP/IP library by Lukas Gebauer')
+  else
+    Value.Insert(0, 'X-mailer: ' + FXMailer);
+  Value.Insert(0, 'MIME-Version: 1.0 (produced by Synapse)');
+  if FOrganization <> '' then
+    Value.Insert(0, 'Organization: ' + InlineCodeEx(FOrganization, FCharsetCode));
+  s := '';
+  for n := 0 to FCCList.Count - 1 do
+    if s = '' then
+      s := InlineEmailEx(FCCList[n], FCharsetCode)
+    else
+      s := s + ', ' + InlineEmailEx(FCCList[n], FCharsetCode);
+  if s <> '' then
+    Value.Insert(0, 'CC: ' + s);
+  Value.Insert(0, 'Date: ' + Rfc822DateTime(FDate));
+  if FSubject <> '' then
+    Value.Insert(0, 'Subject: ' + InlineCodeEx(FSubject, FCharsetCode));
+  s := '';
+  for n := 0 to FToList.Count - 1 do
+    if s = '' then
+      s := InlineEmailEx(FToList[n], FCharsetCode)
+    else
+      s := s + ', ' + InlineEmailEx(FToList[n], FCharsetCode);
+  if s <> '' then
+    Value.Insert(0, 'To: ' + s);
+  Value.Insert(0, 'From: ' + InlineEmailEx(FFrom, FCharsetCode));
+end;
+
+function TMessHeader.ParsePriority(value: string): TMessPriority;
+var
+  s: string;
+  x: integer;
+begin
+  Result := MP_unknown;
+  s := Trim(separateright(value, ':'));
+  s := Separateleft(s, ' ');
+  x := StrToIntDef(s, -1);
+  if x >= 0 then
+    case x of
+      1, 2:
+        Result := MP_High;
+      3:
+        Result := MP_Normal;
+      4, 5:
+        Result := MP_Low;
+    end
+  else
+  begin
+    s := lowercase(s);
+    if (s = 'urgent') or (s = 'high') or (s = 'highest') then
+      Result := MP_High;
+    if (s = 'normal') or (s = 'medium') then
+      Result := MP_Normal;
+    if (s = 'low') or (s = 'lowest')
+      or (s = 'no-priority')  or (s = 'non-urgent') then
+      Result := MP_Low;
+  end;
+end;
+
+function TMessHeader.DecodeHeader(value: string): boolean;
+var
+  s, t: string;
+  cp: TMimeChar;
+begin
+  Result := True;
+  cp := FCharsetCode;
+  s := uppercase(value);
+  if Pos('X-MAILER:', s) = 1 then
+  begin
+    FXMailer := Trim(SeparateRight(Value, ':'));
+    Exit;
+  end;
+  if Pos('FROM:', s) = 1 then
+  begin
+    FFrom := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
+    Exit;
+  end;
+  if Pos('SUBJECT:', s) = 1 then
+  begin
+    FSubject := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
+    Exit;
+  end;
+  if Pos('ORGANIZATION:', s) = 1 then
+  begin
+    FOrganization := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
+    Exit;
+  end;
+  if Pos('TO:', s) = 1 then
+  begin
+    s := Trim(SeparateRight(Value, ':'));
+    repeat
+      t := InlineDecode(Trim(FetchEx(s, ',', '"')), cp);
+      if t <> '' then
+        FToList.Add(t);
+    until s = '';
+    Exit;
+  end;
+  if Pos('CC:', s) = 1 then
+  begin
+    s := Trim(SeparateRight(Value, ':'));
+    repeat
+      t := InlineDecode(Trim(FetchEx(s, ',', '"')), cp);
+      if t <> '' then
+        FCCList.Add(t);
+    until s = '';
+    Exit;
+  end;
+  if Pos('DATE:', s) = 1 then
+  begin
+    FDate := DecodeRfcDateTime(Trim(SeparateRight(Value, ':')));
+    Exit;
+  end;
+  if Pos('REPLY-TO:', s) = 1 then
+  begin
+    FReplyTo := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
+    Exit;
+  end;
+  if Pos('MESSAGE-ID:', s) = 1 then
+  begin
+    FMessageID := GetEmailAddr(Trim(SeparateRight(Value, ':')));
+    Exit;
+  end;
+  if Pos('PRIORITY:', s) = 1 then
+  begin
+    FPri := ParsePriority(value);
+    Exit;
+  end;
+  if Pos('X-PRIORITY:', s) = 1 then
+  begin
+    FXPri := ParsePriority(value);
+    Exit;
+  end;
+  if Pos('X-MSMAIL-PRIORITY:', s) = 1 then
+  begin
+    FXmsPri := ParsePriority(value);
+    Exit;
+  end;
+  if Pos('MIME-VERSION:', s) = 1 then
+    Exit;
+  if Pos('CONTENT-TYPE:', s) = 1 then
+    Exit;
+  if Pos('CONTENT-DESCRIPTION:', s) = 1 then
+    Exit;
+  if Pos('CONTENT-DISPOSITION:', s) = 1 then
+    Exit;
+  if Pos('CONTENT-ID:', s) = 1 then
+    Exit;
+  if Pos('CONTENT-TRANSFER-ENCODING:', s) = 1 then
+    Exit;
+  Result := False;
+end;
+
+procedure TMessHeader.DecodeHeaders(const Value: TStrings);
+var
+  s: string;
+  x: Integer;
+begin
+  Clear;
+  Fpri := MP_unknown;
+  Fxpri := MP_unknown;
+  Fxmspri := MP_unknown;
+  x := 0;
+  while Value.Count > x do
+  begin
+    s := NormalizeHeader(Value, x);
+    if s = '' then
+      Break;
+    if not DecodeHeader(s) then
+      FCustomHeaders.Add(s);
+  end;
+  if Fpri <> MP_unknown then
+    FPriority := Fpri
+  else
+    if Fxpri <> MP_unknown then
+      FPriority := Fxpri
+    else
+      if Fxmspri <> MP_unknown then
+        FPriority := Fxmspri
+end;
+
+function TMessHeader.FindHeader(Value: string): string;
+var
+  n: integer;
+begin
+  Result := '';
+  for n := 0 to FCustomHeaders.Count - 1 do
+    if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then
+    begin
+      Result := Trim(SeparateRight(FCustomHeaders[n], ':'));
+      break;
+    end;
+end;
+
+procedure TMessHeader.FindHeaderList(Value: string; const HeaderList: TStrings);
+var
+  n: integer;
+begin
+  HeaderList.Clear;
+  for n := 0 to FCustomHeaders.Count - 1 do
+    if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then
+    begin
+      HeaderList.Add(Trim(SeparateRight(FCustomHeaders[n], ':')));
+    end;
+end;
+
+{==============================================================================}
+
+constructor TMimeMess.Create;
+begin
+  CreateAltHeaders(TMessHeader);
+end;
+
+constructor TMimeMess.CreateAltHeaders(HeadClass: TMessHeaderClass);
+begin
+  inherited Create;
+  FMessagePart := TMimePart.Create;
+  FLines := TStringList.Create;
+  FHeader := HeadClass.Create;
+end;
+
+destructor TMimeMess.Destroy;
+begin
+  FMessagePart.Free;
+  FHeader.Free;
+  FLines.Free;
+  inherited Destroy;
+end;
+
+{==============================================================================}
+
+procedure TMimeMess.Clear;
+begin
+  FMessagePart.Clear;
+  FLines.Clear;
+  FHeader.Clear;
+end;
+
+{==============================================================================}
+
+function TMimeMess.AddPart(const PartParent: TMimePart): TMimePart;
+begin
+  if PartParent = nil then
+    Result := FMessagePart
+  else
+    Result := PartParent.AddSubPart;
+  Result.Clear;
+end;
+
+{==============================================================================}
+
+function TMimeMess.AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart;
+begin
+  Result := AddPart(PartParent);
+  with Result do
+  begin
+    Primary := 'Multipart';
+    Secondary := MultipartType;
+    Description := 'Multipart message';
+    Boundary := GenerateBoundary;
+    EncodePartHeader;
+  end;
+end;
+
+function TMimeMess.AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart;
+begin
+  Result := AddPart(PartParent);
+  with Result do
+  begin
+    Value.SaveToStream(DecodedLines);
+    Primary := 'text';
+    Secondary := 'plain';
+    Description := 'Message text';
+    Disposition := 'inline';
+    CharsetCode := IdealCharsetCoding(Value.Text, TargetCharset, IdealCharsets);
+    EncodingCode := ME_QUOTED_PRINTABLE;
+    EncodePart;
+    EncodePartHeader;
+  end;
+end;
+
+function TMimeMess.AddPartTextEx(const Value: TStrings; const PartParent: TMimePart;
+  PartCharset: TMimeChar; Raw: Boolean; PartEncoding: TMimeEncoding): TMimepart;
+begin
+  Result := AddPart(PartParent);
+  with Result do
+  begin
+    Value.SaveToStream(DecodedLines);
+    Primary := 'text';
+    Secondary := 'plain';
+    Description := 'Message text';
+    Disposition := 'inline';
+    CharsetCode := PartCharset;
+    EncodingCode := PartEncoding;
+    ConvertCharset := not Raw;
+    EncodePart;
+    EncodePartHeader;
+  end;
+end;
+
+function TMimeMess.AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart;
+begin
+  Result := AddPart(PartParent);
+  with Result do
+  begin
+    Value.SaveToStream(DecodedLines);
+    Primary := 'text';
+    Secondary := 'html';
+    Description := 'HTML text';
+    Disposition := 'inline';
+    CharsetCode := UTF_8;
+    EncodingCode := ME_QUOTED_PRINTABLE;
+    EncodePart;
+    EncodePartHeader;
+  end;
+end;
+
+function TMimeMess.AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
+var
+  tmp: TStrings;
+begin
+  tmp := TStringList.Create;
+  try
+    tmp.LoadFromFile(FileName);
+    Result := AddPartText(tmp, PartParent);
+  Finally
+    tmp.Free;
+  end;
+end;
+
+function TMimeMess.AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
+var
+  tmp: TStrings;
+begin
+  tmp := TStringList.Create;
+  try
+    tmp.LoadFromFile(FileName);
+    Result := AddPartHTML(tmp, PartParent);
+  Finally
+    tmp.Free;
+  end;
+end;
+
+function TMimeMess.AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart;
+begin
+  Result := AddPart(PartParent);
+  Result.DecodedLines.LoadFromStream(Stream);
+  Result.MimeTypeFromExt(FileName);
+  Result.Description := 'Attached file: ' + FileName;
+  Result.Disposition := 'attachment';
+  Result.FileName := FileName;
+  Result.EncodingCode := ME_BASE64;
+  Result.EncodePart;
+  Result.EncodePartHeader;
+end;
+
+function TMimeMess.AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
+var
+  tmp: TMemoryStream;
+begin
+  tmp := TMemoryStream.Create;
+  try
+    tmp.LoadFromFile(FileName);
+    Result := AddPartBinary(tmp, ExtractFileName(FileName), PartParent);
+  finally
+    tmp.Free;
+  end;
+end;
+
+function TMimeMess.AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
+begin
+  Result := AddPart(PartParent);
+  Result.DecodedLines.LoadFromStream(Stream);
+  Result.MimeTypeFromExt(FileName);
+  Result.Description := 'Included file: ' + FileName;
+  Result.Disposition := 'inline';
+  Result.ContentID := Cid;
+  Result.FileName := FileName;
+  Result.EncodingCode := ME_BASE64;
+  Result.EncodePart;
+  Result.EncodePartHeader;
+end;
+
+function TMimeMess.AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
+var
+  tmp: TMemoryStream;
+begin
+  tmp := TMemoryStream.Create;
+  try
+    tmp.LoadFromFile(FileName);
+    Result :=AddPartHTMLBinary(tmp, ExtractFileName(FileName), Cid, PartParent);
+  finally
+    tmp.Free;
+  end;
+end;
+
+function TMimeMess.AddPartMess(const Value: TStrings; const PartParent: TMimePart): TMimepart;
+var
+  part: Tmimepart;
+begin
+  Result := AddPart(PartParent);
+  part := AddPart(result);
+  part.lines.addstrings(Value);
+  part.DecomposeParts;
+  with Result do
+  begin
+    Primary := 'message';
+    Secondary := 'rfc822';
+    Description := 'E-mail Message';
+    EncodePart;
+    EncodePartHeader;
+  end;
+end;
+
+function TMimeMess.AddPartMessFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
+var
+  tmp: TStrings;
+begin
+  tmp := TStringList.Create;
+  try
+    tmp.LoadFromFile(FileName);
+    Result := AddPartMess(tmp, PartParent);
+  Finally
+    tmp.Free;
+  end;
+end;
+
+{==============================================================================}
+
+procedure TMimeMess.EncodeMessage;
+var
+  l: TStringList;
+  x: integer;
+begin
+  //merge headers from THeaders and header field from MessagePart
+  l := TStringList.Create;
+  try
+    FHeader.EncodeHeaders(l);
+    x := IndexByBegin('CONTENT-TYPE', FMessagePart.Headers);
+    if x >= 0 then
+      l.add(FMessagePart.Headers[x]);
+    x := IndexByBegin('CONTENT-DESCRIPTION', FMessagePart.Headers);
+    if x >= 0 then
+      l.add(FMessagePart.Headers[x]);
+    x := IndexByBegin('CONTENT-DISPOSITION', FMessagePart.Headers);
+    if x >= 0 then
+      l.add(FMessagePart.Headers[x]);
+    x := IndexByBegin('CONTENT-ID', FMessagePart.Headers);
+    if x >= 0 then
+      l.add(FMessagePart.Headers[x]);
+    x := IndexByBegin('CONTENT-TRANSFER-ENCODING', FMessagePart.Headers);
+    if x >= 0 then
+      l.add(FMessagePart.Headers[x]);
+    FMessagePart.Headers.Assign(l);
+  finally
+    l.Free;
+  end;
+  FMessagePart.ComposeParts;
+  FLines.Assign(FMessagePart.Lines);
+end;
+
+{==============================================================================}
+
+procedure TMimeMess.DecodeMessage;
+begin
+  FHeader.Clear;
+  FHeader.DecodeHeaders(FLines);
+  FMessagePart.Lines.Assign(FLines);
+  FMessagePart.DecomposeParts;
+end;
+
+end.

Units/Synapse/nntpsend.pas

@@ -0,0 +1,474 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.005.001 |
+|==============================================================================|
+| Content: NNTP client                                                         |
+|==============================================================================|
+| Copyright (c)1999-2007, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c) 1999-2007.               |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(NNTP client)
+NNTP (network news transfer protocol)
+
+Used RFC: RFC-977, RFC-2980
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+unit nntpsend;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synautil;
+
+const
+  cNNTPProtocol = '119';
+
+type
+
+  {:abstract(Implementation of Network News Transfer Protocol.
+
+   Note: Are you missing properties for setting Username and Password? Look to
+   parent @link(TSynaClient) object!
+
+   Are you missing properties for specify server address and port? Look to
+   parent @link(TSynaClient) too!}
+  TNNTPSend = class(TSynaClient)
+  private
+    FSock: TTCPBlockSocket;
+    FResultCode: Integer;
+    FResultString: string;
+    FData: TStringList;
+    FDataToSend: TStringList;
+    FAutoTLS: Boolean;
+    FFullSSL: Boolean;
+    FNNTPcap: TStringList;
+    function ReadResult: Integer;
+    function ReadData: boolean;
+    function SendData: boolean;
+    function Connect: Boolean;
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:Connects to NNTP server and begin session.}
+    function Login: Boolean;
+
+    {:Logout from NNTP server and terminate session.}
+    function Logout: Boolean;
+
+    {:By this you can call any NNTP command.}
+    function DoCommand(const Command: string): boolean;
+
+    {:by this you can call any NNTP command. This variant is used for commands
+     for download information from server.}
+    function DoCommandRead(const Command: string): boolean;
+
+    {:by this you can call any NNTP command. This variant is used for commands
+     for upload information to server.}
+    function DoCommandWrite(const Command: string): boolean;
+
+    {:Download full message to @link(data) property. Value can be number of
+     message or message-id (in brackets).}
+    function GetArticle(const Value: string): Boolean;
+
+    {:Download only body of message to @link(data) property. Value can be number
+     of message or message-id (in brackets).}
+    function GetBody(const Value: string): Boolean;
+
+    {:Download only headers of message to @link(data) property. Value can be
+     number of message or message-id (in brackets).}
+    function GetHead(const Value: string): Boolean;
+
+    {:Get message status. Value can be number of message or message-id
+     (in brackets).}
+    function GetStat(const Value: string): Boolean;
+
+    {:Select given group.}
+    function SelectGroup(const Value: string): Boolean;
+
+    {:Tell to server 'I have mesage with given message-ID.' If server need this
+     message, message is uploaded to server.}
+    function IHave(const MessID: string): Boolean;
+
+    {:Move message pointer to last item in group.}
+    function GotoLast: Boolean;
+
+    {:Move message pointer to next item in group.}
+    function GotoNext: Boolean;
+
+    {:Download to @link(data) property list of all groups on NNTP server.}
+    function ListGroups: Boolean;
+
+    {:Download to @link(data) property list of all groups created after given time.}
+    function ListNewGroups(Since: TDateTime): Boolean;
+
+    {:Download to @link(data) property list of message-ids in given group since
+     given time.}
+    function NewArticles(const Group: string; Since: TDateTime): Boolean;
+
+    {:Upload new article to server. (for new messages by you)}
+    function PostArticle: Boolean;
+
+    {:Tells to remote NNTP server 'I am not NNTP client, but I am another NNTP
+     server'.}
+    function SwitchToSlave: Boolean;
+
+    {:Call NNTP XOVER command.}
+    function Xover(xoStart, xoEnd: string): boolean;
+
+    {:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
+    function StartTLS: Boolean;
+
+    {:Try to find given capability in extension list. This list is getted after
+     successful login to NNTP server. If extension capability is not found,
+     then return is empty string.}
+    function FindCap(const Value: string): string;
+
+    {:Try get list of server extensions. List is returned in @link(data) property.}
+    function ListExtensions: Boolean;
+  published
+    {:Result code number of last operation.}
+    property ResultCode: Integer read FResultCode;
+
+    {:String description of last result code from NNTP server.}
+    property ResultString: string read FResultString;
+
+    {:Readed data. (message, etc.)}
+    property Data: TStringList read FData;
+
+    {:If is set to @true, then upgrade to SSL/TLS mode after login if remote
+     server support it.}
+    property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
+
+    {:SSL/TLS mode is used from first contact to server. Servers with full
+     SSL/TLS mode usualy using non-standard TCP port!}
+    property FullSSL: Boolean read FFullSSL Write FFullSSL;
+
+    {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
+    property Sock: TTCPBlockSocket read FSock;
+  end;
+
+implementation
+
+constructor TNNTPSend.Create;
+begin
+  inherited Create;
+  FSock := TTCPBlockSocket.Create;
+  FData := TStringList.Create;
+  FDataToSend := TStringList.Create;
+  FNNTPcap := TStringList.Create;
+  FSock.ConvertLineEnd := True;
+  FTimeout := 60000;
+  FTargetPort := cNNTPProtocol;
+  FAutoTLS := False;
+  FFullSSL := False;
+end;
+
+destructor TNNTPSend.Destroy;
+begin
+  FSock.Free;
+  FDataToSend.Free;
+  FData.Free;
+  FNNTPcap.Free;
+  inherited Destroy;
+end;
+
+function TNNTPSend.ReadResult: Integer;
+var
+  s: string;
+begin
+  Result := 0;
+  FData.Clear;
+  s := FSock.RecvString(FTimeout);
+  FResultString := Copy(s, 5, Length(s) - 4);
+  if FSock.LastError <> 0 then
+    Exit;
+  if Length(s) >= 3 then
+    Result := StrToIntDef(Copy(s, 1, 3), 0);
+  FResultCode := Result;
+end;
+
+function TNNTPSend.ReadData: boolean;
+var
+  s: string;
+begin
+  repeat
+    s := FSock.RecvString(FTimeout);
+    if s = '.' then
+      break;
+    if (s <> '') and (s[1] = '.') then
+      s := Copy(s, 2, Length(s) - 1);
+    FData.Add(s);
+  until FSock.LastError <> 0;
+  Result := FSock.LastError = 0;
+end;
+
+function TNNTPSend.SendData: boolean;
+var
+  s: string;
+  n: integer;
+begin
+  for n := 0 to FDataToSend.Count - 1 do
+  begin
+    s := FDataToSend[n];
+    if (s <> '') and (s[1] = '.') then
+      s := s + '.';
+    FSock.SendString(s + CRLF);
+    if FSock.LastError <> 0 then
+      break;
+  end;
+  if FDataToSend.Count = 0 then
+    FSock.SendString(CRLF);
+  if FSock.LastError = 0 then
+    FSock.SendString('.' + CRLF);
+  FDataToSend.Clear;
+  Result := FSock.LastError = 0;
+end;
+
+function TNNTPSend.Connect: Boolean;
+begin
+  FSock.CloseSocket;
+  FSock.Bind(FIPInterface, cAnyPort);
+  if FSock.LastError = 0 then
+    FSock.Connect(FTargetHost, FTargetPort);
+  if FSock.LastError = 0 then
+    if FFullSSL then
+      FSock.SSLDoConnect;
+  Result := FSock.LastError = 0;
+end;
+
+function TNNTPSend.Login: Boolean;
+begin
+  Result := False;
+  FNNTPcap.Clear;
+  if not Connect then
+    Exit;
+  Result := (ReadResult div 100) = 2;
+  ListExtensions;
+  FNNTPcap.Assign(Fdata);
+  if Result then
+    if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then
+      Result := StartTLS;
+  if (FUsername <> '') and Result then
+  begin
+    FSock.SendString('AUTHINFO USER ' + FUsername + CRLF);
+    if (ReadResult div 100) = 3 then
+    begin
+      FSock.SendString('AUTHINFO PASS ' + FPassword + CRLF);
+      Result := (ReadResult div 100) = 2;
+    end;
+  end;
+end;
+
+function TNNTPSend.Logout: Boolean;
+begin
+  FSock.SendString('QUIT' + CRLF);
+  Result := (ReadResult div 100) = 2;
+  FSock.CloseSocket;
+end;
+
+function TNNTPSend.DoCommand(const Command: string): Boolean;
+begin
+  FSock.SendString(Command + CRLF);
+  Result := (ReadResult div 100) = 2;
+  Result := Result and (FSock.LastError = 0);
+end;
+
+function TNNTPSend.DoCommandRead(const Command: string): Boolean;
+begin
+  Result := DoCommand(Command);
+  if Result then
+  begin
+    Result := ReadData;
+    Result := Result and (FSock.LastError = 0);
+  end;
+end;
+
+function TNNTPSend.DoCommandWrite(const Command: string): Boolean;
+var
+  x: integer;
+begin
+  FDataToSend.Assign(FData);
+  FSock.SendString(Command + CRLF);
+  x := (ReadResult div 100);
+  if x = 3 then
+  begin
+    SendData;
+    x := (ReadResult div 100);
+  end;
+  Result := x = 2;
+  Result := Result and (FSock.LastError = 0);
+end;
+
+function TNNTPSend.GetArticle(const Value: string): Boolean;
+var
+  s: string;
+begin
+  s := 'ARTICLE';
+  if Value <> '' then
+    s := s + ' ' + Value;
+  Result := DoCommandRead(s);
+end;
+
+function TNNTPSend.GetBody(const Value: string): Boolean;
+var
+  s: string;
+begin
+  s := 'BODY';
+  if Value <> '' then
+    s := s + ' ' + Value;
+  Result := DoCommandRead(s);
+end;
+
+function TNNTPSend.GetHead(const Value: string): Boolean;
+var
+  s: string;
+begin
+  s := 'HEAD';
+  if Value <> '' then
+    s := s + ' ' + Value;
+  Result := DoCommandRead(s);
+end;
+
+function TNNTPSend.GetStat(const Value: string): Boolean;
+var
+  s: string;
+begin
+  s := 'STAT';
+  if Value <> '' then
+    s := s + ' ' + Value;
+  Result := DoCommand(s);
+end;
+
+function TNNTPSend.SelectGroup(const Value: string): Boolean;
+begin
+  Result := DoCommand('GROUP ' + Value);
+end;
+
+function TNNTPSend.IHave(const MessID: string): Boolean;
+begin
+  Result := DoCommandWrite('IHAVE ' + MessID);
+end;
+
+function TNNTPSend.GotoLast: Boolean;
+begin
+  Result := DoCommand('LAST');
+end;
+
+function TNNTPSend.GotoNext: Boolean;
+begin
+  Result := DoCommand('NEXT');
+end;
+
+function TNNTPSend.ListGroups: Boolean;
+begin
+  Result := DoCommandRead('LIST');
+end;
+
+function TNNTPSend.ListNewGroups(Since: TDateTime): Boolean;
+begin
+  Result := DoCommandRead('NEWGROUPS ' + SimpleDateTime(Since) + ' GMT');
+end;
+
+function TNNTPSend.NewArticles(const Group: string; Since: TDateTime): Boolean;
+begin
+  Result := DoCommandRead('NEWNEWS ' + Group + ' ' + SimpleDateTime(Since) + ' GMT');
+end;
+
+function TNNTPSend.PostArticle: Boolean;
+begin
+  Result := DoCommandWrite('POST');
+end;
+
+function TNNTPSend.SwitchToSlave: Boolean;
+begin
+  Result := DoCommand('SLAVE');
+end;
+
+function TNNTPSend.Xover(xoStart, xoEnd: string): Boolean;
+var
+  s: string;
+begin
+  s := 'XOVER ' + xoStart;
+  if xoEnd <> xoStart then
+    s := s + '-' + xoEnd;
+  Result := DoCommandRead(s);
+end;
+
+function TNNTPSend.StartTLS: Boolean;
+begin
+  Result := False;
+  if FindCap('STARTTLS') <> '' then
+  begin
+    if DoCommand('STARTTLS') then
+    begin
+      Fsock.SSLDoConnect;
+      Result := FSock.LastError = 0;
+    end;
+  end;
+end;
+
+function TNNTPSend.ListExtensions: Boolean;
+begin
+  Result := DoCommandRead('LIST EXTENSIONS');
+end;
+
+function TNNTPSend.FindCap(const Value: string): string;
+var
+  n: Integer;
+  s: string;
+begin
+  s := UpperCase(Value);
+  Result := '';
+  for n := 0 to FNNTPcap.Count - 1 do
+    if Pos(s, UpperCase(FNNTPcap[n])) = 1 then
+    begin
+      Result := FNNTPcap[n];
+      Break;
+    end;
+end;
+
+{==============================================================================}
+
+end.

Units/Synapse/pingsend.pas

@@ -0,0 +1,708 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 004.000.000 |
+|==============================================================================|
+| Content: PING sender                                                         |
+|==============================================================================|
+| Copyright (c)1999-2007, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2000-2007.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(ICMP PING implementation.)
+Allows create PING and TRACEROUTE. Or you can diagnose your network.
+
+This unit using IpHlpApi (on WinXP or higher) if available. Otherwise it trying
+ to use RAW sockets.
+
+Warning: For use of RAW sockets you must have some special rights on some
+ systems. So, it working allways when you have administator/root rights.
+ Otherwise you can have problems!
+
+Note: This unit is NOT portable to .NET!
+  Use native .NET classes for Ping instead.
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$Q-}
+{$R-}
+{$H+}
+
+{$IFDEF CIL}
+  Sorry, this unit is not for .NET!
+{$ENDIF}
+
+unit pingsend;
+
+interface
+
+uses
+  SysUtils,
+  synsock, blcksock, synautil, synafpc, synaip
+{$IFDEF WIN32}
+  , windows
+{$ENDIF}
+  ;
+
+const
+  ICMP_ECHO = 8;
+  ICMP_ECHOREPLY = 0;
+  ICMP_UNREACH = 3;
+  ICMP_TIME_EXCEEDED = 11;
+//rfc-2292
+  ICMP6_ECHO = 128;
+  ICMP6_ECHOREPLY = 129;
+  ICMP6_UNREACH = 1;
+  ICMP6_TIME_EXCEEDED = 3;
+
+type
+  {:List of possible ICMP reply packet types.}
+  TICMPError = (
+    IE_NoError,
+    IE_Other,
+    IE_TTLExceed,
+    IE_UnreachOther,
+    IE_UnreachRoute,
+    IE_UnreachAdmin,
+    IE_UnreachAddr,
+    IE_UnreachPort
+    );
+
+  {:@abstract(Implementation of ICMP PING and ICMPv6 PING.)}
+  TPINGSend = class(TSynaClient)
+  private
+    FSock: TICMPBlockSocket;
+    FBuffer: string;
+    FSeq: Integer;
+    FId: Integer;
+    FPacketSize: Integer;
+    FPingTime: Integer;
+    FIcmpEcho: Byte;
+    FIcmpEchoReply: Byte;
+    FIcmpUnreach: Byte;
+    FReplyFrom: string;
+    FReplyType: byte;
+    FReplyCode: byte;
+    FReplyError: TICMPError;
+    FReplyErrorDesc: string;
+    FTTL: Byte;
+    Fsin: TVarSin;
+    function Checksum(Value: string): Word;
+    function Checksum6(Value: string): Word;
+    function ReadPacket: Boolean;
+    procedure TranslateError;
+    procedure TranslateErrorIpHlp(value: integer);
+    function InternalPing(const Host: string): Boolean;
+    function InternalPingIpHlp(const Host: string): Boolean;
+    function IsHostIP6(const Host: string): Boolean;
+    procedure GenErrorDesc;
+  public
+    {:Send ICMP ping to host and count @link(pingtime). If ping OK, result is
+     @true.}
+    function Ping(const Host: string): Boolean;
+    constructor Create;
+    destructor Destroy; override;
+  published
+    {:Size of PING packet. Default size is 32 bytes.}
+    property PacketSize: Integer read FPacketSize Write FPacketSize;
+
+    {:Time between request and reply.}
+    property PingTime: Integer read FPingTime;
+
+    {:From this address is sended reply for your PING request. It maybe not your
+     requested destination, when some error occured!}
+    property ReplyFrom: string read FReplyFrom;
+
+    {:ICMP type of PING reply. Each protocol using another values! For IPv4 and
+     IPv6 are used different values!}
+    property ReplyType: byte read FReplyType;
+
+    {:ICMP code of PING reply. Each protocol using another values! For IPv4 and
+     IPv6 are used different values! For protocol independent value look to
+     @link(ReplyError)}
+    property ReplyCode: byte read FReplyCode;
+
+    {:Return type of returned ICMP message. This value is independent on used
+     protocol!}
+    property ReplyError: TICMPError read FReplyError;
+
+    {:Return human readable description of returned packet type.}
+    property ReplyErrorDesc: string read FReplyErrorDesc;
+
+    {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
+    property Sock: TICMPBlockSocket read FSock;
+
+    {:TTL value for ICMP query}
+    property TTL: byte read FTTL write FTTL;
+  end;
+
+{:A very useful function and example of its use would be found in the TPINGSend
+ object. Use it to ping to any host. If successful, returns the ping time in
+ milliseconds.  Returns -1 if an error occurred.}
+function PingHost(const Host: string): Integer;
+
+{:A very useful function and example of its use would be found in the TPINGSend
+ object. Use it to TraceRoute to any host.}
+function TraceRouteHost(const Host: string): string;
+
+implementation
+
+type
+  {:Record for ICMP ECHO packet header.}
+  TIcmpEchoHeader = record
+    i_type: Byte;
+    i_code: Byte;
+    i_checkSum: Word;
+    i_Id: Word;
+    i_seq: Word;
+    TimeStamp: integer;
+  end;
+
+  {:record used internally by TPingSend for compute checksum of ICMPv6 packet
+   pseudoheader.}
+  TICMP6Packet = record
+    in_source: TInAddr6;
+    in_dest: TInAddr6;
+    Length: integer;
+    free0: Byte;
+    free1: Byte;
+    free2: Byte;
+    proto: Byte;
+  end;
+
+{$IFDEF WIN32}
+const
+  DLLIcmpName = 'iphlpapi.dll';
+type
+  TIP_OPTION_INFORMATION = packed record
+    TTL: Byte;
+    TOS: Byte;
+    Flags: Byte;
+    OptionsSize: Byte;
+    OptionsData: PChar;
+  end;
+  PIP_OPTION_INFORMATION = ^TIP_OPTION_INFORMATION;
+
+  TICMP_ECHO_REPLY = packed record
+    Address: TInAddr;
+    Status: integer;
+    RoundTripTime: integer;
+    DataSize: Word;
+    Reserved: Word;
+    Data: pointer;
+    Options: TIP_OPTION_INFORMATION;
+  end;
+  PICMP_ECHO_REPLY = ^TICMP_ECHO_REPLY;
+
+  TICMPV6_ECHO_REPLY = packed record
+    Address: TSockAddrIn6;
+    Status: integer;
+    RoundTripTime: integer;
+  end;
+  PICMPV6_ECHO_REPLY = ^TICMPV6_ECHO_REPLY;
+
+  TIcmpCreateFile = function: integer; stdcall;
+  TIcmpCloseHandle = function(handle: integer): boolean; stdcall;
+  TIcmpSendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer;
+    ApcContext: pointer; DestinationAddress: TInAddr; RequestData: pointer;
+    RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION;
+    ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall;
+  TIcmp6CreateFile = function: integer; stdcall;
+  TIcmp6SendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer;
+    ApcContext: pointer; SourceAddress: PSockAddrIn6; DestinationAddress: PSockAddrIn6;
+    RequestData: pointer; RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION;
+    ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall;
+
+var
+  IcmpDllHandle: TLibHandle = 0;
+  IcmpHelper4: boolean = false;
+  IcmpHelper6: boolean = false;
+  IcmpCreateFile: TIcmpCreateFile = nil;
+  IcmpCloseHandle: TIcmpCloseHandle = nil;
+  IcmpSendEcho2: TIcmpSendEcho2 = nil;
+  Icmp6CreateFile: TIcmp6CreateFile = nil;
+  Icmp6SendEcho2: TIcmp6SendEcho2 = nil;
+{$ENDIF}
+{==============================================================================}
+
+constructor TPINGSend.Create;
+begin
+  inherited Create;
+  FSock := TICMPBlockSocket.Create;
+  FTimeout := 5000;
+  FPacketSize := 32;
+  FSeq := 0;
+  Randomize;
+  FTTL := 128;
+end;
+
+destructor TPINGSend.Destroy;
+begin
+  FSock.Free;
+  inherited Destroy;
+end;
+
+function TPINGSend.ReadPacket: Boolean;
+begin
+  FBuffer := FSock.RecvPacket(Ftimeout);
+  Result := FSock.LastError = 0;
+end;
+
+procedure TPINGSend.GenErrorDesc;
+begin
+  case FReplyError of
+    IE_NoError:
+      FReplyErrorDesc := '';
+    IE_Other:
+      FReplyErrorDesc := 'Unknown error';
+    IE_TTLExceed:
+      FReplyErrorDesc := 'TTL Exceeded';
+    IE_UnreachOther:
+      FReplyErrorDesc := 'Unknown unreachable';
+    IE_UnreachRoute:
+      FReplyErrorDesc := 'No route to destination';
+    IE_UnreachAdmin:
+      FReplyErrorDesc := 'Administratively prohibited';
+    IE_UnreachAddr:
+      FReplyErrorDesc := 'Address unreachable';
+    IE_UnreachPort:
+      FReplyErrorDesc := 'Port unreachable';
+  end;
+end;
+
+function TPINGSend.IsHostIP6(const Host: string): Boolean;
+var
+  f: integer;
+begin
+  f := AF_UNSPEC;
+  if IsIp(Host) then
+    f := AF_INET
+  else
+    if IsIp6(Host) then
+      f := AF_INET6;
+  synsock.SetVarSin(Fsin, host, '0', f,
+    IPPROTO_UDP, SOCK_DGRAM, Fsock.PreferIP4);
+  result := Fsin.sin_family = AF_INET6;
+end;
+
+function TPINGSend.Ping(const Host: string): Boolean;
+var
+  b: boolean;
+begin
+  FPingTime := -1;
+  FReplyFrom := '';
+  FReplyType := 0;
+  FReplyCode := 0;
+  FReplyError := IE_Other;
+  GenErrorDesc;
+  FBuffer := StringOfChar(#55, SizeOf(TICMPEchoHeader) + FPacketSize);
+{$IFDEF WIN32}
+  b := IsHostIP6(host);
+  if not(b) and IcmpHelper4 then
+    result := InternalPingIpHlp(host)
+  else
+    if b and IcmpHelper6 then
+      result := InternalPingIpHlp(host)
+    else
+      result := InternalPing(host);
+{$ELSE}
+   result := InternalPing(host);
+{$ENDIF}
+end;
+
+function TPINGSend.InternalPing(const Host: string): Boolean;
+var
+  IPHeadPtr: ^TIPHeader;
+  IpHdrLen: Integer;
+  IcmpEchoHeaderPtr: ^TICMPEchoHeader;
+  t: Boolean;
+  x: cardinal;
+  IcmpReqHead: string;
+begin
+  Result := False;
+  FSock.TTL := FTTL;
+  FSock.Bind(FIPInterface, cAnyPort);
+  FSock.Connect(Host, '0');
+  if FSock.LastError <> 0 then
+    Exit;
+  FSock.SizeRecvBuffer := 60 * 1024;
+  if FSock.IP6used then
+  begin
+    FIcmpEcho := ICMP6_ECHO;
+    FIcmpEchoReply := ICMP6_ECHOREPLY;
+    FIcmpUnreach := ICMP6_UNREACH;
+  end
+  else
+  begin
+    FIcmpEcho := ICMP_ECHO;
+    FIcmpEchoReply := ICMP_ECHOREPLY;
+    FIcmpUnreach := ICMP_UNREACH;
+  end;
+  IcmpEchoHeaderPtr := Pointer(FBuffer);
+  with IcmpEchoHeaderPtr^ do
+  begin
+    i_type := FIcmpEcho;
+    i_code := 0;
+    i_CheckSum := 0;
+    FId := System.Random(32767);
+    i_Id := FId;
+    TimeStamp := GetTick;
+    Inc(FSeq);
+    i_Seq := FSeq;
+    if fSock.IP6used then
+      i_CheckSum := CheckSum6(FBuffer)
+    else
+      i_CheckSum := CheckSum(FBuffer);
+  end;
+  FSock.SendString(FBuffer);
+  // remember first 8 bytes of ICMP packet
+  IcmpReqHead := Copy(FBuffer, 1, 8);
+  x := GetTick;
+  repeat
+    t := ReadPacket;
+    if not t then
+      break;
+    if fSock.IP6used then
+    begin
+{$IFNDEF WIN32}
+      IcmpEchoHeaderPtr := Pointer(FBuffer);
+{$ELSE}
+//WinXP SP1 with networking update doing this think by another way ;-O
+//      FBuffer := StringOfChar(#0, 4) + FBuffer;
+      IcmpEchoHeaderPtr := Pointer(FBuffer);
+//      IcmpEchoHeaderPtr^.i_type := FIcmpEchoReply;
+{$ENDIF}
+    end
+    else
+    begin
+      IPHeadPtr := Pointer(FBuffer);
+      IpHdrLen := (IPHeadPtr^.VerLen and $0F) * 4;
+      IcmpEchoHeaderPtr := @FBuffer[IpHdrLen + 1];
+    end;
+  //check for timeout
+    if TickDelta(x, GetTick) > FTimeout then
+    begin
+      t := false;
+      Break;
+    end;
+  //it discard sometimes possible 'echoes' of previosly sended packet
+  //or other unwanted ICMP packets...
+  until (IcmpEchoHeaderPtr^.i_type <> FIcmpEcho)
+    and ((IcmpEchoHeaderPtr^.i_id = FId)
+    or (Pos(IcmpReqHead, FBuffer) > 0));
+  if t then
+    begin
+      FPingTime := TickDelta(x, GetTick);
+      FReplyFrom := FSock.GetRemoteSinIP;
+      FReplyType := IcmpEchoHeaderPtr^.i_type;
+      FReplyCode := IcmpEchoHeaderPtr^.i_code;
+      TranslateError;
+      Result := True;
+    end;
+end;
+
+function TPINGSend.Checksum(Value: string): Word;
+var
+  CkSum: integer;
+  Num, Remain: Integer;
+  n, i: Integer;
+begin
+  Num := Length(Value) div 2;
+  Remain := Length(Value) mod 2;
+  CkSum := 0;
+  i := 1;
+  for n := 0 to Num - 1 do
+  begin
+    CkSum := CkSum + Synsock.HtoNs(DecodeInt(Value, i));
+    inc(i, 2);
+  end;
+  if Remain <> 0 then
+    CkSum := CkSum + Ord(Value[Length(Value)]);
+  CkSum := (CkSum shr 16) + (CkSum and $FFFF);
+  CkSum := CkSum + (CkSum shr 16);
+  Result := Word(not CkSum);
+end;
+
+function TPINGSend.Checksum6(Value: string): Word;
+const
+  IOC_OUT = $40000000;
+  IOC_IN = $80000000;
+  IOC_INOUT = (IOC_IN or IOC_OUT);
+  IOC_WS2 = $08000000;
+  SIO_ROUTING_INTERFACE_QUERY = 20 or IOC_WS2 or IOC_INOUT;
+var
+  ICMP6Ptr: ^TICMP6Packet;
+  s: string;
+  b: integer;
+  ip6: TSockAddrIn6;
+  x: integer;
+begin
+  Result := 0;
+{$IFDEF WIN32}
+  s := StringOfChar(#0, SizeOf(TICMP6Packet)) + Value;
+  ICMP6Ptr := Pointer(s);
+  x := synsock.WSAIoctl(FSock.Socket, SIO_ROUTING_INTERFACE_QUERY,
+    @FSock.RemoteSin, SizeOf(FSock.RemoteSin),
+    @ip6, SizeOf(ip6), @b, nil, nil);
+  if x <> -1 then
+    ICMP6Ptr^.in_dest := ip6.sin6_addr
+  else
+    ICMP6Ptr^.in_dest := FSock.LocalSin.sin6_addr;
+  ICMP6Ptr^.in_source := FSock.RemoteSin.sin6_addr;
+  ICMP6Ptr^.Length := synsock.htonl(Length(Value));
+  ICMP6Ptr^.proto := IPPROTO_ICMPV6;
+  Result := Checksum(s);
+{$ENDIF}
+end;
+
+procedure TPINGSend.TranslateError;
+begin
+  if fSock.IP6used then
+  begin
+    case FReplyType of
+      ICMP6_ECHOREPLY:
+        FReplyError := IE_NoError;
+      ICMP6_TIME_EXCEEDED:
+        FReplyError := IE_TTLExceed;
+      ICMP6_UNREACH:
+        case FReplyCode of
+          0:
+            FReplyError := IE_UnreachRoute;
+          3:
+            FReplyError := IE_UnreachAddr;
+          4:
+            FReplyError := IE_UnreachPort;
+          1:
+            FReplyError := IE_UnreachAdmin;
+        else
+          FReplyError := IE_UnreachOther;
+        end;
+    else
+      FReplyError := IE_Other;
+    end;
+  end
+  else
+  begin
+    case FReplyType of
+      ICMP_ECHOREPLY:
+        FReplyError := IE_NoError;
+      ICMP_TIME_EXCEEDED:
+        FReplyError := IE_TTLExceed;
+      ICMP_UNREACH:
+        case FReplyCode of
+          0:
+            FReplyError := IE_UnreachRoute;
+          1:
+            FReplyError := IE_UnreachAddr;
+          3:
+            FReplyError := IE_UnreachPort;
+          13:
+            FReplyError := IE_UnreachAdmin;
+        else
+          FReplyError := IE_UnreachOther;
+        end;
+    else
+      FReplyError := IE_Other;
+    end;
+  end;
+  GenErrorDesc;
+end;
+
+procedure TPINGSend.TranslateErrorIpHlp(value: integer);
+begin
+  case value of
+    11000, 0:
+      FReplyError := IE_NoError;
+    11013:
+      FReplyError := IE_TTLExceed;
+    11002:
+      FReplyError := IE_UnreachRoute;
+    11003:
+      FReplyError := IE_UnreachAddr;
+    11005:
+      FReplyError := IE_UnreachPort;
+    11004:
+      FReplyError := IE_UnreachAdmin;
+  else
+    FReplyError := IE_Other;
+  end;
+  GenErrorDesc;
+end;
+
+function TPINGSend.InternalPingIpHlp(const Host: string): Boolean;
+{$IFDEF WIN32}
+var
+  PingIp6: boolean;
+  PingHandle: integer;
+  r: integer;
+  ipo: TIP_OPTION_INFORMATION;
+  RBuff: string;
+  ip4reply: PICMP_ECHO_REPLY;
+  ip6reply: PICMPV6_ECHO_REPLY;
+  ip6: TSockAddrIn6;
+begin
+  Result := False;
+  PingIp6 := Fsin.sin_family = AF_INET6;
+  if pingIp6 then
+    PingHandle := Icmp6CreateFile
+  else
+    PingHandle := IcmpCreateFile;
+  if PingHandle <> -1 then
+  begin
+    try
+      ipo.TTL := FTTL;
+      ipo.TOS := 0;
+      ipo.Flags := 0;
+      ipo.OptionsSize := 0;
+      ipo.OptionsData := nil;
+      setlength(RBuff, 4096);
+      if pingIp6 then
+      begin
+        FillChar(ip6, sizeof(ip6), 0);
+        r := Icmp6SendEcho2(PingHandle, nil, nil, nil, @ip6, @Fsin,
+          Pchar(FBuffer), length(FBuffer), @ipo, pchar(RBuff), length(RBuff), FTimeout);
+        if r > 0 then
+        begin
+          RBuff := #0 + #0 + RBuff;
+          ip6reply := PICMPV6_ECHO_REPLY(pointer(RBuff));
+          FPingTime := ip6reply^.RoundTripTime;
+          ip6reply^.Address.sin6_family := AF_INET6;
+          FReplyFrom := GetSinIp(TVarSin(ip6reply^.Address));
+          TranslateErrorIpHlp(ip6reply^.Status);
+          Result := True;
+        end;
+      end
+      else
+      begin
+        r := IcmpSendEcho2(PingHandle, nil, nil, nil, Fsin.sin_addr,
+          Pchar(FBuffer), length(FBuffer), @ipo, pchar(RBuff), length(RBuff), FTimeout);
+        if r > 0 then
+        begin
+          ip4reply := PICMP_ECHO_REPLY(pointer(RBuff));
+          FPingTime := ip4reply^.RoundTripTime;
+          FReplyFrom := IpToStr(swapbytes(ip4reply^.Address.S_addr));
+          TranslateErrorIpHlp(ip4reply^.Status);
+          Result := True;
+        end;
+      end
+    finally
+      IcmpCloseHandle(PingHandle);
+    end;
+  end;
+end;
+{$ELSE}
+begin
+  result := false;
+end;
+{$ENDIF}
+
+{==============================================================================}
+
+function PingHost(const Host: string): Integer;
+begin
+  with TPINGSend.Create do
+  try
+    Result := -1;
+    if Ping(Host) then
+      if ReplyError = IE_NoError then
+        Result := PingTime;
+  finally
+    Free;
+  end;
+end;
+
+function TraceRouteHost(const Host: string): string;
+var
+  Ping: TPingSend;
+  ttl : byte;
+begin
+  Result := '';
+  Ping := TPINGSend.Create;
+  try
+    ttl := 1;
+    repeat
+      ping.TTL := ttl;
+      inc(ttl);
+      if ttl > 30 then
+        Break;
+      if not ping.Ping(Host) then
+      begin
+        Result := Result + cAnyHost+ ' Timeout' + CRLF;
+        continue;
+      end;
+      if (ping.ReplyError <> IE_NoError)
+        and (ping.ReplyError <> IE_TTLExceed) then
+      begin
+        Result := Result + Ping.ReplyFrom + ' ' + Ping.ReplyErrorDesc + CRLF;
+        break;
+      end;
+      Result := Result + Ping.ReplyFrom + ' ' + IntToStr(Ping.PingTime) + CRLF;
+    until ping.ReplyError = IE_NoError;
+  finally
+    Ping.Free;
+  end;
+end;
+
+{$IFDEF WIN32}
+initialization
+begin
+  IcmpHelper4 := false;
+  IcmpHelper6 := false;
+  IcmpDllHandle := LoadLibrary(DLLIcmpName);
+  if IcmpDllHandle <> 0 then
+  begin
+    IcmpCreateFile := GetProcAddress(IcmpDLLHandle, 'IcmpCreateFile');
+    IcmpCloseHandle := GetProcAddress(IcmpDLLHandle, 'IcmpCloseHandle');
+    IcmpSendEcho2 := GetProcAddress(IcmpDLLHandle, 'IcmpSendEcho2');
+    Icmp6CreateFile := GetProcAddress(IcmpDLLHandle, 'Icmp6CreateFile');
+    Icmp6SendEcho2 := GetProcAddress(IcmpDLLHandle, 'Icmp6SendEcho2');
+    IcmpHelper4 := assigned(IcmpCreateFile)
+      and assigned(IcmpCloseHandle)
+      and assigned(IcmpSendEcho2);
+    IcmpHelper6 := assigned(Icmp6CreateFile)
+      and assigned(Icmp6SendEcho2);
+  end;
+end;
+
+finalization
+begin
+  FreeLibrary(IcmpDllHandle);
+end;
+{$ENDIF}
+
+end.

Units/Synapse/pop3send.pas

@@ -0,0 +1,476 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 002.006.000 |
+|==============================================================================|
+| Content: POP3 client                                                         |
+|==============================================================================|
+| Copyright (c)1999-2007, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2001-2007.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(POP3 protocol client)
+
+Used RFC: RFC-1734, RFC-1939, RFC-2195, RFC-2449, RFC-2595
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+unit pop3send;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synautil, synacode;
+
+const
+  cPop3Protocol = '110';
+
+type
+
+  {:The three types of possible authorization methods for "logging in" to a POP3
+   server.}
+  TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP);
+
+  {:@abstract(Implementation of POP3 client protocol.)
+
+   Note: Are you missing properties for setting Username and Password? Look to
+   parent @link(TSynaClient) object!
+
+   Are you missing properties for specify server address and port? Look to
+   parent @link(TSynaClient) too!}
+  TPOP3Send = class(TSynaClient)
+  private
+    FSock: TTCPBlockSocket;
+    FResultCode: Integer;
+    FResultString: string;
+    FFullResult: TStringList;
+    FStatCount: Integer;
+    FStatSize: Integer;
+    FListSize: Integer;
+    FTimeStamp: string;
+    FAuthType: TPOP3AuthType;
+    FPOP3cap: TStringList;
+    FAutoTLS: Boolean;
+    FFullSSL: Boolean;
+    function ReadResult(Full: Boolean): Integer;
+    function Connect: Boolean;
+    function AuthLogin: Boolean;
+    function AuthApop: Boolean;
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:You can call any custom by this method. Call Command without trailing CRLF.
+      If MultiLine parameter is @true, multilined response are expected.
+      Result is @true on sucess.}
+    function CustomCommand(const Command: string; MultiLine: Boolean): boolean;
+
+    {:Call CAPA command for get POP3 server capabilites.
+     note: not all servers support this command!}
+    function Capability: Boolean;
+
+    {:Connect to remote POP3 host. If all OK, result is @true.}
+    function Login: Boolean;
+
+    {:Disconnects from POP3 server.}
+    function Logout: Boolean;
+
+    {:Send RSET command. If all OK, result is @true.}
+    function Reset: Boolean;
+
+    {:Send NOOP command. If all OK, result is @true.}
+    function NoOp: Boolean;
+
+    {:Send STAT command and fill @link(StatCount) and @link(StatSize) property.
+     If all OK, result is @true.}
+    function Stat: Boolean;
+
+    {:Send LIST command. If Value is 0, LIST is for all messages. After
+     successful operation is listing in FullResult. If all OK, result is @True.}
+    function List(Value: Integer): Boolean;
+
+    {:Send RETR command. After successful operation dowloaded message in
+     @link(FullResult). If all OK, result is @true.}
+    function Retr(Value: Integer): Boolean;
+
+    {:Send RETR command. After successful operation dowloaded message in
+     @link(Stream). If all OK, result is @true.}
+    function RetrStream(Value: Integer; Stream: TStream): Boolean;
+
+    {:Send DELE command for delete specified message. If all OK, result is @true.}
+    function Dele(Value: Integer): Boolean;
+
+    {:Send TOP command. After successful operation dowloaded headers of message
+     and maxlines count of message in @link(FullResult). If all OK, result is
+     @true.}
+    function Top(Value, Maxlines: Integer): Boolean;
+
+    {:Send UIDL command. If Value is 0, UIDL is for all messages. After
+     successful operation is listing in FullResult. If all OK, result is @True.}
+    function Uidl(Value: Integer): Boolean;
+
+    {:Call STLS command for upgrade connection to SSL/TLS mode.}
+    function StartTLS: Boolean;
+
+    {:Try to find given capabily in capabilty string returned from POP3 server
+     by CAPA command.}
+    function FindCap(const Value: string): string;
+  published
+    {:Result code of last POP3 operation. 0 - error, 1 - OK.}
+    property ResultCode: Integer read FResultCode;
+
+    {:Result string of last POP3 operation.}
+    property ResultString: string read FResultString;
+
+    {:Stringlist with full lines returned as result of POP3 operation. I.e. if
+     operation is LIST, this property is filled by list of messages. If
+     operation is RETR, this property have downloaded message.}
+    property FullResult: TStringList read FFullResult;
+
+    {:After STAT command is there count of messages in inbox.}
+    property StatCount: Integer read FStatCount;
+
+    {:After STAT command is there size of all messages in inbox.}
+    property StatSize: Integer read  FStatSize;
+
+    {:After LIST 0 command size of all messages on server, After LIST x size of message x on server}
+    property ListSize: Integer read  FListSize;
+
+    {:If server support this, after comnnect is in this property timestamp of
+     remote server.}
+    property TimeStamp: string read FTimeStamp;
+
+    {:Type of authorisation for login to POP3 server. Dafault is autodetect one
+     of possible authorisation. Autodetect do this:
+
+     If remote POP3 server support APOP, try login by APOP method. If APOP is
+     not supported, or if APOP login failed, try classic USER+PASS login method.}
+    property AuthType: TPOP3AuthType read FAuthType Write FAuthType;
+
+    {:If is set to @true, then upgrade to SSL/TLS mode if remote server support it.}
+    property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
+
+    {:SSL/TLS mode is used from first contact to server. Servers with full
+     SSL/TLS mode usualy using non-standard TCP port!}
+    property FullSSL: Boolean read FFullSSL Write FFullSSL;
+    {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
+    property Sock: TTCPBlockSocket read FSock;
+  end;
+
+implementation
+
+constructor TPOP3Send.Create;
+begin
+  inherited Create;
+  FFullResult := TStringList.Create;
+  FPOP3cap := TStringList.Create;
+  FSock := TTCPBlockSocket.Create;
+  FSock.ConvertLineEnd := true;
+  FTimeout := 60000;
+  FTargetPort := cPop3Protocol;
+  FStatCount := 0;
+  FStatSize := 0;
+  FListSize := 0;
+  FAuthType := POP3AuthAll;
+  FAutoTLS := False;
+  FFullSSL := False;
+end;
+
+destructor TPOP3Send.Destroy;
+begin
+  FSock.Free;
+  FPOP3cap.Free;
+  FullResult.Free;
+  inherited Destroy;
+end;
+
+function TPOP3Send.ReadResult(Full: Boolean): Integer;
+var
+  s: string;
+begin
+  Result := 0;
+  FFullResult.Clear;
+  s := FSock.RecvString(FTimeout);
+  if Pos('+OK', s) = 1 then
+    Result := 1;
+  FResultString := s;
+  if Full and (Result = 1) then
+    repeat
+      s := FSock.RecvString(FTimeout);
+      if s = '.' then
+        Break;
+      if s <> '' then
+        if s[1] = '.' then
+          Delete(s, 1, 1);
+      FFullResult.Add(s);
+    until FSock.LastError <> 0;
+  if not Full and (Result = 1) then
+    FFullResult.Add(SeparateRight(FResultString, ' '));
+  if FSock.LastError <> 0 then
+    Result := 0;
+  FResultCode := Result;
+end;
+
+function TPOP3Send.CustomCommand(const Command: string; MultiLine: Boolean): boolean;
+begin
+  FSock.SendString(Command + CRLF);
+  Result := ReadResult(MultiLine) <> 0;
+end;
+
+function TPOP3Send.AuthLogin: Boolean;
+begin
+  Result := False;
+  if not CustomCommand('USER ' + FUserName, False) then
+    exit;
+  Result := CustomCommand('PASS ' + FPassword, False)
+end;
+
+function TPOP3Send.AuthAPOP: Boolean;
+var
+  s: string;
+begin
+  s := StrToHex(MD5(FTimeStamp + FPassWord));
+  Result := CustomCommand('APOP ' + FUserName + ' ' + s, False);
+end;
+
+function TPOP3Send.Connect: Boolean;
+begin
+  // Do not call this function! It is calling by LOGIN method!
+  FStatCount := 0;
+  FStatSize := 0;
+  FSock.CloseSocket;
+  FSock.LineBuffer := '';
+  FSock.Bind(FIPInterface, cAnyPort);
+  if FSock.LastError = 0 then
+    FSock.Connect(FTargetHost, FTargetPort);
+  if FSock.LastError = 0 then
+    if FFullSSL then
+      FSock.SSLDoConnect;
+  Result := FSock.LastError = 0;
+end;
+
+function TPOP3Send.Capability: Boolean;
+begin
+  FPOP3cap.Clear;
+  Result := CustomCommand('CAPA', True);
+  if Result then
+    FPOP3cap.AddStrings(FFullResult);
+end;
+
+function TPOP3Send.Login: Boolean;
+var
+  s, s1: string;
+begin
+  Result := False;
+  FTimeStamp := '';
+  if not Connect then
+    Exit;
+  if ReadResult(False) <> 1 then
+    Exit;
+  s := SeparateRight(FResultString, '<');
+  if s <> FResultString then
+  begin
+    s1 := Trim(SeparateLeft(s, '>'));
+    if s1 <> s then
+      FTimeStamp := '<' + s1 + '>';
+  end;
+  Result := False;
+  if Capability then
+    if FAutoTLS and (Findcap('STLS') <> '') then
+      if StartTLS then
+        Capability
+      else
+      begin
+        Result := False;
+        Exit;
+      end;
+  if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then
+  begin
+    Result := AuthApop;
+    if not Result then
+    begin
+      if not Connect then
+        Exit;
+      if ReadResult(False) <> 1 then
+        Exit;
+    end;
+  end;
+  if not Result and not (FAuthType = POP3AuthAPOP) then
+    Result := AuthLogin;
+end;
+
+function TPOP3Send.Logout: Boolean;
+begin
+  Result := CustomCommand('QUIT', False);
+  FSock.CloseSocket;
+end;
+
+function TPOP3Send.Reset: Boolean;
+begin
+  Result := CustomCommand('RSET', False);
+end;
+
+function TPOP3Send.NoOp: Boolean;
+begin
+  Result := CustomCommand('NOOP', False);
+end;
+
+function TPOP3Send.Stat: Boolean;
+var
+  s: string;
+begin
+  Result := CustomCommand('STAT', False);
+  if Result then
+  begin
+    s := SeparateRight(ResultString, '+OK ');
+    FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0);
+    FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0);
+  end;
+end;
+
+function TPOP3Send.List(Value: Integer): Boolean;
+var
+  s: string;
+  n: integer;
+begin
+  if Value = 0 then
+    s := 'LIST'
+  else
+    s := 'LIST ' + IntToStr(Value);
+  Result := CustomCommand(s, Value = 0);
+  FListSize := 0;
+  if Result then
+    if Value <> 0 then
+    begin
+      s := SeparateRight(ResultString, '+OK ');
+      FListSize := StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0);
+    end
+    else
+      for n := 0 to FFullResult.Count - 1 do
+        FListSize := FListSize + StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0);
+end;
+
+function TPOP3Send.Retr(Value: Integer): Boolean;
+begin
+  Result := CustomCommand('RETR ' + IntToStr(Value), True);
+end;
+
+//based on code by Miha Vrhovnik
+function TPOP3Send.RetrStream(Value: Integer; Stream: TStream): Boolean;
+var
+  s: string;
+begin
+  Result := False;
+  FFullResult.Clear;
+  Stream.Size := 0;
+  FSock.SendString('RETR ' + IntToStr(Value) + CRLF);
+
+  s := FSock.RecvString(FTimeout);
+  if Pos('+OK', s) = 1 then
+    Result := True;
+  FResultString := s;
+  if Result then begin
+    repeat
+      s := FSock.RecvString(FTimeout);
+      if s = '.' then
+        Break;
+      if s <> '' then begin
+        if s[1] = '.' then
+          Delete(s, 1, 1);
+      end;
+      WriteStrToStream(Stream, s);
+      WriteStrToStream(Stream, CRLF);
+    until FSock.LastError <> 0;
+  end;
+
+  if Result then
+    FResultCode := 1
+  else
+    FResultCode := 0;
+end;
+
+function TPOP3Send.Dele(Value: Integer): Boolean;
+begin
+  Result := CustomCommand('DELE ' + IntToStr(Value), False);
+end;
+
+function TPOP3Send.Top(Value, Maxlines: Integer): Boolean;
+begin
+  Result := CustomCommand('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines), True);
+end;
+
+function TPOP3Send.Uidl(Value: Integer): Boolean;
+var
+  s: string;
+begin
+  if Value = 0 then
+    s := 'UIDL'
+  else
+    s := 'UIDL ' + IntToStr(Value);
+  Result := CustomCommand(s, Value = 0);
+end;
+
+function TPOP3Send.StartTLS: Boolean;
+begin
+  Result := False;
+  if CustomCommand('STLS', False) then
+  begin
+    Fsock.SSLDoConnect;
+    Result := FSock.LastError = 0;
+  end;
+end;
+
+function TPOP3Send.FindCap(const Value: string): string;
+var
+  n: Integer;
+  s: string;
+begin
+  s := UpperCase(Value);
+  Result := '';
+  for n := 0 to FPOP3cap.Count - 1 do
+    if Pos(s, UpperCase(FPOP3cap[n])) = 1 then
+    begin
+      Result := FPOP3cap[n];
+      Break;
+    end;
+end;
+
+end.

Units/Synapse/slogsend.pas

@@ -0,0 +1,319 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.002.002 |
+|==============================================================================|
+| Content: SysLog client                                                       |
+|==============================================================================|
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2001-2003.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|    Christian Brosius                                                         |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(BSD SYSLOG protocol)
+
+Used RFC: RFC-3164
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$Q-}
+{$H+}
+
+unit slogsend;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synautil;
+
+const
+  cSysLogProtocol = '514';
+
+  FCL_Kernel = 0;
+  FCL_UserLevel = 1;
+  FCL_MailSystem = 2;
+  FCL_System = 3;
+  FCL_Security = 4;
+  FCL_Syslogd = 5;
+  FCL_Printer = 6;
+  FCL_News = 7;
+  FCL_UUCP = 8;
+  FCL_Clock = 9;
+  FCL_Authorization = 10;
+  FCL_FTP = 11;
+  FCL_NTP = 12;
+  FCL_LogAudit = 13;
+  FCL_LogAlert = 14;
+  FCL_Time = 15;
+  FCL_Local0 = 16;
+  FCL_Local1 = 17;
+  FCL_Local2 = 18;
+  FCL_Local3 = 19;
+  FCL_Local4 = 20;
+  FCL_Local5 = 21;
+  FCL_Local6 = 22;
+  FCL_Local7 = 23;
+
+type
+  {:@abstract(Define possible priority of Syslog message)}
+  TSyslogSeverity = (Emergency, Alert, Critical, Error, Warning, Notice, Info,
+    Debug);
+
+  {:@abstract(encoding or decoding of SYSLOG message)}
+  TSyslogMessage = class(TObject)
+  private
+    FFacility:Byte;
+    FSeverity:TSyslogSeverity;
+    FDateTime:TDateTime;
+    FTag:String;
+    FMessage:String;
+    FLocalIP:String;
+    function GetPacketBuf:String;
+    procedure SetPacketBuf(Value:String);
+  public
+    {:Reset values to defaults}
+    procedure Clear;
+  published
+    {:Define facilicity of Syslog message. For specify you may use predefined
+     FCL_* constants. Default is "FCL_Local0".}
+    property Facility:Byte read FFacility write FFacility;
+
+    {:Define possible priority of Syslog message. Default is "Debug".}
+    property Severity:TSyslogSeverity read FSeverity write FSeverity;
+
+    {:date and time of Syslog message}
+    property DateTime:TDateTime read FDateTime write FDateTime;
+
+    {:This is used for identify process of this message. Default is filename
+     of your executable file.}
+    property Tag:String read FTag write FTag;
+
+    {:Text of your message for log.}
+    property LogMessage:String read FMessage write FMessage;
+
+    {:IP address of message sender.}
+    property LocalIP:String read FLocalIP write FLocalIP;
+
+    {:This property holds encoded binary SYSLOG packet}
+    property PacketBuf:String read GetPacketBuf write SetPacketBuf;
+  end;
+
+  {:@abstract(This object implement BSD SysLog client)
+
+   Note: Are you missing properties for specify server address and port? Look to
+   parent @link(TSynaClient) too!}
+  TSyslogSend = class(TSynaClient)
+  private
+    FSock: TUDPBlockSocket;
+    FSysLogMessage: TSysLogMessage;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    {:Send Syslog UDP packet defined by @link(SysLogMessage).}
+    function DoIt: Boolean;
+  published
+    {:Syslog message for send}
+    property SysLogMessage:TSysLogMessage read FSysLogMessage write FSysLogMessage;
+  end;
+
+{:Simply send packet to specified Syslog server.}
+function ToSysLog(const SyslogServer: string; Facil: Byte;
+  Sever: TSyslogSeverity; const Content: string): Boolean;
+
+implementation
+
+function TSyslogMessage.GetPacketBuf:String;
+begin
+  Result := '<' + IntToStr((FFacility * 8) + Ord(FSeverity)) + '>';
+  Result := Result + CDateTime(FDateTime) + ' ';
+  Result := Result + FLocalIP + ' ';
+  Result := Result + FTag + ': ' + FMessage;
+end;
+
+procedure TSyslogMessage.SetPacketBuf(Value:String);
+var StrBuf:String;
+    IntBuf,Pos:Integer;
+begin
+  if Length(Value) < 1 then exit;
+  Pos := 1;
+  if Value[Pos] <> '<' then exit;
+  Inc(Pos);
+  // Facility and Severity
+  StrBuf := '';
+  while (Value[Pos] <> '>')do
+  begin
+    StrBuf := StrBuf + Value[Pos];
+    Inc(Pos);
+  end;
+  IntBuf := StrToInt(StrBuf);
+  FFacility := IntBuf div 8;
+  case (IntBuf mod 8)of
+    0:FSeverity := Emergency;
+    1:FSeverity := Alert;
+    2:FSeverity := Critical;
+    3:FSeverity := Error;
+    4:FSeverity := Warning;
+    5:FSeverity := Notice;
+    6:FSeverity := Info;
+    7:FSeverity := Debug;
+  end;
+  // DateTime
+  Inc(Pos);
+  StrBuf := '';
+    // Month
+  while (Value[Pos] <> ' ')do
+    begin
+      StrBuf := StrBuf + Value[Pos];
+      Inc(Pos);
+    end;
+    StrBuf := StrBuf + Value[Pos];
+    Inc(Pos);
+    // Day
+  while (Value[Pos] <> ' ')do
+    begin
+      StrBuf := StrBuf + Value[Pos];
+      Inc(Pos);
+    end;
+    StrBuf := StrBuf + Value[Pos];
+    Inc(Pos);
+    // Time
+  while (Value[Pos] <> ' ')do
+    begin
+      StrBuf := StrBuf + Value[Pos];
+      Inc(Pos);
+    end;
+  FDateTime := DecodeRFCDateTime(StrBuf);
+  Inc(Pos);
+
+  // LocalIP
+  StrBuf := '';
+  while (Value[Pos] <> ' ')do
+    begin
+      StrBuf := StrBuf + Value[Pos];
+      Inc(Pos);
+    end;
+  FLocalIP := StrBuf;
+  Inc(Pos);
+  // Tag
+  StrBuf := '';
+  while (Value[Pos] <> ':')do
+    begin
+      StrBuf := StrBuf + Value[Pos];
+      Inc(Pos);
+    end;
+  FTag := StrBuf;
+  // LogMessage
+  Inc(Pos);
+  StrBuf := '';
+  while (Pos <= Length(Value))do
+    begin
+      StrBuf := StrBuf + Value[Pos];
+      Inc(Pos);
+    end;
+  FMessage := TrimSP(StrBuf);
+end;
+
+procedure TSysLogMessage.Clear;
+begin
+  FFacility := FCL_Local0;
+  FSeverity := Debug;
+  FTag := ExtractFileName(ParamStr(0));
+  FMessage := '';
+  FLocalIP  := '0.0.0.0';
+end;
+
+//------------------------------------------------------------------------------
+
+constructor TSyslogSend.Create;
+begin
+  inherited Create;
+  FSock := TUDPBlockSocket.Create;
+  FSysLogMessage := TSysLogMessage.Create;
+  FTargetPort := cSysLogProtocol;
+end;
+
+destructor TSyslogSend.Destroy;
+begin
+  FSock.Free;
+  FSysLogMessage.Free;
+  inherited Destroy;
+end;
+
+function TSyslogSend.DoIt: Boolean;
+var
+  L: TStringList;
+begin
+  Result := False;
+  L := TStringList.Create;
+  try
+    FSock.ResolveNameToIP(FSock.Localname, L);
+    if L.Count < 1 then
+      FSysLogMessage.LocalIP := '0.0.0.0'
+    else
+      FSysLogMessage.LocalIP := L[0];
+  finally
+    L.Free;
+  end;
+  FSysLogMessage.DateTime := Now;
+  if Length(FSysLogMessage.PacketBuf) <= 1024 then
+  begin
+    FSock.Connect(FTargetHost, FTargetPort);
+    FSock.SendString(FSysLogMessage.PacketBuf);
+    Result := FSock.LastError = 0;
+  end;
+end;
+
+{==============================================================================}
+
+function ToSysLog(const SyslogServer: string; Facil: Byte;
+  Sever: TSyslogSeverity; const Content: string): Boolean;
+begin
+  with TSyslogSend.Create do
+    try
+      TargetHost :=SyslogServer;
+      SysLogMessage.Facility := Facil;
+      SysLogMessage.Severity := Sever;
+      SysLogMessage.LogMessage := Content;
+      Result := DoIt;
+    finally
+      Free;
+    end;
+end;
+
+end.

Units/Synapse/smtpsend.pas

@@ -0,0 +1,719 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 003.005.000 |
+|==============================================================================|
+| Content: SMTP client                                                         |
+|==============================================================================|
+| Copyright (c)1999-2009, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c) 1999-2009.               |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(SMTP client)
+
+Used RFC: RFC-1869, RFC-1870, RFC-1893, RFC-2034, RFC-2104, RFC-2195, RFC-2487,
+ RFC-2554, RFC-2821
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+unit smtpsend;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synautil, synacode;
+
+const
+  cSmtpProtocol = '25';
+
+type
+  {:@abstract(Implementation of SMTP and ESMTP procotol),
+   include some ESMTP extensions, include SSL/TLS too.
+
+   Note: Are you missing properties for setting Username and Password for ESMTP?
+   Look to parent @link(TSynaClient) object!
+
+   Are you missing properties for specify server address and port? Look to
+   parent @link(TSynaClient) too!}
+  TSMTPSend = class(TSynaClient)
+  private
+    FSock: TTCPBlockSocket;
+    FResultCode: Integer;
+    FResultString: string;
+    FFullResult: TStringList;
+    FESMTPcap: TStringList;
+    FESMTP: Boolean;
+    FAuthDone: Boolean;
+    FESMTPSize: Boolean;
+    FMaxSize: Integer;
+    FEnhCode1: Integer;
+    FEnhCode2: Integer;
+    FEnhCode3: Integer;
+    FSystemName: string;
+    FAutoTLS: Boolean;
+    FFullSSL: Boolean;
+    procedure EnhancedCode(const Value: string);
+    function ReadResult: Integer;
+    function AuthLogin: Boolean;
+    function AuthCram: Boolean;
+    function AuthPlain: Boolean;
+    function Helo: Boolean;
+    function Ehlo: Boolean;
+    function Connect: Boolean;
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:Connects to SMTP server (defined in @link(TSynaClient.TargetHost)) and
+     begin SMTP session. (First try ESMTP EHLO, next old HELO handshake). Parses
+     ESMTP capabilites and if you specified Username and password and remote
+     server can handle AUTH command, try login by AUTH command. Preffered login
+     method is CRAM-MD5 (if safer!). If all OK, result is @true, else result is
+     @false.}
+    function Login: Boolean;
+
+    {:Close SMTP session (QUIT command) and disconnect from SMTP server.}
+    function Logout: Boolean;
+
+    {:Send RSET SMTP command for reset SMTP session. If all OK, result is @true,
+     else result is @false.}
+    function Reset: Boolean;
+
+    {:Send NOOP SMTP command for keep SMTP session. If all OK, result is @true,
+     else result is @false.}
+    function NoOp: Boolean;
+
+    {:Send MAIL FROM SMTP command for set sender e-mail address. If sender's
+     e-mail address is empty string, transmited message is error message.
+
+     If size not 0 and remote server can handle SIZE parameter, append SIZE
+     parameter to request. If all OK, result is @true, else result is @false.}
+    function MailFrom(const Value: string; Size: Integer): Boolean;
+
+    {:Send RCPT TO SMTP command for set receiver e-mail address. It cannot be an
+     empty string. If all OK, result is @true, else result is @false.}
+    function MailTo(const Value: string): Boolean;
+
+    {:Send DATA SMTP command and transmit message data. If all OK, result is
+     @true, else result is @false.}
+    function MailData(const Value: Tstrings): Boolean;
+
+    {:Send ETRN SMTP command for start sending of remote queue for domain in
+     Value. If all OK, result is @true, else result is @false.}
+    function Etrn(const Value: string): Boolean;
+
+    {:Send VRFY SMTP command for check receiver e-mail address. It cannot be
+     an empty string. If all OK, result is @true, else result is @false.}
+    function Verify(const Value: string): Boolean;
+
+    {:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
+    function StartTLS: Boolean;
+
+    {:Return string descriptive text for enhanced result codes stored in
+     @link(EnhCode1), @link(EnhCode2) and @link(EnhCode3).}
+    function EnhCodeString: string;
+
+    {:Try to find specified capability in ESMTP response.}
+    function FindCap(const Value: string): string;
+  published
+    {:result code of last SMTP command.}
+    property ResultCode: Integer read FResultCode;
+
+    {:result string of last SMTP command (begin with string representation of
+     result code).}
+    property ResultString: string read FResultString;
+
+    {:All result strings of last SMTP command (result is maybe multiline!).}
+    property FullResult: TStringList read FFullResult;
+
+    {:List of ESMTP capabilites of remote ESMTP server. (If you connect to ESMTP
+     server only!).}
+    property ESMTPcap: TStringList read FESMTPcap;
+
+    {:@TRUE if you successfuly logged to ESMTP server.}
+    property ESMTP: Boolean read FESMTP;
+
+    {:@TRUE if you successfuly pass authorisation to remote server.}
+    property AuthDone: Boolean read FAuthDone;
+
+    {:@TRUE if remote server can handle SIZE parameter.}
+    property ESMTPSize: Boolean read FESMTPSize;
+
+    {:When @link(ESMTPsize) is @TRUE, contains max length of message that remote
+     server can handle.}
+    property MaxSize: Integer read FMaxSize;
+
+    {:First digit of Enhanced result code. If last operation does not have
+     enhanced result code, values is 0.}
+    property EnhCode1: Integer read FEnhCode1;
+
+    {:Second digit of Enhanced result code. If last operation does not have
+     enhanced result code, values is 0.}
+    property EnhCode2: Integer read FEnhCode2;
+
+    {:Third digit of Enhanced result code. If last operation does not have
+     enhanced result code, values is 0.}
+    property EnhCode3: Integer read FEnhCode3;
+
+    {:name of our system used in HELO and EHLO command. Implicit value is
+     internet address of your machine.}
+    property SystemName: string read FSystemName Write FSystemName;
+
+    {:If is set to true, then upgrade to SSL/TLS mode if remote server support it.}
+    property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
+
+    {:SSL/TLS mode is used from first contact to server. Servers with full
+     SSL/TLS mode usualy using non-standard TCP port!}
+    property FullSSL: Boolean read FFullSSL Write FFullSSL;
+
+    {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
+    property Sock: TTCPBlockSocket read FSock;
+  end;
+
+{:A very useful function and example of its use would be found in the TSMTPsend
+ object. Send maildata (text of e-mail with all SMTP headers! For example when
+ text of message is created by @link(TMimemess) object) from "MailFrom" e-mail
+ address to "MailTo" e-mail address (If you need more then one receiver, then
+ separate their addresses by comma).
+
+ Function sends e-mail to a SMTP server defined in "SMTPhost" parameter.
+ Username and password are used for authorization to the "SMTPhost". If you
+ don't want authorization, set "Username" and "Password" to empty strings. If
+ e-mail message is successfully sent, the result returns @true.
+
+ If you need use different port number then standard, then add this port number
+ to SMTPhost after colon. (i.e. '127.0.0.1:1025')}
+function SendToRaw(const MailFrom, MailTo, SMTPHost: string;
+  const MailData: TStrings; const Username, Password: string): Boolean;
+
+{:A very useful function and example of its use would be found in the TSMTPsend
+ object. Send "Maildata" (text of e-mail without any SMTP headers!) from
+ "MailFrom" e-mail address to "MailTo" e-mail address with "Subject".  (If you
+ need more then one receiver, then separate their addresses by comma).
+
+ This function constructs all needed SMTP headers (with DATE header) and sends
+ the e-mail to the SMTP server defined in the "SMTPhost" parameter. If the
+ e-mail message is successfully sent, the result will be @TRUE.
+
+ If you need use different port number then standard, then add this port number
+ to SMTPhost after colon. (i.e. '127.0.0.1:1025')}
+function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string;
+  const MailData: TStrings): Boolean;
+
+{:A very useful function and example of its use would be found in the TSMTPsend
+ object. Sends "MailData" (text of e-mail without any SMTP headers!) from
+ "MailFrom" e-mail address to "MailTo" e-mail address (If you need more then one
+ receiver, then separate their addresses by comma).
+
+ This function sends the e-mail to the SMTP server defined in the "SMTPhost"
+ parameter. Username and password are used for authorization to the "SMTPhost".
+ If you dont want authorization, set "Username" and "Password" to empty Strings.
+ If the e-mail message is successfully sent, the result will be @TRUE.
+
+ If you need use different port number then standard, then add this port number
+ to SMTPhost after colon. (i.e. '127.0.0.1:1025')}
+function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string;
+  const MailData: TStrings; const Username, Password: string): Boolean;
+
+implementation
+
+constructor TSMTPSend.Create;
+begin
+  inherited Create;
+  FFullResult := TStringList.Create;
+  FESMTPcap := TStringList.Create;
+  FSock := TTCPBlockSocket.Create;
+  FSock.ConvertLineEnd := true;
+  FTimeout := 60000;
+  FTargetPort := cSmtpProtocol;
+  FSystemName := FSock.LocalName;
+  FAutoTLS := False;
+  FFullSSL := False;
+end;
+
+destructor TSMTPSend.Destroy;
+begin
+  FSock.Free;
+  FESMTPcap.Free;
+  FFullResult.Free;
+  inherited Destroy;
+end;
+
+procedure TSMTPSend.EnhancedCode(const Value: string);
+var
+  s, t: string;
+  e1, e2, e3: Integer;
+begin
+  FEnhCode1 := 0;
+  FEnhCode2 := 0;
+  FEnhCode3 := 0;
+  s := Copy(Value, 5, Length(Value) - 4);
+  t := Trim(SeparateLeft(s, '.'));
+  s := Trim(SeparateRight(s, '.'));
+  if t = '' then
+    Exit;
+  if Length(t) > 1 then
+    Exit;
+  e1 := StrToIntDef(t, 0);
+  if e1 = 0 then
+    Exit;
+  t := Trim(SeparateLeft(s, '.'));
+  s := Trim(SeparateRight(s, '.'));
+  if t = '' then
+    Exit;
+  if Length(t) > 3 then
+    Exit;
+  e2 := StrToIntDef(t, 0);
+  t := Trim(SeparateLeft(s, ' '));
+  if t = '' then
+    Exit;
+  if Length(t) > 3 then
+    Exit;
+  e3 := StrToIntDef(t, 0);
+  FEnhCode1 := e1;
+  FEnhCode2 := e2;
+  FEnhCode3 := e3;
+end;
+
+function TSMTPSend.ReadResult: Integer;
+var
+  s: string;
+begin
+  Result := 0;
+  FFullResult.Clear;
+  repeat
+    s := FSock.RecvString(FTimeout);
+    FResultString := s;
+    FFullResult.Add(s);
+    if FSock.LastError <> 0 then
+      Break;
+  until Pos('-', s) <> 4;
+  s := FFullResult[0];
+  if Length(s) >= 3 then
+    Result := StrToIntDef(Copy(s, 1, 3), 0);
+  FResultCode := Result;
+  EnhancedCode(s);
+end;
+
+function TSMTPSend.AuthLogin: Boolean;
+begin
+  Result := False;
+  FSock.SendString('AUTH LOGIN' + CRLF);
+  if ReadResult <> 334 then
+    Exit;
+  FSock.SendString(EncodeBase64(FUsername) + CRLF);
+  if ReadResult <> 334 then
+    Exit;
+  FSock.SendString(EncodeBase64(FPassword) + CRLF);
+  Result := ReadResult = 235;
+end;
+
+function TSMTPSend.AuthCram: Boolean;
+var
+  s: ansistring;
+begin
+  Result := False;
+  FSock.SendString('AUTH CRAM-MD5' + CRLF);
+  if ReadResult <> 334 then
+    Exit;
+  s := Copy(FResultString, 5, Length(FResultString) - 4);
+  s := DecodeBase64(s);
+  s := HMAC_MD5(s, FPassword);
+  s := FUsername + ' ' + StrToHex(s);
+  FSock.SendString(EncodeBase64(s) + CRLF);
+  Result := ReadResult = 235;
+end;
+
+function TSMTPSend.AuthPlain: Boolean;
+var
+  s: ansistring;
+begin
+  Result := False;
+  s := ansichar(0) + FUsername + ansichar(0) + FPassword;
+  FSock.SendString('AUTH PLAIN ' + EncodeBase64(s) + CRLF);
+  Result := ReadResult = 235;
+end;
+
+function TSMTPSend.Connect: Boolean;
+begin
+  FSock.CloseSocket;
+  FSock.Bind(FIPInterface, cAnyPort);
+  if FSock.LastError = 0 then
+    FSock.Connect(FTargetHost, FTargetPort);
+  if FSock.LastError = 0 then
+    if FFullSSL then
+      FSock.SSLDoConnect;
+  Result := FSock.LastError = 0;
+end;
+
+function TSMTPSend.Helo: Boolean;
+var
+  x: Integer;
+begin
+  FSock.SendString('HELO ' + FSystemName + CRLF);
+  x := ReadResult;
+  Result := (x >= 250) and (x <= 259);
+end;
+
+function TSMTPSend.Ehlo: Boolean;
+var
+  x: Integer;
+begin
+  FSock.SendString('EHLO ' + FSystemName + CRLF);
+  x := ReadResult;
+  Result := (x >= 250) and (x <= 259);
+end;
+
+function TSMTPSend.Login: Boolean;
+var
+  n: Integer;
+  auths: string;
+  s: string;
+begin
+  Result := False;
+  FESMTP := True;
+  FAuthDone := False;
+  FESMTPcap.clear;
+  FESMTPSize := False;
+  FMaxSize := 0;
+  if not Connect then
+    Exit;
+  if ReadResult <> 220 then
+    Exit;
+  if not Ehlo then
+  begin
+    FESMTP := False;
+    if not Helo then
+      Exit;
+  end;
+  Result := True;
+  if FESMTP then
+  begin
+    for n := 1 to FFullResult.Count - 1 do
+      FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4));
+    if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then
+      if StartTLS then
+      begin
+        Ehlo;
+        FESMTPcap.Clear;
+        for n := 1 to FFullResult.Count - 1 do
+          FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4));
+      end
+      else
+      begin
+        Result := False;
+        Exit;
+      end;
+    if not ((FUsername = '') and (FPassword = '')) then
+    begin
+      s := FindCap('AUTH ');
+      if s = '' then
+        s := FindCap('AUTH=');
+      auths := UpperCase(s);
+      if s <> '' then
+      begin
+        if Pos('CRAM-MD5', auths) > 0 then
+          FAuthDone := AuthCram;
+        if (not FauthDone) and (Pos('PLAIN', auths) > 0) then
+          FAuthDone := AuthPlain;
+        if (not FauthDone) and (Pos('LOGIN', auths) > 0) then
+          FAuthDone := AuthLogin;
+      end;
+    end;
+    s := FindCap('SIZE');
+    if s <> '' then
+    begin
+      FESMTPsize := True;
+      FMaxSize := StrToIntDef(Copy(s, 6, Length(s) - 5), 0);
+    end;
+  end;
+end;
+
+function TSMTPSend.Logout: Boolean;
+begin
+  FSock.SendString('QUIT' + CRLF);
+  Result := ReadResult = 221;
+  FSock.CloseSocket;
+end;
+
+function TSMTPSend.Reset: Boolean;
+begin
+  FSock.SendString('RSET' + CRLF);
+  Result := ReadResult div 100 = 2;
+end;
+
+function TSMTPSend.NoOp: Boolean;
+begin
+  FSock.SendString('NOOP' + CRLF);
+  Result := ReadResult div 100 = 2;
+end;
+
+function TSMTPSend.MailFrom(const Value: string; Size: Integer): Boolean;
+var
+  s: string;
+begin
+  s := 'MAIL FROM:<' + Value + '>';
+  if FESMTPsize and (Size > 0) then
+    s := s + ' SIZE=' + IntToStr(Size);
+  FSock.SendString(s + CRLF);
+  Result := ReadResult div 100 = 2;
+end;
+
+function TSMTPSend.MailTo(const Value: string): Boolean;
+begin
+  FSock.SendString('RCPT TO:<' + Value + '>' + CRLF);
+  Result := ReadResult div 100 = 2;
+end;
+
+function TSMTPSend.MailData(const Value: TStrings): Boolean;
+var
+  n: Integer;
+  s: string;
+  t: string;
+  x: integer;
+begin
+  Result := False;
+  FSock.SendString('DATA' + CRLF);
+  if ReadResult <> 354 then
+    Exit;
+  t := '';
+  x := 1500;
+  for n := 0 to Value.Count - 1 do
+  begin
+    s := Value[n];
+    if Length(s) >= 1 then
+      if s[1] = '.' then
+        s := '.' + s;
+    if Length(t) + Length(s) >= x then
+    begin
+      FSock.SendString(t);
+      t := '';
+    end;
+    t := t + s + CRLF;
+  end;
+  if t <> '' then
+    FSock.SendString(t);
+  FSock.SendString('.' + CRLF);
+  Result := ReadResult div 100 = 2;
+end;
+
+function TSMTPSend.Etrn(const Value: string): Boolean;
+var
+  x: Integer;
+begin
+  FSock.SendString('ETRN ' + Value + CRLF);
+  x := ReadResult;
+  Result := (x >= 250) and (x <= 259);
+end;
+
+function TSMTPSend.Verify(const Value: string): Boolean;
+var
+  x: Integer;
+begin
+  FSock.SendString('VRFY ' + Value + CRLF);
+  x := ReadResult;
+  Result := (x >= 250) and (x <= 259);
+end;
+
+function TSMTPSend.StartTLS: Boolean;
+begin
+  Result := False;
+  if FindCap('STARTTLS') <> '' then
+  begin
+    FSock.SendString('STARTTLS' + CRLF);
+    if (ReadResult = 220) and (FSock.LastError = 0) then
+    begin
+      Fsock.SSLDoConnect;
+      Result := FSock.LastError = 0;
+    end;
+  end;
+end;
+
+function TSMTPSend.EnhCodeString: string;
+var
+  s, t: string;
+begin
+  s := IntToStr(FEnhCode2) + '.' + IntToStr(FEnhCode3);
+  t := '';
+  if s = '0.0' then t := 'Other undefined Status';
+  if s = '1.0' then t := 'Other address status';
+  if s = '1.1' then t := 'Bad destination mailbox address';
+  if s = '1.2' then t := 'Bad destination system address';
+  if s = '1.3' then t := 'Bad destination mailbox address syntax';
+  if s = '1.4' then t := 'Destination mailbox address ambiguous';
+  if s = '1.5' then t := 'Destination mailbox address valid';
+  if s = '1.6' then t := 'Mailbox has moved';
+  if s = '1.7' then t := 'Bad sender''s mailbox address syntax';
+  if s = '1.8' then t := 'Bad sender''s system address';
+  if s = '2.0' then t := 'Other or undefined mailbox status';
+  if s = '2.1' then t := 'Mailbox disabled, not accepting messages';
+  if s = '2.2' then t := 'Mailbox full';
+  if s = '2.3' then t := 'Message Length exceeds administrative limit';
+  if s = '2.4' then t := 'Mailing list expansion problem';
+  if s = '3.0' then t := 'Other or undefined mail system status';
+  if s = '3.1' then t := 'Mail system full';
+  if s = '3.2' then t := 'System not accepting network messages';
+  if s = '3.3' then t := 'System not capable of selected features';
+  if s = '3.4' then t := 'Message too big for system';
+  if s = '3.5' then t := 'System incorrectly configured';
+  if s = '4.0' then t := 'Other or undefined network or routing status';
+  if s = '4.1' then t := 'No answer from host';
+  if s = '4.2' then t := 'Bad connection';
+  if s = '4.3' then t := 'Routing server failure';
+  if s = '4.4' then t := 'Unable to route';
+  if s = '4.5' then t := 'Network congestion';
+  if s = '4.6' then t := 'Routing loop detected';
+  if s = '4.7' then t := 'Delivery time expired';
+  if s = '5.0' then t := 'Other or undefined protocol status';
+  if s = '5.1' then t := 'Invalid command';
+  if s = '5.2' then t := 'Syntax error';
+  if s = '5.3' then t := 'Too many recipients';
+  if s = '5.4' then t := 'Invalid command arguments';
+  if s = '5.5' then t := 'Wrong protocol version';
+  if s = '6.0' then t := 'Other or undefined media error';
+  if s = '6.1' then t := 'Media not supported';
+  if s = '6.2' then t := 'Conversion required and prohibited';
+  if s = '6.3' then t := 'Conversion required but not supported';
+  if s = '6.4' then t := 'Conversion with loss performed';
+  if s = '6.5' then t := 'Conversion failed';
+  if s = '7.0' then t := 'Other or undefined security status';
+  if s = '7.1' then t := 'Delivery not authorized, message refused';
+  if s = '7.2' then t := 'Mailing list expansion prohibited';
+  if s = '7.3' then t := 'Security conversion required but not possible';
+  if s = '7.4' then t := 'Security features not supported';
+  if s = '7.5' then t := 'Cryptographic failure';
+  if s = '7.6' then t := 'Cryptographic algorithm not supported';
+  if s = '7.7' then t := 'Message integrity failure';
+  s := '???-';
+  if FEnhCode1 = 2 then s := 'Success-';
+  if FEnhCode1 = 4 then s := 'Persistent Transient Failure-';
+  if FEnhCode1 = 5 then s := 'Permanent Failure-';
+  Result := s + t;
+end;
+
+function TSMTPSend.FindCap(const Value: string): string;
+var
+  n: Integer;
+  s: string;
+begin
+  s := UpperCase(Value);
+  Result := '';
+  for n := 0 to FESMTPcap.Count - 1 do
+    if Pos(s, UpperCase(FESMTPcap[n])) = 1 then
+    begin
+      Result := FESMTPcap[n];
+      Break;
+    end;
+end;
+
+{==============================================================================}
+
+function SendToRaw(const MailFrom, MailTo, SMTPHost: string;
+  const MailData: TStrings; const Username, Password: string): Boolean;
+var
+  SMTP: TSMTPSend;
+  s, t: string;
+begin
+  Result := False;
+  SMTP := TSMTPSend.Create;
+  try
+// if you need SOCKS5 support, uncomment next lines:
+    // SMTP.Sock.SocksIP := '127.0.0.1';
+    // SMTP.Sock.SocksPort := '1080';
+// if you need support for upgrade session to TSL/SSL, uncomment next lines:
+    // SMTP.AutoTLS := True;
+// if you need support for TSL/SSL tunnel, uncomment next lines:
+    // SMTP.FullSSL := True;
+    SMTP.TargetHost := Trim(SeparateLeft(SMTPHost, ':'));
+    s := Trim(SeparateRight(SMTPHost, ':'));
+    if (s <> '') and (s <> SMTPHost) then
+      SMTP.TargetPort := s;
+    SMTP.Username := Username;
+    SMTP.Password := Password;
+    if SMTP.Login then
+    begin
+      if SMTP.MailFrom(GetEmailAddr(MailFrom), Length(MailData.Text)) then
+      begin
+        s := MailTo;
+        repeat
+          t := GetEmailAddr(Trim(FetchEx(s, ',', '"')));
+          if t <> '' then
+            Result := SMTP.MailTo(t);
+          if not Result then
+            Break;
+        until s = '';
+        if Result then
+          Result := SMTP.MailData(MailData);
+      end;
+      SMTP.Logout;
+    end;
+  finally
+    SMTP.Free;
+  end;
+end;
+
+function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string;
+  const MailData: TStrings; const Username, Password: string): Boolean;
+var
+  t: TStrings;
+begin
+  t := TStringList.Create;
+  try
+    t.Assign(MailData);
+    t.Insert(0, '');
+    t.Insert(0, 'X-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer');
+    t.Insert(0, 'Subject: ' + Subject);
+    t.Insert(0, 'Date: ' + Rfc822DateTime(now));
+    t.Insert(0, 'To: ' + MailTo);
+    t.Insert(0, 'From: ' + MailFrom);
+    Result := SendToRaw(MailFrom, MailTo, SMTPHost, t, Username, Password);
+  finally
+    t.Free;
+  end;
+end;
+
+function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string;
+  const MailData: TStrings): Boolean;
+begin
+  Result := SendToEx(MailFrom, MailTo, Subject, SMTPHost, MailData, '', '');
+end;
+
+end.

Units/Synapse/sntpsend.pas

@@ -0,0 +1,373 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 003.000.002 |
+|==============================================================================|
+| Content: SNTP client                                                         |
+|==============================================================================|
+| Copyright (c)1999-2007, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2000-2007.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|   Patrick Chevalley                                                          |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract( NTP and SNTP client)
+
+Used RFC: RFC-1305, RFC-2030
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$Q-}
+{$H+}
+
+unit sntpsend;
+
+interface
+
+uses
+  SysUtils,
+  synsock, blcksock, synautil;
+
+const
+  cNtpProtocol = '123';
+
+type
+
+  {:@abstract(Record containing the NTP packet.)}
+  TNtp = packed record
+    mode: Byte;
+    stratum: Byte;
+    poll: Byte;
+    Precision: Byte;
+    RootDelay: Longint;
+    RootDisperson: Longint;
+    RefID: Longint;
+    Ref1: Longint;
+    Ref2: Longint;
+    Org1: Longint;
+    Org2: Longint;
+    Rcv1: Longint;
+    Rcv2: Longint;
+    Xmit1: Longint;
+    Xmit2: Longint;
+  end;
+
+  {:@abstract(Implementation of NTP and SNTP client protocol),
+   include time synchronisation. It can send NTP or SNTP time queries, or it
+   can receive NTP broadcasts too.
+   
+   Note: Are you missing properties for specify server address and port? Look to
+   parent @link(TSynaClient) too!}
+  TSNTPSend = class(TSynaClient)
+  private
+    FNTPReply: TNtp;
+    FNTPTime: TDateTime;
+    FNTPOffset: double;
+    FNTPDelay: double;
+    FMaxSyncDiff: double;
+    FSyncTime: Boolean;
+    FSock: TUDPBlockSocket;
+    FBuffer: string;
+    FLi, FVn, Fmode : byte;
+    function StrToNTP(const Value: AnsiString): TNtp;
+    function NTPtoStr(const Value: Tntp): AnsiString;
+    procedure ClearNTP(var Value: Tntp);
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:Decode 128 bit timestamp used in NTP packet to TDateTime type.}
+    function DecodeTs(Nsec, Nfrac: Longint): TDateTime;
+
+    {:Decode TDateTime type to 128 bit timestamp used in NTP packet.}
+    procedure EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint);
+
+    {:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all
+     is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are
+     valid.}
+    function GetSNTP: Boolean;
+
+    {:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all
+     is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are
+     valid. Result time is after all needed corrections.}
+    function GetNTP: Boolean;
+
+    {:Wait for broadcast NTP packet. If all OK, result is @true and
+     @link(NTPReply) and @link(NTPTime) are valid.}
+    function GetBroadcastNTP: Boolean;
+
+    {:Holds last received NTP packet.}
+    property NTPReply: TNtp read FNTPReply;
+  published
+    {:Date and time of remote NTP or SNTP server. (UTC time!!!)}
+    property NTPTime: TDateTime read FNTPTime;
+
+    {:Offset between your computer and remote NTP or SNTP server.}
+    property NTPOffset: Double read FNTPOffset;
+
+    {:Delay between your computer and remote NTP or SNTP server.}
+    property NTPDelay: Double read FNTPDelay;
+
+    {:Define allowed maximum difference between your time and remote time for
+     synchronising time. If difference is bigger, your system time is not
+     changed!}
+    property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff;
+
+    {:If @true, after successfull getting time is local computer clock
+     synchronised to given time.
+     For synchronising time you must have proper rights! (Usually Administrator)}
+    property SyncTime: Boolean read FSyncTime write FSyncTime;
+
+    {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
+    property Sock: TUDPBlockSocket read FSock;
+  end;
+
+implementation
+
+constructor TSNTPSend.Create;
+begin
+  inherited Create;
+  FSock := TUDPBlockSocket.Create;
+  FTimeout := 5000;
+  FTargetPort := cNtpProtocol;
+  FMaxSyncDiff := 3600;
+  FSyncTime := False;
+end;
+
+destructor TSNTPSend.Destroy;
+begin
+  FSock.Free;
+  inherited Destroy;
+end;
+
+function TSNTPSend.StrToNTP(const Value: AnsiString): TNtp;
+begin
+  if length(FBuffer) >= SizeOf(Result) then
+  begin
+    Result.mode := ord(Value[1]);
+    Result.stratum := ord(Value[2]);
+    Result.poll := ord(Value[3]);
+    Result.Precision := ord(Value[4]);
+    Result.RootDelay := DecodeLongInt(value, 5);
+    Result.RootDisperson := DecodeLongInt(value, 9);
+    Result.RefID := DecodeLongInt(value, 13);
+    Result.Ref1 := DecodeLongInt(value, 17);
+    Result.Ref2 := DecodeLongInt(value, 21);
+    Result.Org1 := DecodeLongInt(value, 25);
+    Result.Org2 := DecodeLongInt(value, 29);
+    Result.Rcv1 := DecodeLongInt(value, 33);
+    Result.Rcv2 := DecodeLongInt(value, 37);
+    Result.Xmit1 := DecodeLongInt(value, 41);
+    Result.Xmit2 := DecodeLongInt(value, 45);
+  end;
+
+end;
+
+function TSNTPSend.NTPtoStr(const Value: Tntp): AnsiString;
+begin
+  SetLength(Result, 4);
+  Result[1] := AnsiChar(Value.mode);
+  Result[2] := AnsiChar(Value.stratum);
+  Result[3] := AnsiChar(Value.poll);
+  Result[4] := AnsiChar(Value.precision);
+  Result := Result + CodeLongInt(Value.RootDelay);
+  Result := Result + CodeLongInt(Value.RootDisperson);
+  Result := Result + CodeLongInt(Value.RefID);
+  Result := Result + CodeLongInt(Value.Ref1);
+  Result := Result + CodeLongInt(Value.Ref2);
+  Result := Result + CodeLongInt(Value.Org1);
+  Result := Result + CodeLongInt(Value.Org2);
+  Result := Result + CodeLongInt(Value.Rcv1);
+  Result := Result + CodeLongInt(Value.Rcv2);
+  Result := Result + CodeLongInt(Value.Xmit1);
+  Result := Result + CodeLongInt(Value.Xmit2);
+end;
+
+procedure TSNTPSend.ClearNTP(var Value: Tntp);
+begin
+  Value.mode := 0;
+  Value.stratum := 0;
+  Value.poll := 0;
+  Value.Precision := 0;
+  Value.RootDelay := 0;
+  Value.RootDisperson := 0;
+  Value.RefID := 0;
+  Value.Ref1 := 0;
+  Value.Ref2 := 0;
+  Value.Org1 := 0;
+  Value.Org2 := 0;
+  Value.Rcv1 := 0;
+  Value.Rcv2 := 0;
+  Value.Xmit1 := 0;
+  Value.Xmit2 := 0;
+end;
+
+function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime;
+const
+  maxi = 4294967295.0;
+var
+  d, d1: Double;
+begin
+  d := Nsec;
+  if d < 0 then
+    d := maxi + d + 1;
+  d1 := Nfrac;
+  if d1 < 0 then
+    d1 := maxi + d1 + 1;
+  d1 := d1 / maxi;
+  d1 := Trunc(d1 * 10000) / 10000;
+  Result := (d + d1) / 86400;
+  Result := Result + 2;
+end;
+
+procedure TSNTPSend.EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint);
+const
+  maxi = 4294967295.0;
+  maxilongint = 2147483647;
+var
+  d, d1: Double;
+begin
+  d  := (dt - 2) * 86400;
+  d1 := frac(d);
+  if d > maxilongint then
+     d := d - maxi - 1;
+  d  := trunc(d);
+  d1 := Trunc(d1 * 10000) / 10000;
+  d1 := d1 * maxi;
+  if d1 > maxilongint then
+     d1 := d1 - maxi - 1;
+  Nsec:=trunc(d);
+  Nfrac:=trunc(d1);
+end;
+
+function TSNTPSend.GetBroadcastNTP: Boolean;
+var
+  x: Integer;
+begin
+  Result := False;
+  FSock.Bind(FIPInterface, FTargetPort);
+  FBuffer := FSock.RecvPacket(FTimeout);
+  if FSock.LastError = 0 then
+  begin
+    x := Length(FBuffer);
+    if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FSock.ResolveName(FTargetHost)) then
+      if x >= SizeOf(NTPReply) then
+      begin
+        FNTPReply := StrToNTP(FBuffer);
+        FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
+        if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
+          SetUTTime(FNTPTime);
+        Result := True;
+      end;
+  end;
+end;
+
+function TSNTPSend.GetSNTP: Boolean;
+var
+  q: TNtp;
+  x: Integer;
+begin
+  Result := False;
+  FSock.CloseSocket;
+  FSock.Bind(FIPInterface, cAnyPort);
+  FSock.Connect(FTargetHost, FTargetPort);
+  ClearNtp(q);
+  q.mode := $1B;
+  FBuffer := NTPtoStr(q);
+  FSock.SendString(FBuffer);
+  FBuffer := FSock.RecvPacket(FTimeout);
+  if FSock.LastError = 0 then
+  begin
+    x := Length(FBuffer);
+    if x >= SizeOf(NTPReply) then
+    begin
+      FNTPReply := StrToNTP(FBuffer);
+      FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
+      if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
+        SetUTTime(FNTPTime);
+      Result := True;
+    end;
+  end;
+end;
+
+function TSNTPSend.GetNTP: Boolean;
+var
+  q: TNtp;
+  x: Integer;
+  t1, t2, t3, t4 : TDateTime;
+begin
+  Result := False;
+  FSock.CloseSocket;
+  FSock.Bind(FIPInterface, cAnyPort);
+  FSock.Connect(FTargetHost, FTargetPort);
+  ClearNtp(q);
+  q.mode := $1B;
+  t1 := GetUTTime;
+  EncodeTs(t1, q.org1, q.org2);
+  FBuffer := NTPtoStr(q);
+  FSock.SendString(FBuffer);
+  FBuffer := FSock.RecvPacket(FTimeout);
+  if FSock.LastError = 0 then
+  begin
+    x := Length(FBuffer);
+    t4 := GetUTTime;
+    if x >= SizeOf(NTPReply) then
+    begin
+      FNTPReply := StrToNTP(FBuffer);
+      FLi := (NTPReply.mode and $C0) shr 6;
+      FVn := (NTPReply.mode and $38) shr 3;
+      Fmode := NTPReply.mode and $07;
+      if (Fli < 3) and (Fmode = 4) and
+         (NTPReply.stratum >= 1) and (NTPReply.stratum <= 15) and
+         (NTPReply.Rcv1 <> 0) and (NTPReply.Xmit1 <> 0)
+         then begin
+           t2 := DecodeTs(NTPReply.Rcv1, NTPReply.Rcv2);
+           t3 := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
+           FNTPDelay := (T4 - T1) - (T2 - T3);
+           FNTPTime := t3 + FNTPDelay / 2;
+           FNTPOffset := (((T2 - T1) + (T3 - T4)) / 2) * 86400;
+           FNTPDelay := FNTPDelay * 86400;
+           if FSyncTime and ((abs(FNTPTime - t1) * 86400) <= FMaxSyncDiff) then
+             SetUTTime(FNTPTime);
+           Result := True;
+           end
+         else result:=false;
+    end;
+  end;
+end;
+
+end.

Units/Synapse/ssfpc.pas

@@ -0,0 +1,891 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.001.000 |
+|==============================================================================|
+| Content: Socket Independent Platform Layer - FreePascal definition include   |
+|==============================================================================|
+| Copyright (c)2006-2009, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2006-2009.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@exclude}
+
+{$IFDEF FPC}
+{For FreePascal 2.x.x}
+
+//{$DEFINE FORCEOLDAPI}
+{Note about define FORCEOLDAPI:
+If you activate this compiler directive, then is allways used old socket API
+for name resolution. If you leave this directive inactive, then the new API
+is used, when running system allows it.
+
+For IPv6 support you must have new API!
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+{$ifdef FreeBSD}
+{$DEFINE SOCK_HAS_SINLEN}               // BSD definition of scoketaddr
+{$endif}
+{$ifdef darwin}
+{$DEFINE SOCK_HAS_SINLEN}               // BSD definition of scoketaddr
+{$endif}
+
+interface
+
+uses
+  SyncObjs, SysUtils, Classes,
+  synafpc, BaseUnix, Unix, termio, sockets, netdb;
+
+function InitSocketInterface(stack: string): Boolean;
+function DestroySocketInterface: Boolean;
+
+const
+  DLLStackName = '';
+  WinsockLevel = $0202;
+
+  cLocalHost = '127.0.0.1';
+  cAnyHost = '0.0.0.0';
+  c6AnyHost = '::0';
+  c6Localhost = '::1';
+  cLocalHostStr = 'localhost';
+
+type
+  TSocket = longint;
+  TAddrFamily = integer;
+
+  TMemory = pointer;
+
+
+type
+  TFDSet = Baseunix.TFDSet;
+  PFDSet = ^TFDSet;
+  Ptimeval = Baseunix.ptimeval;
+  Ttimeval = Baseunix.ttimeval;
+
+const
+  FIONREAD        = termio.FIONREAD;
+  FIONBIO         = termio.FIONBIO;
+  FIOASYNC        = termio.FIOASYNC;
+
+const
+  IPPROTO_IP     =   0;		{ Dummy					}
+  IPPROTO_ICMP   =   1;		{ Internet Control Message Protocol }
+  IPPROTO_IGMP   =   2;		{ Internet Group Management Protocol}
+  IPPROTO_TCP    =   6;		{ TCP           			}
+  IPPROTO_UDP    =   17;	{ User Datagram Protocol		}
+  IPPROTO_IPV6   =   41;
+  IPPROTO_ICMPV6 =   58;
+
+  IPPROTO_RAW    =   255;
+  IPPROTO_MAX    =   256;
+
+type
+  PInAddr = ^TInAddr;
+  TInAddr = sockets.in_addr;
+
+  PSockAddrIn = ^TSockAddrIn;
+  TSockAddrIn = sockets.TInetSockAddr;
+
+
+  TIP_mreq =  record
+    imr_multiaddr: TInAddr;     // IP multicast address of group
+    imr_interface: TInAddr;     // local IP address of interface
+  end;
+
+
+  PInAddr6 = ^TInAddr6;
+  TInAddr6 = sockets.Tin6_addr;
+
+  PSockAddrIn6 = ^TSockAddrIn6;
+  TSockAddrIn6 = sockets.TInetSockAddr6;
+
+
+  TIPv6_mreq = record
+    ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address.
+    ipv6mr_interface: integer;   // Interface index.
+  end;
+
+const
+  INADDR_ANY       = $00000000;
+  INADDR_LOOPBACK  = $7F000001;
+  INADDR_BROADCAST = $FFFFFFFF;
+  INADDR_NONE      = $FFFFFFFF;
+  ADDR_ANY		 = INADDR_ANY;
+  INVALID_SOCKET		= TSocket(NOT(0));
+  SOCKET_ERROR			= -1;
+
+Const
+  IP_TOS             = sockets.IP_TOS;             { int; IP type of service and precedence.  }
+  IP_TTL             = sockets.IP_TTL;             { int; IP time to live.  }
+  IP_HDRINCL         = sockets.IP_HDRINCL;         { int; Header is included with data.  }
+  IP_OPTIONS         = sockets.IP_OPTIONS;         { ip_opts; IP per-packet options.  }
+//  IP_ROUTER_ALERT    = sockets.IP_ROUTER_ALERT;    { bool }
+  IP_RECVOPTS        = sockets.IP_RECVOPTS;        { bool }
+  IP_RETOPTS         = sockets.IP_RETOPTS;         { bool }
+//  IP_PKTINFO         = sockets.IP_PKTINFO;         { bool }
+//  IP_PKTOPTIONS      = sockets.IP_PKTOPTIONS;
+//  IP_PMTUDISC        = sockets.IP_PMTUDISC;        { obsolete name? }
+//  IP_MTU_DISCOVER    = sockets.IP_MTU_DISCOVER;    { int; see below }
+//  IP_RECVERR         = sockets.IP_RECVERR;         { bool }
+//  IP_RECVTTL         = sockets.IP_RECVTTL;         { bool }
+//  IP_RECVTOS         = sockets.IP_RECVTOS;         { bool }
+  IP_MULTICAST_IF    = sockets.IP_MULTICAST_IF;    { in_addr; set/get IP multicast i/f }
+  IP_MULTICAST_TTL   = sockets.IP_MULTICAST_TTL;   { u_char; set/get IP multicast ttl }
+  IP_MULTICAST_LOOP  = sockets.IP_MULTICAST_LOOP;  { i_char; set/get IP multicast loopback }
+  IP_ADD_MEMBERSHIP  = sockets.IP_ADD_MEMBERSHIP;  { ip_mreq; add an IP group membership }
+  IP_DROP_MEMBERSHIP = sockets.IP_DROP_MEMBERSHIP; { ip_mreq; drop an IP group membership }
+
+  SOL_SOCKET    = sockets.SOL_SOCKET;
+
+  SO_DEBUG      = sockets.SO_DEBUG;
+  SO_REUSEADDR  = sockets.SO_REUSEADDR;
+  SO_TYPE       = sockets.SO_TYPE;
+  SO_ERROR      = sockets.SO_ERROR;
+  SO_DONTROUTE  = sockets.SO_DONTROUTE;
+  SO_BROADCAST  = sockets.SO_BROADCAST;
+  SO_SNDBUF     = sockets.SO_SNDBUF;
+  SO_RCVBUF     = sockets.SO_RCVBUF;
+  SO_KEEPALIVE  = sockets.SO_KEEPALIVE;
+  SO_OOBINLINE  = sockets.SO_OOBINLINE;
+//  SO_NO_CHECK   = sockets.SO_NO_CHECK;
+//  SO_PRIORITY   = sockets.SO_PRIORITY;
+  SO_LINGER     = sockets.SO_LINGER;
+//  SO_BSDCOMPAT  = sockets.SO_BSDCOMPAT;
+//  SO_REUSEPORT  = sockets.SO_REUSEPORT;
+//  SO_PASSCRED   = sockets.SO_PASSCRED;
+//  SO_PEERCRED   = sockets.SO_PEERCRED;
+  SO_RCVLOWAT   = sockets.SO_RCVLOWAT;
+  SO_SNDLOWAT   = sockets.SO_SNDLOWAT;
+  SO_RCVTIMEO   = sockets.SO_RCVTIMEO;
+  SO_SNDTIMEO   = sockets.SO_SNDTIMEO;
+{ Security levels - as per NRL IPv6 - don't actually do anything }
+//  SO_SECURITY_AUTHENTICATION       = sockets.SO_SECURITY_AUTHENTICATION;
+//  SO_SECURITY_ENCRYPTION_TRANSPORT = sockets.SO_SECURITY_ENCRYPTION_TRANSPORT;
+//  SO_SECURITY_ENCRYPTION_NETWORK   = sockets.SO_SECURITY_ENCRYPTION_NETWORK;
+//  SO_BINDTODEVICE                  = sockets.SO_BINDTODEVICE;
+{ Socket filtering }
+//  SO_ATTACH_FILTER = sockets.SO_ATTACH_FILTER;
+//  SO_DETACH_FILTER = sockets.SO_DETACH_FILTER;
+
+  SOMAXCONN       = 1024;
+
+  IPV6_UNICAST_HOPS     = sockets.IPV6_UNICAST_HOPS;
+  IPV6_MULTICAST_IF     = sockets.IPV6_MULTICAST_IF;
+  IPV6_MULTICAST_HOPS   = sockets.IPV6_MULTICAST_HOPS;
+  IPV6_MULTICAST_LOOP   = sockets.IPV6_MULTICAST_LOOP;
+  IPV6_JOIN_GROUP       = sockets.IPV6_JOIN_GROUP;
+  IPV6_LEAVE_GROUP      = sockets.IPV6_LEAVE_GROUP;
+
+const
+  SOCK_STREAM     = 1;               { stream socket }
+  SOCK_DGRAM      = 2;               { datagram socket }
+  SOCK_RAW        = 3;               { raw-protocol interface }
+  SOCK_RDM        = 4;               { reliably-delivered message }
+  SOCK_SEQPACKET  = 5;               { sequenced packet stream }
+
+{ TCP options. }
+  TCP_NODELAY     = $0001;
+
+{ Address families. }
+
+  AF_UNSPEC       = 0;               { unspecified }
+  AF_INET         = 2;               { internetwork: UDP, TCP, etc. }
+  AF_INET6        = 10;              { Internetwork Version 6 }
+  AF_MAX          = 24;
+
+{ Protocol families, same as address families for now. }
+  PF_UNSPEC       = AF_UNSPEC;
+  PF_INET         = AF_INET;
+  PF_INET6        = AF_INET6;
+  PF_MAX          = AF_MAX;
+
+type
+{ Structure used for manipulating linger option. }
+  PLinger = ^TLinger;
+  TLinger = packed record
+    l_onoff: integer;
+    l_linger: integer;
+  end;
+
+const
+
+  MSG_OOB       = sockets.MSG_OOB;      // Process out-of-band data.
+  MSG_PEEK      = sockets.MSG_PEEK;     // Peek at incoming messages.
+  MSG_NOSIGNAL  = sockets.MSG_NOSIGNAL; // Do not generate SIGPIPE.
+
+const
+  WSAEINTR = ESysEINTR;
+  WSAEBADF = ESysEBADF;
+  WSAEACCES = ESysEACCES;
+  WSAEFAULT = ESysEFAULT;
+  WSAEINVAL = ESysEINVAL;
+  WSAEMFILE = ESysEMFILE;
+  WSAEWOULDBLOCK = ESysEWOULDBLOCK;
+  WSAEINPROGRESS = ESysEINPROGRESS;
+  WSAEALREADY = ESysEALREADY;
+  WSAENOTSOCK = ESysENOTSOCK;
+  WSAEDESTADDRREQ = ESysEDESTADDRREQ;
+  WSAEMSGSIZE = ESysEMSGSIZE;
+  WSAEPROTOTYPE = ESysEPROTOTYPE;
+  WSAENOPROTOOPT = ESysENOPROTOOPT;
+  WSAEPROTONOSUPPORT = ESysEPROTONOSUPPORT;
+  WSAESOCKTNOSUPPORT = ESysESOCKTNOSUPPORT;
+  WSAEOPNOTSUPP = ESysEOPNOTSUPP;
+  WSAEPFNOSUPPORT = ESysEPFNOSUPPORT;
+  WSAEAFNOSUPPORT = ESysEAFNOSUPPORT;
+  WSAEADDRINUSE = ESysEADDRINUSE;
+  WSAEADDRNOTAVAIL = ESysEADDRNOTAVAIL;
+  WSAENETDOWN = ESysENETDOWN;
+  WSAENETUNREACH = ESysENETUNREACH;
+  WSAENETRESET = ESysENETRESET;
+  WSAECONNABORTED = ESysECONNABORTED;
+  WSAECONNRESET = ESysECONNRESET;
+  WSAENOBUFS = ESysENOBUFS;
+  WSAEISCONN = ESysEISCONN;
+  WSAENOTCONN = ESysENOTCONN;
+  WSAESHUTDOWN = ESysESHUTDOWN;
+  WSAETOOMANYREFS = ESysETOOMANYREFS;
+  WSAETIMEDOUT = ESysETIMEDOUT;
+  WSAECONNREFUSED = ESysECONNREFUSED;
+  WSAELOOP = ESysELOOP;
+  WSAENAMETOOLONG = ESysENAMETOOLONG;
+  WSAEHOSTDOWN = ESysEHOSTDOWN;
+  WSAEHOSTUNREACH = ESysEHOSTUNREACH;
+  WSAENOTEMPTY = ESysENOTEMPTY;
+  WSAEPROCLIM = -1;
+  WSAEUSERS = ESysEUSERS;
+  WSAEDQUOT = ESysEDQUOT;
+  WSAESTALE = ESysESTALE;
+  WSAEREMOTE = ESysEREMOTE;
+  WSASYSNOTREADY = -2;
+  WSAVERNOTSUPPORTED = -3;
+  WSANOTINITIALISED = -4;
+  WSAEDISCON = -5;
+  WSAHOST_NOT_FOUND = 1;
+  WSATRY_AGAIN = 2;
+  WSANO_RECOVERY = 3;
+  WSANO_DATA = -6;
+
+const
+  WSADESCRIPTION_LEN     =   256;
+  WSASYS_STATUS_LEN      =   128;
+type
+  PWSAData = ^TWSAData;
+  TWSAData = packed record
+    wVersion: Word;
+    wHighVersion: Word;
+    szDescription: array[0..WSADESCRIPTION_LEN] of Char;
+    szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char;
+    iMaxSockets: Word;
+    iMaxUdpDg: Word;
+    lpVendorInfo: PChar;
+  end;
+
+  function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
+  function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean;
+  procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
+  procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
+
+var
+  in6addr_any, in6addr_loopback : TInAddr6;
+
+procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet);
+function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean;
+procedure FD_SET(Socket: TSocket; var FDSet: TFDSet);
+procedure FD_ZERO(var FDSet: TFDSet);
+
+{=============================================================================}
+
+var
+  SynSockCS: SyncObjs.TCriticalSection;
+  SockEnhancedApi: Boolean;
+  SockWship6Api: Boolean;
+
+type
+  TVarSin = packed record
+  {$ifdef SOCK_HAS_SINLEN}
+     sin_len     : cuchar;
+  {$endif}
+    case integer of
+      0: (AddressFamily: sa_family_t);
+      1: (
+        case sin_family: sa_family_t of
+          AF_INET: (sin_port: word;
+                    sin_addr: TInAddr;
+                    sin_zero: array[0..7] of Char);
+          AF_INET6: (sin6_port:     word;
+                		sin6_flowinfo: longword;
+      	    	      sin6_addr:     TInAddr6;
+      		          sin6_scope_id: longword);
+          );
+  end;
+
+function SizeOfVarSin(sin: TVarSin): integer;
+
+  function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer;
+  function WSACleanup: Integer;
+  function WSAGetLastError: Integer;
+  function GetHostName: string;
+  function Shutdown(s: TSocket; how: Integer): Integer;
+  function SetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory;
+    optlen: Integer): Integer;
+  function GetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory;
+    var optlen: Integer): Integer;
+  function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+  function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+  function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
+  function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
+  function ntohs(netshort: word): word;
+  function ntohl(netlong: longword): longword;
+  function Listen(s: TSocket; backlog: Integer): Integer;
+  function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer;
+  function htons(hostshort: word): word;
+  function htonl(hostlong: longword): longword;
+  function GetSockName(s: TSocket; var name: TVarSin): Integer;
+  function GetPeerName(s: TSocket; var name: TVarSin): Integer;
+  function Connect(s: TSocket; const name: TVarSin): Integer;
+  function CloseSocket(s: TSocket): Integer;
+  function Bind(s: TSocket; const addr: TVarSin): Integer;
+  function Accept(s: TSocket; var addr: TVarSin): TSocket;
+  function Socket(af, Struc, Protocol: Integer): TSocket;
+  function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
+    timeout: PTimeVal): Longint;
+
+function IsNewApi(Family: integer): Boolean;
+function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
+function GetSinIP(Sin: TVarSin): string;
+function GetSinPort(Sin: TVarSin): Integer;
+procedure ResolveNameToIP(Name: string;  Family, SockProtocol, SockType: integer; const IPList: TStrings);
+function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string;
+function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word;
+
+
+{==============================================================================}
+implementation
+
+
+function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and
+             (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0));
+end;
+
+function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and
+             (a^.u6_addr32[2] = 0) and
+             (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and
+             (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1));
+end;
+
+function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80));
+end;
+
+function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0));
+end;
+
+function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
+begin
+  Result := (a^.u6_addr8[0] = $FF);
+end;
+
+function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean;
+begin
+  Result := (CompareMem( a, b, sizeof(TInAddr6)));
+end;
+
+procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
+begin
+  FillChar(a^, sizeof(TInAddr6), 0);
+end;
+
+procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
+begin
+  FillChar(a^, sizeof(TInAddr6), 0);
+  a^.u6_addr8[15] := 1;
+end;
+
+{=============================================================================}
+
+function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer;
+begin
+  with WSData do
+  begin
+    wVersion := wVersionRequired;
+    wHighVersion := $202;
+    szDescription := 'Synsock - Synapse Platform Independent Socket Layer';
+    szSystemStatus := 'Running on Unix/Linux by FreePascal';
+    iMaxSockets := 32768;
+    iMaxUdpDg := 8192;
+  end;
+  Result := 0;
+end;
+
+function WSACleanup: Integer;
+begin
+  Result := 0;
+end;
+
+function WSAGetLastError: Integer;
+begin
+  Result := fpGetErrno; 
+end;
+
+function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean;
+begin
+  Result := fpFD_ISSET(socket, fdset) <> 0;
+end;
+
+procedure FD_SET(Socket: TSocket; var fdset: TFDSet);
+begin
+  fpFD_SET(Socket, fdset);
+end;
+
+procedure FD_CLR(Socket: TSocket; var fdset: TFDSet);
+begin
+  fpFD_CLR(Socket, fdset);
+end;
+
+procedure FD_ZERO(var fdset: TFDSet);
+begin
+  fpFD_ZERO(fdset);
+end;
+
+{=============================================================================}
+
+function SizeOfVarSin(sin: TVarSin): integer;
+begin
+  case sin.sin_family of
+    AF_INET:
+            Result := SizeOf(TSockAddrIn);
+    AF_INET6:
+            Result := SizeOf(TSockAddrIn6);
+  else
+    Result := 0;
+  end;
+end;
+
+{=============================================================================}
+
+function Bind(s: TSocket; const addr: TVarSin): Integer;
+begin
+  if fpBind(s, @addr, SizeOfVarSin(addr)) = 0 then
+    Result := 0
+  else
+    Result := SOCKET_ERROR;
+end;
+
+function Connect(s: TSocket; const name: TVarSin): Integer;
+begin
+  if fpConnect(s, @name, SizeOfVarSin(name)) = 0 then
+    Result := 0
+  else
+    Result := SOCKET_ERROR;
+end;
+
+function GetSockName(s: TSocket; var name: TVarSin): Integer;
+var
+  len: integer;
+begin
+  len := SizeOf(name);
+  FillChar(name, len, 0);
+  Result := fpGetSockName(s, @name, @Len);
+end;
+
+function GetPeerName(s: TSocket; var name: TVarSin): Integer;
+var
+  len: integer;
+begin
+  len := SizeOf(name);
+  FillChar(name, len, 0);
+  Result := fpGetPeerName(s, @name, @Len);
+end;
+
+function GetHostName: string;
+begin
+  Result := unix.GetHostName;
+end;
+
+function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+begin
+  Result := fpSend(s, pointer(Buf), len, flags);
+end;
+
+function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+begin
+  Result := fpRecv(s, pointer(Buf), len, flags);
+end;
+
+function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
+begin
+  Result := fpSendTo(s, pointer(Buf), len, flags, @addrto, SizeOfVarSin(addrto));
+end;
+
+function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
+var
+  x: integer;
+begin
+  x := SizeOf(from);
+  Result := fpRecvFrom(s, pointer(Buf), len, flags, @from, @x);
+end;
+
+function Accept(s: TSocket; var addr: TVarSin): TSocket;
+var
+  x: integer;
+begin
+  x := SizeOf(addr);
+  Result := fpAccept(s, @addr, @x);
+end;
+
+function Shutdown(s: TSocket; how: Integer): Integer;
+begin
+  Result := fpShutdown(s, how);
+end;
+
+function SetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory;
+  optlen: Integer): Integer;
+begin
+  Result := fpsetsockopt(s, level, optname, pointer(optval), optlen);
+end;
+
+function GetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory;
+  var optlen: Integer): Integer;
+begin
+  Result := fpgetsockopt(s, level, optname, pointer(optval), @optlen);
+end;
+
+function  ntohs(netshort: word): word;
+begin
+  Result := sockets.ntohs(NetShort);
+end;
+
+function  ntohl(netlong: longword): longword;
+begin
+  Result := sockets.ntohl(NetLong);
+end;
+
+function  Listen(s: TSocket; backlog: Integer): Integer;
+begin
+  if fpListen(s, backlog) = 0 then
+    Result := 0
+  else
+    Result := SOCKET_ERROR;
+end;
+
+function  IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer;
+begin
+  Result := fpIoctl(s, cmd, @arg);
+end;
+
+function  htons(hostshort: word): word;
+begin
+  Result := sockets.htons(Hostshort);
+end;
+
+function  htonl(hostlong: longword): longword;
+begin
+  Result := sockets.htonl(HostLong);
+end;
+
+function CloseSocket(s: TSocket): Integer;
+begin
+  Result := sockets.CloseSocket(s);
+end;
+
+function Socket(af, Struc, Protocol: Integer): TSocket;
+begin
+  Result := fpSocket(af, struc, protocol);
+end;
+
+function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
+  timeout: PTimeVal): Longint;
+begin
+  Result := fpSelect(nfds, readfds, writefds, exceptfds, timeout);
+end;
+
+{=============================================================================}
+function IsNewApi(Family: integer): Boolean;
+begin
+  Result := SockEnhancedApi;
+  if not Result then
+    Result := (Family = AF_INET6) and SockWship6Api;
+end;
+
+function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
+var
+  TwoPass: boolean;
+  f1, f2: integer;
+
+  function GetAddr(f:integer): integer;
+  var
+    a4: array [1..1] of in_addr;
+    a6: array [1..1] of Tin6_addr;
+  begin
+    Result := WSAEPROTONOSUPPORT;
+    case f of
+      AF_INET:
+        begin
+          if IP = cAnyHost then
+          begin
+            Sin.sin_family := AF_INET;
+            Result := 0;
+          end
+          else
+          begin
+            if lowercase(IP) = cLocalHostStr then
+              a4[1].s_addr := htonl(INADDR_LOOPBACK)
+            else
+            begin
+              a4[1].s_addr := 0;
+              Result := WSAHOST_NOT_FOUND;
+              a4[1] := StrTonetAddr(IP);
+              if a4[1].s_addr = INADDR_ANY then
+                Resolvename(ip, a4);
+            end;
+            if a4[1].s_addr <> INADDR_ANY then
+            begin
+              Sin.sin_family := AF_INET;
+              sin.sin_addr := a4[1];
+              Result := 0;
+            end;
+          end;
+        end;
+      AF_INET6:
+        begin
+          if IP = c6AnyHost then
+          begin
+            Sin.sin_family := AF_INET6;
+            Result := 0;
+          end
+          else
+          begin
+            if lowercase(IP) = cLocalHostStr then
+              SET_LOOPBACK_ADDR6(@a6[1])
+            else
+            begin
+              Result := WSAHOST_NOT_FOUND;
+              SET_IN6_IF_ADDR_ANY(@a6[1]);
+              a6[1] := StrTonetAddr6(IP);
+              if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then
+                Resolvename6(ip, a6);
+            end;
+            if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then
+            begin
+              Sin.sin_family := AF_INET6;
+              sin.sin6_addr := a6[1];
+              Result := 0;
+            end;
+          end;
+        end;
+    end;
+  end;
+begin
+  Result := 0;
+  FillChar(Sin, Sizeof(Sin), 0);
+  Sin.sin_port := Resolveport(port, family, SockProtocol, SockType);
+  TwoPass := False;
+  if Family = AF_UNSPEC then
+  begin
+    if PreferIP4 then
+    begin
+      f1 := AF_INET;
+      f2 := AF_INET6;
+      TwoPass := True;
+    end
+    else
+    begin
+      f2 := AF_INET;
+      f1 := AF_INET6;
+      TwoPass := True;
+    end;
+  end
+  else
+    f1 := Family;
+  Result := GetAddr(f1);
+  if Result <> 0 then
+    if TwoPass then
+      Result := GetAddr(f2);
+end;
+
+function GetSinIP(Sin: TVarSin): string;
+begin
+  Result := '';
+  case sin.AddressFamily of
+    AF_INET:
+      begin
+        result := NetAddrToStr(sin.sin_addr);
+      end;
+    AF_INET6:
+      begin
+        result := NetAddrToStr6(sin.sin6_addr);
+      end;
+  end;
+end;
+
+function GetSinPort(Sin: TVarSin): Integer;
+begin
+  if (Sin.sin_family = AF_INET6) then
+    Result := synsock.ntohs(Sin.sin6_port)
+  else
+    Result := synsock.ntohs(Sin.sin_port);
+end;
+
+procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings);
+var
+  x, n: integer;
+  a4: array [1..255] of in_addr;
+  a6: array [1..255] of Tin6_addr;
+begin
+  IPList.Clear;
+  if (family = AF_INET) or (family = AF_UNSPEC) then
+  begin
+    if lowercase(name) = cLocalHostStr then
+      IpList.Add(cLocalHost)
+    else
+    begin
+      a4[1] := StrTonetAddr(name);
+      if a4[1].s_addr = INADDR_ANY then
+        x := Resolvename(name, a4)
+      else
+        x := 1;
+      for n := 1  to x do
+        IpList.Add(netaddrToStr(a4[n]));
+    end;
+  end;
+
+  if (family = AF_INET6) or (family = AF_UNSPEC) then
+  begin
+    if lowercase(name) = cLocalHostStr then
+      IpList.Add(c6LocalHost)
+    else
+    begin
+      a6[1] := StrTonetAddr6(name);
+      if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then
+        x := Resolvename6(name, a6)
+      else
+        x := 1;
+      for n := 1  to x do
+        IpList.Add(netaddrToStr6(a6[n]));
+    end;
+  end;
+
+  if IPList.Count = 0 then
+    IPList.Add(cLocalHost);
+end;
+
+function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word;
+var
+  ProtoEnt: TProtocolEntry;
+  ServEnt: TServiceEntry;
+begin
+  Result := synsock.htons(StrToIntDef(Port, 0));
+  if Result = 0 then
+  begin
+    ProtoEnt.Name := '';
+    GetProtocolByNumber(SockProtocol, ProtoEnt);
+    ServEnt.port := 0;
+    GetServiceByName(Port, ProtoEnt.Name, ServEnt);
+    Result := ServEnt.port;  
+  end;
+end;
+
+function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string;
+var
+  n: integer;
+  a4: array [1..1] of in_addr;
+  a6: array [1..1] of Tin6_addr;
+  a: array [1..1] of string;
+begin
+  Result := IP;
+  a4[1] := StrToNetAddr(IP);
+  if a4[1].s_addr <> INADDR_ANY then
+  begin
+//why ResolveAddress need address in HOST order? :-O 
+    n := ResolveAddress(nettohost(a4[1]), a);
+    if n > 0 then
+      Result := a[1];
+  end
+  else
+  begin
+    a6[1] := StrToNetAddr6(IP);
+    n := ResolveAddress6(a6[1], a);
+    if n > 0 then
+      Result := a[1];
+  end;
+end;
+
+{=============================================================================}
+
+function InitSocketInterface(stack: string): Boolean;
+begin
+  SockEnhancedApi := False;
+  SockWship6Api := False;
+//  Libc.Signal(Libc.SIGPIPE, TSignalHandler(Libc.SIG_IGN));
+  Result := True;
+end;
+
+function DestroySocketInterface: Boolean;
+begin
+  Result := True;
+end;
+
+initialization
+begin
+  SynSockCS := SyncObjs.TCriticalSection.Create;
+  SET_IN6_IF_ADDR_ANY (@in6addr_any);
+  SET_LOOPBACK_ADDR6  (@in6addr_loopback);
+end;
+
+finalization
+begin
+  SynSockCS.Free;
+end;
+
+{$ENDIF}
+

Units/Synapse/ssl_cryptlib.pas

@@ -0,0 +1,569 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.001.000 |
+|==============================================================================|
+| Content: SSL/SSH support by Peter Gutmann's CryptLib                         |
+|==============================================================================|
+| Copyright (c)1999-2005, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2005.                     |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(SSL/SSH plugin for CryptLib)
+
+This plugin requires cl32.dll at least version 3.2.0! It can be used on Win32
+and Linux. This library is staticly linked - when you compile your application
+with this plugin, you MUST distribute it with Cryptib library, otherwise you
+cannot run your application!
+
+It can work with keys and certificates stored as PKCS#15 only! It must be stored
+as disk file only, you cannot load them from memory! Each file can hold multiple
+keys and certificates. You must identify it by 'label' stored in
+@link(TSSLCryptLib.PrivateKeyLabel).
+
+If you need to use secure connection and authorize self by certificate
+(each SSL/TLS server or client with client authorization), then use
+@link(TCustomSSL.PrivateKeyFile), @link(TSSLCryptLib.PrivateKeyLabel) and
+@link(TCustomSSL.KeyPassword) properties.
+
+If you need to use server what verifying client certificates, then use
+@link(TCustomSSL.CertCAFile) as PKCS#15 file with public keyas of allowed clients. Clients
+with non-matching certificates will be rejected by cryptLib.
+
+This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS
+server without explicitly assigned key and certificate, then this plugin create
+Ad-Hoc key and certificate for each incomming connection by self. It slowdown
+accepting of new connections!
+
+You can use this plugin for SSHv2 connections too! You must explicitly set
+@link(TCustomSSL.SSLType) to value LT_SSHv2 and set @link(TCustomSSL.username)
+and @link(TCustomSSL.password). You can use special SSH channels too, see
+@link(TCustomSSL).
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+unit ssl_cryptlib;
+
+interface
+
+uses
+  SysUtils,
+  blcksock, synsock, synautil, synacode,
+  cryptlib;
+
+type
+  {:@abstract(class implementing CryptLib SSL/SSH plugin.)
+   Instance of this class will be created for each @link(TTCPBlockSocket).
+   You not need to create instance of this class, all is done by Synapse itself!}
+  TSSLCryptLib = class(TCustomSSL)
+  protected
+    FCryptSession: CRYPT_SESSION;
+    FPrivateKeyLabel: string;
+    FDelCert: Boolean;
+    FReadBuffer: string;
+    function SSLCheck(Value: integer): Boolean;
+    function Init(server:Boolean): Boolean;
+    function DeInit: Boolean;
+    function Prepare(server:Boolean): Boolean;
+    function GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string;
+    function CreateSelfSignedCert(Host: string): Boolean; override;
+    function PopAll: string;
+  public
+    {:See @inherited}
+    constructor Create(const Value: TTCPBlockSocket); override;
+    destructor Destroy; override;
+    {:See @inherited}
+    function LibVersion: String; override;
+    {:See @inherited}
+    function LibName: String; override;
+    {:See @inherited}
+    procedure Assign(const Value: TCustomSSL); override;
+    {:See @inherited and @link(ssl_cryptlib) for more details.}
+    function Connect: boolean; override;
+    {:See @inherited and @link(ssl_cryptlib) for more details.}
+    function Accept: boolean; override;
+    {:See @inherited}
+    function Shutdown: boolean; override;
+    {:See @inherited}
+    function BiShutdown: boolean; override;
+    {:See @inherited}
+    function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
+    {:See @inherited}
+    function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
+    {:See @inherited}
+    function WaitingData: Integer; override;
+    {:See @inherited}
+    function GetSSLVersion: string; override;
+    {:See @inherited}
+    function GetPeerSubject: string; override;
+    {:See @inherited}
+    function GetPeerIssuer: string; override;
+    {:See @inherited}
+    function GetPeerName: string; override;
+    {:See @inherited}
+    function GetPeerFingerprint: string; override;
+  published
+    {:name of certificate/key within PKCS#15 file. It can hold more then one
+     certificate/key and each certificate/key must have unique label within one file.}
+    property PrivateKeyLabel: string read FPrivateKeyLabel Write FPrivateKeyLabel;
+  end;
+
+implementation
+
+{==============================================================================}
+
+constructor TSSLCryptLib.Create(const Value: TTCPBlockSocket);
+begin
+  inherited Create(Value);
+  FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
+  FPrivateKeyLabel := 'synapse';
+  FDelCert := false;
+end;
+
+destructor TSSLCryptLib.Destroy;
+begin
+  DeInit;
+  inherited Destroy;
+end;
+
+procedure TSSLCryptLib.Assign(const Value: TCustomSSL);
+begin
+  inherited Assign(Value);
+  if Value is TSSLCryptLib then
+  begin
+    FPrivateKeyLabel := TSSLCryptLib(Value).privatekeyLabel;
+  end;
+end;
+
+function TSSLCryptLib.GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string;
+var
+  l: integer;
+begin
+  l := 0;
+  cryptGetAttributeString(cryptHandle, attributeType, nil, l);
+  setlength(Result, l);
+  cryptGetAttributeString(cryptHandle, attributeType, pointer(Result), l);
+  setlength(Result, l);
+end;
+
+function TSSLCryptLib.LibVersion: String;
+var
+  x: integer;
+begin
+  Result := GetString(CRYPT_UNUSED, CRYPT_OPTION_INFO_DESCRIPTION);
+  cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MAJORVERSION, x);
+  Result := Result + ' v' + IntToStr(x);
+  cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MINORVERSION, x);
+  Result := Result + '.' + IntToStr(x);
+  cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_STEPPING, x);
+  Result := Result + '.' + IntToStr(x);
+end;
+
+function TSSLCryptLib.LibName: String;
+begin
+  Result := 'ssl_cryptlib';
+end;
+
+function TSSLCryptLib.SSLCheck(Value: integer): Boolean;
+begin
+  Result := true;
+  FLastErrorDesc := '';
+  if Value = CRYPT_ERROR_COMPLETE then
+    Value := 0;
+  FLastError := Value;
+  if FLastError <> 0 then
+  begin
+    Result := False;
+    FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_INT_ERRORMESSAGE);
+  end;
+end;
+
+function TSSLCryptLib.CreateSelfSignedCert(Host: string): Boolean;
+var
+  privateKey: CRYPT_CONTEXT;
+  keyset: CRYPT_KEYSET;
+  cert: CRYPT_CERTIFICATE;
+  publicKey: CRYPT_CONTEXT;
+begin
+  Result := False;
+  if FPrivatekeyFile = '' then
+    FPrivatekeyFile := GetTempFile('', 'key');
+  cryptCreateContext(privateKey, CRYPT_UNUSED, CRYPT_ALGO_RSA);
+  cryptSetAttributeString(privateKey, CRYPT_CTXINFO_LABEL, Pointer(FPrivatekeyLabel),
+    Length(FPrivatekeyLabel));
+  cryptSetAttribute(privateKey, CRYPT_CTXINFO_KEYSIZE, 1024);
+  cryptGenerateKey(privateKey);
+  cryptKeysetOpen(keyset, CRYPT_UNUSED, CRYPT_KEYSET_FILE, PChar(FPrivatekeyFile), CRYPT_KEYOPT_CREATE);
+  FDelCert := True;
+  cryptAddPrivateKey(keyset, privateKey, PChar(FKeyPassword));
+  cryptCreateCert(cert, CRYPT_UNUSED, CRYPT_CERTTYPE_CERTIFICATE);
+  cryptSetAttribute(cert, CRYPT_CERTINFO_XYZZY, 1);
+  cryptGetPublicKey(keyset, publicKey, CRYPT_KEYID_NAME, PChar(FPrivatekeyLabel));
+  cryptSetAttribute(cert, CRYPT_CERTINFO_SUBJECTPUBLICKEYINFO, publicKey);
+  cryptSetAttributeString(cert, CRYPT_CERTINFO_COMMONNAME, Pointer(host), Length(host));
+  cryptSignCert(cert, privateKey);
+  cryptAddPublicKey(keyset, cert);
+  cryptKeysetClose(keyset);
+  cryptDestroyCert(cert);
+  cryptDestroyContext(privateKey);
+  cryptDestroyContext(publicKey);
+  Result := True;
+end;
+
+function TSSLCryptLib.PopAll: string;
+const
+  BufferMaxSize = 32768;
+var
+  Outbuffer: string;
+  WriteLen: integer;
+begin
+  Result := '';
+  repeat
+    setlength(outbuffer, BufferMaxSize);
+    Writelen := 0;
+    SSLCheck(CryptPopData(FCryptSession, @OutBuffer[1], BufferMaxSize, Writelen));
+    if FLastError <> 0 then
+      Break;
+    if WriteLen > 0 then
+    begin
+      setlength(outbuffer, WriteLen);
+      Result := Result + outbuffer;
+    end;
+  until WriteLen = 0;
+end;
+
+function TSSLCryptLib.Init(server:Boolean): Boolean;
+var
+  st: CRYPT_SESSION_TYPE;
+  keysetobj: CRYPT_KEYSET;
+  cryptContext: CRYPT_CONTEXT;
+  x: integer;
+begin
+  Result := False;
+  FLastErrorDesc := '';
+  FLastError := 0;
+  FDelCert := false;
+  FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
+  if server then
+    case FSSLType of
+      LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1:
+        st := CRYPT_SESSION_SSL_SERVER;
+      LT_SSHv2:
+        st := CRYPT_SESSION_SSH_SERVER;
+    else
+      Exit;
+    end
+  else
+    case FSSLType of
+      LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1:
+        st := CRYPT_SESSION_SSL;
+      LT_SSHv2:
+        st := CRYPT_SESSION_SSH;
+    else
+      Exit;
+    end;
+  if not SSLCheck(cryptCreateSession(FcryptSession, CRYPT_UNUSED, st)) then
+    Exit;
+  x := -1;
+  case FSSLType of
+    LT_SSLv3:
+      x := 0;
+    LT_TLSv1:
+      x := 1;
+    LT_TLSv1_1:
+      x := 2;
+  end;
+  if x >= 0 then
+    if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x)) then
+      Exit;
+  if FUsername <> '' then
+  begin
+    cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_USERNAME,
+      Pointer(FUsername), Length(FUsername));
+    cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_PASSWORD,
+      Pointer(FPassword), Length(FPassword));
+  end;
+  if FSSLType = LT_SSHv2 then
+    if FSSHChannelType <> '' then
+    begin
+      cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL, CRYPT_UNUSED);
+      cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_TYPE,
+        Pointer(FSSHChannelType), Length(FSSHChannelType));
+      if FSSHChannelArg1 <> '' then
+        cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG1,
+          Pointer(FSSHChannelArg1), Length(FSSHChannelArg1));
+      if FSSHChannelArg2 <> '' then
+        cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG2,
+          Pointer(FSSHChannelArg2), Length(FSSHChannelArg2));
+    end;
+
+
+  if server and (FPrivatekeyFile = '') then
+  begin
+    if FPrivatekeyLabel = '' then
+      FPrivatekeyLabel := 'synapse';
+    if FkeyPassword = '' then
+      FkeyPassword := 'synapse';
+    CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP));
+  end;
+
+  if (FPrivatekeyLabel <> '') and (FPrivatekeyFile <> '') then
+  begin
+    if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE,
+      PChar(FPrivatekeyFile), CRYPT_KEYOPT_READONLY)) then
+      Exit;
+    try
+    if not SSLCheck(cryptGetPrivateKey(KeySetObj, cryptcontext, CRYPT_KEYID_NAME,
+      PChar(FPrivatekeyLabel), PChar(FKeyPassword))) then
+      Exit;
+    if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_PRIVATEKEY,
+      cryptcontext)) then
+      Exit;
+    finally
+      cryptKeysetClose(keySetObj);
+      cryptDestroyContext(cryptcontext);
+    end;
+  end;
+  if server and FVerifyCert then
+  begin
+    if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE,
+      PChar(FCertCAFile), CRYPT_KEYOPT_READONLY)) then
+      Exit;
+    try
+    if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_KEYSET,
+      keySetObj)) then
+      Exit;
+    finally
+      cryptKeysetClose(keySetObj);
+    end;
+  end;
+  Result := true;
+end;
+
+function TSSLCryptLib.DeInit: Boolean;
+begin
+  Result := True;
+  if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    CryptDestroySession(FcryptSession);
+  FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
+  FSSLEnabled := False;
+  if FDelCert then
+    Deletefile(FPrivatekeyFile);
+end;
+
+function TSSLCryptLib.Prepare(server:Boolean): Boolean;
+begin
+  Result := false;
+  DeInit;
+  if Init(server) then
+    Result := true
+  else
+    DeInit;
+end;
+
+function TSSLCryptLib.Connect: boolean;
+begin
+  Result := False;
+  if FSocket.Socket = INVALID_SOCKET then
+    Exit;
+  if Prepare(false) then
+  begin
+    if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then
+      Exit;
+    if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then
+      Exit;
+    FSSLEnabled := True;
+    Result := True;
+    FReadBuffer := '';
+  end;
+end;
+
+function TSSLCryptLib.Accept: boolean;
+begin
+  Result := False;
+  if FSocket.Socket = INVALID_SOCKET then
+    Exit;
+  if Prepare(true) then
+  begin
+    if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then
+      Exit;
+    if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then
+      Exit;
+    FSSLEnabled := True;
+    Result := True;
+    FReadBuffer := '';
+  end;
+end;
+
+function TSSLCryptLib.Shutdown: boolean;
+begin
+  Result := BiShutdown;
+end;
+
+function TSSLCryptLib.BiShutdown: boolean;
+begin
+  if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 0);
+  DeInit;
+  FReadBuffer := '';
+  Result := True;
+end;
+
+function TSSLCryptLib.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
+var
+  l: integer;
+begin
+  FLastError := 0;
+  FLastErrorDesc := '';
+  SSLCheck(cryptPushData(FCryptSession, Buffer, Len, L));
+  cryptFlushData(FcryptSession);
+  Result := l;
+end;
+
+function TSSLCryptLib.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
+var
+  l: integer;
+begin
+  FLastError := 0;
+  FLastErrorDesc := '';
+  if Length(FReadBuffer) = 0 then
+    FReadBuffer := PopAll;
+  if Len > Length(FReadBuffer) then
+    Len := Length(FReadBuffer);
+  Move(Pointer(FReadBuffer)^, buffer^, Len);
+  Delete(FReadBuffer, 1, Len);
+  Result := Len;
+end;
+
+function TSSLCryptLib.WaitingData: Integer;
+begin
+  Result := Length(FReadBuffer);
+end;
+
+function TSSLCryptLib.GetSSLVersion: string;
+var
+  x: integer;
+begin
+  Result := '';
+  if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    Exit;
+  cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x);
+  if FSSLType in [LT_SSLv3, LT_TLSv1, LT_TLSv1_1, LT_all] then
+    case x of
+      0:
+        Result := 'SSLv3';
+      1:
+        Result := 'TLSv1';
+      2:
+        Result := 'TLSv1.1';
+    end;
+  if FSSLType in [LT_SSHv2] then
+    case x of
+      0:
+        Result := 'SSHv1';
+      1:
+        Result := 'SSHv2';
+    end;
+end;
+
+function TSSLCryptLib.GetPeerSubject: string;
+var
+  cert: CRYPT_CERTIFICATE;
+begin
+  Result := '';
+  if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    Exit;
+  cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
+  cryptSetAttribute(cert, CRYPT_CERTINFO_SUBJECTNAME, CRYPT_UNUSED);
+  Result := GetString(cert, CRYPT_CERTINFO_DN);
+  cryptDestroyCert(cert);
+end;
+
+function TSSLCryptLib.GetPeerName: string;
+var
+  cert: CRYPT_CERTIFICATE;
+begin
+  Result := '';
+  if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    Exit;
+  cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
+  cryptSetAttribute(cert, CRYPT_CERTINFO_ISSUERNAME, CRYPT_UNUSED);
+  Result := GetString(cert, CRYPT_CERTINFO_COMMONNAME);
+  cryptDestroyCert(cert);
+end;
+
+function TSSLCryptLib.GetPeerIssuer: string;
+var
+  cert: CRYPT_CERTIFICATE;
+begin
+  Result := '';
+  if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    Exit;
+  cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
+  cryptSetAttribute(cert, CRYPT_CERTINFO_ISSUERNAME, CRYPT_UNUSED);
+  Result := GetString(cert, CRYPT_CERTINFO_DN);
+  cryptDestroyCert(cert);
+end;
+
+function TSSLCryptLib.GetPeerFingerprint: string;
+var
+  cert: CRYPT_CERTIFICATE;
+begin
+  Result := '';
+  if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    Exit;
+  cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
+  Result := GetString(cert, CRYPT_CERTINFO_FINGERPRINT);
+  Result := MD5(Result);
+  cryptDestroyCert(cert);
+end;
+
+{==============================================================================}
+
+initialization
+  if cryptInit = CRYPT_OK then
+    SSLImplementation := TSSLCryptLib;
+  cryptAddRandom(nil, CRYPT_RANDOM_SLOWPOLL);
+
+finalization
+  cryptEnd;
+
+end.
+

Units/Synapse/ssl_openssl.pas

@@ -0,0 +1,821 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.001.000 |
+|==============================================================================|
+| Content: SSL support by OpenSSL                                              |
+|==============================================================================|
+| Copyright (c)1999-2008, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2005-2008.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+//requires OpenSSL libraries!
+
+{:@abstract(SSL plugin for OpenSSL)
+
+You need OpenSSL libraries version 0.9.7. It can work with 0.9.6 too, but
+application mysteriously crashing when you are using freePascal on Linux.
+Use Kylix on Linux is OK! If you have version 0.9.7 on Linux, then I not see
+any problems with FreePascal.
+
+OpenSSL libraries are loaded dynamicly - you not need OpenSSl librares even you
+compile your application with this unit. SSL just not working when you not have
+OpenSSL libraries.
+
+This plugin have limited support for .NET too! Because is not possible to use
+callbacks with CDECL calling convention under .NET, is not supported
+key/certificate passwords and multithread locking. :-(
+
+For handling keys and certificates you can use this properties:
+
+@link(TCustomSSL.CertificateFile) for PEM or ASN1 DER (cer) format. @br
+@link(TCustomSSL.Certificate) for ASN1 DER format only. @br
+@link(TCustomSSL.PrivateKeyFile) for PEM or ASN1 DER (key) format. @br
+@link(TCustomSSL.PrivateKey) for ASN1 DER format only. @br
+@link(TCustomSSL.CertCAFile) for PEM CA certificate bundle. @br
+@link(TCustomSSL.PFXFile) for PFX format. @br
+@link(TCustomSSL.PFX) for PFX format from binary string. @br
+
+This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS
+server without explicitly assigned key and certificate, then this plugin create
+Ad-Hoc key and certificate for each incomming connection by self. It slowdown
+accepting of new connections!
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+unit ssl_openssl;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synsock, synautil,
+{$IFDEF CIL}
+  System.Text,
+{$ENDIF}
+  ssl_openssl_lib;
+
+type
+  {:@abstract(class implementing OpenSSL SSL plugin.)
+   Instance of this class will be created for each @link(TTCPBlockSocket).
+   You not need to create instance of this class, all is done by Synapse itself!}
+  TSSLOpenSSL = class(TCustomSSL)
+  protected
+    FSsl: PSSL;
+    Fctx: PSSL_CTX;
+    function SSLCheck: Boolean;
+    function SetSslKeys: boolean;
+    function Init(server:Boolean): Boolean;
+    function DeInit: Boolean;
+    function Prepare(server:Boolean): Boolean;
+    function LoadPFX(pfxdata: ansistring): Boolean;
+    function CreateSelfSignedCert(Host: string): Boolean; override;
+  public
+    {:See @inherited}
+    constructor Create(const Value: TTCPBlockSocket); override;
+    destructor Destroy; override;
+    {:See @inherited}
+    function LibVersion: String; override;
+    {:See @inherited}
+    function LibName: String; override;
+    {:See @inherited and @link(ssl_cryptlib) for more details.}
+    function Connect: boolean; override;
+    {:See @inherited and @link(ssl_cryptlib) for more details.}
+    function Accept: boolean; override;
+    {:See @inherited}
+    function Shutdown: boolean; override;
+    {:See @inherited}
+    function BiShutdown: boolean; override;
+    {:See @inherited}
+    function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
+    {:See @inherited}
+    function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
+    {:See @inherited}
+    function WaitingData: Integer; override;
+    {:See @inherited}
+    function GetSSLVersion: string; override;
+    {:See @inherited}
+    function GetPeerSubject: string; override;
+    {:See @inherited}
+    function GetPeerIssuer: string; override;
+    {:See @inherited}
+    function GetPeerName: string; override;
+    {:See @inherited}
+    function GetPeerFingerprint: string; override;
+    {:See @inherited}
+    function GetCertInfo: string; override;
+    {:See @inherited}
+    function GetCipherName: string; override;
+    {:See @inherited}
+    function GetCipherBits: integer; override;
+    {:See @inherited}
+    function GetCipherAlgBits: integer; override;
+    {:See @inherited}
+    function GetVerifyCert: integer; override;
+  end;
+
+implementation
+
+{==============================================================================}
+
+{$IFNDEF CIL}
+function PasswordCallback(buf:PAnsiChar; size:Integer; rwflag:Integer; userdata: Pointer):Integer; cdecl;
+var
+  Password: AnsiString;
+begin
+  Password := '';
+  if TCustomSSL(userdata) is TCustomSSL then
+    Password := TCustomSSL(userdata).KeyPassword;
+  if Length(Password) > (Size - 1) then
+    SetLength(Password, Size - 1);
+  Result := Length(Password);
+  StrLCopy(buf, PAnsiChar(Password + #0), Result + 1);
+end;
+{$ENDIF}
+
+{==============================================================================}
+
+constructor TSSLOpenSSL.Create(const Value: TTCPBlockSocket);
+begin
+  inherited Create(Value);
+  FCiphers := 'DEFAULT';
+  FSsl := nil;
+  Fctx := nil;
+end;
+
+destructor TSSLOpenSSL.Destroy;
+begin
+  DeInit;
+  inherited Destroy;
+end;
+
+function TSSLOpenSSL.LibVersion: String;
+begin
+  Result := SSLeayversion(0);
+end;
+
+function TSSLOpenSSL.LibName: String;
+begin
+  Result := 'ssl_openssl';
+end;
+
+function TSSLOpenSSL.SSLCheck: Boolean;
+var
+{$IFDEF CIL}
+  sb: StringBuilder;
+{$ENDIF}
+  s : AnsiString;
+begin
+  Result := true;
+  FLastErrorDesc := '';
+  FLastError := ErrGetError;
+  ErrClearError;
+  if FLastError <> 0 then
+  begin
+    Result := False;
+{$IFDEF CIL}
+    sb := StringBuilder.Create(256);
+    ErrErrorString(FLastError, sb, 256);
+    FLastErrorDesc := Trim(sb.ToString);
+{$ELSE}
+    s := StringOfChar(#0, 256);
+    ErrErrorString(FLastError, s, Length(s));
+    FLastErrorDesc := s;
+{$ENDIF}
+  end;
+end;
+
+function TSSLOpenSSL.CreateSelfSignedCert(Host: string): Boolean;
+var
+  pk: EVP_PKEY;
+  x: PX509;
+  rsa: PRSA;
+  t: PASN1_UTCTIME;
+  name: PX509_NAME;
+  b: PBIO;
+  xn, y: integer;
+  s: AnsiString;
+{$IFDEF CIL}
+  sb: StringBuilder;
+{$ENDIF}
+begin
+  Result := True;
+  pk := EvpPkeynew;
+  x := X509New;
+  try
+    rsa := RsaGenerateKey(1024, $10001, nil, nil);
+    EvpPkeyAssign(pk, EVP_PKEY_RSA, rsa);
+    X509SetVersion(x, 2);
+    Asn1IntegerSet(X509getSerialNumber(x), 0);
+    t := Asn1UtctimeNew;
+    try
+      X509GmtimeAdj(t, -60 * 60 *24);
+      X509SetNotBefore(x, t);
+      X509GmtimeAdj(t, 60 * 60 * 60 *24);
+      X509SetNotAfter(x, t);
+    finally
+      Asn1UtctimeFree(t);
+    end;
+    X509SetPubkey(x, pk);
+    Name := X509GetSubjectName(x);
+    X509NameAddEntryByTxt(Name, 'C', $1001, 'CZ', -1, -1, 0);
+    X509NameAddEntryByTxt(Name, 'CN', $1001, host, -1, -1, 0);
+    x509SetIssuerName(x, Name);
+    x509Sign(x, pk, EvpGetDigestByName('SHA1'));
+    b := BioNew(BioSMem);
+    try
+      i2dX509Bio(b, x);
+      xn := bioctrlpending(b);
+{$IFDEF CIL}
+      sb := StringBuilder.Create(xn);
+      y := bioread(b, sb, xn);
+      if y > 0 then
+      begin
+        sb.Length := y;
+        s := sb.ToString;
+      end;
+{$ELSE}
+      setlength(s, xn);
+      y := bioread(b, s, xn);
+      if y > 0 then
+        setlength(s, y);
+{$ENDIF}
+    finally
+      BioFreeAll(b);
+    end;
+    FCertificate := s;
+    b := BioNew(BioSMem);
+    try
+      i2dPrivatekeyBio(b, pk);
+      xn := bioctrlpending(b);
+{$IFDEF CIL}
+      sb := StringBuilder.Create(xn);
+      y := bioread(b, sb, xn);
+      if y > 0 then
+      begin
+        sb.Length := y;
+        s := sb.ToString;
+      end;
+{$ELSE}
+      setlength(s, xn);
+      y := bioread(b, s, xn);
+      if y > 0 then
+        setlength(s, y);
+{$ENDIF}
+    finally
+      BioFreeAll(b);
+    end;
+    FPrivatekey := s;
+  finally
+    X509free(x);
+    EvpPkeyFree(pk);
+  end;
+end;
+
+function TSSLOpenSSL.LoadPFX(pfxdata: Ansistring): Boolean;
+var
+  cert, pkey, ca: SslPtr;
+  b: PBIO;
+  p12: SslPtr;
+begin
+  Result := False;
+  b := BioNew(BioSMem);
+  try
+    BioWrite(b, pfxdata, Length(PfxData));
+    p12 := d2iPKCS12bio(b, nil);
+    if not Assigned(p12) then
+      Exit;
+    try
+      cert := nil;
+      pkey := nil;
+      ca := nil;
+      if PKCS12parse(p12, FKeyPassword, pkey, cert, ca) > 0 then
+        if SSLCTXusecertificate(Fctx, cert) > 0 then
+          if SSLCTXusePrivateKey(Fctx, pkey) > 0 then
+            Result := True;
+    finally
+      PKCS12free(p12);
+    end;
+  finally
+    BioFreeAll(b);
+  end;
+end;
+
+function TSSLOpenSSL.SetSslKeys: boolean;
+var
+  st: TFileStream;
+  s: string;
+begin
+  Result := False;
+  if not assigned(FCtx) then
+    Exit;
+  try
+    if FCertificateFile <> '' then
+      if SslCtxUseCertificateChainFile(FCtx, FCertificateFile) <> 1 then
+        if SslCtxUseCertificateFile(FCtx, FCertificateFile, SSL_FILETYPE_PEM) <> 1 then
+          if SslCtxUseCertificateFile(FCtx, FCertificateFile, SSL_FILETYPE_ASN1) <> 1 then
+            Exit;
+    if FCertificate <> '' then
+      if SslCtxUseCertificateASN1(FCtx, length(FCertificate), FCertificate) <> 1 then
+        Exit;
+    SSLCheck;
+    if FPrivateKeyFile <> '' then
+      if SslCtxUsePrivateKeyFile(FCtx, FPrivateKeyFile, SSL_FILETYPE_PEM) <> 1 then
+        if SslCtxUsePrivateKeyFile(FCtx, FPrivateKeyFile, SSL_FILETYPE_ASN1) <> 1 then
+          Exit;
+    if FPrivateKey <> '' then
+      if SslCtxUsePrivateKeyASN1(EVP_PKEY_RSA, FCtx, FPrivateKey, length(FPrivateKey)) <> 1 then
+        Exit;
+    SSLCheck;
+    if FCertCAFile <> '' then
+      if SslCtxLoadVerifyLocations(FCtx, FCertCAFile, '') <> 1 then
+        Exit;
+    if FPFXfile <> '' then
+    begin
+      try
+        st := TFileStream.Create(FPFXfile, fmOpenRead	 or fmShareDenyNone);
+        try
+          s := ReadStrFromStream(st, st.Size);
+        finally
+          st.Free;
+        end;
+        if not LoadPFX(s) then
+          Exit;
+      except
+        on Exception do
+          Exit;
+      end;
+    end;
+    if FPFX <> '' then
+      if not LoadPFX(FPfx) then
+        Exit;
+    SSLCheck;
+    Result := True;
+  finally
+    SSLCheck;
+  end;
+end;
+
+function TSSLOpenSSL.Init(server:Boolean): Boolean;
+var
+  s: AnsiString;
+begin
+  Result := False;
+  FLastErrorDesc := '';
+  FLastError := 0;
+  Fctx := nil;
+  case FSSLType of
+    LT_SSLv2:
+      Fctx := SslCtxNew(SslMethodV2);
+    LT_SSLv3:
+      Fctx := SslCtxNew(SslMethodV3);
+    LT_TLSv1:
+      Fctx := SslCtxNew(SslMethodTLSV1);
+    LT_all:
+      Fctx := SslCtxNew(SslMethodV23);
+  else
+    Exit;
+  end;
+  if Fctx = nil then
+  begin
+    SSLCheck;
+    Exit;
+  end
+  else
+  begin
+    s := FCiphers;
+    SslCtxSetCipherList(Fctx, s);
+    if FVerifyCert then
+      SslCtxSetVerify(FCtx, SSL_VERIFY_PEER, nil)
+    else
+      SslCtxSetVerify(FCtx, SSL_VERIFY_NONE, nil);
+{$IFNDEF CIL}
+    SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback);
+    SslCtxSetDefaultPasswdCbUserdata(FCtx, self);
+{$ENDIF}
+
+    if server and (FCertificateFile = '') and (FCertificate = '')
+      and (FPFXfile = '') and (FPFX = '') then
+    begin
+      CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP));
+    end;
+
+    if not SetSSLKeys then
+      Exit
+    else
+    begin
+      Fssl := nil;
+      Fssl := SslNew(Fctx);
+      if Fssl = nil then
+      begin
+        SSLCheck;
+        exit;
+      end;
+    end;
+  end;
+  Result := true;
+end;
+
+function TSSLOpenSSL.DeInit: Boolean;
+begin
+  Result := True;
+  if assigned (Fssl) then
+    sslfree(Fssl);
+  Fssl := nil;
+  if assigned (Fctx) then
+  begin
+    SslCtxFree(Fctx);
+    Fctx := nil;
+    ErrRemoveState(0);
+  end;
+  FSSLEnabled := False;
+end;
+
+function TSSLOpenSSL.Prepare(server:Boolean): Boolean;
+begin
+  Result := false;
+  DeInit;
+  if Init(server) then
+    Result := true
+  else
+    DeInit;
+end;
+
+function TSSLOpenSSL.Connect: boolean;
+var
+  x: integer;
+begin
+  Result := False;
+  if FSocket.Socket = INVALID_SOCKET then
+    Exit;
+  if Prepare(False) then
+  begin
+{$IFDEF CIL}
+    if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then
+{$ELSE}
+    if sslsetfd(FSsl, FSocket.Socket) < 1 then
+{$ENDIF}
+    begin
+      SSLCheck;
+      Exit;
+    end;
+    x := sslconnect(FSsl);
+    if x < 1 then
+    begin
+      SSLcheck;
+      Exit;
+    end;
+  if FverifyCert then
+    if GetVerifyCert <> 0 then
+      Exit;
+    FSSLEnabled := True;
+    Result := True;
+  end;
+end;
+
+function TSSLOpenSSL.Accept: boolean;
+var
+  x: integer;
+begin
+  Result := False;
+  if FSocket.Socket = INVALID_SOCKET then
+    Exit;
+  if Prepare(True) then
+  begin
+{$IFDEF CIL}
+    if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then
+{$ELSE}
+    if sslsetfd(FSsl, FSocket.Socket) < 1 then
+{$ENDIF}
+    begin
+      SSLCheck;
+      Exit;
+    end;
+    x := sslAccept(FSsl);
+    if x < 1 then
+    begin
+      SSLcheck;
+      Exit;
+    end;
+    FSSLEnabled := True;
+    Result := True;
+  end;
+end;
+
+function TSSLOpenSSL.Shutdown: boolean;
+begin
+  if assigned(FSsl) then
+    sslshutdown(FSsl);
+  DeInit;
+  Result := True;
+end;
+
+function TSSLOpenSSL.BiShutdown: boolean;
+var
+  x: integer;
+begin
+  if assigned(FSsl) then
+  begin
+    x := sslshutdown(FSsl);
+    if x = 0 then
+    begin
+      Synsock.Shutdown(FSocket.Socket, 1);
+      sslshutdown(FSsl);
+    end;
+  end;
+  DeInit;
+  Result := True;
+end;
+
+function TSSLOpenSSL.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
+var
+  err: integer;
+{$IFDEF CIL}
+  s: ansistring;
+{$ENDIF}
+begin
+  FLastError := 0;
+  FLastErrorDesc := '';
+  repeat
+{$IFDEF CIL}
+    s := StringOf(Buffer);
+    Result := SslWrite(FSsl, s, Len);
+{$ELSE}
+    Result := SslWrite(FSsl, Buffer , Len);
+{$ENDIF}
+    err := SslGetError(FSsl, Result);
+  until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE);
+  if err = SSL_ERROR_ZERO_RETURN then
+    Result := 0
+  else
+    if (err <> 0) then
+      FLastError := err;
+end;
+
+function TSSLOpenSSL.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
+var
+  err: integer;
+{$IFDEF CIL}
+  sb: stringbuilder;
+  s: ansistring;
+{$ENDIF}
+begin
+  FLastError := 0;
+  FLastErrorDesc := '';
+  repeat
+{$IFDEF CIL}
+    sb := StringBuilder.Create(Len);
+    Result := SslRead(FSsl, sb, Len);
+    if Result > 0 then
+    begin
+      sb.Length := Result;
+      s := sb.ToString;
+      System.Array.Copy(BytesOf(s), Buffer, length(s));
+    end;
+{$ELSE}
+    Result := SslRead(FSsl, Buffer , Len);
+{$ENDIF}
+    err := SslGetError(FSsl, Result);
+  until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE);
+  if err = SSL_ERROR_ZERO_RETURN then
+    Result := 0
+  else
+    if (err <> 0) then
+      FLastError := err;
+end;
+
+function TSSLOpenSSL.WaitingData: Integer;
+begin
+  Result := sslpending(Fssl);
+end;
+
+function TSSLOpenSSL.GetSSLVersion: string;
+begin
+  if not assigned(FSsl) then
+    Result := ''
+  else
+    Result := SSlGetVersion(FSsl);
+end;
+
+function TSSLOpenSSL.GetPeerSubject: string;
+var
+  cert: PX509;
+  s: ansistring;
+{$IFDEF CIL}
+  sb: StringBuilder;
+{$ENDIF}
+begin
+  if not assigned(FSsl) then
+  begin
+    Result := '';
+    Exit;
+  end;
+  cert := SSLGetPeerCertificate(Fssl);
+  if not assigned(cert) then
+  begin
+    Result := '';
+    Exit;
+  end;
+{$IFDEF CIL}
+  sb := StringBuilder.Create(4096);
+  Result := X509NameOneline(X509GetSubjectName(cert), sb, 4096);
+{$ELSE}
+  setlength(s, 4096);
+  Result := X509NameOneline(X509GetSubjectName(cert), s, Length(s));
+{$ENDIF}
+  X509Free(cert);
+end;
+
+function TSSLOpenSSL.GetPeerName: string;
+var
+  s: ansistring;
+begin
+  s := GetPeerSubject;
+  s := SeparateRight(s, '/CN=');
+  Result := Trim(SeparateLeft(s, '/'));
+end;
+
+function TSSLOpenSSL.GetPeerIssuer: string;
+var
+  cert: PX509;
+  s: ansistring;
+{$IFDEF CIL}
+  sb: StringBuilder;
+{$ENDIF}
+begin
+  if not assigned(FSsl) then
+  begin
+    Result := '';
+    Exit;
+  end;
+  cert := SSLGetPeerCertificate(Fssl);
+  if not assigned(cert) then
+  begin
+    Result := '';
+    Exit;
+  end;
+{$IFDEF CIL}
+  sb := StringBuilder.Create(4096);
+  Result := X509NameOneline(X509GetIssuerName(cert), sb, 4096);
+{$ELSE}
+  setlength(s, 4096);
+  Result := X509NameOneline(X509GetIssuerName(cert), s, Length(s));
+{$ENDIF}
+  X509Free(cert);
+end;
+
+function TSSLOpenSSL.GetPeerFingerprint: string;
+var
+  cert: PX509;
+  x: integer;
+{$IFDEF CIL}
+  sb: StringBuilder;
+{$ENDIF}
+begin
+  if not assigned(FSsl) then
+  begin
+    Result := '';
+    Exit;
+  end;
+  cert := SSLGetPeerCertificate(Fssl);
+  if not assigned(cert) then
+  begin
+    Result := '';
+    Exit;
+  end;
+{$IFDEF CIL}
+  sb := StringBuilder.Create(EVP_MAX_MD_SIZE);
+  X509Digest(cert, EvpGetDigestByName('MD5'), sb, x);
+  sb.Length := x;
+  Result := sb.ToString;
+{$ELSE}
+  setlength(Result, EVP_MAX_MD_SIZE);
+  X509Digest(cert, EvpGetDigestByName('MD5'), Result, x);
+  SetLength(Result, x);
+{$ENDIF}
+  X509Free(cert);
+end;
+
+function TSSLOpenSSL.GetCertInfo: string;
+var
+  cert: PX509;
+  x, y: integer;
+  b: PBIO;
+  s: AnsiString;
+{$IFDEF CIL}
+  sb: stringbuilder;
+{$ENDIF}
+begin
+  if not assigned(FSsl) then
+  begin
+    Result := '';
+    Exit;
+  end;
+  cert := SSLGetPeerCertificate(Fssl);
+  if not assigned(cert) then
+  begin
+    Result := '';
+    Exit;
+  end;
+  b := BioNew(BioSMem);
+  try
+    X509Print(b, cert);
+    x := bioctrlpending(b);
+{$IFDEF CIL}
+    sb := StringBuilder.Create(x);
+    y := bioread(b, sb, x);
+    if y > 0 then
+    begin
+      sb.Length := y;
+      s := sb.ToString;
+    end;
+{$ELSE}
+    setlength(s,x);
+    y := bioread(b,s,x);
+    if y > 0 then
+      setlength(s, y);
+{$ENDIF}
+    Result := ReplaceString(s, LF, CRLF);
+  finally
+    BioFreeAll(b);
+  end;
+end;
+
+function TSSLOpenSSL.GetCipherName: string;
+begin
+  if not assigned(FSsl) then
+    Result := ''
+  else
+    Result := SslCipherGetName(SslGetCurrentCipher(FSsl));
+end;
+
+function TSSLOpenSSL.GetCipherBits: integer;
+var
+  x: integer;
+begin
+  if not assigned(FSsl) then
+    Result := 0
+  else
+    Result := SSLCipherGetBits(SslGetCurrentCipher(FSsl), x);
+end;
+
+function TSSLOpenSSL.GetCipherAlgBits: integer;
+begin
+  if not assigned(FSsl) then
+    Result := 0
+  else
+    SSLCipherGetBits(SslGetCurrentCipher(FSsl), Result);
+end;
+
+function TSSLOpenSSL.GetVerifyCert: integer;
+begin
+  if not assigned(FSsl) then
+    Result := 1
+  else
+    Result := SslGetVerifyResult(FSsl);
+end;
+
+{==============================================================================}
+
+initialization
+  if InitSSLInterface then
+    SSLImplementation := TSSLOpenSSL;
+
+end.

Units/Synapse/ssl_sbb.pas

@@ -0,0 +1,697 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.000.003 |
+|==============================================================================|
+| Content: SSL support for SecureBlackBox                                     |
+|==============================================================================|
+| Copyright (c)1999-2005, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2005.                     |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|   Allen Drennan (adrennan@wiredred.com)                                      |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(SSL plugin for Eldos SecureBlackBox)
+
+For handling keys and certificates you can use this properties:
+@link(TCustomSSL.CertCAFile), @link(TCustomSSL.CertCA),
+@link(TCustomSSL.TrustCertificateFile), @link(TCustomSSL.TrustCertificate),
+@link(TCustomSSL.PrivateKeyFile), @link(TCustomSSL.PrivateKey),
+@link(TCustomSSL.CertificateFile), @link(TCustomSSL.Certificate),
+@link(TCustomSSL.PFXFile). For usage of this properties and for possible formats
+of keys and certificates refer to SecureBlackBox documentation.
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+unit ssl_sbb;
+
+interface
+
+uses
+  SysUtils, Classes, Windows, blcksock, synsock, synautil, synacode,
+  SBClient, SBServer, SBX509, SBWinCertStorage, SBCustomCertStorage,
+  SBUtils, SBConstants, SBSessionPool;
+
+const
+  DEFAULT_RECV_BUFFER=32768;
+
+type
+  {:@abstract(class implementing SecureBlackbox SSL plugin.)
+   Instance of this class will be created for each @link(TTCPBlockSocket).
+   You not need to create instance of this class, all is done by Synapse itself!}
+  TSSLSBB=class(TCustomSSL)
+  protected
+    FServer: Boolean;
+    FElSecureClient:TElSecureClient;
+    FElSecureServer:TElSecureServer;
+    FElCertStorage:TElMemoryCertStorage;
+    FElX509Certificate:TElX509Certificate;
+    FElX509CACertificate:TElX509Certificate;
+    FCipherSuites:TBits;
+  private
+    FRecvBuffer:String;
+    FRecvBuffers:String;
+    FRecvBuffersLock:TRTLCriticalSection;
+    FRecvDecodedBuffers:String;
+    function GetCipherSuite:Integer;
+    procedure Reset;
+    function Prepare(Server:Boolean):Boolean;
+    procedure OnError(Sender:TObject; ErrorCode:Integer; Fatal:Boolean; Remote:Boolean);
+    procedure OnSend(Sender:TObject;Buffer:Pointer;Size:LongInt);
+    procedure OnReceive(Sender:TObject;Buffer:Pointer;MaxSize:LongInt;var Written:LongInt);
+    procedure OnData(Sender:TObject;Buffer:Pointer;Size:LongInt);
+  public
+    constructor Create(const Value: TTCPBlockSocket); override;
+    destructor Destroy; override;
+    {:See @inherited}
+    function LibVersion: String; override;
+    {:See @inherited}
+    function LibName: String; override;
+    {:See @inherited and @link(ssl_sbb) for more details.}
+    function Connect: boolean; override;
+    {:See @inherited and @link(ssl_sbb) for more details.}
+    function Accept: boolean; override;
+    {:See @inherited}
+    function Shutdown: boolean; override;
+    {:See @inherited}
+    function BiShutdown: boolean; override;
+    {:See @inherited}
+    function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
+    {:See @inherited}
+    function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
+    {:See @inherited}
+    function WaitingData: Integer; override;
+    {:See @inherited}
+    function GetSSLVersion: string; override;
+    {:See @inherited}
+    function GetPeerSubject: string; override;
+    {:See @inherited}
+    function GetPeerIssuer: string; override;
+    {:See @inherited}
+    function GetPeerName: string; override;
+    {:See @inherited}
+    function GetPeerFingerprint: string; override;
+    {:See @inherited}
+    function GetCertInfo: string; override;
+  published
+    property ElSecureClient:TElSecureClient read FElSecureClient write FElSecureClient;
+    property ElSecureServer:TElSecureServer read FElSecureServer write FElSecureServer;
+    property CipherSuites:TBits read FCipherSuites write FCipherSuites;
+    property CipherSuite:Integer read GetCipherSuite;
+  end;
+
+implementation
+
+var
+  FAcceptThread:THandle=0;
+
+// on error
+procedure TSSLSBB.OnError(Sender:TObject; ErrorCode:Integer; Fatal:Boolean; Remote:Boolean);
+
+begin
+  FLastErrorDesc:='';
+  FLastError:=ErrorCode;
+end;
+
+// on send
+procedure TSSLSBB.OnSend(Sender:TObject;Buffer:Pointer;Size:LongInt);
+
+var
+  lResult:Integer;
+
+begin
+  if FSocket.Socket=INVALID_SOCKET then
+    Exit;
+  lResult:=Send(FSocket.Socket,Buffer,Size,0);
+  if lResult=SOCKET_ERROR then
+    begin
+      FLastErrorDesc:='';
+      FLastError:=WSAGetLastError;
+    end;
+end;
+
+// on receive
+procedure TSSLSBB.OnReceive(Sender:TObject;Buffer:Pointer;MaxSize:LongInt;var Written:LongInt);
+
+begin
+  if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock);
+  try
+    if Length(FRecvBuffers)<=MaxSize then
+      begin
+        Written:=Length(FRecvBuffers);
+        Move(FRecvBuffers[1],Buffer^,Written);
+        FRecvBuffers:='';
+      end
+    else
+      begin
+        Written:=MaxSize;
+        Move(FRecvBuffers[1],Buffer^,Written);
+        Delete(FRecvBuffers,1,Written);
+      end;
+  finally
+    if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock);
+  end;
+end;
+
+// on data
+procedure TSSLSBB.OnData(Sender:TObject;Buffer:Pointer;Size:LongInt);
+
+var
+  lString:String;
+
+begin
+  SetLength(lString,Size);
+  Move(Buffer^,lString[1],Size);
+  FRecvDecodedBuffers:=FRecvDecodedBuffers+lString;
+end;
+
+{ inherited }
+
+constructor TSSLSBB.Create(const Value: TTCPBlockSocket);
+
+var
+  loop1:Integer;
+
+begin
+  inherited Create(Value);
+  FServer:=FALSE;
+  FElSecureClient:=NIL;
+  FElSecureServer:=NIL;
+  FElCertStorage:=NIL;
+  FElX509Certificate:=NIL;
+  FElX509CACertificate:=NIL;
+  SetLength(FRecvBuffer,DEFAULT_RECV_BUFFER);
+  FRecvBuffers:='';
+  InitializeCriticalSection(FRecvBuffersLock);
+  FRecvDecodedBuffers:='';
+  FCipherSuites:=TBits.Create;
+  if FCipherSuites<>NIL then
+    begin
+      FCipherSuites.Size:=SB_SUITE_LAST+1;
+      for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do
+        FCipherSuites[loop1]:=TRUE;
+    end;
+end;
+
+destructor TSSLSBB.Destroy;
+
+begin
+  Reset;
+  inherited Destroy;
+  if FCipherSuites<>NIL then
+    FreeAndNIL(FCipherSuites);
+  DeleteCriticalSection(FRecvBuffersLock);
+end;
+
+function TSSLSBB.LibVersion: String;
+
+begin
+  Result:='SecureBlackBox';
+end;
+
+function TSSLSBB.LibName: String;
+
+begin
+  Result:='ssl_sbb';
+end;
+
+function FileToString(lFile:String):String;
+
+var
+  lStream:TMemoryStream;
+
+begin
+  Result:='';
+  lStream:=TMemoryStream.Create;
+  if lStream<>NIL then
+    begin
+      lStream.LoadFromFile(lFile);
+      if lStream.Size>0 then
+        begin
+          lStream.Position:=0;
+          SetLength(Result,lStream.Size);
+          Move(lStream.Memory^,Result[1],lStream.Size);
+        end;
+      lStream.Free;
+    end;
+end;
+
+function TSSLSBB.GetCipherSuite:Integer;
+
+begin
+  if FServer then
+    Result:=FElSecureServer.CipherSuite
+  else
+    Result:=FElSecureClient.CipherSuite;
+end;
+
+procedure TSSLSBB.Reset;
+
+begin
+  if FElSecureServer<>NIL then
+    FreeAndNIL(FElSecureServer);
+  if FElSecureClient<>NIL then
+    FreeAndNIL(FElSecureClient);
+  if FElX509Certificate<>NIL then
+    FreeAndNIL(FElX509Certificate);
+  if FElX509CACertificate<>NIL then
+    FreeAndNIL(FElX509CACertificate);
+  if FElCertStorage<>NIL then
+    FreeAndNIL(FElCertStorage);
+  FSSLEnabled:=FALSE;
+end;
+
+function TSSLSBB.Prepare(Server:Boolean): Boolean;
+
+var
+  loop1:Integer;
+  lStream:TMemoryStream;
+  lCertificate,lPrivateKey,lCertCA:String;
+
+begin
+  Result:=FALSE;
+  FServer:=Server;
+
+  // reset, if necessary
+  Reset;
+
+  // init, certificate
+  if FCertificateFile<>'' then
+    lCertificate:=FileToString(FCertificateFile)
+  else
+    lCertificate:=FCertificate;
+  if FPrivateKeyFile<>'' then
+    lPrivateKey:=FileToString(FPrivateKeyFile)
+  else
+    lPrivateKey:=FPrivateKey;
+  if FCertCAFile<>'' then
+    lCertCA:=FileToString(FCertCAFile)
+  else
+    lCertCA:=FCertCA;
+  if (lCertificate<>'') and (lPrivateKey<>'') then
+    begin
+      FElCertStorage:=TElMemoryCertStorage.Create(NIL);
+      if FElCertStorage<>NIL then
+        FElCertStorage.Clear;
+
+      // apply ca certificate
+      if lCertCA<>'' then
+        begin
+          FElX509CACertificate:=TElX509Certificate.Create(NIL);
+          if FElX509CACertificate<>NIL then
+            begin
+              with FElX509CACertificate do
+                begin
+                  lStream:=TMemoryStream.Create;
+                  try
+                    WriteStrToStream(lStream,lCertCA);
+                    lStream.Seek(0,soFromBeginning);
+                    LoadFromStream(lStream);
+                  finally
+                    lStream.Free;
+                  end;
+                end;
+              if FElCertStorage<>NIL then
+                FElCertStorage.Add(FElX509CACertificate);
+            end;
+        end;
+
+      // apply certificate
+      FElX509Certificate:=TElX509Certificate.Create(NIL);
+      if FElX509Certificate<>NIL then
+        begin
+          with FElX509Certificate do
+            begin
+              lStream:=TMemoryStream.Create;
+              try
+                WriteStrToStream(lStream,lCertificate);
+                lStream.Seek(0,soFromBeginning);
+                LoadFromStream(lStream);
+              finally
+                lStream.Free;
+              end;
+              lStream:=TMemoryStream.Create;
+              try
+                WriteStrToStream(lStream,lPrivateKey);
+                lStream.Seek(0,soFromBeginning);
+                LoadKeyFromStream(lStream);
+              finally
+                lStream.Free;
+              end;
+              if FElCertStorage<>NIL then
+                FElCertStorage.Add(FElX509Certificate);
+            end;
+        end;
+    end;
+
+  // init, as server
+  if FServer then
+    begin
+      FElSecureServer:=TElSecureServer.Create(NIL);
+      if FElSecureServer<>NIL then
+        begin
+          // init, ciphers
+          for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do
+            FElSecureServer.CipherSuites[loop1]:=FCipherSuites[loop1];
+          FElSecureServer.Versions:=[sbSSL2,sbSSL3,sbTLS1];
+          FElSecureServer.ClientAuthentication:=FALSE;
+          FElSecureServer.OnError:=OnError;
+          FElSecureServer.OnSend:=OnSend;
+          FElSecureServer.OnReceive:=OnReceive;
+          FElSecureServer.OnData:=OnData;
+          FElSecureServer.CertStorage:=FElCertStorage;
+          Result:=TRUE;
+        end;
+    end
+  else
+    // init, as client
+    begin
+      FElSecureClient:=TElSecureClient.Create(NIL);
+      if FElSecureClient<>NIL then
+        begin
+          // init, ciphers
+          for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do
+            FElSecureClient.CipherSuites[loop1]:=FCipherSuites[loop1];
+          FElSecureClient.Versions:=[sbSSL3,sbTLS1];
+          FElSecureClient.OnError:=OnError;
+          FElSecureClient.OnSend:=OnSend;
+          FElSecureClient.OnReceive:=OnReceive;
+          FElSecureClient.OnData:=OnData;
+          FElSecureClient.CertStorage:=FElCertStorage;
+          Result:=TRUE;
+        end;
+    end;
+end;
+
+function TSSLSBB.Connect:Boolean;
+
+var
+  lResult:Integer;
+
+begin
+  Result:=FALSE;
+  if FSocket.Socket=INVALID_SOCKET then
+    Exit;
+  if Prepare(FALSE) then
+    begin
+      FElSecureClient.Open;
+
+      // reset
+      FRecvBuffers:='';
+      FRecvDecodedBuffers:='';
+
+      // wait for open or error
+      while (not FElSecureClient.Active) and
+        (FLastError=0) do
+        begin
+          // data available?
+          if FRecvBuffers<>'' then
+            FElSecureClient.DataAvailable
+          else
+            begin
+              // socket recv
+              lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0);
+              if lResult=SOCKET_ERROR then
+                begin
+                  FLastErrorDesc:='';
+                  FLastError:=WSAGetLastError;
+                end
+              else
+                begin
+                  if lResult>0 then
+                    FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult)
+                  else
+                    Break;
+                end;
+            end;
+        end;
+      if FLastError<>0 then
+        Exit;
+      FSSLEnabled:=FElSecureClient.Active;
+      Result:=FSSLEnabled;
+    end;
+end;
+
+function TSSLSBB.Accept:Boolean;
+
+var
+  lResult:Integer;
+
+begin
+  Result:=FALSE;
+  if FSocket.Socket=INVALID_SOCKET then
+    Exit;
+  if Prepare(TRUE) then
+    begin
+      FAcceptThread:=GetCurrentThreadId;
+      FElSecureServer.Open;
+
+      // reset
+      FRecvBuffers:='';
+      FRecvDecodedBuffers:='';
+
+      // wait for open or error
+      while (not FElSecureServer.Active) and
+        (FLastError=0) do
+        begin
+          // data available?
+          if FRecvBuffers<>'' then
+            FElSecureServer.DataAvailable
+          else
+            begin
+              // socket recv
+              lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0);
+              if lResult=SOCKET_ERROR then
+                begin
+                  FLastErrorDesc:='';
+                  FLastError:=WSAGetLastError;
+                end
+              else
+                begin
+                  if lResult>0 then
+                    FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult)
+                  else
+                    Break;
+                end;
+            end;
+        end;
+      if FLastError<>0 then
+        Exit;
+      FSSLEnabled:=FElSecureServer.Active;
+      Result:=FSSLEnabled;
+    end;
+end;
+
+function TSSLSBB.Shutdown:Boolean;
+
+begin
+  Result:=BiShutdown;
+end;
+
+function TSSLSBB.BiShutdown: boolean;
+
+begin
+  Reset;
+  Result:=TRUE;
+end;
+
+function TSSLSBB.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
+
+begin
+  if FServer then
+    FElSecureServer.SendData(Buffer,Len)
+  else
+    FElSecureClient.SendData(Buffer,Len);
+  Result:=Len;
+end;
+
+function TSSLSBB.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
+
+begin
+  Result:=0;
+  try
+    // recv waiting, if necessary
+    if FRecvDecodedBuffers='' then
+      WaitingData;
+
+    // received
+    if Length(FRecvDecodedBuffers)<Len then
+      begin
+        Result:=Length(FRecvDecodedBuffers);
+        Move(FRecvDecodedBuffers[1],Buffer^,Result);
+        FRecvDecodedBuffers:='';
+      end
+    else
+      begin
+        Result:=Len;
+        Move(FRecvDecodedBuffers[1],Buffer^,Result);
+        Delete(FRecvDecodedBuffers,1,Result);
+      end;
+  except
+    // ignore
+  end;
+end;
+
+function TSSLSBB.WaitingData: Integer;
+
+var
+  lResult:Integer;
+  lRecvBuffers:Boolean;
+
+begin
+  Result:=0;
+  if FSocket.Socket=INVALID_SOCKET then
+    Exit;
+  // data available?
+  if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock);
+  try
+    lRecvBuffers:=FRecvBuffers<>'';
+  finally
+    if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock);
+  end;
+  if lRecvBuffers then
+    begin
+      if FServer then
+        FElSecureServer.DataAvailable
+      else
+        FElSecureClient.DataAvailable;
+    end
+  else
+    begin
+      // socket recv
+      lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0);
+      if lResult=SOCKET_ERROR then
+        begin
+          FLastErrorDesc:='';
+          FLastError:=WSAGetLastError;
+        end
+      else
+        begin
+          if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock);
+          try
+            FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult);
+          finally
+            if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock);
+          end;
+
+          // data available?
+          if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock);
+          try
+            lRecvBuffers:=FRecvBuffers<>'';
+          finally
+            if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock);
+          end;
+          if lRecvBuffers then
+            begin
+              if FServer then
+                FElSecureServer.DataAvailable
+              else
+                FElSecureClient.DataAvailable;
+            end;
+        end;
+    end;
+
+  // decoded buffers result
+  Result:=Length(FRecvDecodedBuffers);
+end;
+
+function TSSLSBB.GetSSLVersion: string;
+
+begin
+  Result:='SSLv3 or TLSv1';
+end;
+
+function TSSLSBB.GetPeerSubject: string;
+
+begin
+  Result := '';
+//  if FServer then
+    // must return subject of the client certificate
+//  else
+    // must return subject of the server certificate
+end;
+
+function TSSLSBB.GetPeerName: string;
+
+begin
+  Result := '';
+//  if FServer then
+    // must return commonname of the client certificate
+//  else
+    // must return commonname of the server certificate
+end;
+
+function TSSLSBB.GetPeerIssuer: string;
+
+begin
+  Result := '';
+//  if FServer then
+    // must return issuer of the client certificate
+//  else
+    // must return issuer of the server certificate
+end;
+
+function TSSLSBB.GetPeerFingerprint: string;
+
+begin
+  Result := '';
+//  if FServer then
+    // must return a unique hash string of the client certificate
+//  else
+    // must return a unique hash string of the server certificate
+end;
+
+function TSSLSBB.GetCertInfo: string;
+
+begin
+  Result := '';
+//  if FServer then
+    // must return a text representation of the ASN of the client certificate
+//  else
+    // must return a text representation of the ASN of the server certificate
+end;
+
+{==============================================================================}
+
+initialization
+  SSLImplementation := TSSLSBB;
+
+finalization
+
+end.

Units/Synapse/ssl_streamsec.pas

@@ -0,0 +1,539 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.000.006 |
+|==============================================================================|
+| Content: SSL support by StreamSecII                                          |
+|==============================================================================|
+| Copyright (c)1999-2005, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2005.                     |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|   Henrick Hellström <henrick@streamsec.se>                                   |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(SSL plugin for StreamSecII or OpenStreamSecII)
+
+StreamSecII is native pascal library, you not need any external libraries!
+
+You can tune lot of StreamSecII properties by using your GlobalServer. If you not
+using your GlobalServer, then this plugin create own TSimpleTLSInternalServer
+instance for each TCP connection. Formore information about GlobalServer usage
+refer StreamSecII documentation.
+
+If you are not using key and certificate by GlobalServer, then you can use
+properties of this plugin instead, but this have limited features and
+@link(TCustomSSL.KeyPassword) not working properly yet!
+
+For handling keys and certificates you can use this properties:
+@link(TCustomSSL.CertCAFile), @link(TCustomSSL.CertCA),
+@link(TCustomSSL.TrustCertificateFile), @link(TCustomSSL.TrustCertificate),
+@link(TCustomSSL.PrivateKeyFile), @link(TCustomSSL.PrivateKey),
+@link(TCustomSSL.CertificateFile), @link(TCustomSSL.Certificate),
+@link(TCustomSSL.PFXFile). For usage of this properties and for possible formats
+of keys and certificates refer to StreamSecII documentation.
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+unit ssl_streamsec;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synsock, synautil, synacode,
+  TlsInternalServer, TlsSynaSock, TlsConst, StreamSecII, Asn1, X509Base,
+  SecUtils;
+
+type
+  {:@exclude}
+  TMyTLSSynSockSlave = class(TTLSSynSockSlave)
+  protected
+    procedure SetMyTLSServer(const Value: TCustomTLSInternalServer);
+    function GetMyTLSServer: TCustomTLSInternalServer;
+  published
+    property MyTLSServer: TCustomTLSInternalServer read GetMyTLSServer write SetMyTLSServer;
+  end;
+
+  {:@abstract(class implementing StreamSecII SSL plugin.)
+   Instance of this class will be created for each @link(TTCPBlockSocket).
+   You not need to create instance of this class, all is done by Synapse itself!}
+  TSSLStreamSec = class(TCustomSSL)
+  protected
+    FSlave: TMyTLSSynSockSlave;
+    FIsServer: Boolean;
+    FTLSServer: TCustomTLSInternalServer;
+    FServerCreated: Boolean;
+    function SSLCheck: Boolean;
+    function Init(server:Boolean): Boolean;
+    function DeInit: Boolean;
+    function Prepare(server:Boolean): Boolean;
+    procedure NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean);
+    function X500StrToStr(const Prefix: string; const Value: TX500String): string;
+    function X501NameToStr(const Value: TX501Name): string;
+    function GetCert: PASN1Struct;
+  public
+    constructor Create(const Value: TTCPBlockSocket); override;
+    destructor Destroy; override;
+    {:See @inherited}
+    function LibVersion: String; override;
+    {:See @inherited}
+    function LibName: String; override;
+    {:See @inherited and @link(ssl_streamsec) for more details.}
+    function Connect: boolean; override;
+    {:See @inherited and @link(ssl_streamsec) for more details.}
+    function Accept: boolean; override;
+    {:See @inherited}
+    function Shutdown: boolean; override;
+    {:See @inherited}
+    function BiShutdown: boolean; override;
+    {:See @inherited}
+    function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
+    {:See @inherited}
+    function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
+    {:See @inherited}
+    function WaitingData: Integer; override;
+    {:See @inherited}
+    function GetSSLVersion: string; override;
+    {:See @inherited}
+    function GetPeerSubject: string; override;
+    {:See @inherited}
+    function GetPeerIssuer: string; override;
+    {:See @inherited}
+    function GetPeerName: string; override;
+    {:See @inherited}
+    function GetPeerFingerprint: string; override;
+    {:See @inherited}
+    function GetCertInfo: string; override;
+  published
+    {:TLS server for tuning of StreamSecII.}
+    property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer;
+  end;
+
+implementation
+
+{==============================================================================}
+procedure TMyTLSSynSockSlave.SetMyTLSServer(const Value: TCustomTLSInternalServer);
+begin
+  TLSServer := Value;
+end;
+
+function TMyTLSSynSockSlave.GetMyTLSServer: TCustomTLSInternalServer;
+begin
+  Result := TLSServer;
+end;
+
+{==============================================================================}
+
+constructor TSSLStreamSec.Create(const Value: TTCPBlockSocket);
+begin
+  inherited Create(Value);
+  FSlave := nil;
+  FIsServer := False;
+  FTLSServer := nil;
+end;
+
+destructor TSSLStreamSec.Destroy;
+begin
+  DeInit;
+  inherited Destroy;
+end;
+
+function TSSLStreamSec.LibVersion: String;
+begin
+  Result := 'StreamSecII';
+end;
+
+function TSSLStreamSec.LibName: String;
+begin
+  Result := 'ssl_streamsec';
+end;
+
+function TSSLStreamSec.SSLCheck: Boolean;
+begin
+  Result := true;
+  FLastErrorDesc := '';
+  if not Assigned(FSlave) then
+    Exit;
+  FLastError := FSlave.ErrorCode;
+  if FLastError <> 0 then
+  begin
+    FLastErrorDesc := TlsConst.AlertMsg(FLastError);
+  end;
+end;
+
+procedure TSSLStreamSec.NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean);
+begin
+  ExplicitTrust := true;
+end;
+
+function TSSLStreamSec.Init(server:Boolean): Boolean;
+var
+  st: TMemoryStream;
+  pass: ISecretKey;
+  ws: WideString;
+begin
+  Result := False;
+  ws := FKeyPassword;
+  pass := TSecretKey.CreateBmpStr(PWideChar(ws), length(ws));
+  try
+    FIsServer := Server;
+    FSlave := TMyTLSSynSockSlave.CreateSocket(FSocket.Socket);
+    if Assigned(FTLSServer) then
+      FSlave.MyTLSServer := FTLSServer
+    else
+      if Assigned(TLSInternalServer.GlobalServer) then
+        FSlave.MyTLSServer := TLSInternalServer.GlobalServer
+      else begin
+        FSlave.MyTLSServer := TSimpleTLSInternalServer.Create(nil);
+        FServerCreated := True;
+      end;
+    if server then
+      FSlave.MyTLSServer.ClientOrServer := cosServerSide
+    else
+      FSlave.MyTLSServer.ClientOrServer := cosClientSide;
+    if not FVerifyCert then
+    begin
+      FSlave.MyTLSServer.OnCertNotTrusted := NotTrustEvent;
+    end;
+    FSlave.MyTLSServer.Options.VerifyServerName := [];
+    FSlave.MyTLSServer.Options.Export40Bit := prAllowed;
+    FSlave.MyTLSServer.Options.Export56Bit := prAllowed;
+    FSlave.MyTLSServer.Options.RequestClientCertificate := False;
+    FSlave.MyTLSServer.Options.RequireClientCertificate := False;
+    if server and FVerifyCert then
+    begin
+      FSlave.MyTLSServer.Options.RequestClientCertificate := True;
+      FSlave.MyTLSServer.Options.RequireClientCertificate := True;
+    end;
+    if FCertCAFile <> '' then
+      FSlave.MyTLSServer.LoadRootCertsFromFile(CertCAFile);
+    if FCertCA <> '' then
+    begin
+      st := TMemoryStream.Create;
+      try
+        WriteStrToStream(st, FCertCA);
+        st.Seek(0, soFromBeginning);
+        FSlave.MyTLSServer.LoadRootCertsFromStream(st);
+      finally
+        st.free;
+      end;
+    end;
+    if FTrustCertificateFile <> '' then
+      FSlave.MyTLSServer.LoadTrustedCertsFromFile(FTrustCertificateFile);
+    if FTrustCertificate <> '' then
+    begin
+      st := TMemoryStream.Create;
+      try
+        WriteStrToStream(st, FTrustCertificate);
+        st.Seek(0, soFromBeginning);
+        FSlave.MyTLSServer.LoadTrustedCertsFromStream(st);
+      finally
+        st.free;
+      end;
+    end;
+    if FPrivateKeyFile <> '' then
+      FSlave.MyTLSServer.LoadPrivateKeyRingFromFile(FPrivateKeyFile, pass);
+//      FSlave.MyTLSServer.PrivateKeyRing.LoadPrivateKeyFromFile(FPrivateKeyFile, pass);
+    if FPrivateKey <> '' then
+    begin
+      st := TMemoryStream.Create;
+      try
+        WriteStrToStream(st, FPrivateKey);
+        st.Seek(0, soFromBeginning);
+        FSlave.MyTLSServer.LoadPrivateKeyRingFromStream(st, pass);
+      finally
+        st.free;
+      end;
+    end;
+    if FCertificateFile <> '' then
+      FSlave.MyTLSServer.LoadMyCertsFromFile(FCertificateFile);
+    if FCertificate <> '' then
+    begin
+      st := TMemoryStream.Create;
+      try
+        WriteStrToStream(st, FCertificate);
+        st.Seek(0, soFromBeginning);
+        FSlave.MyTLSServer.LoadMyCertsFromStream(st);
+      finally
+        st.free;
+      end;
+    end;
+    if FPFXfile <> '' then
+      FSlave.MyTLSServer.ImportFromPFX(FPFXfile, pass);
+    if server and FServerCreated then
+    begin
+      FSlave.MyTLSServer.Options.BulkCipherAES128 := prPrefer;
+      FSlave.MyTLSServer.Options.BulkCipherAES256 := prAllowed;
+      FSlave.MyTLSServer.Options.EphemeralECDHKeySize := ecs256;
+      FSlave.MyTLSServer.Options.SignatureRSA := prPrefer;
+      FSlave.MyTLSServer.Options.KeyAgreementRSA := prAllowed;
+      FSlave.MyTLSServer.Options.KeyAgreementECDHE := prAllowed;
+      FSlave.MyTLSServer.Options.KeyAgreementDHE := prPrefer;
+      FSlave.MyTLSServer.TLSSetupServer;
+    end;
+    Result := true;
+  finally
+    pass := nil;
+  end;
+end;
+
+function TSSLStreamSec.DeInit: Boolean;
+var
+  obj: TObject;
+begin
+  Result := True;
+  if assigned(FSlave) then
+  begin
+    FSlave.Close;
+    if FServerCreated then
+      obj := FSlave.TLSServer
+    else
+      obj := nil;
+    FSlave.Free;
+    obj.Free;
+    FSlave := nil;
+  end;
+  FSSLEnabled := false;
+end;
+
+function TSSLStreamSec.Prepare(server:Boolean): Boolean;
+begin
+  Result := false;
+  DeInit;
+  if Init(server) then
+    Result := true
+  else
+    DeInit;
+end;
+
+function TSSLStreamSec.Connect: boolean;
+begin
+  Result := False;
+  if FSocket.Socket = INVALID_SOCKET then
+    Exit;
+  if Prepare(false) then
+  begin
+    FSlave.Open;
+    SSLCheck;
+    if FLastError <> 0 then
+      Exit;
+    FSSLEnabled := True;
+    Result := True;
+  end;
+end;
+
+function TSSLStreamSec.Accept: boolean;
+begin
+  Result := False;
+  if FSocket.Socket = INVALID_SOCKET then
+    Exit;
+  if Prepare(true) then
+  begin
+    FSlave.DoConnect;
+    SSLCheck;
+    if FLastError <> 0 then
+      Exit;
+    FSSLEnabled := True;
+    Result := True;
+  end;
+end;
+
+function TSSLStreamSec.Shutdown: boolean;
+begin
+  Result := BiShutdown;
+end;
+
+function TSSLStreamSec.BiShutdown: boolean;
+begin
+  DeInit;
+  Result := True;
+end;
+
+function TSSLStreamSec.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
+var
+  l: integer;
+begin
+  l := len;
+  FSlave.SendBuf(Buffer^, l, true);
+  Result := l;
+  SSLCheck;
+end;
+
+function TSSLStreamSec.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
+var
+  l: integer;
+begin
+  l := Len;
+  Result := FSlave.ReceiveBuf(Buffer^, l);
+  SSLCheck;
+end;
+
+function TSSLStreamSec.WaitingData: Integer;
+begin
+  Result := 0;
+  while FSlave.Connected do begin
+    Result := FSlave.ReceiveLength;
+    if Result > 0 then
+      Break;
+    Sleep(1);
+  end;
+end;
+
+function TSSLStreamSec.GetSSLVersion: string;
+begin
+  Result := 'SSLv3 or TLSv1';
+end;
+
+function TSSLStreamSec.GetCert: PASN1Struct;
+begin
+  if FIsServer then
+    Result := FSlave.GetClientCert
+  else
+    Result := FSlave.GetServerCert;
+end;
+
+function TSSLStreamSec.GetPeerSubject: string;
+var
+  XName: TX501Name;
+  Cert: PASN1Struct;
+begin
+  Result := '';
+  Cert := GetCert;
+  if Assigned(cert) then
+  begin
+    ExtractSubject(Cert^,XName, false);
+    Result := X501NameToStr(XName);
+  end;
+end;
+
+function TSSLStreamSec.GetPeerName: string;
+var
+  XName: TX501Name;
+  Cert: PASN1Struct;
+begin
+  Result := '';
+  Cert := GetCert;
+  if Assigned(cert) then
+  begin
+    ExtractSubject(Cert^,XName, false);
+    Result := XName.commonName.Str;
+  end;
+end;
+
+function TSSLStreamSec.GetPeerIssuer: string;
+var
+  XName: TX501Name;
+  Cert: PASN1Struct;
+begin
+  Result := '';
+  Cert := GetCert;
+  if Assigned(cert) then
+  begin
+    ExtractIssuer(Cert^, XName, false);
+    Result := X501NameToStr(XName);
+  end;
+end;
+
+function TSSLStreamSec.GetPeerFingerprint: string;
+var
+  Cert: PASN1Struct;
+begin
+  Result := '';
+  Cert := GetCert;
+  if Assigned(cert) then
+    Result := MD5(Cert.ContentAsOctetString);
+end;
+
+function TSSLStreamSec.GetCertInfo: string;
+var
+  Cert: PASN1Struct;
+  l: Tstringlist;
+begin
+  Result := '';
+  Cert := GetCert;
+  if Assigned(cert) then
+  begin
+    l := TStringList.Create;
+    try
+      Asn1.RenderAsText(cert^, l, true, true, true, 2);
+      Result := l.Text;
+    finally
+      l.free;
+    end;
+  end;
+end;
+
+function TSSLStreamSec.X500StrToStr(const Prefix: string;
+  const Value: TX500String): string;
+begin
+  if Value.Str = '' then
+    Result := ''
+  else
+    Result := '/' + Prefix + '=' + Value.Str;
+end;
+
+function TSSLStreamSec.X501NameToStr(const Value: TX501Name): string;
+begin
+  Result := X500StrToStr('CN',Value.commonName) +
+           X500StrToStr('C',Value.countryName) +
+           X500StrToStr('L',Value.localityName) +
+           X500StrToStr('ST',Value.stateOrProvinceName) +
+           X500StrToStr('O',Value.organizationName) +
+           X500StrToStr('OU',Value.organizationalUnitName) +
+           X500StrToStr('T',Value.title) +
+           X500StrToStr('N',Value.name) +
+           X500StrToStr('G',Value.givenName) +
+           X500StrToStr('I',Value.initials) +
+           X500StrToStr('SN',Value.surname) +
+           X500StrToStr('GQ',Value.generationQualifier) +
+           X500StrToStr('DNQ',Value.dnQualifier) +
+           X500StrToStr('E',Value.emailAddress);
+end;
+
+
+{==============================================================================}
+
+initialization
+  SSLImplementation := TSSLStreamSec;
+
+finalization
+
+end.
+
+

Units/Synapse/synadbg.pas

@@ -0,0 +1,152 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.001.000 |
+|==============================================================================|
+| Content: Socket debug tools                                                  |
+|==============================================================================|
+| Copyright (c)2008, Lukas Gebauer                                             |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2008.                     |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(Socket debug tools)
+
+Routines for help with debugging of events on the Sockets.
+}
+
+
+unit synadbg;
+
+interface
+
+uses
+  blcksock, synsock, synautil, classes, sysutils;
+
+type
+  TSynaDebug = class(TObject)
+    class procedure HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
+    class procedure HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer);
+  end;
+
+procedure AppendToLog(const value: Ansistring);
+
+var
+  LogFile: string;
+
+implementation
+
+procedure AppendToLog(const value: Ansistring);
+var
+  st: TFileStream;
+  s: string;
+  h, m, ss, ms: word;
+  dt: Tdatetime;
+begin
+  if fileexists(LogFile) then
+    st := TFileStream.Create(LogFile, fmOpenReadWrite or fmShareDenyWrite)
+  else
+    st := TFileStream.Create(LogFile, fmCreate or fmShareDenyWrite);
+  try
+    st.Position := st.Size;
+    dt := now;
+    decodetime(dt, h, m, ss, ms);
+    s := formatdatetime('yyyymmdd-hhnnss', dt) + format('.%.3d', [ms]) + ' ' + value;
+    WriteStrToStream(st, s);
+  finally
+    st.free;
+  end;
+end;
+
+class procedure TSynaDebug.HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
+var
+  s: string;
+begin
+  case Reason of
+    HR_ResolvingBegin:
+      s := 'HR_ResolvingBegin';
+    HR_ResolvingEnd:
+      s := 'HR_ResolvingEnd';
+    HR_SocketCreate:
+      s := 'HR_SocketCreate';
+    HR_SocketClose:
+      s := 'HR_SocketClose';
+    HR_Bind:
+      s := 'HR_Bind';
+    HR_Connect:
+      s := 'HR_Connect';
+    HR_CanRead:
+      s := 'HR_CanRead';
+    HR_CanWrite:
+      s := 'HR_CanWrite';
+    HR_Listen:
+      s := 'HR_Listen';
+    HR_Accept:
+      s := 'HR_Accept';
+    HR_ReadCount:
+      s := 'HR_ReadCount';
+    HR_WriteCount:
+      s := 'HR_WriteCount';
+    HR_Wait:
+      s := 'HR_Wait';
+    HR_Error:
+      s := 'HR_Error';
+  else
+    s := '-unknown-';
+  end;
+  s := inttohex(integer(Sender), 8) + s + ': ' + value + CRLF;
+  AppendToLog(s);
+end;
+
+class procedure TSynaDebug.HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer);
+var
+  s, d: Ansistring;
+begin
+  setlength(s, len);
+  move(Buffer^, pointer(s)^, len);
+  if writing then
+    d := '-> '
+  else
+    d := '<- ';
+  s :=inttohex(integer(Sender), 8) + d + s + CRLF;
+  AppendToLog(s);
+end;
+
+initialization
+begin
+  Logfile := changefileext(paramstr(0), '.slog');
+end;
+
+end.

Units/Synapse/synafpc.pas

@@ -0,0 +1,131 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.001.001 |
+|==============================================================================|
+| Content: Utils for FreePascal compatibility                                  |
+|==============================================================================|
+| Copyright (c)1999-2007, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2003-2007.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@exclude}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+unit synafpc;
+
+interface
+
+uses
+{$IFDEF FPC}
+  dynlibs, sysutils;
+{$ELSE}
+  {$IFDEF WIN32}
+  Windows;
+  {$ELSE}
+  SysUtils;
+  {$ENDIF}
+{$ENDIF}
+
+{$IFDEF FPC}
+type
+  TLibHandle = dynlibs.TLibHandle;
+  
+function LoadLibrary(ModuleName: PChar): TLibHandle;
+function FreeLibrary(Module: TLibHandle): LongBool;
+function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer;
+function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer;
+{$ELSE}
+type
+  {$IFDEF CIL}
+  TLibHandle = Integer;
+  {$ELSE}
+  TLibHandle = HModule;
+  {$ENDIF}
+  {$IFDEF VER100}
+  LongWord = DWord;
+  {$ENDIF}
+{$ENDIF}
+
+procedure Sleep(milliseconds: Cardinal);
+
+
+implementation
+
+{==============================================================================}
+{$IFDEF FPC}
+function LoadLibrary(ModuleName: PChar): TLibHandle;
+begin
+  Result := dynlibs.LoadLibrary(Modulename);
+end;
+
+function FreeLibrary(Module: TLibHandle): LongBool;
+begin
+  Result := dynlibs.UnloadLibrary(Module);
+end;
+
+function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer;
+begin
+  Result := dynlibs.GetProcedureAddress(Module, Proc);
+end;
+
+function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer;
+begin
+  Result := 0;
+end;
+
+{$ELSE}
+{$ENDIF}
+
+procedure Sleep(milliseconds: Cardinal);
+begin
+{$IFDEF WIN32}
+  {$IFDEF FPC}
+  sysutils.sleep(milliseconds);
+  {$ELSE}
+  windows.sleep(milliseconds);
+  {$ENDIF}
+{$ELSE}
+  sysutils.sleep(milliseconds);
+{$ENDIF}
+
+end;
+
+end.

Units/Synapse/synaicnv.pas

@@ -0,0 +1,357 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.001.000 |
+|==============================================================================|
+| Content: ICONV support for Win32, Linux and .NET                             |
+|==============================================================================|
+| Copyright (c)2004-2008, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2004-2008.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+{:@abstract(LibIconv support)
+
+This unit is Pascal interface to LibIconv library for charset translations.
+LibIconv is loaded dynamicly on-demand. If this library is not found in system,
+requested LibIconv function just return errorcode.
+}
+unit synaicnv;
+
+interface
+
+uses
+{$IFDEF CIL}
+  System.Runtime.InteropServices,
+  System.Text,
+{$ENDIF}
+  synafpc,
+{$IFNDEF WIN32}
+  {$IFNDEF FPC}
+  Libc,
+  {$ENDIF}
+  SysUtils;
+{$ELSE}
+  Windows;
+{$ENDIF}
+
+
+const
+  {$IFNDEF WIN32}
+  DLLIconvName = 'libiconv.so';
+  {$ELSE}
+  DLLIconvName = 'iconv.dll';
+  {$ENDIF}
+
+type
+  size_t = Cardinal;
+{$IFDEF CIL}
+  iconv_t = IntPtr;
+{$ELSE}
+  iconv_t = Pointer;
+{$ENDIF}
+  argptr = iconv_t;
+
+var
+  iconvLibHandle: TLibHandle = 0;
+
+function SynaIconvOpen(const tocode, fromcode: Ansistring): iconv_t;
+function SynaIconvOpenTranslit(const tocode, fromcode: Ansistring): iconv_t;
+function SynaIconvOpenIgnore(const tocode, fromcode: Ansistring): iconv_t;
+function SynaIconv(cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer;
+function SynaIconvClose(var cd: iconv_t): integer;
+function SynaIconvCtl(cd: iconv_t; request: integer; argument: argptr): integer;
+
+function IsIconvloaded: Boolean;
+function InitIconvInterface: Boolean;
+function DestroyIconvInterface: Boolean;
+
+const
+  ICONV_TRIVIALP          = 0;  // int *argument
+  ICONV_GET_TRANSLITERATE = 1;  // int *argument
+  ICONV_SET_TRANSLITERATE = 2;  // const int *argument
+  ICONV_GET_DISCARD_ILSEQ = 3;  // int *argument
+  ICONV_SET_DISCARD_ILSEQ = 4;  // const int *argument
+
+
+implementation
+
+uses SyncObjs;
+
+{$IFDEF CIL}
+  [DllImport(DLLIconvName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'libiconv_open')]
+    function _iconv_open(tocode: string; fromcode: string): iconv_t; external;
+
+  [DllImport(DLLIconvName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'libiconv')]
+    function _iconv(cd: iconv_t; var inbuf: IntPtr; var inbytesleft: size_t;
+    var outbuf: IntPtr; var outbytesleft: size_t): size_t; external;
+
+  [DllImport(DLLIconvName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'libiconv_close')]
+    function _iconv_close(cd: iconv_t): integer; external;
+
+  [DllImport(DLLIconvName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'libiconvctl')]
+    function _iconvctl(cd: iconv_t; request: integer; argument: argptr): integer; external;
+
+{$ELSE}
+type
+  Ticonv_open = function(tocode: pAnsichar; fromcode: pAnsichar): iconv_t; cdecl;
+  Ticonv = function(cd: iconv_t; var inbuf: pointer; var inbytesleft: size_t;
+    var outbuf: pointer; var outbytesleft: size_t): size_t; cdecl;
+  Ticonv_close = function(cd: iconv_t): integer; cdecl;
+  Ticonvctl = function(cd: iconv_t; request: integer; argument: argptr): integer; cdecl;
+var
+  _iconv_open: Ticonv_open = nil;
+  _iconv: Ticonv = nil;
+  _iconv_close: Ticonv_close = nil;
+  _iconvctl: Ticonvctl = nil;
+{$ENDIF}
+
+
+var
+  IconvCS: TCriticalSection;
+  Iconvloaded: boolean = false;
+
+function SynaIconvOpen (const tocode, fromcode: Ansistring): iconv_t;
+begin
+{$IFDEF CIL}
+  try
+    Result := _iconv_open(tocode, fromcode);
+  except
+    on Exception do
+      Result := iconv_t(-1);
+  end;
+{$ELSE}
+  if InitIconvInterface and Assigned(_iconv_open) then
+    Result := _iconv_open(PAnsiChar(tocode), PAnsiChar(fromcode))
+  else
+    Result := iconv_t(-1);
+{$ENDIF}
+end;
+
+function SynaIconvOpenTranslit (const tocode, fromcode: Ansistring): iconv_t;
+begin
+  Result := SynaIconvOpen(tocode + '//IGNORE//TRANSLIT', fromcode);
+end;
+
+function SynaIconvOpenIgnore (const tocode, fromcode: Ansistring): iconv_t;
+begin
+  Result := SynaIconvOpen(tocode + '//IGNORE', fromcode);
+end;
+
+function SynaIconv (cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer;
+var
+{$IFDEF CIL}
+  ib, ob: IntPtr;
+  ibsave, obsave: IntPtr;
+  l: integer;
+{$ELSE}
+  ib, ob: Pointer;
+{$ENDIF}
+  ix, ox: size_t;
+begin
+{$IFDEF CIL}
+  l := Length(inbuf) * 4;
+  ibsave := IntPtr.Zero;
+  obsave := IntPtr.Zero;
+  try
+    ibsave := Marshal.StringToHGlobalAnsi(inbuf);
+    obsave := Marshal.AllocHGlobal(l);
+    ib := ibsave;
+    ob := obsave;
+    ix := Length(inbuf);
+    ox := l;
+    _iconv(cd, ib, ix, ob, ox);
+    Outbuf := Marshal.PtrToStringAnsi(obsave, l);
+    setlength(Outbuf, l - ox);
+    Result := Length(inbuf) - ix;
+  finally
+    Marshal.FreeCoTaskMem(ibsave);
+    Marshal.FreeHGlobal(obsave);
+  end;
+{$ELSE}
+  if InitIconvInterface and Assigned(_iconv) then
+  begin
+    setlength(Outbuf, Length(inbuf) * 4);
+    ib := Pointer(inbuf);
+    ob := Pointer(Outbuf);
+    ix := Length(inbuf);
+    ox := Length(Outbuf);
+    _iconv(cd, ib, ix, ob, ox);
+    setlength(Outbuf, cardinal(Length(Outbuf)) - ox);
+    Result := Cardinal(Length(inbuf)) - ix;
+  end
+  else
+  begin
+    Outbuf := '';
+    Result := 0;
+  end;
+{$ENDIF}
+end;
+
+function SynaIconvClose(var cd: iconv_t): integer;
+begin
+  if cd = iconv_t(-1) then
+  begin
+    Result := 0;
+    Exit;
+  end;
+{$IFDEF CIL}
+  try;
+    Result := _iconv_close(cd)
+  except
+    on Exception do
+      Result := -1;
+  end;
+  cd := iconv_t(-1);
+{$ELSE}
+  if InitIconvInterface and Assigned(_iconv_close) then
+    Result := _iconv_close(cd)
+  else
+    Result := -1;
+  cd := iconv_t(-1);
+{$ENDIF}
+end;
+
+function SynaIconvCtl (cd: iconv_t; request: integer; argument: argptr): integer;
+begin
+{$IFDEF CIL}
+  Result := _iconvctl(cd, request, argument)
+{$ELSE}
+  if InitIconvInterface and Assigned(_iconvctl) then
+    Result := _iconvctl(cd, request, argument)
+  else
+    Result := 0;
+{$ENDIF}
+end;
+
+function InitIconvInterface: Boolean;
+begin
+  IconvCS.Enter;
+  try
+    if not IsIconvloaded then
+    begin
+{$IFDEF CIL}
+      IconvLibHandle := 1;
+{$ELSE}
+      IconvLibHandle := LoadLibrary(PChar(DLLIconvName));
+{$ENDIF}
+      if (IconvLibHandle <> 0) then
+      begin
+{$IFNDEF CIL}
+        _iconv_open := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_open')));
+        _iconv := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv')));
+        _iconv_close := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_close')));
+        _iconvctl := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconvctl')));
+{$ENDIF}
+        Result := True;
+        Iconvloaded := True;
+      end
+      else
+      begin
+        //load failed!
+        if IconvLibHandle <> 0 then
+        begin
+{$IFNDEF CIL}
+          FreeLibrary(IconvLibHandle);
+{$ENDIF}
+          IconvLibHandle := 0;
+        end;
+        Result := False;
+      end;
+    end
+    else
+      //loaded before...
+      Result := true;
+  finally
+    IconvCS.Leave;
+  end;
+end;
+
+function DestroyIconvInterface: Boolean;
+begin
+  IconvCS.Enter;
+  try
+    Iconvloaded := false;
+    if IconvLibHandle <> 0 then
+    begin
+{$IFNDEF CIL}
+      FreeLibrary(IconvLibHandle);
+{$ENDIF}
+      IconvLibHandle := 0;
+    end;
+{$IFNDEF CIL}
+    _iconv_open := nil;
+    _iconv := nil;
+    _iconv_close := nil;
+    _iconvctl := nil;
+{$ENDIF}
+  finally
+    IconvCS.Leave;
+  end;
+  Result := True;
+end;
+
+function IsIconvloaded: Boolean;
+begin
+  Result := IconvLoaded;
+end;
+
+ initialization
+begin
+  IconvCS:= TCriticalSection.Create;
+end;
+
+finalization
+begin
+{$IFNDEF CIL}
+  DestroyIconvInterface;
+{$ENDIF}
+  IconvCS.Free;
+end;
+
+end.

Units/Synapse/synaip.pas

@@ -0,0 +1,416 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.002.000 |
+|==============================================================================|
+| Content: IP address support procedures and functions                         |
+|==============================================================================|
+| Copyright (c)2006-2009, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c) 2006-2008.               |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(IP adress support procedures and functions)}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$Q-}
+{$R-}
+{$H+}
+
+unit synaip;
+
+interface
+
+uses
+  SysUtils, SynaUtil;
+
+type
+{:binary form of IPv6 adress (for string conversion routines)}
+  TIp6Bytes = array [0..15] of Byte;
+{:binary form of IPv6 adress (for string conversion routines)}
+  TIp6Words = array [0..7] of Word;
+
+{:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!}
+function IsIP(const Value: string): Boolean;
+
+{:Returns @TRUE, if "Value" is a valid IPv6 address. Cannot be a symbolic Name!}
+function IsIP6(const Value: string): Boolean;
+
+{:Returns a string with the "Host" ip address converted to binary form.}
+function IPToID(Host: string): Ansistring;
+
+{:Convert IPv6 address from their string form to binary byte array.}
+function StrToIp6(value: string): TIp6Bytes;
+
+{:Convert IPv6 address from binary byte array to string form.}
+function Ip6ToStr(value: TIp6Bytes): string;
+
+{:Convert IPv4 address from their string form to binary.}
+function StrToIp(value: string): integer;
+
+{:Convert IPv4 address from binary to string form.}
+function IpToStr(value: integer): string;
+
+{:Convert IPv4 address to reverse form.}
+function ReverseIP(Value: AnsiString): AnsiString;
+
+{:Convert IPv6 address to reverse form.}
+function ReverseIP6(Value: AnsiString): AnsiString;
+
+{:Expand short form of IPv6 address to long form.}
+function ExpandIP6(Value: AnsiString): AnsiString;
+
+
+implementation
+
+{==============================================================================}
+
+function IsIP(const Value: string): Boolean;
+var
+  TempIP: string;
+  function ByteIsOk(const Value: string): Boolean;
+  var
+    x, n: integer;
+  begin
+    x := StrToIntDef(Value, -1);
+    Result := (x >= 0) and (x < 256);
+    // X may be in correct range, but value still may not be correct value!
+    // i.e. "$80"
+    if Result then
+      for n := 1 to length(Value) do
+        if not (Value[n] in ['0'..'9']) then
+        begin
+          Result := False;
+          Break;
+        end;
+  end;
+begin
+  TempIP := Value;
+  Result := False;
+  if not ByteIsOk(Fetch(TempIP, '.')) then
+    Exit;
+  if not ByteIsOk(Fetch(TempIP, '.')) then
+    Exit;
+  if not ByteIsOk(Fetch(TempIP, '.')) then
+    Exit;
+  if ByteIsOk(TempIP) then
+    Result := True;
+end;
+
+{==============================================================================}
+
+function IsIP6(const Value: string): Boolean;
+var
+  TempIP: string;
+  s,t: string;
+  x: integer;
+  partcount: integer;
+  zerocount: integer;
+  First: Boolean;
+begin
+  TempIP := Value;
+  Result := False;
+  if Value = '::' then
+  begin
+    Result := True;
+    Exit;
+  end;
+  partcount := 0;
+  zerocount := 0;
+  First := True;
+  while tempIP <> '' do
+  begin
+    s := fetch(TempIP, ':');
+    if not(First) and (s = '') then
+      Inc(zerocount);
+    First := False;
+    if zerocount > 1 then
+      break;
+    Inc(partCount);
+    if s = '' then
+      Continue;
+    if partCount > 8 then
+      break;
+    if tempIP = '' then
+    begin
+      t := SeparateRight(s, '%');
+      s := SeparateLeft(s, '%');
+      x := StrToIntDef('$' + t, -1);
+      if (x < 0) or (x > $ffff) then
+        break;
+    end;
+    x := StrToIntDef('$' + s, -1);
+    if (x < 0) or (x > $ffff) then
+      break;
+    if tempIP = '' then
+      if not((PartCount = 1) and (ZeroCount = 0)) then
+        Result := True;
+  end;
+end;
+
+{==============================================================================}
+function IPToID(Host: string): Ansistring;
+var
+  s: string;
+  i, x: Integer;
+begin
+  Result := '';
+  for x := 0 to 3 do
+  begin
+    s := Fetch(Host, '.');
+    i := StrToIntDef(s, 0);
+    Result := Result + Chr(i);
+  end;
+end;
+
+{==============================================================================}
+
+function StrToIp(value: string): integer;
+var
+  s: string;
+  i, x: Integer;
+begin
+  Result := 0;
+  for x := 0 to 3 do
+  begin
+    s := Fetch(value, '.');
+    i := StrToIntDef(s, 0);
+    Result := (256 * Result) + i;
+  end;
+end;
+
+{==============================================================================}
+
+function IpToStr(value: integer): string;
+var
+  x1, x2: word;
+  y1, y2: byte;
+begin
+  Result := '';
+  x1 := value shr 16;
+  x2 := value and $FFFF;
+  y1 := x1 div $100;
+  y2 := x1 mod $100;
+  Result := inttostr(y1) + '.' + inttostr(y2) + '.';
+  y1 := x2 div $100;
+  y2 := x2 mod $100;
+  Result := Result + inttostr(y1) + '.' + inttostr(y2);
+end;
+
+{==============================================================================}
+
+function ExpandIP6(Value: AnsiString): AnsiString;
+var
+ n: integer;
+ s: ansistring;
+ x: integer;
+begin
+  Result := '';
+  if value = '' then
+    exit;
+  x := countofchar(value, ':');
+  if x > 7 then
+    exit;
+  if value[1] = ':' then
+    value := '0' + value;
+  if value[length(value)] = ':' then
+    value := value + '0';
+  x := 8 - x;
+  s := '';
+  for n := 1 to x do
+    s := s + ':0';
+  s := s + ':';
+  Result := replacestring(value, '::', s);
+end;
+{==============================================================================}
+
+function StrToIp6(Value: string): TIp6Bytes;
+var
+ IPv6: TIp6Words;
+ Index: Integer;
+ n: integer;
+ b1, b2: byte;
+ s: string;
+ x: integer;
+begin
+  for n := 0 to 15 do
+    Result[n] := 0;
+  for n := 0 to 7 do
+    Ipv6[n] := 0;
+  Index := 0;
+  Value := ExpandIP6(value);
+  if value = '' then
+    exit;
+  while Value <> '' do
+  begin
+    if Index > 7 then
+      Exit;
+    s := fetch(value, ':');
+    if s = '@' then
+      break;
+    if s = '' then
+    begin
+      IPv6[Index] := 0;
+    end
+    else
+    begin
+      x := StrToIntDef('$' + s, -1);
+      if (x > 65535) or (x < 0) then
+        Exit;
+      IPv6[Index] := x;
+    end;
+    Inc(Index);
+  end;
+  for n := 0 to 7 do
+  begin
+    b1 := ipv6[n] div 256;
+    b2 := ipv6[n] mod 256;
+    Result[n * 2] := b1;
+    Result[(n * 2) + 1] := b2;
+  end;
+end;
+
+{==============================================================================}
+//based on routine by the Free Pascal development team
+function Ip6ToStr(value: TIp6Bytes): string;
+var
+  i, x: byte;
+  zr1,zr2: set of byte;
+  zc1,zc2: byte;
+  have_skipped: boolean;
+  ip6w: TIp6words;
+begin
+  zr1 := [];
+  zr2 := [];
+  zc1 := 0;
+  zc2 := 0;
+  for i := 0 to 7 do
+  begin
+    x := i * 2;
+    ip6w[i] := value[x] * 256 + value[x + 1];
+    if ip6w[i] = 0 then
+    begin
+      include(zr2, i);
+      inc(zc2);
+    end
+    else
+    begin
+      if zc1 < zc2 then
+      begin
+        zc1 := zc2;
+        zr1 := zr2;
+        zc2 := 0;
+        zr2 := [];
+      end;
+    end;
+  end;
+  if zc1 < zc2 then
+  begin
+    zr1 := zr2;
+  end;
+  SetLength(Result, 8*5-1);
+  SetLength(Result, 0);
+  have_skipped := false;
+  for i := 0 to 7 do
+  begin
+    if not(i in zr1) then
+    begin
+      if have_skipped then
+      begin
+        if Result = '' then
+          Result := '::'
+        else
+          Result := Result + ':';
+        have_skipped := false;
+      end;
+      Result := Result + IntToHex(Ip6w[i], 1) + ':';
+    end
+    else
+    begin
+      have_skipped := true;
+    end;
+  end;
+  if have_skipped then
+    if Result = '' then
+      Result := '::0'
+    else
+      Result := Result + ':';
+
+  if Result = '' then
+    Result := '::0';
+  if not (7 in zr1) then
+    SetLength(Result, Length(Result)-1);
+  Result := LowerCase(result);
+end;
+
+{==============================================================================}
+function ReverseIP(Value: AnsiString): AnsiString;
+var
+  x: Integer;
+begin
+  Result := '';
+  repeat
+    x := LastDelimiter('.', Value);
+    Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x);
+    Delete(Value, x, Length(Value) - x + 1);
+  until x < 1;
+  if Length(Result) > 0 then
+    if Result[1] = '.' then
+      Delete(Result, 1, 1);
+end;
+
+{==============================================================================}
+function ReverseIP6(Value: AnsiString): AnsiString;
+var
+  ip6: TIp6bytes;
+  n: integer;
+  x, y: integer;
+begin
+  ip6 := StrToIP6(Value);
+  x := ip6[15] div 16;
+  y := ip6[15] mod 16;
+  Result := IntToHex(y, 1) + '.' + IntToHex(x, 1);
+  for n := 14 downto 0 do
+  begin
+    x := ip6[n] div 16;
+    y := ip6[n] mod 16;
+    Result := Result + '.' + IntToHex(y, 1) + '.' + IntToHex(x, 1);
+  end;
+end;
+
+{==============================================================================}
+end.

Units/Synapse/synamisc.pas

@@ -0,0 +1,389 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.003.000 |
+|==============================================================================|
+| Content: misc. procedures and functions                                      |
+|==============================================================================|
+| Copyright (c)1999-2008, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c) 2002-2008.               |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(Misc. network based utilities)}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$Q-}
+{$H+}
+
+unit synamisc;
+
+interface
+
+{$IFDEF VER125}
+  {$DEFINE BCB}
+{$ENDIF}
+{$IFDEF BCB}
+  {$ObjExportAll On}
+  {$HPPEMIT '#pragma comment( lib , "wininet.lib" )'}
+{$ENDIF}
+
+uses
+  synautil, blcksock, SysUtils, Classes,
+{$IFDEF LINUX}
+  Libc;
+{$ELSE}
+  Windows;
+{$ENDIF}
+
+Type
+  {:@abstract(This record contains information about proxy setting.)}
+  TProxySetting = record
+    Host: string;
+    Port: string;
+    Bypass: string;
+  end;
+
+{:By this function you can turn-on computer on network, if this computer
+ supporting Wake-on-lan feature. You need MAC number (network card indentifier)
+ of computer for turn-on. You can also assign target IP addres. If you not
+ specify it, then is used broadcast for delivery magic wake-on packet. However
+ broadcasts workinh only on your local network. When you need to wake-up
+ computer on another network, you must specify any existing IP addres on same
+ network segment as targeting computer.}
+procedure WakeOnLan(MAC, IP: string);
+
+{:Autodetect current DNS servers used by system. If is defined more then one DNS
+ server, then result is comma-delimited.}
+function GetDNS: string;
+
+{:Autodetect InternetExplorer proxy setting for given protocol. This function
+working only on windows!}
+function GetIEProxy(protocol: string): TProxySetting;
+
+{:Return all known IP addresses on local system. Addresses are divided by comma.}
+function GetLocalIPs: string;
+
+implementation
+
+{==============================================================================}
+procedure WakeOnLan(MAC, IP: string);
+var
+  sock: TUDPBlockSocket;
+  HexMac: Ansistring;
+  data: Ansistring;
+  n: integer;
+  b: Byte;
+begin
+  if MAC <> '' then
+  begin
+    MAC := ReplaceString(MAC, '-', '');
+    MAC := ReplaceString(MAC, ':', '');
+    if Length(MAC) < 12 then
+      Exit;
+    HexMac := '';
+    for n := 0 to 5 do
+    begin
+      b := StrToIntDef('$' + MAC[n * 2 + 1] + MAC[n * 2 + 2], 0);
+      HexMac := HexMac + char(b);
+    end;
+    if IP = '' then
+      IP := cBroadcast;
+    sock := TUDPBlockSocket.Create;
+    try
+      sock.CreateSocket;
+      sock.EnableBroadcast(true);
+      sock.Connect(IP, '9');
+      data := #$FF + #$FF + #$FF + #$FF + #$FF + #$FF;
+      for n := 1 to 16 do
+        data := data + HexMac;
+      sock.SendString(data);
+    finally
+      sock.Free;
+    end;
+  end;
+end;
+
+{==============================================================================}
+
+{$IFNDEF LINUX}
+function GetDNSbyIpHlp: string;
+type
+  PTIP_ADDRESS_STRING = ^TIP_ADDRESS_STRING;
+  TIP_ADDRESS_STRING = array[0..15] of Ansichar;
+  PTIP_ADDR_STRING = ^TIP_ADDR_STRING;
+  TIP_ADDR_STRING = packed record
+    Next: PTIP_ADDR_STRING;
+    IpAddress: TIP_ADDRESS_STRING;
+    IpMask: TIP_ADDRESS_STRING;
+    Context: DWORD;
+  end;
+  PTFixedInfo = ^TFixedInfo;
+  TFixedInfo = packed record
+    HostName: array[1..128 + 4] of Ansichar;
+    DomainName: array[1..128 + 4] of Ansichar;
+    CurrentDNSServer: PTIP_ADDR_STRING;
+    DNSServerList: TIP_ADDR_STRING;
+    NodeType: UINT;
+    ScopeID: array[1..256 + 4] of Ansichar;
+    EnableRouting: UINT;
+    EnableProxy: UINT;
+    EnableDNS: UINT;
+  end;
+const
+  IpHlpDLL = 'IPHLPAPI.DLL';
+var
+  IpHlpModule: THandle;
+  FixedInfo: PTFixedInfo;
+  InfoSize: Longint;
+  PDnsServer: PTIP_ADDR_STRING;
+  err: integer;
+  GetNetworkParams: function(FixedInfo: PTFixedInfo; pOutPutLen: PULONG): DWORD; stdcall;
+begin
+  InfoSize := 0;
+  Result := '...';
+  IpHlpModule := LoadLibrary(IpHlpDLL);
+  if IpHlpModule = 0 then
+    exit;
+  try
+    GetNetworkParams := GetProcAddress(IpHlpModule,PAnsiChar(AnsiString('GetNetworkParams')));
+    if @GetNetworkParams = nil then
+      Exit;
+    err := GetNetworkParams(Nil, @InfoSize);
+    if err <> ERROR_BUFFER_OVERFLOW then
+      Exit;
+    Result := '';
+    GetMem (FixedInfo, InfoSize);
+    try
+      err := GetNetworkParams(FixedInfo, @InfoSize);
+      if err <> ERROR_SUCCESS then
+        exit;
+      with FixedInfo^ do
+      begin
+        Result := DnsServerList.IpAddress;
+        PDnsServer := DnsServerList.Next;
+        while PDnsServer <> Nil do
+        begin
+          if Result <> '' then
+            Result := Result + ',';
+          Result := Result + PDnsServer^.IPAddress;
+          PDnsServer := PDnsServer.Next;
+        end;
+    end;
+    finally
+      FreeMem(FixedInfo);
+    end;
+  finally
+    FreeLibrary(IpHlpModule);
+  end;
+end;
+
+function ReadReg(SubKey, Vn: PChar): string;
+var
+ OpenKey: HKEY;
+ DataType, DataSize: integer;
+ Temp: array [0..2048] of char;
+begin
+  Result := '';
+  if RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, REG_OPTION_NON_VOLATILE,
+    KEY_READ, OpenKey) = ERROR_SUCCESS then
+  begin
+    DataType := REG_SZ;
+    DataSize := SizeOf(Temp);
+    if RegQueryValueEx(OpenKey, Vn, nil, @DataType, @Temp, @DataSize) = ERROR_SUCCESS then
+      SetString(Result, Temp, DataSize div SizeOf(Char) - 1);
+    RegCloseKey(OpenKey);
+   end;
+end ;
+{$ENDIF}
+
+function GetDNS: string;
+{$IFDEF LINUX}
+var
+  l: TStringList;
+  n: integer;
+begin
+  Result := '';
+  l := TStringList.Create;
+  try
+    l.LoadFromFile('/etc/resolv.conf');
+    for n := 0 to l.Count - 1 do
+      if Pos('NAMESERVER', uppercase(l[n])) = 1 then
+      begin
+        if Result <> '' then
+          Result := Result + ',';
+        Result := Result + SeparateRight(l[n], ' ');
+      end;
+  finally
+    l.Free;
+  end;
+end;
+{$ELSE}
+const
+  NTdyn = 'System\CurrentControlSet\Services\Tcpip\Parameters\Temporary';
+  NTfix = 'System\CurrentControlSet\Services\Tcpip\Parameters';
+  W9xfix = 'System\CurrentControlSet\Services\MSTCP';
+begin
+  Result := GetDNSbyIpHlp;
+  if Result = '...' then
+  begin
+    if Win32Platform = VER_PLATFORM_WIN32_NT then
+    begin
+      Result := ReadReg(NTdyn, 'NameServer');
+      if result = '' then
+        Result := ReadReg(NTfix, 'NameServer');
+      if result = '' then
+        Result := ReadReg(NTfix, 'DhcpNameServer');
+    end
+    else
+      Result := ReadReg(W9xfix, 'NameServer');
+    Result := ReplaceString(trim(Result), ' ', ',');
+  end;
+end;
+{$ENDIF}
+
+{==============================================================================}
+
+function GetIEProxy(protocol: string): TProxySetting;
+{$IFDEF LINUX}
+begin
+  Result.Host := '';
+  Result.Port := '';
+  Result.Bypass := '';
+end;
+{$ELSE}
+type
+  PInternetProxyInfo = ^TInternetProxyInfo;
+  TInternetProxyInfo = packed record
+    dwAccessType: DWORD;
+    lpszProxy: LPCSTR;
+    lpszProxyBypass: LPCSTR;
+  end;
+const
+  INTERNET_OPTION_PROXY = 38;
+  INTERNET_OPEN_TYPE_PROXY = 3;
+  WininetDLL = 'WININET.DLL';
+var
+  WininetModule: THandle;
+  ProxyInfo: PInternetProxyInfo;
+  Err: Boolean;
+  Len: DWORD;
+  Proxy: string;
+  DefProxy: string;
+  ProxyList: TStringList;
+  n: integer;
+  InternetQueryOption: function (hInet: Pointer; dwOption: DWORD;
+    lpBuffer: Pointer; var lpdwBufferLength: DWORD): BOOL; stdcall;
+begin
+  Result.Host := '';
+  Result.Port := '';
+  Result.Bypass := '';
+  WininetModule := LoadLibrary(WininetDLL);
+  if WininetModule = 0 then
+    exit;
+  try
+    InternetQueryOption := GetProcAddress(WininetModule,PAnsiChar(AnsiString('InternetQueryOptionA')));
+    if @InternetQueryOption = nil then
+      Exit;
+
+    if protocol = '' then
+      protocol := 'http';
+    Len := 4096;
+    GetMem(ProxyInfo, Len);
+    ProxyList := TStringList.Create;
+    try
+      Err := InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len);
+      if Err then
+        if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then
+        begin
+          ProxyList.CommaText := ReplaceString(ProxyInfo^.lpszProxy, ' ', ',');
+          Proxy := '';
+          DefProxy := '';
+          for n := 0 to ProxyList.Count -1 do
+          begin
+            if Pos(lowercase(protocol) + '=', lowercase(ProxyList[n])) = 1 then
+            begin
+              Proxy := SeparateRight(ProxyList[n], '=');
+              break;
+            end;
+            if Pos('=', ProxyList[n]) < 1 then
+              DefProxy := ProxyList[n];
+          end;
+          if Proxy = '' then
+            Proxy := DefProxy;
+          if Proxy <> '' then
+          begin
+            Result.Host := Trim(SeparateLeft(Proxy, ':'));
+            Result.Port := Trim(SeparateRight(Proxy, ':'));
+          end;
+          Result.Bypass := ReplaceString(ProxyInfo^.lpszProxyBypass, ' ', ',');
+        end;
+    finally
+      ProxyList.Free;
+      FreeMem(ProxyInfo);
+    end;
+  finally
+    FreeLibrary(WininetModule);
+  end;
+end;
+{$ENDIF}
+
+{==============================================================================}
+
+function GetLocalIPs: string;
+var
+  TcpSock: TTCPBlockSocket;
+  ipList: TStringList;
+begin
+  Result := '';
+  ipList := TStringList.Create;
+  try
+    TcpSock := TTCPBlockSocket.create;
+    try
+      TcpSock.ResolveNameToIP(TcpSock.LocalName, ipList);
+      Result := ipList.CommaText;
+    finally
+      TcpSock.Free;
+    end;
+  finally
+    ipList.Free;
+  end;
+end;
+
+{==============================================================================}
+
+end.

Units/Synapse/synsock.pas

@@ -0,0 +1,67 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 005.001.000 |
+|==============================================================================|
+| Content: Socket Independent Platform Layer                                   |
+|==============================================================================|
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2001-2003.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@exclude}
+
+unit synsock;
+
+{$MINENUMSIZE 4}
+
+{$IFDEF CIL}
+  {$I ssdotnet.pas}
+{$ENDIF}
+
+{$IFDEF WIN32}
+  {$I sswin32.pas}
+{$ELSE}
+  {$IFDEF FPC}
+    {$I ssfpc.pas}
+  {$ELSE}
+    {$I sslinux.pas}
+  {$ENDIF}
+{$ENDIF}
+
+
+end.
+

Units/Synapse/tlntsend.pas

@@ -0,0 +1,358 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.003.000 |
+|==============================================================================|
+| Content: TELNET and SSH2 client                                              |
+|==============================================================================|
+| Copyright (c)1999-2008, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2002-2008.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(Telnet script client)
+
+Used RFC: RFC-854
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+unit tlntsend;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synautil;
+
+const
+  cTelnetProtocol = '23';
+  cSSHProtocol = '22';
+
+  TLNT_EOR                = #239;
+  TLNT_SE                 = #240;
+  TLNT_NOP                = #241;
+  TLNT_DATA_MARK          = #242;
+  TLNT_BREAK              = #243;
+  TLNT_IP                 = #244;
+  TLNT_AO                 = #245;
+  TLNT_AYT                = #246;
+  TLNT_EC                 = #247;
+  TLNT_EL                 = #248;
+  TLNT_GA                 = #249;
+  TLNT_SB                 = #250;
+  TLNT_WILL               = #251;
+  TLNT_WONT               = #252;
+  TLNT_DO                 = #253;
+  TLNT_DONT               = #254;
+  TLNT_IAC                = #255;
+
+type
+  {:@abstract(State of telnet protocol). Used internaly by TTelnetSend.}
+  TTelnetState =(tsDATA, tsIAC, tsIAC_SB, tsIAC_WILL, tsIAC_DO, tsIAC_WONT,
+     tsIAC_DONT, tsIAC_SBIAC, tsIAC_SBDATA, tsSBDATA_IAC);
+
+  {:@abstract(Class with implementation of Telnet/SSH script client.)
+
+   Note: Are you missing properties for specify server address and port? Look to
+   parent @link(TSynaClient) too!}
+  TTelnetSend = class(TSynaClient)
+  private
+    FSock: TTCPBlockSocket;
+    FBuffer: Ansistring;
+    FState: TTelnetState;
+    FSessionLog: Ansistring;
+    FSubNeg: Ansistring;
+    FSubType: Ansichar;
+    FTermType: Ansistring;
+    function Connect: Boolean;
+    function Negotiate(const Buf: Ansistring): Ansistring;
+    procedure FilterHook(Sender: TObject; var Value: AnsiString);
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:Connects to Telnet server.}
+    function Login: Boolean;
+
+    {:Connects to SSH2 server and login by Username and Password properties.
+
+     You must use some of SSL plugins with SSH support. For exammple CryptLib.}
+    function SSHLogin: Boolean;
+
+    {:Logout from telnet server.}
+    procedure Logout;
+
+    {:Send this data to telnet server.}
+    procedure Send(const Value: string);
+
+    {:Reading data from telnet server until Value is readed. If it is not readed
+     until timeout, result is @false. Otherwise result is @true.}
+    function WaitFor(const Value: string): Boolean;
+
+    {:Read data terminated by terminator from telnet server.}
+    function RecvTerminated(const Terminator: string): string;
+
+    {:Read string from telnet server.}
+    function RecvString: string;
+  published
+    {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
+    property Sock: TTCPBlockSocket read FSock;
+
+    {:all readed datas in this session (from connect) is stored in this large
+     string.}
+    property SessionLog: Ansistring read FSessionLog write FSessionLog;
+
+    {:Terminal type indentification. By default is 'SYNAPSE'.}
+    property TermType: Ansistring read FTermType write FTermType;
+  end;
+
+implementation
+
+constructor TTelnetSend.Create;
+begin
+  inherited Create;
+  FSock := TTCPBlockSocket.Create;
+  FSock.OnReadFilter := FilterHook;
+  FTimeout := 60000;
+  FTargetPort := cTelnetProtocol;
+  FSubNeg := '';
+  FSubType := #0;
+  FTermType := 'SYNAPSE';
+end;
+
+destructor TTelnetSend.Destroy;
+begin
+  FSock.Free;
+  inherited Destroy;
+end;
+
+function TTelnetSend.Connect: Boolean;
+begin
+  // Do not call this function! It is calling by LOGIN method!
+  FBuffer := '';
+  FSessionLog := '';
+  FState := tsDATA;
+  FSock.CloseSocket;
+  FSock.LineBuffer := '';
+  FSock.Bind(FIPInterface, cAnyPort);
+  FSock.Connect(FTargetHost, FTargetPort);
+  Result := FSock.LastError = 0;
+end;
+
+function TTelnetSend.RecvTerminated(const Terminator: string): string;
+begin
+  Result := FSock.RecvTerminated(FTimeout, Terminator);
+end;
+
+function TTelnetSend.RecvString: string;
+begin
+  Result := FSock.RecvTerminated(FTimeout, CRLF);
+end;
+
+function TTelnetSend.WaitFor(const Value: string): Boolean;
+begin
+  Result := FSock.RecvTerminated(FTimeout, Value) <> '';
+end;
+
+procedure TTelnetSend.FilterHook(Sender: TObject; var Value: AnsiString);
+begin
+  Value := Negotiate(Value);
+  FSessionLog := FSessionLog + Value;
+end;
+
+function TTelnetSend.Negotiate(const Buf: Ansistring): Ansistring;
+var
+  n: integer;
+  c: Ansichar;
+  Reply: Ansistring;
+  SubReply: Ansistring;
+begin
+  Result := '';
+  for n := 1 to Length(Buf) do
+  begin
+    c := Buf[n];
+    Reply := '';
+    case FState of
+      tsData:
+        if c = TLNT_IAC then
+          FState := tsIAC
+        else
+          Result := Result + c;
+
+      tsIAC:
+        case c of
+          TLNT_IAC:
+            begin
+              FState := tsData;
+              Result := Result + TLNT_IAC;
+            end;
+          TLNT_WILL:
+            FState := tsIAC_WILL;
+          TLNT_WONT:
+            FState := tsIAC_WONT;
+          TLNT_DONT:
+            FState := tsIAC_DONT;
+          TLNT_DO:
+            FState := tsIAC_DO;
+          TLNT_EOR:
+            FState := tsDATA;
+          TLNT_SB:
+            begin
+              FState := tsIAC_SB;
+              FSubType := #0;
+              FSubNeg := '';
+            end;
+        else
+          FState := tsData;
+        end;
+
+      tsIAC_WILL:
+        begin
+        case c of
+          #3:  //suppress GA
+            Reply := TLNT_DO;
+        else
+          Reply := TLNT_DONT;
+        end;
+          FState := tsData;
+        end;
+
+      tsIAC_WONT:
+        begin
+          Reply := TLNT_DONT;
+          FState := tsData;
+        end;
+
+      tsIAC_DO:
+      begin
+        case c of
+          #24:  //termtype
+            Reply := TLNT_WILL;
+        else
+          Reply := TLNT_WONT;
+        end;
+        FState := tsData;
+      end;
+
+      tsIAC_DONT:
+      begin
+        Reply := TLNT_WONT;
+        FState := tsData;
+      end;
+
+      tsIAC_SB:
+        begin
+          FSubType := c;
+          FState := tsIAC_SBDATA;
+        end;
+
+      tsIAC_SBDATA:
+        begin
+          if c = TLNT_IAC then
+            FState := tsSBDATA_IAC
+          else
+            FSubNeg := FSubNeg + c;
+        end;
+
+      tsSBDATA_IAC:
+        case c of
+          TLNT_IAC:
+            begin
+              FState := tsIAC_SBDATA;
+              FSubNeg := FSubNeg + c;
+            end;
+          TLNT_SE:
+            begin
+              SubReply := '';
+              case FSubType of
+                #24:  //termtype
+                  begin
+                    if (FSubNeg <> '') and (FSubNeg[1] = #1) then
+                      SubReply := #0 + FTermType;
+                  end;
+              end;
+              Sock.SendString(TLNT_IAC + TLNT_SB + FSubType + SubReply + TLNT_IAC + TLNT_SE);
+              FState := tsDATA;
+            end;
+         else
+           FState := tsDATA;
+         end;
+
+      else
+        FState := tsData;
+    end;
+    if Reply <> '' then
+      Sock.SendString(TLNT_IAC + Reply + c);
+  end;
+
+end;
+
+procedure TTelnetSend.Send(const Value: string);
+begin
+  Sock.SendString(ReplaceString(Value, TLNT_IAC, TLNT_IAC + TLNT_IAC));
+end;
+
+function TTelnetSend.Login: Boolean;
+begin
+  Result := False;
+  if not Connect then
+    Exit;
+  Result := True;
+end;
+
+function TTelnetSend.SSHLogin: Boolean;
+begin
+  Result := False;
+  if Connect then
+  begin
+    FSock.SSL.SSLType := LT_SSHv2;
+    FSock.SSL.Username := FUsername;
+    FSock.SSL.Password := FPassword;
+    FSock.SSLDoConnect;
+    Result := FSock.LastError = 0;
+  end;
+end;
+
+procedure TTelnetSend.Logout;
+begin
+  FSock.CloseSocket;
+end;
+
+
+end.