Catch WM_COPYDATA from Delphi component - delphi

I'm trying to write a component, to send string messages between applications by WM_COPYDATA.
I'd like trap the WM_COPYDATA, but this doesn't work:
TMyMessage = class(TComponent)
private
{ Private declarations }
…
protected
{ Protected declarations }
…
procedure WMCopyData(var Msg : TMessage); message WM_COPYDATA;
…
end;
Searching Google a lot, found some reference using wndproc. I tried it, but it isn't working either.
TMyMessage = class(TComponent)
…
protected
{ Protected declarations }
…
procedure WMCopyData(var Msg : TMessage); message WM_COPYDATA;
procedure WndProc(var Msg: TMessage);
…
end;
…
procedure TMyMessage.WndProc(var Msg: TMessage);
begin
//inherited;
if Msg.Msg = WM_COPYDATA then
WMCopyData(Msg);
end;
Please help, what is wrong?

What you have so far is fine, but you need to arrange for messages to be delivered to your component in the first place. That requires a window handle. Call AllocateHWnd and pass it your component's WndProc method. It will return a window handle, which you should destroy as your component is destroyed.
constructor TMyMessage.Create(AOwner: TComponent);
begin
inhreited;
FHandle := AllocateHWnd(WndProc);
end;
destructor TMyMessage.Destroy;
begin
DeallocateHWnd(FHandle);
inherited;
end;
Rather than testing for each message directly, you can let TObject do that for you. That's what the Dispatch method is for. Pass it a TMessage record, and it will find and call the corresponding message-handler method for you. If there is no such handler, it will call DefaultHandler instead. Override that can call DefWindowProc.
procedure TMyMessage.WndProc(var Message);
begin
Dispatch(Message);
end;
procedure TMyMessage.DefaultHandler(var Message);
begin
TMessage(Message).Result := DefWindowProc(Self.Handle, TMessage(Message).Msg,
TMessage(Message).WParam, TMessage(Message).LParam);
end;

Your problem is that TComponent is not a windowed component. WM_COPYDATA is a windows message and is delivered via a window procedure. Hence you need a window handle. Use AllocateHwnd to get hold of one of these.
type
TMyComponent = class(TComponent)
private
FWindowHandle: HWND;
procedure WndProc(var Msg: TMessage);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
constructor TMyComponent.Create(AOwner: TComponent);
begin
inherited;
FWindowHandle := AllocateHwnd(WndProc);
end;
destructor TMyComponent.Destroy;
begin
DeallocateHwnd(FWindowHandle);
inherited;
end;
procedure TMyComponent.WndProc(var Msg: TMessage);
begin
if Msg.Msg=WM_COPYDATA then
//do domething
else
Msg.Result := DefWindowProc(FWindowHandle, Msg.Msg, Msg.WParam, Msg.LParam);
end;
Whatever is sending the messages will need to find a way to get hold of the window handle.

