uaserviceobjectpool.~pas

基于Midas 技术的多层应用开发包

{******************************************************************************************}
{                                                                                          }
{       Universal Agent on demond SDK                                                      }
{                                                                                          }
{                                                                                          }
{ COPYRIGHT                                                                                }
{ =========                                                                                }
{ The UA SDK (software) is Copyright (C) 2001-2003, by vinson zeng(曾胡龙).                }
{ All rights reserved.                                                                     }
{ The authors - vinson zeng (曾胡龙),                                                      }
{ exclusively own all copyrights to the Advanced Application                               }
{ Controls (AppControls) and all other products distributed by Utilmind Solutions(R).      }
{                                                                                          }
{ LIABILITY DISCLAIMER                                                                     }
{ ====================                                                                     }
{ THIS SOFTWARE IS DISTRIBUTED "AS IS" AND WITHOUT WARRANTIES AS TO PERFORMANCE            }
{ OF MERCHANTABILITY OR ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED.                 }
{ YOU USE IT AT YOUR OWN RISK. THE AUTHOR WILL NOT BE LIABLE FOR DATA LOSS,                }
{ DAMAGES, LOSS OF PROFITS OR ANY OTHER KIND OF LOSS WHILE USING OR MISUSING THIS SOFTWARE.}
{                                                                                          }
{ RESTRICTIONS                                                                             }
{ ============                                                                             }
{ You may not attempt to reverse compile, modify,                                          }
{ translate or disassemble the software in whole or in part.                               }
{ You may not remove or modify any copyright notice or the method by which                 }
{ it may be invoked.                                                                       }
{******************************************************************************************}


unit UAServiceObjectPool;

interface
uses
   Windows, SysUtils, TypInfo, Classes,  ActiveX
   ,SyncObjs,Contnrs,UAUnits;

type


  TPoolThreadList = class
  private
    FLock:  TRTLCriticalSection;
    FItems: TList;
    function GetCount: Integer;
    function GetItem(Index: Integer): Pointer;
  public
    constructor Create;
    destructor Destroy; override;
    procedure BeginRead;
    procedure EndRead;
    procedure BeginWrite;
    procedure EndWrite;
    procedure Lock;
    procedure Unlock;
    function  IndexOf(Item: Pointer): Integer;
    function  Add(Item: Pointer): Integer;
    procedure Insert(Index: Integer; Item: Pointer);
    procedure Remove(Item: Pointer);
    procedure Clear;
    property  Count: Integer read GetCount;
    property  Items[Index: Integer]: Pointer read GetItem; default;
  end;


  TCustomPoolManager = class;

  TCustomPoolObject = class(TObject)
  private
    FInUse: Boolean;
    FPoolManager: TCustomPoolManager;
    FPoGID:LongWord;
    FIsDirty: Boolean;
    procedure SetIsDirty(const Value: Boolean);
  public

    property PoolManager: TCustomPoolManager read FPoolManager;
    property InUse: Boolean read FInUse;
    property PoGID:LongWord read FPoGID;
    // add by vinson zeng 2004-12-06
    property IsDirty:Boolean read FIsDirty write SetIsDirty; 
    //----------- %% end of %%---------------

  end;

  TCustomPoolManager = class(TObject) ///PoolManagerList 来管理
  private
    FItems: TPoolThreadList;
    FMaxCount: Integer;
    FTimeout: DWord;
    FSemaphore: THandle;
    FSrvObjMgrType:TSrvObjMgrType;
    FLastSrvObjActivityGID:LongWord;
    FSrvObjMgrName:string;
    function  GetCount: Integer;
    function  GetItem(Index: Integer): TCustomPoolObject;
    procedure SetSrvObjMgrType(const Value: TSrvObjMgrType);
    procedure SetLastSrvObjActivityGID(const Value: LongWord);
    procedure SetSrvObjMgrName(const Value: string);

  protected
    function  InternalCreateNewInstance: TCustomPoolObject; virtual; abstract;
    function  CreateNewInstance: TCustomPoolObject;
    function  GetLock(Instance: TCustomPoolObject): Boolean;
    procedure LockedInstance(Instance: TCustomPoolObject; Value: Boolean);
    procedure CheckLocked(Instance: TCustomPoolObject; var InUse: Boolean);

    procedure ReleaseAllDirtyObj0;virtual;

  public
    constructor Create(iMaxCount: Integer; iTimeout: DWord);virtual;
    destructor Destroy; override;
    procedure  Clear;
    procedure  ClearUnused;
    procedure  Lock;
    procedure  Unlock;
    function   LockInstance: TCustomPoolObject;
    procedure  UnlockInstance(Instance: TCustomPoolObject);
    property Items[Index: Integer]: TCustomPoolObject read GetItem;
    property Count: Integer read GetCount;
    property Timeout: DWord read FTimeout;
    property MaxCount: Integer read FMaxCount;
    property SrvObjMgrType:TSrvObjMgrType read FSrvObjMgrType write SeTSrvObjMgrType;
    property SrvObjMgrName:string read FSrvObjMgrName write SetSrvObjMgrName;
    property LastSrvObjActivityGID:LongWord read FLastSrvObjActivityGID write SetLastSrvObjActivityGID;

  end;

  TPmObj = class(TObject)
    Name:string;
    aPm:TCustomPoolManager;
  end;


