(*******************************************************************************
FireDac連線池--從何應祖--SQLADOPoolUnit.pas改編，從ado轉到firedac
*******************************************************************************
池滿的情況下 池子DAC連線 動態建立
系統預設池子中 一個小時以上未用的 TFDConnection 連線 系統自動釋放
使用如下
先Uses SQLFirDACPoolUnit 單元
在程式初始化時(initialization)建立連線池類
DAConfig := TDAConfig.Create('YxDServer.ini');
DACPool := TDACPool.Create(32);
在程式關閉時(finalization)釋放連線池類
DACPool.Free;
DAConfig.Free;
呼叫如下
try
FDQuery.Connecttion:= DACPool.GetCon(DAConfig);
FDQuery.Open;
finally
DACPool.PutCon(FDQuery.Connecttion);
end;
QQ:2405414352
2021-3
如有優化 請傳一份 。謝謝！
*********************************************************************************
程式碼源自：作者:何應祖--SQLADOPoolUnit.pas
********************************************************************************)

unit SQLFirDACPoolUnit;

interface

uses
Windows, SqlExpr, SysUtils, Classes, ExtCtrls, DateUtils, IniFiles, uEncry,
Messages, Provider, FireDAC.Comp.Client, FireDAC.Phys.MSSQL,
FireDAC.Phys.ODBCBase, FireDAC.DApt,FireDAC.Moni.FlatFile,FireDAC.Stan.Intf,
FireDAC.Moni.Base,QLog;

type// 資料庫型別
TDBType = (Access, SqlServer, Oracle);
//資料庫配置 DAC

type
TDAConfig = class
private
//資料庫配置
ConnectionName: string; //連線驅動名字
ProviderName: string; //通用驅動
DBServer: ansistring; //資料來源 --資料庫伺服器IP
DataBase: ansistring; //資料庫名字 //sql server連線時需要資料庫名引數--資料庫例項名稱
OSAuthentication: Boolean; //是否是windows驗證
UserName: ansistring; //資料庫使用者
PassWord: ansistring; //密碼
AccessPassWord: string; //Access可能需要資料庫密碼
Port: integer; //資料庫埠
BDEBUG:Boolean; //是否記錄sql語句
DriverName: string; //驅動
HostName: string; //服務地址
//埠配置
TCPPort: Integer; //TCP埠
HttpPort: Integer; //http 埠
LoginSrvUser: string; //驗證中間層服務登入使用者
LoginSrvPassword: string; //驗證登入模組密碼
public
constructor Create(iniFile: string); overload;
destructor Destroy; override;
end;

type
TDACon = class
private
FConnObj: TFDConnection; //資料庫連線物件
FMDFF:TFDMoniFlatFileClientLink; //SQL記錄物件
FAStart: TDateTime; //最後一次活動時間
function GetUseFlag: Boolean;
procedure SetUseFlag(value: Boolean);
procedure FDMFFOutput(ASender: TFDMoniClientLinkBase; const AClassName,
AObjName, AMessage: string);
public
constructor Create(DAConfig: TDAConfig); overload;
destructor Destroy; override;
//當前物件是否被使用
property UseFlag: boolean read GetUseFlag write SetUseFlag;
property ConnObj: TFDConnection read FConnObj;
property AStart: TDateTime read FAStart write FAStart;
end;

type
TDACPool = class
procedure OnMyTimer(Sender: TObject); //做輪詢用
private
FSection: TRTLCriticalSection;
FPoolNumber: Integer; //池大小
FPollingInterval: Integer; //輪詢時間 以 分 為單位
FDACon: TDACon;
FList: TList; //用來管理連線
FTime: TTimer; //主要做輪詢
procedure Enter;
procedure Leave;
function SameConfig(const Source: TDAConfig; Target: TDACon): Boolean;
function GetConnectionCount: Integer;
public
constructor Create(const MaxNumBer: Integer; FreeMinutes: Integer = 60;
TimerTime: Integer = 5000); overload;
destructor Destroy; override;
//從池中取出可用的連線。
function GetCon(const tmpConfig: TDAConfig): TFDConnection;
//把用完的連線放回連線池。
procedure PutCon(const DAConnection: TFDConnection);
//釋放池中許久未用的連線，由定時器定期掃描執行
procedure FreeConnection;
//當前池中連線數.
property ConnectionCount: Integer read GetConnectionCount;
end;

var
DACPool: TDACPool;
DAConfig: TDAConfig;
PoolNum: Integer = 32;

implementation
{ TDAConfig }

