TCPserver without OnExecute event - delphi

I want to make a TCPserver and send/receive message to clients as needed, not OnExecute event of the TCPserver.
Send/receive message is not a problem; I do like that:
procedure TFormMain.SendMessage(IP, Msg: string);
var
I: Integer;
begin
with TCPServer.Contexts.LockList do
try
for I := 0 to Count-1 do
if TIdContext(Items[I]).Connection.Socket.Binding.PeerIP = IP then
begin
TIdContext(Items[I]).Connection.IOHandler.WriteBuffer(Msg[1], Length(Msg));
// and/or Read
Break;
end;
finally
TCPServer.Contexts.UnlockList;
end;
end;
Note 1: If I don't use OnExecute, the program raise an exception when a client connects.
Note 2: If I use OnExecute without doing anything, the CPU usage goes to %100
Note 3: I don't have a chance to change the TCP clients.
So what should I do?

TIdTCPServer requires an OnExecute event handler assigned by default. To get around that, you would have to derive a new class from TIdTCPServer and override its virtual CheckOkToBeActive() method, and should also override the virtual DoExecute() to call Sleep(). Otherwise, just assign an event handler and have it call Sleep().
This is not an effective use of TIdTCPServer, though. A better design is to not write your outbound data to clients from inside of your SendMessage() method directly. Not only is that error-prone (you are not catching exceptions from WriteBuffer()) and blocks SendMessage() during writing, but it also serializes your communications (client 2 cannot receive data until client 1 does first). A much more effective design is to give each client its own thread-safe outbound queue, and then have SendMessage() put the data into each client's queue as needed. You can then use the OnExecute event to check each client's queue and do the actual writing. This way, SendMessage() does not get blocked anymore, is less error-prone, and clients can be written to in parallel (like they should be).
Try something like this:
uses
..., IdThreadSafe;
type
TMyContext = class(TIdServerContext)
private
FQueue: TIdThreadSafeStringList;
FEvent: TEvent;
public
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TThreadList = nil); override;
destructor Destroy; override;
procedure AddMsgToQueue(const Msg: String);
function GetQueuedMsgs: TStrings;
end;
constructor TMyContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TThreadList = nil);
begin
inherited;
FQueue := TIdThreadSafeStringList.Create;
FEvent := TEvent.Create(nil, True, False, '');
end;
destructor TMyContext.Destroy;
begin
FQueue.Free;
FEvent.Free;
inherited;
end;
procedure TMyContext.AddMsgToQueue(const Msg: String);
begin
with FQueue.Lock do
try
Add(Msg);
FEvent.SetEvent;
finally
FQueue.Unlock;
end;
end;
function TMyContext.GetQueuedMsgs: TStrings;
var
List: TStringList;
begin
Result := nil;
if FEvent.WaitFor(1000) <> wrSignaled then Exit;
List := FQueue.Lock;
try
if List.Count > 0 then
begin
Result := TStringList.Create;
try
Result.Assign(List);
List.Clear;
except
Result.Free;
raise;
end;
end;
FEvent.ResetEvent;
finally
FQueue.Unlock;
end;
end;
procedure TFormMain.FormCreate(Sender: TObject);
begin
TCPServer.ContextClass := TMyContext;
end;
procedure TFormMain.TCPServerExecute(AContext: TIdContext);
var
List: TStrings;
I: Integer;
begin
List := TMyContext(AContext).GetQueuedMsgs;
if List = nil then Exit;
try
for I := 0 to List.Count-1 do
AContext.Connection.IOHandler.Write(List[I]);
finally
List.Free;
end;
end;
procedure TFormMain.SendMessage(const IP, Msg: string);
var
I: Integer;
begin
with TCPServer.Contexts.LockList do
try
for I := 0 to Count-1 do
begin
with TMyContext(Items[I]) do
begin
if Binding.PeerIP = IP then
begin
AddMsgToQueue(Msg);
Break;
end;
end;
end;
finally
TCPServer.Contexts.UnlockList;
end;
end;

