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 begin
306 fItems.Clear;
307 end;
308
309 procedure THeapTrcViewForm.DoUpdateLeaks(FromClip: Boolean = False);
310 var
311 data : TLeakStatus;
312 txt: String;
313 begin
314 FreeAndNil(Finfo);
315 trvTraceInfo.BeginUpdate;
316 try
317 ClearItems;
318 trvTraceInfo.Items.Clear;
319 if FromClip then begin
320 txt := Clipboard.AsText;
321 if txt = '' then exit;
322 Finfo := AllocHeapTraceInfoFromText(txt);
323 end else begin
324 if (not FileExistsUTF8(edtTrcFileName.Text)) or FromClip then Exit;
325 Finfo := AllocHeapTraceInfo(edtTrcFileName.Text);
326 end;
327
328 if Finfo.GetLeakInfo(data, fItems) then ItemsToTree
329 else trvTraceInfo.Items.Add(nil, rsErrorParse);
330
331 memoSummary.Clear;
332 with memoSummary.Lines do begin
333 Add( Format(strTotalMemAlloc, [data.TotalMem]));
334 Add( Format(strLeakingMemSize, [data.LeakedMem]));
335 Add( Format(strLeakingBlocksCount, [data.LeakCount]));
336 end;
337
338 finally
339 trvTraceInfo.EndUpdate;
340 end;
341 if trvTraceInfo.Items.TopLvlCount = 1 then
342 trvTraceInfo.Items.TopLvlItems[0].Expand(False);
343 end;
344
345 procedure THeapTrcViewForm.DoJump;
346 var
347 nd : TTreeNode;
348 searchFile : string;
349 idx : Integer;
350 trace : TStackTrace;
351 StackLine: TStackLine;
352 begin
353 if not Assigned(@OnJumpProc) then Exit;
354 nd := trvTraceInfo.Selected;
355
356 if not Assigned(nd) then Exit;
357 if nd.Parent = nil then Exit;
358
359 idx := Integer({%H-}PtrInt(nd.Data));
360 trace := TStackTrace(nd.Parent.Data);
361 if not Assigned(trace) or (idx >= trace.Count) then Exit;
362
363 searchFile := trace.Lines[idx].FileName;
364 if searchFile = '' then Exit;
365
366 StackLine:= trace.Lines[idx];
367 OnJumpProc(Self, searchFile, StackLine.LineNum, StackLine.Column);
368 end;
369
370 procedure THeapTrcViewForm.ChangeTreeText;
371 var
372 i, j : Integer;
373 useRaw : Boolean;
374 nd : TTreeNode;
375 trace : TStackTrace;
376 begin
377 trvTraceInfo.Items.BeginUpdate;
378 try
379 useRaw := chkUseRaw.Checked;
380 for i := 0 to trvTraceInfo. Items.Count - 1 do begin
381 nd := TTreeNode(trvTraceInfo.Items[i]);
382 if Assigned(nd.Parent) or not Assigned(nd.Data) then Continue;
383 trace := TStackTrace(nd.Data);
384 nd.Text := GetStackTraceText(trace, useRaw);
385 for j := 0 to nd.Count - 1 do begin
386 nd.Items[j].Text := GetStackLineText( trace.Lines[j], useRaw );
387 end;
388 end;
389 finally
390 trvTraceInfo.Items.EndUpdate;
391 end;
392 end;
393
GetStackTraceTextnull394 function THeapTrcViewForm.GetStackTraceText(trace: TStackTrace; useRaw: boolean): string;
395 begin
396 if useRaw then begin
397 Result := trace.RawStackData;
398 if (Result <> '') and (trace.LeakCount > 1) then Result := Result + Format(
399 rsDTimes, [trace.LeakCount]);
400 end;
401
402 if not useRaw or (Result = '') then begin
403 if trace.LeakCount > 1
404 then Result := Format(StackTraceFormat, [trace.BlockSize, trace.LeakCount])
405 else Result := Format(StackTraceFormatSingle, [trace.BlockSize]);
406 end;
407
408 end;
409
GetStackLineTextnull410 function THeapTrcViewForm.GetStackLineText(const Line: TStackLine; useRaw: boolean): string;
411 begin
412 if useRaw then
413 Result := Line.RawLineData;
414
415 if (not useRaw) or (Result = '') or
416 ( (Pos(' ', Trim(Result)) < 1) and (Pos(':', Trim(Result)) < 1) and
417 ( (copy(Trim(Result),1,1) = '$') or (copy(Trim(Result),1,2) = '0x') )
418 ) // Rawdata may be address only
419 then
420 with Line do
421 if FileName <> ''
422 then Result := Format(StackLineFormatWithFile, ['$'+IntToHex(Addr, sizeof(Pointer)*2), ExtractFileName(FileName), LineNum])
423 else Result := Format(StackLineFormat, ['$'+IntToHex(Addr, sizeof(Pointer)*2)]);
424 end;
425
426 procedure THeapTrcViewForm.SaveState(cfg:TXMLConfig);
427 var
428 b : TRect;
429 i : Integer;
430 begin
431 cfg.SetValue('isStayOnTop',FormStyle=fsStayOnTop);
432 b:=BoundsRect;
433 cfg.OpenKey('bounds');
434 cfg.SetValue('left', b.Left);
435 cfg.SetValue('top', b.Top);
436 cfg.SetValue('right', b.Right);
437 cfg.SetValue('bottom', b.Bottom);
438 cfg.CloseKey;
439 for i:=0 to edtTrcFileName.Items.Count-1 do
440 cfg.SetValue(DOMString('path'+IntToStr(i)), UTF8Decode(edtTrcFileName.Items[i]) );
441 end;
442
443 function PointInRect(p: TPoint; const r: TRect): Boolean;
444 begin
445 Result:=(p.X>=r.Left) and (p.X<=r.Right) and (p.y>=r.Top) and (p.y<=r.Bottom);
446 end;
447
448 procedure inAnyMonitor(var b: TRect);
449 var
450 m: TMonitor;
451 mb: TRect;
452 const
453 MinOverLap = 40;
454 begin
455 m := Screen.MonitorFromRect(b); // Nearest Monitor
456 if assigned(m)
457 then mb := m.BoundsRect
458 else mb := Screen.WorkAreaRect;
459
460 // make sure top(window-bar) is visible
461 if b.Top < mb.Top then OffsetRect(b, 0, mb.Top-b.Top);
462 if b.Top + MinOverLap > mb.Bottom then OffsetRect(b, 0, mb.Top-b.Top-MinOverLap);
463 // move left/right
464 if b.Left + MinOverLap > mb.Right then OffsetRect(b, mb.Right-b.Left-MinOverLap, 0);
465 if b.Right - MinOverLap < mb.Left then OffsetRect(b, mb.Left-b.Right+MinOverLap, 0);
466 end;
467
468 procedure THeapTrcViewForm.LoadState(cfg:TXMLConfig);
469 var
470 b : TRect;
471 isTop : Boolean;
472 st : TStringList;
473 s : WideString;
474 i : Integer;
475 const
476 InitFormStyle: array [Boolean] of TFormStyle = (fsNormal, fsStayOnTop);
477 begin
478 isTop:=True;
479 b:=BoundsRect;
480 st:=TStringList.Create;
481 try
482 istop:=cfg.GetValue('isStayOnTop',isTop);
483 cfg.OpenKey('bounds');
484 b.Left:=cfg.GetValue('left', b.Left);
485 b.Top:=cfg.GetValue('top', b.Top);
486 b.Right:=cfg.GetValue('right', b.Right);
487 b.Bottom:=cfg.GetValue('bottom', b.Bottom);
488 cfg.CloseKey;
489
490 if b.Right-b.Left<=0 then b.Right:=b.Left+40;
491 if b.Bottom-b.Top<=0 then b.Bottom:=b.Top+40;
492
493 for i:=0 to 7 do begin
494 s:=cfg.GetValue(DOMString('path'+IntToStr(i)), '');
495 if s<>'' then st.Add(UTF8Encode(s));
496 end;
497
498 except
499 end;
500 inAnyMonitor(b);
501
502 FormStyle:=InitFormStyle[isTop];
503 BoundsRect:=b;
504 chkStayOnTop.Checked := isTop;
505 if st.Count>0 then begin
506 edtTrcFileName.Items.AddStrings(st);
507 edtTrcFileName.ItemIndex:=0;
508 end;
509
510 st.Free;
511 end;
512
513 procedure THeapTrcViewForm.AddFileToList(const FileName:AnsiString);
514 var
515 i : Integer;
516 begin
517 i:=edtTrcFileName.Items.IndexOf(FileName);
518 if (i<0) then begin
519 if edtTrcFileName.Items.Count=8 then
520 edtTrcFileName.Items.Delete(7);
521 end else
522 edtTrcFileName.Items.Delete(i);
523 edtTrcFileName.Items.Insert(0, FileName);
524 end;
525
526 procedure THeapTrcViewForm.LazarusJump(Sender: TObject;
527 const SourceFile: string; Line, Column: Integer);
528 var
529 nm : string;
530 begin
531 if not FileExistsUTF8(SourceFile) then begin
532 nm := LazarusIDE.FindSourceFile(SourceFile, '', [fsfUseIncludePaths] );
533 if nm = '' then
534 nm := SourceFile;
535 end else
536 nm := SourceFile;
537 LazarusIDE.DoOpenFileAndJumpToPos(nm, Point(Column, Line), -1, -1, -1, [ofOnlyIfExists, ofRegularFile]);
538 end;
539
540 destructor THeapTrcViewForm.Destroy;
541 begin
542 FreeAndNil(Finfo);
543 inherited Destroy;
544 end;
545
546 procedure IDEMenuClicked(Sender: TObject);
547 begin
548 ShowHeapTrcViewForm(nil);
549 end;
550
551 procedure Register;
552 var
553 IDEShortCutX: TIDEShortCut;
554 IDECommandCategory: TIDECommandCategory;
555 IDECommand: TIDECommand;
556 IDEButtonCommand: TIDEButtonCommand;
557 begin
558 RegisterIDEMenuCommand(itmViewMainWindows, 'mnuLeakView', rsLeakView, nil, @IDEMenuClicked);
559
560 IDEShortCutX := IDEShortCut(VK_UNKNOWN, [], VK_UNKNOWN, []);
561 IDECommandCategory := IDECommandList.FindCategoryByName(CommandCategoryViewName);
562 if IDECommandCategory <> nil then
563 begin
564 IDECommand := RegisterIDECommand(IDECommandCategory, 'Leaks and Traces', rsLeakView, IDEShortCutX, nil, @IDEMenuClicked);
565 if IDECommand <> nil then
566 begin
567 IDEButtonCommand := RegisterIDEButtonCommand(IDECommand);
568 if IDEButtonCommand=nil then ;
569 end;
570 end;
571 end;
572
573 end.
574
575