Delphi数据库连接池

工作中用的数据库连接池，非常好用，和大家分享一下。也希望共同探讨。

unit uAdoDb;

interface


uses
SysUtils, Classes, DB, ADODB, Variants, ActiveX, IdGlobal,
SyncObjs, Windows, IdThread, DateUtils, Math;


type
TObjectEvent = procedure(Sender: TObject; var AObject: TObject) of object;
TADOConnectionPool = class;


EConnPoolException = class(Exception)
end;


IDBConnection = interface(IInterface)
function Connection: TADOConnection;
function GetRefCount: integer;
function GetLastAccess: TDateTime;
function NoInUse: Boolean; stdcall;
property LastAccess: TDateTime read GetLastAccess;
property RefCount: integer read GetRefCount;
end;


TPoolDBConnection = class(TComponent, IDBConnection)
SQLConnection1: TADOConnection;
private
CriticalSection: TCriticalSection;
protected
FRefCount: integer;
FLastAccess: TDateTime;


Semaphore: THandle;


function _AddRef: integer; stdcall;
function _Release: integer; stdcall;


function GetLastAccess: TDateTime;
function GetRefCount: integer;
function NoInUse: Boolean; stdcall;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function Connection: TADOConnection;
end;


TCleanupThread = class(TThread)
private
FCleanupDelay: integer;
protected


CriticalSection: TCriticalSection;
ConnectionPool: TADOConnectionPool;
procedure Execute; override;
constructor Create(CreateSuspended: Boolean;
const CleanupDelayMinutes: integer);
end;


TADOConnectionPool = class(TObject)
private
FPool: array of IDBConnection;
FLock: array of TCriticalSection;
FTimeout: LargeInt;
CleanupThread: TCleanupThread;
Semaphore: THandle;
cs: TCriticalSection;
FOnCreateObject: TObjectEvent;
FPoolSize: integer;
public
constructor Create(const PoolSize: integer = 10; const CleanupDelayMinutes: integer = 5;
const Timeoutms: LargeInt = 60000); overload;
destructor Destroy; override;
function Acquire: IDBConnection;
procedure ClearLock;
function NewItem(const Index: integer): IDBConnection;
property OnCreateObject: TObjectEvent read FOnCreateObject write
FOnCreateObject;
end;


{ 数据库操作基类 }
TAdoDb = class
protected
//
public
// 通用数据库处理
class function GetFirstValInt(const sSql: string; const AConn: TADOConnection;
DefaultVal: integer = 0): integer;
class function GetFirstValDbl(const sSql: string; const AConn: TADOConnection;
DefaultVal: Double = 0): Double;
class function GetFirstValStr(const sSql: string; const AConn: TADOConnection;
DefaultVal: string = ''): string;
class function GetSomeValStr(const sSql: string; const AConn: TADOConnection;
const sSplit: string = #13#10; bTrim: Boolean = False): string;
end;


TAdoDbServer = class(TAdoDb)
private
FConnectionString: string;
procedure SetConnectionString(const Value: string);
public
ConnectTimeout: integer;
FConnections: TADOConnectionPool;
constructor Create; reintroduce; virtual;
destructor Destroy; override;
procedure CreateConnection(Sender: TObject; var AObject: TObject);
function ExecSQL(const Value: string): Boolean;
function GetFirstValInt(const sSql: string; DefaultVal: integer = 0): integer;
function GetFirstValDbl(const sSql: string; DefaultVal: Double = 0): Double;
function GetFirstValStr(const sSql: string; DefaultVal: string = ''): string;
function GetSomeValStr(const sSql: string; const sSplit: string = #13#10;
bTrim: Boolean = False): string;
property Connections: TADOConnectionPool read FConnections;
property ConnectionString: string read FConnectionString write
SetConnectionString;
end;


/// ////////////////////////////////////////////////////////////////////////////
implementation


{ TAdoDbServer }


constructor TAdoDbServer.Create;
begin


inherited Create;

FConnections := TADOConnectionPool.Create(20, 2);
FConnections.OnCreateObject := CreateConnection;
ConnectTimeout := 1000 * 10;
end;


destructor TAdoDbServer.Destroy;
begin
FConnections.Free;
inherited;
end;


procedure TAdoDbServer.CreateConnection(Sender: TObject; var AObject: TObject);
var
tcp: TADOConnection;
begin
try
tcp := TADOConnection.Create(nil);
tcp.ConnectionTimeout := Self.ConnectTimeout;
tcp.ConnectionString := ConnectionString;
tcp.LoginPrompt := False;


tcp.Connected := true;


except
on E: Exception do
begin


tcp.Free;
raise;
end;
end;
AObject := tcp;
end;


function TAdoDbServer.ExecSQL(const Value: string): Boolean;
var
conn: IDBConnection;
Qry2: TADOQuery;
begin
Result := False;
conn := Connections.Acquire;
Qry2 := TADOQuery.Create(nil);
try
Qry2.Connection := conn.Connection;
Qry2.SQL.Text := Value;
Qry2.ExecSQL;
Qry2.Close;
Result := true;
finally
freeandnil(Qry2);


end;


end;


function TAdoDbServer.GetFirstValDbl(const sSql: string; DefaultVal: Double =
0): Double;
var
conn: IDBConnection;
begin
conn := FConnections.Acquire;
try
Result := inherited GetFirstValDbl(sSql, conn.Connection, DefaultVal);
finally


end;


end;


function TAdoDbServer.GetFirstValInt(const sSql: string; DefaultVal: integer =
0): integer;
var
conn: IDBConnection;
begin
conn := FConnections.Acquire;
try
Result := inherited GetFirstValInt(sSql, conn.Connection, DefaultVal);
finally


end;


end;


function TAdoDbServer.GetFirstValStr(const sSql: string; DefaultVal: string =
''): string;
var
conn: IDBConnection;
begin
conn := FConnections.Acquire;
try
Result := inherited GetFirstValStr(sSql, conn.Connection, DefaultVal);
finally


end;
end;


function TAdoDbServer.GetSomeValStr(const sSql: string; const sSplit: string =
#13#10; bTrim: Boolean = False): string;
var
conn: IDBConnection;
begin
conn := FConnections.Acquire;
try
Result := inherited GetSomeValStr(sSql, conn.Connection, sSplit, bTrim);
finally


end;
end;


procedure TAdoDbServer.SetConnectionString(const Value: string);
begin
FConnectionString := Value;
end;


/// ////////////////////////////////////////////////////////////////////////////


{ TAdoDb }


class function TAdoDb.GetFirstValDbl(const sSql: string;
const AConn: TADOConnection; DefaultVal: Double): Double;
var
myQry: TADOQuery;
begin
Result := DefaultVal;
myQry := TADOQuery.Create(nil);
myQry.Connection := AConn;
try
myQry.SQL.Text := sSql;
myQry.Open;
if (myQry.Eof or myQry.Fields[0].IsNull) then
Result := DefaultVal
else
Result := myQry.Fields[0].Value;
finally
myQry.Close;
myQry.Free;
end;
end;


class function TAdoDb.GetFirstValInt(const sSql: string;
const AConn: TADOConnection; DefaultVal: integer): integer;
var
myQry: TADOQuery;
begin
Result := DefaultVal;
myQry := TADOQuery.Create(nil);
myQry.Connection := AConn;
try
myQry.SQL.Text := sSql;
myQry.Open;
if (myQry.Eof or myQry.Fields[0].IsNull) then
Result := DefaultVal
else
Result := myQry.Fields[0].Value;
finally
myQry.Close;
myQry.Free;
end;
end;


class function TAdoDb.GetFirstValStr(const sSql: string;
const AConn: TADOConnection; DefaultVal: string): string;
var
myQry: TADOQuery;
begin
Result := DefaultVal;
myQry := TADOQuery.Create(nil);
myQry.Connection := AConn;
try
myQry.SQL.Text := sSql;
myQry.Open;
if (myQry.Eof or myQry.Fields[0].IsNull) then
Result := DefaultVal
else
Result := myQry.Fields[0].Value;
finally
myQry.Close;
myQry.Free;
end;
end;


class function TAdoDb.GetSomeValStr(const sSql: string;
const AConn: TADOConnection; const sSplit: string;
bTrim: Boolean): string;
var
sFldName, sOne: string;
myQry: TADOQuery;
begin
Result := '';
myQry := TADOQuery.Create(nil);
myQry.Connection := AConn;
// 查询结果
try
myQry.SQL.Text := sSql;
myQry.Open;
sFldName := myQry.Fields[0].FieldName;
while not myQry.Eof do
begin
sOne := myQry.FieldByName(sFldName).AsString; // Fields[0].Value;
if bTrim then
sOne := Trim(sOne);
if Result <> '' then
Result := Result + sSplit;
Result := Result + sOne;
myQry.Next;
end;
finally
myQry.Close;
myQry.Free;
end;
end;


constructor TPoolDBConnection.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
CoInitialize(nil);


end;


destructor TPoolDBConnection.Destroy;
begin


if Assigned(SQLConnection1) then
begin
SQLConnection1.Close;
freeandnil(SQLConnection1);
end;
CoUninitialize;


inherited Destroy;
end;


{ TConnectionModule }


function TPoolDBConnection.Connection: TADOConnection;
begin
Result := SQLConnection1;
end;


function TPoolDBConnection.GetLastAccess: TDateTime;
begin
Result := FLastAccess;
end;


function TPoolDBConnection.GetRefCount: integer;
begin
Result := FRefCount;
end;


function TPoolDBConnection.NoInUse: Boolean;
begin
Result := FRefCount = 1
end;


function TPoolDBConnection._AddRef: integer;
begin


CriticalSection.Enter;
try
// Result := InterlockedIncrement(FRefCount);
Inc(FRefCount);
Result := FRefCount;
finally
CriticalSection.Leave;
end;
end;


function TPoolDBConnection._Release: integer;
begin
CriticalSection.Enter;
try
Dec(FRefCount);
Result := FRefCount;
// Result := InterlockedDecrement(FRefCount);


if Result = 0 then
Destroy
else
Self.FLastAccess := now;
finally
CriticalSection.Leave;
if FRefCount = 1 then
ReleaseSemaphore(Semaphore, 1, nil);
end;
end;


constructor TCleanupThread.Create(CreateSuspended: Boolean;
const CleanupDelayMinutes: integer);
begin


inherited Create(true);
FCleanupDelay := CleanupDelayMinutes;


if not CreateSuspended then
Resume;
end;


procedure TCleanupThread.Execute;
var
i: integer;
tmp: string;
begin
while true do
begin
if Terminated then
exit;
// sleep for delay
Sleep(ceil(FCleanupDelay / 2) * 1000 * 60);
if Terminated then
exit;
ConnectionPool.cs.Enter;
try
for i := low(ConnectionPool.FPool) to High(ConnectionPool.FPool) do
begin
try
if (ConnectionPool.FPool[i] <> nil) and
(ConnectionPool.FPool[i].RefCount = 1) and
(MinutesBetween(ConnectionPool.FPool[i].LastAccess, now) >=
FCleanupDelay) then
ConnectionPool.FPool[i] := nil;
except
on E: Exception do
tmp := E.Message;
end;


end;
finally
ConnectionPool.cs.Leave;
end; // try
end; // while
end;


constructor TADOConnectionPool.Create(const PoolSize: integer = 10;
const CleanupDelayMinutes: integer = 5;
const Timeoutms: LargeInt = 60000);
begin


FPoolSize := PoolSize;
FTimeout := Timeoutms;
Semaphore := CreateSemaphore(nil, PoolSize, PoolSize, '');
cs := TCriticalSection.Create;


SetLength(FPool, PoolSize);
SetLength(FLock, PoolSize);


CleanupThread := TCleanupThread.Create(true, CleanupDelayMinutes);
with CleanupThread do
begin
FreeOnTerminate := true;
Priority := tpLower;
ConnectionPool := Self;
Resume;
end;
end;


function TADOConnectionPool.Acquire: IDBConnection;
var
i: integer;
WaitResult: integer;


begin
Result := nil;
WaitResult := WaitForSingleObject(Semaphore, FTimeout);
if WaitResult <> WAIT_OBJECT_0 then
raise EConnPoolException.Create('服务器忙');
cs.Enter;
try


for i := Low(FPool) to High(FPool) do
begin
if FPool[i] = nil then
begin
Result := NewItem(i);


FPool[i] := Result;
exit;
end;
if FPool[i].NoInUse then
begin
Result := FPool[i];
exit;
end;
end; // for
finally
cs.Leave;
end;
end;


destructor TADOConnectionPool.Destroy;
var
i: integer;
begin
// Free any remaining connections
CleanupThread.Terminate;
cs.Enter;
try
for i := Low(FPool) to High(FPool) do
FPool[i] := nil;
SetLength(FPool, 0);
finally
cs.Leave;
end;
cs.Free;
// Release the semaphore
CloseHandle(Semaphore);
ClearLock;
inherited;
end;


procedure TADOConnectionPool.ClearLock;
var
i: integer;
begin
for i := Low(FLock) to High(FLock) do
begin
if FLock[i] <> nil then


FLock[i].Free;
end;
SetLength(FLock, 0);
end;


function TADOConnectionPool.NewItem(const Index: integer): IDBConnection;
var
tmpobj: TObject;
DM: TPoolDBConnection;
begin
DM := TPoolDBConnection.Create(nil);
DM.Semaphore := Self.Semaphore;
FLock[index] := TCriticalSection.Create;
DM.CriticalSection := FLock[Index];
FOnCreateObject(Self, tmpobj);
DM.SQLConnection1 := TADOConnection(tmpobj);
Result := DM;
end;


end.