Delphi XE2 Indy 10 TIdCmdTCPServer 冻结应用

Question

Delphi XE2 Indy 10 TIdCmdTCPServer 冻结应用

Jer*_*dge 1 delphi indy freeze indy10 delphi-xe2

我刚刚开始学习如何在 Delphi XE2 中使用 Indy 10 组件。我从一个将使用命令套接字（TIdCmdTCPServer和TIdCmdTCPClient）的项目开始。我已经完成了所有设置并且客户端连接到服务器，但是在客户端连接之后，服务器发送给客户端的任何命令只会冻结服务器应用程序，直到它最终崩溃并关闭（深度冻结之后）。

项目设置

设置非常简单；有一个小型服务器应用程序和一个小型客户端应用程序，每个应用程序都有其对应的 Indy 命令 tcp 套接字组件。客户端上只有一个命令处理程序。

服务器应用程序

在服务器上，我有一个非常简单的上下文包装器type TCli = class(TIdServerContext)，它只包含一个公共属性（继承实际上是 Indy 的要求）。

客户端应用程序

另一方面，客户端工作得很好。它从服务器接收命令并执行其操作。客户端有一个计时器，如果它尚未连接，它会自动连接。当前设置为在应用程序启动 1 秒后尝试连接，如果尚未连接，则每 10 秒继续尝试一次。

问题详情

我能够成功地从服务器向客户端发送一两个命令（客户端正确响应），但服务器在发送命令后几秒钟就死机了。我在服务器上有用于OnConnect、OnDisconnect、OnContextCreated和的事件处理程序，OnException它们真正做的就是在列表视图中发布日志或处理连接/断开连接对象。

截屏

单击 2 次后服务器应用程序冻结

最后，当客户端应用程序正常关闭时，服务器也会正常退出冻结状态。但是，如果客户端被强制关闭，那么服务器也会被强制关闭。这就是我看到的模式。它发布到登录事件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

Run Code Online (Sandbox Code Playgroud)

客户端代码（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

Run Code Online (Sandbox Code Playgroud)

Answer 1

Rem*_*eau 5

您的服务器冻结的原因是您的服务器代码死锁了。

对于连接到的每个客户端，TIdCmdTCPServer都会创建一个工作线程，该线程不断从该连接读取入站命令，以便它可以触发集合中的TIdCommandHandler.OnCommand事件TIdCmdTCPServer.CommandHandlers。 TCli.DoTest()调用TIdTCPConnection.SendCmd()向客户端发送命令并读取其响应。您在主线程的上下文中调用TCli.DoTest()（因此SendCmd()），因此您有两个单独的线程上下文试图同时从同一个连接读取，从而导致竞争条件。内部运行的工作线程TIdCmdTCPServer可能正在读取SendCmd()预期数据的部分（如果不是全部）并且永远不会看到，因此SendCmd()无法正确退出，阻止主消息循环再次处理新消息，因此冻结。

TIdAntiFreeze通过允许主线程上下文在SendCmd()死锁时继续处理消息，在服务器应用程序中放置 a可以帮助避免冻结。但这不是真正的解决方案。要真正解决这个问题，您需要重新设计您的服务器应用程序。首先，不要使用TIdCmdTCPServerwith 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.

Run Code Online (Sandbox Code Playgroud)

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

Run Code Online (Sandbox Code Playgroud)

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.

Run Code Online (Sandbox Code Playgroud)

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

Run Code Online (Sandbox Code Playgroud)

“对于初学者，不要将 TIdCmdTCPServer 与 TIdCmdTCPClient 一起使用，因为它们不是设计为一起使用的。” 那为什么它们的名称和图标几乎相同？它们比豌豆和胡萝卜更适合搭配。 (2认同)

归档时间：	13 年，10 月前
查看次数：	5377 次
最近记录：	13 年，7 月前