Delphi跨平台TCP库的封装-木庄网络博客

本文整理自网络，侵删。
 Delphi的跨平台框架FireMonkey下的TCP组件默认自带INDY的，但我个人在使用某些特别的库的时候喜欢再封装一层，封装为简单的对外公开的接口，这里分享一下基于indy的封装的tcp的请求的库。以下代码基于Delphi 10.2。


{ 
  单元名：跨平台的TCP客户端库封装
  作者：5bug
  网站:http://www.5bug. wang
 }
unit uCPTcpClient;
interface
uses System.Classes, System.SysUtils, IdTCPClient, IdGlobal;
type
  TOnRevDataEvent = procedure(const pData: Pointer; const pSize: Cardinal) of object;
  TCPTcpClient = class
  private
    FConnected: Boolean;
    FHost: string;
    FPort: Integer;
    FOnRevDataEvent: TOnRevDataEvent;
    FOnDisconnectEvent: TNotifyEvent;
  type
    TTcpThreadType = (tt_Send, tt_Recv, tt_Handle);
    TCPTcpThread = class(TThread)
    private
      FOnExecuteProc: TProc;
    protected
      procedure Execute; override;
    public
      property OnExecuteProc: TProc read FOnExecuteProc write FOnExecuteProc;
    end;
    TTcpDataRecord = class(TMemoryStream);
  protected
    FTCPClient: TIdTCPClient;
    FSendDataList: TThreadList;
    FRecvDataList: TThreadList;
    FCahceDataList: TThreadList;
    FTcpThread: array [TTcpThreadType] of TCPTcpThread;
    procedure InitThread;
    procedure FreeThread;
    procedure ExcuteSendProc;
    procedure ExcuteRecvProc;
    procedure ExcuteHandleProc;
    procedure ExcuteDisconnect;
    procedure ClearData;
    function PushToSendCahce(const AData: Pointer; const ASize: NativeInt): Boolean;
  public
    constructor Create();
    destructor Destroy; override;
    procedure InitHostAddr(const AHost: string; const APort: Integer);
    function TryConnect: Boolean;
    procedure DisConnect;
    function Send(const AData: Pointer; const ASize: NativeInt): Boolean;
    property Connected: Boolean read FConnected;
    property Host: string read FHost;
    property Port: Integer read FPort;
    property OnRevDataEvent: TOnRevDataEvent read FOnRevDataEvent write FOnRevDataEvent;
    property OnDisconnectEvent: TNotifyEvent read FOnDisconnectEvent write FOnDisconnectEvent;
  end;
implementation
uses uLogSystem;
{ TCPTcpClient }
procedure TCPTcpClient.ClearData;
var
  I: Integer;
  ADataRecord: TTcpDataRecord;
begin
  with FSendDataList.LockList do
    try
      for I := 0 to Count - 1 do
      begin
        ADataRecord := Items[I];
        FreeAndNil(ADataRecord);
      end;
      Clear;
    finally
      FSendDataList.UnlockList;
    end;
  with FRecvDataList.LockList do
    try
      for I := 0 to Count - 1 do
      begin
        ADataRecord := Items[I];
        FreeAndNil(ADataRecord);
      end;
      Clear;
    finally
      FRecvDataList.UnlockList;
    end;
  with FCahceDataList.LockList do
    try
      for I := 0 to Count - 1 do
      begin
        ADataRecord := Items[I];
        FreeAndNil(ADataRecord);
      end;
      Clear;
    finally
      FCahceDataList.UnlockList;
    end;
end;
constructor TCPTcpClient.Create;
begin
  FTCPClient := TIdTCPClient.Create(nil);
  FTCPClient.ConnectTimeout := 5000;
  FTCPClient.ReadTimeout := 5000;
  InitThread;
end;
destructor TCPTcpClient.Destroy;
begin
  FreeThread;
  FTCPClient.Free;
  inherited;
end;
procedure TCPTcpClient.DisConnect;
begin
  ExcuteDisconnect;
end;
procedure TCPTcpClient.ExcuteDisconnect;
begin
  FConnected := False;
  FTCPClient.DisConnect;
  if MainThreadID = CurrentThreadId then
  begin
    if Assigned(FOnDisconnectEvent) then
      FOnDisconnectEvent(Self);
  end
  else
  begin
    TThread.Synchronize(FTcpThread[tt_Recv],
      procedure
      begin
        if Assigned(FOnDisconnectEvent) then
          FOnDisconnectEvent(Self);
      end);
  end;
end;
procedure TCPTcpClient.ExcuteHandleProc;
var
  I: Integer;
  ADataRecord: TTcpDataRecord;
