Delphi XE2 Indy 10 TIdCmdTCPServer приложение для замораживания

Question

Я только начинаю изучать, как использовать компоненты Indy 10 в Delphi XE2. Я начал с проекта, который будет использовать командные сокеты (TIdCmdTCPServer и TIdCmdTCPClient). У меня все настроено, и клиент подключается к серверу, но после подключения клиента любая команда, которую сервер отправляет клиенту, просто замораживает приложение сервера, пока оно в конечном итоге не завершится сбоем и не закроется (после глубокого замораживания).

Настройка проекта

Настройка очень проста; есть небольшое серверное приложение и небольшое клиентское приложение, каждое со своим соответствующим компонентом сокета TCP-команды Indy. На клиенте есть только один обработчик команд.

Серверное приложение

На сервере у меня есть очень простая оболочка для контекста type TCli = class(TIdServerContext), которая содержит только одно открытое свойство (наследование является практически обязательным требованием Indy).

Клиентское приложение

С другой стороны, клиент работает просто отлично. Он получает команду с сервера и делает свое дело. У клиента есть таймер, который автоматически подключается, если он еще не подключен. В настоящее время он настроен на попытку подключения через 1 секунду после запуска приложения и повторяет попытки каждые 10 секунд, если он еще не подключен.

Сведения о проблеме

Я могу успешно отправить одну или две команды с сервера клиенту (клиент отвечает правильно), но сервер останавливается через несколько секунд после отправки команды. У меня есть обработчики событий для OnConnect, OnDisconnect, OnContextCreated и OnException на сервере, и все, что они на самом деле делают, - это либо публикует журнал, либо обрабатывают объекты подключения / отключения в представлении списка.

Снимок экрана

Наконец, когда клиентское приложение изящно закрыто, сервер также изящно выходит из замороженного состояния. Однако если клиент принудительно закрыт, то сервер также принудительно закрыт. Это картина, которую я вижу. Он отправляет в журнал события с PostLog(const S: String), который просто добавляет короткие сообщения в TMemo.

Я сделал два проекта, и у меня были проблемы с обоими. Я подготовил пример проекта ...

Код сервера ( uServer.pas и 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

Код клиента ( uClient.pas и 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

Answer 1

Причина, по которой ваш сервер зависает, заключается в том, что вы блокируете код своего сервера.

Для каждого клиента, который подключается к TIdCmdTCPServer, создается рабочий поток, который непрерывно считывает входящие команды из этого соединения, поэтому онможет вызывать TIdCommandHandler.OnCommand события в коллекции TIdCmdTCPServer.CommandHandlers.TCli.DoTest() вызывает TIdTCPConnection.SendCmd(), чтобы отправить команду клиенту и прочитать его ответ.Вы вызываете TCli.DoTest() (и, следовательно, SendCmd()) в контексте основного потока, поэтому у вас есть два отдельных контекста потока, пытающихся одновременно считывать данные из одного и того же соединения, вызывая состояние гонки.Рабочий поток, работающий внутри TIdCmdTCPServer, вероятно, читает части (если не все) данных, которые SendCmd() ожидает и никогда не увидит, поэтому SendCmd() не завершается должным образом, блокируя цикл основного сообщения от возможностичтобы обрабатывать новые сообщения когда-либо снова, запустите замораживание.

Размещение TIdAntiFreeze в серверном приложении может помочь избежать замораживания, позволяя контексту основного потока продолжить обработку сообщений, пока SendCmd() заблокирован.Но это не верное решение.Чтобы действительно это исправить, вам нужно изменить дизайн своего серверного приложения.Для начинающих не используйте TIdCmdTCPServer с TIdCmdTCPClient, так как они не предназначены для совместного использования.Если ваш сервер собирается отправлять команды клиенту, а клиент никогда не отправляет команды на сервер, тогда используйте простой TIdTCPServer вместо TIdCmdTCPServer.Но даже если вы не сделаете это изменение, у вас все равно будут другие проблемы с текущим кодом сервера.Обработчики событий вашего сервера не выполняют поточно-ориентированные операции, и вам нужно переместить вызов на TCli.DoTest() из контекста основного потока.

Попробуйте этот код:

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 

Answer 2

Вы пытались отладить сервер?

Строка

Result:= TCli(AContext);

(жесткое приведение в TIdContext) выглядит как потенциальная причина для замораживания.

Есть ли у васПрочтите это, как заставить TIdCustomTCPServer знать о вашем собственном классе TIdServerContext?

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

Соответствующий код в ответе:

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

  ...

    ContextClass := TOurContext;

  ...
end;