detail9x.pas

《Delphi开发人员指南》配书原码

unit Detail9x;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, HeadList, TlHelp32, Menus, SysMain, DetBase;

type
  TListType = (ltThread, ltModule, ltHeap);

  TWin9xDetailForm = class(TBaseDetailForm)
    procedure DetailTabsChange(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure DetailLBDblClick(Sender: TObject);
  private
    FCurSnap: THandle;
    FCurProc: TProcessEntry32;
    DetailLists: array[TListType] of TStringList;
    ProcMem: PByte;
    HeapListAlloc: Boolean;
    procedure FreeHeapList;
    procedure ShowList(ListType: TListType);
    procedure WalkThreads;
    procedure WalkHeaps;
    procedure WalkModules;
  public
    procedure NewProcess(P: PProcessEntry32);
  end;

procedure ShowProcessDetails(P: PProcessEntry32);

implementation

{$R *.DFM}

uses ProcMem;

const
  { Array of strings which goes into the header of each respective list. }
  HeaderStrs: array[TListType] of TDetailStrings = (
      ('Thread ID', 'Base Priority', 'Delta Priority', 'Usage Count'),
      ('Module', 'Base Addr', 'Size', 'Usage Count'),
      ('Heap ID', 'Base Addr', 'Size', 'Flags'));

  { Array of strings which goes into the footer of each list. }
  ACountStrs: array[TListType] of string[31] = (
      'Total Threads: %d', 'Total Modules: %d', 'Total Heaps: %d');

  TabStrs: array[TListType] of string[7] = ('Threads', 'Modules', 'Heaps');

  SCaptionStr  = 'Details for %s';       // form caption
  SThreadStr   = '%x'#1'%s'#1'%s'#1'%d'; // id, base pri, delta pri, usage
  SModuleStr   = '%s'#1'$%p'#1'%d bytes'#1'%d'; // name, addr, size, usage
  SHeapStr     = '%x'#1'$%p'#1'%d bytes'#1'%s'; // ID, addr, size, flags
  SHeapReadErr = 'This heap is not accessible for read access.';

  ProcMemMaxSize = $7FFE;                // max size of heap view

procedure ShowProcessDetails(P: PProcessEntry32);
var
  I: TListType;
begin
  with TWin9xDetailForm.Create(Application) do
    try
      for I := Low(TabStrs) to High(TabStrs) do
        DetailTabs.Tabs.Add(TabStrs[I]);
      NewProcess(P);
      Font := MainForm.Font;
      ShowModal;
    finally
      Free;
    end;
end;

function GetThreadPriorityString(Priority: Integer): string;
{ Returns string describing thread priority }
begin
  case Priority of
    THREAD_PRIORITY_IDLE:          Result := '%d (Idle)';
    THREAD_PRIORITY_LOWEST:        Result := '%d (Lowest)';
    THREAD_PRIORITY_BELOW_NORMAL:  Result := '%d (Below Normal)';
    THREAD_PRIORITY_NORMAL:        Result := '%d (Normal)';
    THREAD_PRIORITY_ABOVE_NORMAL:  Result := '%d (Above Normal)';
    THREAD_PRIORITY_HIGHEST:       Result := '%d (Highest)';
    THREAD_PRIORITY_TIME_CRITICAL: Result := '%d (Time critical)';
  else
    Result := '%d (unknown)';
  end;
  Result := Format(Result, [Priority]);
end;

function GetClassPriorityString(Priority: DWORD): String;
{ returns string describing process priority class }
begin
  case Priority of
    4:   Result := '%d (Idle)';
    8:   Result := '%d (Normal)';
    13:  Result := '%d (High)';
    24:  Result := '%d (Real time)';
  else
    Result := '%d (non-standard)';
  end;
  Result := Format(Result, [Priority]);
end;

function GetHeapFlagString(Flag: DWORD): String;
{ Returns a string describing a heap flag }
begin
  case Flag of
    LF32_FIXED:    Result := 'Fixed';
    LF32_FREE:     Result := 'Free';
    LF32_MOVEABLE: Result := 'Moveable';
  end;
end;

procedure TWin9xDetailForm.ShowList(ListType: TListType);
{ Shows appropriate thread, heap, or module list in DetailLB }
var
  i: Integer;
begin
  Screen.Cursor := crHourGlass;
  try
    with DetailLB do
    begin
      for i := 0 to 3 do
        Sections[i].Text := HeaderStrs[ListType, i];
      Items.Clear;
      Items.Assign(DetailLists[ListType]);
    end;
     DetailSB.Panels[0].Text := Format(ACountStrs[ListType],
       [DetailLists[ListType].Count]);
     if ListType = ltHeap then
       DetailSB.Panels[1].Text := 'Double-click to view heap'
     else
       DetailSB.Panels[1].Text := '';
  finally
    Screen.Cursor := crDefault;
  end;
end;

procedure TWin9xDetailForm.WalkThreads;
{ Uses ToolHelp32 functions to walk list of threads }
var
  T: TThreadEntry32;
begin
  DetailLists[ltThread].Clear;
  T.dwSize := SizeOf(T);
  if Thread32First(FCurSnap, T) then
    repeat
      { Make sure thread is for current process }
      if T.th32OwnerProcessID = FCurProc.th32ProcessID then
        DetailLists[ltThread].Add(Format(SThreadStr, [T.th32ThreadID,
          GetClassPriorityString(T.tpBasePri),
          GetThreadPriorityString(T.tpDeltaPri), T.cntUsage]));
    until not Thread32Next(FCurSnap, T);
end;

procedure TWin9xDetailForm.WalkModules;
{ Uses ToolHelp32 functions to walk list of modules }
var
  M: TModuleEntry32;
begin
  DetailLists[ltModule].Clear;
  M.dwSize := SizeOf(M);
  if Module32First(FCurSnap, M) then
    repeat
      DetailLists[ltModule].Add(Format(SModuleStr, [M.szModule, M.ModBaseAddr,
        M.ModBaseSize, M.ProcCntUsage]));
    until not Module32Next(FCurSnap, M);
end;

procedure TWin9xDetailForm.WalkHeaps;
{ Uses ToolHelp32 functions to walk list of heaps }
var
  HL: THeapList32;
  HE: THeapEntry32;
  PHE: PHeapEntry32;
begin
  DetailLists[ltHeap].Clear;
  HL.dwSize := SizeOf(HL);
  HE.dwSize := SizeOf(HE);
  if Heap32ListFirst(FCurSnap, HL) then
    repeat
      if Heap32First(HE, HL.th32ProcessID, HL.th32HeapID) then
        repeat
          New(PHE);      // need to make copy of THeapList32 record so we
          PHE^ := HE;    // have enough info to view heap later
          DetailLists[ltHeap].AddObject(Format(SHeapStr, [HL.th32HeapID,
            Pointer(HE.dwAddress), HE.dwBlockSize,
            GetHeapFlagString(HE.dwFlags)]), TObject(PHE));
        until not Heap32Next(HE);
    until not Heap32ListNext(FCurSnap, HL);
  HeapListAlloc := True;
end;

procedure TWin9xDetailForm.FreeHeapList;
{ Since special allocation of PHeapList32 objects are added to the list, }
{ these must be freed. }
var
  i: integer;
begin
  for i := 0 to DetailLists[ltHeap].Count - 1 do
    Dispose(PHeapEntry32(DetailLists[ltHeap].Objects[i]));
end;

procedure TWin9xDetailForm.NewProcess(P: PProcessEntry32);
{ This procedure is called from the main form to show the detail }
{ form for a particular process. }
begin
  { Create a snapshot for the current process }
  FCurSnap := CreateToolhelp32Snapshot(TH32CS_SNAPALL, P^.th32ProcessID);
  if FCurSnap = INVALID_HANDLE_VALUE then
    raise Exception.Create('CreateToolHelp32Snapshot failed');
  HeapListAlloc := False;
  Screen.Cursor := crHourGlass;
  try
    FCurProc := P^;
    { Include module name in detail form caption }
    Caption := Format(SCaptionStr, [ExtractFileName(FCurProc.szExeFile)]);
    WalkThreads;                        // walk ToolHelp32 lists
    WalkModules;
    WalkHeaps;
    DetailTabs.TabIndex := 0;           // 0 = thread tab
    ShowList(ltThread);                 // show thread page first
  finally
    Screen.Cursor := crDefault;
    if HeapListAlloc then FreeHeapList;
    CloseHandle(FCurSnap);              // close snapshot handle
  end;
end;

procedure TWin9xDetailForm.DetailTabsChange(Sender: TObject);
{ OnChange event handler for tab set.  Sets visible list to jive with tabs. }
begin
  inherited;
  ShowList(TListType(DetailTabs.TabIndex));
end;

procedure TWin9xDetailForm.FormCreate(Sender: TObject);
var
  LT: TListType;
begin
  inherited;
  { Dispose of lists }
  for LT := Low(TListType) to High(TListType) do
    DetailLists[LT] := TStringList.Create;
end;

procedure TWin9xDetailForm.FormDestroy(Sender: TObject);
var
  LT: TListType;
begin
  inherited;
  { Dispose of lists }
  for LT := Low(TListType) to High(TListType) do
    DetailLists[LT].Free;
end;

procedure TWin9xDetailForm.DetailLBDblClick(Sender: TObject);
{ This procedure is called when the user double clicks on an item }
{ in DetailLB.  If the current tab page is heaps, a heap view     }
{ form is presented to the user. }
var
  NumRead: DWORD;
  HE: THeapEntry32;
  MemSize: integer;
begin
  inherited;
  if DetailTabs.TabIndex = 2 then
  begin
    HE := PHeapEntry32(DetailLB.Items.Objects[DetailLB.ItemIndex])^;
    MemSize := HE.dwBlockSize;         // get heap size
    { if heap is too big, use ProcMemMaxSize }
    if MemSize > ProcMemMaxSize then MemSize := ProcMemMaxSize;
    ProcMem := AllocMem(MemSize);     // allocate a temp buffer
    Screen.Cursor := crHourGlass;
    try
      { Copy heap into temp buffer }
      if Toolhelp32ReadProcessMemory(FCurProc.th32ProcessID,
        Pointer(HE.dwAddress), ProcMem^, MemSize, NumRead) then
        { point HeapView control at temp buffer }
        ShowHeapView(ProcMem, MemSize)
      else
        MessageDlg(SHeapReadErr, mtInformation, [mbOk], 0);
    finally
      Screen.Cursor := crDefault;
      FreeMem(ProcMem, MemSize);
    end;
  end;
end;

end.