堆栈内存溢出
  繁体   English   中英

Delphi XE2 Indy 10 TIdCmdTCPServer冻结应用程序

[英]Delphi XE2 Indy 10 TIdCmdTCPServer freezing application

 原文  2012-02-04 09:48:57  9   2    delphi/ delphi-xe2/ freeze/ indy/ indy10

问题描述

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

项目设置

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

服务器应用

在服务器上，我为上下文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

2 个解决方案

解决方案1
 3 已采纳  2012-02-07 01:08:31

服务器冻结的原因是因为您使服务器代码陷入僵局。

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

将TIdAntiFreeze放置在服务器应用程序中可以通过避免主线程上下文在SendCmd()死锁时继续处理消息来帮助避免冻结。 但这不是一个真正的解决方案。 要真正解决此问题，您需要重新设计服务器应用程序。 对于初学者，请勿将TIdCmdTCPServer与TIdCmdTCPClient TIdCmdTCPServer使用，因为它们并非旨在一起使用。 如果服务器要向客户端发送命令，而客户端从不向服务器发送命令，则使用普通的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

解决方案2
 1  2012-02-04 10:39:04

您是否尝试过调试服务器？

线 

Result:= TCli(AContext);

（对TIdContext进行强制转换）看起来像是冻结的潜在原因。

您读过这篇文章，如何使TIdCustomTCPServer知道您自己的TIdServerContext类？

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

答案中的相关代码： 

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

  ...

    ContextClass := TOurContext;

  ...
end;

暂无
暂无

声明:本站的技术帖子网页，遵循CC BY-SA 4.0协议，如果您需要转载，请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.

相关问题 Delphi（XE2）Indy（10）多线程Ping 如何重建Delphi XE2随附的Indy 10？ 在Delphi XE2中通过Indy使用curl Delphi XE2 Indy IRC Unicode 如何获取delphi Xe2 Indy 10套接字服务器对等主机名 Indy TCPServer缺少数据。 德尔福XE2 Delphi XE2 / Indy TIdTCPServer /“对等方重置连接” 使用 Delphi XE2 为 Indy 升级 TLSv1_1 和 TLSv1_2 Indy DnsResolver无效数据包大小Delphi XE2 iOS上的Delphi XE2，带有Indy或第三方Internet组件
相关标签
 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM