The following are a couple of tips that can be usefull when fixing leaks in an application :
下面的这些技巧对于修复应用程序的内存泄漏非常有用：
* First just launch the app and then close it. If even this action generates leaks, fix those leaks first. Only after the main leaks are fixed, you should go into specific functionality areas of the application.
* Go for the biggest classes first - if you see a TMyFom <class> leaking, try to fix this one first instead of going after a tiny TFont class. Since a Form will usually contain a lot of other classes, with one shot you will have fixed a lot of contained leaks.
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 Output(Text: string; Value: integer); begin Writeln(OutFile, Text: FIELD_WIDTH, Value div 1024, ' KB(', Value, ' Byte)'); end;
begin AssignFile(OutFile, Filename); try if FileExists(Filename) then begin Append(OutFile); Writeln(OutFile); end else Rewrite(OutFile); CurrFree := FreeInList; HeapStatus := GetHeapStatus; { 局部堆状态 } with HeapStatus do begin Writeln(OutFile, '===== ', ExtractFileName(ParamStr(0)), ',', DateTimeToStr(Now), ' ====='); Writeln(OutFile); Output('可用地址空间 : ', TotalAddrSpace); Output('未提交部分 : ', TotalUncommitted); Output('已提交部分 : ', TotalCommitted); Output('空闲部分 : ', TotalFree); Output('已分配部分 : ', TotalAllocated); Output('全部小空闲内存块 : ', FreeSmall); Output('全部大空闲内存块 : ', FreeBig); Output('其它未用内存块 : ', Unused); Output('内存管理器消耗 : ', Overhead); Writeln(OutFile, '地址空间载入 : ': FIELD_WIDTH, TotalAllocated div (TotalAddrSpace div 100), '%'); end; Writeln(OutFile); Writeln(OutFile, Format('当前出现 %d 处内存漏洞 :', [GetMemCount - FreeMemCount])); for I := 0 to CurrFree - 1 do begin Write(OutFile, I: 4, ') ', IntToHex(Cardinal(ObjList[I]), 16), ' - '); BlockSize := PDWORD(DWORD(ObjList[I]) - 4)^; Write(OutFile, BlockSize: 4, '($' + IntToHex(BlockSize, 4) + ')字节', ' - '); try Item := TObject(ObjList[I]); if PTypeInfo(Item.ClassInfo).Kind <> tkClass then { type info technique } write(OutFile, '不是对象') else begin ptd := GetTypeData(PTypeInfo(Item.ClassInfo)); ppi := GetPropInfo(PTypeInfo(Item.ClassInfo), 'Name'); { 如果是TComponent } if ppi <> nil then begin write(OutFile, GetStrProp(Item, ppi)); write(OutFile, ' : '); end else write(OutFile, '(未命名): '); Write(OutFile, Item.ClassName, ' (', ptd.ClassType.InstanceSize, ' 字节) - In ', ptd.UnitName, '.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;
