ADO连接池

　　Delphi做服务器端如果每次请求都创建一个连接就太耗资源了，而使用一个全局的连接那效率可想而知，这样就体现出了线程池的重要了。参考一些例子做了个ADO的连接池，用到项目中挺不错的，分享下。

{ ******************************************************* }
{ Description : ADO连接池                                 }
{ Create Date : 2010-8-31 23:22:09                        }
{ Modify Remark :2010-9-1 12:00:09                                           }
{ Modify Date :                                           }
{ Version : 1.0                                           }
{ ******************************************************* }

unit ADOConnectionPool;

interface

uses
  Classes, Windows, SyncObjs, SysUtils, ADODB;

type
  TADOConnectionPool = class(TObject)
  private
    FConnectionList:TThreadList;
    //FConnList: TList;
    FTimeout: Integer;
    FMaxCount: Integer;
    FSemaphore: Cardinal;
    //FCriticalSection: TCriticalSection;
    FConnectionString,
    FDataBasePass,
    FDataBaseUser:string;
    function CreateNewInstance(AOwnerList:TList): TADOConnection;
    function GetLock(AOwnerList:TList;Index: Integer): Boolean;
  public
    property ConnectionString:string read FConnectionString write FConnectionString;
    property DataBasePass:string read FDataBasePass write FDataBasePass;
    property DataBaseUser:string read FDataBaseUser write FDataBaseUser;
    property Timeout:Integer read FTimeout write FTimeout;
    property MaxCount:Integer read FMaxCount;

    constructor Create(ACapicity:Integer=15);overload;
    destructor Destroy;override;
    /// <summary>
    /// 申请并一个连接并上锁，使用完必须调用UnlockConnection来释放锁
    /// </summary>
    function LockConnection: TADOConnection;
    /// <summary>
    /// 释放一个连接
    /// </summary>
    procedure UnlockConnection(var Value: TADOConnection);
  end;

type
  PRemoteConnection=^TRemoteConnection;
  TRemoteConnection=record
    Connection : TADOConnection;
    InUse:Boolean;
  end;

var
  ConnectionPool: TADOConnectionPool;

implementation

constructor TADOConnectionPool.Create(ACapicity:Integer=15);
begin
  //FConnList := TList.Create;
  FConnectionList:=TThreadList.Create;
  //FCriticalSection := TCriticalSection.Create;
  FTimeout := 15000;
  FMaxCount := ACapicity;
  FSemaphore := CreateSemaphore(nil, FMaxCount, FMaxCount, nil);
end;

function TADOConnectionPool.CreateNewInstance(AOwnerList:TList): TADOConnection;
var
  p: PRemoteConnection;
begin
  Result := nil;

  New(p);
  p.Connection := TADOConnection.Create(nil);
  p.Connection.ConnectionString := ConnectionString;
  p.Connection.LoginPrompt := False;
  try
    if (DataBaseUser='') and (DataBasePass='') then
      p.Connection.Connected:=True
    else
      p.Connection.Open(DataBaseUser, DataBasePass);
  except
    p.Connection.Free;
    Dispose(p);
    raise;
    Exit;
  end;
  p.InUse := True;
  AOwnerList.Add(p);
  Result := p.Connection;
end;

destructor TADOConnectionPool.Destroy;
var
  i: Integer;
  ConnList:TList;
begin
  //FCriticalSection.Free;
  ConnList:=FConnectionList.LockList;
  try
    for i := ConnList.Count - 1 downto 0 do
    begin
      try
        PRemoteConnection(ConnList[i]).Connection.Free;
        Dispose(ConnList[i]);
      except
        //忽略释放错误
      end;
    end;
  finally
    FConnectionList.UnlockList;
  end;

  FConnectionList.Free;
  CloseHandle(FSemaphore);
  inherited Destroy;
end;

function TADOConnectionPool.GetLock(AOwnerList:TList;Index: Integer): Boolean;
begin
  Result := not PRemoteConnection(AOwnerList[Index]).InUse;
  if Result then
    PRemoteConnection(AOwnerList[Index]).InUse := True;
end;

function TADOConnectionPool.LockConnection: TADOConnection;
var
  i,WaitResult: Integer;
  ConnList:TList;
begin
  Result := nil;
  WaitResult:= WaitForSingleObject(FSemaphore, Timeout);
  if WaitResult = WAIT_FAILED then
    raise Exception.Create('Server busy, please try again');

  ConnList:=FConnectionList.LockList;
  try
    try
      for i := 0 to ConnList.Count - 1 do
      begin
        if GetLock(ConnList,i) then
        begin
          Result := PRemoteConnection(ConnList[i]).Connection;
          Exit;
        end;
      end;
      if ConnList.Count < MaxCount then
        Result := CreateNewInstance(ConnList);
    except
      // 获取信号且失败则释放一个信号量
      if WaitResult=WAIT_OBJECT_0 then
        ReleaseSemaphore(FSemaphore, 1, nil);
      raise;
    end;
  finally
    FConnectionList.UnlockList;
  end;

  if Result = nil then
  begin
    if WaitResult=WAIT_TIMEOUT then
      raise Exception.Create('Timeout expired.Connection pool is full.')
    else
      { This   shouldn 't   happen   because   of   the   sempahore   locks }
      raise Exception.Create('Unable to lock Connection');
  end;
end;

procedure TADOConnectionPool.UnlockConnection(var Value: TADOConnection);
var
  i: Integer;
  ConnList:TList;
begin
  ConnList:=FConnectionList.LockList;
  try
    for i := 0 to ConnList.Count - 1 do
    begin
      if Value = PRemoteConnection(ConnList[i]).Connection then
      begin
        PRemoteConnection(ConnList[I]).InUse := False;
        ReleaseSemaphore(FSemaphore, 1, nil);

        break;
      end;
    end;
  finally
    FConnectionList.UnlockList;
  end;
end;

initialization

ConnectionPool := TADOConnectionPool.Create();

finalization

ConnectionPool.Free;

end.