مشکل بالا رفتن usage cpu تا 100 درصد در استفاده از IdTcpClient

[rayangostar_co]

با سلام خدمت همه دوستان

تو نرم افزارم برای ارسال پیام ها بین کاربران تو شبکه دارم از Indy استفاده میکنم.
با استفاده از Thread پیاده سازیش کردم که به صورت لحظه ای این پیام ها بین کاربران رد و بدل بشه و درست هم کار می کنه.
مشکل اینجاست که Usage Cpu وقتی که کاربران کاننکت میشن بالا میره. !!!!!!!!!!!!!!!!!!!!!!!!!

[یوسف زالی]

سلام.
نه کد گذاشتید، نه پروژه، فقط چند خط کلیات. انتظار چجور کمکی دقیقا دارید؟

[rayangostar_co]

سورس هاش زیاد و طولانیه به خاطز همین نذاشتم.
ببین تو سمت سرور دارم از کد زیر استفاده میکنم


procedure TfrmMain.bnStartClick(Sender: TObject);begin
try
Server.DefaultPort := DEFAULT_PORT;
Server.Active := True;
bnStart.Down := Server.Active;
bnStop.Down := NOT Server.Active;
if Server.Active then
AddFmtLog('<%s> سرور با موفقیت راه اندازی شد', [DateTimeToStr(Now)]);
except
AddFmtLog('خطا در راه اندازی سرور', []);
end;
end;

تو رویداد Execute هم کد زیر


procedure TfrmMain.ServerExecute(AContext: TIdContext);var


LBuffer: TBytes;
tBuff: TBytes;
LMessageBuffer: TBytes;
LDataSize: integer;
LProtocol: TProtocol;
size: integer;
s: string;
LClientContext: TClientContext;


begin


LClientContext := TClientContext(AContext);
LDataSize := LClientContext.Connection.IOHandler.InputBuffer.si ze;
if LDataSize >= szProtocol then
try
LClientContext.Connection.IOHandler.ReadBytes(LBuf fer, szProtocol);
LProtocol := BytesToProtocol(LBuffer);
case LProtocol.Command of
cmdConnect:
begin


AddFmtLog('<آنلاین> %s', [LProtocol.Sender.UserName]);


LClientContext.Client := LProtocol.Sender;
Application.ProcessMessages;
LClientContext.SendClientList;
Application.ProcessMessages;
LClientContext.BroadcastBuffer(LBuffer);
end;
cmdDisconnect:
begin
AddFmtLog('<آفلاین> %s', [LProtocol.Sender.UserName]);
Application.ProcessMessages;
LClientContext.BroadcastBuffer(LBuffer);
end;
cmdMessageBroadcast:
begin
LClientContext.Connection.IOHandler.ReadBytes(LBuf fer,
LProtocol.DataSize);
SetLength(LMessageBuffer, LProtocol.DataSize);
Move(LBuffer[szProtocol], LMessageBuffer[0], LProtocol.DataSize);
AddFmtLog('<%s> %s', [LProtocol.Sender.UserName,
ZDecompressStr(LMessageBuffer)]);
Application.ProcessMessages;
LClientContext.BroadcastBuffer(LBuffer);
end;
cmdMessagePrivate:
begin
LClientContext.Connection.IOHandler.ReadBytes(LBuf fer,
LProtocol.DataSize);
SetLength(LMessageBuffer, LProtocol.DataSize);
Move(LBuffer[szProtocol], LMessageBuffer[0], LProtocol.DataSize);


ClearBuffer(LMessageBuffer);
LMessageBuffer := ZCompressStr(s);
Move(LMessageBuffer[0], LBuffer[szProtocol], LProtocol.DataSize);
AddFmtLog('<private %s -> %s> %s', [LProtocol.Sender.UserName,
LProtocol.Receiver.UserName, ZDecompressStr(LMessageBuffer)]);
Application.ProcessMessages;
LClientContext.SendBuffer(LBuffer, LProtocol.Receiver.ID);
end;


end;
finally
ClearBuffer(LBuffer);
ClearBuffer(LMessageBuffer);
end;
end;

البته تو سایت ها دیدم که گفتن از کامپوننت IdAntiFreeze استفاده کنید - ولی نمیدونم چطور ازش استفاده کنم!!!!

[یوسف زالی]

