pltis_lazarus-exception-logger/UStackTrace.pas at master · tranquilit/pltis_lazarus-exception-logger · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
unit UStackTrace;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Contnrs, CustomLineInfo;

type
  TStackFrameInfo = class
    Index: Integer;
    LineNumber: Integer;
    Address: Integer;
    FunctionClassName: string;
    FunctionName: string;
    Source: string;
    procedure GetFrameInfo(Addr: Pointer);
  end;

  { TStackTrace }

  TStackTrace = class(TObjectList)
    Frames: array of Pointer;
    MaxDepth: Integer;
    procedure GetExceptionBackTrace;
    procedure GetCallStack(BP: Pointer);
    procedure GetCurrentCallStack;
    procedure GetInfo;
    constructor Create;
  end;


implementation

procedure TStackFrameInfo.GetFrameInfo(Addr: Pointer);
var
  Func: shortstring;
  SourceStr: shortstring;
  Line: LongInt;
  Store: TBackTraceStrFunc;
  Success: Boolean;
begin
  // Reset to prevent infinite recursion if problems inside the code PM
  Store := BackTraceStrFunc;
  BackTraceStrFunc := @SysBackTraceStr;
  Line := 0;
  SourceStr := EmptyStr;
  Func := EmptyStr;
  Success := GetLineInfo(ptruint(Addr), Func, SourceStr, Line);
  Address := Integer(Addr);
  FunctionName := Func;
  if Pos('__', FunctionName) > 0 then begin
    FunctionClassName := Copy(FunctionName, 1, Pos('__', FunctionName) - 1);
    Delete(FunctionName, 1, Length(FunctionClassName) + 2);
  end else FunctionClassName := '';
  LineNumber := Line;
  Source := SourceStr;
  BackTraceStrFunc := Store;
end;

procedure TStackTrace.GetCallStack(BP: Pointer);
var
  I: Longint;
  prevbp: Pointer;
  CallerFrame: Pointer;
  CallerAddress: Pointer;
  StackFrameInfo: TStackFrameInfo;
begin
  Clear;
  try
    I := 0;
    SetLength(Frames, 0);
    while (BP <> nil) and (I < MaxDepth) do begin
      SetLength(Frames, Length(Frames) + 1);
      Frames[I] := TStackFrameInfo(get_caller_addr(BP));
      Inc(I);
      BP := TStackFrameInfo(get_caller_frame(BP));
    end;
  except
    { prevent endless dump if an exception occured }
  end;
end;

constructor TStackTrace.Create;
begin
  inherited;
  MaxDepth := 20;
end;

procedure TStackTrace.GetExceptionBackTrace;
var
  FrameCount: Integer;
  FramesList: PPointer;
  FrameNumber: Integer;
begin
  SetLength(Frames, 1);
  Frames[0] := ExceptAddr;
  FrameCount := ExceptFrameCount;
  FramesList := ExceptFrames;
  if FrameCount > MaxDepth then FrameCount := MaxDepth;
  SetLength(Frames, FrameCount + 1);
  for FrameNumber := 0 to FrameCount - 1 do begin
    Frames[FrameNumber + 1] := FramesList[FrameNumber]
  end;
end;

procedure TStackTrace.GetCurrentCallStack;
begin
  GetCallStack(get_frame);
end;

procedure TStackTrace.GetInfo;
var
  I: Integer;
  StackFrameInfo: TStackFrameInfo;
begin
  Clear;
  for I := 0 to High(Frames) do begin
    StackFrameInfo := TStackFrameInfo.Create;
    StackFrameInfo.GetFrameInfo(Frames[I]);
    StackFrameInfo.Index := I + 1;
    Add(StackFrameInfo);
  end;
end;

end.