diff --git a/wst/trunk/base_service_intf.pas b/wst/trunk/base_service_intf.pas index 56324e797..b11603a80 100644 --- a/wst/trunk/base_service_intf.pas +++ b/wst/trunk/base_service_intf.pas @@ -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); diff --git a/wst/trunk/base_soap_formatter.pas b/wst/trunk/base_soap_formatter.pas index 161353184..939e07746 100644 --- a/wst/trunk/base_soap_formatter.pas +++ b/wst/trunk/base_soap_formatter.pas @@ -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 diff --git a/wst/trunk/imp_utils.pas b/wst/trunk/imp_utils.pas index 3ec167dbe..d1c1cc714 100644 --- a/wst/trunk/imp_utils.pas +++ b/wst/trunk/imp_utils.pas @@ -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; diff --git a/wst/trunk/service_intf.pas b/wst/trunk/service_intf.pas index debabea5a..5953f1295 100644 --- a/wst/trunk/service_intf.pas +++ b/wst/trunk/service_intf.pas @@ -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); diff --git a/wst/trunk/tests/test_suite/test_soap_specific.pas b/wst/trunk/tests/test_suite/test_soap_specific.pas index 46355501d..95644a33a 100644 --- a/wst/trunk/tests/test_suite/test_soap_specific.pas +++ b/wst/trunk/tests/test_suite/test_soap_specific.pas @@ -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 = + '' + sLineBreak + + '' + sLineBreak + + ' ' + sLineBreak + + ' ' + sLineBreak + + ' Inoussa-wst' + sLineBreak + + ' sample password' + sLineBreak + + ' ' + sLineBreak + + ' ' + sLineBreak + + ' ' + sLineBreak + + ' ' + sLineBreak + + ' ' + sLineBreak + + ''; +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 = + '' + sLineBreak + + '' + sLineBreak + + ' ' + sLineBreak + + ' ' + sLineBreak + + ' Inoussa-wst' + sLineBreak + + ' sample password' + sLineBreak + + ' ' + sLineBreak + + ' ' + sLineBreak + + ' ' + sLineBreak + + ' ' + sLineBreak + + ' ' + sLineBreak + + ''; +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. diff --git a/wst/trunk/tests/test_suite/test_support.pas b/wst/trunk/tests/test_suite/test_support.pas index 1c8cbc72a..635748a7b 100644 --- a/wst/trunk/tests/test_suite/test_support.pas +++ b/wst/trunk/tests/test_suite/test_support.pas @@ -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) diff --git a/wst/trunk/wst_delphi.inc b/wst/trunk/wst_delphi.inc index 250673fef..83069a4bc 100644 --- a/wst/trunk/wst_delphi.inc +++ b/wst/trunk/wst_delphi.inc @@ -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}