اون کامپوننت ربطی به یوزیج نداره و فرم هاتون رو از لاک در میاره. یکی بذارید رو فرم، همین.
کدتون باید تریس دقیق بشه اما فکر می کنم بلاک بلاک کدهاش رو کامنت کنید می تونید پیدا کنید که کجا سر چه خطی یوزرج بالا می ره.

[rayangostar_co]

مرحله 1 - سرور استارت (مشکلی نیست)
مرحله 2 - کلاینت اول کاننکت (usage cpu 50)
مرحله 3 - کلاینت دوم کاننکت (Usage cpu 100)

[rayangostar_co]

در ضمن از کلاس زیر هم استفاده می کنم که بین برنامه سرور و کلاینت مشترکه.


unit uDGProtocol;

// Author: Dorin Duminica
// Free to use for free and/or commercial products


interface


uses
SysUtils,
Windows,
Classes,
SyncObjs,
PngImage,
Graphics,
IdContext,
IdTCPConnection,
IdBaseComponent,
IdComponent,
IdCustomTCPServer,
IdTCPServer,
IdTCPClient,
IdYarn;


const
DEFAULT_PORT = 1234;


// define the protocol commands
type
TCommand = (
cmdConnect,
cmdDisconnect,
cmdMessageBroadcast,
cmdMessagePrivate,
cmdScreenShotGet,
cmdScreenShotData);


// client information structure, you can extend this based on your needs
type
TClient = record
UserName: string[50];
ID: TDateTime;
end; // TClient = record


// size of the client information structure
const
szClient = SizeOf(TClient);


// we use this on client side to store client information in the list box
type
TClientObj = class(TObject)
public
ClientData: TClient;
end;


// the communication protocol, this structure holds requests/responses
type
TProtocol = record
// the command
Command: TCommand;
// sender information
Sender: TClient;
// receiver
Receiver: TClient;
// additional data
DataSize: Integer;
end; // TProtocol = record


// size of the protocol structure
const
szProtocol = SizeOf(TProtocol);


// our custom client context
type
TClientContext = class(TIdServerContext)
private
// we use critical section to ensure a single access on the connection
// at a time
FCriticalSection: TCriticalSection;
// client information
FClient: TClient;
public
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn;
AList: TThreadList = nil); override;
destructor Destroy; override;
public
// enter critical section
procedure Lock;
// leave critical section
procedure Unlock;
// broadcast a buffer to connected clients
procedure BroadcastBuffer(const ABuffer: TBytes);
// send a buffer to a specific client
procedure SendBuffer(const ABuffer: TBytes; const AReceiverID: TDateTime);
// send all clients data to this client when he connects
procedure SendClientList;
public
property Client: TClient read FClient write FClient;
end;


type
// connect/disconnect event
TClientStatus = procedure (const AClient: TClient) of Object;


// on message event
TClientMessage = procedure (const AClient: TClient; const AMessage: string) of Object;


// on screen shot receive event
TClientScreenShot = procedure (const AClient: TClient; AImage: TPngImage) of Object;


// our custom listener thread for the client
type
TClientThread = class(TThread)
private
// the TCP client
FTCPClient: TIdTCPClient;
// our client information
FClient: TClient;
// temporary client data holder
FClientSender: TClient;
// temporary buffer for message or screen shot
FTempBuffer: TBytes;
// temporary message holder
FTempMessage: string;
// a critical section
FCriticalSection: TCriticalSection;
// a client is connected
FOnClientConnect: TClientStatus;
// a client is disconnected
FOnClientDisconnect: TClientStatus;
// receive a message
FOnClientMessage: TClientMessage;
// receive a screen shot
FOnClientScreenShotGet: TClientScreenShot;
// procedures that will be executed in synchronization with main thread
procedure DoClientConnect;
procedure DoClientDisconnect;
procedure DoClientMessage;
procedure DoClientScreenShotSend;
procedure DoClientScreenShotGet;
public
// constructor and destructor
constructor Create(ATCPClient: TIdTCPClient);
destructor Destroy; override;
protected
procedure Execute; override;
public
// enter critical section
procedure Lock;
// leave critical section
procedure Unlock;
// notify clients that we're connected
procedure SendConnected;
// notify clients that we disconnect
procedure SendDisconnected;
// broadcast a message
procedure SendMessageBroadcast(const AMessage: string);
// send a private message
procedure SendMessagePrivate(const AReceiver: TClient; const AMessage: string);
// send a screen shot request to a client
procedure SendScreenShotReq(const AReceiver: TClient);
public
property ClientData: TClient read FClient write FClient;
// events
property OnClientConnect: TClientStatus read FOnClientConnect write FOnClientConnect;
property OnClientDisconnect: TClientStatus read FOnClientDisconnect write FOnClientDisconnect;
property OnClientMessage: TClientMessage read FOnClientMessage write FOnClientMessage;
property OnClientScreenShotGet: TClientScreenShot read FOnClientScreenShotGet write FOnClientScreenShotGet;
end;


