I've coding a multithread application that send and receive TCP packages. I'm with the problem that when I call twice event confirmBoxRecognized(peerIP: string) of the code bellow. I'm getting the following exception:
Cannot call Start on a running or suspended thread
If I check in the thread object I've that terminated == true and suspended == false. Why am I coding wrong?
Following the code:
TThreadReadTCP = class(TThread)
private
context: TfrmBoxTest;
looping: Boolean;
procedure readTCP;
protected
procedure DoTerminate; override;
procedure Execute; override;
public
peerIP: String;
responseObject: TProtocolObject;
constructor Create(CreateSuspended: Boolean; ctx: TFrmBoxTest); overload;
end;
{ TThreadReadTCP }
constructor TThreadReadTCP.Create(CreateSuspended: Boolean; ctx: TFrmBoxTest);
begin
inherited Create(CreateSuspended);
Self.context := ctx;
FreeOnTerminate := True;
end;
procedure TThreadReadTCP.DoTerminate;
begin
looping := false;
inherited DoTerminate();
end;
procedure TThreadReadTCP.Execute;
begin
inherited;
looping := true;
readTCP;
end;
procedure TThreadReadTCP.readTCP;
var
buffer: TBytes;
begin
while looping do
begin
if context.tcpClientBox.Connected then
begin
try
buffer := TEncoding.ASCII.GetBytes(context.tcpClientBox.Socket.ReadLn());
//do something else
except on E:Exception do
ShowMessage('Error receiving TCP buffer with message: ' + e.Message);
end;
end;
end;
end;
procedure TfrmBoxTest.confirmBoxRecognized(peerIP: string);
begin
if (connectBoxTCP(peerIP)) then
begin
if Assigned(threadReadTCP) then
begin
threadReadTCP.Terminate();
threadReadTCP.Start(); // I get the exception here when I run this code twice...
end;
showBoxRecognized();
end;
sendBoxRecognized();
end;
Are there running thread status can I get? Or anyone can explain how can I improve this code to solve this problem?
Thanks a lot!
You get the exception because you can only call Start() on a TThread object one time. Once the thread has been started, you cannot restart it. Once it has been signaled to terminate, all you can do is wait for it to finish terminating, and then destroy the object.
If you want another thread to start running, you have to create a new TThread object, eg:
type
TThreadReadTCP = class(TThread)
private
context: TfrmBoxTest;
protected
procedure Execute; override;
procedure TerminatedSet; override;
public
peerIP: String;
responseObject: TProtocolObject;
constructor Create(ctx: TFrmBoxTest); reintroduce;
end;
constructor TThreadReadTCP.Create(ctx: TFrmBoxTest);
begin
inherited Create(False);
Self.context := ctx;
// NEVER use FreeOnTerminate=True with a thread object that you keep a reference to!
// FreeOnTerminate := True;
end;
procedure TThreadReadTCP.Execute;
var
buffer: TBytes;
begin
while not Terminated do
begin
try
buffer := TEncoding.ASCII.GetBytes(context.tcpClientBox.Socket.ReadLn());
// do something else
except
on E: Exception do
begin
// do something
raise;
end;
end;
end;
end;
procedure TThreadReadTCP.TerminatedSet;
begin
try
context.tcpClientBox.Disconnect(False);
except
end;
end;
...
procedure TfrmBoxTest.confirmBoxRecognized(peerIP: string);
begin
if Assigned(threadReadTCP) then
begin
threadReadTCP.Terminate();
threadReadTCP.WaitFor();
FreeAndNil(threadReadTCP);
end;
if connectBoxTCP(peerIP) then
begin
threadReadTCP := TThreadReadTCP.Create(Self);
showBoxRecognized();
end;
sendBoxRecognized();
end;
I'm using Delphi XE6.
I have a thread where I pass a ID and would like to get back a string created by the thread. I looked at all examples, but they all getting values back when thread is running I just need it OnTerminate.
Calling the thread from a form:
StringReturnedFromThread := PrintThread.Create(MacId);
PrintThread = class(TThread)
private
MyReturnStr, PrinterMacId : String;
public
constructor Create(MacId: String); reintroduce;
procedure OnThreadTerminate(Sender: TObject);
protected
procedure Execute; override;
end;
constructor PrintThread.Create(MacId: String);
begin
inherited Create(False);
OnTerminate := OnThreadTerminate;
FreeOnTerminate := True;
PrinterMacId := MacId;
end;
procedure PrintThread.Execute;
begin
PrepareConnection;
MyReturnStr:= RequestPrintJobs(PrinterMacId);
end;
procedure PrintThread.OnThreadTerminate(Sender: TObject);
begin
end;
Thanks for any help.
You need to intercept thread termination. One way is to use TThread.OnTerminate event/callback.
Below a sample code.
Thread unit:
unit Processes;
interface
uses
System.Classes;
type
TProcess = class(TThread)
private
FReturnStr: string;
FMacId: string;
protected
procedure Execute; override;
public
property MacId: string read FMacId write FMacId;
property ReturnStr: string read FReturnStr write FReturnStr;
constructor Create;
end;
implementation
constructor TProcess.Create;
begin
inherited Create(True);
FreeOnTerminate := True;
end;
procedure TProcess.Execute;
begin
// Some hard calculation here
FReturnStr := FMacId + 'BLA';
end;
end.
Thread usage:
uses Processes;
procedure TForm1.Button1Click(Sender: TObject);
var P: TProcess;
begin
// Create the thread
P := TProcess.Create;
// Initialize it
P.MacId := 'MID123';
// Callback handler
P.OnTerminate := OnProcessTerminate;
// Let's go
P.Start;
end;
procedure TForm1.OnProcessTerminate(Sender: TObject);
var P: TProcess;
begin
// The thread has been terminated
P := TProcess(Sender);
ShowMessage(P.ReturnStr);
end;
The thread will return MID123BLA on it's termination.
I am designing a thread pool with following features.
New thread should be spawned only when all other threads are running.
Maximum number of thread should be configurable.
When a thread is waiting, it should be able to handle new requests.
Each IO operation should call a callback on completion
Thread should have a way to manage request its serving and IO callbacks
Here is the code:
unit ThreadUtilities;
interface
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;
fis32MaxThreadCount : Integer;
FThreadQueue: TThreadQueue;
FHandlePoolEvent: TThreadPoolEvent;
procedure DoHandleThreadExecute(Thread: TThread);
procedure SetMaxThreadCount(const pis32MaxThreadCount : Integer);
function GetMaxThreadCount : Integer;
public
constructor Create( HandlePoolEvent: TThreadPoolEvent; MaxThreads: Integer = 1); virtual;
destructor Destroy; override;
procedure Add(const Data: Pointer);
property MaxThreadCount : Integer read GetMaxThreadCount write SetMaxThreadCount;
end;
implementation
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;
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;
Changed the code as suggested by J... also added critical sections but the problem i am facing now is that when i am trying call multiple task only one thread is being used, Lets say if i added 5 threads in the pool then only one thread is being used which is thread 1. Please check my client code as well in the below section.
procedure TSimpleThread.Execute;
begin
// if Assigned(FExecuteEvent) then
// FExecuteEvent(Self);
while not self.Terminated do begin
try
// FGoEvent.WaitFor(INFINITE);
// FGoEvent.ResetEvent;
EnterCriticalSection(csCriticalSection);
if self.Terminated then break;
if Assigned(FExecuteEvent) then
FExecuteEvent(Self);
finally
LeaveCriticalSection(csCriticalSection);
// HandleException;
end;
end;
end;
In the Add method, how can I check if there is any thread which is not busy, if it is not busy then reuse it else create a new thread and add it in ThreadPool list?
{ TThreadPool }
procedure TThreadPool.Add(const Data: Pointer);
begin
FThreadQueue.Push(Data);
// if FThreads.Count < MaxThreadCount then
// begin
// FThreads.Add(TSimpleThread.Create(False, DoHandleThreadExecute, False));
// end;
end;
constructor TThreadPool.Create(HandlePoolEvent: TThreadPoolEvent;
MaxThreads: Integer);
begin
FHandlePoolEvent := HandlePoolEvent;
FThreadQueue := TThreadQueue.Create;
FThreads := TList.Create;
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;
function TThreadPool.GetMaxThreadCount: Integer;
begin
Result := fis32MaxThreadCount;
end;
procedure TThreadPool.SetMaxThreadCount(const pis32MaxThreadCount: Integer);
begin
fis32MaxThreadCount := pis32MaxThreadCount;
end;
end.
Client Code :
This the client i created to log the data in text file :
unit ThreadClient;
interface
uses Windows, SysUtils, Classes, 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);
procedure SetMaxThreadCount(const pis32MaxThreadCnt : Integer);
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, 5);
end;
destructor TThreadFileLog.Destroy;
begin
FThreadPool.Free;
inherited;
end;
procedure TThreadFileLog.HandleLogRequest(Data: Pointer; AThread: TThread);
var
Request: PLogRequest;
los32Idx : Integer;
begin
Request := Data;
try
for los32Idx := 0 to 100 do
begin
LogToFile(FFileName, IntToStr( AThread.ThreadID) + Request^.LogText);
end;
finally
Dispose(Request);
end;
end;
procedure TThreadFileLog.Log(const LogText: string);
var
Request: PLogRequest;
begin
New(Request);
Request^.LogText := LogText;
FThreadPool.Add(Request);
end;
procedure TThreadFileLog.SetMaxThreadCount(const pis32MaxThreadCnt: Integer);
begin
FThreadPool.MaxThreadCount := pis32MaxThreadCnt;
end;
end.
This is the form application where i added three buttons, each button click will write some value to the file with thread id and text msg. But the problem is thread id is always same
unit ThreadPool;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ThreadClient;
type
TForm5 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
Edit1: TEdit;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Edit1Change(Sender: TObject);
private
{ Private declarations }
fiFileLog : TThreadFileLog;
public
{ Public declarations }
end;
var
Form5: TForm5;
implementation
{$R *.dfm}
procedure TForm5.Button1Click(Sender: TObject);
begin
fiFileLog.Log('Button one click');
end;
procedure TForm5.Button2Click(Sender: TObject);
begin
fiFileLog.Log('Button two click');
end;
procedure TForm5.Button3Click(Sender: TObject);
begin
fiFileLog.Log('Button three click');
end;
procedure TForm5.Edit1Change(Sender: TObject);
begin
fiFileLog.SetMaxThreadCount(StrToInt(Edit1.Text));
end;
procedure TForm5.FormCreate(Sender: TObject);
begin
fiFileLog := TThreadFileLog.Create('C:/test123.txt');
end;
end.
First, and probably most strongly advisable, you might consider using a library like OmniThread to implement a threadpool. The hard work is done for you and you will likely end up making a substandard and buggy product with a roll-your-own solution. Unless you have special requirements this is probably the fastest and easiest solution.
That said, if you want to try to do this...
What you might consider is to just make all of the threads in your pool at startup rather than on-demand. If the server is going to busy at any point then it will eventually end up with a pool of MaxThreadCount soon enough anyway.
In any case, if you want to keep a pool of threads alive and available for work then they would need to follow a slightly different model than what you have written.
Consider:
procedure TSimpleThread.Execute;
begin
if Assigned(FExecuteEvent) then
FExecuteEvent(Self);
end;
Here when you run your thread it will execute this callback and then terminate. This doesn't seem to be what you want. What you seem to want is to keep the thread alive but waiting for its next work package. I use a base thread class (for pools) with an execute method that looks something like this (this is somewhat simplified):
procedure TMyCustomThread.Execute;
begin
while not self.Terminated do begin
try
FGoEvent.WaitFor(INFINITE);
FGoEvent.ResetEvent;
if self.Terminated then break;
MainExecute;
except
HandleException;
end;
end;
end;
Here FGoEvent is a TEvent. The implementing class defines what the work package looks like in the abstract MainExecute method, but whatever it is the thread will perform its work and then return to waiting for the FGoEvent to signal that it has new work to do.
In your case, you need to keep track of which threads are waiting and which are working. You will probably want a manager class of some sort to keep track of these thread objects. Assigning something simple like a threadID to each one seems sensible. For each thread, just before launching it, make a record that it is currently busy. At the very end of your work package you can then post a message back to the manager class telling it that the work is done (and that it can flag the thread as available for work).
When you add work to the queue you can first check for available threads to run the work (or create a new one if you wish to follow the model you outlined). If there are threads then launch the task, if there are not then push the work onto the work queue. When worker threads report complete the manager can check the queue for outstanding work. If there is work it can immediately re-deploy the thread. If there isn't work it can flag the thread as available for work (here you might use a second queue for available workers).
A full implementation is too complex to document in a single answer here - this aims just to rough out some general ideas.
I am implementing a live chat in my deplhi project, which receives new messages by doing GET request to the server. The server itself closes connection after 20 seconds if no new messages occur. Code discribed above is located in a separate thread (it is created on visiting chat "page") so it doesnt freezes the GUI. When i go to a non-chat page from chat, i call this code outside of thread_chat in order to make the thread exit:
if thread_chat <> nil then
begin
thread_chat.Terminate;
thread_chat := nil;
end;
However since my server timeout is 20 seconds, thread actualy closes only when it receives a response (yea, this sounds logically, since my thread loop is while not Terminated do). So what i am looking for is to close HTTP connection in the middle of the request.
Attemp #1
Initially i looked into TerminateThread by calling it like
TerminateThread(thread_chat.Handle, 0)
and this works fine until i try to kill thread on second time - my app completly freezes. So i went to
Attemp #2
I created a global variable URL_HTTP: TIdHTTP and i receive the server page content with this function:
function get_URL_Content(const Url: string): string;
var URL_stream: TStringStream;
begin
URL_HTTP := TIdHTTP.Create(nil);
URL_stream := TStringStream.Create(Result);
URL_HTTP.Get(Url, URL_stream);
if URL_HTTP <> nil then
try
URL_stream.Position := 0;
Result := URL_stream.ReadString(URL_stream.Size);
finally
FreeAndNil(URL_HTTP);
FreeAndNil(URL_stream);
end;
end;
and when i call this code outside of thread_chat
if thread_chat <> nil then
begin
URL_HTTP.Disconnect;
thread_chat.Terminate;
end;
i get EidClosedSocket exception (after some tests while writing this post, i get EAccessViolation error instead).
I run out of ideas. How can i close HTTP request before server response?
procedure thread_chat.Execute; //overrided
begin
while not Terminated do
if check_messages then //sends request to the server, processes response, true if new message(s) exist
show_messages;
end;
Try something like this:
type
TThreadChat = class(TThread)
private
HTTP: TIdHTTP;
function CheckMessages: Boolean;
procedure ShowMessages;
protected
procedure Execute; override;
public
constructor Create;
destructor Destroy; override;
procedure Stop;
end;
constructor TThreadChat.Create;
begin
inherited Create(False);
HTTP := TIdHTTP.Create(nil);
end;
destructor TThreadChat.Destroy;
begin
HTTP.Free;
inherited;
end;
function TThreadChat.CheckMessages: Boolean;
var
Resp: string;
begin
//...
Resp := HTTP.Get(Url);
//...
end;
procedure TThreadChat.ShowMessages;
begin
//...
end;
procedure TThreadChat.Execute;
begin
while not Terminated do
begin
if CheckMessages then
ShowMessages;
end;
end;
procedure TThreadChat.Stop;
begin
Terminate;
try
HTTP.Disconnect;
except
end;
end;
thread_chat := TThreadChat.Create;
...
if thread_chat <> nil then
begin
thread_chat.Stop;
thread_chat.WaitFor;
FreeAndNil(thread_chat);
end;
I have written a program that has been troubled by the network. It was used in the multithreading. The problem is thread output. The program is mixed. And the output does not display correctly.
I have written two sample programs, neither of which work correctly.
Program 1
unit Unit1;
interface
uses
Windows, Classes, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
IdRawBase,IdRawClient, IdIcmpClient, Messages, SysUtils, Variants, Graphics, Controls, Forms,
Dialogs,StdCtrls,ExtCtrls;
type
TPSThread=class(TThread)
protected
procedure execute; override;
end;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
Edit4: TEdit;
Edit5: TEdit;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
Procedure WndProc(var Message: TMessage); Override;
{ Public declarations }
end;
var
Form1: TForm1;
PortG:Integer;
HostG:string;
FormG:TForm;
WM_Msg_PS:DWORD;
implementation
{$R *.dfm}
procedure TPSThread.execute;
var
IcmpClient:TIdIcmpClient;
TCPClient:TIdTCPClient;
HostT:string;
PortT:Integer;
ActiveServer:Boolean;
begin
inherited;
HostT:=HostG;
PortT:=PortG;
IcmpClient:= TIdIcmpClient.Create();
try
with IcmpClient do
begin
ReceiveTimeout := 5000;
Protocol := 1;
ProtocolIPv6 := 0;
PacketSize := 1024;
Host:=HostT;
end;
IcmpClient.Ping(HostT,Random(1024));
if IcmpClient.ReplyStatus.BytesReceived=0 then
begin
SendMessage(FormG.Handle, WM_Msg_PS, Integer(HostT+'*'+IntToStr(1)+'#'), 0);
ActiveServer:=False;
end
else
ActiveServer:=True;
finally
IcmpClient.Free;
end;
if ActiveServer then
begin
TCPClient:=TIdTCPClient.Create(nil);
try
with TCPClient do
begin
Host:=HostT;
Port:=PortT;
try
Connect;
try
IOHandler.WriteLn('salam');
SendMessage(FormG.Handle, WM_Msg_PS, Integer(HostT+'*'+IntToStr(2)+'#'), 0);
finally
Disconnect;
end;
except
SendMessage(FormG.Handle, WM_Msg_PS, Integer(HostT+'*'+IntToStr(3)+'#'), 0);
end;
end;
finally
TCPClient.Free;
end;
end;
end;
procedure PS_System(FormNameForMessage:TForm;HostP:string;PortP:Integer);
var
PSThread:TPSThread;
begin
HostG:=HostP;
PortG:=PortP;
FormG:=FormNameForMessage;
PSThread:=TPSThread.Create(false);
PSThread.FreeOnTerminate:=true;
PSThread.Resume;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Memo1.Clear;
PS_System(form1,Edit1.Text,4321);
PS_System(form1,Edit2.Text,4321);
PS_System(form1,Edit3.Text,4321);
PS_System(form1,Edit4.Text,4321);
PS_System(form1,Edit5.Text,4321);
end;
procedure TForm1.WndProc(var Message: TMessage);
var Id:byte;
Ip:string;
begin
if Message.Msg= WM_Msg_PS then
begin
Ip:=copy(String(Message.WParam),1,pos('*',String(Message.WParam))-1);
id:=strtoint(copy(String(Message.WParam),pos('*',String(Message.WParam))+1,(pos('#',String(Message.WParam))-pos('*',String(Message.WParam))-1)));
case id of
1:
begin
Memo1.Lines.Add(' Server '+ip+' Is inactive ');
//ShowMessage(' Server '+ip+' Is inactive ');
end;
2:
begin
Memo1.Lines.Add(' Message was sent successfully to server '+ip);
//ShowMessage(' Message was sent successfully to server '+ip);
end;
3:
begin
Memo1.Lines.Add(' Send message to the server fails '+ip);
//ShowMessage(' Send message to the server fails '+ip);
end;
end;
end;
inherited;
end;
end.
Program 2
unit Unit1;
interface
uses
Windows, Classes, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
IdRawBase,IdRawClient, IdIcmpClient, Messages, SysUtils, Variants, Graphics, Controls, Forms,
Dialogs,StdCtrls,ExtCtrls;
type
TPSThread=class(TThread)
protected
procedure execute; override;
end;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
Edit4: TEdit;
Edit5: TEdit;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
PortG:Integer;
HostG:string;
WM_Msg_PS:DWORD;
implementation
{$R *.dfm}
procedure IsInactiveServer(M:string);
begin
Form1.Memo1.Lines.Add(' Server '+M+' Is inactive ');
//ShowMessage(' Server '+M+' Is inactive ');
end;
procedure SentSuccessfullyToServer(M:string);
begin
Form1.Memo1.Lines.Add(' Message was sent successfully to server '+M);
//ShowMessage(' Message was sent successfully to server '+M);
end;
procedure SendMessageFails(M:string);
begin
Form1.Memo1.Lines.Add(' Send message to the server fails '+M);
//ShowMessage(' Send message to the server fails '+M);
end;
procedure TPSThread.execute;
var
IcmpClient:TIdIcmpClient;
TCPClient:TIdTCPClient;
HostT:string;
PortT:Integer;
ActiveServer:Boolean;
begin
inherited;
HostT:=HostG;
PortT:=PortG;
IcmpClient:= TIdIcmpClient.Create();
try
with IcmpClient do
begin
ReceiveTimeout := 5000;
Protocol := 1;
ProtocolIPv6 := 0;
PacketSize := 1024;
Host:=HostT;
end;
IcmpClient.Ping(HostT,Random(1024));
if IcmpClient.ReplyStatus.BytesReceived=0 then
begin
IsInactiveServer(HostT);
ActiveServer:=False;
end
else
ActiveServer:=True;
finally
IcmpClient.Free;
end;
if ActiveServer then
begin
TCPClient:=TIdTCPClient.Create(nil);
try
with TCPClient do
begin
Host:=HostT;
Port:=PortT;
try
Connect;
try
IOHandler.WriteLn('salam');
SentSuccessfullyToServer(HostT);
finally
Disconnect;
end;
except
SendMessageFails(HostT);
end;
end;
finally
TCPClient.Free;
end;
end;
end;
procedure PS_System(HostP:string;PortP:Integer);
var
PSThread:TPSThread;
begin
HostG:=HostP;
PortG:=PortP;
PSThread:=TPSThread.Create(false);
PSThread.FreeOnTerminate:=true;
PSThread.Resume;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Memo1.Clear;
PS_System(Edit1.Text,4321);
PS_System(Edit2.Text,4321);
PS_System(Edit3.Text,4321);
PS_System(Edit4.Text,4321);
PS_System(Edit5.Text,4321);
end;
end.
Thank you
But my problem is not the ping
The my problem is the send message.
They also interfere with the thread send message.
If the parts do I remove my ping. Again there is the added problem.
Does this compile? TThread.Execute() is abstract - you cannot call 'inherited' in your descendant 'TPSThread.execute'. Do you not get an error from the compiler?
Creating your TPSThread with 'CreateSuspended' as false means that the thread may run 'immediately'. Setting fields after the Create call may not be effective.
Continually creating and destroying threads is wasteful, inefficient and prone to errors. Try hard not to do it.
If you want your four 'PS_System' calls to perform the network ping operations in a different thread, (so as not to block the main thread), but in sequential order, you should queue the output requests off to one thread that is waiting on a producer-consumer queue to perform them.
Performing ICMP operations in parallel on seperate threads can be problematic since ICMP has no socket layer. PING replies may not be returned to the same thread that issued the request. There is a workaround - the ping payload may contain the requesting thread ID and a 'routing' layer in the ICMP component can work out which waiting thread to make ready. I don't know if the Indy ICMP has implemented this.
The helper procedures that are called from the thread add text to the GUI thread directly. You cannot do that - you must signal correctly.
Multi-threaded PING example, (TCP connection obviously fails - I have no server):
unit foPinger;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Buttons, ExtCtrls, SyncObjs,Contnrs, IdBaseComponent,
IdComponent, IdRawBase, IdRawClient, IdIcmpClient, IdTCPConnection,
IdTCPClient;
type
EthreadRequest=(EtcDoPing,EtcReport,EtcError,EtcSuicide);
TpingRequest=class(TObject) // a thread comms object
command:EthreadRequest;
hostName:string;
port:string;
reportText:string;
errorMess:string;
end;
pObject=^Tobject;
TsemaphoreMailbox=class(TobjectQueue) // Producer-consumer queue
private
countSema:Thandle;
protected
access:TcriticalSection;
public
property semaHandle:Thandle read countSema;
constructor create; virtual;
procedure push(aObject:Tobject); virtual;
function pop(pResObject:pObject;timeout:DWORD):boolean; virtual;
function peek(pResObject:pObject):boolean; virtual;
destructor destroy; override;
end;
TPSThread=class(TThread) // The thread to try the network comms
private
FinQueue:TsemaphoreMailbox;
IcmpClient:TIdIcmpClient;
TCPClient:TIdTCPClient;
ActiveServer:Boolean;
FmyForm:TForm;
protected
procedure execute; override;
public
constructor create(myForm:TForm;inputQueue:TsemaphoreMailbox);
procedure postToMain(mess:TpingRequest);
procedure postReport(text:string);
end;
TpingerForm = class(TForm) // main form
Panel1: TPanel;
sbPing1: TSpeedButton;
ebHostName: TEdit;
Memo1: TMemo;
ebPort: TEdit;
Label1: TLabel;
Label2: TLabel;
ebThreadCount: TEdit;
Label3: TLabel;
procedure sbPing1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure ebThreadCountChange(Sender: TObject);
private
threadCount:integer;
queueToThreads:TsemaphoreMailbox;
protected
procedure WMAPP(var message:Tmessage); message WM_APP;
public
{ Public declarations }
end;
var
pingerForm: TpingerForm;
implementation
{$R *.dfm}
{ TsemaphoreMailbox }
constructor TsemaphoreMailbox.create;
begin
inherited Create;
access:=TcriticalSection.create;
countSema:=createSemaphore(nil,0,maxInt,nil);
end;
destructor TsemaphoreMailbox.destroy;
begin
access.free;
closeHandle(countSema);
inherited;
end;
function TsemaphoreMailbox.pop(pResObject: pObject;
timeout: DWORD): boolean;
// dequeues an object, if one is available on the queue. If the queue is empty,
// the caller is blocked until either an object is pushed on or the timeout
// period expires
begin // wait for a unit from the semaphore
result:=(WAIT_OBJECT_0=waitForSingleObject(countSema,timeout));
if result then // if a unit was supplied before the timeout,
begin
access.acquire;
try
pResObject^:=inherited pop; // get an object from the queue
finally
access.release;
end;
end;
end;
procedure TsemaphoreMailbox.push(aObject: Tobject);
// pushes an object onto the queue. If threads are waiting in a 'pop' call,
// one of them is made ready.
begin
access.acquire;
try
inherited push(aObject); // shove the object onto the queue
finally
access.release;
end;
releaseSemaphore(countSema,1,nil); // release one unit to semaphore
end;
function TsemaphoreMailbox.peek(pResObject: pObject): boolean;
begin
access.acquire;
try
result:=(Count>0);
if result then pResObject^:=inherited pop; // get an object from the queue
finally
access.release;
end;
end;
{ TPSThread }
constructor TPSThread.create(myForm:TForm;inputQueue:TsemaphoreMailbox);
begin
inherited create(true);
FmyForm:=myForm;
FinQueue:=inputQueue;
FreeOnTerminate:=true;
Resume;
end;
procedure TPSThread.postToMain(mess:TpingRequest);
begin
PostMessage(FmyForm.Handle,WM_APP,integer(FmyForm),integer(mess));
end;
procedure TPSThread.postReport(text:string);
var reportMess:TpingRequest;
begin
reportMess:=TpingRequest.Create;
reportMess.command:=EtcReport;
reportMess.reportText:=text;
postToMain(reportMess);
end;
procedure TPSThread.execute;
var inMess:TpingRequest;
ActiveServer:Boolean;
procedure tryConnect;
begin
with IcmpClient do
begin
ReceiveTimeout := 5000;
Protocol := 1;
ProtocolIPv6 := 0;
PacketSize := 1024;
Host:=inMess.hostName;
end;
IcmpClient.Ping(inMess.hostName,Random(1024));
if IcmpClient.ReplyStatus.BytesReceived=0 then
begin
inMess.errorMess:=('PING failed');
ActiveServer:=False;
end
else
ActiveServer:=True;
if ActiveServer then
begin
with TCPClient do
begin
Host:=inMess.hostName;
Port:=strToInt(inMess.port);
try
Connect;
try
IOHandler.WriteLn('salam');
inMess.reportText:='Message was sent successfully to server';
finally
Disconnect;
end;
except
on e:exception do
begin
inMess.errorMess:=('TCP connection failed : '+e.Message);
end;
end;
end;
end;
end;
begin
postReport('PING thread started');
IcmpClient:= TIdIcmpClient.Create(); // make Indy components
TCPClient:=TIdTCPClient.Create(nil);
try
while FinQueue.pop(#inMess,INFINITE) do // wait for message
begin
try
case inMess.command of // switch on command in message
EtcDoPing: tryConnect;
EtcSuicide: begin
inMess.command:=EtcReport;
inMess.reportText:='Thread exit';
exit;
end;
else
begin
inMess.command:=EtcError;;
inMess.errorMess:='Command not understood in PSThread';
end;
end;
finally
postToMain(inMess); // send message back with results
end;
end;
finally
IcmpClient.Free; // free off all the stuff made in ctor
TCPClient.Free;
end;
end;
{ TpingerForm }
procedure TpingerForm.ebThreadCountChange(Sender: TObject);
var newThreads:integer;
suicideMess:TpingRequest;
begin
try
newThreads:=strToInt(ebThreadCount.Text);
while threadCount<newThreads do
begin
TPSThread.create(self,queueToThreads);
inc(threadCount);
end;
while threadCount>newThreads do
begin
suicideMess:=TpingRequest.Create;
suicideMess.command:=EtcSuicide;
queueToThreads.push(suicideMess);
dec(threadCount);
end;
except;
end;
end;
procedure TpingerForm.FormCreate(Sender: TObject);
var editThreadCount:integer;
begin
queueToThreads:=TsemaphoreMailbox.create;
editThreadCount:=strToInt(ebThreadCount.Text);
while(threadCount<editThreadCount) do // make initial number of threads
begin
TPSThread.create(self,queueToThreads);
inc(threadCount);
end;
end;
procedure TpingerForm.sbPing1Click(Sender: TObject);
var outMess:TpingRequest;
begin
outMess:=TpingRequest.Create; // make a thread comms object
outMess.command:=EtcDoPing; // fill up
outMess.hostName:=ebHostName.Text;
outMess.port:=ebPort.Text;
queueToThreads.push(outMess);
end;
// Message-handler for messages from thread
procedure TpingerForm.WMAPP(var message: Tmessage);
var inMess:TpingRequest;
procedure messReport;
begin
memo1.Lines.Add(inMess.reportText);
end;
procedure messError;
begin
memo1.Lines.Add('>*Error*< '+inMess.errorMess);
end;
procedure messPing;
var reportOut:string;
begin
reportOut:='Host '+inMess.hostName+', port: '+inMess.port+', ';
if (inMess.errorMess='') then
reportOut:=reportOut+'comms OK'
else
begin
reportOut:=reportOut+'comms failed: '+inMess.ErrorMess;
end;
memo1.Lines.Add(reportOut);
memo1.Lines.Add('');
end;
begin
inMess:=TpingRequest(message.LParam);
try
case inMess.command of
EtcReport: messReport;
EtcError: messError;
EtcDoPing:messPing;
end;
finally
inMess.Free;
end;
end;
end.
When writing code with threads, you need to understand the the execution order is not guaranteed, as a matter of a fact ,when programming in multi-thread, you should know that code that is not locked(synchronized) could be executed and cause non safe calls and cause data to behave not as expected.
Please read more on threads and understand the case of critical section thread synchronization is a good place to start.
if you need execution order ,then do all the calculation before the printing, wait for all the threads to finish, and then do all the printing. The Downside of this order ,is not real time printing, however, you get clean output.