ADOConnection数据库连接池

unit AdoconnectPool;

interface

uses
  Classes, Windows, SysUtils, ADODB, IniFiles, forms;

type
  TADOConnectionPool = class(TObject)
  private
    FObjList:TThreadList;
    FTimeout: Integer;
    FMaxCount: Integer;
    FSemaphore: Cardinal;
    function CreateNewInstance(List:TList): TADOConnection;
    function GetLock(List:TList;Index: Integer): Boolean;
  public
    property Timeout:Integer read FTimeout write FTimeout;
    property MaxCount:Integer read FMaxCount;

    constructor Create(ACapicity:Integer=30);overload;
    destructor Destroy;override;
    function Lock: TADOConnection;
    procedure Unlock(var Value: TADOConnection);
  end;

var
  ConnPool: TADOConnectionPool;
  g_ini: TIniFile;

implementation

constructor TADOConnectionPool.Create(ACapicity:Integer=30);
begin
  FObjList:=TThreadList.Create;
  FTimeout := 3000;              // 3 second
  FMaxCount := ACapicity;
  FSemaphore := CreateSemaphore(nil, FMaxCount, FMaxCount, nil);
end;

function TADOConnectionPool.CreateNewInstance(List:TList): TADOConnection;
var
  p: TADOConnection;

  function GetConnStr: string;
  begin
    try
      Result := g_ini.ReadString('ado','connstr','');
    except
      Exit;
    end;
  end;
begin
  try
    p := TADOConnection.Create(nil);
    p.ConnectionString := GetConnStr;
    p.LoginPrompt := False;
    p.Connected:=True;
    p.Tag := 1;
    List.Add(p);
    Result := p;
  except
    on E: Exception do
    begin
      Result := nil;
      Exit;
    end;
  end;
end;

destructor TADOConnectionPool.Destroy;
var
  i: Integer;
  List:TList;
begin
  List:=FObjList.LockList;
  try
    for i := List.Count - 1 downto 0 do
    begin
      TADOConnection(List[i]).Free;
    end;
  finally
    FObjList.UnlockList;
  end;
  FObjList.Free;
  FObjList := nil;
  CloseHandle(FSemaphore);
  inherited;
end;

function TADOConnectionPool.GetLock(List:TList;Index: Integer): Boolean;
begin
  try
    Result := TADOConnection(List[Index]).Tag = 0;
    if Result then
      TADOConnection(List[Index]).Tag := 1;
  except
    Result :=False;
    Exit;
  end;
end;

function TADOConnectionPool.Lock: TADOConnection;
var
  i: Integer;
  List:TList;
begin
  try
    Result :=nil;
    if WaitForSingleObject(FSemaphore, Timeout) = WAIT_FAILED then Exit;
    List:=FObjList.LockList;
    try
      for i := 0 to List.Count - 1 do
      begin
        if GetLock(List,i) then
        begin
          Result := TADOConnection(List[i]);
          PostMessage(Application.MainForm.Handle,8888,13,0);
          Exit;
        end;
      end;
      if List.Count < MaxCount then
      begin
        Result := CreateNewInstance(List);
        PostMessage(Application.MainForm.Handle,8888,11,0);
      end;
    finally
      FObjList.UnlockList;
    end;
  except
    Result := nil;
    Exit;
  end;
end;

procedure TADOConnectionPool.Unlock(var Value: TADOConnection);
var
  List:TList;
begin
  try
    List:=FObjList.LockList;
    try
      TADOConnection(List[List.IndexOf(Value)]).Tag :=0;
      ReleaseSemaphore(FSemaphore, 1, nil);
    finally
      FObjList.UnlockList;
    end;
    PostMessage(Application.MainForm.Handle, 8888, 12, 0);
  except
    Exit;
  end;
end;

initialization
  ConnPool := TADOConnectionPool.Create();
  g_ini := TIniFile.Create(ExtractFilePath(Application.ExeName)+'server.ini');
finalization
  FreeAndNil(ConnPool);
  FreeAndNil(g_ini);

end.

2.

　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.

 

3.

当连接数多，使用频繁时，用连接池大大提高效率

unit uDBPool;

interface

