Novas classes TServer e TClient [Exclusivo]

[Rento]

Após eu passar por dores de cabeças com o TServerSocket e o TClientSocket, fiz está classes.

Ela corrige os principais erros que enfrentei e mais alguns que podem estar acontecendo por ai:

• MensagensComProblamaDeJuntaTudoAndBugarTudo
• Mensagens grandes 100%
• Address com "localhost" auto para 127.0.0.1

Junto com o arquivo unSocket.pas vem um projeto de exemplo.

Você pode modificar quaisquer arquivo, mantendo por favor o cabeçalho.

Link de tudo:

http://www.myfileupload.net/download.php?f...58d91c2146ebf79

unSocket.pas:

{*----------------------------------------------------------------------------*}
{* Socket Tools v1.0 written by Rento (rento@click21.com.br) ******************}
{*----------------------------------------------------------------------------*}
{* Constants for use with Socket Tools ****************************************}
{*----------------------------------------------------------------------------*}
{* Copyright © 2008 Rento                                                   *}
{* Permission is hereby granted, free of charge, to any person obtaining a    *}
{* copy of this software and associated documentation files (the "Software"), *}
{* to deal in the Software without restriction, including without limitation  *}
{* the rights to use, copy, modify, merge, publish, distribute, sublicense,   *}
{* and/or sell copies of the Software, and to permit persons to whom the      *}
{* Software is furnished to do so, subject to the following conditions:       *}
{*                                                                            *}
{* The above copyright notice and this permission notice shall be included in *}
{* all copies or substantial portions of the Software.                        *}
{*                                                                            *}
{* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *}
{* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,   *}
{* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL    *}
{* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *}
{* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING    *}
{* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER        *}
{* DEALINGS IN THE SOFTWARE.                                                  *}
{********************************* FUNCTIONS **********************************}
//      DAY     | Function              | Type
// 10/04/2008    create               v1  Server
// 10/04/2008    rSendMessage         v1  Server
// 10/04/2008    rOnBefRead           v1  Server
// 10/04/2008    rChangeActive        v1  Server
// 10/04/2008    Destroy              v1  Server
// 
// 11/04/2008    rSeparateMsg         v1  unit
// 11/04/2008    rOnBefRead           v2  Server
// 11/04/2008    onLogin              v1  Server
// 11/04/2008    onLogout             v1  Server
// 
// 12/04/2008    rSendText overload   v1  Server
// 12/04/2008    rOnBefRead           v2  Server
// 12/04/2008    onError              v1  Server
// 12/04/2008    create               v1  Client
// 12/04/2008    rOnBefRead           v1  Client
// 12/04/2008    Destroy              v1  Client
// 12/04/2008    rSendMessage         v1  Client
// 12/04/2008    onError              v1  Client
// Ops! Are 00:03 of 13/04/2008
// 13/04/2008    onConnect            v1  Client

{*----------------------------------------------------------------------------*}
unit unSocket;

interface

uses
  ScktComp, WinSock, Classes, Windows, forms, SysUtils;
//------------------------------------------------------------------------------
   procedure   rSeparateMsg(var pLst: TStrings; pMsg: string);
