unit pooler;

interface

uses
  ComObj, ActiveX, Classes, SyncObjs, Windows, Pserver_TLB;

type
  TPooler = class(TAutoObject, iSvrRDM)
  private
    function LockRDM: iSvrRDM;
    procedure UnlockRDM(Value: iSvrRDM);
  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;
    {User define function and produce}
    procedure setip(const ip: WideString); safecall;
    function login(const usercode, password: WideString): Integer; safecall;
    function getusername(const usercode, password: WideString): WideString;
      safecall;
    function getadmin(const usercode, password: WideString): WordBool;
      safecall;
    function getapptitle: WideString; safecall;
    function getgroupid(const usercode, username: WideString): Integer;
      safecall;
    function syslog(const fform, fevent, fuser, fpcname: WideString): Integer;
      safecall;
    function execsql(const cmdstr: WideString): WordBool; safecall;
    function getlargedata(const psql: WideString;
      precCount: Integer): OleVariant; safecall;
    function applyupdata(pdelta: OleVariant; const ptablename,
      pkeyfield: WideString): WordBool; safecall;
    function getmaxid(const ptablename, pkeyfield: WideString): Integer;
      safecall;
    function isunique(const ptablename, pkeyfield,
      pkeyvalue: WideString): WordBool; safecall;
    function getnumber(pBilltypeid: Integer): WideString; safecall;
    function getinnunber(pbilltypeid: Integer): Integer; safecall;
    function purchasedetail(pitemid: Integer): OleVariant; safecall;     
  end;

  TPoolManager = class(TObject)
  private
    FRDMList: TList;
    FMaxCount: Integer;
    FTimeout: Integer;
    FCriticalSection: TCriticalSection;
    FSemaphore: THandle;

    function GetLock(Index: Integer): Boolean;
    procedure ReleaseLock(Index: Integer; var Value: iSvrRDM);
    function CreateNewInstance: iSvrRDM;
  public
    constructor Create;
    destructor Destroy; override;
    function LockRDM: iSvrRDM;
    procedure UnlockRDM(var Value: iSvrRDM);

    property Timeout: Integer read FTimeout;
    property MaxCount: Integer read FMaxCount;
  end;

  PRDM = ^TRDM;
  TRDM = record
    Intf: iSvrRDM;
    InUse: Boolean;
  end;

var
  PoolManager: TPoolManager;

implementation

uses ComServ, SysUtils, uSrvRDM;

