Delphi XE2 Indy 10 TIdCmdTCPServer freezing application

1
votes

I'm just starting to learn how to use the Indy 10 components in Delphi XE2. I started with a project that will use the command sockets (TIdCmdTCPServer and TIdCmdTCPClient). I've got everything set up and the client connects to the server, but after the client connects, any command the server sends to the client just freezes the server app, until it eventually crashes and closes (after a deep freeze).

Project Setup

The setup is very simple; there's a small server app and a small client app, each with its corresponding Indy command tcp socket component. There's only one command handler on the client.

Server App

On the server, I have a very simple wrapper for the context type TCli = class(TIdServerContext) which only contains one public property (the inheritance is practically a requirement of Indy).

Client App

The client on the other hand works just fine. It receives the command from the server and does its thing. The client has a timer which auto-connects if it's not already connected. It's currently set to try to connect after 1 second of the app starting, and keep attempting every 10 seconds if not connected already.

Problem Details

I am able to send one or two commands from the server to the client successfully (client responds properly), but the server freezes a few seconds after sending the command. I have event handlers for OnConnect, OnDisconnect, OnContextCreated, and OnException on the server, which all they do really is either post a log or handle connect/disconnect objects in a list view.

Screen Shot

Server app frozen after 2 clicks

Finally when the client app is gracefully closed, the server also gracefully snaps out of its frozen state. However if the client is forcefully closed, then the server is also forcefully closed. That's the pattern I'm seeing. It posts to a log on events with PostLog(const S: String) which simply appends short messages to a TMemo.

I've done two projects and had the problem on both. I've prepared a sample project...

Server Code (uServer.pas and uServer.dfm)

unit uServer;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, IdContext, IdBaseComponent, IdComponent,
  IdCustomTCPServer, IdTCPServer, IdCmdTCPServer, Vcl.StdCtrls, Vcl.Buttons,
  Vcl.ComCtrls;

type
  TCli = class(TIdServerContext)
  private
    function GetIP: String;
  public
    property IP: String read GetIP;
    procedure DoTest;
  end;

  TForm3 = class(TForm)
    Svr: TIdCmdTCPServer;
    Lst: TListView;
    Log: TMemo;
    cmdDoCmdTest: TBitBtn;
    procedure cmdDoCmdTestClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
    procedure SvrConnect(AContext: TIdContext);
    procedure SvrContextCreated(AContext: TIdContext);
    procedure SvrDisconnect(AContext: TIdContext);
    procedure SvrException(AContext: TIdContext; AException: Exception);
  private
  public
    procedure PostLog(const S: String);
    function NewContext(AContext: TIdContext): TCli;
    procedure DelContext(AContext: TIdContext);
  end;

var
  Form3: TForm3;

implementation

{$R *.dfm}

{ TCli }

procedure TCli.DoTest;
begin
  Connection.SendCmd('DoCmdTest');
end;

function TCli.GetIP: String;
begin
  Result:= Binding.PeerIP;
end;

{ TForm3 }

procedure TForm3.PostLog(const S: String);
begin
  Log.Lines.Append(S);
end;

procedure TForm3.SvrConnect(AContext: TIdContext);
var
  C: TCli;
begin
  C:= TCli(AContext);
  PostLog(C.IP+': Connected');
end;

procedure TForm3.SvrContextCreated(AContext: TIdContext);
var
  C: TCli;
begin
  C:= NewContext(AContext);
  PostLog(C.IP+': Context Created');
end;

procedure TForm3.SvrDisconnect(AContext: TIdContext);
var
  C: TCli;
begin
  C:= TCli(AContext);
  PostLog(C.IP+': Disconnected');
  DelContext(AContext);
end;

procedure TForm3.SvrException(AContext: TIdContext; AException: Exception);
var
  C: TCli;
begin
  C:= TCli(AContext);
  PostLog(C.IP+': Exception: '+AException.Message);
end;