type
     {               10060  |    10061 | 10065,      10064   | 10040       }
   TErrorType = (etTimeOut, etRefused, etNoHost, etHostDown, etTooLong, etUnknow);
   TRetEvt    = procedure(pMessage: string; pFrom: Pointer) of object;
   TEtnEvt    = procedure(pSocket: TCustomWinSocket) of object;
   TGetEvt    = procedure(pSocket: TCustomWinSocket; pMsg: string) of object;
   TErrEvt    = procedure(pSocket: TCustomWinSocket; pErroType: TErrorType; var pErroCode: Integer) of object;
   TServer = class
   protected
      FServer : TServerSocket;
      FRetEvt : TRetEvt;
      FLogin  : TEtnEvt;
      FLogout : TEtnEvt;
      FLastMsg: string;
      FMsgLst : TStrings;
      FConIds : TList;
      FErrEvt : TErrEvt;
      procedure   rOnBefRead(Sender: TObject; Socket: TCustomWinSocket);
      procedure   rOnBefLogin(Sender: TObject; Socket: TCustomWinSocket);
      procedure   rOnBefLogout(Sender: TObject; Socket: TCustomWinSocket);
      procedure   rOnBefError(Sender: TObject; Socket: TCustomWinSocket;
                     ErrorEvent: TErrorEvent; var ErrorCode: Integer);
   public
      constructor Create(pPort: Integer; const pActive: Boolean = False);
      destructor  Destroy(); override;
      property    onExecute: TRetEvt read FRetEvt write FRetEvt;
      property    onLogin  : TEtnEvt read FLogin write FLogin;
      property    onLogout : TEtnEvt read FLogout write FLogout; 
      procedure   rSendMessage(pIdx: Integer; pMsg: string); overload;
      procedure   rSendMessage(pData: Pointer; pMsg: string); overload;
      procedure   rChangeActive(pValor: Boolean);
      property    onError  : TErrEvt read FErrEvt write FErrEvt;
   end;

   TClient = class
   protected
      FGetEvt : TGetEvt;
      FLastMsg: String;
      FMsgLst : TStrings;
      FClient : TClientSocket;
      FErrEvt : TErrEvt;
      FLogin  : TEtnEvt;
      procedure   rOnBefRead(Sender: TObject; Socket: TCustomWinSocket);
      procedure   rOnBefError(Sender: TObject; Socket: TCustomWinSocket;
                     ErrorEvent: TErrorEvent; var ErrorCode: Integer);
      procedure   rOnBefCon(Sender: TObject; Socket: TCustomWinSocket);                
   public
      constructor Create(pIp: string; pPort: Integer; const pActive: Boolean = False);
      destructor  Destroy(); override;
      property    onRead   : TGetEvt read FGetEvt write FGetEvt;
      property    onError  : TErrEvt read FErrEvt write FErrEvt;
      property    onConnect: TEtnEvt read FLogin write FLogin;
      procedure   rSendMessage(pMsg: string);
   end;
//------------------------------------------------------------------------------
implementation

constructor TServer.Create(pPort: Integer; const pActive: Boolean = False);
begin
   FServer                    := TServerSocket.Create(nil);
   FMsgLst                    := TStringList  .Create;
   FConIds                    := TList        .Create;
   FServer.Port               := pPort;
   FServer.OnClientConnect    := rOnBefLogin;
   FServer.OnClientRead       := rOnBefRead;
   FServer.OnClientDisconnect := rOnBefLogout;
   FServer.OnClientError      := rOnBefError;
   rChangeActive(pActive);
end;

procedure TServer.rSendMessage(pIdx: Integer; pMsg: string);
var
  I: Integer;
