Share Button

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.

// 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;
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;

Share Button

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:


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;

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.

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.

Como usar a nova implementação de TTask…

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);

 

Ver PPL – TTask an example in how not to use

Share Button

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’;