// converts the protocol structure to an array of bytes
function ProtocolToBytes(const AProtocol: TProtocol): TBytes;
// converts a array of bytes to our protocol
function BytesToProtocol(const ABytes: TBytes): TProtocol;
// fills the memory with zero
procedure InitProtocol(var AProtocol: TProtocol);
// sets the length of the array of bytes to zero
procedure ClearBuffer(var ABuffer: TBytes);


implementation


uses
Forms,
// for message compression/decompression
ZLib;


function ProtocolToBytes(const AProtocol: TProtocol): TBytes;
begin
// set the length of result to the length of the protocol
SetLength(Result, szProtocol);
// move a block of memory from AProtocol to Result
Move(AProtocol, Result[0], szProtocol);
end;


function BytesToProtocol(const ABytes: TBytes): TProtocol;
begin
// move a block of memory from ABytes to Result
Move(ABytes[0], Result, szProtocol);
end;


procedure InitProtocol(var AProtocol: TProtocol);
begin
FillChar(AProtocol, szProtocol, 0);
end;


procedure ClearBuffer(var ABuffer: TBytes);
begin
// set the length to zero
SetLength(ABuffer, 0);
end;


{ TClientContext }


procedure TClientContext.BroadcastBuffer(const ABuffer: TBytes);
var
// loop variable
Index: Integer;
// client list, holds TClientContext objects
LClients: TList;
// temporary client context reference
LClientContext: TClientContext;
begin
// lock the client list
LClients := FContextList.LockList;
try
// for each client
for Index := 0 to LClients.Count -1 do begin
// store locally the current client in the list
LClientContext := TClientContext(LClients[Index]);
// lock it
LClientContext.Lock;
try
// write the buffer
LClientContext.Connection.IOHandler.Write(ABuffer) ;
finally
// unlock
LClientContext.Unlock;
end; // tryf
end; // for Index := 0 to LClients.Count -1 do begin
finally
// unlock client list
FContextList.UnlockList;
end; // tryf
end;


constructor TClientContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn;
AList: TThreadList);
begin
inherited Create(AConnection, AYarn, AList);
// create the critical section
FCriticalSection := TCriticalSection.Create;
end;


destructor TClientContext.Destroy;
begin
// free and nil critical section
FreeAndNil(FCriticalSection);
inherited;
end;


procedure TClientContext.Lock;
begin
FCriticalSection.Enter;
end;


procedure TClientContext.SendBuffer(const ABuffer: TBytes;
const AReceiverID: TDateTime);
var
// loop variable
Index: Integer;
// client list, holds TClientContext objects
LClients: TList;
// temporary client context reference
LClientContext: TClientContext;
begin
LClients := FContextList.LockList;
try
for Index := 0 to LClients.Count -1 do begin
LClientContext := TClientContext(LClients[Index]);
if LClientContext.Client.ID = AReceiverID then begin
LClientContext.Lock;
try
LClientContext.Connection.IOHandler.Write(ABuffer) ;
finally
LClientContext.Unlock;
end;


Break;
end;
end;
finally
FContextList.UnlockList;
end;
end;


procedure TClientContext.SendClientList;
var
Index: Integer;
LBuffer: TBytes;
LClients: TList;
LProtocol: TProtocol;
LClientContext: TClientContext;
begin
InitProtocol(LProtocol);
LProtocol.Command := cmdConnect;
LClients := FContextList.LockList;
try
for Index := 0 to LClients.Count -1 do begin
LClientContext := TClientContext(LClients[Index]);
if LClientContext.Client.ID <> Self.Client.ID then begin
LProtocol.Sender := LClientContext.Client;
LBuffer := ProtocolToBytes(LProtocol);
Lock;
try
Self.Connection.IOHandler.Write(LBuffer);
finally
Unlock;
end;
end;
end;
finally
FContextList.UnlockList;
ClearBuffer(LBuffer);
end; // tryf
end;


procedure TClientContext.Unlock;
begin
FCriticalSection.Leave;
end;


{ TClientThread }


