How can I Pause/Continue TThread I am looking for a safe alternative to the deprecated TThread.Suspend aswell as TThread.Resume.
Here is the solution I ended up with. Safe alternative to Suspend/Resume.
type
TMyThread = class(TThread)
private
FHandles: array[0..1] of THandle;
protected
procedure Execute; override;
public
constructor Create;
destructor Destroy; override;
procedure Pause;
procedure UnPause;
procedure Stop;
end;
constructor TMyThread.Create;
begin
inherited Create(False);
FHandles[0] := CreateEvent(nil, False, False, nil);
FHandles[1] := CreateEvent(nil, True, True, nil);
FreeOnTerminate := True;
end;
destructor TMyThread.Destroy;
begin
CloseHandle(FHandles[1]);
CloseHandle(FHandles[0]);
inherited Destroy;
end;
procedure TMyThread.Execute;
begin
while not Terminated do
begin
case WaitForMultipleObjects(2, #FHandles[0], False, INFINITE) of
WAIT_FAILED:
RaiseLastOsError;
WAIT_OBJECT_0:
Terminate;
WAIT_OBJECT_0 + 1:
begin
end;
end;
end;
end;
procedure TMyThread.Pause;
begin
ResetEvent(FHandles[1]);
end;
procedure TMyThread.UnPause;
begin
SetEvent(FHandles[1]);
end;
procedure TMyThread.Stop;
begin
SetEvent(FHandles[0]);
end;
Related
In a Delphi/Linux program, let's say I have two running threads, ThreadA and ThreadB. At some point in time ThreadB need to make ThreadA execute a function and block until the function returns.
In Delphi, we have TThread.Synchronize which does the work, but only when ThreadA is the main thread.
Any idea? I use Delphi but an answer with C code is also welcome.
To do this the threads will have to co-operate, there's no mechanism to trigger events across threads. However if you are prepared to implement such a mechanism it's not difficult to do, and of course you can look at the source code for TThread.Synchronize for tips.
Borrowing from the source for TThread.Syncrhonize I have come up with the following. You will have to have the co-operating threads check their queues as part of their main loops - which is of course how TThread.Synchronize works.
The following code is based on code we use in production - my apologies if there are comments or references to items not in the unit. There is no mechanism to provide a result of the function, but that could be resolved with using different calling templates (so the result type is known). I have allowed for a Result TObject (even though there's no way to know what that should be currently) so that multi-valued results can be returned if needed.
There's no windows specific code in the following, so it should work on Linux as you requested.
unit Unit1;
interface
uses Classes, SyncObjs, Generics.Collections;
type
TQueuedCallback = class(TObject)
protected
_pEvent: TEvent;
_pResult: TObject;
_fnMethod: TThreadMethod;
_fnProcedure: TThreadProcedure;
public
property Event: TEvent read _pEvent write _pEvent;
property Result: TObject read _pResult write _pResult;
property Method: TThreadMethod read _fnMethod write _fnMethod;
property Proc: TThreadProcedure read _fnProcedure write _fnProcedure;
end;
TQueueableThread = class(TThread)
protected
_pCSLock: TCriticalSection;
_pQueuedCalls: TList<TQueuedCallback>;
_haSignals: THandleObjectArray;
_pQueueEvent: TEvent;
_pStopEvent: TEvent;
_dwMaxWait: Cardinal;
procedure _DoWork(nEventIndex: Integer); virtual; abstract; // where th thread does it's work
procedure _ExecuteQueued(blAll: Boolean = False); virtual;
public
destructor Destroy; override;
procedure AfterConstruction(); override;
procedure Execute(); override;
procedure QueueProcedure(fnMethod: TThreadMethod); overload; virtual;
procedure QueueProcedure(fnProcedure: TThreadProcedure); overload; virtual;
procedure QueueProcedureAndWait(fnMethod: TThreadMethod); overload; virtual;
procedure QueueProcedureAndWait(fnProcedure: TThreadProcedure); overload; virtual;
function QueueProcedureAndWaitForResult(fnMethod: TThreadMethod): TObject; overload; virtual;
function QueueProcedureAndWaitForResult(fnProcedure: TThreadProcedure): TObject; overload; virtual;
end;
implementation
uses SysUtils;
{ TQueueableThread }
procedure TQueueableThread._ExecuteQueued(blAll: Boolean);
begin
repeat
Self._pCSLock.Enter();
if(Self._pQueuedCalls.Count>0) then
begin
if(Assigned(Self._pQueuedCalls.Items[0].Method)) then
Self._pQueuedCalls.Items[0].Method()
else if(Assigned(Self._pQueuedCalls.Items[0].Proc)) then
Self._pQueuedCalls.Items[0].Proc();
// No mechanism for supplying a result ...
if(Self._pQueuedCalls.Items[0]._pEvent<>nil) then
Self._pQueuedCalls.Items[0]._pEvent.SetEvent()
else
Self._pQueuedCalls.Items[0].Free;
Self._pQueuedCalls.Delete(0);
end;
blAll:=(blAll And (Self._pQueuedCalls.Count>0));
Self._pCSLock.Leave();
until not blAll;
end;
destructor TQueueableThread.Destroy;
begin
if(Self._pQueuedCalls<>nil) then
begin
while(Self._pQueuedCalls.Count>0) do
begin
if(Self._pQueuedCalls.Items[0].Event<>nil) then
Self._pQueuedCalls.Items[0].Event.SetEvent()
else
Self._pQueuedCalls.Items[0].Free();
Self._pQueuedCalls.Delete(0);
end;
FreeAndNil(Self._pQueuedCalls);
end;
FreeAndNil(Self._pQueueEvent);
FreeAndNil(Self._pStopEvent);
FreeAndNil(Self._pCSLock);
inherited;
end;
procedure TQueueableThread.AfterConstruction();
begin
inherited;
Self._pCSLock:=TCriticalSection.Create();
Self._pQueuedCalls:=TList<TQueuedCallback>.Create();
SetLength(Self._haSignals, 2);
Self._pQueueEvent:=TEvent.Create();
Self._haSignals[0]:=Self._pQueueEvent;
Self._pStopEvent:=TEvent.Create();
Self._haSignals[1]:=Self._pStopEvent;
Self._dwMaxWait:=30000;
end;
procedure TQueueableThread.Execute();
var
dwWaitResult: TWaitResult;
nEventIndex: Integer;
nLoop: Integer;
pSignalled: THandleObject;
begin
while(not Self.Terminated) do
begin
//LogThreadMessage(GetCurrentThreadId(), Self.ClassType, Format('WaitingFor: %u', [Self._MaxWaitTime]));
dwWaitResult:=THandleObject.WaitForMultiple(Self._haSignals, Self._dwMaxWait, False, pSignalled);
//LogThreadMessage(GetCurrentThreadId(), Self.ClassType, Format('WaitForMultipleObjects Result: %u', [dwWaitResult]));
if(dwWaitResult=wrError) then
Self.Terminate;
if not Self.Terminated then
begin
if(pSignalled=Self._pQueueEvent) then
begin
Self._ExecuteQueued(True);
Self._pQueueEvent.ResetEvent();
end
else if(pSignalled=Self._pStopEvent) then
Self.Terminate()
else
begin
nEventIndex:=-2;
if(dwWaitResult=wrTimeout) then
nEventIndex:=-1
else
begin
nLoop:=0;
while( (nEventIndex<0) And (nLoop<Length(Self._haSignals)) ) do
begin
if(Self._haSignals[nLoop]=pSignalled) then
nEventIndex:=nLoop
else
Inc(nLoop);
end;
if(nEventIndex>-2) then
begin
try
Self._DoWork(nEventIndex);
except
on e: Exception do
// error handling
end;
end;
end;
end;
end;
end;
end;
procedure TQueueableThread.QueueProcedure(fnMethod: TThreadMethod);
var
pQueue: TQueuedCallback;
begin
if(Assigned(fnMethod)) then
begin
Self._pCSLock.Enter();
pQueue:=TQueuedCallback.Create();
pQueue.Method:=fnMethod;
Self._pQueuedCalls.Add(pQueue);
Self._pQueueEvent.SetEvent();
Self._pCSLock.Leave();
end;
end;
procedure TQueueableThread.QueueProcedure(fnProcedure: TThreadProcedure);
var
pQueue: TQueuedCallback;
begin
if(Assigned(fnProcedure)) then
begin
Self._pCSLock.Enter();
pQueue:=TQueuedCallback.Create();
pQueue.Proc:=fnProcedure;
Self._pQueuedCalls.Add(pQueue);
Self._pQueueEvent.SetEvent();
Self._pCSLock.Leave();
end;
end;
procedure TQueueableThread.QueueProcedureAndWait(fnMethod: TThreadMethod);
var
pQueue: TQueuedCallback;
begin
if(Assigned(fnMethod)) then
begin
Self._pCSLock.Enter();
pQueue:=TQueuedCallback.Create();
pQueue.Method:=fnMethod;
pQueue.Event:=TEvent.Create();
Self._pQueuedCalls.Add(pQueue);
Self._pQueueEvent.SetEvent();
Self._pCSLock.Leave();
pQueue._pEvent.WaitFor(INFINITE);
FreeAndNil(pQueue._pEvent);
FreeAndNil(pQueue);
end;
end;
procedure TQueueableThread.QueueProcedureAndWait(fnProcedure: TThreadProcedure);
var
pQueue: TQueuedCallback;
begin
if(Assigned(fnPRocedure)) then
begin
Self._pCSLock.Enter();
pQueue:=TQueuedCallback.Create();
pQueue.Proc:=fnProcedure;
pQueue.Event:=TEvent.Create();
Self._pQueuedCalls.Add(pQueue);
Self._pQueueEvent.SetEvent();
Self._pCSLock.Leave();
pQueue._pEvent.WaitFor(INFINITE);
FreeAndNil(pQueue._pEvent);
FreeAndNil(pQueue);
end;
end;
function TQueueableThread.QueueProcedureAndWaitForResult(fnMethod: TThreadMethod): TObject;
var
pQueue: TQueuedCallback;
begin
Result:=nil;
if(Assigned(fnMethod)) then
begin
Self._pCSLock.Enter();
pQueue:=TQueuedCallback.Create();
pQueue.Method:=fnMethod;
pQueue.Event:=TEvent.Create();
Self._pQueuedCalls.Add(pQueue);
Self._pQueueEvent.SetEvent();
Self._pCSLock.Leave();
pQueue._pEvent.WaitFor(INFINITE);
Result:=pQueue._pResult;
FreeAndNil(pQueue._pEvent);
FreeAndNil(pQueue);
end;
end;
function TQueueableThread.QueueProcedureAndWaitForResult(fnProcedure: TThreadProcedure): TObject;
var
pQueue: TQueuedCallback;
begin
Result:=nil;
if(Assigned(fnProcedure)) then
begin
Self._pCSLock.Enter();
pQueue:=TQueuedCallback.Create();
pQueue.Proc:=fnProcedure;
pQueue.Event:=TEvent.Create();
Self._pQueuedCalls.Add(pQueue);
Self._pQueueEvent.SetEvent();
Self._pCSLock.Leave();
pQueue._pEvent.WaitFor(INFINITE);
Result:=pQueue._pResult;
FreeAndNil(pQueue._pEvent);
FreeAndNil(pQueue);
end;
end;
end.
You could have inherited classes of TQueuedCallback that use a specific calling template, and this would be one way to identify the return value
I need to do a label to blink 5 times using a thread.
When I click on the button, I need the label blinks 5 times.
Now, I have a problem.
when I close the form I have a Memory Leak on Thread.
What am I doing wrong here?
type
TForm1= class(TForm)
...
labelNewMsg:Tlabel;
private
MEvent: TEvent;
procedure Torm1.FormCreate(Sender: TObject);
begin
MEvent := TEvent.Create(nil, False, False, '');
waitNewMessage();
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
MEvent.Free;
end;
procedure TForm1.ButtonDoSetEventClick(Sender: TObject);
begin
Mevent.SetEvent;
end;
procedure TForm1.waitNewMessage;
var
Status:TWaitResult;
begin
TThread.CreateAnonymousThread(
procedure
var IntCnt: Integer;
begin
while not TThread.CurrentThread.CheckTerminated and (not application.terminated) do begin
Sleep(100);
Status:=MEvent.WaitFor(INFINITE);
if Status=wrSignaled then begin
for IntCnt:=1 to 5 do begin
Sleep(1000);
TThread.Synchronize(nil,procedure begin
labelNewMsg.Visible:=not labelNewMsg.Visible;
end);
end;
IntCnt:=0;
MEvent.ResetEvent;
end;
end;
end
).Start;
end;
Hi, I created a second option, but I have the same problem:
procedure TFrm_PrincipalDemo.waitNewMessage;
var
Status:TWaitResult;
begin
TThread.CreateAnonymousThread(
procedure
var IntCnt: Integer;
begin
while MEvent.WaitFor(INFINITE) in [wrSignaled] do begin
if TThread.CurrentThread.CheckTerminated then exit;
MEvent.ResetEvent;
Sleep(100);
for IntCnt:=1 to 5 do begin
Sleep(1000);
TThread.Synchronize(nil,procedure begin
labelNewMsg.Visible:=not labelNewMsg.Visible;
end);
end;
if TThread.CurrentThread.CheckTerminated then exit;
end;
end
).Start;
end;
You are not signaling the thread to terminate itself before your Form is closed. For instance, if the thread is blocked waiting for MEvent, you need to signal MEvent so the thread can wake up and check for termination.
The Application.Terminated property is not set to True until the main message loop has processed a WM_QUIT message from PostQuitMessage(), which Application.Terminate() calls. The program's Application.MainForm calls Application.Terminate() when the Form is closed (not destroyed, that comes later).
If you keep a reference to the TThread object that you create, you can then call the TThread.Terminate() method directly, which sets the thread's Terminated property to True (otherwise, there is no point in calling TThread.CheckTerminated() inside of the thread at all), eg:
type
TForm1 = class(TForm)
...
labelNewMsg: TLabel;
ButtonDoSetEvent: TButton;
...
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; Action: TCloseAction);
procedure FormDestroy(Sender: TObject);
procedure ButtonDoSetEventClick(Sender: TObject);
...
private
MEvent: TEvent;
Thread: TThread;
procedure waitNewMessage;
procedure ThreadTerminated(Sender: TObject);
...
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
MEvent := TEvent.Create(nil, False, False, '');
waitNewMessage();
end;
procedure TForm1.FormClose(Sender: TObject; Action: TCloseAction);
begin
if Thread <> nil then
begin
Thread.Terminate;
MEvent.SetEvent;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
if Thread <> nil then
Thread.OnTerminate := nil;
MEvent.Free;
end;
procedure TForm1.ButtonDoSetEventClick(Sender: TObject);
begin
MEvent.SetEvent;
end;
procedure TForm1.waitNewMessage;
begin
Thread := TThread.CreateAnonymousThread(
procedure
var
IntCnt: Integer;
Status: TWaitResult;
begin
while not TThread.CheckTerminated do begin
Sleep(100);
Status := MEvent.WaitFor(INFINITE);
if (Status = wrSignaled) and (not TThread.CheckTerminated) then begin
for IntCnt := 1 to 5 do begin
Sleep(1000);
TThread.Synchronize(nil,
procedure
begin
labelNewMsg.Visible := not labelNewMsg.Visible;
end
);
end;
end;
end;
end
);
Thread.OnTerminate := ThreadTerminated;
Thread.Start;
end;
procedure TForm1.ThreadTerminated(Sender: TObject);
begin
Thread := nil;
end;
But really, why are you even using a thread at all? Nothing your thread does actually needs to be in a thread in the first place. A simple timer would suffice instead, and it would be safer for the UI, and easier to stop during program shutdown.
type
TForm1 = class(TForm)
...
labelNewMsg: TLabel;
ButtonDoSetEvent: TButton;
NewMsgTimer: TTimer;
...
procedure ButtonDoSetEventClick(Sender: TObject);
procedure NewMsgTimerTimer(Sender: TObject);
...
end;
procedure TForm1.ButtonDoSetEventClick(Sender: TObject);
begin
NewMsgTimer.Tag := 0;
NewMsgTimer.Enabled := True;
end;
procedure TForm1.NewMsgTimerTimer(Sender: TObject);
begin
NewMsgTimer.Tag := NewMsgTimer.Tag + 1;
labelNewMsg.Visible := not labelNewMsg.Visible;
if NewMsgTimer.Tag = 5 then
NewMsgTimer.Enabled := False;
end;
Is it possible to restart TEvent.WaitFor without exiting it? I need to start waiting again when _interval was changed by setter. For example, when one hour was set and I would like to change interval to 15 seconds, changes will come into effect when one hour is elapsed.
_terminatingEvent: TEvent;
procedure TTimerThread.Execute();
begin
inherited;
while not Terminated do begin
try
_terminatingEvent.WaitFor(_interval);
if Assigned(_onTimer) and _enabled then _onTimer(Self);
except
on ex: Exception do _logError(ex);
end;
end;
end;
procedure TTimerThread.TerminatedSet();
begin
_terminatingEvent.SetEvent();
end;
procedure TTimerThread._setInterval(const Value: Integer);
begin
_interval := Value;
//Restart WaitFor here
end;
Currently I "solved" the issue in a following way:
procedure TTimerThread.Execute();
begin
inherited;
while not Terminated do begin
try
if _terminatingEvent.WaitFor(_interval) = wrTimeout then
if Assigned(_onTimer) and _enabled then _onTimer(Self);
except
on ex: Exception do _logError(ex);
end;
end;
end;
procedure TTimerThread.TerminatedSet();
begin
_terminatingEvent.SetEvent();
end;
procedure TTimerThread._setInterval(const Value: Integer);
begin
_interval := Value;
_terminatingEvent.ResetEvent();
end;
It seems that when I use SetEvent instead of ResetEvent, the "set" state is saved permanently and CPU usage jumps to 100%.
You can use two TEvent objects, one for the timer and one for the setter, eg:
type
TTimerThread = class(TThread)
private
_terminatingEvent: TEvent;
_updatedEvent: TEvent;
...
protected
procedure Execute; override;
procedure TerminatedSet; override;
public
constructor Create(ASuspended: Boolean); reintroduce;
destructor Destroy; override;
end;
constructor TTimerThread.Create(ASuspended: Boolean);
begin
inherited Create(ASuspended);
_terminatingEvent := TEvent.Create(nil, True, False, '');
_updatedEvent := TEvent.Create(nil, False, False, '');
end;
destructor TTimerThread.Destroy;
begin
_terminatingEvent.Free;
_updatedEvent.Free;
inherited;
end;
procedure TTimerThread.Execute;
var
Arr: THandleObjectArray;
SignaledObj: THandleObject;
begin
SetLength(Arr, 2);
Arr[0] := _terminatingEvent;
Arr[1] := _updatedEvent;
while not Terminated do
begin
try
case THandleObject.WaitForMultiple(Arr, _interval, False, SignaledObj) of
wrSignaled: begin
if (SignaledObj is TEvent) then (SignaledObj as TEvent).ResetEvent();
end;
wrTimeOut: begin
if Assigned(_onTimer) and _enabled then
_onTimer(Self);
end;
wrError: begin
RaiseLastOSError;
end;
end;
except
on ex: Exception do
_logError(ex);
end;
end;
end;
procedure TTimerThread.TerminatedSet;
begin
inherited;
_terminatingEvent.SetEvent;
end;
procedure TTimerThread._setInterval(const Value: Integer);
begin
if _interval <> Value then
begin
_interval := Value;
_updatedEvent.SetEvent;
end;
end;
Finally I used a combination of SetEvent and ResetEvent. If somebody has a better answer, I will accept it.
procedure TTimerThread.Execute();
begin
inherited;
while not Terminated do begin
try
case _terminatingEvent.WaitFor(_interval) of
wrTimeout: if Assigned(_onTimer) and _enabled then _onTimer(Self);
wrSignaled: _terminatingEvent.ResetEvent();
end;
except
on ex: Exception do _logError(ex);
end;
end;
end;
procedure TTimerThread.TerminatedSet();
begin
_terminatingEvent.SetEvent();
end;
procedure TTimerThread._setInterval(const Value: Integer);
begin
_interval := Value;
_terminatingEvent.SetEvent();
end;
procedure TTimerThread._setEnabled(const Value: Boolean);
begin
if _enabled = Value then Exit();
_enabled := Value;
if _enabled and Suspended then Suspended := False;
_terminatingEvent.SetEvent();
end;
I'm trying to put an indy TIdHttp in a thread,
I have tried this :
type
TSendThread = class(TThread)
private
{ Private declarations }
protected
procedure Execute; override;
public
http : TIdHTTP;
URL : String;
Method : String;
property ReturnValue;
end;
procedure TSendThread.Execute;
begin
form1.Memo1.lines.Add(http.Get(URL));
ReturnValue := 1;
end;
And in the main :
procedure TForm1.Button1Click(Sender: TObject);
var t : TSendThread;
begin
t := TSendThread.Create(true);
t.URL := 'http://www.url.com/';
t.http := http;
t.Start;
showmessage(IntToStr(t.ReturnValue));
end;
My problem here is that the next instruction gets executed(showmessage) without waiting the thread to be done, i tried to use the "WaitFor" but it freezes the application.
Is there any other workaround?
Thank you.
Use the TThread.OnTerminate event to know when the thread has finished:
type
TSendThread = class(TThread)
private
http : TIdHTTP;
Line: string;
procedure AddLine;
protected
procedure Execute; override;
public
constructor Create; reintroduce;
destructor Destroy; override;
URL : String;
Method : String;
property ReturnValue;
end;
constructor TSendThread.Create;
begin
inherited Create(True);
FreeOnTerminate := True;
http := TIdHTTP.Create;
end;
destructor TSendThread.Destroy;
begin
http.Free;
inherited;
end;
procedure TSendThread.Execute;
begin
Line := http.Get(URL);
Synchronize(AddLine);
ReturnValue := 1;
end;
procedure TSendThread.AddLine;
begin
Form1.Memo1.Lines.Add(Line);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
t : TSendThread;
begin
t := TSendThread.Create;
t.URL := 'http://www.url.com/';
t.OnTerminate := ThreadTerminated;
t.Start;
end;
procedure TForm1.ThreadTerminated(Sender: TObject);
begin
ShowMessage(IntToStr(TSendThread(Sender).ReturnValue));
end;
If you want to use a loop to wait for the thread to finish, without blocking the UI, then you can do it like this:
constructor TSendThread.Create;
begin
inherited Create(True);
//FreeOnTerminate := True; // <-- remove this
http := TIdHTTP.Create;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
t : TSendThread;
h : THandle;
begin
t := TSendThread.Create;
try
t.URL := 'http://www.url.com/';
t.Start;
h := t.Handle;
repeat
case MsgWaitForMultipleObjects(1, h, 0, INFINITE, QS_ALLINPUT) of
WAIT_OBJECT_0: Break;
WAIT_OBJECT_0+1: Application.ProcessMessages;
WAIT_FAILED: RaiseLastOSError;
else
Break;
end;
until False;
ShowMessage(IntToStr(t.ReturnValue));
finally
t.Free;
end;
end;
Download the source code with compiled executable (221 KB (226,925 bytes)): http://www.eyeclaxton.com/download/delphi/skeleton.zip
Why doesn't the Destroy destructor get called if I close the application (click the X button) before the thread has terminated? FastMM4 reports a memory leak with FPauseEvent event.
How should i destroy thread? If someone closes the application before the thread finishes.
unit SkeletonThread;
interface
uses
Windows, Classes, SysUtils, SyncObjs;
type
TOnInitialize = procedure(Sender: TObject; const AMaxValue: Integer) of object;
TOnBegin = procedure(Sender: TObject) of object;
TOnProgress = procedure(Sender: TObject; const APosition: Integer) of object;
TOnPause = procedure(Sender: TObject; const APaused: Boolean) of object;
TOnFinish = procedure(Sender: TObject) of object;
TOnFinalize = procedure(Sender: TObject) of object;
TMasterThread = class(TThread)
private
{ Private declarations }
FPaused: Boolean;
FPosition: Integer;
FMaxValue: Integer;
FOnBegin: TOnBegin;
FOnProgress: TOnProgress;
FOnFinish: TOnFinish;
FOnInitialize: TOnInitialize;
FOnFinalize: TOnFinalize;
FPauseEvent: TEvent;
FOnPause: TOnPause;
procedure BeginEvent();
procedure ProgressEvent();
procedure FinishEvent();
procedure InitializeEvent();
procedure FinalizeEvent();
procedure PauseEvent();
procedure CheckForPause();
protected
{ Protected declarations }
procedure DoInitializeEvent(const AMaxValue: Integer); virtual;
procedure DoBeginEvent(); virtual;
procedure DoProgress(const APosition: Integer); virtual;
procedure DoPauseEvent(const APaused: Boolean); virtual;
procedure DoFinishEvent(); virtual;
procedure DoFinalizeEvent(); virtual;
public
{ Public declarations }
constructor Create(const CreateSuspended: Boolean; const theValue: Integer);
destructor Destroy(); override;
procedure Pause();
procedure Unpause();
published
{ Published declarations }
property IsPaused: Boolean read FPaused write FPaused default False;
property OnInitialize: TOnInitialize read FOnInitialize write FOnInitialize default nil;
property OnBegin: TOnBegin read FOnBegin write FOnBegin default nil;
property OnProgress: TOnProgress read FOnProgress write FOnProgress default nil;
property OnPause: TOnPause read FOnPause write FOnPause default nil;
property OnFinish: TOnFinish read FOnFinish write FOnFinish default nil;
property OnFinalize: TOnFinalize read FOnFinalize write FOnFinalize default nil;
end;
TSkeletonThread = class(TMasterThread)
private
{ Private declarations }
procedure DoExecute(const theValue: Integer);
protected
{ Protected declarations }
procedure Execute(); override;
public
{ Public declarations }
published
{ Published declarations }
end;
implementation
{ TMasterThread }
constructor TMasterThread.Create(const CreateSuspended: Boolean; const theValue: Integer);
begin
inherited Create(CreateSuspended);
Self.FreeOnTerminate := True;
Self.FPosition := 0;
Self.FMaxValue := theValue;
Self.FPaused := False;
Self.FPauseEvent := TEvent.Create(nil, True, True, '');
end;
destructor TMasterThread.Destroy();
begin
FreeAndNil(FPauseEvent);
if (Pointer(FPauseEvent) <> nil) then Pointer(FPauseEvent) := nil;
inherited Destroy();
end;
procedure TMasterThread.DoBeginEvent();
begin
if Assigned(Self.FOnBegin) then Self.FOnBegin(Self);
end;
procedure TMasterThread.BeginEvent();
begin
Self.DoBeginEvent();
end;
procedure TMasterThread.DoProgress(const APosition: Integer);
begin
if Assigned(Self.FOnProgress) then Self.FOnProgress(Self, APosition);
end;
procedure TMasterThread.ProgressEvent();
begin
Self.DoProgress(Self.FPosition);
end;
procedure TMasterThread.DoFinishEvent();
begin
if Assigned(Self.FOnFinish) then Self.FOnFinish(Self);
end;
procedure TMasterThread.FinishEvent();
begin
Self.DoFinishEvent();
end;
procedure TMasterThread.DoInitializeEvent(const AMaxValue: Integer);
begin
if Assigned(Self.FOnInitialize) then Self.FOnInitialize(Self, AMaxValue);
end;
procedure TMasterThread.InitializeEvent();
begin
Self.DoInitializeEvent(Self.FMaxValue);
end;
procedure TMasterThread.DoFinalizeEvent();
begin
if Assigned(Self.FOnFinalize) then Self.FOnFinalize(Self);
end;
procedure TMasterThread.FinalizeEvent;
begin
Self.DoFinalizeEvent();
end;
procedure TMasterThread.DoPauseEvent(const APaused: Boolean);
begin
if Assigned(Self.FOnPause) then Self.FOnPause(Self, APaused);
end;
procedure TMasterThread.PauseEvent();
begin
Self.DoPauseEvent(Self.FPaused);
end;
procedure TMasterThread.Pause();
begin
Self.FPauseEvent.ResetEvent();
Self.FPaused := True;
Self.Synchronize(Self.PauseEvent);
end;
procedure TMasterThread.Unpause();
begin
Self.FPaused := False;
Self.Synchronize(Self.PauseEvent);
Self.FPauseEvent.SetEvent();
end;
procedure TMasterThread.CheckForPause();
begin
if (not (Self.Terminated)) then Windows.Sleep(1);
Self.FPauseEvent.WaitFor(INFINITE);
end;
{ TSkeletonThread }
procedure TSkeletonThread.DoExecute(const theValue: Integer);
var
X: Integer;
begin
Self.Synchronize(InitializeEvent);
try
Self.Synchronize(BeginEvent);
try
for X := 0 to (theValue - 1) do
begin
Self.CheckForPause();
if (not Self.FPaused) and (not Self.Terminated) then
begin
Self.FPosition := Self.FPosition + 1;
Self.Synchronize(ProgressEvent);
end
else begin
Break;
end;
end;
for X := Self.FPosition downto 1 do
begin
Self.CheckForPause();
if (not Self.FPaused) and (not Self.Terminated) then
begin
Self.FPosition := X;
Self.Synchronize(ProgressEvent);
end
else begin
Break;
end;
end;
finally
Self.Synchronize(FinishEvent);
end;
finally
Self.Synchronize(FinalizeEvent);
end;
end;
procedure TSkeletonThread.Execute();
begin
Self.DoExecute(Self.FMaxValue);
end;
end.
You have to terminate the thread yourself (tell it to stop). One way is to use the Terminate procedure of the thread, but you have to check for this in the thread Execute method. Something like this:
procedure Execute;
begin
inherited;
while not Terminated do
begin
// do your job
end;
end;
procedure TForm1.StopThread;
begin
MyThread.Terminate;
// wait and block until the scheduling thread is finished
AResult := WaitForSingleObject(MyThread.Handle, cShutdownTimeout);
// check if we timed out
if AResult = WAIT_TIMEOUT then
TerminateThread(MyThread.Handle, 0);
end;
Or you can use signalization build into windows so you do not have to loop.
procedure Execute;
begin
inherited;
while not Terminated do
begin
WaitStatus := WaitForSingleObject(FTermEvent, Max(0, SleepInterval));
// check what was the cause for signalization
if WaitStatus <> WAIT_TIMEOUT then
Terminate;
end;
end;
procedure TForm1.StopThread;
begin
// Terminate the thread
SetEvent(FTermEvent);
// close the handle
CloseHandle(FTermEvent);
// wait and block until the scheduling thread is finished
AResult := WaitForSingleObject(MyThread.Handle, cShutdownTimeout);
// check if we timed out
if AResult = WAIT_TIMEOUT then
TerminateThread(MyThread.Handle, 0);
end;
Signalization can be very neat way of signaling for termination because you can use WaitForMultipleObjects and release the wait in different conditions. I used WaitForSingleObject to not complicate things to much.
Also be sure to set "FreeOnTerminate := True" in thread constructor. Oh and the hard termination at the end is optional of course. It can be dangerous. You know best yourself if you will use it or not. You can also wait for a longer period or infinite if you are sure the thread will stop eventually.