Writer:flier (flier)

引用:

标 题:delphi中如何检测内存泄露(null)

试试偶这个内存使用监视器:)

用法非常简单，在你的project source里把

应用这个单元的那句放到最前，如

复制内容到剪贴板

代码:

...

uses

MemoryManager in '...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, &#39;不是对象&#39;)

else

begin

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

// name, 如果是TComponent

ppi := GetPropInfo(PTypeInfo(Item.ClassInfo), &#39;Name&#39;);

if ppi <> nil then

begin

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

write(OutFile, &#39; : &#39;);

end

else

write(OutFile, &#39;(未命名): &#39;);

write(OutFile, PTypeInfo(Item.ClassInfo).Name);

write(OutFile, &#39; (&#39;);

write(OutFile, ptd.ClassType.InstanceSize);

write(OutFile, &#39; 字节) - In &#39;);

write(OutFile, ptd.UnitName);

write(OutFile, &#39;.pas&#39;);

end

except

on Exception do

write(OutFile, &#39;不是对象&#39;);

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(&#39;出现%d处内存漏洞: &#39;,

[GetMemCount - FreeMemCount])), &#39;内存管理监视器&#39;, mb_ok);

if mmErrLogFile = &#39;&#39; then

mmErrLogFile := ExtractFileDir(ParamStr(0)) + &#39;.Log&#39;;

if mmSaveToLogFile then

SnapToFile(mmErrLogFile);

end;

end.

据说是修正Delphi VCL内存泄漏用的   
   
{ 需要修改Forms.pas单元或这是其他单元中相应的代码 }

复制内容到剪贴板

代码:

// While discussing one memory leak in Russian FidoNet Delphi conference, it

// seemed to turn out that Object Instancing is subject to be buggy.

// I tried to mend those problem. Thanx to anyone, who's posts i used in this patch

// These are changes for forms.pas (Delphi 5 and prior) or classes.pas (Delphi 6 or above)

// Made by [email]Arioch@nm.ru[/email]

// PS: I wonder if publishing bugfixes to Borland's RTL violates its licanse, since bugfix

// is certainly a 'derived software'

// Resume of trouble:

// Seems that MakeObjInstance been made in Delphi 1, where it tried to mimic MS-DOS styled

// chained lists (file handles, fcbs, mcbs, disk buffers, etc...)

// But the job was not finished and so there is an issues:

// 1) if one uses dll's with forms, Delphi leaks 4kb of RAM at each freeing of the last form,

// created in DLL.

// 2) more generic: RAM will leak at each subsequent call to MakeObjInstance having (mod 314 = 0)

// i hope it will fix it.

const

InstanceCount = 313;

{ Object instance management }

type

PObjectInstance = ^TObjectInstance;

TObjectInstance = packed record

Code: Byte;

Offset: Integer;

case Integer of

0: (Next: PObjectInstance);

1: (Method: TWndMethod);

end;

type

PInstanceBlock = ^TInstanceBlock;

TInstanceBlock = packed record

Next: PInstanceBlock;

Counter: word; //Arioch - aligning WndProcPtr to 32-bit boundary.

// We sure can add this after Instances to keep binary compatibility,

// but possibly loose in spead since no boundary for pointer and since

// counter would not be cached in CPU when reading record header

// after this addition record size is 4094 bytes. There are 2 bytes more for a i386 page

Code: array[1..2] of Byte;

WndProcPtr: Pointer;

Instances: array[0..InstanceCount] of TObjectInstance;

end;

var

InstBlockList: PInstanceBlock;

InstFreeList: PObjectInstance;

InstCritSect: TCriticalSection; //Arioch: multi-thread blocker

　

implementation

uses SyncObjs, //Arioch: add the rest of uses clause.... Need TCriticalSection from unit.

function CalcJmpOffset(Src, Dest: Pointer): Longint;

begin

Result := Longint(Dest) - (Longint(Src) + 5);

end;

function CalcJmpTarget(Src: Pointer, Offs: integer): Pointer; //Arioch

begin

Integer(Result) := Offs + (Longint(Src) + 5);

end;

function GetInstanceBlock(ObjectInstance: Pointer): PInstanceBlock; //Arioch

var oi: PObjectInstance absolute ObjectInstance; //i'mm to lazy to use with and typecast :-)

begin Result := nil; if ObjectInstance = nil then exit;

Pointer(Result) := CalcJmpTarget(ObjectInstance, oi^.Offset)

- sizeof(TInstanceBlock.Counter) - sizeof(TInstanceBlock.Next);

end;

function MakeObjectInstance(Method: TWndMethod): Pointer;

const

BlockCode: array[1..2] of Byte = (

$59, { POP ECX }

$E9); { JMP StdWndProc }

PageSize = 4096;

var

Block: PInstanceBlock;

Instance: PObjectInstance;

begin

try InstCritSect.Enter;

if InstFreeList = nil then

begin

Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);

Block^.Next := InstBlockList; //Arioch: seems inherited from D1 -

// not finished MS-DOS styled array-chains model

// Move(BlockCode, Block^.Code, SizeOf(BlockCode));

//Arioch: since the procedure is not inline - it is CPU loss

Word(Block^.Code) := Word(BlockCode);

//Arioch: here we assume size of 2 bytes - but here is so lot of hacks, that one more will not hurt

Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdWndProc));

Block^.Counter := 0; // Arioch: here we will init counter

Instance := @Block^.Instances;

repeat

Instance^.Code := $E8; { CALL NEAR PTR Offset }

Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);

Instance^.Next := InstFreeList; //Nil, then prev. Instance

InstFreeList := Instance;

//Inc(Longint(Instance), SizeOf(TObjectInstance));

//Arioch: LongInt? certainly D1 code, not even D3! Let's avoid misty code!

Instance := Succ(Instance);

until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock);

InstBlockList := Block;

end;

Result := InstFreeList;

Instance := InstFreeList;

InstFreeList := Instance^.Next;

Instance^.Method := Method;

Inc(GetInstanceBlock(Instance)^.Counter); //Arioch: need not check for overflow

// since last one will have NExt = nil, making RTL to allocate new block

finally InstCritSect.Leave; end;

end;

　

　

function FreeInstanceBlock(block: pointer): boolean;

var bi: PInstanceBlock absolute block;

oi, poi, noi: PObjectInstance; // needed to free block

begin

Result := false; if bi = nil then exit; if bi^.Counter <> 0 then exit;

oi := InstFreeList; poi := nil;

while oi <> nil do begin

noi := oi^.next;

// Here we must remove instances from the free-list before freeing block

// Othewise MakeObjectInstance will reuse it :-( leading to GPF

// I hope we do not need oi any more! We have bi instead.

if GetInstanceBlock(oi) = bi then // our victim! steal it away!

if poi <> nil then poi^.Next := noi;

if oi = InstFreeList then InstFreeList := noi;

// not effective, but simple, stupid, and solid (i hope)

end;

poi := oi; oi := noi;

end;

VirtualFree(block, 0, MEM_RELEASE); // no more memory leaks! at last! i hope!!!

Result := true;

end;

procedure FreeInstanceBlocks; //Garbage collection. Queerest of the queer.

var pbi, bi, nbi: PBlockInstance;

begin

pbi := nil; bi := InstBlockList;

while bi <> nil do begin

nbi := bi^.Next;

if FreeInstanceBlock(bi) then begin

if pbi <> nil then pbi^.Next := nbi;

if bi = InstBlockList then InstBlockList := nbi;

// not effective, but simple, stupid, and solid (i hope)

end;

pbi := bi; bi := nbi;

end;

end;

{ Free an object instance }

procedure FreeObjectInstance(ObjectInstance: Pointer);

var bi: PInstanceBlock; i: integer; //Arioch

oi: PObjectInstance absolute ObjectInstance; //i&#39;m to lazy to use with and typecast :-)

begin

if ObjectInstance <> nil then

try InstCritSect.Enter;

bi := GetInstanceBlock(ObjectInstance); // what the block did we cleaned a bit?

if bi = nil then exit; // i cannot tell how may this be - but it is a crush!

if (bi^.Counter <= 0) or (bi^.Counter > InstanceCount + 1) then exit;

// crash! it was not TObjectInstance???

PObjectInstance(ObjectInstance)^.Next := InstFreeList;

InstFreeList := ObjectInstance;

//saving freed instance for the further re-use in never-sorting list.

//maybe it would be better to keep tracks in easc of blocks separately

//(for example checking if Instance^.Next=nil), but... To much to change.

Dec(bi^.Counter); if bi^.Counter <= 0 then FreeInstanceBlocks;

//full garbage collection - no one tells that we&#39;re freeing the top block!

finally InstCritSect.Leave; end;

end;

initialization

InstCritSect := TCriticalSection.Create();

//Arioch: here put the rest of original initialisation of unit

finalization

InstCritSect.Free();

//Arioch: here put the rest of original finalisation of unit