May 1 2014 at 13:44

CallStack ошибки

Invite pending

В Delphi с самых первых версий существует класс Exception, но не существует штатного способа получения стека ошибки.
В последних версиях в этом классе появились методы для получения стека, но вот реализовать их почему-то забыли.
Но это дело поправимо…

unit uExceptionHook;

interface

uses Classes, SysUtils, Windows;

implementation

const
  MAX_STACK_LENGTH = 16;

type
  PStackFrame = ^TStackFrame;
  TStackFrame = record
    CallerFrame: Pointer;
    CallerAddr: Pointer;
  end;

  NT_TIB32 = packed record
    ExceptionList: DWORD;
    StackBase: DWORD;
    StackLimit: DWORD;
    SubSystemTib: DWORD;
    case Integer of
      0 : (
        FiberData: DWORD;
        ArbitraryUserPointer: DWORD;
        Self: DWORD;
      );
      1 : (
        Version: DWORD;
      );
  end;

var
  OldDebugHook: Byte = 0;
  InDebugMode: Boolean = False;

threadvar
  _Buf: TMemoryBasicInformation;

{ Функции проверки валидности адресов }

function IsValidCodeAddr(const Addr: Pointer): Boolean;
const
  _PAGE_CODE: Cardinal = 
    (PAGE_EXECUTE or PAGE_EXECUTE_READ or PAGE_EXECUTE_READWRITE or PAGE_EXECUTE_WRITECOPY);
Begin
  Result := (VirtualQuery(Addr, _Buf, SizeOf(TMemoryBasicInformation)) <> 0) and 
    ((_Buf.Protect and _PAGE_CODE) <> 0);
end;

function IsValidAddr(const Addr: Pointer): Boolean;
Begin
  Result := (VirtualQuery(Addr, _Buf, SizeOf(TMemoryBasicInformation)) <> 0);
end;

function GetStackTop: Pointer; assembler;
asm
  MOV     EAX, FS:[0].NT_TIB32.StackBase
end;

{ Функции получения стека }

function GetCallStack(const EIP, EBP: Pointer): TList; overload;
var
  TopOfStack: Pointer;
  BaseOfStack: Pointer;
  StackFrame: PStackFrame;
  Level: Integer;
begin
  Result := TList.Create;
  try
    Level := 0; // пропуск по стеку

    Result.Add(EIP);

    StackFrame := EBP;
    BaseOfStack := Pointer(Cardinal(StackFrame) - 1);

    TopOfStack := GetStackTop;
    while (Level < MAX_STACK_LENGTH) and (
        (Cardinal(BaseOfStack) < Cardinal(StackFrame)) and
        (Cardinal(StackFrame) < Cardinal(TopOfStack)) and
        (StackFrame <> StackFrame^.CallerFrame) and
        IsValidAddr(StackFrame) and
        IsValidCodeAddr(StackFrame^.CallerAddr)
      )
    do begin
      if Level >= 0 then
        Result.Add(Pointer(Cardinal(StackFrame^.CallerAddr) - 1));

      StackFrame := PStackFrame(StackFrame^.CallerFrame);

      Inc(Level);
    end;
  except
    // Skip
  end;
end;

function GetCallStack(Context: PContext): TList; overload;
begin
  Result := GetCallStack(Pointer(Context^.Eip), Pointer(Context^.Ebp));
end;

{ Методы для класса Exception }

procedure _CleanUpStackInfoProc(Info: Pointer);
begin
  FreeAndNil(Info);
end;

function _GetStackInfoStringProc(Info: Pointer): String;
var
  StackList: TList;
  I: Integer;
begin
  Result := '';
  if Assigned(Info) then
  begin
    StackList := TList(Info);

    for I := 0 to StackList.Count - 1 do
    begin
      if Result <> '' then
        Result := Result + ' ';

      Result := Result + Format('%p', [StackList[I]]);
    end;
  end;
end;

var
  _BaseRaiseExceptionProc: TRaiseExceptionProc = nil;

type
  TParamArray = array[0..14] of Pointer;
  HookException = class(Exception);

