unit MemPool;

interface

uses
  Classes, SysUtils, SyncObjs;

const
  blockSize = 16;    
  blockNum = 10;    

type
  TMemBlock = record 
    buf: Pointer;
    size: Integer;
  end;

  pMemBlock = ^TMemBlock;

  TMemoryPool = class
  private
    freelist, uselist: TList;   
    FBlkSize: Integer;          
    FBlkCnt: Integer;            
    FCS: TCriticalSection;
    procedure InitLock;
    procedure Lock;
    procedure UnLock;
    procedure UnInitLock;
    procedure GetRes(ABlocks: Integer);
    procedure FreeRes;
  public
    constructor Create(const ABlocks: Integer = blockNum; const ABlockSize: Integer = blockSize);
    destructor Destroy; override;
    function GetBuf: Pointer;
    procedure FreeBuf(const ABuffer: Pointer);
  published
    property BlockSize: Integer read FBlkSize;
  end;

type
  TSockMemList = class
  private
    FMS: TMemoryStream;
    FPool: TMemoryPool;
    FList: TList;
    function GetSize: integer;
    procedure list2stream(list: TList; ms: TMemoryStream);
  public
    constructor Create(pool: TMemoryPool);
    destructor Destroy; override;
    function addBuf(buf: Pointer; len: Integer): TMemoryStream;
    procedure freeList(list: TList);
  end;

implementation

{ TMemoryPool }
constructor TMemoryPool.Create(const ABlocks, ABlockSize: Integer);
begin
  InitLock;
  FBlkCnt := ABlocks;
  FBlkSize := ABlockSize;
  freelist := TList.Create;
  uselist := TList.Create;
  GetRes(ABlocks);
end;

destructor TMemoryPool.Destroy;
begin
//  FreeRes;
  FreeAndNil(freelist);
  FreeAndNil(uselist);
  UnInitLock;
  inherited;
end;

procedure TMemoryPool.FreeBuf(const ABuffer: Pointer);
begin
  Lock;
  try
    freelist.Add(ABuffer);
    uselist.Delete(uselist.IndexOf(ABuffer));
  finally
    UnLock;
  end;
end;

procedure TMemoryPool.FreeRes;
var
  p: pMemBlock;
begin
  while freelist.count > 0 do
  begin
    p := freelist[0];
    try
      FreeMem(p.buf);
    except
      Continue;
    end;
    Dispose(p);
    freelist.Delete(0);
  end;
  while uselist.count > 0 do
  begin
    p := uselist[0];
    try
      FreeMem(p.buf);
    except
      Continue;
    end;
    Dispose(p);
    uselist.Delete(0);
  end;
end;

function TMemoryPool.GetBuf: Pointer;
begin
  Lock;
  try
    if freelist.Count = 0 then
      GetRes(100);

    Result := freelist[0];
    uselist.Add(Result);
    freelist.Delete(0);
  finally
    UnLock;
  end;
end;

procedure TMemoryPool.GetRes(ABlocks: Integer);
var
  i: Integer;
  p: pMemBlock;
begin
  for i := 1 to ABlocks do
  begin
    New(p);
    GetMem(p.buf, FBlkSize);
    freelist.Add(p);
  end;
end;

procedure TMemoryPool.InitLock;
begin
  FCS := TCriticalSection.Create;
end;

procedure TMemoryPool.Lock;
begin
  FCS.Enter;
end;

procedure TMemoryPool.UnInitLock;
begin
  FCS.Free;
end;

procedure TMemoryPool.UnLock;
begin
  FCS.Leave;
end;

{ TSockMemList }

function TSockMemList.addBuf(buf: Pointer; len: Integer): TMemoryStream;
var
  p: pMemBlock;
begin
  Result := nil;
  p := FPool.GetBuf;
  p.buf := buf;
  p.size := len;
  FList.Add(p);
  if len < blocksize then
  begin
    list2stream(FList, FMS);
    FMS.Position := 0;
    Result := FMS;
    freeList(FList);
  end;
end;

constructor TSockMemList.Create(pool: TMemoryPool);
begin
  FPool := pool;
  FMS := TMemoryStream.Create;
  FList := TList.Create;
end;

destructor TSockMemList.Destroy;
begin
  FreeAndNil(FMS);
  FreeAndNil(FList);
  inherited;
end;

procedure TSockMemList.freeList(list: TList);
var
  p: pMemBlock;
begin
  while list.Count > 0 do
  begin
    p := pmemblock(list[0]);
    FPool.FreeBuf(p);
    list.Delete(0);
  end;
end;

function TSockMemList.GetSize: integer;
var
  i: Integer;
begin
  i := FList.Count;
  Result := blockSize * (i - 1) + pMemblock(FList[i - 1]).size;
end;

procedure TSockMemList.list2stream(list: TList; ms: TMemoryStream);
var
  i: integer;
  p: pMemBlock;
begin
  ms.SetSize(GetSize);
  for i := 0 to list.Count - 1 do
  begin
    p := pmemblock(list[i]);
    ms.Write(p.buf^, p.size);
  end;
end;

end.