constructor TDAConfig.Create(iniFile: string);
var
AINI: TIniFile;
begin
try
AINI := TIniFile.Create(iniFile);
DBServer := AINI.ReadString('DB', 'Server', '');
DataBase := AINI.ReadString('DB', 'DataBase', '');
DBServer := DeCode(AINI.ReadString('DB', 'Server', ''));
DataBase := DeCode(AINI.ReadString('DB', 'DataBase', ''));
UserName := DeCode(AINI.ReadString('DB', 'UserName', ''));
PassWord := DeCode(AINI.ReadString('DB', 'PassWord', ''));
PoolNum := AINI.ReadInteger('YxCisSvr', 'Pools', 32);
BDEBUG := AINI.ReadBool('YxCisSvr', 'SQLDEBUG', False);
finally
Freeandnil(AINI);
end;

end;

destructor TDAConfig.Destroy;
begin
inherited;
end;
{ tdacon }

procedure TDACon.FDMFFOutput(ASender: TFDMoniClientLinkBase;
const AClassName, AObjName, AMessage: string);
begin
PostLog(llDebug,AMessage);
end;

constructor TDACon.Create(DAConfig: TDAConfig);
var
str: string;
begin
str := 'DriverID=MSSQL;Server=' + DAConfig.DBServer + ';Database=' + DAConfig.DataBase
+ ';User_name=' + DAConfig.UserName + ';Password=' + DAConfig.PassWord +
';LoginTimeOut=3';
FConnObj := TFDConnection.Create(nil);
FMDFF := TFDMoniFlatFileClientLink.Create(nil);
with FConnObj,FMDFF do
begin
//ConnectionTimeout:=18000;
ConnectionString := str;
//解決執行sql過程斷線，等待時間過程 ,加上之後，資料量過大寫入會超時！遮蔽！
//Params.add('ResourceOptions.CmdExecTimeout=3');
//解決查詢只返回50條資料問題
Params.add('FetchOptions.Mode=fmAll');
//解決！，&等字元插入資料庫時丟失
Params.add('ResourceOptions.MacroCreate=False');
Params.add('ResourceOptions.MacroExpand=False');
//////////SQL日誌設定/////////
Params.add('MonitorBy=FlatFile');
Params.add('ConnectionIntf.Tracing=True');
FileName := '';
EventKinds := [ekcmdExecute];
ShowTraces := False;
OnOutput := FDMFFOutput;
try
FileEncoding := ecANSI;
Except
raise Exception.Create('正在初始化SQL跟蹤日誌！請重新提交資料！');
end;
///////////////////////////
try
Connected := True;
Tracing := DAConfig.BDEBUG;
except
raise Exception.Create('資料庫連線失敗！請檢查資料庫配置或者網路連結！');
end;
end;
end;

destructor tdacon.Destroy;
begin
FAStart := 0;
if Assigned(FConnObj) then
begin
if FConnObj.Connected then
FConnObj.Close;
FreeAndnil(FConnObj);
FreeAndnil(FMDFF);
end;
inherited;
end;

procedure tdacon.SetUseFlag(value: Boolean);
begin
//False表示閒置，True表示在使用。
if not value then
FConnObj.Tag := 0
else
begin
if FConnObj.Tag = 0 then
FConnObj.Tag := 1; //設定為使用標識。
FAStart := now; //設定啟用時間 。
end;
end;

function tdacon.GetUseFlag: Boolean;
begin
Result := (FConnObj.Tag > 0); //Tag=0表示閒置，Tag>0表示在使用。
end;
{ TDACPool }

constructor TDACPool.Create(const MaxNumBer: Integer; FreeMinutes: Integer = 60;
TimerTime: Integer = 5000);
begin
InitializeCriticalSection(FSection);
FPOOLNUMBER := MaxNumBer; //設定池大小
FPollingInterval := FreeMinutes; // 連線池中 FPollingInterval 以上沒用的 自動回收連線池
FList := TList.Create;
FTime := TTimer.Create(nil);
FTime.Enabled := False;
FTime.Interval := TimerTime; //5秒檢查一次
FTime.OnTimer := OnMyTimer;
FTime.Enabled := True;
end;

destructor TDACPool.Destroy;
var
i: integer;
begin
FTime.OnTimer := nil;
FTime.Free;
for i := FList.Count - 1 downto 0 do
begin
try
FDACon := TDAcon(FList.Items[i]);
if Assigned(FDACon) then
FreeAndNil(FDACon);
FList.Delete(i);
except
end;
end;
FList.Free;
DeleteCriticalSection(FSection);
inherited;
end;

procedure TDACPool.Enter;
begin
EnterCriticalSection(FSection);
//System.TMonitor.Enter(self);
end;

procedure TDACPool.Leave;
begin
LeaveCriticalSection(FSection);
// System.TMonitor.Exit(self);
end;
//根據字串連線引數 取出當前連線池可以用的tdaconnection

