Question

Я смотрел на этот пример для использования компонентов TIdTCPServer / client, и я обнаружил, что если есть какие-либо клиенты, то серверный компонент зависнет, если вы измените active на false.В частности, он зависает при вызове функции Windows «ExitThread» для потока контекста.

Чтобы воспроизвести поведение:

Запустите сервер,
нажмите кнопку «Запустить сервер»,
запустите клиент,
нажмите кнопку подключения
нажмите кнопку «Стоп сервер»

Я хочу, чтобы простой TCP-сервер контролировал процесс через локальную сеть, но я не могу понять, как предотвратить эту блокировку.Я нашел много информации, которая обходит эту тему, но для меня еще ничего не имело смысла.Я использую Delphi 10.2 на Win 8.1 с Indy 10.6.2.5366.

Remy Lebeau · Answer 1 · 01 февраля 2019

ExitThread() не может зависнуть, если DLL не работает в обработчике DllMain / DllEntryPoint(), вызывая тупик в загрузчике DLL.Но установщик свойств сервера Active может зависнуть, например, если какой-либо из клиентских потоков заблокирован.

Пример, на который вы ссылаетесь, НЕ является хорошим примером для подражания.Потоковые обработчики событий делают вещи, которые не являются потокобезопасными.Они получают доступ к элементам управления пользовательского интерфейса без синхронизации с основным потоком пользовательского интерфейса, что может вызвать множество проблем, включая взаимоблокировки и неработающие элементы управления пользовательского интерфейса.И метод широковещательной передачи сервера реализован совершенно неправильно, что делает его подверженным тупикам, сбоям и повреждению данных.

Кто бы ни писал этот пример (не я), явно не знал, что делал.Это должно быть переписано, чтобы должным образом учитывать безопасность потоков.Вместо этого попробуйте что-то вроде этого:

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.

TIdTCPServer зависает при установке Active = false

Пожалуйста, войдите или зарегистрируйтесь чтобы ответить на этот вопрос.

1 Ответ

Пожалуйста, войдите или зарегистрируйтесь что бы добавить комментарий.

TIdTCPServer зависает при установке Active = false

Пожалуйста, войдите или зарегистрируйтесь чтобы ответить на этот вопрос.

1 Ответ

Пожалуйста, войдите или зарегистрируйтесь что бы добавить комментарий.

Похожие темы