鳥の巣箱

ネトゲしたり、機械いじったり、ソフト書いたり、山篭ったり、ギャンブルしたりする人

トップ > Programing > EurekaLogでスレッドの例外を受け取る

EurekaLogでスレッドの例外を受け取る

Programing Programing-Delphi Programing-Delphi-FMX Programing-Delphi-VCL Programing-Delphi-EurekaLog

EurekaLogで別スレッドで発生した例外を受け取る方法としては、公式Documentにいろいろと書いてあります。

EurekaLog 7 Documentation

公式ドキュメント サンプルソースの罠

で、まずあるのが

type
  TMyThread = class(TThreadEx)
  protected
    procedure Execute; override;
  end;
 
procedure TMyThread.Execute;
begin

  // ... your code ...
end;
 
procedure TForm1.Button1Click(Sender: TObject);
var
  Thread: TMyThread;
  E: TObject;
begin
  // Create thread
  Thread := TMyThread.Create('Thread Name');
  try

 
    // Wait for threads completion. 
    // This wait can be implemented in any other way.

    // E.g. you can assign OnTerminate handler;

    // or you can PostMessage from thread to main thread.
    Thread.WaitFor;
 
    // Analyze thread completion.
    // Re-raise any thread error in current thread.

    // You should do this only after the thread has finished.
    E := Thread.FatalException;
    if Assigned(E) then
    begin

      // clear FatalException property
      PPointer(@Thread.FatalException)^ := nil; 
      raise E;
    end;
 
  finally
    FreeAndNil(Thread);
  end;
end;

まぁ、ぱっと見でこれを使うのはありえないなって感じですよね。
メインスレッド側でWaitFor使ってスレッドの終了を待機しています。これじゃスレッド使う意味がないので、実用性もないです。

で、次に出てくるのがこれ

type
  TMyThread = class(TThreadEx)
  protected
    procedure Execute; override;
  end;
 
procedure TMyThread.Execute;
begin
  // ... your code ...
end;
 
procedure TForm1.Button1Click(Sender: TObject);
var
  Thread: TMyThread;
begin
  Thread := TMyThread.Create(True, 'My thread');
  Thread.AutoHandleException := True; // <- added
  Thread.FreeOnTerminate := True;
  Thread.Start;
  Thread := nil; // never access thread var with FreeOnTerminate after Start
end;

これだと、メインスレッドを止めることなくスレッド側の例外通知を受け取れます。
とはいってもこれも問題で、Thread.StartのあとにThreadのポインタをnilにしちゃってることです。
コメントにも書いてありますが「二度とアクセスするな」と。。。なんじゃそら。
スレッド自体はFreeOnTerminateで自動的に終了するようですが、これだとスレッドの現在の状況とかわからないし、こっちも結構不便です。
例外発生して終了していた場合、OnTerminateも発生しなかったので終了検知ができないわけです。

こっちとしては、今まで通りスレッドへのアクセスもしたいわけですし、それでいて例外通知も処理したいと。
で、どうするのか。。。

自作クラスで対応

というわけで、こんな感じのを作りました。
以前TThreadから派生したTTscThreadというのは作っていたので、それに近い形で実装したものが以下。

unit TsuThreadEx;

interface
uses
  System.Classes, System.Generics.Collections, System.SysUtils,
  ExceptionLog7, EBase, EInject, EException, EEvents
  ;

type
  TTsrThreadCallBacks = object
    OnExecute     : TNotifyEvent;
    OnTerminate   : TNotifyEvent;
    OnTerminating : TNotifyEvent;
    OnThreadLoop  : TNotifyEvent;
    procedure Clear;
  end;
  TTscThreadEx  = class(TThreadEx)
    private
      FLoopBreak      : Boolean;
      FOnExecute      : TNotifyEvent;
      FOnTerminating  : TNotifyEvent;
      FOnThreadLoop   : TNotifyEvent;
    protected
      procedure Execute;override;
      procedure Initialize;virtual;
      procedure ThreadMain;virtual;
      procedure DeInitialize;virtual;
    public
      constructor Create(callbacks:TTsrThreadCallBacks);

      property OnTerminate;
      property OnExecute      : TNotifyEvent  read FOnExecute     write FOnExecute;
      property OnTerminating  : TNotifyEvent  read FOnTerminating write FOnTerminating;
      property LoopBreak      : Boolean       read FLoopBreak     write FloopBreak;
      property OnThreadLoop   : TNotifyEvent  read FOnThreadLoop  write FOnThreadLoop;
      property Terminated;
  end;
  TTscThreadExCtrl  = class(TObject)
    private
      function GetFinished:Boolean;
    protected
      FThread       : TTscThreadEx;
      FOnTerminate  : TNotifyEvent;
      FActive       : Boolean;
      FCallBacks    : TTsrThreadCallBacks;
      procedure Terminate;
      procedure ThreadFree;
      procedure ExecuteThread;virtual;abstract;
      procedure ThreadOnTerminate(Sender:TObject);
    public
      constructor Create;
      destructor  Destroy;override;
      procedure SetUp(callbacks:TTsrThreadCallBacks; params:Pointer);virtual;
      procedure Execute;
      procedure TerminateAndNil;
      procedure ExceptProcEvent(AExceptionInfo: TEurekaExceptionInfo;
                                var AHandle: Boolean;
                                var ACallNextHandler: Boolean);
      property OnTerminate  : TNotifyEvent read FOnTerminate write FOnTerminate;
      property Active       : Boolean read FActive;
      property Finished     : Boolean read GetFinished;
  end;