constructor TClientThread.Create(ATCPClient: TIdTCPClient);
begin
// set reference to the TCP client
FTCPClient := ATCPClient;
// create a critical section instance
FCriticalSection := TCriticalSection.Create;
inherited Create(True);
end;


destructor TClientThread.Destroy;
begin
// free and nil the critical section
FreeAndNil(FCriticalSection);
// clear the temporary message
FTempMessage := '';
inherited;
end;


procedure TClientThread.DoClientConnect;
begin
// check if the event is assign
if Assigned(FOnClientConnect) then
// call it
FOnClientConnect(FClientSender);
end;


procedure TClientThread.DoClientDisconnect;
begin
// check if the event is assign
if Assigned(FOnClientDisconnect) then
// call it
FOnClientDisconnect(FClientSender);
end;


procedure TClientThread.DoClientMessage;
begin
// check if the event is assign
if Assigned(FOnClientMessage) then
// call it
FOnClientMessage(FClientSender, FTempMessage);
end;


procedure TClientThread.DoClientScreenShotGet;
var
// temporary memory stream
LStream: TMemoryStream;
// we send, receive PNG images
LPngImage: TPngImage;
begin
// create a memory strema instance
LStream := TMemoryStream.Create;
// create a png image instance
LPngImage := TPngImage.Create;
Lock;
try
// the screen shot is saved in FTempBuffer, write it to stream
LStream.Write(FTempBuffer[0], Length(FTempBuffer));
// reset the position of the stream to the begining
LStream.Position := 0;
// load the png image from the stream
LPngImage.LoadFromStream(LStream);
// if the event is assigned
if Assigned(FOnClientScreenShotGet) then
// call it
FOnClientScreenShotGet(FClientSender, LPngImage);
finally
Unlock;
FreeAndNil(LStream);
FreeAndNil(LPngImage);
ClearBuffer(FTempBuffer);
end; // tryf
end;


procedure TClientThread.DoClientScreenShotSend;
var
LBuffer: TBytes;
// screen shot holder
LBitmap: TBitmap;
// the protocol
LProtocol: TProtocol;
// in memory bytes stream
LBytesStream: TBytesStream;
// the png image, we assign LBitmap to LPngImage so we send less data
LPngImage: TPngImage;
// handle to the desktop canvas
LDesktopCanvasHandle: HDC;
begin
// fill protocol variable with zero's
InitProtocol(LProtocol);
// set the command
LProtocol.Command := cmdScreenShotData;
// set the sender
LProtocol.Sender := FClient;
// set the receiver, the client who requested the screen shot
LProtocol.Receiver := FClientSender;
// create object instances
LBitmap := TBitmap.Create;
LPngImage := TPngImage.Create;
LBytesStream := TBytesStream.Create;
Lock;
try
// get handle to desktop canvas
LDesktopCanvasHandle := GetWindowDC(GetDesktopWindow);
// set the bitmap height and width
LBitmap.Height := Screen.Height;
LBitmap.Width := Screen.Width;
// copy the screen data from desktop to LBitmap
BitBlt(
LBitmap.Canvas.Handle,
0, 0,
Screen.Width, Screen.Height,
LDesktopCanvasHandle,
0, 0,
SRCCOPY);
// convert from bitmap to png image
LPngImage.Assign(LBitmap);
// save the png image to stream
LPngImage.SaveToStream(LBytesStream);
// set the data size in protocol structure
LProtocol.DataSize := LBytesStream.Size;
// convert protocol to array of bytes
LBuffer := ProtocolToBytes(LProtocol);
// increase the size of the buffer to <size of protocl> + <screen shot size>
SetLength(LBuffer, szProtocol + LProtocol.DataSize);
// move screen shot data from the stream to the buffer that we send
Move(LBytesStream.Bytes[0], LBuffer[szProtocol], LProtocol.DataSize);
// send buffer to the server
FTCPClient.IOHandler.Write(LBuffer);
finally
Unlock;
ClearBuffer(LBuffer);
FreeAndNil(LBitmap);
FreeAndNil(LPngImage);
FreeAndNil(LBytesStream);
end;
end;


