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

Posted 2021-11-28 marklove

tags:

篇首语：本文由小常识网(cha138.com)小编为大家整理，主要介绍了分享一个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 := 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.

unit uCPHttpClient; 
interface 
uses System.Classes, System.SysUtils, System.Net.HttpClient, uXGDataList; 
const 
  V_HttpResponse_Success = 200; 
  V_HttpResponse_ConnectFail = 12029; 
  V_HttpResponse_ReadTimeOut = 12002; 
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 = 3; 
  { TCPHttpClient } 
procedure TCPHttpClient.ClearData; 
var 
  I: Integer; 
  AHttpItem: TCPHttpItem; 
begin 
  FRequestList.Lock; 
  try 
    for I := 0 to FRequestList.Count - 1 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 := 0 to FRequestList.Count - 1 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 := 3000; 
  FHttp.ResponseTimeout := 5000; 
  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 := 0; 
  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), #0); 
  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) + 1; 
  AStopIndex := Pos(‘)‘, AEMessage) - 1; 
  Result := StrToIntDef(Copy(AEMessage, AStartIndex, AStopIndex - AStartIndex + 1), MaxInt - 1); 
end; 
function TCPHttpClient.TCPHttpItem.ConvertResponse(const AError: string): TCPHttpResponse; 
begin 
  FillChar(Result, sizeof(TCPHttpResponse), #0); 
  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.

以上是关于分享一个Delphi跨平台Http库的封装,一个Delphi跨平台TCP库的封装的主要内容，如果未能解决你的问题，请参考以下文章

Delphi GDI

Delphi Dll 动态调用例子-仔细看一下

DELPHI实现百度开放平台

Delphi的Indy ICMP封装在DLL之后 PING一个不存在的主机时程序会崩溃

DELPHI XE7 新的并行库

对xlslib库与libxls库的简易封装