مدير الذاكرة دلفي

وحدة إدارة الذاكرة؛

واجهة

PROcedure SnapCurrMemStatToFile(Filename: string);

تطبيق

الاستخدامات

ويندوز، سيسوتيلس، تايبينفو؛

ثابت

MaxCount = High(Word);

فار

OldMemMgr: TMemoryManager;

ObjList: صفيف [0...MaxCount] من المؤشر؛

FreeInList: عدد صحيح = 0؛

GetMemCount: عدد صحيح = 0؛

FreeMemCount: عدد صحيح = 0؛

ReallocMemCount: عدد صحيح = 0؛

الإجراء AddToList(P: Pointer);

يبدأ

إذا FreeInList > High(ObjList) إذن

يبدأ

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

مخرج؛

نهاية؛

ObjList[FreeInList] := P;

Inc(FreeInList);

نهاية؛

الإجراء RemoveFromList(P: Pointer);

فار

أنا: عدد صحيح؛

يبدأ

لأني := 0 إلى FreeInList - 1 do

إذا ObjList[I] = P إذن

يبدأ

Dec(FreeInList);

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

مخرج؛

نهاية؛

نهاية؛

الإجراء SnapCurrMemStatToFile(Filename: string);

ثابت

FIELD_WIDTH = 20؛

فار

الملف الخارجي: ملف نصي؛

أنا، CurrFree، BlockSize: عدد صحيح؛

هيابستاتوس: ثيبستاتوس؛

العنصر: TObject؛

ptd: PTypeData;

نقطة في البوصة: PPPropInfo؛

إخراج الإجراء (النص: سلسلة؛ القيمة: عدد صحيح)؛

يبدأ

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

نهاية؛

يبدأ

AssignFile(OutFile, Filename);

يحاول

إذا FileExists(اسم الملف) ثم

يبدأ

إلحاق (OutFile)؛

Writeln(OutFile);

نهاية

آخر

إعادة كتابة(OutFile);

CurrFree := FreeInList;

HeapStatus := GetHeapStatus; {المنتجات }

مع HeapStatus تفعل ذلك

يبدأ

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

Writeln(OutFile);

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

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

Output('已提交部分 :', TotalCommitted);

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

Output('已分配部分 :', TotalAllocated);

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

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

Output('其它未用内存块 :', غير مستخدم);

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

Writeln(OutFile, '地址空间载入 : ': FIELD_WIDTH, TotalAllocated div (TotalAddrSpace div 100), '%');

نهاية؛

Writeln(OutFile);

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

لأني := 0 إلى CurrFree - 1 افعل

يبدأ

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

إذا كان PTypeInfo(Item.ClassInfo).Kind <> tkClass ثم { اكتب تقنية المعلومات }

الكتابة (OutFile، '不是对象')

آخر

يبدأ

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

نقطة في البوصة := GetPropInfo(PTypeInfo(Item.ClassInfo), 'Name'); {مكون TComponent}

إذا مؤشر أسعار المنتجين <> لا شيء ثم

يبدأ

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

اكتب (OutFile، ' : ')؛

نهاية

آخر

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

الكتابة (OutFile، Item.ClassName، '('، ptd.ClassType.InstanceSize،

' 字节) - في '، ptd.UnitName، '.pas')؛

نهاية

يستثني

على استثناء القيام به

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

نهاية؛

writeln(OutFile);

نهاية؛

أخيراً

CloseFile(OutFile);

نهاية؛

نهاية؛

وظيفة NewGetMem(الحجم: عدد صحيح): المؤشر؛

يبدأ

Inc(GetMemCount);

النتيجة := OldMemMgr.GetMem(Size);

AddToList(Result);

نهاية؛

وظيفة NewFreeMem(P: المؤشر): عدد صحيح؛

يبدأ

Inc(FreeMemCount);

النتيجة := OldMemMgr.FreeMem(P);

RemoveFromList(P);

نهاية؛

وظيفة NewReallocMem(P: المؤشر؛ الحجم: عدد صحيح): المؤشر؛

يبدأ

Inc(ReallocMemCount);

النتيجة := OldMemMgr.ReallocMem(P, Size);

RemoveFromList(P);

AddToList(Result);

نهاية؛

ثابت

NewMemMgr: TMemoryManager = (

GetMem: NewGetMem;

FreeMem: NewFreeMem؛

ReallocMem: NewReallocMem);

التهيئة

GetMemoryManager(OldMemMgr);

SetMemoryManager(NewMemMgr);

وضع اللمسات النهائية

SetMemoryManager(OldMemMgr);

إذا (GetMemCount - FreeMemCount) <> 0 ثم

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

نهاية.