Release 30

git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@66 7c85be65-684b-0410-a082-b2ed4fbef004

asn1util.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 001.003.004 |
+| Project : Delphree - Synapse                                   | 001.003.005 |
 |==============================================================================|
 | Content: support for ASN.1 BER coding and decoding                           |
 |==============================================================================|
-| Copyright (c)1999-2002, Lukas Gebauer                                        |
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c) 1999,2000,2001.          |
+| Portions created by Lukas Gebauer are Copyright (c) 1999-2003                |
 | Portions created by Hernan Sanchez are Copyright (c) 2000.                   |
 | All Rights Reserved.                                                         |
 |==============================================================================|
@@ -301,7 +301,6 @@ begin
     else // NULL
       begin
         Result := '';
-        Inc(Start);
         Start := Start + ASNSize;
       end;
     end;

blcksock.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 006.001.004 |
+| Project : Delphree - Synapse                                   | 006.006.001 |
 |==============================================================================|
 | Content: Library base                                                        |
 |==============================================================================|
-| Copyright (c)1999-2002, Lukas Gebauer                                        |
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)1999-2002.                |
+| Portions created by Lukas Gebauer are Copyright (c)1999-2003.                |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -48,7 +48,18 @@ Special thanks to Gregor Ibic <gregor.ibic@intelicom.si>
 }
 
 {$Q-}
-{$WEAKPACKAGEUNIT ON}
+
+{$DEFINE ONCEWINSOCK}
+{Note about define ONCEWINSOCK:
+If you remove this compiler directive, then socket interface is loaded and
+initialized on constructor of TBlockSocket class for each socket separately.
+Socket interface is used only if your need it.
+
+If you leave this directive here, then socket interface is loaded and
+initialized only once at start of your program! It boost performace on high
+count of created and destroyed sockets. It eliminate possible small resource
+leak on Windows systems too.
+}
 
 unit blcksock;
 
@@ -68,13 +79,20 @@ const
   cAnyHost = '0.0.0.0';
   cBroadcast = '255.255.255.255';
   cAnyPort = '0';
+  CR = #$0d;
+  LF = #$0a;
+  CRLF = CR + LF;
+
 
 type
 
   ESynapseError = class(Exception)
-  public
+  private
-    ErrorCode: Integer;
+    FErrorCode: Integer;
-    ErrorMessage: string;
+    FErrorMessage: string;
+  published
+    property ErrorCode: Integer read FErrorCode Write FErrorCode;
+    property ErrorMessage: string read FErrorMessage Write FErrorMessage;
   end;
 
   THookSocketReason = (
@@ -89,15 +107,20 @@ type
     HR_Listen,
     HR_Accept,
     HR_ReadCount,
-    HR_WriteCount
+    HR_WriteCount,
+    HR_Wait
     );
 
   THookSocketStatus = procedure(Sender: TObject; Reason: THookSocketReason;
     const Value: string) of object;
 
+  THookDataFilter = procedure(Sender: TObject; var Value: string) of object;
+
   TBlockSocket = class(TObject)
   private
     FOnStatus: THookSocketStatus;
+    FOnReadFilter: THookDataFilter;
+    FOnWriteFilter: THookDataFilter;
     FWsaData: TWSADATA;
     FLocalSin: TSockAddrIn;
     FRemoteSin: TSockAddrIn;
@@ -112,11 +135,16 @@ type
     FMaxRecvBandwidth: Integer;
     FNextRecv: Cardinal;
     FConvertLineEnd: Boolean;
+    FLastCR: Boolean;
+    FLastLF: Boolean;
+    FBinded: Boolean;
     function GetSizeRecvBuffer: Integer;
     procedure SetSizeRecvBuffer(Size: Integer);
     function GetSizeSendBuffer: Integer;
     procedure SetSizeSendBuffer(Size: Integer);
     procedure SetNonBlockMode(Value: Boolean);
+    procedure SetTTL(TTL: integer);
+    function GetTTL:integer;
   protected
     FSocket: TSocket;
     FProtocol: Integer;
@@ -126,6 +154,8 @@ type
     function GetSinIP(Sin: TSockAddrIn): string;
     function GetSinPort(Sin: TSockAddrIn): Integer;
     procedure DoStatus(Reason: THookSocketReason; const Value: string);
+    procedure DoReadFilter(Buffer: Pointer; var Length: Integer);
+    procedure DoWriteFilter(Buffer: Pointer; var Length: Integer);
     procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: Cardinal);
     procedure SetBandwidth(Value: Integer);
   public
@@ -141,6 +171,7 @@ type
     function RecvBuffer(Buffer: Pointer; Length: Integer): Integer; virtual;
     function RecvBufferEx(Buffer: Pointer; Length: Integer;
       Timeout: Integer): Integer; virtual;
+    function RecvBufferStr(Length: Integer; Timeout: Integer): String; virtual;
     function RecvByte(Timeout: Integer): Byte; virtual;
     function RecvString(Timeout: Integer): string; virtual;
     function RecvTerminated(Timeout: Integer; const Terminator: string): string; virtual;
@@ -189,13 +220,16 @@ type
     property SizeRecvBuffer: Integer read GetSizeRecvBuffer write SetSizeRecvBuffer;
     property SizeSendBuffer: Integer read GetSizeSendBuffer write SetSizeSendBuffer;
     property WSAData: TWSADATA read FWsaData;
-    property OnStatus: THookSocketStatus read FOnStatus write FOnStatus;
     property NonBlockMode: Boolean read FNonBlockMode Write SetNonBlockMode;
     property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength;
     property MaxSendBandwidth: Integer read FMaxSendBandwidth Write FMaxSendBandwidth;
     property MaxRecvBandwidth: Integer read FMaxRecvBandwidth Write FMaxRecvBandwidth;
     property MaxBandwidth: Integer Write SetBandwidth;
     property ConvertLineEnd: Boolean read FConvertLineEnd Write FConvertLineEnd;
+    property TTL: Integer read GetTTL Write SetTTL;
+    property OnStatus: THookSocketStatus read FOnStatus write FOnStatus;
+    property OnReadFilter: THookDataFilter read FOnReadFilter write FOnReadFilter;
+    property OnWriteFilter: THookDataFilter read FOnWriteFilter write FOnWriteFilter;
   end;
 
   TSocksBlockSocket = class(TBlockSocket)
@@ -304,6 +338,8 @@ type
   protected
     FSocksControlSock: TTCPBlockSocket;
     function UdpAssociation: Boolean;
+    procedure SetMulticastTTL(TTL: integer);
+    function GetMulticastTTL:integer;
   public
     destructor Destroy; override;
     procedure CreateSocket; override;
@@ -315,6 +351,9 @@ type
     function RecvBufferFrom(Buffer: Pointer; Length: Integer): Integer; override;
     procedure AddMulticast(MCastIP:string);
     procedure DropMulticast(MCastIP:string);
+    function EnableMulticastLoop(Value: Boolean): Boolean;
+  published
+    property MulticastTTL: Integer read GetMulticastTTL Write SetMulticastTTL;
   end;
 
   //See 'winsock2.txt' file in distribute package!
@@ -366,9 +405,54 @@ type
     MCastIfc : u_long;
   end;
 
+{$IFDEF ONCEWINSOCK}
+var
+  WsaDataOnce: TWSADATA;
+  e: ESynapseError;
+{$ENDIF}
+
+
 constructor TBlockSocket.Create;
+{$IFNDEF ONCEWINSOCK}
 var
   e: ESynapseError;
+{$ENDIF}
+begin
+  inherited Create;
+  FRaiseExcept := False;
+  FSocket := INVALID_SOCKET;
+  FProtocol := IPPROTO_IP;
+  FBuffer := '';
+  FLastCR := False;
+  FLastLF := False;
+  FBinded := False;
+  FNonBlockMode := False;
+  FMaxLineLength := 0;
+  FMaxSendBandwidth := 0;
+  FNextSend := 0;
+  FMaxRecvBandwidth := 0;
+  FNextRecv := 0;
+  FConvertLineEnd := False;
+{$IFDEF ONCEWINSOCK}
+  FWsaData := WsaDataOnce;
+{$ELSE}
+  if not InitSocketInterface('') then
+  begin
+    e := ESynapseError.Create('Error loading Winsock DLL!');
+    e.ErrorCode := 0;
+    e.ErrorMessage := 'Error loading Winsock DLL!';
+    raise e;
+  end;
+  SockCheck(synsock.WSAStartup($101, FWsaData));
+  ExceptCheck;
+{$ENDIF}
+end;
+
+constructor TBlockSocket.CreateAlternate(Stub: string);
+{$IFNDEF ONCEWINSOCK}
+var
+  e: ESynapseError;
+{$ENDIF}
 begin
   inherited Create;
   FRaiseExcept := False;
@@ -382,26 +466,9 @@ begin
   FMaxRecvBandwidth := 0;
   FNextRecv := 0;
   FConvertLineEnd := False;
-  if not InitSocketInterface('') then
+{$IFDEF ONCEWINSOCK}
-  begin
+  FWsaData := WsaDataOnce;
-    e := ESynapseError.Create('Error loading Winsock DLL!');
+{$ELSE}
-    e.ErrorCode := 0;
-    e.ErrorMessage := 'Error loading Winsock DLL!';
-    raise e;
-  end;
-  SockCheck(synsock.WSAStartup($101, FWsaData));
-  ExceptCheck;
-end;
-
-constructor TBlockSocket.CreateAlternate(Stub: string);
-var
-  e: ESynapseError;
-begin
-  inherited Create;
-  FRaiseExcept := False;
-  FSocket := INVALID_SOCKET;
-  FProtocol := IPPROTO_IP;
-  FBuffer := '';
   if not InitSocketInterface(Stub) then
   begin
     e := ESynapseError.Create('Error loading alternate Winsock DLL (' + Stub + ')!');
@@ -411,13 +478,16 @@ begin
   end;
   SockCheck(synsock.WSAStartup($101, FWsaData));
   ExceptCheck;
+{$ENDIF}
 end;
 
 destructor TBlockSocket.Destroy;
 begin
   CloseSocket;
+{$IFNDEF ONCEWINSOCK}
   synsock.WSACleanup;
   DestroySocketInterface;
+{$ENDIF}
   inherited Destroy;
 end;
 
@@ -430,27 +500,32 @@ var
   HostEnt: PHostEnt;
 begin
   DoStatus(HR_ResolvingBegin, IP + ':' + Port);
-  FillChar(Sin, Sizeof(Sin), 0);
+  SynSockCS.Enter;
-  Sin.sin_family := AF_INET;
+  try
-  ProtoEnt := synsock.GetProtoByNumber(FProtocol);
+    FillChar(Sin, Sizeof(Sin), 0);
-  ServEnt := nil;
+    Sin.sin_family := AF_INET;
-  if ProtoEnt <> nil then
+    ProtoEnt := synsock.GetProtoByNumber(FProtocol);
-    ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name);
+    ServEnt := nil;
-  if ServEnt = nil then
+    if ProtoEnt <> nil then
-    Sin.sin_port := synsock.htons(StrToIntDef(Port, 0))
+      ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name);
-  else
+    if ServEnt = nil then
-    Sin.sin_port := ServEnt^.s_port;
+      Sin.sin_port := synsock.htons(StrToIntDef(Port, 0))
-  if IP = cBroadcast then
+    else
-    Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST)
+      Sin.sin_port := ServEnt^.s_port;
-  else
+    if IP = cBroadcast then
-  begin
+      Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST)
-    Sin.sin_addr.s_addr := synsock.inet_addr(PChar(IP));
+    else
-    if SIn.sin_addr.s_addr = u_long(INADDR_NONE) then
     begin
-      HostEnt := synsock.GetHostByName(PChar(IP));
+      Sin.sin_addr.s_addr := synsock.inet_addr(PChar(IP));
-      if HostEnt <> nil then
+      if SIn.sin_addr.s_addr = u_long(INADDR_NONE) then
-        SIn.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^);
+      begin
+        HostEnt := synsock.GetHostByName(PChar(IP));
+        if HostEnt <> nil then
+          SIn.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^);
+      end;
     end;
+  finally
+    SynSockCS.Leave;
   end;
   DoStatus(HR_ResolvingEnd, IP + ':' + Port);
 end;
@@ -474,6 +549,7 @@ end;
 procedure TBlockSocket.CreateSocket;
 begin
   FBuffer := '';
+  FBinded := False;
   if FSocket = INVALID_SOCKET then
     FLastError := synsock.WSAGetLastError
   else
@@ -490,7 +566,6 @@ end;
 
 procedure TBlockSocket.CloseSocket;
 begin
-  synsock.Shutdown(FSocket, 2);
   synsock.CloseSocket(FSocket);
   FSocket := INVALID_SOCKET;
   DoStatus(HR_SocketClose, '');
@@ -507,6 +582,7 @@ begin
   Len := SizeOf(FLocalSin);
   synsock.GetSockName(FSocket, FLocalSin, Len);
   FBuffer := '';
+  FBinded := True;
   ExceptCheck;
   DoStatus(HR_Bind, IP + ':' + Port);
 end;
@@ -520,6 +596,8 @@ begin
   SockCheck(synsock.Connect(FSocket, Sin, SizeOf(Sin)));
   GetSins;
   FBuffer := '';
+  FLastCR := False;
+  FLastLF := False;
   ExceptCheck;
   DoStatus(HR_Connect, IP + ':' + Port);
 end;
@@ -552,7 +630,10 @@ begin
     begin
       x := Next - y;
       if x > 0 then
+      begin
+        DoStatus(HR_Wait, IntToStr(x));
         sleep(x);
+      end;
     end;
     Next := y + Trunc((Length / MaxB) * 1000);
   end;
@@ -561,6 +642,7 @@ end;
 function TBlockSocket.SendBuffer(Buffer: Pointer; Length: Integer): Integer;
 begin
   LimitBandwidth(Length, FMaxSendBandwidth, FNextsend);
