3
\$\begingroup\$

I was inspired by @LU RD's answer to the question: Using VCL TTimer in Delphi console application, and wrote a bit simplified TTimerThread class. By simplified I mean, I did not used TSimpleEvent;TStopWatch and used API. This will also work for older Delphi versions such as D5. I also "reintroduced" the public Terminate method.

unit TimerThread;
// https://stackoverflow.com/questions/12026951/using-vcl-ttimer-in-delphi-console-application
interface

uses
  Windows, Classes;

type
  TTimerThread = class(TThread)
  private
    FTimerEnabledFlag: THandle;
    FCancelFlag: THandle;
    FTimerProc: TNotifyEvent; // method to call
    FInterval: Cardinal;
    procedure SetEnabled(AEnable: Boolean);
    function GetEnabled: Boolean;
    procedure SetInterval(AInterval: Cardinal);
  protected
    procedure Execute; override;
  public
    constructor Create;
    Destructor Destroy; override;
    procedure Terminate;
    property Enabled: Boolean read GetEnabled write SetEnabled;
    property Interval: Cardinal read FInterval write SetInterval;
    // Note: OnTimerEvent is executed in TTimerThread thread
    property OnTimerEvent: TNotifyEvent read FTimerProc write FTimerProc;
  end;

implementation

constructor TTimerThread.Create;
begin
  FTimerEnabledFlag := CreateEvent(nil, True, False, nil);
  FCancelFlag := CreateEvent(nil, True, False, nil);
  FTimerProc := nil;
  FInterval := 1000;
  FreeOnTerminate := False; // Main thread controls for thread destruction
  inherited Create(False);
end;

destructor TTimerThread.Destroy; // Call TTimerThread.Free to cancel the thread
begin
  Terminate;
  if GetCurrentThreadID = MainThreadID then
  begin
    OutputDebugString('TTimerThread.Destroy :: MainThreadID (Waitfor)');
    Waitfor; // Synchronize
  end;
  CloseHandle(FCancelFlag);
  CloseHandle(FTimerEnabledFlag);
  OutputDebugString('TTimerThread.Destroy');
  inherited;
end;

procedure TTimerThread.Terminate;
begin
  inherited Terminate;
  Windows.ResetEvent(FTimerEnabledFlag); // Stop timer event
  Windows.SetEvent(FCancelFlag); // Set cancel flag
end;

procedure TTimerThread.SetEnabled(AEnable: Boolean);
begin
  if AEnable then
    Windows.SetEvent(FTimerEnabledFlag)
  else
    Windows.ResetEvent(FTimerEnabledFlag);
end;

function TTimerThread.GetEnabled: Boolean;
begin
  Result := WaitForSingleObject(FTimerEnabledFlag, 0) = WAIT_OBJECT_0 // Signaled
end;

procedure TTimerThread.SetInterval(AInterval: Cardinal);
begin
  FInterval := AInterval;
end;

procedure TTimerThread.Execute;
var
  WaitList: array[0..1] of THandle;
  WaitInterval, LastProcTime: Int64;
  Frequency, StartCount, StopCount: Int64; // minimal stop watch
begin
  QueryPerformanceFrequency(Frequency); // this will never return 0 on Windows XP or later
  WaitList[0] := FTimerEnabledFlag;
  WaitList[1] := FCancelFlag;
  LastProcTime := 0;
  while not Terminated do
  begin
    if (WaitForMultipleObjects(2, @WaitList[0], False, INFINITE) <> WAIT_OBJECT_0) then
      Break; // Terminate thread when FCancelFlag is signaled

    if Assigned(FTimerProc) then
    begin
      WaitInterval := FInterval - LastProcTime;
      if (WaitInterval < 0) then
        WaitInterval := 0;
      if WaitForSingleObject(FCancelFlag, WaitInterval) <> WAIT_TIMEOUT then
        Break;

      if Enabled then
      begin
        QueryPerformanceCounter(StartCount);
        if not Terminated then
          FTimerProc(Self);
        QueryPerformanceCounter(StopCount);
        // Interval adjusted for FTimerProc execution time
        LastProcTime := 1000 * (StopCount - StartCount) div Frequency; // ElapsedMilliSeconds
      end;
    end;
  end;
end;

end.

The main issue is the check I added in TTimerThread.Destroy:

if GetCurrentThreadID = MainThreadID then
begin
  Waitfor; // Synchronize
end;

Why did I do it? consider this test case where I need to terminate the thread if some condition in the Timer event (note I switch to FreeOnTerminate := True and let it auto free):

procedure TForm1.FormShow(Sender: TObject);
begin
  FTimerThread := TTimerThread.Create;
  FTimerThread.Interval := 5000;
  FTimerThread.OnTimerEvent := TimerThreadEvent;
  FTimerThread.OnTerminate := TimerThreadTerminate;
  FTimerThread.Enabled := True;
end;

procedure TForm1.TimerThreadEvent(Sender: TObject);
begin
  Beep;
  // do some real work every 5 seconds
  // if some condition then terminate and stop the thread...
  TTimerThread(Sender).FreeOnTerminate := True; // Let the the thread auto-terminate
  TTimerThread(Sender).Terminate;
  FTimerThread := nil; // Clear references to FTimerThread
end;

procedure TForm1.TimerThreadTerminate(Sender: TObject);
begin
  // nothing special here for now...
  // do something in the main UI
  ShowMessage('TForm1.TimerThreadTerminate');
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  FreeAndNil(FTimerThread);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin      
   FreeAndNil(FTimerThread);    
end;

If I omit the check if GetCurrentThreadID = MainThreadID then Waitfor; the thread hangs, and Waitfor does not return.

Any thoughts?

\$\endgroup\$
  • \$\begingroup\$ I cannot understand why you think you need to call WaitFor inside the Destroy destructor. \$\endgroup\$ – LU RD Jan 28 '17 at 16:18
  • \$\begingroup\$ @LURD it's your code (with WaitFor in the destruction). When the destruction is in the main thread it waits for the thread to finish/synchronize. the code works fine as is. I was just wondering if there is another way to "bail out" if needed in the OnTimerEvent event and free the thread correctly. \$\endgroup\$ – kobik Jan 28 '17 at 16:55

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.