MessageBoxEx stops updation of actions - delphi

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;

Related

Looping without causing app to freeze

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.

How to avoid crash with Thread.terminate command?

Scenario 1) When I click button1 and then close form with X while thread is working I get "Thread Error: The handle is invalid"
Scenario 2) When I close application without clicking button1 I get "Access Violation ..."
procedure TForm1.Button1Click(Sender: TObject);
begin
ProccesSupervisor:= TMyThread0.Create(True);
ProccesSupervisor.FreeOnTerminate:=true;
ProccesSupervisor.Priority := tpNormal;
ProccesSupervisor.Resume;
end;
procedure TMyThread0.Execute;
begin
repeat
//some code here
until ProccesSupervisor.terminated=true;
end;
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
ProccesSupervisor.Terminate;
ProccesSupervisor.WaitFor;
end;
Never reference a thread object when FreeOnTerminate = true. The thread may already have finished its work and destroyed itself, so accessing it may not be safe.
In your OnCloseQuery event handler, you furthermore are accessing an uninitialized object if Button1 has not been clicked.
If you want to control the lifetime of the thread, leave FreeOnTerminate = false.
In your OnCloseQuery event handler, check if the thread is assigned before terminating it, and also prevent a Button1 click event to start more than one thread at a time.
In TMyThread0.Execute(), there must not be a reference to a specific thread instance when accessing the fields and methods of the class. Write this instead:
until Terminated;
Do not use TThread.WaitFor() with TThread.FreeOnTerminate=True.
When Execute() exits, if TThread.FreeOnTerminate=True then the TThread object destroys itself, closing the thread handle that TThread.WaitFor() waits on. So you may see the "invalid handle" error. Or you may get an access violation instead, or any number of other unexpected errors/symptoms, since you have undefined behavior due to a race condition where WaitFor() might be called on an invalid object, or usually the object is destroyed while WaitFor() is still running. And WaitFor() raises an exception on any OS error, including the "invalid handle" error.
Setting TThread.FreeOnTerminate=True is primarily meant to be used with threads that are forgotten about once they are started. If you need to reference a thread after it is started, do not use FreeOnTerminate at all. You don't want the thread to disappear behind your back.
Also, Execute() should not be accessing its Terminated property via an external object pointer. Use the Self pointer instead.
Try this instead:
procedure TForm1.Button1Click(Sender: TObject);
begin
ProccesSupervisor := TMyThread0.Create(False);
end;
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
if ProccesSupervisor <> nil then
begin
ProccesSupervisor.Terminate;
ProccesSupervisor.WaitFor;
FreeAndnil(ProccesSupervisor);
end;
end;
procedure TMyThread0.Execute;
begin
while not Terminated do
begin
//some code here
end;
end;
If you absolutely must set TThread.FreeOnTerminate=True, then you should use the TThread.OnTerminate event to know when the thread disappears, but still stay away from TThread.WaitFor(), do your own error handling, eg:
procedure TForm1.Button1Click(Sender: TObject);
begin
ProccesSupervisor := TMyThread0.Create(True);
ProccesSupervisor.FreeOnTerminate := True;
ProccesSupervisor.OnTerminate := ThreadTerminated;
ProccesSupervisor.Resume;
end;
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
var
H: array[0..1] of THandle;
Msg: TMsg;
begin
if ProccesSupervisor <> nil then
begin
ProccesSupervisor.Terminate;
//ProccesSupervisor.WaitFor;
H[0] := ProccesSupervisor.Handle;
H[1] := Classes.SyncEvent;
WaitResult := 0;
repeat
case MsgWaitForMultipleObjects(2, H, False, INFINITE, QS_SENDMESSAGE) of
WAIT_OBJECT_0, WAIT_FAILED: Break;
WAIT_OBJECT_0 + 1: CheckSynchronize;
WAIT_OBJECT_0 + 2: PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE);
end;
until ProccesSupervisor = nil;
end;
end;
procedure TForm1.ThreadTerminated(Sender: TObject);
begin
ProccesSupervisor := nil;
end;
procedure TMyThread0.Execute;
begin
while not Terminated do
begin
//some code here
end;
end;

Delphi: Issues during download of update file, with Indy (TidHttp)

