Question

点击btDisconn按钮后，Memo1的结果仍为“ConnCnt：1”，但我等了好几分钟。

但是在windows xp下它运行正常，如何让idtcpserver删除无效的上下文线程？

这是我的代码：

客户端（Windows7 + DelphiXE2 + Indy10.5.8）：

procedure TForm1.FormShow(Sender: TObject);
begin
  TcpClient.Host:=192.168.1.103;
  TcpClient.Port:=10000;
  TcpClient.Connect;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  try
    TcpClient.Disconnect;
  except
  end;
end;

服务器端（Vmware + CentOS + Lararus1.0.12 + Indy10.5.8）

procedure TForm1.FormShow(Sender: TObject);
var Bind:TIdSocketHandle;
begin
  TCPServer.Bindings.Clear;
  Bind:=TCPServer.Bindings.Add;
  Bind.IPVersion:=Id_IPv4;
  Bind.Port:=10000;
  TcpServer.OnExecute:=@TcpServerExecute;
  TcpServer.DefaultPort:=10000;
  TcpServer.Active:=true;
  Timer1.Interval:=5000;
  Timer1.Enabled:=true;
end;

procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
  Timer1.Enabled:=false;
  TcpServer.Active:=false;
end;

procedure TForm1.TcpServerExecute(AContext: TIdContext);
var b:Byte;
begin
  try
    b:=AContext.Connection.IOHandler.ReadByte();
  except
    on E:Exception do memo1.Lines.Add('Error:'+E.Message)
  end;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var lst:TList;
begin
  try
    lst:=TcpServer.Contexts.LockList();
    Memo1.Lines.Add('ConnCnt:'+inttostr(lst.Count));//the result is still ConnCnt:1 after i click btDisconn
  finally
    TcpServer.Contexts.UnlockList();
  end;
end;

procedure TForm1.btDisconnClick(Sender: TObject);
var i:Integer;lst:TList;itm:TIdContext;
begin
  try
    lst:=TcpServer.Contexts.LockList();
    for i:=0 to lst.Count-1 do begin
      itm:=TIdContext(lst.Items[i]);
      if Assigned(itm) then begin
        itm.Connection.Disconnect();
        itm.Connection.IOHandler.DiscardAll;
      end;
    end;
  finally
    TcpServer.Contexts.UnlockList();
  end;
end;

Answer 1

您的服务器代码存在两个问题，导致其无法正常关闭：

您的OnExecute代码正在捕获并丢弃所有异常，并且不允许TIdTCPServer处理其中任何异常。当TIdTCPServer被取消激活时，它会关闭所有活动套接字，这反过来会导致当前/后续套接字操作失败并引发异常。通过丢弃例外，TIdTCPServer不知道连接已经关闭，并且愉快地继续调用OnExecute事件。如果必须捕获异常（例如记录它们），则需要在完成任何特定于Indy的异常时重新引发它们，以便TIdTCPServer可以处理它们。
您是以线程不安全的方式访问TMemo，这可能（除其他外）导致死锁。

请改为尝试：

uses
  ..., IdSync;

type
  TMemoNotify = class(TIdNotify)
  protected
    FMsg: String;
    procedure DoNotify; override;
  public
    class procedure AddToMemo(const AMsg: string);
  end;

procedure TMemoNotify.DoNotify;
begin
  Form1.Memo1.Lines.Add(FMsg);
end;

class procedure TMemoNotify.AddToMemo(const AMsg: string);
begin
  with Create do
  begin
    FMsg := AMsg;
    Notify;
  end;
end;

uses
  ..., EIdException;

procedure TForm1.FormShow(Sender: TObject);
var
  Bind: TIdSocketHandle;
begin
  TCPServer.Bindings.Clear;
  Bind := TCPServer.Bindings.Add;
  Bind.IPVersion := Id_IPv4;
  Bind.Port := 10000;
  TcpServer.OnExecute := TcpServerExecute;
  TcpServer.Active := True;
  Timer1.Interval := 5000;
  Timer1.Enabled := True;
end;

procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
  Timer1.Enabled := False;
  TcpServer.Active := False;
end;

procedure TForm1.TcpServerExecute(AContext: TIdContext);
var
  b: Byte;
begin
  try
    b := AContext.Connection.IOHandler.ReadByte;
  except
    on E: Exception do
    begin
      TMemoNotify.AddToMemo('Error:'+E.Message);
      if E is EIdException then raise;
    end;
  end;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  lst: TList;
begin
  lst := TcpServer.Contexts.LockList;
  try
    Memo1.Lines.Add('ConnCnt:'+IntToStr(lst.Count));
  finally
    TcpServer.Contexts.UnlockList;
  end;
end;

procedure TForm1.btDisconnClick(Sender: TObject);
var
  i: Integer;
  lst: TList;
begin
  lst := TcpServer.Contexts.LockList;
  try
    for i := 0 to lst.Count-1 do
    begin
      try
        TIdContext(lst.Items[i]).Connection.Disconnect;
       except
       end;
    end;
  finally
    TcpServer.Contexts.UnlockList;
  end;
end;

除了重新引发Indy异常之外，您可以完全摆脱OnExecute事件中的异常处理并改为使用TIdTCPServer.OnException事件：

procedure TForm1.TcpServerExecute(AContext: TIdContext);
var
  b: Byte;
begin
  b := AContext.Connection.IOHandler.ReadByte;
  ...
end;

procedure TForm1.TcpServerException(AContext: TIdContext; AException: Exception);
begin
  TMemoNotify.AddToMemo('Error:'+AException.Message);
end;

IdTcpServer无法在CentOS + Lazarus下的context.connection.disconnect（）之后释放其上下文线程

1 个答案: