数据模块池

unit untDMPool;

interface

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

const
cMaxNum = 1000;
cInitNum = 20;
cTimeOut = 1800000;

type

PServerObject = ^TServerObject;

TServerObject = record
ServerObject: TdmData;
InUse: Boolean;
lastFreeTime: TDateTime;
end;

TDMPool = class
private
FCriticalSection: TCriticalSection;
FServerObjects: TList;
FPoolSize: integer;
FUsedNum: integer;
FCreateNum: integer;
FTimer: TThreadedTimer;
procedure myTimer(Sender: TObject);
public
constructor Create; overload;
destructor Destroy; override;
function Lock: TdmData;
procedure Unlock(Value: TdmData);
procedure Init;
property PoolSize: integer read FPoolSize write FPoolSize;
property UsedNum: integer read FUsedNum write FUsedNum default 0;
property CreateNum: integer read FCreateNum write FCreateNum
default cInitNum;
end;

var
gDMPool: TDMPool;

implementation

uses untLog;

constructor TDMPool.Create;
begin
FPoolSize := cInitNum;
FServerObjects := TList.Create;
FCriticalSection := TCriticalSection.Create;
FTimer := TThreadedTimer.Create(nil);
FTimer.OnTimer := myTimer;
FTimer.Interval := 300000;
end;

destructor TDMPool.Destroy;
begin
while FServerObjects.Count > 0 do
begin
PServerObject(FServerObjects[0])^.ServerObject.Free;
Dispose(PServerObject(FServerObjects[0]));
FServerObjects.Delete(0);
end;
FreeAndNil(FServerObjects);
FreeAndNil(FCriticalSection);
FreeAndNil(FTimer);
inherited Destroy;
end;

procedure TDMPool.Init;
var
i: integer;
p: PServerObject;
begin
if not Assigned(FServerObjects) then
exit;
try
for i := 1 to FPoolSize do
begin
New(p);
if Assigned(p) then
begin
p^.ServerObject := TdmData.Create(nil);
p^.InUse := False;
p^.lastFreeTime := Now;
FServerObjects.Add(p);
InterlockedIncrement(FCreateNum);
end;
end;
except
On E: Exception do
begin
gSysLog.WriteLog(E.Message);
exit;
end;
end;
end;

function TDMPool.Lock: TdmData;
var
i: integer;
bFound: Boolean;
begin
Result := nil;
try
FCriticalSection.Enter;
try
bFound := False;
for i := 0 to FServerObjects.Count - 1 do
begin
if not PServerObject(FServerObjects[i])^.InUse then
begin
InterlockedIncrement(FUsedNum);
PServerObject(FServerObjects[i])^.InUse := True;
Result := PServerObject(FServerObjects[i])^.ServerObject;
bFound := True;
Break;
end;
end;
if (FServerObjects.Count = PoolSize) and (not bFound) and
(FCreateNum < cMaxNum) then
begin
Result := TdmData.Create(nil);
Result.tag := 5;
InterlockedIncrement(FCreateNum);
end;
finally
FCriticalSection.Leave;
end;
except
on E: Exception do
begin
gSysLog.WriteLog(E.Message);
exit;
end;
end;
end;

procedure TDMPool.myTimer(Sender: TObject);
var
i: Integer;
begin
try
FCriticalSection.Enter;
try
for i := FServerObjects.Count - 1 downto 0 do
begin
if (not PServerObject(FServerObjects[i])^.InUse) and
(now - PServerObject(FServerObjects[i])^.lastFreeTime > cTimeOut) and
(FCreateNum > FPoolSize) then
begin
InterlockedDecrement(FUsedNum);
InterlockedDecrement(FCreateNum);
PServerObject(FServerObjects[i])^.ServerObject.Free;
Dispose(PServerObject(FServerObjects[i]));
FServerObjects.Delete(i);
end;
end;
finally
FCriticalSection.Leave;
end;
except
on E: Exception do
begin
gSysLog.WriteLog(E.Message);
exit;
end;
end;
end;

procedure TDMPool.Unlock(Value: TdmData);
var
i: integer;
begin
if not Assigned(Value) then
exit;
try
FCriticalSection.Enter;
try
for i := 0 to FServerObjects.Count - 1 do
begin
if Value = PServerObject(FServerObjects[i])^.ServerObject then
begin
InterlockedDecrement(FUsedNum);
PServerObject(FServerObjects[i])^.InUse := False;
PServerObject(FServerObjects[i])^.lastFreeTime := Now;
Break;
end;
end;
finally
FCriticalSection.Leave;
end;
except
On E: Exception do
begin
gSysLog.WriteLog(E.Message);
exit;
end;
end;
end;

end.