Q1: Why during downloading process the modal form cannot be closed
Q2: Why when download is finished the progress bar doesn't rich 100% (it's a manner of repaint?)
Q3: Why if I stop and restart the connection to the web server during
download the transfer is stopping without indicating any error and
never continue? What can I do to get and catch the error and go
back to initial status (download and install with progress bar at
position 0)
Remark: IdAntiFreeze is active
procedure Tform_update.button_downloadClick(Sender: TObject);
var
FS: TFileStream;
url, file_name: String;
begin
//execute download
if button_download.Tag = 0 then
begin
Fdone:= False;
Fcancel:= False;
url:= APP_DOMAIN + '/downloads/Setup.exe';
file_name:= 'C:\Temp\Setup.exe';
if FileExists(file_name) then DeleteFile(file_name);
try
FS:= TFileStream.Create(file_name, fmCreate);
Http:= TIdHTTP.Create(nil);
Http.OnWorkBegin:= HttpWorkBegin;
Http.OnWork:= HttpWork;
Http.Get(url, FS);
finally
FS.Free;
Http.Free;
if Fdone then ModalResult:= mrOk;
end;
end
else
//cancel download
begin
Fcancel:= True;
end;
end;
procedure Tform_update.HttpWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64);
var
ContentLength: Int64;
Percent: Integer;
begin
ContentLength:= Http.Response.ContentLength;
if AWorkCount = ContentLength then Fdone:= True; //
if (Pos('chunked', LowerCase(Http.Response.TransferEncoding)) = 0) and (ContentLength > 0) then
begin
sleep(15);
Percent := 100 * AWorkCount div ContentLength;
progress_bar.Position:= Percent;
end;
//stop download
if Fcancel and Http.Connected then
begin
Http.IOHandler.InputBuffer.Clear;
Http.Disconnect;
Fcancel:= False;
button_download.Caption:= _('Download and Install');
button_download.Tag:= 0;
progress_bar.Position:= 0;
end;
end;
procedure Tform_update.HttpWorkBegin(ASender: TObject; AWorkMode: TWorkMode; AWorkCountMax: Int64);
begin
if AWorkMode <> wmRead then Exit;
button_download.Tag:= 1;
button_download.Caption:= _('Cancel');
end;
procedure Tform_update.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Fcancel:= True;
end;
Q1. Indy is blocking. All Antifreeze does invoke windows messages processing regularly. It doesn't stop the blocking nature of Indy and so unless you explicitly have a way to handle errors it won't behave how you want. You need to do the download in a different thread and use your form to monitor the status of that thread rather than try and rely on antifreeze. Don't put any UI actions in that thread, leave them in the main thread, so don't try and update the progress bar from within the thread. Set a synchronised variable to the progress percentage and read that from a timer in the main thread, for example. Remember that UI components are not thread safe and so should only ever be updated from a single thread.
Q2. I've seen that too. Nothing to do with Indy. I think that when you set the status bar to 100% the component does not immediately respond but tries to move smoothly to that point (but doesn't have time). That is just a guess, though. I am not sure. Or it may be the frequency with which antifreeze processes messages I guess (in which case it is to do with Indy).
Q3. Really the same as Q1, with the same solution. Put in a separate thread and monitor the status of that thread from the main thread.
Once you have moved the Indy actions to a separate thread, you should not need Antifreeze.
A different approach is to use TThread to control the execution. Something like this:
ThreadUpdate = class(TThread)
protected
procedure Execute; override;
public
procedure ThreadUpdate.Execute;
begin
inherited;
while (not terminated) do
begin
//YOUR CODE HERE - maybe your button_download Click
Terminate;
end;
end;
Also you may try to let Windows process messages for your app.
if (Pos('chunked', LowerCase(Http.Response.TransferEncoding)) = 0) and (ContentLength > 0) then
begin
sleep(15);
Percent := 100 * AWorkCount div ContentLength;
progress_bar.Position:= Percent;
**Application.ProcessMessages;**
end;
Regarding Q1 and Q2, a thread is certainly better. If you decide to keep using Indy Antifreeze, you should make sure the OnlyWhenIdle flag is set to False so it can process messages whenever work is done.

How to replace timeSetEvent function without losing functionality?

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.

How can I make AllocateHwnd threadsafe?

