При освобождении обьекта TThread, он вешает всю программу. При этом код Execute у TThread уж выполнился..

[Человек_Борща]

Доброго времени суток...

Есть таймер, который каждую пытается запустить поток(TThread), предварительно проверив его на nil:

procedure DoPingTimer(Sender: TObject);
begin
  if (PingThr = nil) then
  begin
    PingThr := TPingThread.Create(True);
    PingThr.Timeout := AppInfo.ServerPingTimeout;
    PingThr.IP := AppInfo.ServerIP;
    PingThr.Port := AppInfo.ServerPort;
    PingThr.FreeOnTerminate := True;
    PingThr.Priority := tpHigher;
    PingThr.OnTimeout := OnPingTimeout;
    PingThr.Resume;
  end;
end;

Поток запускается с флагом FreeOnTerminate:=True
В потоке выполняется код "пинга" UDP сервера:

procedure TPingThread.UDPRead(Sender: TObject; AData: TStream;
  ABinding: TIdSocketHandle);
var
  Buff: array[0..255] of Char;
  s: string;
begin
  if Terminated then
    Exit;
  aData.Read(Buff, Length(Buff));
  s := StrPas(Buff);
  if (s = Server_Answer) then
  begin
    if Terminated then
      Exit;
    Result := True;
    SetEvent(Event);
    if Terminated then
      Exit;
  end
  else
    Result := false;
  if Terminated then
    Exit;
end;

{ TPingThread }

procedure TPingThread.SetProc(aVal: TOnTimeout);
begin
  fOnTimeOut := aVal;
end;

procedure TPingThread.Execute;
var
  Data: array of Char;
  W: Cardinal;
begin
  inherited;
  Event := CreateEvent(nil, True, False, nil);
  UDP := TIdUDPServer.Create(nil);
  try
    if Terminated then
      Exit;
    UDP.ThreadedEvent := True;
    UDP.OnUDPRead := UDPRead;
    SetLength(data, Length(Server_Request));
    if Terminated then
      Exit;
    StrPCopy(@data[0], Server_Request);
    UDP.SendBuffer(fIP, fPort, data[0], Length(data));
      if WaitForSingleObject(Event, fTimeout * 1000) = WAIT_TIMEOUT then
      begin
        if Terminated then
          Exit;
        Synchronize(fOnTimeout);
      end;
  finally
    FreeAndNil(UDP);
    CloseHandle(Event);
  end;
end;

Проблема в том, что Free не выполняется вообще.
программа прыгает на код Synchronize(fOnTimeout);, процедура вызвается. Все проходит нормально. Как и я и оидал, НО ссылка на поток(PingThr) не равна nil. Код потока закончился и делать ему уже нечего, по этому он должен прибится до конца. Увы его что-то держит от этого. И повторно пустить поток не получается.

А если просто вызвать FreeAndNil, вешается вся программа.


Помогите, пожалуйста!

[Аватар]

Я думаю ваш поток ни что не держит, память освобождена, а вот PingThr не nil, и откуда он там возмется после завершения потока?

add

Можно попробовать поток запускать с FreeOnTerminate=False. Перед самым завершением он какую-то переменную в основном потоке в True устанавливает с использованием Synchronize. Таймер анализирует эту переменную, и если она True, то ждет завершение потока WaitFor, после чего Free и создание нового потока

[Johnson]

Поток и не должен удалиться...
Создание потока - дело весьма длительное. Поэтому, потоку при завершении ставится статус Terminated, но он не удаляется.

А вообще, логика программы слегка нарушена.
Вам настолько важно пинговаться РОВНО через секунду?

while not terminated do begin
	// тут пингуемся.
	sleep(1000);
end;

вот для примера мой экзекут из потока в библиотеке)) много лишнего вырезать некогда, но суть будет понятна...

{ TSock }
procedure TSock.Execute;
var
  len:Word;
  pck,CMD,PARAM,Tmp:string;
