TIdTCPServer требуется обработчик событий OnExecute, назначенный по умолчанию. Чтобы обойти это, вам нужно извлечь новый класс из TIdTCPServer и переопределить его виртуальный метод CheckOkToBeActive(), а также переопределить виртуальный DoExecute() для вызова Sleep(). В противном случае просто назначьте обработчик события и вызовите его Sleep().
Однако это неэффективное использование TIdTCPServer. Лучшее решение - не записывать исходящие данные клиентам изнутри вашего метода SendMessage() напрямую. Он не только подвержен ошибкам (вы не перехватываете исключения из WriteBuffer()) и блокирует SendMessage() во время записи, но также сериализует ваши сообщения (клиент 2 не может получать данные, пока клиент 1 не сделает первый). Гораздо более эффективный способ - предоставить каждому клиенту свою собственную потокобезопасную исходящую очередь, а затем SendMessage() поместить данные в очередь каждого клиента по мере необходимости. Затем вы можете использовать событие OnExecute, чтобы проверить очередь каждого клиента и выполнить фактическую запись. Таким образом, SendMessage() больше не блокируется, менее подвержен ошибкам, и клиенты могут записываться параллельно (как и должно быть).
Попробуйте что-то вроде этого:
uses
..., IdThreadSafe;
type
TMyContext = class(TIdServerContext)
private
FQueue: TIdThreadSafeStringList;
FEvent: TEvent;
public
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TThreadList = nil); override;
destructor Destroy; override;
procedure AddMsgToQueue(const Msg: String);
function GetQueuedMsgs: TStrings;
end;
constructor TMyContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TThreadList = nil);
begin
inherited;
FQueue := TIdThreadSafeStringList.Create;
FEvent := TEvent.Create(nil, True, False, '');
end;
destructor TMyContext.Destroy;
begin
FQueue.Free;
FEvent.Free;
inherited;
end;
procedure TMyContext.AddMsgToQueue(const Msg: String);
begin
with FQueue.Lock do
try
Add(Msg);
FEvent.SetEvent;
finally
FQueue.Unlock;
end;
end;
function TMyContext.GetQueuedMsgs: TStrings;
var
List: TStringList;
begin
Result := nil;
if FEvent.WaitFor(1000) <> wrSignaled then Exit;
List := FQueue.Lock;
try
if List.Count > 0 then
begin
Result := TStringList.Create;
try
Result.Assign(List);
List.Clear;
except
Result.Free;
raise;
end;
end;
FEvent.ResetEvent;
finally
FQueue.Unlock;
end;
end;
procedure TFormMain.FormCreate(Sender: TObject);
begin
TCPServer.ContextClass := TMyContext;
end;
procedure TFormMain.TCPServerExecute(AContext: TIdContext);
var
List: TStrings;
I: Integer;
begin
List := TMyContext(AContext).GetQueuedMsgs;
if List = nil then Exit;
try
for I := 0 to List.Count-1 do
AContext.Connection.IOHandler.Write(List[I]);
finally
List.Free;
end;
end;
procedure TFormMain.SendMessage(const IP, Msg: string);
var
I: Integer;
begin
with TCPServer.Contexts.LockList do
try
for I := 0 to Count-1 do
begin
with TMyContext(Items[I]) do
begin
if Binding.PeerIP = IP then
begin
AddMsgToQueue(Msg);
Break;
end;
end;
end;
finally
TCPServer.Contexts.UnlockList;
end;
end;