Estava precisando de informações sobre uma exceção e o log de erro não dizia nada relevante possível de encontrar onde o problema ocorria.

Já vi vários posts sobre o assunto peguntando como fazer isto. Então não tive outra saída… mãos-a-obra.

(uso Delphi 10.1)

A instância  “Application” possui um evento “application.onException” que permite indicar um método para redirecionar a saída de todas as exceções não tratadas pelo aplicativo.

[code lang=”pascal”]
// preparando o evento no formulário principal
procedure TForm1.DoAppException(sender:TObject; E:Exception);
begin
DoAppExceptionEvent(sender,e,true);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnException := DoAppException;

end;
[/code]

[code lang=”pascal”]
uses Forms, System.Classes,System.SysUtils,System.RTTI;

// grava o log em disco
procedure ErrorLog(ATexto: string);
var
LArquivo: string;
LTextFile: textfile;
begin
LArquivo := ‘Erros_’ + formatDateTime(‘yyyymmdd’, date) + ‘.log’;
ForceDirectories(ExtractFilePath(LArquivo));

AssignFile(LTextFile, LArquivo);
try
{$I-}
Append(LTextFile);
{$I+}
if IOResult <> 0 then // se o arquivo nao existe, criar um novo;
Rewrite(LTextFile);
WriteLn(LTextFile, ATexto);
finally
CloseFile(LTextFile);
end;
end;

// monta a mensagem do log com base nos atributos do objecto que gerou a exceção
procedure DoAppExceptionEvent(Sender: TObject; E: Exception;
AShow: boolean = True);
var
LMsg: string;
function GetRTTILog(ASender: TObject): string;
var
LNome: string;
LContext: TRttiContext;
LType: TRttiType;
LProp: TRttiProperty;
LVar: TValue;
LTxt: String;
begin
result := ”;
if ASender=nil then exit;
result := ‘ClassName: ‘ + ASender.ClassName + #13#10;
LContext := TRttiContext.Create;
try
LType := LContext.GetType(ASender.ClassType);
for LProp in LType.GetProperties do
begin
try
LVar := LProp.GetValue(ASender);
LTxt := LVar.AsString;
if LTxt <> ” then
result := result + LProp.Name + ‘: ‘ + LTxt + #13#10;
except
end;
end;
finally
LContext.Free;
end;
end;

begin
try
LMsg := ”;
if assigned(Sender) then
begin
LMsg := GetRTTILog(Sender);
end;
LMsg := LMsg + ‘ Message: ‘ + E.Message;
ErrorLog(LMsg);
except
on ee: Exception do
ErrorLog(ee.Message);
end;
if AShow then
begin
E.Message := LMsg;
Application.ShowException(E);
end;
end;

[/code]

Quando estamos rodando um código em um processo paralelo e internamente a Thread encontra pela frente uma EXCEPTION nada é apresentado para o usuário. Isto ocorre porque a Thread não tem como notificar a Thread Principal (do app) para mostrar a exceção ao usuário. Com isto não há um expediente para mostrar a exceção na thread principal.  escreve sobre o tema em seu blog Rob’s Technology Corner.

Robert propõe a rotina que gera erro para contextuar o problema:

[code lang=”pascal”]

procedure TForm5.Button1Click(Sender: TObject);
begin
Button1.Enabled := False;
SlowProc;
end;

procedure TForm5.FormDestroy(Sender: TObject);
begin
Task.Cancel;
end;

procedure TForm5.SlowProc;
begin
Task := TTask.Create( procedure
var
I : Integer;
begin
for I := 0 to 9 do
begin
if TTask.CurrentTask.Status = TTaskStatus.Canceled then
exit;
Sleep(1000);
if I = 2 then
raise EProgrammerNotFound.Create(‘Something bad just happened’);
end;
if TTask.CurrentTask.Status <> TTaskStatus.Canceled then
begin
TThread.Queue(TThread.CurrentThread,
procedure
begin
if Assigned(ListBox1) then
begin
Listbox1.Items.Add(’10 Seconds’);
Button1.Enabled := True;
end;
end);
end;
end);
Task.Start;
end;
[/code]

