Chip 2003 January/Chip_2003-01_cd1.bin/zkuste/delphi/kompon/d56/VKDBF.ZIP/VKDBFMemMgr.pas

Pascal/Delphi Source File | 2002-05-30 | 5.7 KB | 269 lines

unit VKDBFMemMgr;

interface

uses
  contnrs, Dialogs, sysutils;

type

  {TVKDBFOneAlloc}
  TVKDBFOneAlloc = class
  private

    FMemory: Pointer;
    FCaller: TObject;
    FCaption: String;
    FSize: Cardinal;

  public

    constructor Create; overload;
    constructor Create(Caller: TObject; Caption: String; Size: Cardinal); overload;
    constructor Create(Caller: TObject; Size: Cardinal); overload;
    destructor Destroy; override;

    procedure GetMem(Size: Cardinal);
    procedure ReallocMem(NewSize: Cardinal);
    procedure FreeMem;

    property Memory: Pointer read FMemory;
    property Caller: TObject read FCaller write FCaller;
    property Caption: String read FCaption write FCaption;
    property Size: Cardinal read FSize;

  end;

  {TVKDBFMemMgr}
  TVKDBFMemMgr = class(TObjectList)
  private
  public
    constructor Create;
    destructor Destroy; override;

    function FindIndex(p: Pointer; out Ind: Integer): boolean;
    function FindCaption(Capt: String; out Ind: Integer): boolean;

    procedure FreeForCaption(Capt: String);

    function GetMem(Caller: TObject; size: Integer): Pointer; overload;
    function ReallocMem(p: Pointer; size: Integer): Pointer; overload;
    procedure FreeMem(p: Pointer); overload;

    function GetMem(Capt: String; size: Integer): Pointer; overload;

    function GetSize(p: Pointer): Integer;

  end;

var
  oMem: TVKDBFMemMgr;

implementation

{ TVKDBFMemMgr }

constructor TVKDBFMemMgr.Create;
begin
  inherited Create;
end;

destructor TVKDBFMemMgr.Destroy;
begin
  inherited Destroy;
end;

function TVKDBFMemMgr.FindCaption(Capt: String; out Ind: Integer): boolean;
var
  i: Integer;
begin
  Result := false;
  Ind := -1;
  for i := 0 to Count - 1 do
    if TVKDBFOneAlloc(Items[i]).Caption = Capt then begin
      Result := true;
      Ind := i;
      Exit;
    end;
end;

function TVKDBFMemMgr.FindIndex(p: Pointer; out Ind: Integer): boolean;
var
  B: TVKDBFOneAlloc;
  beg, Mid: Integer;
begin
  Ind := Count;
  if ( Ind > 0 ) then begin
    beg := 0;
    B := TVKDBFOneAlloc(Items[beg]);
    if ( Integer(p) > Integer(B.FMemory) ) then begin
      repeat
        Mid := (Ind + beg) div 2;
        B := TVKDBFOneAlloc(Items[Mid]);
        if ( Integer(p) > Integer(B.FMemory) ) then
           beg := Mid
        else
           Ind := Mid;
      until ( ((Ind - beg) div 2) = 0 );
    end else
      Ind := beg;
    if Ind < Count then begin
      B := TVKDBFOneAlloc(Items[Ind]);
      Result := (Integer(p) = Integer(B.FMemory));
    end else
      Result := false;
  end else
    Result := false;
end;

procedure TVKDBFMemMgr.FreeForCaption(Capt: String);
var
  i: Integer;
begin
  while FindCaption(Capt, i) do Delete(i);
end;

procedure TVKDBFMemMgr.FreeMem(p: Pointer);
var
  i: Integer;
begin
  if (p <> nil) and FindIndex(p, i) then Delete(i);
end;

function TVKDBFMemMgr.GetMem(Caller: TObject; size: Integer): Pointer;
var
  Obj: TVKDBFOneAlloc;
  i: Integer;
begin
  Obj := TVKDBFOneAlloc.Create(Caller, size);
  FindIndex(Obj.FMemory, i);
  Insert(i, Obj);
  Result := Obj.FMemory;
end;

function TVKDBFMemMgr.GetMem(Capt: String; size: Integer): Pointer;
var
  Obj: TVKDBFOneAlloc;
  i: Integer;
begin
  Obj := TVKDBFOneAlloc.Create(nil, Capt, size);
  FindIndex(Obj.FMemory, i);
  Insert(i, Obj);
  Result := Obj.FMemory;
end;

function TVKDBFMemMgr.GetSize(p: Pointer): Integer;
var
  Obj: TVKDBFOneAlloc;
  i: Integer;
begin
  if p <> nil then begin
    if FindIndex(p, i) then begin
      Obj := TVKDBFOneAlloc(Items[i]);
      Result := Obj.FSize;
    end else
      Result := 0;
  end else
    Result := 0;
end;

function TVKDBFMemMgr.ReallocMem(p: Pointer; size: Integer): Pointer;
var
  Obj: TVKDBFOneAlloc;
  i: Integer;
  Old: Pointer;
begin
  if p <> nil then begin
    if FindIndex(p, i) then begin
      Obj := TVKDBFOneAlloc(Items[i]);
      Old := Obj.FMemory;
      Obj.ReallocMem(size);
      Result := Obj.FMemory;
      if Integer(Old) <> Integer(Obj.FMemory) then begin
        OwnsObjects := false;
        try
          Delete(i);
          FindIndex(Obj.FMemory, i);
          Insert(i, Obj);
        finally
          OwnsObjects := true;
        end;
      end;
    end else
      Result := nil;
  end else
    Result := self.GetMem(self, size);
end;

{ TVKDBFOneAlloc }

constructor TVKDBFOneAlloc.Create;
begin
  FMemory := nil;
  FCaller := nil;
  FSize := 0;
  FCaption := '';
end;

constructor TVKDBFOneAlloc.Create(Caller: TObject; Caption: String; Size: Cardinal);
begin
  Create;
  self.GetMem(Size);
  FCaller := Caller;
  FCaption := Caption;
end;

constructor TVKDBFOneAlloc.Create(Caller: TObject; Size: Cardinal);
begin
  if Size > 0 then begin
  Create;
  self.GetMem(Size);
  FCaller := Caller;
  if FCaller <> nil then
    FCaption := FCaller.ClassName;
  end else
    raise Exception.Create('TVKDBFOneAlloc: Can not allocate 0 bytes memory!');
end;

destructor TVKDBFOneAlloc.Destroy;
begin
  self.FreeMem;
  inherited Destroy;
end;

procedure TVKDBFOneAlloc.FreeMem;
begin
  if FMemory <> nil then begin
    System.FreeMem(FMemory);
    FMemory := nil;
    FSize := 0;
  end;
end;

procedure TVKDBFOneAlloc.GetMem(Size: Cardinal);
begin
  if FMemory = nil then begin
    System.GetMem(FMemory, Size);
    FSize := Size;
  end else begin
    System.ReallocMem(FMemory, Size);
    FSize := Size;
  end;
end;

procedure TVKDBFOneAlloc.ReallocMem(NewSize: Cardinal);
begin
  System.ReallocMem(FMemory, NewSize);
  FSize := NewSize;
end;

initialization

    oMem := TVKDBFMemMgr.Create;

finalization

    oMem.Free;

end.