TIpTCPServer и клиент в одном приложении - PullRequest
Новая
       55

TIpTCPServer и клиент в одном приложении

0 голосов
/ 25 сентября 2018

Я делаю приложение, где клиент и сервер находятся в одной программе.Я использую Delphi XE7 и компоненты TIpTCPServer / ... Client.Но когда я пытаюсь закрыть сервер с подключенным клиентом (в том же окне), программа перестает отвечать на запросы.Возможно, это связано с многопоточностью.Как реализовать программу с клиентом и сервером в одном приложении, и это правильный подход? 

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;

1 Ответ

0 голосов
/ 25 сентября 2018

Я вижу ряд проблем с этим кодом.

  • Как реализованы addToLog() и addToConsole()?Они потокобезопасны?Помните, что TIdTCPServer является многопоточным компонентом, его события запускаются в контексте рабочих потоков, а не основного потока пользовательского интерфейса, поэтому любой доступ к пользовательскому интерфейсу, общим переменным и т. Д. Должен быть синхронизирован.

  • Что такое clients?Это пользовательский интерфейс?Вам необходимо синхронизировать доступ к нему, чтобы не повредить его содержимое, когда несколько потоков пытаются получить к нему доступ одновременно.

  • Использование свойства 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;
...