begin
   if pMsg <> '' then
      begin
      if pIdx = -1 then
         begin
         for I := 0 to FServer.Socket.ActiveConnections - 1 do
            begin
            Application.ProcessMessages; // If ActiveConnections so large...
            FServer.Socket.Connections[I].SendText(#0 + pMsg + #0 + 'END');
            end;
         end
      else
         begin
         if pIdx <= FServer.Socket.ActiveConnections - 1 then
            begin
            FServer.Socket.Connections[pIdx].SendText(#0 + pMsg + #0 + 'END');
            end;
         end;
      end;
end;

procedure TServer.rSendMessage(pData: Pointer; pMsg: string);
begin
   rSendMessage(FConIds.IndexOf(pData), pMsg);
end;

procedure TServer.rOnBefRead(Sender: TObject; Socket: TCustomWinSocket);
var
  lvAllRec: Boolean;
  lvLength: Integer;
  lvRecive: string;
  lvAllMsg: string;
  I: Integer;
begin
   lvRecive := Socket.ReceiveText;
   lvLength := Length(lvRecive);
   lvAllRec := Copy(lvRecive, lvLength - 2, 3) = 'END';
   if lvAllRec then
      begin
      lvAllMsg := FLastMsg + Copy(lvRecive, 1, lvLength - 3);
      rSeparateMsg(FMsgLst, lvAllMsg);
      for I := 0 to FMsgLst.Count - 1 do
         onExecute(FMsgLst.Strings[I], Socket.Data);
      end
   else
      begin
      FLastMsg := FLastMsg + lvRecive;
      end;   
end;

procedure TServer.rOnBefLogin(Sender: TObject; Socket: TCustomWinSocket);
var
  lvP: ^integer;
begin
   New(lvP);
   Socket.Data := lvP;
   FConIds.Add(Socket.Data);
   onLogin(Socket);
end;

procedure TServer.rOnBefLogout(Sender: TObject; Socket: TCustomWinSocket);
begin
   onLogout(Socket);
   FConIds.Remove(Socket.Data);
   Dispose(Socket.Data);
end;

procedure rSeparateMsg(var pLst: TStrings; pMsg: string);
var
  I: Integer;
  lvTmp: String;
begin
   lvTmp := '';
   I     := 1;
   pLst.Clear;
   while (I <= Length(pMsg)) do
      begin
      if pMsg[I] = #0 then
         begin
         Inc(I);
         while ((pMsg[I] <> #0) and (I <= Length(pMsg))) do
            begin
            lvTmp := lvTmp + pMsg[I];
            Inc(I);
            end;
         end;
      Inc(I);
      if lvTmp <> '' then
         pLst.Add(lvTmp);
      lvTmp := '';
      end;                   
end;

procedure TServer.rOnBefError(Sender: TObject; Socket: TCustomWinSocket;
   ErrorEvent: TErrorEvent; var ErrorCode: Integer);
var
  lvEt: TErrorType;
begin
   case ErrorCode of
      10060: lvEt := etTimeOut;
      10061: lvEt := etRefused;
      10065: lvEt := etNoHost;
      10064: lvEt := etHostDown;
      10040: lvEt := etTooLong;
       else lvEt := etUnknow;
   end;
   onError(Socket, lvEt, ErrorCode);
end;

procedure TServer.rChangeActive(pValor: Boolean);
begin
   if not pValor then
      begin
      FLastMsg := '';
      FMsgLst.Clear;
      FConIds.Clear;
      FServer.Close;
      end
   else
      begin
      if not FServer.Active then
         FServer.Open;
      end;
end;

destructor TServer.Destroy();
begin
   FMsgLst.Free;
   FConIds.Free;
end;
//------------------------------------------------------------------------------
constructor TClient.Create(pIp: string; pPort: Integer; const pActive: Boolean = False);
begin
   FLastMsg := '';
   FMsgLst  := TStringList  .Create;
   FClient  := TClientSocket.Create(nil);
   FClient.Port := pPort;
   if (LowerCase(pIp) = 'localhost') or (Trim(pIp) = '') then
      FClient.Address := '127.0.0.1'
   else
      FClient.Address := pIp;
   FClient.OnRead  := rOnBefRead;
   FClient.OnError := rOnBefError;
   if pActive then
      if not FClient.Active then
         FClient.Open;
end;

procedure TClient.rSendMessage(pMsg: string);
begin
   if pMsg <> '' then
      if FClient.Socket.Connected then
         FClient.Socket.SendText(#0 + pMsg + #0+'END');
end;

procedure TClient.rOnBefRead(Sender: TObject; Socket: TCustomWinSocket);
var
  lvAllRec: Boolean;
  lvLength: Integer;
  lvRecive: string;
  lvAllMsg: string;
  I: Integer;
begin
   lvRecive := Socket.ReceiveText;
   lvLength := Length(lvRecive);
   lvAllRec := Copy(lvRecive, lvLength - 2, 3) = 'END';
   if lvAllRec then
      begin
      lvAllMsg := FLastMsg + Copy(lvRecive, 1, lvLength - 3);
      rSeparateMsg(FMsgLst, lvAllMsg);
      for I := 0 to FMsgLst.Count - 1 do
         onRead(Socket.Data, FMsgLst.Strings[I]);
      end
   else
      begin
      FLastMsg := FLastMsg + lvRecive;
      end;   
end;

procedure TClient.rOnBefError(Sender: TObject; Socket: TCustomWinSocket;
   ErrorEvent: TErrorEvent; var ErrorCode: Integer);
var
  lvEt: TErrorType;
begin
   case ErrorCode of
      10060: lvEt := etTimeOut;
      10061: lvEt := etRefused;
      10065: lvEt := etNoHost;
      10064: lvEt := etHostDown;
      10040: lvEt := etTooLong;
       else lvEt := etUnknow;
   end;
   onError(Socket,lvEt, ErrorCode);
   ErrorCode := ErrorCode;
end;

procedure TClient.rOnBefCon(Sender: TObject; Socket: TCustomWinSocket);
begin
   onConnect(Socket);
end;

destructor TClient.Destroy();
begin
   FClient.Close;
   FMsgLst.Free;
end;

end.[/codebox]

Editado Abril 13, 2008 por Rento