You've already forked lazarus-ccr
+Delphi : QWord = UInt64 for CompilerVersion > 16.0
+THeaderBlockProxy : This class is used as a wrapper to allow a TBaseRemotable instance to be sent and received as a header block +ICallContext.AddHeader() : Overload to support classes that do not inherit from THeaderBlock +TTypeRegistryItem.AddExternalSynonym(), TTypeRegistryItem.IsExternalSynonym() Usefull when a xsd defines a complex type and a "element" which type is the complex one. +TTypeRegistry.FindByDeclaredName(): Add an option to include the external synonyms in the search git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@744 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
inoussa
@ -123,7 +123,12 @@ type
|
||||
function AddHeader(
|
||||
const AHeader : THeaderBlock;
|
||||
const AKeepOwnership : Boolean
|
||||
):Integer;
|
||||
):Integer;overload;
|
||||
function AddHeader(
|
||||
const AHeader : TBaseRemotable;
|
||||
const AKeepOwnership : Boolean;
|
||||
const AName : string = ''
|
||||
):Integer;overload;
|
||||
function GetHeaderCount(const ADirections : THeaderDirections):Integer;
|
||||
function GetHeader(const AIndex : Integer) : THeaderBlock;
|
||||
procedure ClearHeaders(const ADirection : THeaderDirection);
|
||||
@ -228,7 +233,12 @@ type
|
||||
function AddHeader(
|
||||
const AHeader : THeaderBlock;
|
||||
const AKeepOwnership : Boolean
|
||||
):Integer;
|
||||
):Integer;overload;
|
||||
function AddHeader(
|
||||
const AHeader : TBaseRemotable;
|
||||
const AKeepOwnership : Boolean;
|
||||
const AName : string = ''
|
||||
):Integer;overload;
|
||||
function GetHeaderCount(const ADirections : THeaderDirections):Integer;
|
||||
function GetHeader(const AIndex : Integer) : THeaderBlock;
|
||||
procedure ClearHeaders(const ADirection : THeaderDirection);
|
||||
@ -758,12 +768,18 @@ type
|
||||
private
|
||||
FDirection: THeaderDirection;
|
||||
FmustUnderstand: Integer;
|
||||
FName: string;
|
||||
FUnderstood: Boolean;
|
||||
private
|
||||
function HasmustUnderstand: boolean;
|
||||
procedure SetmustUnderstand(const AValue: Integer);
|
||||
protected
|
||||
function GetName: string; virtual;
|
||||
procedure SetName(const AValue: string); virtual;
|
||||
public
|
||||
property Direction : THeaderDirection read FDirection write FDirection;
|
||||
property Understood : Boolean read FUnderstood write FUnderstood;
|
||||
property Name : string read GetName write SetName;
|
||||
published
|
||||
property mustUnderstand : Integer read FmustUnderstand write SetmustUnderstand stored HasmustUnderstand;
|
||||
end;
|
||||
@ -790,7 +806,40 @@ type
|
||||
);override;
|
||||
property Value : string read FValue write FValue;
|
||||
end;
|
||||
|
||||
|
||||
{ THeaderBlockProxy
|
||||
This class is used as a wrapper to allow a TBaseRemotable instance to be
|
||||
sent and received as a header block.
|
||||
}
|
||||
THeaderBlockProxy = class(THeaderBlock)
|
||||
private
|
||||
FActualObject: TBaseRemotable;
|
||||
FOwnObject: Boolean;
|
||||
FNameSet : Boolean;
|
||||
private
|
||||
procedure SetActualObject(const AValue: TBaseRemotable);
|
||||
protected
|
||||
function GetName : string; override;
|
||||
procedure SetName(const AValue: string); override;
|
||||
public
|
||||
destructor Destroy(); override;
|
||||
class procedure Save(
|
||||
AObject : TBaseRemotable;
|
||||
AStore : IFormatterBase;
|
||||
const AName : string;
|
||||
const ATypeInfo : PTypeInfo
|
||||
);override;
|
||||
class procedure Load(
|
||||
var AObject : TObject;
|
||||
AStore : IFormatterBase;
|
||||
var AName : string;
|
||||
const ATypeInfo : PTypeInfo
|
||||
);override;
|
||||
|
||||
property ActualObject : TBaseRemotable read FActualObject write SetActualObject;
|
||||
property OwnObject : Boolean read FOwnObject write FOwnObject;
|
||||
end;
|
||||
|
||||
{ TObjectCollectionRemotable
|
||||
An implementation for array handling. The array items are "owned" by
|
||||
this class instance, so one has not to free them.
|
||||
@ -1434,7 +1483,8 @@ type
|
||||
FNameSpace: string;
|
||||
FDeclaredName : string;
|
||||
FOptions: TTypeRegistryItemOptions;
|
||||
FSynonymTable : TStrings;
|
||||
FPascalSynonyms : TStrings;
|
||||
FExternalSynonyms : TStrings;
|
||||
FExternalNames : TStrings;
|
||||
FInternalNames : TStrings;
|
||||
private
|
||||
@ -1448,7 +1498,9 @@ type
|
||||
);virtual;
|
||||
destructor Destroy();override;
|
||||
function AddPascalSynonym(const ASynonym : string):TTypeRegistryItem;
|
||||
function AddExternalSynonym(const ASynonym : string):TTypeRegistryItem;
|
||||
function IsSynonym(const APascalTypeName : string):Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF}
|
||||
function IsExternalSynonym(const AExternalName : string):Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF}
|
||||
|
||||
procedure RegisterExternalPropertyName(const APropName, AExtPropName : string);
|
||||
function GetExternalPropertyName(const APropName : string) : string;{$IFDEF USE_INLINE}inline;{$ENDIF}
|
||||
@ -1464,6 +1516,9 @@ type
|
||||
property Options : TTypeRegistryItemOptions read FOptions write FOptions;
|
||||
end;
|
||||
|
||||
TTypeRegistrySearchOption = ( trsoIncludeExternalSynonyms );
|
||||
TTypeRegistrySearchOptions = set of TTypeRegistrySearchOption;
|
||||
|
||||
{ TTypeRegistry }
|
||||
|
||||
TTypeRegistry = class
|
||||
@ -1491,7 +1546,11 @@ type
|
||||
):TTypeRegistryItem;
|
||||
function Find(ATypeInfo : PTypeInfo; Const AExact : Boolean):TTypeRegistryItem;overload;
|
||||
function Find(const APascalTypeName : string):TTypeRegistryItem;overload;
|
||||
function FindByDeclaredName(const ATypeName,ANameSpace : string):TTypeRegistryItem;
|
||||
function FindByDeclaredName(
|
||||
const ATypeName,
|
||||
ANameSpace : string;
|
||||
const AOptions : TTypeRegistrySearchOptions = []
|
||||
) : TTypeRegistryItem;
|
||||
Property Count : Integer Read GetCount;
|
||||
Property Item[Index:Integer] : TTypeRegistryItem Read GetItemByIndex;default;
|
||||
Property ItemByTypeInfo[Index:PTypeInfo] : TTypeRegistryItem Read GetItemByTypeInfo;
|
||||
@ -1543,6 +1602,10 @@ const
|
||||
const AField : shortstring;
|
||||
const AVisibility : Boolean
|
||||
);
|
||||
function GetExternalName(
|
||||
const ATypeInfo : PTypeInfo;
|
||||
const ARegistry : TTypeRegistry = nil
|
||||
) : string;
|
||||
|
||||
|
||||
function IsStoredPropClass(AClass : TClass;PropInfo : PPropInfo) : TPropStoreType;
|
||||
@ -1629,6 +1692,8 @@ begin
|
||||
ri.Options := ri.Options + [trioNonVisibleToMetadataService];
|
||||
ri := r.Register(sSOAP_ENV,TypeInfo(TSimpleContentHeaderBlock));
|
||||
ri.Options := ri.Options + [trioNonVisibleToMetadataService];
|
||||
ri := r.Register(sSOAP_ENV,TypeInfo(THeaderBlockProxy));
|
||||
ri.Options := ri.Options + [trioNonVisibleToMetadataService];
|
||||
|
||||
|
||||
r.Register(sWST_BASE_NS,TypeInfo(TArrayOfStringRemotable),'TArrayOfStringRemotable').AddPascalSynonym('TArrayOfStringRemotable');
|
||||
@ -1683,6 +1748,25 @@ begin
|
||||
r.Register(sXSD_NS,TypeInfo(TBase16StringExtRemotable),'hexBinary').AddPascalSynonym('TBase16StringExtRemotable');
|
||||
end;
|
||||
|
||||
function GetExternalName(
|
||||
const ATypeInfo : PTypeInfo;
|
||||
const ARegistry : TTypeRegistry
|
||||
) : string;
|
||||
var
|
||||
locReg : TTypeRegistry;
|
||||
locRegItem : TTypeRegistryItem;
|
||||
begin
|
||||
if ( ARegistry = nil ) then
|
||||
locReg := GetTypeRegistry()
|
||||
else
|
||||
locReg := ARegistry;
|
||||
locRegItem := locReg.Find(ATypeInfo,False);
|
||||
if ( locRegItem <> nil ) then
|
||||
Result := locRegItem.DeclaredName
|
||||
else
|
||||
Result := ATypeInfo^.Name;
|
||||
end;
|
||||
|
||||
procedure SetFieldSerializationVisibility(
|
||||
const ATypeInfo : PTypeInfo; // must be tkRecord
|
||||
const AField : shortstring;
|
||||
@ -2766,6 +2850,35 @@ begin
|
||||
AddObjectToFree(AHeader);
|
||||
end;
|
||||
|
||||
function TSimpleCallContext.AddHeader(
|
||||
const AHeader : TBaseRemotable;
|
||||
const AKeepOwnership : Boolean;
|
||||
const AName : string = ''
|
||||
) : Integer;
|
||||
var
|
||||
locProxy : THeaderBlockProxy;
|
||||
begin
|
||||
if ( AHeader <> nil ) then begin
|
||||
if AHeader.InheritsFrom(THeaderBlock) then begin
|
||||
if not IsStrEmpty(AName) then
|
||||
THeaderBlock(AHeader).Name := AName;
|
||||
Result := AddHeader(THeaderBlock(AHeader),AKeepOwnership);
|
||||
end else begin
|
||||
locProxy := THeaderBlockProxy.Create();
|
||||
locProxy.ActualObject := AHeader;
|
||||
locProxy.OwnObject := AKeepOwnership;
|
||||
if not IsStrEmpty(AName) then
|
||||
locProxy.Name := AName;
|
||||
Result := AddHeader(locProxy,True);
|
||||
end;
|
||||
end else begin
|
||||
locProxy := THeaderBlockProxy.Create();
|
||||
if not IsStrEmpty(AName) then
|
||||
locProxy.Name := AName;
|
||||
Result := AddHeader(locProxy,True);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TSimpleCallContext.GetHeaderCount(const ADirections : THeaderDirections):Integer;
|
||||
var
|
||||
i : Integer;
|
||||
@ -2885,7 +2998,8 @@ begin
|
||||
FreeObjects();
|
||||
FInternalNames.Free();
|
||||
FExternalNames.Free();
|
||||
FSynonymTable.Free();
|
||||
FPascalSynonyms.Free();
|
||||
FExternalSynonyms.Free();
|
||||
inherited Destroy();
|
||||
end;
|
||||
|
||||
@ -2894,19 +3008,39 @@ begin
|
||||
Result := Self;
|
||||
if AnsiSameText(ASynonym,DataType^.Name) then
|
||||
Exit;
|
||||
if not Assigned(FSynonymTable) then begin
|
||||
FSynonymTable := TStringList.Create();
|
||||
FSynonymTable.Add(FDataType^.Name);
|
||||
if not Assigned(FPascalSynonyms) then begin
|
||||
FPascalSynonyms := TStringList.Create();
|
||||
FPascalSynonyms.Add(FDataType^.Name);
|
||||
end;
|
||||
if ( FSynonymTable.IndexOf(ASynonym) = -1 ) then
|
||||
FSynonymTable.Add(AnsiLowerCase(ASynonym));
|
||||
if ( FPascalSynonyms.IndexOf(ASynonym) = -1 ) then
|
||||
FPascalSynonyms.Add(AnsiLowerCase(ASynonym));
|
||||
end;
|
||||
|
||||
function TTypeRegistryItem.AddExternalSynonym(const ASynonym: string): TTypeRegistryItem;
|
||||
begin
|
||||
Result := Self;
|
||||
if AnsiSameText(ASynonym,DataType^.Name) then
|
||||
Exit;
|
||||
if not Assigned(FExternalSynonyms) then begin
|
||||
FExternalSynonyms := TStringList.Create();
|
||||
FExternalSynonyms.Add(Self.DeclaredName);
|
||||
end;
|
||||
if ( FExternalSynonyms.IndexOf(ASynonym) = -1 ) then
|
||||
FExternalSynonyms.Add(AnsiLowerCase(ASynonym));
|
||||
end;
|
||||
|
||||
function TTypeRegistryItem.IsSynonym(const APascalTypeName: string): Boolean;
|
||||
begin
|
||||
Result := AnsiSameText(APascalTypeName,DataType^.Name);
|
||||
if ( not Result ) and Assigned(FSynonymTable) then
|
||||
Result := ( FSynonymTable.IndexOf(APascalTypeName) >= 0 ) ;
|
||||
if ( not Result ) and Assigned(FPascalSynonyms) then
|
||||
Result := ( FPascalSynonyms.IndexOf(APascalTypeName) >= 0 ) ;
|
||||
end;
|
||||
|
||||
function TTypeRegistryItem.IsExternalSynonym(const AExternalName: string): Boolean;
|
||||
begin
|
||||
Result := AnsiSameText(AExternalName,Self.DeclaredName);
|
||||
if ( not Result ) and Assigned(FExternalSynonyms) then
|
||||
Result := ( FExternalSynonyms.IndexOf(AExternalName) >= 0 ) ;
|
||||
end;
|
||||
|
||||
procedure TTypeRegistryItem.RegisterExternalPropertyName(const APropName,AExtPropName: string);
|
||||
@ -3119,18 +3253,33 @@ end;
|
||||
|
||||
function TTypeRegistry.FindByDeclaredName(
|
||||
const ATypeName,
|
||||
ANameSpace : string
|
||||
ANameSpace : string;
|
||||
const AOptions : TTypeRegistrySearchOptions
|
||||
): TTypeRegistryItem;
|
||||
var
|
||||
i, c : Integer;
|
||||
begin
|
||||
{ The external synonym is not tested in the first loop so that the declared
|
||||
names are _first_ search for.
|
||||
}
|
||||
c := Count;
|
||||
for i := 0 to Pred(c) do begin
|
||||
Result := Item[i];
|
||||
if AnsiSameText(ANameSpace,Result.NameSpace) and
|
||||
AnsiSameText(ATypeName,Result.DeclaredName)
|
||||
then
|
||||
Exit;
|
||||
if ( c > 0 ) then begin
|
||||
for i := 0 to Pred(c) do begin
|
||||
Result := Item[i];
|
||||
if AnsiSameText(ANameSpace,Result.NameSpace) and
|
||||
AnsiSameText(ATypeName,Result.DeclaredName)
|
||||
then
|
||||
Exit;
|
||||
end;
|
||||
if ( trsoIncludeExternalSynonyms in AOptions ) then begin
|
||||
for i := 0 to Pred(c) do begin
|
||||
Result := Item[i];
|
||||
if AnsiSameText(ANameSpace,Result.NameSpace) and
|
||||
Result.IsExternalSynonym(ATypeName)
|
||||
then
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
Result := nil;
|
||||
end;
|
||||
@ -4429,6 +4578,13 @@ begin
|
||||
Result := ( FmustUnderstand <> 0 );
|
||||
end;
|
||||
|
||||
function THeaderBlock.GetName : string;
|
||||
begin
|
||||
if IsStrEmpty(FName) then
|
||||
FName := GetExternalName(PTypeInfo(Self.ClassInfo));
|
||||
Result := FName;
|
||||
end;
|
||||
|
||||
procedure THeaderBlock.SetmustUnderstand(const AValue: Integer);
|
||||
begin
|
||||
if ( AValue <> 0 ) then
|
||||
@ -4437,6 +4593,11 @@ begin
|
||||
FmustUnderstand := 0;
|
||||
end;
|
||||
|
||||
procedure THeaderBlock.SetName(const AValue: string);
|
||||
begin
|
||||
FName := AValue;
|
||||
end;
|
||||
|
||||
{ TSimpleContentHeaderBlock }
|
||||
|
||||
class procedure TSimpleContentHeaderBlock.Save(
|
||||
@ -4498,6 +4659,91 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
{ THeaderBlockProxy }
|
||||
|
||||
procedure THeaderBlockProxy.SetActualObject(const AValue: TBaseRemotable);
|
||||
var
|
||||
locObj : TObject;
|
||||
begin
|
||||
if ( FActualObject <> AValue ) then begin
|
||||
if OwnObject and ( FActualObject <> nil ) then begin
|
||||
locObj := FActualObject;
|
||||
FActualObject := nil;
|
||||
locObj.Free();
|
||||
end;
|
||||
FActualObject := AValue;
|
||||
end;
|
||||
end;
|
||||
|
||||
function THeaderBlockProxy.GetName : string;
|
||||
begin
|
||||
if FNameSet then
|
||||
Result := inherited GetName()
|
||||
else if ( ActualObject <> nil ) then
|
||||
Result := GetExternalName(PTypeInfo(ActualObject.ClassInfo))
|
||||
else
|
||||
Result := Self.ClassName();
|
||||
end;
|
||||
|
||||
procedure THeaderBlockProxy.SetName(const AValue: string);
|
||||
begin
|
||||
inherited SetName(AValue);
|
||||
FNameSet := not IsStrEmpty(AValue);
|
||||
end;
|
||||
|
||||
destructor THeaderBlockProxy.Destroy();
|
||||
begin
|
||||
if OwnObject then
|
||||
ActualObject.Free();
|
||||
inherited Destroy();
|
||||
end;
|
||||
|
||||
class procedure THeaderBlockProxy.Save(
|
||||
AObject : TBaseRemotable;
|
||||
AStore : IFormatterBase;
|
||||
const AName : string;
|
||||
const ATypeInfo : PTypeInfo
|
||||
);
|
||||
var
|
||||
locObj : THeaderBlockProxy;
|
||||
begin
|
||||
if ( AObject <> nil ) and AObject.InheritsFrom(THeaderBlockProxy) then begin
|
||||
locObj := THeaderBlockProxy(AObject);
|
||||
if ( locObj.ActualObject <> nil ) then
|
||||
locObj.ActualObject.Save(
|
||||
locObj.ActualObject,
|
||||
AStore,
|
||||
AName,
|
||||
PTypeInfo(locObj.ActualObject.ClassInfo)
|
||||
);
|
||||
end;
|
||||
end;
|
||||
|
||||
class procedure THeaderBlockProxy.Load(
|
||||
var AObject : TObject;
|
||||
AStore : IFormatterBase;
|
||||
var AName : string;
|
||||
const ATypeInfo : PTypeInfo
|
||||
);
|
||||
var
|
||||
locObj : THeaderBlockProxy;
|
||||
locActualObj : TObject;
|
||||
begin
|
||||
if ( AObject <> nil ) and AObject.InheritsFrom(THeaderBlockProxy) then begin
|
||||
locObj := THeaderBlockProxy(AObject);
|
||||
if ( locObj.ActualObject <> nil ) then
|
||||
locActualObj := locObj.ActualObject;
|
||||
locObj.ActualObject.Load(
|
||||
locActualObj,
|
||||
AStore,
|
||||
AName,
|
||||
PTypeInfo(locObj.ActualObject.ClassInfo)
|
||||
);
|
||||
if ( locObj.ActualObject <> locActualObj ) then
|
||||
locObj.ActualObject := TBaseRemotable(locActualObj);
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TStoredPropertyManager }
|
||||
|
||||
procedure TStoredPropertyManager.Error(Const AMsg: string);
|
||||
|
||||
@ -441,6 +441,7 @@ type
|
||||
|
||||
resourcestring
|
||||
SERR_NodeNotFoundByID = 'Node not found with this ID in the document : %s.';
|
||||
SERR_ExpectingRemotableObjectClass = 'Expecting remotable object class but found %s.';
|
||||
|
||||
implementation
|
||||
Uses {$IFDEF WST_DELPHI}XMLDoc,XMLIntf,{$ELSE}XMLWrite, XMLRead,wst_fpc_xml,{$ENDIF}
|
||||
@ -1540,16 +1541,22 @@ function TSOAPBaseFormatter.ReadHeaders(ACallContext: ICallContext): Integer;
|
||||
s := sXML_NS + ':' + nsSN;
|
||||
if not FindAttributeByNameInNode(s,ANode,nsLN) then
|
||||
nsLN := FindAttributeByNameInScope(s);
|
||||
Result := GetTypeRegistry().FindByDeclaredName(Copy(ndName,Succ(j),MaxInt),nsLN);
|
||||
Result := GetTypeRegistry().FindByDeclaredName(
|
||||
Copy(ndName,Succ(j),MaxInt),
|
||||
nsLN,
|
||||
[trsoIncludeExternalSynonyms]
|
||||
);
|
||||
end;
|
||||
|
||||
var
|
||||
i : Integer;
|
||||
nd : TDOMElement;
|
||||
typItm : TTypeRegistryItem;
|
||||
tmpObj : THeaderBlock;
|
||||
tmpHeader : THeaderBlock;
|
||||
locName : string;
|
||||
chdLst : TDOMNodeList;
|
||||
typData : PTypeData;
|
||||
tmpObj : TBaseRemotable;
|
||||
begin
|
||||
SetStyleAndEncoding(Document,Literal);
|
||||
try
|
||||
@ -1562,12 +1569,29 @@ begin
|
||||
typItm := ExtractTypeInfo(nd);
|
||||
if Assigned(typItm) then begin
|
||||
if ( typItm.DataType^.Kind = tkClass ) then begin
|
||||
tmpObj := nil;
|
||||
tmpHeader := nil;
|
||||
locName := nd.NodeName;
|
||||
Get(typItm.DataType,locName,tmpObj);
|
||||
if Assigned(tmpObj) then begin
|
||||
tmpObj.Direction := hdIn;
|
||||
ACallContext.AddHeader(tmpObj,True);
|
||||
typData := GetTypeData(typItm.DataType);
|
||||
if typData^.ClassType.InheritsFrom(THeaderBlock) then begin
|
||||
Get(typItm.DataType,locName,tmpHeader);
|
||||
if Assigned(tmpHeader) then begin
|
||||
tmpHeader.Direction := hdIn;
|
||||
ACallContext.AddHeader(tmpHeader,True);
|
||||
tmpHeader.Name := ExtractNameFromQualifiedName(locName);
|
||||
end;
|
||||
end else if typData^.ClassType.InheritsFrom(TBaseRemotable) then begin
|
||||
tmpObj := nil;
|
||||
Get(typItm.DataType,locName,tmpObj);
|
||||
if Assigned(tmpObj) then begin
|
||||
tmpHeader := THeaderBlockProxy.Create();
|
||||
THeaderBlockProxy(tmpHeader).ActualObject := tmpObj;
|
||||
THeaderBlockProxy(tmpHeader).OwnObject := True;
|
||||
tmpHeader.Direction := hdIn;
|
||||
ACallContext.AddHeader(tmpHeader,True);
|
||||
tmpHeader.Name := ExtractNameFromQualifiedName(locName);
|
||||
end;
|
||||
end else begin
|
||||
Error(SERR_ExpectingRemotableObjectClass,[typItm.DataType^.Name]);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
@ -1596,7 +1620,8 @@ begin
|
||||
h := ACallContext.GetHeader(i);
|
||||
if ( h.Direction = hdOut ) then begin
|
||||
ptyp := PTypeInfo(h.ClassInfo);
|
||||
Put(GetTypeRegistry().ItemByTypeInfo[ptyp].DeclaredName,ptyp,h);
|
||||
//Put(GetTypeRegistry().ItemByTypeInfo[ptyp].DeclaredName,ptyp,h);
|
||||
Put(h.Name,ptyp,h);
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
|
||||
@ -46,6 +46,7 @@ Type
|
||||
function IsStrEmpty(Const AStr:ShortString):Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF}overload;
|
||||
function GetToken(var ABuffer : string; const ADelimiter : string): string;
|
||||
function ExtractOptionName(const ACompleteName : string):string;
|
||||
function ExtractNameFromQualifiedName(const AQualifiedName : string; const ASeparator : Char = ':') : string;
|
||||
function TranslateDotToDecimalSeperator(const Value: string) : string;
|
||||
function wst_FormatFloat(
|
||||
const ATypeInfo : PTypeInfo;
|
||||
@ -101,6 +102,16 @@ begin
|
||||
Result := Trim(Result);
|
||||
end;
|
||||
|
||||
function ExtractNameFromQualifiedName(const AQualifiedName : string; const ASeparator : Char) : string;
|
||||
var
|
||||
sepPos : Integer;
|
||||
begin
|
||||
sepPos := Pos(ASeparator,AQualifiedName);
|
||||
if ( sepPos <= 0 ) then
|
||||
sepPos := 0;
|
||||
Result := Copy(AQualifiedName,(sepPos + 1),Length(AQualifiedName));
|
||||
end;
|
||||
|
||||
function TranslateDotToDecimalSeperator(const Value: string) : string;
|
||||
var
|
||||
i : PtrInt;
|
||||
|
||||
@ -19,11 +19,8 @@ interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, TypInfo, Contnrs,
|
||||
base_service_intf;
|
||||
base_service_intf, wst_types;
|
||||
|
||||
{$INCLUDE wst.inc}
|
||||
{$INCLUDE wst_delphi.inc}
|
||||
|
||||
Const
|
||||
sTARGET = 'target';
|
||||
|
||||
@ -99,7 +96,12 @@ Type
|
||||
function AddHeader(
|
||||
const AHeader : THeaderBlock;
|
||||
const AKeepOwnership : Boolean
|
||||
):Integer;
|
||||
):Integer;overload;
|
||||
function AddHeader(
|
||||
const AHeader : TBaseRemotable;
|
||||
const AKeepOwnership : Boolean;
|
||||
const AName : string = ''
|
||||
):Integer;overload;
|
||||
function GetHeaderCount(const ADirections : THeaderDirections):Integer;
|
||||
function GetHeader(const AIndex : Integer) : THeaderBlock;
|
||||
// ---- END >> ICallContext implementation ----
|
||||
@ -267,6 +269,15 @@ begin
|
||||
Result := FCallContext.AddHeader(AHeader,AKeepOwnership);
|
||||
end;
|
||||
|
||||
function TBaseProxy.AddHeader(
|
||||
const AHeader : TBaseRemotable;
|
||||
const AKeepOwnership : Boolean;
|
||||
const AName : string = ''
|
||||
): Integer;
|
||||
begin
|
||||
Result := FCallContext.AddHeader(AHeader,AKeepOwnership,AName);
|
||||
end;
|
||||
|
||||
function TBaseProxy.GetHeaderCount(const ADirections : THeaderDirections):Integer;
|
||||
begin
|
||||
Result := FCallContext.GetHeaderCount(ADirections);
|
||||
|
||||
@ -33,6 +33,28 @@ type
|
||||
|
||||
TSOAPTestEnum = ( steOne, steTwo, steThree, steFour );
|
||||
|
||||
{ TLoginInfos }
|
||||
|
||||
TLoginInfos = class(TBaseComplexRemotable)
|
||||
private
|
||||
FPassword: string;
|
||||
FUserName: string;
|
||||
published
|
||||
property UserName : string read FUserName write FUserName;
|
||||
property Password : string read FPassword write FPassword;
|
||||
end;
|
||||
|
||||
{ THeaderProxyTestObject }
|
||||
|
||||
THeaderProxyTestObject = class(TBaseComplexRemotable)
|
||||
private
|
||||
FDestructionCount: PInteger;
|
||||
procedure SetDestructionCount(const AValue: PInteger);
|
||||
public
|
||||
destructor Destroy(); override;
|
||||
property DestructionCount : PInteger read FDestructionCount write SetDestructionCount;
|
||||
end;
|
||||
|
||||
{ NBHeader }
|
||||
|
||||
NBHeader = class(THeaderBlock)
|
||||
@ -130,9 +152,15 @@ type
|
||||
TTest_SoapFormatterHeader = class(TTestCase)
|
||||
published
|
||||
procedure write_header_simple_content_1();
|
||||
procedure write_header_simple_content_1_b();
|
||||
procedure write_header_simple_content_2();
|
||||
procedure read_header_simple_content_1();
|
||||
procedure read_header_simple_content_2();
|
||||
|
||||
procedure write_header_proxy_header_block();
|
||||
procedure write_header_proxy_header_block_name();
|
||||
procedure read_header_proxy_header_block();
|
||||
procedure read_header_proxy_header_block_name();
|
||||
end;
|
||||
|
||||
THRefTestSession = class(TBaseComplexRemotable)
|
||||
@ -151,6 +179,15 @@ type
|
||||
procedure test_soap_href_id();
|
||||
end;
|
||||
|
||||
{ TTest_THeaderBlockProxy }
|
||||
|
||||
TTest_THeaderBlockProxy = class(TTestCase)
|
||||
published
|
||||
procedure ActualObject;
|
||||
procedure OwnObject_Destroy;
|
||||
procedure OwnObject_SetActualObject;
|
||||
end;
|
||||
|
||||
implementation
|
||||
uses
|
||||
object_serializer, server_service_soap, test_suite_utils, soap_formatter;
|
||||
@ -489,6 +526,39 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTest_SoapFormatterHeader.write_header_simple_content_1_b();
|
||||
var
|
||||
ser : IFormatterClient;
|
||||
cc : ICallContext;
|
||||
hdr : TSampleSimpleContentHeaderBlock_A;
|
||||
locStream : TMemoryStream;
|
||||
locDoc, locExistDoc : TXMLDocument;
|
||||
begin
|
||||
cc := TSimpleCallContext.Create();
|
||||
hdr := TSampleSimpleContentHeaderBlock_A.Create();
|
||||
cc.AddHeader(TBaseRemotable(hdr),True);
|
||||
hdr.Direction := hdOut;
|
||||
hdr.Value := 'sample header simple content value';
|
||||
ser := soap_formatter.TSOAPFormatter.Create();
|
||||
ser.BeginCall('test_proc','TestService',cc);
|
||||
ser.EndScope();
|
||||
locDoc := nil;
|
||||
locExistDoc := nil;
|
||||
locStream := TMemoryStream.Create();
|
||||
try
|
||||
ser.SaveToStream(locStream);
|
||||
//locStream.SaveToFile(wstExpandLocalFileName('write_header_simple_content_1.xml'));
|
||||
locStream.Position := 0;
|
||||
ReadXMLFile(locDoc,locStream);
|
||||
ReadXMLFile(locExistDoc,wstExpandLocalFileName(TestFilesPath + 'write_header_simple_content_1.xml'));
|
||||
Check(CompareNodes(locExistDoc.DocumentElement,locDoc.DocumentElement),'generated document differs from the existent one.');
|
||||
finally
|
||||
ReleaseDomNode(locDoc);
|
||||
ReleaseDomNode(locExistDoc);
|
||||
locStream.Free();
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTest_SoapFormatterHeader.write_header_simple_content_2();
|
||||
var
|
||||
ser : IFormatterClient;
|
||||
@ -623,6 +693,175 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTest_SoapFormatterHeader.write_header_proxy_header_block();
|
||||
var
|
||||
ser : IFormatterClient;
|
||||
cc : ICallContext;
|
||||
locLoginInfo : TLoginInfos;
|
||||
locStream : TMemoryStream;
|
||||
locDoc, locExistDoc : TXMLDocument;
|
||||
begin
|
||||
cc := TSimpleCallContext.Create();
|
||||
locLoginInfo := TLoginInfos.Create();
|
||||
locLoginInfo.UserName := 'Inoussa-wst';
|
||||
locLoginInfo.Password := 'sample password';
|
||||
cc.AddHeader(locLoginInfo,True);
|
||||
ser := soap_formatter.TSOAPFormatter.Create();
|
||||
ser.BeginCall('test_proc','TestService',cc);
|
||||
ser.EndScope();
|
||||
locDoc := nil;
|
||||
locExistDoc := nil;
|
||||
locStream := TMemoryStream.Create();
|
||||
try
|
||||
ser.SaveToStream(locStream);
|
||||
locStream.SaveToFile(wstExpandLocalFileName('write_header_proxy_header_block.xml'));
|
||||
locStream.Position := 0;
|
||||
ReadXMLFile(locDoc,locStream);
|
||||
ReadXMLFile(locExistDoc,wstExpandLocalFileName(TestFilesPath + 'write_header_proxy_header_block.xml'));
|
||||
Check(CompareNodes(locExistDoc.DocumentElement,locDoc.DocumentElement),'generated document differs from the existent one.');
|
||||
finally
|
||||
ReleaseDomNode(locDoc);
|
||||
ReleaseDomNode(locExistDoc);
|
||||
locStream.Free();
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTest_SoapFormatterHeader.write_header_proxy_header_block_name();
|
||||
var
|
||||
ser : IFormatterClient;
|
||||
cc : ICallContext;
|
||||
locLoginInfo : TLoginInfos;
|
||||
locStream : TMemoryStream;
|
||||
locDoc, locExistDoc : TXMLDocument;
|
||||
begin
|
||||
cc := TSimpleCallContext.Create();
|
||||
locLoginInfo := TLoginInfos.Create();
|
||||
locLoginInfo.UserName := 'Inoussa-wst';
|
||||
locLoginInfo.Password := 'sample password';
|
||||
cc.AddHeader(locLoginInfo,True,'NamedLoginInfos');
|
||||
ser := soap_formatter.TSOAPFormatter.Create();
|
||||
ser.BeginCall('test_proc','TestService',cc);
|
||||
ser.EndScope();
|
||||
locDoc := nil;
|
||||
locExistDoc := nil;
|
||||
locStream := TMemoryStream.Create();
|
||||
try
|
||||
ser.SaveToStream(locStream);
|
||||
locStream.SaveToFile(wstExpandLocalFileName('write_header_proxy_header_block_name.xml'));
|
||||
locStream.Position := 0;
|
||||
ReadXMLFile(locDoc,locStream);
|
||||
ReadXMLFile(locExistDoc,wstExpandLocalFileName(TestFilesPath + 'write_header_proxy_header_block_name.xml'));
|
||||
Check(CompareNodes(locExistDoc.DocumentElement,locDoc.DocumentElement),'generated document differs from the existent one.');
|
||||
finally
|
||||
ReleaseDomNode(locDoc);
|
||||
ReleaseDomNode(locExistDoc);
|
||||
locStream.Free();
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTest_SoapFormatterHeader.read_header_proxy_header_block();
|
||||
const
|
||||
XML_SOURCE =
|
||||
'<?xml version="1.0"?>' + sLineBreak +
|
||||
'<SOAP-ENV:Envelope ' + sLineBreak +
|
||||
' xmlns:xsd="http://www.w3.org/2001/XMLSchema" ' + sLineBreak +
|
||||
' xmlns:xsi="http://www.w3.org/1999/XMLSchema-instance" ' + sLineBreak +
|
||||
' xmlns:SOAP-ENC="http://schemas.xmlsoap.org/soap/encoding/" ' + sLineBreak +
|
||||
' xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/">' + sLineBreak +
|
||||
' <SOAP-ENV:Header xmlns:ns1="soap.test.namespace">' + sLineBreak +
|
||||
' <ns1:LoginInfos >' + sLineBreak +
|
||||
' <ns1:UserName>Inoussa-wst</ns1:UserName>' + sLineBreak +
|
||||
' <ns1:Password>sample password</ns1:Password>' + sLineBreak +
|
||||
' </ns1:LoginInfos>' + sLineBreak +
|
||||
' </SOAP-ENV:Header>' + sLineBreak +
|
||||
' <SOAP-ENV:Body>' + sLineBreak +
|
||||
' <ns2:test_proc xmlns:ns2="TestService"/>' + sLineBreak +
|
||||
' </SOAP-ENV:Body>' + sLineBreak +
|
||||
'</SOAP-ENV:Envelope>';
|
||||
var
|
||||
f : IFormatterClient;
|
||||
strm : TMemoryStream;
|
||||
strBuffer : ansistring;
|
||||
cctx : ICallContext;
|
||||
hdr : THeaderBlockProxy;
|
||||
actualHeader : TLoginInfos;
|
||||
begin
|
||||
f := soap_formatter.TSOAPFormatter.Create() as IFormatterClient;
|
||||
strm := TMemoryStream.Create();
|
||||
try
|
||||
strBuffer := XML_SOURCE;
|
||||
strm.Write(strBuffer[1],Length(strBuffer));
|
||||
strm.Position := 0;
|
||||
f.LoadFromStream(strm);
|
||||
cctx := TSimpleCallContext.Create() as ICallContext;
|
||||
f.BeginCallRead(cctx);
|
||||
CheckEquals(0,cctx.GetHeaderCount([hdOut]),'Ouput header count');
|
||||
CheckEquals(1,cctx.GetHeaderCount([hdIn]),'Input header count');
|
||||
CheckIs(cctx.GetHeader(0),THeaderBlockProxy);
|
||||
hdr := THeaderBlockProxy(cctx.GetHeader(0));
|
||||
CheckIs(hdr.ActualObject,TLoginInfos);
|
||||
actualHeader := TLoginInfos(hdr.ActualObject);
|
||||
//CheckEquals(1,hdr.mustUnderstand,'mustUnderstand');
|
||||
CheckEquals('LoginInfos',hdr.Name,'Name');
|
||||
CheckEquals('Inoussa-wst',actualHeader.UserName,'UserName');
|
||||
CheckEquals('sample password',actualHeader.Password,'Password');
|
||||
f.EndScopeRead();
|
||||
finally
|
||||
FreeAndNil(strm);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTest_SoapFormatterHeader.read_header_proxy_header_block_name();
|
||||
const
|
||||
XML_SOURCE =
|
||||
'<?xml version="1.0"?>' + sLineBreak +
|
||||
'<SOAP-ENV:Envelope ' + sLineBreak +
|
||||
' xmlns:xsd="http://www.w3.org/2001/XMLSchema" ' + sLineBreak +
|
||||
' xmlns:xsi="http://www.w3.org/1999/XMLSchema-instance" ' + sLineBreak +
|
||||
' xmlns:SOAP-ENC="http://schemas.xmlsoap.org/soap/encoding/" ' + sLineBreak +
|
||||
' xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/">' + sLineBreak +
|
||||
' <SOAP-ENV:Header xmlns:ns1="soap.test.namespace">' + sLineBreak +
|
||||
' <ns1:NamedLoginInfos >' + sLineBreak +
|
||||
' <ns1:UserName>Inoussa-wst</ns1:UserName>' + sLineBreak +
|
||||
' <ns1:Password>sample password</ns1:Password>' + sLineBreak +
|
||||
' </ns1:NamedLoginInfos>' + sLineBreak +
|
||||
' </SOAP-ENV:Header>' + sLineBreak +
|
||||
' <SOAP-ENV:Body>' + sLineBreak +
|
||||
' <ns2:test_proc xmlns:ns2="TestService"/>' + sLineBreak +
|
||||
' </SOAP-ENV:Body>' + sLineBreak +
|
||||
'</SOAP-ENV:Envelope>';
|
||||
var
|
||||
f : IFormatterClient;
|
||||
strm : TMemoryStream;
|
||||
strBuffer : ansistring;
|
||||
cctx : ICallContext;
|
||||
hdr : THeaderBlockProxy;
|
||||
actualHeader : TLoginInfos;
|
||||
begin
|
||||
f := soap_formatter.TSOAPFormatter.Create() as IFormatterClient;
|
||||
strm := TMemoryStream.Create();
|
||||
try
|
||||
strBuffer := XML_SOURCE;
|
||||
strm.Write(strBuffer[1],Length(strBuffer));
|
||||
strm.Position := 0;
|
||||
f.LoadFromStream(strm);
|
||||
cctx := TSimpleCallContext.Create() as ICallContext;
|
||||
f.BeginCallRead(cctx);
|
||||
CheckEquals(0,cctx.GetHeaderCount([hdOut]),'Ouput header count');
|
||||
CheckEquals(1,cctx.GetHeaderCount([hdIn]),'Input header count');
|
||||
CheckIs(cctx.GetHeader(0),THeaderBlockProxy);
|
||||
hdr := THeaderBlockProxy(cctx.GetHeader(0));
|
||||
CheckIs(hdr.ActualObject,TLoginInfos);
|
||||
actualHeader := TLoginInfos(hdr.ActualObject);
|
||||
CheckEquals('NamedLoginInfos',hdr.Name,'Name');
|
||||
CheckEquals('Inoussa-wst',actualHeader.UserName,'UserName');
|
||||
CheckEquals('sample password',actualHeader.Password,'Password');
|
||||
f.EndScopeRead();
|
||||
finally
|
||||
FreeAndNil(strm);
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TTest_SoapFormatterClient }
|
||||
|
||||
procedure TTest_SoapFormatterClient.test_soap_href_id();
|
||||
@ -674,6 +913,92 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
{ THeaderProxyTestObject }
|
||||
|
||||
procedure THeaderProxyTestObject.SetDestructionCount(const AValue: PInteger);
|
||||
begin
|
||||
if ( FDestructionCount = AValue ) then
|
||||
Exit;
|
||||
FDestructionCount := AValue;
|
||||
end;
|
||||
|
||||
destructor THeaderProxyTestObject.Destroy();
|
||||
begin
|
||||
if ( FDestructionCount <> nil ) then
|
||||
Inc(FDestructionCount^);
|
||||
inherited Destroy();
|
||||
end;
|
||||
|
||||
{ TTest_THeaderBlockProxy }
|
||||
|
||||
procedure TTest_THeaderBlockProxy.ActualObject;
|
||||
var
|
||||
locObj : THeaderBlockProxy;
|
||||
ao1, ao2 : THeaderProxyTestObject;
|
||||
begin
|
||||
ao1 := nil;
|
||||
ao2 := nil;
|
||||
locObj := THeaderBlockProxy.Create();
|
||||
try
|
||||
CheckNull(locObj.ActualObject);
|
||||
CheckEquals(False, locObj.OwnObject);
|
||||
ao1 := THeaderProxyTestObject.Create();
|
||||
ao2 := THeaderProxyTestObject.Create();
|
||||
|
||||
locObj.ActualObject := ao1;
|
||||
CheckSame(ao1, locObj.ActualObject);
|
||||
locObj.ActualObject := ao2;
|
||||
CheckSame(ao2,locObj.ActualObject);
|
||||
locObj.ActualObject := nil;
|
||||
CheckNull(locObj.ActualObject);
|
||||
finally
|
||||
locObj.Free();
|
||||
ao1.Free();
|
||||
ao2.Free();
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTest_THeaderBlockProxy.OwnObject_Destroy;
|
||||
var
|
||||
locObj : THeaderBlockProxy;
|
||||
ao1 : THeaderProxyTestObject;
|
||||
locDestructionCount : Integer;
|
||||
begin
|
||||
locDestructionCount := 0;
|
||||
ao1 := nil;
|
||||
locObj := THeaderBlockProxy.Create();
|
||||
ao1 := THeaderProxyTestObject.Create();
|
||||
locObj.ActualObject := ao1;
|
||||
locObj.OwnObject := True;
|
||||
ao1.DestructionCount := @locDestructionCount;
|
||||
locObj.Free();
|
||||
CheckEquals(1,locDestructionCount);
|
||||
end;
|
||||
|
||||
procedure TTest_THeaderBlockProxy.OwnObject_SetActualObject;
|
||||
var
|
||||
locObj : THeaderBlockProxy;
|
||||
ao1, ao2 : THeaderProxyTestObject;
|
||||
locDestructionCount : Integer;
|
||||
begin
|
||||
locDestructionCount := 0;
|
||||
ao1 := nil;
|
||||
locObj := THeaderBlockProxy.Create();
|
||||
ao1 := THeaderProxyTestObject.Create();
|
||||
ao1.DestructionCount := @locDestructionCount;
|
||||
ao2 := THeaderProxyTestObject.Create();
|
||||
ao2.DestructionCount := @locDestructionCount;
|
||||
locObj.OwnObject := True;
|
||||
|
||||
locObj.ActualObject := ao1;
|
||||
locObj.ActualObject := ao2;
|
||||
CheckEquals(1,locDestructionCount);
|
||||
locObj.ActualObject := ao2;
|
||||
CheckEquals(1,locDestructionCount,'Setting the same value should not free the object.');
|
||||
locObj.Free();
|
||||
CheckEquals(2,locDestructionCount);
|
||||
end;
|
||||
|
||||
initialization
|
||||
|
||||
GetTypeRegistry().Register(TSampleSimpleContentHeaderBlock_A.GetNameSpace(),TypeInfo(TSampleSimpleContentHeaderBlock_A));
|
||||
@ -686,10 +1011,14 @@ initialization
|
||||
GetTypeRegistry().Register(TNameSpaceC_Class.GetNameSpace(),TypeInfo(TNameSpaceC_Class));
|
||||
GetTypeRegistry().Register(ns_soap_test,TypeInfo(TSOAPTestEnum));
|
||||
GetTypeRegistry().Register('urn:WS_PlotjetIntfU',TypeInfo(THRefTestSession),'TSession');
|
||||
GetTypeRegistry().Register(ns_soap_test,TypeInfo(TLoginInfos),'LoginInfos').AddExternalSynonym('NamedLoginInfos');
|
||||
GetTypeRegistry().Register(ns_soap_test,TypeInfo(THeaderProxyTestObject));
|
||||
|
||||
|
||||
RegisterTest('Serializer',TTest_SoapFormatterServerNameSpace.Suite);
|
||||
RegisterTest('Serializer',TTest_SoapFormatterHeader.Suite);
|
||||
RegisterTest('Serializer',TTest_SoapFormatterClient.Suite);
|
||||
|
||||
RegisterTest('Support',TTest_THeaderBlockProxy.Suite);
|
||||
end.
|
||||
|
||||
|
||||
@ -103,7 +103,7 @@ type
|
||||
class function GetItemClass():TBaseRemotableClass;override;
|
||||
property Item[AIndex:Integer] : TClass_A Read GetItem;Default;
|
||||
end;
|
||||
|
||||
|
||||
{ TTest_TBaseComplexRemotable }
|
||||
|
||||
TTest_TBaseComplexRemotable = class(TTestCase)
|
||||
|
||||
@ -1,6 +1,14 @@
|
||||
{$IFNDEF FPC}
|
||||
{$IFDEF DELPHI}
|
||||
type
|
||||
{$IFDEF CompilerVersion}
|
||||
{$IF ( CompilerVersion > 16.0 )}
|
||||
QWord = UInt64;
|
||||
{$IFEND}
|
||||
{$ENDIF CompilerVersion}
|
||||
{$IF Not Declared(QWord) }
|
||||
QWord = type Int64;
|
||||
{$IFEND
|
||||
}
|
||||
DWORD = LongWord;
|
||||
PtrInt = Integer;
|
||||
PByteArray = ^ByteArray;
|
||||
@ -8,4 +16,4 @@
|
||||
PtrUInt = Cardinal;
|
||||
SizeInt = Longint;
|
||||
UnicodeChar = WideChar;
|
||||
{$ENDIF}
|
||||
{$ENDIF DELPHI}
|
||||
|
||||
Reference in New Issue
Block a user