I have the following service written with Delphi 2007 which I find is not releasing the thread Handle. The functions CurrentMemoryUsage and GetOpenHandles are functions to return memory used and the number of handle used by the application. The Timer fires each second, creating a thread which is immediately destroyed. And I can see in my log the Number of Open Handles increments by one each time. This is a very basic threading question.
TMyThread = class(TThread)
private
protected
procedure Execute; override;
public
constructor Create(CreateSuspended: Boolean);
destructor Destroy; override;
end;
procedure TMyService.MyTimerTimer(Sender: TObject);
var
MyThread : TMyThread;
begin
MyThread := TMyThread.Create(True);
MyThread.OnTerminate := ThreadTerminated;
MyThread.FreeOnTerminate := True;
MyThread.Resume;
end;
procedure TMyThread.Execute;
begin
FreeOnTerminate := True;
end;
destructor TMyThread.Destroy;
begin
appendtolog((FormatFloat('Memory used: ,.# K', CurrentMemoryUsage / 1024))+',Number of Handles:'+inttostr(GetOpenHandles)) ;
end;
constructor TMyThread.Create(CreateSuspended: Boolean);
begin
inherited Create(CreateSuspended);
end;
procedure TMyService.ThreadTerminated(Sender: TObject);
begin
appendtolog('thread terminiated');
end;
You have forgotten to call the inherited Destroy. That is what frees the system resources associated with the thread.
destructor TMyThread.Destroy;
begin
appendtolog((FormatFloat('Memory used: ,.# K',
CurrentMemoryUsage / 1024))+',Number of Handles:'+inttostr(GetOpenHandles));
inherited;
end;
Related
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.
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.
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;
If I create a (suspended) thread from the main thread as such:
with TMyThread.Create(True) do
begin
OnTerminate := ThreadTerminated;
FreeOnTerminate := False;
Start;
end;
How do I go about freeing that instance once it's completed? (ie the Execute procedure has finished executing - assume I've captured exceptions).
This Proper way of destroying a tthread object link shows a way (via the PostMessage procedure) which works fine and makes sense. However, what if I create the thread and I don't have a handle to a form or something where I can invoke the PostMessage procedure. eg I create the thread within a class descended directly from TObject?
TMyClass = class
public
procedure DoSomething;
end;
TMyClass.DoSomething;
begin
with TMyThread.Create(True) do
begin
OnTerminate := ThreadTerminated;
FreeOnTerminate := False;
Start;
end;
end;
So, I guess, how do I free a thread without access to a form handle?
Thanks
Obviously, somewhere there has to be a reference to the instantiated thread. But I can relate to your wish: you want a always-done-never-care solution.
I suggest you manage the thread's existence by a separate ThreadController class:
unit Unit2;
interface
uses
Classes, SysUtils, Forms, Windows, Messages;
type
TMyThreadProgressEvent = procedure(Value: Integer;
Proceed: Boolean) of object;
procedure RunMyThread(StartValue: Integer; OnProgress: TMyThreadProgressEvent);
implementation
type
TMyThread = class(TThread)
private
FException: Exception;
FOnProgress: TMyThreadProgressEvent;
FProceed: Boolean;
FValue: Integer;
procedure DoProgress;
procedure HandleException;
procedure ShowException;
protected
procedure Execute; override;
end;
TMyThreadController = class(TObject)
private
FThreads: TList;
procedure StartThread(StartValue: Integer;
OnProgress: TMyThreadProgressEvent);
procedure ThreadTerminate(Sender: TObject);
public
constructor Create;
destructor Destroy; override;
end;
var
FMyThreadController: TMyThreadController;
function MyThreadController: TMyThreadController;
begin
if not Assigned(FMyThreadController) then
FMyThreadController := TMyThreadController.Create;
Result := FMyThreadController
end;
procedure RunMyThread(StartValue: Integer; OnProgress: TMyThreadProgressEvent);
begin
MyThreadController.StartThread(StartValue, OnProgress);
end;
{ TMyThreadController }
constructor TMyThreadController.Create;
begin
inherited;
FThreads := TList.Create;
end;
destructor TMyThreadController.Destroy;
var
Thread: TThread;
begin
while FThreads.Count > 0 do
begin
Thread := FThreads[0]; //Save reference because Terminate indirectly
//extracts the list entry in OnTerminate!
Thread.Terminate; //Indirectly decreases FThreads.Count
Thread.Free;
end;
FThreads.Free;
inherited Destroy;
end;
procedure TMyThreadController.StartThread(StartValue: Integer;
OnProgress: TMyThreadProgressEvent);
var
Thread: TMyThread;
begin
Thread := TMyThread.Create(True);
FThreads.Add(Thread); //Add to list before a call to Resume because once
//resumed, the thread might be gone already!
Thread.FValue := StartValue;
Thread.FOnProgress := OnProgress;
Thread.OnTerminate := ThreadTerminate;
Thread.Resume;
end;
procedure TMyThreadController.ThreadTerminate(Sender: TObject);
begin
FThreads.Extract(Sender);
end;
{ TMyThread }
procedure TMyThread.DoProgress;
begin
if (not Application.Terminated) and Assigned(FOnProgress) then
FOnProgress(FValue, FProceed);
end;
procedure TMyThread.Execute;
begin
try
FProceed := True;
while (not Terminated) and (not Application.Terminated) and FProceed and
(FValue < 20) do
begin
Synchronize(DoProgress);
if not FProceed then
Break;
Inc(FValue);
Sleep(2000);
end;
//In case of normal execution ending, the thread may free itself. Otherwise,
//the thread controller object frees the thread.
if not Terminated then
FreeOnTerminate := True;
except
HandleException;
end;
end;
procedure TMyThread.HandleException;
begin
FException := Exception(ExceptObject);
try
if not (FException is EAbort) then
Synchronize(ShowException);
finally
FException := nil;
end;
end;
procedure TMyThread.ShowException;
begin
if GetCapture <> 0 then
SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
if (FException is Exception) and (not Application.Terminated) then
Application.ShowException(FException)
else
SysUtils.ShowException(FException, nil);
end;
initialization
finalization
FreeAndNil(FMyThreadController);
end.
To run this sample thread which counts from 5 to 19 in 2 second intervals and provides feedback and an opportunity to a premature termination, call from the main thread:
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
procedure MyThreadProgress(Value: Integer; Proceed: Boolean);
end;
...
procedure TForm1.Button1Click(Sender: TObject);
begin
RunMyThread(5, MyThreadProgress);
end;
procedure TForm1.MyThreadProgress(Value: Integer; Proceed: Boolean);
begin
Caption := IntToStr(Value);
end;
This thread automatically kills itself on either thread's or application's termination.
Maybe this unit is a little overkill for your situation because it is capable of handling multiple threads (of the same type), but I think it answers your question. Adjust to your liking.
Partial origin of this answer: NLDelphi.com.
I got the crazy idea one day to make a completely new replacement of TApplication for experimentation. I got everything to compile and run, and it does show the main form properly, everything responds good, but upon closing the form, the application does not halt. I'm sure I copied all the necessary stuff from the original Forms.pas TApplication (registering close event) but I don't see it working. I have to terminate the debug session the nasty way.
My goal in this little experiment is to build a lightweight application for very simple things instead of all the possible things a TApplication can handle, and also mostly so I have some good experience in such a field.
Here's the unit as I have it now, and below is the implementation of it.
unit JDForms;
interface
uses
Forms, Classes, SysUtils, StrUtils, Windows, Win7, XPMan, Variants,
Messages, Dialogs;
type
TJDForm = class;
TJDApplication = class;
TJDApplicationThread = class;
TJDForm = class(TCustomForm)
private
public
published
end;
TJDApplication = class(TComponent)
private
fRunning: Bool;
fTerminated: Bool;
fThread: TJDApplicationThread;
fMainForm: TJDForm;
fOnMessage: TMessageEvent;
fShowMainForm: Bool;
fHandle: HWND;
procedure ThreadTerminated(Sender: TObject);
procedure HandleMessage;
procedure ProcessMessages;
function ProcessMessage(var Msg: TMsg): Boolean;
procedure ThreadSync(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
property Thread: TJDApplicationThread read fThread;
procedure Initialize;
procedure Run;
procedure CreateForm(InstanceClass: TComponentClass; var Reference);
procedure Terminate;
property Terminated: Bool read fTerminated;
procedure HandleException(Sender: TObject);
property Handle: HWND read fHandle;
published
property ShowMainForm: Bool read fShowMainForm write fShowMainForm;
property OnMessage: TMessageEvent read fOnMessage write fOnMessage;
end;
TJDApplicationThread = class(TThread)
private
fOwner: TJDApplication;
fStop: Bool;
fOnSync: TNotifyEvent;
procedure DoSync;
protected
procedure Execute; override;
public
constructor Create(AOwner: TJDApplication);
destructor Destroy; override;
procedure Start;
procedure Stop;
published
property OnSync: TNotifyEvent read fOnSync write fOnSync;
end;
var
JDApplication: TJDApplication;
implementation
procedure DoneApplication;
begin
with JDApplication do begin
if Handle <> 0 then ShowOwnedPopups(Handle, False);
//ShowHint := False;
Destroying;
DestroyComponents;
end;
end;
{ TJDApplication }
constructor TJDApplication.Create(AOwner: TComponent);
begin
fRunning:= False;
fTerminated:= False;
fMainForm:= nil;
fThread:= TJDApplicationThread.Create(Self);
fThread.FreeOnTerminate:= True;
fThread.OnTerminate:= ThreadTerminated;
fShowMainForm:= True;
end;
procedure TJDApplication.CreateForm(InstanceClass: TComponentClass; var Reference);
var
Instance: TComponent;
begin
Instance:= TComponent(InstanceClass.NewInstance);
TComponent(Reference) := Instance;
try
Instance.Create(Self);
except
TComponent(Reference):= nil;
raise;
end;
if (fMainForm = nil) and (Instance is TForm) then begin
TForm(Instance).HandleNeeded;
fMainForm:= TJDForm(Instance);
end;
end;
procedure TJDApplication.HandleException(Sender: TObject);
begin
{
if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
if ExceptObject is Exception then
begin
if not (ExceptObject is EAbort) then
if Assigned(FOnException) then
FOnException(Sender, Exception(ExceptObject))
else
ShowException(Exception(ExceptObject));
end else
SysUtils.ShowException(ExceptObject, ExceptAddr);
}
end;
procedure TJDApplication.HandleMessage;
var
Msg: TMsg;
begin
if not ProcessMessage(Msg) then begin
//Idle(Msg);
end;
end;
function TJDApplication.ProcessMessage(var Msg: TMsg): Boolean;
var
Handled: Boolean;
begin
Result := False;
if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
begin
Result := True;
if Msg.Message <> WM_QUIT then begin
Handled := False;
if Assigned(FOnMessage) then FOnMessage(Msg, Handled);
//if not IsHintMsg(Msg) and not Handled and not IsMDIMsg(Msg) and
//not IsKeyMsg(Msg) and not IsDlgMsg(Msg) then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end else begin
fTerminated:= True;
end;
end;
end;
procedure TJDApplication.ProcessMessages;
var
Msg: TMsg;
begin
while ProcessMessage(Msg) do {loop};
end;
procedure TJDApplication.Initialize;
begin
if InitProc <> nil then TProcedure(InitProc);
end;
procedure TJDApplication.Run;
begin {
fRunning := True;
try
AddExitProc(DoneApplication);
if FMainForm <> nil then
begin
case CmdShow of
SW_SHOWMINNOACTIVE: FMainForm.FWindowState := wsMinimized;
SW_SHOWMAXIMIZED: MainForm.WindowState := wsMaximized;
end;
if FShowMainForm then
if FMainForm.FWindowState = wsMinimized then
Minimize else
FMainForm.Visible := True;
repeat
try
HandleMessage;
except
HandleException(Self);
end;
until Terminated;
end;
finally
FRunning := False;
end;
}
fRunning:= True;
try
AddExitProc(DoneApplication);
if fMainForm <> nil then begin
fHandle:= fMainForm.Handle;
if fShowMainForm then begin
fMainForm.Show;
end;
fThread.Start;
repeat
try
HandleMessage;
//--- THREAD HANDLING MESSAGES ---
except
HandleException(Self);
end;
until fTerminated;
end else begin
//Main form is nil - can not run
end;
finally
fRunning:= False;
fTerminated:= True;
end;
end;
procedure TJDApplication.Terminate;
begin
fTerminated:= True;
try
fThread.Stop;
except
end;
if CallTerminateProcs then PostQuitMessage(0);
end;
procedure TJDApplication.ThreadTerminated(Sender: TObject);
begin
//Free objects
end;
procedure TJDApplication.ThreadSync(Sender: TObject);
var
Msg: TMsg;
begin
if not ProcessMessage(Msg) then begin
//Idle(Msg);
end;
end;
{ TJDApplicationThread }
constructor TJDApplicationThread.Create(AOwner: TJDApplication);
begin
inherited Create(True);
fOwner:= AOwner;
end;
destructor TJDApplicationThread.Destroy;
begin
inherited;
end;
procedure TJDApplicationThread.DoSync;
begin
Self.fOwner.ThreadSync(Self);
// if assigned(fOnSync) then fOnSync(Self);
end;
procedure TJDApplicationThread.Execute;
var
ST: Integer;
begin
ST:= 5;
fStop:= False;
while (not Terminated) and (not fStop) do begin
//----- BEGIN -----
Synchronize(DoSync);
//----- END -----
//Sleep(1000 * ST);
end;
end;
procedure TJDApplicationThread.Start;
begin
fStop:= False;
Resume;
end;
procedure TJDApplicationThread.Stop;
begin
fStop:= True;
Suspend;
end;
initialization
JDApplication:= TJDApplication.Create(nil);
finalization
if assigned(JDApplication) then begin
JDApplication.Free;
JDApplication:= nil;
end;
end.
And here's an application using this:
program Win7FormTestD7;
uses
Forms,
W7Form1 in 'W7Form1.pas' {Win7Form1},
JDForms in 'JDForms.pas';
begin
JDApplication.Initialize;
JDApplication.CreateForm(TWin7Form1, Win7Form1);
JDApplication.Run;
end.
The form 'W7Form1' is just a plain form with a couple random controls on it to test with.
Users here should not ask the question of why I want to do this, I have my reasons. I learn by doing, not by someone showing me or by reading some book or finding a bunch of code which I don't know how it works. This is a way for me to better learn the workings of applications and be able to expand my knowledge in the field to be able to build more complex applications in the future.
Keep in mind that TCustomForm has no concept of your TJDApplication class, it only works with the Forms.TApplication class instead. Make sure your TJDApplication.Run() method is exiting when the Forms.TApplication.Terminated property has been set to True.
If building lightweight application is your motto, I suggest you to play around with :
The KOL Library
The SDA Framework
VCL Light by Paul TOTH
LVCL based on VCL Light code by SO member Arnaud Bouchez.