Deadlock when closing thread - delphi

I created a class that opens a COM port and handles overlapped read and write operations. It contains two independent threads - one that reads and one that writes data. Both of them call OnXXX procedures (eg OnRead or OnWrite) notifying about finished read or write operation.
The following is a short example of the idea how the threads work:
TOnWrite = procedure (Text: string);
TWritingThread = class(TThread)
strict private
FOnWrite: TOnWrite;
FWriteQueue: array of string;
FSerialPort: TAsyncSerialPort;
protected
procedure Execute; override;
public
procedure Enqueue(Text: string);
{...}
end;
TAsyncSerialPort = class
private
FCommPort: THandle;
FWritingThread: TWritingThread;
FLock: TCriticalSection;
{...}
public
procedure Open();
procedure Write(Text: string);
procedure Close();
{...}
end;
var
AsyncSerialPort: TAsyncSerialPort;
implementation
{$R *.dfm}
procedure OnWrite(Text: string);
begin
{...}
if {...} then
AsyncSerialPort.Write('something');
{...}
end;
{ TAsyncSerialPort }
procedure TAsyncSerialPort.Close;
begin
FLock.Enter;
try
FWritingThread.Terminate;
if FWritingThread.Suspended then
FWritingThread.Resume;
FWritingThread.WaitFor;
FreeAndNil(FWritingThread);
CloseHandle(FCommPort);
FCommPort := 0;
finally
FLock.Leave;
end;
end;
procedure TAsyncSerialPort.Open;
begin
FLock.Enter;
try
{open comm port}
{create writing thread}
finally
FLock.Leave;
end;
end;
procedure TAsyncSerialPort.Write(Text: string);
begin
FLock.Enter;
try
{add Text to the FWritingThread's queue}
FWritingThread.Enqueue(Text);
finally
FLock.Leave;
end;
end;
{ TWritingThread }
procedure TWritingThread.Execute;
begin
while not Terminated do
begin
{GetMessage() - wait for a message informing about a new value in the queue}
{pop a value from the queue}
{write the value}
{call OnWrite method}
end;
end;
When you look at the Close() procedure, you will see that it enters the critical section, terminates the writing thread and then waits for it to finish.
Because of the fact that the writing thread can enqueue a new value to be written when it calls the OnWrite method, it will try to enter the same critical section when calling the Write() procedure of the TAsyncSerialPort class.
And here we've got a deadlock. The thread that called the Close() method entered the critical section and then waits for the writing thread to be closed, while at the same time that thread waits for the critical section to be freed.
I've been thinking for quite a long time and I didn't manage to find a solution to that problem. The thing is that I would like to be sure that no reading/writing thread is alive when the Close() method is left, which means that I cannot just set the Terminated flag of those threads and leave.
How can I solve the problem? Maybe I should change my approach to handling serial port asynchronously?
Thanks for your advice in advance.
Mariusz.
--------- EDIT ----------
How about such a solution?
procedure TAsyncSerialPort.Close;
var
lThread: TThread;
begin
FLock.Enter;
try
lThread := FWritingThread;
if Assigned(lThread) then
begin
lThread.Terminate;
if lThread.Suspended then
lThread.Resume;
FWritingThread := nil;
end;
if FCommPort <> 0 then
begin
CloseHandle(FCommPort);
FCommPort := 0;
end;
finally
FLock.Leave;
end;
if Assigned(lThread) then
begin
lThread.WaitFor;
lThread.Free;
end;
end;
If my thinking is correct, this should eliminate the deadlock problem. Unfortunately, however, I close the comm port handle before the writing thread is closed. This means that when it calls any method that takes the comm port handle as one of its arguments (eg Write, Read, WaitCommEvent) an exception should be raised in that thread. Can I be sure that if I catch that exception in that thread it will not affect the work of the whole application? This question may sound stupid, but I think some exceptions may cause the OS to close the application that caused it, right? Do I have to worry about that in this case?

Yes, you should probably reconsider your approach. Asynchronous operations are available exactly to eliminate the need for threads. If you use threads, then use synchronous (blocking) calls. If you use asynchronous operations, then handle everything in one thread - not necessarily the main thread, but it doesn't make sense IMO to do the sending and receiving in different threads.
There are of course ways around your synchronization problem, but I'd rather change the design.

You can take the lock out of the Close. By the time it returns from the WaitFor, the thread body has noticed it has been terminated, completed the last loop, and ended.
If you don't feel happy doing this, then you could move setting the lock just before the FreeAndNil. This explicitly lets the thread shutdown mechanisms work before you apply the lock (so it won't have to compete with anything for the lock)
EDIT:
(1) If you also want to close the comms handle do it after the loop in the Execute, or in the thread's destructor.
(2) Sorry, but your edited solution is a terrible mess. Terminate and Waitfor will do everything you need, perfectly safely.

The main problem seems to be that you place the entire content of Close in a critical section. I'm almost sure (but you'll have to check the docs) that TThread.Terminate and TThread.WaitFor are safe to call from outside the section. By pulling that part outside the critical section you will solve the deadlock.

Related

Using Abort to improve/simplify code in some situations

