1 unit HeapTrcView;
2
3 {$mode objfpc}{$H+}
4
5 interface
6
7 uses
8 Classes, SysUtils, XMLConf, DOM, contnrs, Clipbrd, LCLProc, LCLType,
9 LResources, Forms, Controls, Graphics, Dialogs, StdCtrls, ComCtrls, ExtCtrls,
10 // LazUtils
11 FileUtil, LazFileUtils,
12 // IDEIntf
13 LazIDEIntf, MenuIntf, ToolBarIntf, IDECommands,
14 // LeakView
15 LeakInfo;
16
17 type
18 TJumpProc = procedure (Sender: TObject; const SourceName: string;
19 Line, Column: integer) of object;
20
21 { THeapTrcViewForm }
22
23 THeapTrcViewForm = class(TForm)
24 btnUpdate: TButton;
25 btnBrowse: TButton;
26 btnClipboard: TButton;
27 BtnResolve: TButton;
28 chkUseRaw: TCheckBox;
29 chkStayOnTop: TCheckBox;
30 edtTrcFileName:TComboBox;
31 lblTrcFile: TLabel;
32 ctrlPanel: TPanel;
33 memoSummary: TMemo;
34 OpenDialog: TOpenDialog;
35 splitter: TSplitter;
36 trvTraceInfo: TTreeView;
37 procedure btnClipboardClick(Sender: TObject);
38 procedure BtnResolveClick(Sender: TObject);
39 procedure btnUpdateClick(Sender: TObject);
40 procedure btnBrowseClick(Sender: TObject);
41 procedure chkStayOnTopChange(Sender: TObject);
42 procedure chkUseRawChange(Sender: TObject);
43 procedure FormCreate(Sender: TObject);
44 procedure FormDestroy(Sender: TObject);
45 procedure trvTraceInfoDblClick(Sender: TObject);
46 private
47 Finfo : TLeakInfo;
48 fItems : TStackTraceList;
49
50 procedure DoUpdateLeaks(FromClip: Boolean = False);
51
52 procedure ItemsToTree;
53 procedure ChangeTreeText;
54
55 procedure ClearItems;
56 procedure DoJump;
57
GetStackTraceTextnull58 function GetStackTraceText(trace: TStackTrace; useRaw: Boolean): string;
GetStackLineTextnull59 function GetStackLineText(const Line: TStackLine; useRaw: Boolean): string;
60
61 procedure SaveState(cfg: TXMLConfig);
62 procedure LoadState(cfg: TXMLConfig);
63
64 procedure AddFileToList(const FileName: AnsiString);
65 protected
66 procedure LazarusJump(Sender: TObject; const SourceFile: string;
67 Line, Column: Integer);
68 public
69 destructor Destroy; override;
70 public
71 OnJumpProc : TJumpProc; //= procedure (Sender: TObject; const SourceName: string; Line: integer) of object;
72 end;
73
74 resourcestring
75 StackTraceFormat = 'Leak: %d bytes x %d times'; // number of bytes leaked, leaks count
76 StackTraceFormatSingle = 'Leak: %d bytes'; // number of bytes leaked
77 StackLineFormatWithFile = '%s file: %s : %d; '; // stack addr, filename (no path), line number
78 StackLineFormat = '%s'; // stack addr
79
80 strTotalMemAlloc = 'Total Mem allocated: %d';
81 strLeakingMemSize = 'Leaking Mem Size: %d';
82 strLeakingBlocksCount = 'Leaking Blocks Count: %d';
83 //
84 rsErrorParse = 'Error while parsing trace file';
85 rsDTimes = ' (%d times)';
86 rsLeakView = 'Leaks and Traces';
87 //
88 slblTrace = '.trc file';
89 sbtnUpdate = 'Update';
90 sbtnClipBrd = 'Paste Clipboard';
91 sbtnResolve = 'Resolve';
92 schkRaw = 'Raw leak data';
93 schkTop = 'Stay on top';
94 sfrmCap = 'Leaks and Traces - HeapTrc and GDB backtrace output viewer';
95 sfrmSelectFileWithDebugInfo = 'Select file with debug info';
96 sfrmSelectTrcFile = 'Select file with trace log';
97
98 var
99 HeapTrcViewForm: THeapTrcViewForm = nil;
100
101 // JumpProc is the callback that is called everytime user double clicks
102 // on the leak line. It's legal to pass nil, then LazarusIDE is used to peform a jump
103 procedure ShowHeapTrcViewForm(JumpProc: TJumpProc = nil);
104
105 procedure Register;
106
107 implementation
108
109 {$R *.lfm}
110
111 procedure ShowHeapTrcViewForm(JumpProc: TJumpProc);
112 begin
113 if not Assigned(HeapTrcViewForm) then
114 HeapTrcViewForm := THeapTrcViewForm.Create(Application);
115 if Assigned(JumpProc) then
116 HeapTrcViewForm.OnJumpProc := JumpProc
117 else
118 HeapTrcViewForm.OnJumpProc := @HeapTrcViewForm.LazarusJump;
119 HeapTrcViewForm.Show;
120 end;
121
122 { THeapTrcViewForm }
123
124 procedure THeapTrcViewForm.btnUpdateClick(Sender: TObject);
125 begin
126 DoUpdateLeaks;
127 AddFileToList(edtTrcFileName.Text);
128 end;
129
130 procedure THeapTrcViewForm.btnClipboardClick(Sender: TObject);
131 begin
132 DoUpdateLeaks(True);
133 end;
134
135 procedure THeapTrcViewForm.BtnResolveClick(Sender: TObject);
136 begin
137 if Finfo = nil then exit;
138
139 OpenDialog.FileName := '';
140 OpenDialog.Filter := '';
141 OpenDialog.Title := sfrmSelectFileWithDebugInfo;
142 if not OpenDialog.Execute then Exit;
143
144 Finfo.ResolveLeakInfo(OpenDialog.FileName, fItems);
145 ChangeTreeText;
146 end;
147
148 procedure THeapTrcViewForm.btnBrowseClick(Sender: TObject);
149 begin
150 OpenDialog.FileName := '';
151 OpenDialog.Filter := slblTrace + '|*.trc';
152 OpenDialog.Title := sfrmSelectTrcFile;
153 if not OpenDialog.Execute then Exit;
154
155 edtTrcFileName.Text := OpenDialog.FileName;
156 DoUpdateLeaks;
157 AddFileToList(edtTrcFileName.Text);
158 end;
159
160 procedure THeapTrcViewForm.chkStayOnTopChange(Sender: TObject);
161 begin
162 if chkStayOnTop.Checked then Self.formStyle := fsStayOnTop
163 else Self.formStyle := fsNormal;
164 end;
165
166 procedure THeapTrcViewForm.chkUseRawChange(Sender: TObject);
167 begin
168 ChangeTreeText;
169 trvTraceInfo.Invalidate;
170 end;
171
172 var
173 ConfigFileName : AnsiString = '';
174 function CreateXMLConfig: TXMLConfig;
175 begin
176 Result:=TXMLConfig.Create(nil);
177 Result.RootName:='config';
178 if (ConfigFileName='') and Assigned(LazarusIDE) then
179 ConfigFileName:=AppendPathDelim(LazarusIDE.GetPrimaryConfigPath)+'leakview.xml';
180 Result.FileName:=ConfigFileName;
181 end;
182
183 procedure THeapTrcViewForm.FormCreate(Sender: TObject);
184 var
185 cfg : TXMLConfig;
186 begin
187 Caption:=sfrmCap;
188 lblTrcFile.Caption:=slblTrace;
189 btnUpdate.Caption:=sbtnUpdate;
190 btnClipboard.Caption:=sbtnClipBrd;
191 BtnResolve.Caption:=sbtnResolve;
192 chkUseRaw.Caption:=schkRaw;
193 chkStayOnTop.Caption:=schkTop;
194 fItems:=TStackTraceList.Create;
195 try
196 cfg:=CreateXMLConfig;
197 try
198 LoadState(cfg);
199 finally
200 cfg.Free;
201 end;
202 except
203 end;
204 end;
205
206 procedure THeapTrcViewForm.FormDestroy(Sender: TObject);
207 var
208 cfg : TXMLConfig;
209 begin
210 ClearItems;
211 fItems.Free;
212 try
213 cfg:=CreateXMLConfig;
214 try
215 SaveState(cfg);
216 finally
217 cfg.Free;
218 end;
219 except
220 end;
221 HeapTrcViewForm:=nil;
222 end;
223
224 procedure THeapTrcViewForm.trvTraceInfoDblClick(Sender: TObject);
225 begin
226 DoJump;
227 end;
228
229 //note: to range check performed
230 procedure HexInt64ToStr(i64: Int64; var s: string; ofs: Integer);
231 var
232 i : Integer;
233 j : Integer;
234 const
235 Hexes: array [0..$F] of char = ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
236 begin
237 j := ofs + 15;
238 for i := 0 to 7 do begin
239 s[j] := Hexes[ i64 and $F ]; dec(j);
240 s[j] := Hexes[ ((i64 and $F0) shr 4) and $F ]; dec(j);
241 i64 := i64 shr 8;
242 end;
243 end;
244
245 function GetHashString(trace: TStackTrace): string;
246 var
247 i : integer;
248 sz : Integer;
249 begin
250 sz := 32 + trace.Count * 16; // 8 hex digits for Size + 8 hex digits for Size
251 SetLength(Result, sz);
252 HexInt64ToStr(trace.BlockSize, Result, 1);
253 HexInt64ToStr(hash(trace.RawStackData), Result, 17);
254 for i := 0 to trace.Count - 1 do
255 if trace.lines[i].Addr <> 0
256 then HexInt64ToStr(trace.lines[i].Addr, Result, 33 + i * 16)
257 else HexInt64ToStr(Hash(trace.lines[i].RawLineData), Result, 17 + i * 16);
258 end;
259
260 procedure THeapTrcViewForm.ItemsToTree;
261 var
262 i : Integer;
263 j : Integer;
264 trace : TStackTrace;
265 nd : TTreeNode;
266 hash : TFPObjectHashTable;
267 hashed : TStackTrace;
268 s : string;
269 begin
270 hash := TFPObjectHashTable.Create(false);
271 try
272 // removing duplicates
273 for i := 0 to fItems.Count - 1 do begin
274 trace := TStackTrace(fItems[i]);
275 if trace = nil then
276 continue;
277 s := GetHashString(trace);
278 hashed := TStackTrace(hash.Items[s]);
279 if Assigned(hashed) then begin
280 inc(hashed.LeakCount);
281 fItems[i] := nil; // this call destroy on the old trace object
282 end else
283 hash.Add(s, trace)
284 end;
285 fItems.Pack;
286
287 // filling the tree
288 for i := 0 to fItems.Count - 1 do begin
289 trace := TStackTrace(fItems[i]);
290 nd := trvTraceInfo.Items.AddChildObject(nil, '+', trace);
291 for j := 0 to trace.Count - 1 do begin
292 trvTraceInfo.Items.AddChildObject(nd, '-', {%H-}Pointer(PtrInt(j)));
293 end;
294 end;
295
296 // updating tree text
297 ChangeTreeText;
298
299 finally
300 hash.free;
301 end;
302 end;
303
304 procedure THeapTrcViewForm.ClearItems;
305 var
306 i : integer;
307 begin
308 fItems.Clear;
309 end;
310
311 procedure THeapTrcViewForm.DoUpdateLeaks(FromClip: Boolean = False);
312 var
313 data : TLeakStatus;
314 txt: String;
315 begin
316 FreeAndNil(Finfo);
317 trvTraceInfo.BeginUpdate;
318 try
319 ClearItems;
320 trvTraceInfo.Items.Clear;
321 if FromClip then begin
322 txt := Clipboard.AsText;
323 if txt = '' then exit;
324 Finfo := AllocHeapTraceInfoFromText(txt);
325 end else begin
326 if (not FileExistsUTF8(edtTrcFileName.Text)) or FromClip then Exit;
327 Finfo := AllocHeapTraceInfo(edtTrcFileName.Text);
328 end;
329
330 if Finfo.GetLeakInfo(data, fItems) then ItemsToTree
331 else trvTraceInfo.Items.Add(nil, rsErrorParse);
332
333 memoSummary.Clear;
334 with memoSummary.Lines do begin
335 Add( Format(strTotalMemAlloc, [data.TotalMem]));
336 Add( Format(strLeakingMemSize, [data.LeakedMem]));
337 Add( Format(strLeakingBlocksCount, [data.LeakCount]));
338 end;
339
340 finally
341 trvTraceInfo.EndUpdate;
342 end;
343 if trvTraceInfo.Items.TopLvlCount = 1 then
344 trvTraceInfo.Items.TopLvlItems[0].Expand(False);
345 end;
346
347 procedure THeapTrcViewForm.DoJump;
348 var
349 nd : TTreeNode;
350 searchFile : string;
351 idx : Integer;
352 trace : TStackTrace;
353 StackLine: TStackLine;
354 begin
355 if not Assigned(@OnJumpProc) then Exit;
356 nd := trvTraceInfo.Selected;
357
358 if not Assigned(nd) then Exit;
359 if nd.Parent = nil then Exit;
360
361 idx := Integer({%H-}PtrInt(nd.Data));
362 trace := TStackTrace(nd.Parent.Data);
363 if not Assigned(trace) or (idx >= trace.Count) then Exit;
364
365 searchFile := trace.Lines[idx].FileName;
366 if searchFile = '' then Exit;
367
368 StackLine:= trace.Lines[idx];
369 OnJumpProc(Self, searchFile, StackLine.LineNum, StackLine.Column);
370 end;
371
372 procedure THeapTrcViewForm.ChangeTreeText;
373 var
374 i, j : Integer;
375 useRaw : Boolean;
376 nd : TTreeNode;
377 trace : TStackTrace;
378 begin
379 trvTraceInfo.Items.BeginUpdate;
380 try
381 useRaw := chkUseRaw.Checked;
382 for i := 0 to trvTraceInfo. Items.Count - 1 do begin
383 nd := TTreeNode(trvTraceInfo.Items[i]);
384 if Assigned(nd.Parent) or not Assigned(nd.Data) then Continue;
385 trace := TStackTrace(nd.Data);
386 nd.Text := GetStackTraceText(trace, useRaw);
387 for j := 0 to nd.Count - 1 do begin
388 nd.Items[j].Text := GetStackLineText( trace.Lines[j], useRaw );
389 end;
390 end;
391 finally
392 trvTraceInfo.Items.EndUpdate;
393 end;
394 end;
395
GetStackTraceTextnull396 function THeapTrcViewForm.GetStackTraceText(trace: TStackTrace; useRaw: boolean): string;
397 begin
398 if useRaw then begin
399 Result := trace.RawStackData;
400 if (Result <> '') and (trace.LeakCount > 1) then Result := Result + Format(
401 rsDTimes, [trace.LeakCount]);
402 end;
403
404 if not useRaw or (Result = '') then begin
405 if trace.LeakCount > 1
406 then Result := Format(StackTraceFormat, [trace.BlockSize, trace.LeakCount])
407 else Result := Format(StackTraceFormatSingle, [trace.BlockSize]);
408 end;
409
410 end;
411
GetStackLineTextnull412 function THeapTrcViewForm.GetStackLineText(const Line: TStackLine; useRaw: boolean): string;
413 begin
414 if useRaw then
415 Result := Line.RawLineData;
416
417 if (not useRaw) or (Result = '') or
418 ( (Pos(' ', Trim(Result)) < 1) and (Pos(':', Trim(Result)) < 1) and
419 ( (copy(Trim(Result),1,1) = '$') or (copy(Trim(Result),1,2) = '0x') )
420 ) // Rawdata may be address only
421 then
422 with Line do
423 if FileName <> ''
424 then Result := Format(StackLineFormatWithFile, ['$'+IntToHex(Addr, sizeof(Pointer)*2), ExtractFileName(FileName), LineNum])
425 else Result := Format(StackLineFormat, ['$'+IntToHex(Addr, sizeof(Pointer)*2)]);
426 end;
427
428 procedure THeapTrcViewForm.SaveState(cfg:TXMLConfig);
429 var
430 b : TRect;
431 i : Integer;
432 begin
433 cfg.SetValue('isStayOnTop',FormStyle=fsStayOnTop);
434 b:=BoundsRect;
435 cfg.OpenKey('bounds');
436 cfg.SetValue('left', b.Left);
437 cfg.SetValue('top', b.Top);
438 cfg.SetValue('right', b.Right);
439 cfg.SetValue('bottom', b.Bottom);
440 cfg.CloseKey;
441 for i:=0 to edtTrcFileName.Items.Count-1 do
442 cfg.SetValue(DOMString('path'+IntToStr(i)), UTF8Decode(edtTrcFileName.Items[i]) );
443 end;
444
445 function PointInRect(p: TPoint; const r: TRect): Boolean;
446 begin
447 Result:=(p.X>=r.Left) and (p.X<=r.Right) and (p.y>=r.Top) and (p.y<=r.Bottom);
448 end;
449
450 procedure inAnyMonitor(var b: TRect);
451 var
452 m: TMonitor;
453 mb: TRect;
454 const
455 MinOverLap = 40;
456 begin
457 m := Screen.MonitorFromRect(b); // Nearest Monitor
458 if assigned(m)
459 then mb := m.BoundsRect
460 else mb := Screen.WorkAreaRect;
461
462 // make sure top(window-bar) is visible
463 if b.Top < mb.Top then OffsetRect(b, 0, mb.Top-b.Top);
464 if b.Top + MinOverLap > mb.Bottom then OffsetRect(b, 0, mb.Top-b.Top-MinOverLap);
465 // move left/right
466 if b.Left + MinOverLap > mb.Right then OffsetRect(b, mb.Right-b.Left-MinOverLap, 0);
467 if b.Right - MinOverLap < mb.Left then OffsetRect(b, mb.Left-b.Right+MinOverLap, 0);
468 end;
469
470 procedure THeapTrcViewForm.LoadState(cfg:TXMLConfig);
471 var
472 b : TRect;
473 isTop : Boolean;
474 st : TStringList;
475 s : WideString;
476 i : Integer;
477 const
478 InitFormStyle: array [Boolean] of TFormStyle = (fsNormal, fsStayOnTop);
479 begin
480 isTop:=True;
481 b:=BoundsRect;
482 st:=TStringList.Create;
483 try
484 istop:=cfg.GetValue('isStayOnTop',isTop);
485 cfg.OpenKey('bounds');
486 b.Left:=cfg.GetValue('left', b.Left);
487 b.Top:=cfg.GetValue('top', b.Top);
488 b.Right:=cfg.GetValue('right', b.Right);
489 b.Bottom:=cfg.GetValue('bottom', b.Bottom);
490 cfg.CloseKey;
491
492 if b.Right-b.Left<=0 then b.Right:=b.Left+40;
493 if b.Bottom-b.Top<=0 then b.Bottom:=b.Top+40;
494
495 for i:=0 to 7 do begin
496 s:=cfg.GetValue(DOMString('path'+IntToStr(i)), '');
497 if s<>'' then st.Add(UTF8Encode(s));
498 end;
499
500 except
501 end;
502 inAnyMonitor(b);
503
504 FormStyle:=InitFormStyle[isTop];
505 BoundsRect:=b;
506 chkStayOnTop.Checked := isTop;
507 if st.Count>0 then begin
508 edtTrcFileName.Items.AddStrings(st);
509 edtTrcFileName.ItemIndex:=0;
510 end;
511
512 st.Free;
513 end;
514
515 procedure THeapTrcViewForm.AddFileToList(const FileName:AnsiString);
516 var
517 i : Integer;
518 begin
519 i:=edtTrcFileName.Items.IndexOf(FileName);
520 if (i<0) then begin
521 if edtTrcFileName.Items.Count=8 then
522 edtTrcFileName.Items.Delete(7);
523 end else
524 edtTrcFileName.Items.Delete(i);
525 edtTrcFileName.Items.Insert(0, FileName);
526 end;
527
528 procedure THeapTrcViewForm.LazarusJump(Sender: TObject;
529 const SourceFile: string; Line, Column: Integer);
530 var
531 nm : string;
532 begin
533 if not FileExistsUTF8(SourceFile) then begin
534 nm := LazarusIDE.FindSourceFile(SourceFile, '', [fsfUseIncludePaths] );
535 if nm = '' then
536 nm := SourceFile;
537 end else
538 nm := SourceFile;
539 LazarusIDE.DoOpenFileAndJumpToPos(nm, Point(Column, Line), -1, -1, -1, [ofOnlyIfExists, ofRegularFile]);
540 end;
541
542 destructor THeapTrcViewForm.Destroy;
543 begin
544 FreeAndNil(Finfo);
545 inherited Destroy;
546 end;
547
548 procedure IDEMenuClicked(Sender: TObject);
549 begin
550 ShowHeapTrcViewForm(nil);
551 end;
552
553 procedure Register;
554 var
555 IDEShortCutX: TIDEShortCut;
556 IDECommandCategory: TIDECommandCategory;
557 IDECommand: TIDECommand;
558 IDEButtonCommand: TIDEButtonCommand;
559 begin
560 RegisterIDEMenuCommand(itmViewMainWindows, 'mnuLeakView', rsLeakView, nil, @IDEMenuClicked);
561
562 IDEShortCutX := IDEShortCut(VK_UNKNOWN, [], VK_UNKNOWN, []);
563 IDECommandCategory := IDECommandList.FindCategoryByName(CommandCategoryViewName);
564 if IDECommandCategory <> nil then
565 begin
566 IDECommand := RegisterIDECommand(IDECommandCategory, 'Leaks and Traces', rsLeakView, IDEShortCutX, nil, @IDEMenuClicked);
567 if IDECommand <> nil then
568 begin
569 IDEButtonCommand := RegisterIDEButtonCommand(IDECommand);
570 if IDEButtonCommand=nil then ;
571 end;
572 end;
573 end;
574
575 end.
576
577