Delphi三层 server 下数据连接缓冲池

unit uAppCenter;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
Windows, ComObj, ComServ, ActiveX, HISAPP_TLB, Classes, SyncObjs, StdVcl,
VCLCom, SysUtils, Forms, uDataType;

type
TAppCenter = class(TComponent, IRDMSystem)
private
    function LockRDM: IRDMSystem;
    procedure UnlockRDM(Value: IRDMSystem);
protected
    { 实现IAppServer接口定义的方法 }
    function AS_ApplyUpdates(const ProviderName: WideString; Delta: OleVariant;
                              MaxErrors: Integer; out ErrorCount: Integer; var OwnerData: OleVariant): OleVariant; safecall;
    function AS_GetRecords(const ProviderName: WideString; Count: Integer; out RecsOut: Integer;
                            Options: Integer; const CommandText: WideString;
                            var Params: OleVariant; var OwnerData: OleVariant): OleVariant; safecall;
    function AS_DataRequest(const ProviderName: WideString; Data: OleVariant): OleVariant; safecall;
    function AS_GetProviderNames: OleVariant; safecall;
    function AS_GetParams(const ProviderName: WideString; var OwnerData: OleVariant): OleVariant; safecall;
    function AS_RowRequest(const ProviderName: WideString; Row: OleVariant; RequestType: Integer;
                            var OwnerData: OleVariant): OleVariant; safecall;
    procedure AS_Execute(const ProviderName: WideString; const CommandText: WideString;
                         var Params: OleVariant; var OwnerData: OleVariant); safecall;
                         
    { 实现IDMSystem接口定义的方法 }
    // 用户登录函数
    procedure Login(const aID, aKey: WideString; out Data: OleVariant); safecall;
    // 获得单据流水帐号
    procedure GetNewBill(const BillKind: WideString; out Data: OleVariant);
      safecall;
    // 药品出库审核函数
    procedure CheckOut(const OutNo: WideString; out Data: OleVariant);
      safecall;
public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
end;

{ 缓冲池维护一个RDMs对列，向外界提供没有使用的RDMs }

TPoolManager = class(TObject)
private
    FRDMList: TList;
    FCurrentSemaphoreCount: Integer; //信号数
    FMaxSemaphoreCount: Integer;     //最大信号数
    FMaxDBSessionCount: Integer;     //最大连接数
    FActivePoolerCount: Integer;     //并发用户数
    FRDMTimeOut: Integer;            //运行超时
    FSemaphoreTimeOut: Integer;      //同步超时
    FCriticalSection: TCriticalSection;
    FSemaphore: THandle;
    FAppInfo: TAppInfo;
    FUserCount: Integer;

    function GetLock(Index: Integer): Boolean;
    function CreateNewInstance: IRDMSystem;
    function GetActivePoolerCount: Integer;
    function CloseALLRDM: Boolean;
    procedure ReleaseLock(Index: Integer; var Value: IRDMSystem);
    procedure ShowAppInfo;
public
    constructor Create;
    destructor Destroy; override;
    function LockRDM: IRDMSystem;
    procedure UnlockRDM(var Value: IRDMSystem);
    property CurrentSemaphoreCount: Integer read FCurrentSemaphoreCount;
    property MaxSemaphoreCount: Integer read FMaxSemaphoreCount;
    property MaxDBSessionCount: Integer read FMaxDBSessionCount;
    property ActivePoolerCount: Integer read GetActivePoolerCount;
    property RDMTimeOut: Integer read FRDMTimeOut;
    property SemaphoreTimeOut: Integer read FSemaphoreTimeOut;
    property UserCount: Integer read FUserCount;
end;

PRDM = ^TRDM;
TRDM = record
    Intf: IRDMSystem;
    InUse: Boolean; //表示是否真正使用该接口
    BeginUseTime: TDateTime; //开始Use该接口的时间,来判断此接口是否已经TimeOut
end;

var
PoolManager: TPoolManager;

implementation

uses uRDMSystem, uUtils;

{ TPoolManager类 }

constructor TPoolManager.Create;
begin
FRDMList := TList.Create;
FCriticalSection := TCriticalSection.Create;
FRDMTimeOut := 60;
FSemaphoreTimeOut := 5000;
FMaxDBSessionCount := 8;
FMaxSemaphoreCount := 5;
FCurrentSemaphoreCount := 5;
FSemaphore := CreateSemaphore(nil, FMaxSemaphoreCount, FMaxSemaphoreCount, nil);
end;

destructor TPoolManager.Destroy;
var
i: Integer;
begin
FCriticalSection.Free;
for i := 0 to FRDMList.Count - 1 do
begin
    PRDM(FRDMList[i]).Intf := nil;
    FreeMem(PRDM(FRDMList[i]));
end;
FRDMList.Free;
CloseHandle(FSemaphore);
inherited Destroy;
end;

function TPoolManager.GetLock(Index: Integer): Boolean;
begin
FCriticalSection.Enter;
try
    //检查是否运行超时，释放运行超时的接口
    if IsTimeOut(PRDM(FRDMList[Index]).BeginUseTime, RDMTimeOut) then
      PRDM(FRDMList[Index]).InUse := False;
    Result := not PRDM(FRDMList[Index]).InUse;
    //存在未使用的接口，记录下新的开始时间
    if Result then
    begin
      PRDM(FRDMList[Index]).InUse := True;
      PRDM(FRDMList[Index]).BeginUseTime := Now;
    end;
finally
    FCriticalSection.Leave;
end;
end;

procedure TPoolManager.ReleaseLock(Index: Integer; var Value: IRDMSystem);
begin
FCriticalSection.Enter;
try
    PRDM(FRDMList[Index]).InUse := False;
    Value := nil;
    ReleaseSemaphore(FSemaphore, 1, @FCurrentSemaphoreCount);
    Inc(FCurrentSemaphoreCount); //调用ReleaseSemaphore，当前同步信号数会加1
finally
    FCriticalSection.Leave;
end;
end;

function TPoolManager.CreateNewInstance: IRDMSystem;
var
p: PRDM;
begin
FCriticalSection.Enter;
try
    New(p);
    p.Intf := RDMFactory.CreateComObject(nil) as IRDMSystem;;
    p.InUse := True;
    p.BeginUseTime := Now;
    FRDMList.Add(p);
    Result := p.Intf;
finally
    FCriticalSection.Leave;
end;
end;

function TPoolManager.LockRDM: IRDMSystem;
var
i: Integer;
begin
ShowAppInfo;
Result := nil;
if WaitForSingleObject(FSemaphore, SemaphoreTimeOut) = WAIT_TIMEOUT then
    raise Exception.Create('应用服务器忙！');
for i := 0 to FRDMList.Count - 1 do
begin
    if GetLock(i) then
    begin
      Result := PRDM(FRDMList[i]).Intf;
      Exit;
    end;
end;
if FRDMList.Count < MaxDBSessionCount then
    Result := CreateNewInstance;