Executando o código é possível constatar que o procedimento levanta uma exceção e o usuário não recebe a informação de erro.

Stefan Glienke observando o que escreve Robert, propõe uma alteração em TTask para permitir tratar as exceções transparentes para o usuário e mais simples na implementação.
Glienke empresta de .NET uma implementação de Task.ContinueWith que permite continuar a execução após a ocorrência da exceção, veja como ficou.

[code lang=”pascal”]
unit ThreadingEx;

interface

uses
SysUtils,
Threading;

type
TAction<T> = reference to procedure(const arg: T);

TTaskContinuationOptions = (
NotOnCompleted,
NotOnFaulted,
NotOnCanceled,
OnlyOnCompleted,
OnlyOnFaulted,
OnlyOnCanceled
);

ITaskEx = interface(ITask)
[‘{3AE1A614-27AA-4B5A-BC50-42483650E20D}’]
function GetExceptObj: Exception;
function GetStatus: TTaskStatus;
function ContinueWith(const continuationAction: TAction<ITaskEx>;
continuationOptions: TTaskContinuationOptions): ITaskEx;

property ExceptObj: Exception read GetExceptObj;
property Status: TTaskStatus read GetStatus;
end;

TTaskEx = class(TTask, ITaskEx)
private
fExceptObj: Exception;
function GetExceptObj: Exception;
protected
function ContinueWith(const continuationAction: TAction<ITaskEx>;
continuationOptions: TTaskContinuationOptions): ITaskEx;
public
destructor Destroy; override;

class function Run(const action: TProc): ITaskEx; static;
end;

implementation

uses
Classes;

{ TTaskEx }

function TTaskEx.ContinueWith(const continuationAction: TAction<ITaskEx>;
continuationOptions: TTaskContinuationOptions): ITaskEx;
begin
Result := TTaskEx.Run(
procedure
var
task: ITaskEx;
doContinue: Boolean;
begin
task := Self;
if not IsComplete then
DoneEvent.WaitFor;
fExceptObj := GetExceptionObject;
case continuationOptions of
NotOnCompleted: doContinue := GetStatus <> TTaskStatus.Completed;
NotOnFaulted: doContinue := GetStatus <> TTaskStatus.Exception;
NotOnCanceled: doContinue := GetStatus <> TTaskStatus.Canceled;
OnlyOnCompleted: doContinue := GetStatus = TTaskStatus.Completed;
OnlyOnFaulted: doContinue := GetStatus = TTaskStatus.Exception;
OnlyOnCanceled: doContinue := GetStatus = TTaskStatus.Canceled;
else
doContinue := False;
end;
if doContinue then
continuationAction(task);
end);
end;

destructor TTaskEx.Destroy;
begin
fExceptObj.Free;
inherited;
end;

function TTaskEx.GetExceptObj: Exception;
begin
Result := fExceptObj;
end;

class function TTaskEx.Run(const action: TProc): ITaskEx;
var
task: TTaskEx;
begin
task := TTaskEx.Create(nil, TNotifyEvent(nil), action, TThreadPool.Default, nil);
Result := task.Start as ITaskEx;
end;

end.
[/code]

Como usar a nova implementação de TTask…
[code lang=”pascal”]
TTaskEx.Run(
procedure
begin
Sleep(2000);
raise EProgrammerNotFound.Create(‘whoops’)
end)
.ContinueWith(
procedure(const t: ITaskEx)
begin
TThread.Queue(nil,
procedure
begin
ShowMessage(t.ExceptObj.Message);
end);
end, OnlyOnFaulted);
[/code]
 

Ver PPL – TTask an example in how not to use

No Firebird 3 passou a ser possível criar exception com parâmetros que adicionam texto à mensagem retornada para o usuário.

create exception e_invalid_val ‘Valor invalido @1  para a coluna @2’;


if (val < 1000) then
thing = val;
else

exception e_invalid_val using (val, ‘thing’);
end

 

Este recurso na prática não adiciona nenhum ganho, já que no 2.5 era possível adicionar um texto à exceção..

Exception erro ‘Valor invalido ‘||val||’ para a coluna xxxx’;