I want to wait for a WebBrowser control to finish navigation. So i create an Event, and then i want to wait for it to be set:
procedure TContoso.NavigateToEmpty(WebBrowser: IWebBrowser2);
begin
FEvent.ResetEvent;
WebBrowser.Navigate2('about:blank'); //Event is signalled in the DocumentComplete event
Self.WaitFor;
end;
And then i set the event in the DocumentComplete event:
procedure TContoso.DocumentComplete(ASender: TObject; const pDisp: IDispatch; const URL: OleVariant);
var
doc: IHTMLDocument2;
begin
if (pDisp <> FWebBrowser.DefaultInterface) then
begin
//This DocumentComplete event is for another frame
Exit;
end;
//Set the event that it's complete
FEvent.SetEvent;
end;
The problem comes in how to wait for this event to happen.
WaitFor it
First reaction would be to wait for the event to become triggered:
procedure TContoso.WaitFor;
begin
FEvent.WaitFor;
end;
The problem with that is that the DocumentComplete event can never fire, because the application never goes idle enough to allow the COM event to get through.
Busy Sleep Wait
My first reaction was to do a busy sleep, waiting for a flag:
procedure TContoso.NavigateToEmpty(WebBrowser: IWebBrowser2);
begin
FIsDocumentComplete := False;
WebBrowser.Navigate2('about:blank'); //Flag is set in the DocumentComplete event
Self.WaitFor;
end;
procedure TContoso.WaitFor;
var
n: Iterations;
const
MaxIterations = 25; //100ms each * 10 * 5 = 5 seconds
begin
while n < MaxIterations do
begin
if FIsDocumentComplete then
Exit;
Inc(n);
Sleep(100); //100ms
end;
end;
The problem with a Sleep, is that it doesn't allow the application to do idle enough to allow the COM event messages to get through.
Use CoWaitForMultipleHandles
After research, it seems that COM folks created a function created exactly for this situation:
While a thread in a Single-Threaded Apartment (STA) blocks, we will pump certain messages for you. Message pumping during blocking is one of the black arts at Microsoft. Pumping too much can cause reentrancy that invalidates assumptions made by your application. Pumping too little causes deadlocks. Starting with Windows 2000, OLE32 exposes CoWaitForMultipleHandles so that you can pump “just the right amount.”
So i tried that:
procedure TContoso.WaitFor;
var
hr: HRESULT;
dwIndex: DWORD;
begin
hr := CoWaitForMultipleHandles(0, 5000, 1, #FEvent.Handle, {out}dwIndex);
OleCheck(hr);
end;
The problem is that just doesn't work; it doesn't allow the COM event to appear.
Use UseCOMWait wait
i could also try Delphi's own mostly secret feature of TEvent: UseCOMWait
Set UseCOMWait to True to ensure that when a thread is blocked and waiting for the object, any STA COM calls can be made back into this thread.
Excellent! Lets use that:
FEvent := TEvent.Create(True);
function TContoso.WaitFor: Boolean;
begin
FEvent.WaitFor;
end;
Except that doesn't work; because the callback event never gets fired.
MsgWaitForMultipleBugs
So now i start to delve into the awful, awful, awful, awful, buggy, error-prone, re-entrancy inducing, sloppy, requires a mouse nudge, sometimes crashes world of MsgWaitForMultipleObjects:
function TContoso.WaitFor: Boolean;
var
// hr: HRESULT;
// dwIndex: DWORD;
// msg: TMsg;
dwRes: DWORD;
begin
// hr := CoWaitForMultipleHandles(0, 5000, 1, #FEvent.Handle, {out}dwIndex);
// OleCheck(hr);
// Result := (hr = S_OK);
Result := False;
while (True) do
begin
dwRes := MsgWaitForMultipleObjects(1, #FEvent.Handle, False, 5000, QS_SENDMESSAGE);
if (dwRes = WAIT_OBJECT_0) then
begin
//Our event signalled
Result := True;
Exit;
end
else if (dwRes = WAIT_TIMEOUT) then
begin
//We waited our five seconds; give up
Exit;
end
else if (dwRes = WAIT_ABANDONED_0) then
begin
//Our event object was destroyed; something's wrong
Exit;
end
else if (dwRes = (WAIT_OBJECT_0+1)) then
begin
GetMessage(msg, 0, 0, 0);
if msg.message = WM_QUIT then
begin
{
http://blogs.msdn.com/oldnewthing/archive/2005/02/22/378018.aspx
PeekMessage will always return WM_QUIT. If we get it, we need to
cancel what we're doing and "re-throw" the quit message.
The other important thing about modality is that a WM_QUIT message
always breaks the modal loop. Remember this in your own modal loops!
If ever you call the PeekMessage function or The GetMessage
function and get a WM_QUIT message, you must not only exit your
modal loop, but you must also re-generate the WM_QUIT message
(via the PostQuitMessage message) so the next outer layer will
see the WM_QUIT message and do its cleanup as well. If you fail
to propagate the message, the next outer layer will not know that
it needs to quit, and the program will seem to "get stuck" in its
shutdown code, forcing the user to terminate the process the hard way.
}
PostQuitMessage(msg.wParam);
Exit;
end;
TranslateMessage(msg);
DispatchMessage(msg);
end;
end;
The above code is wrong because:
i don't know what kind of message to wake up for (are com events sent?)
i don't know i don't want to call GetMessage, because that gets messages; i only want to get the COM message (see point one)
i might should be using PeekMessage (see point 2)
i don't know if i have to call GetMessage in a loop until it returns false (see Old New Thing)
I've been programming long enough to run away, far away, if i'm going to pump my own messages.
The questions
So i have four questions. All related. This post is one of the four:
How to make WebBrower.Navigate2 synchronous?
How to pump COM messages?
Does pumping COM messages cause COM events to callback?
How to use CoWaitForMultipleHandles
I am writing in, and using Delphi. But obviously any native code would work (C, C++, Assembly, Machine code).
See also
MSDN Blog: Managed Blocking - Chris Brumme
CoWaitForMultipleHandles API doesn't behave as documented
Visual Studio Forums: How to use "CoWaitForMultipleHandles" ?
MSDN: CoWaitForMultipleHandles function
MSDN Blog: Apartments and Pumping in the CLR - Chris Brumme
Which blocking operations cause an STA thread to pump COM messages?
The short and long of it is that you have to pump ALL messages normally, you can't just single out COM messages by themselves (and besides, there is no documented messages that you can peek/pump by themselves, they are known only to COM's internals).
How to make WebBrower.Navigate2 synchronous?
You can't. But you don't have to wait for the OnDocumentComplete event, either. You can busy-loop inside of NavigateToEmpty() itself until the WebBrowser's ReadyState property is READYSTATE_COMPLETE, pumping the message queue when messages are waiting to be processed:
procedure TContoso.NavigateToEmpty(WebBrowser: IWebBrowser2);
begin
WebBrowser.Navigate2('about:blank');
while (WebBrowser.ReadyState <> READYSTATE_COMPLETE) and (not Application.Terminated) do
begin
// if MsgWaitForMultipleObjects(0, Pointer(nil)^, False, 5000, QS_ALLINPUT) = WAIT_OBJECT_0 then
// if GetQueueStatus(QS_ALLINPUT) <> 0 then
Application.ProcessMessages;
end;
end;
How to pump COM messages?
You can't, not by themselves anyway. Pump everything, and be prepared to handle any reentry issues that result from that.
Does pumping COM messages cause COM events to callback?
Yes.
How to use CoWaitForMultipleHandles
Try something like this:
procedure TContoso.NavigateToEmpty(WebBrowser: IWebBrowser2);
var
hEvent: THandle;
dwIndex: DWORD;
hr: HRESULT;
begin
// when UseCOMWait() is true, TEvent.WaitFor() does not wait for, or
// notify, when messages are pending in the queue, so use
// CoWaitForMultipleHandles() directly instead. But you have to still
// use a waitable object, just don't signal it...
hEvent := CreateEvent(nil, True, False, nil);
if hEvent = 0 then RaiseLastOSError;
try
WebBrowser.Navigate2('about:blank');
while (WebBrowser.ReadyState <> READYSTATE_COMPLETE) and (not Application.Terminated) do
begin
hr := CoWaitForMultipleHandles(COWAIT_INPUTAVAILABLE, 5000, 1, hEvent, dwIndex);
case hr of
S_OK: Application.ProcessMessages;
RPC_S_CALLPENDING, RPC_E_TIMEOUT: begin end;
else
RaiseLastOSError(hr);
end;
end;
finally
CloseHandle(hEvent);
end;
end;
Related
Somewhere in my application (along with 3rd party libraries of code) is a window procedure that is preventing Windows from:
logging off
shutting down
restarting
I found one spot in my code where I made the extraordinarily common mistake of calling DefWindowProc, but calling it incorrectly:
Before:
void Grobber.BroadcastListenerWindowProc(ref TMessage msg)
{
DefWindowProc(_broadcastListenerHwnd, msg.msg, msg.wparam, msg.lparam);
}
After:
void Grobber.BroadcastListenerWindowProc(ref TMessage msg)
{
//20170207: Forgetting to set the result can, for example, prevent Windows from restarting
msg.Result = DefWindowProc(_broadcastListenerHwnd, msg.msg, msg.wparam, msg.lparam);
}
I fixed that bug, and my test program no longer halted the shutdown.
But a full application does
I'm now faced with having to tear a program down to nothing, until my computer finally reboots.
Somewhere deep inside my application is a Window procedure attached to an HWND that is returning zero to WM_QUERYENDSESSION. If only i knew the HWND, i could use the Spy++ to find the Window.
But how can i find that hwnd?
The Windows Application event log notes the process that halt a shutdown:
And there very well be a more detailed log in the more detailed Applications and Services Logs. But those are undocumented.
How can i find my problematic hwnd?
Attempts
I tried to use EnumThreadWindows to get all the windows of my "main" thread, with the idea of manually sending WM_QUERYENDSESSION to them all to see who returns false:
var
wnds: TList<HWND>;
function DoFindWindow(Window: HWnd; Param: LPARAM): Bool; stdcall;
var
wnds: TList<HWND>;
begin
wnds := TList<HWND>(Param);
wnds.Add(Window);
Result := True;
end;
wnds := TList<HWND>.Create;
enumProc := #DoFindWindow;
EnumThreadWindows(GetCurrentThreadId, EnumProc, LPARAM(wnds));
Now i have a list of twelve hwnds. Poke them:
var
window: HWND;
res: LRESULT;
for window in wnds do
begin
res := SendMessage(window, WM_QUERYENDSESSION, 0, 0);
if res = 0 then
begin
ShowMessage('Window: '+IntToHex(window, 8)+' returned false to WM_QUERYENDSESSION');
end;
end;
But nobody did return zero.
So that's one tube down the drain.
EnumThreadWindows only enumerates the windows of one particular thread. It could be that the offending window was created in a thread. So I'd suggest that you use EnumWindows to enum all top level windows in your application for your test.
It's enough to initialize COM in a thread and you'll have a window you don't know about. That way a call to WaitForSingleObject in a thread could be your culprit:
Debugging an application that would not behave with WM_QUERYENDSESSION
This might sound a bit like overkill but here goes. I would solve this using code hooks for AllocateHWnd and DeallocateHWnd. We had to solve a different issue related to handles and it worked well for us.
Your replacement routines will just be copies of the versions in System.Classes. You will also need to copy all of the dependencies (PObjectInstance, TObjectInstance, CodeBytes, PInstanceBlock, TInstanceBlock, InstBlockList, InstFreeList, StdWndProc, CalcJmpOffset, MakeObjectInstance, FreeObjectInstance, CleanupInstFreeList, GetFreeInstBlockItemCount, ReleaseObjectInstanceBlocks, UtilWindowClass) from that unit. The only difference is that you log all allocated and deallocated handles in your replacement routines. It would help to include stack traces too.
That will give you a list of all of the handles that are allocated at the time of your shutdown along with their calling stack traces.
The basic structure is something like this. I can't post full code because it's mostly VCL code with the exception of the code hooks and logging.
const
{$IF Defined(CPUX86)}
CodeBytes = 2;
{$ELSEIF Defined(CPUX64)}
CodeBytes = 8;
{$ENDIF CPU}
InstanceCount = (4096 - SizeOf(Pointer) * 2 - CodeBytes) div SizeOf(TObjectInstance) - 1;
type
PInstanceBlock = ^TInstanceBlock;
TInstanceBlock = packed record
...
end;
var
InstBlockList: PInstanceBlock;
InstFreeList: PObjectInstance;
{ Standard window procedure }
function StdWndProc(Window: HWND; Message: UINT; WParam: WPARAM; LParam: WPARAM): LRESULT; stdcall;
...
function CalcJmpOffset(Src, Dest: Pointer): Longint;
...
function MakeObjectInstance(const AMethod: TWndMethod): Pointer;
...
procedure FreeObjectInstance(ObjectInstance: Pointer);
...
procedure CleanupInstFreeList(BlockStart, BlockEnd: PByte);
...
function GetFreeInstBlockItemCount(Item: PObjectInstance; Block: PInstanceBlock): Integer;
...
procedure ReleaseObjectInstanceBlocks;
...
var
UtilWindowClass: TWndClass = (
... );
function AllocateHWnd(const AMethod: TWndMethod): HWND;
begin
< Logging/Stack trace code here >
...
end;
procedure DeallocateHWnd(Wnd: HWND);
begin
< Logging/Stack trace code here >
...
end;
It may also be necessary to hook and log SetWindowLong, SetWindowLongA and SetWindowLongW too.
I've build a datasnap server application for handling data between a windows application and mobile apps.
One method can take a while, and I want to be able to stop it after a certain time(Timeout).
How can I achieve this?
The code below shows one way to provide a server method with timeout behaviour.
The task which may take too long is executed in a secondary thread which is
started in the server method. This method uses a TSimpleEvent object (see the online help) to enable the
secondary thread to signal back to the server method's thread that it has completed. The value (in milliseconds) you specify in the call to Event.WaitFor defines how long to wait before the call times out.
If the call to WaitFor on the SimpleEvent times out, you can take whatever action you
like to notify the server's client. If the call to WaitFor returns wsSignaled, that means that the DBThread must have called SetEvent on the Event object before the period specified when calling WaitFor expired.
Btw, this example was written for D7, so might require minor adaptation for
Seattle. Also it uses a TForm descendant as the "server", but should work equally well in a DataSnap server method, since the principle is the same.
It doesn't address the issue of how exactly to stop whatever task you kick off in the secondary thread, because whether that is possible and how to do it if it is depends on exactly what the task is. Because of that, and the fact that you probably wouldn't want to delay the server method by waiting for the DBThread to complete, it does not attempt to free the DBThread, though in the real world that should of course be done.
type
TServer = class;
TDBThread = class(TThread)
private
FServer: TServer;
FEvent: TSimpleEvent;
FCancelled : Boolean;
function GetCancelled: Boolean;
procedure SetCancelled(const Value: Boolean);
public
procedure Execute; override;
constructor Create(AServer : TServer);
property Server : TServer read FServer;
property Event : TSimpleEvent read FEvent;
property Cancelled : Boolean read GetCancelled write SetCancelled;
end;
TServer = class(TForm)
// ignore the fact that in this case, TServer is a descendant of TForm
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
protected
CS : TCriticalSection;
Event : TSimpleEvent;
public
procedure DoServerMethod;
end;
[...]
{ TDBThread }
constructor TDBThread.Create(AServer: TServer);
begin
inherited Create(True); // create suspended
FreeOnTerminate := False;
FServer := AServer;
FEvent := FServer.Event;
end;
procedure TDBThread.Execute;
var
StartTime : Cardinal;
begin
Cancelled := False;
// Following is for illustration ONLY, to simulate a process which takes time.
// Do not call Sleep() in a loop in a real thread
StartTime := GetTickCount;
repeat
Sleep(100);
until GetTickCount - StartTime > 5000;
if not Cancelled then begin
{ TODO : Transfer result back to server thread }
Event.SetEvent;
end;
end;
function TDBThread.GetCancelled: Boolean;
begin
FServer.CS.Enter;
try
Result := FCancelled;
finally
FServer.CS.Leave;
end;
end;
procedure TDBThread.SetCancelled(const Value: Boolean);
begin
FServer.CS.Enter;
try
FCancelled := Value;
finally
FServer.CS.Leave;
end;
end;
procedure TServer.DoServerMethod;
var
DBThread : TDBThread;
WaitResult : TWaitResult;
begin
DBThread := TDBThread.Create(Self);
DBThread.Resume;
WaitResult := Event.WaitFor(1000);
case WaitResult of
wrSignaled : begin
// the DBThread completed
ShowMessage('DBThread completed');
end;
wrTimeOut : begin
// the DBThread time out
DBThread.Cancelled := True;
ShowMessage('DBThread timed out');
// Maybe use PostThreadMessage here to tell the DBThread to abort (if possible)
// whatever task it is doing that has taken too long.
end;
end; {case}
{ TODO : Terminate and dispose of the DBThread }
end;
procedure TServer.FormCreate(Sender: TObject);
begin
CS := TCriticalSection.Create;
Event := TSimpleEvent.Create;
end;
procedure TServer.Button1Click(Sender: TObject);
begin
DoServerMethod;
end;
I have a room with 60 computers/devices (40 computers and 20 oscilloscopes Windows CE based) and I would like to know which and every one is alive using ping. First I wrote a standard ping (see here Delphi Indy Ping Error 10040), which is working fine now but takes ages when most computers are offline.
So what I am trying to do is to write a MultiThread Ping but I am quite struggling with it. I have seen only very few examples over the internet and no one was matching my needs, that's why I try to write it myself.
I use XE2 and Indy 10 and the form is only constitued of a memo and a button.
unit Main;
interface
uses
Winapi.Windows, System.SysUtils, System.Classes, Vcl.Forms,
IdIcmpClient, IdGlobal, Vcl.StdCtrls, Vcl.Controls;
type
TMainForm = class(TForm)
Memo1: TMemo;
ButtonStartPing: TButton;
procedure ButtonStartPingClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
type
TMyPingThread = class(TThread)
private
fIndex : integer;
fIdIcmpClient: TIdIcmpClient;
procedure doOnPingReply;
protected
procedure Execute; override;
public
constructor Create(index: integer);
end;
var
MainForm: TMainForm;
ThreadCOunt : integer;
implementation
{$R *.dfm}
constructor TMyPingThread.Create(index: integer);
begin
inherited Create(false);
fIndex := index;
fIdIcmpClient := TIdIcmpClient.Create(nil);
fIdIcmpClient.ReceiveTimeout := 200;
fIdIcmpClient.PacketSize := 24;
fIdIcmpClient.Protocol := 1;
fIdIcmpClient.IPVersion := Id_IPv4;
//first computer is at adresse 211
fIdIcmpClient.Host := '128.178.26.'+inttostr(211+index-1);
self.FreeOnTerminate := true;
end;
procedure TMyPingThread.doOnPingReply;
begin
MainForm.Memo1.lines.add(inttostr(findex)+' '+fIdIcmpClient.ReplyStatus.Msg);
dec(ThreadCount);
if ThreadCount = 0 then
MainForm.Memo1.lines.add('--- End ---');
end;
procedure TMyPingThread.Execute;
begin
inherited;
try
fIdIcmpClient.Ping('',findex);
except
end;
while not Terminated do
begin
if fIdIcmpClient.ReplyStatus.SequenceId = findex then Terminate;
end;
Synchronize(doOnPingReply);
fIdIcmpClient.Free;
end;
procedure TMainForm.ButtonStartPingClick(Sender: TObject);
var
i: integer;
myPing : TMyPingThread;
begin
Memo1.Lines.Clear;
ThreadCount := 0;
for i := 1 to 40 do
begin
inc(ThreadCount);
myPing := TMyPingThread.Create(i);
//sleep(10);
end;
end;
end.
My problem is that it "seems" to work when I uncomment the "sleep(10)", and "seems" not to be working without it. This for sure means I am missing a point in the threading I have written.
In other words. When Sleep(10) is in the code. Every time I clicked the button to get to check the connections the result was correct.
Without the sleep(10), it is working "most" of the time but some times the result is wrong giving me a ping echo on offline computers and no ping echo on online computer, as is the ping reply was not assigned to the correct thread.
Any comment or help is welcome.
----- EDIT / IMPORTANT -----
As a general follow up of this question, #Darian Miller started a Google Code project here https://code.google.com/p/delphi-stackoverflow/ which is a working basis. I mark his answer as the "accepted answer" but users should refer to this open source project (all the credit belongs to him) as it will surely be extended and updated in the future.
The root problem is that pings are connectionless traffic. If you have multiple TIdIcmpClient objects pinging the network at the same time, one TIdIcmpClient instance can receive a reply that actually belongs to another TIdIcmpClient instance. You are trying to account for that in your thread loop, by checking SequenceId values, but you are not taking into account that TIdIcmpClient already does that same check internally. It reads network replies in a loop until it receives the reply it is expecting, or until the ReceiveTimeout occurs. If it receives a reply it is not expecting, it simply discards that reply. So, if one TIdIcmpClient instance discards a reply that another TIdIcmpClient instance was expecting, that reply will not get processed by your code, and that other TIdIcmpClient will likely receive another TIdIcmpClient's reply instead, and so on. By adding the Sleep(), you are decreasing (but not eliminating) the chances that pings will overlap each other.
For what you are attempting to do, you won't be able to use TIdIcmpClient as-is to have multiple pings running in parallel, sorry. It is simply not designed for that. There is no way for it to differentiate reply data the way you need it. You will have to serialize your threads so only one thread can call TIdIcmpClient.Ping() at a time.
If serializing the pings is not an option for you, you can try copying portions of TIdIcmpClient's source code into your own code. Have 41 threads running - 40 device threads and 1 response thread. Create a single socket that all of the threads share. Have each device thread prepare and send its individual ping request to the network using that socket. Then have the response thread continuously reading replies from that same socket and routing them back to the appropriate device thread for processing. This is a bit more work, but it will give you the multiple-ping parallelism you are looking for.
If you don't want to go to all that trouble, an alternative is to just use a third-party app that already supports pinging multiple machines at the same time, like FREEPing.
Remy explained the problems... I've wanted to do this in Indy for a while so I posted a possible solution that I just put together to a new Google Code project instead of having a long comment here. It's a first-stab sort of thing, let me know if you have some changes to integrate:
https://code.google.com/p/delphi-vault/
This code has two ways to Ping...multi-threaded clients as in your example, or with a simple callback procedure. Written for Indy10 and later versions of Delphi.
Your code would end up using a TThreadedPing descendant defining a SynchronizedResponse method:
TMyPingThread = class(TThreadedPing)
protected
procedure SynchronizedResponse(const ReplyStatus:TReplyStatus); override;
end;
And to fire off some client threads, the code becomes something like:
procedure TfrmThreadedPingSample.butStartPingClick(Sender: TObject);
begin
TMyPingThread.Create('www.google.com');
TMyPingThread.Create('127.0.0.1');
TMyPingThread.Create('www.shouldnotresolvetoanythingatall.com');
TMyPingThread.Create('127.0.0.1');
TMyPingThread.Create('www.microsoft.com');
TMyPingThread.Create('127.0.0.1');
end;
The threaded response is called in a synchronized method:
procedure TMyPingThread.SynchronizedResponse(const ReplyStatus:TReplyStatus);
begin
frmThreadedPingSample.Memo1.Lines.Add(TPingClient.FormatStandardResponse(ReplyStatus));
end;
I did not try your code, so that is all hypothetical, but i think you messed the threads and got classic race condition. I restate my advice to use AsyncCalls or OmniThreadLibrary - they are much simpler and would save you few attempts at "shooting your own foot".
Threads are made to minimize main-thread load. Thread constructor should do minimal work of remembering parameters. Personally i'd moved idICMP creation into .Execute method. If for any reason it would want to create its internal synchronization objects, like window and message queue or signal or whatever, i'd like it to happen already in a new spawned thread.
There is no sense for "inherited;" in .Execute. Better remove it.
Silencing all exceptions is bad style. You probably have errors - but have no way to know about them. You should propagate them to main thread and display them. OTL and AC help you in that, while for tThread you have to do it manually. How to Handle Exceptions thrown in AsyncCalls function without calling .Sync?
Exception logic is flawed. There is no point to have a loop if exception thrown - if no succesful Ping was set - then why waiting for response ? You loop should go within same try-except frame as issuing ping.
Your doOnPingReply executes AFTER fIdIcmpClient.Free yet accesses fIdIcmpClient's internals. Tried changing .Free for FreeAndNil ?
That is a classic mistake of using dead pointer after freeing it.
The correct approach would be to:
5.1. either free the object in doOnPingReply
5.2. or copy all relevant data from doOnPingReply to TThread's private member vars before calling both Synchronize and idICMP.Free (and only use those vars in doOnPingReply )
5.3. only do fIdIcmpClient.Free inside TMyThread.BeforeDestruction or TMyThread.Destroy. Afterall, if you chosen to create the object in constructor - then you should free it in the matching language construct - destructor.
Since you do not keep references to the thread objects - that While not Terminated loop seems redundant. Just make usual forever-loop and call break.
The aforementioned loop is CPU-hungry, it is like spin-loop. Please call Sleep(0); or Yield(); inside loop to give other threads better chance to do their work. Don't work agaisnt OS scheduler here - you are not in a speed-critical path, no reason to make spinlock here.
Overall, i consider:
4 and 5 as critical bugs for you
1 and 3 as a potential gotcha maybe influencing or maybe not. You'd better 'play safe' rather than doing risky things and investigating if they would work or not.
2 and 7 - bad style, 2 regarding language and 7 regarding platform
6 either you have plans to extend your app, or you broke YAGNI principle, dunno.
Sticking with complex TThread instead of OTL or AsyncCalls - strategic errors. Don't you put rooks on your runway, use simple tools.
Funny, this is example of the bug that FreeAndNil could expose and make obvious, while FreeAndNil-haters are claiming it "conceals" bugs.
// This is my communication unit witch works well, no need to know its work but your
// ask is in the TPingThread class.
UNIT UComm;
INTERFACE
USES
Windows, Messages, SysUtils, Classes, Graphics, Controls, ExtCtrls, Forms, Dialogs,
StdCtrls,IdIcmpClient, ComCtrls, DB, abcwav, SyncObjs, IdStack, IdException,
IdTCPServer, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdContext,
UDM, UCommon;
TYPE
TNetworkState = (nsNone, nsLAN, nsNoLAN, nsNet, nsNoNet);
TDialerStatus = (dsNone, dsConnected, dsDisconnected, dsNotSync);
{ TBaseThread }
TBaseThread = Class(TThread)
Private
FEvent : THandle;
FEventOwned : Boolean;
Procedure ThreadTerminate(Sender: TObject); Virtual;
Public
Constructor Create(AEventName: String);
Property EventOwned: Boolean Read FEventOwned;
End;
.
.
.
{ TPingThread }
TPingThread = Class(TBaseThread)
Private
FReply : Boolean;
FTimeOut : Integer;
FcmpClient : TIdIcmpClient;
Procedure ReplyEvent(Sender: TComponent; Const AReplyStatus: TReplyStatus);
Protected
Procedure Execute; Override;
Procedure ThreadTerminate(Sender: TObject); Override;
Public
Constructor Create(AHostIP, AEventName: String; ATimeOut: Integer);
Property Reply: Boolean Read FReply;
End;
.
.
.
{ =============================================================================== }
IMPLEMENTATION
{$R *.dfm}
USES
TypInfo, WinSock, IdGlobal, UCounter, UGlobalInstance, URemoteDesktop;
{IdGlobal: For RawToBytes function 10/07/2013 04:18 }
{ TBaseThread }
//---------------------------------------------------------
Constructor TBaseThread.Create(AEventName: String);
Begin
SetLastError(NO_ERROR);
FEvent := CreateEvent(Nil, False, False, PChar(AEventName));
If GetLastError = ERROR_ALREADY_EXISTS
Then Begin
CloseHandle(FEvent);
FEventOwned := False;
End
Else If FEvent <> 0 Then
Begin
FEventOwned := True;
Inherited Create(True);
FreeOnTerminate := True;
OnTerminate := ThreadTerminate;
End;
End;
//---------------------------------------------------------
Procedure TBaseThread.ThreadTerminate(Sender: TObject);
Begin
CloseHandle(FEvent);
End;
{ TLANThread }
.
.
.
{ TPingThread }
//---------------------------------------------------------
Constructor TPingThread.Create(AHostIP: String; AEventName: String; ATimeOut: Integer);
Begin
Inherited Create(AEventName);
If Not EventOwned Then Exit;
FTimeOut := ATimeOut;
FcmpClient := TIdIcmpClient.Create(Nil);
With FcmpClient Do
Begin
Host := AHostIP;
ReceiveTimeOut := ATimeOut;
OnReply := ReplyEvent;
End;
End;
//---------------------------------------------------------
Procedure TPingThread.Execute;
Begin
Try
FcmpClient.Ping;
FReply := FReply And (WaitForSingleObject(FEvent, FTimeOut) = WAIT_OBJECT_0);
Except
FReply := False;
End;
End;
//---------------------------------------------------------
Procedure TPingThread.ReplyEvent(Sender: TComponent; Const AReplyStatus: TReplyStatus);
Begin
With AReplyStatus Do
FReply := (ReplyStatusType = rsEcho) And (BytesReceived <> 0);
SetEvent(FEvent);
End;
//---------------------------------------------------------
Procedure TPingThread.ThreadTerminate(Sender: TObject);
Begin
FreeAndNil(FcmpClient);
Inherited;
End;
{ TNetThread }
.
.
.
I have implemented a windows xp service application that starts a couple of working threads.
From one of the threads i need to send custom messages back to the service.
How do i do that?
One option is to use OmniThreadLibrary (read this blog post for an example).
Thanks for your help. Here is how I solved the problem:
In the Service class definition:
WHandle: HWND;
protected
procedure HandleServiceMessage(var Msg: TMessage); virtual;
In the ServiceExecute method:
WHandle := AllocateHWnd(HandleServiceMessage);
MyThread := TMyThread.Create(true);
MyThread.HndMain := WHandle;
MyThread.Resume;
while not Terminated do ServiceThread.ProcessRequests(True);
DeallocateHWnd(WHandle);
end;
In ServiceStop method:
MyThread.Terminate;
And the method for handling messages:
procedure TMessageService.HandleServiceMessage(var Msg : TMessage);
var
Handled: Boolean;
begin
Handled := True;
if Msg.Msg = WM_MYMESSAGE then
Beep
else
Handled := False;
if Handled then
Msg.Result := 0
else
Msg.Result := DefWindowProc(WHandle, Msg.Msg, Msg.WParam, Msg.LParam);
end;
In MyThread.Execute method:
PostMessage(HndMain,WM_MYMESSAGE,0,0);
Its working just fine.
I agree with TOndrej that shared objects should be sufficient.
On the other hand you can use my IPC (Cromis IPC) which works just fine inside services. It is easy to use, message oriented, so you don't need to know how named pipes work and very fast. The server part also uses a thread pool, so there is no waiting for something to be processed. You can use the fire and forget scenario.
Or if you think a little redesign is ok, you can try OmniThreadLibrary which has all the messaging already build in and is made for tasks like this.
EDIT:
Ok probably the cleanest way to go, without any redesing is to have a common object list which is protected by a critical section. The working thread is adding objects that need to be processed in the list. When and object is added the working thread signals an event. Then you have an object processing thread which is waiting with WaitForSingleObject for this event. As soon as something is added to the list the event is signaled and the processing thread just processes all the objects it finds in the list. Then it waits again. All you need to do is to protect the access to the common list.
Simplified the code would look like this:
WORKER THREAD
ObjectList.Add(MessageObject);
SetEvent(FEvent);
PROCESSING THREAD
while not Terminated do
begin
WaitForSingleObjest(FEvent, INFINITE);
// process all the objects
end;
Creating message-only window:
procedure TMyService.MessageQueueDispatch(var Message: TMessage);
begin
Dispatch(Message); //Delphi default dispatcher for TMyService
end;
procedure TMyService.SomeKindOfOnCreate;
begin
MessageQueue := AllocateHWnd(MessageQueueDispatch);
end;
Destroying:
procedure TMyService.SomeKindOfDestroy;
begin
CloseHandle(MessageQueue);
end;
Now you can handle messages like you would do with form messages:
TMyService = class(TService)
...
protected
procedure HandleMyMessage(var msg: TMsg); message WM_MY_MESSAGE;
end;
Delphi Dispatch() handler will take care of calling the function.
I'm testing the existence of a file in a remote share (on a Windows server). The underlying function used for testing is WinAPI's GetFileAttributes, and what happens is that function can take an inordinate amount of time (dozens of seconds) in various situations, like when the target server being offline, when there are rights or DNS issues, etc.
However, in my particular case, it's always a LAN access, so if the file can't be accessed in less than 1 second, then it typically won't be accessible by waiting dozens of seconds more...
Is there an alternative to GetFileAttributes that wouldn't stall? (apart from calling it in a thread and killing the thread after a timeout, which seems to bring its own bag of issues)
The problem isn't GetFileAttributes really. It typically uses just one call to the underlying file system driver. It's that IO which is stalling.
Still, the solution is probably easy. Call CancelSynchronousIo() after one second (this obviously requires a second thread as your first is stuck inside GetFileAttributes).
One cool thing about delegates is you can always BeginInvoke and EndInvoke them. Just make sure the called method doesn't throw an exception out since [I believe] it will cause a crash (unhandled exception).
AttributeType attributes = default(AttributeType);
Action<string> helper =
(path) =>
{
try
{
// GetFileAttributes
attributes = result;
}
catch
{
}
};
IAsyncResult asyncResult = helper.BeginInvoke();
// whatever
helper.EndInvoke();
// at this point, the attributes local variable has a valid value.
I think your best solution is to use a thread-pool thread to perform the work.
assign a unit of work to query the attributes of a file
let GetFileAttributes run to completion
post the results back to your form
when your thread function completes, the thread automatically returns back to the pool (no need to kill it)
By using the thread pool you save the costs of creating new threads.
And you save the misery of trying to get rid of them.
Then you have your handy helper method that runs an object's method procedure on a thread-pool thread using QueueUserWorkItem:
RunInThreadPoolThread(
GetFileAttributesThreadMethod,
TGetFileAttributesData.Create('D:\temp\foo.xml', Self.Handle),
WT_EXECUTEDEFAULT);
You create the object to hold the thread data information:
TGetFileAttributesData = class(TObject)
public
Filename: string;
WndParent: HWND;
Attributes: DWORD;
constructor Create(Filename: string; WndParent: HWND);
end;
and you create your thread callback method:
procedure TForm1.GetFileAttributesThreadMethod(Data: Pointer);
var
fi: TGetFileAttributesData;
begin
fi := TObject(Data) as TGetFileAttributesData;
if fi = nil then
Exit;
fi.attributes := GetFileAttributes(PWideChar(fi.Filename));
PostMessage(fi.WndParent, WM_GetFileAttributesComplete, NativeUInt(Data), 0);
end;
then you just handle the message:
procedure WMGetFileAttributesComplete(var Msg: TMessage); message WM_GetFileAttributesComplete;
procedure TfrmMain.WMGetFileAttributesComplete(var Msg: TMessage);
var
fi: TGetFileAttributesData;
begin
fi := TObject(Pointer(Msg.WParam)) as TGetFileAttributesData;
try
ShowMessage(Format('Attributes of "%s": %.8x', [fi.Filename, fi.attributes]));
finally
fi.Free;
end;
end;
The magical RunInThreadPoolThread is just a bit of fluff that lets you execute an instance method in a thread:
Which is just a wrapper that lets you call method on an instance variable:
TThreadMethod = procedure (Data: Pointer) of object;
TThreadPoolCallbackContext = class(TObject)
public
ThreadMethod: TThreadMethod;
Context: Pointer;
end;
function ThreadPoolCallbackFunction(Parameter: Pointer): Integer; stdcall;
var
tpContext: TThreadPoolCallbackContext;
begin
try
tpContext := TObject(Parameter) as TThreadPoolCallbackContext;
except
Result := -1;
Exit;
end;
try
tpContext.ThreadMethod(tpContext.Context);
finally
try
tpContext.Free;
except
end;
end;
Result := 0;
end;
function RunInThreadPoolThread(const ThreadMethod: TThreadMethod; const Data: Pointer; Flags: ULONG): BOOL;
var
tpContext: TThreadPoolCallbackContext;
begin
{
Unless you know differently, the flag you want to use is 0 (WT_EXECUTEDEFAULT).
If your callback might run for a while you can pass the WT_ExecuteLongFunction flag.
Sure, I'm supposed to pass WT_EXECUTELONGFUNCTION if my function takes a long time, but how long is long?
http://blogs.msdn.com/b/oldnewthing/archive/2011/12/09/10245808.aspx
WT_EXECUTEDEFAULT (0):
By default, the callback function is queued to a non-I/O worker thread.
The callback function is queued to a thread that uses I/O completion ports, which means they cannot perform
an alertable wait. Therefore, if I/O completes and generates an APC, the APC might wait indefinitely because
there is no guarantee that the thread will enter an alertable wait state after the callback completes.
WT_EXECUTELONGFUNCTION (0x00000010):
The callback function can perform a long wait. This flag helps the system to decide if it should create a new thread.
WT_EXECUTEINPERSISTENTTHREAD (0x00000080)
The callback function is queued to a thread that never terminates.
It does not guarantee that the same thread is used each time. This flag should be used only for short tasks
or it could affect other timer operations.
This flag must be set if the thread calls functions that use APCs.
For more information, see Asynchronous Procedure Calls.
Note that currently no worker thread is truly persistent, although worker threads do not terminate if there
are any pending I/O requests.
}
tpContext := TThreadPoolCallbackContext.Create;
tpContext.ThreadMethod := ThreadMethod;
tpContext.Context := Data;
Result := QueueUserWorkItem(ThreadPoolCallbackFunction, tpContext, Flags);
end;
Exercise for the reader: Create a Cancelled flag inside the GetFileAttributesData object that tells the thread that it must free the data object and not post a message to the parent.
It's all a long way of saying that you're creating:
DWORD WINAPI GetFileAttributes(
_In_ LPCTSTR lpFileName,
_Inout_ LPOVERLAPPED lpOverlapped,
_In_ LPOVERLAPPED_COMPLETION_ROUTINE lpCompletionRoutine
);