1 | unit UExceptionLogger;
|
---|
2 |
|
---|
3 | {$H+}
|
---|
4 |
|
---|
5 | interface
|
---|
6 |
|
---|
7 | uses
|
---|
8 | {$ifdef windows}Windows,{$endif}
|
---|
9 | Classes, SysUtils, UStackTrace, CustomLineInfo, Forms;
|
---|
10 |
|
---|
11 | type
|
---|
12 | TThreadSynchronizeEvent = procedure (AObject: TObject; Method: TThreadMethod) of object;
|
---|
13 |
|
---|
14 | { TExceptionLogger }
|
---|
15 |
|
---|
16 | TExceptionLogger = class(TComponent)
|
---|
17 | private
|
---|
18 | FMaxCallStackDepth: Integer;
|
---|
19 | FLogFileName: string;
|
---|
20 | FOnThreadSynchronize: TThreadSynchronizeEvent;
|
---|
21 | procedure ThreadSynchronize(AObject: TObject; Method: TThreadMethod);
|
---|
22 | function GetAppVersion: string;
|
---|
23 | procedure SetMaxCallStackDepth(const AValue: Integer);
|
---|
24 | procedure MakeReport;
|
---|
25 | procedure ShowForm;
|
---|
26 | public
|
---|
27 | StackTrace: TStackTrace;
|
---|
28 | LastException: Exception;
|
---|
29 | ExceptionSender: TObject;
|
---|
30 | IgnoreList: TStringList;
|
---|
31 | procedure LoadDetails;
|
---|
32 | constructor Create(AOwner: TComponent); override;
|
---|
33 | destructor Destroy; override;
|
---|
34 | procedure ExceptionHandler(Sender: TObject; E: Exception);
|
---|
35 | procedure CreateTextReport(Output: TStringList);
|
---|
36 | procedure LogToFile(Report: TStringList);
|
---|
37 | procedure LogStackTraceToFile(StackTrace: TStackTrace);
|
---|
38 | procedure ShowReportForm;
|
---|
39 | published
|
---|
40 | property LogFileName: string read FLogFileName write FLogFileName;
|
---|
41 | property MaxCallStackDepth: Integer read FMaxCallStackDepth write SetMaxCallStackDepth;
|
---|
42 | property OnThreadSynchronize: TThreadSynchronizeEvent read FOnThreadSynchronize
|
---|
43 | write FOnThreadSynchronize;
|
---|
44 | end;
|
---|
45 |
|
---|
46 | procedure Register;
|
---|
47 |
|
---|
48 | resourcestring
|
---|
49 | SExceptionClass = 'Class';
|
---|
50 | SMessage = 'Message';
|
---|
51 | SApplication = 'Application';
|
---|
52 | STime = 'Time';
|
---|
53 | SProcessID = 'Process ID';
|
---|
54 | SThreadID = 'Thread ID';
|
---|
55 | SVersion = 'Version';
|
---|
56 | SCallStack = 'Call stack';
|
---|
57 | SGeneral = 'General';
|
---|
58 | SErrorOccured = 'Error occured during program execution:';
|
---|
59 | STerminate = 'Exit program';
|
---|
60 | SClose = 'Continue';
|
---|
61 | SDetails = 'Details';
|
---|
62 | SIgnoreNextTime = 'Next time ignore this exception';
|
---|
63 | SExceptionInfo = 'Exception info';
|
---|
64 | SIndex = 'Index';
|
---|
65 | SAddress = 'Address';
|
---|
66 | SLine = 'Line';
|
---|
67 | SClass = 'Class';
|
---|
68 | SProcedureMethod = 'Procedure/method';
|
---|
69 | SUnit = 'Unit';
|
---|
70 | SExceptionHandlerCannotBeSynchronized = 'Exception handler cannot be synchronized with main thread.';
|
---|
71 |
|
---|
72 | implementation
|
---|
73 |
|
---|
74 | uses
|
---|
75 | UExceptionForm;
|
---|
76 |
|
---|
77 | procedure Register;
|
---|
78 | begin
|
---|
79 | RegisterComponents('Samples', [TExceptionLogger]);
|
---|
80 | end;
|
---|
81 |
|
---|
82 | { TExceptionLogger }
|
---|
83 |
|
---|
84 | constructor TExceptionLogger.Create(AOwner: TComponent);
|
---|
85 | begin
|
---|
86 | inherited Create(AOwner);
|
---|
87 | IgnoreList := TStringList.Create;
|
---|
88 | StackTrace := TStackTrace.Create;
|
---|
89 | MaxCallStackDepth := 20;
|
---|
90 | Application.OnException := ExceptionHandler;
|
---|
91 | Application.Flags := Application.Flags - [AppNoExceptionMessages];
|
---|
92 | OnThreadSynchronize := ThreadSynchronize;
|
---|
93 | end;
|
---|
94 |
|
---|
95 | destructor TExceptionLogger.Destroy;
|
---|
96 | begin
|
---|
97 | StackTrace.Free;
|
---|
98 | IgnoreList.Free;
|
---|
99 | inherited Destroy;
|
---|
100 | end;
|
---|
101 |
|
---|
102 | procedure TExceptionLogger.CreateTextReport(Output: TStringList);
|
---|
103 | begin
|
---|
104 | with Output do begin
|
---|
105 | Clear;
|
---|
106 | Add(SExceptionClass + ': ' + LastException.ClassName);
|
---|
107 | Add(SMessage + ': ' + LastException.Message);
|
---|
108 | Add(SApplication + ': ' + Application.Title);
|
---|
109 | Add(SVersion + ': ' + GetAppVersion);
|
---|
110 | Add(STime + ': ' + DateTimeToStr(Now));
|
---|
111 | Add(SProcessID + ': ' + IntToStr(GetProcessID));
|
---|
112 | Add(SThreadID + ': ' + IntToStr(GetThreadID));
|
---|
113 | end;
|
---|
114 | end;
|
---|
115 |
|
---|
116 | procedure TExceptionLogger.LogToFile(Report: TStringList);
|
---|
117 | var
|
---|
118 | LogFile: TFileStream;
|
---|
119 | Buffer: string;
|
---|
120 | begin
|
---|
121 | Buffer := Report.Text;
|
---|
122 | if FileExists(FLogFileName) then
|
---|
123 | LogFile := TFileStream.Create(UTF8Decode(FLogFileName), fmOpenReadWrite)
|
---|
124 | else LogFile := TFileStream.Create(UTF8Decode(FLogFileName), fmCreate);
|
---|
125 | with LogFile do try
|
---|
126 | Seek(0, soFromEnd);
|
---|
127 | if Length(Buffer) > 0 then
|
---|
128 | Write(Buffer[1], Length(Buffer));
|
---|
129 | finally
|
---|
130 | LogFile.Free;
|
---|
131 | end;
|
---|
132 | end;
|
---|
133 |
|
---|
134 | procedure TExceptionLogger.LogStackTraceToFile(StackTrace: TStackTrace);
|
---|
135 | var
|
---|
136 | I: Integer;
|
---|
137 | LogFile: TFileStream;
|
---|
138 | Line: string;
|
---|
139 | begin
|
---|
140 | if FileExists(FLogFileName) then
|
---|
141 | LogFile := TFileStream.Create(UTF8Decode(FLogFileName), fmOpenReadWrite)
|
---|
142 | else LogFile := TFileStream.Create(UTF8Decode(FLogFileName), fmCreate);
|
---|
143 | with LogFile do try
|
---|
144 | Seek(0, soFromEnd);
|
---|
145 | for I := 0 to StackTrace.Count - 1 do
|
---|
146 | with TStackFrameInfo(StackTrace[I]) do begin
|
---|
147 | Line := IntToStr(Index) + ': ' + IntToHex(Address, 8) + ' in ' + FunctionName + ' ' +
|
---|
148 | Source + '(' + IntToStr(LineNumber) + ')' + LineEnding;
|
---|
149 | if Length(Line) > 0 then
|
---|
150 | Write(Line[1], Length(Line));
|
---|
151 | end;
|
---|
152 | Line := LineEnding;
|
---|
153 | Write(Line[1], Length(Line));
|
---|
154 | finally
|
---|
155 | LogFile.Free;
|
---|
156 | end;
|
---|
157 | end;
|
---|
158 |
|
---|
159 | procedure TExceptionLogger.ShowReportForm;
|
---|
160 | begin
|
---|
161 | ExceptionForm.LoadStackTraceToListView(StackTrace);
|
---|
162 | if not ExceptionForm.Visible then ExceptionForm.ShowModal;
|
---|
163 | end;
|
---|
164 |
|
---|
165 | procedure TExceptionLogger.ExceptionHandler(Sender: TObject; E: Exception);
|
---|
166 | begin
|
---|
167 | BackTraceStrFunc := @StabBackTraceStr;
|
---|
168 | StackTrace.GetExceptionBackTrace;
|
---|
169 | LastException := E;
|
---|
170 | ExceptionSender := Sender;
|
---|
171 | if (MainThreadID <> ThreadID) then begin
|
---|
172 | if Assigned(FOnThreadSynchronize) then
|
---|
173 | FOnThreadSynchronize(Sender, ShowForm)
|
---|
174 | else raise Exception.Create(SExceptionHandlerCannotBeSynchronized);
|
---|
175 | end else ShowForm;
|
---|
176 | end;
|
---|
177 |
|
---|
178 | procedure TExceptionLogger.MakeReport;
|
---|
179 | var
|
---|
180 | Report: TStringList;
|
---|
181 | begin
|
---|
182 | StackTrace.GetInfo;
|
---|
183 | if IgnoreList.IndexOf(LastException.ClassName) = -1 then begin
|
---|
184 | Report := TStringList.Create;
|
---|
185 | try
|
---|
186 | CreateTextReport(Report);
|
---|
187 | if FLogFileName <> '' then begin
|
---|
188 | LogToFile(Report);
|
---|
189 | LogStackTraceToFile(StackTrace);
|
---|
190 | end;
|
---|
191 | ExceptionForm.MemoExceptionInfo.Lines.Assign(Report);
|
---|
192 | ShowReportForm;
|
---|
193 | finally
|
---|
194 | Report.Free;
|
---|
195 | end;
|
---|
196 | if ExceptionForm.CheckBoxIgnore.Checked then
|
---|
197 | IgnoreList.Add(LastException.ClassName);
|
---|
198 | end;
|
---|
199 | end;
|
---|
200 |
|
---|
201 | procedure TExceptionLogger.ShowForm;
|
---|
202 | begin
|
---|
203 | ExceptionForm.Logger := Self;
|
---|
204 | ExceptionForm.LabelMessage.Caption := LastException.Message;
|
---|
205 | ExceptionForm.MemoExceptionInfo.Clear;
|
---|
206 | if not ExceptionForm.Visible then ExceptionForm.ShowModal;
|
---|
207 | end;
|
---|
208 |
|
---|
209 | procedure TExceptionLogger.LoadDetails;
|
---|
210 | begin
|
---|
211 | if ExceptionSender is TThread then
|
---|
212 | TThread.Synchronize(TThread(ExceptionSender), MakeReport)
|
---|
213 | else MakeReport;
|
---|
214 | end;
|
---|
215 |
|
---|
216 | procedure TExceptionLogger.SetMaxCallStackDepth(const AValue: Integer);
|
---|
217 | begin
|
---|
218 | FMaxCallStackDepth := AValue;
|
---|
219 | StackTrace.MaxDepth := AValue;
|
---|
220 | end;
|
---|
221 |
|
---|
222 | procedure TExceptionLogger.ThreadSynchronize(AObject: TObject;
|
---|
223 | Method: TThreadMethod);
|
---|
224 | begin
|
---|
225 | if AObject is TThread then TThread.Synchronize(TThread(AObject), Method)
|
---|
226 | else raise Exception.Create(SExceptionHandlerCannotBeSynchronized);
|
---|
227 | end;
|
---|
228 |
|
---|
229 | function TExceptionLogger.GetAppVersion: string;
|
---|
230 | var
|
---|
231 | Size, Size2: DWord;
|
---|
232 | Pt, Pt2: Pointer;
|
---|
233 | begin
|
---|
234 | {$ifdef windows}
|
---|
235 | Size := GetFileVersionInfoSize(PChar(ParamStr(0)), Size2);
|
---|
236 | if Size > 0 then
|
---|
237 | begin
|
---|
238 | GetMem(Pt, Size);
|
---|
239 | try
|
---|
240 | GetFileVersionInfo(PChar (ParamStr(0)), 0, Size, Pt);
|
---|
241 | VerQueryValue(Pt, '\', Pt2, Size2);
|
---|
242 | with TVSFixedFileInfo(Pt2^) do
|
---|
243 | begin
|
---|
244 | Result := IntToStr(HiWord(dwFileVersionMS)) + '.' +
|
---|
245 | IntToStr(LoWord(dwFileVersionMS)) + '.' +
|
---|
246 | IntToStr(HiWord(dwFileVersionLS)) + '.' +
|
---|
247 | IntToStr(LoWord(dwFileVersionLS));
|
---|
248 | end;
|
---|
249 | finally
|
---|
250 | FreeMem(Pt);
|
---|
251 | end;
|
---|
252 | end;
|
---|
253 | {$else}
|
---|
254 | Result := '';
|
---|
255 | {$endif}
|
---|
256 | end;
|
---|
257 |
|
---|
258 | end.
|
---|
259 |
|
---|