I did it this way:
My web modules which are running in a thread need to send strings to a memo on the main form.
FReceiverFromWS is a THandle
On create:
procedure TWebModuleWebServices.WebModuleCreate(Sender: TObject);
begin
FReceiverFromWS := FindWindow(PChar('TFormWebServices'),PChar(cFormCaption + FormWebServices.Instance)); // Search by class name and caption of receiving form
// ==> you could to that without form caption, but I need to distinguish between running services
if FReceiverFromWS = 0 then
begin
Assert(False,'CopyData receiver NOT found!'); // Probably TFormWebServices not yet created
Exit;
end;
end;
To send messages:
procedure TWebModuleWebServices.SendAMessage(Msg: String);
// Windows will guarantee that the data sent in the COPYDATASTRUCT will exist until after the WM_COPYDATA message
// has been carried out. As such, we must use SendMessage() to send a WM_COPYDATA message. We cannot use PostMessage().
var
lCopyDataStruct: TCopyDataStruct;
begin
lCopyDataStruct.dwData := 0;
lCopyDataStruct.cbData := 1 + Length(Msg);
lCopyDataStruct.lpData := PChar(Msg);
SendMessage(FReceiverFromWS, WM_COPYDATA, wParam(FReceiverFromWS), lParam(#lCopyDataStruct));
end;
In the main form, public method
procedure WMCopyData(var Msg : TWMCopyData) ; message WM_COPYDATA;
is:
procedure TFormWebServices.WMCopyData(var Msg: TWMCopyData);
var
i : integer;
s : string;
begin
i := Msg.CopyDataStruct.dwData;
case i of
0: begin // Message to display
s := String(PChar(Msg.CopyDataStruct.lpData));
AddMemoLine(s);
end;
1: begin // Statistical data
s := String(PChar(Msg.CopyDataStruct.lpData));
FrmWebServiceStats.CollectStats(s);
end;
end;
end;
(As you can see, I actually use dwData to signal the kind of message and handle these differently)

Related

Delphi Component Development - Propagate Events inside component

I am trying to develop a new TEdit-Component.
TDBFilterEdit = class(TEdit)
The component is meant to Filter an associated DataSet based on the string that is entered in its Edit-Field.
this is what my component looks like:
type
TDBFilterEdit = class(TEdit)
private
{ Private-Deklarationen }
fFilter:String;
fDataSource:TDataSource;
fDataSet:TDataSet;
fText:string;
protected
{ Protected-Deklarationen }
procedure SetFilter(value:String);
procedure SetDS(value:TDataSource);
procedure FilterRecords(DataSet:TDataSet; var Accept:Boolean);
procedure Change(Sender:TObject);
procedure SetText(value:String);
public
{ Public-Deklarationen }
constructor Create(AOwner:TComponent);
published
{ Published-Deklarationen }
property Text:String read fText write SetText;
property Filter:String read fFilter write SetFilter;
property DataSource:TDataSource read fDataSource write SetDS;
end;
Now, I am pretty Novice when it comes to component-development. My first Idea was to Override the OnFilterRecord-method of the Dataset as soon as the DataSource gets assigned to my component and trigger it whenever the text of my Edit-component changes.
procedure TDBFilterEdit.SetDS(value:TDataSource);
var
myaccept:Boolean;
begin
fDataSource:=value;
fDataSet:=fDataSource.DataSet;
if fDataSet=nil then Exit;
fDataSet.OnFilterRecord:=FilterRecords;
if Filter<>'' then fDataSet.OnFilterRecord(fDataSet,myaccept);
end;
My Problem is, I don't know how to make the component aware that its Text-property got updated. I tried overriding the OnChange-Method with following code
procedure TDBFilterEdit.Change(Sender:TObject);
begin
Filter:=Text;
inherited Change();
end;
however, to no avail so far.
My Problem is, I don't know how to make the component aware that its Text-property got updated.
The Text property is inherited from TControl. When the property value changes, TControl issues a CM_TEXTCHANGED notification message to itself. Descendant classes can handle that message by either:
using a message handler:
type
TDBFilterEdit = class(TEdit)
...
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
...
published
...
// DO NOT redeclare the Text property here!
// It is already published by TEdit...
end;
procedure TDBFilterEdit.CMTextChanged(var Message: TMessage);
begin
inherited;
// use new Text value as needed...
Filter := Text;
end;
overriding the virtual WndProc() method.
type
TDBFilterEdit = class(TEdit)
...
protected
...
procedure WndProc(var Message: TMessage); override;
...
end;
procedure TDBFilterEdit.WndProc(var Message: TMessage);
begin
inherited;
if Message.Msg = CM_TEXTCHANGED then
begin
// use new Text value as needed...
Filter := Text;
end;
end;
As for the rest of your component, it should look more like this:
type
TDBFilterEdit = class(TEdit)
private
{ Private-Deklarationen }
fDataSource: TDataSource;
fDataSet: TDataSet;
fFilter: String;
procedure FilterRecords(DataSet: TDataSet; var Accept: Boolean);
procedure SetDataSource(Value: TDataSource);
procedure SetDataSet(Value: TDataSet);
procedure SetFilter(const Value: String);
procedure StateChanged(Sender: TObject);
procedure UpdateDataSetFilter;
protected
{ Protected-Deklarationen }
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure WndProc(var Message: TMessage); override;
public
{ Public-Deklarationen }
destructor Destroy; override;
published
{ Published-Deklarationen }
property DataSource: TDataSource read fDataSource write SetDataSource;
property Filter: String read fFilter write SetFilter;
end;
...
destructor TDBFilterEdit.Destroy;
begin
SetDataSource(nil);
inherited;
end;
procedure TDBFilterEdit.FilterRecords(DataSet: TDataSet; var Accept: Boolean);
begin
// ...
end;
procedure TDBFilterEdit.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if Operation = opRemove then
begin
if AComponent = fDataSource then
begin
SetDataSet(nil);
fDataSource := nil;
end
else if AComponent = fDataSet then
begin
fDataSet := nil;
end;
end;
end;
procedure TDBFilterEdit.SetFilter(const Value: String);
begin
if fFilter <> Value then
begin
fFilter := Value;
UpdateDataSetFilter;
end;
end;
procedure TDBFilterEdit.SetDataSource(Value: TDataSource);
begin
if fDataSource <> Value then
begin
SetDataSet(nil);
if fDataSource <> nil then
begin
fDataSource.RemoveFreeNotification(Self);
fDataSource.OnStateChange := nil;
end;
fDataSource := Value;
if fDataSource <> nil then
begin
fDataSource.FreeNotification(Self);
fDataSource.OnStateChange := StateChanged;
SetDataSet(fDataSource.DataSet);
end;
end;
end;
procedure TDBFilterEdit.SetDataSet(Value: TDataSet);
begin
if fDataSet <> Value then
begin
if fDataSet <> nil then
begin
fDataSet.RemoveFreeNotification(Self);
fDataSet.OnFilterRecord := nil;
end;
fDataSet := Value;
if fDataSet <> nil then
begin
fDataSet.FreeNotification(Self);
fDataSet.OnFilterRecord := FilterRecords;
UpdateDataSetFilter;
end;
end;
end;
procedure TDBFilterEdit.StateChanged(Sender: TObject);
begin
if fDataSource.DataSet <> fDataSet then
SetDataSet(fDataSource.DataSet);
end;
procedure TDBFilterEdit.UpdateDataSetFilter;
begin
if fDataSet <> nil then
begin
fDataSet.Filter := fFilter;
fDataSet.Filtered := fFilter <> '';
end;
end;
procedure TDBFilterEdit.WndProc(var Message: TMessage);
begin
inherited;
if Message.Msg = CM_TEXTCHANGED then
Filter := Text;
end;
UPDATE: sorry, my bad. The CM_TEXTCHANGED message is only sent when the Text property is updated programmably in code. To detect when the user changed the text, you need to handle the Win32 EN_CHANGE notification instead:
using a message handler:
type
TDBFilterEdit = class(TEdit)
...
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
...
published
...
// DO NOT redeclare the Text property here!
// It is already published by TEdit...
end;
procedure TDBFilterEdit.CMTextChanged(var Message: TMessage);
begin
inherited;
// use new Text value as needed...
Filter := Text;
end;
procedure TDBFilterEdit.CNCommand(var Message: TWMCommand);
begin
inherited;
if Message.NotifyCode = EN_CHANGE then
begin
// use new Text value as needed...
Filter := Text;
end;
end;
overriding the virtual WndProc() method.
type
TDBFilterEdit = class(TEdit)
...
protected
...
procedure WndProc(var Message: TMessage); override;
...
end;
procedure TDBFilterEdit.WndProc(var Message: TMessage);
begin
inherited;
case Message.Msg of
CM_TEXTCHANGED: begin
// use new Text value as needed...
Filter := Text;
end;
CN_COMMAND: begin
if TWMCommand(Message).NotifyCode = EN_CHANGE then
begin
// use new Text value as needed...
Filter := Text;
end;
end;
end;
end;
In fact, TCustomEdit already handles EN_CHANGE for you, and will call its virtual Change() method (to fire its OnChange event), which you can override:
type
TDBFilterEdit = class(TEdit)
...
protected
...
procedure Change; override;
...
end;
procedure TDBFilterEdit.Change;
begin
inherited;
// use new Text value as needed...
Filter := Text;
end;

How to make my custom control be notified when his form or application receives and loses focus?

I want my control to receive distinct notifications only when it's parent form (not panel or something else, just the main form of this control) receives and loses focus. Doesn't matter if the focus is switched from another form of the application or between my application and other application, it must be received for both cases. Is it possible? I want to suspend some updates of the control when his form is not active and resume the updates when the form is activated.
Edit: In other words, the control must catch the (TForm.OnActivate + TApplication.OnActivate) and (TForm.OnDeactivate + TApplication.OnDeactivate)
Edit2: If it's not possible both, at least if I can make the control catch the events from TApplication. It's more important than those from TForm.
I want to suspend some updates of the control when his form is not active and resume the updates when the form is activated.
If those updates are done continuously, or are being triggered by a timer or actions, then you could be done with:
type
TMyControl = class(TControl)
private
procedure PerformUpdate;
end;
procedure TMyControl.PerformUpdate;
begin
if Application.Active and HasParent and GetParentForm(Self).Active then
//...
else
//...
end;
...at least if I can make the control catch the events from the application
Catching TApplication.OnActivate and TApplication.OnDeactivate is pretty easy with a TApplicationEvents component:
uses
Vcl.AppEvnts;
type
TMyControl = class(TControl)
private
FActive: Boolean;
FAppEvents: TApplicationEvents;
procedure ApplicationActiveChanged(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
end;
procedure TMyControl.ApplicationActiveChanged(Sender: TObject);
begin
FActive := Application.Active;
end;
constructor TMyControl.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FAppEvents := TApplicationEvents.Create(Self);
FAppEvents.OnActivate := ApplicationActiveChanged;
FAppEvents.OnDeactivate := ApplicationActiveChanged;
end;
...it's more important than those from the form
Catching the (de)activation of the parenting form can be done in Application.OnIdle. All this combined could result in something like this:
type
TMyControl = class(TControl)
private
FActive: Boolean;
FAppEvents: TApplicationEvents;
FParentForm: TCustomForm;
procedure ApplicationActiveChanged(Sender: TObject);
procedure ApplicationIdle(Sender: TObject; var Done: Boolean);
procedure UpdateActive;
protected
procedure SetParent(AParent: TWinControl); override;
public
constructor Create(AOwner: TComponent); override;
end;
procedure TMyControl.ApplicationActiveChanged(Sender: TObject);
begin
UpdateActive;
end;
procedure TMyControl.ApplicationIdle(Sender: TObject; var Done: Boolean);
begin
UpdateActive;
Done := True;
end;
constructor TMyControl.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FAppEvents := TApplicationEvents.Create(Self);
FAppEvents.OnActivate := ApplicationActiveChanged;
FAppEvents.OnDeactivate := ApplicationActiveChanged;
end;
procedure TMyControl.SetParent(AParent: TWinControl);
begin
inherited SetParent(AParent);
FParentForm := GetParentForm(Self);
end;
procedure TMyControl.UpdateActive;
var
SaveActive: Boolean;
begin
SaveActive := FActive;
FActive := Application.Active and (FParentForm <> nil) and FParentForm.Active;
if Application.Active then
FAppEvents.OnIdle := ApplicationIdle
else
FAppEvents.OnIdle := nil;
if FActive <> SaveActive then
Invalidate;
end;
Because using Application.OnIdle is quite a rigorous method, spare its use like I did above by only assigning it when necessary and speed up its implementation by caching function results like GetParentForm.

How to ignore timer events in Delphis MessageDlg

I have set up a global exception handler in Delphi. On some severe exceptions an error message is displayed (followed by Halt()). While the error message is shown, Delphi is processing the message queue, processing timer events, that lead to further errors.
What I want is to show an error dialog which does not process timer events. How is that possible in Delphi?
Edit: I use Dialogs.MessageDlg(...) to display the message.
You can filter queued messages, such as WM_TIMER, with TApplication.OnMessage.
procedure TMainForm.ApplicationMessage(var Msg: TMsg; var Handled: Boolean);
begin
if ShowingFatalErrorDialog then
if Msg.Message = WM_TIMER then
Handled := True;
end;
Either assign that event handler directly to Application.OnMessage or use a TApplicationEvents object.
Obviously you'll have to provide the implementation for ShowingFatalErrorDialog but I trust that it is obvious to you how to do so.
Try something like this:
...
private
FAboutToTerminate: Boolean;
end;
...
type
ESevereError = class(Exception);
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Tag := Tag + 1;
if Tag > 2 then
raise ESevereError.Create('Error');
end;
procedure TForm1.ApplicationEvents1Exception(Sender: TObject;
E: Exception);
begin
if (E is ESevereError) and (not FAboutToTerminate) then
begin
FAboutToTerminate := True;
Application.ShowException(E);
Application.Terminate;
end;
end;
Just for reference: I will use the following code, which is a mixture from both answers.
procedure SaveShowErrorMessage(...)
begin
with TFatalErrorAppEvents.Create(nil) do //avoid timer and further exceptions
try
Dialogs.MessageDlg(...);
finally
Free;
end;
end;
With TFatalErrorAppEvents as follows:
type
TFatalErrorAppEvents = class(TApplicationEvents)
protected
procedure KillTimerMessages(var Msg: tagMSG; var Handled: Boolean);
procedure IgnoreAllExceptions(Sender: TObject; E: Exception);
public
constructor Create(AOwner: TComponent); override;
end;
constructor TFatalErrorAppEvents.Create(AOwner: TComponent);
begin
inherited;
OnMessage := KillTimerMessages;
OnException := IgnoreAllExceptions;
end;
procedure TFatalErrorAppEvents.IgnoreAllExceptions(Sender: TObject; E: Exception);
begin
//in case of an Exception do nothing here to ignore the exception
end;
procedure TFatalErrorAppEvents.KillTimerMessages(var Msg: tagMSG; var Handled: Boolean);
begin
if (Msg.message = WM_TIMER) then
Handled := True;
end;

How to handle Log in a Threaded manner

I have a form with a TMemo that I want to show what is going on in several services started by the application.
What I have running:
idHTTPServer running with idContext responding to requests
a Thread downloading updates from Dropbox
idUDPServer responding to UDP requests
another thread taking care of some database stuff.
the main application thread also needed to add log
Basically, I need to know how to create a standard, unified, thread safe way to channel the log messages to my TMemo and keep the user updated of what is going on.
Since you are already using Indy anyway, you can use Indy's TIdSync (synchronous) or TIdNotify (asynchronous) class to access the TMemo safely. For simple logging purposes, I would use TIdNotify, eg:
type
TLog = class(TIdNotify)
protected
FMsg: string;
procedure DoNotify; override;
public
class procedure LogMsg(const AMsg; string);
end;
procedure TLog.DoNotify;
begin
Form1.Memo1.Lines.Add(FMsg);
end;
class procedure TLog.LogMsg(const AMsg: string);
begin
with TLog.Create do
try
FMsg := AMsg;
Notify;
except
Free;
raise;
end;
end;
Then you can directly call it in any thread like this:
TLog.LogMsg('some text message here');
UPDATE: in Delphi 2009 and later, you can use anonymous procedures with the static versions of TThread.Synchronize() and TThread.Queue(), thus making Indy's TIdSync and TIdNotify classes obsolete, eg:
type
TLog = class
public
class procedure LogMsg(const AMsg; string);
end;
class procedure TLog.LogMsg(const AMsg: string);
begin
TThread.Queue(nil,
procedure
begin
Form1.Memo1.Lines.Add(AMsg);
end
);
end;
Basically, you can build a thread that receive all the message (here, it is a function AddEvent). Messages are queued (and timestamped) and written down to the memo when possible (if you're under heavy load...).
Don't forget to clean the memo if it exceeds a number of line, add exception handling etc...
I use something like this :
TThreadedMsgEvent = class( TThread )
private
FLock : TCriticalSection;
FStr : TQueue<String>;
FMemo : TMemo;
function GetEvent : String;
protected
procedure Execute; override;
public
procedure AddEvent( aMsg : String );
constructor Create( AMemo: TMemo );
destructor Destroy; override;
end;
implementation
{ TThreadedMsgEvent }
procedure TThreadedMsgEvent.AddEvent(aMsg: String);
begin
FLock.Acquire;
FStr.Enqueue( FormatDateTime('DD/MM/YY HH:NN:SS.ZZZ',Now)+ ' : '+ aMsg );
FLock.Release;
end;
constructor TThreadedMsgEvent.Create(aMemo: TMemo);
begin
inherited Create(True);
FreeOnTerminate := False;
FOnMessage := ACallBack;
FStr := TQueue<String>.Create();
FLock := TCriticalSection.Create;
FMemo := aMemo;
Resume;
end;
destructor TThreadedMsgEvent.Destroy; override;
begin
FreeAndNil( FStr );
FreeAndNil( FLock );
end;
procedure TThreadedMsgEvent.Execute;
begin
while not Terminated do
begin
try
if (FStr.Count > 0) then
begin
if Assigned( aMemo ) then
begin
TThread.synchronize( procedure
begin
FMemo.Lines.Add( GetEvent );
end; );
end;
end;
except
end;
TThread.Sleep(1);
end;
end;
function TThreadedMsgEvent.GetEvent: String;
begin
FLock.Acquire;
result := FStr.Dequeue;
FLock.Release;
end;
You can also notify this thread with Windows Messages. It might be easier as you won't need any reference to this thread in your classes.

Delphi unit test for a TThread with FreeOnTerminate = True

What is the best way to write a Delphi DUnit test for a TThread descendant when FreeOnTerminate = True? The TThread descendant returns a reference which I need to test for, but I can't figure out how to wait for the thread to finish in the test...
unit uThreadTests;
interface
uses
Classes, TestFramework;
type
TMyThread = class(TThread)
strict private
FId: Integer;
protected
procedure Execute; override;
public
constructor Create(AId: Integer);
property Id: Integer read FId;
end;
TestTMyThread = class(TTestCase)
strict private
FMyId: Integer;
procedure OnThreadTerminate(Sender: TObject);
protected
procedure SetUp; override;
procedure TearDown; override;
published
procedure TestMyThread;
end;
implementation
{ TMyThread }
constructor TMyThread.Create(AId: Integer);
begin
FreeOnTerminate := True;
FId := AId;
inherited Create(False);
end;
procedure TMyThread.Execute;
begin
inherited;
FId := FId + 1;
end;
{ TestTMyThread }
procedure TestTMyThread.TestMyThread;
//var
// LThread: TMyThread;
begin
// LThread := TMyThread.Create(1);
// LThread.OnTerminate := OnThreadTerminate;
// LThread.WaitFor;
// CheckEquals(2, FMyId);
// LThread.Free;
///// The above commented out code is only useful of FreeOnTerminate = False;
with TMyThread.Create(1) do
begin
OnTerminate := OnThreadTerminate;
WaitFor; /// Not sure how else to wait for the thread to finish?
end;
CheckEquals(2, FMyId);
end;
procedure TestTMyThread.OnThreadTerminate(Sender: TObject);
begin
FMyId := (Sender as TMyThread).Id;
end; /// When FreeOnTerminate = True - THIS LINE CAUSES ERROR: Thread Error the handle is invalid
procedure TestTMyThread.SetUp;
begin
inherited;
end;
procedure TestTMyThread.TearDown;
begin
inherited;
end;
initialization
RegisterTests([TestTMyThread.Suite]);
end.
Any ideas would be welcomed.
Delphi 2010.
Subclass the thread to make it more testable. TThread and TObject provide enough hooks that you can add sensing variables to observe that it reaches certain points with the states you want it to have.
I see three aspects to this particular class that you might wish to test:
It computes a value for its Id property based on the value sent to the constructor.
It computes the new Id property in the new thread, not the thread that calls the constructor.
It frees itself when it's finished.
All those things are testable from a subclass, but hard to test otherwise without making changes to the thread's interface. (All the other answers so far require changing the thread's interface, such as by adding more constructor arguments or by changing the way it starts itself. That can make the thread harder, or at least more cumbersome, to use in the real program.)
type
PTestData = ^TTestData;
TTestData = record
Event: TEvent;
OriginalId: Integer;
FinalId: Integer;
end;
TTestableMyThread = class(TMyThread)
private
FData: PTestData;
public
constructor Create(AId: Integer; AData: PTestData);
destructor Destroy; override;
procedure AfterConstruction; override;
end;
constructor TTestableMyThread.Create(AId: Integer; const AData: PTestData);
begin
inherited Create(AId);
FData := AData;
end;
destructor TestableMyThread.Destroy;
begin
inherited;
FData.FinalId := Id;
// Tell the test that the thread has been freed
FData.Event.SetEvent;
end;
procedure TTestableMyThread.AfterConstruction;
begin
FData.OriginalId := Id;
inherited; // Call this last because this is where the thread starts running
end;
Using that subclass, it's possible to write a test that checks the three qualities identified earlier:
procedure TestTMyThread.TestMyThread;
var
Data: TTestData;
WaitResult: TWaitResult;
begin
Data.OriginalId := -1;
Data.FinalId := -1;
Data.Event := TSimpleEvent.Create;
try
TTestableMyThread.Create(1, #Data);
// We don't free the thread, and the event is only set in the destructor,
// so if the event is signaled, it means the thread freed itself: That
// aspect of the test implicitly passes. We don't want to wait forever,
// though, so we fail the test if we have to wait too long. Either the
// Execute method is taking too long to do its computations, or the thread
// isn't freeing itself.
// Adjust the timeout based on expected performance of Execute.
WaitResult := Data.Event.WaitFor(5000);
case WaitResult of
wrSignaled: ; // This is the expected result
wrTimeOut: Fail('Timed out waiting for thread');
wrAbandoned: Fail('Event was abandoned');
wrError: RaiseLastOSError(Data.Event.LastError);
else Fail('Unanticipated error waiting for thread');
end;
CheckNotEquals(2, Data.OriginalId,
'Didn''t wait till Execute to calculate Id');
CheckEquals(2, Data.FinalId,
'Calculated wrong Id value');
finally
Data.Event.Free;
end;
end;
Because you made the thread free itself upon termination then you have asked it to destroy all traces of itself as soon as it is done. Since you cannot exert influence on when it finishes, it is wrong to refer to anything inside the thread after you start it.
The solutions proposed by other, namely asking the thread to signal you when it terminates, are good. I personally would probably elect to do it that way. If you use an event as a signal then you can wait on that event.
However, there is another way to do it.
Create the thread suspended.
Duplicate the thread handle.
Start the thread.
Wait on the duplicated handle.
Because you own the duplicated handle, rather than the thread, you are safe to wait on it. It seems a little more complicated, but I suppose it avoids creating an extra synchronization object where one is not needed. Note that I'm not advocating this approach over the approach of using an event to signal completion.
Anyway, here's a simple demonstration of the idea.
{$APPTYPE CONSOLE}
uses
SysUtils, Windows, Classes;
type
TMyThread = class(TThread)
protected
procedure Execute; override;
public
destructor Destroy; override;
end;
destructor TMyThread.Destroy;
begin
Writeln('I''m dead!');
inherited;
end;
procedure TMyThread.Execute;
begin
end;
var
DuplicatedHandle: THandle;
begin
with TMyThread.Create(True) do // must create suspended
begin
FreeOnTerminate := True;
Win32Check(DuplicateHandle(
GetCurrentProcess,
Handle,
GetCurrentProcess,
#DuplicatedHandle,
0,
False,
DUPLICATE_SAME_ACCESS
));
Start;
end;
Sleep(500);
Writeln('I''m waiting');
if WaitForSingleObject(DuplicatedHandle, INFINITE)=WAIT_OBJECT_0 then
Writeln('Wait succeeded');
CloseHandle(DuplicatedHandle);
Readln;
end.
Create the thread in a suspended state, then set the OnTerminate and finally Resume the thread.
In your test class, define a private boolean field FThreadDone which is initialized with false and set to true by the OnTerminate Eventhandler.
Also, your constructor logic is a bit dirty, as you should not initialize field prior to calling the inherited constructor.
So:
constructor TMyThread.Create(AId: Integer);
begin
inherited Create(true);
FreeOnTerminate := True;
FId := AId;
end;
...
procedure TestTMyThread.TestMyThread;
begin
FThreadDone := False;
with TMyThread.Create(1) do begin // Note: Thread is suspended...
OnTerminate := OnThreadTerminate;
// Resume; // ... and finally started here!
Start;
end;
While not FThreadDone do Application.ProcessMessages;
CheckEquals(2, FMyId);
end;
procedure TestTMyThread.OnThreadTerminate(Sender: TObject);
begin
FMyId := (Sender as TMyThread).Id;
FThreadDone := True;
end;
This should do the job.
EDIT: Corrected stupid corrections, tested, works.
Here is an example using an anonymous thread.
An event (TSimpleEvent) is created
An anonymous thread executes the test thread and
Waits for the event, which signals in the OnTerminate handler of the test thread
The anonymous thread is on hold until executed with a WaitFor
The result was picked up by the OnTerminate handler
The important thing here is that the event is waited for in a thread. No dead-lock situation.
Uses
SyncObjs;
type
TMyThread = class(TThread)
private
FId : Integer;
protected
procedure Execute; override;
public
constructor Create( anInt : Integer);
property Id : Integer read FId;
end;
TestTMyThread = class
strict private
FMyId: Integer;
FMyEvent : TSimpleEvent;
procedure OnThreadTerminate(Sender: TObject);
protected
public
procedure TestMyThread;
end;
{ TMyThread }
constructor TMyThread.Create(anInt : Integer);
begin
inherited Create(True);
FreeOnTerminate := True;
FId := anInt;
end;
procedure TMyThread.Execute;
begin
Inc(FId);
end;
procedure TestTMyThread.TestMyThread;
var
AnonThread : TThread;
begin
FMyEvent := TSimpleEvent.Create(nil,true,false,'');
try
AnonThread :=
TThread.CreateAnonymousThread(
procedure
begin
With TMyThread.Create(1) do
begin
OnTerminate := Self.OnThreadTerminate;
Start;
end;
FMyEvent.WaitFor; // Wait until TMyThread is ready
end
);
AnonThread.FreeOnTerminate := False;
AnonThread.Start;
AnonThread.WaitFor; // Wait here until test is ready
AnonThread.Free;
Assert(FMyId = 2); // Check result
finally
FMyEvent.Free;
end;
end;
procedure TestTMyThread.OnThreadTerminate(Sender: TObject);
begin
FMyId := (Sender as TMyThread).Id;
FMyEvent.SetEvent; // Signal TMyThread ready
end;
Update, since Delphi-2010 does not have an anonymous thread class, here is an alternative which you can implement:
Type
TMyAnonymousThread = class(TThread)
private
FProc : TProc;
protected
procedure Execute; override;
public
constructor Create(CreateSuspended,SelfFree: Boolean; const aProc: TProc);
end;
constructor TMyAnonymousThread.Create(CreateSuspended,SelfFree: Boolean;
const aProc: TProc);
begin
Inherited Create(CreateSuspended);
FreeOnTerminate := SelfFree;
FProc := aProc;
end;
procedure TMyAnonymousThread.Execute;
begin
FProc();
end;

Resources