delphi 自我删除和线程池（1000行代码，需要仔细研究）

1. unit Unit4;  
2.   
3. interface  
4.   
5. uses  
6.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,  
7.   Dialogs, StdCtrls, ShellAPI, ShlObj, uThreadPool;  
8.   
9. type  
10.   TForm4 = class(TForm)  
11.     Button1: TButton;  
12.     Button2: TButton;  
13.     Button3: TButton;  
14.     Button4: TButton;  
15.     procedure Button1Click(Sender: TObject);  
16.     procedure FormCreate(Sender: TObject);  
17.     procedure Button2Click(Sender: TObject);  
18.     procedure Button3Click(Sender: TObject);  
19.     procedure Button4Click(Sender: TObject);  
20.   private  
21.     { Private declarations }  
22.   public  
23.     { Public declarations }  
24.     procedure MyFun(Sender: TThreadsPool; WorkItem: TWorkItem;  
25.       aThread: TProcessorThread);  
26.   end;  
27.   TRecvCommDataWorkItem=class(TWorkItem)  
28.   
29.   end;  
30.   
31. function selfdel: Boolean;  
32. procedure deleteSelf;  
33.   
34. var  
35.   Form4: TForm4;  
36.   
37. implementation  
38.   
39. {$R *.dfm}  
40.   
41. procedure TForm4.Button1Click(Sender: TObject);  
42.   
43. var  
44.   BatchFile: TextFile;  
45.   BatchFileName: string;  
46.   ProcessInfo: TProcessInformation;  
47.   StartUpInfo: TStartupInfo;  
48. begin  
49.   BatchFileName := ExtractFilePath(ParamStr(0)) + ‘_deleteme.bat‘;  
50.   AssignFile(BatchFile, BatchFileName);  
51.   Rewrite(BatchFile);  
52.   Writeln(BatchFile, ‘:try‘);  
53.   Writeln(BatchFile, ‘del "‘ + ParamStr(0) + ‘"‘);  
54.   Writeln(BatchFile, ‘if exist "‘ + ParamStr(0) + ‘"‘ + ‘ goto try‘);  
55.   Writeln(BatchFile, ‘del %0‘);  
56.   CloseFile(BatchFile);  
57.   FillChar(StartUpInfo, SizeOf(StartUpInfo), $00);  
58.   StartUpInfo.dwFlags := STARTF_USESHOWWINDOW;  
59.   StartUpInfo.wShowWindow := SW_HIDE;  
60.   if CreateProcess(nil, PChar(BatchFileName), nil, nil, False,  
61.     IDLE_PRIORITY_CLASS, nil, nil, StartUpInfo, ProcessInfo) then  
62.   begin  
63.     CloseHandle(ProcessInfo.hThread);  
64.     CloseHandle(ProcessInfo.hProcess);  
65.   end;  
66.   Application.Terminate;  
67. end;  
68.   
69. procedure TForm4.Button2Click(Sender: TObject);  
70. var  
71.   f: TextFile;  
72. begin  
73.   AssignFile(f, ‘.\delme.bat‘);  
74.   Rewrite(f);  
75.   Writeln(f, ‘@echo off‘);  
76.   Writeln(f, ‘:loop‘);  
77.   Writeln(f, ‘del "‘ + Application.ExeName + ‘"‘);  
78.   Writeln(f, ‘if exist .\file.exe goto loop‘);  
79.   Writeln(f, ‘del .\delme.bat‘);  
80.   CloseFile(f);  
81.   winexec(‘.\delme.bat‘, SW_HIDE);  
82.   close;  
83.   Application.Terminate;  
84. end;  
85.   
86. procedure TForm4.Button3Click(Sender: TObject);  
87. begin  
88.   selfdel();  
89. end;  
90.   
91. procedure TForm4.Button4Click(Sender: TObject);  
92. var  
93.   FThreadPool: TThreadsPool;  
94.   AWorkItem: TRecvCommDataWorkItem; // 继承自TWorkItem  
95. begin  
96.   // 创建线程池  
97.   FThreadPool := TThreadsPool.Create(Self); // 创建线程池  
98.   FThreadPool.ThreadsMin := 5; // 初始工作线程数  
99.   FThreadPool.ThreadsMax := 50; // 最大允许工作线程数  
100.   FThreadPool.OnProcessRequest := MyFun; // 线程工作函数(DealwithCommRecvData在工作者线程的Execute方法中被调用)  
101.   
102.   // 使用线程池  
103.   AWorkItem := TRecvCommDataWorkItem.Create;  
104.   
105.   FThreadPool.AddRequest(AWorkItem); // 向线程池分配一个任务 end;  
106.   
107.   FThreadPool.Free;  
108. end;  
109.   
110. function selfdel: Boolean;  
111. var  
112.   sei: TSHELLEXECUTEINFO;  
113.   szModule: PChar;  
114.   szComspec: PChar;  
115.   szParams: PChar;  
116. begin  
117.   szModule := AllocMem(MAX_PATH);  
118.   szComspec := AllocMem(MAX_PATH);  
119.   szParams := AllocMem(MAX_PATH); // get file path names:  
120.   if ((GetModuleFileName(0, szModule, MAX_PATH) <> 0) and  
121.       (GetShortPathName(szModule, szModule, MAX_PATH) <> 0) and  
122.       (GetEnvironmentVariable(‘COMSPEC‘, szComspec, MAX_PATH) <> 0)) then  
123.   begin // set command shell parameters  
124.     lstrcpy(szParams, ‘/c del ‘);  
125.     lstrcat(szParams, szModule); // set struct members  
126.     sei.cbSize := SizeOf(sei);  
127.     sei.Wnd := 0;  
128.     sei.lpVerb := ‘Open‘;  
129.     sei.lpFile := szComspec;  
130.     sei.lpParameters := szParams;  
131.     sei.lpDirectory := nil;  
132.     sei.nShow := SW_HIDE;  
133.     sei.fMask := SEE_MASK_NOCLOSEPROCESS; // invoke command shell  
134.     if (ShellExecuteEx(@sei)) then  
135.     begin // suppress command shell process until program exits  
136.       SetPriorityClass(sei.hProcess, HIGH_PRIORITY_CLASS);  
137.       // IDLE_PRIORITY_CLASS);  
138.       SetPriorityClass(GetCurrentProcess(), REALTIME_PRIORITY_CLASS);  
139.       SetThreadPriority(GetCurrentThread(), THREAD_PRIORITY_TIME_CRITICAL);  
140.       // notify explorer shell of deletion  
141.       SHChangeNotify(SHCNE_Delete, SHCNF_PATH, szModule, nil);  
142.       Result := True;  
143.     end  
144.     else  
145.       Result := False;  
146.   end  
147.   else  
148.     Result := False;  
149. end;  
150.   
151. procedure TForm4.FormCreate(Sender: TObject);  
152. begin  
153.   // Button1Click(Sender);  
154.   // Button2Click(Sender);  
155.   // selfdel();  
156.   // Application.Terminate;  
157.   // deleteSelf;  
158. end;  
159.   
160. procedure TForm4.MyFun(Sender: TThreadsPool; WorkItem: TWorkItem;  
161.   aThread: TProcessorThread);  
162. var  
163.   i: Integer;  
164. begin  
165.   for i := 0 to 500 do  
166.   begin  
167.     Form4.Canvas.Lock;  
168.     Form4.Canvas.TextOut(10, 10,  
169.       ‘threadid=‘ + IntToStr(GetCurrentThreadId()) + ‘,‘ + IntToStr(i));  
170.     Form4.Canvas.Unlock;  
171.     Sleep(10);  
172.   end;  
173. end;  
174.   
175. // http://www.52delphi.com/List.asp?ID=364&Page=3  
176. procedure deleteSelf;  
177. var  
178.   hModule: THandle;  
179.   szModuleName: array [0 .. MAX_PATH] of char;  
180.   hKrnl32: THandle;  
181.   pExitProcess, pdeleteFile, pFreeLibrary, pUnmapViewOfFile: pointer;  
182.   ExitCode: UINT;  
183. begin  
184.   hModule := GetModuleHandle(nil);  
185.   GetModuleFileName(hModule, szModuleName, SizeOf(szModuleName));  
186.   hKrnl32 := GetModuleHandle(‘kernel32‘);  
187.   pExitProcess := GetProcAddress(hKrnl32, ‘ExitProcess‘);  
188.   pdeleteFile := GetProcAddress(hKrnl32, ‘deleteFileA‘);  
189.   pFreeLibrary := GetProcAddress(hKrnl32, ‘FreeLibrary‘);  
190.   pUnmapViewOfFile := GetProcAddress(hKrnl32, ‘UnmapViewOfFile‘);  
191.   ExitCode := system.ExitCode;  
192.   if ($80000000 and GetVersion()) <> 0 then // Win95, 98, Me  
193.   asm lea eax, szModuleName  
194.   push ExitCode  
195.   push 0  
196.   push eax  
197.   push pExitProcess  
198.   push hModule  
199.   push pdeleteFile  
200.   push pFreeLibrary  
201.   ret  
202.    end  
203.   else  
204.   begin  
205.     CloseHandle(THandle(4));  
206.       asm lea eax, szModuleName  
207.       push ExitCode  
208.       push 0  
209.       push eax  
210.       push pExitProcess  
211.       push hModule  
212.       push pdeleteFile  
213.       push pUnmapViewOfFile  
214.        ret end  
215.   end  
216. end;  
217.   
218. end.  

