JclDebugでスタックトレースを取得する/Get stack trace descriptions from JclDebug

DumpExceptionStack.pas

unit DumpExceptionStack;

interface

uses
  Winapi.Windows,
  System.SysUtils,
  JclBase, JclDebug;

function GetExceptionDescription(E: Exception): String;
function DumpLastExceptStackInfoList(const Separator: String = '|'): String;


implementation

function GetStackInfoDescription(const Addr: Pointer): String;
var
  Info: TJclLocationInfo;
  StartProcInfo: TJclLocationInfo;
  OffsetStr: String;
  StartProcOffsetStr: String;
  FixedProcedureName: String;
  UnitNameWithoutUnitscope: String;
begin

  OffsetStr := '';

  if GetLocationInfo(Addr, Info) = True then
  begin
    with Info do
    begin
      FixedProcedureName := ProcedureName;
      if Pos(UnitName + '.', FixedProcedureName) = 1 then
      begin
        FixedProcedureName := Copy(FixedProcedureName,
                                   Length(UnitName) + 2,
                                   Length(FixedProcedureName) - Length(UnitName) - 1);
      end
      else if Pos('.', UnitName) > 1 then
      begin
        UnitNameWithoutUnitscope := UnitName;
        Delete(UnitNameWithoutUnitscope, 1, Pos('.', UnitNameWithoutUnitscope));
        if Pos(UnitNameWithoutUnitscope + '.', FixedProcedureName) = 1 then
        begin
          FixedProcedureName := Copy(FixedProcedureName, Length(UnitNameWithoutUnitscope) + 2, Length(FixedProcedureName) - Length(UnitNameWithoutUnitscope) - 1);
        end;
      end;

      if LineNumber > 0 then
      begin
        if (GetLocationInfo(Pointer(TJclAddr(Info.Address) - Cardinal(Info.OffsetFromProcName)), StartProcInfo) = True) and
           (StartProcInfo.LineNumber > 0) then
        begin
          StartProcOffsetStr := Format(' + %d', [LineNumber - StartProcInfo.LineNumber]);
        end
        else
        begin
          StartProcOffsetStr := '';
        end;

        if OffsetFromLineNumber >= 0 then
        begin
          OffsetStr := Format(' +0x%x', [OffsetFromLineNumber]);
        end
        else
        begin
          OffsetStr := Format(' -0x%x', [-OffsetFromLineNumber]);
        end;

        Result := Format('[0x%p] %s.%s (Line %u, "%s"%s)%s',
                         [Addr, UnitName, FixedProcedureName, LineNumber, SourceName, StartProcOffsetStr, OffsetStr]);
      end
      else
      begin
        OffsetStr := Format(' +0x%x', [OffsetFromProcName]);
        if UnitName <> '' then
        begin
          Result := Format('[0x%p] %s.%s%s', [Addr, UnitName, FixedProcedureName, OffsetStr]);
        end
        else
        begin
          Result := Format('[0x%p] %s%s', [Addr, FixedProcedureName, OffsetStr]);
        end;
      end;
    end;
  end
  else
  begin
    Result := Format('[0x%p]', [Addr]);
  end;

end;

function GetExceptionDescription(E: Exception): String;
const
  CThreadType: array [Boolean] of String = ('Sub thread','Main thread');
var
  ThreadId: TThreadID;
begin

  ThreadId := GetCurrentThreadId;
  Result := Format('%s (%d) %s (%s)',[CThreadType[ThreadId = MainThreadID],ThreadId,E.ClassName,E.Message]);

end;

function DumpLastExceptStackInfoList(const Separator: String = '|'): String;
var
  I: Integer;
begin

  Result := '';

  with JclLastExceptStackList do
  begin
    ForceStackTracing;
    for I := 0 to Count - 1 do
    begin
      Result := Result + GetStackInfoDescription(Items[I].CallerAddr) + Separator;
    end;
  end;

  if Result <> '' then
  begin
    Delete(Result,Length(Result) - Length(Separator) + 1,Length(Separator));
  end;

end;

initialization
//  Include(JclStackTrackingOptions, stRawMode);
  Include(JclStackTrackingOptions, stStaticModuleList);
  JclStartExceptionTracking;

finalization
  JclStopExceptionTracking;

end.