procedure TForm3.cmdDoCmdTestClick(Sender: TObject);
var
  X: Integer;
  C: TCli;
  I: TListItem;
begin
  for X := 0 to Lst.Items.Count - 1 do begin
    I:= Lst.Items[X];
    C:= TCli(I.Data);
    C.DoTest;
  end;
end;

procedure TForm3.DelContext(AContext: TIdContext);
var
  I: TListItem;
  X: Integer;
begin
  for X := 0 to Lst.Items.Count - 1 do begin
    I:= Lst.Items[X];
    if I.Data = TCli(AContext) then begin
      Lst.Items.Delete(X);
      Break;
    end;
  end;
end;

procedure TForm3.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Svr.Active:= False;
end;

procedure TForm3.FormCreate(Sender: TObject);
begin
  Svr.Active:= True;
end;

function TForm3.NewContext(AContext: TIdContext): TCli;
var
  I: TListItem;
begin
  Result:= TCli(AContext);
  I:= Lst.Items.Add;
  I.Caption:= Result.IP;
  I.Data:= Result;
end;

end.

//////// DFM ////////

object Form3: TForm3
  Left = 315
  Top = 113
  Caption = 'Indy 10 Command TCP Server'
  ClientHeight = 308
  ClientWidth = 529
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  DesignSize = (
    529
    308)
  PixelsPerInch = 96
  TextHeight = 13
  object Lst: TListView
    Left = 336
    Top = 8
    Width = 185
    Height = 292
    Anchors = [akTop, akRight, akBottom]
    Columns = <
      item
        AutoSize = True
      end>
    TabOrder = 0
    ViewStyle = vsReport
    ExplicitLeft = 333
    ExplicitHeight = 288
  end
  object Log: TMemo
    Left = 8
    Top = 56
    Width = 316
    Height = 244
    Anchors = [akLeft, akTop, akRight, akBottom]
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'Tahoma'
    Font.Style = [fsBold]
    ParentFont = False
    ScrollBars = ssVertical
    TabOrder = 1
  end
  object cmdDoCmdTest: TBitBtn
    Left = 8
    Top = 8
    Width = 217
    Height = 42
    Caption = 'Send Test Command'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'Tahoma'
    Font.Style = [fsBold]
    ParentFont = False
    TabOrder = 2
    OnClick = cmdDoCmdTestClick
  end
  object Svr: TIdCmdTCPServer
    Bindings = <>
    DefaultPort = 8664
    MaxConnections = 100
    OnContextCreated = SvrContextCreated
    OnConnect = SvrConnect
    OnDisconnect = SvrDisconnect
    OnException = SvrException
    CommandHandlers = <>
    ExceptionReply.Code = '500'
    ExceptionReply.Text.Strings = (
      'Unknown Internal Error')
    Greeting.Code = '200'
    Greeting.Text.Strings = (
      'Welcome')
    HelpReply.Code = '100'
    HelpReply.Text.Strings = (
      'Help follows')
    MaxConnectionReply.Code = '300'
    MaxConnectionReply.Text.Strings = (
      'Too many connections. Try again later.')
    ReplyTexts = <>
    ReplyUnknownCommand.Code = '400'
    ReplyUnknownCommand.Text.Strings = (
      'Unknown Command')
    Left = 288
    Top = 8
  end
end

Client Code (uClient.pas and uClient.dfm)

unit uClient;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
  Vcl.ExtCtrls,
  IdContext, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
  IdCmdTCPClient, IdCommandHandlers, Vcl.StdCtrls;

const                             // --- Change accordingly ---
  TMR_INT = 10000;                //how often to check for connection
  SVR_IP =  '192.168.4.100';      //Server IP Address
  SVR_PORT = 8664;                //Server Port