uses Classes ,ADODB,ADOInt,Messages,SysUtils,DataDefine,Windows , Forms,
    Dialogs;

type
   TDBPool = class
   private
     FList :TList;
     FbLoad :Boolean;
     FsConnStr :String;
     FbResetConnect: Boolean;  //是否准备复位所有的连接

     CS_GetConn: TRTLCriticalSection;
     FConnStatus: Boolean;// ADOConnection 连接状态
     procedure Clear;
     procedure Load;
   protected
     procedure ConRollbackTransComplete(
                Connection: TADOConnection; const Error: ADOInt.Error;
                var EventStatus: TEventStatus);
     procedure ConCommitTransComplete(
                Connection: TADOConnection; const Error: ADOInt.Error;
                var EventStatus: TEventStatus);
     procedure ConBeginTransComplete(
                Connection: TADOConnection; TransactionLevel: Integer;
                const Error: ADOInt.Error; var EventStatus: TEventStatus);
   public
     constructor Create(ConnStr :string);
     destructor Destroy; override;
     procedure Reset;
     function GetConnection: PRecConnection;
     procedure AddConnetion ;  // GetConnection繁忙遍历多次时，添加新连接
     procedure FreeIdleConnetion ; // 销毁闲着的链接
     procedure RemoveConnection(ARecConnetion: PRecConnection);
     procedure CloseConnection;   //关闭所有连接
     property bConnStauts : Boolean read FConnStatus write FConnStatus default True;
   end;

var
  DataBasePool : TDBPool;

implementation

{ TDBPool }

procedure TDBPool.ConRollbackTransComplete(
  Connection: TADOConnection; const Error: ADOInt.Error;
  var EventStatus: TEventStatus);
begin
  Now_SWcount := Now_SWcount-1;
end;

procedure TDBPool.ConCommitTransComplete(
  Connection: TADOConnection; const Error: ADOInt.Error;
  var EventStatus: TEventStatus);
begin
  Now_SWcount := Now_SWcount-1;
end;

procedure TDBPool.ConBeginTransComplete(
  Connection: TADOConnection; TransactionLevel: Integer;
  const Error: ADOInt.Error; var EventStatus: TEventStatus);
begin
  Now_SWcount := Now_SWcount+1;
end;

constructor TDBPool.Create(ConnStr: string);
begin
  inherited Create;
  InitializeCriticalSection(CS_GetConn); //初始临界区对象。
  FbResetConnect := False;
  FList  := TList.Create;
  FbLoad := False;
  FsConnStr := ConnStr;
  Load;
end;

destructor TDBPool.Destroy;
begin
  Clear;
  FList.Free;
  DeleteCriticalSection(CS_GetConn);
  inherited;
end;

procedure TDBPool.Clear;
var
  i:Integer;
  tmpRecConn :PRecConnection;
begin
  for i:= 0 to FList.Count-1 do
  begin
    tmpRecConn := FList.items[i];
    tmpRecConn^.ADOConnection.Close;
    tmpRecConn^.ADOConnection.Free;
    Dispose(tmpRecConn);
    FList.Items[i] := nil;
  end;
  FList.Pack;
  FList.Clear;
end;

procedure TDBPool.Load;
var
  i :Integer;
  tmpRecConn :PRecConnection;
  AdoConn :TADOConnection;
begin
  if FbLoad then Exit;
  Clear;
  for i:=1 to iConnCount do
  begin
    AdoConn := TADOConnection.Create(nil);
    AdoConn.ConnectionString:= FsConnStr;
    AdoConn.OnRollbackTransComplete := ConRollbackTransComplete;
    AdoConn.OnCommitTransComplete   := ConCommitTransComplete;
    AdoConn.OnBeginTransComplete    := ConBeginTransComplete;
//    AdoConn.Open;
    AdoConn.LoginPrompt := False;
    New(tmpRecConn);
    tmpRecConn^.ADOConnection := AdoConn;
    tmpRecConn^.isBusy := False;
    FList.Add(tmpRecConn);
    FConnStatus := True;
  end;
end;

procedure TDBPool.Reset;
begin
  FbLoad := False;
  Load;
end;

function TDBPool.GetConnection: PRecConnection;
var
  i :Integer;
  tmpRecConnection :PRecConnection;
  bFind :Boolean ;
