一个应用程序中的 TIpTCPServer 和 Client

Question

我做了一个客户端和服务器在同一个程序中的应用程序。我使用 Delphi XE7 和组件 TIpTCPServer / ... 客户端。但是当我尝试关闭连接客户端的服务器时（在同一个 window 中），程序停止响应。也许这与多线程有关。如何在一个应用程序中实现具有客户端和服务器的程序，这是正确的方法吗？

procedure TfrmMain.startClick(Sender: TObject);
begin
  if (server.active) then stopServer()
  else startServer();
end;

procedure TfrmMain.startServer();
var
  binding: TIdSocketHandle;
begin
  server.bindings.clear();

  try
    server.defaultPort := strToInt(port.text);
    binding := server.bindings.add();
    binding.ip := ip;
    binding.port := strToInt(port.text);

    server.active := true;

    if (server.active) then begin
      addToLog('Server started');
      start.caption := 'Stop';
    end;
  except on e: exception do
    addToLog('Error: ' + e.message + '.');
  end;
end;

procedure TfrmMain.stopServer();
begin
  server.active := false;
  server.bindings.clear();

  if (not(server.active)) then begin
    addToLog('Server stopped');
    start.caption := 'Start';
  end
  else addToLog('Server shutdown error.');
end;

procedure TfrmMain.serverConnect(AContext: TIdContext);
var
  i: integer;
begin
  addToLog('New client: ' + aContext.connection.socket.binding.peerIP + '.');

  clients.clear();
  for i := 0 to server.contexts.lockList.count - 1 do begin
    with TIdContext(server.contexts.lockList[i]) do
      clients.items.add(connection.socket.binding.peerIP);
  end;
  server.contexts.unlockList();
end;

procedure TfrmMain.serverDisconnect(AContext: TIdContext);
begin
  addToLog('Client ' + aContext.connection.socket.binding.peerIP + ' disconnected from the server.');
end;

procedure TfrmMain.clientConnected(Sender: TObject);
begin
  addToConsole('You connected to server successfully.');
end;

procedure TfrmMain.clientDisconnected(Sender: TObject);
begin
  addToConsole('The connection to the server was interrupted.');
end;

和连接代码：

client.host := ip;

try
  client.connect();
except on e: exception do
  addToConsole('Error: ' + e.message);
end;

Answer 1

我发现此代码存在许多问题。

addToLog()和addToConsole()是如何实现的？它们是线程安全的吗？请记住 TIdTCPServer 是一个多线程组件，它的事件是在工作线程的上下文中触发的，而不是主 UI 线程，因此任何对 UI、共享变量等的访问必须同步。
什么是clients？是UI控件吗？您需要同步访问它，这样当多个线程试图同时访问它时您就不会破坏它的内容。
您对 TIdTCPServer.Contexts 属性的使用未得到充分保护免受异常影响。您需要一个 try..finally 块以便您可以安全地调用 Contexts.UnlockList()。
更重要的是，您在 serverConnect() 循环中调用了 Contexts.LockList() 太多次 （这是您的根本原因问题）。 LockList() returns 一个 TIdContextList 对象。在循环中，您应该访问该列表的 Items[] 属性而不是再次调用 LockList() 。因为你没有为每个 LockList() 匹配的 UnlockList()，一旦客户端连接到你的服务器，Contexts 列表就会陷入僵局，并且无法再访问一次 serverConnect()退出，包括客户端 connect/disconnect 和 TIdTCPServer 关闭期间（例如您的情况）。
serverDisconnect() 没有从 clients 中删除任何项目。 serverConnect() 根本不应该重置 clients。它应该只将调用 TIdContext 添加到 clients，然后 serverDisconnect() 应该稍后从 clients 中删除相同的 TIdContext。

话虽如此，请尝试更像这样的事情：

procedure TfrmMain.addToConsole(const AMsg: string);
begin
  TThread.Queue(nil,
    procedure
    begin
      // add AMsg to console ...
    end
  );
end;

procedure TfrmMain.addToLog(const AMsg: string);
begin
  TThread.Queue(nil,
    procedure
    begin
      // add AMsg to log ...
    end
  );
end;

procedure TfrmMain.startClick(Sender: TObject);
begin
  if server.Active then
    stopServer()
  else
    startServer();
end;

procedure TfrmMain.startServer();
var
  binding: TIdSocketHandle;
begin
  server.Bindings.Clear();

  try
    server.DefaultPort := StrToInt(port.Text);
    binding := server.Bindings.Add();
    binding.IP := ip;
    binding.Port := StrToInt(port.Text);

    server.Active := True;

    addToLog('Server started');
    start.Caption := 'Stop';
  except
    on e: Exception do
      addToLog('Error: ' + e.message + '.');
  end;
end;

procedure TfrmMain.stopServer();
begin
  try
    server.Active := False;
    server.Bindings.Clear();

    addToLog('Server stopped');
    start.Caption := 'Start';
  except
    on e: Exception do
      addToLog('Server shutdown error.');
  end;
end;

procedure TfrmMain.serverConnect(AContext: TIdContext);
var
  PeerIP: string;
begin
  PeerIP := AContext.Binding.PeerIP;
  addToLog('New client: ' + PeerIP + '.');

  TThread.Queue(nil,
    procedure
    {
    var
      i: integer;
      list: TIdContextList;
    }
    begin
      {
      clients.clear();
      list := server.Contexts.LockList;
      try
        for i := 0 to list.count - 1 do begin
          clients.Items.Add(TIdContext(list[i]).Binding.PeerIP);
        end;
      finally
        list.UnlockList();
      end;
      }

      // I'm assuming clients is a UI control whose Items property
      // is a TStrings object.  If not, adjust this code as needed...
      clients.Items.AddObject(PeerIP, AContext);
    end;
  );
end;

procedure TfrmMain.serverDisconnect(AContext: TIdContext);
begin
  addToLog('Client ' + AContext.Binding.PeerIP + ' disconnected from the server.');

  TThread.Queue(nil,
    procedure
    var
      i: Integer;
    begin
      // I'm assuming clients is a UI control whose Items property
      // is a TStrings object.  If not, adjust this code as needed...
      i := clients.Items.IndexOfObject(AContext);
      if i <> -1 then
        clients.Items.Delete(i);
    end
  );
end;

procedure TfrmMain.clientConnected(Sender: TObject);
begin
  addToConsole('You connected to server successfully.');
end;

procedure TfrmMain.clientDisconnected(Sender: TObject);
begin
  addToConsole('The connection to the server was interrupted.');
end;

一个应用程序中的 TIpTCPServer 和 Client

TIpTCPServer and Client in one application

delphi

indy

indy10

delphi-xe

delphi-xe7