unit unitMemoryManager;

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.