System.Threading => mehrere Threads gleichzeitig ??

[Sir Rufo]

Hier mal auf die Schnelle etwas zum Ansschauen

Delphi-Quellcode:

unit dp_186773.Forms.MainForm;

interface

uses
  Threading.ProcQueue,

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

type
  TMainForm = class( TForm )
    Button1: TButton;
    ListBox1: TListBox;
    procedure Button1Click( Sender: TObject );
  private
    FProcQueue: TProcQueue;
    procedure Log( const AMsg: string );
    function CreateProc( const AID: string ): TProc;
  public
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
  end;

var
  MainForm: TMainForm;

implementation

{$R *.dfm}

procedure TMainForm.AfterConstruction;
begin
  inherited;
  FProcQueue := TProcQueue.Create( 4 );
end;

procedure TMainForm.BeforeDestruction;
begin
  FProcQueue.Free;
  inherited;
end;

procedure TMainForm.Button1Click( Sender: TObject );
var
  I: Integer;
begin
  for I := 1 to 10 do
    begin
      FProcQueue.Add( CreateProc( TGUID.NewGuid.ToString ) );
    end;
end;

function TMainForm.CreateProc( const AID: string ): TProc;
begin
  Result :=
    procedure
    begin
      TThread.Synchronize( nil,
        procedure
        begin
          Log( AID + ' started' );
        end );
      try
        Sleep( 1000 );
      finally
        TThread.Synchronize( nil,
          procedure
          begin
            Log( AID + ' finished' );
          end );
      end;
    end;
end;

procedure TMainForm.Log( const AMsg: string );
begin
  ListBox1.ItemIndex := ListBox1.Items.Add( AMsg );
end;

end.

Delphi-Quellcode:

unit Threading.ProcQueue;

interface

uses
  System.Generics.Collections,
  System.SysUtils,
  System.Threading;

type
  TProcQueue = class
  private
    FShutdown   : Boolean;
    FMaxParallel: Integer;
    FSync       : TObject;
    FProcQueue  : TQueue<TProc>;
    FTaskList   : TList<ITask>;
    procedure Execute( const AProc: TProc );
    procedure TaskHasFinished( const ATask: ITask );
  public
    constructor Create( const MaxParallel: Integer );
    destructor Destroy; override;

    procedure Add( const AProc: TProc );
  end;

implementation

{ TProcQueue }

procedure TProcQueue.Add( const AProc: TProc );
begin
  if FShutdown
  then
    raise EInvalidOpException.Create( 'we are going down' );

  TMonitor.Enter( FSync );
  try
    if FTaskList.Count < FMaxParallel
    then
      Execute( AProc )
    else
      FProcQueue.Enqueue( AProc );
  finally
    TMonitor.Exit( FSync );
  end;
end;

constructor TProcQueue.Create( const MaxParallel: Integer );
begin
  inherited Create;
  FMaxParallel := MaxParallel;
  FSync        := TObject.Create;
  FProcQueue   := TQueue<TProc>.Create;
  FTaskList    := TList<ITask>.Create;
end;

destructor TProcQueue.Destroy;
var
  task: ITask;
begin
  TMonitor.Enter( FSync );
  try
    FShutdown := True;
    FProcQueue.Clear;
  finally
    TMonitor.Exit( FSync );
  end;
  try
    TTask.WaitForAll( FTaskList.ToArray );
  except
    // we do not care about exceptions
  end;
  FTaskList.Free;
  FProcQueue.Free;
  inherited;
  FSync.Free;
end;

procedure TProcQueue.Execute( const AProc: TProc );
var
  task: ITask;
begin
  task := TTask.Create(
    procedure
    begin
      try
        AProc( );
      finally
        TaskHasFinished( task );
      end;
    end );
  FTaskList.Add( task );
  task.Start;
end;

procedure TProcQueue.TaskHasFinished( const ATask: ITask );
begin
  TMonitor.Enter( FSync );
  try
    FTaskList.Remove( ATask );
    if not FShutdown and ( FProcQueue.Count > 0 )
    then
      Execute( FProcQueue.Dequeue( ) );
  finally
    TMonitor.Exit( FSync );
  end;
end;

end.

PS: ITask.Cancel sollte man sich verkneifen