unit UntThreadTimer;

interface

uses
Windows, Classes;

type
TTimerStatus = (TS_ENABLE, TS_CHANGEINTERVAL, TS_DISABLE, TS_SETONTIMER);
TThreadedTimer = class;
TTimerThread = class;
//PTimerThread = ^TTimerThread;

TTimerThread = class(TThread)
private
FOwnerTimer: TThreadedTimer;
FInterval: DWord;
FEnabled : Boolean;
FStatus : TTimerStatus;
public
constructor Create(CreateSuspended: Boolean);
destructor Destroy; override;
procedure Execute; override;
procedure DoTimer;
end;

TThreadedTimer = class(TComponent)
private
FEnabled: Boolean;
FInterval: DWord;
FOnTimer: TNotifyEvent;
FTimerThread: TTimerThread;
FThreadPriority: TThreadPriority;
protected
procedure UpdateTimer;
procedure SetEnabled(Value: Boolean);
procedure SetInterval(Value: DWord);
procedure SetOnTimer(Value: TNotifyEvent);
procedure Timer; dynamic;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Enabled: Boolean read FEnabled write SetEnabled default True;
property Interval: DWord read FInterval write SetInterval default 1000;
property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;
end;

implementation

procedure WakeupDownThrdproc(const evenFlag: Integer); stdcall;
begin

end;
{TTimerThread}
constructor TTimerThread.Create(CreateSuspended: Boolean);
begin
inherited Create(CreateSuspended);
FInterval := 1000;
FEnabled := False;
FStatus := TS_DISABLE;
end;

destructor TTimerThread.Destroy;
begin
inherited;
end;

procedure TTimerThread.Execute;
begin
inherited;
while not Terminated do
begin
SleepEx(FInterval, True);
if (not Terminated) and (FStatus = TS_ENABLE) then Synchronize(DoTimer);
if FStatus <> TS_ENABLE then
begin
case FStatus of
TS_CHANGEINTERVAL:
begin
FStatus := TS_ENABLE;
SleepEx(0,True);
end;
TS_DISABLE:
begin
FStatus := TS_ENABLE;
SleepEx(0, True);
if not Terminated then Suspend;
end;
TS_SETONTIMER:
begin
FStatus := TS_ENABLE;
end else
FStatus := TS_ENABLE;
end;
end;
end;
end;

procedure TTimerThread.DoTimer;
begin
FOwnerTimer.Timer;
end;

{TThreadedTimer}
constructor TThreadedTimer.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FInterval := 1000;
FThreadPriority := tpNormal;
FTimerThread := TTimerThread.Create(true);
FTimerThread.FOwnerTimer := Self;
end;

destructor TThreadedTimer.Destroy;
begin
inherited Destroy;
FTimerThread.Terminate;
QueueUserAPC(@WakeupDownThrdproc, FTimerThread.Handle, DWORD(FTimerThread));
FTimerThread.Free;
end;

procedure TThreadedTimer.UpdateTimer;
begin
if (FEnabled = False) then
begin
FTimerThread.FOwnerTimer := Self;
FTimerThread.FInterval := FInterval;
FTimerThread.Priority := FThreadPriority;
FTimerThread.Resume;
end;
if (FEnabled = True) then
begin
QueueUserAPC(@WakeupDownThrdproc, FTimerThread.Handle, DWORD(FTimerThread));
end;
end;

procedure TThreadedTimer.SetEnabled(Value: Boolean);
begin
if Value <> FEnabled then
begin
FEnabled := Value;
if Value then
begin
FTimerThread.FStatus := TS_ENABLE;
FTimerThread.Resume;
end else
begin
FTimerThread.FStatus := TS_DISABLE;
QueueUserAPC(@WakeupDownThrdproc, FTimerThread.Handle, DWORD(FTimerThread));
end;
end;
end;

procedure TThreadedTimer.SetInterval(Value: DWord);
begin
if Value <> FInterval then
begin
if (not FEnabled) then
begin
FInterval := Value;
FTimerThread.FInterval := FInterval;
end else
begin
FInterval := Value;
FTimerThread.FInterval := FInterval;
FTimerThread.FStatus := TS_CHANGEINTERVAL;
QueueUserAPC(@WakeupDownThrdproc, FTimerThread.Handle, DWORD(FTimerThread));
end;
end;
end;

procedure TThreadedTimer.SetOnTimer(Value: TNotifyEvent);
begin
FOnTimer := Value;
end;

procedure TThreadedTimer.Timer;
begin
if Assigned(FOnTimer) then FOnTimer(Self);
end;

end.

数据模块池,布布扣,bubuko.com

数据模块池

原文：http://www.cnblogs.com/hnxxcxg/p/3619672.html