+  DoWriteFilter(Buffer, Length);
   Result := synsock.Send(FSocket, Buffer^, Length, 0);
   SockCheck(Result);
   ExceptCheck;
@@ -587,68 +669,46 @@ begin
     SockCheck(Result);
   ExceptCheck;
   DoStatus(HR_ReadCount, IntToStr(Result));
+  DoReadFilter(Buffer, Result);
 end;
 
 function TBlockSocket.RecvBufferEx(Buffer: Pointer; Length: Integer;
   Timeout: Integer): Integer;
 var
-  s, ss, st: string;
+  s: string;
-  x, l, lss: Integer;
+  rl, l: integer;
-  fb, fs: Integer;
-  max: Integer;
 begin
   FLastError := 0;
-  x := System.Length(FBuffer);
+  rl := 0;
-  if Length <= x then
+  repeat
+    s := RecvPacket(Timeout);
+    l := System.Length(s);
+    if (rl + l) > Length then
+      l := Length - rl;
+    Move(Pointer(s)^, IncPoint(Buffer, rl)^, l);
+    rl := rl + l;
+    if FLastError <> 0 then
+      Break;
+  until rl >= Length;
+  delete(s, 1, l);
+  FBuffer := s;
+  Result := rl;
+end;
+
+function TBlockSocket.RecvBufferStr(Length: Integer; Timeout: Integer): string;
+var
+  x: integer;
+begin
+  Result := '';
+  if Length > 0 then
   begin
-    fb := Length;
+    Setlength(Result, Length);
-    fs := 0;
+    x := RecvBufferEx(PChar(Result), Length , Timeout);
-  end
+    if FLastError = 0 then
-  else
+      SetLength(Result, x)
-  begin
+    else
-    fb := x;
+      Result := '';
-    fs := Length - x;
   end;
-  ss := '';
-  if fb > 0 then
-  begin
-    s := Copy(FBuffer, 1, fb);
-    Delete(FBuffer, 1, fb);
-  end;
-  if fs > 0 then
-  begin
-    Max := GetSizeRecvBuffer;
-    ss := '';
-    while System.Length(ss) < fs do
-    begin
-      if CanRead(Timeout) then
-      begin
-        l := WaitingData;
-        if l > max then
-          l := max;
-        if (system.Length(ss) + l) > fs then
-          l := fs - system.Length(ss);
-        SetLength(st, l);
-        x := RecvBuffer(Pointer(st), l);
-        if FLastError <> 0 then
-          Break;
-        lss := system.Length(ss);
-        SetLength(ss, lss + x);
-        Move(Pointer(st)^, Pointer(@ss[lss + 1])^, x);
-        {It is 3x faster then ss:=ss+copy(st,1,x);}
-        Sleep(0);
-      end
-      else
-        FLastError := WSAETIMEDOUT;
-      if FLastError <> 0 then
-        Break;
-    end;
-    fs := system.Length(ss);
-  end;
-  Result := fb + fs;
-  s := s + ss;
-  Move(Pointer(s)^, Buffer^, Result);
-  ExceptCheck;
 end;
 
 function TBlockSocket.RecvPacket(Timeout: Integer): string;
@@ -657,16 +717,19 @@ var
 begin
   Result := '';
   FLastError := 0;
-  x := -1;
   if FBuffer <> '' then
   begin
     Result := FBuffer;
     FBuffer := '';
   end
   else
+  begin
+    Sleep(0);
     if CanRead(Timeout) then
     begin
       x := WaitingData;
+      if x = 0 then
+        FLastError := WSAECONNRESET;
       if x > 0 then
       begin
         SetLength(Result, x);
@@ -677,9 +740,8 @@ begin
     end
     else
       FLastError := WSAETIMEDOUT;
+  end;
   ExceptCheck;
-  if x = 0 then
-    FLastError := WSAECONNRESET;
 end;
 
 
@@ -689,9 +751,7 @@ begin
   FLastError := 0;
   if FBuffer = '' then
     FBuffer := RecvPacket(Timeout);
-  if (FBuffer = '') and (FLastError = 0) then
+  if (FLastError = 0) and (FBuffer <> '') then
-    FLastError := WSAETIMEDOUT;
-  if FLastError = 0 then
   begin
     Result := Ord(FBuffer[1]);
     System.Delete(FBuffer, 1, 1);
@@ -714,29 +774,7 @@ begin
   if l = 0 then
     Exit;
   tl := l;
-  CorCRLF := FConvertLineEnd and (Terminator = #$0d + #$0a);
+  CorCRLF := FConvertLineEnd and (Terminator = CRLF);
-  // if FBuffer contains requested data, return it...
-  if FBuffer<>'' then
-  begin
-    if CorCRLF then
-    begin
-      t := '';
-      x := PosCRLF(FBuffer, t);
-      tl := system.Length(t);
-    end
-    else
-    begin
-      x := pos(Terminator, FBuffer);
-      tl := l;
-    end;
-    if x > 0 then
-    begin
-      Result := copy(FBuffer, 1, x - 1);
-      System.Delete(FBuffer, 1, x + tl - 1);
-      Exit;
-    end;
-  end;
-  // now FBuffer is empty or not contains all data...
   s := '';
   x := 0;
   repeat
@@ -744,17 +782,29 @@ begin
     s := s + RecvPacket(Timeout);
     if FLastError <> 0 then
       Break;
-    if CorCRLF then
+    x := 0;
-    begin
+    if Length(s) > 0 then
-      t := '';
+      if CorCRLF then
-      x := PosCRLF(s, t);
+      begin
-      tl := system.Length(t);
+        if FLastCR and (s[1] = LF) then
-    end
+          Delete(s, 1, 1);
-    else
+        if FLastLF and (s[1] = CR) then
-    begin
+          Delete(s, 1, 1);
-      x := pos(Terminator, s);
+        FLastCR := False;
-      tl := l;
+        FLastLF := False;
-    end;
+        t := '';
+        x := PosCRLF(s, t);
+        tl := system.Length(t);
+        if t = CR then
+          FLastCR := True;
+        if t = LF then
+          FLastLF := True;
+      end
+      else
+      begin
+        x := pos(Terminator, s);
+        tl := l;
+      end;
     if (FMaxLineLength <> 0) and (system.Length(s) > FMaxLineLength) then
     begin
       FLastError := WSAENOBUFS;
@@ -775,7 +825,7 @@ var
   s: string;
 begin
   Result := '';
-  s := RecvTerminated(Timeout, #13 + #10);
+  s := RecvTerminated(Timeout, CRLF);
   if FLastError = 0 then
     Result := s;
 end;
@@ -872,9 +922,14 @@ begin
   if BufPtr[0] <> #0 then
   begin
     // try get Fully Qualified Domain Name
-    RemoteHost := synsock.GetHostByName(BufPtr);
+    SynSockCS.Enter;
-    if RemoteHost <> nil then
+    try
-      Result := PChar(RemoteHost^.h_name);
+      RemoteHost := synsock.GetHostByName(BufPtr);
+      if RemoteHost <> nil then
+        Result := PChar(RemoteHost^.h_name);
+    finally
+      SynSockCS.Leave;
+    end;
   end;
   if Result = '' then
     Result := '127.0.0.1';
@@ -896,23 +951,28 @@ begin
   IP := synsock.inet_addr(PChar(Name));
   if IP = u_long(INADDR_NONE) then
   begin
-    RemoteHost := synsock.GetHostByName(PChar(Name));
+    SynSockCS.Enter;
-    if RemoteHost <> nil then
+    try
-    begin
+      RemoteHost := synsock.GetHostByName(PChar(Name));
-      PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list);
+      if RemoteHost <> nil then
-      i := 0;
-      while PAdrPtr^[i] <> nil do
       begin
-        InAddr := PAdrPtr^[i]^;
+        PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list);
-        with InAddr.S_un_b do
+        i := 0;
-          s := Format('%d.%d.%d.%d',
+        while PAdrPtr^[i] <> nil do
-            [Ord(s_b1), Ord(s_b2), Ord(s_b3), Ord(s_b4)]);
+        begin
-        IPList.Add(s);
+          InAddr := PAdrPtr^[i]^;
-        Inc(i);
+          with InAddr.S_un_b do
+            s := Format('%d.%d.%d.%d',
+              [Ord(s_b1), Ord(s_b2), Ord(s_b3), Ord(s_b4)]);
+          IPList.Add(s);
+          Inc(i);
+        end;
       end;
+      if IPList.Count = 0 then
+        IPList.Add('0.0.0.0');
+    finally
+      SynSockCS.Leave;
     end;
-    if IPList.Count = 0 then
-      IPList.Add('0.0.0.0');
   end
   else
     IPList.Add(Name);
@@ -936,14 +996,19 @@ var
   ProtoEnt: PProtoEnt;
   ServEnt: PServEnt;
 begin
-  ProtoEnt := synsock.GetProtoByNumber(FProtocol);
+  SynSockCS.Enter;
-  ServEnt := nil;
+  try
-  if ProtoEnt <> nil then
+    ProtoEnt := synsock.GetProtoByNumber(FProtocol);
-    ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name);
+    ServEnt := nil;
-  if ServEnt = nil then
+    if ProtoEnt <> nil then
-    Result := synsock.htons(StrToIntDef(Port, 0))
+      ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name);
-  else
+    if ServEnt = nil then
-    Result := ServEnt^.s_port;
+      Result := synsock.htons(StrToIntDef(Port, 0))
+    else
+      Result := ServEnt^.s_port;
+  finally
+    SynSockCS.Leave;
+  end;
 end;
 
 procedure TBlockSocket.SetRemoteSin(IP, Port: string);
@@ -1166,12 +1231,64 @@ begin
   ExceptCheck;
 end;
 
+procedure TBlockSocket.SetTTL(TTL: integer);
+var
+  Res: Integer;
+begin
+  Res := synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_TTL, @TTL, SizeOf(TTL));
+  SockCheck(Res);
+  ExceptCheck;
+end;
+
+function TBlockSocket.GetTTL:integer;
+var
+  l: Integer;
+begin
+  l := SizeOf(Result);
+  SockCheck(synsock.GetSockOpt(FSocket, IPPROTO_IP, IP_TTL, @Result, l));
+  ExceptCheck;
+end;
+
 procedure TBlockSocket.DoStatus(Reason: THookSocketReason; const Value: string);
 begin
   if assigned(OnStatus) then
     OnStatus(Self, Reason, Value);
 end;
 
+procedure TBlockSocket.DoReadFilter(Buffer: Pointer; var Length: Integer);
+var
+  s: string;
+begin
+  if assigned(OnReadFilter) then
+    if Length > 0 then
+      begin
+        SetLength(s, Length);
+        Move(Buffer^, Pointer(s)^, Length);
+        OnReadFilter(Self, s);
+        if System.Length(s) > Length then
+          SetLength(s, Length);
+        Length := System.Length(s);
+        Move(Pointer(s)^, Buffer^, Length);
+      end;
+end;
+
+procedure TBlockSocket.DoWriteFilter(Buffer: Pointer; var Length: Integer);
+var
+  s: string;
+begin
+  if assigned(OnWriteFilter) then
+    if Length > 0 then
+      begin
+        SetLength(s, Length);
+        Move(Buffer^, Pointer(s)^, Length);
+        OnWriteFilter(Self, s);
+        if System.Length(s) > Length then
+          SetLength(s, Length);
+        Length := System.Length(s);
+        Move(Pointer(s)^, Buffer^, Length);
+      end;
+end;
+
 class function TBlockSocket.GetErrorDesc(ErrorCode: Integer): string;
 begin
   case ErrorCode of
@@ -1320,8 +1437,7 @@ begin
     else
       Buf := #5 + #2 + #2 +#0;
     SendString(Buf);
-    Buf := RecvPacket(FSocksTimeout);
+    Buf := RecvBufferStr(2, FSocksTimeout);
-    FBuffer := Copy(Buf, 3, Length(buf) - 2);
     if Length(Buf) < 2 then
       Exit;
     if Buf[1] <> #5 then
@@ -1335,8 +1451,7 @@ begin
           Buf := #1 + char(Length(FSocksUsername)) + FSocksUsername
             + char(Length(FSocksPassword)) + FSocksPassword;
           SendString(Buf);
-          Buf := RecvPacket(FSocksTimeout);
+          Buf := RecvBufferStr(2, FSocksTimeout);
-          FBuffer := Copy(Buf, 3, Length(buf) - 2);
           if Length(Buf) < 2 then
             Exit;
           if Buf[2] <> #0 then
@@ -1369,7 +1484,7 @@ end;
 
 function TSocksBlockSocket.SocksResponse: Boolean;
 var
-  Buf: string;
+  Buf, s: string;
   x: integer;
 begin
   Result := False;
@@ -1377,18 +1492,33 @@ begin
   try
     FSocksResponseIP := '';
     FSocksResponsePort := '';
-    Buf := RecvPacket(FSocksTimeout);
+
+    Buf := RecvBufferStr(4, FSocksTimeout);
     if FLastError <> 0 then
       Exit;
-    if Length(Buf) < 5 then
-      Exit;
     if Buf[1] <> #5 then
       Exit;
+    case Ord(Buf[4]) of
+      1:
+        s := RecvBufferStr(4, FSocksTimeout);
+      3:
+        begin
+          x := RecvByte(FSocksTimeout);
+          if FLastError <> 0 then
+            Exit;
+          s := char(x) + RecvBufferStr(x, FSocksTimeout);
+        end;
+    else
+      Exit;
+    end;
+    Buf := Buf + s + RecvBufferStr(2, FSocksTimeout);
+    if FLastError <> 0 then
+      Exit;
+
     FSocksLastError := Ord(Buf[2]);
     if FSocksLastError <> 0 then
       Exit;
-    x := SocksDecode(Buf);
+    SocksDecode(Buf);
-    FBuffer := Copy(Buf, x, Length(buf) - x + 1);
     Result := True;
   finally
     FBypassFlag := False;