begin
  Result := nil;
  //                   1、加互斥对象，防止多客户端同时访问
  //                   2、改为循环获取连接，知道获取到为止
  //                   3、加判断ADOConnection 没链接是才打开

  EnterCriticalSection(CS_GetConn);
  bFind :=False ;
  try
    try
      //iFindFount :=0 ;
    while (not bFind) and (not FbResetConnect) do
      begin
//        if not FConnStatus then     //当测试断线的时候可能ADOConnection的状态不一定为False
//          Reset;
        for i:= 0 to FList.Count-1 do
        begin
          //PRecConnection(FList.Items[i])^.ADOConnection.Close ;
          tmpRecConnection := FList.Items[i];
          if not tmpRecConnection^.isBusy then
          begin
            if not tmpRecConnection^.ADOConnection.Connected then
              tmpRecConnection^.ADOConnection.Open;
            tmpRecConnection^.isBusy := True;
            Result := tmpRecConnection;
            bFind :=True ;
            Break;
          end;
        end;
      application.ProcessMessages;
        Sleep(50) ;
       { Inc(iFindFount) ;
        if(iFindFount>=1) then
        begin       // 遍历5次还找不到空闲连接，则添加链接
          AddConnetion ;
        end;  }
      end ;
    except
      on e: Exception do
        raise Exception.Create('TDBPOOL.GetConnection-->' + e.Message);
    end;
  finally
    LeaveCriticalSection(CS_GetConn);
  end ;
end;

procedure TDBPool.RemoveConnection(ARecConnetion: PRecConnection);
begin
  if ARecConnetion^.ADOConnection.InTransaction then
     ARecConnetion^.ADOConnection.CommitTrans;
  ARecConnetion^.isBusy := False;
end;

procedure TDBPool.AddConnetion;
var
  i,uAddCount :Integer ;
  tmpRecConn :PRecConnection;
  AdoConn : TADOConnection ;
begin
  if  FList.Count >= iMaxConnCount  then
    Exit ;
  if iMaxConnCount - FList.Count > 10 then
  begin
    uAddCount :=10 ;
  end else
  begin
    uAddCount :=iMaxConnCount - FList.Count ;
  end;
  for i:=1 to uAddCount do
  begin
    AdoConn := TADOConnection.Create(nil);
    AdoConn.ConnectionString:= FsConnStr;
    AdoConn.OnRollbackTransComplete := ConRollbackTransComplete;
    AdoConn.OnCommitTransComplete   := ConCommitTransComplete;
    AdoConn.OnBeginTransComplete    := ConBeginTransComplete;
//    AdoConn.Open;
    AdoConn.LoginPrompt := False;
    New(tmpRecConn);
    tmpRecConn^.ADOConnection := AdoConn;
    tmpRecConn^.isBusy := False;
    FList.Add(tmpRecConn);
    Dispose(tmpRecConn) ;
  end;
end;

procedure TDBPool.FreeIdleConnetion;
var
  i,uFreeCount,uMaxFreeCount :Integer ;
  tmpRecConn : PRecConnection ;
begin
  if FList.Count<=iConnCount then
    Exit ;
  uMaxFreeCount :=FList.Count- iConnCount ;
  uFreeCount :=0 ;
  for i:= 0 to FList.Count do
  begin
    if (uFreeCount>=uMaxFreeCount) then
      Break ;
   // New(tmpRecConn) ;
    tmpRecConn := FList.items[i];
    if tmpRecConn^.isBusy =False  then
    begin
      tmpRecConn^.ADOConnection.Close;
      tmpRecConn^.ADOConnection.Free;
      uFreeCount :=uFreeCount +1 ;
    end;
    Dispose(tmpRecConn);
    FList.Items[i] := nil;
  end;
  FList.Pack;
end;

procedure TDBPool.CloseConnection;
begin
  FbResetConnect := True;
  EnterCriticalSection(CS_GetConn);
  try
    Reset;
  finally
    LeaveCriticalSection(CS_GetConn);
    FbResetConnect := False;
  end;
end;

end.

 http://blog.csdn.net/aroc_lo/article/details/22299303