Delphi資料庫連線池原始碼
阿新 • • 發佈:2019-01-23
1.連線池基類THL_RTC_DBPool,可以在這個類基礎上繼承實現具體資料庫的連線池
unit THighlander_rtcDatabasePool; // RTC SDK Test proyect // freeware // Font used in Delphi IDE = Fixedsys { Database parameters: Set before first call to AddDBConn or GetDBConn. Put a database connection back into the pool. Need to call this after you抮e done using the connection. GetDBConn = Get database connection from the pool. Need to call this after you抮e done using the connection. CloseAllDBConns = Close all connections inside the Pool. } interface uses // From CodeGear Classes, SysUtils, // From RealThinClient rtcSyncObjs; type THL_RTC_DBPool = class private CS : TRtcCritSec; fDBPool : TList; protected function SetUpDB : TComponent; virtual; abstract; function InternalGetDBConn : TComponent; function GetCount : integer; procedure InternalPutDBConn(conn : TComponent ); public db_server : ansistring; db_username : ansistring; db_password : ansistring; property Count : integer read GetCount; constructor Create; destructor Destroy; override; procedure AddDBConn; procedure CloseAllDBConns ; end; implementation constructor THL_RTC_DBPool.Create; begin inherited Create; CS := TRtcCritSec.Create; fDBPool := TList.Create; end; Function THL_RTC_DBPool.GetCount : integer; begin result := fDBPool.Count; end; destructor THL_RTC_DBPool.Destroy; begin CloseAllDBConns; fDBPool.Free; CS.Free; inherited; end; procedure THL_RTC_DBPool.AddDBConn; begin CS.Enter; try fDBPool.Add(SetUpDB); finally CS.Leave; end; end; Function THL_RTC_DBPool.InternalGetDBConn : TComponent; begin Result := nil; CS.Enter; try if fDBPool.Count > 0 then begin Result := fDBPool.items[fDBPool.Count-1]; fDBPool.Delete(fDBPool.Count-1); end; finally CS.Leave; end; end; procedure THL_RTC_DBPool.InternalPutDBConn(conn : tcomponent) ; begin CS.Enter; try fDBPool.Add(conn); finally CS.Leave; end; end; procedure THL_RTC_DBPool.CloseAllDBConns; var i : integer; dbx : tComponent; begin CS.Enter; try for i := 0 to fDBPool.count - 1 do begin dbx := fDBPool.items[i]; FreeAndNil(dbx); end; fDBPool.clear; finally CS.Leave; end; end; end.
2.在THL_RTC_DBPool上繼承生成THL_RTC_IBXDBPoll連線池
unit THighlander_rtcIBXDatabasePool; // RTC SDK Test proyect // freeware // Font used in Delphi IDE = Fixedsys interface uses // From CodeGear Classes, SysUtils, // Classes and Components for accessing Interbase from Codegear IBDatabase, // From RealThinClient rtcSyncObjs, // Dennis Ortiz rtc DBPool version; THighlander_rtcDatabasePool; type THL_RTC_IBXDBPoll = class(THL_RTC_DBPool) protected function SetUpDB : TComponent; override; public function GetDBConn : TIBDatabase; procedure PutDBConn(conn : TIBDatabase); end; implementation function THL_RTC_IBXDBPoll.SetUpDB : Tcomponent; var pIBXTrans : TIBTransaction; begin Result := TIBDatabase.Create(nil); try tIBDatabase(result).DatabaseName := db_server; tIBDatabase(result).LoginPrompt := false; pIBXTrans := TIBTransaction.Create(tIBDatabase(result)); pIBXTrans.Params.Clear; pIbxTrans.Params.Add('read_committed'); pIbxTrans.Params.Add('rec_version'); pIbxTrans.Params.Add('nowait'); tIBDatabase(result).DefaultTransaction := pIBXTrans; tIBDatabase(result).Params.Clear; tIBDatabase(result).Params.add('user_name='+db_UserName); tIBDatabase(result).Params.add('password='+db_Password); tIBDatabase(result).Open; except FreeAndNil(Result); raise; end; end; function THL_RTC_IBXDBPoll.GetDBConn : TIBDatabase; begin result := TIBDatabase(InternalGetDBConn); if Result = nil then begin Result := TIBDatabase(SetupDB); end else if not Result.Connected then begin Result.Free; Result := TIBDatabase(SetupDB); end; end; procedure THL_RTC_IBXDBPoll.PutDBConn(conn : tIBDatabase); begin if conn is tIBDatabase then InternalPutDBConn(conn); end; end.
原始碼來自:http://www.realthinclient.com/sdkarchive/index9f38.html?cmd=viewtopic&topic_id=11§ion_id=23&sid=