@@ -1414,6 +1544,8 @@ var
   w: Word;
 begin
   FSocksResponsePort := '0';
+  if Length(Value) < 4 then
+    Exit;
   Atyp := Ord(Value[4]);
   Result := 5;
   case Atyp of
@@ -1505,14 +1637,12 @@ begin
     if FSocksControlSock.LastError <> 0 then
       Exit;
     // if not assigned local port, assign it!
-    if GetLocalSinPort = 0 then
+    if not FBinded then
-      Bind(GetLocalSinIP, '0');
+      Bind('0.0.0.0', '0');
-    GetSins;
     //open control TCP connection to SOCKS
     b := FSocksControlSock.SocksOpen;
     if b then
-      b := FSocksControlSock.SocksRequest(3, GetLocalSinIP,
+      b := FSocksControlSock.SocksRequest(3, GetLocalSinIP, IntToStr(GetLocalSinPort));
-        IntToStr(GetLocalSinPort));
     if b then
       b := FSocksControlSock.SocksResponse;
     if not b and (FLastError = 0) then
@@ -1520,7 +1650,7 @@ begin
     FUsingSocks :=FSocksControlSock.UsingSocks;
     FSocksRemoteIP := FSocksControlSock.FSocksResponseIP;
     FSocksRemotePort := FSocksControlSock.FSocksResponsePort;
-    Result := True;
+    Result := b and (FLastError = 0);
   end;
 end;
 
@@ -1530,22 +1660,27 @@ var
   SPort: integer;
   Buf: string;
 begin
-  UdpAssociation;
+  FUsingSocks := False;
-  if FUsingSocks then
+  if (FSocksIP <> '') and (not UdpAssociation) then
-  begin
+    FLastError := WSANO_RECOVERY
-    Sip := GetRemoteSinIp;
-    SPort := GetRemoteSinPort;
-    SetRemoteSin(FSocksRemoteIP, FSocksRemotePort);
-    SetLength(Buf,Length);
-    Move(Buffer^, PChar(Buf)^, Length);
-    Buf := #0 + #0 + #0 + SocksCode(Sip, IntToStr(SPort)) + Buf;
-    Result := inherited SendBufferTo(PChar(Buf), System.Length(buf));
-    SetRemoteSin(Sip, IntToStr(SPort));
-  end
   else
   begin
-    Result := inherited SendBufferTo(Buffer, Length);
+    if FUsingSocks then
-    GetSins;
+    begin
+      Sip := GetRemoteSinIp;
+      SPort := GetRemoteSinPort;
+      SetRemoteSin(FSocksRemoteIP, FSocksRemotePort);
+      SetLength(Buf,Length);
+      Move(Buffer^, PChar(Buf)^, Length);
+      Buf := #0 + #0 + #0 + SocksCode(Sip, IntToStr(SPort)) + Buf;
+      Result := inherited SendBufferTo(PChar(Buf), System.Length(buf));
+      SetRemoteSin(Sip, IntToStr(SPort));
+    end
+    else
+    begin
+      Result := inherited SendBufferTo(Buffer, Length);
+      GetSins;
+    end;
   end;
 end;
 
@@ -1589,6 +1724,36 @@ begin
   ExceptCheck;
 end;
 
+procedure TUDPBlockSocket.SetMulticastTTL(TTL: integer);
+var
+  Res: Integer;
+begin
+  Res := synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_MULTICAST_TTL, @TTL, SizeOf(TTL));
+  SockCheck(Res);
+  ExceptCheck;
+end;
+
+function TUDPBlockSocket.GetMulticastTTL:integer;
+var
+  l: Integer;
+begin
+  l := SizeOf(Result);
+  SockCheck(synsock.GetSockOpt(FSocket, IPPROTO_IP, IP_MULTICAST_TTL, @Result, l));
+  ExceptCheck;
+end;
+
+function TUDPBlockSocket.EnableMulticastLoop(Value: Boolean): Boolean;
+var
+  Opt: Integer;
+  Res: Integer;
+begin
+  opt := Ord(Value);
+  Res := synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_MULTICAST_LOOP, @Opt, SizeOf(opt));
+  SockCheck(Res);
+  Result := res = 0;
+  ExceptCheck;
+end;
+
 {======================================================================}
 
 function PasswordCallback(buf:PChar; size:Integer; rwflag:Integer; userdata: Pointer):Integer; cdecl;
@@ -1643,7 +1808,8 @@ end;
 
 procedure TTCPBlockSocket.CloseSocket;
 begin
-  synsock.Shutdown(FSocket, 1);
+  if FSocket <> INVALID_SOCKET then
+    synsock.Shutdown(FSocket, 1);
   inherited CloseSocket;
 end;
 
@@ -1761,11 +1927,11 @@ begin
     if FLastError <> 0 then
       Exit;
     FHTTPTunnel := False;
