delphi 线程池基础 TSimplePool

  1 unit uSimpleThread;
  2 interface
  3 uses
  4   System.Classes, System.SysUtils, System.SyncObjs;
  5 
  6 type
  7 
  8   // 显示信息,调用方法 DoOnStatusMsg(AMsg);
  9   TOnStatusMsg = procedure(AMsg: string) of object;
 10 
 11   // 显示调试信息,一般用于显示出错信息,用法 DoOnDebugMsg(AMsg);
 12   TOnDebugMsg = TOnStatusMsg;
 13 
 14   TSimpleThread = class(TThread)
 15   public type // "执行过程"的类别定义
 16 
 17     TGeneralProc = procedure; // 普通的,即 procedure DoSomeThing;
 18     TObjectProc = procedure of object; // 类的,即 TXxxx.DoSomeThign; 用得多
 19     TAnonymousProc = reference to procedure; // 匿名的
 20   private type
 21     TProcKind = (pkGeneral, pkObject, pkAnonymous); // "执行过程"的类别
 22   private
 23 
 24     FGeneralProc: TGeneralProc;
 25     FObjProc: TObjectProc;
 26     FAnoProc: TAnonymousProc;
 27 
 28     FProcKind: TProcKind;
 29 
 30     FEvent: TEvent; // 用于阻塞，它是一个信号量
 31     FActiveX: boolean; // 是否在线程中支持 Com ,如果你要在线程中访问 IE 的话，就设定为 True
 32 
 33     FOnStatusMsg: TOnStatusMsg;
 34     FOnDebugMsg: TOnDebugMsg;
 35 
 36     FTagID: integer; // 给线程一个代号,在线程池的时候用来作区别
 37     FParam: integer; // 给线程一个参数，方便识别
 38 
 39     procedure SelfStart; // 触发线程运行
 40 
 41     procedure DoExecute; // 这个函数里面运行的代码是“线程空间”
 42     procedure DoOnException(e: exception); // 异常信息显示 调用 DoOnDebugMsg(AMsg);
 43 
 44     procedure SetTagID(const Value: integer);
 45     procedure SetParam(const Value: integer);
 46 
 47     procedure SetOnStatusMsg(const Value: TOnStatusMsg);
 48     procedure SetOnDebugMsg(const Value: TOnDebugMsg);
 49 
 50   protected
 51 
 52     FWaitStop: boolean; // 结束标志，可以在继承类中使用它，以确定线程是否停止运行
 53 
 54     procedure DoOnStatusMsg(AMsg: string); // 显示普通信息
 55     procedure DoOnDebugMsg(AMsg: string); // 显示调式信息
 56 
 57     procedure Execute; override; // 重载 TThread.Execute
 58 
 59     procedure OnThreadProcErr(e: exception); virtual; // 异常发生事件
 60 
 61     procedure WaitThreadStop; // 等待线程结束
 62 
 63     procedure BeforeExecute; virtual; // 看名字,不解释
 64     Procedure AfterExecute; virtual; // 看名字,不解释
 65 
 66     procedure SleepExceptStopped(ATimeOut: Cardinal); // 这个高大上了，要解释一下。
 67     { 有时线程没有任务时，就会休息一会儿，但是，休息的时候，可能会接收到退出线程的指令
 68       此函数就是在休息的时候也检查一下停止指令
 69     }
 70 
 71   public
 72 
 73     // 改变一下 Create 的参数,AllowedActiveX：是否允许线程代码访问 Com
 74     constructor Create(AllowedActiveX: boolean = false); reintroduce;
 75 
 76     destructor Destroy; override;
 77 
 78     procedure ExeProcInThread(AProc: TGeneralProc); overload; // 这三个,对外的接口。
 79     procedure ExeProcInThread(AProc: TObjectProc); overload;
 80     procedure ExeProcInThread(AProc: TAnonymousProc); overload;
 81 
 82     procedure StartThread; virtual;
 83     { 启动线程，一般只调用一次。
 84       以后就由线程的响应事件来执行了
 85     }
 86 
 87     procedure StopThread; virtual; // 停止线程
 88 
 89     property OnStatusMsg: TOnStatusMsg read FOnStatusMsg write SetOnStatusMsg;
 90     property OnDebugMsg: TOnDebugMsg read FOnDebugMsg write SetOnDebugMsg;
 91     property WaitStop: boolean read FWaitStop;
 92     property TagID: integer read FTagID write SetTagID;
 93     property Param: integer read FParam write SetParam;
 94 
 95   end;
 96 
 97 implementation
 98 
 99 uses
