[英]Delphi XE2 Indy 10 TIdCmdTCPServer freezing application
I'm just starting to learn how to use the Indy 10 components in Delphi XE2. 我刚刚开始学习如何在Delphi XE2中使用Indy 10组件。 I started with a project that will use the command sockets (
TIdCmdTCPServer
and TIdCmdTCPClient
). 我从一个将使用命令套接字(
TIdCmdTCPServer
和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.
有一个小型服务器应用程序和一个小型客户端应用程序,每个应用程序都有其对应的Indy命令tcp套接字组件。 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). 在服务器上,我为上下文
type TCli = class(TIdServerContext)
提供了一个非常简单的包装,该包装仅包含一个公共属性(继承实际上是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.
目前设置为在应用启动1秒后尝试连接,如果尚未连接,则每10秒尝试尝试连接一次。
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. 我在服务器上具有
OnConnect
, OnDisconnect
, OnContextCreated
和OnException
事件处理程序,它们的全部作用实际上是发布日志或在列表视图中处理连接/断开连接对象。
Screen Shot 屏幕截图
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. 它使用
PostLog(const S: String)
将事件发布到日志中,该事件仅将短消息附加到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 ) 服务器代码 ( 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
Client Code ( uClient.pas and uClient.dfm ) 客户端代码 ( 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
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. 对于连接到每一个客户端
TIdCmdTCPServer
,创建工作线程将继续从该连接入站命令,以便它可以触发TIdCommandHandler.OnCommand
在事件TIdCmdTCPServer.CommandHandlers
集合。 TCli.DoTest()
calls TIdTCPConnection.SendCmd()
to send a command to a client and read its response. TCli.DoTest()
调用TIdTCPConnection.SendCmd()
将命令发送到客户端并读取其响应。 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. 您呼叫
TCli.DoTest()
因此SendCmd()
在主线程的上下文中),所以你有两个独立的线程上下文试图从在同一时间同一个连接来读取,从而导致竞争条件。 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. 在
TIdCmdTCPServer
内部运行的辅助线程可能会读取SendCmd()
期望且永远不会看到的部分数据(如果不是全部),因此SendCmd()
无法正确退出,从而阻止了主消息循环的处理新消息再次出现,冻结了。
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. 将
TIdAntiFreeze
放置在服务器应用程序中可以通过避免主线程上下文在SendCmd()
死锁时继续处理消息来帮助避免冻结。 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. 对于初学者,请勿将
TIdCmdTCPServer
与TIdCmdTCPClient
TIdCmdTCPServer
使用,因为它们并非旨在一起使用。 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
. 如果服务器要向客户端发送命令,而客户端从不向服务器发送命令,则使用普通的
TIdTCPServer
而不是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. 您的服务器事件处理程序未执行线程安全操作,因此您需要
TCli.DoTest()
的调用移出主线程上下文。
Try this code: 试试这个代码:
uServer.pas: 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: 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: 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: 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
Have you tried debugging the server? 您是否尝试过调试服务器?
The line 线
Result:= TCli(AContext);
(hard cast of TIdContext) looks like a potential reason for the freeze. (对TIdContext进行强制转换)看起来像是冻结的潜在原因。
Have you read this, how to make the TIdCustomTCPServer aware of your own TIdServerContext class? 您读过这篇文章,如何使TIdCustomTCPServer知道您自己的TIdServerContext类?
https://stackoverflow.com/a/5514932/80901 https://stackoverflow.com/a/5514932/80901
The relevant code in the answer: 答案中的相关代码:
constructor TOurServer.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
...
ContextClass := TOurContext;
...
end;
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.