Indy TCPServer冻结: Active => False

Question

当我运行时，我试图找出为什么我的应用程序会冻结: IdTCPServer1.Active 1. trying := False；

当没有客户端连接时，就没有问题了。当一个或多个客户端连接时，它就会冻结。

如果有人能找到我犯错误的地方。(我是德尔菲的新手，如果你看到了其他的错误，或者用错误的方式.告诉我)

 TLog = class(TIdSync)
        protected
            FMsg: String;
            procedure DoSynchronize; override;
        public
            constructor Create(const AMsg: String);
            class procedure AddMsg(const AMsg: String);
        end;


procedure TLog.DoSynchronize;
  begin
    Form2.AddInfoDebugger( 'RECEPTION', FMsg );
  end;


class procedure TLog.AddMsg( const AMsg : String );
  begin
    with Create( AMsg ) do
      try
        Synchronize;
      finally
        Free;
      end;
  end;


constructor TLog.Create( const AMsg : String );
  begin
    FMsg := AMsg;
    inherited Create;
  end;


  /// TFORM 2 ///

constructor TForm2.Create( AOwner : TComponent );
  begin
    inherited Create( AOwner );
    LoadIniConfiguration;

    IdTCPServer1.ContextClass := TMyContext;
    IdTCPServer1.DefaultPort := IndyServerPort;
    DictionaryMessage := TDictionaryMessage.Create;

    fSvrClose := False;

    if fileexists( SaveFileName )
    then
      DictionaryMessage.LoadFromFile( SaveFileName );
    UpdateListQuestions;
    if IndyAutoStart
    then
      StartStopIndyServer;

    // add info state debug save
    if DebugConfigState
    then
      LabelStateDebugSave.Caption :=
        'Sauvegarde des journaux sur disque: Activé'
    else
      LabelStateDebugSave.Caption :=
        'Sauvegarde des journaux sur disque: Désactivé';

  end;


procedure TForm2.FormClose(
  Sender     : TObject;
  var action : TCloseAction );
  var
    iA : integer;
    Context : TIdContext;
  begin
    if IdTCPServer1.Active
    then
    begin
      fSvrClose := true;
      IdTCPServer1.Active := False;
      fSvrClose := False;
    end;

  end;

// ******
// ******INDY procedures START*******//
// ******


procedure TForm2.StartStopIndyServer;
  begin
    if not IdTCPServer1.Active
    then
    begin
      IdTCPServer1.Active := true;
      Form2.AddInfoDebugger( 'ONLINE',
        'Server is now connected and ready to accept clients' );
      ListBoxClients.Clear;
      ListBoxClients.Items.Add( 'Serveur' );
      UpdateCountClients;
      Button1.Caption := 'Arret';
    end
    else
    begin
      fSvrClose := true;
      IdTCPServer1.Active := False;
      fSvrClose := False;
      ListBoxClients.Clear;
      Form2.AddInfoDebugger( 'Offline', 'Server is now disconnected' );
      Button1.Caption := 'Démarrer';
      UpdateCountClients;
    end;
  end;


procedure TForm2.tsConnect( AContext : TIdContext );
  begin
    with TMyContext( AContext ) do
    begin
      Con := Now;
      if ( Connection.Socket <> nil )
      then
        IP := Connection.Socket.Binding.PeerIP;

      Nick := Connection.IOHandler.ReadLn;
      if Nick <> ''
      then
      begin
        Connection.IOHandler.WriteLn( 'Welcome ' + Nick + '!' );
        ListBoxClients.Items.Add( Nick );

      end
      else
      begin
        Connection.IOHandler.WriteLn( 'No Nick provided! Goodbye.' );
        Connection.Disconnect;
      end;
    end;
  end;


procedure TForm2.tsExecute( AContext : TIdContext );
  var
    FMsg, FMSG2, FMSG3, msg, str, toname, filename, cmd, from,
      orsender : string;
    FStream, fstream2 : TFileStream;
    MStream : TMemoryStream;
    idx, posi, col : integer;
    Name1, Name2, Name3, MainStr : string;
    RXStreamRichedit, DictionaryMessageStream : TStringStream;
    LStreamSize : int64;
  begin
        //Empty for test//
  end;


procedure TForm2.tsDisconnect( AContext : TIdContext );
  begin
    AContext.Connection.Socket.InputBuffer.Clear;
    AContext.Connection.Disconnect;
    TLog.AddMsg( TMyContext( AContext ).Nick + ' Left the chat' );
    ListBoxClients.Items.Delete
      ( ListBoxClients.Items.IndexOf( TMyContext( AContext ).Nick ) );
  end;

编辑

问题在于ListBoxClients在tsConnect和tsDisconnect中的应用。我在寻找一种让它成为ThreadSafe的方法。

Answer 1

雷米·莱博是对的！

我确实看到了一些不是线程安全的代码，例如tsConnect() andtsDisconnect()访问ListBoxClients而不与主UI线程同步。

我已经能够通过以下方法解决我的问题：

  TLog = class( TIdSync )
    protected
      FMsg : String;
      procedure DoSynchronize; override;
    public
      constructor Create( const AMsg : String );
      class procedure ProcessMsg( const AMsg : String );
  end;


procedure TLog.DoSynchronize;
var
posi: integer;
MsgCommand, ContentCommand: string;
  begin
    posi := Pos( '@', FMsg );
    MsgCommand := Copy( FMsg, 1, posi - 1 );
    ContentCommand := Copy( FMsg, Pos( '@', FMsg ) + 1, Length( FMsg ) - Pos( '@', FMsg ) );

    if MsgCommand = 'AddListBox' then
      Form2.ListBoxClients.items.Add( ContentCommand )
    else if MsgCommand = 'DelListBox' then
      Form2.ListBoxClients.Items.Delete(Form2.ListBoxClients.Items.IndexOf( ContentCommand ));


  end;


class procedure TLog.ProcessMsg( const AMsg : String );
  begin
    if not fSvrClose then
    begin
      with Create( AMsg ) do
        try
          Synchronize;
        finally
          Free;
        end;
    end;
  end;


constructor TLog.Create( const AMsg : String );
  begin
    FMsg := AMsg;
    inherited Create;
  end;

改变我的tsConnect和tsDisconnect

TLog.ProcessMsg('AddListBox@'+Nick);

不知道这是不是正确的方法，但它是有效的。