1 | unit UStackTrace;
|
---|
2 |
|
---|
3 | {$mode objfpc}{$H+}
|
---|
4 |
|
---|
5 | interface
|
---|
6 |
|
---|
7 | uses
|
---|
8 | Classes, SysUtils, Contnrs, CustomLineInfo;
|
---|
9 |
|
---|
10 | type
|
---|
11 | TStackFrameInfo = class
|
---|
12 | Index: Integer;
|
---|
13 | LineNumber: Integer;
|
---|
14 | Address: Integer;
|
---|
15 | FunctionClassName: string;
|
---|
16 | FunctionName: string;
|
---|
17 | Source: string;
|
---|
18 | procedure GetFrameInfo(Addr: Pointer);
|
---|
19 | end;
|
---|
20 |
|
---|
21 | { TStackTrace }
|
---|
22 |
|
---|
23 | TStackTrace = class(TObjectList)
|
---|
24 | Frames: array of Pointer;
|
---|
25 | MaxDepth: Integer;
|
---|
26 | procedure GetExceptionBackTrace;
|
---|
27 | procedure GetCallStack(BP: Pointer);
|
---|
28 | procedure GetCurrentCallStack;
|
---|
29 | procedure GetInfo;
|
---|
30 | constructor Create;
|
---|
31 | end;
|
---|
32 |
|
---|
33 |
|
---|
34 | implementation
|
---|
35 |
|
---|
36 | procedure TStackFrameInfo.GetFrameInfo(Addr: Pointer);
|
---|
37 | var
|
---|
38 | Func: shortstring;
|
---|
39 | SourceStr: shortstring;
|
---|
40 | Line: LongInt;
|
---|
41 | Store: TBackTraceStrFunc;
|
---|
42 | Success: Boolean;
|
---|
43 | begin
|
---|
44 | // Reset to prevent infinite recursion if problems inside the code PM
|
---|
45 | Store := BackTraceStrFunc;
|
---|
46 | BackTraceStrFunc := @SysBackTraceStr;
|
---|
47 | Success := GetLineInfo(ptruint(Addr), Func, SourceStr, Line);
|
---|
48 | Address := Integer(Addr);
|
---|
49 | FunctionName := Func;
|
---|
50 | if Pos('__', FunctionName) > 0 then begin
|
---|
51 | FunctionClassName := Copy(FunctionName, 1, Pos('__', FunctionName) - 1);
|
---|
52 | Delete(FunctionName, 1, Length(FunctionClassName) + 2);
|
---|
53 | end else FunctionClassName := '';
|
---|
54 | LineNumber := Line;
|
---|
55 | Source := SourceStr;
|
---|
56 | BackTraceStrFunc := Store;
|
---|
57 | end;
|
---|
58 |
|
---|
59 | procedure TStackTrace.GetCallStack(BP: Pointer);
|
---|
60 | var
|
---|
61 | I: Longint;
|
---|
62 | prevbp: Pointer;
|
---|
63 | CallerFrame: Pointer;
|
---|
64 | CallerAddress: Pointer;
|
---|
65 | StackFrameInfo: TStackFrameInfo;
|
---|
66 | begin
|
---|
67 | Clear;
|
---|
68 | try
|
---|
69 | I := 0;
|
---|
70 | SetLength(Frames, 0);
|
---|
71 | while (BP <> nil) and (I < MaxDepth) do begin
|
---|
72 | SetLength(Frames, Length(Frames) + 1);
|
---|
73 | Frames[I] := TStackFrameInfo(get_caller_addr(BP));
|
---|
74 | Inc(I);
|
---|
75 | BP := TStackFrameInfo(get_caller_frame(BP));
|
---|
76 | end;
|
---|
77 | except
|
---|
78 | { prevent endless dump if an exception occured }
|
---|
79 | end;
|
---|
80 | end;
|
---|
81 |
|
---|
82 | constructor TStackTrace.Create;
|
---|
83 | begin
|
---|
84 | inherited;
|
---|
85 | MaxDepth := 20;
|
---|
86 | end;
|
---|
87 |
|
---|
88 | procedure TStackTrace.GetExceptionBackTrace;
|
---|
89 | var
|
---|
90 | FrameCount: Integer;
|
---|
91 | FramesList: PPointer;
|
---|
92 | FrameNumber: Integer;
|
---|
93 | begin
|
---|
94 | SetLength(Frames, 1);
|
---|
95 | Frames[0] := ExceptAddr;
|
---|
96 | FrameCount := ExceptFrameCount;
|
---|
97 | FramesList := ExceptFrames;
|
---|
98 | if FrameCount > MaxDepth then FrameCount := MaxDepth;
|
---|
99 | SetLength(Frames, FrameCount + 1);
|
---|
100 | for FrameNumber := 0 to FrameCount - 1 do begin
|
---|
101 | Frames[FrameNumber + 1] := FramesList[FrameNumber]
|
---|
102 | end;
|
---|
103 | end;
|
---|
104 |
|
---|
105 | procedure TStackTrace.GetCurrentCallStack;
|
---|
106 | begin
|
---|
107 | GetCallStack(get_frame);
|
---|
108 | end;
|
---|
109 |
|
---|
110 | procedure TStackTrace.GetInfo;
|
---|
111 | var
|
---|
112 | I: Integer;
|
---|
113 | StackFrameInfo: TStackFrameInfo;
|
---|
114 | begin
|
---|
115 | Clear;
|
---|
116 | for I := 0 to High(Frames) do begin
|
---|
117 | StackFrameInfo := TStackFrameInfo.Create;
|
---|
118 | StackFrameInfo.GetFrameInfo(Frames[I]);
|
---|
119 | StackFrameInfo.Index := I + 1;
|
---|
120 | Add(StackFrameInfo);
|
---|
121 | end;
|
---|
122 | end;
|
---|
123 |
|
---|
124 | end.
|
---|
125 |
|
---|