一个DELPHI的MemoryManager

unit MemoryManager;

interface

procedure SnapCurrMemStatToFile(Filename: string);

implementation

uses
  Windows, SysUtils, TypInfo;

const
  MaxCount = High(Word);

var
  OldMemMgr: TMemoryManager;
  ObjList: array[0..MaxCount] of Pointer;
  FreeInList: Integer = 0;
  GetMemCount: Integer = 0;
  FreeMemCount: Integer = 0;
  ReallocMemCount: Integer = 0;

procedure AddToList(P: Pointer);
begin
  if FreeInList > High(ObjList) then
  begin
    MessageBox(0, '内存管理监视器指针列表溢出，请增大列表项数！', '内存管理监视器', mb_ok);
    Exit;
  end;
  ObjList[FreeInList] := P;
  Inc(FreeInList);
end;

procedure RemoveFromList(P: Pointer);
var
  I: Integer;
begin
  for I := 0 to FreeInList - 1 do
    if ObjList[I] = P then
    begin
      Dec(FreeInList);
      Move(ObjList[I + 1], ObjList[I], (FreeInList - I) * SizeOf(Pointer));
      Exit;
    end;
end;

procedure SnapCurrMemStatToFile(Filename: string);
const
  FIELD_WIDTH = 20;
var
  OutFile: TextFile;
  I, CurrFree, BlockSize: Integer;
  HeapStatus: THeapStatus;
  Item: TObject;
  ptd: PTypeData;
  ppi: PPropInfo;

  procedure Output(Text: string; Value: integer);
  begin
    Writeln(OutFile, Text: FIELD_WIDTH, Value div 1024, ' KB(', Value, ' Byte)');
  end;

begin
  AssignFile(OutFile, Filename);
  try
    if FileExists(Filename) then
    begin
      Append(OutFile);
      Writeln(OutFile);
    end
    else
      Rewrite(OutFile);
    CurrFree := FreeInList;
    HeapStatus := GetHeapStatus; { 局部堆状态 }
    with HeapStatus do
    begin
      Writeln(OutFile, '===== ', ExtractFileName(ParamStr(0)), ',', DateTimeToStr(Now), ' =====');
      Writeln(OutFile);
      Output('可用地址空间 : ', TotalAddrSpace);
      Output('未提交部分 : ', TotalUncommitted);
      Output('已提交部分 : ', TotalCommitted);
      Output('空闲部分 : ', TotalFree);
      Output('已分配部分 : ', TotalAllocated);
      Output('全部小空闲内存块 : ', FreeSmall);
      Output('全部大空闲内存块 : ', FreeBig);
      Output('其它未用内存块 : ', Unused);
      Output('内存管理器消耗 : ', Overhead);
      Writeln(OutFile, '地址空间载入 : ': FIELD_WIDTH, TotalAllocated div (TotalAddrSpace div 100), '%');
    end;
    Writeln(OutFile);
    Writeln(OutFile, Format('当前出现 %d 处内存漏洞 :', [GetMemCount - FreeMemCount]));
    for I := 0 to CurrFree - 1 do
    begin
      Write(OutFile, I: 4, ') ', IntToHex(Cardinal(ObjList[I]), 16), ' - ');
      BlockSize := PDWORD(DWORD(ObjList[I]) - 4)^;
      Write(OutFile, BlockSize: 4, '($' + IntToHex(BlockSize, 4) + ')字节', ' - ');
      try
        Item := TObject(ObjList[I]);
        if PTypeInfo(Item.ClassInfo).Kind <> tkClass then { type info technique }
          write(OutFile, '不是对象')
        else
        begin
          ptd := GetTypeData(PTypeInfo(Item.ClassInfo));
          ppi := GetPropInfo(PTypeInfo(Item.ClassInfo), 'Name'); { 如果是TComponent }
          if ppi <> nil then
          begin
            write(OutFile, GetStrProp(Item, ppi));
            write(OutFile, ' : ');
          end
          else
            write(OutFile, '(未命名): ');
          Write(OutFile, Item.ClassName, ' (', ptd.ClassType.InstanceSize,
            ' 字节) - In ', ptd.UnitName, '.pas');
        end
      except
        on Exception do
          write(OutFile, '不是对象');
      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);
  RemoveFromList(P);
  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
    SnapCurrMemStatToFile(ExtractFileDir(ParamStr(0)) + '\Memory.Log');
end.

本文地址：http://com.8s8s.com/it/it5201.htm