数据模块池

unit untDBPool;

interface

uses
Classes, SyncObjs, SysUtils,
DateUtils, untDB, Windows, UntThreadTimer;

const
cMinNum = 10; // 池最多保留10个对象
cMaxNum = 1000; // 池容量 最多创建1000个对象
cTimeOut = 1800000; // 超过30分钟还没有被使用的数据库对象将被释放掉
cInterval = 300000; // threadTimer.interval 隔5分钟轮询一次对象池

type

Pobj = ^Tobj;

Tobj = record
obj: TfrmDB;
InUse: Boolean;
lastFreeTime: TDateTime;
dbIndexNo: Integer;
end;

TDBPool = class
private
FCriticalSection: TCriticalSection;
Fobjs: TList;
FTimer: TThreadedTimer;
procedure myTimer(Sender: TObject);
function GetLoginDBParams(dbIndexNo: Integer): TLoginDBParams;
public
constructor Create; overload;
destructor Destroy; override;
function Lock(dbIndexNo: Integer): TfrmDB;
procedure Unlock(Value: TfrmDB);
end;

var
DBPool: TDBPool;

implementation

uses untLog, untMain;

constructor TDBPool.Create;
begin
Fobjs := TList.Create;
FCriticalSection := TCriticalSection.Create;
FTimer := TThreadedTimer.Create(nil);
FTimer.OnTimer := myTimer;
FTimer.Interval := cInterval;
end;

destructor TDBPool.Destroy;
begin
while Fobjs.Count > 0 do
begin
Pobj(Fobjs[0])^.obj.Free;
Dispose(Pobj(Fobjs[0]));
Fobjs.Delete(0);
end;
FreeAndNil(Fobjs);
FreeAndNil(FCriticalSection);
FreeAndNil(FTimer);
inherited Destroy;
end;

function TDBPool.GetLoginDBParams(dbIndexNo: Integer): TLoginDBParams;
begin
if frmMain.cdsDBConfig.FindKey([dbIndexNo]) then
begin
if SameText(frmMain.cdsDBConfig.FieldByName('dbtype').Text, 'mssql') then
Result.dbType := dbMSSQL
else if SameText(frmMain.cdsDBConfig.FieldByName('dbtype').Text, 'ora') then
Result.dbType := dbOracle;
Result.User_Name := frmMain.cdsDBConfig.FieldByName('user').Text;
Result.Password := frmMain.cdsDBConfig.FieldByName('password').Text;
Result.Server := frmMain.cdsDBConfig.FieldByName('ip').Text;
Result.dbName := frmMain.cdsDBConfig.FieldByName('dbName').Text;
end;
end;

function TDBPool.Lock(dbIndexNo: Integer): TfrmDB;
var
i: Integer;
bFoundFreeObj: Boolean;
p: Pobj;
begin
Result := nil;
try
FCriticalSection.Enter;
try
bFoundFreeObj := False;
if Fobjs.Count = 0 then
begin
Result := TfrmDB.Create(nil);
Result.LoginDBParams := Self.GetLoginDBParams(dbIndexNo);
Result.ConnectDB;
New(p);
p^.InUse := True;
p^.obj := Result;
p^.dbIndexNo := dbIndexNo;
Fobjs.Add(p);
bFoundFreeObj := True;
end
else if Fobjs.Count > 0 then
begin
for i := 0 to Fobjs.Count - 1 do
begin
if (not Pobj(Fobjs[i])^.InUse) and (Pobj(Fobjs[i])^.dbIndexNo = dbIndexNo) then
begin
Pobj(Fobjs[i])^.InUse := True;
Result := Pobj(Fobjs[i])^.obj;
bFoundFreeObj := True;
end;
end;
end;
if (not bFoundFreeObj) and (Fobjs.Count < cMaxNum) then
begin
Result := TfrmDB.Create(nil);
Result.LoginDBParams := Self.GetLoginDBParams(dbIndexNo);
Result.ConnectDB;
New(p);
p^.InUse := true;
p^.obj := Result;
p^.dbIndexNo := dbIndexNo;
Fobjs.Add(p);
end;
finally
FCriticalSection.Leave;
end;
except
on E: Exception do
begin
Log.WriteLog('TDBPool.Lock ' + E.Message);
exit;
end;
end;
end;

procedure TDBPool.myTimer(Sender: TObject);
var
i: Integer;
begin
if Fobjs.Count > cMinNum then
try
for i := Fobjs.Count - 1 downto 0 do
begin
if (not Pobj(Fobjs[i])^.InUse) and
((now - Pobj(Fobjs[i])^.lastFreeTime) > cTimeOut) then
begin
Pobj(Fobjs[i])^.obj.Free;
Dispose(Pobj(Fobjs[i]));
Fobjs.Delete(i);
end;
end;
except
on E: Exception do
begin
Log.WriteLog('TDBPool.myTimer ' + E.Message);
exit;
end;
end;
end;

