Why 'form close' event is not happening when a huge for loop is runnig in Delphi? - performance

I am trying out following code. However, if I click on form's close button while this code is running, nothing happens. How can I correct this? I need to close the form even when this loop is executing.
procedure TForm1.Button1Click(Sender: TObject);
var
i: Integer;
begin
for i := 0 to 9999999 do
begin
Memo1.Lines.Add('hi');
Application.ProcessMessages;
end;
end;

Have a look at what's going on inside Application.ProcessMessages.
When you close the main form, windows sends a WM_QUIT message to the program. The relevant part of TApplication.ProcessMessages looks like this:
if Msg.Message <> WM_QUIT then
begin
//skipped
end
else
begin
{$IF DEFINED(CLR)}
if Assigned(FOnShutDown) then FOnShutDown(self);
DoneApplication;
{$IFEND}
FTerminate := True;
end;
I assume this is not a CLR program, so the only thing that happens at this point is setting FTerminate := True on Application. This is reflected in the Application.Terminated property.
When the application shuts down, one of the things it does in order to shut down safely is wait for all threads to finish. This code happens to be running in the main thread, but the principle would be the same in any thread: If you're doing a long-running task that might have to finish early, you have to explicitly check for early termination.
Knowing this, it's easy to figure out how to fix your code:
procedure TForm1.Button1Click(Sender: TObject);
var
i: Integer;
begin
for i := 0 to 9999999 do
begin
Memo1.Lines.Add('hi');
Application.ProcessMessages;
if Application.Terminated then
Break;
end;
end;
Also, beware of using Application.ProcessMessages in the first place, as it will process all messages for the application. For a simple idea of what might go wrong, try adding IntToStr(i) instead of 'hi' to Memo1.Lines, knock a couple of orders of magnitude off the counter, and then click the button two or three times in rapid succession and watch the output...

Check for Apllication Terminated:
for i := 0 to 9999999 do
begin
Memo1.Lines.Add('hi');
Application.ProcessMessages;
if Application.Terminated then Exit;
end;

You need to run any tight loop in a thread. This will solve the problem.
BUT if you want to keep the code as it is, Application.ProcessMessages will make your loop terribly slow. So you need to run Application.ProcessMessages not so often:
Counter:= 0;
for i := 0 to 9999999 do
begin
DoSomeStuff;
{ Prevent freeze }
inc(Counter);
if counter > 10000 then
begin
Counter:= 0;
Application.ProcessMessages;
if Application.Terminated then Exit;
end;
end;

Related

Display image using Windows API

I am using a looping primitive code to output a test image:
procedure TForm1.Button1Click(Sender: TObject);
var
LP1, LP2: TLogPen;
hp1, hp2: THandle;
hdcv: Handle;
i: integer;
begin
LP1.lopnColor:=$FF0000;
LP1.lopnStyle:=0;
LP1.lopnWidth:=Classes.Point(1,0);
LP2.lopnColor:=$FFFFFF;
LP2.lopnStyle:=0;
LP2.lopnWidth:=Classes.Point(1,0);
hp1:=Windows.CreatePenIndirect(Windows.LOGPEN(LP1));
hp2:=Windows.CreatePenIndirect(Windows.LOGPEN(LP2));
hdcv:=Canvas.Handle;
for i:=1 to 1000 do
begin
SelectObject(hdcv, hp1);
Windows.MoveToEx(hdcv, 10+2*i, 10, nil);
Windows.LineTo(hdcv, 50+2*i, 50);
Sleep(100);
Application.ProcessMessages;
SelectObject(hdcv, hp2);
Windows.MoveToEx(hdcv, 10+2*i+1, 10, nil);
Windows.LineTo(hdcv, 50+2*i+1, 50);
Sleep(100);
Application.ProcessMessages;
end;
Windows.DeleteObject(hp1);
Windows.DeleteObject(hp2);
end;
The problem is that when the mouse is on the button (Button1), lines output is intermittent. As if drawing takes place in some kind of buffer, and after some time it is displayed on the form. I recorded a video. I am using Windows 7 and Lazarus 1.6.4. Can someone explain this graphics behavior?
During the sleep, windows repaint messages can't operate. So it is possible that the repaint only happens on the processmessages stage.
The best solution is to rewrite this asynchronously using a timer.
To test the hypothesis you could replace the sleep-application.processes with a more fine grained solution like
So instead of
sleep(100);
Application.ProcessMessages;
we replace it with
for y:=1 to 10 do
begin
sleep(10);
Application.ProcessMessages;
end;
Somewhat nicer is a solution like this (pseudocode only):
startticks:=gettickcount64; // startticks = int64
while (gettickcount64-startticks)<100 do
begin
sleep(10);
Application.ProcessMessages;
end;
which accounts better for the time spent in Application.Processmessages.

