(******************************************************************************

Copyright (c) 2022+ Pepak (https://www.pepak.net)
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.
    * Redistributions in binary form must reproduce the above copyright
      notice, this list of conditions and the following disclaimer in the
      documentation and/or other materials provided with the distribution.
    * Neither the name of Pepak nor the
      names of his contributors may be used to endorse or promote products
      derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL PEPAK BE LIABLE FOR ANY
DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

******************************************************************************)

unit pkThreads;
{$INCLUDE 'pepak.inc'}

interface

uses
  Windows, SysUtils, Classes;

type
  TPausableThread = class(TThread)
  private
    FPauseHandle: THandle;
  protected
    function Pause(const Milliseconds: DWORD): boolean;
      // Returns True if paused for the full interval.
      // Must be called from Execute!!!
    procedure Unpause;
    {$IFDEF DELPHI2009_UP}
    procedure TerminatedSet; override;
    {$ELSE}
    procedure DoTerminate; override;
    {$ENDIF}
  public
    procedure AfterConstruction; override;
    destructor Destroy; override;
  end;

type
  TTimerThread = class(TPausableThread)
  private
    FLock: TRTLCriticalSection;
    FOnTimer: TNotifyEvent;
    FInterval: integer;
    FEnabled: boolean;
    function GetAndCheckValues(out Enabled: boolean; out Interval: integer; out OnTimer: TNotifyEvent; CheckTerminated: boolean): boolean;
    procedure SetEnabled(const Value: boolean);
    procedure SetInterval(const Value: integer);
    procedure SetOnTimer(const Value: TNotifyEvent);
  protected
    procedure Execute; override;
  public
    constructor Create;
    destructor Destroy; override;
    property Enabled: boolean read FEnabled write SetEnabled;
    property Interval: integer read FInterval write SetInterval;
    property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;
  end;

implementation

{ TPausableThread }

procedure TPausableThread.AfterConstruction;
begin
  FPauseHandle := CreateEvent(nil, FALSE, FALSE, nil);
  inherited;
end;

destructor TPausableThread.Destroy;
begin
  if FPauseHandle <> 0 then
  begin
    Unpause;
    CloseHandle(FPauseHandle);
    FPauseHandle := 0;
  end;
  inherited;
end;

{$IFDEF DELPHI2009_UP}
procedure TPausableThread.TerminatedSet;
{$ELSE}
procedure TPausableThread.DoTerminate;
{$ENDIF}
begin
  inherited;
  Unpause;
end;

function TPausableThread.Pause(const Milliseconds: DWORD): boolean;
begin
  Result := False;
  if GetCurrentThreadId <> Self.ThreadID then
    Raise EInvalidOp.Create('Pause can only be called from within the thread!');
  if FPauseHandle <> 0 then
  begin
    ResetEvent(FPauseHandle);
    if WaitForSingleObject(FPauseHandle, Milliseconds) = WAIT_TIMEOUT then
      Result := True;
    ResetEvent(FPauseHandle);
  end;
end;

procedure TPausableThread.Unpause;
begin
  if FPauseHandle <> 0 then
    SetEvent(FPauseHandle);
end;

{ TTimerThread }

constructor TTimerThread.Create;
begin
  inherited Create( {$IFDEF DELPHI2009_UP} False {$ELSE} True {$ENDIF} );
  InitializeCriticalSection(FLock);
  FOnTimer := nil;
  FInterval := 1000;
  FEnabled := True;
  {$IFNDEF DELPHI2009_UP}
  Resume;
  {$ENDIF}
end;

destructor TTimerThread.Destroy;
begin
  if not Terminated then
    Terminate;
  DeleteCriticalSection(FLock);
  inherited;
end;

procedure TTimerThread.Execute;
var
  LEnabled: boolean;
  LInterval: integer;
  LOnTimer: TNotifyEvent;
  LWaitedFullInterval: boolean;
begin
  while not Terminated do
  begin
    if not GetAndCheckValues(LEnabled, LInterval, LOnTimer, False) then
    begin
      Pause(INFINITE);
      Continue;
    end;
    LWaitedFullInterval := False;
    if GetAndCheckValues(LEnabled, LInterval, LOnTimer, True) then
    begin
      if Pause(LInterval) then
        LWaitedFullInterval := True;
    end;
    if LWaitedFullInterval and GetAndCheckValues(LEnabled, LInterval, LOnTimer, True) then
    begin
      LOnTimer(Self);
    end;
  end;
end;

function TTimerThread.GetAndCheckValues(out Enabled: boolean; out Interval: integer; out OnTimer: TNotifyEvent; CheckTerminated: boolean): boolean;
begin
  Result := True;
  EnterCriticalSection(FLock);
  try
    Enabled := Self.Enabled;
    Interval := Self.Interval;
    OnTimer := Self.OnTimer;
  finally
    LeaveCriticalSection(FLock);
  end;
  if not Enabled then
    Result := False;
  if Interval <= 0 then
    Result := False;
  if not Assigned(OnTimer) then
    Result := False;
  if CheckTerminated and Terminated then
    Result := False;
end;

procedure TTimerThread.SetEnabled(const Value: boolean);
var
  OldValue: boolean;
begin
  EnterCriticalSection(FLock);
  try
    OldValue := FEnabled;
    FEnabled := Value;
    if (Value <> OldValue) and Value then
      Unpause;
  finally
    LeaveCriticalSection(FLock);
  end;
end;

procedure TTimerThread.SetInterval(const Value: integer);
var
  OldValue: integer;
begin
  EnterCriticalSection(FLock);
  try
    OldValue := FInterval;
    FInterval := Value;
    if (Value <> OldValue) and (Value > 0) then
      Unpause;
  finally
    LeaveCriticalSection(FLock);
  end;
end;

procedure TTimerThread.SetOnTimer(const Value: TNotifyEvent);
var
  OldValue: TNotifyEvent;
begin
  EnterCriticalSection(FLock);
  try
    OldValue := FOnTimer;
    FOnTimer := Value;
    if (@Value <> @OldValue) and Assigned(Value) and (not Assigned(OldValue)) then
      Unpause;
  finally
    LeaveCriticalSection(FLock);
  end;
end;

end.