// ---------public function ----------------------------
function  ListCount(List: TList): Integer;
function  ListItem(List: TList; Index: Integer): Pointer;
procedure ListError(Index: Integer);
function  ListIndexOf(List: TList; Item: Pointer): Integer;
function  FindInteger(Value: Integer; const Buff; Count: Integer): Integer; assembler;
procedure ListInsert(var List: TList; Index: Integer; Item: Pointer);
procedure ListClear(var List: TList);
function  ListRemove(var List: TList; Item: Pointer): Pointer;
function  ListDelete(var List: TList; Index: Integer): Pointer;
procedure ListDestroy(var List: TList);
procedure FreeObject(var Obj); assembler;
//-----------%% end of %%------------------------------------
procedure RegisterPoolManager(const sName: string;var aPm: TCustomPoolManager;const MgrType:TSrvObjMgrType = sotBiz);




var
  PoolManagerList: TObjectList;       {Global SrvObjMgr List Manager}

implementation

procedure RegisterPoolManager(const sName: string;var aPm: TCustomPoolManager;const MgrType:TSrvObjMgrType = sotBiz);
var
  aPmObj: TPmObj;
begin

  if PoolManagerList=nil then
  begin
    PoolManagerList := TObjectList.Create;
    PoolManagerList.OwnsObjects := true;
  end;

  aPmObj :=TPmObj.Create;
  aPmObj.Name   := lowercase(sName);
  aPmObj.aPm  := aPm;
  aPmObj.aPm.SrvObjMgrName := sName;
  aPmObj.aPm.SrvObjMgrType := MgrType;
  PoolManagerList.Add(aPmObj);

end;



function ListCount(List: TList): Integer;
begin
  if Assigned(List) then Result := List.Count else Result := 0;
end;

function ListItem(List: TList; Index: Integer): Pointer;
begin
  if Assigned(List) then
    Result := List[Index]
  else begin
    Result := nil;
    ListError(Index);
  end;
end;

procedure ListError(Index: Integer);
begin
  raise EListError.Create('Index out of bounds!');
end;


function ListIndexOf(List: TList; Item: Pointer): Integer;
begin
  if Assigned(List) then
    with List do Result := FindInteger(Integer(Item), List^, Count) else Result := -1;
end;

function FindInteger(Value: Integer; const Buff; Count: Integer): Integer; assembler;
asm
        XCHG    EDI,EDX
        PUSH    ECX
        REPNE   SCASD
        MOV     EDI,EDX
        POP     EAX
        JE      @@1
        XOR     EAX,EAX
@@1:    SUB     EAX,ECX
        DEC     EAX
        MOV     EDI,EDX
end;

procedure ListInsert(var List: TList; Index: Integer; Item: Pointer);
begin
  if not Assigned(List) then List := TList.Create;
  List.Insert(Index, Item);
end;


procedure ListClear(var List: TList);
asm
    JMP  FreeObject
end;

function ListRemove(var List: TList; Item: Pointer): Pointer;
var
  I: Integer;
begin
  I := ListIndexOf(List, Item);
  if I >= 0 then
    Result := ListDelete(List, I) else
    Result := nil;
end;


function ListDelete(var List: TList; Index: Integer): Pointer;
begin
  Result := ListItem(List, Index);
  List.Delete(Index);
  if List.Count = 0 then ListDestroy(List);
end;


procedure ListDestroy(var List: TList);
asm
        JMP     FreeObject
end;


procedure FreeObject(var Obj); assembler;
asm
  MOV     ECX, [EAX]
  TEST    ECX, ECX
  JE      @@exit
  PUSH    EAX
  MOV     EAX, ECX
  MOV     ECX, [EAX]
  MOV     DL,1
  CALL    dword ptr [ECX - 4] { vtDestroy }
  POP     EAX
  XOR     ECX, ECX
  MOV     [EAX], ECX
@@exit:
end;




{ TPoolThreadList }
constructor TPoolThreadList.Create;
begin
  InitializeCriticalSection(FLock);
end;

destructor TPoolThreadList.Destroy;
begin
  Clear;
  DeleteCriticalSection(FLock);
  inherited;
end;

function TPoolThreadList.GetCount: Integer;
begin
  BeginRead;
  try
    Result := ListCount(FItems);
  finally
    EndRead;
  end;
end;

function TPoolThreadList.GetItem(Index: Integer): Pointer;
begin
  BeginRead;
  try
    Result := ListItem(FItems, Index);
  finally
    EndRead;
  end;
end;

function TPoolThreadList.IndexOf(Item: Pointer): Integer;
begin
  BeginRead;
  try
    Result := ListIndexOf(FItems, Item);
  finally
    EndRead;
  end;
end;