ddhmman.pas

Delphi高级开发指南是开发程序的好帮手

unit DdhMMan;

interface

var
  GetMemCount: Integer = 0;
  FreeMemCount: Integer = 0;
  ReallocMemCount: Integer = 0;

procedure SnapToFile (Filename: string);

implementation

uses
  Windows, SysUtils, TypInfo;

var
  OldMemMgr: TMemoryManager;
  ObjList: array [1..10000] of Pointer;
  FreeInList: Integer = 1;

procedure AddToList (P: Pointer);
begin
  if FreeInList > High (ObjList) then
  begin
    MessageBox (0, 'List full', 'MemMan', mb_ok);
    Exit;
  end;
  ObjList [FreeInList] := P;
  Inc (FreeInList);
end;

procedure RemoveFromList (P: Pointer);
var
  I: Integer;
begin
  for I := 1 to FreeInList - 1 do
    if ObjList [I] = P then
    begin
      // remove element shifting down the others
      Dec (FreeInList);
      Move (ObjList [I+1], ObjList [I],
        (FreeInList - I) * sizeof (pointer));
      Exit;
    end;
end;

procedure SnapToFile (Filename: string);
var
  OutFile: TextFile;
  I, CurrFree: Integer;
  HeapStatus: THeapStatus;
  Item: TObject;
  ptd: PTypeData;
  ppi: PPropInfo;
begin
  AssignFile (OutFile, Filename);
  try
    Rewrite (OutFile);
    CurrFree := FreeInList;
    // local heap status
    HeapStatus := GetHeapStatus;
    with HeapStatus do
    begin
      write (OutFile, 'Available address space: ');
      write (OutFile, TotalAddrSpace div 1024);
      writeln (OutFile, ' Kbytes');
      write (OutFile, 'Uncommitted portion: ');
      write (OutFile, TotalUncommitted div 1024);
      writeln (OutFile, ' Kbytes');
      write (OutFile, 'Committed portion: ');
      write (OutFile, TotalCommitted div 1024);
      writeln (OutFile, ' Kbytes');
      write (OutFile, 'Free portion: ');
      write (OutFile, TotalFree div 1024);
      writeln (OutFile, ' Kbytes');
      write (OutFile, 'Allocated portion: ');
      write (OutFile, TotalAllocated div 1024);
      writeln (OutFile, ' Kbytes');
      write (OutFile, 'Address space load: ');
      write (OutFile, TotalAllocated div
        (TotalAddrSpace div 100));
      writeln (OutFile, '%');
      write (OutFile, 'Total small free blocks: ');
      write (OutFile, FreeSmall div 1024);
      writeln (OutFile, ' Kbytes');
      write (OutFile, 'Total big free blocks: ');
      write (OutFile, FreeBig div 1024);
      writeln (OutFile, ' Kbytes');
      write (OutFile, 'Other unused blocks: ');
      write (OutFile, Unused div 1024);
      writeln (OutFile, ' Kbytes');
      write (OutFile, 'Total overhead: ');
      write (OutFile, Overhead div 1024);
      writeln (OutFile, ' Kbytes');
    end;

    // custom memory manager information
    writeln (OutFile); // free line
    write (OutFile, 'Memory objects: ');
    writeln (OutFile, CurrFree - 1);
    for I := 1 to CurrFree - 1 do
    begin
      write (OutFile, I);
      write (OutFile, ') ');
      write (OutFile, IntToHex (
        Cardinal (ObjList [I]), 16));
      write (OutFile, ' - ');
      try
        Item := TObject(ObjList [I]);
        // code not reliable
        { write (OutFile, Item.ClassName);
        write (OutFile, ' (');
        write (OutFile, IntToStr (Item.InstanceSize));
        write (OutFile, ' bytes)');}
        // type info technique
        if PTypeInfo (Item.ClassInfo).Kind <> tkClass then
          write (OutFile, 'Not an object')
        else
        begin
          ptd := GetTypeData (PTypeInfo (Item.ClassInfo));
          // name, if a component
          ppi := GetPropInfo (
            PTypeInfo (Item.ClassInfo), 'Name');
          if ppi <> nil then
          begin
            write (OutFile, GetStrProp (Item, ppi));
            write (OutFile, ' :  ');
          end
          else
            write (OutFile, '(unnamed): ');
          write (OutFile, PTypeInfo (Item.ClassInfo).Name);
          write (OutFile, ' (');
          write (OutFile, ptd.ClassType.InstanceSize);
          write (OutFile, ' bytes)  -  In ');
          write (OutFile, ptd.UnitName);
          write (OutFile, '.dcu');
        end
      except
        on Exception do
          write (OutFile, 'Not an object');
      end;
      writeln (OutFile);
    end;
  finally
    CloseFile (OutFile);
  end;
end;

function NewGetMem (Size: Integer): Pointer;
begin
  Inc (GetMemCount);
  Result := OldMemMgr.GetMem (Size);
  AddToList (Result);
end;

function NewFreeMem (P: Pointer): Integer;
begin
  Inc (FreeMemCount);
  Result := OldMemMgr.FreeMem (P);
  RemoveFromList (P);
end;

function NewReallocMem (P: Pointer; Size: Integer): Pointer;
begin
  Inc (ReallocMemCount);
  Result := OldMemMgr.ReallocMem (P, Size);
  // remove older object
  RemoveFromList (P);
  // add new one
  AddToList (Result);
end;

const
  NewMemMgr: TMemoryManager = (
    GetMem: NewGetMem;
    FreeMem: NewFreeMem;
    ReallocMem: NewReallocMem);

initialization
  GetMemoryManager(OldMemMgr);
  SetMemoryManager(NewMemMgr);

finalization
  SetMemoryManager(OldMemMgr);
  if (GetMemCount - FreeMemCount) <> 0 then
    MessageBox (0, pChar ('Objects left: ' +
      IntToStr (GetMemCount - FreeMemCount)),
      'MemManager', mb_ok);
end.