function TDACPool.GetCon(const tmpConfig: TDAConfig): TFDConnection;
var
i: Integer;
IsResult: Boolean; //標識
CurOutTime: Integer;
begin
Result := nil;
IsResult := False;
CurOutTime := 0;
Enter;
try
for i := 0 to FList.Count - 1 do
begin
FDACon := TDACon(FList.Items[i]);
if not FDACon.UseFlag then //可用
if SameConfig(tmpConfig, FDACon) then //找到
begin
FDACon.UseFlag := True; //標記已經分配用了
Result := FDACon.ConnObj;
IsResult := True;
Break; //退出迴圈
end;
end; // end for
finally
Leave;
end;
if IsResult then
Exit;
//池未滿 新建一個
Enter;
try
if FList.Count < FPOOLNUMBER then //池未滿
begin
FDACon := tdacon.Create(tmpConfig);
FDACon.UseFlag := True;
Result := FDACon.ConnObj;
IsResult := True;
FList.Add(FDACon); //加入管理佇列
end;
finally
Leave;
end;
if IsResult then
Exit;
//池滿 等待 等候釋放
while True do
begin
Enter;
try
for i := 0 to FList.Count - 1 do
begin
FDACon := tdacon(FList.Items[i]);
if SameConfig(tmpConfig, FDACon) then //找到
if not FDACon.UseFlag then //可用
begin
FDACon.UseFlag := True; //標記已經分配用了
Result := FDACon.ConnObj;
IsResult := True;
Break; //退出迴圈
end;
end; // end for
if IsResult then
Break; //找到退出
finally
Leave;
end;
//如果不存在這種字串的池子 則 一直等到超時
if CurOutTime >= 5000 * 6 then //1分鐘
begin
raise Exception.Create('連線超時!');
Break;
end;
Sleep(500); //0.5秒鐘
CurOutTime := CurOutTime + 500; //超時設定成60秒
end; //end while
end;

procedure TDACPool.PutCon(const DAConnection: TFDConnection);
var
i: Integer;
begin
{
if not Assigned(DAConnection) then Exit;
try
Enter;
DAConnection.Tag := 0; //如此應該也可以 ，未測試...
finally
Leave;
end;
}
Enter; //併發控制
try
for i := FList.Count - 1 downto 0 do
begin
FDACon := tdacon(FList.Items[i]);
if FDACon.ConnObj = DAConnection then
begin
FDACon.UseFlag := False;
Break;
end;
end;
finally
Leave;
end;
end;

procedure TDACPool.FreeConnection;
var
i: Integer;

function MyMinutesBetween(const ANow, AThen: TDateTime): Integer;
begin
Result := Round(MinuteSpan(ANow, AThen));
end;

begin
Enter;
try
for i := FList.Count - 1 downto 0 do
begin
FDACon := tdacon(FList.Items[i]);
if MyMinutesBetween(Now, FDACon.AStart) >= FPollingInterval then //釋放池子許久不用的DAC
begin
FreeAndNil(FDACon);
FList.Delete(i);
end;
end;
finally
Leave;
end;
end;

procedure TDACPool.OnMyTimer(Sender: TObject);
begin
FreeConnection;
end;

function TDACPool.SameConfig(const Source: TDAConfig; Target: TDACon): Boolean;
begin
//考慮到支援多資料庫連線，需要本方法做如下等效連線判斷.如果是單一資料庫，可忽略本過程。
{ Result := False;
if not Assigned(Source) then Exit;
if not Assigned(Target) then Exit;
Result := SameStr(LowerCase(Source.ConnectionName),LowerCase(Target.ConnObj.Name));
Result := Result and SameStr(LowerCase(Source.DriverName),LowerCase(Target.ConnObj.Provider));
Result := Result and SameStr(LowerCase(Source.HostName),LowerCase(Target.ConnObj.Properties['Data Source'].Value));
Result := Result and SameStr(LowerCase(Source.DataBase),LowerCase(Target.ConnObj.Properties['Initial Catalog'].Value));
Result := Result and SameStr(LowerCase(Source.UserName),LowerCase(Target.ConnObj.Properties['User ID'].Value));
Result := Result and SameStr(LowerCase(Source.PassWord),LowerCase(Target.ConnObj.Properties['Password'].Value));
//Result := Result and (Source.OSAuthentication = Target.ConnObj.OSAuthentication);
}
end;

function TDACPool.GetConnectionCount: Integer;
begin
Result := FList.Count;
end;
//初始化時建立物件

initialization
DAConfig := TDAConfig.Create(ChangeFileExt(ParamStr(0), '.ini'));
DACPool := TDACPool.Create(PoolNum);

finalization
if Assigned(DACPool) then
DACPool.Free;
if Assigned(DAConfig) then
DAConfig.Free;

end.