/components/leakview/heaptrcview.pas

  1unit HeapTrcView;
  2
  3{$mode objfpc}{$H+}
  4
  5interface
  6
  7uses
  8  Classes, SysUtils, XMLConf, contnrs, Clipbrd, LCLProc,
  9  LResources, Forms, Controls, Graphics, Dialogs, StdCtrls, ComCtrls, ExtCtrls,
 10  // LazUtils
 11  FileUtil, LazFileUtils,
 12  // IDEIntf
 13  LazIDEIntf, MenuIntf,
 14  // LeakView
 15  LeakInfo;
 16
 17type
 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  : TList;
 49
 50    procedure DoUpdateLeaks(FromClip: Boolean = False);
 51
 52    procedure ItemsToTree;
 53    procedure ChangeTreeText;
 54
 55    procedure ClearItems;
 56    procedure DoJump;
 57
 58    function GetStackTraceText(trace: TStackTrace; useRaw: Boolean): string;
 59    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
 74resourcestring
 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
 98var
 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
103procedure ShowHeapTrcViewForm(JumpProc: TJumpProc = nil);
104
105procedure Register;
106
107implementation
108
109{$R *.lfm}
110
111procedure ShowHeapTrcViewForm(JumpProc: TJumpProc);
112begin
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;
120end;
121
122{ THeapTrcViewForm }
123
124procedure THeapTrcViewForm.btnUpdateClick(Sender: TObject);
125begin
126  DoUpdateLeaks;
127  AddFileToList(edtTrcFileName.Text);
128end;
129
130procedure THeapTrcViewForm.btnClipboardClick(Sender: TObject);
131begin
132  DoUpdateLeaks(True);
133end;
134
135procedure THeapTrcViewForm.BtnResolveClick(Sender: TObject);
136begin
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;
146end;
147
148procedure THeapTrcViewForm.btnBrowseClick(Sender: TObject);
149begin
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);
158end;
159
160procedure THeapTrcViewForm.chkStayOnTopChange(Sender: TObject);
161begin
162  if chkStayOnTop.Checked then Self.formStyle := fsStayOnTop
163  else Self.formStyle := fsNormal;
164end;
165
166procedure THeapTrcViewForm.chkUseRawChange(Sender: TObject);
167begin
168  ChangeTreeText;
169  trvTraceInfo.Invalidate;
170end;
171
172var
173  ConfigFileName : AnsiString = '';
174function CreateXMLConfig: TXMLConfig;
175begin
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;
181end;
182
183procedure THeapTrcViewForm.FormCreate(Sender: TObject);
184var
185  cfg   : TXMLConfig;
186begin
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:=TList.Create;
195  try
196    cfg:=CreateXMLConfig;
197    try
198      LoadState(cfg);
199    finally
200      cfg.Free;
201    end;
202  except
203  end;
204end;
205
206procedure THeapTrcViewForm.FormDestroy(Sender: TObject);
207var
208  cfg : TXMLConfig;
209begin
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;
222end;
223
224procedure THeapTrcViewForm.trvTraceInfoDblClick(Sender: TObject);
225begin
226  DoJump;
227end;
228
229//note: to range check performed
230procedure HexInt64ToStr(i64: Int64; var s: string; ofs: Integer);
231var
232  i : Integer;
233  j : Integer;
234const
235  Hexes: array [0..$F] of char = ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
236begin
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;
243end;
244
245function GetHashString(trace: TStackTrace): string;
246var
247  i   : integer;
248  sz  : Integer;
249begin
250  sz := 16 + trace.Count * 16; // 8 hex digits for Size + 8 hex digits for Size
251  SetLength(Result, sz);
252  HexInt64ToStr(trace.BlockSize, Result, 1);
253  for i := 0 to trace.Count - 1 do
254    HexInt64ToStr(trace.lines[i].Addr, Result, 17 + i * 16);
255end;
256
257procedure THeapTrcViewForm.ItemsToTree;
258var
259  i      : Integer;
260  j      : Integer;
261  trace  : TStackTrace;
262  nd     : TTreeNode;
263  hash   : TFPObjectHashTable;
264  hashed : TStackTrace;
265  s      : string;
266begin
267  hash := TFPObjectHashTable.Create(false);
268  try
269    // removing duplicates
270    for i := 0 to fItems.Count - 1 do begin
271      trace := TStackTrace(fItems[i]);
272      s := GetHashString(trace);
273      hashed := TStackTrace(hash.Items[s]);
274      if Assigned(hashed) then begin
275        inc(hashed.LeakCount);
276        trace.Free; // remove from list
277        fItems[i] := nil;
278      end else
279        hash.Add(s, trace)
280    end;
281    fItems.Pack;
282
283    // filling the tree
284    for i := 0 to fItems.Count - 1 do begin
285      trace := TStackTrace(fItems[i]);
286      nd := trvTraceInfo.Items.AddChildObject(nil, '+', trace);
287      for j := 0 to trace.Count - 1 do begin
288        trvTraceInfo.Items.AddChildObject(nd, '-', {%H-}Pointer(PtrInt(j)));
289      end;
290    end;
291
292    // updating tree text
293    ChangeTreeText;
294
295  finally
296    hash.free;
297  end;
298end;
299
300procedure THeapTrcViewForm.ClearItems;
301var
302  i : integer;
303begin
304  for i := 0 to fItems.Count - 1 do
305    TObject(fItems[i]).Free;
306  fItems.Clear;
307end;
308
309procedure THeapTrcViewForm.DoUpdateLeaks(FromClip: Boolean = False);
310var
311  data  : TLeakStatus;
312  txt: String;
313begin
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);
343end;
344
345procedure THeapTrcViewForm.DoJump;
346var
347  nd         : TTreeNode;
348  searchFile : string;
349  idx        : Integer;
350  trace      : TStackTrace;
351  StackLine: TStackLine;
352begin
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);
368end;
369
370procedure THeapTrcViewForm.ChangeTreeText;
371var
372  i, j    : Integer;
373  useRaw  : Boolean;
374  nd      : TTreeNode;
375  trace   : TStackTrace;
376begin
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;
392end;
393
394function THeapTrcViewForm.GetStackTraceText(trace: TStackTrace; useRaw: boolean): string;
395begin
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
408end;
409
410function THeapTrcViewForm.GetStackLineText(const Line: TStackLine; useRaw: boolean): string;
411begin
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)]);
424end;
425
426procedure THeapTrcViewForm.SaveState(cfg:TXMLConfig);
427var
428  b : TRect;
429  i : Integer;
430begin
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('path'+IntToStr(i), UTF8Decode(edtTrcFileName.Items[i]) );
441end;
442
443function PointInRect(p: TPoint; const r: TRect): Boolean;
444begin
445  Result:=(p.X>=r.Left) and (p.X<=r.Right) and (p.y>=r.Top) and (p.y<=r.Bottom);
446end;
447
448procedure inAnyMonitor(var b: TRect);
449var
450  m: TMonitor;
451  mb: TRect;
452const
453  MinOverLap = 40;
454begin
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);
466end;
467
468procedure THeapTrcViewForm.LoadState(cfg:TXMLConfig);
469var
470  b     : TRect;
471  isTop : Boolean;
472  st    : TStringList;
473  s     : WideString;
474  i     : Integer;
475const
476  InitFormStyle: array [Boolean] of TFormStyle = (fsNormal, fsStayOnTop);
477begin
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('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;
511end;
512
513procedure THeapTrcViewForm.AddFileToList(const FileName:AnsiString);
514var
515  i : Integer;
516begin
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);
524end;
525
526procedure THeapTrcViewForm.LazarusJump(Sender: TObject;
527  const SourceFile: string; Line, Column: Integer);
528var
529  nm  : string;
530begin
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]);
538end;
539
540destructor THeapTrcViewForm.Destroy;
541begin
542  FreeAndNil(Finfo);
543  inherited Destroy;
544end;
545
546procedure IDEMenuClicked(Sender: TObject);
547begin
548  ShowHeapTrcViewForm(nil);
549end;
550
551procedure Register;
552begin
553  RegisterIDEMenuCommand(itmViewMainWindows, 'mnuLeakView', rsLeakView, nil,
554    @IDEMenuClicked);
555end;
556
557end.
558