/components/leakview/heaptrcview.pas

http://github.com/graemeg/lazarus · Pascal · 558 lines · 468 code · 73 blank · 17 comment · 55 complexity · 334009207f4e0749d7dd0b7110a2d119 MD5 · raw file

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