Universal Agent on demond SDK --UAServiceObjectPool(0分)

{******************************************************************************************}
{ }
{ 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 begin
Read;
procedure EndRead;
procedure begin
Write;
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;
public
property PoolManager: TCustomPoolManager read FPoolManager;
property InUse: Boolean read FInUse;
property PoGID:LongWord read FPoGID;
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);
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 Listdo
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
begin
Read;
try
Result := ListCount(FItems);
finally
EndRead;
end;
end;

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

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

procedure TPoolThreadList.begin
Read;
begin
EnterCriticalSection(FLock);
end;

procedure TPoolThreadList.EndRead;
begin
LeaveCriticalSection(FLock);
end;

procedure TPoolThreadList.begin
Write;
begin
EnterCriticalSection(FLock);
end;

procedure TPoolThreadList.EndWrite;
begin
LeaveCriticalSection(FLock);
end;

procedure TPoolThreadList.Lock;
begin
begin
Write;
end;

procedure TPoolThreadList.Unlock;
begin
EndWrite;
end;

function TPoolThreadList.Add(Item: Pointer): Integer;
begin
begin
Write;
try
Result := Count;
Insert(Result, Item);
finally
EndWrite;
end;
end;

procedure TPoolThreadList.Insert(Index: Integer;
Item: Pointer);
begin
begin
Write;
try
ListInsert(FItems, Index, Item);
finally
EndWrite;
end;
end;

procedure TPoolThreadList.Clear;
begin
begin
Write;
try
ListClear(FItems);
finally
EndWrite;
end;
end;

procedure TPoolThreadList.Remove(Item: Pointer);
begin
begin
Write;
try
if ListIndexOf(FItems, Item) >= 0 then
ListRemove(FItems, Item);
finally
EndWrite;
end;
end;

{ TCustomPoolManager }
constructor TCustomPoolManager.Create(iMaxCount: Integer;
iTimeout: DWord);
begin
FItems := TPoolThreadList.Create;
FTimeout := iTimeout;
FMaxCount := iMaxCount;
FSemaphore := CreateSemaphore(nil, FMaxCount, FMaxCount, nil);
end;

destructor TCustomPoolManager.Destroy;
begin
FItems.Free;
CloseHandle(FSemaphore);
inherited;
end;

procedure TCustomPoolManager.Clear;
var
I: Integer;
begin
Lock;
try
for I := 0 to FItems.Count - 1do
Items.Free;
FItems.Clear;
finally
Unlock;
end;
end;

procedure TCustomPoolManager.ClearUnused;
var
I: Integer;
Item: TCustomPoolObject;
begin
Lock;
try
for I := FItems.Count - 1do
wnto 0do
begin
Item := Items;
if not Item.InUse then
begin
Item.Free;
FItems.Remove(Item);
end;
end;
finally
Unlock;
end;
end;

procedure TCustomPoolManager.Lock;
begin
FItems.Lock;
end;

procedure TCustomPoolManager.Unlock;
begin
FItems.Unlock;
end;

function TCustomPoolManager.GetCount: Integer;
begin
Result := FItems.Count;
end;

function TCustomPoolManager.GetItem(Index: Integer): TCustomPoolObject;
begin
Result := FItems[Index];
end;

function TCustomPoolManager.LockInstance: TCustomPoolObject;
procedure RaiseError;
begin
raise EInvalidOp.Create('Error for Lock Server Object !');
end;

var
I: Integer;
Instance: TCustomPoolObject;
begin

Result := nil;
if WaitForSingleObject(FSemaphore, Timeout) = WAIT_FAILED then
RaiseError;
Lock;
try
for I := 0 to FItems.Count - 1do
begin
Instance := FItems;
if GetLock(Instance) then
begin
LastSrvObjActivityGID := Instance.PoGID;
Result := Instance;
{ UADebugEx(ddLockObj,Now(),Result,
'---Lock An Instance---'+#13#10+
'Server Object Manager :'+ SrvObjMgrName +#13#10+
Format('Max Count Is %s ;
Current Count Is %s',[IntToStr(MaxCount),IntToStr(Count)]) +#13#10+
'Last Activity Instance GID:'+ IntToStr(LastSrvObjActivityGID)+#13#10);
}
Exit;
end;
end;
if FItems.Count < MaxCount then
begin
Result := CreateNewInstance;
{ UADebugEx(ddLockObj,Now(),Result,
'---Create An Instance And Lock ---'+#13#10+
'Server Object Manager :'+ SrvObjMgrName +#13#10+
Format('Max Count Is %s ;
Current Count Is %s',[IntToStr(MaxCount),IntToStr(Count)]) +#13#10+
'Last Activity Instance GID:'+ IntToStr(LastSrvObjActivityGID)+#13#10);
}
end
else
RaiseError;
finally
Unlock;
end;

end;

procedure TCustomPoolManager.UnlockInstance(Instance: TCustomPoolObject);
begin

Lock;
try
LockedInstance(Instance, False);
Instance.FInUse := False;
ReleaseSemaphore(FSemaphore, 1, nil);
{ UADebugEx(ddUnLockObj,Now(),Instance,
'---UnLock An Instance---'+#13#10+
'Server Object Manager :'+ SrvObjMgrName +#13#10+
Format('Max Count Is %s ;
Current Count Is %s',[IntToStr(MaxCount),IntToStr(Count)]) +#13#10+
'Last Activity Instance GID:'+ IntToStr(LastSrvObjActivityGID)+#13#10 );
}
finally
Unlock;
end;

end;

procedure TCustomPoolManager.LockedInstance(Instance: TCustomPoolObject;
Value: Boolean);
begin

end;

procedure TCustomPoolManager.CheckLocked(Instance: TCustomPoolObject;
var InUse: Boolean);
begin

if TCustomPoolObject(Instance) = nil then
begin

end
else
begin

end;

end;

function TCustomPoolManager.GetLock(Instance: TCustomPoolObject): Boolean;
begin
Lock;
try
CheckLocked(Instance, Instance.FInUse);
Result := not Instance.InUse;
if Result then
begin
Instance.FInUse := True;
////
end;
LockedInstance(Instance, True);
finally
Unlock;
end;
end;

function TCustomPoolManager.CreateNewInstance: TCustomPoolObject;
begin
Lock;
try
Result := InternalCreateNewInstance;
if Assigned(Result) then
try
Result.FInUse := True;
Result.FPoGID := GenerateGUID32;
LastSrvObjActivityGID := Result.PoGID;
Result.FPoolManager := Self;
FItems.Add(Result);
LockedInstance(Result, True);
except
Result.Free;
raise;
end;
finally
Unlock;
end;
end;


procedure TCustomPoolManager.SetSrvObjMgrType(const Value: TSrvObjMgrType);
begin
FSrvObjMgrType := Value;
end;

procedure TCustomPoolManager.SetLastSrvObjActivityGID(
const Value: LongWord);
begin
FLastSrvObjActivityGID := Value;
end;

procedure TCustomPoolManager.SetSrvObjMgrName(const Value: string);
begin
FSrvObjMgrName := Value;
end;

initialization
PoolManagerList := TObjectList.Create;
PoolManagerList.OwnsObjects := true;
finalization
if Assigned(PoolManagerList) then
FreeAndNil(PoolManagerList);
end.