-    SendString('CONNECT ' + IP + ':' + Port + ' HTTP/1.0' + #$0d + #$0a);
+    SendString('CONNECT ' + IP + ':' + Port + ' HTTP/1.0' + CRLF);
     if FHTTPTunnelUser <> '' then
     Sendstring('Proxy-Authorization: Basic ' +
-      EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + #$0d + #$0a);
+      EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + CRLF);
-    SendString(#$0d + #$0a);
+    SendString(CRLF);
     repeat
       s := RecvTerminated(30000, #$0a);
       if FLastError <> 0 then
@@ -1975,6 +2141,7 @@ begin
         FLastError := WSASYSNOTREADY;
     ExceptCheck;
     DoStatus(HR_ReadCount, IntToStr(Result));
+    DoReadFilter(Buffer, Result);
   end
   else
     Result := inherited RecvBuffer(Buffer, Length);
@@ -1987,6 +2154,7 @@ begin
   if FSslEnabled and not(FSslBypass) and not(FBypassFlag) then
   begin
     FLastError := 0;
+    DoWriteFilter(Buffer, Length);
     repeat
       Result := SslWrite(FSsl, Buffer, Length);
       err := SslGetError(FSsl, Result);
@@ -2111,4 +2279,26 @@ begin
   FTimeout := 5000;
 end;
 
+{======================================================================}
+
+{$IFDEF ONCEWINSOCK}
+initialization
+begin
+  if not InitSocketInterface('') then
+  begin
+    e := ESynapseError.Create('Error loading Winsock DLL!');
+    e.ErrorCode := 0;
+    e.ErrorMessage := 'Error loading Winsock DLL!';
+    raise e;
+  end;
+  synsock.WSAStartup($101, WsaDataOnce);
+end;
+
+finalization
+begin
+  synsock.WSACleanup;
+  DestroySocketInterface;
+end;
+{$ENDIF}
+
 end.

dnssend.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 001.002.000 |
+| Project : Delphree - Synapse                                   | 002.001.001 |
 |==============================================================================|
 | Content: DNS client                                                          |
 |==============================================================================|
-| Copyright (c)1999-2002, Lukas Gebauer                                        |
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2000,2001.                |
+| Portions created by Lukas Gebauer are Copyright (c)2000-2003.                |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -94,31 +94,48 @@ const
   QTYPE_NAPTR = 35; // RFC-2168
   QTYPE_KX = 36;
 
-  QTYPE_AXFR = 252; //
+  QTYPE_AXFR = 252;
   QTYPE_MAILB = 253; //
   QTYPE_MAILA = 254; //
-  QTYPE_ALL = 255; //
+  QTYPE_ALL = 255;
 
 type
   TDNSSend = class(TSynaClient)
   private
+    FID: Word;
     FRCode: Integer;
     FBuffer: string;
     FSock: TUDPBlockSocket;
+    FTCPSock: TTCPBlockSocket;
+    FUseTCP: Boolean;
+    FAnsferInfo: TStringList;
+    FNameserverInfo: TStringList;
+    FAdditionalInfo: TStringList;
+    FAuthoritative: Boolean;
     function CompressName(const Value: string): string;
     function CodeHeader: string;
     function CodeQuery(const Name: string; QType: Integer): string;
     function DecodeLabels(var From: Integer): string;
-    function DecodeResource(var i: Integer; const Name: string;
+    function DecodeString(var From: Integer): string;
+    function DecodeResource(var i: Integer; const Info: TStringList;
       QType: Integer): string;
+    function RecvTCPResponse(const WorkSock: TBlockSocket): string;
+    function DecodeResponse(const Buf: string; const Reply: TStrings;
+      QType: Integer):boolean;
   public
     constructor Create;
     destructor Destroy; override;
     function DNSQuery(Name: string; QType: Integer;
       const Reply: TStrings): Boolean;
   published
-    property RCode: Integer read FRCode;
     property Sock: TUDPBlockSocket read FSock;
+    property TCPSock: TTCPBlockSocket read FTCPSock;
+    property UseTCP: Boolean read FUseTCP Write FUseTCP;
+    property RCode: Integer read FRCode;
+    property Authoritative: Boolean read FAuthoritative;
+    property AnsferInfo: TStringList read FAnsferInfo;
+    property NameserverInfo: TStringList read FNameserverInfo;
+    property AdditionalInfo: TStringList read FAdditionalInfo;
   end;
 
 function GetMailServers(const DNSHost, Domain: string;
@@ -130,13 +147,22 @@ constructor TDNSSend.Create;
 begin
   inherited Create;
   FSock := TUDPBlockSocket.Create;
-  FSock.CreateSocket;
+  FTCPSock := TTCPBlockSocket.Create;
-  FTimeout := 5000;
+  FUseTCP := False;
+  FTimeout := 10000;
   FTargetPort := cDnsProtocol;
+  FAnsferInfo := TStringList.Create;
+  FNameserverInfo := TStringList.Create;
+  FAdditionalInfo := TStringList.Create;
+  Randomize;
 end;
 
 destructor TDNSSend.Destroy;
 begin
+  FAnsferInfo.Free;
+  FNameserverInfo.Free;
+  FAdditionalInfo.Free;
+  FTCPSock.Free;
   FSock.Free;
   inherited Destroy;
 end;
@@ -168,8 +194,8 @@ end;
 
 function TDNSSend.CodeHeader: string;
 begin
-  Randomize;
+  FID := Random(32767);
-  Result := CodeInt(Random(32767)); // ID
+  Result := CodeInt(FID); // ID
   Result := Result + CodeInt($0100); // flags
   Result := Result + CodeInt(1); // QDCount
   Result := Result + CodeInt(0); // ANCount
@@ -184,6 +210,16 @@ begin
   Result := Result + CodeInt(1); // Type INTERNET
 end;
 
+function TDNSSend.DecodeString(var From: Integer): string;
+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): string;
 var
   l, f: Integer;
@@ -191,6 +227,8 @@ begin
   Result := '';
   while True do
   begin
+    if From >= Length(FBuffer) then
+      Break;
     l := Ord(FBuffer[From]);
     Inc(From);
     if l = 0 then
@@ -213,88 +251,112 @@ begin
   end;
 end;
 
-function TDNSSend.DecodeResource(var i: Integer; const Name: string;
+function TDNSSend.DecodeResource(var i: Integer; const Info: TStringList;
   QType: Integer): string;
 var
   Rname: string;
   RType, Len, j, x, n: Integer;
+  R: string;
+  t1, t2, ttl: integer;
 begin
   Result := '';
+  R := '';
   Rname := DecodeLabels(i);
   RType := DecodeInt(FBuffer, i);
-  Inc(i, 8);
+  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 (Name = Rname) and (QType = RType) then
+  case RType of
-  begin
+    QTYPE_A:
-    case RType of
+      begin
-      QTYPE_A:
+        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_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
-          Result := IntToStr(Ord(FBuffer[j]));
+          x := DecodeInt(FBuffer, j) * 65536 + DecodeInt(FBuffer, j + 2);
-          Inc(j);
+          Inc(j, 4);
-          Result := Result + '.' + IntToStr(Ord(FBuffer[j]));
+          R := R + ',' + IntToStr(x);
-          Inc(j);
-          Result := Result + '.' + IntToStr(Ord(FBuffer[j]));
-          Inc(j);
-          Result := Result + '.' + IntToStr(Ord(FBuffer[j]));
         end;
-      QTYPE_NS, QTYPE_MD, QTYPE_MF, QTYPE_CNAME, QTYPE_MB,
+      end;
-        QTYPE_MG, QTYPE_MR, QTYPE_PTR, QTYPE_X25, QTYPE_NSAP,
+    QTYPE_NULL:
-        QTYPE_NSAPPTR:
+      begin
-        Result := DecodeLabels(j);
+      end;
-      QTYPE_SOA:
+    QTYPE_WKS:
-        begin
+      begin
-          Result := DecodeLabels(j);
+      end;
-          Result := Result + ',' + DecodeLabels(j);
+    QTYPE_HINFO:
-          for n := 1 to 5 do
+      begin
-          begin
+        R := DecodeString(j);
-            x := DecodeInt(FBuffer, j) * 65536 + DecodeInt(FBuffer, j + 2);
+        R := R + ',' + DecodeString(j);
-            Inc(j, 4);
+      end;
-            Result := Result + ',' + IntToStr(x);
+    QTYPE_MINFO, QTYPE_RP, QTYPE_ISDN:
-          end;
+      begin
-        end;
+        R := DecodeLabels(j);
-      QTYPE_NULL:
+        R := R + ',' + DecodeLabels(j);
-        begin
+      end;
-        end;
+    QTYPE_MX, QTYPE_AFSDB, QTYPE_RT, QTYPE_KX:
-      QTYPE_WKS:
+      begin
-        begin
+        x := DecodeInt(FBuffer, j);
-        end;
+        Inc(j, 2);
-      QTYPE_HINFO, QTYPE_MINFO, QTYPE_RP, QTYPE_ISDN:
+        R := IntToStr(x);
-        begin
+        R := R + ',' + DecodeLabels(j);
-          Result := DecodeLabels(j);
+      end;
-          Result := Result + ',' + DecodeLabels(j);
+    QTYPE_TXT:
-        end;
+      R := DecodeString(j);
-      QTYPE_MX, QTYPE_AFSDB, QTYPE_RT, QTYPE_KX:
+    QTYPE_GPOS:
-        begin
+      begin
-          x := DecodeInt(FBuffer, j);
+        R := DecodeLabels(j);
-          Inc(j, 2);
+        R := R + ',' + DecodeLabels(j);
-          Result := IntToStr(x);
+        R := R + ',' + DecodeLabels(j);
-          Result := Result + ',' + DecodeLabels(j);
+      end;
-        end;
+    QTYPE_PX:
-      QTYPE_TXT:
+      begin
-        Result := DecodeLabels(j);
+        x := DecodeInt(FBuffer, j);
-      QTYPE_GPOS:
+        Inc(j, 2);
-        begin
+        R := IntToStr(x);
-          Result := DecodeLabels(j);
+        R := R + ',' + DecodeLabels(j);
-          Result := Result + ',' + DecodeLabels(j);
+        R := R + ',' + DecodeLabels(j);
-          Result := Result + ',' + DecodeLabels(j);
+      end;
-        end;
-      QTYPE_PX:
-        begin
-          x := DecodeInt(FBuffer, j);
-          Inc(j, 2);
-          Result := IntToStr(x);
-          Result := Result + ',' + DecodeLabels(j);
-          Result := Result + ',' + DecodeLabels(j);
-        end;
-    end;
   end;
+  if R <> '' then
+    Info.Add(RName + ',' + IntToStr(RType) + ',' + IntToStr(ttl) + ',' + R);
+  if QType = RType then
+    Result := R;
 end;
 
-function TDNSSend.DNSQuery(Name: string; QType: Integer;
+function TDNSSend.RecvTCPResponse(const WorkSock: TBlockSocket): string;
-  const Reply: TStrings): Boolean;
+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: string; const Reply: TStrings;
+  QType: Integer):boolean;
 var
   n, i: Integer;
   flag, qdcount, ancount, nscount, arcount: Integer;
@@ -302,43 +364,100 @@ var
 begin
   Result := False;
   Reply.Clear;
-  if IsIP(Name) then
+  FAnsferInfo.Clear;
-    Name := ReverseIP(Name) + '.in-addr.arpa';
+  FNameserverInfo.Clear;
-  FBuffer := CodeHeader + CodeQuery(Name, QType);
+  FAdditionalInfo.Clear;
-  FSock.Bind(FIPInterface, cAnyPort);
+  FAuthoritative := False;
-  FSock.Connect(FTargetHost, FTargetPort);
+  if (Length(Buf) > 13) and (FID = DecodeInt(Buf, 1)) then
-  FSock.SendString(FBuffer);
-  FBuffer := FSock.RecvPacket(FTimeout);
-  if (FSock.LastError = 0) and (Length(FBuffer) > 13) then
   begin
-    flag := DecodeInt(FBuffer, 3);
+    flag := DecodeInt(Buf, 3);
     FRCode := Flag and $000F;
+    FAuthoritative := (Flag and $0400) > 0;
     if FRCode = 0 then
     begin
-      qdcount := DecodeInt(FBuffer, 5);
+      qdcount := DecodeInt(Buf, 5);
-      ancount := DecodeInt(FBuffer, 7);
+      ancount := DecodeInt(Buf, 7);
-      nscount := DecodeInt(FBuffer, 9);
+      nscount := DecodeInt(Buf, 9);
-      arcount := DecodeInt(FBuffer, 11);
+      arcount := DecodeInt(Buf, 11);
       i := 13; //begin of body
-      if qdcount > 0 then //skip questions
+      if (qdcount > 0) and (Length(Buf) > i) then //skip questions
         for n := 1 to qdcount do
         begin
-          while (FBuffer[i] <> #0) and ((Ord(FBuffer[i]) and $C0) <> $C0) do
+          while (Buf[i] <> #0) and ((Ord(Buf[i]) and $C0) <> $C0) do
             Inc(i);
           Inc(i, 5);
         end;
-      if ancount > 0 then
+      if (ancount > 0) and (Length(Buf) > i) then // decode reply
         for n := 1 to ancount do
         begin
-          s := DecodeResource(i, Name, QType);
+          s := DecodeResource(i, FAnsferInfo, 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);
       Result := True;
     end;
   end;
 end;
 
+function TDNSSend.DNSQuery(Name: string; 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';
+  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 (AnsferInfo.Count > 0) then  //find end of transfer
+          b := b and (t[0] <> AnsferInfo[AnsferInfo.count - 1]);
+        if b then
+        begin
+          t.AddStrings(AnsferInfo);
+          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: string;

ftpsend.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 002.003.001 |
+| Project : Delphree - Synapse                                   | 002.005.004 |
 |==============================================================================|
 | Content: FTP client                                                          |
 |==============================================================================|
-| Copyright (c)1999-2002, Lukas Gebauer                                        |
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c) 1999-2002.               |
+| Portions created by Lukas Gebauer are Copyright (c) 1999-2003.               |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -112,6 +112,10 @@ type
     FPassiveMode: Boolean;
     FForceDefaultPort: Boolean;
     FFtpList: TFTPList;
+    FBinaryMode: Boolean;
+    FAutoTLS: Boolean;
+    FIsTLS: Boolean;
+    FFullSSL: Boolean;
     function Auth(Mode: integer): Boolean;
     function Connect: Boolean;
     function InternalStor(const Command: string; RestoreAt: integer): Boolean;
@@ -169,6 +173,10 @@ type
     property ForceDefaultPort: Boolean read FForceDefaultPort Write FForceDefaultPort;
     property OnStatus: TFTPStatus read FOnStatus write FOnStatus;
     property FtpList: TFTPList read FFtpList;
+    property BinaryMode: Boolean read FBinaryMode Write FBinaryMode;
+    property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
+    property FullSSL: Boolean read FFullSSL Write FFullSSL;
+    property IsTLS: Boolean read FIsTLS;
   end;
 
 function FtpGetFile(const IP, Port, FileName, LocalFile,
@@ -181,15 +189,13 @@ function FtpInterServerTransfer(
 
 implementation
 
-const
-  CRLF = #13#10;
-
 constructor TFTPSend.Create;
 begin
   inherited Create;
   FFullResult := TStringList.Create;
   FDataStream := TMemoryStream.Create;
   FSock := TTCPBlockSocket.Create;
+  FSock.ConvertLineEnd := True;
   FDSock := TTCPBlockSocket.Create;
   FFtpList := TFTPList.Create;
   FTimeout := 300000;
@@ -205,6 +211,10 @@ begin
   FFWUsername := '';
   FFWPassword := '';
   FFWMode := 0;
+  FBinaryMode := True;
+  FAutoTLS := False;
+  FFullSSL := False;
+  FIsTLS := False;
 end;
 
 destructor TFTPSend.Destroy;
@@ -256,38 +266,114 @@ end;
 // based on idea by Petr Esner <petr.esner@atlas.cz>
 function TFTPSend.Auth(Mode: integer): Boolean;
 const
-  // Direct connection USER[+PASS[+ACCT]]
+  //if not USER <username> then
+  //  if not PASS <password> then
+  //    if not ACCT <account> then ERROR!
+  //OK!
   Action0: TLogonActions =
-    (0, FTP_OK, 3, 1, FTP_OK, 6, 2, FTP_OK, FTP_ERR, 0, 0, 0, 0, 0, 0, 0, 0, 0);
+    (0, FTP_OK, 3,
-  // SITE <hostname>
+     1, FTP_OK, 6,
+     2, FTP_OK, FTP_ERR,
+     0, 0, 0, 0, 0, 0, 0, 0, 0);
+
+  //if not USER <FWusername> then
+  //  if not PASS <FWPassword> then ERROR!
+  //if SITE <FTPServer> then ERROR!
+  //if not USER <username> then
+  //  if not PASS <password> then
+  //    if not ACCT <account> then ERROR!
+  //OK!
   Action1: TLogonActions =
-    (3, 6, 3, 4, 6, FTP_ERR, 5, FTP_ERR, 9, 0, FTP_OK, 12, 1, FTP_OK, 15, 2,
+    (3, 6, 3,
-    FTP_OK, FTP_ERR);
+     4, 6, FTP_ERR,
-  // USER after logon
+     5, FTP_ERR, 9,
+     0, FTP_OK, 12,
+     1, FTP_OK, 15,
+     2, FTP_OK, FTP_ERR);
+
+  //if not USER <FWusername> then
+  //  if not PASS <FWPassword> then ERROR!
+  //if USER <UserName>'@'<FTPServer> then OK!
+  //if not PASS <password> then
+  //  if not ACCT <account> then ERROR!
+  //OK!
   Action2: TLogonActions =
-    (3, 6, 3, 4, 6, FTP_ERR, 6, FTP_OK, 9, 1, FTP_OK, 12, 2, FTP_OK, FTP_ERR,
+    (3, 6, 3,
+     4, 6, FTP_ERR,
+     6, FTP_OK, 9,
+     1, FTP_OK, 12,
+     2, FTP_OK, FTP_ERR,
      0, 0, 0);
-  // Transparent
+
+  //if not USER <FWusername> then
+  //  if not PASS <FWPassword> then ERROR!
+  //if not USER <username> then
+  //  if not PASS <password> then
+  //    if not ACCT <account> then ERROR!
+  //OK!
   Action3: TLogonActions =
-    (3, 6, 3, 4, 6, FTP_ERR, 0, FTP_OK, 9, 1, FTP_OK, 12, 2, FTP_OK, FTP_ERR,
+    (3, 6, 3,
+     4, 6, FTP_ERR,
+     0, FTP_OK, 9,
+     1, FTP_OK, 12,
+     2, FTP_OK, FTP_ERR,
      0, 0, 0);
-  // proxy OPEN
+
+  //OPEN <FTPserver>
+  //if not USER <username> then
+  //  if not PASS <password> then
+  //    if not ACCT <account> then ERROR!
+  //OK!
   Action4: TLogonActions =
-    (7, 3, 3, 0, FTP_OK, 6, 1, FTP_OK, 9, 2, FTP_OK, FTP_ERR,
+    (7, 3, 3,
+     0, FTP_OK, 6,
+     1, FTP_OK, 9,
+     2, FTP_OK, FTP_ERR,
      0, 0, 0, 0, 0, 0);
-  // USER with no logon
+
+  //if USER <UserName>'@'<FTPServer> then OK!
+  //if not PASS <password> then
+  //  if not ACCT <account> then ERROR!
+  //OK!
   Action5: TLogonActions =
-    (6, FTP_OK, 3, 1, FTP_OK, 6, 2, FTP_OK, FTP_ERR, 0, 0, 0, 0, 0, 0, 0, 0, 0);
+    (6, FTP_OK, 3,
-  // USER fireID@remotehost
+     1, FTP_OK, 6,
+     2, FTP_OK, FTP_ERR,
+     0, 0, 0, 0, 0, 0, 0, 0, 0);
+
+  //if not USER <FWUserName>@<FTPServer> then
+  //  if not PASS <FWPassword> then ERROR!
+  //if not USER <username> then
+  //  if not PASS <password> then
+  //    if not ACCT <account> then ERROR!
+  //OK!
   Action6: TLogonActions =
-    (8, 6, 3, 4, 6, FTP_ERR, 0, FTP_OK, 9, 1, FTP_OK, 12, 2, FTP_OK, FTP_ERR,
+    (8, 6, 3,
+     4, 6, FTP_ERR,
+     0, FTP_OK, 9,
+     1, FTP_OK, 12,
+     2, FTP_OK, FTP_ERR,
      0, 0, 0);
-  // USER remoteID@remotehost fireID
+
+  //if USER <UserName>@<FTPServer> <FWUserName> then ERROR!
+  //if not PASS <password> then
+  //  if not ACCT <account> then ERROR!
+  //OK!
   Action7: TLogonActions =
-    (9, FTP_ERR, 3, 1, FTP_OK, 6, 2, FTP_OK, FTP_ERR, 0, 0, 0, 0, 0, 0, 0, 0, 0);
+    (9, FTP_ERR, 3,
-  // USER remoteID@fireID@remotehost
+     1, FTP_OK, 6,
+     2, FTP_OK, FTP_ERR,
+     0, 0, 0, 0, 0, 0, 0, 0, 0);
+
+  //if not USER <UserName>@<FWUserName>@<FTPServer> then
+  //  if not PASS <Password>@<FWPassword> then
+  //    if not ACCT <account> then ERROR!
+  //OK!
   Action8: TLogonActions =
-    (10, FTP_OK, 3, 11, FTP_OK, 6, 2, FTP_OK, FTP_ERR, 0, 0, 0, 0, 0, 0, 0, 0, 0);
+    (10, FTP_OK, 3,
+     11, FTP_OK, 6,
+     2, FTP_OK, FTP_ERR,
+     0, 0, 0, 0, 0, 0, 0, 0, 0);
 var
   FTPServer: string;
   LogonActions: TLogonActions;
@@ -362,6 +448,8 @@ function TFTPSend.Connect: Boolean;
 begin
   FSock.CloseSocket;
   FSock.CreateSocket;
+  if FFullSSL then
+    FSock.SSLEnabled := True;
   FSock.Bind(FIPInterface, cAnyPort);
   if FFWHost = '' then
     FSock.Connect(FTargetHost, FTargetPort)
@@ -376,10 +464,22 @@ begin
   FCanResume := False;
   if not Connect then
     Exit;
+  FIsTLS := FFullSSL;
   if (ReadResult div 100) <> 2 then
     Exit;
+  if FAutoTLS and not(FIsTLS) then
+    if (FTPCommand('AUTH TLS') div 100) = 2 then
+    begin
+      FSock.SSLDoConnect;
+      FIsTLS := True;
+    end;
   if not Auth(FFWMode) then
     Exit;
+  if FIsTLS then
+  begin
+    FTPCommand('PROT P');
+    FTPCommand('PBSZ 0');
+  end;
   FTPCommand('TYPE I');
   FTPCommand('STRU F');
   FTPCommand('MODE S');
@@ -458,12 +558,13 @@ begin
       FSock.Bind(FIPInterface, s);
     if FDSock.LastError <> 0 then
       Exit;
+    FDSock.SetLinger(True, 10);
     FDSock.Listen;
     FDSock.GetSins;
     FDataIP := FDSock.GetLocalSinIP;
     FDataIP := FDSock.ResolveName(FDataIP);
     FDataPort := IntToStr(FDSock.GetLocalSinPort);
-    s := StringReplace(FDataIP, '.', ',');
+    s := ReplaceString(FDataIP, '.', ',');
     s := 'PORT ' + s + ',' + IntToStr(FDSock.GetLocalSinPort div 256)
       + ',' + IntToStr(FDSock.GetLocalSinPort mod 256);
     Result := (FTPCommand(s) div 100) = 2;
@@ -488,6 +589,8 @@ begin
       Result := True;
     end;
   end;
+  if FIsTLS then
+    FDSock.SSLDoConnect;
 end;
 
 function TFTPSend.DataRead(const DestStream: TStream): Boolean;
@@ -604,7 +707,10 @@ begin
   try
     if not DataSocket then
       Exit;
-    FTPCommand('TYPE I');
+    if FBinaryMode then
+      FTPCommand('TYPE I')
+    else
+      FTPCommand('TYPE A');
     if Restore then
     begin
       RetrStream.Seek(0, soFromEnd);
@@ -642,7 +748,10 @@ begin
   try
     if not DataSocket then
       Exit;
-    FTPCommand('TYPE I');
+    if FBinaryMode then
+      FTPCommand('TYPE I')
+    else
+      FTPCommand('TYPE A');
     StorSize := SendStream.Size;
     if not FCanResume then
       RestoreAt := 0;
@@ -759,6 +868,11 @@ begin
   end;
 end;
 
+procedure TFTPSend.Abort;
+begin
+  FDSock.CloseSocket;
+end;
+
 {==============================================================================}
 
 constructor TFTPList.Create;
@@ -965,11 +1079,11 @@ begin
       else
       begin
         flr.Readable := true;
-        flr.Filesize := StrToIntDef(s, 0);
+        flr.FileSize := StrToIntDef(s, 0);
       end;
       if Value = '' then
         Exit;
-      flr.FileName := Trim(s);
+      flr.FileName := Trim(Value);
       Result := True;
       Exit;
     end;
@@ -1103,27 +1217,27 @@ begin
       Exit;
     if not ToFTP.Login then
       Exit;
-    if FromFTP.FTPCommand('PASV') <> 227 then
+    if (FromFTP.FTPCommand('PASV') div 100) <> 2 then
       Exit;
     FromFTP.ParseRemote(FromFTP.ResultString);
-    s := StringReplace(FromFTP.DataIP, '.', ',');
+    s := ReplaceString(FromFTP.DataIP, '.', ',');
     s := 'PORT ' + s + ',' + IntToStr(StrToIntDef(FromFTP.DataPort, 0) div 256)
       + ',' + IntToStr(StrToIntDef(FromFTP.DataPort, 0) mod 256);
-    if ToFTP.FTPCommand(s) <> 200 then
+    if (ToFTP.FTPCommand(s) div 100) <> 2 then
       Exit;
-    x := FromFTP.FTPCommand('STOR ' + FromFile);
+    x := ToFTP.FTPCommand('RETR ' + FromFile);
-    if (x <> 125) and (x <> 150) then
+    if (x div 100) <> 1 then
       Exit;
-    x := ToFTP.FTPCommand('RETR ' + ToFile);
+    x := FromFTP.FTPCommand('STOR ' + ToFile);
-    if (x <> 125) and (x <> 150) then
+    if (x div 100) <> 1 then
       Exit;
     FromFTP.Timeout := 21600000;
     x := FromFTP.ReadResult;
-    if (x <> 226) and (x <> 250) then
+    if (x  div 100) <> 2 then
       Exit;
     ToFTP.Timeout := 21600000;
     x := ToFTP.ReadResult;
-    if (x <> 226) and (x <> 250) then
+    if (x div 100) <> 2 then
       Exit;
     Result := True;
   finally
@@ -1132,9 +1246,4 @@ begin
   end;
 end;
 
-procedure TFTPSend.Abort;
-begin
-  FDSock.CloseSocket;
-end;
-
 end.

httpsend.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 003.002.000 |
+| Project : Delphree - Synapse                                   | 003.004.004 |
 |==============================================================================|
 | Content: HTTP client                                                         |
 |==============================================================================|
-| Copyright (c)1999-2002, Lukas Gebauer                                        |
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c) 1999-2002.               |
+| Portions created by Lukas Gebauer are Copyright (c) 1999-2003.               |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -75,18 +75,29 @@ type
     FProxyPass: string;
     FResultCode: Integer;
     FResultString: string;
+    FUserAgent: string;
+    FCookies: TStringList;
+    FDownloadSize: integer;
+    FUploadSize: integer;
+    FRangeStart: integer;
+    FRangeEnd: integer;
     function ReadUnknown: Boolean;
     function ReadIdentity(Size: Integer): Boolean;
     function ReadChunked: Boolean;
+    procedure ParseCookies;
   public
     constructor Create;
     destructor Destroy; override;
     procedure Clear;
     procedure DecodeStatus(const Value: string);
     function HTTPMethod(const Method, URL: string): Boolean;
+    procedure Abort;
   published
-    property Headers: TStringList read FHeaders Write FHeaders;
+    property Headers: TStringList read FHeaders;
-    property Document: TMemoryStream read FDocument Write FDocument;
+    property Cookies: TStringList read FCookies;
+    property Document: TMemoryStream read FDocument;
+    property RangeStart: integer read FRangeStart Write FRangeStart;
+    property RangeEnd: integer read FRangeEnd Write FRangeEnd;
     property MimeType: string read FMimeType Write FMimeType;
     property Protocol: string read FProtocol Write FProtocol;
     property KeepAlive: Boolean read FKeepAlive Write FKeepAlive;
@@ -94,8 +105,11 @@ type
     property ProxyPort: string read FProxyPort Write FProxyPort;
     property ProxyUser: string read FProxyUser Write FProxyUser;
     property ProxyPass: string read FProxyPass Write FProxyPass;
+    property UserAgent: string read FUserAgent Write FUserAgent;
     property ResultCode: Integer read FResultCode;
     property ResultString: string read FResultString;
+    property DownloadSize: integer read FDownloadSize;
+    property UploadSize: integer read FUploadSize;
     property Sock: TTCPBlockSocket read FSock;
   end;
 
@@ -108,18 +122,16 @@ function HttpPostFile(const URL, FieldName, FileName: string;
 
 implementation
 
-const
-  CRLF = #13#10;
-
 constructor THTTPSend.Create;
 begin
   inherited Create;
   FHeaders := TStringList.Create;
+  FCookies := TStringList.Create;
   FDocument := TMemoryStream.Create;
   FSock := TTCPBlockSocket.Create;
+  FSock.ConvertLineEnd := True;
   FSock.SizeRecvBuffer := 65536;
   FSock.SizeSendBuffer := 65536;
-  FSock.ConvertLineEnd := True;
   FTimeout := 300000;
   FTargetPort := cHttpProtocol;
   FProxyHost := '';
@@ -130,6 +142,9 @@ begin
   FAlivePort := '';
   FProtocol := '1.0';
   FKeepAlive := True;
+  FUserAgent := 'Mozilla/4.0 (compatible; Synapse)';
+  FDownloadSize := 0;
+  FUploadSize := 0;
   Clear;
 end;
 
@@ -137,12 +152,15 @@ 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';
@@ -170,11 +188,14 @@ var
   Prot, User, Pass, Host, Port, Path, Para, URI: string;
   s, su: string;
   HttpTunnel: Boolean;
+  n: integer;
 begin
   {initial values}
   Result := False;
   FResultCode := 500;
   FResultString := '';
+  FDownloadSize := 0;
+  FUploadSize := 0;
 
   URI := ParseURL(URL, Prot, User, Pass, Host, Port, Path, Para);
 
@@ -208,6 +229,15 @@ begin
     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 FRangeEnd > 0 then
+    FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-' + IntToStr(FRangeEnd));
+  { setting Cookies }
+  for n := 0 to FCookies.Count - 1 do
+    FHeaders.Insert(0, 'Cookie: ' + FCookies[n]);
   { setting KeepAlives }
   if not FKeepAlive then
     FHeaders.Insert(0, 'Connection: close');
@@ -309,6 +339,7 @@ begin
   { send document }
   if Sending then
   begin
+    FUploadSize := FDocument.Size;
     FSock.SendBuffer(FDocument.Memory, FDocument.Size);
     if FSock.LastError <> 0 then
       Exit;
@@ -382,15 +413,16 @@ begin
       TE_CHUNKED:
         ReadChunked;
     end;
+  Result := True;
 
   FDocument.Seek(0, soFromBeginning);
-  Result := True;
   if ToClose then
   begin
     FSock.CloseSocket;
     FAliveHost := '';
     FAlivePort := '';
   end;
+  ParseCookies;
 end;
 
 function THTTPSend.ReadUnknown: Boolean;
@@ -407,17 +439,13 @@ end;
 
 function THTTPSend.ReadIdentity(Size: Integer): Boolean;
 var
-  mem: TMemoryStream;
+  x: integer;
 begin
-  mem := TMemoryStream.Create;
+  FDownloadSize := Size;
-  try
+  FDocument.SetSize(FDocument.Position + Size);
-    mem.SetSize(Size);
+  x := FSock.RecvBufferEx(IncPoint(FDocument.Memory, FDocument.Position), Size, FTimeout);
-    FSock.RecvBufferEx(mem.Memory, Size, FTimeout);
+  FDocument.SetSize(FDocument.Position + x);
-    Result := FSock.LastError = 0;
+  Result := FSock.LastError = 0;
-    FDocument.CopyFrom(mem, 0);
-  finally
-    mem.Free;
-  end;
 end;
 
 function THTTPSend.ReadChunked: Boolean;
@@ -440,6 +468,28 @@ begin
   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.CloseSocket;
+end;
+
 {==============================================================================}
 
 function HttpGetText(const URL: string; const Response: TStrings): Boolean;
@@ -502,8 +552,6 @@ end;
 
 function HttpPostFile(const URL, FieldName, FileName: string;
   const Data: TStream; const ResultData: TStrings): Boolean;
-const
-  CRLF = #$0D + #$0A;
 var
   HTTP: THTTPSend;
   Bound, s: string;
@@ -519,7 +567,7 @@ begin
     HTTP.Document.CopyFrom(Data, 0);
     s := CRLF + '--' + Bound + '--' + CRLF;
     HTTP.Document.Write(Pointer(s)^, Length(s));
-    HTTP.MimeType := 'multipart/form-data, boundary=' + Bound;
+    HTTP.MimeType := 'multipart/form-data; boundary=' + Bound;
     Result := HTTP.HTTPMethod('POST', URL);
     ResultData.LoadFromStream(HTTP.Document);
   finally

imapsend.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 002.001.000 |
+| Project : Delphree - Synapse                                   | 002.002.002 |
 |==============================================================================|
 | Content: IMAP4rev1 client                                                    |
 |==============================================================================|
-| Copyright (c)1999-2002, Lukas Gebauer                                        |
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2001-2002.                |
+| Portions created by Lukas Gebauer are Copyright (c)2001-2003.                |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -115,6 +115,7 @@ type
     function SetFlagsMess(MessID: integer; Flags: string): Boolean;
     function GetFlagsMess(MessID: integer; var Flags: string): Boolean;
     function StartTLS: Boolean;
+    function GetUID(MessID: integer; var UID : Integer): Boolean;
     function FindCap(const Value: string): string;
   published
     property ResultString: string read FResultString;
@@ -135,19 +136,16 @@ type
 
 implementation
 
-const
-  CRLF = #13#10;
-
 constructor TIMAPSend.Create;
 begin
   inherited Create;
   FFullResult := TStringList.Create;
   FIMAPcap := TStringList.Create;
   FSock := TTCPBlockSocket.Create;
+  FSock.ConvertLineEnd := True;
   FSock.CreateSocket;
   FSock.SizeRecvBuffer := 32768;
   FSock.SizeSendBuffer := 32768;
-  FSock.ConvertLineEnd := True;
   FTimeout := 300000;
   FTargetPort := cIMAPProtocol;
   FUsername := '';
@@ -196,9 +194,7 @@ begin
       l := StrToIntDef(s, -1);
       if l <> -1 then
       begin
-        setlength(s, l);
+        s := FSock.RecvBufferStr(l, FTimeout);
-        x := FSock.recvbufferex(PChar(s), l, FTimeout);
-        SetLength(s, x);
         FFullResult.Add(s);
       end;
     end;
@@ -220,7 +216,8 @@ var
 begin
   Inc(FTagCommand);
   l := Length(Data.Text);
-  FSock.SendString(IntToStr(FTagCommand) + ' ' + Value + ' {'+ IntToStr(l) + '}' + CRLF);
+  FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + ' {'+ IntToStr(l) + '}' + CRLF);
+  FSock.RecvString(FTimeout);
   FSock.SendString(Data.Text + CRLF);
   Result := ReadResult;
 end;
@@ -247,9 +244,18 @@ begin
   for n := 0 to FFullResult.Count - 1 do
   begin
     s := FFullResult[n];
-    x := RPos(' ', s);
+    if (s <> '') and (Pos('\NOSELECT', UpperCase(s)) = 0) then
-    if (x > 0) and (Pos('NOSELECT', UpperCase(s)) = 0) then
+    begin
-      Value.Add(Copy(s, x + 1, Length(s) - x));
+      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;
 
@@ -472,7 +478,7 @@ begin
     for n := 0 to FFullResult.Count - 1 do
     begin
       s := UpperCase(FFullResult[n]);
-      if (Pos('* STATUS ', s) = 1) and (Pos(Value, s) > 0 ) then
+      if (Pos(FolderName, s) >= 1) and (Pos(Value, s) > 0 ) then
       begin
         t := SeparateRight(s, Value);
         t := SeparateLeft(t, ')');
@@ -598,7 +604,7 @@ begin
   for n := 0 to FFullResult.Count - 1 do
   begin
     s := uppercase(FFullResult[n]);
-    if Pos('* FETCH (FLAGS', s) = 1 then
+    if (Pos('* ', s) = 1) and (Pos('FLAGS', s) > 0 ) then
     begin
       s := SeparateRight(s, 'FLAGS');
       s := Separateright(s, '(');
@@ -620,6 +626,27 @@ begin
   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';
+  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 := SeparateLeft(s, ')');
+    end;
+  end;
+  UID := StrToIntDef(sUID, 0);
+end;
+
 {==============================================================================}
 
 end.

mimeinln.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 001.000.003 |
+| Project : Delphree - Synapse                                   | 001.000.005 |
 |==============================================================================|
 | Content: Inline MIME support procedures and functions                        |
 |==============================================================================|
-| Copyright (c)1999-2002, Lukas Gebauer                                        |
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2000,2001.                |
+| Portions created by Lukas Gebauer are Copyright (c)2000-2003.                |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -64,7 +64,7 @@ implementation
 
 function InlineDecode(const Value: string; CP: TMimeChar): string;
 var
-  s, su: string;
+  s, su, v: string;
   x, y, z, n: Integer;
   ichar: TMimeChar;
   c: Char;
@@ -88,12 +88,17 @@ var
   end;
 
 begin
-  Result := Value;
+  Result := '';
-  x := Pos('=?', Result);
+  v := Value;
-  y := SearchEndInline(Result, x);
+  x := Pos('=?', v);
-  while (y > x) and (x > 0) do  //fix by Marcus Moennig (minibbjd@gmx.de)
+  y := SearchEndInline(v, x);
+  while (y > x) and (x > 0) do
   begin
-    s := Copy(Result, x, y - x + 2);
+    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);
     ichar := GetCPFromID(su);
     z := Pos('?', su);
@@ -118,11 +123,11 @@ begin
         s := CharsetConversion(s, ichar, CP);
       end;
     end;
-    Result := Copy(Result, 1, x - 1) + s +
+    Result := Result + s;
-      Copy(Result, y + 2, Length(Result) - y - 1);
+    x := Pos('=?', v);
-    x := Pos('=?', Result);
+    y := SearchEndInline(v, x);
-    y := SearchEndInline(Result, x);
   end;
+  Result := Result + v;
 end;
 
 {==============================================================================}

mimemess.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 002.001.001 |
+| Project : Delphree - Synapse                                   | 002.001.002 |
 |==============================================================================|
 | Content: MIME message object                                                 |
 |==============================================================================|
-| Copyright (c)1999-2002, Lukas Gebauer                                        |
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2000-2002.                |
+| Portions created by Lukas Gebauer are Copyright (c)2000-2003.                |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -154,9 +154,9 @@ begin
     if FCustomHeaders[n] <> '' then
       Value.Insert(0, FCustomHeaders[n]);
   if FXMailer = '' then
-    Value.Insert(0, 'x-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer')
+    Value.Insert(0, 'X-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer')
   else
-    Value.Insert(0, 'x-mailer: ' + FXMailer);
+    Value.Insert(0, 'X-mailer: ' + FXMailer);
   Value.Insert(0, 'MIME-Version: 1.0 (produced by Synapse)');
   if FOrganization <> '' then
     Value.Insert(0, 'Organization: ' + InlineCode(FOrganization));

mimepart.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 002.001.002 |
+| Project : Delphree - Synapse                                   | 002.003.002 |
 |==============================================================================|
 | Content: MIME support procedures and functions                               |
 |==============================================================================|
-| Copyright (c)1999-2002, Lukas Gebauer                                        |
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2000-2002.                |
+| Portions created by Lukas Gebauer are Copyright (c)2000-2003.                |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -95,6 +95,8 @@ type
   public
     constructor Create;
     destructor Destroy; override;
+    procedure Assign(Value: TMimePart);
+    procedure AssignSubParts(Value: TMimePart);
     procedure Clear;
     procedure DecodePart;
     procedure DecodePartHeader;
@@ -103,6 +105,7 @@ type
     procedure MimeTypeFromExt(Value: string);
     function GetSubPartCount: integer;
     function GetSubPart(index: integer): TMimePart;
+    procedure DeleteSubPart(index: integer);
     procedure ClearSubParts;
     function AddSubPart: TMimePart;
     procedure DecomposeParts;
@@ -255,6 +258,47 @@ end;
 
 {==============================================================================}
 
+procedure TMIMEPart.Assign(Value: TMimePart);
+begin
+  Primary := Value.Primary;
+  Encoding := Value.Encoding;
+  Charset := Value.Charset;
+  DefaultCharset := Value.DefaultCharset;
+  PrimaryCode := Value.PrimaryCode;
+  EncodingCode := Value.EncodingCode;
+  CharsetCode := Value.CharsetCode;
+  TargetCharset := Value.TargetCharset;
+  Secondary := Value.Secondary;
+  Description := Value.Description;
+  Disposition := Value.Disposition;
+  ContentID := Value.ContentID;
+  Boundary := Value.Boundary;
+  FileName := Value.FileName;
+  Lines.Assign(Value.Lines);
+  PartBody.Assign(Value.PartBody);
+  Headers.Assign(Value.Headers);
+  PrePart.Assign(Value.PrePart);
+  PostPart.Assign(Value.PostPart);
+  MaxLineLength := Value.MaxLineLength;
+end;
+
+{==============================================================================}
+
+procedure TMIMEPart.AssignSubParts(Value: TMimePart);
+var
+  n: integer;
+  p: TMimePart;
+begin
+  Assign(Value);
+  for n := 0 to Value.GetSubPartCount - 1 do
+  begin
+    p := AddSubPart;
+    p.AssignSubParts(Value.GetSubPart(n));
+  end;
+end;
+
+{==============================================================================}
+
 function TMIMEPart.GetSubPartCount: integer;
 begin
   Result :=  FSubParts.Count;
@@ -271,6 +315,17 @@ end;
 
 {==============================================================================}
 
+procedure TMIMEPart.DeleteSubPart(index: integer);
+begin
+  if Index < GetSubPartCount then
+  begin
+    GetSubPart(Index).Free;
+    FSubParts.Delete(Index);
+  end;
+end;
+
+{==============================================================================}
+
 procedure TMIMEPart.ClearSubParts;
 var
   n: integer;
@@ -342,7 +397,7 @@ begin
       Mime := AddSubPart;
       while FLines.Count > x do
       begin
-        s := TrimRight(FLines[x]);
+        s := FLines[x];
         Inc(x);
         if Pos('--' + FBoundary, s) = 1 then
           Break;
@@ -702,7 +757,7 @@ begin
   begin
     s := '';
     if FFileName <> '' then
-      s := '; FileName="' + FFileName + '"';
+      s := '; FileName="' + InlineCode(FFileName) + '"';
     FHeaders.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s);
   end;
   if FContentID <> '' then

nntpsend.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 001.001.000 |
+| Project : Delphree - Synapse                                   | 001.002.003 |
 |==============================================================================|
 | Content: NNTP client                                                         |
 |==============================================================================|
-| Copyright (c)1999-2002, Lukas Gebauer                                        |
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c) 1999,2000,2001.          |
+| Portions created by Lukas Gebauer are Copyright (c) 1999-2003.               |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -62,6 +62,9 @@ type
     FResultCode: Integer;
     FResultString: string;
     FData: TStringList;
+    FDataToSend: TStringList;
+    FUsername: string;
+    FPassword: string;
     function ReadResult: Integer;
     function ReadData: boolean;
     function SendData: boolean;
@@ -71,6 +74,9 @@ type
     destructor Destroy; override;
     function Login: Boolean;
     procedure Logout;
+    function DoCommand(const Command: string): boolean;
+    function DoCommandRead(const Command: string): boolean;
+    function DoCommandWrite(const Command: string): boolean;
     function GetArticle(const Value: string): Boolean;
     function GetBody(const Value: string): Boolean;
     function GetHead(const Value: string): Boolean;
@@ -84,7 +90,10 @@ type
     function NewArticles(const Group: string; Since: TDateTime): Boolean;
     function PostArticle: Boolean;
     function SwitchToSlave: Boolean;
+    function Xover(xoStart, xoEnd: string): boolean;
   published
+    property Username: string read FUsername write FUsername;
+    property Password: string read FPassword write FPassword;
     property ResultCode: Integer read FResultCode;
     property ResultString: string read FResultString;
     property Data: TStringList read FData;
@@ -93,23 +102,23 @@ type
 
 implementation
 
-const
-  CRLF = #13#10;
-
 constructor TNNTPSend.Create;
 begin
   inherited Create;
   FData := TStringList.Create;
+  FDataToSend := TStringList.Create;
   FSock := TTCPBlockSocket.Create;
-  FSock.CreateSocket;
   FSock.ConvertLineEnd := True;
   FTimeout := 300000;
   FTargetPort := cNNTPProtocol;
+  FUsername := '';
+  FPassword := '';
 end;
 
 destructor TNNTPSend.Destroy;
 begin
   FSock.Free;
+  FDataToSend.Free;
   FData.Free;
   inherited Destroy;
 end;
@@ -149,22 +158,26 @@ var
   s: string;
   n: integer;
 begin
-  for n := 0 to FData.Count -1 do
+  for n := 0 to FDataToSend.Count - 1 do
   begin
-    s := FData[n];
+    s := FDataToSend[n];
-    if (s <> '') and (s[1]='.') then
+    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.CreateSocket;
   FSock.Bind(FIPInterface, cAnyPort);
   FSock.Connect(FTargetHost, FTargetPort);
   Result := FSock.LastError = 0;
@@ -176,6 +189,15 @@ begin
   if not Connect then
     Exit;
   Result := (ReadResult div 100) = 2;
+  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;
 
 procedure TNNTPSend.Logout;
@@ -185,136 +207,132 @@ begin
   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
-  Result := False;
   s := 'ARTICLE';
   if Value <> '' then
     s := s + ' ' + Value;
-  FSock.SendString(s + CRLF);
+  Result := DoCommandRead(s);
-  if (ReadResult div 100) <> 2 then
-    Exit;
-  Result := ReadData;
 end;
 
 function TNNTPSend.GetBody(const Value: string): Boolean;
 var
   s: string;
 begin
-  Result := False;
   s := 'BODY';
   if Value <> '' then
     s := s + ' ' + Value;
-  FSock.SendString(s + CRLF);
+  Result := DoCommandRead(s);
-  if (ReadResult div 100) <> 2 then
-    Exit;
-  Result := ReadData;
 end;
 
 function TNNTPSend.GetHead(const Value: string): Boolean;
 var
   s: string;
 begin
-  Result := False;
   s := 'HEAD';
   if Value <> '' then
     s := s + ' ' + Value;
-  FSock.SendString(s + CRLF);
+  Result := DoCommandRead(s);
-  if (ReadResult div 100) <> 2 then
-    Exit;
-  Result := ReadData;
 end;
 
 function TNNTPSend.GetStat(const Value: string): Boolean;
 var
   s: string;
 begin
-  Result := False;
   s := 'STAT';
   if Value <> '' then
     s := s + ' ' + Value;
-  FSock.SendString(s + CRLF);
+  Result := DoCommandRead(s);
-  if (ReadResult div 100) <> 2 then
-    Exit;
-  Result := FSock.LastError = 0;
 end;
 
 function TNNTPSend.SelectGroup(const Value: string): Boolean;
 begin
-  FSock.SendString('GROUP ' + Value + CRLF);
+  Result := DoCommand('GROUP ' + Value);
-  Result := (ReadResult div 100) = 2;
 end;
 
 function TNNTPSend.IHave(const MessID: string): Boolean;
-var
-  x: integer;
 begin
-  FSock.SendString('IHAVE ' + MessID + CRLF);
+  Result := DoCommandWrite('IHAVE ' + MessID);
-  x := (ReadResult div 100);
-  if x = 3 then
-  begin
-    SendData;
-    x := (ReadResult div 100);
-  end;
-  Result := x = 2;
 end;
 
 function TNNTPSend.GotoLast: Boolean;
 begin
-  FSock.SendString('LAST' + CRLF);
+  Result := DoCommand('LAST');
-  Result := (ReadResult div 100) = 2;
 end;
 
 function TNNTPSend.GotoNext: Boolean;
 begin
-  FSock.SendString('NEXT' + CRLF);
+  Result := DoCommand('NEXT');
-  Result := (ReadResult div 100) = 2;
 end;
 
 function TNNTPSend.ListGroups: Boolean;
 begin
-  FSock.SendString('LIST' + CRLF);
+  Result := DoCommandRead('LIST');
-  Result := (ReadResult div 100) = 2;
-  if Result then
-    Result := ReadData;
 end;
 
 function TNNTPSend.ListNewGroups(Since: TDateTime): Boolean;
 begin
-  FSock.SendString('NEWGROUPS ' + SimpleDateTime(Since) + ' GMT' + CRLF);
+  Result := DoCommandRead('NEWGROUPS ' + SimpleDateTime(Since) + ' GMT');
-  Result := (ReadResult div 100) = 2;
-  if Result then
-    Result := ReadData;
 end;
 
 function TNNTPSend.NewArticles(const Group: string; Since: TDateTime): Boolean;
 begin
-  FSock.SendString('NEWNEWS ' + Group + ' ' + SimpleDateTime(Since) + ' GMT' + CRLF);
+  Result := DoCommandRead('NEWNEWS ' + Group + ' ' + SimpleDateTime(Since) + ' GMT');
-  Result := (ReadResult div 100) = 2;
-  if Result then
-    Result := ReadData;
 end;
 
 function TNNTPSend.PostArticle: Boolean;
-var
-  x: integer;
 begin
-  FSock.SendString('POST' + CRLF);
+  Result := DoCommandWrite('POST');
-  x := (ReadResult div 100);
-  if x = 3 then
-  begin
-    SendData;
-    x := (ReadResult div 100);
-  end;
-  Result := x = 2;
 end;
 
 function TNNTPSend.SwitchToSlave: Boolean;
 begin
-  FSock.SendString('SLAVE' + CRLF);
+  Result := DoCommand('SLAVE');
-  Result := (ReadResult div 100) = 2;
+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;
 
 {==============================================================================}

pingsend.pas

@@ -3,7 +3,7 @@
 |==============================================================================|
 | Content: PING sender                                                         |
 |==============================================================================|
-| Copyright (c)1999-2002, Lukas Gebauer                                        |
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2000,2001.                |
+| Portions created by Lukas Gebauer are Copyright (c)2000-2003.                |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |

pop3send.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 002.001.000 |
+| Project : Delphree - Synapse                                   | 002.001.004 |
 |==============================================================================|
 | Content: POP3 client                                                         |
 |==============================================================================|
-| Copyright (c)1999-2002, Lukas Gebauer                                        |
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2001-2002.                |
+| Portions created by Lukas Gebauer are Copyright (c)2001-2003.                |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -116,9 +116,6 @@ type
 
 implementation
 
-const
-  CRLF = #13#10;
-
 constructor TPOP3Send.Create;
 begin
   inherited Create;
@@ -126,7 +123,7 @@ begin
   FPOP3cap := TStringList.Create;
   FSock := TTCPBlockSocket.Create;
   FSock.CreateSocket;
-  FSock.ConvertLineEnd := True;
+  FSock.ConvertLineEnd := true;
   FTimeout := 300000;
   FTargetPort := cPop3Protocol;
   FUsername := '';
@@ -161,6 +158,9 @@ begin
       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;
   FResultCode := Result;
@@ -203,7 +203,6 @@ end;
 function TPOP3Send.Capability: Boolean;
 begin
   FPOP3cap.Clear;
-  Result := False;
   FSock.SendString('CAPA' + CRLF);
   Result := ReadResult(True) = 1;
   if Result then

slogsend.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 001.001.000 |
+| Project : Delphree - Synapse                                   | 001.001.001 |
 |==============================================================================|
 | Content: SysLog client                                                       |
 |==============================================================================|
-| Copyright (c)1999-2002, Lukas Gebauer                                        |
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2001.                     |
+| Portions created by Lukas Gebauer are Copyright (c)2001-2003.                |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -167,7 +167,6 @@ end;
 function ToSysLog(const SyslogServer: string; Facil: Byte;
   Sever: TSyslogSeverity; const Content: string): Boolean;
 begin
-  Result := False;
   with TSyslogSend.Create do
     try
       TargetHost :=SyslogServer;

smtpsend.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 003.002.001 |
+| Project : Delphree - Synapse                                   | 003.002.004 |
 |==============================================================================|
 | Content: SMTP client                                                         |
 |==============================================================================|
-| Copyright (c)1999-2002, Lukas Gebauer                                        |
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c) 1999-2002.          |
+| Portions created by Lukas Gebauer are Copyright (c) 1999-2003.          |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -126,9 +126,6 @@ function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string;
 
 implementation
 
-const
-  CRLF = #13#10;
-
 constructor TSMTPSend.Create;
 begin
   inherited Create;
@@ -136,7 +133,7 @@ begin
   FESMTPcap := TStringList.Create;
   FSock := TTCPBlockSocket.Create;
   FSock.CreateSocket;
-  FSock.ConvertLineEnd := True;
+  FSock.ConvertLineEnd := true;
   FTimeout := 300000;
   FTargetPort := cSmtpProtocol;
   FUsername := '';
@@ -547,11 +544,11 @@ begin
   try
     t.Assign(MailData);
     t.Insert(0, '');
-    t.Insert(0, 'x-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer');
+    t.Insert(0, 'X-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer');
-    t.Insert(0, 'subject: ' + Subject);
+    t.Insert(0, 'Subject: ' + Subject);
-    t.Insert(0, 'date: ' + Rfc822DateTime(now));
+    t.Insert(0, 'Date: ' + Rfc822DateTime(now));
-    t.Insert(0, 'to: ' + MailTo);
+    t.Insert(0, 'To: ' + MailTo);
-    t.Insert(0, 'from: ' + MailFrom);
+    t.Insert(0, 'From: ' + MailFrom);
     Result := SendToRaw(MailFrom, MailTo, SMTPHost, t, Username, Password);
   finally
     t.Free;

snmpsend.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 002.005.000 |
+| Project : Delphree - Synapse                                   | 002.006.000 |
 |==============================================================================|
 | Content: SNMP client                                                         |
 |==============================================================================|
-| Copyright (c)1999-2002, Lukas Gebauer                                        |
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2000,2001.                |
+| Portions created by Lukas Gebauer are Copyright (c)2000-2003.                |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -102,6 +102,8 @@ type
     procedure MIBAdd(const MIB, Value: string; ValueType: Integer);
     procedure MIBDelete(Index: Integer);
     function MIBGet(const MIB: string): string;
+    function MIBCount: integer;
+    function MIBByIndex(Index: Integer): TSNMPMib;
   published
     property Version: Integer read FVersion write FVersion;
     property Community: string read FCommunity write FCommunity;
@@ -262,19 +264,31 @@ end;
 
 procedure TSNMPRec.MIBDelete(Index: Integer);
 begin
-  if (Index >= 0) and (Index < FSNMPMibList.Count) then
+  if (Index >= 0) and (Index < MIBCount) then
   begin
     TSNMPMib(FSNMPMibList[Index]).Free;
     FSNMPMibList.Delete(Index);
   end;
 end;
 
+function TSNMPRec.MIBCount: integer;
+begin
+  Result := FSNMPMibList.Count;
+end;
+
+function TSNMPRec.MIBByIndex(Index: Integer): TSNMPMib;
+begin
+  Result := nil;
+  if (Index >= 0) and (Index < MIBCount) then
+    Result := TSNMPMib(FSNMPMibList[Index]);
+end;
+
 function TSNMPRec.MIBGet(const MIB: string): string;
 var
   i: Integer;
 begin
   Result := '';
-  for i := 0 to FSNMPMibList.Count - 1 do
+  for i := 0 to MIBCount - 1 do
   begin
     if ((TSNMPMib(FSNMPMibList[i])).OID = MIB) then
     begin
@@ -365,25 +379,32 @@ begin
   end;
 end;
 
+function InternalGetNext(const SNMPSend: TSNMPSend; var OID: string;
+  const Community: string; var Value: string): Boolean;
+begin
+  SNMPSend.Query.Clear;
+  SNMPSend.Query.ID := SNMPSend.Query.ID + 1;
+  SNMPSend.Query.Community := Community;
+  SNMPSend.Query.PDUType := PDUGetNextRequest;
+  SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL);
+  Result := SNMPSend.DoIt;
+  Value := '';
+  if Result then
+    if SNMPSend.Reply.SNMPMibList.Count > 0 then
+    begin
+      OID := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).OID;
+      Value := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).Value;
+    end;
+end;
+
 function SNMPGetNext(var OID: string; const Community, SNMPHost: string; var Value: string): Boolean;
 var
   SNMPSend: TSNMPSend;
 begin
   SNMPSend := TSNMPSend.Create;
   try
-    SNMPSend.Query.Clear;
-    SNMPSend.Query.Community := Community;
-    SNMPSend.Query.PDUType := PDUGetNextRequest;
-    SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL);
     SNMPSend.TargetHost := SNMPHost;
-    Result := SNMPSend.DoIt;
+    Result := InternalGetNext(SNMPSend, OID, Community, Value);
-    Value := '';
-    if Result then
-      if SNMPSend.Reply.SNMPMibList.Count > 0 then
-      begin
-        OID := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).OID;
-        Value := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).Value;
-      end;
   finally
     SNMPSend.Free;
   end;
@@ -394,33 +415,39 @@ var
   OID: string;
   s: string;
   col,row: string;
-  lastcol: string;
+  x: integer;
-  x, n: integer;
+  SNMPSend: TSNMPSend;
+  RowList: TStringList;
 begin
   Value.Clear;
-  OID := BaseOID;
+  SNMPSend := TSNMPSend.Create;
-  lastcol := '';
+  RowList := TStringList.Create;
-  x := 0;
+  try
-  repeat
+    SNMPSend.TargetHost := SNMPHost;
-    Result := SNMPGetNext(OID, Community, SNMPHost, s);
+    OID := BaseOID;
-    if Pos(BaseOID, OID) <> 1 then
+    repeat
-        break;
+      Result := InternalGetNext(SNMPSend, OID, Community, s);
-    row := separateright(oid, baseoid + '.');
+      if Pos(BaseOID, OID) <> 1 then
-    col := fetch(row, '.');
+          break;
-    if col = lastcol then
+      row := separateright(oid, baseoid + '.');
-      inc(x)
+      col := fetch(row, '.');
-    else
+
-      x:=0;
+      if IsBinaryString(s) then
-    lastcol := col;
+        s := StrToHex(s);
-    if value.count <= x then
+      x := RowList.indexOf(Row);
-      for n := value.Count - 1 to x do
+      if x < 0 then
-        value.add('');
+      begin
-    if value[x] <> '' then
+        x := RowList.add(Row);
-      value[x] := value[x] + ',';
+        Value.Add('');
-    if IsBinaryString(s) then
+      end;
-      s := StrToHex(s);
+      if (Value[x] <> '') then
-    value[x] := value[x] + AnsiQuotedStr(s, '"');
+        Value[x] := Value[x] + ',';
-  until not result;
+      Value[x] := Value[x] + AnsiQuotedStr(s, '"');
+    until not result;
+  finally
+    SNMPSend.Free;
+    RowList.Free;
+  end;
 end;
 
 function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: string; var Value: String): Boolean;

