program prjHookHeap; { Small test/demo program to demonstrate version of heaptrc.pp WITH CLASSNAME reporting of leaked objects and HeapNotification callback to track construction/destruction of TObject instances / other system variables Works only with optimization <0 O1 -OoREGVAR } uses Classes, SysUtils; var lNotifStep : integer = -1; procedure HeapNotification(const aSerial: IntPtr; const aMemory: pointer; const aMemInstType: TMemInstanceType; aMemOp: TMemOp); begin Inc(lNotifStep); Write(lNotifStep, ';'); Write(HexStr(aMemory), ';'); case aMemInstType of mitObject: Write(TObject(aMemory).ClassName, ';'); mitAnsiString: Write('ansistring', ';'); mitUnicodeString: Write('unicodestring', ';'); else Write('memory', ';'); end; case aMemOp of moGetMem: Write('getmem', ';'); moReallocMem: Write('reallocmem', ';'); moFreeMem: Write('getmem/allocmem', ';'); end; WriteLn('size;', MemSize(aMemory), ';', 'serial;', aSerial); end; { Needed to fake ansistring / unicodestring leak } Type PAnsiRec = ^TAnsiRec; TAnsiRec = Record CodePage : TSystemCodePage; ElementSize : Word; {$ifdef CPU64} { align fields } Dummy : DWord; {$endif CPU64} Ref : SizeInt; Len : SizeInt; end; var lLogFileName : string; LostMemory:tobject; StupidPointer:Pointer; lUnicString : unicodestring; lAnsiString : ansistring; lPansiRec : PAnsiRec; begin {$if declared(UseHeapTrace)} SetHeapNotification(@HeapNotification); // <-- Heaptrc callback for TObject's lLogFileName := ChangeFileExt(ParamStr(0), '_log.txt'); if FileExists(lLogFileName) then DeleteFile(lLogFileName); SetHeapTraceOutput(lLogFileName); // ~bk debug heap HeapLogTextStart:=ExtractFilename(ParamStr(0))+' HeapTrc START session : '+DateTimeToStr(Now); GlobalSkipIfNoLeaks := true; // supported as of debugger version 3.1.1 {$endif} StupidPointer:=GetMem(100000); ReallocMem(StupidPointer, 50000); FreeMem(StupidPointer); LostMemory:=TObject.create; LostMemory.Free; LostMemory:=TObject.create; StupidPointer:=GetMem(129); StupidPointer:=ReallocMem(StupidPointer, 213); LostMemory:=TList.Create; LostMemory.Free; LostMemory:=TList.Create; LostMemory:=TComponent.create(nil); LostMemory:=TFPList.Create; lAnsiString := 'Bonjour'; lAnsiString := lAnsiString + ' Bruno'; lPansiRec := pointer(lAnsiString)-SizeOf(TAnsiRec); Inc(lPansiRec^.Ref); lUnicString := 'Bonjour '; lUnicString := lUnicString + 'Bruno'; lPansiRec := pointer(lUnicString)-SizeOf(TAnsiRec); Inc(lPansiRec^.Ref); {$if declared(UseHeapTrace)} HeapLogTextEnd:=ExtractFilename(ParamStr(0))+' HeapTrc END THeaptrcObject. : '+DateTimeToStr(Now); {$endif} WriteLn('Press ENTER to Quit'); ReadLn; end.