我正在研究使用{d3TCP} / client组件的这个example，我发现如果有任何客户端，那么当您将active更改为false时，服务器组件将挂起。具体来说，它挂在对上下文线程的Windows“ ExitThread”函数调用上。
要重现行为：
我想要一个简单的TCP服务器来监视LAN上的进程，但是我不知道如何防止这种锁定。我发现有很多信息可以解决这个问题，但是对我来说还没有任何意义。我在带有Indy 10.6.2.5366的Win 8.1上使用了Delphi 10.2。
答案 0 :(得分：5)
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.
答案 1 :(得分：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 [procedure TIdScheduler.TerminateAllYarns]中， 我们尝试终止所有线程。线程被报告为已停止（通过过程TIdThread.GetStopped），但这从未反映在FActiveYarns中，如通过LList.Count（IdScheduler：182）指定的那样。 我正在使用Indy 10.1.5和CBuilder 10.0（Seattle）版本23.0.20618.2753
致谢
`
答案 2 :(得分：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;