Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

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

01.01.2007
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