设置 Active = false 时 TIdTCPServer 挂起

6
投票

ExitThread()

 无法挂起，除非 DLL 在其

DllMain

DllEntryPoint()

 处理程序中行为不当，导致 DLL 加载器死锁。但是，服务器的

Active

 属性设置器肯定会挂起，例如任何客户端线程死锁。

您链接到的示例不是一个值得遵循的好示例。线程事件处理程序正在执行非线程安全的操作。它们在不与主 UI 线程同步的情况下访问 UI 控件，这可能会导致许多问题，包括死锁和死 UI 控件。而且服务器的广播方法实现完全错误，很容易出现死锁、崩溃和数据损坏。

无论谁写了这个例子（不是我）显然不知道他们在做什么。需要重写它以正确考虑线程安全。尝试更多类似这样的事情：

unit UServer;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, IdContext, IdComponent, Vcl.StdCtrls,
  IdBaseComponent, IdCustomTCPServer, IdTCPServer, Vcl.ExtCtrls;

type
  TFServer = class(TForm)
    Title         : TLabel;

    btn_start     : TButton;
    btn_stop      : TButton;
    btn_clear     : TButton;

    clients_connected : TLabel;

    IdTCPServer   : TIdTCPServer;
    Label1        : TLabel;
    Panel1        : TPanel;
    messagesLog   : TMemo;

    procedure FormShow(Sender: TObject);

    procedure btn_startClick(Sender: TObject);
    procedure btn_stopClick(Sender: TObject);
    procedure btn_clearClick(Sender: TObject);

    procedure IdTCPServerConnect(AContext: TIdContext);
    procedure IdTCPServerDisconnect(AContext: TIdContext);
    procedure IdTCPServerExecute(AContext: TIdContext);
    procedure IdTCPServerStatus(ASender: TObject; const AStatus: TIdStatus;
                                const AStatusText: string);

  private
    { Private declarations }

    procedure broadcastMessage(p_message : string);
    procedure Log(p_who, p_message: string);
    procedure UpdateClientsConnected(ignoreOne: boolean);

  public
    { Public declarations }

  end;
  // ...

var
  FServer     : TFServer;

implementation

uses
  IdGlobal, IdYarn, IdThreadSafe;

{$R *.dfm}

// ... listening port
const
  GUEST_CLIENT_PORT = 20010;

// *****************************************************************************
//   CLASS : TMyContext
//           HELPER CLASS FOR QUEUING OUTBOUND MESSAGES TO A CLIENT
// *****************************************************************************
type
  TMyContext = class(TIdServerContext)
  private
    FQueue: TIdThreadSafeStringList;
    FAnyInQueue: Boolean;
  public
    constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
    destructor Destroy; override;
    procedure AddToQueue(p_message: string);
    procedure CheckQueue;
  end;

constructor TMyContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
  inherited Create(AConnection, AYarn, AList);
  FQueue := TIdThreadSafeStringList.Create;
  FAnyQueued := false;
end;

destructor TMyContext.Destroy;
begin
  FQueue.Free;
  inherited;
end;

procedure TMyContext.AddToQueue(p_message: string);
begin
  with FQueue.Lock do
  try
    Add(p_message);
    FAnyInQueue := true;
  finally
    FQueue.Unlock;
  end;
end;

procedure TMyContext.CheckQueue;
var
  queue, tmpList  : TStringList;
  i               : integer;
begin
  if not FAnyInQueue then Exit;
  tmpList := TStringList.Create;
  try
    queue := FQueue.Lock;
    try
      tmpList.Assign(queue);
      queue.Clear;
      FAnyInQueue := false;
    finally
      FQueue.Unlock;
    end;
    for i := 0 to tmpList.Count - 1 do begin
      Connection.IOHandler.WriteLn(tmpList[i]);
    end;
  finally
    tmpList.Free;
  end;
end;
// .............................................................................


// *****************************************************************************
//   EVENT : onShow()
//           ON FORM SHOW
// *****************************************************************************
procedure TFServer.FormShow(Sender: TObject);
begin
  // ... INITIALIZE:

  // ... clear message log
  messagesLog.Lines.Clear;

  // ... zero to clients connected
  clients_connected.Caption := IntToStr(0);

  // ... set buttons
  btn_start.Visible := true;
  btn_start.Enabled := true;
  btn_stop.Visible  := false;

  // ... set context class
  IdTCPServer.ContextClass := TMyContext;
end;
// .............................................................................


// *****************************************************************************
//   EVENT : btn_startClick()
//           CLICK ON START BUTTON
// *****************************************************************************
procedure TFServer.btn_startClick(Sender: TObject);
begin
  btn_start.Enabled := false;

  // ... START SERVER:

  // ... clear the Bindings property ( ... Socket Handles )
  IdTCPServer.Bindings.Clear;
  // ... Bindings is a property of class: TIdSocketHandles;

  // ... add listening ports:

  // ... add a port for connections from guest clients.
  IdTCPServer.Bindings.Add.Port := GUEST_CLIENT_PORT;
  // ... etc..

  // ... ok, Active the Server!
  IdTCPServer.Active  := true;

  // ... hide start button
  btn_start.Visible   := false;

  // ... show stop button
  btn_stop.Visible    := true;
  btn_stop.Enabled    := true;

  // ... message log
  Log('SERVER', 'STARTED!');

end;
// .............................................................................


// *****************************************************************************
//   EVENT : btn_stopClick()
//           CLICK ON STOP BUTTON
// *****************************************************************************
procedure TFServer.btn_stopClick(Sender: TObject);
begin
  btn_stop.Enabled := false;

  // ... before stopping the server ... send 'good bye' to all clients connected
  broadcastMessage( 'Goodbye my Clients :)');

  // ... stop server!
  IdTCPServer.Active := false;

  // ... hide stop button
  btn_stop.Visible   := false;

  // ... show start button
  btn_start.Visible  := true;
  btn_start.Enabled  := true;

  // ... message log
  Log('SERVER', 'STOPPED!');

end;
// .............................................................................


// *****************************************************************************
//   EVENT : btn_clearClick()
//           CLICK ON CLEAR BUTTON
// *****************************************************************************
procedure TFServer.btn_clearClick(Sender: TObject);
begin
  //... clear messages log
  MessagesLog.Lines.Clear;
end;
// .............................................................................


// *****************************************************************************
//   EVENT : onConnect()
//           OCCURS ANY TIME A CLIENT IS CONNECTED
// *****************************************************************************
procedure TFServer.IdTCPServerConnect(AContext: TIdContext);
var
  PeerIP      : string;
  PeerPort    : TIdPort;
begin

  // ... OnConnect is a TIdServerThreadEvent property that represents the event
  //     handler signalled when a new client connection is connected to the server.

  // ... Use OnConnect to perform actions for the client after it is connected
  //     and prior to execution in the OnExecute event handler.

  // ... see indy doc:
  //     http://www.indyproject.org/sockets/docs/index.en.aspx

  // ... getting IP address and Port of Client that connected
  PeerIP    := AContext.Binding.PeerIP;
  PeerPort  := AContext.Binding.PeerPort;

  // ... message log ...........................................................
  Log('SERVER', 'Client Connected! Peer=' + PeerIP + ':' + IntToStr(PeerPort));
  // ...

  // ... update number of clients connected
  UpdateClientsConnected(false);
  // ...

  // ... send the Welcome message to Client connected
  AContext.Connection.IOHandler.WriteLn('Welcome GUEST Client :)');

end;
// .............................................................................


// *****************************************************************************
//   EVENT : onDisconnect()
//           OCCURS ANY TIME A CLIENT IS DISCONNECTED
// *****************************************************************************
procedure TFServer.IdTCPServerDisconnect(AContext: TIdContext);
var
  PeerIP      : string;
  PeerPort    : TIdPort;
begin

  // ... getting IP address and Port of Client that connected
  PeerIP    := AContext.Binding.PeerIP;
  PeerPort  := AContext.Binding.PeerPort;

  // ... message log ...........................................................
  Log('SERVER', 'Client Disconnected! Peer=' + PeerIP + ':' + IntToStr(PeerPort));
  // ...

  // ... update number of clients connected
  UpdateClientsConnected(true);
  // ...

end;
// .............................................................................


// *****************************************************************************
//   EVENT : onExecute()
//           ON EXECUTE THREAD CLIENT
// *****************************************************************************
procedure TFServer.IdTCPServerExecute(AContext: TIdContext);
var
  PeerIP        : string;
  PeerPort      : TIdPort;
  msgFromClient : string;
begin

  // ... OnExecute is a TIdServerThreadEvents event handler used to execute
  //     the task for a client connection to the server.

  // ... check for pending broadcast messages to the client
  TMyContext(AContext).CheckQueue;
  // ...

  // check for inbound messages from client
  if AContext.Connection.IOHandler.InputBufferIsEmpty then
  begin
    AContext.Connection.IOHandler.CheckForDataOnSource(100);
    AContext.Connection.IOHandler.CheckForDisconnect;
    if AContext.Connection.IOHandler.InputBufferIsEmpty then Exit;
  end;

  // ... received a message from the client

  // ... get message from client
  msgFromClient := AContext.Connection.IOHandler.ReadLn;

  // ... getting IP address, Port and PeerPort from Client that connected
  PeerIP    := AContext.Binding.PeerIP;
  PeerPort  := AContext.Binding.PeerPort;

  // ... message log ...........................................................
  Log('CLIENT', '(Peer=' + PeerIP + ':' + IntToStr(PeerPort) + ') ' + msgFromClient);
  // ...

  // ... process message (request) from Client

  // ...

  // ... send response to Client

  AContext.Connection.IOHandler.WriteLn('... response from server :)');

end;
// .............................................................................


// *****************************************************************************
//   EVENT : onStatus()
//           ON STATUS CONNECTION
// *****************************************************************************
procedure TFServer.IdTCPServerStatus(ASender: TObject; const AStatus: TIdStatus;
                                     const AStatusText: string);
begin

  // ... OnStatus is a TIdStatusEvent property that represents the event handler
  //     triggered when the current connection state is changed...

  // ... message log
  Log('SERVER', AStatusText);
end;
// .............................................................................


// *****************************************************************************
//   PROCEDURE : broadcastMessage()
//               BROADCAST A MESSAGE TO ALL CLIENTS CONNECTED
// *****************************************************************************
procedure TFServer.broadcastMessage( p_message : string );
var
  tmpList      : TIdContextList;
  contexClient : TIdContext;
  i            : integer;
begin

  // ... send a message to all clients connected

  // ... get context Locklist
  tmpList := IdTCPServer.Contexts.LockList;
  try
    for i := 0 to tmpList.Count-1 do begin
      // ... get context ( thread of i-client )
      contexClient := tmpList[i];

      // ... queue message to client
      TMyContext(contexClient).AddToQueue(p_message);
    end;
  finally
    // ... unlock list of clients!
    IdTCPServer.Contexts.UnlockList;
  end;

end;
// .............................................................................


// *****************************************************************************
//   PROCEDURE : Log()
//               LOG A MESSAGE TO THE UI
// *****************************************************************************
procedure TFServer.Log(p_who, p_message : string);
begin
  TThread.Queue(nil,
    procedure
    begin
      MessagesLog.Lines.Add('[' + p_who + '] - ' + FormatDateTime('yyyy-mm-dd hh:nn:ss', Now) + ': ' + p_message);
    end
  );
end;
// .............................................................................


// *****************************************************************************
//   PROCEDURE : UpdateClientsConnected()
//               DISPLAY THE NUMBER OF CLIENTS CONNECTED
// *****************************************************************************
procedure TFServer.UpdateClientsConnected(ignoreOne: Boolean);
var
  NumClients: integer;
begin
  with IdTCPServer.Contexts.LockList do
  try
    NumClients := Count;
  finally
    IdTCPServer.Contexts.UnlockList;
  end;

  if ignoreOne then Dec(NumClients);

  TThread.Queue(nil,
    procedure
    begin
      clients_connected.Caption := IntToStr(NumClients);
    end
  );
end;
// .............................................................................

end.

unit UClient;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, IdBaseComponent,
  IdComponent, IdTCPConnection, IdTCPClient, IdThreadComponent;

type
  TFClient = class(TForm)

    Label1        : TLabel;
    Label2        : TLabel;

    messageToSend : TMemo;
    messagesLog   : TMemo;

    btn_connect   : TButton;
    btn_disconnect: TButton;
    btn_send      : TButton;

    // ... TIdTCPClient
    IdTCPClient       : TIdTCPClient;

    // ... TIdThreadComponent
    IdThreadComponent : TIdThreadComponent;

    procedure FormShow(Sender: TObject);

    procedure btn_connectClick(Sender: TObject);
    procedure btn_disconnectClick(Sender: TObject);
    procedure btn_sendClick(Sender: TObject);

    procedure IdTCPClientConnected(Sender: TObject);
    procedure IdTCPClientDisconnected(Sender: TObject);

    procedure IdThreadComponentRun(Sender: TIdThreadComponent);


  private
    { Private declarations }

    procedure Log(p_who, p_message: string);

  public
    { Public declarations }

  end;

var
  FClient     : TFClient;

implementation

{$R *.dfm}

// ... listening port: GUEST CLIENT
const
  GUEST_PORT = 20010;

