IdTCPServer Freeze on Delphi

[rlebeau]

I edited and tested the code with your suggestion. The result is the same for Delphi.

The VCL code looks fine. There should be no freezing.

I test on Ubuntu(18.04) Console app. I got the same result on Linux

Your Linux code is not servicing the TThread.Queue() requests, so they never execute your handlers. Since you are not using a UI message loop, you need a manual loop that calls the RTL's CheckSynchronize() function periodically.

It is also important NOT to access the members of TIdContext asynchronously, especially after a disconnect, since the TIdContext object will be destroyed after the OnDisconnect handler exits, and will likely not exist anymore before (or worse, while) your TThread.Queue() handler is run. That is why in the code I provided you, I use the TIdContext pointer only as a lookup key in the TListBox, nothing more. In your Linux code, you don't need the TIdContext pointer at all.

Try this:

Code:

//Delphi Console App for Linux
program Project3;

{$APPTYPE CONSOLE}

{$R *.res}

uses
    System.SysUtils
  , System.Classes
  , System.Threading
  , IdContext
  , IdBaseComponent
  , IdComponent
  , IdCustomTCPServer
  , IdTCPServer;

type
  TSocketServer = class
  private
    procedure HandleClientConnected(APeerIP: string; APeerPort: Integer);
    procedure HandleClientDisconnected();
    procedure UpdateClientsCount;
  public
    IdTCPServer1: TIdTCPServer;

    procedure IdTCPServer1Connect(AContext: TIdContext);
    procedure IdTCPServer1Disconnect(AContext: TIdContext);
    procedure IdTCPServer1Execute(AContext: TIdContext);
    constructor Create();
    destructor Destroy; override;
  end;

var
  Server: TSocketServer;

constructor TSocketServer.Create();
begin
  inherited;
  IdTCPServer1 := TIdTCPServer.Create;
  IdTCPServer1.DefaultPort := 20000;

  IdTCPServer1.OnConnect := IdTCPServer1Connect;
  IdTCPServer1.OnDisconnect := IdTCPServer1Disconnect;
  IdTCPServer1.OnExecute := IdTCPServer1Execute;

  IdTCPServer1.Active := True;
end;

destructor TSocketServer.Destroy;
begin
  IdTCPServer1.Active := False;
  inherited;
end;

procedure TSocketServer.HandleClientConnected(APeerIP: string; APeerPort: Integer);
begin
  Writeln(APeerIP + ':' + APeerPort.ToString);
  UpdateClientsCount;
end;

procedure TSocketServer.HandleClientDisconnected();
begin
  UpdateClientsCount;
end;

procedure TSocketServer.IdTCPServer1Connect(AContext: TIdContext);
var
  PeerIP: string;
  PeerPort: Integer;
begin
  PeerIP := AContext.Binding.PeerIP;
  PeerPort := AContext.Binding.PeerPort;

  TThread.Queue(nil,
    procedure
    begin
      HandleClientConnected(PeerIP, PeerPort);
    end
  );
end;

procedure TSocketServer.IdTCPServer1Disconnect(AContext: TIdContext);
begin
  TThread.Queue(nil,
    procedure
    begin
      HandleClientDisconnected();
    end
  );
end;

procedure TSocketServer.IdTCPServer1Execute(AContext: TIdContext);
var
  data: string;
begin
  data := AContext.Connection.IOHandler.ReadLn;
  if data = 'E' then
    AContext.Connection.Disconnect;
end;

procedure TSocketServer.UpdateClientsCount;
var
  List : TIdContextList;
  Count: Integer;
begin
  if IdTCPServer1.Active then
  begin
    List := IdTCPServer1.Contexts.LockList;
    try
      Count := List.Count;
    finally
      IdTCPServer1.Contexts.UnlockList;
    end;
  end else begin
    Count := 0;
  end;
  Writeln('Server - Client : ' + Count.ToString);
end;

begin
  Server := TSocketServer.Create;
  try
    while True do
    begin
      try
        CheckSynchronize(100);
      except
        on E: Exception do
          Writeln(E.ClassName, ': ', E.Message);
      end;
    end;
  finally
    Server.Free;
  end;
end.