unit SnapForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TFormSnap = class(TForm)
    Memo1: TMemo;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FormSnap: TFormSnap;

implementation

{$R *.DFM}

end.

unit DdhMMan;

interface

var
  GetMemCount: Integer = 0;
  FreeMemCount: Integer = 0;
  ReallocMemCount: Integer = 0;

procedure SnapToFile(Filename: string);

implementation

uses
  Windows, SysUtils, TypInfo;

var
  OldMemMgr: TMemoryManager;
  ObjList: array[1..10000] of Pointer;
  FreeInList: Integer = 1;

procedure AddToList(P: Pointer);
begin
  if FreeInList > High(ObjList) then
  begin
    MessageBox(0, 'List full', 'MemMan', mb_ok);
    Exit;
  end;
  ObjList[FreeInList] := P;
  Inc(FreeInList);
end;

procedure RemoveFromList(P: Pointer);
var
  I: Integer;
begin
  for I := 1 to FreeInList - 1 do
    if ObjList[I] = P then
    begin
      // remove element shifting down the others
      Dec(FreeInList);
      Move(ObjList[I + 1], ObjList[I],
        (FreeInList - I) * sizeof(pointer));
      Exit;
    end;
end;

procedure SnapToFile(Filename: string);
var
  OutFile: TextFile;
  I, CurrFree: Integer;
  HeapStatus: THeapStatus;
  Item: TObject;
  ptd: PTypeData;
  ppi: PPropInfo;
begin
  AssignFile(OutFile, Filename);
  try
    Rewrite(OutFile);
    CurrFree := FreeInList;
    // local heap status
    HeapStatus := GetHeapStatus;
    with HeapStatus do
    begin
      write(OutFile, 'Available address space: ');
      write(OutFile, TotalAddrSpace div 1024);
      writeln(OutFile, ' Kbytes');
      write(OutFile, 'Uncommitted portion: ');
      write(OutFile, TotalUncommitted div 1024);
      writeln(OutFile, ' Kbytes');
      write(OutFile, 'Committed portion: ');
      write(OutFile, TotalCommitted div 1024);
      writeln(OutFile, ' Kbytes');
      write(OutFile, 'Free portion: ');
      write(OutFile, TotalFree div 1024);
      writeln(OutFile, ' Kbytes');
      write(OutFile, 'Allocated portion: ');
      write(OutFile, TotalAllocated div 1024);
      writeln(OutFile, ' Kbytes');
      write(OutFile, 'Address space load: ');
      write(OutFile, TotalAllocated div
        (TotalAddrSpace div 100));
      writeln(OutFile, '%');
      write(OutFile, 'Total small free blocks: ');
      write(OutFile, FreeSmall div 1024);
      writeln(OutFile, ' Kbytes');
      write(OutFile, 'Total big free blocks: ');
      write(OutFile, FreeBig div 1024);
      writeln(OutFile, ' Kbytes');
      write(OutFile, 'Other unused blocks: ');
      write(OutFile, Unused div 1024);
      writeln(OutFile, ' Kbytes');
      write(OutFile, 'Total overhead: ');
      write(OutFile, Overhead div 1024);
      writeln(OutFile, ' Kbytes');
    end;

    // custom memory manager information
    writeln(OutFile); // free line
    write(OutFile, 'Memory objects: ');
    writeln(OutFile, CurrFree - 1);
    for I := 1 to CurrFree - 1 do
    begin
      write(OutFile, I);
      write(OutFile, ') ');
      write(OutFile, IntToHex(
        Cardinal(ObjList[I]), 16));
      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, 'Not an object')
        else
        begin
          ptd := GetTypeData(PTypeInfo(Item.ClassInfo));
          // name, if a component
          ppi := GetPropInfo(
            PTypeInfo(Item.ClassInfo), 'Name');
          if ppi <> nil then
          begin
            write(OutFile, GetStrProp(Item, ppi));
            write(OutFile, ' :  ');
          end
          else
            write(OutFile, '(unnamed): ');
          write(OutFile, PTypeInfo(Item.ClassInfo).Name);
          write(OutFile, ' (');
          write(OutFile, ptd.ClassType.InstanceSize);
          write(OutFile, ' bytes)  -  In ');
          write(OutFile, ptd.UnitName);
          write(OutFile, '.dcu');
        end
      except
        on Exception do
          write(OutFile, 'Not an object');
      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);
  // remove older object
  RemoveFromList(P);
  // add new one
  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
    MessageBox(0, pChar('Objects left: ' +
      IntToStr(GetMemCount - FreeMemCount)),
      'MemManager', mb_ok);
end.

unit MemForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    BtnCreateNil: TButton;
    BtnCreateOwner: TButton;
    BtnFreeLast: TButton;
    LblResult: TLabel;
    Btn100Strings: TButton;
    Bevel1: TBevel;
    BtnRefresh2: TButton;
    BtnSnap: TButton;
    SaveDialog1: TSaveDialog;
    procedure Button1Click(Sender: TObject);
    procedure BtnCreateNilClick(Sender: TObject);
    procedure BtnCreateOwnerClick(Sender: TObject);
    procedure BtnFreeLastClick(Sender: TObject);
    procedure Btn100StringsClick(Sender: TObject);
    procedure BtnRefresh2Click(Sender: TObject);
    procedure BtnSnapClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
  public
    b: TButton;
    procedure Refresh2;
  end;

var
  Form1: TForm1;

implementation

uses
  DdhMMan, SnapForm;

{$R *.DFM}

procedure TForm1.Refresh2;
begin
  LblResult.Caption := Format(
    'Allocated: %d'#13'Free: %d'#13'Existing: %d'#13'Re-allocated %d'      ,
    [GetMemCount, FreeMemCount,
    GetMemCount - FreeMemCount, ReallocMemCount]);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Refresh2;
end;

procedure TForm1.BtnCreateNilClick(Sender: TObject);
begin
  b := TButton.Create(nil);
  Refresh2;
end;

procedure TForm1.BtnCreateOwnerClick(Sender: TObject);
begin
  b := TButton.Create(self);
  Refresh2;
end;

procedure TForm1.BtnFreeLastClick(Sender: TObject);
begin
  if Assigned(b) then
  begin
    b.Free;
    b := nil;
  end;
  Refresh2;
end;

procedure TForm1.Btn100StringsClick(Sender: TObject);
var
  s1, s2: string;
  I: Integer;
begin
  s1 := 'hi';
  s2 := Btn100Strings.Caption;
  for I := 1 to 100 do
    s1 := s1 + ': hello world';
  Btn100Strings.Caption := s1;
  s1 := s2;
  Btn100Strings.Caption := s1;
  Refresh2;
end;

procedure TForm1.BtnRefresh2Click(Sender: TObject);
begin
  Refresh2;
end;

procedure TForm1.BtnSnapClick(Sender: TObject);
begin
  if SaveDialog1.Execute then
  begin
    SnapToFile(SaveDialog1.Filename);
    FormSnap.Memo1.Lines.LoadFromFile(
      SaveDialog1.Filename);
    FormSnap.Show;
  end;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  Refresh2;
end;

end.