snmptrap.pas

@@ -3,7 +3,7 @@
 |==============================================================================|
 | Content: SNMP traps                                                          |
 |==============================================================================|
-| Copyright (c)1999-2002, Lukas Gebauer                                        |
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Hernan Sanchez are Copyright (c)2000,2001.               |
+| Portions created by Hernan Sanchez are Copyright (c)2000-2003.               |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |

sntpsend.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 002.002.000 |
+| Project : Delphree - Synapse                                   | 002.002.001 |
 |==============================================================================|
 | Content: SNTP client                                                         |
 |==============================================================================|
-| Copyright (c)1999-2002, Lukas Gebauer                                        |
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2000,2001.                |
+| Portions created by Lukas Gebauer are Copyright (c)2000-2003.                |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -154,12 +154,12 @@ var
 begin
   d  := (dt - 2) * 86400;
   d1 := frac(d);
-  d  := trunc(d);
+  if d > maxilongint then
-  if d>maxilongint then
      d := d - maxi - 1;
+  d  := trunc(d);
   d1 := Trunc(d1 * 10000) / 10000;
   d1 := d1 * maxi;
-  if d1>maxilongint then
+  if d1 > maxilongint then
      d1 := d1 - maxi - 1;
   Nsec:=trunc(d);
   Nfrac:=trunc(d1);
