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.