100   ActiveX;
101 
102 procedure TSimpleThread.AfterExecute;
103 begin
104 end;
105 
106 procedure TSimpleThread.BeforeExecute;
107 begin
108 end;
109 
110 constructor TSimpleThread.Create(AllowedActiveX: boolean);
111 var
112   BGUID: TGUID;
113 begin
114   inherited Create(false);
115   FActiveX := AllowedActiveX;
116   FreeOnTerminate := false; // 我们要手动Free线程
117   CreateGUID(BGUID);
118   FEvent := TEvent.Create(nil, true, false, GUIDToString(BGUID));
119 end;
120 
121 destructor TSimpleThread.Destroy;
122 begin
123   StopThread; // 先停止
124   WaitThreadStop; // 再等待线程停止
125   {
126     在继承类的 Destroy 中，也要写上这两句. 如:
127     暂时未找到更好的办法，这点代码省不了
128     destructor TXXThread.Destroy;
129     begin
130     StopThread;
131     WaitThreadStop;
132     xxx.Free;
133     Inherited;
134     end;
135   }
136   FEvent.Free;
137   inherited;
138 end;
139 
140 procedure TSimpleThread.DoExecute; // 此函数内执行的代码,就是在多线程空间里运行
141 begin
142   BeforeExecute;
143   repeat
144 
145     FEvent.WaitFor;
146     FEvent.ResetEvent; // 下次waitfor 一直等
147     { 这里尝试了很多些，总 SelfStart 觉得有冲突，经过多次修改并使用证明，
148       没有必要在这里加锁,因为只调用 startThread 一次，剩下的交给线程影应事件
149     }
150 
151     if not Terminated then // 如果线程需要退出
152     begin
153 
154       try
155 
156         case FProcKind of
157           pkGeneral: FGeneralProc;
158           pkObject: FObjProc;
159           pkAnonymous: FAnoProc;
160         end;
161 
162       except
163 
164         on e: exception do
165         begin
166           DoOnException(e);
167         end;
168 
169       end;
170 
171     end;
172 
173   until Terminated;
174   AfterExecute;
175   //代码运行到这里，就表示这个线程不存在了。再也回不去了，必须释放资源了。
176 end;
177 
178 procedure TSimpleThread.DoOnDebugMsg(AMsg: string);
179 begin
180   if Assigned(FOnDebugMsg) then
181     FOnDebugMsg(AMsg);
182 end;
183 
184 procedure TSimpleThread.DoOnException(e: exception);
185 var
186   sErrMsg: string;
187 begin
188   sErrMsg := ‘ClassName:‘ + ClassName + #13#10;
189   sErrMsg := sErrMsg + ‘TagID:‘ + IntToStr(FTagID) + #13#10;
190   sErrMsg := sErrMsg + ‘Param:‘ + IntToStr(Param) + #13#10;
191   sErrMsg := sErrMsg + ‘ErrMsg:‘ + e.Message + #13#10;
192   DoOnDebugMsg(sErrMsg);
193   OnThreadProcErr(e);
194 end;
195 
196 procedure TSimpleThread.DoOnStatusMsg(AMsg: string);
197 begin
198   if Assigned(FOnStatusMsg) then
199     FOnStatusMsg(AMsg);
200 end;
201 
202 procedure TSimpleThread.Execute;
203 begin
204   //是否支持 Com
205   if FActiveX then
206   begin
207     CoInitialize(nil);
208     try
209       DoExecute;
210     finally
211       CoUninitialize;
212     end;
213   end
214   else
215     DoExecute;
216 end;
217 
218 procedure TSimpleThread.ExeProcInThread(AProc: TGeneralProc);
219 begin
220   FGeneralProc := AProc;
221   FProcKind := pkGeneral;
222   SelfStart;
223 end;
224 
225 procedure TSimpleThread.ExeProcInThread(AProc: TObjectProc);
226 begin
227   FObjProc := AProc;
228   FProcKind := pkObject;
229   SelfStart;
230 end;
231 
232 procedure TSimpleThread.ExeProcInThread(AProc: TAnonymousProc);
233 begin
234   FAnoProc := AProc;
235   FProcKind := pkAnonymous;
236   SelfStart;
237 end;
238 
239 procedure TSimpleThread.OnThreadProcErr(e: exception);
240 begin;
241 end;
242 
243 procedure TSimpleThread.SelfStart;
244 begin
245   //经常多次尝试，最终写成这样，运行没有问题
246   if FEvent.WaitFor(0) <> wrSignaled then
247     FEvent.SetEvent; // 让waitfor 不再等
248 end;
249 
250 procedure TSimpleThread.StopThread;
251 begin
252   //继承类的代码中，需要检查 FWaitStop ，来控制线程结束
253   FWaitStop := true;
254 end;
255 
256 procedure TSimpleThread.SetOnDebugMsg(const Value: TOnDebugMsg);
257 begin
258   FOnDebugMsg := Value;
259 end;
260 
261 procedure TSimpleThread.SetOnStatusMsg(const Value: TOnStatusMsg);
262 begin
263   FOnStatusMsg := Value;
264 end;
265 
266 procedure TSimpleThread.SetParam(const Value: integer);
267 begin
268   FParam := Value;
269 end;
270 
271 procedure TSimpleThread.SetTagID(const Value: integer);
272 begin
273   FTagID := Value;
274 end;
275 
276 procedure TSimpleThread.SleepExceptStopped(ATimeOut: Cardinal);
277 var
278   BOldTime: Cardinal;
279 begin
280   // sleep 时检测退出指令,以确保线程顺序退出
281   // 多个线程同时工作，要保证正确退出，确实不容易
282   BOldTime := GetTickCount;
283   while not WaitStop do
284   begin
285     sleep(50);
286     if (GetTickCount - BOldTime) > ATimeOut then
287       break;
288   end;
289 end;
290 
291 procedure TSimpleThread.StartThread;
292 begin
293   FWaitStop := false;
294 end;
295 
296 procedure TSimpleThread.WaitThreadStop;
297 begin
298   //等待线程结束
299   StopThread;
300   Terminate;
301   SelfStart;
302   WaitFor;
303 end;
304 
305 end.

  1 unit uSimpleList;
  2 
  3 interface
  4 
  5 uses
  6   Generics.Collections;
  7 
  8 type
  9 
 10   TSimpleList<T> = class(TList<T>)
 11   private
 12     FCurIndexPos: integer;
 13     function DoPopByIndex(Index: integer): T;
 14     procedure FreeAllItems;
 15     procedure SetCurIndexPos(const Value: integer);
 16   protected
 17     FNeedFreeItem: boolean;
 18     procedure FreeItem(Item: T); virtual; //子类可以重截这个以确定该如何释放
 19   public
 20 
 21     constructor Create;
 22     destructor Destroy; override;
 23 
 24     procedure Lock; //新版的Lock功能值得学习
 25     procedure Unlock; //
 26 
 27     function PopFirst: T; //不解释，下同
 28     function PopLast: T;
 29     function PopByIndex(Index: integer): T;
 30 
 31     procedure ClearAndFreeAllItems; //清空并释放所有的Item
 32     property CurIndexPos: integer read FCurIndexPos write SetCurIndexPos;
 33 
 34   end;
 35 
 36   //加 Constructor 限制是要求 T 要有一个没带参数的Create函数,也就是构造器
 37   TClassSimpleList<T: Class, Constructor> = class(TSimpleList<T>)
 38   protected
 39     procedure FreeItem(Item: T); override;
 40     function AddNewOne: T;// T有了Create 才能写这个
 41   end;
 42 
 43 implementation
 44 
 45 procedure TSimpleList<T>.ClearAndFreeAllItems;
 46 begin
 47   FreeAllItems;
 48   clear;
 49 end;
 50 
 51 constructor TSimpleList<T>.Create;
 52 begin
 53   inherited;
 54   FNeedFreeItem := true;
 55   FCurIndexPos := -1;
 56 end;
 57 
 58 destructor TSimpleList<T>.Destroy;
 59 begin
 60   FreeAllItems;
 61   inherited;
 62 end;
 63 
 64 function TSimpleList<T>.DoPopByIndex(Index: integer): T;
 65 begin
 66   if (index >= 0) and (index <= count - 1) then
 67   begin
 68     result := items[index];
 69     Delete(index);
 70     Exit;
 71   end;
 72   result := T(nil);
 73 end;
 74 
 75 procedure TSimpleList<T>.FreeAllItems;
 76 var
 77   Item: T;
 78 begin
 79   if FNeedFreeItem then
 80   begin
 81     FCurIndexPos := -1;
 82     for Item in self do
 83       FreeItem(Item);
 84   end;
 85 end;
 86 
 87 procedure TSimpleList<T>.FreeItem(Item: T);
 88 begin
 89   // 假设 T 是 PMyRec =^TMyRec  TMyRec=record;
 90   // 这个写法对吗？
 91   // if GetTypeKind(T) = tkPointer then
 92   // begin
 93   // Dispose(Pointer(Pointer(@Item)^));
 94   // end;
 95   // 此写法未认真测试所以不使用。
 96   // 如果 Item 是指针，我在继承类中的 FreeItem 中写 Dispose(Item);
 97 end;
 98 
 99 procedure TSimpleList<T>.Lock;
