You've already forked lazarus-ccr
service implementation pooling
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@189 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
inoussa
@ -15,7 +15,7 @@ unit base_service_intf;
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, TypInfo, Contnrs;
|
||||
Classes, SysUtils, TypInfo, Contnrs, syncobjs, semaphore;
|
||||
|
||||
{$INCLUDE wst.inc}
|
||||
{$INCLUDE wst_delphi.inc}
|
||||
@ -90,6 +90,7 @@ type
|
||||
|
||||
IItemFactoryEx = interface(IItemFactory)
|
||||
['{66B77926-7E45-4780-8FFB-FB78625EDC1D}']
|
||||
procedure ReleaseInstance(var AInstance : IInterface);
|
||||
function GetPropertyManager(
|
||||
const APropertyGroup : string;
|
||||
const ACreateIfNotExists : Boolean
|
||||
@ -987,26 +988,84 @@ type
|
||||
private
|
||||
FItemClass : TSimpleFactoryItemClass;
|
||||
protected
|
||||
function CreateInstance():IInterface;
|
||||
function CreateInstance():IInterface;virtual;
|
||||
function GetItemClass() : TSimpleFactoryItemClass;
|
||||
public
|
||||
constructor Create(AItemClass : TSimpleFactoryItemClass);
|
||||
End;
|
||||
|
||||
{ TIntfPoolItem }
|
||||
|
||||
TIntfPoolItem = class
|
||||
private
|
||||
FIntf: IInterface;
|
||||
FUsed: Boolean;
|
||||
public
|
||||
constructor Create(AIntf : IInterface; const AUsed : Boolean);
|
||||
destructor Destroy();override;
|
||||
property Intf : IInterface read FIntf;
|
||||
property Used : Boolean read FUsed write FUsed;
|
||||
end;
|
||||
|
||||
TIntfPool = class
|
||||
private
|
||||
FList : TObjectList;
|
||||
FCS : TCriticalSection;
|
||||
FLock : TSemaphoreObject;
|
||||
FFactory : IItemFactory;
|
||||
FMin : PtrInt;
|
||||
FMax : PtrInt;
|
||||
private
|
||||
function CreateNew() : TIntfPoolItem;
|
||||
function TryGet(const AIndex : PtrInt) : Boolean;
|
||||
public
|
||||
constructor Create(
|
||||
const AMin, AMax : PtrInt;
|
||||
AFactory : IItemFactory
|
||||
);
|
||||
destructor Destroy();override;
|
||||
function Get(const ATimeOut : Cardinal) : IInterface;
|
||||
procedure Release(var AItem : IInterface);
|
||||
property Min : PtrInt read FMin;
|
||||
property Max : PtrInt read FMax;
|
||||
end;
|
||||
|
||||
{ TSimpleItemFactoryEx }
|
||||
|
||||
TSimpleItemFactoryEx = class(TSimpleItemFactory,IInterface,IItemFactory,IItemFactoryEx)
|
||||
private
|
||||
FPooled: Boolean;
|
||||
FPoolMax: PtrInt;
|
||||
FPoolMin: PtrInt;
|
||||
FPropertyNames : TStringList;
|
||||
FProperties : IInterfaceList;
|
||||
FPool : TIntfPool;
|
||||
FTimeOut: PtrUInt;
|
||||
private
|
||||
procedure PreparePool();
|
||||
procedure SetPooled(const AValue: Boolean);
|
||||
procedure SetPoolMax(const AValue: PtrInt);
|
||||
procedure SetPoolMin(const AValue: PtrInt);
|
||||
protected
|
||||
function CreateInstance():IInterface;override;
|
||||
procedure ReleaseInstance(var AInstance : IInterface);virtual;
|
||||
function GetPropertyManager(
|
||||
const APropertyGroup : string;
|
||||
const ACreateIfNotExists : Boolean
|
||||
):IPropertyManager;
|
||||
public
|
||||
constructor Create(AItemClass : TSimpleFactoryItemClass);
|
||||
constructor Create(
|
||||
AItemClass : TSimpleFactoryItemClass;
|
||||
const APropsString : string
|
||||
);overload;
|
||||
constructor Create(AItemClass : TSimpleFactoryItemClass);overload;
|
||||
destructor Destroy();override;
|
||||
End;
|
||||
published
|
||||
property PoolMax : PtrInt read FPoolMax write SetPoolMax;
|
||||
property PoolMin : PtrInt read FPoolMin write SetPoolMin;
|
||||
property Pooled : Boolean read FPooled write SetPooled;
|
||||
property TimeOut : PtrUInt read FTimeOut write FTimeOut;
|
||||
end;
|
||||
|
||||
TTypeRegistryItemOption = ( trioNonVisibleToMetadataService );
|
||||
TTypeRegistryItemOptions = set of TTypeRegistryItemOption;
|
||||
@ -1107,6 +1166,7 @@ const
|
||||
function IsStoredPropClass(AClass : TClass;PropInfo : PPropInfo) : TPropStoreType;
|
||||
|
||||
implementation
|
||||
uses imp_utils;
|
||||
|
||||
Var
|
||||
TypeRegistryInstance : TTypeRegistry = Nil;
|
||||
@ -1999,6 +2059,11 @@ begin
|
||||
Result := FItemClass.Create() as IInterface;
|
||||
end;
|
||||
|
||||
function TSimpleItemFactory.GetItemClass(): TSimpleFactoryItemClass;
|
||||
begin
|
||||
Result := FItemClass;
|
||||
end;
|
||||
|
||||
constructor TSimpleItemFactory.Create(AItemClass: TSimpleFactoryItemClass);
|
||||
begin
|
||||
Assert(Assigned(AItemClass));
|
||||
@ -2007,6 +2072,62 @@ end;
|
||||
|
||||
{ TSimpleItemFactoryEx }
|
||||
|
||||
procedure TSimpleItemFactoryEx.PreparePool();
|
||||
begin
|
||||
if ( FPool = nil ) then begin
|
||||
FPool := TIntfPool.Create(PoolMin,PoolMax,TSimpleItemFactory.Create(FItemClass));
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSimpleItemFactoryEx.SetPooled(const AValue: Boolean);
|
||||
begin
|
||||
if ( FPooled = AValue ) then
|
||||
Exit;
|
||||
FreeAndNil(FPool);
|
||||
if AValue then begin
|
||||
if ( PoolMin < 0 ) or ( PoolMin > PoolMax ) or ( PoolMax < 1 ) then
|
||||
raise EServiceException.Create('Invalid pool parametters.');
|
||||
PreparePool();
|
||||
end;
|
||||
FPooled := AValue;
|
||||
end;
|
||||
|
||||
procedure TSimpleItemFactoryEx.SetPoolMax(const AValue: PtrInt);
|
||||
begin
|
||||
if ( FPoolMax = AValue ) then
|
||||
Exit;
|
||||
if Pooled then
|
||||
raise EServiceException.Create('Operation not allowed on an active pool.');
|
||||
FPoolMax := AValue;
|
||||
end;
|
||||
|
||||
procedure TSimpleItemFactoryEx.SetPoolMin(const AValue: PtrInt);
|
||||
begin
|
||||
if ( FPoolMin = AValue ) then
|
||||
Exit;
|
||||
if Pooled then
|
||||
raise EServiceException.Create('Operation not allowed on an active pool.');
|
||||
FPoolMin := AValue;
|
||||
end;
|
||||
|
||||
function TSimpleItemFactoryEx.CreateInstance(): IInterface;
|
||||
begin
|
||||
if Pooled then begin
|
||||
Result := FPool.Get(TimeOut);
|
||||
end else begin
|
||||
Result := inherited CreateInstance();
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSimpleItemFactoryEx.ReleaseInstance(var AInstance: IInterface);
|
||||
begin
|
||||
if Pooled then begin
|
||||
FPool.Release(AInstance);
|
||||
end else begin
|
||||
AInstance := nil;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TSimpleItemFactoryEx.GetPropertyManager(
|
||||
const APropertyGroup : string;
|
||||
const ACreateIfNotExists : Boolean
|
||||
@ -2022,22 +2143,37 @@ begin
|
||||
if not ACreateIfNotExists then
|
||||
Exit;
|
||||
i := FPropertyNames.Add(s);
|
||||
FProperties.Add(TStoredPropertyManager.Create() as IInterface);
|
||||
if ( s = '' ) then
|
||||
FProperties.Add(TPublishedPropertyManager.Create(Self) as IInterface)
|
||||
else
|
||||
FProperties.Add(TStoredPropertyManager.Create() as IInterface);
|
||||
end;
|
||||
Result := FProperties.Get(i) as IPropertyManager;
|
||||
end;
|
||||
|
||||
constructor TSimpleItemFactoryEx.Create(AItemClass: TSimpleFactoryItemClass);
|
||||
constructor TSimpleItemFactoryEx.Create(
|
||||
AItemClass : TSimpleFactoryItemClass;
|
||||
const APropsString : string
|
||||
);
|
||||
begin
|
||||
inherited Create(AItemClass);
|
||||
FPropertyNames := TStringList.Create();
|
||||
FProperties := TInterfaceList.Create();
|
||||
if ( Length(APropsString) > 0 ) then begin
|
||||
GetPropertyManager('',True).SetProperties(APropsString);
|
||||
end;
|
||||
end;
|
||||
|
||||
constructor TSimpleItemFactoryEx.Create(AItemClass: TSimpleFactoryItemClass);
|
||||
begin
|
||||
Create(AItemClass,'');
|
||||
end;
|
||||
|
||||
destructor TSimpleItemFactoryEx.Destroy();
|
||||
begin
|
||||
FreeAndNil(FPropertyNames);
|
||||
FProperties := nil;
|
||||
FreeAndNil(FPool);
|
||||
inherited Destroy();
|
||||
end;
|
||||
|
||||
@ -4138,6 +4274,110 @@ begin
|
||||
(AObject as TComplexBooleanContentRemotable).Value := i;
|
||||
end;
|
||||
|
||||
{ TIntfPoolItem }
|
||||
|
||||
constructor TIntfPoolItem.Create(AIntf: IInterface; const AUsed: Boolean);
|
||||
begin
|
||||
FIntf := AIntf;
|
||||
FUsed := AUsed;
|
||||
end;
|
||||
|
||||
destructor TIntfPoolItem.Destroy();
|
||||
begin
|
||||
FIntf := nil;
|
||||
inherited Destroy();
|
||||
end;
|
||||
|
||||
{ TIntfPool }
|
||||
|
||||
function TIntfPool.CreateNew(): TIntfPoolItem;
|
||||
begin
|
||||
FCS.Acquire();
|
||||
try
|
||||
Result := TIntfPoolItem.Create(FFactory.CreateInstance(),True);
|
||||
FList.Add(Result);
|
||||
finally
|
||||
FCS.Release();
|
||||
end;
|
||||
end;
|
||||
|
||||
function TIntfPool.TryGet(const AIndex: PtrInt): Boolean;
|
||||
var
|
||||
itm : TIntfPoolItem;
|
||||
begin
|
||||
FCS.Acquire();
|
||||
try
|
||||
itm := TIntfPoolItem(FList[AIndex]);
|
||||
Result := not itm.Used;
|
||||
if Result then begin
|
||||
itm.Used := True;
|
||||
end;
|
||||
finally
|
||||
FCS.Release();
|
||||
end;
|
||||
end;
|
||||
|
||||
constructor TIntfPool.Create(
|
||||
const AMin, AMax : PtrInt;
|
||||
AFactory : IItemFactory
|
||||
);
|
||||
var
|
||||
i : PtrInt;
|
||||
begin
|
||||
Assert( ( AMin >= 0 ) and ( AMax >= AMin ) and ( AFactory <> nil ) );
|
||||
FMax := AMax;
|
||||
FMin := AMin;
|
||||
FFactory := AFactory;
|
||||
FLock := TSemaphoreObject.Create(FMax);
|
||||
FList := TObjectList.Create(True);
|
||||
FCS := TCriticalSection.Create();
|
||||
for i := 0 to Pred(AMin) do begin
|
||||
CreateNew();
|
||||
end;
|
||||
end;
|
||||
|
||||
destructor TIntfPool.Destroy();
|
||||
begin
|
||||
FFactory := nil;
|
||||
FreeAndNil(FCS);
|
||||
FreeAndNil(FLock);
|
||||
FreeAndNil(FList);
|
||||
inherited Destroy();
|
||||
end;
|
||||
|
||||
function TIntfPool.Get(const ATimeOut : Cardinal): IInterface;
|
||||
var
|
||||
i : PtrInt;
|
||||
begin
|
||||
Result := nil;
|
||||
if ( FLock.WaitFor(ATimeOut) = wrSignaled ) then begin
|
||||
for i := 0 to Pred(FList.Count) do begin
|
||||
if TryGet(i) then begin
|
||||
Result := TIntfPoolItem(FList[i]).Intf;
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
if ( Result = nil ) then begin
|
||||
Result := CreateNew().Intf;
|
||||
end;
|
||||
end else begin
|
||||
raise EServiceException.Create('Unable to create the object : Timeout expired.');
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TIntfPool.Release(var AItem: IInterface);
|
||||
var
|
||||
i : PtrInt;
|
||||
begin
|
||||
for i := 0 to Pred(FList.Count) do begin
|
||||
if ( TIntfPoolItem(FList[i]).Intf = AItem ) then begin
|
||||
TIntfPoolItem(FList[i]).Used := False;
|
||||
AItem := nil;
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
initialization
|
||||
TypeRegistryInstance := TTypeRegistry.Create();
|
||||
SerializeOptionsRegistryInstance := TSerializeOptionsRegistry.Create();
|
||||
|
||||
@ -96,6 +96,10 @@ begin
|
||||
If TryStrToInt64(AValue,int64Val) Then
|
||||
SetOrdProp(FParent,AName,int64Val);
|
||||
End;
|
||||
{$IFDEF FPC}
|
||||
tkBool :
|
||||
SetOrdProp(FParent,AName,Ord(StrToBool(AValue)));
|
||||
{$ENDIF}
|
||||
End;
|
||||
End;
|
||||
end;
|
||||
|
||||
@ -15,16 +15,23 @@ type
|
||||
|
||||
TWSTMetadataService_ServiceBinder=class(TBaseServiceBinder)
|
||||
Protected
|
||||
procedure GetRepositoryListHandler(AFormatter:IFormatterResponse);
|
||||
procedure GetRepositoryInfoHandler(AFormatter:IFormatterResponse);
|
||||
procedure GetRepositoryListHandler(AFormatter:IFormatterResponse; AContext : ICallContext);
|
||||
procedure GetRepositoryInfoHandler(AFormatter:IFormatterResponse; AContext : ICallContext);
|
||||
Public
|
||||
constructor Create();
|
||||
End;
|
||||
|
||||
{ TWSTMetadataService_ServiceBinderFactory }
|
||||
|
||||
TWSTMetadataService_ServiceBinderFactory = class(TInterfacedObject,IItemFactory)
|
||||
private
|
||||
FInstance : IInterface;
|
||||
protected
|
||||
function CreateInstance():IInterface;
|
||||
End;
|
||||
public
|
||||
constructor Create();
|
||||
destructor Destroy();override;
|
||||
end;
|
||||
|
||||
procedure Server_service_RegisterWSTMetadataServiceService();
|
||||
|
||||
@ -32,7 +39,7 @@ Implementation
|
||||
uses TypInfo, wst_resources_imp,metadata_repository;
|
||||
|
||||
{ TWSTMetadataService_ServiceBinder implementation }
|
||||
procedure TWSTMetadataService_ServiceBinder.GetRepositoryListHandler(AFormatter:IFormatterResponse);
|
||||
procedure TWSTMetadataService_ServiceBinder.GetRepositoryListHandler(AFormatter:IFormatterResponse; AContext : ICallContext);
|
||||
Var
|
||||
cllCntrl : ICallControl;
|
||||
tmpObj : IWSTMetadataService;
|
||||
@ -41,14 +48,14 @@ Var
|
||||
procName,trgName : string;
|
||||
returnVal : TArrayOfStringRemotable;
|
||||
Begin
|
||||
callCtx := GetCallContext();
|
||||
callCtx := AContext;
|
||||
If ( PTypeInfo(TypeInfo(TArrayOfStringRemotable))^.Kind in [tkClass,tkInterface] ) Then
|
||||
Pointer(returnVal) := Nil;
|
||||
|
||||
|
||||
tmpObj := Self.GetFactory().CreateInstance() as IWSTMetadataService;
|
||||
if Supports(tmpObj,ICallControl,cllCntrl) then
|
||||
cllCntrl.SetCallContext(GetCallContext());
|
||||
cllCntrl.SetCallContext(callCtx);
|
||||
|
||||
returnVal := tmpObj.GetRepositoryList();
|
||||
If ( PTypeInfo(TypeInfo(TArrayOfStringRemotable))^.Kind = tkClass ) And Assigned(Pointer(returnVal)) Then
|
||||
@ -64,7 +71,7 @@ Begin
|
||||
callCtx := Nil;
|
||||
End;
|
||||
|
||||
procedure TWSTMetadataService_ServiceBinder.GetRepositoryInfoHandler(AFormatter:IFormatterResponse);
|
||||
procedure TWSTMetadataService_ServiceBinder.GetRepositoryInfoHandler(AFormatter:IFormatterResponse; AContext : ICallContext);
|
||||
Var
|
||||
cllCntrl : ICallControl;
|
||||
tmpObj : IWSTMetadataService;
|
||||
@ -74,14 +81,14 @@ Var
|
||||
AName : string;
|
||||
returnVal : TWSTMtdRepository;
|
||||
Begin
|
||||
callCtx := GetCallContext();
|
||||
callCtx := AContext;
|
||||
Pointer(returnVal) := Nil;
|
||||
|
||||
strPrmName := 'AName'; AFormatter.Get(TypeInfo(string),strPrmName,AName);
|
||||
|
||||
tmpObj := Self.GetFactory().CreateInstance() as IWSTMetadataService;
|
||||
if Supports(tmpObj,ICallControl,cllCntrl) then
|
||||
cllCntrl.SetCallContext(GetCallContext());
|
||||
cllCntrl.SetCallContext(callCtx);
|
||||
|
||||
returnVal := tmpObj.GetRepositoryInfo(AName);
|
||||
If Assigned(Pointer(returnVal)) Then
|
||||
@ -109,9 +116,20 @@ End;
|
||||
{ TWSTMetadataService_ServiceBinderFactory }
|
||||
function TWSTMetadataService_ServiceBinderFactory.CreateInstance():IInterface;
|
||||
Begin
|
||||
Result := TWSTMetadataService_ServiceBinder.Create() as IInterface;
|
||||
Result := FInstance;
|
||||
End;
|
||||
|
||||
constructor TWSTMetadataService_ServiceBinderFactory.Create();
|
||||
begin
|
||||
FInstance := TWSTMetadataService_ServiceBinder.Create();
|
||||
end;
|
||||
|
||||
destructor TWSTMetadataService_ServiceBinderFactory.Destroy();
|
||||
begin
|
||||
FInstance := nil;
|
||||
inherited Destroy();
|
||||
end;
|
||||
|
||||
|
||||
procedure Server_service_RegisterWSTMetadataServiceService();
|
||||
Begin
|
||||
|
||||
@ -577,7 +577,7 @@ procedure TBaseComplexRemotable_TypeHandler.Generate(
|
||||
var
|
||||
typItm, propTypItm : TTypeRegistryItem;
|
||||
s, prop_ns_shortName : string;
|
||||
defTypesNode, defSchemaNode, cplxNode, sqcNode, propNode, eltNode : TDOMElement;
|
||||
defTypesNode, defSchemaNode, cplxNode, sqcNode, propNode : TDOMElement;
|
||||
i : Integer;
|
||||
propList : PPropList;
|
||||
propCount, propListLen : Integer;
|
||||
@ -596,13 +596,10 @@ begin
|
||||
Assert(Assigned(defTypesNode));
|
||||
defSchemaNode := defTypesNode.FirstChild as TDOMElement;
|
||||
|
||||
s := Format('%s:%s',[sXSD,sELEMENT]);
|
||||
eltNode := CreateElement(s,defSchemaNode,AWsdlDocument);
|
||||
eltNode.SetAttribute(sNAME, typItm.DeclaredName) ;
|
||||
|
||||
s := Format('%s:%s',[sXSD,sCOMPLEX_TYPE]);
|
||||
cplxNode := CreateElement(s,eltNode,AWsdlDocument);
|
||||
//cplxNode.SetAttribute(sNAME, typItm.DeclaredName) ;
|
||||
cplxNode := CreateElement(s,defSchemaNode,AWsdlDocument);
|
||||
cplxNode.SetAttribute(sNAME, typItm.DeclaredName) ;
|
||||
|
||||
s := Format('%s:%s',[sXSD,sSEQUENCE]);
|
||||
sqcNode := CreateElement(s,cplxNode,AWsdlDocument);
|
||||
objTypeData := GetTypeData(typItm.DataType);
|
||||
@ -623,7 +620,7 @@ begin
|
||||
s := Format('%s:%s',[sXSD,sELEMENT]);
|
||||
propNode := CreateElement(s,sqcNode,AWsdlDocument);
|
||||
end;
|
||||
propNode.SetAttribute(sNAME,p^.Name);
|
||||
propNode.SetAttribute(sNAME,typItm.GetExternalPropertyName(p^.Name));
|
||||
propTypItm := GetTypeRegistry().Find(p^.PropType^.Name);
|
||||
if Assigned(propTypItm) then begin
|
||||
prop_ns_shortName := GetNameSpaceShortName(propTypItm.NameSpace,AWsdlDocument);
|
||||
@ -775,7 +772,7 @@ procedure TBaseArrayRemotable_TypeHandler.Generate(
|
||||
var
|
||||
typItm, propTypItm : TTypeRegistryItem;
|
||||
s, prop_ns_shortName : string;
|
||||
defTypesNode, defSchemaNode, cplxNode, sqcNode, propNode, eltNode : TDOMElement;
|
||||
defTypesNode, defSchemaNode, cplxNode, sqcNode, propNode : TDOMElement;
|
||||
arrayTypeData : PTypeData;
|
||||
arrayTypeClass : TBaseArrayRemotableClass;
|
||||
begin
|
||||
@ -792,13 +789,10 @@ begin
|
||||
Assert(Assigned(defTypesNode));
|
||||
defSchemaNode := defTypesNode.FirstChild as TDOMElement;
|
||||
|
||||
s := Format('%s:%s',[sXSD,sELEMENT]);
|
||||
eltNode := CreateElement(s,defSchemaNode,AWsdlDocument);
|
||||
eltNode.SetAttribute(sNAME, typItm.DeclaredName) ;
|
||||
|
||||
s := Format('%s:%s',[sXSD,sCOMPLEX_TYPE]);
|
||||
cplxNode := CreateElement(s,eltNode,AWsdlDocument);
|
||||
//cplxNode.SetAttribute(sNAME, typItm.DeclaredName) ;
|
||||
cplxNode := CreateElement(s,defSchemaNode,AWsdlDocument);
|
||||
cplxNode.SetAttribute(sNAME, typItm.DeclaredName) ;
|
||||
|
||||
s := Format('%s:%s',[sXSD,sSEQUENCE]);
|
||||
sqcNode := CreateElement(s,cplxNode,AWsdlDocument);
|
||||
arrayTypeClass := TBaseArrayRemotableClass(arrayTypeData^.ClassType);
|
||||
|
||||
99
wst/trunk/semaphore.pas
Normal file
99
wst/trunk/semaphore.pas
Normal file
@ -0,0 +1,99 @@
|
||||
unit semaphore;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, syncobjs;
|
||||
|
||||
type
|
||||
|
||||
ESemaphoreException = class(Exception);
|
||||
|
||||
{ TSemaphoreObject }
|
||||
|
||||
TSemaphoreObject = class
|
||||
private
|
||||
FHandle : PRTLEvent;
|
||||
FLimit: Integer;
|
||||
FCurrentState : Integer;
|
||||
FCriticalSection : TCriticalSection;
|
||||
public
|
||||
constructor Create(const ALimit : Integer);
|
||||
destructor Destroy(); override;
|
||||
function WaitFor(ATimeout : Cardinal) : TWaitResult;
|
||||
procedure Release();
|
||||
property Limit : Integer read FLimit;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TSemaphoreObject }
|
||||
|
||||
constructor TSemaphoreObject.Create(const ALimit: Integer);
|
||||
begin
|
||||
Assert(ALimit>0);
|
||||
FLimit := ALimit;
|
||||
FHandle := RTLEventCreate();
|
||||
FCriticalSection := TCriticalSection.Create();
|
||||
FCurrentState := FLimit;
|
||||
RTLeventSetEvent(FHandle);
|
||||
end;
|
||||
|
||||
destructor TSemaphoreObject.Destroy();
|
||||
begin
|
||||
RTLeventdestroy(FHandle);
|
||||
FreeAndNil(FCriticalSection);
|
||||
inherited Destroy();
|
||||
end;
|
||||
|
||||
function TSemaphoreObject.WaitFor(ATimeout: Cardinal): TWaitResult;
|
||||
var
|
||||
ok : Boolean;
|
||||
begin
|
||||
Result := wrTimeout;
|
||||
ok := False;
|
||||
FCriticalSection.Acquire();
|
||||
try
|
||||
if ( FCurrentState > 0 ) then begin
|
||||
Dec(FCurrentState);
|
||||
ok := True;
|
||||
if ( FCurrentState = 0 ) then
|
||||
RTLeventResetEvent(FHandle);
|
||||
end;
|
||||
finally
|
||||
FCriticalSection.Release();
|
||||
end;
|
||||
if not ok then begin
|
||||
RTLeventWaitFor(FHandle,ATimeout);
|
||||
FCriticalSection.Acquire();
|
||||
try
|
||||
if ( FCurrentState > 0 ) then begin
|
||||
Dec(FCurrentState);
|
||||
ok := True;
|
||||
end;
|
||||
finally
|
||||
FCriticalSection.Release();
|
||||
end;
|
||||
end;
|
||||
if ok then
|
||||
Result := wrSignaled;
|
||||
end;
|
||||
|
||||
procedure TSemaphoreObject.Release();
|
||||
begin
|
||||
FCriticalSection.Acquire();
|
||||
try
|
||||
if ( FCurrentState < Limit ) then begin
|
||||
Inc(FCurrentState);
|
||||
end else begin
|
||||
raise ESemaphoreException.Create('Invalid semaphore operation.');
|
||||
end;
|
||||
finally
|
||||
FCriticalSection.Release();
|
||||
end;
|
||||
RTLeventSetEvent(FHandle);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
@ -33,6 +33,7 @@ Type
|
||||
|
||||
IServiceExtension = interface;
|
||||
IServiceExtensionRegistry = interface;
|
||||
IObjectControl = interface;
|
||||
|
||||
ICallControl = interface
|
||||
['{7B4B7192-EE96-4B52-92C7-AE855FBC31E7}']
|
||||
@ -95,7 +96,7 @@ Type
|
||||
const AExtensionList : array of string
|
||||
);
|
||||
function GetExtension(
|
||||
out AExtensionList : string
|
||||
out AExtensionList : string
|
||||
) : Boolean;
|
||||
end;
|
||||
|
||||
@ -122,15 +123,21 @@ Type
|
||||
procedure EndExceptionList();
|
||||
End;
|
||||
|
||||
TServiceVerbMethod = procedure(AFormatter:IFormatterResponse) of object;
|
||||
IObjectControl = interface
|
||||
['{C422C7CA-4C95-48A4-9A82-2616E619F851}']
|
||||
procedure Activate();
|
||||
procedure Deactivate();
|
||||
function CanBePooled() : Boolean;
|
||||
end;
|
||||
|
||||
TServiceVerbMethod = procedure(AFormatter:IFormatterResponse; AContext : ICallContext) of object;
|
||||
|
||||
{ TBaseServiceBinder }
|
||||
|
||||
TBaseServiceBinder = Class(TInterfacedObject,IServerService)
|
||||
TBaseServiceBinder = Class(TInterfacedPersistent,IServerService)
|
||||
Private
|
||||
FVerbList : TObjectList;
|
||||
FImplementationFactory : IServiceImplementationFactory;
|
||||
FCallContext : ICallContext;
|
||||
Protected
|
||||
procedure RegisterVerbHandler(
|
||||
const AVerb : string;
|
||||
@ -138,9 +145,8 @@ Type
|
||||
);
|
||||
function FindVerbHandler(const AVerb : string):TServiceVerbMethod;
|
||||
procedure HandleRequest(ARequestBuffer : IRequestBuffer);
|
||||
function GetFactory():IItemFactory;
|
||||
function GetFactory():IServiceImplementationFactory;
|
||||
function CreateCallContext():ICallContext;virtual;
|
||||
function GetCallContext():ICallContext;
|
||||
procedure DoProcessMessage(
|
||||
const AMessageStage : TMessageStage;
|
||||
ACallContext : ICallContext;
|
||||
@ -163,6 +169,14 @@ Type
|
||||
function GetCallContext():ICallContext;
|
||||
End;
|
||||
|
||||
{ TActivableServiceImplementation }
|
||||
|
||||
TActivableServiceImplementation = class(TBaseServiceImplementation,IObjectControl)
|
||||
protected
|
||||
procedure Activate();virtual;
|
||||
procedure Deactivate();virtual;
|
||||
function CanBePooled() : Boolean;virtual;
|
||||
end;
|
||||
|
||||
{ TImplementationFactory }
|
||||
|
||||
@ -178,7 +192,7 @@ Type
|
||||
const AExtensionList : array of string
|
||||
);
|
||||
function GetExtension(
|
||||
out AExtensionList : string
|
||||
out AExtensionList : string
|
||||
) : Boolean;
|
||||
end;
|
||||
|
||||
@ -332,17 +346,17 @@ begin
|
||||
if not Assigned(f) then
|
||||
Error('No formatter for that content type : "%s"',[s]);
|
||||
try
|
||||
cllCtx := GetCallContext();
|
||||
cllCtx := CreateCallContext();
|
||||
DoProcessMessage(msBeforeDeserialize,cllCtx,ARequestBuffer);
|
||||
strm := ARequestBuffer.GetContent();
|
||||
f.LoadFromStream(strm);
|
||||
f.BeginCallRead(GetCallContext());
|
||||
f.BeginCallRead(cllCtx);
|
||||
DoProcessMessage(msAfterDeserialize,cllCtx,f);
|
||||
s := f.GetCallProcedureName();
|
||||
m := FindVerbHandler(s);
|
||||
if not Assigned(m) then
|
||||
Error('No handler for that verb : "%s"',[s]);
|
||||
m(f);
|
||||
m(f,cllCtx);
|
||||
for i := 0 to Pred(cllCtx.GetHeaderCount(AllHeaderDirection)) do begin
|
||||
hdr := cllCtx.GetHeader(i);
|
||||
if ( hdr.Direction = hdIn ) and ( hdr.mustUnderstand <> 0 ) and ( not hdr.Understood ) then begin
|
||||
@ -368,23 +382,14 @@ begin
|
||||
DoProcessMessage(msAfterSerialize,cllCtx,ARequestBuffer);
|
||||
end;
|
||||
|
||||
function TBaseServiceBinder.GetFactory(): IItemFactory;
|
||||
function TBaseServiceBinder.GetFactory(): IServiceImplementationFactory;
|
||||
begin
|
||||
Result := FImplementationFactory;
|
||||
end;
|
||||
|
||||
function TBaseServiceBinder.CreateCallContext(): ICallContext;
|
||||
begin
|
||||
if not Assigned(FCallContext) then
|
||||
FCallContext := TSimpleCallContext.Create() as ICallContext;
|
||||
Result := FCallContext;
|
||||
end;
|
||||
|
||||
function TBaseServiceBinder.GetCallContext(): ICallContext;
|
||||
begin
|
||||
if not Assigned(FCallContext) then
|
||||
CreateCallContext();
|
||||
Result := FCallContext;
|
||||
Result := TSimpleCallContext.Create() as ICallContext;
|
||||
end;
|
||||
|
||||
procedure TBaseServiceBinder.DoProcessMessage(
|
||||
@ -421,6 +426,7 @@ end;
|
||||
constructor TBaseServiceBinder.Create(AImplementationFactory : IServiceImplementationFactory);
|
||||
begin
|
||||
Assert(Assigned(AImplementationFactory));
|
||||
inherited Create();
|
||||
FImplementationFactory := AImplementationFactory;
|
||||
FVerbList := TObjectList.Create(True);
|
||||
end;
|
||||
@ -554,6 +560,7 @@ end;
|
||||
|
||||
{ TImplementationFactory }
|
||||
const sSERVICES_EXTENSIONS = 'extensions';sLIST = 'list';
|
||||
|
||||
procedure TImplementationFactory.RegisterExtension(
|
||||
const AExtensionList : array of string
|
||||
);
|
||||
@ -621,6 +628,23 @@ begin
|
||||
Result := ServiceExtensionRegistryInst;
|
||||
end;
|
||||
|
||||
{ TActivableServiceImplementation }
|
||||
|
||||
procedure TActivableServiceImplementation.Activate();
|
||||
begin
|
||||
|
||||
end;
|
||||
|
||||
procedure TActivableServiceImplementation.Deactivate();
|
||||
begin
|
||||
|
||||
end;
|
||||
|
||||
function TActivableServiceImplementation.CanBePooled(): Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
end;
|
||||
|
||||
Initialization
|
||||
FormatterRegistryInst := TFormatterRegistry.Create() as IFormatterRegistry;
|
||||
ServerServiceRegistryInst := TServerServiceRegistry.Create() as IServerServiceRegistry;
|
||||
|
||||
Reference in New Issue
Block a user