I had a discussion the other day: https://stackoverflow.com/a/42156860/937125
where I didn't quite understand why an Abort was better than calling Exit in that situation. I tend not to use it in my code flow. I consider it a bad practice and bad for code flow.
but #David's statement in the comments made me wonder if maybe I was missing something:
Without a silent exception, how would you abort an operation when deep
down the call stack. For instance how would you abort a file copy
operation with a 10 deep call stack? Isn't that exactly what
exceptions are designed for? Sure you can code it without exceptions
but it is much more verbose and error prone.
I can't imagine such situation. Can someone give me an example of such code/scenario, and convince me that Abort in the above case is really a good thing and "much more verbose and error prone". (3-4 deep call stack is enough to illustrate)
The simplest scenario that illustrates my point is like so:
procedure MethodA;
begin
MethodB;
MethodC;
end;
procedure MethodB;
begin
// ... do stuff
end;
procedure MethodC;
begin
// ... do stuff
end;
That's fine as it is. Now suppose that MethodB asks the user for some input, and if the user presses the Cancel button, that no further work should be carried out. You could implement that like this:
procedure MethodA;
begin
if MethodB then
MethodC;
end;
function MethodB: Boolean;
begin
Result := MessageDlg(...)=mrOK;
if not Result then
exit;
// ... do stuff
end;
procedure MethodC;
begin
// ... do stuff
end;
That works fine, but imagine that you in the real world code, there was deeper nesting. The boolean returned by MethodB might need to be passed on up a great many levels. This would become cumbersome.
Or consider what happens if MethodB needs to return a value to its caller. In that scenario the original code might be like so:
procedure MethodA;
begin
MethodC(MethodB);
end;
function MethodB: string;
begin
Result := ...;
end;
procedure MethodC(Value: string);
begin
// ... do stuff with Value
end;
Now once more consider what happens if the user gets a chance to cancel. How can we return both a boolean and a string from MethodB? Using an out parameter for one of the return values? Using a compound structure like a record to wrap both values. The latter obviously involves lots of boilerplate so let us explore the former.
procedure MethodA;
var
Value: string;
begin
if MethodB(Value) then
MethodC(Value);
end;
function MethodB(out Value: string): Boolean;
begin
Result := MessageDlg(...)=mrOK;
if not Result then
exit;
Value := ...;
end;
procedure MethodC(Value: string);
begin
// ... do stuff with Value
end;
For sure you can do this, but this is beginning to look like the sort of code that exceptions were designed to simplify. And at this point, let us consider the existence of a silent exception, EAbort, raised by calling Abort, that does not result in a message being shown by the top level exception handler. That last point is what is meant by silent.
Now the code becomes:
procedure MethodA;
begin
MethodC(MethodB);
end;
function MethodB: string;
begin
if MessageDlg(...)<>mrOK then
Abort;
Result := ...;
end;
procedure MethodC(Value: string);
begin
// ... do stuff with Value
end;
The advantage is that MethodA does not need to worry about cancellation. And if the call stack was deeper, none of the methods between MethodA at the top, and MethodB at the point of user input, would need to know anything about cancellation.
A further benefit is that MethodB can retain its natural signature. It returns a string. In case of failure, either from a more traditional exception, or from user cancellation, an exception is thrown.
This very simple example isn't that much more compelling than the previous one that does not use Abort. But imagine what the code would look like if MethodB were 4 or 5 deep in the call stack?
I am absolutely not saying that Abort should always be used in place of exit. My belief is that both have their place. Where Abort shines is when the user opts to cancel an operation and you don't want any more processing to take place in the current event handler. Furthermore, since the user expressly opted to cancel, no further UI needs to be presented to them. You don't need a message box telling the user that they cancelled, they already know that.
Assume your program is doing a lengthy operation either in a separate thread or (even though it's frowned upon) calling Application.ProcessMessages. Now, you want the user to be able to abort that operation in a safe manner (that is: All resources are cleaned up, the data is in a consistent state etc.). So, the UI sets a flag somewhere and in your code you periodically check for that flag. If it is set, you call Abort or explicitly raise EAbort. This will cause all your carefully crafted try / except / finally blocks to be execute and making sure aborting the operation is safe.
// in the main thread:
procedure TMyProgressDialog.b_AbortClick(Sender: TObject);
begin
if AskUserIfHeIsSure then begin
gblAbortedFlag := true;
b_Abort.Enabled := false;
b_Abort.Caption := _('Aborting');
end;
end;
// call this repeatedly during the lenghty operation:
procecdure CheckAborted;
begin
// If you are in the main thread, you might want to call
// Application.ProcessMessages;
// here. If not, definitely don't.
if gblAbortedFlag then
Abort;
end;
Of course this could be done with a different exception, but I can't think of any other way to safely exit from a deep call stack without having to program lots of ifs and exits.

How to prevent application from freezing in a long running process?

The app seems to freeze sometimes when we try to pass a lot of imported files at once, which is done a each call of the function below for each file so the proposed solution is to add a sleep, but I can't seem to find proper documentation or explaining on how to handle it, or if I can even pass it as a parameter in a function.
This is the call for the proc
OpenQuery(FOrderToImportQuery.Database,FOrderToImportQuery);
My suggested idea if I can pass Sleep as Param
OpenQuery(FOrderToImportQuery.Database,FOrderToImportQuery, Sleep(200));
This is the function itself minus the sleep
procedure OpenQuery(aDatabase : TIBDatabase; aQuery : TIBQuery);
begin
if aDatabase.Connected = false then
databaseConnect(aDatabase);
if aDatabase.connected then
begin
try
aQuery.Open;
except
//try
aDatabase.ForceClose;
aDatabase.Open;
aQuery.Open;
{
except
on e: exception do
begin
Log('Error opening query : '+e.Message);
end;
end;
}
end;
end;
end;
The idea is I want the call to wait so it can complete properly before being called again. Would it be just fine to put Sleep at the end of the function itself?(Before the last END)
Or would passing it as a parameter in the call of the function be best? And if is so, how is this achieved... I can't find any doc on this particular circumstance.
The idea is I want the call to wait so it can complete properly before being called again.
Then the idea of using Sleep() is completely misconceived.
If, in a single thread, you call procedures A, B and C, as in
A;
B;
C;
then execution in the thread will only ever proceed to B after the call to A returns. Adding a Sleep() in either of them or in between them will only delay things: if there is a "log-jam" in A, adding a call to Sleep() in or after it will make no difference whatsoever. The fact that A, B and C all call your OpenQuery makes no difference either.
This is true even if A runs an asynchronous query, because the whole point of a call to an asynchronous query is that the call returns before the query completes - an asynchronous query spawns its own background thread in which the query actually executes, then typically passes the results back to the VCL thread via a call to Synchronize().
You have had comments suggesting that you put your query in a separate worker thread (separate from the VCL thread, that is). That's fine for stopping the VCL thread seizing up while waiting for the query(s) to complete, but including calls to Sleep() in the worker thread won't help there either.
So, the real answer to your q is for you to investigate and solve why a single call to OpenQuery causes the program to hang. But that's not what you've asked ...
First of all, let me say that I'm assuming your code is as optimized as it can be, and the time it takes to complete is inherently long. If you believe this might not be the case, you should open a new question with the details of your queries so we can help you on this.
Sleeping your main thread is definitely not the answer
The Sleep function will actually suspend the main thread for the amount of milliseconds specified. So, you will actually just be freezing your gui even more than now.
Worker thread
Creating a worker thread to handle the long-running work is probably your best bet to keep your program responsive while it's doing all the dirty work.
You'll have to take some precautions, though, because you probably don't want the user to be using the program while it's running the worker thread. For example, you don't want the user to click the start button again; or close the application, etc. But if these precautions are something like freezing the main thread, then you better just freeze it with the long-running work, anyway.
Maybe you will want a cancel button somewhere, if this is a process that can be interrupted in the middle (proper control of database transactions could provide this option safely).
Your worker thread could be something along these lines:
type
TWorkerThread = class(TThread)
private
{ Private declarations }
FDatabase: TIBDatabase;
FListQueries: TStringList;
protected
procedure Execute; override;
public
constructor Create(aDatabase: TIBDatabase; ListQueries: TStringList; CreateSuspended: Boolean);
destructor Destroy; override;
end;
implementation
{ TWorkerThread }
constructor TWorkerThread.Create(aDatabase: TIBDatabase; ListQueries: TStringList; CreateSuspended: Boolean);
begin
FListQueries.Create;
FListQueries.Assign(ListQueries);
FDatabase := aDatabase;
inherited Create(CreateSuspended);
end;
destructor TWorkerThread.Destroy;
begin
FListQueries.Free;
inherited;
end;
procedure TWorkerThread.Execute;
var i: Integer;
ibQuery: TIBQuery;
begin
{ Place thread code here }
ibQuery := TIBQuery.Create(aDatabase);
try
for i := 0 to FListQueries.Count - 1 do begin
if Terminated then
Exit;
ibQuery.SQL.Clear;
ibQuery.SQL.Add(FListQueries[i]);
OpenQuery(FDatabase, ibQuery);
end;
finally
ibQuery.Free;
end;
end;
PS: I'm sorry if there are compilation errors or if code for TIBDatabase/TIBQuery is wrong, I don't use any of these.
PPS: There is probably a problem with this code, though: I believe that the TIBConnection is very likely to not be thread-safe (I believe the client library itself is not). So you actually should create one connection just for use within the worker thread, rather than just use the same from main thread. I'll leave this correction for you, though. ;)

Delphi. How to know if TEvent is Signaled or not?

please tell me: how to know if TEvent is Signaled or not?
Click on STOP-button = SetEvent(Events[1]);
I am trying to unzip an archive and if STOP-button is pressed then a tread must be terminated and Unzippping must be aborted.
My code:
procedure TForm2.ZipForge1OverallProgress(Sender: TObject; Progress: Double;
Operation: TZFProcessOperation; ProgressPhase: TZFProgressPhase;
var Cancel: Boolean);
begin
if Events[1]<>null then
begin
ThreadUpdating.Terminate;
Abort;
end else
form2.Update_ProgressBar.Position := Trunc(Progress);
end;
But if I press STOP-button(SetEvent(Events[1])) nothing happens.
PS: I am using WaitForMultipleObjects(Event[1],Event[2]) in a thread. Event [1] is being used as a signal of STOP in two parts: in ZipForge1OverallProgress and WaitForMultipleObjects.
Call WaitForMultipleObjects, but do it properly. You haven't shown that code, and the code you have shown doesn't look right anyway.
First, it looks like you're trying to check whether the Events[1] element is a null pointer. Null pointers in Delphi are spelled nil, not null; the latter is a function that returns a null Variant value (but since Variant is convertible to lots of other types, the compiler probably doesn't alert you that your code is wrong). Next, it looks as though the event you're handling has a Cancel parameter that you can set to notify the caller that it should stop what it's doing, but instead of just setting that, you're throwing an EAbort exception.
If the progress event you show here is really running in a separate thread, then it must not modify property of VCL objects like TProgressBar. You need to use Synchronize to make sure VCL operations only occur in the VCL thread.
As I said, you need to call WaitForMultipleObjects property. That means passing it four parameters, for one thing. You appear to have an array with at least two handles in it, so call it like this:
var
Ret: DWord;
Ret := WaitForMultipleObjects(2, #Events[1], False, Timeout);
case Ret of
Wait_Object_0: begin
// Events[1] is signaled
end;
Wait_Object_0 + 1: begin
// Events[2] is signaled
end;
Wait_Timeout: begin
// Neither is signaled. Do some more work, or go back to waiting.
end;
Wait_Failed: begin
RaiseLastOSError;
end;
end;
If all you want to do is check whether the handle is signaled, but you don't want to wait for it to become signaled if it isn't already, then use a timeout value of zero.
'if Events[1]<>null then begin' is this pseudocode? Doesn't lok like it - looks more like real Delphi to me:) If so, you are just checking to see if the Event object is assigned, rather than signaled.
If you want to poll the stop event in your OverallProgress handler, you need to call WaitForSingleObject() with a timeout of 0.
Can you not just check a 'stop' boolean in your handler? This would be much quicker than a kernel call. You may need the Event as well so that the WFMO call at the top of the thread gets signaled when an abort/terminate is needed or you might get away with signaling some other event in the WFMO array by always checking for stop:
TmyThread = class(TThread)
..
public
stopRequested:boolean;
procedure stop;
..
end;
procedure TmyThread.stop;
begin
stopRequested:=true;
someEventInWFMOarray.signal;
end;
procedure TmyThread.execute;
begin;
while true do
begin
waitForMultipeObjects();
if stopRequested then exit;
work;
end;
end;
TForm2.ZipForge1OverallProgress(sender:TObject,......)
begin
cancel:=TmyThread(Sender).stopRequested;
if cancel then exit;
doStuff;
end;

What's the best way to ping many network devices in parallel?

I poll a lot of devices in network (more than 300) by iterative ping.
The program polls the devices sequentially, so it's slow.
I'd like to enhance the speed of polling.
There some ways to do this in Delphi 7:
Each device has a thread doing ping. Manage threads manually.
Learn and use Indy 10. Need examples.
Use overlapped I/O based on window messages.
Use completion ports based on events.
What is faster, easier? Please, provide some examples or links for example.
Flooding the network with ICMP is not a good idea.
You might want to consider some kind of thread pool and queue up the ping requests and have a fixed number of threads doing the requests.
Personally I would go with IOCP. I'm using that very successfully for the transport implementation in NexusDB.
If you want to perform 300 send/receive cycles using blocking sockets and threads in parallel, you end up needing 300 threads.
With IOCP, after you've associated the sockets with the IOCP, you can perform the 300 send operations, and they will return instantly before the operation is completed. As the operations are completed, so called completion packages will be queued to the IOCP. You then have a pool of threads waiting on the IOCP, and the OS wakes them up as the completion packets come in. In reaction to completed send operations you can then perform the receive operations. The receive operations also return instantly and once actually completed get queued to the IOCP.
The real special thing about an IOCP is that it knows which threads belong to it and are currently processing completion packages. And the IOCP only wakes up new threads if the total number of active threads (not in a kernel mode wait state) is lower than the concurrency number of the IOCP (by default that equals the number of logical cores available on the machine). Also, if there are threads waiting for completion packages on the IOCP (which haven't been started yet despite completion packages being queued because the number of active threads was equal to the concurrancy number), the moment one of the threads that is currently processing a completion package enters a kernel mode wait state for any reason, one of the waiting threads is started.
Threads returning to the IOCP pick up completion packages in LIFO order. That is, if a thread is returning to the IOCP and there are completion packages still waiting, that thread directly picks up the next completion package, instead of being put into a wait state and the thread waiting for the longest time waking up.
Under optimal conditions, you will have a number of threads equal to the number of available cores running concurrently (one on each core), picking up the next completion package, processing it, returning to the IOCP and directly picking up the next completion package, all without ever entering a kernel mode wait state or a thread context switch having to take place.
If you would have 300 threads and blocking operations instead, not only would you waste at least 300 MB address space (for the reserved space for the stacks), but you would also have constant thread context switches as one thread enters a wait state (waiting for a send or receive to complete) and the next thread with a completed send or receive waking up. – Thorsten Engler 12 hours ago
Direct ICMP access is deprecated on windows. Direct access to the ICMP protocol on Windows is controlled. Due to malicious use of ICMP/ping/traceroute style raw sockets, I believe that on some versions of Windows you will need to use Windows own api. Windows XP, Vista, and Windows 7, in particular, don't let user programs access raw sockets.
I have used the canned-functionality in ICMP.dll, which is what some Delphi ping components do, but a comment below alerted me to the fact that this is considered "using an undocumented API interface".
Here's a sample of the main delphi ping component call itself:
function TICMP.ping: pIcmpEchoReply;
{var }
begin
// Get/Set address to ping
if ResolveAddress = True then begin
// Send packet and block till timeout or response
_NPkts := _IcmpSendEcho(_hICMP, _Address,
_pEchoRequestData, _EchoRequestSize,
#_IPOptions,
_pIPEchoReply, _EchoReplySize,
_TimeOut);
if _NPkts = 0 then begin
result := nil;
status := CICMP_NO_RESPONSE;
end else begin
result := _pIPEchoReply;
end;
end else begin
status := CICMP_RESOLVE_ERROR;
result := nil;
end;
end;
I believe that most modern Ping component implementations are going to be based on a similar bit of code to the one above, and I have used it to run this ping operation in a background thread, without any probems. (Demo program included in link below).
Full sample source code for the ICMP.DLL based demo is here.
UPDATE A more modern IPHLPAPI.DLL sample is found at About.com here.
Here's an article from Delphi3000 showing how to use IOCP to create a thread pool. I am not the author of this code, but the author's information is in the source code.
I'm re-posting the comments and code here:
Everyone by now should understand what
a thread is, the principles of threads
and so on. For those in need, the
simple function of a thread is to
separate processing from one thread to
another, to allow concurrent and
parallel execution. The main principle
of threads is just as simple, memory
allocated which is referenced between
threads must be marshalled to ensure
safety of access. There are a number
of other principles but this is really
the one to care about.
And on..
A thread safe queue will allow
multiple threads to add and remove,
push and pop values to and from the
queue safely on a First on First off
basis. With an efficient and well
written queue you can have a highly
useful component in developing
threaded applications, from helping
with thread safe logging, to
asynchronous processing of requests.
A thread pool is simply a thread or a
number of threads which are most
commonly used to manage a queue of
requests. For example a web server
which would have a continuous queue of
requests needing to be processed use
thread pools to manage the http
requests, or a COM+ or DCOM server
uses a thread pool to handle the rpc
requests. This is done so there is
less impact from the processing of one
request to another, say if you ran 3
requests synchronously and the first
request took 1 minute to complete, the
second two requests would not complete
for at least 1 minute adding on top
there own time to process, and for
most of the clients this is not
acceptable.
So how to do this..
Starting with the queue!!
Delphi does provides a TQueue object
which is available but is
unfortunately not thread safe nor
really too efficient, but people
should look at the Contnrs.pas file to
see how borland write there stacks and
queues. There are only two main
functions required for a queue, these
are add and remove/push and pop.
Add/push will add a value, pointer or
object to the end of a queue. And
remove/pop will remove and return the
first value in the queue.
You could derive from TQueue object
and override the protected methods and
add in critical sections, this will
get you some of the way, but I would
want my queue to wait until new
requests are in the queue, and put the
thread into a state of rest while it
waits for new requests. This could be
done by adding in Mutexes or signaling
events but there is an easier way. The
windows api provides an IO completion
queue which provides us with thread
safe access to a queue, and a state of
rest while waiting for new request in
the queue.
Implementing the Thread Pool
The thread pool is going to be very
simple and will manage x number of
threads desired and pass each queue
request to an event provided to be
processed. There is rarely a need to
implement a TThread class and your
logic to be implemented and
encapsulated within the execute event
of the class, thus a simple
TSimpleThread class can be created
which will execute any method in any
object within the context of another
thread. Once people understand this,
all you need to concern yourself with
is allocated memory.
Here is how it is implemented.
TThreadQueue and TThreadPool
implementation
(* Implemented for Delphi3000.com Articles, 11/01/2004
Chris Baldwin
Director & Chief Architect
Alive Technology Limited
http://www.alivetechnology.com
*)
unit ThreadUtilities;
uses Windows, SysUtils, Classes;
type
EThreadStackFinalized = class(Exception);
TSimpleThread = class;
// Thread Safe Pointer Queue
TThreadQueue = class
private
FFinalized: Boolean;
FIOQueue: THandle;
public
constructor Create;
destructor Destroy; override;
procedure Finalize;
procedure Push(Data: Pointer);
function Pop(var Data: Pointer): Boolean;
property Finalized: Boolean read FFinalized;
end;
TThreadExecuteEvent = procedure (Thread: TThread) of object;
TSimpleThread = class(TThread)
private
FExecuteEvent: TThreadExecuteEvent;
protected
procedure Execute(); override;
public
constructor Create(CreateSuspended: Boolean; ExecuteEvent: TThreadExecuteEvent; AFreeOnTerminate: Boolean);
end;
TThreadPoolEvent = procedure (Data: Pointer; AThread: TThread) of Object;
TThreadPool = class(TObject)
private
FThreads: TList;
FThreadQueue: TThreadQueue;
FHandlePoolEvent: TThreadPoolEvent;
procedure DoHandleThreadExecute(Thread: TThread);
public
constructor Create( HandlePoolEvent: TThreadPoolEvent; MaxThreads: Integer = 1); virtual;
destructor Destroy; override;
procedure Add(const Data: Pointer);
end;
implementation
{ TThreadQueue }
constructor TThreadQueue.Create;
begin
//-- Create IO Completion Queue
FIOQueue := CreateIOCompletionPort(INVALID_HANDLE_VALUE, 0, 0, 0);
FFinalized := False;
end;
destructor TThreadQueue.Destroy;
begin
//-- Destroy Completion Queue
if (FIOQueue <> 0) then
CloseHandle(FIOQueue);
inherited;
end;
procedure TThreadQueue.Finalize;
begin
//-- Post a finialize pointer on to the queue
PostQueuedCompletionStatus(FIOQueue, 0, 0, Pointer($FFFFFFFF));
FFinalized := True;
end;
(* Pop will return false if the queue is completed *)
function TThreadQueue.Pop(var Data: Pointer): Boolean;
var
A: Cardinal;
OL: POverLapped;
begin
Result := True;
if (not FFinalized) then
//-- Remove/Pop the first pointer from the queue or wait
GetQueuedCompletionStatus(FIOQueue, A, Cardinal(Data), OL, INFINITE);
//-- Check if we have finalized the queue for completion
if FFinalized or (OL = Pointer($FFFFFFFF)) then begin
Data := nil;
Result := False;
Finalize;
end;
end;
procedure TThreadQueue.Push(Data: Pointer);
begin
if FFinalized then
Raise EThreadStackFinalized.Create('Stack is finalized');
//-- Add/Push a pointer on to the end of the queue
PostQueuedCompletionStatus(FIOQueue, 0, Cardinal(Data), nil);
end;
{ TSimpleThread }
constructor TSimpleThread.Create(CreateSuspended: Boolean;
ExecuteEvent: TThreadExecuteEvent; AFreeOnTerminate: Boolean);
begin
FreeOnTerminate := AFreeOnTerminate;
FExecuteEvent := ExecuteEvent;
inherited Create(CreateSuspended);
end;
procedure TSimpleThread.Execute;
begin
if Assigned(FExecuteEvent) then
FExecuteEvent(Self);
end;
{ TThreadPool }
procedure TThreadPool.Add(const Data: Pointer);
begin
FThreadQueue.Push(Data);
end;
constructor TThreadPool.Create(HandlePoolEvent: TThreadPoolEvent;
MaxThreads: Integer);
begin
FHandlePoolEvent := HandlePoolEvent;
FThreadQueue := TThreadQueue.Create;
FThreads := TList.Create;
while FThreads.Count < MaxThreads do
FThreads.Add(TSimpleThread.Create(False, DoHandleThreadExecute, False));
end;
destructor TThreadPool.Destroy;
var
t: Integer;
begin
FThreadQueue.Finalize;
for t := 0 to FThreads.Count-1 do
TThread(FThreads[t]).Terminate;
while (FThreads.Count > 0) do begin
TThread(FThreads[0]).WaitFor;
TThread(FThreads[0]).Free;
FThreads.Delete(0);
end;
FThreadQueue.Free;
FThreads.Free;
inherited;
end;
procedure TThreadPool.DoHandleThreadExecute(Thread: TThread);
var
Data: Pointer;
begin
while FThreadQueue.Pop(Data) and (not TSimpleThread(Thread).Terminated) do begin
try
FHandlePoolEvent(Data, Thread);
except
end;
end;
end;
end.
As you can see it's quite straight
forward, and with this you can
implement very easily any queuing of
requests over threads and really any
type of requirement that requires
threading can be done using these
object and save you a lot of time and
effort.
You can use this to queue requests
from one thread to multiple threads,
or queue requests from multiple
threads down to one thread which makes
this quite a nice solution.
Here are some examples of using these
objects.
Thread safe logging
To allow multiple
threads to asynchronously write to a
log file.
uses Windows, ThreadUtilities,...;
type
PLogRequest = ^TLogRequest;
TLogRequest = record
LogText: String;
end;
TThreadFileLog = class(TObject)
private
FFileName: String;
FThreadPool: TThreadPool;
procedure HandleLogRequest(Data: Pointer; AThread: TThread);
public
constructor Create(const FileName: string);
destructor Destroy; override;
procedure Log(const LogText: string);
end;
implementation
(* Simple reuse of a logtofile function for example *)
procedure LogToFile(const FileName, LogString: String);
var
F: TextFile;
begin
AssignFile(F, FileName);
if not FileExists(FileName) then
Rewrite(F)
else
Append(F);
try
Writeln(F, DateTimeToStr(Now) + ': ' + LogString);
finally
CloseFile(F);
end;
end;
constructor TThreadFileLog.Create(const FileName: string);
begin
FFileName := FileName;
//-- Pool of one thread to handle queue of logs
FThreadPool := TThreadPool.Create(HandleLogRequest, 1);
end;
destructor TThreadFileLog.Destroy;
begin
FThreadPool.Free;
inherited;
end;
procedure TThreadFileLog.HandleLogRequest(Data: Pointer; AThread: TThread);
var
Request: PLogRequest;
begin
Request := Data;
try
LogToFile(FFileName, Request^.LogText);
finally
Dispose(Request);
end;
end;
procedure TThreadFileLog.Log(const LogText: string);
var
Request: PLogRequest;
begin
New(Request);
Request^.LogText := LogText;
FThreadPool.Add(Request);
end;
As this is logging to a file it will
process all requests down to a single
thread, but you could do rich email
notifications with a higher thread
count, or even better, process
profiling with what’s going on or
steps in your program which I will
demonstrate in another article as this
one has got quite long now.
For now I will leave you with this,
enjoy.. Leave a comment if there's
anything people are stuck with.
Chris
Do you need a response from every machine on the network, or are these 300 machines just a subset of the larger network?
If you need a response from every machine, you could consider using a broadcast address or multicast address for your echo request.
Please give a try on "chknodes" parallel ping for Linux which will send a single ping to all nodes of your network. It will do also dns reverse lookup and request http response if specified so. It's written completely in bash i.e. you can easily check it or modify it to your needs. Here is a printout of help:
chknodes -h
chknodes ---- fast parallel ping
chknodes [-l|--log] [-h|--help] [-H|--http] [-u|--uninstall] [-v|--version] [-V|--verbose]
-l | --log Log to file
-h | --help Show this help screen
-H | --http Check also http response
-n | --names Get also host names
-u | --uninstall Remove installation
-v | --version Show version
-V | --verbose Show each ip address pinged
You need to give execute right for it (like with any sh/bash script) in order to run it:
chmod +x chknodes
On the first run i.e.
./chknodes
it will suggest to install itself to /usr/local/bin/chknodes, after that giving just
chknodes
will be enough. You can find it here:
www.homelinuxpc.com/download/chknodes

PostMessage in service applications

There is a problem I am unable to solve. I created two service applications in Delphi and tried to post messages within them. Of course, there are no windows in such applications and PostMessage needs a window handle parameter to send a message.
Therefore, I created a window handle using the AllocateHWnd(MyMethod: TWndMethod) function and passed, as the 'MyMethod' parameter, a procedure I want to be called when a message is received. If it was a windowed application, PostMessage() called using the handle returned by the AllocateHWnd method would certainly send a message that would then be received by the 'MyMethod' procedure.
The situation, however, is different in my service applications. I do not understand why, but in one of them posting messages this way works fine, whereas in the second one it does not (the messages are not received at all). Only when the service is being stopped do I notice that two messages are received by 'MyMethod': WM_DESTROY and WM_NCDESTROY. The messages I send using PostMessage are never received by this procedure. On the other hand, the first service always receives all messages I send.
Could you please give me a clue that would help me find the reason of the second service not receiving my messages? I do not know in what way they can differ. I checked the settings of the services and they seem to be identical. Why then one of them works fine and the second one does not (as far as sending messages is concerned)?
Thanks for any advice.
Mariusz.
Without more information it will be difficult to help you debug this, especially why it works in one service but not in the other. However:
Instead of trying to fix the problem in your code you might want to remove the windows altogether, and use PostThreadMessage() instead of PostMessage(). For the posting of messages to work correctly you need a message loop, but not necessarily receiving windows.
Edit: I'm trying to reply to all your answers in one go.
First - if you want to make your life easy you should really check out OmniThreadLibrary by gabr. I don't know whether it does work in a Windows service application, I don't even know whether that has been tried yet. You could ask in the forum. It has however a lot of great features and is worth looking into, if only for the learning effect.
But of course you can also program this for yourself, and you will have to for Delphi versions prior to Delphi 2007. I will simply add some snippets from our internal library, which has evolved over the years and works in several dozen programs. I don't claim it to be bug-free though. You can compare it with your code, and if anything sticks out, feel free to ask and I'll try to clarify.
This is the simplified Execute() method of the worker thread base class:
procedure TCustomTestThread.Execute;
var
Msg: TMsg;
begin
try
while not Terminated do begin
if (integer(GetMessage(Msg, HWND(0), 0, 0)) = -1) or Terminated then
break;
TranslateMessage(Msg);
DispatchMessage(Msg);
if Msg.Message = WM_USER then begin
// handle differently according to wParam and lParam
// ...
end;
end;
except
on E: Exception do begin
...
end;
end;
end;
It is important to not let exceptions get unhandled, so there is a top-level exception handler around everything. What you do with the exception is your choice and depends on the application, but all exceptions have to be caught, otherwise the application will get terminated. In a service your only option is probably to log them.
There is a special method to initiate thread shutdown, because the thread needs to be woken up when it is inside of GetMessage():
procedure TCustomTestThread.Shutdown;
begin
Terminate;
Cancel; // internal method dealing with worker objects used in thread
DoSendMessage(WM_QUIT);
end;
procedure TCustomTestThread.DoSendMessage(AMessage: Cardinal;
AWParam: integer = 0; ALParam: integer = 0);
begin
PostThreadMessage(ThreadID, AMessage, AWParam, ALParam);
end;
Posting WM_QUIT will cause the message loop to exit. There is however the problem that code in descendant classes could rely on Windows messages being properly handled during shutdown of the thread, especially when COM interfaces are used. That's why instead of a simple WaitFor() the following code is used to free all running threads:
procedure TCustomTestController.BeforeDestruction;
var
i: integer;
ThreadHandle: THandle;
WaitRes: LongWord;
Msg: TMsg;
begin
inherited;
for i := Low(fPositionThreads) to High(fPositionThreads) do begin
if fPositionThreads[i] <> nil then try
ThreadHandle := fPositionThreads[i].Handle;
fPositionThreads[i].Shutdown;
while TRUE do begin
WaitRes := MsgWaitForMultipleObjects(1, ThreadHandle, FALSE, 30000,
QS_POSTMESSAGE or QS_SENDMESSAGE);
if WaitRes = WAIT_OBJECT_0 then begin
FreeAndNil(fPositionThreads[i]);
break;
end;
if WaitRes = WAIT_TIMEOUT then
break;
while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
except
on E: Exception do
// ...
end;
fPositionThreads[i] := nil;
end;
end;
This is in the overridden BeforeDestruction() method because all threads need to be freed before the destructor of the descendant controller class begins to free any objects the threads might use.
I'd suggest you consider using named pipes for IPC. That is what they are designed to do:
Looking for an alternative to windows messages used in inter-process communication
As Mghie mentioned, you need a message processing loop. That's why PeekMessage returns the messages correctly. It's not that the messages aren't there, it's that you aren't processing them. In a standard application, Delphi creates a TApplication class and calls Application.Run. This IS the message processing loop for a normal app. It basically consists of:
repeat
try
HandleMessage;
except
HandleException(Self);
end;
until Terminated;
If you want your service application to handle messages, you'll need to perform the same kind of work.
There's an example of using a service and handling PostThreadMessage dispatches here. Keep in mind, as Mick mentioned, you cannot use message handling between applications of differing security contexts (particularly in Vista). You should use named pipes or similar. Microsoft discusses this here.
Edit:
Based on the code snippet that you posted, you may just be fighting a threading issue. AllocHWnd is not thread safe. See here for a really detailed explanation of the issue and a version that works correctly in threads.
Of course, this still leads us back to why you aren't using PostThreadMessage instead. The way your code sample is structured, it would be trivial to make the message handling a function of the thread and then pass it down into the class for disposition.
Thanks for all your answers. I think we can forget about the problem. I created a new service application and performed quick post message tests. The messages were delivered correctly, so I hope I can now state that normally everything works fine and something is wrong only with this one service I described. I know it is stupid, but I will just try to copy one fragment of code after another from the 'bad' service to a new one. Maybe this will help me find the reason of the problem.
I hope I can now consider the message-waiting loop unnecessary as long as everything works fine without it, can't I?
If it comes to the privileges, Microsoft says: "UAC uses WIM to block Windows messages from being sent between processes of different privilege levels.". My Vista's UAC is off and I did not set any privileges for those services I described. Apart from that I do not send messages between different processes. Messages are sent within one process.
To give you the idea of what I am doing, I'll show you a code snippet from a test service application.
uses ...;
type
TMyThread = class;
TMyClass = class
private
FThread: TMyThread;
procedure ReadMessage(var Msg: TMessage);
public
FHandle: HWND;
constructor Create;
destructor Destroy; override;
end;
TMyThread = class(TThread)
private
FMyClass: TMyClass;
protected
procedure Execute; override;
constructor Create(MyClass: TMyClass); reintroduce;
end;
implementation
{ TMyClass }
constructor TMyClass.Create;
begin
inherited Create;
FHandle := AllocateHWnd(ReadMessage);
FThread := TMyThread.Create(Self);
end;
destructor TMyClass.Destroy;
begin
FThread.Terminate;
FThread.WaitFor;
FThread.Free;
DeallocateHWnd(FHandle);
inherited Destroy;
end;
procedure TMyClass.ReadMessage(var Msg: TMessage);
begin
Log.Log('message read: ' + IntToStr(Msg.Msg));
end;
{ TMyThread }
constructor TMyThread.Create(MyClass: TMyClass);
begin
inherited Create(True);
FMyClass := MyClass;
Resume;
end;
procedure TMyThread.Execute;
begin
while not Terminated do
begin
//do some work and
//send a message when finished
if PostMessage(FMyClass.FHandle, WM_USER, 0, 0) then
Log.Log('message sent')
else
Log.Log('message not sent: ' + SysErrorMessage(GetLastError));
//do something else...
Sleep(1000);
end;
end;
This is only an example, but functioning of my real code bases on the same idea. When you create an object of this class, it will create a thread that will start sending messages to that class. Log.Log() saves data into a text file. When I use this code in a new service application, everything works fine. When i put it into the 'broken' service, it does not. Please note that I do not use any message-waiting loop to receive messages. I created a new service and just put the code above into it, then created an object of the class. That's all.
If I get to know why this does not work in the 'broken' service, I'll write about it.
Thanks for the time you devoted me.
Mariusz.
Here's what I would try:
Check the return value and GetLastError of PostMessage
Is this a Vista/2008 machine? If yes, check if the sending application have sufficient priviliges to do send the message.
I have to have more information to help you further.
I spent long hours trying to find the reason of the messages not being received. As I showed in my code snippet, the constructor of the class creates a window handle which I used to send messages to. As long as the class was constructed by the main thread, everything worked fine for the window handle (if I understand it correctly) existed in the context of the main thread which, by default, awaits messages. In the 'broken' service, as I called it by mistake, my class was created by another thread, so the handle must have existed in the context of that thread. Therefore, when I sent messages using this window handle, they were received by that thread, not by the main one. Because of the fact that this thread did not have any message-waiting loop, my messages were not received at all.
I just did not know it worked this way. To solve the problem in an easy way, I create and destroy the class in the main thread even though I use it in the second one.
Thanks for your time and all the information you gave me.
Mghie, I think you are absolutely right. I implemented a message waiting loop this way:
procedure TAsyncSerialPort.Execute;
var
Msg: tagMSG;
begin
while GetMessage(Msg, 0, 0, 0) do
begin
{thread message}
if Msg.hwnd = 0 then
begin
case Msg.message of
WM_DATA_READ: Log.Log('data read');
WM_READ_TIMEOUT: Log.Log('read timeout');
WM_DATA_WRITTEN: Log.Log('data written');
WM_COMM_ERROR: Log.Log('comm error');
else
DispatchMessage(Msg);
end;
end
else
DispatchMessage(Msg);
end;
end;
I'm doing it for the first time, so please, could you check the code whether it is correct? In fact, this is my real class code snippet (the logs will be substituted with a real code). It handles overlapped comm port. There are two threads that send thread messages to the thread above, informing it that they wrote or received some data from comm port, etc. When the thread gets such a message, it takes an action - it gets the received data from a queue, where the threads first put it and then calls an external method that, lets say, analyses the received data. I don't want to go into details for it is unimportant :). I send thread messages like this: PostThreadMessage(MyThreadId, WM_DATA_READ, 0, 0).
This code works properly as I checked, but I would like to be sure everything is correct, so I'm asking you about that. I would be grateful if you answered.
To free the thread I do the following:
destructor TAsyncSerialPort.Destroy;
begin
{send a quit message to the thread so that GetMessage returns false and the loop ends}
PostThreadMessage(ThreadID, WM_QUIT, 0, 0);
{terminate the thread but wait until it finishes before the following objects
(critical sections) are destroyed for the thread might use them before it quits}
Terminate;
if Suspended then
Resume;
WaitFor;
FreeAndNil(FLock);
FreeAndNil(FCallMethodsLock);
inherited Destroy;
end;
I hope this is the proper way to end the message loop.
Thank you very much for your help.
BTW, I hope my English language is understandable, isn't it? :) Sorry if you have difficulties understanding me.
There's one trick in message loops in threads. Windows won't create a message queue for a thread immediately so there will be some time when posting messages to a thread will fail. Details are here. In my msg loop thread I use the technique MS proposes:
constructor TMsgLoopThread.Create;
begin
inherited Create(True);
FEvMsgQueueReady := CreateEvent(nil, True, False, nil);
if FEvMsgQueueReady = 0 then
Error('CreateEvent: '+LastErrMsg);
end;
procedure TMsgLoopThread.Execute;
var
MsgRec: TMsg;
begin
// Call fake PeekMessage for OS to create message queue for the thread.
// When it finishes, signal the event. In the main app execution will wait
// for this event.
PeekMessage(MsgRec, 0, WM_USER, WM_USER, PM_NOREMOVE);
SetEvent(FEvMsgQueueReady);
...
end;
// Start the thread with waitinig for it to get ready
function TMsgLoopThread.Start(WaitInterval: DWORD): DWORD;
begin
inherited Start;
Result := WaitForSingleObject(FEvMsgQueueReady, WaitInterval);
end;
But in your case I'd strongly recommend using other means of IPC.

Resources