+ patch from Benito van der Zander to enable heaptrc to dump leaked or faulty memory blocks (function disabled by default), resolves #19691

git-svn-id: trunk@18231 -

rtl/inc/heaptrc.pp

@@ -80,6 +80,9 @@ const
     this allows to test for writing into that part }
   usecrc : boolean = true;
 
+  printleakedblock: boolean = false;
+  printfaultyblock: boolean = false;
+  maxprintedblocklength: integer = 128;
 
 implementation
 
@@ -255,14 +258,50 @@ function InternalFreeMemSize(loc_info: pheap_info; p: pointer; pp: pheap_mem_inf
   size: ptruint; release_todo_lock: boolean): ptruint; forward;
 function TraceFreeMem(p: pointer): ptruint; forward;
 
+procedure printhex(p : pointer; const size : PtrUInt; var ptext : text);
+var s: PtrUInt;
+ i: Integer;
+begin
+  s := size;
+  if s > maxprintedblocklength then
+    s := maxprintedblocklength;
+
+  for i:=0 to s-1 do
+    write(ptext, hexstr(pbyte(p + i)^,2));
+
+  if size > maxprintedblocklength then
+    writeln(ptext,'.. - ')
+  else
+    writeln(ptext, ' - ');
+
+  for i:=0 to s-1 do
+    if pchar(p + sizeof(theap_mem_info) + i)^ < ' ' then
+      write(ptext, ' ')
+    else
+      write(ptext, pchar(p + i)^);
+
+  if size > maxprintedblocklength then
+    writeln(ptext,'..')
+  else
+    writeln(ptext);
+end;
+
 procedure call_stack(pp : pheap_mem_info;var ptext : text);
 var
   i  : ptruint;
+  s: PtrUInt;
 begin
   writeln(ptext,'Call trace for block $',hexstr(pointer(pp)+sizeof(theap_mem_info)),' size ',pp^.size);
+  if printleakedblock then
+    begin
+      write(ptext, 'Block content: ');
+      printhex(pointer(pp) + sizeof(theap_mem_info), pp^.size, ptext);
+    end;
+
   for i:=1 to tracesize do
    if pp^.calls[i]<>nil then
      writeln(ptext,BackTraceStrFunc(pp^.calls[i]));
+
   { the check is done to be sure that the procvar is not overwritten }
   if assigned(pp^.extra_info) and
      (pp^.extra_info^.check=$12345678) and
@@ -303,6 +342,11 @@ procedure dump_error(p : pheap_mem_info;var ptext : text);
 begin
   Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid');
   Writeln(ptext,'Wrong signature $',hexstr(p^.sig,8),' instead of ',hexstr(calculate_sig(p),8));
+  if printfaultyblock then
+    begin
+      write(ptext, 'Block content: ');
+      printhex(pointer(p) + sizeof(theap_mem_info), p^.size, ptext);
+    end;
   dump_stack(ptext,get_caller_frame(get_frame));
 end;