1. unit uThreadPool;  
2.   
3. {   aPool.AddRequest(TMyRequest.Create(RequestParam1, RequestParam2, ...)); }  
4.   
5. interface  
6. uses  
7.   Windows,  
8.   Classes;  
9.   
10. // 是否记录日志  
11. // {$DEFINE NOLOGS}  
12.   
13. type  
14.   TCriticalSection = class(TObject)  
15.   protected  
16.     FSection: TRTLCriticalSection;  
17.   public  
18.     constructor Create;  
19.     destructor Destroy; override;  
20.     // 进入临界区  
21.     procedure Enter;  
22.     // 离开临界区  
23.     procedure Leave;  
24.     // 尝试进入  
25.     function TryEnter: Boolean;  
26.   end;  
27.   
28. type  
29.   // 储存请求数据的基本类  
30.   TWorkItem = class(TObject)  
31.   public  
32.     // 是否有重复任务  
33.     function IsTheSame(DataObj: TWorkItem): Boolean; virtual;  
34.     // 如果 NOLOGS 被定义，则禁用。  
35.     function TextForLog: string; virtual;  
36.   end;  
37.   
38. type  
39.   TThreadsPool = class;  
40.   
41.   //线程状态  
42.   TThreadState = (tcsInitializing, tcsWaiting, tcsGetting, tcsProcessing,  
43.     tcsProcessed, tcsTerminating, tcsCheckingDown);  
44.   // 工作线程仅用于线程池内， 不要直接创建并调用它。  
45.   TProcessorThread = class(TThread)  
46.   private  
47.     // 创建线程时临时的Event对象, 阻塞线程直到初始化完成  
48.     hInitFinished: THandle;  
49.     // 初始化出错信息  
50.     sInitError: string;  
51.     // 记录日志  
52.     procedure WriteLog(const Str: string; Level: Integer = 0);  
53.   protected  
54.     // 线程临界区同步对像  
55.     csProcessingDataObject: TCriticalSection;  
56.     // 平均处理时间  
57.     FAverageProcessing: Integer;  
58.     // 等待请求的平均时间  
59.     FAverageWaitingTime: Integer;  
60.     // 本线程实例的运行状态  
61.     FCurState: TThreadState;  
62.     // 本线程实例所附属的线程池  
63.     FPool: TThreadsPool;  
64.     // 当前处理的数据对像。  
65.     FProcessingDataObject: TWorkItem;  
66.     // 线程停止 Event, TProcessorThread.Terminate 中开绿灯  
67.     hThreadTerminated: THandle;  
68.     uProcessingStart: DWORD;  
69.     // 开始等待的时间, 通过 GetTickCount 取得。  
70.     uWaitingStart: DWORD;  
71.     // 计算平均工作时间  
72.     function AverageProcessingTime: DWORD;  
73.     // 计算平均等待时间  
74.     function AverageWaitingTime: DWORD;  
75.     procedure Execute; override;  
76.     function IamCurrentlyProcess(DataObj: TWorkItem): Boolean;  
77.     // 转换枚举类型的线程状态为字串类型  
78.     function InfoText: string;  
79.     // 线程是否长时间处理同一个请求？（已死掉？）  
80.     function IsDead: Boolean;  
81.     // 线程是否已完成当成任务  
82.     function isFinished: Boolean;  
83.     // 线程是否处于空闲状态  
84.     function isIdle: Boolean;  
85.     // 平均值校正计算。  
86.     function NewAverage(OldAvg, NewVal: Integer): Integer;  
87.   public  
88.     Tag: Integer;  
89.     constructor Create(APool: TThreadsPool);  
90.     destructor Destroy; override;  
91.     procedure Terminate;  
92.   end;  
93.   
94.   // 线程初始化时触发的事件  
95.   TProcessorThreadInitializing = procedure(Sender: TThreadsPool; aThread:  
96.     TProcessorThread) of object;  
97.   // 线程结束时触发的事件  
98.   TProcessorThreadFinalizing = procedure(Sender: TThreadsPool; aThread:  
99.     TProcessorThread) of object;  
100.   // 线程处理请求时触发的事件  
101.   TProcessRequest = procedure(Sender: TThreadsPool; WorkItem: TWorkItem;  
102.     aThread: TProcessorThread) of object;  
103.   TEmptyKind = (  
104.     ekQueueEmpty, //任务被取空后  
105.     ekProcessingFinished // 最后一个任务处理完毕后  
106.     );  
107.   // 任务队列空时触发的事件  
108.   TQueueEmpty = procedure(Sender: TThreadsPool; EmptyKind: TEmptyKind) of  
109.     object;  
110.   
111.   TThreadsPool = class(TComponent)  
112.   private  
113.     csQueueManagment: TCriticalSection;  
114.     csThreadManagment: TCriticalSection;  
115.     FProcessRequest: TProcessRequest;  
116.     FQueue: TList;  
117.     FQueueEmpty: TQueueEmpty;  
118.     // 线程超时阀值  
119.     FThreadDeadTimeout: DWORD;  
120.     FThreadFinalizing: TProcessorThreadFinalizing;  
121.     FThreadInitializing: TProcessorThreadInitializing;  
122.     // 工作中的线程  
123.     FThreads: TList;  
124.     // 执行了 terminat 发送退出指令, 正在结束的线程.  
125.     FThreadsKilling: TList;  
126.     // 最少, 最大线程数  
127.     FThreadsMax: Integer;  
128.     // 最少, 最大线程数  
129.     FThreadsMin: Integer;  
130.     // 池平均等待时间  
131.     function PoolAverageWaitingTime: Integer;  
132.     procedure WriteLog(const Str: string; Level: Integer = 0);  
133.   protected  
134.     FLastGetPoint: Integer;  
135.     // Semaphore， 统计任务队列  
136.     hSemRequestCount: THandle;  
137.     // Waitable timer. 每30触发一次的时间量同步  
138.     hTimCheckPoolDown: THandle;  
139.     // 线程池停机（检查并清除空闲线程和死线程）  
140.     procedure CheckPoolDown;  
141.     // 清除死线程，并补充不足的工作线程  
142.     procedure CheckThreadsForGrow;  
143.     procedure DoProcessed;  
144.     procedure DoProcessRequest(aDataObj: TWorkItem; aThread: TProcessorThread);  
145.       virtual;  
146.     procedure DoQueueEmpty(EmptyKind: TEmptyKind); virtual;  
147.     procedure DoThreadFinalizing(aThread: TProcessorThread); virtual;  
148.     // 执行事件  
149.     procedure DoThreadInitializing(aThread: TProcessorThread); virtual;  
150.     // 释放 FThreadsKilling 列表中的线程  
151.     procedure FreeFinishedThreads;  
152.     // 申请任务  
153.     procedure GetRequest(out Request: TWorkItem);  
154.     // 清除死线程  
155.     procedure KillDeadThreads;  
156.   public  
157.     constructor Create(AOwner: TComponent); override;  
158.     destructor Destroy; override;  
159.     // 就进行任务是否重复的检查, 检查发现重复就返回 False  
160.     function AddRequest(aDataObject: TWorkItem; CheckForDoubles: Boolean =  
161.       False): Boolean; overload;  
162.     // 转换枚举类型的线程状态为字串类型  
163.     function InfoText: string;  
164.   published  
165.     // 线程处理任务时触发的事件  
166.     property OnProcessRequest: TProcessRequest read FProcessRequest write  
167.       FProcessRequest;  
168.     // 任务列表为空时解发的事件  
169.     property OnQueueEmpty: TQueueEmpty read FQueueEmpty write FQueueEmpty;  
170.     // 线程结束时触发的事件  
171.     property OnThreadFinalizing: TProcessorThreadFinalizing read  
172.       FThreadFinalizing write FThreadFinalizing;  
173.     // 线程初始化时触发的事件  
174.     property OnThreadInitializing: TProcessorThreadInitializing read  
175.       FThreadInitializing write FThreadInitializing;  
176.     // 线程超时值（毫秒), 如果处理超时，将视为死线程  
177.     property ThreadDeadTimeout: DWORD read FThreadDeadTimeout write  
178.       FThreadDeadTimeout default 0;  
179.     // 最大线程数  
180.     property ThreadsMax: Integer read FThreadsMax write FThreadsMax default 1;  
181.     // 最小线程数  
182.     property ThreadsMin: Integer read FThreadsMin write FThreadsMin default 0;  
183.   end;  
184.   
185. type  
186.   //日志记志函数  
187.   TLogWriteProc = procedure(  
188.     const Str: string; //日志  
189.     LogID: Integer = 0;  
190.     Level: Integer = 0 //Level = 0 - 跟踪信息, 10 - 致命错误  
191.     );  
192.   
193. var  
194.   WriteLog: TLogWriteProc; // 如果存在实例就写日志  
195.   
196. implementation  
197. uses  
198.   SysUtils;  
199.   
200. // 储存请求数据的基本类  
201. { 
202. ********************************** TWorkItem *********************************** 
203. }  
204.   
205. function TWorkItem.IsTheSame(DataObj: TWorkItem): Boolean;  
206. begin  
207.   Result := False;  
208. end; { TWorkItem.IsTheSame }  
209.   
210. function TWorkItem.TextForLog: string;  
211. begin  
212.   Result := ‘Request‘;  
213. end; { TWorkItem.TextForLog }  
214.   
215. { 
216. ********************************* TThreadsPool ********************************* 
217. }  
218.   
219. constructor TThreadsPool.Create(AOwner: TComponent);  
220. var  
221.   DueTo: Int64;  
222. begin  
223. {$IFNDEF NOLOGS}  
224.   WriteLog(‘创建线程池‘, 5);  
225. {$ENDIF}  
226.   inherited;  
227.   csQueueManagment := TCriticalSection.Create;  
228.   FQueue := TList.Create;  
229.   csThreadManagment := TCriticalSection.Create;  
230.   FThreads := TList.Create;  
231.   FThreadsKilling := TList.Create;  
232.   FThreadsMin := 0;  
233.   FThreadsMax := 1;  
234.   FThreadDeadTimeout := 0;  
235.   FLastGetPoint := 0;  
236.   //  
237.   hSemRequestCount := CreateSemaphore(nil, 0, $7FFFFFFF, nil);  
238.   
239.   DueTo := -1;  
240.   //可等待的定时器（只用于Window NT4或更高）  
241.   hTimCheckPoolDown := CreateWaitableTimer(nil, False, nil);  
242.   
243.   if hTimCheckPoolDown = 0 then // Win9x不支持  
244.     // In Win9x number of thread will be never decrised  
245.     hTimCheckPoolDown := CreateEvent(nil, False, False, nil)  
246.   else  
247.     SetWaitableTimer(hTimCheckPoolDown, DueTo, 30000, nil, nil, False);  
248. end; { TThreadsPool.Create }  
249.   
250. destructor TThreadsPool.Destroy;  
251. var  
252.   n, i: Integer;  
253.   Handles: array of THandle;  
254. begin  
255. {$IFNDEF NOLOGS}  
256.   WriteLog(‘线程池销毁‘, 5);  
257. {$ENDIF}  
258.   csThreadManagment.Enter;  
259.   
260.   SetLength(Handles, FThreads.Count);  
261.   n := 0;  
262.   for i := 0 to FThreads.Count - 1 do  
263.     if FThreads[i] <> nil then  
264.     begin  
265.       Handles[n] := TProcessorThread(FThreads[i]).Handle;  
266.       TProcessorThread(FThreads[i]).Terminate;  
267.       Inc(n);  
268.     end;  
269.   
270.   csThreadManagment.Leave;  // lixiaoyu 添加于 2009.1.6，如没有此行代码无法成功释放正在执行中的工作者线程，死锁。  
271.   
272.   WaitForMultipleObjects(n, @Handles[0], True, 30000);  // 等待工作者线程执行终止  lixiaoyu 注释于 2009.1.6  
273.   
274.   csThreadManagment.Enter;  // lixiaoyu 添加于 2009.1.6 再次进入锁定，并释放资源  
275.   for i := 0 to FThreads.Count - 1 do  
276.     TProcessorThread(FThreads[i]).Free;  
277.   FThreads.Free;  
278.   FThreadsKilling.Free;  
279.   csThreadManagment.Free;  
280.   
281.   csQueueManagment.Enter;  
282.   for i := FQueue.Count - 1 downto 0 do  
283.     TObject(FQueue[i]).Free;  
284.   FQueue.Free;  
285.   csQueueManagment.Free;  
286.   
287.   CloseHandle(hSemRequestCount);  
288.   CloseHandle(hTimCheckPoolDown);  
289.   inherited;  
290. end; { TThreadsPool.Destroy }  
291.   
292. function TThreadsPool.AddRequest(aDataObject: TWorkItem; CheckForDoubles:  
293.   Boolean = False): Boolean;  
294. var  
295.   i: Integer;  
296. begin  
297. {$IFNDEF NOLOGS}  
298.   WriteLog(‘AddRequest(‘ + aDataObject.TextForLog + ‘)‘, 2);  
299. {$ENDIF}  
300.   Result := False;  
301.   csQueueManagment.Enter;  
302.   try  
303.     // 如果 CheckForDoubles = TRUE  
304.     // 则进行任务是否重复的检查  
305.     if CheckForDoubles then  
306.       for i := 0 to FQueue.Count - 1 do  
307.         if (FQueue[i] <> nil)  
308.           and aDataObject.IsTheSame(TWorkItem(FQueue[i])) then  
309.           Exit; // 发现有相同的任务  
310.   
311.     csThreadManagment.Enter;  
312.     try  
313.       // 清除死线程，并补充不足的工作线程  
314.       CheckThreadsForGrow;  
315.   
316.       // 如果 CheckForDoubles = TRUE  
317.       // 则检查是否有相同的任务正在处理中  
318.       if CheckForDoubles then  
319.         for i := 0 to FThreads.Count - 1 do  
320.           if TProcessorThread(FThreads[i]).IamCurrentlyProcess(aDataObject) then  
321.             Exit; // 发现有相同的任务  
322.   
323.     finally  
324.       csThreadManagment.Leave;  
325.     end;  
326.   
327.     //将任务加入队列  
328.     FQueue.Add(aDataObject);  
329.   
330.     //释放一个同步信号量  
331.     ReleaseSemaphore(hSemRequestCount, 1, nil);  
332. {$IFNDEF NOLOGS}  
333.     WriteLog(‘释放一个同步信号量)‘, 1);  
334. {$ENDIF}  
335.     Result := True;  
336.   finally  
337.     csQueueManagment.Leave;  
338.   end;  
339. {$IFNDEF NOLOGS}  
340.   //调试信息  
341.   WriteLog(‘增加一个任务(‘ + aDataObject.TextForLog + ‘)‘, 1);  
342. {$ENDIF}  
343. end; { TThreadsPool.AddRequest }  
344.   
345. { 
346. 函 数 名：TThreadsPool.CheckPoolDown 
347. 功能描述：线程池停机（检查并清除空闲线程和死线程） 
348. 输入参数：无 
349. 返 回 值: 无 
350. 创建日期：2006.10.22 11:31 
351. 修改日期：2006. 
352. 作    者：Kook 
353. 附加说明： 
354. }  
355.   
356. procedure TThreadsPool.CheckPoolDown;  
357. var  
358.   i: Integer;  
359. begin  
360. {$IFNDEF NOLOGS}  
361.   WriteLog(‘TThreadsPool.CheckPoolDown‘, 1);  
362. {$ENDIF}  
363.   csThreadManagment.Enter;  
364.   try  
365. {$IFNDEF NOLOGS}  
366.     WriteLog(InfoText, 2);  
367. {$ENDIF}  
368.     // 清除死线程  
369.     KillDeadThreads;  
370.     // 释放 FThreadsKilling 列表中的线程  
371.     FreeFinishedThreads;  
372.   
373.     // 如果线程空闲，就终止它  
374.     for i := FThreads.Count - 1 downto FThreadsMin do  
375.       if TProcessorThread(FThreads[i]).isIdle then  
376.       begin  
377.         //发出终止命令  
378.         TProcessorThread(FThreads[i]).Terminate;  
379.         //加入待清除队列  
380.         FThreadsKilling.Add(FThreads[i]);  
381.         //从工作队列中除名  
382.         FThreads.Delete(i);  
383.         //todo: ？？  
384.         Break;  
385.       end;  
386.   finally  
387.     csThreadManagment.Leave;  
388.   end;  
389. end; { TThreadsPool.CheckPoolDown }  
390.   
391. { 
392. 函 数 名：TThreadsPool.CheckThreadsForGrow 
393. 功能描述：清除死线程，并补充不足的工作线程 
394. 输入参数：无 
395. 返 回 值: 无 
396. 创建日期：2006.10.22 11:31 
397. 修改日期：2006. 
398. 作    者：Kook 
399. 附加说明： 
400. }  
401.   
402. procedure TThreadsPool.CheckThreadsForGrow;  
403. var  
404.   AvgWait: Integer;  
405.   i: Integer;  
406. begin  
407.   { 
408.     New thread created if: 
409.     新建线程的条件： 
410.       1. 工作线程数小于最小线程数 
411.       2. 工作线程数小于最大线程数 and 线程池平均等待时间 < 100ms(系统忙) 
412.       3. 任务大于工作线程数的4倍 
413.   }  
414.   
415.   csThreadManagment.Enter;  
416.   try  
417.     KillDeadThreads;  
418.     if FThreads.Count < FThreadsMin then  
419.     begin  
420. {$IFNDEF NOLOGS}  
421.       WriteLog(‘工作线程数小于最小线程数‘, 4);  
422. {$ENDIF}  
423.       for i := FThreads.Count to FThreadsMin - 1 do  
424.       try  
425.         FThreads.Add(TProcessorThread.Create(Self));  
426.       except  
427.         on e: Exception do  
428.   
429.           WriteLog(  
430.             ‘TProcessorThread.Create raise: ‘ + e.ClassName + #13#10#9‘Message: ‘  
431.             + e.Message,  
432.             9  
433.             );  
434.       end  
435.     end  
436.     else if FThreads.Count < FThreadsMax then  
437.     begin  
438. {$IFNDEF NOLOGS}  
439.       WriteLog(‘工作线程数小于最大线程数 and 线程池平均等待时间 < 100ms‘, 3);  
440. {$ENDIF}  
441.       AvgWait := PoolAverageWaitingTime;  
442. {$IFNDEF NOLOGS}  
443.       WriteLog(Format(  
444.         ‘FThreads.Count (%d)<FThreadsMax(%d), AvgWait=%d‘,  
445.         [FThreads.Count, FThreadsMax, AvgWait]),  
446.         4  
447.         );  
448. {$ENDIF}  
449.   
450.       if AvgWait < 100 then  
451.       try  
452.         FThreads.Add(TProcessorThread.Create(Self));  
453.       except  
454.         on e: Exception do  
455.           WriteLog(  
456.             ‘TProcessorThread.Create raise: ‘ + e.ClassName +  
457.             #13#10#9‘Message: ‘ + e.Message,  
458.             9  
459.             );  
460.       end;  
461.     end;  
462.   finally  
463.     csThreadManagment.Leave;  
464.   end;  
465. end; { TThreadsPool.CheckThreadsForGrow }  
466.   
467. procedure TThreadsPool.DoProcessed;  
468. var  
469.   i: Integer;  
470. begin  
471.   if (FLastGetPoint < FQueue.Count) then  
472.     Exit;  
473.   csThreadManagment.Enter;  
474.   try  
475.     for i := 0 to FThreads.Count - 1 do  
476.       if TProcessorThread(FThreads[i]).FCurState in [tcsProcessing] then  
477.         Exit;  
478.   finally  
479.     csThreadManagment.Leave;  
480.   end;  
481.   DoQueueEmpty(ekProcessingFinished);  
482. end; { TThreadsPool.DoProcessed }  
483.   
484. procedure TThreadsPool.DoProcessRequest(aDataObj: TWorkItem; aThread:  
485.   TProcessorThread);  
486. begin  
487.   if Assigned(FProcessRequest) then  
488.     FProcessRequest(Self, aDataObj, aThread);  
489. end; { TThreadsPool.DoProcessRequest }  
490.   
491. procedure TThreadsPool.DoQueueEmpty(EmptyKind: TEmptyKind);  
492. begin  
493.   if Assigned(FQueueEmpty) then  
494.     FQueueEmpty(Self, EmptyKind);  
495. end; { TThreadsPool.DoQueueEmpty }  
496.   
497. procedure TThreadsPool.DoThreadFinalizing(aThread: TProcessorThread);  
498. begin  
499.   if Assigned(FThreadFinalizing) then  
500.     FThreadFinalizing(Self, aThread);  
501. end; { TThreadsPool.DoThreadFinalizing }  
502.   
503. procedure TThreadsPool.DoThreadInitializing(aThread: TProcessorThread);  
504. begin  
505.   if Assigned(FThreadInitializing) then  
506.     FThreadInitializing(Self, aThread);  
507. end; { TThreadsPool.DoThreadInitializing }  
508.   
509. { 
510. 函 数 名：TThreadsPool.FreeFinishedThreads 
511. 功能描述：释放 FThreadsKilling 列表中的线程 
512. 输入参数：无 
513. 返 回 值: 无 
514. 创建日期：2006.10.22 11:34 
515. 修改日期：2006. 
516. 作    者：Kook 
517. 附加说明： 
518. }  
519.   
520. procedure TThreadsPool.FreeFinishedThreads;  
521. var  
522.   i: Integer;  
523. begin  
524.   if csThreadManagment.TryEnter then  
525.   try  
526.     for i := FThreadsKilling.Count - 1 downto 0 do  
527.       if TProcessorThread(FThreadsKilling[i]).isFinished then  
528.       begin  
529.         TProcessorThread(FThreadsKilling[i]).Free;  
530.         FThreadsKilling.Delete(i);  
531.       end;  
532.   finally  
533.     csThreadManagment.Leave  
534.   end;  
535. end; { TThreadsPool.FreeFinishedThreads }  
536.   
537. { 
538. 函 数 名：TThreadsPool.GetRequest 
539. 功能描述：申请任务 
540. 输入参数：out Request: TRequestDataObject 
541. 返 回 值: 无 
542. 创建日期：2006.10.22 11:34 
543. 修改日期：2006. 
544. 作    者：Kook 
545. 附加说明： 
546. }  
547.   
548. procedure TThreadsPool.GetRequest(out Request: TWorkItem);  
549. begin  
550. {$IFNDEF NOLOGS}  
551.   WriteLog(‘申请任务‘, 2);  
552. {$ENDIF}  
553.   csQueueManagment.Enter;  
554.   try  
555.     //跳过空的队列元素  
556.     while (FLastGetPoint < FQueue.Count) and (FQueue[FLastGetPoint] = nil) do  
557.       Inc(FLastGetPoint);  
558.   
559.     Assert(FLastGetPoint < FQueue.Count);  
560.     //压缩队列，清除空元素  
561.     if (FQueue.Count > 127) and (FLastGetPoint >= (3 * FQueue.Count) div 4) then  
562.     begin  
563. {$IFNDEF NOLOGS}  
564.       WriteLog(‘FQueue.Pack‘, 1);  
565. {$ENDIF}  
566.       FQueue.Pack;  
567.       FLastGetPoint := 0;  
568.     end;  
569.   
570.     Request := TWorkItem(FQueue[FLastGetPoint]);  
571.     FQueue[FLastGetPoint] := nil;  
572.     inc(FLastGetPoint);  
573.     if (FLastGetPoint = FQueue.Count) then //如果队列中无任务  
574.     begin  
575.   
576.       DoQueueEmpty(ekQueueEmpty);  
577.       FQueue.Clear;  
578.       FLastGetPoint := 0;  
579.     end;  
580.   finally  
581.     csQueueManagment.Leave;  
582.   end;  
583. end; { TThreadsPool.GetRequest }  
584.   
585. function TThreadsPool.InfoText: string;  
586. begin  
587.   Result := ‘‘;  
588.   //end;  
589.   //{$ELSE}  
590.   //var  
591.   //  i: Integer;  
592.   //begin  
593.   //  csQueueManagment.Enter;  
594.   //  csThreadManagment.Enter;  
595.   //  try  
596.   //    if (FThreads.Count = 0) and (FThreadsKilling.Count = 1) and  
597.   //      TProcessorThread(FThreadsKilling[0]).isFinished then  
598.   //      FreeFinishedThreads;  
599.   //  
600.   //    Result := Format(  
601.   //      ‘Pool thread: Min=%d, Max=%d, WorkingThreadsCount=%d, TerminatedThreadCount=%d, QueueLength=%d‘#13#10,  
602.   //      [ThreadsMin, ThreadsMax, FThreads.Count, FThreadsKilling.Count,  
603.   //      FQueue.Count]  
604.   //        );  
605.   //    if FThreads.Count > 0 then  
606.   //      Result := Result + ‘Working threads:‘#13#10;  
607.   //    for i := 0 to FThreads.Count - 1 do  
608.   //      Result := Result + TProcessorThread(FThreads[i]).InfoText + #13#10;  
609.   //    if FThreadsKilling.Count > 0 then  
610.   //      Result := Result + ‘Terminated threads:‘#13#10;  
611.   //    for i := 0 to FThreadsKilling.Count - 1 do  
612.   //      Result := Result + TProcessorThread(FThreadsKilling[i]).InfoText + #13#10;  
613.   //  finally  
614.   //    csThreadManagment.Leave;  
615.   //    csQueueManagment.Leave;  
616.   //  end;  
617.   //end;  
618.   //{$ENDIF}  
619. end; { TThreadsPool.InfoText }  
620.   
621. { 
622. 函 数 名：TThreadsPool.KillDeadThreads 
623. 功能描述：清除死线程 
624. 输入参数：无 
625. 返 回 值: 无 
626. 创建日期：2006.10.22 11:32 
627. 修改日期：2006. 
628. 作    者：Kook 
629. 附加说明： 
630. }  
631.   
632. procedure TThreadsPool.KillDeadThreads;  
633. var  
634.   i: Integer;  
635. begin  
636.   // Check for dead threads  
637.   if csThreadManagment.TryEnter then  
638.   try  
639.     for i := 0 to FThreads.Count - 1 do  
640.       if TProcessorThread(FThreads[i]).IsDead then  
641.       begin  
642.         // Dead thread moverd to other list.  
643.         // New thread created to replace dead one  
644.         TProcessorThread(FThreads[i]).Terminate;  
645.         FThreadsKilling.Add(FThreads[i]);  
646.         try  
647.           FThreads[i] := TProcessorThread.Create(Self);  
648.         except  
649.           on e: Exception do  
650.           begin  
651.             FThreads[i] := nil;  
652. {$IFNDEF NOLOGS}  
653.             WriteLog(  
654.               ‘TProcessorThread.Create raise: ‘ + e.ClassName +  
655.               #13#10#9‘Message: ‘ + e.Message,  
656.               9  
657.               );  
658. {$ENDIF}  
659.           end;  
660.         end;  
661.       end;  
662.   finally  
663.     csThreadManagment.Leave  
664.   end;  
665. end; { TThreadsPool.KillDeadThreads }  
666.   
667. function TThreadsPool.PoolAverageWaitingTime: Integer;  
668. var  
669.   i: Integer;  
670. begin  
671.   Result := 0;  
672.   if FThreads.Count > 0 then  
673.   begin  
674.     for i := 0 to FThreads.Count - 1 do  
675.       Inc(result, TProcessorThread(FThreads[i]).AverageWaitingTime);  
676.     Result := Result div FThreads.Count  
677.   end  
678.   else  
679.     Result := 1;  
680. end; { TThreadsPool.PoolAverageWaitingTime }  
681.   
682. procedure TThreadsPool.WriteLog(const Str: string; Level: Integer = 0);  
683. begin  
684. {$IFNDEF NOLOGS}  
685.   uThreadPool.WriteLog(Str, 0, Level);  
686. {$ENDIF}  
687. end; { TThreadsPool.WriteLog }  
688.   
689. // 工作线程仅用于线程池内， 不要直接创建并调用它。  
690. { 
691. ******************************* TProcessorThread ******************************* 
692. }  
693.   
694. constructor TProcessorThread.Create(APool: TThreadsPool);  
695. begin  
696.   WriteLog(‘创建工作线程‘, 5);  
697.   inherited Create(True);  
698.   FPool := aPool;  
699.   
700.   FAverageWaitingTime := 1000;  
701.   FAverageProcessing := 3000;  
702.   
703.   sInitError := ‘‘;  
704.   { 
705.   各参数的意义如下： 
706.   　 
707.    参数一：填上 nil 即可。 
708.    参数二：是否采用手动调整灯号。 
709.    参数三：灯号的起始状态，False 表示红灯。 
710.    参数四：Event 名称, 对象名称相同的话，会指向同一个对象，所以想要有两个Event对象，便要有两个不同的名称(这名称以字符串来存.为NIL的话系统每次会自己创建一个不同的名字，就是被次创建的都是新的EVENT)。 
711.    传回值：Event handle。 
712.   }  
713.   hInitFinished := CreateEvent(nil, True, False, nil);  
714.   hThreadTerminated := CreateEvent(nil, True, False, nil);  
715.   csProcessingDataObject := TCriticalSection.Create;  
716.   try  
717.     WriteLog(‘TProcessorThread.Create::Resume‘, 3);  
718.     Resume;  
719.     //阻塞, 等待初始化完成  
720.     WaitForSingleObject(hInitFinished, INFINITE);  
721.     if sInitError <> ‘‘ then  
722.       raise Exception.Create(sInitError);  
723.   finally  
724.     CloseHandle(hInitFinished);  
725.   end;  
726.   WriteLog(‘TProcessorThread.Create::Finished‘, 3);  
727. end; { TProcessorThread.Create }  
728.   
729. destructor TProcessorThread.Destroy;  
730. begin  
731.   WriteLog(‘工作线程销毁‘, 5);  
732.   CloseHandle(hThreadTerminated);  
733.   csProcessingDataObject.Free;  
734.   inherited;  
735. end; { TProcessorThread.Destroy }  
736.   
737. function TProcessorThread.AverageProcessingTime: DWORD;  
738. begin  
739.   if (FCurState in [tcsProcessing]) then  
740.     Result := NewAverage(FAverageProcessing, GetTickCount - uProcessingStart)  
741.   else  
742.     Result := FAverageProcessing  
743. end; { TProcessorThread.AverageProcessingTime }  
744.   
745. function TProcessorThread.AverageWaitingTime: DWORD;  
746. begin  
747.   if (FCurState in [tcsWaiting, tcsCheckingDown]) then  
748.     Result := NewAverage(FAverageWaitingTime, GetTickCount - uWaitingStart)  
749.   else  
750.     Result := FAverageWaitingTime  
751. end; { TProcessorThread.AverageWaitingTime }  
752.   
753. procedure TProcessorThread.Execute;  
754.   
755. type  
756.   THandleID = (hidTerminateThread, hidRequest, hidCheckPoolDown);  
757. var  
758.   WaitedTime: Integer;  
759.   Handles: array[THandleID] of THandle;  
760.   
761. begin  
762.   WriteLog(‘工作线程进常运行‘, 3);  
763.   //当前状态：初始化  
764.   FCurState := tcsInitializing;  
765.   try  
766.     //执行外部事件  
767.     FPool.DoThreadInitializing(Self);  
768.   except  
769.     on e: Exception do  
770.       sInitError := e.Message;  
771.   end;  
772.   
773.   //初始化完成，初始化Event绿灯  
774.   SetEvent(hInitFinished);  
775.   
776.   WriteLog(‘TProcessorThread.Execute::Initialized‘, 3);  
777.   
778.   //引用线程池的同步 Event  
779.   Handles[hidTerminateThread] := hThreadTerminated;  
780.   Handles[hidRequest] := FPool.hSemRequestCount;  
781.   Handles[hidCheckPoolDown] := FPool.hTimCheckPoolDown;  
782.   
783.   //时间戳，  
784.   //todo: 好像在线程中用 GetTickCount; 会不正常  
785.   uWaitingStart := GetTickCount;  
786.   //任务置空  
787.   FProcessingDataObject := nil;  
788.   
789.   //大巡环  
790.   while not terminated do  
791.   begin  
792.     //当前状态：等待  
793.     FCurState := tcsWaiting;  
794.     //阻塞线程，使线程休眠  
795.     case WaitForMultipleObjects(Length(Handles), @Handles, False, INFINITE) -  
796.       WAIT_OBJECT_0 of  
797.   
798.       WAIT_OBJECT_0 + ord(hidTerminateThread):  
799.         begin  
800.           WriteLog(‘TProcessorThread.Execute:: Terminate event signaled ‘, 5);  
801.           //当前状态：正在终止线程  
802.           FCurState := tcsTerminating;  
803.           //退出大巡环(结束线程)  
804.           Break;  
805.         end;  
806.   
807.       WAIT_OBJECT_0 + ord(hidRequest):  
808.         begin  
809.           WriteLog(‘TProcessorThread.Execute:: Request semaphore signaled ‘, 3);  
810.           //等待的时间  
811.           WaitedTime := GetTickCount - uWaitingStart;  
812.           //重新计算平均等待时间  
813.           FAverageWaitingTime := NewAverage(FAverageWaitingTime, WaitedTime);  
814.           //当前状态：申请任务  
815.           FCurState := tcsGetting;  
816.           //如果等待时间过短，则检查工作线程是否足够  
817.           if WaitedTime < 5 then  
818.             FPool.CheckThreadsForGrow;  
819.           //从线程池的任务队列中得到任务  
820.           FPool.GetRequest(FProcessingDataObject);  
821.           //开始处理的时间戳  
822.           uProcessingStart := GetTickCount;  
823.           //当前状态：执行任务  
824.           FCurState := tcsProcessing;  
825.           try  
826. {$IFNDEF NOLOGS}  
827.             WriteLog(‘Processing: ‘ + FProcessingDataObject.TextForLog, 2);  
828. {$ENDIF}  
829.             //执行任务  
830.             FPool.DoProcessRequest(FProcessingDataObject, Self);  
831.           except  
832.             on e: Exception do  
833.               WriteLog(  
834.                 ‘OnProcessRequest for ‘ + FProcessingDataObject.TextForLog +  
835.                 #13#10‘raise Exception: ‘ + e.Message,  
836.                 8  
837.                 );  
838.           end;  
839.   
840.           //释放任务对象  
841.           csProcessingDataObject.Enter;  
842.           try  
843.             FProcessingDataObject.Free;  
844.             FProcessingDataObject := nil;  
845.           finally  
846.             csProcessingDataObject.Leave;  
847.           end;  
848.           //重新计算  
849.           FAverageProcessing := NewAverage(FAverageProcessing, GetTickCount -  
850.             uProcessingStart);  
851.           //当前状态：执行任务完毕  
852.           FCurState := tcsProcessed;  
853.           //执行线程外事件  
854.           FPool.DoProcessed;  
855.   
856.           uWaitingStart := GetTickCount;  
857.         end;  
858.       WAIT_OBJECT_0 + ord(hidCheckPoolDown):  
859.         begin  
860.           // !!! Never called under Win9x  
861.           WriteLog(‘TProcessorThread.Execute:: CheckPoolDown timer signaled ‘,  
862.             4);  
863.           //当前状态：线程池停机（检查并清除空闲线程和死线程）  
864.           FCurState := tcsCheckingDown;  
865.           FPool.CheckPoolDown;  
866.         end;  
867.     end;  
868.   end;  
869.   FCurState := tcsTerminating;  
870.   
871.   FPool.DoThreadFinalizing(Self);  
872. end; { TProcessorThread.Execute }  
873.   
874. function TProcessorThread.IamCurrentlyProcess(DataObj: TWorkItem): Boolean;  
875. begin  
876.   csProcessingDataObject.Enter;  
877.   try  
878.     Result := (FProcessingDataObject <> nil) and  
879.       DataObj.IsTheSame(FProcessingDataObject);  
880.   finally  
881.     csProcessingDataObject.Leave;  
882.   end;  
883. end; { TProcessorThread.IamCurrentlyProcess }  
884.   
885. function TProcessorThread.InfoText: string;  
886.   
887. const  
888.   ThreadStateNames: array[TThreadState] of string =  
889.   (  
890.     ‘tcsInitializing‘,  
891.     ‘tcsWaiting‘,  
892.     ‘tcsGetting‘,  
893.     ‘tcsProcessing‘,  
894.     ‘tcsProcessed‘,  
895.     ‘tcsTerminating‘,  
896.     ‘tcsCheckingDown‘  
897.     );  
898.   
899. begin  
900. {$IFNDEF NOLOGS}  
901.   Result := Format(  
902.     ‘%5d: %15s, AverageWaitingTime=%6d, AverageProcessingTime=%6d‘,  
903.     [ThreadID, ThreadStateNames[FCurState], AverageWaitingTime,  
904.     AverageProcessingTime]  
905.       );  
906.   case FCurState of  
907.     tcsWaiting:  
908.       Result := Result + ‘, WaitingTime=‘ + IntToStr(GetTickCount -  
909.         uWaitingStart);  
910.     tcsProcessing:  
911.       Result := Result + ‘, ProcessingTime=‘ + IntToStr(GetTickCount -  
912.         uProcessingStart);  
913.   end;  
914.   
915.   csProcessingDataObject.Enter;  
916.   try  
917.     if FProcessingDataObject <> nil then  
918.       Result := Result + ‘ ‘ + FProcessingDataObject.TextForLog;  
919.   finally  
920.     csProcessingDataObject.Leave;  
921.   end;  
922. {$ENDIF}  
923. end; { TProcessorThread.InfoText }  
924.   
925. function TProcessorThread.IsDead: Boolean;  
926. begin  
927.   Result :=  
928.     Terminated or  
929.     (FPool.ThreadDeadTimeout > 0) and (FCurState = tcsProcessing) and  
930.     (GetTickCount - uProcessingStart > FPool.ThreadDeadTimeout);  
931.   if Result then  
932.     WriteLog(‘Thread dead‘, 5);  
933. end; { TProcessorThread.IsDead }  
934.   
935. function TProcessorThread.isFinished: Boolean;  
936. begin  
937.   Result := WaitForSingleObject(Handle, 0) = WAIT_OBJECT_0;  
938. end; { TProcessorThread.isFinished }  
939.   
940. function TProcessorThread.isIdle: Boolean;  
941. begin  
942.   // 如果线程状态是 tcsWaiting, tcsCheckingDown  
943.   // 并且 空间时间 > 100ms,  
944.   // 并且 平均等候任务时间大于平均工作时间的 50%  
945.   // 则视为空闲。  
946.   Result :=  
947.     (FCurState in [tcsWaiting, tcsCheckingDown]) and  
948.     (AverageWaitingTime > 100) and  
949.     (AverageWaitingTime * 2 > AverageProcessingTime);  
950. end; { TProcessorThread.isIdle }  
951.   
952. function TProcessorThread.NewAverage(OldAvg, NewVal: Integer): Integer;  
953. begin  
954.   Result := (OldAvg * 2 + NewVal) div 3;  
955. end; { TProcessorThread.NewAverage }  
956.   
957. procedure TProcessorThread.Terminate;  
958. begin  
959.   WriteLog(‘TProcessorThread.Terminate‘, 5);  
960.   inherited Terminate;  
961.   SetEvent(hThreadTerminated);  
962. end; { TProcessorThread.Terminate }  
963.   
964. procedure TProcessorThread.WriteLog(const Str: string; Level: Integer = 0);  
965. begin  
966. {$IFNDEF NOLOGS}  
967.   uThreadPool.WriteLog(Str, ThreadID, Level);  
968. {$ENDIF}  
969. end; { TProcessorThread.WriteLog }  
970.   
971. { 
972. ******************************* TCriticalSection ******************************* 
973. }  
974.   
975. constructor TCriticalSection.Create;  
976. begin  
977.   InitializeCriticalSection(FSection);  
978. end; { TCriticalSection.Create }  
979.   
980. destructor TCriticalSection.Destroy;  
981. begin  
982.   DeleteCriticalSection(FSection);  
983. end; { TCriticalSection.Destroy }  
984.   
985. procedure TCriticalSection.Enter;  
986. begin  
987.   EnterCriticalSection(FSection);  
988. end; { TCriticalSection.Enter }  
989.   
990. procedure TCriticalSection.Leave;  
991. begin  
992.   LeaveCriticalSection(FSection);  
993. end; { TCriticalSection.Leave }  
994.   
995. function TCriticalSection.TryEnter: Boolean;  
996. begin  
997.   Result := TryEnterCriticalSection(FSection);  
998. end; { TCriticalSection.TryEnter }  
999.   
1000. procedure NoLogs(const Str: string; LogID: Integer = 0; Level: Integer = 0);  
1001. begin  
1002. end;  
1003.   
1004. initialization  
1005.   WriteLog := NoLogs;  
1006. end.  

http://blog.csdn.net/earbao/article/details/46515261