type
  TForm4 = class(TForm)
    Tmr: TTimer;
    Cli: TIdCmdTCPClient;
    Log: TMemo;
    procedure CliCommandHandlers0Command(ASender: TIdCommand);
    procedure TmrTimer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure CliConnected(Sender: TObject);
    procedure CliDisconnected(Sender: TObject);
  private
    procedure PostLog(const S: String);
  public
  end;

var
  Form4: TForm4;

implementation

{$R *.dfm}

procedure TForm4.PostLog(const S: String);
begin
  Log.Lines.Append(S);
end;

procedure TForm4.CliCommandHandlers0Command(ASender: TIdCommand);
begin
  PostLog('Received command successfully');
end;

procedure TForm4.CliConnected(Sender: TObject);
begin
  PostLog('Connected to Server');
end;

procedure TForm4.CliDisconnected(Sender: TObject);
begin
  PostLog('Disconnected from Server');
end;

procedure TForm4.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Cli.Disconnect;
end;

procedure TForm4.FormCreate(Sender: TObject);
begin
  Tmr.Enabled:= True;
end;

procedure TForm4.TmrTimer(Sender: TObject);
begin
  if Tmr.Interval <> TMR_INT then
    Tmr.Interval:= TMR_INT;
  if not Cli.Connected then begin
    try
      Cli.Host:= SVR_IP;
      Cli.Port:= SVR_PORT;
      Cli.Connect;
    except
      on e: exception do begin
        Cli.Disconnect;
      end;
    end;
  end;
end;

end.

//////// DFM ////////

object Form4: TForm4
  Left = 331
  Top = 570
  Caption = 'Indy 10 Command TCP Client'
  ClientHeight = 317
  ClientWidth = 305
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnClose = FormClose
  OnCreate = FormCreate
  DesignSize = (
    305
    317)
  PixelsPerInch = 96
  TextHeight = 13
  object Log: TMemo
    Left = 8
    Top = 56
    Width = 289
    Height = 253
    Anchors = [akLeft, akTop, akRight, akBottom]
    ScrollBars = ssVertical
    TabOrder = 0
    ExplicitWidth = 221
    ExplicitHeight = 245
  end
  object Tmr: TTimer
    Enabled = False
    OnTimer = TmrTimer
    Left = 56
    Top = 8
  end
  object Cli: TIdCmdTCPClient
    OnDisconnected = CliDisconnected
    OnConnected = CliConnected
    ConnectTimeout = 0
    Host = '192.168.4.100'
    IPVersion = Id_IPv4
    Port = 8664
    ReadTimeout = -1
    CommandHandlers = <
      item
        CmdDelimiter = ' '
        Command = 'DoCmdTest'
        Disconnect = False
        Name = 'cmdDoCmdTest'
        NormalReply.Code = '200'
        ParamDelimiter = ' '
        ParseParams = True
        Tag = 0
        OnCommand = CliCommandHandlers0Command
      end>
    ExceptionReply.Code = '500'
    ExceptionReply.Text.Strings = (
      'Unknown Internal Error')
    Left = 16
    Top = 8
  end
end
2
delphidelphi-xe2freezeindyindy10
@Jerry John's comment was not a joke. Try adding antifreeze. Anyway, what does the debugger tell you? Which thread is blocking and what is it blocking on. The debugger, especially now they made such huge improvements from D7 days, will tell you a lot. – David Heffernan
Debugger tells me nothing. It's just freezing for no apparent reason. I know nothing about how Indy implements threading. And if Antifreeze isn't a joke then what is it? – Jerry Dodge
TIdAntiFreeze. Debugger tells you nothing?! Look at the list of threads. That should tell you what the blocked thread is waiting on. – David Heffernan
I did start off by mentioning that this is my first time ever working with Indy, to point out that I will not understand terminology like that. So is this blocking, as you mention? Please remember I don't know the same terminology as you may know. – Jerry Dodge
@JerryDodge try adding the TIdAntiFreeze component to your form. – John Easley

2 Answers

5
votes

The reason your server is freezing up is because you are deadlocking your server code.

