Un administrador de memoria DELPHI

unidad MemoryManager;

interfaz

Procedimiento SnapCurrMemStatToFile(Nombre de archivo: cadena);

implementación

usos

Windows, SysUtils, TypInfo;

constante

MaxCount = Alto (Palabra);

var

OldMemMgr: TMemoryManager;

ObjList: matriz [0..MaxCount] de puntero;

FreeInList: Entero = 0;

GetMemCount: Entero = 0;

FreeMemCount: Entero = 0;

ReallocMemCount: Entero = 0;

procedimiento AddToList(P: Puntero);

comenzar

si FreeInList > Alto (ObjList) entonces

comenzar

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

Salida;

fin;

ListaObj[FreeInList] := P;

Inc(LibreEnLista);

fin;

procedimiento RemoveFromList(P: Puntero);

var

I: Entero;

comenzar

para I: = 0 a FreeInList - 1 hacer

si ObjList[I] = P entonces

comenzar

Dec(LibreEnLista);

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

Salida;

fin;

fin;

procedimiento SnapCurrMemStatToFile (nombre de archivo: cadena);

constante

ANCHO_CAMPO = 20;

var

OutFile: Archivo de texto;

I, CurrFree, Tamaño de bloque: entero;

Estado del montón: THeapStatus;

Artículo: TObjeto;

ptd: PTypeData;

ppp: PPropInfo;

procedimiento Salida (Texto: cadena; Valor: entero);

comenzar

Writeln(OutFile, Texto: FIELD_WIDTH, Valor div 1024, ' KB(', Valor, ' Byte)');

fin;

comenzar

AssignFile(OutFile, nombre de archivo);

intentar

si FileExists (nombre de archivo) entonces

comenzar

Agregar(OutFile);

Writeln(OutFile);

fin

demás

Reescribir (OutFile);

CurrFree := LibreEnLista;

Estado del montón := Obtener estado del montón; { 局部堆状态 }

con HeapStatus hacer

comenzar

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

Writeln(OutFile);

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

Salida ('未提交部分: ', Total no comprometido);

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

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

Salida('已分配部分: ', TotalAsignado);

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

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

Salida('其它未用内存块: ', Sin usar);

Salida('内存管理器消耗: ', Gastos generales);

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

fin;

Writeln(OutFile);

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

para I: = 0 a CurrFree - 1 hacer

comenzar

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

Tamaño de bloque := PDWORD(DWORD(ObjList[I]) - 4)^;

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

intentar

Artículo := TObject(ObjList[I]);

si PTypeInfo(Item.ClassInfo).Kind <> tkClass entonces {escriba técnica de información}

escribir(OutFile, '不是对象')

demás

comenzar

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

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

si ppi <> nulo entonces

comenzar

escribir(OutFile, GetStrProp(Artículo, ppi));

escribir(OutFile, ' : ');

fin

demás

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

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

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

fin

excepto

en excepción hacer

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

fin;

writeln(OutFile);

fin;

finalmente

CerrarArchivo(OutFile);

fin;

fin;

función NewGetMem (Tamaño: Entero): Puntero;

comenzar

Inc(GetMemCount);

Resultado := OldMemMgr.GetMem(Tamaño);

AddToList(Resultado);

fin;

función NewFreeMem(P: Puntero): Entero;

comenzar

Inc(FreeMemCount);

Resultado := OldMemMgr.FreeMem(P);

Eliminar de la lista (P);

fin;

función NewReallocMem(P: Puntero; Tamaño: Entero): Puntero;

comenzar

Inc(ReallocMemCount);

Resultado := OldMemMgr.ReallocMem(P, Tamaño);

Eliminar de la lista (P);

AddToList(Resultado);

fin;

constante

NuevoMemMgr: TMemoryManager = (

GetMem: NuevoGetMem;

FreeMem: NuevoFreeMem;

ReallocMem: NuevoReallocMem);

inicialización

GetMemoryManager(OldMemMgr);

SetMemoryManager(NuevoMemMgr);

finalización

SetMemoryManager(OldMemMgr);

si (GetMemCount - FreeMemCount) <> 0 entonces

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

fin.