When computer take order to shutdown , I need to save file

How I can save the content of Listbox to file When the computer shutting down or sleeping, or restarting ???
I use Delphi XE7 ,
I do save the file , and I have no problem with it !
but I want to save the file when computer shutting down .
update my code and Problem:
my problem which is , when my project run in the background the both events OnClose & OnDestroy dose not work!
If the project work normally "not in the background", the both event's is work fine!
I figure my problem , which is my project working in background process , i add this lines to do this Application.MainFormOnTaskbar := False; Application.ShowMainForm := False; If i make my project to run in back ground process the events onClose and onDestroy is definitely not work,
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
str :TStringList;
i : integer;
begin
str := TStringList.Create;
for i := 0 to ListBox1.Count-1 do
str.Add(ListBox1.Items.Strings[i]);
try
str.SaveToFile('D:\test1.txt', TEncoding.UTF8);
finally
str.Free;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
var
str :TStringList;
i : integer;
begin
str := TStringList.Create;
for i := 0 to ListBox1.Count-1 do
str.Add(ListBox1.Items.Strings[i]);
try
str.SaveToFile('D:\test15.txt', TEncoding.UTF8);
finally
str.Free;
end;
end;
Handle the WM_ENDSESSION message and save your file there.
Catch the windows message like this:
private
procedure OnShutDown(var Msg: TMessage); message WM_ENDSESSION;
And here is your implementation
procedure TForm1.OnShutDown(var Msg: TMessage);
begin
//Save your file here.
end;

How to pump COM messages?

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;

Capture all commands output

I want to capture cmd.exe output and show it in a diffrent gui I am making. I want to make a command interpreter with extended functionality. The dir command works flawless, the problem ocurrs when I try to execute another process like ipconfig.
I don't see ipconfig output. Is there a workarround on that ?!
I use TProcess component from Lazarus (FreePascal)
proc := TProcess.Create(nil);
proc.Options:= [poUsePipes, poNoConsole];
proc.ShowWindow:= swoHIDE;
proc.Executable:= 'cmd';
Reading output thread:
if (Length(cmd) > 0) then
begin
cmd := cmd + #13#10;
proc.Input.Write(cmd[1], Length(cmd)); // here I write command from user
strikes := 0;
end
else
if proc.Output.NumBytesAvailable > 0 then
begin
while proc.Output.NumBytesAvailable > 0 do
begin
FillChar(buf, sizeof(buf), #0);
proc.Output.Read(buf, sizeof(buf) - 1);
data := data + buf;
end;
// data gets echoed to user
It works fine for me (I use FPC 3.1.1 & Lazarus 1.5 but I hope it does not matter):
proc.Options:= [poUsePipes];
proc.ShowWindow:= swoHIDE;
proc.Executable:= 'cmd';
...
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
var
cmd: String;
begin
if Key = #13 then
begin
Key := #0;
if not proc.Active then
proc.Active := True;
cmd := Edit1.Text + LineEnding;
proc.Input.Write(cmd[1], Length(cmd));
end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
buf: array[0..65535] of Char;
begin
if proc.Output.NumBytesAvailable > 0 then
begin
while proc.Output.NumBytesAvailable > 0 do
begin
FillChar(buf, sizeof(buf), #0);
proc.Output.Read(buf, sizeof(buf) - 1);
Memo1.Lines.Add(buf);
end;
end;
end;
I guess that you just does not catch process output properly.
Good luck.
PS: If you need to create some windows console-like application, the best way, I think, is using Windows console API instead of cross-platform Lazarus components.
PPS: To emulate console look and behavior with Lazarus use CmdLine component.
In general it is smart to first check if the short examples don't solve the problem:
e.g.
uses process;
var s : ansistring;
begin
runcommand('ipconfig',['/all'],s);
writeln(s);
end.
works fine, and saves a whole lot of trouble. (FPC 2.6.2+ though)

ICMP is support MultiThreading or not? [duplicate]

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 }
.
.
.

Resources