begin
  // 不要长时间锁住收数据的列队
  with FRecvDataList.LockList do
    try
      while Count > 0 do
      begin
        ADataRecord := Items[0];
        FCahceDataList.Add(ADataRecord);
        Delete(0);
      end;
    finally
      FRecvDataList.UnlockList;
    end;
  with FCahceDataList.LockList do
    try
      while Count > 0 do
      begin
        ADataRecord := Items[0];
        Delete(0);
        TThread.Synchronize(FTcpThread[tt_Handle],
          procedure
          begin
            if Assigned(FOnRevDataEvent) then
              FOnRevDataEvent(ADataRecord.Memory, ADataRecord.Size);
            FreeAndNil(ADataRecord);
          end);
      end;
    finally
      FCahceDataList.UnlockList;
    end;
end;
procedure TCPTcpClient.ExcuteRecvProc;
var
  ADataRecord: TTcpDataRecord;
  ADataSize: Integer;
begin
  if FConnected then
  begin
    try
      FTCPClient.Socket.CheckForDataOnSource(1);
      ADataSize := FTCPClient.IOHandler.InputBuffer.Size;
      if ADataSize > 0 then
      begin
        ADataRecord := TTcpDataRecord.Create;
        with FRecvDataList.LockList do
          try
            Add(ADataRecord);
          finally
            FRecvDataList.UnlockList;
          end;
        FTCPClient.Socket.ReadStream(ADataRecord, ADataSize);
      end;
      FTCPClient.Socket.CheckForDisconnect(False, True);
    except
      ExcuteDisconnect;
    end;
  end;
  Sleep(1);
end;
function TCPTcpClient.PushToSendCahce(const AData: Pointer; const ASize: NativeInt): Boolean;
var
  ADataRecord: TTcpDataRecord;
begin
  Result := False;
  if FConnected then
  begin
    ADataRecord := TTcpDataRecord.Create;
    ADataRecord.Write(AData^, ASize);
    with FSendDataList.LockList do
      try
        Add(ADataRecord);
      finally
        FSendDataList.UnlockList;
      end;
    Result := True;
  end;
end;
procedure TCPTcpClient.ExcuteSendProc;
var
  ADataRecord: TTcpDataRecord;
begin
  if FConnected then
  begin
    ADataRecord := nil;
    with FSendDataList.LockList do
      try
        if Count > 0 then
        begin
          ADataRecord := Items[0];
          Delete(0);
        end;
      finally
        FSendDataList.UnlockList;
      end;
    if ADataRecord <> nil then
    begin
      FTCPClient.IOHandler.Write(ADataRecord);
      FreeAndNil(ADataRecord);
    end;
  end;
  Sleep(1);
end;
procedure TCPTcpClient.InitThread;
var
  I: Integer;
  AThreadType: TTcpThreadType;
begin
  FSendDataList := TThreadList.Create;
  FRecvDataList := TThreadList.Create;
  FCahceDataList := TThreadList.Create;
  for AThreadType := Low(TTcpThreadType) to High(TTcpThreadType) do
  begin
    FTcpThread[AThreadType] := TCPTcpThread.Create(True);
    FTcpThread[AThreadType].FreeOnTerminate := False;
    case AThreadType of
      tt_Send:
        FTcpThread[AThreadType].OnExecuteProc := ExcuteSendProc;
      tt_Recv:
        FTcpThread[AThreadType].OnExecuteProc := ExcuteRecvProc;
      tt_Handle:
        FTcpThread[AThreadType].OnExecuteProc := ExcuteHandleProc;
    end;
    FTcpThread[AThreadType].Start;
  end;
end;
procedure TCPTcpClient.FreeThread;
var
  I: Integer;
  AThreadType: TTcpThreadType;
begin
  for AThreadType := Low(TTcpThreadType) to High(TTcpThreadType) do
  begin
    if FTcpThread[AThreadType].Suspended then
{$WARN SYMBOL_DEPRECATED OFF}
      FTcpThread[AThreadType].Resume;
{$WARN SYMBOL_DEPRECATED ON}
    FTcpThread[AThreadType].Terminate;
    FTcpThread[AThreadType].WaitFor;
    FTcpThread[AThreadType].Free;
    FTcpThread[AThreadType] := nil;
  end;
  ClearData;
  FSendDataList.Free;
  FRecvDataList.Free;
  FCahceDataList.Free;
end;
procedure TCPTcpClient.InitHostAddr(const AHost: string; const APort: Integer);
begin
  FHost := AHost;
  FPort := APort;
end;
function TCPTcpClient.Send(const AData: Pointer; const ASize: NativeInt): Boolean;
begin
  Result := PushToSendCahce(AData, ASize);
end;
function TCPTcpClient.TryConnect: Boolean;
begin
  try
    FTCPClient.Host := FHost;
    FTCPClient.Port := FPort;
    FTCPClient.Connect;
    FConnected := True;
  except
    on E: Exception do
    begin
      FConnected := False;
    end;
  end;
  Result := FConnected;
end;
{ TCPTcpClient.TCPTcpThread }
procedure TCPTcpClient.TCPTcpThread.Execute;
begin
  inherited;
  while not Terminated do
  begin
    if Assigned(FOnExecuteProc) then
      FOnExecuteProc;
  end;
end;
end.
Delphi跨平台TCP库的封装

相关推荐

评论
