{
单元名：跨平台的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.
