유닛 메모리매니저;
인터페이스
PRocedure SnapCurrMemStatToFile(파일 이름: 문자열);
구현
용도
윈도우, SysUtils, TypInfo;
const
MaxCount = 높음(워드);
var
OldMemMgr: TMemoryManager;
ObjList: 포인터의 배열[0..MaxCount];
FreeInList: 정수 = 0;
GetMemCount: 정수 = 0;
FreeMemCount: 정수 = 0;
ReallocMemCount: 정수 = 0;
프로시저 AddToList(P: 포인터);
시작하다
FreeInList > High(ObjList)이면
시작하다
MessageBox(0, '内存管理监视器指针列表溢출, 请增大列表项数!', '内存管理监视器', mb_ok);
출구;
끝;
ObjList[FreeInList] := P;
Inc(FreeInList);
끝;
절차 RemoveFromList(P: 포인터);
var
I: 정수;
시작하다
for I := 0에서 FreeInList - 1 do
ObjList[I] = P이면
시작하다
12월(FreeInList);
Move(ObjList[I + 1], ObjList[I], (FreeInList - I) * SizeOf(포인터));
출구;
끝;
끝;
절차 SnapCurrMemStatToFile(파일 이름: 문자열);
const
FIELD_WIDTH = 20;
var
아웃파일: 텍스트파일;
I, CurrFree, BlockSize: 정수;
힙상태: THeapStatus;
항목: TObject;
ptd: PTypeData;
ppi: PPropInfo;
절차 출력(텍스트: 문자열; 값: 정수);
시작하다
Writeln(OutFile, Text: FIELD_WIDTH, Value div 1024, ' KB(', Value, ' Byte)');
끝;
시작하다
AssignFile(OutFile, 파일명);
노력하다
if FileExists(파일 이름) then
시작하다
추가(파일 출력);
Writeln(OutFile);
끝
또 다른
다시 쓰기(파일 출력);
CurrFree := FreeInList;
힙상태 := GetHeapStatus; { 局부堆状态 }
HeapStatus를 사용하면
시작하다
Writeln(OutFile, '===== ', ExtractFileName(ParamStr(0)), ',', DateTimeToStr(Now), ' =====');
Writeln(OutFile);
Output('可용지址공간공간 : ', TotalAddrSpace);
Output('未提交부분분 : ', TotalUncommitted);
Output('已提交부분분 : ', TotalCommitted);
Output('공중부분 : ', TotalFree);
Output('已分配part分 : ', TotalAllocation);
Output('전체 부분소공구内存块 : ', FreeSmall);
Output('전체부대공영闲内存块 : ', FreeBig);
Output('其它未사용内存块 : ', 사용되지 않음);
Output('内存管리器消耗 : ', 오버헤드);
Writeln(OutFile, '地址空间载入 : ': FIELD_WIDTH, TotalAllocation div (TotalAddrSpace div 100), '%');
끝;
Writeln(OutFile);
Writeln(OutFile, Format('当前漏%d 处内存漏洞 :', [GetMemCount - FreeMemCount]));
I의 경우 := 0에서 CurrFree - 1 do
시작하다
Write(OutFile, I: 4, ') ', IntToHex(Cardinal(ObjList[I]), 16), ' - ');
BlockSize := PDWORD(DWORD(ObjList[I]) - 4)^;
Write(OutFile, BlockSize: 4, '($' + IntToHex(BlockSize, 4) + ')字节', ' - ');
노력하다
항목 := TObject(ObjList[I]);
if PTypeInfo(Item.ClassInfo).Kind <> tkClass then { 유형 정보 기술 }
write(OutFile, '不是对象')
또 다른
시작하다
ptd := GetTypeData(PTypeInfo(Item.ClassInfo));
ppi := GetPropInfo(PTypeInfo(Item.ClassInfo), '이름'); { 如果是TComponent }
ppi <> nil이면
시작하다
write(OutFile, GetStrProp(Item, ppi));
write(OutFile, ' : ');
끝
또 다른
write(OutFile, '(이름): ');
쓰기(OutFile, Item.ClassName, ' (', ptd.ClassType.InstanceSize,
' 字节) - ', ptd.UnitName, '.pas');
끝
제외하고
예외적으로
write(OutFile, '不是对象');
끝;
writeln(OutFile);
끝;
마지막으로
CloseFile(OutFile);
끝;
끝;
function NewGetMem(Size: Integer): 포인터;
시작하다
Inc(GetMemCount);
결과 := OldMemMgr.GetMem(크기);
AddToList(결과);
끝;
function NewFreeMem(P: 포인터): 정수;
시작하다
Inc(FreeMemCount);
결과 := OldMemMgr.FreeMem(P);
RemoveFromList(P);
끝;
function NewReallocMem(P: 포인터; 크기: 정수): 포인터;
시작하다
Inc(ReallocMemCount);
결과 := OldMemMgr.ReallocMem(P, 크기);
RemoveFromList(P);
AddToList(결과);
끝;
const
NewMemMgr: TMemoryManager = (
GetMem: NewGetMem;
FreeMem: NewFreeMem;
ReallocMem: NewReallocMem);
초기화
GetMemoryManager(OldMemMgr);
SetMemoryManager(NewMemMgr);
마무리
SetMemoryManager(OldMemMgr);
if (GetMemCount - FreeMemCount) <> 0 then
SnapCurrMemStatToFile(ExtractFileDir(ParamStr(0)) + '/Memory.Log');
끝.