Simple to no more simple connection pool

Unit adoconnectpool;

Interface

Uses
Classes, windows, syncobjs, sysutils, and ADODB;

Type
Tadoconnectionpool = Class (tobject)
Private
Fobjlist: tthreadlist;
Ftimeout: integer;
Fmaxcount: integer;
Fsemaphore: Cardinal;
Fconnectionstring: string;
Function createnewinstance (list: tlist): tadoconnection;
Function getlock (list: tlist; index: integer): Boolean;
Public
Property connectionstring: String read fconnectionstring write fconnectionstring;
Property Timeout: integer read ftimeout write ftimeout;
Property maxcount: integer read fmaxcount;

Constructor create (acapicity: integer = 15); overload;
Destructor destroy; override;
Function lockconnection: tadoconnection;
Procedure unlockconnection (VaR value: tadoconnection );
End;

VaR
Connectionpool: tadoconnectionpool;

Implementation

Constructor tadoconnectionpool. Create (acapicity: integer = 15 );
Begin
Fobjlist: = tthreadlist. Create;
Ftimeout: = 15000;
Fmaxcount: = acapicity;
Fsemaphore: = createsemaphore (nil, fmaxcount, fmaxcount, nil );
End;

function tadoconnectionpool. createnewinstance (list: tlist): tadoconnection;
var
P: tadoconnection;
begin
try
result: = nil;
P: = tadoconnection. create (NiL);
P. connectionstring: = connectionstring;
P. loginprompt: = false;
P. connected: = true;
P. tag: = 1;
list. add (p);
result: = P;
P. free;
quit T
exit;
end;

Destructor tadoconnectionpool. Destroy;
VaR
I: integer;
List: tlist;
Begin
List: = fobjlist. locklist;
Try
For I: = List. Count-1 downto 0 do
Begin
Tadoconnection (list [I]). Free;
Dispose (list [I]);
End;
Finally
Fobjlist. unlocklist;
End;
Fobjlist. Free;
Fobjlist: = nil;
Closehandle (fsemaphore );
Inherited destroy;
End;

Function tadoconnectionpool. getlock (list: tlist; index: integer): Boolean;
Begin
Try
Result: = tadoconnection (list [Index]). Tag = 0;
If result then
Tadoconnection (list [Index]). Tag: = 1;
Except
Exit;
End;
End;

Function tadoconnectionpool. lockconnection: tadoconnection;
VaR
I, waitresult: integer;
List: tlist;
Begin
Try
Result: = nil;
Waitresult: = waitforsingleobject (fsemaphore, timeout );
List: = fobjlist. locklist;
Try
For I: = 0 to list. Count-1 do
Begin
If getlock (list, I) then
Begin
Result: = tadoconnection (list [I]);
Exit;
End;
End;
If list. Count <maxcount then
Result: = createnewinstance (list );
Finally
Fobjlist. unlocklist;
End;
Except
Exit;
End;
End;

Procedure tadoconnectionpool. unlockconnection (VaR value: tadoconnection );
VaR
List: tlist;
Begin
Try
List: = fobjlist. locklist;
Try
Tadoconnection (list [list. indexof (value)]). Tag: = 0;
Releasesemaphore (fsemaphore, 1, nil );
Finally
Fobjlist. unlocklist;
End;
Except
Exit;
End;
End;

Initialization
Connectionpool: = tadoconnectionpool. Create ();
Finalization
Connectionpool. Free;

End.