本文整理自网络，侵删。
delphi线程池
// 单元功用: 线程池
// 单元设计: 陈新光
// 设计日期: 2012-09-03
unit ThreadPool;
interface
uses
system.Classes, system.SyncObjs, system.SysUtils,
system.DateUtils, GlobalVar, Vcl.Forms, Winapi.Windows;
type
TWorkThread = class(TThread)
private
FThreadMethod: TThreadMethod;
Fsync: Boolean;
FEvent: THandle;
protected
procedure Execute; override;
public
constructor Create; overload;
destructor Destroy; override;
property Sync: Boolean read Fsync write Fsync;
property ThreadMethod: TThreadMethod read FThreadMethod write FThreadMethod;
procedure Run;
end;
PServerObject = ^TServerObject;
TServerObject = record
ServerObject: TWorkThread;
InUse: Boolean;
end;
TThreadPool = class
private
FCriticalSection: TCriticalSection;
FServerObjects: TList;
FPoolSize: integer;
public
constructor Create; overload;
destructor Destroy; override;
function Lock: TWorkThread;
procedure Unlock(Value: TWorkThread);
procedure Init;
property PoolSize: integer read FPoolSize write FPoolSize;
end;
var
G_ThreadPool: TThreadPool;
implementation
uses CommonFunction;
constructor TThreadPool.Create;
begin
FPoolSize := G_ThreadPoolSize;
FServerObjects := TList.Create;
FCriticalSection := TCriticalSection.Create;
end;
destructor TThreadPool.Destroy;
begin
while FServerObjects.Count > 0 do
begin
Dispose(PServerObject(FServerObjects[0]));
FServerObjects.Delete(0);
end;
FreeAndNil(FServerObjects);
FreeAndNil(FCriticalSection);
inherited Destroy;
end;
procedure TThreadPool.Init;
var
i: integer;
p: PServerObject;
begin
if not Assigned(FServerObjects) then
exit;
for i := 1 to FPoolSize do
begin
New(p);
if Assigned(p) then
begin
p^.ServerObject := TWorkThread.Create;
p^.InUse := False;
FServerObjects.Add(p);
end;
end;
end;
function TThreadPool.Lock: TWorkThread;
var
i: integer;
begin
Result := nil;
try
FCriticalSection.Enter;
try
for i := 0 to FServerObjects.Count - 1 do
begin
if (not PServerObject(FServerObjects[i])^.InUse) then
begin
PServerObject(FServerObjects[i])^.InUse := True;
Result := PServerObject(FServerObjects[i])^.ServerObject;
Break;
end;
end;
finally
FCriticalSection.Leave;
end;
except
on E: Exception do
begin
LogInfo('TThreadPool.Lock' + E.Message);
exit;
end;
end;
end;
procedure TThreadPool.Unlock(Value: TWorkThread);
var
i: integer;
begin
if not Assigned(Value) then
exit;
try
FCriticalSection.Enter;
try
for i := 0 to FServerObjects.Count - 1 do
begin
if Value = PServerObject(FServerObjects[i])^.ServerObject then
begin
PServerObject(FServerObjects[i])^.InUse := False;
// Value.Suspended := True;
Value.ThreadMethod := nil;
Break;
end;
end;
finally
FCriticalSection.Leave;
end;
except
on E: Exception do
begin
LogInfo('TThreadPool.Unlock' + E.Message);
exit;
end;
end;
end;
{ TWorkThread }
constructor TWorkThread.Create;
begin
FEvent := CreateEvent(nil, True, False, nil);
Create(True);
FreeOnTerminate := True;
end;
destructor TWorkThread.Destroy;
begin
CloseHandle(FEvent);
inherited;
end;
procedure TWorkThread.Execute;
begin
inherited;
while not Terminated do
if WaitForSingleObject(FEvent, INFINITE) = WAIT_OBJECT_0 then
if Assigned(FThreadMethod) then
if Fsync then
Synchronize(FThreadMethod)
else
FThreadMethod;
end;
procedure TWorkThread.Run;
begin
PulseEvent(FEvent);
end;
end.
相关阅读 >>
Delphi tmsweb core webhttprequest1提交json数据
Delphi application.title在win7下失效了？
Delphi xe10 fdmemtable 数据保存本地和从本地加载
更多相关阅读请进入《Delphi》频道 >>
