请教一个Indy中线程列表使用问题。 ( 积分: 50 )

我写了一个这样的TCP服务程序，为什么客户端一连接，CPU占用马上到100%，请教如何解决？

原程序如下：
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IdBaseComponent, IdComponent, IdTCPServer, IdContext, IdThreadSafe,
IdScheduler, IdSchedulerOfThread, IdSchedulerOfThreadDefault;

type

PClient = ^TClient;
TClient = record // Object holding data of client (see events)
DNS : String[20]; { Hostname }
Connected, { Time of connect }
LastAction : TDateTime; { Time of last transaction }
Thread : Pointer; { Pointer to thread }
end;
TForm1 = class(TForm)
Button1: TButton;
IdTCPServer1: TIdTCPServer;
ListBox1: TListBox;
Button2: TButton;
IdSchedulerOfThreadDefault1: TIdSchedulerOfThreadDefault;
procedure IdTCPServer1Disconnect(AContext: TIdContext);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure IdTCPServer1Connect(AContext: TIdContext);
procedure Button2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
Clients : TIdThreadSafeList;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
IdTCPServer1.Active := true;
ListBox1.Items.Add('服务启动');
Clients := TIdThreadSafeList.Create;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
IdTCPServer1.Active := false;
ListBox1.Items.Add('服务停止');
end;

procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
NewClient: PClient;
begin
GetMem(NewClient, SizeOf(TClient));

NewClient.DNS := AContext.Connection.Socket.Binding.PeerIP;
NewClient.Connected := Now;
NewClient.LastAction := NewClient.Connected;
NewClient.Thread :=AContext;

AContext.Data:=TObject(NewClient);

try
Clients.LockList.Add(NewClient);
finally
Clients.UnlockList;
end;
ListBox1.Items.Add(TimeToStr(Time)+' Connection from "'+NewClient.DNS+'"')

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
IdTCPServer1.Active := False;
Clients.Free;
end;

procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
var
ActClient: PClient;

begin
ActClient := PClient(AContext.Data);
ListBox1.items.Add (TimeToStr(Time)+' Disconnect from "'+ActClient^.DNS+'"');
try
Clients.LockList.Remove(ActClient);
finally
Clients.UnlockList;
end;
FreeMem(ActClient);
AContext.Data := nil;
end;

end.

我写了一个这样的TCP服务程序，为什么客户端一连接，CPU占用马上到100%，请教如何解决？

原程序如下：
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IdBaseComponent, IdComponent, IdTCPServer, IdContext, IdThreadSafe,
IdScheduler, IdSchedulerOfThread, IdSchedulerOfThreadDefault;

type

PClient = ^TClient;
TClient = record // Object holding data of client (see events)
DNS : String[20]; { Hostname }
Connected, { Time of connect }
LastAction : TDateTime; { Time of last transaction }
Thread : Pointer; { Pointer to thread }
end;
TForm1 = class(TForm)
Button1: TButton;
IdTCPServer1: TIdTCPServer;
ListBox1: TListBox;
Button2: TButton;
IdSchedulerOfThreadDefault1: TIdSchedulerOfThreadDefault;
procedure IdTCPServer1Disconnect(AContext: TIdContext);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure IdTCPServer1Connect(AContext: TIdContext);
procedure Button2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
Clients : TIdThreadSafeList;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
IdTCPServer1.Active := true;
ListBox1.Items.Add('服务启动');
Clients := TIdThreadSafeList.Create;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
IdTCPServer1.Active := false;
ListBox1.Items.Add('服务停止');
end;

procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
NewClient: PClient;
begin
GetMem(NewClient, SizeOf(TClient));

NewClient.DNS := AContext.Connection.Socket.Binding.PeerIP;
NewClient.Connected := Now;
NewClient.LastAction := NewClient.Connected;
NewClient.Thread :=AContext;

AContext.Data:=TObject(NewClient);

try
Clients.LockList.Add(NewClient);
finally
Clients.UnlockList;
end;
ListBox1.Items.Add(TimeToStr(Time)+' Connection from "'+NewClient.DNS+'"')

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
IdTCPServer1.Active := False;
Clients.Free;
end;

procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
var
ActClient: PClient;

begin
ActClient := PClient(AContext.Data);
ListBox1.items.Add (TimeToStr(Time)+' Disconnect from "'+ActClient^.DNS+'"');
try
Clients.LockList.Remove(ActClient);
finally
Clients.UnlockList;
end;
FreeMem(ActClient);
AContext.Data := nil;
end;

end.

首先说明，我没看上面的程序，但我知道和FTP类似，FTP有两个线程：一个用于等待客户连接，一个用来处理传输数据；可能是你的其中之一个线程太活跃了，占用的CUP太多导致以上原因；

如果不使用线程列表，就不会出现这种情况，是不是线程列表的使用方法不对？

问题已解决。

接受答案了.