procedure TDBPool.Unlock(Value: TfrmDB);
var
i: Integer;
begin
if not Assigned(Value) then
exit;
try
FCriticalSection.Enter;
try
for i := 0 to Fobjs.Count - 1 do
begin
if Value = Pobj(Fobjs[i])^.obj then
begin
Pobj(Fobjs[i])^.InUse := False;
Pobj(Fobjs[i])^.lastFreeTime := now;
Break;
end;
end;
finally
FCriticalSection.Leave;
end;
except
On E: Exception do
begin
Log.WriteLog('TDBPool.Unlock ' + E.Message);
exit;
end;
end;
end;

end.

unit untMethodPool;

interface

uses
Classes, SyncObjs, SysUtils,
DateUtils, ServerMethodsUnit1, Windows, UntThreadTimer;

const
cMinNum = 10; // 池最多保留10个对象
cMaxNum = 1000; // 池容量 最多创建1000个对象
cTimeOut = 1800000; // 超过30分钟还没有被使用的数据库对象将被释放掉
cInterval = 300000; // threadTimer.interval 隔5分钟轮询一次对象池

type

Pobj = ^Tobj;

Tobj = record
obj: TServerMethods1;
InUse: Boolean;
lastFreeTime: TDateTime;
end;

TMethodPool = class
private
FCriticalSection: TCriticalSection;
Fobjs: TList;
FTimer: TThreadedTimer;
procedure myTimer(Sender: TObject);
public
constructor Create; overload;
destructor Destroy; override;
function Lock: TServerMethods1;
procedure Unlock(Value: TServerMethods1);
end;

var
MethodPool: TMethodPool;

implementation

uses untLog, untMain;

constructor TMethodPool.Create;
begin
Fobjs := TList.Create;
FCriticalSection := TCriticalSection.Create;
FTimer := TThreadedTimer.Create(nil);
FTimer.OnTimer := myTimer;
FTimer.Interval := cInterval;
end;

destructor TMethodPool.Destroy;
begin
while Fobjs.Count > 0 do
begin
Pobj(Fobjs[0])^.obj.Free;
Dispose(Pobj(Fobjs[0]));
Fobjs.Delete(0);
end;
FreeAndNil(Fobjs);
FreeAndNil(FCriticalSection);
FreeAndNil(FTimer);
inherited Destroy;
end;

function TMethodPool.Lock: TServerMethods1;
var
i: Integer;
bFoundFreeObj: Boolean;
p: Pobj;
begin
Result := nil;
try
FCriticalSection.Enter;
try
bFoundFreeObj := False;
if Fobjs.Count = 0 then
begin
Result := TServerMethods1.Create(nil);
New(p);
p^.InUse := True;
p^.obj := Result;
Fobjs.Add(p);
bFoundFreeObj := True;
end
else if Fobjs.Count > 0 then
begin
for i := 0 to Fobjs.Count - 1 do
begin
if not Pobj(Fobjs[i])^.InUse then
begin
Pobj(Fobjs[i])^.InUse := True;
Result := Pobj(Fobjs[i])^.obj;
bFoundFreeObj := True;
end;
end;
end;
if (not bFoundFreeObj) and (Fobjs.Count < cMaxNum) then
begin
Result := TServerMethods1.Create(nil);
New(p);
p^.InUse := true;
p^.obj := Result;
Fobjs.Add(p);
end;
finally
FCriticalSection.Leave;
end;
except
on E: Exception do
begin
Log.WriteLog('TMethodPool.Lock ' + E.Message);
exit;
end;
end;
end;

procedure TMethodPool.myTimer(Sender: TObject);
var
i: Integer;
begin
if Fobjs.Count > cMinNum then
try
for i := Fobjs.Count - 1 downto 0 do
begin
if (not Pobj(Fobjs[i])^.InUse) and
((now - Pobj(Fobjs[i])^.lastFreeTime) > cTimeOut) then
begin
Pobj(Fobjs[i])^.obj.Free;
Dispose(Pobj(Fobjs[i]));
Fobjs.Delete(i);
end;
end;
except
on E: Exception do
begin
Log.WriteLog('TMethodPool.myTimer ' + E.Message);
exit;
end;
end;
end;

procedure TMethodPool.Unlock(Value: TServerMethods1);
var
i: Integer;
begin
if not Assigned(Value) then
exit;
try
FCriticalSection.Enter;
try
for i := 0 to Fobjs.Count - 1 do
begin
if Value = Pobj(Fobjs[i])^.obj then
begin
Pobj(Fobjs[i])^.InUse := False;
Pobj(Fobjs[i])^.lastFreeTime := now;
Break;
end;
end;
finally
FCriticalSection.Leave;
end;
except
On E: Exception do
begin
Log.WriteLog('TMethodPool.Unlock ' + E.Message);
exit;
end;
end;
end;

end.