ShowAppInfo;
if Result = nil then { This shouldn't happen because of the sempahore locks }
    raise Exception.Create('不能锁定远程数据模块！');
end;

procedure TPoolManager.UnlockRDM(var Value: IRDMSystem);
var
i: Integer;
begin
for i := 0 to FRDMList.Count - 1 do
begin
    if Value = PRDM(FRDMList[i]).Intf then
    begin
      ReleaseLock(i, Value);
      break;
    end;
end;
ShowAppInfo;
end;

function TPoolManager.GetActivePoolerCount: Integer;
var
i: Integer;
begin
//初始化并发用户数据
Result := 0;
FActivePoolerCount := 0;
for i := 0 to FRDMList.Count - 1 do
begin
    if PRDM(FRDMList[i]).InUse then
      Inc(FActivePoolerCount);
    Result := FActivePoolerCount;
end;
end;

function TPoolManager.CloseALLRDM: Boolean;
var
i: Integer;
begin
for i := FRDMList.Count - 1 downto 0 do
begin
    FCriticalSection.Enter;
    try
      if not PRDM(FRDMList[i])^.InUse then
      try
        PRDM(FRDMList[i])^.Intf := nil;
        Dispose(PRDM(FRDMList[i]));
        FRDMList.Delete(i);
      except
      end;
    finally
      FCriticalSection.Leave;
    end;
end;
Result := True;
end;

{ 显示应用服务器资源使用情况 }
procedure TPoolManager.ShowAppInfo;
begin
with FAppInfo do
begin
    aUserCount := UserCount;
    aActivePoolerCount := ActivePoolerCount;
    aCurrentUsePoolerCount := FRDMList.Count;
    aMaxPoolerCount := MaxDBSessionCount;
    aPoolerTimeOut := RDMTimeOut;
    aSemaphoreTimeOut := SemaphoreTimeOut/1000;
    aCurrentSemaphoreCount := CurrentSemaphoreCount;
    aMaxSemaphoreCount := MaxSemaphoreCount;
end;
{$WARNINGS OFF}
PostMessage(Application.MainForm.Handle, WM_APPINFO, LongInt(@FAppInfo), 0);
{$WARNINGS ON}
end;


{ 包装服务器对象AppCenter类 }

constructor TAppCenter.Create(AOwner: TComponent);
begin
inherited;
//创建了一个TAppCenter对象，就表明有客户在请求COM服务
Inc(PoolManager.FUserCount);
//更新APP信息
PoolManager.ShowAppInfo;
end;

destructor TAppCenter.Destroy;
begin
Dec(PoolManager.FUserCount);
//当没有客户请求服务时，释放所有RDM对象
if PoolManager.FUserCount = 0 then PoolManager.CloseAllRDM;
PoolManager.ShowAppInfo;
inherited;
end;

function TAppCenter.LockRDM: IRDMSystem;
begin
Result := PoolManager.LockRDM;
end;

procedure TAppCenter.UnlockRDM(Value: IRDMSystem);
begin
PoolManager.UnlockRDM(Value);
end;

function TAppCenter.AS_ApplyUpdates(const ProviderName: WideString;
Delta: OleVariant; MaxErrors: Integer; out ErrorCount: Integer;
var OwnerData: OleVariant): OleVariant;
var
RDM: IRDMSystem;
begin
RDM := LockRDM;
try
    Result := RDM.AS_ApplyUpdates(ProviderName, Delta, MaxErrors, ErrorCount, OwnerData);
finally
    UnlockRDM(RDM);
end;
end;

function TAppCenter.AS_DataRequest(const ProviderName: WideString;
Data: OleVariant): OleVariant;
var
RDM: IRDMSystem;
begin
RDM := LockRDM;
try
    Result := RDM.AS_DataRequest(ProviderName, Data);
finally
    UnlockRDM(RDM);
end;
end;

procedure TAppCenter.AS_Execute(const ProviderName, CommandText: WideString;
var Params, OwnerData: OleVariant);
var
RDM: IRDMSystem;
begin
RDM := LockRDM;
try
    RDM.AS_Execute(ProviderName, CommandText, Params, OwnerData);
finally
    UnlockRDM(RDM);
end;
end;

function TAppCenter.AS_GetParams(const ProviderName: WideString;
var OwnerData: OleVariant): OleVariant;
var
RDM: IRDMSystem;
begin
RDM := LockRDM;
try
    Result := RDM.AS_GetParams(ProviderName, OwnerData);
finally
    UnlockRDM(RDM);
end;
end;

function TAppCenter.AS_GetProviderNames: OleVariant;
var
RDM: IRDMSystem;
begin
RDM := LockRDM;
try
    Result := RDM.AS_GetProviderNames;
finally
    UnlockRDM(RDM);
end;
end;

function TAppCenter.AS_GetRecords(const ProviderName: WideString;
Count: Integer; out RecsOut: Integer; Options: Integer;
const CommandText: WideString; var Params,
OwnerData: OleVariant): OleVariant;
var
RDM: IRDMSystem;
begin
RDM := LockRDM;
try
    Result := RDM.AS_GetRecords(ProviderName, Count, RecsOut, Options,
      CommandText, Params, OwnerData);
finally
    UnlockRDM(RDM);
end;
end;

function TAppCenter.AS_RowRequest(const ProviderName: WideString;
Row: OleVariant; RequestType: Integer;
var OwnerData: OleVariant): OleVariant;
var
RDM: IRDMSystem;
begin
RDM := LockRDM;
try
    Result := RDM.AS_RowRequest(ProviderName, Row, RequestType, OwnerData);
finally
    UnlockRDM(RDM);
end;
end;


procedure TAppCenter.Login(const aID, aKey: WideString;
out Data: OleVariant);
var
RDM: IRDMSystem;
begin
RDM := LockRDM;
try
    RDM.Login(aID, aKey, Data);
finally
    UnlockRDM(RDM);
end;
end;

procedure TAppCenter.GetNewBill(const BillKind: WideString;
out Data: OleVariant);
var
RDM: IRDMSystem;
begin
RDM := LockRDM;
try
    RDM.GetNewBill(BillKind, Data);
finally
    UnlockRDM(RDM);
end;
end;

procedure TAppCenter.CheckOut(const OutNo: WideString;
out Data: OleVariant);
var
RDM: IRDMSystem;
begin
RDM := LockRDM;
try
    RDM.CheckOut(OutNo, Data);
finally
    UnlockRDM(RDM);
end;
end;

initialization
PoolManager := TPoolManager.Create;
TComponentFactory.Create(ComServer, TAppCenter, Class_AppCenter,
    ciMultiInstance, tmApartment);

finalization
PoolManager.Free;

end.