[½»Á÷] ¡¾×ªÌû¡¿delphiÖÐÈçºÎ¼ì²âÄÚ´æ͸¶(null)

uses
MemoryManager in '...pas',
Forms,
Main in 'Main.pas' {frmMain},
...
ÐÞÕý ×ÔDelphi Developer's Handbook¡­¡­
´úÂëÈçÏ¡­¡­
unit MemoryManager;
interface
var
GetMemCount: Integer = 0;
FreeMemCount: Integer = 0;
ReallocMemCount: Integer = 0;
var
mmPopupMsgDlg: Boolean = True;
mmSaveToLogFile: Boolean = True;
mmErrLogFile: string = '';
¡¡
procedure SnapToFile(Filename: string);
implementation
uses
Windows, SysUtils, TypInfo;
const
MaxCount = High(Word);
var
OldMemMgr: TMemoryManager;
ObjList: array[0..MaxCount] of Pointer;
FreeInList: 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 SnapToFile(Filename: string);
var
OutFile: TextFile;
I, CurrFree, BlockSize: Integer;
HeapStatus: THeapStatus;
Item: TObject;
ptd: PTypeData;
ppi: PPropInfo;
begin
AssignFile(OutFile, Filename);
try
if FileExists(Filename) then
Append(OutFile)
else
Rewrite(OutFile);
CurrFree := FreeInList;
HeapStatus := GetHeapStatus; { ¾Ö²¿¶Ñ״̬ }
with HeapStatus do
begin
writeln(OutFile, '--');
writeln(OutFile, DateTimeToStr(Now));
writeln(OutFile);
write(OutFile, '¿ÉÓõØÖ·¿Õ¼ä : ');
write(OutFile, TotalAddrSpace div 1024);
writeln(OutFile, ' ǧ×Ö½Ú');
write(OutFile, 'δÌá½»²¿·Ö : ');
write(OutFile, TotalUncommitted div 1024);
writeln(OutFile, ' ǧ×Ö½Ú');
write(OutFile, 'ÒÑÌá½»²¿·Ö : ');
write(OutFile, TotalCommitted div 1024);
writeln(OutFile, ' ǧ×Ö½Ú');
write(OutFile, '¿ÕÏв¿·Ö : ');
write(OutFile, TotalFree div 1024);
writeln(OutFile, ' ǧ×Ö½Ú');
write(OutFile, 'ÒÑ·ÖÅ䲿·Ö : ');
write(OutFile, TotalAllocated div 1024);
writeln(OutFile, ' ǧ×Ö½Ú');
write(OutFile, 'µØÖ·¿Õ¼äÔØÈë : ');
write(OutFile, TotalAllocated div (TotalAddrSpace div 100));
writeln(OutFile, '%');
write(OutFile, 'Õû¸ö С¿ÕÏÐÄÚ´æ¿é : ');
write(OutFile, FreeSmall div 1024);
writeln(OutFile, ' ǧ×Ö½Ú');
write(OutFile, 'Õû¸ö ´ó¿ÕÏÐÄÚ´æ¿é : ');
write(OutFile, FreeBig div 1024);
writeln(OutFile, ' ǧ×Ö½Ú');
write(OutFile, 'ÆäËüδÓÃÄÚ´æ¿é : ');
write(OutFile, Unused div 1024);
writeln(OutFile, ' ǧ×Ö½Ú');
write(OutFile, 'ÄÚ´æ¹ÜÀíÆ÷ºÄËð : ');
write(OutFile, Overhead div 1024);
writeln(OutFile, ' ǧ×Ö½Ú');
end;
writeln(OutFile);
write(OutFile, 'ÄÚ´æ¶ÔÏóÊýÄ¿ : ');
writeln(OutFile, CurrFree);
for I := 0 to CurrFree - 1 do
begin
write(OutFile, I: 4);
write(OutFile, ') ');
write(OutFile, IntToHex(Cardinal(ObjList[I]), 16));
write(OutFile, ' - ');
BlockSize := PDWORD(DWORD(ObjList[I]) - 4)^;
write(OutFile, BlockSize: 4);
write(OutFile, '($' + IntToHex(BlockSize, 4) + ')×Ö½Ú');
write(OutFile, ' - ');
try
Item := TObject(ObjList[I]);
// code not reliable
{ write (OutFile, Item.ClassName);
write (OutFile, ' (');
write (OutFile, IntToStr (Item.InstanceSize));
write (OutFile, ' bytes)');}
// type info technique

if PTypeInfo(Item.ClassInfo).Kind <> tkClass then
write(OutFile, '²»ÊǶÔÏó')
else
begin
ptd := GetTypeData(PTypeInfo(Item.ClassInfo));
// name, Èç¹ûÊÇTComponent
ppi := GetPropInfo(PTypeInfo(Item.ClassInfo), 'Name');
if ppi <> nil then
begin
write(OutFile, GetStrProp(Item, ppi));
write(OutFile, ' : ');
end
else
write(OutFile, '(δÃüÃû): ');
write(OutFile, PTypeInfo(Item.ClassInfo).Name);
write(OutFile, ' (');
write(OutFile, ptd.ClassType.InstanceSize);
write(OutFile, ' ×Ö½Ú) - In ');
write(OutFile, ptd.UnitName);
write(OutFile, '.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
begin
if mmPopupMsgDlg then
MessageBox(0, PChar(Format('³öÏÖ%d´¦Äڴ橶´: ',
[GetMemCount - FreeMemCount])), 'ÄÚ´æ¹ÜÀí¼à¶½ Æ÷', mb_ok);
if mmErrLogFile = '' then
mmErrLogFile := ExtractFileDir(ParamStr(0)) + '.Log';
if mmSaveToLogFile then
SnapToFile(mmErrLogFile);
end;
end.