Освобождение памяти

unit MemMan;
 
interface
 
var
  GetMemCount, FreeMemCount,
    ReallocMemCount: Integer;
 
implementation
 
uses
  Windows, SysUtils;
 
var
  OldMemMgr: TMemoryManager;
 
function NewGetMem(Size: Integer): Pointer;
begin
  Inc(GetMemCount);
  Result := OldMemMgr.GetMem(Size);
end;
 
function NewFreeMem(P: Pointer): Integer;
begin
  Inc(FreeMemCount);
  Result := OldMemMgr.FreeMem(P);
end;
 
function NewReallocMem(P: Pointer; Size: Integer): Pointer;
begin
  Inc(ReallocMemCount);
  Result := OldMemMgr.ReallocMem(P, Size);
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)
    BtnRefresh1: TButton;
    BtnCreateNil: TButton;
    BtnCreateOwner: TButton;
    BtnGetMem: TButton;
    LblResult: TLabel;
    Btn100Strings: TButton;
    Bevel1: TBevel;
    BtnRefresh2: TButton;
    procedure BtnRefresh1Click(Sender: TObject);
    procedure BtnCreateNilClick(Sender: TObject);
    procedure BtnCreateOwnerClick(Sender: TObject);
    procedure BtnGetMemClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Btn100StringsClick(Sender: TObject);
    procedure BtnRefresh2Click(Sender: TObject);
  public
    procedure Refresh;
    procedure Refresh2;
  end;
 
var
  Form1: TForm1;
 
implementation
 
uses MemMan;
 
{$R *.DFM}
 
procedure TForm1.Refresh;
begin
  LblResult.Caption :=
    'Allocated: ' + IntToStr(GetMemCount) + #13 +
    'Free: ' + IntToStr(FreeMemCount) + #13 +
    'Existing: ' +
    IntToStr(GetMemCount - FreeMemCount) + #13 +
    'Re-allocated: ' + IntToStr(ReallocMemCount);
end;
 
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.BtnRefresh1Click(Sender: TObject);
begin
  Refresh;
end;
 
procedure TForm1.BtnCreateNilClick(Sender: TObject);
begin
  TButton.Create(nil);
  Refresh;
end;
 
procedure TForm1.BtnCreateOwnerClick(Sender: TObject);
begin
  TButton.Create(self);
  Refresh;
end;
 
procedure TForm1.BtnGetMemClick(Sender: TObject);
var
  P: Pointer;
begin
  GetMem(P, 100);
  Integer(P^) := 0;
  Refresh;
end;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  Refresh;
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;
  Refresh;
end;
 
procedure TForm1.BtnRefresh2Click(Sender: TObject);
begin
  Refresh2;
end;
 
end.

https://delphiworld.narod.ru/

DelphiWorld 6.0

unit MemMan;
 
interface
 
uses
  StdCtrls, Classes;
 
var
  AllocCount, FreeCount: Integer;
  AllocatedList: TList;
 
type
  TCountButton = class(TButton)
  protected
    class function NewInstance: TObject; override;
    procedure FreeInstance; override;
  end;
 
implementation
 
uses
  Windows, SysUtils;
 
class function TCountButton.NewInstance: TObject;
begin
  Inc(AllocCount);
  Result := inherited NewInstance;
  AllocatedList.Add(Result);
end;
 
procedure TCountButton.FreeInstance;
var
  nItem: Integer;
begin
  Inc(FreeCount);
  nItem := AllocatedList.IndexOf(self);
  AllocatedList.Delete(nItem);
  inherited FreeInstance;
end;
 
initialization
  AllocatedList := TList.Create;
 
finalization
  if (AllocCount - FreeCount) <> 0 then
    MessageBox(0, pChar(
      'Objects left: ' + IntToStr(AllocCount - FreeCount)),
      'MemManager', mb_ok);
  AllocatedList.Free;
end.

https://delphiworld.narod.ru/

DelphiWorld 6.0

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.

https://delphiworld.narod.ru/

DelphiWorld 6.0