Thread open forms in Delphi - forms

I want to create new instances of form(and show them) from a Thread. But it seems that it freeze my application and my thread(my thread becomes an non syncrhonization thread, and it freeze my aplication).
Like this(but it doesn't make what i am looking for)
procedure a.Execute;
var frForm:TForm;
B:TCriticalSection;
begin
b:=TCriticalSection.Create;
while 1=1 do
begin
b.Enter;
frForm:=TForm.Create(Application);
frForm.Show;
b.Leave;
sleep(500); //this sleep with sleep my entire application and not only the thread.
//sleep(1000);
end;
end;
I don't want to use Classes.TThread.Synchronize method

TThread.Synchronize() is the simplest solution:
procedure a.Execute;
begin
while not Terminated do
begin
Synchronize(CreateAndShowForm);
Sleep(500);
end;
end;
procedure a.CreateAndShowForm;
var
frForm:TForm;
begin
frForm:=TForm.Create(Application);
frForm.Show;
end;
If you are using a modern version of Delphi and don't need to wait for the TForm creation to complete before letting the thread move on, you could use TThread.Queue() instead:
procedure a.Execute;
begin
while not Terminated do
begin
Queue(CreateAndShowForm);
Sleep(500);
end;
end;
Update: If you want to use PostMessage(), the safest option is to post your messages to either the TApplication window or a dedicated window created via AllocateHWnd(), eg:
const
WM_CREATE_SHOW_FORM = WM_USER + 1;
procedure TMainForm.FormCreate(Sender: TObject);
begin
Application.OnMessage := AppMessage;
end;
procedure TMainForm.AppMessage(var Msg: TMsg; var Handled: Boolean);
var
frForm:TForm;
begin
if Msg.message = WM_CREATE_SHOW_FORM then
begin
Handled := True;
frForm := TForm.Create(Application);
frForm.Show;
end;
end;
procedure a.Execute;
begin
while not Terminated do
begin
PostMessage(Application.Handle, WM_CREATE_SHOW_FORM, 0, 0);
Sleep(500);
end;
end;
.
const
WM_CREATE_SHOW_FORM = WM_USER + 1;
var
ThreadWnd: HWND = 0;
procedure TMainForm.FormCreate(Sender: TObject);
begin
ThreadWnd := AllocateHWnd(ThreadWndProc);
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
DeallocateHwnd(ThreadWnd);
ThreadWnd := 0;
end;
procedure TMainForm.ThreadWndProc(var Message: TMessage);
var
frForm:TForm;
begin
if Message.Msg = WM_CREATE_SHOW_FORM then
begin
frForm := TForm.Create(Application);
frForm.Show;
end else
Message.Result := DefWindowProc(ThreadWnd, Message.Msg, Message.WParam, Message.LParam);
end;
procedure a.Execute;
begin
while not Terminated do
begin
PostMessage(ThreadWnd, WM_CREATE_SHOW_FORM, 0, 0);
Sleep(500);
end;
end;

You cannot create a notoriously thread-unsafe VCL form in this way, (note - it's not just Delphi - all GUI development I have seen has this restriction). Either use TThread.Synchronize to signal the main thread to create the form, or use some other signaling mechanism like the PostMessage() API.
Overall, it's best to try an keep GUI stuff out of secondary threads, as far as you can. Secondary threads are better used for non-GUI I/O and/or CPU-intensive operations, (especially if they can be split up and be performed in parallel).
PostMessage example, (the form has just one speedbutton on it):
unit mainForm;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Buttons;
const
CM_OBJECTRX=$8FF0;
type
EmainThreadCommand=(EmcMakeBlueForm,EmcMakeGreenForm,EmcMakeRedForm);
TformMakerThread = class(TThread)
protected
procedure execute; override;
public
constructor create;
end;
TForm1 = class(TForm)
SpeedButton1: TSpeedButton;
procedure SpeedButton1Click(Sender: TObject);
private
myThread:TformMakerThread;
protected
procedure CMOBJECTRX(var message:Tmessage); message CM_OBJECTRX;
end;
var
Form1: TForm1;
ThreadPostWindow:Thandle;
implementation
{$R *.dfm}
{ TForm1 }
procedure TForm1.CMOBJECTRX(var message: Tmessage);
var thisCommand:EmainThreadCommand;
procedure makeForm(formColor:integer);
var newForm:TForm1;
begin
newForm:=TForm1.Create(self);
newForm.Color:=formColor;
newForm.Show;
end;
begin
thisCommand:=EmainThreadCommand(message.lparam);
case thisCommand of
EmcMakeBlueForm:makeForm(clBlue);
EmcMakeGreenForm:makeForm(clGreen);
EmcMakeRedForm:makeForm(clRed);
end;
end;
function postThreadWndProc(Window: HWND; Mess, wParam, lParam: Longint): Longint; stdcall;
begin
result:=0;
if (Mess=CM_OBJECTRX) then
begin
try
TControl(wparam).Perform(CM_OBJECTRX,0,lParam);
result:=-1;
except
on e:exception do application.messageBox(PChar(e.message),PChar('PostToMainThread perform error'),MB_OK);
end;
end
else
Result := DefWindowProc(Window, Mess, wParam, lParam);
end;
var
ThreadPostWindowClass: TWndClass = (
style: 0;
lpfnWndProc: #postThreadWndProc;
cbClsExtra: 0;
cbWndExtra: 0;
hInstance: 0;
hIcon: 0;
hCursor: 0;
hbrBackground: 0;
lpszMenuName: nil;
lpszClassName: 'TpostThreadWindow');
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
TformMakerThread.create;
end;
{ TformMakerThread }
constructor TformMakerThread.create;
begin
inherited create(true);
freeOnTerminate:=true;
resume;
end;
procedure TformMakerThread.execute;
begin
while(true) do
begin
postMessage(ThreadPostWindow,CM_OBJECTRX,integer(Form1),integer(EmcMakeBlueForm));
sleep(1000);
postMessage(ThreadPostWindow,CM_OBJECTRX,integer(Form1),integer(EmcMakeGreenForm));
sleep(1000);
postMessage(ThreadPostWindow,CM_OBJECTRX,integer(Form1),integer(EmcMakeRedForm));
sleep(1000);
end;
end;
initialization
Windows.RegisterClass(ThreadPostWindowClass);
ThreadPostWindow:=CreateWindow(ThreadPostWindowClass.lpszClassName, '', 0,
0, 0, 0, 0, 0, 0, HInstance, nil);
finalization
DestroyWindow(ThreadPostWindow);
end.

Just use the "TThread.Synchronize" static method, as it is static and public it can be used even outside the thread
TThread.Synchronize(MyThread, procedure begin Myform.Show(); end);
at least in this event, in the others if "MyForm.DoubleBuffered: = true;" you will have no sync problems, but anything can call the "Application.ProcessMessages ();" method in sync.

Related

Prevent TIdTcpServer Stuck Connections

how are you?
I come here ask for a solution, how prevent TIdTcpServer stuck connections?
Version of indy 10.6.2.5341 and Rad Studio 10.1 Berlin
On both images show the number of connections on TIdTcpServer, these numbers are retrieved from this function:
var
NumClients: Integer;
begin
with Form1.IdTCPServer1.Contexts.LockList do
try
NumClients := Count;
finally
Form1.IdTCPServer1.Contexts.UnlockList;
end;
Result := NumClients;
What happen is, in almost cases this numbers only increase and not decrease. so i believe connections are being stucked on TIdTcpServer.
I use a IdSchedulerOfThreadDefault1 on Scheduler, i don't know if that change something or no but i added.
For manage connections i use ContextClass:
IdTCPServer1.ContextClass := TClientContext;
Who definition is:
type
TCommand = (
cmdConnect,
cmdDisconnect,
cmdHWID,
cmdScreenShotData,
cmdMensagem);
type
TClient = record
HWID : String[40];
Tempo : TDateTime;
Msg : String[100];
end;
const
szClient = SizeOf(TClient);
type
TProtocol = record
Command: TCommand;
Sender: TClient;
DataSize: Integer;
end;
const
szProtocol = SizeOf(TProtocol);
type
TClientContext = class(TIdServerContext)
private
FCriticalSection : TCriticalSection;
FClient : TClient;
public
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
destructor Destroy; override;
public
procedure Lock;
procedure Unlock;
public
property Client: TClient read FClient write FClient;
end;
Others functions who are used:
procedure InitProtocol(var AProtocol: TProtocol);
begin
FillChar(AProtocol, szProtocol, 0);
end;
function ProtocolToBytes(const AProtocol: TProtocol): TBytes;
begin
SetLength(Result, szProtocol);
Move(AProtocol, Result[0], szProtocol);
end;
constructor TClientContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
inherited Create(AConnection, AYarn, AList);
FCriticalSection := TCriticalSection.Create;
end;
destructor TClientContext.Destroy;
begin
FreeAndNil(FCriticalSection);
inherited;
end;
procedure TClientContext.Lock;
begin
FCriticalSection.Enter;
end;
procedure TClientContext.Unlock;
begin
FCriticalSection.Leave;
end;
function BytesToProtocol(const ABytes: TBytes): TProtocol;
begin
Move(ABytes[0], Result, szProtocol);
end;
procedure ClearBuffer(var ABuffer: TBytes);
begin
SetLength(ABuffer, 0);
end;
procedure ClearBufferId(var ABuffer: TIdBytes);
begin
SetLength(ABuffer, 0);
end;
All events (connect/disconnect) i manage on IdTCPServer1Execute
like this example above:
type
PTBytes = ^TBytes;
PTIdBytes = ^TIdBytes;
var
LBuffer : TIdBytes;
LProtocol : TProtocol;
FTempBuffer : TIdBytes;
Enviar : TBytes;
Protocolo : TProtocol;
Conexao : TClientContext;
//
Queue: TStringList;
List: TStringList;
x : Integer;
//
procedure AddToMemo(const AStr: string);
begin
TThread.Synchronize(nil,
procedure
begin
Memo1.Lines.Add(AStr);
Form1.StatusBar1.Panels[0].Text := Format('Connections [%d]', [RetornaOn]);
end
);
end;
begin
Conexao := TClientContext(AContext);
// QUEUE
List := nil;
try
Queue := Conexao.Queue.Lock;
try
if Queue.Count > 0 then
begin
List := TStringList.Create;
List.Assign(Queue);
Queue.Clear;
end;
finally
Conexao.Queue.Unlock;
end;
if List <> nil then
begin
for x := 0 to List.Count-1 do
begin
InitProtocol(Protocolo);
Protocolo.Command := cmdMensagem;
Protocolo.Sender.Msg := Edit2.Text;
Enviar := ProtocolToBytes(Protocolo);
Conexao.Connection.IOHandler.Write(PTIdBytes(#Enviar)^);
ClearBuffer(Enviar);
end;
// Delete Queue
for x := 0 to List.Count-1 do
begin
List.Delete(x);
end;
end;
finally
List.Free;
end;
// QUEUE
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
//AddToMemo(Format('[%s] Running 1 ...', [TimeToStr(Now)]));
AContext.Connection.IOHandler.CheckForDataOnSource(100);
AContext.Connection.IOHandler.CheckForDisconnect;
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
{AddToMemo(Format('[%s] Running 2 ...', [TimeToStr(Now)]));
if GetTickDiff(Conexao.Client.Tick, Ticks) >= 10000 then
begin
AddToMemo(Format('[%s] Running 3 [%d] ...', [TimeToStr(Now), Conexao.Client.Tick]));
AContext.Connection.Disconnect;
Exit;
end;}
Exit;
end;
end;
AContext.Connection.IOHandler.ReadBytes(LBuffer, szProtocol, False);
LProtocol := BytesToProtocol(PTBytes(#LBuffer)^);
case LProtocol.Command of
cmdConnect: begin
Conexao.Client := LProtocol.Sender;
Conexao.FClient.Tick := Ticks;
AddToMemo(Format('[%s] : [%s][%s]', ['Connect', AContext.Connection.Socket.Binding.PeerIP, Protocolo.Sender.HWID]));
end;
cmdMensagem: begin
AddToMemo(Format('[%s] : [%s][%s][%s]', ['Msg', AContext.Connection.Socket.Binding.PeerIP, Conexao.Client.HWID, LProtocol.Sender.Msg]));
end;
cmdDisconnect: begin
AddToMemo(Format('[%s] : [%s][%s]', ['Disconnect', AContext.Connection.Socket.Binding.PeerIP, Conexao.Client.HWID]));
end;
end;
In next code i show how client side connect to TIdTcpServer:
type
PTIdBytes = ^TIdBytes;
var
LBuffer : TBytes;
LProtocol : TProtocol;
begin
ClientThread := TClientThread.Create(False);
InitProtocol(LProtocol);
LProtocol.Command := cmdConnect;
LProtocol.Sender.HWID := Edit1.Text;
LProtocol.Sender.Tempo := Now;
LBuffer := ProtocolToBytes(LProtocol);
IdTCPClient1.IOHandler.Write(PTIdBytes(#LBuffer)^);
ClearBuffer(LBuffer);
AddToMemo('IdTCPClient1 connected to server');
ClientThread on client:
procedure TClientThread.Execute;
type
PTBytes = ^TBytes;
PTIdBytes = ^TIdBytes;
var
LBuffer : TIdBytes;
LDataSize : Integer;
LProtocol : TProtocol;
procedure AddToMemo(const AStr: string);
begin
TThread.Synchronize(nil,
procedure
begin
Form1.Memo1.Lines.Add('Received From Server: ' + AStr);
end
);
end;
begin
inherited;
while NOT Terminated and Form1.IdTCPClient1.Connected do begin
//LDataSize := Form1.IdTCPClient1.IOHandler.InputBuffer.Size;
//if LDataSize >= szProtocol then begin
try
Form1.IdTCPClient1.IOHandler.ReadBytes(LBuffer, szProtocol);
LProtocol := BytesToProtocol(PTBytes(#LBuffer)^);
case LProtocol.Command of
cmdHWID:
begin
HWID := LProtocol.Sender.HWID;
AddToMemo('HWID > ' + LProtocol.Sender.HWID);
end;
cmdDisconnect:
begin
AddToMemo('DC > ' + LProtocol.Sender.HWID);
end;
cmdMensagem:
begin
AddToMemo('MSG > ' + LProtocol.Sender.Msg);
end;
end;
finally
ClearBufferId(LBuffer);
end;
//end;
Sleep(50);
end;
end;
Anybody know why these connections are being stucked on TIdTcpServer?
Maybe if i loop all conenctions and try send a single text will disconnect they if don't are really connected to IdTcpServer no ?
Thanks.

Client.Socket.SendText from of a Form that is displayed above of other Form that stays always on top

I'm with difficulties for send text from a Client.Socket. The Form that sends the text, is displayed always above of Form that stays always on top, when FormOnTop not exists (not is showing), works fine, already when FormOnTop exists and Form that will sends the text is displayed above of FormOntop, the send fail, and text (message) not even exit of Client.exe of my software.
There are some solution for this?
For better understand, I will leave the code that I using:
Form that contains Client Socket component
unit Unit1;
interface
uses
FormSender;
type
......
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.CS1Read(Sender: TObject; Socket: TCustomWinSocket);
var
StrCommand: String;
begin
StrCommand := Socket.ReceiveText;
if Pos('<|Command_From_Server|>', StrCommand) > 0 then
begin
FormSender.PopupMode:= pmExplicit;
FormSender.PopupParent:= FormOnTop;
FormSender.Show;
end;
end;
end.
Form that sends text (FormSender) and appear above of Form that stays always On Top:
unit FormSender;
interface
uses
Unit1;
type
......
end;
var
FormSender: TFormSender;
implementation
{$R *.dfm}
procedure TFormSender.Button1Click(Sender: TObject);
begin
Form1.CS1.Socket.SendText('<|Hello_Server!|>' + Edit1.Text + '<<|);
end;
end.
Form that stays always on top:
FormStyle property is: fsStayOnTop.
unit FormOnTop;
interface
uses
.......
type
......
end;
var
FormOnTop: TFormOnTop;
implementation
{$R *.dfm}
procedure TFormOnTop.FormCreate(Sender: TObject);
begin
{ Position form }
Top := 0 ;
Left := 0 ;
{ Go full screen }
BorderStyle := bsNone ;
WindowState := wsmaximized;
ClientWidth := Screen.Width ;
ClientHeight := Screen.Height;
Refresh;
SetForegroundWindow(Handle) ;
SetActiveWindow(Application.Handle);
end;
procedure TFormOnTop.CreateParams(var Params: TCreateParams);
begin
inherited;
if (FormStyle = fsStayOnTop) then begin
Params.ExStyle := Params.ExStyle or WS_EX_APPWINDOW;
Params.WndParent := GetDesktopWindow;
end;
end;
procedure TFormOnTop.FormShow(Sender: TObject);
begin
SetWindowPos(FormOnTop.handle, HWND_TOPMOST, FormOnTop.Left, FormOnTop.Top, FormOnTop.Width, FormOnTop.Height, 0);
end;
end.

RegisterHotKey from Windows Service application

If I call RegisterHotKey() from the ServiceStart procedure it will fail with ERROR_REQUIRES_INTERACTIVE_WINDOWSTATION. I couldn't find much information on this so I created a thread, made a window (CreateWindow) and called RegisterHotKey() from this context; However, it returns the same error, What is the Proper way to register a hotkey from a Service application?
Function Makewnd(): integer;
Var
Hwnd: THandle;
uMsg: TMsg;
Begin
Hwnd := CreateWindow('STATIC', 'DummyWindow', 0, 0, 0, 100, 100, HWND_MESSAGE, 0, HInstance, Nil);
Writelog(pchar('CreateWindow HWND->'+inttohex(hwnd,8)));
If (RegisterHotKey(Hwnd, 7000, MOD_CONTROL or MOD_ALT, VK_F12) = TRUE) Then
writelog('hotkey set: MOD_CONTROL or MOD_ALT, VK_F12')
Else begin
Writelog(PWideChar('Error: '+inttostr(getlasterror())));
End;
while (GetMessage(uMsg, Hwnd, 0, 0) = TRUE) do
case uMsg.message of
WM_HOTKEY:
Begin
Writelog(PWideChar('Hotkey! ID-> ' + inttostr(uMsg.wParam)));
End;
end;
Writelog('GetMessage=false');
Result := 0;
End;
procedure ServiceController(CtrlCode: DWord); stdcall;
begin
Service4.Controller(CtrlCode);
end;
function TService4.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
procedure TService4.ServiceExecute(Sender: TService);
begin
Writelog('ServiceExecuteing');
while not Terminated do
Begin
ServiceThread.ProcessRequests(TRUE);
End;
end;
procedure TService4.ServiceStart(Sender: TService; var Started: Boolean);
Var
TID: DWORD;
Handle: THandle;
begin
writelog('ServiceStart');
Handle := CreateThread(Nil, 0, #makewnd, Nil, 0, TID);
//not using handle right now
end;
You can't
To add to what Ken said, Interactive Services were eliminated when Session 0 Isolation was introduced in Vista. Prior to that, a service could interact with the user desktop (but only the desktop of the first user to login) if the SERVICE_INTERACTIVE_PROCESS flag was specified in the call to CreateService(). That flag is no longer supported, and services can no longer interact with any user desktops. – Remy Lebeau

Indy/lazarus TIdTCPServer how to close properly

How to close properly a TIdTCPServer with Indy/Lazarus if we press a 'Close' button in the GUI?. Thanks for helping! (Changed my original question)
How to close the TIdTCPServer if a client disconnects?
Should the exception handle anything?
The IO works but it's a bit unstable yet.
Here is the code below:
unit pt_socket;
{$mode objfpc}//{$H+}
interface
uses
Classes, SysUtils,
Forms,
IdGlobal,
IdContext, IdComponent,
IdTCPServer, IdTCPClient,
Controls, Graphics, Dialogs;
type
TSocket = class
private
IdTcpServer1: TIdTCPServer;
IdTcpClient1: TIdTCPClient;
procedure IdTCPServer1Connect(AContext: TIdContext);
procedure IdTCPServer1Disconnect(AContext: TIdContext);
//procedure IdTCPServer1Exception(AContext: TIdContext; AException: Exception);
procedure IdTCPServer1Execute(AContext: TIdContext);
public
procedure init;
function Open: boolean;
procedure Close;
function Write(str: TByteArray; len: integer): integer;
end;
var
lst: Tlist;
implementation
uses main, pt_settings, pt_ctlpanel, pt_terminal;
procedure TSocket.init;
begin
end;
procedure TSocket.IdTCPServer1Connect(AContext: TIdContext);
begin
MainApp.GuiPortOpen;
lst := IdTcpServer1.Contexts.LockList;
end;
procedure TSocket.IdTCPServer1Disconnect(AContext: TIdContext);
begin
IdTcpServer1.Contexts.UnlockList;
MainApp.GuiPortClose;
end;
//procedure TSocket.IdTCPServer1Exception(AContext: TIdContext; AException: Exception);
//begin
// MainApp.GuiPortClose;
//end;
procedure TSocket.IdTCPServer1Execute(AContext: TIdContext);
var
Socket_Receive_Buffer: TIdBytes;
Socket_Input_Length: integer;
Input_Buffer: TByteArray;
begin
with AContext.Connection do
begin
IOHandler.ReadBytes(Socket_Receive_Buffer, -1, false);
Socket_Input_Length := Length(Socket_Receive_Buffer);
if Socket_Input_Length > 0 then
begin
BytesToRaw(Socket_Receive_Buffer,Input_Buffer,Socket_Input_Length);
Terminal.GuiTerminalPutInput(Input_Buffer, Socket_Input_Length);
end;
end;
end;
function TSocket.Open: boolean;
begin
if Settings.SocketModeRadioGroup.ItemIndex = 0 then
begin
IdTcpServer1 := TIdTCPServer.Create(nil);
IdTCPServer1.OnExecute := #IdTCPServer1Execute;
IdTCPServer1.OnConnect := #IdTCPServer1Connect;
IdTCPServer1.OnDisconnect := #IdTCPServer1Disconnect;
//IdTcpServer1.OnException := #IdTCPServer1Exception;
IdTcpServer1.DefaultPort := StrToInt(Settings.SocketPortEdit.Text);
IdTcpServer1.MaxConnections := 1;
IdTCPServer1.Bindings.Add.IPVersion := Id_IPv4;
IdTcpServer1.Active := True;
end
else
begin
IdTcpClient1 := TIdTCPClient.Create(nil);
//IdTcpClient1.DefaultPort := StrToInt(Settings.SocketPortEdit.SelText);
end;
end;
procedure TSocket.Close;
begin
if Settings.SocketModeRadioGroup.ItemIndex = 0 then
begin
IdTcpServer1.Destroy;
end
else
begin
IdTcpClient1.Destroy;
end;
end;
function TSocket.Write(str: TByteArray; len: integer): integer;
var
Socket_Transmit_Buffer: TIdBytes;
begin
Socket_Transmit_Buffer := RawToBytes(str,len);
if len > 0 then
// Only one connection by design
with TIdContext(lst.Items[0]).Connection do
begin
IOHandler.Write(Socket_Transmit_Buffer);
end;
Result := len;
end;
end.
This code has tons of mistakes in it. Misuse of the Contexts list. Improper use of BytesToRaw() and RawToBytes(). Thread-unsafe GUI logic in worker threads. This code is very prone to memory corruption and deadlocks. It is no wonder your code is unstable. You need to fix that.
To answer your specific questions:
How to close properly a TIdTCPServer with Indy/Lazarus if we press a 'Close' button in the GUI?.
Simply deactivate/destroy the server. It will automatically close any active client connection. However, due to the multi-threaded nature of TIdTCPServer you have to make sure NOT to block any of the server's event handlers during deactivation, or you will deadlock your code. If the event handlers have to sync with the main thread while the main thread is deactivating the server, use asynchronous syncs (TThread.Queue(), TIdNotify, etc) or do the deactivation in a worker thread so the main thread is not blocked. Also, if you need to catch exceptions in your event handlers, be sure to re-raise any EIdException-derived exception you catch and let the server handle it, otherwise the client threads will not terminate correctly, deadlocking deactivation as well.
How to close the TIdTCPServer if a client disconnects?
The server cannot be deactivated from inside its own events (deadlock). You will have to perform the deactivation asynchronously. In the OnDisconnect event, you can send yourself an asynchronous signal so the event handler can exit, and then deactivate the server when the signal is processed. Or spawn a worker thread to perform the deactivation.

IdTcpServer cannot free its context thread after context.connection.disconnect() under CentOS+Lazarus

The result of Memo1 is still "ConnCnt:1" after I click btDisconn button, though I wait for several minutes.
But under windows xp it works fine, how can I make idtcpserver remove the invalid context thread?
Here's my code:
Client side (Windows7 + DelphiXE2 + Indy10.5.8):
procedure TForm1.FormShow(Sender: TObject);
begin
TcpClient.Host:=192.168.1.103;
TcpClient.Port:=10000;
TcpClient.Connect;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
try
TcpClient.Disconnect;
except
end;
end;
Server side (Vmware + CentOS + Lararus1.0.12 + Indy10.5.8)
procedure TForm1.FormShow(Sender: TObject);
var Bind:TIdSocketHandle;
begin
TCPServer.Bindings.Clear;
Bind:=TCPServer.Bindings.Add;
Bind.IPVersion:=Id_IPv4;
Bind.Port:=10000;
TcpServer.OnExecute:=#TcpServerExecute;
TcpServer.DefaultPort:=10000;
TcpServer.Active:=true;
Timer1.Interval:=5000;
Timer1.Enabled:=true;
end;
procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
Timer1.Enabled:=false;
TcpServer.Active:=false;
end;
procedure TForm1.TcpServerExecute(AContext: TIdContext);
var b:Byte;
begin
try
b:=AContext.Connection.IOHandler.ReadByte();
except
on E:Exception do memo1.Lines.Add('Error:'+E.Message)
end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var lst:TList;
begin
try
lst:=TcpServer.Contexts.LockList();
Memo1.Lines.Add('ConnCnt:'+inttostr(lst.Count));//the result is still ConnCnt:1 after i click btDisconn
finally
TcpServer.Contexts.UnlockList();
end;
end;
procedure TForm1.btDisconnClick(Sender: TObject);
var i:Integer;lst:TList;itm:TIdContext;
begin
try
lst:=TcpServer.Contexts.LockList();
for i:=0 to lst.Count-1 do begin
itm:=TIdContext(lst.Items[i]);
if Assigned(itm) then begin
itm.Connection.Disconnect();
itm.Connection.IOHandler.DiscardAll;
end;
end;
finally
TcpServer.Contexts.UnlockList();
end;
end;
There are two problems with your server code that prevent it from shutting down correctly:
your OnExecute code is catching and discarding all exceptions and not allowing TIdTCPServer to process any of them. When TIdTCPServer is being deactivated, it closes all active sockets, which in turn causes current/subsequent socket operations to fail and raise exceptions. By discarding the exceptions, TIdTCPServer has no clue that the connections have been closed, and happily keeps calling the OnExecute event. If you must catch exceptions (such as to log them), you need to re-raise any Indy-specific exceptions when you are done with them so TIdTCPServer can then process them.
you are accessing the TMemo in a thread-unsafe manner, which can (amongst other things) cause deadlocks.
Try this instead:
uses
..., IdSync;
type
TMemoNotify = class(TIdNotify)
protected
FMsg: String;
procedure DoNotify; override;
public
class procedure AddToMemo(const AMsg: string);
end;
procedure TMemoNotify.DoNotify;
begin
Form1.Memo1.Lines.Add(FMsg);
end;
class procedure TMemoNotify.AddToMemo(const AMsg: string);
begin
with Create do
begin
FMsg := AMsg;
Notify;
end;
end;
uses
..., EIdException;
procedure TForm1.FormShow(Sender: TObject);
var
Bind: TIdSocketHandle;
begin
TCPServer.Bindings.Clear;
Bind := TCPServer.Bindings.Add;
Bind.IPVersion := Id_IPv4;
Bind.Port := 10000;
TcpServer.OnExecute := TcpServerExecute;
TcpServer.Active := True;
Timer1.Interval := 5000;
Timer1.Enabled := True;
end;
procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
Timer1.Enabled := False;
TcpServer.Active := False;
end;
procedure TForm1.TcpServerExecute(AContext: TIdContext);
var
b: Byte;
begin
try
b := AContext.Connection.IOHandler.ReadByte;
except
on E: Exception do
begin
TMemoNotify.AddToMemo('Error:'+E.Message);
if E is EIdException then raise;
end;
end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
lst: TList;
begin
lst := TcpServer.Contexts.LockList;
try
Memo1.Lines.Add('ConnCnt:'+IntToStr(lst.Count));
finally
TcpServer.Contexts.UnlockList;
end;
end;
procedure TForm1.btDisconnClick(Sender: TObject);
var
i: Integer;
lst: TList;
begin
lst := TcpServer.Contexts.LockList;
try
for i := 0 to lst.Count-1 do
begin
try
TIdContext(lst.Items[i]).Connection.Disconnect;
except
end;
end;
finally
TcpServer.Contexts.UnlockList;
end;
end;
Alternatively to re-raising Indy exceptions, you could just get rid of the exception handling in the OnExecute event altogether and use the TIdTCPServer.OnException event instead:
procedure TForm1.TcpServerExecute(AContext: TIdContext);
var
b: Byte;
begin
b := AContext.Connection.IOHandler.ReadByte;
...
end;
procedure TForm1.TcpServerException(AContext: TIdContext; AException: Exception);
begin
TMemoNotify.AddToMemo('Error:'+AException.Message);
end;