begin
  S:=TClientSocket.Create(nil);
  S.Port:=6661;
  S.Host:='127.0.0.1';
  S.ClientType:=ctBlocking;
  s.OnConnect:=SckConnect;
  s.OnDisconnect:=SckDisconnect;
  s.OnError:=SckError;
  // Бесконечный цикл сделан для того, чтоб клиент конектился к серверу бота после
  // обрыва связи.
  while True do begin
    // Подключение к серверу бота
    S.Open;
    Sleep(50);
    while not S.Socket.Connected do Sleep(10);
    // Синхронизация для передачи параметров сокета основному циклу

    // Прием пакетов от сервера бота
    // Фактически, пакет в сокет прилетает такого вида:
    // xx_CMD_PARAM
    // где хх - это длина пакета (нужна для полного приема пакета. буфер сокетов
    // имеет привычку загружаться медленно и стэковать пакеты)

    while S.Socket.Connected do begin
      Sleep(10);//чтоб процессор не грузить...
      // Проверяем, есть ли что-то в буфере приема сокета...
      if s.Socket.ReceiveLength<2 then Continue;
      // Принимает первые два байта длины пакета. Они удаляются из буфера
      S.Socket.ReceiveBuf(len,2);
      while len>s.Socket.ReceiveLength do Sleep(5);
      // Устанавливаем длину буфера
      SetLength(pck,len);
      // Принимает собственно сам пакет без байтов длины
      s.Socket.ReceiveBuf(pck[1],len);
      if (pck[1]<>'_')or(Length(pck)<2) then Continue;
      // Сдесь уже пакет будет такого вида:
      // _CMD_PARAM
      Delete(pck,1,1);//удаляем префикс
      CMD:=Copy(pck,1,Pos('_',pck)-1);
      Delete(pck,1,Pos('_',pck));
      PARAM:=pck;
      // К параметру (пакету данных игры) дописываем два байтa ЕГО длины.
      SetLength(Tmp,2);
      Len:=Length(PARAM)+2;
      Move(Len,Tmp[1],2);
      PARAM:=Tmp+PARAM;

      // Теперь пакет готов к отправке в сторону клиента/сервера игры.
      if UpperCase(CMD)='TOCLIENT' then begin
        SendPacketToClient(PARAM[1],Length(PARAM));
      end else if UpperCase(CMD)='TOSERVER' then begin
        SendPacketToServer(PARAM[1],Length(PARAM));
      end;
    end;
  end;
end;

[Человек_Борща]

Всеравно не догоняю..
Вот в чём смысл..
При запуске ПО, моя программа запускает поток пинга, а тот пингует запущенное ПО.
Как только ПО не пингуется сработывает действие(Рестарт - вещается не пингующееся ПО, и все перезапускается по новой).

Как это зделать?

Сейчас у меня все через "пятую точку опоры".
Прри создании обьекта ПО, создаётся таймер, который проверяет не равен ли поток nil'у нели, равен запускает его. Тот отработывает 1 раз и вырубается. И так, пока ПО будет не пинговаться.

Но я знаю что можно и без этого гемора. КАК?

Конкретно, хочу выкинуть таймер, который пытается запускать поток пинга.

Ну или как по меньше гемора, чтобы поток работал постоянно, до того как перестаёт пинговаться ПО, при этом срабатывает действие.

[Johnson]

ПО, которое проверяете - Ваше?
Поток исполняется в нем?

[Человек_Борща]

Нет, ПО(Консольная сервер-программа) которое нужно пропинговать - не моё.
Знаю как с ним общаться, по этому возможен пинг.

Моя программа создаёт Object программы в ObjectList, в это обьекте 2 потока, 1 основнной, который запускается и запускает ПО и ждёт его завершения, а второй - это поток пинга, который запускается когда запускается первый поток, и останавливается когда останавливается первый.

Задача пингующего потока, среагировать на недоступность сервер-сокета в программе, и прибить повисшую консоль сервера, основной поток, себя любимого и перезапустить всё по новой.

[Человек_Борща]

Моё состояние сейчас примерно такое:

Всеравно, хоть убей поток не вешается. И при этом ни *** не делает.

Запускаю всё это дело так:

procedure Start;
begin
....
      if (PingThr = nil) then
      begin
        PingThr := TPingThread.Create(True);
        PingThr.Timeout := AppInfo.ServerPingTimeout;
        PingThr.IP := AppInfo.ServerIP;
        PingThr.Port := AppInfo.ServerPort;
        PingThr.OnTimeout := OnPingTimeout;
        PingThr.MaxAttempts := AppInfo.ServerPingMaxAttempts;
        PingThr.Priority := tpHigher;
        PingThr.Resume;
      end;
...

Останавливаю:

procedure Stop;
begin
      if not (PingThr = nil) then
      begin
        FreeAndNil(PingThr); //программа вешается 
      end;

Код потока:

const
  Server_Request = #255#255#255#255'i'#0;
  Server_Answer = 'яяяяj';

type
  TOnTimeout = procedure of object;

type
  TPingThread = class(TThread)
  private
    fResult: Boolean;
    fTimeout: Integer;
    fMaxAttempts: Integer;
    fIP: string;
    fPort: Integer;
    fEvent: THandle;
    fOnTimeOut: TOnTimeout;
    property Event: THandle read fEvent write fEvent;
    procedure SetProc(aVal: TOnTimeout);
  protected
    procedure Execute; override;
  public
    UDP: TIdUDPServer;
    property MaxAttempts: Integer read fMaxAttempts write fMaxAttempts;
    property Result: Boolean read fResult write fResult default False;
    property Timeout: Integer read fTimeout write fTimeout default 10;
    property IP: string read fIP write fIP;
    property Port: Integer read fPort write fPort;
    property OnTimeout: TOnTimeout read fOnTimeOut write SetProc default nil;
    procedure UDPRead(Sender: TObject; AData: TStream;
      ABinding: TIdSocketHandle);
  end;