100 begin
101   system.TMonitor.Enter(self);
102 end;
103 
104 procedure TSimpleList<T>.Unlock;
105 begin
106   system.TMonitor.Exit(self);
107 end;
108 
109 function TSimpleList<T>.PopByIndex(Index: integer): T;
110 begin
111   result := DoPopByIndex(index);
112 end;
113 
114 function TSimpleList<T>.PopFirst: T;
115 begin
116   result := DoPopByIndex(0);
117 end;
118 
119 function TSimpleList<T>.PopLast: T;
120 begin
121   result := DoPopByIndex(count - 1);
122 end;
123 
124 procedure TSimpleList<T>.SetCurIndexPos(const Value: integer);
125 begin
126   FCurIndexPos := Value;
127 end;
128 
129 { TThreadClassList<T> }
130 
131 function TClassSimpleList<T>.AddNewOne: T;
132 begin
133   result := T.Create();
134   Add(result);
135 end;
136 
137 procedure TClassSimpleList<T>.FreeItem(Item: T);
138 begin
139   Item.Free;
140 end;
141 
142 end.

  1 unit uSimplePool;
  2 
  3 interface
  4 
  5 uses
  6   uSimpleThread, uSimpleList, uSyncObjs, System.Generics.Collections;
  7 
  8 Type
  9 
 10   TSimplePool<T: TSimpleThread, Constructor> = class
 11   private Type
 12     TWorkThreadList = Class(TClassSimpleList<T>);
 13   private
 14 
 15     FOnStatusMsg: TOnStatusMsg;
 16     FOnDebugMsg: TOnDebugMsg;
 17     FMaxThreadCount: integer;
 18 
 19     procedure SetOnDebugMsg(const Value: TOnDebugMsg);
 20     procedure SetOnStatusMsg(const Value: TOnStatusMsg);
 21     procedure SetMaxThreadCount(const Value: integer);
 22     procedure InitThreadList(AThreadCount: integer);
 23 
 24   protected
 25 
 26     FStopThreadCount: integer;
 27     FWorkThreadList: TWorkThreadList;
 28     FEvent: TSuperEvent; //提供给继承类阻塞用
 29 
 30     procedure DoOnStatusMsg(AMsg: string);
 31     procedure DoOnDebugMsg(AMsg: string);
 32     procedure OnEachNewWorkThread(AWorkThread: T); virtual;
 33 
 34   public
 35 
 36     property OnStatusMsg: TOnStatusMsg read FOnStatusMsg write SetOnStatusMsg;
 37     property OnDebugMsg: TOnDebugMsg read FOnDebugMsg write SetOnDebugMsg;
 38 
 39     constructor Create;
 40     destructor Destroy; override;
 41 
 42     procedure StartWork; virtual;
 43     procedure StopWork; virtual;
 44 
 45     property MaxThreadCount: integer read FMaxThreadCount write SetMaxThreadCount default 5;
 46 
 47   end;
 48 
 49 const
 50   cnDefaultWorkThreadCount = 5;
 51   cnLimitedWorkTreadCount = 20;
 52 
 53 implementation
 54 
 55 { TSimplePool }
 56 
 57 procedure TSimplePool<T>.DoOnDebugMsg(AMsg: string);
 58 begin
 59   if Assigned(FOnDebugMsg) then
 60     FOnDebugMsg(AMsg);
 61 end;
 62 
 63 procedure TSimplePool<T>.DoOnStatusMsg(AMsg: string);
 64 begin
 65   if Assigned(FOnStatusMsg) then
 66     FOnStatusMsg(AMsg);
 67 end;
 68 
 69 procedure TSimplePool<T>.InitThreadList(AThreadCount: integer);
 70 var
 71   i, nTagID: integer;
 72   B: T;
 73 begin
 74   nTagID := FWorkThreadList.Count;
 75   for i := 0 to AThreadCount do
 76   begin
 77     B := FWorkThreadList.AddNewOne;
 78     B.TagID := nTagID;
 79     B.OnStatusMsg := self.DoOnStatusMsg;
 80     B.OnDebugMsg := self.DoOnDebugMsg;
 81     OnEachNewWorkThread(B);
 82     inc(nTagID);
 83   end;
 84 end;
 85 
 86 procedure TSimplePool<T>.OnEachNewWorkThread(AWorkThread: T);
 87 begin
 88 end;
 89 
 90 procedure TSimplePool<T>.SetMaxThreadCount(const Value: integer);
 91 var
 92   ndiff: integer;
 93 begin
 94   FMaxThreadCount := Value;
 95   if FMaxThreadCount > cnLimitedWorkTreadCount then
 96     FMaxThreadCount := cnLimitedWorkTreadCount;
 97   if FMaxThreadCount <= 0 then
 98     FMaxThreadCount := 1;
 99   ndiff := FMaxThreadCount - FWorkThreadList.Count;
