I have such thread safe class for file system objects:
type
PFSObject = ^TFSObject;
TFSObject = class
private
FMREW: TMREWSync;
FChildren: TObjectList<TFSObject>;
FFilesCount: UInt32;
FFoldersCount: UInt32;
FName: string;
FParent: TFSObject;
function GetFullPath: string;
public
constructor Create(const AName: string; AParent: TFSObject; AFilesCount, AFoldersCount: UInt32 = 0);
destructor Destroy; override;
property Children: TObjectList<TFSObject> read FChildren write FChildren;
property FilesCount: UInt32 read FFilesCount write FFilesCount;
property FoldersCount: UInt32 read FFoldersCount write FFoldersCount;
property Name: string read FName write FName;
property Parent: TFSObject read FParent write FParent;
procedure LockRead;
procedure LockWrite;
procedure UnlockRead;
procedure UnlockWrite;
end;
Have thread, which scan file system and fill this.
On the main form have Timer, which receiving data from this class to show in TVirtualStringTree.
Which is the best method to show such data in TVirtualStringTree without loosing additional memory to store copy of data in Nodes?
Update:
Ok, what I have now.
type
PSizeData = ^TSizeData;
TSizeData = record
FSObj: PFSObject;
end;
// OnTimer reader
procedure TformSize.tmrSizeTimer(Sender: TObject);
begin
if tvSize.RootNodeCount = 0 then
tvSize.RootNodeCount := 1
else begin
tvSize.Repaint;
if FSThread.Finished then begin
// Thread finished, disable timer
SetTimerEnabled(False);
// Expant first node
tvSize.Expanded[tvSize.GetFirst] := True;
end;
end;
end;
// GetText of TVirtualStringTree
procedure TformSize.tvSizeGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;
TextType: TVSTTextType; var CellText: string);
var
Data, ParData: PSizeData;
begin
// Check that children count changed for node
Data := tvSize.GetNodeData(Node);
if (Int32(Node.ChildCount) <> Data.FSObj.Children.Count) then begin
tvSize.ChildCount[Node] := Data.FSObj.Children.Count;
// Check that children count changed for parent node
ParData := tvSize.GetNodeData(Node.Parent);
if Assigned(ParData) and (Int32(Node.Parent.ChildCount) <> ParData.FSObj.Children.Count) then
tvSize.ChildCount[Node.Parent] := ParData.FSObj.Children.Count;
end;
// Get node text
CellText := GetSizeDataText(Data, Column);
end;
// InitNode of TVirtualStringTree
procedure TformSize.tvSizeInitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode;
var InitialStates: TVirtualNodeInitStates);
var
Data, ParData: PSizeData;
PFSObj: PFSObject;
begin
Data := Sender.GetNodeData(Node);
if not Assigned(ParentNode) then
PFSObj := #FSThread.FSObject
else begin
ParData := Sender.GetNodeData(ParentNode);
PFSObj := PFSObject(ParData.FSObj.Children[Node.Index]);
end;
Data.FSObj := PFSObj;
end;
And now I have out of memory in TVirtualStringTree :(
where is my error?
That's for sure a threading issue between the VCL main thread and the file reading / writing thread.
When using VCL (remember: TVirtualStringTree is a VCL component) you need to synchronize additional threads with the VCL main thread.
What i've done in the past to avoid these kind of issues:
create a mutex in the VCL main thread (aka your TForm or something)
create the thread and pass the mutex to it
run the thread and when accessing VCL properties do a mutex lock before and a mutex unlock after
in VCL main thread do a mutex lock / unlock also
Basically you should never access or change VCL properties from additional threads without secure synchronization.
Related
I'm beginner in Delphi programing.
I use a thread to communicate with my server and I want to pass a Tevent to my thread at creation time and use it to signal a task on this thread from main thread and finally on thread clear the event. This event set in main thread to signal the task on my net thread and finally clear after task completed in the net thread.
I use this line to create thread on run time. All work fine but after adding event to my code rise a problem.
Net_thread:= TNetThread.Create(user, password, TheCallback, Tevent);
TNetThread is my thread class on other unit and Net_thread is my net thread.
TheCallback is a procedure for change UI from thread. Declare this type in TNetThread.
user, password are login data collected in GUI.
Tevent is a handle to my event created in main thread and pass it to Net_thread.
Before I add event to my code I only pass 2 string and a procedure to thread and I have no problem. ...Create(user, password, TheCallback); after add event to my code and pass it as THandle to my thread can not use it. Its like a Cardinal variable and when I try to check its state with this code:
System.SyncObjs.TEvent.WaitFor(FEvent)
I have an error e2076. FEvent set on constructor TNetThread.Create and equal to Tevent received from main thread.
Please give me a simple example?
This is my minimal code:
on main form:
procedure TMainform.FormCreate(Sender: TObject);
var
T_event: THandle;
begin
T_event: := CreateEvent(nil, True, False, nil);
Net_thread:= TNetThread.Create(user, password, TheCallback, T_event);
end;
procedure TMainform.TheCallback(const st,h : String);
begin
//recive data from net thread
end;
on event in main thread
SetEvent(T_event);
And on other unit
type
TMyCallback = procedure(const st, h : String) of object;
TNetThread = class(TThread)
IdTCPClient1: TIdTCPClient;
private
FCallback : TMyCallback;
FEvent: THandle;
protected
procedure execute; override;
procedure SendLog(st, h: string);
public
constructor Create(user_n, psw: string ;aCallback : TMyCallback ; const AEvent: THandle);
end;
constructor TNetThread.Create(user_n, psw: string ;aCallback: TMyCallback; const AEvent: THandle);
begin
inherited Create(false);
FCallback := aCallback;
FEvent := AEvent;
user_name := user_n;
password:= psw;
FreeOnTerminate := true;
end;
procedure TNetThread.SendLog(st ,h: string);
begin
if not Assigned(FCallback) then
Exit;
Self.Queue( // Executed later in the main thread
procedure
begin
FCallback(st, h);
end
);
end;
procedure TNetThread.Execute;
begin
.
.
if (System.SyncObjs.TEvent.WaitFor(FEvent) = wrSignaled) then...
.
.
end;
I have multithreaded app and I have a question regarding assigning objects between threads and how to lock them properly.
I defined custom type class and in main thread I create an instance of that type. I would like to assign different objects to a thread, those objects will be used within Execute method of a thread.
type TMyClass = class
private
FData: Integer;
public
property Data: Integer read FData write FData;
end;
TMyThread = class(TThread)
private
FMyObject: TMyObject;
FLock: TCriticalSection;
protected
procedure Execute; override;
public
procedure Lock;
procedure Unlock;
property MyObject: TMyObject read FMyObject write FMyObject;
end;
procedure TMyThread.Lock;
begin
FLock.Acquire;
end;
procedure TMyThread.Unlock;
begin
FLock.Release;
end;
procedure TMyThread.Execute;
begin
while not Terminated do
begin
Lock;
try
if Assigned(FMyObject) then
FMyObject.Data := FMyObject.Data + 1;
finally
Unlock;
end;
end;
end;
from main thread:
var MyObject1, MyObject2: TMyObject;
thOperation: TMyThread;
CurrData1, CurrData2: Integer;
begin
// create two objects
MyObject1 := TMyObject.Create;
MyObject2 := TMyObject.Create;
// create thread(started)
thOperation := TMyThread.Create(false);
thOperation.Lock;
try
thOperation.MyObject := MyObject1;
finally
thOperation.Unlock;
end;
/// .... do some stuff in main thread
thOperation.Lock;
try
CurrData1 := thOperation.MyObject.Data;
finally
Unlock;
end;
// let's assign new object on a running thread
thOperation.Lock;
try
thOperation.MyObject := MyObject2;
finally
thOperation.Unlock;
end;
/// .... do some stuff in main thread again
thOperation.Lock;
try
CurrData2 := thOperation.MyObject.Data;
finally
Unlock;
end;
if CurrData1 <> CurrData2 then ShowMessage('Different result!');
// do cleanup
thOperation.Terminate;
thOperation.WaitFor;
thOperation.Free;
MyObject1.Free;
MyObject2.Free;
end;
Is this approach of locking when assigning different objects to a thread ok?
To answer your question, yes, your approach of using TCriticalSection is ok.
For more information on multithreading, in case you don't have it yet, Google for 'Multithreading - The Delphi way' by Martin Harvey. An excellent article (or should I say book).
I am implementing a pool of objects in Delphi. I need to synchronize the threads to get the objects from the pool.
Thread Code:
uClientQueryPool.CLIENT_POOL_GUARD.Acquire();
QueryClient := QUERY_POOL.GetClient();
uClientQueryPool.CLIENT_POOL_GUARD.Release;
Pool Code:
var
CLIENT_POOL_GUARD: TCriticalSection;
type
TClientQueryPool = class
public
function GetClient(): TQueryClient;
end;
The CLIENT_POOL_GUARD is a unit variable. The pool is working well, but can I use "uClientQueryPool.CLIENT_POOL_GUARD.Acquire();" and "uClientQueryPool.CLIENT_POOL_GUARD.Release;" inside the GetClient method?
Like this:
function TClientQueryPool.GetClient: TQueryClient;
begin
CLIENT_POOL_GUARD.Acquire();
...
CLIENT_POOL_GUARD.Release;
end;
Moving the lock inside the get/pop/whatever method is just fine, as is making the CriticalSection instance a private member of the pool class. Use the same CS in the release() call that pushes the objects back onto the pool.
Been doing this for decades, usually with TObjectQueue as the pool queue, a CS to protect it and a semaphore to count the pool contents and something for requesting threads to block on if the pool empties temporarily.
Don't know where that 'double acquire' thread came from. Either the lock is inside the pool class, or outside. I really can't imagine why anyone would code up both!
Example classes:
First, thread-safe P-C queue, for holding the pooled objects:
unit tinySemaphoreQueue;
interface
uses
Windows, Messages, SysUtils, Classes,syncObjs,contnrs;
type
pObject=^Tobject;
TsemaphoreMailbox=class(TobjectQueue)
private
countSema:Thandle;
protected
access:TcriticalSection;
public
property semaHandle:Thandle read countSema;
constructor create; virtual;
procedure push(aObject:Tobject); virtual;
function pop(pResObject:pObject;timeout:DWORD):boolean; virtual;
end;
implementation
{ TsemaphoreMailbox }
constructor TsemaphoreMailbox.create;
begin
inherited Create;
access:=TcriticalSection.create;
countSema:=createSemaphore(nil,0,maxInt,nil);
end;
function TsemaphoreMailbox.pop(pResObject: pObject;
timeout: DWORD): boolean;
begin // wait for a unit from the semaphore
result:=(WAIT_OBJECT_0=waitForSingleObject(countSema,timeout));
if result then // if a unit was supplied before the timeout,
begin
access.acquire;
try
pResObject^:=inherited pop; // get an object from the queue
finally
access.release;
end;
end;
end;
procedure TsemaphoreMailbox.push(aObject: Tobject);
begin
access.acquire;
try
inherited push(aObject); // shove the object onto the queue
finally
access.release;
end;
releaseSemaphore(countSema,1,nil); // release one unit to semaphore
end;
end.
then object pool:
unit tinyObjectPool;
interface
uses
Windows, Messages, SysUtils, Classes,syncObjs,contnrs,
tinySemaphoreQueue;
type
TobjectPool=class;
TpooledObject=class(TObject)
private
FmyPool:TObjectPool;
protected
Fparameter:TObject;
public
procedure release;
constructor create(parameter:TObject); virtual;
end;
TpooledObjectClass=class of TpooledObject;
TobjectPool=class(TsemaphoreMailbox)
private
Fparameter:TObject;
function getPoolLevel: integer;
public
property poolLevel:integer read getPoolLevel;
constructor create(poolDepth:integer;
pooledObjectClass:TpooledObjectClass;parameter:TObject); reintroduce; virtual;
end;
implementation
{ TobjectPool }
constructor TobjectPool.create(poolDepth: integer;
pooledObjectClass: TpooledObjectClass;parameter:TObject);
var objectCount:integer;
thisObject:TpooledObject;
begin
inherited create;
Fparameter:=parameter; // a user parameter passed to all objects
for objectCount:=0 to poolDepth-1 do // fill up the pool with objects
begin
thisObject:=pooledObjectClass.create(parameter);
thisObject.FmyPool:=self;
inherited push(thisObject);
end;
end;
function TobjectPool.getPoolLevel: integer;
begin
access.acquire;
result:=inherited count;
access.release;
end;
{ TpooledObject }
constructor TpooledObject.create(parameter: TObject);
begin
inherited create;
Fparameter:=parameter;
end;
procedure TpooledObject.release;
begin
FmyPool.push(self);
end;
end.
Yes you can. Note, though that although you can pull an object from the pool in a thread-safe manner, it may not be thread-safe to use it if the object itself isn't thread-safe. For instance, in the example below, the pool is thread safe and even makes threads wait if all objects in the pool are in use, but once an object is in use, using it still is not thread safe, because it uses global data.
uses
SyncObjs;
var
GlobalData: Integer = 0;
type
TDataObject = class
Used: Boolean;
procedure UpdateData;
end;
type
TPool = class
FLock: TCriticalSection;
FSemaphore: TSemaphore;
FDataObjects: array[0..9] of TDataObject;
constructor Create;
destructor Destroy; override;
function GetDataObject: TDataObject;
procedure ReleaseDataObject(AObject: TDataObject);
end;
var
Pool: TPool;
type
TDataThread = class(TThread)
constructor Create;
procedure Execute; override;
end;
{ TPool }
constructor TPool.Create;
var
i: Integer;
begin
inherited Create;
FLock := TCriticalSection.Create;
FSemaphore := TSemaphore.Create(nil, Length(FDataObjects), Length(FDataObjects), '', False);
for i := Low(FDataObjects) to High(FDataObjects) do
FDataObjects[i] := TDataObject.Create;
end;
destructor TPool.Destroy;
var
i: Integer;
begin
for i := Low(FDataObjects) to High(FDataObjects) do
FDataObjects[i].Free;
FSemaphore.Free;
FLock.Free;
end;
function TPool.GetDataObject: TDataObject;
var
i: Integer;
begin
Result := nil;
FLock.Acquire;
try
FSemaphore.Acquire;
for i := Low(FDataObjects) to High(FDataObjects) do
if not FDataObjects[i].Used then
begin
Result := FDataObjects[i];
Result.Used := True;
Exit;
end;
Assert(Result <> nil, 'Pool did not return an object');
finally
FLock.Release;
end;
end;
procedure TPool.ReleaseDataObject(AObject: TDataObject);
begin
if not AObject.Used then
raise Exception.Create('Data object cannot be released, because it is not in use.');
AObject.Used := False;
FSemaphore.Release;
end;
{ TDataObject }
procedure TDataObject.UpdateData;
begin
Inc(GlobalData);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
TDataThread.Create;
end;
{ TDataThread }
constructor TDataThread.Create;
begin
inherited Create(True);
FreeOnTerminate := True;
Resume;
end;
procedure TDataThread.Execute;
var
DataObject: TDataObject;
begin
DataObject := Pool.GetDataObject;
DataObject.UpdateData; // <-- Not thread-safe!
Pool.ReleaseDataObject(DataObject);
end;
initialization
Pool := TPool.Create;
finalization
Pool.Free;
end.
1) I'd remove Acquire/Release code from threads code - it is fragile. In one thread you forget to call it - and ba-bang! Security measures, as a rule of thumb, should be centralized and enforced by server, not distributed in fuzzy way in clients.
2) Acquire/Release calls should be guarded from errors, else any stray exception would forever lock all the threads.
function TClientQueryPool.GetClient: TQueryClient;
begin
CS.Acquire;
try
// actually getting object, preferably just calling
// internal non-public thread-unsafe method for it
finally
CS.Release;
end;
end;
3) Critical section itself should better be a Pool's internal, non-public member. That way you would be allowed in future, when you forget of implementation details, easy refactoring, like:
3.1) implementing several pools
3.2) moving pool code to another unit
3.3) ensuring any stray erroneous code outside pool would not be able to crash the application be randomly acquiring or releasing the CS
4) Double calling of acquire/release over TCriticalSection object puts all your bets over implications from a single note in TCriticalSection documentation, pointed to by The_Fox.
"Each call to Release should be balance by an earlier call to Acquire"
http://docwiki.embarcadero.com/Libraries/en/System.SyncObjs.TCriticalSection.Release
And over the hope that all other Pascal implementations today and tomorrow would not miss it.
That is fragile practice. And multi-threading code is famous for creating Heisenbugs, when there are problems at clients sites, but you can not reproduce and find it in house.
If in future your company would expand to different platform or different language implementation, that puts a potential land mine. And the kind of mine, that would be hard to find by testing in house. Multithreading code is the place where you'd better be over-defeinsive and just do not allow ANY uncertainty to happen.
i tried to use the openDialog in new thread but it made so strange behavior ..
if i put the if opendialog.execute then in the create constructor like this :
constructor TChatMemberThread.Create(Name: string);
begin
inherited Create(True);
FName := Name;
FreeOnTerminate := True;
Opendialog := TOpenDialog.create(nil);
if opendialog.execute then
for 0 to opendialog.filescount do
somecodeishere
end;
end;
the opendialog open normally but when i put it in the execute producer of the thread it didn't open at all !!
i'm so beginner in threads so can any one explain for me what happened ?
Thanks in advance .
[Edit]
unit Unit1;
interface
uses
Classes,Dialogs,ComCtrls,SysUtils,DCPcrypt2, DCPmd5;
type
TOpenThread = class(TThread)
private
{ Private declarations }
OpenDlG : TOpenDialog;
LI : TListItem;
Procedure Openit;
Function MD5it(Const filename : string ):String;
protected
procedure Execute; override;
Public
Constructor Create;
Destructor Destroy;Override;
end;
implementation
uses Main;
{ TOpenThread }
Constructor TOpenThread.Create;
begin
inherited Create(True);
opendlg := Topendialog.Create(nil);
opendlg.Filter := 'All Files | *.*';
openDlg.Options := [OfAllowMultiSelect];
openDlg.InitialDir := GetCurrentDir;
end;
Destructor TOpenThread.Destroy;
begin
OpenDlg.Free;
inherited;
end;
Function TOpenThread.MD5it(Const filename : string ):String;
var
hash : TDCP_MD5 ;
Digest: array[0..15] of byte;
Source: TFileStream;
i: integer;
s: string;
begin
Source:= nil;
try
Source:= TFileStream.Create(filename,fmOpenRead); // open the file specified by Edit1
except
MessageDlg('Unable to open file',mtError,[mbOK],0);
end;
if Source <> nil then
begin
Hash:= TDCP_MD5.Create(nil); // create the hash
Hash.Init; // initialize it
Hash.UpdateStream(Source,Source.Size); // hash the stream contents
Hash.Final(Digest); // produce the digest
Source.Free;
s:= '';
for i:= 0 to 15 do
s:= s + IntToHex(Digest[i],2);
Result := s;
end;
Hash.Free;
end;
Procedure TOpenThread.Openit;
var
I: Integer;
begin
if opendlg.Execute then
begin
for I := 0 to openDlg.Files.Count - 1 do begin
LI := Form1.LV1.Items.Add;
LI.Caption := ExtractFileName(openDlg.Files[i]);
LI.SubItems.Add(MD5it(openDlg.Files[i]));
LI.SubItems.add(openDlg.Files[i]);
end;
//SB.Panels[0].Text := ' '+IntToStr(LV1.Items.Count)+' File(s)';
OpenDlg.Free;
end;end;
procedure TOpenThread.Execute;
begin
{ Place thread code here }
Synchronize(OpenIt);
end;
end.
It works when you call it in the constructor because the constructor runs in the context of the calling thread (ie the main thread), whereas Execute() runs in the context of the worker thread. The VCL is not thread-safe, and UI components in particular rarely if ever work correctly outside of the main thread. If you want to display an open dialog in a thread, then have your TThread.Execute() method either:
1) call TThread.Synchronize() to access the TOpenDialog within the context of the main thread.
2) call the Win32 API GetOpenFileName() function directly instead. API dialogs can be safely used in threads when used properly.
I just hit a similar case in Delphi XE2 but I suppose it can happen in 2009 too.
Delphi was uplifted to use new Windows Vista open/save dialogs, which are COM-based components instead of old flat C-style API.
https://msdn.microsoft.com/library/windows/desktop/bb776913.aspx
I was adding a debug logging function, and it used to call PromptForFileName if the dump file name was not set yet. The function never did a thing.
I traced into Delphi RTL/VCL internals and reached function TCustomFileSaveDialog.CreateFileDialog in Dialogs.pas.
The said function was calling into Microsoft COM API, but then - oops! - just suppressed all the errors that could be returned. I used CPU Window in the Delphi Debugger and saw EAX register having $800401f0 error, which stands for 'COM was not initialized yet' situation.
https://msdn.microsoft.com/en-us/library/cc704587.aspx
I knew for sure that the said function worked perfectly in other places of the program, so I supposed it was - unexpectedly for me - executing in a separate thread. That was the case. In your case you DO KNOW already you have multithreading issues, and I think you may try the direct solution, instead of the workaround with Synchronize
uses ActiveX, Windows;
constructor TChatMemberThread.Create(Name: string);
var COM_Init_Here: Boolean;
begin
inherited Create(True);
FName := Name;
FreeOnTerminate := True;
COM_Init_Here := S_OK = CoInitialize(nil); // ***
try // ***
Opendialog := TOpenDialog.create(nil);
if opendialog.execute then
for 0 to opendialog.filescount do
somecodeishere
end;
finally // ***
if COM_Init_Here then CoUnInitialize(); // ***
end; // ***
end;
I'm new to multithreading, but not a complete novice. I need to perform a call to a webservice in a worker thread.
In the main thread I have a form (TForm) with a private data member (private string) that only the worker thread will write to (I pass the a pointer to it into the thread before it resumes). When the worker thread has finished its webservice call and written the resultant response xml to the private member on the form, the worker thread uses PostMessage to send a message to the form's handle (which I also passed into the thread before it resumed).
interface
const WM_WEBSERVCALL_COMPLETE = WM_USER + 1;
type
TWebServiceResponseXML = string;
PWebServiceResponseXML = ^TWebServiceResponseXML;
TMyForm = class(TForm)
...
private
...
fWorkerThreadID: Cardinal;
fWebServiceResponseXML: TWebServiceResponseXML;
public
...
procedure StartWorkerThread;
procedure OnWebServiceCallComplete(var Message: TMessage); Message WM_WEBSERVCALL_COMPLETE;
end;
TMyThread = class(TThread)
private
protected
procedure Execute; override;
public
SenderHandle: HWnd;
RequestXML: string;
ResponseXML: string;
IMyService: IService;
PResponseXML: PWebServiceResponseXML;
end;
implementation
procedure TMyForm.StartWorkerThread;
var
MyWorkerThread: TMyThread;
begin
MyWorkerThread := TMyThread.Create(True);
MyWorkerThread.FreeOnTerminate := True;
MyWorkerThread.SenderHandle := self.Handle;
MyWorkerThread.RequestXML := ComposeRequestXML;
MyWorkerThread.PResponseXML := ^fWebServiceResponseXML;
MyWorkerThread.Resume;
end;
procedure TMyForm.OnWebServiceCallComplete(var Message: TMessage);
begin
// Do what you want with the response xml string in fWebServiceResponseXML
end;
procedure TMyThread.Execute;
begin
inherited;
CoInitialize(nil);
try
IMyService := IService.GetMyService(URI);
ResponseXML := IMyService.Search(RequestXML);
PResponseXML := ResponseXML;
PostMessage(SenderHandle, WM_WEBSERVCALL_COMPLETE, 0, 0);
finally
CoUninitialize;
end;
end;
It works great, but now I want to do the same thing from a datamodule (which doesn't have a Handle)... so I would really appreciate some useful code to supplement the working model I have.
EDIT
What I really want is the code (if possible) that would allow me to replace the line
MyWorkerThread.SenderHandle := self.Handle;
with
MyWorkerThread.SenderHandle := GetHandleForThisSOAPDataModule;
I have used this technique before with some success: Sending messages to non-windowed applications
Basically, use a second thread as a message pump on a handle obtained via AllocateHWND. This is admittedly irritating, and you would be better off using a library to handle all the details. I prefer OmniThreadLibrary but there are others - see How Do I Choose Between the Various Ways to do Threading in Delphi? and Delphi - Threading frameworks.
You can allocate you own handle with AllocateHwnd and use that as a PostMessage target.
TTestThread = class(TThread)
private
FSignalShutdown: boolean;
// hidden window handle
FWinHandle: HWND;
protected
procedure Execute; override;
// our window procedure
procedure WndProc(var msg: TMessage);
public
constructor Create;
destructor Destroy; override;
procedure PrintMsg;
end;
constructor TTestThread.Create;
begin
FSignalShutdown := False;
// create the hidden window, store it's
// handle and change the default window
// procedure provided by Windows with our
// window procedure
FWinHandle := AllocateHWND(WndProc);
inherited Create(False);
end;
destructor TTestThread.Destroy;
begin
// destroy the hidden window and free up memory
DeallocateHWnd(FWinHandle);
inherited;
end;
procedure TTestThread.WndProc(var msg: TMessage);
begin
if Msg.Msg = WM_SHUTDOWN_THREADS then
// if the message id is WM_SHUTDOWN_THREADS
// do our own processing
FSignalShutdown := True
else
// for all other messages call
// the default window procedure
Msg.Result := DefWindowProc(FWinHandle, Msg.Msg,
Msg.wParam, Msg.lParam);
end;
You can apply this to anything not just threads. Just beware that AllocateHWND is NOT threade safe as indicated here.
Alternatives based on the use of an event:
Use OnTerminate of the thread (already present) in combination with a flag:
TMyDataModule = class(TDataModule)
private
procedure OnWebServiceCallComplete(Sender: TObject);
...
TMyThread = class(TThread)
public
property TerminateFlag: Integer ...
...
procedure TMyDataModule.StartWorkerThread;
...
MyWorkerThread.OnTerminate := <Self.>OnWebServiceCallComplete;
...
procedure TMyDataModule.OnWebServiceCallComplete(Sender: TObject);
begin
if MyWorkerThread.TerminateFlag = WEBCALL_COMPLETE then
...
end;
Set the TerminateFlag in the Execute routine. OnTerminate will automatically fire, even if FreeOnTerminate is True.
Add a new event property to the thread class in which you may provide the flag as a parameter to indicate termination/thread result. Something like shown here. Be sure to synchronize the event call. Or forget the parameter and just only call the event if execution completed gracefully (like you're doing now).