unit Tasks;

interface

uses
  Winapi.Windows, Winapi.Messages,
  System.Classes, System.Types,
  System.Generics.Collections,
  System.Rtti, System.SysUtils, System.SyncObjs;

type
  TTaskRecord = packed record
    TaskName: string;
    TaskArgs: array of TValue;
  end;

  ETaskNotFound = class(Exception);

type
  TTaskThread = class(TThread)
  private class var
    FRttiContext: TRttiContext;
  private
    FTaskList: TThreadList<TTaskRecord>;
    FQueueEvent: TEvent;
    procedure StartTasking; {$IFNDEF DEBUG} inline; {$ENDIF}
    procedure StopTasking; {$IFNDEF DEBUG} inline; {$ENDIF}
    function IsTaskingFinished: Boolean;
  protected
    procedure BeforeExecute; virtual;
    procedure AfterExecute; virtual;
    procedure Execute; override;
    function HandleException: Boolean; virtual;
  public
    class constructor CreateContext;
    constructor Create; virtual;
    destructor Destroy; override;
    procedure CreateTask(const ATaskName: string; const ATaskArgs: array of TValue); overload;
  end;

implementation

uses
  Winapi.ActiveX;

resourcestring
  ERR_TASKEXCEPTION = 'TASK EXCEPTION HAS BEEN RAISED WIDTH MESSAGE: ''';

{ TTaskThread }

class constructor TTaskThread.CreateContext;
begin
  FRttiContext := TRttiContext.Create
end;

constructor TTaskThread.Create;
begin
  inherited Create(False);
  FQueueEvent := TEvent.Create(nil, True, False, '');
  FTaskList := TThreadList<TTaskRecord>.Create
end;

procedure TTaskThread.BeforeExecute;
begin
  CoInitializeEx(nil, COINIT_MULTITHREADED)
end;

procedure TTaskThread.AfterExecute;
begin
  CoUninitialize
end;

procedure TTaskThread.StartTasking;
begin
  TMonitor.Enter(Self);
  FQueueEvent.SetEvent;
  TMonitor.Exit(Self)
end;

procedure TTaskThread.CreateTask(const ATaskName: string; const ATaskArgs: array of TValue);
var
  TaskRecord: TTaskRecord;
  I: Integer;
begin
  with TaskRecord do
  begin
    SetLength(TaskArgs, Length(ATaskArgs));
    for I := 0 to High(ATaskArgs) do
      TaskArgs[I] := ATaskArgs[I];
    TaskName := ATaskName
  end;
  FTaskList.Add(TaskRecord);
  StartTasking
end;

procedure TTaskThread.StopTasking;
begin
  TMonitor.Enter(Self);
  FQueueEvent.ResetEvent;
  TMonitor.Exit(Self)
end;

procedure TTaskThread.Execute;
var
  Task: TTaskRecord;
  TaskExists: Boolean;
  TaskList: TList<TTaskRecord>;
  RttiType: TRttiType;
  RttiMethod: TRttiMethod;
begin
  try
    BeforeExecute;
    try
      while not Terminated do
      begin
        FQueueEvent.WaitFor;
        repeat
          TaskList := FTaskList.LockList;
          try
            TaskExists := TaskList.Count > 0;
            if TaskExists then
            begin
              Task := TaskList.First;
              TaskList.Delete(0)
            end;
          finally
            FTaskList.UnlockList
          end;
          if Terminated or not TaskExists then
            Break;
          with Task do
            try
              RttiType := FRttiContext.GetType(ClassType);
              RttiMethod := RttiType.GetMethod(TaskName);
              if Assigned(RttiMethod) then
                RttiMethod.Invoke(Self, TaskArgs)
              else
                raise ETaskNotFound.CreateFmt('TASK %s NOT FOUND', [TaskName])
            except
              if not HandleException then
                raise
            end
        until not TaskExists;
        StopTasking
      end
    finally
      AfterExecute
    end
  except
    OutputDebugString(PChar(Concat(ERR_TASKEXCEPTION, Exception(ExceptObject).Message, '''')))
  end
end;

function TTaskThread.HandleException: Boolean;
begin
  Result := True;
  OutputDebugString(PChar(Concat(ERR_TASKEXCEPTION, Exception(ExceptObject).Message, '''')))
end;

function TTaskThread.IsTaskingFinished: Boolean;
begin
  Result := Finished
end;

destructor TTaskThread.Destroy;
begin
  Terminate;
  FQueueEvent.SetEvent;
  while not TSpinWait.SpinUntil(IsTaskingFinished, INFINITE) do
    CheckSynchronize;
  inherited Destroy;
  FreeAndNil(FTaskList);
  FreeAndNil(FQueueEvent)
end;

end.

unit Unit11;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils,
  System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Tasks;

type
  TMyString = type string;

  TMainFormTasks = class(TTaskThread)
  public
    procedure TestMyString(const AText: TMyString);
  end;

  TMainForm = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    MainFormTasks: TMainFormTasks;
  end;

var
  MainForm: TMainForm;

implementation

{$R *.dfm}

{ TMainFormTasks }

procedure TMainFormTasks.TestMyString(const AText: TMyString);
begin
  Synchronize(procedure
    begin
      ShowMessage(AText)
    end);
end;

procedure TMainForm.FormCreate(Sender: TObject);
begin
  MainFormTasks := TMainFormTasks.Create;
  MainFormTasks.CreateTask('TestMyString', ['Test My String']);
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
  MainFormTasks.Free
end;

end.