分享一個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.