source: trunk/Packages/Common/UThreading.pas

Last change on this file was 2, checked in by chronos, 9 years ago
  • Added: TPakFile class for extraction PAK files from original game.
File size: 9.2 KB
Line 
1unit UThreading;
2
3{$mode delphi}
4
5interface
6
7uses
8 Classes, SysUtils, Forms, Contnrs, SyncObjs;
9
10type
11 TExceptionEvent = procedure (Sender: TObject; E: Exception) of object;
12 TMethodCall = procedure of object;
13
14
15 { TVirtualThread }
16
17 TVirtualThread = class
18 private
19 function GetFinished: Boolean; virtual; abstract;
20 function GetFreeOnTerminate: Boolean; virtual; abstract;
21 function GetPriority: TThreadPriority; virtual; abstract;
22 function GetSuspended: Boolean; virtual; abstract;
23 function GetTerminated: Boolean; virtual; abstract;
24 function GetThreadId: Integer; virtual; abstract;
25 procedure SetFreeOnTerminate(const AValue: Boolean); virtual; abstract;
26 procedure SetPriority(const AValue: TThreadPriority); virtual; abstract;
27 procedure SetSuspended(const AValue: Boolean); virtual; abstract;
28 procedure SetTerminated(const AValue: Boolean); virtual; abstract;
29 public
30 Name: string;
31 procedure Execute; virtual; abstract;
32 procedure Resume; virtual; abstract;
33 procedure Suspend; virtual; abstract;
34 procedure Start; virtual; abstract;
35 procedure Terminate; virtual; abstract;
36 procedure Synchronize(AMethod: TThreadMethod); virtual; abstract;
37 procedure WaitFor; virtual; abstract;
38 procedure Sleep(Delay: Integer); virtual; abstract;
39 property FreeOnTerminate: Boolean read GetFreeOnTerminate
40 write SetFreeOnTerminate;
41 property Suspended: Boolean read GetSuspended
42 write SetSuspended;
43 property Priority: TThreadPriority read GetPriority write SetPriority;
44 property Terminated: Boolean read GetTerminated write SetTerminated;
45 property Finished: Boolean read GetFinished;
46 property ThreadId: Integer read GetThreadId;
47 end;
48
49 TVirtualThreadClass = class of TVirtualThread;
50
51 TListedThread = class;
52
53 { TListedThreadExecute }
54
55 TListedThreadExecute = class(TThread)
56 Parent: TListedThread;
57 procedure Execute; override;
58 end;
59
60 { TListedThread }
61
62 TListedThread = class(TVirtualThread)
63 private
64 FTerminated: Boolean;
65 FFinished: Boolean;
66 FThread: TListedThreadExecute;
67 function GetFinished: Boolean; override;
68 function GetFreeOnTerminate: Boolean; override;
69 function GetPriority: TThreadPriority; override;
70 function GetSuspended: Boolean; override;
71 function GetTerminated: Boolean; override;
72 function GetThreadId: Integer; override;
73 procedure SetFreeOnTerminate(const AValue: Boolean); override;
74 procedure SetPriority(const AValue: TThreadPriority); override;
75 procedure SetSuspended(const AValue: Boolean); override;
76 procedure SetTerminated(const AValue: Boolean); override;
77 public
78 constructor Create(CreateSuspended: Boolean;
79 const StackSize: SizeUInt = DefaultStackSize);
80 destructor Destroy; override;
81 procedure Sleep(Delay: Integer); override;
82 procedure Execute; override;
83 procedure Resume; override;
84 procedure Suspend; override;
85 procedure Start; override;
86 procedure Terminate; override;
87 procedure Synchronize(AMethod: TThreadMethod); override;
88 procedure WaitFor; override;
89 end;
90
91 TTermThreadState = (ttsReady, ttsRunning, ttsFinished, ttsExceptionOccured);
92
93 { TTermThread }
94
95 TTermThread = class(TListedThread)
96 private
97 FOnFinished: TNotifyEvent;
98 public
99 State: TTermThreadState;
100 ExceptionMessage: string;
101 Method: TMethodCall;
102 procedure Execute; override;
103 property OnFinished: TNotifyEvent read FOnFinished write FOnFinished;
104 end;
105
106 { TThreadList }
107
108 TThreadList = class(TObjectList)
109 function FindById(Id: Integer): TVirtualThread;
110 constructor Create; virtual;
111 end;
112
113var
114 ThreadList: TThreadList;
115 ThreadListLock: TCriticalSection;
116 OnException: TExceptionEvent;
117
118procedure RunInThread(Method: TMethodCall);
119procedure RunInThreadAsync(Method: TMethodCall; Callback: TNotifyEvent = nil);
120procedure Synchronize(Method: TMethodCall);
121
122resourcestring
123 SCurrentThreadNotFound = 'Current thread ID %d not found in virtual thread list.';
124
125
126implementation
127
128procedure RunInThread(Method: TMethodCall);
129var
130 Thread: TTermThread;
131begin
132 try
133 Thread := TTermThread.Create(True);
134 Thread.FreeOnTerminate := False;
135 Thread.Method := Method;
136 Thread.Resume;
137 while (Thread.State = ttsRunning) or (Thread.State = ttsReady) do begin
138 if MainThreadID = ThreadID then Application.ProcessMessages;
139 Sleep(1);
140 end;
141 if Thread.State = ttsExceptionOccured then
142 raise Exception.Create(Thread.ExceptionMessage);
143 finally
144 Thread.Free;
145 end;
146end;
147
148procedure RunInThreadAsync(Method: TMethodCall; Callback: TNotifyEvent = nil);
149var
150 Thread: TTermThread;
151begin
152 try
153 Thread := TTermThread.Create(True);
154 Thread.FreeOnTerminate := True;
155 Thread.Method := Method;
156 Thread.OnFinished := CallBack;
157 Thread.Resume;
158 //if Thread.State = ttsExceptionOccured then
159 // raise Exception.Create(Thread.ExceptionMessage);
160 finally
161 end;
162end;
163
164procedure Synchronize(Method: TMethodCall);
165var
166 Thread: TVirtualThread;
167begin
168 if MainThreadID = ThreadID then Method
169 else begin
170 Thread := ThreadList.FindById(ThreadID);
171 if Assigned(Thread) then begin
172 Thread.Synchronize(Method);
173 end else raise Exception.Create(Format(SCurrentThreadNotFound, [ThreadID]));
174 end;
175end;
176
177{ TThreadList }
178
179function TThreadList.FindById(Id: Integer): TVirtualThread;
180var
181 I: Integer;
182begin
183 I := 0;
184 while (I < ThreadList.Count) and (TVirtualThread(ThreadList[I]).ThreadID <> Id) do
185 Inc(I);
186 if I < ThreadList.Count then Result := TVirtualThread(ThreadList[I])
187 else Result := nil;
188end;
189
190constructor TThreadList.Create;
191begin
192 inherited Create;
193end;
194
195{ TListedThreadExecute }
196
197procedure TListedThreadExecute.Execute;
198begin
199 try
200 try
201 Parent.Execute;
202 except
203 on E: Exception do
204 if Assigned(OnException) then
205 OnException(Parent.FThread, E);
206 end;
207 finally
208 Parent.FFinished := True;
209 end;
210end;
211
212{ TListedThread }
213
214function TListedThread.GetFinished: Boolean;
215begin
216 Result := FFinished;
217end;
218
219function TListedThread.GetFreeOnTerminate: Boolean;
220begin
221 Result := FThread.FreeOnTerminate;
222end;
223
224function TListedThread.GetPriority: TThreadPriority;
225begin
226 Result := FThread.Priority;
227end;
228
229function TListedThread.GetSuspended: Boolean;
230begin
231 Result := FThread.Suspended;
232end;
233
234function TListedThread.GetTerminated: Boolean;
235begin
236 Result := FTerminated;
237end;
238
239function TListedThread.GetThreadId: Integer;
240begin
241 Result := FThread.ThreadID;
242end;
243
244procedure TListedThread.SetFreeOnTerminate(const AValue: Boolean);
245begin
246 FThread.FreeOnTerminate := AValue;
247end;
248
249procedure TListedThread.SetPriority(const AValue: TThreadPriority);
250begin
251 FThread.Priority := AValue;
252end;
253
254procedure TListedThread.SetSuspended(const AValue: Boolean);
255begin
256 FThread.Suspended := AValue;
257end;
258
259procedure TListedThread.SetTerminated(const AValue: Boolean);
260begin
261 FTerminated := AValue;
262 if AValue then FThread.Terminate;
263end;
264
265constructor TListedThread.Create(CreateSuspended: Boolean;
266 const StackSize: SizeUInt);
267begin
268 FFinished := False;
269 FTerminated := False;
270
271 FThread := TListedThreadExecute.Create(True, StackSize);
272 FThread.Parent := Self;
273 try
274 ThreadListLock.Acquire;
275 ThreadList.Add(Self);
276 finally
277 ThreadListLock.Release;
278 end;
279 if CreateSuspended = False then FThread.Start;
280end;
281
282destructor TListedThread.Destroy;
283begin
284 if not Suspended then
285 begin
286 Terminate;
287 WaitFor;
288 end;
289 try
290 ThreadListLock.Acquire;
291 ThreadList.Delete(ThreadList.IndexOf(Self));
292 finally
293 ThreadListLock.Release;
294 end;
295 FThread.Free;
296 inherited Destroy;
297end;
298
299procedure TListedThread.Sleep(Delay: Integer);
300const
301 Quantum = 20;
302var
303 I: Integer;
304begin
305 if Terminated then Exit;
306 SysUtils.Sleep(Delay mod Quantum);
307 for I := 1 to (Delay div Quantum) do begin
308 if Terminated then Break;
309 SysUtils.Sleep(Quantum);
310 end;
311end;
312
313procedure TListedThread.Execute;
314begin
315end;
316
317procedure TListedThread.Resume;
318begin
319 FThread.Resume;
320end;
321
322procedure TListedThread.Suspend;
323begin
324 FThread.Suspend;
325end;
326
327procedure TListedThread.Start;
328begin
329 FThread.Start;
330end;
331
332procedure TListedThread.Terminate;
333begin
334 FTerminated := True;
335 FThread.Terminate;
336end;
337
338procedure TListedThread.Synchronize(AMethod: TThreadMethod);
339begin
340 FThread.Synchronize(FThread, AMethod);
341end;
342
343procedure TListedThread.WaitFor;
344begin
345 FThread.WaitFor;
346end;
347
348{ TTermThread }
349
350procedure TTermThread.Execute;
351begin
352 try
353 State := ttsRunning;
354 Method;
355 State := ttsFinished;
356 if Assigned(FOnFinished) then
357 FOnFinished(Self);
358 except
359 on E: Exception do begin
360 ExceptionMessage := E.Message;
361 State := ttsExceptionOccured;
362 if Assigned(OnException) then
363 OnException(FThread, E);
364 end;
365 end;
366end;
367
368initialization
369
370ThreadListLock := TCriticalSection.Create;
371ThreadList := TThreadList.Create;
372ThreadList.OwnsObjects := False;
373
374finalization
375
376ThreadList.Free;
377ThreadListLock.Free;
378
379end.
380
Note: See TracBrowser for help on using the repository browser.