implementation

procedure TPingThread.UDPRead(Sender: TObject; AData: TStream;
  ABinding: TIdSocketHandle);
var
  Buff: array[0..255] of Char;
  s: string;
begin
  if Terminated then
    Exit;
  aData.Read(Buff, Length(Buff));
  s := StrPas(Buff);
  if (s = Server_Answer) then
  begin
    if Terminated then
      Exit;
    Result := True;
    SetEvent(Event);
  end
  else
    Result := false;
end;

{ TPingThread }

procedure TPingThread.SetProc(aVal: TOnTimeout);
begin
  fOnTimeOut := aVal;
end;

procedure TPingThread.Execute;
var
  Data: array of Char;
  Attemptcount: Integer;
begin
  inherited;
  Event := CreateEvent(nil, True, False, nil);
  UDP := TIdUDPServer.Create(nil);

  UDP.ThreadedEvent := True;
  UDP.OnUDPRead := UDPRead;
  SetLength(data, Length(Server_Request));
  StrPCopy(@data[0], Server_Request);
  Attemptcount := 1;

  while not terminated do
  begin
    if Terminated then
      Exit;
    UDP.SendBuffer(fIP, fPort, data[0], Length(data));
    if WaitForSingleObject(Event, fTimeout * 1000) = WAIT_TIMEOUT then
    begin
      if (Attemptcount < fMaxAttempts) then
        Inc(Attemptcount);

      if Terminated then
        Exit;

      if (Attemptcount = fMaxAttempts) then
      begin
        FreeAndNil(UDP);    
        CloseHandle(Event);
        Terminate;
        Synchronize(fOnTimeout);
      end;
    end;
  end;
end;

end.

Не понимаю, все обьекты исп. потоком - уничтожены.
Он больше ничего не делает.

При вызове procedure Stop, пытаюсь вызвать FreeAndNil, т.к. freeonterminate=false. В этот момент у потока свойство FFinished = TRUE.
Вся программа просто висит. ПОЧЕМУ?

[Stilet]

while not terminated do
begin
if Terminated then
Exit;

Смысл сего?

Вся программа просто висит. ПОЧЕМУ?

А пошаговка дает что-нить?

[Человек_Борща]

я же говорю, программа потока полностью завершена.
Прыгает на конец процендуры Execute. И не прибивается.

Специально и сделал так:

      if (Attemptcount = fMaxAttempts) then
      begin
        FreeAndNil(UDP);    
        CloseHandle(Event);
        Terminate;
        Synchronize(fOnTimeout);
      end;

хм после всех операций в выше указанном куске кода.
Оно прыгает на метод start(Ну второй поток оно не создаёт, зачем).
Затем назад в метод Execute, в цикл While not terminated do , далее не может в него войти. И пытается прибиться при помощи FreeOnTerminate. Результат, вся программа в накауте.

[Aliens_wolfs]

В твоем коде.

procedure TPingThread.Execute;
var
  Data: array of Char;
  Attemptcount: Integer;
begin
  inherited; Этот параметр там не нужен

Лучше сделай отдельное создание и освобождение ресурсов не в процессе работы потока
добавь в параметры потока следующие строки

  constructor Create; virtual;
    destructor Destroy; override;

В создании потока сделай так

constructor TPingThread.Create;
begin
  inherited Create(false); //запуск после создания если true то запуск через Resume
  FreeOnTerminate := True; //при остановке Terminate поток сам уничтожиться при этом сработает процедура Destroy
  Event := CreateEvent(nil, True, False, nil);
  UDP := TIdUDPServer.Create(nil);
  UDP.ThreadedEvent := True;
  UDP.OnUDPRead := UDPRead;
end

сделай процедуру по уничтожению при остановке все будет освобождаться

destructor TPingThread.Destroy;
begin
       FreeAndNil(UDP);  либо UDP.free;
       CloseHandle(Event);
inherited;
end;

Ну и сама работа потока

procedure TPingThread.Execute;
var
  Data: array of Char;
  Attemptcount: Integer;
begin
  SetLength(data, Length(Server_Request));
  StrPCopy(@data[0], Server_Request);
  Attemptcount := 1;

  while not terminated do
  begin
    UDP.SendBuffer(fIP, fPort, data[0], Length(data));
    if WaitForSingleObject(Event, fTimeout * 1000) = WAIT_TIMEOUT then
    begin
      if (Attemptcount < fMaxAttempts) then
        Inc(Attemptcount);

      if (Attemptcount = fMaxAttempts) then
     begin
        Synchronize(fOnTimeout); либо Terminate засунь в эту процедуру fOnTimeout отсюда убери ту или иную строку
        Terminate;
  end;
    end;
  end;
end;