const
  cNonDelphiException = $0EEDFAE4;
  cDelphiException    = $0EEDFADE;
  cContinuable        = 0;

{ Метод для перехвата всех ошибок }

procedure _RaiseExceptionProc(ExceptionCode, ExceptionFlags: LongWord; 
  NumberOfArguments: LongWord; Args: Pointer); stdcall;
var
  ContextRecord: PContext;
  ExceptionObj: HookException;
begin
  if InDebugMode then
  begin
    // Дебагер сам отработает все коды эксепшинов
    _BaseRaiseExceptionProc(ExceptionCode, ExceptionFlags, NumberOfArguments, Args);
  end
  else
  begin
    if (ExceptionCode = cNonDelphiException) then
    begin
      ContextRecord := TParamArray(Args^)[0];
      ExceptionObj := TParamArray(Args^)[1];
      ExceptionObj.SetStackInfo(GetCallStack(ContextRecord));
    end
    else
    if (ExceptionCode = cDelphiException) and (ExceptionFlags <> cContinuable) then
    begin
      ExceptionObj := TParamArray(Args^)[1]; // Except object
      ExceptionObj.SetStackInfo(
        GetCallStack(TParamArray(Args^)[0]{Address}, TParamArray(Args^)[5]{Stack frame}));
    end;

    if ExceptionFlags <> cContinuable then
    begin
      if not InDebugMode then
        DebugHook := OldDebugHook;
      try
        _BaseRaiseExceptionProc(ExceptionCode, ExceptionFlags, NumberOfArguments, Args)
      finally
        if not InDebugMode then
          DebugHook := 1;
      end;
    end;
  end;
end;

{ Установка хука для обработки ошибок }

procedure _InitExceptionHook;
begin
  // Приложение запущено по дебагом
  InDebugMode := (DebugHook <> 0);

  OldDebugHook := DebugHook;

  if not InDebugMode then
    DebugHook := 1; // Для вызова RaiseExceptionProc

  //if not InDebugMode then // Убрать комментарий для дебага
  begin
    _BaseRaiseExceptionProc := RaiseExceptionProc;
    RaiseExceptionProc := @_RaiseExceptionProc;

    Exception.CleanUpStackInfoProc := @_CleanUpStackInfoProc;
    Exception.GetStackInfoStringProc := @_GetStackInfoStringProc;
  end;
end;

{ Снятие хука обработки ошибок }

procedure _ReleaseExceptionHook;
begin
  if not InDebugMode then
    DebugHook := OldDebugHook;

  //if not InDebugMode then // Убрать комментарий для дебага
  begin
    RaiseExceptionProc := @_BaseRaiseExceptionProc;

    Exception.CleanUpStackInfoProc := nil;
    Exception.GetStackInfoStringProc := nil;
  end;
end;

initialization
  _InitExceptionHook;

finalization
  _ReleaseExceptionHook;

end.

После добавление этого модуля в проект, можно использовать такой код:

try
  Proc1;
  Proc2;
  ...
  ProcN;
except
  on E: Exception do
    Log.Add('Error: %s [%s]', [E.Message, E.StackTrace]);
end;

P.S. Для получения стека в любом месте программы можно использовать (для Win7 и выше):

function RtlCaptureStackBackTrace(FramesToSkip: ULONG; FramesToCapture: ULONG; BackTrace: Pointer; 
  BackTraceHash: PULONG): USHORT; stdcall; external 'kernel32.dll' name 'RtlCaptureStackBackTrace';

const
  DBG_STACK_LENGTH = 32;
type
  TDbgInfoStack = array[0..(DBG_STACK_LENGTH - 1)] of Pointer;

procedure GetCallStackOS(var Stack: TDbgInfoStack; FramesToSkip: Integer); stdcall;
begin
  ZeroMemory(@Stack[0], SizeOf(TDbgInfoStack));

  RtlCaptureStackBackTrace(FramesToSkip, DBG_STACK_LENGTH, @Stack[0], Nil);
end;

Стек получили… А что с ним дальше делать? Об этом в следующей статье.

Hubs:

Delphi