Exception call stacks on Windows with only a few LOCs
Many of us miss call stacks in Delphi and have to use heavy or commercial libs. Luckily Microsoft cares of us and provides necessary API's.
Here's the unit
// Stack tracing with WinAPI
// (c) Fr0sT-Brutal
// License MIT
unit StackTrace;
interface
{$IFDEF MSWINDOWS}
uses
Windows, SysUtils;
const
DBG_STACK_LENGTH = 32;
type
TDbgInfoStack = array[0..DBG_STACK_LENGTH - 1] of Pointer;
PDbgInfoStack = ^TDbgInfoStack;
function RtlCaptureStackBackTrace(FramesToSkip: ULONG; FramesToCapture: ULONG; BackTrace: Pointer;
BackTraceHash: PULONG): USHORT; stdcall; external 'kernel32.dll';
procedure GetCallStackOS(var Stack: TDbgInfoStack; FramesToSkip: Integer);
function CallStackToStr(const Stack: TDbgInfoStack): string;
procedure InstallExceptionCallStack;
{$ENDIF}
implementation
{$IFDEF MSWINDOWS}
procedure GetCallStackOS(var Stack: TDbgInfoStack; FramesToSkip: Integer);
begin
ZeroMemory(@Stack, SizeOf(Stack));
RtlCaptureStackBackTrace(FramesToSkip, Length(Stack), @Stack, nil);
end;
function CallStackToStr(const Stack: TDbgInfoStack): string;
var
Ptr: Pointer;
begin
Result := '';
for Ptr in Stack do
if Ptr <> nil then
Result := Result + sLineBreak + Format('$%p', [Ptr])
else
Break;
end;
function GetExceptionStackInfo(P: PExceptionRecord): Pointer;
begin
Result := AllocMem(SizeOf(TDbgInfoStack));
GetCallStackOS(PDbgInfoStack(Result)^, 1); // excluding the very function GetCallStackOS
end;
function GetStackInfoStringProc(Info: Pointer): string;
begin
Result := CallStackToStr(PDbgInfoStack(Info)^);
end;
procedure CleanUpStackInfoProc(Info: Pointer);
begin
Dispose(PDbgInfoStack(Info));
end;
procedure InstallExceptionCallStack;
begin
Exception.GetExceptionStackInfoProc := GetExceptionStackInfo;
Exception.GetStackInfoStringProc := GetStackInfoStringProc;
Exception.CleanUpStackInfoProc := CleanUpStackInfoProc;
end;
procedure UninstallExceptionCallStack;
begin
Exception.GetExceptionStackInfoProc := nil;
Exception.GetStackInfoStringProc := nil;
Exception.CleanUpStackInfoProc := nil;
end;
{$ENDIF}
end.
test project
program Project2;
{$APPTYPE CONSOLE}
{$R *.res}
uses
Windows,
SysUtils,
StackTrace in 'StackTrace.pas';
// Demo subs
procedure Nested2;
begin
Abort;
end;
procedure Nested1;
begin
Nested2;
end;
procedure Nested0;
begin
Nested1;
end;
begin
try
InstallExceptionCallStack;
Nested0;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message, sLineBreak, E.StackTrace);
end;
Readln;
end.
and output
Your comment got me to remember ASLR in 11. Removing ASLR makes it work correctly.
For anyone else interested, it is the 2nd to last option in Linking.
