ADOConnection數據庫連接池

幾種寫法，暫時還沒有細看。先轉了再說：

1、

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.

　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.

當連接數多，使用頻繁時，用連接池大大提高效率

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.

aroc_lo

發佈了171 篇原創文章 · 獲贊 15 · 訪問量 65萬+

他的留言板關注

ADOConnection數據庫連接池

vue項目獲取富文本編輯器wangEditor內容導出爲word（html轉word格式並下載）

dotnet C# 創建 X11 應用時設置窗口背景顏色

Navicat安裝與激活教程

TDengine docker安裝方法

vue3組件通信與props

sapui5

Alpine Linux apk add DNS lookup error

部分JDK版本的發佈時間

工作中用到的腳本合集

合併代碼時Beyond Compare設置

分組字符合並SQL語句

一個簡易的加解密字符串函數

軟件在運行期，修改panel的位置與大小

uniGui 出現 [FireDAC][Phys][ODBC][Microsoft][ODBC SQL Server Driver]連接佔線導致另一個 hstmt

delphi bpl插件系統開發

https://yachay.unat.edu.pe/blog/index.php?comment_area=format_blog&comment_component=blog&comment_co

linux以太網驅動總結