分享一个Delphi跨平台Http库的封装,一个Delphi跨平台TCP库的封装

{
  单元名：跨平台的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 :=  to Count -  do
      begin
        ADataRecord := Items[I];
        FreeAndNil(ADataRecord);
      end;
      Clear;
    finally
      FSendDataList.UnlockList;
    end;
  with FRecvDataList.LockList do
    try
      for I :=  to Count -  do
      begin
        ADataRecord := Items[I];
        FreeAndNil(ADataRecord);
      end;
      Clear;
    finally
      FRecvDataList.UnlockList;
    end;
  with FCahceDataList.LockList do
    try
      for I :=  to Count -  do
      begin
        ADataRecord := Items[I];
        FreeAndNil(ADataRecord);
      end;
      Clear;
    finally
      FCahceDataList.UnlockList;
    end;
end;
constructor TCPTcpClient.Create;
begin
  FTCPClient := TIdTCPClient.Create(nil);
  FTCPClient.ConnectTimeout := ;
  FTCPClient.ReadTimeout := ;
  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 >  do
      begin
        ADataRecord := Items[];
        FCahceDataList.Add(ADataRecord);
        Delete();
      end;
    finally
      FRecvDataList.UnlockList;
    end;
  with FCahceDataList.LockList do
    try
      while Count >  do
      begin
        ADataRecord := Items[];
        Delete();
        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();
      ADataSize := FTCPClient.IOHandler.InputBuffer.Size;
      if ADataSize >  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();
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 >  then
        begin
          ADataRecord := Items[];
          Delete();
        end;
      finally
        FSendDataList.UnlockList;
      end;
    if ADataRecord <> nil then
    begin
      FTCPClient.IOHandler.Write(ADataRecord);
      FreeAndNil(ADataRecord);
    end;
  end;
  Sleep();
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.

unit uCPHttpClient;
interface
uses System.Classes, System.SysUtils, System.Net.HttpClient, uXGDataList;
const
  V_HttpResponse_Success = ;
  V_HttpResponse_ConnectFail = ;
  V_HttpResponse_ReadTimeOut = ;
type
  TCPHttpType = (ht_Get, ht_Post, ht_Put);
  TCPHttpResponse = record
    StatusCode: Integer;
    HttpData: string;
    ErrorMsg: string;
  end;
  TOnResponseEvent = reference to procedure(const AHttpResponse: TCPHttpResponse);
  TCPHttpClient = class
  private type
    TCPWorkState = (ws_Wait, ws_Work);
    TCPHttpThread = class(TThread)
    private
      FOnExecuteProc: TProc;
    protected
      procedure Execute; override;
    public
      property OnExecuteProc: TProc read FOnExecuteProc write FOnExecuteProc;
    end;
    TCPHttpItem = class(TObject)
    private
      procedure DoHttpReceiveData(const Sender: TObject; AContentLength, AReadCount: Int64; var Abort: Boolean);
      function ConvertResponse(const AResponse: IHTTPResponse): TCPHttpResponse; overload;
      function ConvertResponse(const AError: string): TCPHttpResponse; overload;
      function ReadErrorIDEMessage(const AEMessage: string): Integer;
      procedure Excute;
    protected
      FThread: TCPHttpThread;
      FHttp: THTTPClient;
      WorkState: TCPWorkState;
      OnResponseEvent: TOnResponseEvent;
      HttpType: TCPHttpType;
      ReqURL, Params, Headers: string;
      TryTimes: Integer;
      procedure Reset;
      procedure Request;
      procedure Stop;
      procedure UpdateError(const AError: string);
      procedure UpdateCompleted(const AResponse: IHTTPResponse);
      procedure SynchNotifyResponse(const AHttpResponse: TCPHttpResponse);
    public
      constructor Create;
      destructor Destroy; override;
    end;
  private
    FRequestList: TCustomDataList<TCPHttpItem>;
    procedure ClearData;
    function GetWorkHttpItem: TCPHttpItem;
  protected
    procedure HttpRequest(const AHttpType: TCPHttpType; const AReqURL, AParams, AHeaders: string;
      const AOnResponseEvent: TOnResponseEvent);
  public
    constructor Create();
    destructor Destroy; override;
    procedure Get(const AReqURL, AParams, AHeaders: string; const AOnResponseEvent: TOnResponseEvent);
    procedure Post(const AReqURL, AParams, AHeaders: string; const AOnResponseEvent: TOnResponseEvent);
  end;
implementation
uses System.Threading, uLogSystem;
const
  V_MaxTryTimes = ;
  { TCPHttpClient }
procedure TCPHttpClient.ClearData;
var
  I: Integer;
  AHttpItem: TCPHttpItem;
begin
  FRequestList.Lock;
  try
    for I :=  to FRequestList.Count -  do
    begin
      AHttpItem := FRequestList.Items[I];
      AHttpItem.FHttp.OnReceiveData := nil;
      AHttpItem.Free;
    end;
    FRequestList.Clear;
  finally
    FRequestList.UnLock;
  end;
end;
constructor TCPHttpClient.Create;
begin
  FRequestList := TCustomDataList<TCPHttpItem>.Create;
end;
destructor TCPHttpClient.Destroy;
begin
  ClearData;
  FRequestList.Free;
  inherited;
end;
procedure TCPHttpClient.Get(const AReqURL, AParams, AHeaders: string; const AOnResponseEvent: TOnResponseEvent);
begin
  HttpRequest(ht_Get, AReqURL, AParams, AHeaders, AOnResponseEvent);
end;
procedure TCPHttpClient.Post(const AReqURL, AParams, AHeaders: string; const AOnResponseEvent: TOnResponseEvent);
begin
  HttpRequest(ht_Post, AReqURL, AParams, AHeaders, AOnResponseEvent);
end;
function TCPHttpClient.GetWorkHttpItem: TCPHttpItem;
var
  I: Integer;
  AHttpItem: TCPHttpItem;
begin
  FRequestList.Lock;
  try
    for I :=  to FRequestList.Count -  do
    begin
      AHttpItem := FRequestList.Items[I];
      if AHttpItem.WorkState = ws_Wait then
      begin
        Result := AHttpItem;
        Result.WorkState := ws_Work;
        Exit;
      end;
    end;
    Result := TCPHttpItem.Create;
    Result.WorkState := ws_Work;
    FRequestList.Add(Result);
  finally
    FRequestList.UnLock;
  end;
end;
procedure TCPHttpClient.HttpRequest(const AHttpType: TCPHttpType; const AReqURL, AParams, AHeaders: string;
  const AOnResponseEvent: TOnResponseEvent);
var
  AHttpItem: TCPHttpItem;
begin
  AHttpItem := GetWorkHttpItem;
  AHttpItem.HttpType := AHttpType;
  AHttpItem.ReqURL := AReqURL;
  AHttpItem.Params := AParams;
  AHttpItem.Headers := AHeaders;
  AHttpItem.OnResponseEvent := AOnResponseEvent;
  AHttpItem.Request;
end;
{ TCPHttpClient.TCPHttpItem }
constructor TCPHttpClient.TCPHttpItem.Create;
begin
  FHttp := THTTPClient.Create;
  FHttp.OnReceiveData := DoHttpReceiveData;
  FHttp.ConnectionTimeout := ;
  FHttp.ResponseTimeout := ;
  WorkState := ws_Wait;
  FThread := nil;
end;
destructor TCPHttpClient.TCPHttpItem.Destroy;
begin
  Reset;
  Stop;
  FHttp.Free;
  inherited;
end;
procedure TCPHttpClient.TCPHttpItem.DoHttpReceiveData(const Sender: TObject; AContentLength, AReadCount: Int64;
  var Abort: Boolean);
begin
end;
procedure TCPHttpClient.TCPHttpItem.Excute;
  procedure HandleException(const AEMessage: string);
  var
    AErrorID: Integer;
  begin
    if FThread.Terminated then
    begin
      WriteLog(ClassName, 'FThread.Terminated true:' + Integer(Self).ToString);
      Exit;
    end;
    Inc(TryTimes);
    AErrorID := ReadErrorIDEMessage(AEMessage);
    if ((AErrorID = V_HttpResponse_ConnectFail) or (AErrorID = V_HttpResponse_ReadTimeOut)) and
      (TryTimes < V_MaxTryTimes) then
      Excute
    else
      UpdateError(AEMessage);
  end;
var
  AHttpURL: string;
  AParamList: TStringList;
  AResponse: IHTTPResponse;
begin
  case HttpType of
    ht_Get:
      begin
        if Params.IsEmpty then
          AHttpURL := ReqURL
        else
          AHttpURL := ReqURL + '?' + Params;
        try
          AResponse := FHttp.Get(AHttpURL);
          UpdateCompleted(AResponse);
        except
          on E: Exception do
          begin
            HandleException(E.Message);
          end;
        end;
      end;
    ht_Post:
      begin
        AHttpURL := ReqURL;
        AParamList := TStringList.Create;
        try
          AParamList.Text := Trim(Params);
          try
            AResponse := FHttp.Post(AHttpURL, AParamList);
            UpdateCompleted(AResponse);
          except
            on E: Exception do
            begin
              HandleException(E.Message);
            end;
          end;
        finally
          AParamList.Free;
        end;
      end;
    ht_Put:
      ;
  end;
end;
procedure TCPHttpClient.TCPHttpItem.Request;
begin
  if not Assigned(FThread) then
  begin
    FThread := TCPHttpThread.Create(True);
    FThread.FreeOnTerminate := False;
    FThread.OnExecuteProc := Excute;
    FThread.Start;
  end
  else
  begin
    if FThread.Suspended then
{$WARN SYMBOL_DEPRECATED OFF}
      FThread.Resume;
{$WARN SYMBOL_DEPRECATED ON}
  end;
end;
procedure TCPHttpClient.TCPHttpItem.Reset;
begin
  TryTimes := ;
  OnResponseEvent := nil;
  WorkState := ws_Wait;
end;
procedure TCPHttpClient.TCPHttpItem.Stop;
begin
  if Assigned(FThread) then
  begin
    if FThread.Suspended then
{$WARN SYMBOL_DEPRECATED OFF}
      FThread.Resume;
{$WARN SYMBOL_DEPRECATED ON}
    FThread.Terminate;
    FThread.WaitFor;
    FThread.Free;
    FThread := nil;
  end;
end;
procedure TCPHttpClient.TCPHttpItem.SynchNotifyResponse(const AHttpResponse: TCPHttpResponse);
var
  AResponse: TCPHttpResponse;
begin
  AResponse := AHttpResponse;
  if AResponse.StatusCode = V_HttpResponse_Success then
    WriteLog(ClassName, Format('%d  %s', [AResponse.StatusCode, AResponse.HttpData]))
  else
    WriteLog(ClassName, Format('%d  %s', [AResponse.StatusCode, AResponse.ErrorMsg]));
  if Assigned(OnResponseEvent) then
    TThread.Synchronize(FThread,
      procedure
      begin
        if FThread.Terminated then
          Exit;
        OnResponseEvent(AResponse);
      end);
end;
procedure TCPHttpClient.TCPHttpItem.UpdateError(const AError: string);
begin
  SynchNotifyResponse(ConvertResponse(AError));
  Reset;
end;
procedure TCPHttpClient.TCPHttpItem.UpdateCompleted(const AResponse: IHTTPResponse);
begin
  if Assigned(AResponse) then
  begin
    SynchNotifyResponse(ConvertResponse(AResponse));
    Reset;
  end
  else
    raise Exception.Create('UpdateCompleted  AResponse is nil');
end;
function TCPHttpClient.TCPHttpItem.ConvertResponse(const AResponse: IHTTPResponse): TCPHttpResponse;
var
  AStringStream: TStringStream;
begin
  FillChar(Result, sizeof(TCPHttpResponse), #);
  Result.StatusCode := AResponse.StatusCode;
  AStringStream := TStringStream.Create('', TEncoding.UTF8);
  try
    AStringStream.LoadFromStream(AResponse.ContentStream);
    if Result.StatusCode = V_HttpResponse_Success then
      Result.HttpData := AStringStream.DataString
    else
      Result.ErrorMsg := AStringStream.DataString;
  finally
    AStringStream.Free;
  end;
end;
function TCPHttpClient.TCPHttpItem.ReadErrorIDEMessage(const AEMessage: string): Integer;
var
  AStartIndex, AStopIndex: Integer;
begin
  AStartIndex := Pos('(', AEMessage) + ;
  AStopIndex := Pos(')', AEMessage) - ;
  Result := StrToIntDef(Copy(AEMessage, AStartIndex, AStopIndex - AStartIndex + ), MaxInt - );
end;
function TCPHttpClient.TCPHttpItem.ConvertResponse(const AError: string): TCPHttpResponse;
begin
  FillChar(Result, sizeof(TCPHttpResponse), #);
  Result.StatusCode := ReadErrorIDEMessage(AError);
  Result.ErrorMsg := AError;
end;
{ TCPHttpClient.TCPHttpThread }
procedure TCPHttpClient.TCPHttpThread.Execute;
begin
  inherited;
  while not Terminated do
  begin
    if Assigned(FOnExecuteProc) then
      FOnExecuteProc;
    if not Terminated then
{$WARN SYMBOL_DEPRECATED OFF}
      Suspend;
{$WARN SYMBOL_DEPRECATED ON}
  end;
end;
end.