Sordie.co.uk

libsassy/libSassy.Threads.pas

Raw

{(
 )) libSassy.Threading
((    Multithreading and locking library
 ))
((  Copyright  Sordie Aranka Solomon-Smith 2015-2016
 ))
((  This work is made available under the terms of the Creative Commons
 )) Attribution-NonCommercial-ShareAlike 3.0 Unported license
((  http://creativecommons.org/licenses/by-nc-sa/3.0/
 )}

unit libSassy.Threads;

interface

uses
  Winapi.Windows,

  libSassy.Interfaces,
  libSassy.DateTime;

type
  TProcedure = reference to procedure;

{$REGION 'TRTLCriticalSectionHelper'}
  TRTLCriticalSectionHelper = record helper for TRTLCriticalSection
    class function Create: TRTLCriticalSection; static;

    procedure Free; inline;

    procedure Enter; inline;
    procedure Leave; inline;

    procedure Section(Code: TProcedure); inline;
  end;
{$ENDREGION}

{$REGION 'TThread'}
  TThread = class(TInterface)
  private
    fHandle:  Cardinal;
    fRunning: Boolean;

    class function ThreadProc(Thread: TThread): Integer; static;
  public
    FreeOnStop: Boolean;

    CriticalSection: TRTLCriticalSection;

    constructor Create;
    destructor  Destroy; override;

    function Execute: Boolean; virtual; abstract;

    procedure Start;
    procedure Stop(const WaitForStop: Boolean = True);

    procedure Pause;
    procedure Resume;

    procedure Wait;

    function  OnStart: Boolean; virtual;
    procedure OnStop; virtual;
    procedure OnPause; virtual;
    procedure OnResume; virtual;
    procedure OnException(E: TObject); virtual;

    property Handle: Cardinal read fHandle;
    property Running: Boolean read fRunning;
  end;
{$ENDREGION}

{$REGION 'TThreadTimer'}
  TTimerProc = reference to function: Boolean;

  TThreadTimer = class(TThread)
  private
    fOnTimer:  TTimerProc;
    fInterval: Extended;
  public
    constructor Create(const AOnTimer: TTimerProc; const AInterval: Extended = 1);

    function Execute: Boolean; override;

    property Interval: Extended   read fInterval write fInterval;
    property OnTimer:  TTimerProc read fOnTimer  write fOnTimer;
  end;
{$ENDREGION}

{$REGION 'Thread functions'}
procedure Fork(Code: TProcedure);

function InterlockedExchangeAdd64(var Addend: Int64; Value: Int64): Int64; inline;
{$ENDREGION}

implementation

{$REGION 'Thread functions'}
type
  PFork = ^TFork;
  TFork = record
    Code:   TProcedure;
    Handle: Cardinal;
  end;

function ForkProc(Fork: PFork): Integer;
begin
  try
    Fork^.Code.Invoke;
  except end;
  dispose(Fork);
  EndThread(0);
  Result := 0;
end;

procedure Fork;
var
  Fork: PFork;
begin
  new(Fork);

  Fork^.Code := Code;
  BeginThread(nil, 0, @ForkProc, Fork, 0, Fork^.Handle)
end;

function InterlockedExchangeAdd64;
begin
  Result := InterlockedCompareExchange64(Addend, Addend + Value, Addend);
end;
{$ENDREGION}

{$REGION 'TRTLCriticalSectionHelper'}
class function TRTLCriticalSectionHelper.Create;
begin
  InitializeCriticalSection(Result);
end;

procedure TRTLCriticalSectionHelper.Free;
begin
  DeleteCriticalSection(Self);
end;

procedure TRTLCriticalSectionHelper.Enter;
begin
  EnterCriticalSection(Self);
end;

procedure TRTLCriticalSectionHelper.Leave;
begin
  LeaveCriticalSection(Self);
end;

procedure TRTLCriticalSectionHelper.Section;
begin
  Enter;
  try
    Code;
  finally
    Leave;
  end;
end;
{$ENDREGION}

{$REGION 'TThread'}
class function TThread.ThreadProc;
begin
  Result := 0;

  try
    if not Thread.OnStart then exit;

    try
      while Thread.fRunning and Thread.Execute do
        Sleep(1);
    except
      on E: TObject do
        Thread.OnException(E);
    end;
  finally
    Thread.fHandle  := 0;
    Thread.fRunning := False;

    Thread.OnStop;

    EndThread(Result);
  end;
end;

constructor TThread.Create;
begin
  inherited;

  fHandle  := 0;
  fRunning := False;

  FreeOnStop := False;

  CriticalSection := TRTLCriticalSection.Create;
end;

destructor TThread.Destroy;
begin
  Stop(True);

  CriticalSection.Free;

  inherited;
end;

procedure TThread.Start;
begin
  if fHandle <> 0 then exit;
  fRunning := True;

  BeginThread(nil, 0, @ThreadProc, Pointer(Self), 0, fHandle);
end;

procedure TThread.Stop;
begin
  if fHandle = 0 then exit;
  fRunning := False;

  if WaitForStop then Wait;
end;

procedure TThread.Pause;
begin
  if fHandle = 0 then exit;
  SuspendThread(fHandle);
end;

procedure TThread.Resume;
begin
  if fHandle = 0 then exit;
  ResumeThread(fHandle);
end;

procedure TThread.Wait;
begin
  while fRunning do Sleep(100);
end;

function TThread.OnStart;
begin
  Result := True;
end;

procedure TThread.OnStop;
begin
  if FreeOnStop then Free;
end;

procedure TThread.OnPause;
begin

end;

procedure TThread.OnResume;
begin

end;

procedure TThread.OnException;
begin

end;
{$ENDREGION}

{$REGION 'TThreadTimer'}
constructor TThreadTimer.Create;
begin
  inherited Create;

  fInterval := AInterval;
  fOnTimer  := AOnTimer;
end;

function TThreadTimer.Execute;
begin
  TickService.Sleep(fInterval);

  if Assigned(fOnTimer) then
    Result := fOnTimer
  else
    Result := False;
end;
{$ENDREGION}

end.