Ein DELPHI MemoryManager

Unit MemoryManager;

Schnittstelle

PROcedure SnapCurrMemStatToFile(Filename: string);

Durchführung

verwendet

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);

beginnen

wenn FreeInList > High(ObjList), dann

beginnen

MessageBox(0, '内存管理监视器指针列表溢出，请增大列表项数！', '内存管理监视器', mb_ok);

Ausfahrt;

Ende;

ObjList[FreeInList] := P;

Inc(FreeInList);

Ende;

procedure RemoveFromList(P: Pointer);

var

I: Ganzzahl;

beginnen

for I := 0 to FreeInList - 1 do

wenn ObjList[I] = P dann

beginnen

Dec(FreeInList);

Move(ObjList[I + 1], ObjList[I], (FreeInList - I) * SizeOf(Pointer));

Ausfahrt;

Ende;

Ende;

procedure SnapCurrMemStatToFile(Filename: string);

const

FIELD_WIDTH = 20;

var

OutFile: TextFile;

I, CurrFree, BlockSize: Integer;

HeapStatus: THeapStatus;

Artikel: TObject;

ptd: PTypeData;

ppi: PPropInfo;

procedure Output(Text: string; Wert: integer);

beginnen

Writeln(OutFile, Text: FIELD_WIDTH, Value div 1024, ' KB(', Value, ' Byte)');

Ende;

beginnen

AssignFile(OutFile, Dateiname);

versuchen

wenn FileExists(Dateiname), dann

beginnen

Append(OutFile);

Writeln(OutFile);

Ende

anders

Rewrite(OutFile);

CurrFree := FreeInList;

HeapStatus := GetHeapStatus; {局部堆状态}

mit HeapStatus tun

beginnen

Writeln(OutFile, '===== ', ExtractFileName(ParamStr(0)), ',', DateTimeToStr(Now), ' =====');

Writeln(OutFile);

Output('可用地址空间 : ', TotalAddrSpace);

Output('未提交部分: ', TotalUncommitted);

Output('Ergebnis: ', TotalCommitted);

Output('空闲部分 : ', TotalFree);

Output('Ergebnis: ', TotalAllocated);

Output('全部小空闲内存块 : ', FreeSmall);

Output('全部大空闲内存块 : ', FreeBig);

Output('其它未用内存块 : ', Unused);

Output('内存管理器消耗 : ', Overhead);

Writeln(OutFile, 'Verwaltungsdatei : ': FIELD_WIDTH, TotalAllocated div (TotalAddrSpace div 100), '%');

Ende;

Writeln(OutFile);

Writeln(OutFile, Format('当前出现 %d 处内存漏洞 :', [GetMemCount - FreeMemCount]));

für I := 0 bis CurrFree - 1 do

beginnen

Write(OutFile, I: 4, ') ', IntToHex(Cardinal(ObjList[I]), 16), ' - ');

BlockSize := PDWORD(DWORD(ObjList[I]) - 4)^;

Write(OutFile, BlockSize: 4, '($' + IntToHex(BlockSize, 4) + ')字节', ' - ');

versuchen

Item := TObject(ObjList[I]);

if PTypeInfo(Item.ClassInfo).Kind <> tkClass then { Typ-Info-Technik }

write(OutFile, '不是对象')

anders

beginnen

ptd := GetTypeData(PTypeInfo(Item.ClassInfo));

ppi := GetPropInfo(PTypeInfo(Item.ClassInfo), 'Name'); { 如果是TComponent }

Wenn ppi <> Null, dann

beginnen

write(OutFile, GetStrProp(Item, ppi));

write(OutFile, ' : ');

Ende

anders

write(OutFile, '(未命名): ');

Write(OutFile, Item.ClassName, ' (', ptd.ClassType.InstanceSize,

' 字节) - In ', ptd.UnitName, '.pas');

Ende

außer

ausnahmsweise tun

write(OutFile, '不是对象');

Ende;

writeln(OutFile);

Ende;

Endlich

CloseFile(OutFile);

Ende;

Ende;

Funktion NewGetMem(Size: Integer): Pointer;

beginnen

Inc(GetMemCount);

Ergebnis := OldMemMgr.GetMem(Size);

AddToList(Ergebnis);

Ende;

Funktion NewFreeMem(P: Pointer): Integer;

beginnen

Inc(FreeMemCount);

Ergebnis := OldMemMgr.FreeMem(P);

RemoveFromList(P);

Ende;

function NewReallocMem(P: Pointer; Size: Integer): Pointer;

beginnen

Inc(ReallocMemCount);

Ergebnis := OldMemMgr.ReallocMem(P, Size);

RemoveFromList(P);

AddToList(Ergebnis);

Ende;

const

NewMemMgr: TMemoryManager = (

GetMem: NewGetMem;

FreeMem: NewFreeMem;

ReallocMem: NewReallocMem);

Initialisierung

GetMemoryManager(OldMemMgr);

SetMemoryManager(NewMemMgr);

Finalisierung

SetMemoryManager(OldMemMgr);

if (GetMemCount - FreeMemCount) <> 0 dann

SnapCurrMemStatToFile(ExtractFileDir(ParamStr(0)) + '/Memory.Log');

Ende.