100   InitThreadList(ndiff);
101 end;
102 
103 procedure TSimplePool<T>.SetOnDebugMsg(const Value: TOnDebugMsg);
104 begin
105   FOnDebugMsg := Value;
106 end;
107 
108 procedure TSimplePool<T>.SetOnStatusMsg(const Value: TOnStatusMsg);
109 begin
110   FOnStatusMsg := Value;
111 end;
112 
113 procedure TSimplePool<T>.StartWork;
114 var
115   i: integer;
116 begin
117   for i := 1 to MaxThreadCount do
118   begin
119     FWorkThreadList[i].StartThread;
120   end;
121 end;
122 
123 procedure TSimplePool<T>.StopWork;
124 var
125   B: T;
126 begin
127   for B in FWorkThreadList do
128   begin
129     B.StopThread;
130   end;
131 end;
132 
133 constructor TSimplePool<T>.Create;
134 begin
135   inherited Create;
136   FMaxThreadCount := 5;
137   FEvent := TSuperEvent.Create;
138   FWorkThreadList := TWorkThreadList.Create;
139   InitThreadList(cnDefaultWorkThreadCount);
140 end;
141 
142 destructor TSimplePool<T>.Destroy;
143 begin
144   FWorkThreadList.Free;
145   FEvent.Free;
146   inherited Destroy;
147 end;
148 
149 end.

 1 unit uSyncObjs;
 2 
 3 interface
 4 
 5 uses
 6   SyncObjs;
 7 
 8 Type
 9 
10   TSuperEvent = class(TEvent)
11   public
12     constructor Create; reintroduce;
13   end;
14 
15 implementation
16 
17 { TSuperEvent }
18 uses
19   SysUtils;
20 
21 constructor TSuperEvent.Create;
22 var
23   BGUID: TGUID;
24 begin
25   CreateGUID(BGUID);
26   inherited Create(nil, true, false, GUIDToString(BGUID));
27 end;
28 
29 end.