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.
uSimpleThread.pas
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.
uSimpleList.pas
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.
uSimplePool.pas
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.
uSyncObjs.pas
时间： 2024-08-02 10:55:25