// *****************************************************************************
//   EVENT : onShow()
//           ON SHOW FORM
// *****************************************************************************
procedure TFClient.FormShow(Sender: TObject);
begin

  // ... INITAILIZE

  // ... message to send
  messageToSend.Clear;
  messageToSend.Enabled     := false;

  // ... log
  messagesLog.Clear;

  // ... buttons
  btn_connect.Enabled       := true;
  btn_disconnect.Enabled    := false;
  btn_send.Enabled          := false;

end;
// .............................................................................


// *****************************************************************************
//   EVENT : btn_connectClick()
//           CLICK ON CONNECT BUTTON
// *****************************************************************************
procedure TFClient.btn_connectClick(Sender: TObject);
begin
  btn_connect.Enabled := false;

  // ... try to connect to Server
  try
    IdTCPClient.Connect;
  except
    on E: Exception do begin
      Log('CLIENT', 'CONNECTION ERROR! ' + E.Message);
      btn_connect.Enabled := true;
    end;
  end;

end;
// .............................................................................


// *****************************************************************************
//   EVENT : btn_disconnectClick()
//           CLICK ON DISCONNECT BUTTON
// *****************************************************************************
procedure TFClient.btn_disconnectClick(Sender: TObject);
begin
  btn_disconnect.Enabled := false;

  // ... disconnect from Server
  IdTCPClient.Disconnect;

  // ... set buttons
  btn_connect.Enabled       := true;
  btn_send.Enabled          := false;

  // ... message to send
  messageToSend.Enabled     := false;
end;
// .............................................................................


// *****************************************************************************
//   EVENT : onConnected()
//           OCCURS WHEN CLIENT IS CONNECTED
// *****************************************************************************
procedure TFClient.IdTCPClientConnected(Sender: TObject);
begin
  // ... messages log
  Log('CLIENT', 'CONNECTED!');

  // ... after connection is ok, run the Thread ... waiting messages 
  //     from server
  IdThreadComponent.Active := true;

  // ... set buttons
  btn_disconnect.Enabled    := true;
  btn_send.Enabled          := true;

  // ... enable message to send
  messageToSend.Enabled     := true;
end;
// .............................................................................


// *****************************************************************************
//   EVENT : onDisconnected()
//           OCCURS WHEN CLIENT IS DISCONNECTED
// *****************************************************************************
procedure TFClient.IdTCPClientDisconnected(Sender: TObject);
begin
  // ... message log
  Log('CLIENT', 'DISCONNECTED!');
end;
// .............................................................................


// *****************************************************************************
//   EVENT : btn_sendClick()
//           CLICK ON SEND BUTTON
// *****************************************************************************
procedure TFClient.btn_sendClick(Sender: TObject);
begin
  // ... send message to Server
  IdTCPClient.IOHandler.WriteLn(messageToSend.Text);
end;
// .............................................................................


// *****************************************************************************
//   EVENT : onRun()
//           OCCURS WHEN THE SERVER SEND A MESSAGE TO CLIENT
// *****************************************************************************
procedure TFClient.IdThreadComponentRun(Sender: TIdThreadComponent);
var
  msgFromServer : string;
begin
  // ... read message from server
  msgFromServer := IdTCPClient.IOHandler.ReadLn();

  // ... messages log
  Log('SERVER', msgFromServer);
end;
// .............................................................................


// *****************************************************************************
//   FUNCTION : Log()
//              LOGS A MESSAGE TO THE UI
// *****************************************************************************
procedure TFClient.Log(p_who, p_message: string);
begin
  TThread.Queue(nil,
    procedure
    begin
      MessagesLog.Lines.Add('[' + p_who + '] - ' + FormatDateTime('yyyy-mm-dd hh:nn:ss', Now) + ': ' + p_message);
    end
  );
end;
// .............................................................................

end.

0
投票

