memorydump.pas

全世界知名的Open Source Delphi开发组织JCL的作品。JCL包含了很多Delphi和C++Builder中的可重用单元

{**************************************************************************************************}
{                                                                                                  }
{ 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 MemoryDump.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: 2006-05-30 00:02:45 +0200 (mar., 30 mai 2006) $                                                      }
{                                                                                                  }
{**************************************************************************************************}

unit MemoryDump;

{$I JCL.INC}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, ToolWin, ActnList, ExtCtrls, ViewTemplate, Menus;

type
  TMemoryInfo = packed record
    MemInfo: TMemoryBasicInformation;
    RepeatedItem, MappedFile: Boolean;
  end;

  TMemoryDumpForm = class(TViewForm)
    StatusBar: TStatusBar;
    PagesListView: TListView;
    Splitter1: TSplitter;
    DumpListView: TListView;
    ToolButton5: TToolButton;
    ToolButton6: TToolButton;
    MemoryTreeView: TTreeView;
    Splitter2: TSplitter;
    ToolButton1: TToolButton;
    ToolButton2: TToolButton;
    ToolButton3: TToolButton;
    ToolButton4: TToolButton;
    Refresh2: TMenuItem;
    N1: TMenuItem;
    Copy2: TMenuItem;
    Save1: TMenuItem;
    N2: TMenuItem;
    Selectall2: TMenuItem;
    ViewAsText1: TAction;
    ToolButton7: TToolButton;
    ToolButton8: TToolButton;
    N3: TMenuItem;
    Viewastext2: TMenuItem;
    SaveData1: TAction;
    ToolButton9: TToolButton;
    Savedata2: TMenuItem;
    SaveDataDialog: TSaveDialog;
    ToolButton10: TToolButton;
    procedure Refresh1Execute(Sender: TObject);
    procedure DumpListViewData(Sender: TObject; Item: TListItem);
    procedure PagesListViewSelectItem(Sender: TObject; Item: TListItem;
      Selected: Boolean);
    procedure FormDestroy(Sender: TObject);
    procedure PagesListViewCustomDrawItem(Sender: TCustomListView;
      Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
    procedure FormCreate(Sender: TObject);
    procedure PagesListViewData(Sender: TObject; Item: TListItem);
    procedure MemoryTreeViewChange(Sender: TObject; Node: TTreeNode);
    procedure MemoryTreeViewGetSelectedIndex(Sender: TObject;
      Node: TTreeNode);
    procedure ViewAsText1Execute(Sender: TObject);
    procedure SaveData1Update(Sender: TObject);
    procedure SaveData1Execute(Sender: TObject);
  private
    FDumpBytesPerLine: Integer;
    FProcessID: DWORD;
    FProcess: THandle;
    FFileName: TFileName;
    FMemoryInfo: array of TMemoryInfo;
    FModulesList: TStringList;
    procedure BuildPagesList;
    procedure BuildModulesList;
    procedure UpdateDumpList;
  public
    procedure SetParams(ProcessID: DWORD; const FileName: TFileName);
  end;

var
  MemoryDumpForm: TMemoryDumpForm;

implementation

uses Global, TLHelp32, ToolsUtils, FindDlg, JclBase;

{$R *.DFM}

resourcestring
  sAllocations = 'Allocations';
  sCaption = 'Virtual Memory list - %s';
  sCommited = 'Comitted: %.0n';
  sCount = 'Count: %d';
  sModules = 'Modules';
  sReserved = 'Reserved: %.0n';

function AllocationProtectStr(P: DWORD): string;
begin
  case P of
    PAGE_NOACCESS:
      Result := 'NoAccess';
    PAGE_READONLY:
      Result := 'ReadOnly';
    PAGE_READWRITE:
      Result := 'ReadWrite';
    PAGE_WRITECOPY:
      Result := 'WriteCopy';
    PAGE_EXECUTE:
      Result := 'Exec';
    PAGE_EXECUTE_READ:
      Result := 'ExecRead';
    PAGE_EXECUTE_READWRITE:
      Result := 'ExecReadWrite';
    PAGE_EXECUTE_WRITECOPY:
      Result := 'ExecWriteCopy';
    PAGE_GUARD:
      Result := 'Guard';
    PAGE_NOCACHE:
      Result := 'NoCache';
  else
    Result := '';
  end;
end;

function StateStr(P: DWORD): string;
begin
  case P of
    MEM_COMMIT:
      Result := 'Commit';
    MEM_FREE:
      Result := 'Free';
    MEM_RESERVE:
      Result := 'Reserve';
  else
    Result := Format('%x', [P]);
  end;
end;

function TypeStr(P: DWORD): string;
begin
  case P of
    MEM_IMAGE:
      Result := 'Image';
    MEM_MAPPED:
      Result := 'Mapped';
    MEM_PRIVATE:
      Result := 'Private';
  else
    Result := Format('%x', [P]);
  end;
end;

function ImageIndexFromInfo(MemInfo: TMemoryInfo): Integer;
begin
  with MemInfo do
    if MappedFile then Result := 6 else
      if RepeatedItem then Result := 21 else
        Result := 19;
end;

{ TMemoryDumpForm }

procedure TMemoryDumpForm.FormCreate(Sender: TObject);
begin
  inherited;
  FModulesList := TStringList.Create;
end;

procedure TMemoryDumpForm.FormDestroy(Sender: TObject);
begin
  FModulesList.Free;
  if FProcess <> 0 then CloseHandle(FProcess);
end;

procedure TMemoryDumpForm.BuildPagesList;
var
  AllocationsNode, ModulesNode, TempNode: TTreeNode;
  LastAllocationBase: Pointer;
  LastMappedFile: Boolean;
  I, N, TotalCommit, TotalReserve: Integer;

  procedure EnumAllocations;
var
  P: PChar;
  MI: TMemoryBasicInformation;
  Res: DWORD;
  Count: Integer;
begin
  FMemoryInfo := nil;
  Count := 0;
  P := Pointer(0);
  Res := VirtualQueryEx(FProcess, P, MI, SizeOf(MI));
  if Res <> SizeOf(MI) then RaiseLastOSError;
  while Res = SizeOf(MI) do
  begin
    if MI.AllocationBase <> nil then
    begin
      SetLength(FMemoryInfo, Count + 1);
      FMemoryInfo[Count].MemInfo := MI;
      Inc(Count);
    end;
    Inc(P, MI.RegionSize);
    Res := VirtualQueryEx(FProcess, P, MI, SizeOf(MI));
  end;
end;

begin
  Screen.Cursor := crHourGlass;
  try
    PagesListView.Items.BeginUpdate;
    PagesListView.Items.Count := 0;
    MemoryTreeView.Items.BeginUpdate;
    StatusBar.Panels.BeginUpdate;
    try
      EnumAllocations;
      PagesListView.Items.Count := Length(FMemoryInfo);

      with MemoryTreeView.Items do
      begin
        Clear;
        AllocationsNode := AddFirst(nil, sAllocations);
        AllocationsNode.ImageIndex := 19;
        ModulesNode := Add(nil, sModules);
        ModulesNode.ImageIndex := 6;
        LastAllocationBase := nil;
        LastMappedFile := False;
        for I := 0 to Length(FMemoryInfo) - 1 do
          with FMemoryInfo[I] do
            if LastAllocationBase <> MemInfo.AllocationBase then
            begin
              TempNode := AddChildObject(AllocationsNode, Format('%p', [MemInfo.AllocationBase]), Pointer(I));
              with TempNode do ImageIndex := Parent.ImageIndex;
              LastAllocationBase := MemInfo.AllocationBase;
              RepeatedItem := False;
              N := FModulesList.IndexOfObject(LastAllocationBase);
              if N <> -1 then
              begin
                TempNode := AddChildObject(ModulesNode, FModulesList[N], Pointer(I));