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

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

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.

http://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.

http://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.
http://delphiworld.narod.ru/ DelphiWorld 6.0

Отправить комментарий

Проверка
Антиспам проверка
Image CAPTCHA
...