内存泄漏

发信人: 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 .