Dear Delphi programmers,
I'm looking for help how to write a one-shot timer (No GUI, so VCL Timers out of question)...
Let me explain a little bit more.
In my code (explaining with VCL timer but in this particular project I have no forms):
Call a procedure which send a char over serial port
Enable a timer with a X amount of Interval
In the OnTimer event:
I have a code which send a char then disable the timer itself to never be executed again.
The problem is that I need to make the creation of these timers dynamic.
I thought of the function SetTimer() then KillTimer() in the "OnTimer event" to disable it (free it).
Is it a good (safe) way?
Thank you!
Is it safe to kill timer from inside of a timer event ?
Yes, that's perfectly safe.
How to implement simplest one shot timer ?
The easiest implementation of a 1 second one shot timer is this, but note, that if you start more of them, you won't be able to distinguish which one of them elapsed its interval:
procedure TimerProc(hwnd: HWND; uMsg: UINT; idEvent: UINT_PTR;
dwTime: DWORD); stdcall;
begin
KillTimer(0, idEvent);
ShowMessage('I''m done!');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SetTimer(0, 0, 1000, #TimerProc);
end;
The multimedia timer API provides support for a one shot timer. The benefit is, that the timing is much more precise than the SetTimer/KillTimer solution and you can use it with intervals <50 ms. This comes at a price, as the callback does not return in the context of the main thread.
Here is my implementation of a one-shot timer using the multimedia timer API:
unit MMTimer;
interface
uses windows, Classes, mmsystem, SysUtils;
TOneShotCallbackEvent = procedure (const UserData: Pointer) of object;
(*
The MMOneShotCallback function calls the Callback after the Interval passed.
** Attention: **
The Callback is not called within the context of the main thread.
*)
type TMMOneShotTimer = class(TObject)
private
FTimeCaps: TTimeCaps;
FResult: Integer;
FResolution: Cardinal;
public
constructor Create;
function MMOneShotCallback(const Interval: Cardinal; UserData: Pointer; Callback: TOneShotCallbackEvent): Boolean;
property Result: Integer read FResult;
property Resolution: Cardinal read FResolution;
end;
implementation
type
TOneShotCallbackData = record
Callback: TOneShotCallbackEvent;
UserData: Pointer;
end;
POneShotCallbackData = ^TOneShotCallbackData;
procedure OneShotCallback(TimerID, Msg: UINT;
dwUser, dw1, dw2: DWord); pascal;
var pdata: POneShotCallbackData;
begin
pdata := Pointer(dwUser);
pdata.Callback(pdata.UserData);
FreeMemory(pdata);
end;
constructor TMMOneShotTimer.Create;
begin
FResult := timeGetDevCaps(#FTimeCaps, SizeOF(FTimeCaps));
Assert(FResult=TIMERR_NOERROR, 'Call to timeGetDevCaps failed');
FResolution := FTimeCaps.wPeriodMin;
FResult := timeBeginPeriod(FResolution);
Assert(FResult=TIMERR_NOERROR, 'Call to timeBeginPeriod failed');
end;
function TMMOneShotTimer.MMOneShotCallback(const Interval: Cardinal; UserData: Pointer; Callback: TOneShotCallbackEvent): Boolean;
var pdata: POneShotCallbackData;
begin
GetMem(pdata, SizeOf(TOneShotCallbackData));
pdata.Callback := Callback;
pdata.UserData := UserData;
result := (0 <> timeSetEvent(Interval, FResolution, #OneShotCallback, DWord(pdata), TIME_ONESHOT));
if not result then
FreeMemory(pdata);
end;
end.
Do you realize, that you do not have to have a GUI, to use a VCL timer as long as you do have a window handle? You can simply instantiate one from the code by
fTimer := TTimer.Create(hWindowHandle);
And even if you don't have a window handle You can create one by calling
fVirtualWindowHWND := AllocateHWnd(WndMethod);
but in that case you also have to write your own message loop.
I know that calling the Windows API seems to be an easier solution, but it also has its own caveeats (like you can not pass a class method to it...), and I tought, You might want to know about this one.
Related
Hopefully a simple one. I am using an OTL Parallel.For loop to process lots of data. The amount of data can change and if there is a lot (that takes over 2 seconds) Windows flickers the application form and gives a temporary "not responding" status in the title bar.
To get around this I thought I could put the procedure with the Parallel.For loop inside an OTL Async call, like
done:=false;
Async(ProcedureThatDoesParallelFor).Await(
procedure begin
done:=true;
end);
repeat application.processmessages until done=true;
This works (or seems to work) but can lead to the program just aborting/exiting without any error messages. It only seems to cause the silent abort problem when the Parallel.For loop is very quick to run.
If I remark the above code and take the call to ProcedureThatDoesParallelFor outside of it the app runs fine without unexpected quitting, so I am assuming it must be the Async call causing the problem. Or a combination of Parallel.For within Async?
Is using Async the best way to run another procedure and wait for it to finish? Is there a better OTL way of doing this?
Thanks for any ideas or solutions.
Here is the simplest example to show the crashing error. Single form with a memo and button. Click the button and the program will hang around iteration 300.
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls,OtlParallel,OtlTaskControl;
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure AsyncParallelFor;
var iterations:integer;
blah:integer;
begin
iterations:=10;
//for iter:=0 to limit-1 do
Parallel.For(0,iterations-1).Execute(procedure(iter:integer)
var x,y:integer;
begin
for y:=0 to 50 do
begin
for x:=0 to 50 do
begin
blah:=x+y;
end;
end;
end);
end;
procedure AsyncProcedure;
var done:boolean;
begin
done:=false;
Parallel.Async(
procedure
begin
//executed in background thread
AsyncParallelFor;
end,
Parallel.TaskConfig.OnTerminated(
procedure (const task: IOmniTaskControl)
begin
//executed in main thread after the async has finished
done:=true;
end
)
);
//this point is reached immediately after the call to Async
//the repeat loop waits until the Async is finished being signalled via done variable
repeat
application.processmessages;
until done=true;
end;
procedure TForm1.Button1Click(Sender: TObject);
var iters:integer;
begin
iters:=0;
repeat
memo1.lines.add('Iteration '+inttostr(iters)+'...');
memo1.lines.add('Before Async');
application.processmessages;
AsyncProcedure;
memo1.lines.add('After Async');
application.processmessages;
inc(iters);
until 1>2;
end;
end.
AsyncParallelFor shows the basic nested loops. Just a simple addition in there to demo the issue.
AsyncProcedure does the OTL Async call and waits for the return.
I have a lot of non parallel code before and after the call to AsyncProcedure that need to wait for the parallel.for loop to finish.
If I change the button click to call AsynParallelFor directly without the Async then there is no hang.
In your AsyncProcedure, there is no need to repeatedly wait for the async call to finish. This defeats the event driven model that the OS is built on. Specially calling Application.ProcessMessages can lead to unexpected things to happen.
Use the OnTerminate event to signal that the async call is done and there take actions what to do next. In the example provided in this answer, a callback method is used to handle that.
A button click method is supposed to do only a short task, not an eternal loop with the dreaded calls to Application.ProcessMessages.
Instead, use a flag to indicate whether a new call to the async procedure should be done.
Below is an example how to modify your test with a callback method and an event driven model (I did not try the OTL calls, but I would be surprised if the library is the cause of your problems):
type
TForm1 = class(TForm)
BtnStart: TButton;
BtnStop: TButton;
Memo1: TMemo;
procedure BtnStartClick(Sender: TObject);
procedure BtnStopClick(Sender: TObject);
private
{ Private declarations }
fDoRepeat : Boolean;
fIterations : Integer;
procedure MyCallbackMethod(Sender : TObject);
public
{ Public declarations }
end;
procedure AsyncProcedure( MyCallbackMethod : TNotifyEvent);
begin
Parallel.Async(
procedure
begin
//executed in background thread
AsyncParallelFor;
end,
Parallel.TaskConfig.OnTerminated(
procedure (const task: IOmniTaskControl)
begin
//executed in main thread after the async has finished
MyCallbackMethod(Nil);
end)
);
end;
procedure TForm1.MyCallbackMethod(Sender : TObject);
begin
if (Sender = nil) then // Callback from AsyncProcedure
memo1.lines.add('After Async');
if fDoRepeat then begin
Inc(fIterations);
memo1.lines.add('Iteration '+inttostr(fIterations)+'...');
memo1.lines.add('Before Async');
AsyncProcedure(MyCallbackMethod);
end;
end;
procedure TForm1.BtnStartClick(Sender: TObject);
begin
fDoRepeat := true;
fIterations := 0;
BtnStart.Enabled := false;
MyCallbackMethod(Sender); // Start iteration event looping
end;
procedure TForm1.BtnStopClick(Sender: TObject);
begin
fDoRepeat := false; // Stop iteration loop
BtnStart.Enabled := true;
end;
Update
Running the above test in debug mode gave:
Out of memory
after 387 iterations in an OTL unit allocating memory for a buffer (and it is running slow).
Testing the OTL Parallel.For() with some other examples from Updating a Progress Bar From a Parallel For Loop (Plus Two Bonuses) did not improve the outcome. Program hangs at 400 iterations.
Using the bug ridden Delphi PPL did in fact work, though.
Uses
Threading;
procedure AsyncParallelFor;
var
iterations:integer;
blah:integer;
begin
iterations := 10;
TParallel.For(0,iterations-1,
procedure(iter : integer)
var x,y:integer;
begin
for y := 0 to 50 do
begin
for x := 0 to 50 do
begin
blah := x+y;
end;
end;
end);
end;
procedure AsyncProcedure( MyCallbackMethod : TNotifyEvent);
begin
TTask.Run(
procedure
begin
AsyncParallelFor;
//executed in main thread after the async has finished
TThread.Queue(nil,
procedure
begin
MyCallbackMethod(Nil);
end
);
end);
end;
To update the GUI within a parallel for loop, just use this code within the loop:
TThread.Queue(nil,
procedure
begin
// Some code that updates the GUI or calls a method to do so.
end
);
I would like to write a loop that checks the value of a variable has changed. There's no event that fires to tell me the value has changed.
The application doesn't support multi threading.
How to achieve this without causing app to freeze ?
The aim is this:
Application starts
...
loop
Check variable value
If changed then
exit
if timedOut then
exit
While loop causes application to freeze.
Thank you.
* Edit *
This is what I'm after (this code is written by Remy Lebeau):
const
APPWM_COM_EVENT_DONE = WM_APP + 1;
APPWM_COM_EVENT_TIMEOUT = WM_APP + 2;
type
MyClass = class
private
MsgWnd: HWND;
procedure COMEventHandler(parameters);
procedure WndProc(var Message: TMessage);
public
constructor Create;
destructor Destroy; override;
procedure DoIt;
end;
constructor MyClass.Create;
begin
inherited;
MsgWnd := AllocateHWnd(WndProc);
end
destructor MyClass.Destroy;
begin
KillTimer(MsgWnd, 1);
DeallocateHWnd(MsgWnd);
inherited;
end;
procedure MyClass.COMEventHandler(parameters);
begin
KillTimer(MsgWnd, 1);
PostMessage(MsgWnd, APPWM_COM_EVENT_DONE, 0, 0);
end;
procedure MyTimer(hWnd: HWND; uMsg: UINT; idEvent: UINT_PTR; dwTime: DWORD); stdcall;
begin
KillTimer(hWnd, idEvent);
PostMessage(hWnd, APPWM_COM_EVENT_TIMEOUT, 0, 0);
end;
procedure MyClass.WndProc(var Message: TMessage);
begin
case Message.Msg of
APPWM_COM_EVENT_DONE:
begin
// Event fired, all good
end;
APPWM_COM_EVENT_TIMEOUT:
begin
// Event timed out
end;
else
begin
Message.Result := DefWindowProc(MsgWnd, Message.Msg, Message.WParam, Message.LParam);
end;
end;
end;
procedure MyClass.DoIt;
begin
SetTimer(MsgWnd, 1, 1000 * 1000, #MyTimer);
// invoke COM function that will eventually trigger the COM event...
end;
How to call DoIt and wait for either Event to fire or timeout without causing the application to freeze ?
Tried using while do loop but that prevented WndProc from running.
Thank you
Answer depends on your application demands. There are 2 easy solutions with prons and cons each:
1. Put Timer to application and check value by timeout. Dignity - it is the most easy way for GUI application (Windows messages loop already exists), drawback on other side - there will be delta time of detecting value have been changed.
2. Handle Application.OnIdle event. Disadvantage of this approach - yor checking procedure will be runned if nobody click on GUI elements.
Professional way to solve your solution - wrap your variable by complex object, for example:
Trigger = class
private
FOnChanged: TNotifyEvent;
public
procedure Emit;
property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;
end;
procedure Trigger.Emit;
if Assined(FOnChanged) then
FOnChanged(Self)
end;
Cause of your application has not threads we can implement Trigger without mutexes/critical sections, on another side you can handle changing as soon as event producer will raise Emit
Good approach if you don't want use multithreading is split your ligic on multiple state machines based on coroutines.
Example based on AIO framework https://github.com/Purik/AIO
AIO framework create itself events loop, scheduling multiple state machines in parallel without threads:
program TriggerExample;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils,
SyncObjs,
Gevent,
Greenlets;
const
WAIT_TMEOUT_MSEC = 1000;
var
ChangedEvent: TGevent;
Value: Boolean = False;
// Part of application that raise change events randomly
procedure EventsProducer;
begin
while True do
begin
Greenlets.GreenSleep(100+Random(10000));
Value := True;
ChangedEvent.SetEvent;
end;
end;
begin
ChangedEvent := TGevent.Create(False, False);
// run fake event producer inside other state machine
TSymmetric.Spawn(EventsProducer);
// Loop
while True do
begin
if ChangedEvent.WaitFor(WAIT_TMEOUT_MSEC) = wrSignaled then
begin
WriteLn('Value was changed');
Value := False
end
else
begin
WriteLn('Exit by timeout');
end;
end;
end.
Has anybody tried SIP Delphi component? I bought it some time ago at a reasonable price with sources in order to replace the old code written for Dialogic HMP. It looks like mail support was not implied, docs and help were absent either though with available codes I was not going to have troubles. And they didn't appear until now when I got stuck with the problem I cannot find a solution to.
The library during the call sends small RTP data packets via UDP every 20 ms and to keep these intervals equal it uses a winsdk function timeSetEvent. Here is the extracts from the code (I simplified it to make the things clearer):
Interface
type
// RTP packet header
TRTPHeader = packed record
Byte80: Byte;
PayloadType: Byte;
SeqNo: WORD;
TimeStamp: DWORD;
SSRC: DWORD;
end;
//RTP packet structure
TRTP = packed record
H: TRTPHeader;
Payload: packed array [0 .. 1023] of Byte;
end;
//class realisation of ISipCall interface
TCall = class(TInterfacedObject, ISipCall)
FRtpPacketToSend:TRTP;//RTP packet
//callback function, it is invoked by TMicrophoneThread regularly
procedure OnMicrophone(const Buffer: Pointer);
end;
//Thread class for timing purposes
TMicrophoneThread = class(TThread)
public
FCall: TCall;//call associated with this thread
FEvent: THandle;// Event handle
FTimerHandle: THandle;// Timer handle
procedure Execute; override;
constructor Create(const ACall: TCall);
destructor Destroy; override;
end;
implementation
procedure TCall.OnMicrophone(const Buffer: Pointer); //callback function, it is invoked by TMicrophoneThread regularly
var socket: TSocket;
begin
//preparing FRtpPacketToSend data, initializing socket, Remote server address
//win32 function, sends data to the “Remote” server
sendto(socket, FRtpPacketToSend, sizeof(FRtpPacketToSend), 0, #Remote, SizeOf(Remote));
end;
//callback function invoked by windows timer every 20 ms
procedure Timer20ms(uTimerID, uMessage: UINT; dwUser, dw1, dw2: DWORD_PTR); stdcall;
begin
SetEvent(TMicrophoneThread(dwUser).FEvent);//Sets the TMicrophoneThread event
end;
constructor TMicrophoneThread.Create(ACall: TCall);
begin
inherited;
FCall:=ACall;
FEvent := CreateEvent(nil, False, False, nil);
//Setting timer
FTimerHandle := timeSetEvent(20, 0, #Timer20ms, Cardinal(Self), TIME_CALLBACK_FUNCTION + TIME_PERIODIC);
end;
destructor TMicrophoneThread.Destroy;
begin
timeKillEvent(FTimerHandle);//removing timer
CloseHandle(FEvent);
inherited;
end;
procedure TMicrophoneThread.Execute;
var
buf: array [0 .. 159] of SmallInt;//buffer data, looks like for storing data between function calls
begin
FillChar(buf, SizeOf(buf), 0);
Repeat
//waiting for the timer to set FEvent from Timer20ms function
if (WaitForSingleObject(FEvent, INFINITE) <> WAIT_TIMEOUT) and not Terminated then
begin
if not Terminated then
try
FCall.OnMicrophone(#buf);
except
end;
end;
until Terminated;
end;
//Using these classes:
// Sip call object
Call:=TCall.Create;
// TMicrophoneThread object creates timer and every 20 ms invokes OnMicrophone function to send UDP data in realtime
Mth= TMicrophoneThread.Create(Call);
This code works fine, voice data flows smoothly. But to my surprise it works perfectly up until the number of simultaneous calls exceeds 16, the 17th and other calls do not receive timer signals. I found that this function is already marked as obsolete and some people encountered the same undocumented restrictions of this function - no more than 16 threads.
Instead of timeSetEvent I tried using CreateTimerQueue/CreateTimerQueueTimer with different parameters:
implementation
var
TimerQueue: THandle;
....
procedure WaitOrTimerCallback(lpParameter: Pointer; TimerOrWaitFired: BOOL); stdcall;
begin
SetEvent(TMicrophoneThread(lpParameter).FEvent);
end;
constructor TMicrophoneThread.Create(ACall: TCall);
begin
inherited;
FCall:=ACall;
FEvent := CreateEvent(nil, False, False, nil);
//Setting timer
CreateTimerQueueTimer(FTimerHandle, TimerQueue, #WaitOrTimerCallback, Self, 0, 20, 0);
end;
...
initialization
TimerQueue := CreateTimerQueue;
Also I tried Sleep and its more advanced realization based on QueryPerformanceFrequency/QueryPerformanceCounter:
procedure TMicrophoneThread.Execute;
var
buf: array [0 .. 159] of SmallInt;
waittime: integer;
begin
FillChar(buf, SizeOf(buf), 0);
repeat
if not Terminated then
try
FCall.OnMicrophone(#buf);
waittime:=round((Now - FCall.GetStartTime)*MSecsPerDay)
if waittime<20 then
Sleep(20-waittime)
except
end;
until Terminated;
end;
All these possible solutions have the same problem - voice flow stops being continuous and you distinctively hear clicks during the playback especially if you have two or more calls. The only reason I can imagine is that timeSetEvent is more accurate than others. What can be done here?
Given that you have pinpointed a limit in the number of timers, a small design change to keep within that limit seems in order. Each timer currently does a negligible amount of work when procedure Timer20ms is called. So it seems feasible to allow a single timer to set multiple events.
As a first pass I'd try using only a single timer to set all the events.
I doubt this will be a solution because it's unlikely that signalling (resuming) a large number of TMicrophoneThread instances simultaneously won't cause other problems. But it will be useful to see how many can be handled smoothly (let's call it simultaneous-signal-limit); as this will likely be a factor in determining a hard limit before you need to look at scaling to better/more hardware.
constructor TMicrophoneThread.Create(ACall: TCall);
begin
inherited;
FCall:=ACall;
FEvent := CreateEvent(nil, False, False, nil);
{ Instead of setting a new timer, add the event to a list. }
TimerEvents.Add(FEvent);
end;
destructor TMicrophoneThread.Destroy;
begin
{ Instead of removing the timer, remove the event }
TimerEvents.Remove(FEvent);
CloseHandle(FEvent);
inherited;
end;
procedure Timer20ms(uTimerID, uMessage: UINT; dwUser, dw1, dw2: DWORD_PTR); stdcall;
{ The timer callback sets all events in the list. }
var
LTimers: TList;
begin
{ I'm illustrating this code where TimerEvents is implemented as a TThreadList.
If you can ensure all access to the list happens from the same thread,
you'll be able to do away with the locks - which would be better. }
LTimers := TThreadList(dwUser).LockList;
try
for LoopI := 0 to LTimers.Count - 1 do
SetEvent(THandle(LTimers[LoopI]));
finally
TThreadList(dwUser).UnlockList;
end;
end;
Once this experiment is out the way, you could look at running multiple timers. Each with its own list. If you stagger the timers, and manage to get a reasonably fair distribution of TMicrophoneThread instances across each timer; you may be able to get close to handling 16 x simultaneous-signal-limit instance of TMicrophoneThread.
I use Delphi 7 and my project has several non modal visible forms. The problem is if in one of them MessageBoxEx is called all actions of the application are not updated until MessageBoxEx’s form is closed. In my project it can broke business logic of application.
The TApplication.HandleMessage method is never called while MessageBoxEx's window is shown so it doesn’t call the DoActionIdle and Actions are not updated.
I think what I need is to catch a state of my application when it’s idle and update states of all actions.
First I implemented TApplication. OnIdle handler:
procedure TKernel.OnIdle(Sender: TObject; var Done: Boolean);
begin
{It’s only to switch off the standard updating from TApplication.Idle. It's to make the CPU usage lower while MessageBoxEx's window isn't shown }
Done := False;
end;
implementation
var
MsgHook: HHOOK;
{Here is a hook}
function GetMsgHook(nCode: Integer; wParam: Longint; var Msg: TMsg): Longint; stdcall;
var
m: TMsg;
begin
Result := CallNextHookEx(MsgHook, nCode, wParam, Longint(#Msg));
if (nCode >= 0) and (_instance <> nil) then
begin
{If there aren’t the messages in the application's message queue then the application is in idle state.}
if not PeekMessage(m, 0, 0, 0, PM_NOREMOVE) then
begin
_instance.DoActionIdle;
WaitMessage;
end;
end;
end;
initialization
MsgHook := SetWindowsHookEx(WH_GETMESSAGE, #GetMsgHook, 0, GetCurrentThreadID);
finalization
if MsgHook <> 0 then
UnhookWindowsHookEx(MsgHook);
Here is a method for updating states of all actions of the application. It’s just a modified version of TApplication.DoActionIdle:
type
TCustomFormAccess = class(TCustomForm);
procedure TKernel.DoActionIdle;
var
i: Integer;
begin
for I := 0 to Screen.CustomFormCount - 1 do
with Screen.CustomForms[i] do
if HandleAllocated and IsWindowVisible(Handle) and
IsWindowEnabled(Handle) then
TCustomFormAccess(Screen.CustomForms[i]).UpdateActions;
end;
It seems that the updating of the states happens much often than usually (I’m going to find out where is a problem using profiler).
Besides, CPU usage grows seriously when the mouse’s cursor is not over the application’s windows (about 25% on my DualCore Pentium).
What do you think about my problem and the way I try to solve it? Is it a good idea to use hooks or there is a better way to catch the application idle state? Do I rather need to use WH_CALLWNDPROCRET during setting the hook?
Why MessageBoxEx blocks TApplication.HandleMessage? Is there way to prevent this behavior? I’ve tried to call it with MB_APPLMODAL, MB_SYSTEMMODAL, MB_TASKMODAL flags but it didn’t help.
MessageBox/Ex() is a modal dialog, and as such it runs its own message loop internally since the calling thread's normal message loop is blocked. MessageBox/Ex() receives any messages that are in the calling thread's message queue, and will dispatch them to target windows normally (so things like window-based timers still work, such as TTimer), but its modal message loop has no concept of VCL-specific messages, like action upates, and will discard them. TApplication.HandleMessage() is only called by the main VCL message loop, the TApplication.ProcessMessages() method, and the TForm.ShowModal() method (this is why modal VCL Form windows do not suffer from this problem), none of which are called while MessageBox/Ex() is running (the same will be true for any OS modal dialog).
To solve your problem, you have a couple of choices:
set a thread-local message hook via SetWindowsHookEx() right before calling MessageBox/Ex(), then release the hook right after MessageBox/Ex() exits. This allows you to look at every message that MessageBox/Ex() receives and dispatch them to VCL handlers as needed. DO NOT call PeekMessage(), GetMessage() or WaitMessage() inside of a message hook!
type
TApplicationAccess = class(TApplication)
end;
function GetMsgHook(nCode: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
Msg: TMsg;
begin
if (nCode >= 0) and (wParam = PM_REMOVE) then
begin
Msg := PMsg(lParam)^;
with TApplicationAccess(Application) do begin
if (not IsPreProcessMessage(Msg))
and (not IsHintMsg(Msg))
and (not IsMDIMsg(Msg))
and (not IsKeyMsg(Msg))
and (not IsDlgMsg(Msg)) then
begin
end;
end;
end;
Result := CallNextHookEx(MsgHook, nCode, wParam, lParam);
end;
function DoMessageBoxEx(...): Integer;
var
MsgHook: HHOOK;
begin
MsgHook := SetWindowsHookEx(WH_GETMESSAGE, #GetMsgHook, 0, GetCurrentThreadID);
Result := MessageBoxEx(...);
if MsgHook <> 0 then UnhookWindowsHookEx(MsgHook);
end;
move the MessageBox/Ex() call to a separate worker thread so the calling thread is free to process messages normally. If you need to wait for the result of MessageBox/Ex(), such as when prompting the user for input, then you can use MsgWaitForMultipleObjects() to wait for the thread to terminate while allowing the waiting thread to call Application.ProcessMessages() whenever there are pending messages to process.
type
TMessageBoxThread = class(TThread)
protected
procedure Execute; override;
...
public
constructor Create(...);
end;
constructor TMessageBoxThread.Create(...);
begin
inherited Create(False);
...
end;
function TMessageBoxThread.Execute;
begin
ReturnValue := MessageBoxEx(...);
end;
function DoMessageBoxEx(...): Integer;
var
Thread: TMessageBoxThread;
WaitResult: DWORD;
begin
Thread := TMessageBoxThread.Create(...);
try
repeat
WaitResult := MsgWaitForMultipleObjects(1, Thread.Handle, False, INFINITE, QS_ALLINPUT);
if WaitResult = WAIT_FAILED then RaiseLastOSError;
if WaitResult = WAIT_OBJECT_0 + 1 then Application.ProcessMessages;
until WaitResult = WAIT_OBJECT_0;
Result := Thread.ReturnVal;
finally
Thread.Free;
end;
end;
How can I track the count of a certain class in memory in Delphi 7, without adding a static counting member in the class.
For the purpose of tracking the program performance.
Thank you in advanced.
You can hook the NewInstance and FreeInstance methods in the class VMT:
unit ClassHook;
{no$DEFINE SINGLE_THREAD}
interface
var
BitBtnInstanceCounter: integer;
implementation
uses Windows, Buttons;
function GetVirtualMethod(AClass: TClass; const VmtOffset: Integer): Pointer;
begin
Result := PPointer(Integer(AClass) + VmtOffset)^;
end;
procedure SetVirtualMethod(AClass: TClass; const VmtOffset: Integer; const Method: Pointer);
var
WrittenBytes: {$IF CompilerVersion>=23}SIZE_T{$ELSE}DWORD{$IFEND};
PatchAddress: PPointer;
begin
PatchAddress := Pointer(Integer(AClass) + VmtOffset);
WriteProcessMemory(GetCurrentProcess, PatchAddress, #Method, SizeOf(Method), WrittenBytes);
end;
{$IFOPT W+}{$DEFINE WARN}{$ENDIF}{$WARNINGS OFF} // avoid compiler "Symbol 'xxx' is deprecated" warning
const
vmtNewInstance = System.vmtNewInstance;
vmtFreeInstance = System.vmtFreeInstance;
{$IFDEF WARN}{$WARNINGS ON}{$ENDIF}
type
TNewInstanceFn = function(Self: TClass): TObject;
TFreeInstanceProc = procedure(Self: TObject);
var
OrgTBitBtn_NewInstance: TNewInstanceFn;
OrgTBitBtn_FreeInstance: TFreeInstanceProc;
function TBitBtn_NewInstance(Self: TClass): TObject;
begin
Result := OrgTBitBtn_NewInstance(Self);
{$IFDEF SINGLE_THREAD}
Inc(BitBtnInstanceCounter);
{$ELSE}
InterlockedIncrement(BitBtnInstanceCounter);
{$ENDIF}
end;
procedure TBitBtn_FreeInstance(Self: TObject);
begin
{$IFDEF SINGLE_THREAD}
Dec(BitBtnInstanceCounter);
{$ELSE}
InterlockedDecrement(BitBtnInstanceCounter);
{$ENDIF}
OrgTBitBtn_FreeInstance(Self);
end;
procedure InstallHooks;
begin
OrgTBitBtn_NewInstance := GetVirtualMethod(TBitBtn, vmtNewInstance);
OrgTBitBtn_FreeInstance := GetVirtualMethod(TBitBtn, vmtFreeInstance);
SetVirtualMethod(Buttons.TBitBtn, vmtNewInstance, #TBitBtn_NewInstance);
SetVirtualMethod(Buttons.TBitBtn, vmtFreeInstance, #TBitBtn_FreeInstance);
end;
procedure RemoveHooks;
begin
SetVirtualMethod(Buttons.TBitBtn, vmtNewInstance, #OrgTBitBtn_NewInstance);
SetVirtualMethod(Buttons.TBitBtn, vmtFreeInstance, #OrgTBitBtn_FreeInstance);
end;
initialization
InstallHooks;
finalization
RemoveHooks;
end.
Include this unit in any uses clause of your program and now the BitBtnInstanceCounter will track the count of TBitBtn instances.
Edit: if it is possible that several threads simultaneously create objects of the tracked class, it is necessary to use interlocked access to modify the counter variable. Beware that third-party components could silently use threads, so it's safer to not define the SINGLE_THREAD symbol.
There's no built-in way to do that. Some profilers (AQTime?) generate such metrics for you by installing a custom heap manager hook and then by looking at the type pointer that sits at the beginning of any object. You can do this yourself but if this is for profiling during development it's a lot easier to just use what's already been developed and tested by others.