内存泄漏
发信人: flier (flier), 信区: Delphi
标 题:delphi中如何检测内存泄露(null)
试试偶这个内存使用监视器:)
用法非常简单，在你的project source里把
应用这个单元的那句放到最前，如
...
uses
MemoryManager in '..\Common\MemoryManager.pas',
Forms,
Main in 'Main.pas' {frmMain},
...
修改自Delphi Developer's Handbook……
代码如下……
unit MemoryManager ;
interface
var
GetMemCount : Integer = 0 ;
FreeMemCount : Integer = 0 ;
ReallocMemCount : Integer = 0 ;
var
mmPopupMsgDlg : Boolean = True ;
mmSaveToLogFile : Boolean = True ;
mmErrLogFile : string = '' ;
procedure SnapToFile ( Filename : string );
implementation
uses
Windows , SysUtils , TypInfo ;
const
MaxCount = High ( Word );
var
OldMemMgr : TMemoryManager ;
ObjList : array [ 0 .. MaxCount ] of Pointer ;
FreeInList : Integer = 0 ;
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 SnapToFile ( Filename : string );
var
OutFile : TextFile ;
I , CurrFree , BlockSize : Integer ;
HeapStatus : THeapStatus ;
Item : TObject ;
ptd : PTypeData ;
ppi : PPropInfo ;
begin
AssignFile ( OutFile , Filename );
try
if FileExists ( Filename ) then
Append ( OutFile )
else
Rewrite ( OutFile );
CurrFree := FreeInList ;
HeapStatus := GetHeapStatus ; { 局部堆状态 }
with HeapStatus do
begin
writeln ( OutFile , '--' );
writeln ( OutFile , DateTimeToStr ( Now ));
writeln ( OutFile );
write ( OutFile , ' 可用地址空间 : ' );
write ( OutFile , TotalAddrSpace div 1024 );
writeln ( OutFile , ' 千字节 ' );
write ( OutFile , ' 未提交部分 : ' );
write ( OutFile , TotalUncommitted div 1024 );
writeln ( OutFile , ' 千字节 ' );
write ( OutFile , ' 已提交部分 : ' );
write ( OutFile , TotalCommitted div 1024 );
writeln ( OutFile , ' 千字节 ' );
write ( OutFile , ' 空闲部分 : ' );
write ( OutFile , TotalFree div 1024 );
writeln ( OutFile , ' 千字节 ' );
write ( OutFile , ' 已分配部分 : ' );
write ( OutFile , TotalAllocated div 1024 );
writeln ( OutFile , ' 千字节 ' );
write ( OutFile , ' 地址空间载入 : ' );
write ( OutFile , TotalAllocated div ( TotalAddrSpace div 100 ));
writeln ( OutFile , '%' );
write ( OutFile , ' 全部小空闲内存块 : ' );
write ( OutFile , FreeSmall div 1024 );
writeln ( OutFile , ' 千字节 ' );
write ( OutFile , ' 全部大空闲内存块 : ' );
write ( OutFile , FreeBig div 1024 );
writeln ( OutFile , ' 千字节 ' );
write ( OutFile , ' 其它未用内存块 : ' );
write ( OutFile , Unused div 1024 );
writeln ( OutFile , ' 千字节 ' );
write ( OutFile , ' 内存管理器消耗 : ' );
write ( OutFile , Overhead div 1024 );
writeln ( OutFile , ' 千字节 ' );
end ;
writeln ( OutFile );
write ( OutFile , ' 内存对象数目 : ' );
writeln ( OutFile , CurrFree );
for I := 0 to CurrFree - 1 do
begin
write ( OutFile , I : 4 );
write ( OutFile , ') ' );
write ( OutFile , IntToHex ( Cardinal ( ObjList [ I ]), 16 ));
write ( OutFile , ' - ' );
BlockSize := PDWORD ( DWORD ( ObjList [ I ]) - 4 )^;
write ( OutFile , BlockSize : 4 );
write ( OutFile , '($' + IntToHex ( BlockSize , 4 ) + ') 字节 ' );
write ( OutFile , ' - ' );
try
Item := TObject ( ObjList [ I ]);
// code not reliable
{ write (OutFile, Item.ClassName);
write (OutFile, ' (');
write (OutFile, IntToStr (Item.InstanceSize));
write (OutFile, ' bytes)');}
// type info technique
if PTypeInfo ( Item . ClassInfo ). Kind <> tkClass then
write ( OutFile , ' 不是对象 ' )
else
begin
ptd := GetTypeData ( PTypeInfo ( Item . ClassInfo ));
// name, 如果是 TComponent
ppi := GetPropInfo ( PTypeInfo ( Item . ClassInfo ), 'Name' );
if ppi <> nil then
begin
write ( OutFile , GetStrProp ( Item , ppi ));
write ( OutFile , ' : ' );
end
else
write ( OutFile , '( 未命名 ): ' );
write ( OutFile , PTypeInfo ( Item . ClassInfo ). Name );
write ( OutFile , ' (' );
write ( OutFile , ptd . ClassType . InstanceSize );
write ( OutFile , ' 字节 ) - In ' );
write ( OutFile , ptd . UnitName );
write ( OutFile , '.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 ;
const
NewMemMgr : TMemoryManager = (
GetMem : NewGetMem ;
FreeMem : NewFreeMem ;
ReallocMem : NewReallocMem );
initialization
GetMemoryManager ( OldMemMgr );
SetMemoryManager ( NewMemMgr );
finalization
SetMemoryManager ( OldMemMgr );
if ( GetMemCount - FreeMemCount ) <> 0 then
begin
if mmPopupMsgDlg then
MessageBox ( 0 , PChar ( Format ( ' 出现 %d 处内存漏洞 : ' ,
[ GetMemCount - FreeMemCount ])), ' 内存管理监视器 ' , mb_ok );
if mmErrLogFile = '' then
mmErrLogFile := ExtractFileDir ( ParamStr ( 0 )) + '\Memory.Log' ;
if mmSaveToLogFile then
SnapToFile ( mmErrLogFile );
end ;
end .