For each client that connects to TIdCmdTCPServer, a worker thread is created that continuously reads inbound commands from that connection so it can trigger TIdCommandHandler.OnCommand events in the TIdCmdTCPServer.CommandHandlers collection. TCli.DoTest() calls TIdTCPConnection.SendCmd() to send a command to a client and read its response. You are calling TCli.DoTest() (and thus SendCmd()) in the context of the main thread, so you have two separate thread contexts trying to read from the same connection at the same time, causing a race condition. The worker thread running inside of TIdCmdTCPServer is likely reading portions of (if not all of) the data that SendCmd() is expecting and will never see, so SendCmd() does not exit properly, blocking the main message loop from being able to process new messages ever again, hense the freeze.

Placing a TIdAntiFreeze in the server app can help avoid the freezing, by allowing the main thread context to continue processing messages while SendCmd() is deadlocked. But that is not a true solution. To really fix this, you need to redesign your server app. For starters, do not use TIdCmdTCPServer with TIdCmdTCPClient, as they are not designed to be used together. If your server is going to send commands to the client, and the client is never sending commands to the server, then use a plain TIdTCPServer instead of TIdCmdTCPServer. But even if you do not make that change, you still have other problems with your current server code. Your server event handlers are not performing thread-safe operations, and you need to move the call to TCli.DoTest() out of the main thread context.

Try this code:

uServer.pas:

unit uServer; 

interface 

uses 
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, System.SyncObjs,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, IdContext, IdBaseComponent, IdComponent,
  IdTCPConnection, IdCustomTCPServer, IdTCPServer, IdThreadSafe, IdYarn, Vcl.StdCtrls, Vcl.Buttons,
  Vcl.ComCtrls; 

type 
  TCli = class(TIdServerContext) 
  private 
    fCmdQueue: TIdThreadSafeStringList;
    fCmdEvent: TEvent;
    function GetIP: String;
  public 
    constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TThreadList = nil); override;
    destructor Destroy; override;
    procedure PostCmd(const S: String); 
    property CmdQueue: TIdThreadSafeStringList read fCmdQueue;
    property CmdEvent: TEvent read fCmdEvent;
    property IP: String read GetIP;
  end; 

  TForm3 = class(TForm) 
    Svr: TIdTCPServer; 
    Lst: TListView; 
    Log: TMemo; 
    cmdDoCmdTest: TBitBtn; 
    procedure cmdDoCmdTestClick(Sender: TObject); 
    procedure FormClose(Sender: TObject; var Action: TCloseAction); 
    procedure FormCreate(Sender: TObject); 
    procedure SvrConnect(AContext: TIdContext); 
    procedure SvrDisconnect(AContext: TIdContext); 
    procedure SvrExecute(AContext: TIdContext);
    procedure SvrException(AContext: TIdContext; AException: Exception); 
  public 
    procedure NewContext(AContext: TCli); 
    procedure DelContext(AContext: TCli); 
  end; 

var 
  Form3: TForm3; 

implementation 

uses
  IdSync;

{$R *.dfm} 

{ TLog } 

type
  TLog = class(TIdNotify)
  protected
    fMsg: String;
    procedure DoNotify; override;
  public
    class procedure PostLog(const S: String);
  end;

procedure TLog.DoNotify;
begin
  Form3.Log.Lines.Append(fMsg); 
end;

class procedure TLog.PostLog(const S: String);
begin
  with Create do begin
    fMsg := S;
    Notify;
  end;
end;

{ TCliList }

type
  TCliList = class(TIdSync)
  protected
    fCtx: TCli;
    fAdding: Boolean;
    procedure DoSynchronize; override;
  public
    class procedure AddContext(AContext: TCli);
    class procedure DeleteContext(AContext: TCli);
  end;

procedure TCliList.DoSynchronize;
begin
  if fAdding then
    Form3.NewContext(fCtx)
  else
    Form3.DelContext(fCtx); 
end;