Use OnExecute and if you have nothing to do, Sleep() for a period of time, say 10 milliseconds. Each connection has its own OnExecute handler so this will only affect each individual connection.

In the OnExecute handler, you can use thread communication methods like TEvent and TMonitor to wait until there is data for the client.
TMonitor is available since Delphi 2009 and provides methods (Wait, Pulse and PulseAll) to send / receive notifications with mininmal CPU usage.

The Indy component set is designed to emulate blocking operation on a network connection. You're supposed to encapsulate all your code in the OnExecute event handler. That's supposed to be easier, because most protocols are blocking any way (send command, wait for response, etc).
You apparently don't like it's mode of operation, you'd like something that works without blocking. You should consider using a component suite that's designed for the way you intend to use it: give the ICS suite a try! ICS doesn't use threads, all the work is done in event handlers.

I had similar situation taking 100% CPU and it solved by adding IdThreadComponent and:
void __fastcall TForm3::IdThreadComponent1Run(TIdThreadComponent *Sender)
{
Sleep(10);
}
Is it right? I am not sure.

Related

Delphi TThread handle error

I am reading "Delphi High performance" and there is something that I am missing. Given this code as test:
type TTest = class(TThread)
private
amemo: TMemo;
public
constructor Create(ss: boolean; memo: TMemo);
protected
procedure Execute; override;
end;
constructor TTest.Create(ss: boolean; memo: TMemo);
begin
inherited Create(ss);
FreeOnTerminate := true;
amemo := memo;
end;
procedure TTest.Execute;
var i: uint32;
begin
inherited;
i := 0;
while not Terminated do
begin
Inc(i);
Synchronize(procedure
begin amemo.Lines.Add(i.ToString) end);
Sleep(1000);
end;
end;
Very simply, this thread prints some numbers in a memo. I start the thread suspended and so I have to call this piece of code:
procedure TForm1.Button1Click(Sender: TObject);
begin
thread := TTest.Create(true, Memo1);
thread.Start;
end;
I have always stopped the thread calling thread.Terminate; but reading the book I see that Primoz stops a thread like this:
procedure TForm1.Button2Click(Sender: TObject);
begin
thread.Terminate;
thread.WaitFor; //he adds this method call
//FreeAndNil(thread)
//there is the above line as well in the code copied from the book but I have removed it since I have set FreeOnTerminate := true (so I dont have to worry about freeing the obj).
end;
At this point, if I run the code using only Terminate I have no problems. If I run the code with Terminate + WaitFor I get this error:
I have read more coding in delphi too and I see that Nick Hodges just makes a call to Terminate;. Is calling Terminate; enough to safey stop a thread? Note that I've set FreeOnTerminate := true so I don't care about the death of the object. Terminated should stop the execution (what is inside execute) and so it should be like this:
Call Terminated
Execute stops
Thread stops execution
Thread is now free (FreeOnTerminate := true)
Please tell me what I'm missing.
Note.
In the book the thread doesn't have FreeOnTerminate := true. So the thread needs to be freed manually; I guess that this is the reason why he calls
thread.Terminate;
thread.WaitFor;
FreeAndNil(thread)
I agree on Terminate (stop the thread= and FreeAndNil (free the object manually) but the WaitFor?
Please tell me what I'm missing.
The documentation for FreeOnTerminate explicitly says that you cannot use the Thread in any way after Terminate.
That includes your WaitFor call, which would work on a possibly already free'd object. This use-after-free can trigger the error above, among other even more "interesting" behaviours.

Receive partial data with timeout using TIdTcpClient

How to receive a 100-byte-string with following conditions using TIdTcpClient ?:
If nothing comes in, the Read call shall be blocking and thread will wait eternally
If 100 bytes were received the Read call should return the byte string
If more than 0 bytes, but less than 100 were received, Read call should return after some timeout (say 1 second) in order to return at least something in a reasonable time, without producing timeout exception, because exception handling in Delphi IDE's debug mode hasn't been made convenient.
My not optimal code for now is as follows:
unit Unit2;
interface
uses
System.Classes, IdTCPClient;
type
TTcpReceiver = class(TThread)
private
_tcpc: TIdTCPClient;
_onReceive: TGetStrProc;
_buffer: AnsiString;
procedure _receiveLoop();
procedure _postBuffer;
protected
procedure Execute(); override;
public
constructor Create(); reintroduce;
destructor Destroy(); override;
property OnReceive: TGetStrProc read _onReceive write _onReceive;
end;
implementation
uses
System.SysUtils, Vcl.Dialogs, IdGlobal, IdExceptionCore;
constructor TTcpReceiver.Create();
begin
inherited Create(True);
_buffer := '';
_tcpc := TIdTCPClient.Create(nil);
//_tcpc.Host := '192.168.52.175';
_tcpc.Host := '127.0.0.1';
_tcpc.Port := 1;
_tcpc.ReadTimeout := 1000;
_tcpc.Connect();
Suspended := False;
end;
destructor TTcpReceiver.Destroy();
begin
_tcpc.Disconnect();
FreeAndNil(_tcpc);
inherited;
end;
procedure TTcpReceiver.Execute;
begin
_receiveLoop();
end;
procedure TTcpReceiver._postBuffer();
var buf: string;
begin
if _buffer = '' then Exit;
buf := _buffer;
_buffer := '';
if Assigned(_onReceive) then begin
Synchronize(
procedure()
begin
_onReceive(buf);
end
);
end;
end;
procedure TTcpReceiver._receiveLoop();
var
c: AnsiChar;
begin
while not Terminated do begin
try
c := AnsiChar(_tcpc.IOHandler.ReadByte());
_buffer := _buffer + c;
if Length(_buffer) > 100 then
_postBuffer();
except
//Here I have to ignore EIdReadTimeout in Delphi IDE everywhere, but I want just to ignore them here
on ex: EIdReadTimeout do _postBuffer();
end;
end;
end;
end.
TCP is stream oriented, not message oriented like UDP is. Reading arbitrary bytes without any structure to them is bad design, and will easily corrupt your communications if you stop reading prematurely and then the bytes you wanted to read arrive after you have stopped reading. The bytes are not removed from the socket until they are read, so the next read may have more/different bytes than expected.
If you are expecting 100 bytes, then just read 100 bytes and be done with it. If the sender only sends 50 bytes, it needs to tell you that ahead of time so you can stop reading after 50 bytes are received. If the sender is not doing that, then this is a very poorly designed protocol. Using a timeout to detect end-of-transmission in general is bad design. Network lag could easily cause false detections.
TCP messages should be adequately framed so that the receiver knows exactly where one message ends and the next message begins. There are three ways to do that in TCP:
use fixed-length messages. The receiver can keep reading until the expected number of bytes has arrived.
send a message's length before sending the message itself. The receiver can read the length first and then keep reading until the specified number of bytes has arrived.
terminate a message with a unique delimiter that does not appear in the message data. The receiver can keep reading bytes until that delimiter has arrived.
That being said, what you are asking for can be done in TCP (but shouldn't be done in TCP!). And it can be done without using a manual buffer at all, use Indy's built-in buffer instead. For example:
unit Unit2;
interface
uses
System.Classes, IdTCPClient;
type
TTcpReceiver = class(TThread)
private
_tcpc: TIdTCPClient;
_onReceive: TGetStrProc;
procedure _receiveLoop;
procedure _postBuffer;
protected
procedure Execute; override;
public
constructor Create; reintroduce;
destructor Destroy; override;
property OnReceive: TGetStrProc read _onReceive write _onReceive;
end;
implementation
uses
System.SysUtils, Vcl.Dialogs, IdGlobal;
constructor TTcpReceiver.Create;
begin
inherited Create(False);
_tcpc := TIdTCPClient.Create(nil);
//_tcpc.Host := '192.168.52.175';
_tcpc.Host := '127.0.0.1';
_tcpc.Port := 1;
end;
destructor TTcpReceiver.Destroy;
begin
_tcpc.Free;
inherited;
end;
procedure TTcpReceiver.Execute;
begin
_tcpc.Connect;
try
_receiveLoop;
finally
_tcpc.Disconnect;
end;
end;
procedure TTcpReceiver._postBuffer;
var
buf: string;
begin
with _tcpc.IOHandler do
buf := ReadString(IndyMin(InputBuffer.Size, 100));
{ alternatively:
with _tcpc.IOHandler.InputBuffer do
buf := ExtractToString(IndyMin(Size, 100));
}
if buf = '' then Exit;
if Assigned(_onReceive) then
begin
Synchronize(
procedure
begin
if Assigned(_onReceive) then
_onReceive(buf);
end
);
end;
end;
procedure TTcpReceiver._receiveLoop;
var
LBytesRecvd: Boolean;
begin
while not Terminated do
begin
while _tcpc.IOHandler.InputBufferIsEmpty do
begin
_tcpc.IOHandler.CheckForDataOnSource(IdTimeoutInfinite);
_tcpc.IOHandler.CheckForDisconnect;
end;
while _tcpc.IOHandler.InputBuffer.Size < 100 do
begin
// 1 sec is a very short timeout to use for TCP.
// Consider using a larger timeout...
LBytesRecvd := _tcpc.IOHandler.CheckForDataOnSource(1000);
_tcpc.IOHandler.CheckForDisconnect;
if not LBytesRecvd then Break;
end;
_postBuffer;
end;
end;
end.
On a side note, your statement that "exception handling in Delphi IDE's debug mode hasn't been made convenient" is simply ridiculous. Indy's IOHandler has properties and method parameters for controlling exception behavior, and also if you don't like the way the debugger handles exceptions then simply configure it to ignore them. You can configure the debugger to ignore specific exception types, or you can use breakpoints to tell the debugger to skip handling exceptions in specific blocks of code.

IdMappedPortTCP deactivating issue

I have one external program which doesn't support proxy to access internet and but I need proxy.
As a solution, I've written one simple Delphi Application using Indy 10.6.0.5040 and its TIdMappedPortTCP component. How it works simply, external application connects to IdMappedPortTCP locally and IdMappedPortTCP connects to real server using my proxy settings.
To do my proxy setting, I handled OnConnect event of IdMappedPortTCP like below:
procedure TForm1.IdMappedPortTCP1Connect(AContext: TIdContext);
var
io: TIdIOHandlerStack;
proxy: TIdConnectThroughHttpProxy;
begin
if Assigned(TIdMappedPortContext(AContext).OutboundClient) then
begin
io := TIdIOHandlerStack.Create(TIdMappedPortContext(AContext).OutboundClient);
proxy := TIdConnectThroughHttpProxy.Create(io);
proxy.Enabled := False;
proxy.Host := FSettings.ProxyAddress;
proxy.Port := FSettings.ProxyPort;
proxy.Username := FSettings.ProxyUserName;
proxy.Password := FSettings.ProxyPassword;
If (proxy.Username <> '') or (proxy.Password <> '') then proxy.AuthorizationRequired(True);
proxy.Enabled := True;
io.DefaultPort := FSettings.DestinationPort[0];
io.Port := FSettings.DestinationPort[0];
io.Destination := FSettings.DestinationHostAddress[0];
io.Host := FSettings.DestinationHostAddress[0];
io.TransparentProxy := proxy;
io.OnStatus := StackStatus;
TIdMappedPortContext(AContext).OutboundClient.IOHandler := io;
end;
Log(Format('Listener connected at %s:%d', [TIdMappedPortContext(AContext).Server.MappedHost, TIdMappedPortContext(AContext).Server.MappedPort]));
end;
{ TIdConnectThroughHttpProxyHelper }
procedure TIdConnectThroughHttpProxyHelper.AuthorizationRequired(const val: boolean);
begin
Self.FAuthorizationRequired := val;
end;
procedure TForm1.Log(const s: string);
begin
Memo1.Lines.Add(Format('(%s) %s', [FormatDateTime('hh:nn:ss:zzz', Now), s]));
end;
procedure TForm1.IdMappedPortTCP1Disconnect(AContext: TIdContext);
begin
// Log(Format('Listener disconnected at %s:%d', [TIdMappedPortContext(AContext).Server.MappedHost, TIdMappedPortContext(AContext).Server.MappedPort]));
end;
procedure TForm1.IdMappedPortTCP1Exception(AContext: TIdContext;
AException: Exception);
begin
Log(Format('Exception: %s (%s:%d)', [AException.Message,TIdMappedPortContext(AContext).Server.MappedHost, TIdMappedPortContext(AContext).Server.MappedPort]));
end;
procedure TForm1.IdMappedPortTCP1ListenException(AThread: TIdListenerThread;
AException: Exception);
begin
Log(Format('Listener Exception: %s', [AException.Message]));
end;
procedure TForm1.IdMappedPortTCP1OutboundConnect(AContext: TIdContext);
begin
Log('MappedPort Destination connected.');
end;
procedure TForm1.IdMappedPortTCP1OutboundDisconnect(AContext: TIdContext);
begin
Log('MappedPort Destination disconnected.');
end;
procedure TForm1.StackStatus(ASender: TObject;
const AStatus: TIdStatus; const AStatusText: string);
begin
Log(Format('Stack Status: %s', [AStatusText]));
end;
I have many active connections and all work flawlessly. My problem is that, if I try to deactivate IdMappedPortTCP using "IdMappedPortTCP.Active := false;" while there are active traffics, connections, it hangs there and I had to terminate delphi application using task manager.
Is there anything that I need to do manually before setting Active to false?
Thanks.
Indy servers are multi-threaded. Their events (like OnConnect, OnDisconnect, OnExecute, OnException, and OnListenException) are triggered in the context of worker threads, not the context of the main UI thread. As such, you must sync with the main thread, such as with the TThread.Synchronize() or TThread.Queue() methods, or Indy's TIdSync or TIdNotify classes, in order to access UI components safely.
If the main thread is busy deactivating the server, it cannot process sync requests, so an asynchronous approach (TThread.Queue() or
TIdNotify) is preferred over a synchronous one (TThread.Synchronize() or TIdSync) to avoid a deadlock. Alternatively, deactivate the server in a worker thread so the main thread is free to process sync requests.

TCPClient : Custom timeout time

I need to set custom timeout for TTcpClient. I think the default timeout time is about 20-25 seconds but I need to change it to 500ms. Is it possible And How?
procedure TForm1.Button1Click(Sender: TObject);
begin
TcpClient2.RemoteHost := '192.168.1.1';
TcpClient2.RemotePort := '23';
TcpClient2.Connect;
tcpclient2.Receiveln();
tcpclient2.Sendln('admin');
tcpclient2.Receiveln;
end;
I tried non-blocking option but the software returns an error after I click on button And I have to do it again 4-5 times. Any help?
Thanks :)
Winsock has no connect timeout, but this can be overcomed.
You have several options:
Without threads:
Using non-blocking mode: call Connect, then wait using Winsock select function (encapsulated in TBaseSocket Select method inherited by TTcpClient).
Using blocking mode: changing temporarily to non-blocking mode and proceeding as in the previous case.
With threads: see Remy Lebeau's answer to How to control the connect timeout with the Winsock API?.
Use Indy.
Blocking vs non-blocking
Using blocking or non-blocking mode is a very important design decision that will affect many of your code and which you can't easily change afterward.
For example, in non-blocking mode, receive functions (as Receiveln), will not wait until there is enough input available and could return with an empty string. This can be an advantage if is this what you need, but you need to implement some strategy, such as waiting using TcpClient.WaitForData before calling the receive function (in your example, the Receiveln-Sendln-Receiveln will not work as is).
For simple tasks, blocking mode is easier to deal with.
Non-blocking mode
The following function will wait until the connection is successful or the timeout elapses:
function WaitUntilConnected(TcpClient: TTcpClient; Timeout: Integer): Boolean;
var
writeReady, exceptFlag: Boolean;
begin
// Select waits until connected or timeout
TcpClient.Select(nil, #writeReady, #exceptFlag, Timeout);
Result := writeReady and not exceptFlag;
end;
How to use:
// TcpClient.BlockMode must be bmNonBlocking
TcpClient.Connect; // will return immediately
if WaitUntilConnected(TcpClient, 500) then begin // wait up to 500ms
... your code here ...
end;
Also be aware of the following drawbacks/flaws in TTcpClient's non-blocking mode design:
Several functions will call OnError with SocketError set to WSAEWOULDBLOCK (10035).
Connected property will be false because is assigned in Connect.
Blocking mode
Connection timeout can be achieved by changing to non-blocking mode after socket is created but before calling Connect, and reverting back to blocking mode after calling it.
This is a bit more complicated because TTcpClient closes the connection and the socket if we change BlockMode, and also there is not direct way of creating the socket separately from connecting it.
To solve this, we need to hook after socket creation but before connection. This can be done using either the DoCreateHandle protected method or the OnCreateHandle event.
The best way is to derive a class from TTcpClient and use DoCreateHandle, but if for any reason you need to use TTcpClient directly without the derived class, the code can be easily rewriten using OnCreateHandle.
type
TExtendedTcpClient = class(TTcpClient)
private
FIsConnected: boolean;
FNonBlockingModeRequested, FNonBlockingModeSuccess: boolean;
protected
procedure Open; override;
procedure Close; override;
procedure DoCreateHandle; override;
function SetBlockModeWithoutClosing(Block: Boolean): Boolean;
function WaitUntilConnected(Timeout: Integer): Boolean;
public
function ConnectWithTimeout(Timeout: Integer): Boolean;
property IsConnected: boolean read FIsConnected;
end;
procedure TExtendedTcpClient.Open;
begin
try
inherited;
finally
FNonBlockingModeRequested := false;
end;
end;
procedure TExtendedTcpClient.DoCreateHandle;
begin
inherited;
// DoCreateHandle is called after WinSock.socket and before WinSock.connect
if FNonBlockingModeRequested then
FNonBlockingModeSuccess := SetBlockModeWithoutClosing(false);
end;
procedure TExtendedTcpClient.Close;
begin
FIsConnected := false;
inherited;
end;
function TExtendedTcpClient.SetBlockModeWithoutClosing(Block: Boolean): Boolean;
var
nonBlock: Integer;
begin
// TTcpClient.SetBlockMode closes the connection and the socket
nonBlock := Ord(not Block);
Result := ErrorCheck(ioctlsocket(Handle, FIONBIO, nonBlock)) <> SOCKET_ERROR;
end;
function TExtendedTcpClient.WaitUntilConnected(Timeout: Integer): Boolean;
var
writeReady, exceptFlag: Boolean;
begin
// Select waits until connected or timeout
Select(nil, #writeReady, #exceptFlag, Timeout);
Result := writeReady and not exceptFlag;
end;
function TExtendedTcpClient.ConnectWithTimeout(Timeout: Integer): Boolean;
begin
if Connected or FIsConnected then
Result := true
else begin
if BlockMode = bmNonBlocking then begin
if Connect then // will return immediately, tipically with false
Result := true
else
Result := WaitUntilConnected(Timeout);
end
else begin // blocking mode
// switch to non-blocking before trying to do the real connection
FNonBlockingModeRequested := true;
FNonBlockingModeSuccess := false;
try
if Connect then // will return immediately, tipically with false
Result := true
else begin
if not FNonBlockingModeSuccess then
Result := false
else
Result := WaitUntilConnected(Timeout);
end;
finally
if FNonBlockingModeSuccess then begin
// revert back to blocking
if not SetBlockModeWithoutClosing(true) then begin
// undesirable state => abort connection
Close;
Result := false;
end;
end;
end;
end;
end;
FIsConnected := Result;
end;
How to use:
TcpClient := TExtendedTcpClient.Create(nil);
try
TcpClient.BlockMode := bmBlocking; // can also be bmNonBlocking
TcpClient.RemoteHost := 'www.google.com';
TcpClient.RemotePort := '80';
if TcpClient.ConnectWithTimeout(500) then begin // wait up to 500ms
... your code here ...
end;
finally
TcpClient.Free;
end;
As noted before, Connected doesn't work well with non-blocking sockets, so I added a new IsConnected property to overcome this (only works when connecting with ConnectWithTimeout).
Both ConnectWithTimeout and IsConnected will work with both blocking and non-blocking sockets.

Indy10 Deadlock at TCPServer

to write information on the processing state to the GUI inside a tcpserver.onexecute(..) function , i used the following command sequence
ExecuteDUMMYCommand(Global_Send_Record);
BitMap_PaintImageProcess;
TThread.Synchronize(nil, BitMap_PaintImageProcess);
The code is working well on some machines, but on a few it fails. The code execution stops atTThread.Synchronize command. I guess on these machines the function call is trapped inside a deadlock
Any chance to figure out the real problem behind ?
The procedure BitMap_PaintImageProcess , here I create a Bitmap and do a lot of painting stuff , but is seems that this code is never executed ?
I try to explain the very long code and reduce to the main points , the critical thread issues are hidden in processing the bitmap inside my Bitmapprocessingclass.
This class is accessed inside the GUIProcessing procedures of my ServerMainForm which also has the INDY TCP Server component.
{--------------- CLASS DEFINITION -----------------------------}
TBitMapProcessingClass = class()
FBitmap : TBitmap;
FList : TListOfSomething;
procedure ProcessTheBitmap(....);
......
(many many functions);
procedure Init;
procedure Free;
Procedure Create;
end;
TMainform = class(TForm)
MyServer : TIdTCPServer;
aBitMaoProcessingClass : TBitMaoProcessingClass;
procedure BitMap_PaintImageProcess;
procedure BitMap_ListProcess;
.....
end;
{------------------------- Implemantation ------------------------------}
procedure TMainform.IndyTCPServer.Onexecute()
begin
.......
ExecuteDUMMYCommand(Global_Send_Record);
BitMap_PaintImageProcess;
TThread.Synchronize(nil, BitMap_PaintImageProcess);
.......
end;
procedure TMainform.BitMap_PaintImageProcess;
begin
DoSomeServerVCLStuff(....);
aBitMapProcessingClass.ProcessTheBitmap;
DoSomeServerVCLStuff(....);
end;
Having no idea what BitMap_PaintImageProcess() does in fact, I have a few suppositions:
In the TThread.Synchronize call you try to read some data from the socket/idContext, but the data is not yet available. This will block the main thread until the data becomes available. But Indy's thread that is responsible for reading from the underlying socket buffer is currently blocked by your TThread.Synchronize call in the OnExecute event i.e. deadlock occurs;
In the TThread.Synchronize call you use Application.ProcessMessages (a common mistake);
In the OnExecute event you enter a critical section. Then during the TThread.Synchronize call you try to enter the same critical section again;
You modify the GUI in the onExecute event. Because onExecute is not thread safe, accessing VCL/FM from Indy's thread could lead to unpredictable results, including random deadlocks (hard to find).
I would suggest to use MadExcept / Eurekalog. They both have options to check if the main thread is "frozen". When that happens (during the deadlock) they will show you the current call stack. Having the call stack you can figure out which function is causing the deadlock.
Regarding the posted code:
procedure TMainform.IndyTCPServer.Onexecute()
begin
.......
ExecuteDUMMYCommand(Global_Send_Record);
BitMap_PaintImageProcess; //-> You do VCL stuff in the context of Indy's thread!
TThread.Synchronize(nil, BitMap_PaintImageProcess);
end;
In the BitMap_PaintImageProcess() you call DoSomeServerVCLStuff(....). Do not forget that OnExecute is fired from Indy's thread for the current context. I.e. you modify VCL from another thread (other from the Main Thread) which is not thread safe.
On your comment:
...but here my complex TBitmap processing Class must be alive the whole
time my Server is active...
If you have only one (global) instance for image processing, then what will happen if another client connects, while you are still processing the old connection (think Parallel :) )? Your image processing class should be instantiated separately for each new connection/context. For GUI updating you can use TIdNotify descendant.
A possible solution:
type
{ tIdNotify Stuff }
TVclProc= procedure(imgClass: tMyImageProcessingClass) of object;
tIdNotifyDescendant = (tIdNotify)
protected
fImgClass: tMyImageProcessingClass;
fProc: TVclProc;
procedure DoNotify; override;
public
class procedure updateVcl(imgClass: tMyImageProcessingClass; vclProc: TVclProc);
end;
procedure tIdNotifyDescendant.DoNotify;
begin
inherited DoNotify;
FProc(fImgClass);
end;
class procedure tIdNotifyDescendant.updateVcl(imgClass: tMyImageProcessingClass; vclProc: TVclProc);
begin
with Create do
begin
fImgClass := imgClass;
fProc := vclProc;
Notify;
end;
end;
{ Indy stuff & other logic }
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
begin
// Create your instance when the client connects
AContext.Data := tMyImageProcessingClass.Create;
end;
procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
begin
// Do cleanup
if assinged(AContext.Data) then
(AContext.Data as tMyImageProcessingClass).Free // Casting just for clarity
end;
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
imgProcClass: tMyImageProcessingClass;
begin
imgProcClass := acontext.Data as tMyImageProcessingClass;
// Do image processing
// Notify GUI for the progress:
tIdNotifyDescendant.updateVcl(AContext.data as tMyImageProcessingClass);
end;
Tip: If you do JPEG processing and you use Draw() method have in mind this: TJPEGImage.Draw() is not thread safe
I added a few more details on my BitmapProcessingclass and the idea of a thread safe extension of the existing class...
I need the existing class u nchanged in others apps ... I need a extension inside my app with the indy server.
ONly one client my connect to one server, or he has to query the state of the server
type TBmpNotify = class(TIdNotify)
protected
FBMP: MyImageProcessingClass;
procedure DoNotify; override;
public
constructor Create(aBMP: MyImageProcessingClass);
function SetImageView(LL, UR: TPoint): Boolean;
procedure PaintBitMap;
function InitBitMap(x, y: Integer;
PixelFormat: TPixelFormat = pf24bit): Boolean;
destructor free;
end;
implementation
{ TBmpNotify }
constructor TBmpNotify.Create(aBMP: MyImageProcessingClass);
begin
// indise this class I also create
// class.TBitmap
// class.TList
// much more stuff ....
FBmp := MyImageProcessingClass.Create;
end;
procedure TBmpNotify.DoNotify;
begin
inherited;
end;
destructor TBmpNotify.free;
begin
FBmp.Free;
inherited;
end;
function TBmpNotify.InitBitMap(x, y: Integer;
PixelFormat: TPixelFormat): Boolean;
begin
// Write values to the List
// also modify TBitmap
// execution time of this function ~ 5 min
FBmp.InitBitMap(x,y,PixelFormat)
end;
procedure TBmpNotify.PaintBitMap;
begin
// much TBitmap, bitmap.canvas .... is used
// execution time of this function ~ 1 min
FBmp.PaintBitMap;
end;
function TBmpNotify.SetImageView(LL, UR: TPoint): Boolean;
begin
// this function takes about 1 min
FBmp.SetImageView(LL, UR);
end;
end.

Resources