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.
转载于:https://www.cnblogs.com/fyen/archive/2011/04/21/2023160.html