342 lines
11 KiB
ObjectPascal
342 lines
11 KiB
ObjectPascal
{**************************************************************************************************}
|
|
{ }
|
|
{ Project JEDI Code Library (JCL) - Delphi Tools }
|
|
{ }
|
|
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
|
|
{ you may not use this file except in compliance with the License. You may obtain a copy of the }
|
|
{ License at http://www.mozilla.org/MPL/ }
|
|
{ }
|
|
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF }
|
|
{ ANY KIND, either express or implied. See the License for the specific language governing rights }
|
|
{ and limitations under the License. }
|
|
{ }
|
|
{ The Original Code is HeadDump.pas. }
|
|
{ }
|
|
{ The Initial Developer of the Original Code is Petr Vones. Portions created by Petr Vones are }
|
|
{ Copyright (C) of Petr Vones. All Rights Reserved. }
|
|
{ }
|
|
{ Contributor(s): }
|
|
{ }
|
|
{**************************************************************************************************}
|
|
{ }
|
|
{ Last modified: $Date: 2005/10/27 01:44:51 $ }
|
|
{ }
|
|
{**************************************************************************************************}
|
|
|
|
unit HeapDump;
|
|
|
|
{$I JCL.INC}
|
|
|
|
interface
|
|
|
|
uses
|
|
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
|
|
ComCtrls, ExtCtrls, StdCtrls, ToolWin, ActnList, ClipBrd, Menus,
|
|
TLHelp32, ViewTemplate;
|
|
|
|
type
|
|
THeapDumpForm = class(TViewForm)
|
|
StatusBar: TStatusBar;
|
|
Panel1: TPanel;
|
|
HeapListView: TListView;
|
|
Splitter1: TSplitter;
|
|
HeapEntryListView: TListView;
|
|
Splitter2: TSplitter;
|
|
HeapEntryMemo: TMemo;
|
|
ToolButton5: TToolButton;
|
|
ToolButton6: TToolButton;
|
|
ToolButton7: TToolButton;
|
|
ToolButton8: TToolButton;
|
|
Refresh2: TMenuItem;
|
|
N1: TMenuItem;
|
|
Copy2: TMenuItem;
|
|
Save1: TMenuItem;
|
|
ToolButton1: TToolButton;
|
|
ToolButton2: TToolButton;
|
|
N2: TMenuItem;
|
|
Selectall2: TMenuItem;
|
|
ToolButton3: TToolButton;
|
|
procedure HeapListViewColumnClick(Sender: TObject;
|
|
Column: TListColumn);
|
|
procedure HeapListViewCompare(Sender: TObject; Item1, Item2: TListItem;
|
|
Data: Integer; var Compare: Integer);
|
|
procedure StatusBarResize(Sender: TObject);
|
|
procedure Refresh1Execute(Sender: TObject);
|
|
procedure HeapEntryListViewData(Sender: TObject; Item: TListItem);
|
|
procedure HeapEntryListViewSelectItem(Sender: TObject; Item: TListItem;
|
|
Selected: Boolean);
|
|
procedure HeapListViewSelectItem(Sender: TObject; Item: TListItem;
|
|
Selected: Boolean);
|
|
private
|
|
FProcessID: DWORD;
|
|
FFileName: TFileName;
|
|
FreeSum, FixedSum, MoveableSum: Integer;
|
|
FHeapEntries: array of THeapEntry32;
|
|
procedure BuildHeapList;
|
|
procedure BuildHeapEntriesList(HeapID: DWORD);
|
|
procedure UpdateStatusLine;
|
|
procedure ReadHeapEntry(Item: TListItem);
|
|
public
|
|
procedure BuildContent; override;
|
|
procedure SetParams(ProcessID: DWORD; const FileName: TFileName);
|
|
end;
|
|
|
|
var
|
|
HeapDumpForm: THeapDumpForm;
|
|
|
|
implementation
|
|
|
|
{$R *.DFM}
|
|
|
|
uses
|
|
Global, Main, ToolsUtils;
|
|
|
|
resourcestring
|
|
sCaption = 'HeapList - %s';
|
|
sCountStatus = 'Heap Entries: %d';
|
|
sFixedStatus = 'Fixed: %0.n';
|
|
sFreeStatus = 'Free: %0.n';
|
|
sMoveableStatus = 'Moveable: %0.n';
|
|
sPressEscape = 'Press <ESC> to cancel enumerating heap items ...';
|
|
|
|
{ THeapDumpForm }
|
|
|
|
procedure THeapDumpForm.BuildHeapEntriesList(HeapID: DWORD);
|
|
var
|
|
Next: Boolean;
|
|
HeapEntry: THeapEntry32;
|
|
EntriesCount: Integer;
|
|
begin
|
|
with HeapEntryListView do
|
|
begin
|
|
Items.BeginUpdate;
|
|
Screen.Cursor := crHourGlass;
|
|
try
|
|
HeapEntryMemo.Font.Style := [fsBold];
|
|
HeapEntryMemo.Text := sPressEscape;
|
|
Items.Count := 0;
|
|
EntriesCount := 0;
|
|
SetLength(FHeapEntries, 0);
|
|
FreeSum := 0;
|
|
FixedSum := 0;
|
|
MoveableSum := 0;
|
|
HeapEntry.dwSize := Sizeof(HeapEntry);
|
|
Next := Heap32First(HeapEntry, FProcessID, HeapID);
|
|
while Next do
|
|
begin
|
|
SetLength(FHeapEntries, EntriesCount + 1);
|
|
FHeapEntries[EntriesCount] := HeapEntry;
|
|
with HeapEntry do
|
|
case dwFlags of
|
|
LF32_FIXED:
|
|
Inc(FixedSum, dwBlockSize);
|
|
LF32_FREE:
|
|
Inc(FreeSum, dwBlockSize);
|
|
LF32_MOVEABLE:
|
|
Inc(MoveableSum, dwBlockSize);
|
|
end;
|
|
Inc(EntriesCount);
|
|
if EntriesCount mod 200 = 0 then
|
|
begin
|
|
UpdateStatusLine;
|
|
if GetAsyncKeyState(VK_ESCAPE) and $8000 <> 0 then Break;
|
|
end;
|
|
Next := Heap32Next(HeapEntry);
|
|
end;
|
|
Items.Count := EntriesCount;
|
|
if Items.Count > 0 then
|
|
begin
|
|
AlphaSort;
|
|
ItemFocused := Items[0];
|
|
ItemFocused.Selected := True;
|
|
end;
|
|
UpdateStatusLine;
|
|
HeapEntryMemo.ParentFont := True;
|
|
finally
|
|
Items.EndUpdate;
|
|
Screen.Cursor := crDefault;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure THeapDumpForm.BuildHeapList;
|
|
var
|
|
SnapProcHandle: THandle;
|
|
HeapList: THeapList32;
|
|
Next: Boolean;
|
|
begin
|
|
with HeapListView do
|
|
begin
|
|
Items.BeginUpdate;
|
|
try
|
|
Items.Clear;
|
|
SnapProcHandle := CreateToolhelp32Snapshot(TH32CS_SNAPHEAPLIST, FProcessID);
|
|
if SnapProcHandle <> THandle(-1) then
|
|
begin
|
|
HeapList.dwSize := Sizeof(HeapList);
|
|
Next := Heap32ListFirst(SnapProcHandle, HeapList);
|
|
while Next do
|
|
begin
|
|
with Items.Add do
|
|
begin
|
|
Caption := Format('%.8x', [HeapList.th32HeapID]);
|
|
Data := Pointer(HeapList.th32HeapID);
|
|
case HeapList.dwFlags of
|
|
HF32_DEFAULT:
|
|
SubItems.Add('Default');
|
|
HF32_SHARED:
|
|
SubItems.Add('Shared');
|
|
else
|
|
SubItems.Add('Normal');
|
|
end;
|
|
end;
|
|
Next := Heap32ListNext(SnapProcHandle, HeapList);
|
|
end;
|
|
CloseHandle(SnapProcHandle);
|
|
end;
|
|
if Items.Count > 0 then
|
|
begin
|
|
AlphaSort;
|
|
ItemFocused := Items[0];
|
|
ItemFocused.Selected := True;
|
|
end else
|
|
begin
|
|
BuildHeapEntriesList(0);
|
|
HeapEntryMemo.Lines.Clear;
|
|
end;
|
|
finally
|
|
Items.EndUpdate;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure THeapDumpForm.SetParams(ProcessID: DWORD; const FileName: TFileName);
|
|
begin
|
|
FProcessID := ProcessID;
|
|
FFileName := FileName;
|
|
Caption := Format(sCaption, [FFileName]);
|
|
PostBuildContentMessage;
|
|
end;
|
|
|
|
procedure THeapDumpForm.HeapListViewColumnClick(Sender: TObject;
|
|
Column: TListColumn);
|
|
begin
|
|
LVColumnClick(Column);
|
|
end;
|
|
|
|
procedure THeapDumpForm.HeapListViewCompare(Sender: TObject; Item1,
|
|
Item2: TListItem; Data: Integer; var Compare: Integer);
|
|
begin
|
|
LVCompare(TListView(Sender), Item1, Item2, Compare);
|
|
end;
|
|
|
|
procedure THeapDumpForm.UpdateStatusLine;
|
|
begin
|
|
with StatusBar.Panels do
|
|
begin
|
|
BeginUpdate;
|
|
Items[0].Text := Format(sCountStatus, [High(FHeapEntries) + 1]);
|
|
Items[1].Text := Format(sFixedStatus, [IntToExtended(FixedSum)]);
|
|
Items[2].Text := Format(sMoveableStatus, [IntToExtended(MoveableSum)]);
|
|
Items[3].Text := Format(sFreeStatus, [IntToExtended(FreeSum)]);
|
|
EndUpdate;
|
|
Update;
|
|
end;
|
|
end;
|
|
|
|
procedure THeapDumpForm.StatusBarResize(Sender: TObject);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
with StatusBar do
|
|
for I := 0 to Panels.Count - 1 do Panels[I].Width := Width div 4;
|
|
end;
|
|
|
|
procedure THeapDumpForm.ReadHeapEntry(Item: TListItem);
|
|
var
|
|
BlockSize, BytesRead: DWORD;
|
|
Buffer, BufferEnd, P: PChar;
|
|
begin
|
|
with HeapEntryMemo do {if DWORD(Item.SubItems.Objects[2]) <> LF32_FREE then}
|
|
begin
|
|
BlockSize := DWORD(Item.SubItems.Objects[1]);
|
|
if BlockSize > 32768 then BlockSize := 32768;
|
|
GetMem(Buffer, BlockSize);
|
|
Lines.BeginUpdate;
|
|
try
|
|
Lines.Clear;
|
|
if Toolhelp32ReadProcessMemory(FProcessID, Item.SubItems.Objects[0],
|
|
Buffer^, BlockSize - 1, BytesRead) then
|
|
begin
|
|
P := Buffer;
|
|
BufferEnd := Buffer + BytesRead - 1;
|
|
while P < BufferEnd do
|
|
begin
|
|
case P^ of
|
|
#0: P^ := '|';
|
|
#1..#31: P^ := '.';
|
|
end;
|
|
Inc(P);
|
|
end;
|
|
Buffer[BytesRead] := #0;
|
|
SetTextBuf(Buffer);
|
|
end;
|
|
finally
|
|
FreeMem(Buffer);
|
|
Lines.EndUpdate;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure THeapDumpForm.Refresh1Execute(Sender: TObject);
|
|
begin
|
|
BuildHeapList;
|
|
end;
|
|
|
|
procedure THeapDumpForm.HeapEntryListViewData(Sender: TObject;
|
|
Item: TListItem);
|
|
begin
|
|
with Item, FHeapEntries[Item.Index] do
|
|
begin
|
|
Caption := Format('%.8x', [hHandle]);
|
|
SubItems.AddObject(Format('%.8x', [dwAddress]), Pointer(dwAddress));
|
|
SubItems.AddObject(Format('%.0n', [IntToExtended(dwBlockSize)]), Pointer(dwBlockSize));
|
|
SubItems.AddObject(Format('%.8x', [dwAddress + dwBlockSize]), Pointer(dwAddress + dwBlockSize));
|
|
case dwFlags of
|
|
LF32_FIXED:
|
|
SubItems.AddObject('Fixed', Pointer(dwFlags));
|
|
LF32_FREE:
|
|
SubItems.AddObject('Free', Pointer(dwFlags));
|
|
LF32_MOVEABLE:
|
|
SubItems.AddObject('Moveable', Pointer(dwFlags));
|
|
end;
|
|
SubItems.AddObject(Format('%d', [dwLockCount]), Pointer(dwLockCount));
|
|
end;
|
|
end;
|
|
|
|
procedure THeapDumpForm.HeapEntryListViewSelectItem(Sender: TObject;
|
|
Item: TListItem; Selected: Boolean);
|
|
begin
|
|
if Selected then ReadHeapEntry(Item);
|
|
end;
|
|
|
|
procedure THeapDumpForm.HeapListViewSelectItem(Sender: TObject;
|
|
Item: TListItem; Selected: Boolean);
|
|
begin
|
|
if Selected then BuildHeapEntriesList(DWORD(Item.Data));
|
|
end;
|
|
|
|
procedure THeapDumpForm.BuildContent;
|
|
begin
|
|
BuildHeapList;
|
|
end;
|
|
|
|
// History:
|
|
|
|
// $Log: HeapDump.pas,v $
|
|
// Revision 1.2 2005/10/27 01:44:51 rrossmair
|
|
// - added MPL headers and CVS Log tags
|
|
//
|
|
|
|
end.
|