一個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.