VCL components are designed to be used solely from the main thread of an application. For visual components this never presents me with any difficulties. However, I would sometimes like to be able to use, for example, non-visual components like TTimer from a background thread. Or indeed just create a hidden window. This is not safe because of the reliance on AllocateHwnd. Now, AllocateHwnd is not threadsafe which I understand is by design.
Is there an easy solution that allows me to use AllocateHwnd from a background thread?
This problem can be solved like so:
Obtain or implement a threadsafe version of AllocateHwnd and DeallocateHwnd.
Replace the VCL's unsafe versions of these functions.
For item 1 I use Primož Gabrijelcic's code, as described on his blog article on the subject. For item 2 I simply use the very well-known trick of patching the code at runtime and replacing the beginning of the unsafe routines with unconditional JMP instructions that redirect execution to the threadsafe functions.
Putting it all together results in the following unit.
(* Makes AllocateHwnd safe to call from threads. For example this makes TTimer
safe to use from threads. Include this unit as early as possible in your
.dpr file. It must come after any memory manager, but it must be included
immediately after that before any included unit has an opportunity to call
Classes.AllocateHwnd. *)
unit MakeAllocateHwndThreadsafe;
interface
implementation
{$IF CompilerVersion >= 23}{$DEFINE ScopedUnitNames}{$IFEND}
uses
{$IFDEF ScopedUnitNames}System.SysUtils{$ELSE}SysUtils{$ENDIF},
{$IFDEF ScopedUnitNames}System.Classes{$ELSE}Classes{$ENDIF},
{$IFDEF ScopedUnitNames}Winapi.Windows{$ELSE}Windows{$ENDIF},
{$IFDEF ScopedUnitNames}Winapi.Messages{$ELSE}Messages{$ENDIF};
const //DSiAllocateHwnd window extra data offsets
GWL_METHODCODE = SizeOf(pointer) * 0;
GWL_METHODDATA = SizeOf(pointer) * 1;
//DSiAllocateHwnd hidden window (and window class) name
CDSiHiddenWindowName = 'DSiUtilWindow';
var
//DSiAllocateHwnd lock
GDSiWndHandlerCritSect: TRTLCriticalSection;
//Count of registered windows in this instance
GDSiWndHandlerCount: integer;
//Class message dispatcher for the DSiUtilWindow class. Fetches instance's WndProc from
//the window extra data and calls it.
function DSiClassWndProc(Window: HWND; Message, WParam, LParam: longint): longint; stdcall;
var
instanceWndProc: TMethod;
msg : TMessage;
begin
{$IFDEF CPUX64}
instanceWndProc.Code := pointer(GetWindowLongPtr(Window, GWL_METHODCODE));
instanceWndProc.Data := pointer(GetWindowLongPtr(Window, GWL_METHODDATA));
{$ELSE}
instanceWndProc.Code := pointer(GetWindowLong(Window, GWL_METHODCODE));
instanceWndProc.Data := pointer(GetWindowLong(Window, GWL_METHODDATA));
{$ENDIF ~CPUX64}
if Assigned(TWndMethod(instanceWndProc)) then
begin
msg.msg := Message;
msg.wParam := WParam;
msg.lParam := LParam;
msg.Result := 0;
TWndMethod(instanceWndProc)(msg);
Result := msg.Result
end
else
Result := DefWindowProc(Window, Message, WParam,LParam);
end; { DSiClassWndProc }
//Thread-safe AllocateHwnd.
// #author gabr [based on http://fidoforum.ru/pages/new46s35o217746.ru.delphi and
// TIcsWndHandler.AllocateHWnd from ICS v6 (http://www.overbyte.be)]
// #since 2007-05-30
function DSiAllocateHWnd(wndProcMethod: TWndMethod): HWND;
var
alreadyRegistered: boolean;
tempClass : TWndClass;
utilWindowClass : TWndClass;
begin
Result := 0;
FillChar(utilWindowClass, SizeOf(utilWindowClass), 0);
EnterCriticalSection(GDSiWndHandlerCritSect);
try
alreadyRegistered := GetClassInfo(HInstance, CDSiHiddenWindowName, tempClass);
if (not alreadyRegistered) or (tempClass.lpfnWndProc <> #DSiClassWndProc) then begin
if alreadyRegistered then
{$IFDEF ScopedUnitNames}Winapi.{$ENDIF}Windows.UnregisterClass(CDSiHiddenWindowName, HInstance);
utilWindowClass.lpszClassName := CDSiHiddenWindowName;
utilWindowClass.hInstance := HInstance;
utilWindowClass.lpfnWndProc := #DSiClassWndProc;
utilWindowClass.cbWndExtra := SizeOf(TMethod);
if {$IFDEF ScopedUnitNames}Winapi.{$ENDIF}Windows.RegisterClass(utilWindowClass) = 0 then
raise Exception.CreateFmt('Unable to register DSiWin32 hidden window class. %s',
[SysErrorMessage(GetLastError)]);
end;
Result := CreateWindowEx(WS_EX_TOOLWINDOW, CDSiHiddenWindowName, '', WS_POPUP,
0, 0, 0, 0, 0, 0, HInstance, nil);
if Result = 0 then
raise Exception.CreateFmt('Unable to create DSiWin32 hidden window. %s',
[SysErrorMessage(GetLastError)]);
{$IFDEF CPUX64}
SetWindowLongPtr(Result, GWL_METHODDATA, NativeInt(TMethod(wndProcMethod).Data));
SetWindowLongPtr(Result, GWL_METHODCODE, NativeInt(TMethod(wndProcMethod).Code));
{$ELSE}
SetWindowLong(Result, GWL_METHODDATA, cardinal(TMethod(wndProcMethod).Data));
SetWindowLong(Result, GWL_METHODCODE, cardinal(TMethod(wndProcMethod).Code));
{$ENDIF ~CPUX64}
Inc(GDSiWndHandlerCount);
finally LeaveCriticalSection(GDSiWndHandlerCritSect); end;
end; { DSiAllocateHWnd }
//Thread-safe DeallocateHwnd.
// #author gabr [based on http://fidoforum.ru/pages/new46s35o217746.ru.delphi and
// TIcsWndHandler.AllocateHWnd from ICS v6 (http://www.overbyte.be)]
// #since 2007-05-30
procedure DSiDeallocateHWnd(wnd: HWND);
begin
if wnd = 0 then
Exit;
DestroyWindow(wnd);
EnterCriticalSection(GDSiWndHandlerCritSect);
try
Dec(GDSiWndHandlerCount);
if GDSiWndHandlerCount <= 0 then
{$IFDEF ScopedUnitNames}Winapi.{$ENDIF}Windows.UnregisterClass(CDSiHiddenWindowName, HInstance);
finally LeaveCriticalSection(GDSiWndHandlerCritSect); end;
end; { DSiDeallocateHWnd }
procedure PatchCode(Address: Pointer; const NewCode; Size: Integer);
var
OldProtect: DWORD;
begin
if VirtualProtect(Address, Size, PAGE_EXECUTE_READWRITE, OldProtect) then begin
Move(NewCode, Address^, Size);
FlushInstructionCache(GetCurrentProcess, Address, Size);
VirtualProtect(Address, Size, OldProtect, #OldProtect);
end;
end;
type
PInstruction = ^TInstruction;
TInstruction = packed record
Opcode: Byte;
Offset: Integer;
end;
procedure RedirectProcedure(OldAddress, NewAddress: Pointer);
var
NewCode: TInstruction;
begin
NewCode.Opcode := $E9;//jump relative
NewCode.Offset := NativeInt(NewAddress)-NativeInt(OldAddress)-SizeOf(NewCode);
PatchCode(OldAddress, NewCode, SizeOf(NewCode));
end;
initialization
InitializeCriticalSection(GDSiWndHandlerCritSect);
RedirectProcedure(#AllocateHWnd, #DSiAllocateHWnd);
RedirectProcedure(#DeallocateHWnd, #DSiDeallocateHWnd);
finalization
DeleteCriticalSection(GDSiWndHandlerCritSect);
end.
This unit must be included very early in the .dpr file's list of units. Clearly it cannot appear before any custom memory manager, but it should appear immediately after that. The reason being that the replacement routines must be installed before any calls to AllocateHwnd are made.
Update I have merged in the very latest version of Primož's code which he kindly sent to me.
Don't use TTimer in a thread, it will never be safe. Have the thread either:
1) use SetTimer() with a manual message loop. You don't need an HWND if you use a callback function, but you do still have to dispatch messages.
2) use CreateWaitableTimer() and then call WaitForSingleObject() in a loop until the timer is signalled.
3) use timeSetEvent(), which is a multi-threaded timer. Just be careful because its callback is called in its own thread so make sure your callback function is thread-safe, and there are restrictions to what you are allowed to call inside that thread. Best to have it set a signal that your real thread waits on an then does its work outside of the timer.
Since you have already written code that operates in a dedicated thread, I would assume you don't expect any code to run while this code waits for something. In that case you could just call Sleep either with a specific number of milliseconds, or with a small amount of milliseconds and use this in a loop to check Now or GetTickCount to see if a certain time has elapsed. Using Sleep will also keep CPU-usage down, since the operating system is signaled that you don't require the thread to keep running for that time.

Resources