implementation

procedure TTsrThreadCallBacks.Clear;
begin
  OnExecute := nil;
  OnTerminate := nil;
  OnTerminating := nil;
  OnThreadLoop  := nil;
end;

{$region'    TTscThreadEx    '}
constructor TTscThreadEx.Create(callbacks:TTsrThreadCallBacks);
begin
  FLoopBreak          := False;
  AutoHandleException := True;
  FreeOnTerminate     := True;
  OnTerminate         := callbacks.OnTerminate;
  FOnExecute          := callbacks.OnExecute;
  FOnTerminating      := callbacks.OnTerminating;
  FOnThreadLoop       := callbacks.OnThreadLoop;
  inherited Create(True, ClassName);
end;

procedure TTscThreadEx.Execute;
begin
  if Assigned(OnExecute) then OnExecute(Self);
  Initialize;

  while not Terminated do
    begin
      if Assigned(OnThreadLoop) then OnThreadLoop(Self);
      ThreadMain;
      if LoopBreak then Break;
    end;

  if Assigned(OnTerminating) then OnTerminating(Self);
  DeInitialize;
  if Assigned(OnTerminate) then OnTerminate(Self);
end;

procedure TTscThreadEx.Initialize;
begin

end;

procedure TTscThreadEx.ThreadMain;
begin

end;

procedure TTscThreadEx.DeInitialize;
begin

end;
{$endregion}

{$region'    TTscThreadExCtrl    '}
constructor TTscThreadExCtrl.Create;
begin
  FThread := nil;
  RegisterEventExceptionNotify(ExceptProcEvent, False);
  inherited Create;
end;

destructor TTscThreadExCtrl.Destroy;
begin
  if FThread <> nil then
    FreeAndNil(FThread);
  inherited Destroy;
end;

procedure TTscThreadExCtrl.Execute;
begin
  if not Assigned(FThread) then
    begin
      ExecuteThread;
      FThread.Start;
      FActive := True;
    end;
end;

procedure TTscThreadExCtrl.Terminate;
begin
  if Assigned(FThread) then
    if not FThread.Finished then
      FThread.Terminate;
  if Assigned(FOnTerminate) then FOnTerminate(Self);  
  FActive := False;
end;

procedure TTscThreadExCtrl.ThreadFree;
begin
  FThread := nil;
end;

procedure TTscThreadExCtrl.SetUp(callbacks:TTsrThreadCallBacks; params:Pointer);
begin
  FCallBacks  := callbacks;
  FOnTerminate  := callbacks.OnTerminate;
  callbacks.OnTerminate  := ThreadOnTerminate;
end;

procedure TTscThreadExCtrl.ThreadOnTerminate(Sender: TObject);
begin

end;

function TTscThreadExCtrl.GetFinished: Boolean;
begin
  if Assigned(FThread) then
    Result  := FThread.Finished
  else
    Result  := True;
end;

procedure TTscThreadExCtrl.TerminateAndNil;
begin
  Terminate;
  ThreadFree;
end;

procedure TTscThreadExCtrl.ExceptProcEvent(AExceptionInfo: TEurekaExceptionInfo;
                                          var AHandle: Boolean;
                                          var ACallNextHandler: Boolean);
begin
  if Assigned(FThread) then
    begin
      if AExceptionInfo.ThreadID = FThread.ThreadID then TerminateAndNil;
    end;
end;
{$endregion}

はい。
で、ポイントはTTscThreadExCtrlクラス。これはTTscThreadExクラスから派生したスレッドの管理をするクラスです。
これのCreateで

  RegisterEventExceptionNotify(ExceptProcEvent, False);

と書いてますが、これを書くことでEurekaLogが例外を受け取った際に発生させてくれるイベントに登録ができます。
登録したのはExceptProcEventメソッドです。
これの中身は、TTscThreadExCtrlが管理しているスレッドと、イベント引数のAExceptionInfo.ThreadIDとを比較しています。これが一致した場合は、管理下のスレッドから例外が発生しているということなので、スレッドの終了処理に移行する。という流れ。
公式Documentにあったthread := nilはせずにいるので、こちらで破棄するまでアクセス可能です。

あとはこれらを派生させたクラスをベースにコーディングすればスレッド周りはとりあえず問題なく動いています。
EurekaLogは設定まわりもちょいと面倒だったのでいつか書き残そうかと。