constructor TPoolManager.Create;
begin
  FRDMList := TList.Create;
  FCriticalSection := TCriticalSection.Create;
  FTimeout := 5000;
  FMaxCount := 15;
  FSemaphore := CreateSemaphore(nil, FMaxCount, FMaxCount, 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
    Result := not PRDM(FRDMList[Index]).InUse;
    if Result then
      PRDM(FRDMList[Index]).InUse := True;
  finally
    FCriticalSection.Leave;
  end;
end;

procedure TPoolManager.ReleaseLock(Index: Integer; var Value: iSvrRDM);
begin
  FCriticalSection.Enter;
  try
    PRDM(FRDMList[Index]).InUse := False;
    Value := nil;
    ReleaseSemaphore(FSemaphore, 1, nil);
  finally
    FCriticalSection.Leave;
  end;
end;

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

function TPoolManager.LockRDM: iSvrRDM;
var
  i: Integer;
begin
  Result := nil;
  if WaitForSingleObject(FSemaphore, Timeout) = WAIT_FAILED then
    raise Exception.Create('Server too busy');
  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 < MaxCount then
    Result := CreateNewInstance;
  if Result = nil then { This shouldn't happen because of the sempahore locks }
    raise Exception.Create('Unable to lock RDM');
end;

procedure TPoolManager.UnlockRDM(var Value: iSvrRDM);
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;
end;

{
  Each call for the server is wrapped in a call to retrieve the RDM, and then
  when it is finished it releases the RDM.
}

function TPooler.LockRDM: iSvrRDM;
begin
  Result := PoolManager.LockRDM;
end;

procedure TPooler.UnlockRDM(Value: iSvrRDM);
begin
  PoolManager.UnlockRDM(Value);
end;

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

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

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

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

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

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

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

procedure TPooler.setip(const ip: WideString);
var
  RDM:iSvrRDM;
begin
  RDM:=LockRDM;
  try
    Rdm.setip(ip);
  finally
    UnLockRDM(RDM);
  end;
end;

function TPooler.login(const usercode, password: WideString): Integer;
var
  RDM:iSvrRDM;
begin
  RDM:=LockRDM;
  try
    Result:=RDM.login(usercode,password);
  finally
    UnLockRDM(RDM);
  end;
end;

function TPooler.getadmin(const usercode, password: WideString): WordBool;
var
  RDM:iSvrRDM;
begin
  RDM:=LockRDM;
  try
    Result:=RDM.GetAdmin(usercode,password);
  finally
    UnLockRDM(RDM);
  end;
end;

function TPooler.getapptitle: WideString;
var
  RDM:iSvrRDM;
begin
  RDM:=LockRDM;
  try
    Result:=RDM.Getapptitle;
  finally
    UnLockRDM(RDM);
  end;
end;

function TPooler.getgroupid(const usercode, username: WideString): Integer;
var
  RDM:iSvrRDM;
begin
  RDM:=LockRDM;
  try
    Result:=RDM.getgroupid(usercode,username);
  finally
    UnLockRDM(RDM);
  end;
end;

function TPooler.getusername(const usercode,
  password: WideString): WideString;
var
  RDM:iSvrRDM;
begin
  RDM:=LockRDM;
  try
    Result:=RDM.getusername(usercode,password);
  finally
    UnLockRDM(RDM);
  end;
end;

function TPooler.syslog(const fform, fevent, fuser,
  fpcname: WideString): Integer;
var
  RDM:iSvrRDM;
begin
  RDM:=LockRDM;
  try
    Result:=RDM.syslog(fform,fevent,fuser,fpcname);
  finally
    UnLockRDM(RDM);
  end;
end;

function TPooler.execsql(const cmdstr: WideString): WordBool;
var
  RDM:iSvrRDM;
begin
  RDM:=LockRDM;
  try
    Result:=RDM.execsql(cmdstr);
  finally
    UnLockRDM(RDM);
  end;
end;

function TPooler.getlargedata(const psql: WideString;
  precCount: Integer): OleVariant;
var
  RDM:iSvrRDM;
begin
  RDM:=LockRDM;
  try
    Result:=RDM.getlargedata(psql,precCount);
  finally
    UnLockRDM(RDM);
  end;
end;

function TPooler.applyupdata(pdelta: OleVariant; const ptablename,
  pkeyfield: WideString): WordBool;
var
  RDM:iSvrRDM;
begin
  RDM:=LockRDM;
  try
    Result:=RDM.applyupdata(pdelta,ptablename,pkeyfield);
  finally
    UnLockRDM(RDM);
  end;
end;

function TPooler.getmaxid(const ptablename,
  pkeyfield: WideString): Integer;
var
  RDM:iSvrRDM;
begin
  RDM:=LockRDM;
  try
    Result:=RDM.getmaxid(ptablename,pkeyfield);
  finally
    UnLockRDM(RDM);
  end;
end;

function TPooler.isunique(const ptablename, pkeyfield,
  pkeyvalue: WideString): WordBool;
var
  RDM:iSvrRDM;
begin
  RDM:=LockRDM;
  try
    Result:=RDM.isunique(ptablename,pkeyfield,pkeyvalue);
  finally
    UnLockRDM(RDM);
  end;
end;

function TPooler.getnumber(pBilltypeid: Integer): WideString;
var
  RDM:iSvrRDM;
begin
  RDM:=LockRDM;
  try
    Result:=RDM.getnumber(pBilltypeid);
  finally
    UnLockRDM(RDM);
  end;
end;

function TPooler.getinnunber(pbilltypeid: Integer): Integer;
var
  RDM:iSvrRDM;
begin
  RDM:=LockRDM;
  try
    Result:=RDM.Getinnunber(pbilltypeid);
  finally
    UnLockRDM(RDM);
  end;
end;

function TPooler.purchasedetail(pitemid: Integer): OleVariant;
var
  RDM:iSvrRDM;
begin
  RDM:=LockRDM;
  try
    Result:=RDM.purchasedetail(pitemid);
  finally
    UnLockRDM(RDM);
  end;
end;

initialization
  PoolManager := TPoolManager.Create;
  TAutoObjectFactory.Create(ComServer, TPooler, Class_pooler, ciMultiInstance, tmFree);
finalization
  PoolManager.Free;
end.