Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue48/Memory/MemUseU.pas

Pascal/Delphi Source File | 1999-06-22 | 5.7 KB | 192 lines

unit MemUseU;

{$ifdef Ver90} { Delphi 2.0x }
  {$define DelphiLessThan4}
{$endif}
{$ifdef Ver93} { C++ Builder 1.0x }
  {$define DelphiLessThan4}
{$endif}
{$ifdef Ver100} { Delphi 3.0x }
  {$define DelphiLessThan4}
{$endif}
{$ifdef Ver110} { C++ Builder 3.0x }
  {$define DelphiLessThan4}
{$endif}

interface

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

type
  TForm1 = class(TForm)
    tmrHeapMonitor: TTimer;
    pnlActions: TPanel;
    btnNewEdits: TButton;
    btnClearEdits: TButton;
    Label1: TLabel;
    procedure tmrHeapMonitorTimer(Sender: TObject);
    procedure btnNewEditsClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnClearEditsClick(Sender: TObject);
  private
    EditList: TList;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

  function FindHMCommand: Boolean;
{$ifdef DelphiLessThan4}
  var
    I: Integer;
  begin
    Result := False;
    for I := 1 to ParamCount do
      if (UpperCase(ParamStr(I)) = '/HM') or
        (UpperCase(ParamStr(I)) = '-HM') then
        Result := True;
{$else}
  begin
    Result := FindCmdLineSwitch('HM', ['/', '-'], True)
{$endif}
  end;

begin
  if FindHMCommand then
  begin
    //Enable heap monitoring (via timer)
    tmrHeapMonitor.Enabled := True;
    //Make the timer tick straight away
    tmrHeapMonitor.OnTimer(tmrHeapMonitor);
  end;
  EditList := TList.Create;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  EditList.Free
end;

procedure TForm1.btnNewEditsClick(Sender: TObject);
var
  Edit: TEdit;
  I: Integer;
begin
  for I := 1 to 20 do
  begin
    Edit := TEdit.Create(Self);
    EditList.Add(Edit);
    with Edit do
    begin
      Left := Random(Self.ClientWidth - Width - 1);
      Top := pnlActions.Height + Random(Self.ClientHeight - pnlActions.Height - Height - 1);
      Color := Random($1000000);
      Text := Format('$%x', [Color]);
      Parent := Self
    end;
  end;
  pnlActions.BringToFront;
end;

procedure TForm1.btnClearEditsClick(Sender: TObject);
begin
  while EditList.Count > 0 do
  begin
    TEdit(EditList[0]).Free;
    EditList.Delete(0)
  end;
end;

function CommittedMemorySize: DWord;
var
  MBI: TMemoryBasicInformation;
  SI: TSystemInfo;
  RangeStart: Pointer;
begin
  Result := 0;
  GetSystemInfo(SI);
  RangeStart := SI.lpMinimumApplicationAddress;
  while DWord(RangeStart) < DWord(SI.lpMaximumApplicationAddress) do
  begin
    VirtualQuery(RangeStart, MBI, SizeOf(MBI));
    //Only get committed memory (storage allocated for this)
    if MBI.State = MEM_COMMIT then
      Inc(Result, MBI.RegionSize);
    //Delphi 2 & 3 could only handle $7FFFFFFF as biggest int
    //Last region is likely to end at $80000000. To avoid integer
    //overflow, we'll do a comparison and bypass the addition
    if DWord(SI.lpMaximumApplicationAddress) - MBI.RegionSize >= DWord(RangeStart) then
      Inc(PChar(RangeStart), MBI.RegionSize)
    else
      //If overflow would have occurred, loop is over
      Break
  end;
end;

const
  //These come from Delphi's Source\RTL\GetMem.inc file
  cHeapOk           = 0;  // everything's fine
  cReleaseErr       = 1;  // operating system returned an error when we released
  cDecommitErr      = 2;  // operating system returned an error when we decommited
  cBadCommittedList = 3;  // list of committed blocks looks bad
  cBadFiller1       = 4;  // filler block is bad
  cBadFiller2       = 5;  // filler block is bad
  cBadFiller3       = 6;  // filler block is bad
  cBadCurAlloc      = 7;  // current allocation zone is bad
  cCantInit         = 8;  // couldn't initialize
  cBadUsedBlock     = 9;  // used block looks bad
  cBadPrevBlock     = 10; // prev block before a used block is bad
  cBadNextBlock     = 11; // next block after a used block is bad
  cBadFreeList      = 12; // free list is bad
  cBadFreeBlock     = 13; // free block is bad
  cBadBalance       = 14; // free list doesn't correspond to blocks marked free

function HeapErrorDesc(Error: Cardinal): String;
begin
  case Error of
    cHeapOk:           Result := 'Everything''s fine';
    cReleaseErr:       Result := 'OS returned an error when we released';
    cDecommitErr:      Result := 'OS returned an error when we decommited';
    cBadCommittedList: Result := 'List of committed blocks looks bad';
    cBadFiller1,
    cBadFiller2,
    cBadFiller3:       Result := 'Filler block is bad';
    cBadCurAlloc:      Result := 'Current allocation zone is bad';
    cCantInit:         Result := 'Couldn''t initialize';
    cBadUsedBlock:     Result := 'Used block looks bad';
    cBadPrevBlock:     Result := 'Prev block before a used block is bad';
    cBadNextBlock:     Result := 'Next block after a used block is bad';
    cBadFreeList:      Result := 'Free list is bad';
    cBadFreeBlock:     Result := 'Free block is bad';
    cBadBalance:       Result := 'Free list doesn''t correspond to blocks marked free';
  end
end;

procedure TForm1.tmrHeapMonitorTimer(Sender: TObject);
var
  HS: THeapStatus;
begin
  HS := GetHeapStatus;
  if HS.HeapErrorCode = cHeapOk then
    Application.MainForm.Caption := Format(
      '%s (App: Blocks=%d Bytes=$%x (%2:d) Win32: Committed=$%x (%3:d))',
      [Application.Title, AllocMemCount, AllocMemSize, CommittedMemorySize])
  else
    Application.MainForm.Caption := Format(
      '%s (Invalid heap code %d: %s)',
      [Application.Title, HS.HeapErrorCode, HeapErrorDesc(HS.HeapErrorCode)]);
end;

initialization
  Randomize;
end.