Question

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

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()。
更重要的是，您在Contexts.LockList()循环中多次调用serverConnect() （这是问题的根本原因）。 LockList()返回一个TIdContextList对象。在循环内部，您应该访问该列表的Items[]属性，而不是再次调用LockList()。由于每个UnlockList()都没有匹配的LockList()，因此一旦客户端连接到服务器，Contexts列表将陷入死锁状态，并且serverConnect()将无法再访问退出，包括客户端连接/断开连接的时间以及TIdTCPServer关闭期间（例如您的情况）。
serverDisconnect()并未从clients中删除任何项目。 serverConnect()完全不应重设clients。它应该仅将呼叫TIdContext添加到clients中，然后serverDisconnect()随后应从TIdContext中删除相同的clients。

话虽如此，请尝试以下类似操作：

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和客户端

1 个答案: