memman.pas

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

unit MemMan;

interface

var
  GetMemCount, FreeMemCount,
    ReallocMemCount: Integer;

implementation

uses
  Windows, SysUtils;

var
  OldMemMgr: TMemoryManager;

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

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

function NewReallocMem (P: Pointer; Size: Integer): Pointer;
begin
  Inc (ReallocMemCount);
  Result := OldMemMgr.ReallocMem (P, Size);
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.