@@ -232,7 +232,7 @@ begin
   FillChar(q, SizeOf(q), 0);
   q.mode := $1B;
   t1 := GetUTTime;
-  EncodeTs(t1,q.org1,q.org2);
+  EncodeTs(t1, q.org1, q.org2);
   FSock.SendBuffer(@q, SizeOf(q));
   FBuffer := FSock.RecvPacket(FTimeout);
   if FSock.LastError = 0 then

synachar.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 004.000.001 |
+| Project : Delphree - Synapse                                   | 004.000.003 |
 |==============================================================================|
 | Content: Charset conversion support                                          |
 |==============================================================================|
-| Copyright (c)1999-2002, Lukas Gebauer                                        |
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2000,2001.                |
+| Portions created by Lukas Gebauer are Copyright (c)2000-2003.                |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -671,7 +671,7 @@ const
       $0158, $0052,
       $0160, $0053,
       $0164, $0053,
-      $00DA, $0054,
+      $00DA, $0055,
       $016E, $0055,
       $00DD, $0059,
       $017D, $005A
@@ -806,8 +806,15 @@ begin
   b[1] := 0;
   b[2] := 0;
   b[3] := 0;
-  if (Length(Value) + 1) < Index + mb then
+  b1 := 0;
+  b2 := 0;
+  b3 := 0;
+  b4 := 0;
+  if length(Value) < (Index + mb - 1) then
+  begin
+    Inc(index, mb);
     Exit;
