Delphi数据库连接池源码

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=