我也遇到了同样的问题，程序在清除已连接客户端的活动标志时冻结。这似乎是 IdScheduler 中的一个错误。我的代码 `

//---------------------------------------------------------------------------
#include <vcl.h>
#include <IdSync.hpp>
#pragma hdrstop
//---------------------------------------------------------------------------
/*
    This is a general framework for TIdTCSServer and TIdTCPClient
    It uses a thread to read from the client.
    All threads are named.


    Bugs:
    4/11/19     Resetting the 'Active' property while there are still active
                connections (either local or from another program) locks up on
                that line. Both client and server threads remain active.
                Closing the program however works, so its processes must
                operate in a different manner.
                Closing a different process that is running a connected client
                works.
                Resetting the 'Active' property with a differnt process and a
                connected client locks on that line, and does not release
                when the other process is closed ();

    Maybe not an actual bug
        Server::OnStatus doesnt fire. Why ?

    Notes -
        It appears that setting 'Bindings' on the server has no effect.
        Default Ip (0's) will accept on any network (I run several at once,
        even if just ethernet & VirtualBox).
        I had thought that setting the bindings would allow certain network
        cards to be excluded from server access. In a production environment,
        I often find seperated networks are required by my customers.
        (I am aware I can easily refuse non-authorized connections)

        Two string altering functions 'IsMainThread' & 'IsNotMainThread' are
        provided to ensure that the proper mechanisms are used to write
        to the respective TListBox objects (VCL not being thread-safe).
*/
//---------------------------------------------------------------------------
#include "TIdTCPClientServerWin.h"
//---------------------------------------------------------------------------
#pragma package(smart_init)
#pragma resource "*.dfm"
//---------------------------------------------------------------------------
// A TIdSync is required for reading from the Server
//---------------------------------------------------------------------------
class TMyNotify : public TIdSync {
private:
    TListBox * lb;

public:
    String str;

    __fastcall TMyNotify ( TListBox * l ) {
        lb = l;
    }
    void __fastcall DoSynchronize (void) {
        Form2->IsNotMainThread ( str );
        lb->Items->Add ( str );
    }
};
//---------------------------------------------------------------------------
TForm2 *Form2;
//---------------------------------------------------------------------------
//                                  Form
//---------------------------------------------------------------------------
__fastcall TForm2::TForm2 ( TComponent * Owner )
                 : TForm  (              Owner ) {
    String str;

    mn = new TMyNotify ( lbServer );
    str = "Main Thread";
    uiMainThread = GetCurrentThreadId ();
    TThread::NameThreadForDebugging ( str );
}
//---------------------------------------------------------------------------
// Thread checks to ensure msgs that require syncing get it, and vice versa.
//---------------------------------------------------------------------------
void __fastcall TForm2::IsNotMainThread ( String& str ) {
    unsigned int uiCurrentThread;

    uiCurrentThread = GetCurrentThreadId ();
    if ( uiCurrentThread != uiMainThread ) {
        str += " Not Main";
    } /* endif */
}
//---------------------------------------------------------------------------
void __fastcall TForm2::IsMainThread ( String& str ) {
    unsigned int uiCurrentThread;

    uiCurrentThread = GetCurrentThreadId ();
    if ( uiCurrentThread != uiMainThread ) return;
    str += " IsMain";
}
//---------------------------------------------------------------------------
//                                  Server
//---------------------------------------------------------------------------
// Locks up when disabling - in vcl.forms
void __fastcall TForm2::cbServerActiveClick ( TObject * Sender ) {
    bool bFlag;

    bFlag = cbServerActive->Checked;
    IdTCPServer1->Active = bFlag;
}
//---------------------------------------------------------------------------
void __fastcall TForm2::IdTCPServer1Execute ( TIdContext * AContext ) {
    try {
        mn->str = String ( "read " )
                + AContext->Connection->IOHandler->ReadLn ();
        IsMainThread ( mn->str );
        mn->Synchronize ();
        AContext->Connection->IOHandler->WriteLn ( mn->str );
        IsMainThread ( mn->str );
        mn->str = String ( "write" );
        mn->Synchronize ();

    } catch (...) {
        AContext->Connection->Disconnect ();
        IsMainThread ( mn->str );
        mn->str = String ( "Exception caused by disconnection caught" );
        mn->Synchronize ();
    } /* end try/catch */
}
//---------------------------------------------------------------------------
// Thread Naming
//---------------------------------------------------------------------------
// names listener threads
void __fastcall TForm2::IdTCPServer1BeforeListenerRun ( TIdThread * AThread ) {
    String str;
    TIdIPVersion ver;
    TIdListenerThread * listen;

    listen = (TIdListenerThread *) AThread;
    str = IdTCPServer1->Name
        + String ( ":Listening for " );
    ver = listen->Binding->IPVersion;
    switch ( ver ) {
    case Id_IPv4:
        str += String ( "IPv4" );
        break;

    case Id_IPv6:
        str += String ( "IPv6" );
        break;

    default:
        str += String ( "Undefined" ) + String ( (int) ver );
        break;
    }
    str += String ( " connections on " );
    str += listen->Binding->IP;
    AThread->NameThreadForDebugging ( str );
}
//---------------------------------------------------------------------------
// Messaging ( some require syncing )
//---------------------------------------------------------------------------
// Overrides thread's 'OnBeforeRun' event
void __fastcall TForm2::IdTCPServer1Connect ( TIdContext * AContext ) {
    String str;
    String strPrologue;

    strPrologue = IdTCPServer1->Name
                + String ( ":" );
    str = String ( "Connection from " )
        + AContext->Binding->PeerIP
        + String ( ":" )
        + AContext->Binding->PeerPort
        + String ( " accepted" );
    TThread::NameThreadForDebugging ( strPrologue + str );
    mn->str = str;
    IsMainThread ( mn->str );
    mn->Synchronize ();
}
//---------------------------------------------------------------------------
// Overrides thread's 'OnAfterRun' event
void __fastcall TForm2::IdTCPServer1Disconnect ( TIdContext * AContext ) {
    mn->str = String ( "Disconnected from " )
            + AContext->Connection->Socket->Binding->PeerIP
            + String ( ":" )
            + AContext->Connection->Socket->Binding->PeerPort;
    IsMainThread ( mn->str );
    mn->Synchronize ();
}
//---------------------------------------------------------------------------
void __fastcall TForm2::IdTCPServer1Status ( TObject       * ASender,
                                             const TIdStatus AStatus,
                                             const UnicodeString AStatusText ) {
    String str;

    str = String ( "Status:" )
        + AStatusText;
    IsNotMainThread ( str );
    lbServer->Items->Add ( AStatusText );
}
//---------------------------------------------------------------------------
void __fastcall TForm2::IdTCPServer1Exception ( TIdContext * AContext,
                                                Exception  * AException ) {
    IsMainThread ( mn->str );
    mn->str = String ( "Exception:" )
            + AException->Message;
    mn->Synchronize ();
}
//---------------------------------------------------------------------------
//                                  Client
//---------------------------------------------------------------------------
// A thread is required for reading from the Client
class TMyThread : public TIdThread {
private:
    String         str;
    TIdTCPClient * cli;
    TListBox     * lb;

public:
    String __fastcall ThreadName ( TIdTCPClient * c ) {
        str = c->Name
            + String ( ":Host " )
            + c->Socket->Host
            + String ( " connected using local port " )
            + c->Socket->Binding->Port;
        return str;
    }
    __fastcall TMyThread ( TIdTCPClient * c, TListBox * l )
               : TIdThread ( true,
                             true,
                             ThreadName ( c ) ) {
        cli = c;
        lb  = l;
        FreeOnTerminate = false;
    }
    void __fastcall MyRead ( void ) {
        String strMsg;

        strMsg = String ( "recvd " ) + str;
        Form2->IsNotMainThread ( str );
        lb->Items->Add ( strMsg );
    }
    void __fastcall MyTerm ( void ) {
        String strMsg;

        strMsg = String ( "Terminated" );
        Form2->IsNotMainThread ( str );
        lb->Items->Add ( str );
    }
    void __fastcall Run ( void ) {
        try {
            str = cli->IOHandler->ReadLn ();
            cli->IOHandler->CheckForDisconnect ( true, true );
            Synchronize ( MyRead );

        } catch (...) {
            Synchronize ( MyTerm );
            Terminate ();
        } /* end try/catch */
    }
};
//---------------------------------------------------------------------------
void __fastcall TForm2::btnSendClick ( TObject * Sender ) {
    String      str;
    TDateTime   dt;

    dt = Now ();
    str = dt.FormatString ( "HH:NN:SS" );
    try {
        IdTCPClient1->IOHandler->WriteLn ( str );
        IsNotMainThread ( str );
        lbClient->Items->Add ( str );

    } catch (...) {
        str = "Exception in Write";
        IsNotMainThread ( str );
        lbClient->Items->Add ( str );
        IdTCPClient1->Disconnect ();
    } /* end try/catch */
}
//---------------------------------------------------------------------------
void __fastcall TForm2::cbClientEnabledClick ( TObject * Sender ) {
    if ( cbClientEnabled->Checked ) {
        IdTCPClient1->Connect ();
        return;
    } /* endif */
    IdTCPClient1->Disconnect ();
}
//---------------------------------------------------------------------------
// Messaging
//---------------------------------------------------------------------------
void __fastcall TForm2::IdTCPClient1Connected ( TObject * Sender ) {
    mt = new TMyThread ( IdTCPClient1, lbClient );
    mt->Start ();
}
//---------------------------------------------------------------------------
// Connection not yet established at this point
void __fastcall TForm2::IdTCPClient1SocketAllocated ( TObject * Sender ) {
    String str;

    str = "New Socket";
    IsNotMainThread ( str );
    lbClient->Items->Add ( str );
}
//---------------------------------------------------------------------------
void __fastcall TForm2::IdTCPClient1Status ( TObject * ASender,
                                             const TIdStatus AStatus,
                                             const UnicodeString AStatusText ) {
    String str;
    int    iLen;

    str = String ( "Status:" )
        + AStatusText;
    str.Delete ( str.Length (), 1 );

    switch ( AStatus ) {
    case hsConnected:
        str += String ( " using local port " )
            + String ( IdTCPClient1->Socket->Binding->Port );
        break;
    };

    IsNotMainThread ( str );
    lbClient->Items->Add ( str );
}
//---------------------------------------------------------------------------
void __fastcall TForm2::lbClearDblClick ( TObject * Sender ) {
    TListBox * lb;

    lb = (TListBox *) Sender;
    lb->Items->Clear ();
}
//---------------------------------------------------------------------------

// End of File

头文件：

//---------------------------------------------------------------------------
#ifndef TIdTCPClientServerWinH
#define TIdTCPClientServerWinH
//---------------------------------------------------------------------------
#include <System.Classes.hpp>
#include <Vcl.Controls.hpp>
#include <Vcl.StdCtrls.hpp>
#include <Vcl.Forms.hpp>
#include <IdBaseComponent.hpp>
#include <IdComponent.hpp>
#include <IdContext.hpp>
#include <IdCustomTCPServer.hpp>
#include <IdTCPClient.hpp>
#include <IdTCPConnection.hpp>
#include <IdTCPServer.hpp>
#include <Vcl.ComCtrls.hpp>
#include <IdThread.hpp>
#include <System.SysUtils.hpp>
#include <IdAntiFreezeBase.hpp>
#include <Vcl.IdAntiFreeze.hpp>
//---------------------------------------------------------------------------
class TMyNotify;
class TMyThread;
//---------------------------------------------------------------------------
class TForm2 : public TForm
{
__published:    // IDE-managed Components
    TIdTCPServer *IdTCPServer1;
    TIdTCPClient *IdTCPClient1;
    TListBox *lbServer;
    TButton *btnSend;
    TGroupBox *GroupBox1;
    TCheckBox *cbServerActive;
    TGroupBox *GroupBox2;
    TListBox *lbClient;
    TCheckBox *cbClientEnabled;
    TStatusBar *StatusBar1;
    TIdAntiFreeze *IdAntiFreeze1;
    void __fastcall btnSendClick(TObject *Sender);
    void __fastcall IdTCPServer1Connect(TIdContext *AContext);
    void __fastcall IdTCPServer1Disconnect(TIdContext *AContext);
    void __fastcall IdTCPServer1Status(TObject *ASender, const TIdStatus AStatus, 
const UnicodeString AStatusText);
    void __fastcall IdTCPServer1Execute(TIdContext *AContext);
    void __fastcall cbClientEnabledClick(TObject *Sender);
    void __fastcall cbServerActiveClick(TObject *Sender);
    void __fastcall IdTCPClient1Connected(TObject *Sender);
    void __fastcall IdTCPClient1SocketAllocated(TObject *Sender);
    void __fastcall IdTCPClient1Status(TObject *ASender, const TIdStatus AStatus, 
const UnicodeString AStatusText);
    void __fastcall IdTCPServer1BeforeListenerRun(TIdThread *AThread);
    void __fastcall IdTCPServer1Exception(TIdContext *AContext, Exception 
                                          *AException);
    void __fastcall lbClearDblClick(TObject *Sender);



private:    // User declarations
    TMyNotify * mn;
    TMyThread * mt;
    unsigned int uiMainThread;

    void __fastcall RdSync ( void );
    void __fastcall WrSync ( void );
    void __fastcall ExSync ( void );

    void __fastcall BeforeContextRun ( TIdContext * AContext );
    void __fastcall AfterContextRun  ( TIdContext * AContext );

public:     // User declarations
    __fastcall TForm2(TComponent* Owner);
    void __fastcall IsMainThread    ( String& str );
    void __fastcall IsNotMainThread ( String& str );
};
//---------------------------------------------------------------------------
extern PACKAGE TForm2 *Form2;
//---------------------------------------------------------------------------
#endif

DFM 文件：

object Form2: TForm2
Left = 0
Top = 0
Caption = 'TIdTCP Client Sever Test'
ClientHeight = 314
ClientWidth = 554
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
DesignSize = (
  554
  314)
PixelsPerInch = 96
TextHeight = 13
object GroupBox1: TGroupBox
  Left = 8
  Top = 8
  Width = 265
  Height = 273
  Anchors = [akLeft, akTop, akBottom]
  Caption = 'Server'
  TabOrder = 0
  DesignSize = (
    265
    273)
  object lbServer: TListBox
    Left = 16
    Top = 40
    Width = 233
    Height = 217
    Anchors = [akLeft, akTop, akRight, akBottom]
    ItemHeight = 13
    TabOrder = 0
    OnDblClick = lbClearDblClick
  end
  object cbServerActive: TCheckBox
    Left = 16
    Top = 16
    Width = 97
    Height = 17
    Caption = 'cbServerActive'
    TabOrder = 1
    OnClick = cbServerActiveClick
  end
end
object GroupBox2: TGroupBox
  Left = 288
  Top = 8
  Width = 258
  Height = 273
  Anchors = [akTop, akRight, akBottom]
  Caption = 'Client'
  TabOrder = 1
  DesignSize = (
    258
    273)
  object lbClient: TListBox
    Left = 16
    Top = 51
    Width = 226
    Height = 206
    Anchors = [akLeft, akTop, akRight, akBottom]
    ItemHeight = 13
    TabOrder = 0
    OnDblClick = lbClearDblClick
    ExplicitWidth = 193
  end
  object btnSend: TButton
    Left = 134
    Top = 20
    Width = 75
    Height = 25
    Caption = 'Send'
    TabOrder = 1
    OnClick = btnSendClick
  end
  object cbClientEnabled: TCheckBox
    Left = 16
    Top = 20
    Width = 97
    Height = 25
    Caption = 'cbClientEnabled'
    TabOrder = 2
    OnClick = cbClientEnabledClick
  end
end
object StatusBar1: TStatusBar
  Left = 0
  Top = 295
  Width = 554
  Height = 19
  Panels = <>
  SimplePanel = True
end
object IdTCPServer1: TIdTCPServer
  OnStatus = IdTCPServer1Status
  Bindings = <>
  DefaultPort = 474
  OnBeforeListenerRun = IdTCPServer1BeforeListenerRun
  OnConnect = IdTCPServer1Connect
  OnDisconnect = IdTCPServer1Disconnect
  OnException = IdTCPServer1Exception
  UseNagle = False
  OnExecute = IdTCPServer1Execute
  Left = 128
  Top = 24
end
object IdTCPClient1: TIdTCPClient
  OnStatus = IdTCPClient1Status
  OnConnected = IdTCPClient1Connected
  ConnectTimeout = 0
  Host = '127.0.0.1'
  IPVersion = Id_IPv4
  Port = 474
  ReadTimeout = -1
  UseNagle = False
  OnSocketAllocated = IdTCPClient1SocketAllocated
  Left = 320
  Top = 24
end
object IdAntiFreeze1: TIdAntiFreeze
  Left = 272
  Top = 56
end
end

我使用调试器跟踪执行路径，发现它陷入了过程 TIdScheduler.TerminateAllYarns 的循环中。概括在 IdSceduler:168 [过程 TIdScheduler.TerminateAllYarns], 我们尝试终止所有线程。线程被报告为已停止[通过过程 TIdThread.GetStopped]，但这永远不会反映在 FActiveYarns 中，如通过 LList.Count (IdScheduler:182) 指定的那样。我正在使用 Indy 10.1.5，以及 CBuilder 10.0（西雅图）版本 23.0.20618.2753

问候

0
投票

我也遇到了同样的问题。

以前的答案对我没有帮助。

我终于自己找到了。

虽然我读这篇文章很晚，但希望它对你和其他人有帮助

你之前还有事要做

tcpServer.Active := False;

首先，您需要使 onDisconnect 事件处理程序不起作用。

tcpServer.OnDisconnect:= nil;

并且您必须断开所有客户端的连接

aContexClient.Connection.Disconnect();  //aContect -> all Context

参见下面的编码

procedure disconnectAllclient();
var
    tmpList      : TList;
    contexClient : TidContext;
begin
    tmpList  := tcpServer.Contexts.LockList;
    try
       while (tmpList.Count > 0) do begin
           contexClient := tmpList[0];
           contexClient.Connection.Disconnect();
           tmpList.Delete(0);
       end;
    finally
        tcpServer.Contexts.UnlockList;
    end;
end;

use :
    tcpServer.OnDisconnect  := nil;
    disconnectAllclient();
    tcpServer.Active := False;

0
投票

非常感谢，效果很好。它花了我很多时间

问题描述投票：0回答：4

4个回答

最新问题

设置 Active = false 时 TIdTCPServer 挂起

问题描述 投票：0回答：4

4个回答

最新问题

问题描述投票：0回答：4