procedure TClientThread.Execute;
var
LBuffer: TBytes;
LMessage: TBytes;
LDataSize: Integer;
LProtocol: TProtocol;
begin
inherited;
while NOT Terminated and FTCPClient.Connected do begin
LDataSize := FTCPClient.IOHandler.InputBuffer.Size;
if LDataSize >= szProtocol then
try
FTCPClient.IOHandler.ReadBytes(LBuffer, szProtocol);
LProtocol := BytesToProtocol(LBuffer);
FClientSender := LProtocol.Sender;
case LProtocol.Command of
cmdConnect: begin
Synchronize(Self.DoClientConnect);
end;
cmdDisconnect: begin
Synchronize(Self.DoClientDisconnect);
end;
cmdMessageBroadcast, cmdMessagePrivate: begin
FTCPClient.IOHandler.ReadBytes(LMessage, LProtocol.DataSize);
FTempMessage := ZDecompressStr(LMessage);
Synchronize(Self.DoClientMessage);
end;
cmdScreenShotGet: begin
Synchronize(Self.DoClientScreenShotSend);
end;
cmdScreenShotData: begin
FTCPClient.IOHandler.ReadBytes(FTempBuffer, LProtocol.DataSize);
Synchronize(Self.DoClientScreenShotGet);
end;
end;
finally
ClearBuffer(LBuffer);
ClearBuffer(LMessage);
end;


Sleep(50);
end;
end;


procedure TClientThread.Lock;
begin
FCriticalSection.Enter;
end;


procedure TClientThread.SendConnected;
var
LBuffer: TBytes;
LProtocol: TProtocol;
begin
// fill protocol memory with zero's
InitProtocol(LProtocol);
// set the command
LProtocol.Command := cmdConnect;
// set the sender
LProtocol.Sender := FClient;
// convert protocol to array of bytes
LBuffer := ProtocolToBytes(LProtocol);
Lock;
try
// send command to server
FTCPClient.IOHandler.Write(LBuffer);
finally
Unlock;
ClearBuffer(LBuffer);
end; // tryf
end;


procedure TClientThread.SendDisconnected;
var
LBuffer: TBytes;
LProtocol: TProtocol;
begin
InitProtocol(LProtocol);
LProtocol.Command := cmdDisconnect;
LProtocol.Sender := FClient;
LBuffer := ProtocolToBytes(LProtocol);
Lock;
try
FTCPClient.IOHandler.Write(LBuffer);
finally
Unlock;
ClearBuffer(LBuffer);
end;
end;


procedure TClientThread.SendMessageBroadcast(const AMessage: string);
var
LBuffer: TBytes;
LProtocol: TProtocol;
LMessage: TBytes;
begin


InitProtocol(LProtocol);
LMessage := ZCompressStr(AMessage);
LProtocol.Command := cmdMessageBroadcast;
LProtocol.Sender := FClient;


LProtocol.DataSize := Length(LMessage);


LBuffer := ProtocolToBytes(LProtocol);
SetLength(LBuffer, szProtocol + LProtocol.DataSize);


Move(LMessage[0], LBuffer[szProtocol], LProtocol.DataSize);
Lock;
try
FTCPClient.IOHandler.Write(LBuffer);
finally
Unlock;
ClearBuffer(LBuffer);
ClearBuffer(LMessage);
end;
end;


procedure TClientThread.SendMessagePrivate(const AReceiver: TClient;
const AMessage: string);
var
LBuffer: TBytes;
LProtocol: TProtocol;
LMessage: TBytes;
begin
InitProtocol(LProtocol);
LMessage := ZCompressStr(AMessage);
LProtocol.Command := cmdMessagePrivate;
LProtocol.Sender := FClient;
LProtocol.Receiver := AReceiver;
LProtocol.DataSize := Length(LMessage);
LBuffer := ProtocolToBytes(LProtocol);
SetLength(LBuffer, szProtocol + LProtocol.DataSize);
Move(LMessage[0], LBuffer[szProtocol], LProtocol.DataSize);
Lock;
try
FTCPClient.IOHandler.Write(LBuffer);
finally
Unlock;
ClearBuffer(LBuffer);
ClearBuffer(LMessage);
end;
end;


procedure TClientThread.SendScreenShotReq(const AReceiver: TClient);
var
LBuffer: TBytes;
LProtocol: TProtocol;
begin
InitProtocol(LProtocol);
LProtocol.Command := cmdScreenShotGet;
LProtocol.Sender := FClient;
LProtocol.Receiver := AReceiver;
LBuffer := ProtocolToBytes(LProtocol);
Lock;
try
FTCPClient.IOHandler.Write(LBuffer);
finally
Unlock;
ClearBuffer(LBuffer);
end;
end;


procedure TClientThread.Unlock;
begin
FCriticalSection.Leave;
end;


// that's all folks!


end.