unit ConnPool;
interface
uses
SysUtils, Classes, SyncObjs, Windows, Variants,
DateUtils, IniFiles, math, StrUtils,
Ora, OraProvider, DBAccess, DB,
ConnPool_Intr, DAScript, OraScript, MemDS;
type
IConnection = Interface(IInterface)
function Connection: TOraSession;
function GetLastAccess: TDateTime;
function GetRefCount: Integer;
property LastAccess: TDateTime read GetLastAccess;
property RefCount: Integer read GetRefCount;
procedure BeginTrans;
procedure RollbackTrans;
function CommitTrans: Boolean;
function ExecSQL(const SQL: AnsiString; const Params: array of variant): Boolean;
function OpenSQL(const SQL: AnsiString; const Params: array of variant): Variant;
function GetStringByDB(const SQL: AnsiString): string;
function ExecScript(const SQL: AnsiString): Boolean;
function CheckLogin(const UID, Pass, LocalIP: AnsiString;
const Version: integer; Var workURL : AnsiString): integer;
function ProcOpen(const ProcName: AnsiString;
const ParamName: array of variant; const ParamValue: array of variant): Variant;
end;
EConnPoolException = class(Exception);
TCleanupThread = class; //forward declaration
//This is the class that manages the connection pool
TPool = class(TObject)
private
FPool: array of IConnection;
FMinPoolSize, FMaxPoolSize: Integer; // Max PoolSize
FTimeout: Cardinal;
FCS: TCriticalSection;
FConnectString: string; // 连接字符串
thCleanup: TCleanupThread; // Cleanup dead connection
//This semaphore is used to limit the number of
//simultaneous connections. When the nth+1 connection
//is requested, it will be blocked until a connection
//becomes available.
Semaphore: THandle;
public
//This constructor takes two optional
//parameters. These parameters determine the size
//of the connection pool, as well as how long idle
//connections in the connection pool will be kept.
constructor Create(const MinPoolSize: Integer = 3;
const MaxPoolSize: Integer = 50;
const CleanupDelayMinutes: Integer = 5;
const Timeoutms: Cardinal = 10000; const pConn : string = '');
destructor Destroy; override;
//This function returns an object
//that implements the IConnection interface.
//This object can be a data module, as was
//done in this example.
function Get(Index: Integer): IConnection;
function GetConnection: IConnection;
function GetConnectionCount: integer;
property APool[Index: Integer]:IConnection read Get ;
function getPoolCount:integer;
end;
//This thread class is used by the connection pool
//object to cleanup idle connections after a
//configurable period of time.
TCleanupThread = class(TThread)
private
FCleanupDelay: Integer;
FMinSize: Integer;
protected
//When the thread is created, this critical section
//field will be assigned the connection pool's
//critical section. This critical section is
//used to synchronize access to data module
//reference counts.
Pool: TPool;
procedure Execute; override;
constructor Create(CreateSuspended: Boolean;
const MinSize: Integer;
const CleanupDelayMinutes: Integer);
end;
//This data module provides the implementation
//of the IConnection interface. To use a data access
//mechanism other than dbExpress, modify the components
//that appear on this data module, and change the class
//of the Connection function in the IConnection interface
//as well as in this class.
TConnectionModule = class(TDataModule, IConnection)
con: TOraSession;
private
{ Private declarations }
FErrorMsg: string;
// procedure VariantToStream(const V: Variant; Stream : TStream);
// procedure StreamToVariant(Stream : TStream; var V: Variant);
protected
FRefCount: Integer;
FLastAccess: TDateTime;
//When the data module is created the
//connection pool that creates the data module
//will assign its critical section to this field.
//The data module will use this critical section
//to synchronize access to its reference count.
FCS: TCriticalSection;
//This semaphore points to the FixedConnectionPool's
//semaphore. It will be used to call ReleaseSemaphore
//from the _Release method of the TDataModule.
Semaphore: THandle;
//These two static methods are reintroduced
//in order to implement lifecycle management
//for the interface of this object.
//Normally, unlike normal COM objects, Delphi
//TComponent descendants are not lifecycle managed
//when used in interface references.
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
{IConnection methods}
function GetLastAccess: TDateTime;
function GetRefCount: Integer;
procedure SaveExceptionLog(strInfo : string);
public
{ Public declarations }
{IConnection method}
function Connection: TOraSession;
procedure BeginTrans;
procedure RollbackTrans;
function CommitTrans: Boolean;
function ExecSQL(const SQL: AnsiString; const Params: array of variant): Boolean;
function OpenSQL(const SQL: AnsiString; const Params: array of variant): Variant;
function GetStringByDB(const SQL: AnsiString): string;
function ExecScript(const SQL: AnsiString): Boolean;
function CheckLogin(const UID, Pass, LocalIP: AnsiString;
const Version: integer; var workURL: AnsiString): integer;
function ProcOpen(const ProcName: AnsiString;
const ParamName: array of variant; const ParamValue: array of variant): Variant;
procedure VariantToStream(const Data: OleVariant; Stream: TStream);
end;
var
ConnPool: TPool;
implementation
{$R *.dfm}
//This variable is used to control
//the cleanup thread's cleanup delay
var
InternalEvent: TEvent;
//----------------------------------------------------------------------------
// 加密解密函数:EncryptionEngine
//参数:Encrypt:Boolean TRUE :加密 false :解密
//----------------------------------------------------------------------------
function EncryptionEngine(Src: string; Key: string; Encrypt: Boolean): string;
var
idx: integer;
KeyLen: Integer;
KeyPos: Integer;
offset: Integer;
dest: string;
SrcPos: Integer;
SrcAsc: Integer;
TmpSrcAsc: Integer;
Range: Integer;
begin
KeyLen := Length(Key);
if KeyLen = 0 then key := 'abcde';
KeyPos := 0;
SrcPos := 0;
SrcAsc := 0;
Range := 256;
if Encrypt then
begin
Randomize;
offset := Random(Range);
dest := format('%1.2x', [offset]);
for SrcPos := 1 to Length(Src) do
begin
SrcAsc := (Ord(Src[SrcPos]) + offset) mod 255;
if KeyPos < KeyLen then KeyPos := KeyPos + 1 else KeyPos := 1;
SrcAsc := SrcAsc xor Ord(Key[KeyPos]);
dest := dest + format('%1.2x', [SrcAsc]);
offset := SrcAsc;
end;
end
else
begin
offset := StrToInt('$' + copy(src, 1, 2));
SrcPos := 3;
repeat
SrcAsc := StrToInt('$' + copy(src, SrcPos, 2));
if KeyPos < KeyLen then KeyPos := KeyPos + 1 else KeyPos := 1;
TmpSrcAsc := SrcAsc xor Ord(Key[KeyPos]);
if TmpSrcAsc <= offset then
TmpSrcAsc := 255 + TmpSrcAsc - offset
else
TmpSrcAsc := TmpSrcAsc - offset;
dest := dest + chr(TmpSrcAsc);
offset := srcAsc;
SrcPos := SrcPos + 2;
until SrcPos >= Length(Src);
end;
Result := Dest;
end;
{ TFixedConnectionPool }
constructor TPool.Create(const MinPoolSize, MaxPoolSize,
CleanupDelayMinutes: Integer; const Timeoutms: Cardinal;
const pConn: string);
var
DM: TConnectionModule;
i: Integer;
begin
FConnectString := pConn;
FMinPoolSize := MinPoolSize;
FMaxPoolSize := MaxPoolSize;
FTimeout := Timeoutms;
Semaphore := CreateSemaphore(nil, FMaxPoolSize, FMaxPoolSize, '');
FCS := TCriticalSection.Create;
//Set the length of the connection pool
SetLength(FPool, MinPoolSize);
for i := Low(FPool) to High(FPool) do begin
DM := TConnectionModule.Create(nil);
DM.FCS := FCS;
DM.Semaphore := Semaphore;
FPool[i] := DM;
FPool[i].Connection.ConnectString := FConnectString;
FPool[i].Connection.Connected := True;
end;
//Create and start the cleanup thread
thCleanup := TCleanupThread.Create(True,
CleanupDelayMinutes, MinPoolSize);
with thCleanup do begin
FreeOnTerminate := True;
Priority := tpLower;
Pool := Self;
Resume;
end;
end;
destructor TPool.Destroy;
var
i: Integer;
begin
//Terminate the cleanup thread
thCleanup.Terminate;
//If the cleanup thread is waiting for the
//InternalEvent object, cause that wait
//to timeout.
InternalEvent.SetEvent;
//Free any remaining connections
FCS.Enter;
try
for i := Low(FPool) to High(FPool) do
FPool[i] := nil;
SetLength(FPool, 0);
finally
FCS.Leave;
end;
FCS.Free;
//Release the semaphore
CloseHandle(Semaphore);
sleep(50);
inherited;
end;
function TPool.Get(Index: Integer): IConnection;
begin
Result := FPool[index];
end;
function TPool.GetConnection: IConnection;
var
i, iLen: Integer;
DM: TConnectionModule;
WaitResult: Integer;
begin
Result := nil;
WaitResult := WaitForSingleObject(Semaphore, FTimeout);
if WaitResult <> WAIT_OBJECT_0 then Exit;
FCS.Enter;
try
for i := Low(FPool) to High(FPool) do begin
//If FPool[i] = nil, the IConnection has
//not yet been created. Create it, initialize
//it, and return it. If FPool[i] <> nil, then
//check to see if its RefCount = 1 (only the pool
//is referencing the object).
if FPool[i] = nil then begin
DM := TConnectionModule.Create(nil);
DM.FCS := Self.FCS;
DM.Semaphore := Self.Semaphore;
FPool[i] := DM;
FPool[i].Connection.ConnectString := self.FConnectString;
FPool[i].Connection.Connected := True;
Result := FPool[i];
Exit;
end;
//if FPool[i].FRefCount = 1 then
//the connection is available. Return it.
if FPool[i].RefCount = 1 then begin
Result := FPool[i];
Exit;
end;
end; // for
iLen := Length(FPool);
if iLen < FMaxPoolSize then begin
SetLength(FPool, iLen + 1);
DM := TConnectionModule.Create(nil);
DM.FCS := Self.FCS;
DM.Semaphore := Self.Semaphore;
i := High(FPool);
FPool[i] := DM;
FPool[i].Connection.ConnectString := self.FConnectString;
FPool[i].Connection.Connected := True;
Result := FPool[i];
Exit;
end;
finally
FCS.Leave;
end; // try
end;
function TPool.GetConnectionCount: integer;
var
WaitResult: Integer;
begin
Result := -1;
WaitResult := WaitForSingleObject(Semaphore, FTimeout);
if WaitResult <> WAIT_OBJECT_0 then Exit;
FCS.Enter;
try
Result := Length(FPool);
finally
FCS.Leave;
end; // try
end;
{ TConnectionModule }
function TConnectionModule._AddRef: Integer;
begin
//increment the reference count
FCS.Enter;
try
Inc(FRefCount);
Result := FRefCount;
finally
FCS.Leave;
end;
end;
function TConnectionModule._Release: Integer;
var
tmpCS: TCriticalSection;
tmpSemaphore: THandle;
begin
// Get local references to the critical section and semaphore
// These are necessary since the critical section and
// semaphore members of this class will be invalid when
// the data module is being destroyed.
tmpCS := FCS;
tmpSemaphore := Semaphore;
Result := FRefCount;
//decrement the reference count
tmpCS.Enter;
try
Dec(FRefCount);
Result := FRefCount;
//if not more references, call Destroy
if Result = 0 then
Destroy
else
Self.FLastAccess := Now;
finally
tmpCS.Leave;
if Result = 1 then
ReleaseSemaphore(tmpSemaphore, 1, nil);
end;
end;
procedure TConnectionModule.BeginTrans;
begin
RollbackTrans;
con.StartTransaction;
end;
procedure TConnectionModule.RollbackTrans;
begin
if con.InTransaction then con.Rollback;
end;
function TConnectionModule.CommitTrans: Boolean;
begin
FErrorMsg := '';
Result := False;
try
con.Commit;
Result := True;
except
// FErrorMsg := ADOConnection.ConnectionObject.Errors[0].Description;
RollbackTrans;
end;
end;
function TConnectionModule.Connection: TOraSession;
begin
Result := con;
end;
function TConnectionModule.ExecSQL(const SQL: AnsiString; const Params: array of variant): Boolean;
begin
FErrorMsg := '';
Result := False;
BeginTrans;
try
con.ExecSQL(SQL, Params);
CommitTrans;
Result := True;
except
on E: Exception do begin
SaveExceptionLog(FormatDateTime('hh:nn:ss | ', now)
+ #13#10 + E.Message
+ #13#10 + SQL + #13#10);
RollbackTrans;
Exit;
end;
end;
end;
function TConnectionModule.GetRefCount: Integer;
begin
FCS.Enter;
Result := FRefCount;
FCS.Leave;
end;
function TConnectionModule.OpenSQL(const SQL: AnsiString; const Params: array of variant): Variant;
var
i: integer;
qry: TOraQuery;
dsp: TOraProvider;
begin
qry := TOraQuery.Create(nil);
qry.ParamCheck := true;
qry.Session := con;
qry.FetchAll := True;
qry.SQL.Clear;
qry.SQL.Add(SQL);
// qry.Prepare;
for i := 0 to qry.ParamCount - 1 do
if i <= High(Params) then
qry.Params[i].Value := Params[i]
else
qry.Params[i].Value := Null;
try
qry.Prepare;
qry.Open;
dsp := TOraProvider.Create(nil);
try
dsp.DataSet := qry;
result := dsp.Data;
finally
dsp.Free;
end;
qry.Close;
finally
qry.Free;
end;
end;
function TConnectionModule.GetLastAccess: TDateTime;
begin
FCS.Enter;
Result := FLastAccess;
FCS.Leave;
end;
function TConnectionModule.CheckLogin(const UID, Pass, LocalIP: AnsiString;
const Version: integer; var workURL: AnsiString): integer;
var
sp: TOraStoredProc;
begin
sp := TOraStoredProc.Create(nil);
try
result := 1;
sp.Session := con;
sp.StoredProcName := 'oplogin';
sp.Prepare;
sp.ParamByName('opid').AsString := UID;
sp.ParamByName('oppass').AsString := Pass;
sp.ParamByName('localip').AsString := LocalIP;
sp.ExecProc;
workURL := sp.ParamByName('workurl').AsString;
result := sp.ParamByName('state').AsInteger;
finally
sp.Free;
end;
end;
function TConnectionModule.ExecScript(const SQL: AnsiString): Boolean;
var
scr: TOraSQL;
begin
result := true;
scr := TOraSQL.Create(nil);
try
scr.Session := con;
scr.AutoCommit := True;
scr.SQL.Add(SQL);
try
scr.Execute;
except
result := false;
end;
finally
scr.free;
end;
end;
procedure TConnectionModule.VariantToStream(
const Data: OleVariant; Stream: TStream);
var
p: Pointer;
begin
if Data = null then Exit;
p := VarArrayLock(Data);
try
Stream.Write(p^, VarArrayHighBound(Data, 1) + 1); //assuming low bound = 0
finally
VarArrayUnlock(Data);
end;
end;
procedure TConnectionModule.SaveExceptionLog(strInfo: string);
var
F: TextFile;
s : string;
begin
s := ExtractFilePath(ParamStr(0)) + 'Log\' +
FormatDateTime('mmddhhnnsszzz', now) + '.txt';
while FileExists(s) do
begin
sleep(100);
s := ExtractFilePath(ParamStr(0)) + 'Log\' +
FormatDateTime('mmddhhnnsszzz', now) + '.txt';
end;
AssignFile(F, s);
Rewrite(F);
Writeln(F, strInfo);
CloseFile(F);
end;
function TConnectionModule.ProcOpen(const ProcName: AnsiString;
const ParamName, ParamValue: array of variant): Variant;
var
sp: TOraStoredProc;
i:Integer;
dsp: TOraProvider;
begin
sp := TOraStoredProc.Create(nil);
try
sp.Session := con;
sp.Params.clear;
sp.StoredProcName := ProcName;
sp.PrepareSQL;
for i:=0 to Length(ParamName) -1 do begin
sp.ParamByName(ParamName[i]).Value := ParamValue[i];
end;
sp.Prepare;
sp.ExecProc;
if sp.parambyName('RESULT').Value <> '' then
Result := sp.parambyName('RESULT').Value
else
//有接收载体TOraProvider，无需判断游标可用性，所以去掉，否则无数据返回时，会出现数据集错误。
// if sp.ParamByName('RESULT').AsCursor.CanFetch then
begin
dsp := TOraProvider.Create(nil);
try
dsp.DataSet := sp;
result := dsp.Data;
finally
dsp.Free;
end;
end ;
finally
sp.Free;
end;
end;
function TConnectionModule.GetStringByDB(const SQL: AnsiString): string;
var
qry: TOraQuery;
begin
qry := TOraQuery.Create(nil);
qry.Session := con;
qry.SQL.Clear;
qry.SQL.Add(SQL);
try
qry.Open;
Result := qry.Fields[0].AsString;
qry.Close;
finally
qry.Free;
end;
end;
{ TCleanupThread }
constructor TCleanupThread.Create(CreateSuspended: Boolean;
const MinSize, CleanupDelayMinutes: Integer);
begin
// always create suspended
inherited Create(True); // always create suspended
FCleanupDelay := CleanupDelayMinutes;
FMinSize := MinSize;
//Resume if not created suspended
if not CreateSuspended then
Resume;
end;
procedure TCleanupThread.Execute;
var
i: Integer;
WaitMinutes: Cardinal;
begin
WaitMinutes := FCleanupDelay * 1000 * 60;
while True do begin
if Terminated then Exit;
//wait for the FCleanupDelay period
//InternalEvent has been signaled, is in error, or is abandoned,
//in which which case this thread should terminate.
if InternalEvent.WaitFor(WaitMinutes) <> wrTimeout then Exit;
if Terminated then Exit;
//WaitForSingleObject has timed out. Look for connections to clean up
with Pool do begin
FCS.Enter;
try
//if the connection exists, has no external reference,
//and has not been used lately, release it
for i := low(FPool) + FMinSize to High(FPool) do
if (FPool[i] <> nil) and (FPool[i].RefCount = 1) and
(MinutesBetween(FPool[i].LastAccess, Now) > FCleanupDelay) then
Pool.FPool[i] := nil;
finally
FCS.Leave;
end;
end;
end;
end;
function TPool.getPoolCount: integer;
begin
Result := SizeOf(FPool);
end;
initialization
InternalEvent := TEvent.Create(nil, False, False, '');
//ConnPool := TPool.Create(3, 50, 10, 20000);
finalization
//Setting this event causes the cleanup thread to wake up
if ConnPool <> nil then
begin
ConnPool.Free;
ConnPool := nil;
end;
InternalEvent.Free;
end.
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
