delphi 线程池基础 TSimplePool
1. TSimpleThread
2. TSimpleList
3. 以1，2构成 TSimplePool
用法
先定义: TDoSomeThingThread=class(TSimpleThread) ;
并给 TDoSomeThingThread reintroduce Create 不带参数的构造函数。
再定义 TDoSomeThingPool=class(TSimpleTool<TDoSomeThing>);
最后，只需在 TDoSomeThingPool 写线程调度的代码就行了，可以省不少事。(这部分有待进一步完善)
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.
