{******************************************************************************}
{                       CnPack For Delphi/C++Builder                           }
{                     中国人自己的开放源码第三方开发包                         }
{                   (C)Copyright 2001-2008 CnPack 开发组                       }
{                   ------------------------------------                       }
{                                                                              }
{            本开发包是开源的自由软件，您可以遵照 CnPack 的发布协议来修        }
{        改和重新发布这一程序。                                                }
{                                                                              }
{            发布这一开发包的目的是希望它有用，但没有任何担保。甚至没有        }
{        适合特定目的而隐含的担保。更详细的情况请参阅 CnPack 发布协议。        }
{                                                                              }
{            您应该已经和开发包一起收到一份 CnPack 发布协议的副本。如果        }
{        还没有，可访问我们的网站：                                            }
{                                                                              }
{            网站地址：http://www.cnpack.org                                   }
{            电子邮件：master@cnpack.org                                       }
{                                                                              }
{******************************************************************************}

unit CnIocpSimpleMemPool;
{* |<PRE>
================================================================================
* 软件名称：网络通讯组件包
* 单元名称：Windows完成端口(IOCP)组件使用的简单内存池实现单元
* 单元作者：cnwinds
*           菩提(cxmld@126.com) 移植修改
* 备    注：
*           实现Windows完成端口(IOCP)使用的简单内存池的封装
*   1.TCnIocpMemPool类增加了一个方法:GetFreeMemoryType, 获取一个空闲的内存类型
*   2.TCnIocpMemPool分配的内存大小是固定,最大值由每一次分配决定
*   3.增加 TCnIocpSimpleMemPool来包装 TCnIocpMemPool的功能, 即租用内存和归还内存
*   4.使用"租用"和"归还"是为了区别正常的"分配内存"和"释放内存"
*   5.TCnIocpSimpleMemPool对应一个内存类型, 每个内存类型的类型值,自动获取
*   6.二个自定义名词(可能名字起得不够好):"内存块"和"内存类型块"
*     每个 TCnIocpSimpleMemPool 对应一个内存类型块, 它由多个"内存块"组成.每次用户
*     租用就是得到一个整的"内存块", 大小由第一次租用时确定.
*     TCnIocpMemPool包含了多个  "内存类型块", 即每注册一次时,就分配一个"内存类型块"
*
* 开发平台：PWin2000Pro + Delphi 7.01
* 兼容测试：PWin9X/2000/XP + Delphi 5/6/7 + C++Builder 5/6
* 本 地 化：该单元中的字符串均符合本地化处理方式
* 单元标识：$Id: CnIocpSimpleMemPool.pas,v 1.2 2008/10/18 05:54:37 liuxiao Exp $
* 修改记录：2008.09.16 V1.0
*                创建单元
================================================================================
|</PRE>}

interface

{$I CnPack.inc}

uses
  SysUtils, Classes, SyncObjs, Windows, Controls;

const
  SCnErrorRepeatRegister = '重复注册内存类型(%d)!';
  SCnErrorNotRegister = '没有注册该内存类型(%d)!';
  SCnErrorBlockNotRent = '内存块没有被借出！';
  SCnErrorBlockUnknow = '没有该内存块！';

type

  TCreateMemoryEvent = procedure(var MemoryPtr: Pointer; Size: Cardinal) of object;
  TFreeMemoryEvent = procedure(MemoryPtr: Pointer) of object;

  TMemoryBlockItem = record
  {* 内存块头}
    MemoryBlockPtr: Pointer;            //内存指针
    RentTime: Cardinal;                 //租用时间
    IsRent: Boolean;                    //是否租用
    RentCount: Integer;                 //租用次数
    Size: Cardinal;
  end;
  PMemoryBlockItem = ^TMemoryBlockItem;

  TMemoryTypeItem = record
  {* 内存类型块头}
    Lock: TCriticalSection;               //互锁相关
    MemoryType: Integer;                  //内存类型
    MemoryBlockList: TList;               //内存块列表
    CreateMemoryProc: TCreateMemoryEvent;  //创建内存方法指针
    FreeMemoryProc: TFreeMemoryEvent;      //释放内存方法指针
    MaxCount: Integer;                    //内存块总数
  end;
  PMemoryTypeItem = ^TMemoryTypeItem;

  TCnIocpMemPool = class
  private
    FMemoryTypeList: TList;

    function CreateMemoryTypeItem(MemoryType: Integer;
                                  CreateMemoryProc: TCreateMemoryEvent;
                                  FreeMemoryProc: TFreeMemoryEvent): PMemoryTypeItem;
    {* 创建内存类型块(带线程锁)}

    procedure FreeMemoryTypeItem(MemoryTypeItem: PMemoryTypeItem);
    {* 释放内存类型块}

    function CreateMemoryBlockItem(MemoryTypeItem: PMemoryTypeItem;
      Size: Cardinal): PMemoryBlockItem;
    procedure FreeMemoryBlockItem(MemoryTypeItem: PMemoryTypeItem;
      MemoryBlockItem: PMemoryBlockItem);

    function FindMemoryTypeItem(MemoryType: Integer): PMemoryTypeItem;

    procedure Clear;

  public
    constructor Create;
    destructor Destroy; override;

    function GetFreeMemoryType(): Integer;
    {* 分配一个空闲的内存类型，内存类型是一整数标识，
      代表一TCnIocpSimpleMemPool组件所分配的所有内存}

    procedure RegisterMemoryType(MemoryType: Integer;
                                 CreateMemoryProc: TCreateMemoryEvent;
                                 FreeMemoryProc: TFreeMemoryEvent);
    {* 注册内存类型块 参数:内存类型, 创建和释放方法指针
       两方法指针是事件通知，同时可以自定义分配内存与释放内存的方法}

    procedure SetMaxCount(MemoryType: Integer; MaxCount: Integer);


    procedure RentMemory(MemoryType: Integer; var MemoryPtr: Pointer; Size: Cardinal);
    {* 租用一块内存}
    procedure ReturnMemory(MemoryType: Integer; MemoryPtr: Pointer);
    {* 返还一块内存}
  end;

  TCnIocpSimpleMemPool = class (TComponent)
  private
    FBlockMaxCount : Integer;         //内存块的总数
    FMemType       : Integer;         //内存类型值
    FOnCreateMemory : TCreateMemoryEvent;
    FOnFreeMemory   : TFreeMemoryEvent;

    procedure SetBlockMaxCount(Value: Integer);
  protected
    procedure DoCreateMemory(var MemoryPtr: Pointer; Size: Cardinal);
    procedure DoFreeMemory(MemoryPtr: Pointer);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure RentMemory(var MemoryPtr: Pointer; Size: Cardinal);
    {* 租用内存}
    procedure ReturnMemory(MemoryPtr: Pointer);
    {* 归还内存}
  published
    property MemType : Integer read FMemType;
    {* 内存类型,由系统分配,不需人工改变}
    property BlockMaxCount : Integer read FBlockMaxCount write SetBlockMaxCount;
    {* 内存块的数量, 常驻的内存块数(不是最大值,即可分配更多的内存块)}
    property OnCreateMemory : TCreateMemoryEvent  read FOnCreateMemory write FOnCreateMemory;
    {* 自定义在系统中分配内存的方法,默认实现采用 GetMem}
    property OnFreeMemory   : TFreeMemoryEvent    read FOnFreeMemory write  FOnFreeMemory;
    {* 自定义在系统中释放内存的方法,默认实现采用 FreeMem}
  end;

var
  CnMemoryPool: TCnIocpMemPool;

implementation

{ TCnIocpMemPool }

constructor TCnIocpMemPool.Create;
begin
  FMemoryTypeList := TList.Create;
end;

destructor TCnIocpMemPool.Destroy;
begin
  Clear;
  FreeAndNil(FMemoryTypeList);
  inherited;
end;

procedure TCnIocpMemPool.Clear;
var
  TypeItem: PMemoryTypeItem;
  I: Integer;
begin
  // 清除所有内存块
  for I := 0 to FMemoryTypeList.Count - 1 do
  begin
    TypeItem := PMemoryTypeItem(FMemoryTypeList[I]);
    FreeMemoryTypeItem(TypeItem);
  end;
end;

function TCnIocpMemPool.CreateMemoryTypeItem(MemoryType: Integer;
  CreateMemoryProc: TCreateMemoryEvent;
  FreeMemoryProc: TFreeMemoryEvent): PMemoryTypeItem;
begin
  Result := New(PMemoryTypeItem);
  Result^.Lock := TCriticalSection.Create;
  Result^.MemoryType := MemoryType;
  Result^.MemoryBlockList := TList.Create;
  Result^.CreateMemoryProc := CreateMemoryProc;
  Result^.FreeMemoryProc := FreeMemoryProc;
  Result^.MaxCount := 20;
end;

procedure TCnIocpMemPool.FreeMemoryTypeItem(MemoryTypeItem: PMemoryTypeItem);
var
  I: Integer;
begin
  for I := 0 to MemoryTypeItem^.MemoryBlockList.Count - 1 do
    FreeMemoryBlockItem(MemoryTypeItem, MemoryTypeItem^.MemoryBlockList[I]);
  FreeAndNil(MemoryTypeItem^.Lock);
  FreeAndNil(MemoryTypeItem^.MemoryBlockList);
  Dispose(MemoryTypeItem);
end;

function TCnIocpMemPool.GetFreeMemoryType: Integer;
var  i:Integer;
begin
  Result := 1; //从１开始分配
  for i := 0 to FMemoryTypeList.Count - 1 do
  begin
    if Result <= PMemoryTypeItem(FMemoryTypeList[i]).MemoryType then
        Result := PMemoryTypeItem(FMemoryTypeList[i]).MemoryType + 1;
        //分配一个比前值大１的数
  end;
end;

function TCnIocpMemPool.CreateMemoryBlockItem(
  MemoryTypeItem: PMemoryTypeItem; Size: Cardinal): PMemoryBlockItem;
begin
  Result := New(PMemoryBlockItem);
  MemoryTypeItem.CreateMemoryProc(Result^.MemoryBlockPtr, Size);
  Result^.RentTime := 0;
  Result^.IsRent := False;
  Result^.RentCount := 0;
  Result^.Size := Size;
end;

procedure TCnIocpMemPool.FreeMemoryBlockItem(MemoryTypeItem: PMemoryTypeItem;
  MemoryBlockItem: PMemoryBlockItem);
begin
  MemoryTypeItem.FreeMemoryProc(MemoryBlockItem^.MemoryBlockPtr);
  Dispose(MemoryBlockItem);
end;

function TCnIocpMemPool.FindMemoryTypeItem(MemoryType: Integer): PMemoryTypeItem;
var
  I: Integer;
begin
  for I := 0 to FMemoryTypeList.Count - 1 do
  begin
    Result := PMemoryTypeItem(FMemoryTypeList[I]);
    if Result^.MemoryType = MemoryType then Exit;
  end;
  Result := nil;
end;

procedure TCnIocpMemPool.RegisterMemoryType(MemoryType: Integer;
  CreateMemoryProc: TCreateMemoryEvent; FreeMemoryProc: TFreeMemoryEvent);
var
  Item: PMemoryTypeItem;
begin
  Item := FindMemoryTypeItem(MemoryType); //本类型是否已存在,存在就出异常
  if Item = nil then                      //不存在,就创建
    Item := CreateMemoryTypeItem(MemoryType, CreateMemoryProc, FreeMemoryProc)
  else
    raise Exception.Create(Format(SCnErrorRepeatRegister, [MemoryType]));
  FMemoryTypeList.Add(Item);              //并加入List中
end;

procedure TCnIocpMemPool.SetMaxCount(MemoryType, MaxCount: Integer);
var
  Item: PMemoryTypeItem;
begin
  Item := FindMemoryTypeItem(MemoryType);
  if Item <> nil then Item^.MaxCount := MaxCount;
end;

procedure TCnIocpMemPool.RentMemory(MemoryType: Integer; var MemoryPtr: Pointer;
  Size: Cardinal);
var
  TypeItem: PMemoryTypeItem;
  BlockItem: PMemoryBlockItem;
  i: Integer;
begin
  TypeItem := FindMemoryTypeItem(MemoryType);   //内存类型是否注册(存在)
  if TypeItem = nil then raise Exception.Create(Format(SCnErrorNotRegister, [MemoryType]));
  TypeItem^.Lock.Enter;
  try
    for i := 0 to TypeItem.MemoryBlockList.Count-1 do
    begin
      BlockItem := PMemoryBlockItem(TypeItem.MemoryBlockList[i]);
      if not BlockItem^.IsRent then      //第0个内存块是否已租用
      begin
        if BlockItem^.Size >= Size then
        begin
          TypeItem^.MemoryBlockList.Remove(BlockItem);
          TypeItem^.MemoryBlockList.Add(BlockItem);  //将内存块重新放入到LIST的最后
          MemoryPtr := BlockItem.MemoryBlockPtr;    //取得内存块的指针
          Inc(BlockItem^.RentCount);                 //租用总数+1
          BlockItem^.RentTime := GetTickCount;       //租用时间
          BlockItem^.IsRent := True;                 //置租用标志
          Exit;
        end
        else
        begin
          Continue;
        end;
      end
      else
      begin                                       //没有空闲内存,则申请
        Break;
      end;
    end;
    // 新创建一个内存块
    BlockItem := CreateMemoryBlockItem(TypeItem, Size);
    TypeItem^.MemoryBlockList.Add(BlockItem);
    MemoryPtr := BlockItem^.MemoryBlockPtr;
    Inc(BlockItem^.RentCount);
    BlockItem^.RentTime := GetTickCount;
    BlockItem^.IsRent := True;
    //BlockItem.Size := Size;
  finally
    TypeItem^.Lock.Release;
  end;
end;

procedure TCnIocpMemPool.ReturnMemory(MemoryType: Integer; MemoryPtr: Pointer);
var
  TypeItem: PMemoryTypeItem;
  I: Integer;
  BlockItem: PMemoryBlockItem;
begin
  TypeItem := FindMemoryTypeItem(MemoryType);
  if TypeItem = nil then
    raise Exception.Create(Format(SCnErrorNotRegister, [MemoryType]));
    
  TypeItem^.Lock.Enter;
  try
    for I := TypeItem.MemoryBlockList.Count - 1 downto 0 do
    begin
      BlockItem := PMemoryBlockItem(TypeItem^.MemoryBlockList[I]);
      if MemoryPtr = BlockItem^.MemoryBlockPtr then         //查询内存块(比较地址相同)
      begin
        if BlockItem^.IsRent then
        begin
          // 归还内存块
          BlockItem^.RentTime := 0;
          BlockItem^.IsRent := False;
          // 内存块超过上限则释放
          if TypeItem^.MemoryBlockList.Count > TypeItem^.MaxCount then
          begin
            FreeMemoryBlockItem(TypeItem, BlockItem);
            TypeItem^.MemoryBlockList.Remove(BlockItem);
          end else
          begin
            TypeItem^.MemoryBlockList.Remove(BlockItem);
            TypeItem^.MemoryBlockList.Insert(0, BlockItem);  //插入到第0个
          end;
          Exit;
        end 
        else
          raise Exception.Create(SCnErrorBlockNotRent);//没有被租用异常 
      end;
    end;
    raise Exception.Create(SCnErrorBlockUnknow);        //没有找到内存块抛出异常
  finally
    TypeItem^.Lock.Release;
  end;
end;

{ TCnIocpSimpleMemPool }

constructor TCnIocpSimpleMemPool.Create(AOwner: TComponent); 
begin
  inherited;
  FMemType := CnMemoryPool.GetFreeMemoryType;
  FBlockMaxCount := 20;
  CnMemoryPool.RegisterMemoryType(FMemType, DoCreateMemory, DoFreeMemory);
end;

destructor TCnIocpSimpleMemPool.Destroy;
begin

  inherited;
end;

procedure TCnIocpSimpleMemPool.DoCreateMemory(var MemoryPtr: Pointer;
  Size: Cardinal);
begin
  if Assigned(FOnCreateMemory) then
  begin
    FOnCreateMemory(MemoryPtr, Size);
    if MemoryPtr <> nil then
      Exit;
  end;
  GetMem(MemoryPtr, Size);
end;

procedure TCnIocpSimpleMemPool.DoFreeMemory(MemoryPtr: Pointer);
begin
  if Assigned(FOnFreeMemory) then
  begin
    FOnFreeMemory(MemoryPtr);
    if MemoryPtr = nil then
      Exit;
  end;
  FreeMem(MemoryPtr);
end;

procedure TCnIocpSimpleMemPool.RentMemory(var MemoryPtr: Pointer;
  Size: Cardinal);
begin
  CnMemoryPool.RentMemory(FMemType, MemoryPtr, Size);
end;

procedure TCnIocpSimpleMemPool.ReturnMemory(MemoryPtr: Pointer);
begin
  CnMemoryPool.ReturnMemory(FMemType, MemoryPtr);
end;

procedure TCnIocpSimpleMemPool.SetBlockMaxCount(Value: Integer);
begin
  if FBlockMaxCount <> Value then
  begin
    FBlockMaxCount := Value;
    CnMemoryPool.SetMaxCount(FMemType, Value);
  end;
end;

initialization
  CnMemoryPool := TCnIocpMemPool.Create;

finalization
  CnMemoryPool.Free;

end.