class procedure TCliList.AddContext(AContext: TCli);
begin
  with Create do try
    fCtx := AContext;
    fAdding := True;
    Synchronize;
  finally
    Free;
  end;
end;

class procedure TCliList.DeleteContext(AContext: TCli);
begin
  with Create do try
    fCtx := AContext;
    fAdding := False;
    Synchronize;
  finally
    Free;
  end;
end;

{ TCli } 

constructor TCli.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TThreadList = nil);
begin
  inherited Create(AConnection, AYarn, AList);
  fCmdQueue := TIdThreadSafeStringList.Create;
  fCmdEvent := TEvent.Create(nil, True, False, '');
end;

destructor TCli.Destroy;
begin
  fCmdQueue.Free;
  fCmdEvent.Free;
  inherited Destroy;
end;

procedure TCli.PostCmd; 
var
  L: TStringList;
begin
  L := fCmdQueue.Lock;
  try
    L.Add('DoCmdTest');
    fCmdEvent.SetEvent;
  finally
    fCmdQueue.Unlock;
  end;
end; 

function TCli.GetIP: String; 
begin 
  Result := Binding.PeerIP; 
end; 

{ TForm3 } 

procedure TForm3.SvrConnect(AContext: TIdContext); 
var 
  C: TCli; 
begin 
  C := TCli(AContext); 
  TCliList.AddContext(C); 
  TLog.PostLog(C.IP + ': Connected');
end; 

procedure TForm3.SvrDisconnect(AContext: TIdContext); 
var 
  C: TCli; 
begin 
  C := TCli(AContext); 
  TCliList.DeleteContext(C); 
  TLog.PostLog(C.IP + ': Disconnected'); 
end; 

procedure TForm3.SvrExecute(AContext: TIdContext);
var
  C: TCli;
  L, Q: TStringList;
  X: Integer;
begin
  C := TCli(AContext);

  if C.CmdEvent.WaitFor(500) <> wrSignaled then Exit;

  Q := TStringList.Create;
  try
    L := C.CmdQueue.Lock;
    try
      Q.Assign(L);
      L.Clear;
      C.CmdEvent.ResetEvent;
    finally
      C.CmdQueue.Unlock;
    end;
    for X := 0 to Q.Count - 1 do begin
      AContext.Connection.SendCmd(Q.Strings[X]);
    end;
  finally
    Q.Free;
  end;
end;

procedure TForm3.SvrException(AContext: TIdContext; AException: Exception); 
var 
  C: TCli; 
begin 
  C := TCli(AContext); 
  TLog.PostLog(C.IP + ': Exception: ' + AException.Message); 
end; 

procedure TForm3.cmdDoCmdTestClick(Sender: TObject); 
var 
  X: Integer;
  L: TList; 
begin 
  L := Svr.Contexts.LockList; 
  try
    for X := 0 to L.Count - 1 do begin 
      TCli(L.Items[X]).PostCmd; 
    end;
  finally
    Svr.Contexts.UnlockList;
  end; 
end; 

procedure TForm3.DelContext(AContext: TCli); 
var 
  I: TListItem; 
begin 
  I := Lst.FindData(0, AContext, true, false); 
  if I <> nil then I.Delete; 
end; 

procedure TForm3.FormClose(Sender: TObject; var Action: TCloseAction); 
begin 
  Svr.Active := False; 
end; 

procedure TForm3.FormCreate(Sender: TObject); 
begin 
  Svr.ContextClass := TCli;
  Svr.Active := True; 
end; 

procedure TForm3.NewContext(AContext: TCli); 
var 
  I: TListItem; 
begin 
  I := Lst.Items.Add; 
  I.Caption := AContext.IP;
  I.Data := AContext; 
end; 

end.

uServer.dfm:

object Form3: TForm3 
  Left = 315 
  Top = 113 
  Caption = 'Indy 10 Command TCP Server' 
  ClientHeight = 308 
  ClientWidth = 529 
  Color = clBtnFace 
  Font.Charset = DEFAULT_CHARSET 
  Font.Color = clWindowText 
  Font.Height = -11 
  Font.Name = 'Tahoma' 
  Font.Style = [] 
  OldCreateOrder = False 
  OnCreate = FormCreate 
  DesignSize = ( 
    529 
    308) 
  PixelsPerInch = 96 
  TextHeight = 13 
  object Lst: TListView 
    Left = 336 
    Top = 8 
    Width = 185 
    Height = 292 
    Anchors = [akTop, akRight, akBottom] 
    Columns = < 
      item 
        AutoSize = True 
      end> 
    TabOrder = 0 
    ViewStyle = vsReport 
    ExplicitLeft = 333 
    ExplicitHeight = 288 
  end 
  object Log: TMemo 
    Left = 8 
    Top = 56 
    Width = 316 
    Height = 244 
    Anchors = [akLeft, akTop, akRight, akBottom] 
    Font.Charset = DEFAULT_CHARSET 
    Font.Color = clWindowText 
    Font.Height = -11 
    Font.Name = 'Tahoma' 
    Font.Style = [fsBold] 
    ParentFont = False 
    ScrollBars = ssVertical 
    TabOrder = 1 
  end 
  object cmdDoCmdTest: TBitBtn 
    Left = 8 
    Top = 8 
    Width = 217 
    Height = 42 
    Caption = 'Send Test Command' 
    Font.Charset = DEFAULT_CHARSET 
    Font.Color = clWindowText 
    Font.Height = -13 
    Font.Name = 'Tahoma' 
    Font.Style = [fsBold] 
    ParentFont = False 
    TabOrder = 2 
    OnClick = cmdDoCmdTestClick 
  end 
  object Svr: TIdTCPServer 
    Bindings = <> 
    DefaultPort = 8664 
    MaxConnections = 100 
    OnConnect = SvrConnect 
    OnDisconnect = SvrDisconnect 
    OnExecute = SvrExecute
    OnException = SvrException 
    Left = 288 
    Top = 8 
  end 
end

uClient.pas:

unit uClient; 

interface 

uses 
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, 
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, 
  Vcl.ExtCtrls, 
  IdContext, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, 
  IdCmdTCPClient, IdCommandHandlers, Vcl.StdCtrls; 

const                             // --- Change accordingly --- 
  TMR_INT = 10000;                //how often to check for connection 
  SVR_IP =  '192.168.4.100';      //Server IP Address 
  SVR_PORT = 8664;                //Server Port 

type 
  TForm4 = class(TForm) 
    Tmr: TTimer; 
    Cli: TIdCmdTCPClient; 
    Log: TMemo; 
    procedure CliCommandHandlers0Command(ASender: TIdCommand); 
    procedure TmrTimer(Sender: TObject); 
    procedure FormCreate(Sender: TObject); 
    procedure FormClose(Sender: TObject; var Action: TCloseAction); 
    procedure CliConnected(Sender: TObject); 
    procedure CliDisconnected(Sender: TObject); 
  private 
    procedure AppMessage(var Msg: TMsg; var Handled: Boolean);
    procedure PostLog(const S: String); 
    procedure PostReconnect;
  public 
  end; 

var 
  Form4: TForm4; 

implementation 

uses
  IdSync;

{$R *.dfm} 

{ TLog } 

type
  TLog = class(TIdNotify)
  protected
    fMsg: String;
    procedure DoNotify; override;
  public
    class procedure PostLog(const S: String);
  end;

procedure TLog.DoNotify;
begin
  Form4.Log.Lines.Append(fMsg); 
end;

class procedure TLog.PostLog(const S: String);
begin
  with Create do begin
    fMsg := S;
    Notify;
  end;
end;

{ TForm4 }

const
  WM_START_RECONNECT_TIMER = WM_USER + 100;