+  end;
   s := '';
   for n := 1 to mb do
   begin
@@ -937,9 +944,9 @@ end;
 {==============================================================================}
 function UTF7toUCS2(const Value: string): string;
 var
-  n: Integer;
+  n, i: Integer;
   c: Char;
-  s: string;
+  s, t: string;
 begin
   Result := '';
   n := 1;
@@ -968,7 +975,18 @@ begin
       if s = '' then
         s := WriteMulti(Ord('+'), 0, 0, 0, 2)
       else
-        s := DecodeBase64(s);
+      begin
+        t := DecodeBase64(s);
+        if not odd(length(t)) then
+          s := t
+        else
+        begin //ill-formed sequence
+          t := s;
+          s := WriteMulti(Ord('+'), 0, 0, 0, 2);
+          for i := 1 to length(t) do
+            s := s + WriteMulti(Ord(t[i]), 0, 0, 0, 2);
+        end;
+      end;
       Result := Result + s;
     end;
   end;

synacode.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 001.005.005 |
+| Project : Delphree - Synapse                                   | 001.006.001 |
 |==============================================================================|
 | Content: Coding and decoding support                                         |
 |==============================================================================|
-| Copyright (c)1999-2002, Lukas Gebauer                                        |
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2000-2002.                |
+| Portions created by Lukas Gebauer are Copyright (c)2000-2003.                |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -113,6 +113,7 @@ function Encode3to4(const Value, Table: string): string;
 function DecodeBase64(const Value: string): string;
 function EncodeBase64(const Value: string): string;
 function DecodeUU(const Value: string): string;
