一台计算机建立N多个TCP Client Socket与服务端通讯问题(100分)

  • 主题发起人 主题发起人 fftou
  • 开始时间 开始时间
能不能实现5000个客户端同时链接我不知道,但是我知道在2000上是肯定不行!

线程池就是程序启动的时候起若干个空线程,不停的扫描一个公共的任务列表,当任务列表里有N个任务,那么线程池里的线程就会每个线程顺序的抓取一个任务来执行,直到完成.以下是个简单的DEMO

主窗体
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, CheckLst, Unit2, ExtCtrls;


type
TForm1 = class(TForm)
Label1: TLabel;
CheckListBoxTasks: TCheckListBox;
ButtonAddRandomTask: TButton;
ButtonStopCurTask: TButton;
ButtonPauseTask: TButton;
ButtonExit: TButton;
ButtonAddTask: TButton;
EditTaskTime: TEdit;
ButtonDelTask: TButton;
ButtonContinueTask: TButton;
TimerRefreshList: TTimer;
procedure ButtonAddTaskClick(Sender: TObject);
procedure ButtonAddRandomTaskClick(Sender: TObject);
procedure ButtonStopCurTaskClick(Sender: TObject);
procedure ButtonPauseTaskClick(Sender: TObject);
procedure ButtonContinueTaskClick(Sender: TObject);
procedure ButtonDelTaskClick(Sender: TObject);
procedure ButtonExitClick(Sender: TObject);
procedure TimerRefreshListTimer(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
FTaskList: TTaskList;
FTaskIdx: Integer;
FThreads: array of TTaskThread;
public
{ Public declarations }
end;

var
Form1: TForm1;

const
THREAD_COUNT = 4;



implementation

{$R *.dfm}

procedure TForm1.ButtonExitClick(Sender: TObject);
begin
Close;
end;

procedure TForm1.ButtonAddTaskClick(Sender: TObject);
begin
Inc(FTaskIdx);
FTaskList.AddTask(Format('Task%d', [FTaskIdx]),
StrToIntDef(EditTaskTime.Text, 1000));
end;

procedure TForm1.FormCreate(Sender: TObject);
var
I: Integer;
begin
FTaskList := TTaskList.Create;
FTaskIdx := 0;
Randomize;
SetLength(FThreads, THREAD_COUNT);
for I := 0 to High(FThreads) do
FThreads := TTaskThread.Create(FTaskList);
end;

procedure TForm1.FormDestroy(Sender: TObject);
var
I, J: Integer;
begin
for I := 0 to High(FThreads) do
FThreads.Terminate;
for I := 0 to High(FThreads) do
while FThreads.Suspended do
FThreads.Resume;
for I := 0 to High(FThreads) do
begin
//等待线程退出
while WaitForSingleObject(FThreads.Handle, 0) <> WAIT_OBJECT_0 do
for J := 0 to 1000 do
Application.ProcessMessages;
end;

FTaskList.Free;
end;

procedure TForm1.TimerRefreshListTimer(Sender: TObject);
var
AList: TList;
Item: PTaskRecord;
I, C: Integer;
S: string;
begin
AList := FTaskList.LockList;
try
C := CheckListBoxTasks.Count;
if CheckListBoxTasks.Count < AList.Count then
for I := AList.Count - 1 downto CheckListBoxTasks.Count do
begin
Item := AList.Items;
S := Format('%s %d %s %d%%', [Item.Name, Item.Time,
TTaskStatusNames[Item.Status], Round(Item.DoneTimes / Item.Time * 100)]);
CheckListBoxTasks.Items.Add(S);
end;

if CheckListBoxTasks.Count > AList.Count then
begin
C := AList.Count;
for I := CheckListBoxTasks.Count - 1 downto AList.Count - 1 do
CheckListBoxTasks.Items.Delete(I);
end;

for I := C - 1 downto 0 do
begin
Item := AList.Items;
S := Format('%s %d %s %d%%', [Item.Name, Item.Time,
TTaskStatusNames[Item.Status], Round(Item.DoneTimes / Item.Time * 100)]);
if CheckListBoxTasks.Items.Strings <> S then
CheckListBoxTasks.Items.Strings := S;
end;

finally
FTaskList.UnlockList;
end;

for I := 0 to High(FThreads) do
if FThreads.Suspended then
FThreads.CheckTask;
end;

procedure TForm1.ButtonAddRandomTaskClick(Sender: TObject);
begin
Inc(FTaskIdx);
FTaskList.AddTask(Format('Task%d', [FTaskIdx]),
Random(3000) + 1000);
end;

procedure TForm1.ButtonDelTaskClick(Sender: TObject);
var
ID: Integer;
begin
if CheckListBoxTasks.ItemIndex >= 0 then
begin
ID := CheckListBoxTasks.ItemIndex;
if FTaskList.Items[ID].Status <> tsRunning then
CheckListBoxTasks.DeleteSelected;
FTaskList.DelTask(ID);
if CheckListBoxTasks.Count > ID then
CheckListBoxTasks.ItemIndex := ID;
end;
end;

procedure TForm1.ButtonStopCurTaskClick(Sender: TObject);
begin
if CheckListBoxTasks.ItemIndex >= 0 then
FTaskList.TaskCommand(CheckListBoxTasks.ItemIndex, tcStop);
end;

procedure TForm1.ButtonPauseTaskClick(Sender: TObject);
begin
if CheckListBoxTasks.ItemIndex >= 0 then
FTaskList.TaskCommand(CheckListBoxTasks.ItemIndex, tcPause);
end;

procedure TForm1.ButtonContinueTaskClick(Sender: TObject);
begin
if CheckListBoxTasks.ItemIndex >= 0 then
FTaskList.TaskCommand(CheckListBoxTasks.ItemIndex, tcRun);
end;

end.


线程单元
unit Unit2;

interface

uses
Classes, Windows, SysUtils;

type
//状态：未知，等待，运行，暂停，完成
TTaskStatus = (tsUnknow, tsWaiting, tsRunning, tsPause, tsFinished);
//命令：无，运行，暂停，停止
TTaskCommandd = (tcNone, tcRun, tcPause, tcStop);

TTaskRecord = record
Name: string;
Time: Integer;
Command: TTaskCommandd;
Status: TTaskStatus;
DoneTimes: Integer;
end;
PTaskRecord = ^TTaskRecord;

TTaskList = class(TThreadList)
private
function GetItems(Index: Integer): TTaskRecord;
procedure SetItems(Index: Integer; const Value: TTaskRecord);
function SetCount: Integer;
{ Private declarations }
protected

public
destructor Destroy; override;
procedure AddTask(AName: string; ATime: Integer);
procedure DelTask(Index: Integer);
procedure TaskCommand(Index: Integer; Command: TTaskCommandd);
property Count:Integer read SetCount;
property Items[Index: Integer]: TTaskRecord read GetItems write SetItems;
end;


TTaskThread = class(TThread)
private
FTaskList: TTaskList;
FCurTask: PTaskRecord;
FRunTimes: Integer;
function GetTaskFinished: Boolean;
{ Private declarations }
protected
procedure Execute; override;
public
procedure CheckTask;
constructor Create(TaskList: TTaskList);

property TaskFinished: Boolean read GetTaskFinished;
end;


const
TTaskStatusNames: array[TTaskStatus] of string =
('未知', '等待', '运行', '暂停', '完成');

implementation

uses Unit1;

{ TTaskList }

function TTaskList.SetCount: Integer;
var
AList: TList;
begin
AList := LockList;
try
Result := AList.Count;
finally
UnlockList;
end;
end;

procedure TTaskList.AddTask(AName: string; ATime: Integer);
var
AList: TList;
Item: PTaskRecord;
begin
AList := LockList;
try
Item := New(PTaskRecord);
Item.Name := AName;
Item.Time := ATime;
Item.DoneTimes := 0;
Item.Command := tcNone;
Item.Status := tsWaiting;
AList.Add(Item);
finally
UnlockList;
end;
end;

procedure TTaskList.DelTask(Index: Integer);
var
AList: TList;
Item: PTaskRecord;
begin
AList := LockList;
try
Item := AList.Items[Index];
if Item.Status = tsRunning then
begin
Item.Command := tcPause;
Exit;
end;
AList.Remove(Item);
Dispose(Item);
finally
UnlockList;
end;
end;

destructor TTaskList.Destroy;
var
AList: TList;
Item: PTaskRecord;
I: Integer;
begin
AList := LockList;
try
for I := AList.Count - 1 downto 0 do
begin
Item := AList.Items;
//AList.Remove(Item);
Dispose(Item);
end;
finally
UnlockList;
end;
inherited;
end;

function TTaskList.GetItems(Index: Integer): TTaskRecord;
var
AList: TList;
begin
AList := LockList;
try
Result := TTaskRecord(AList.Items[Index]^);
finally
UnlockList;
end;
end;

procedure TTaskList.SetItems(Index: Integer; const Value: TTaskRecord);
var
AList: TList;
begin
AList := LockList;
try
TTaskRecord(AList.Items[Index]^) := Value;
finally
UnlockList;
end;
end;

{ Important: Methods and properties of objects in VCL or CLX can only be used
in a method called using Synchronize, for example,

Synchronize(UpdateCaption);

and UpdateCaption could look like,

procedure TTaskThread.UpdateCaption;
begin
Form1.Caption := 'Updated in a thread';
end; }

procedure TTaskList.TaskCommand(Index: Integer; Command: TTaskCommandd);
var
AList: TList;
Item: PTaskRecord;
begin
AList := LockList;
try
Item := AList.Items[Index];
Item.Command := Command;
finally
UnlockList;
end;
end;

{ TTaskThread }

procedure TTaskThread.CheckTask;
var
AList: TList;
I: Integer;
ATask: PTaskRecord;
begin
if Assigned(FCurTask) then
begin
if FRunTimes >= FCurTask.Time then
begin
FTaskList.LockList;
try
FCurTask.Status := tsFinished;
FCurTask.DoneTimes := FRunTimes;
finally
FTaskList.UnlockList;
end;
FCurTask := nil;
end
else if FCurTask.Command = tcStop then
begin
FTaskList.LockList;
try
FCurTask.Status := tsWaiting;
finally
FTaskList.UnlockList;
end;
FCurTask := nil;
end
else if FCurTask.Command = tcPause then
begin
FTaskList.LockList;
try
FCurTask.Status := tsPause;
finally
FTaskList.UnlockList;
end;
FCurTask := nil;
end;
end;

if not Assigned(FCurTask) then
begin
FRunTimes := 0;
AList := FTaskList.LockList;
try
for I := 0 to AList.Count - 1 do
begin
ATask := AList.Items;
case ATask.Status of
tsWaiting:
begin
FCurTask := ATask;
FCurTask.Status := tsRunning;
end;
tsPause:
if ATask.Command = tcRun then
begin
FCurTask := ATask;
FRunTimes := ATask.DoneTimes;
FCurTask.Command := tcNone;
FCurTask.Status := tsRunning;
end;
end;
if Assigned(FCurTask) then
Break;
end;
finally
FTaskList.UnlockList;
end;
end;

if Assigned(FCurTask) then
while Suspended do
Resume;
end;

constructor TTaskThread.Create(TaskList: TTaskList);
begin
inherited Create(True);
FTaskList := TaskList;
end;

procedure TTaskThread.Execute;
begin
{ Place thread code here }
CheckTask;
while not TaskFinished and not Terminated do
begin
Inc(FRunTimes);

FTaskList.LockList;
try
FCurTask.DoneTimes := FRunTimes;
finally
FTaskList.UnlockList;
end;

Sleep(10);
end;
Suspend;
end;

function TTaskThread.GetTaskFinished: Boolean;
begin
CheckTask;
Result := not Assigned(FCurTask);
end;

end.
 
帮顶!

http://www.source520.com

站长开发推广同盟 站长朋友的终极驿站
同时拥有海量源码电子经典书籍下载

http://www.source520.com/search/search.asp

&quot;编程.站长&quot;论坛搜索引擎-----为中国站长注入动力!
 
您必须登录或注册才可回复。

Similar threads

S
[原]Delphi2010中DataSnap高级技术(5)—建立稳定服务程序之TCP心跳包的使用
回复
0
查看
1K
SUNSTONE的Delphi笔记
S
S
[原]Delphi2010中DataSnap高级技术(5)—建立稳定服务程序之TCP心跳包的使用
回复
0
查看
989
SUNSTONE的Delphi笔记
S
S
[原]Delphi2010中DataSnap高级技术(4)—TCP keepAlive和KeepAliveInterval参数详解
回复
0
查看
1K
SUNSTONE的Delphi笔记
S
S
[原]Delphi2010中DataSnap高级技术(4)—TCP keepAlive和KeepAliveInterval参数详解
回复
0
查看
1K
SUNSTONE的Delphi笔记
S
S
[原]Delphi2010中DataSnap高级技术(2)—DataSnap服务端和客户端发布分发方法
回复
0
查看
982
SUNSTONE的Delphi笔记
S
后退
顶部