procedure TForm4.CliCommandHandlers0Command(ASender: TIdCommand); 
begin 
  TLog.PostLog('Received command successfully'); 
end; 

procedure TForm4.CliConnected(Sender: TObject); 
begin 
  TLog.PostLog('Connected to Server'); 
end; 

procedure TForm4.CliDisconnected(Sender: TObject); 
begin 
  TLog.PostLog('Disconnected from Server'); 
  PostReconnect;
end; 

procedure TForm4.FormClose(Sender: TObject; var Action: TCloseAction); 
begin 
  Tmr.Enabled := False;
  Application.OnMessage := nil;
  Cli.Disconnect; 
end; 

procedure TForm4.FormCreate(Sender: TObject); 
begin 
  Application.OnMessage := AppMessage;
  Tmr.Enabled := True; 
end; 

procedure TForm4.AppMessage(var Msg: TMsg; var Handled: Boolean);
begin
  if Msg.message = WM_START_RECONNECT_TIMER then begin
    Handled := True;
    Tmr.Interval := TMR_INT; 
    Tmr.Enabled := True; 
  end;
end;

procedure TForm4.TmrTimer(Sender: TObject); 
begin 
  Tmr.Enabled := False; 

  Cli.Disconnect; 
  try 
    Cli.Host := SVR_IP; 
    Cli.Port := SVR_PORT; 
    Cli.Connect; 
  except 
    PostReconnect;
  end; 
end; 

procedure TForm4.PostReconnect;
begin
  PostMessage(Application.Handle, WM_START_RECONNECT_TIMER, 0, 0);
end;

end.

uClient.dfm:

object Form4: TForm4 
  Left = 331 
  Top = 570 
  Caption = 'Indy 10 Command TCP Client' 
  ClientHeight = 317 
  ClientWidth = 305 
  Color = clBtnFace 
  Font.Charset = DEFAULT_CHARSET 
  Font.Color = clWindowText 
  Font.Height = -11 
  Font.Name = 'Tahoma' 
  Font.Style = [] 
  OldCreateOrder = False 
  OnClose = FormClose 
  OnCreate = FormCreate 
  DesignSize = ( 
    305 
    317) 
  PixelsPerInch = 96 
  TextHeight = 13 
  object Log: TMemo 
    Left = 8 
    Top = 56 
    Width = 289 
    Height = 253 
    Anchors = [akLeft, akTop, akRight, akBottom] 
    ScrollBars = ssVertical 
    TabOrder = 0 
    ExplicitWidth = 221 
    ExplicitHeight = 245 
  end 
  object Tmr: TTimer 
    Enabled = False 
    OnTimer = TmrTimer 
    Left = 56 
    Top = 8 
  end 
  object Cli: TIdCmdTCPClient 
    OnDisconnected = CliDisconnected 
    OnConnected = CliConnected 
    ConnectTimeout = 0 
    Host = '192.168.4.100' 
    IPVersion = Id_IPv4 
    Port = 8664 
    ReadTimeout = -1 
    CommandHandlers = < 
      item 
        CmdDelimiter = ' ' 
        Command = 'DoCmdTest' 
        Disconnect = False 
        Name = 'cmdDoCmdTest' 
        NormalReply.Code = '200' 
        ParamDelimiter = ' ' 
        ParseParams = True 
        Tag = 0 
        OnCommand = CliCommandHandlers0Command 
      end> 
    ExceptionReply.Code = '500' 
    ExceptionReply.Text.Strings = ( 
      'Unknown Internal Error') 
    Left = 16 
    Top = 8 
  end 
end
1
votes

Have you tried debugging the server?

The line

Result:= TCli(AContext);

(hard cast of TIdContext) looks like a potential reason for the freeze.

Have you read this, how to make the TIdCustomTCPServer aware of your own TIdServerContext class?

https://stackoverflow.com/a/5514932/80901

The relevant code in the answer:

constructor TOurServer.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);

  ...

    ContextClass := TOurContext;

  ...
end;