Jak uzyskać tryb nieblokujący dla metod blokujących

Czasem umieszczamy procedurę w osobnym wątku aby nie blokować wątku głównego. Procedurę można tak zaprojektować, aby dało się ją prosto przerwać, np. korzystając z własności Terminated klasy TThread. Czasem jednak ciężko jest zaprojektować procedurę tak, aby dało się ją przerwać natychmiastowo albo po prostu korzystamy z jakiejś biblioteki która nie jest przystosowana do przerwania procedury. W takim przypadku jedynym wyjściem jest zabicie wątku. Klasa TThread nie daje nam takiej możliwości i musimy użyć funkcji WinAPI TerminateThread. Niestety tak zabijając wątek nie zostanie wywołane zdarzenie OnTerminate. Dodatkowo jeśli nie wyłapiemy wszystkich wyjątków to nie mamy pewności, że procedura zakończyła się pomyślnie.

Z powyższymi niedogonieniami rozprawiłem się tworząc komponent TNonBlockingTask. Poniżej zamieszczam kod komponentu dzięki któremu możemy łatwo wywołać procedurę w trybie nieblokującym i kontrolować jej działanie.

Jednak nie jest tak pięknie do końca. TerminateThread może narobić niezłego zamieszania pozostawiając pootwierane uchwyty, niezwolnioną pamięć i kilka innych (więcej informacji na MSDN) lub nawet całkowicie sparaliżować używaną bibliotekę. Wtedy musimy zrezygnować z trybu nieblokującego lub pogodzić się z konsekwencjami.

Komponent TNonBlockingTask zwiera między innymi:
*metodę Run startującą wątek wykonujący zadanie
*metodę Kill zabijającą wątek
*własność Running mówiącą nam czy wykonywane jest zadanie
*własność Task - zadanie do wykonania (procedurę blokującą)
*zdarzenie OnStop wywoływane po zakończeniu zadania
Zdarzenie OnStop dostarcza nam informacji o przyczynach zakończenia zadania. Podczas jego obsługi powinniśmy "posprzątać" po zadaniu.
*Completed - parametr mówiący nam, czy zadanie zostało wykonane do końca
*Exc - wyjątek który przerwał zadanie (nil jeśli wyjątku nie było)

unit NonBlockingTask;

interface

uses
  Windows, Classes, Controls, SysUtils;

type

TNonBlockingTask = class(TComponent)
public type
  TStopEvent =
    procedure(Sender: TObject; Completed: Boolean; Exc: Exception) of object;
  TTaskProc = procedure of object;
private type
  TTaskThread = class(TThread)
  private
    FTaskProc: TTaskProc;
    FCompleted: Boolean;
    FExc: Exception;
  public
    constructor Create(TaskProc: TTaskProc);
    procedure Execute; override;
    property Completed: Boolean read FCompleted;
    property Exc: Exception read FExc;
  end;
private
  FTaskThread: TTaskThread;
  FTaskProc: TTaskProc;
  FStopEvent: TStopEvent;
  FRaiseStopEventWhileDestroying: Boolean;
  function GetRunning: Boolean;
  procedure TaskThreadTerminate(Sender: TObject);
public
  constructor Create(AOwner: TComponent; TaskProc: TTaskProc = nil);
  destructor Destroy; override;
  procedure Run;
  procedure Kill;
published
  property Running: Boolean read GetRunning;
  property RaiseStopEventWhileDestroying: Boolean
    read FRaiseStopEventWhileDestroying write FRaiseStopEventWhileDestroying;
  property TaskProc: TTaskProc read FTaskProc write FTaskProc;
  property OnStop: TStopEvent read FStopEvent write FStopEvent;
end;

procedure Register;

implementation

constructor TNonBlockingTask.Create(AOwner: TComponent; TaskProc: TTaskProc);
begin
  inherited Create(AOwner);
  FTaskProc := TaskProc;
  FRaiseStopEventWhileDestroying := False;  
end;

destructor TNonBlockingTask.Destroy;
begin
  if FRaiseStopEventWhileDestroying then Kill
  else if Running then TerminateThread(FTaskThread.Handle, 0);
  inherited;
end;

function TNonBlockingTask.GetRunning: Boolean;
begin
  Result := FTaskThread <> nil;
end;

procedure TNonBlockingTask.Run;
begin
  if Assigned(FTaskProc) and not Running then
  begin
    FTaskThread := TTaskThread.Create(TaskProc);
    FTaskThread.OnTerminate := TaskThreadTerminate;
    FTaskThread.FreeOnTerminate := True;
    FTaskThread.Resume;
  end;
end;

procedure TNonBlockingTask.Kill;
begin
  if Running then
  begin
    TerminateThread(FTaskThread.Handle, 0);
    TaskThreadTerminate(FTaskThread);
  end;
end;

procedure TNonBlockingTask.TaskThreadTerminate(Sender: TObject);
begin
  if Running then
  begin
    if Assigned(FStopEvent) then
      FStopEvent(Self, FTaskThread.Completed, FTaskThread.Exc);
    FTaskThread := nil;
  end;
end;

constructor TNonBlockingTask.TTaskThread.Create(TaskProc: TTaskProc);
begin
  FTaskProc := TaskProc;
  FCompleted := False;
  inherited Create(True);
end;

procedure TNonBlockingTask.TTaskThread.Execute;
begin
  try
    FTaskProc;
    FCompleted := True;
  except on E: Exception do
    FExc := E;
  end;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TNonBlockingTask]);
end;

end.