+function EncodeUU(const Value: string): string;
 function DecodeXX(const Value: string): string;
 function UpdateCrc32(Value: Byte; Crc32: Integer): Integer;
 function Crc32(const Value: string): Integer;
@@ -506,7 +507,11 @@ begin
     Exit; //ignore Table yet (set custom UUT)
   //begin decoding
   x := Pos(Value[1], uut) - 1;
-  x := Round((x / 3) * 4);
+  case (x mod 3) of
+    0: x :=(x div 3)* 4;
+    1: x :=((x div 3) * 4) + 2;
+    2: x :=((x  div 3) * 4) + 3;
+  end;
   //x - lenght UU line
   s := Copy(Value, 2, x);
   if s = '' then
@@ -516,6 +521,15 @@ end;
 
 {==============================================================================}
 
+function EncodeUU(const Value: string): string;
+begin
+  Result := '';
+  if Length(Value) < Length(TableUU) then
+    Result := TableUU[Length(Value) + 1] + Encode3to4(Value, TableUU);
+end;
+
+{==============================================================================}
+
 function DecodeXX(const Value: string): string;
 var
   s: string;
@@ -531,7 +545,11 @@ begin
     Exit;
   //begin decoding
   x := Pos(Value[1], TableXX) - 1;
-  x := Round((x / 3) * 4);
+  case (x mod 3) of
+    0: x :=(x div 3)* 4;
+    1: x :=((x div 3) * 4) + 2;
+    2: x :=((x  div 3) * 4) + 3;
+  end;
   //x - lenght XX line
   s := Copy(Value, 2, x);
   if s = '' then

synamisc.pas

@@ -0,0 +1,306 @@
+{==============================================================================|
+| Project : Delphree - Synapse                                   | 001.000.004 |
+|==============================================================================|
+| Content: misc. procedures and functions                                      |
+|==============================================================================|
+| 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) 2002-2003.               |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{$Q-}
+
+unit SynaMisc;
+
+interface
+
+uses
+  SynaUtil, blcksock, SysUtils, Classes,
+{$IFDEF LINUX}
+  Libc;
+{$ELSE}
+  Windows, Wininet;
+{$ENDIF}
+
+Type
+  TProxySetting = record
+    Host: string;
+    Port: string;
+    Bypass: string;
+  end;
+
+procedure WakeOnLan(MAC, IP: string);
+function GetDNS: string;
+function GetIEProxy(protocol: string): TProxySetting;
+
+implementation
+
+{==============================================================================}
+procedure WakeOnLan(MAC, IP: string);
+var
+  sock: TUDPBlockSocket;
+  HexMac: string;
+  data: string;
+  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 char;
+  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 char;
+    DomainName: array[1..128 + 4] of char;
+    CurrentDNSServer: PTIP_ADDR_STRING;
+    DNSServerList: TIP_ADDR_STRING;
+    NodeType: UINT;
+    ScopeID: array[1..256 + 4] of char;
+    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,'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
+      Result := string(Temp);
+    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
+    if Win32Platform = VER_PLATFORM_WIN32_NT then
+    begin
+      Result := ReadReg(NTdyn, 'NameServer');
+      if result = '' then
+        Result := ReadReg(NTfix, 'NameServer');
+    end
+    else
+      Result := ReadReg(W9xfix, 'NameServer');
+end;
+{$ENDIF}
+
+{==============================================================================}
+
+function GetIEProxy(protocol: string): TProxySetting;
+{$IFDEF LINUX}
+begin
+  Result.Host := '';
+  Result.Port := '';
+  Result.Bypass := '';
+end;
+{$ELSE}
+var
+  ProxyInfo: PInternetProxyInfo;
+  Err: Boolean;
+  Len: DWORD;
+  Proxy: string;
+  DefProxy: string;
+  ProxyList: TStringList;
+  n: integer;
+begin
+  Result.Host := '';
+  Result.Port := '';
+  Result.Bypass := '';
+  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 := SeparateLeft(Proxy, ':');
+          Result.Port := SeparateRight(Proxy, ':');
+        end;
+        Result.Bypass := ReplaceString(ProxyInfo^.lpszProxyBypass, ' ', ',');
+      end;
+  finally
+    ProxyList.Free;
+    FreeMem(ProxyInfo);
+  end;
+end;
+{$ENDIF}
+
+{==============================================================================}
+
+end.

synassl.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 001.006.000 |
+| Project : Delphree - Synapse                                   | 001.007.000 |
 |==============================================================================|
 | Content: SSL support                                                         |
 |==============================================================================|
-| Copyright (c)1999-2002, Lukas Gebauer                                        |
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2002.                     |
+| Portions created by Lukas Gebauer are Copyright (c)2002-2003.                |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -63,8 +63,8 @@ const
   DLLSSLName = 'libssl.so';
   DLLUtilName = 'libcrypto.so';
 {$ELSE}
-  DLLSSLName = 'libssl32.dll';
+  DLLSSLName = 'ssleay32.dll';
-  DLLSSLName2 = 'ssleay32.dll';
+  DLLSSLName2 = 'libssl32.dll';
   DLLUtilName = 'libeay32.dll';
 {$ENDIF}
 
@@ -94,6 +94,7 @@ const
 var
   SSLLibHandle: Integer = 0;
   SSLUtilHandle: Integer = 0;
+  SSLLibName: string = '';
 
 // libssl.dll
   SslGetError : function(s: PSSL; ret_code: Integer):Integer cdecl = nil;
@@ -155,11 +156,16 @@ begin
     begin
 {$IFDEF LINUX}
       SSLLibHandle := HMODULE(dlopen(DLLSSLName, RTLD_GLOBAL));
+      SSLLibName := DLLSSLName;
       SSLUtilHandle := HMODULE(dlopen(DLLUtilName, RTLD_GLOBAL));
 {$ELSE}
       SSLLibHandle := LoadLibrary(PChar(DLLSSLName));
+      SSLLibName := DLLSSLName;
       if (SSLLibHandle = 0) then
+      begin
         SSLLibHandle := LoadLibrary(PChar(DLLSSLName2));
+        SSLLibName := DLLSSLName2;
+      end;
       SSLUtilHandle := LoadLibrary(PChar(DLLUtilName));
 {$ENDIF}
       if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then

synautil.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 003.002.001 |
+| Project : Delphree - Synapse                                   | 003.003.000 |
 |==============================================================================|
 | Content: support procedures and functions                                    |
 |==============================================================================|
-| Copyright (c)1999-2002, Lukas Gebauer                                        |
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c) 1999-2002.               |
+| Portions created by Lukas Gebauer are Copyright (c) 1999-2003.               |
 | Portions created by Hernan Sanchez are Copyright (c) 2000.                   |
 | All Rights Reserved.                                                         |
 |==============================================================================|
@@ -90,7 +90,7 @@ function IntToBin(Value: Integer; Digits: Byte): string;
 function BinToInt(const Value: string): Integer;
 function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path,
   Para: string): string;
-function StringReplace(Value, Search, Replace: string): string;
+function ReplaceString(Value, Search, Replace: string): string;
 function RPosEx(const Sub, Value: string; From: integer): Integer;
 function RPos(const Sub, Value: String): Integer;
 function Fetch(var Value: string; const Delimiter: string): string;
@@ -98,6 +98,7 @@ function IsBinaryString(const Value: string): Boolean;
 function PosCRLF(const Value: string; var Terminator: string): integer;
 Procedure StringsTrim(const value: TStrings);
 function PosFrom(const SubStr, Value: String; From: integer): integer;
+function IncPoint(const p: pointer; Value: integer): pointer;
 
 implementation
 
@@ -308,7 +309,7 @@ begin
   x := rpos(':', Value);
   if (x > 0) and ((Length(Value) - x) > 2) then
     Value := Copy(Value, 1, x + 2);
-  Value := StringReplace(Value, ':', TimeSeparator);
+  Value := ReplaceString(Value, ':', TimeSeparator);
   Result := 0;
   try
     Result := StrToTime(Value);
@@ -370,9 +371,9 @@ begin
   month := 0;
   year := 0;
   zone := 0;
-  Value := StringReplace(Value, ' -', ' #');
+  Value := ReplaceString(Value, ' -', ' #');
-  Value := StringReplace(Value, '-', ' ');
+  Value := ReplaceString(Value, '-', ' ');
-  Value := StringReplace(Value, ' #', ' -');
+  Value := ReplaceString(Value, ' #', ' -');
   while Value <> '' do
   begin
     s := Fetch(Value, ' ');
@@ -419,6 +420,8 @@ begin
     if y > 0 then
       month := y;
   end;
+  if year = 0 then
+    year := 1980;
   if (month < 1) or (month > 12) then
     month := 1;
   if (day < 1) or (day > 31) then
@@ -826,7 +829,7 @@ end;
 function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path,
   Para: string): string;
 var
-  x: Integer;
+  x, y: Integer;
   sURL: string;
   s: string;
   s1, s2: string;
@@ -850,7 +853,8 @@ begin
   if UpperCase(Prot) = 'FTP' then
     Port := '21';
   x := Pos('@', sURL);
-  if (x > 0) and (x < Pos('/', sURL)) then
+  y := Pos('/', sURL);
+  if (x > 0) and ((x < y) or (y < 1))then
   begin
     s := SeparateLeft(sURL, '@');
     sURL := SeparateRight(sURL, '@');
@@ -897,7 +901,7 @@ end;
 
 {==============================================================================}
 
-function StringReplace(Value, Search, Replace: string): string;
+function ReplaceString(Value, Search, Replace: string): string;
 var
   x, l, ls, lr: Integer;
 begin
@@ -1061,4 +1065,11 @@ end;
 
 {==============================================================================}
 
+function IncPoint(const p: pointer; Value: integer): pointer;
+begin
+  Result := pointer(integer(p) + Value);
+end;
+
+{==============================================================================}
+
 end.

synsock.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 002.001.000 |
+| Project : Delphree - Synapse                                   | 002.002.000 |
 |==============================================================================|
 | Content: Socket Independent Platform Layer                                   |
 |==============================================================================|
-| Copyright (c)1999-2002, Lukas Gebauer                                        |
+| Copyright (c)1999-2003, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2001.                     |
+| Portions created by Lukas Gebauer are Copyright (c)2001-2003.                |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -53,6 +53,7 @@ unit synsock;
 interface
 
 uses
+  SyncObjs,
 {$IFDEF LINUX}
   Libc, KernelIoctl;
 {$ELSE}
@@ -273,14 +274,14 @@ function LSSelect(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
   timeout: PTimeVal): Longint; stdcall;
 {$ENDIF}
 
+var
+  SynSockCS: TCriticalSection;
+
 implementation
 
 {$IFNDEF LINUX}
 {$IFNDEF STATICWINSOCK}
-uses syncobjs;
-
 var
-  SynSockCS: TCriticalSection;
   SynSockCount: Integer = 0;
 {$ENDIF}
 {$ENDIF}
@@ -622,8 +623,6 @@ begin
   Result := True;
 end;
 
-{$IFNDEF LINUX}
-{$IFNDEF STATICWINSOCK}
 initialization
 begin
   SynSockCS:= TCriticalSection.Create;
@@ -633,7 +632,5 @@ finalization
 begin
   SynSockCS.Free;
 end;
-{$ENDIF}
-{$ENDIF}
 
 end.

tlntsend.pas

@@ -0,0 +1,306 @@
+{==============================================================================|
+| Project : Delphree - Synapse                                   | 001.000.002 |
+|==============================================================================|
+| Content: TELNET 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)2002-2003.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{$WEAKPACKAGEUNIT ON}
+
+//RFC-854
+
+unit TlntSend;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, SynaUtil;
+
+const
+  cTelnetProtocol = 'telnet';
+
+  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
+  TTelnetState =(tsDATA, tsIAC, tsIAC_SB, tsIAC_WILL, tsIAC_DO, tsIAC_WONT,
+     tsIAC_DONT, tsIAC_SBIAC, tsIAC_SBDATA, tsSBDATA_IAC);
+
+  TTelnetSend = class(TSynaClient)
+  private
+    FSock: TTCPBlockSocket;
+    FBuffer: string;
+    FState: TTelnetState;
+    FSessionLog: string;
+    FSubNeg: string;
+    FSubType: char;
+    function Connect: Boolean;
+    function Negotiate(const Buf: string): string;
+    procedure FilterHook(Sender: TObject; var Value: string);
+  public
+    constructor Create;
+    destructor Destroy; override;
+    function Login: Boolean;
+    procedure Logout;
+    procedure Send(const Value: string);
+    function WaitFor(const Value: string): Boolean;
+    function RecvTerminated(const Terminator: string): string;
+    function RecvString: string;
+  published
+    property Sock: TTCPBlockSocket read FSock;
+    property SessionLog: string read FSessionLog write FSessionLog;
+  end;
+
+implementation
+
+constructor TTelnetSend.Create;
+begin
+  inherited Create;
+  FSock := TTCPBlockSocket.Create;
+  FSock.OnReadFilter := FilterHook;
+  FTimeout := 300000;
+  FTargetPort := cTelnetProtocol;
+  FSubNeg := '';
+  FSubType := #0;
+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: string);
+begin
+  Value := Negotiate(Value);
+  FSessionLog := FSessionLog + Value;
+end;
+
+function TTelnetSend.Negotiate(const Buf: string): string;
+var
+  n: integer;
+  c: char;
+  Reply: string;
+  SubReply: string;
+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 + 'SYNAPSE';
+                  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;
+
+procedure TTelnetSend.Logout;
+begin
+  FSock.CloseSocket;
+end;
+
+
+end.