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

Delphi,EurekaLog,FMX,Programing,VCL

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は設定まわりもちょいと面倒だったのでいつか書き残そうかと。