+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

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
+  if not Assigned(FPascalSynonyms) then begin
-    FSynonymTable := TStringList.Create();
+    FPascalSynonyms := TStringList.Create();
-    FSynonymTable.Add(FDataType^.Name);
+    FPascalSynonyms.Add(FDataType^.Name);
   end;
-  if ( FSynonymTable.IndexOf(ASynonym) = -1 ) then
+  if ( FPascalSynonyms.IndexOf(ASynonym) = -1 ) then
-    FSynonymTable.Add(AnsiLowerCase(ASynonym));
+    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
+  if ( not Result ) and Assigned(FPascalSynonyms) then
-    Result := ( FSynonymTable.IndexOf(APascalTypeName) >= 0 ) ;
+    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
+  if ( c > 0 ) then begin
-    Result := Item[i];
+    for i := 0 to Pred(c) do begin
-    if AnsiSameText(ANameSpace,Result.NameSpace) and
+      Result := Item[i];
-       AnsiSameText(ATypeName,Result.DeclaredName)
+      if AnsiSameText(ANameSpace,Result.NameSpace) and
-    then
+         AnsiSameText(ATypeName,Result.DeclaredName)
-      Exit;
+      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);

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);
+              typData := GetTypeData(typItm.DataType);
-              if Assigned(tmpObj) then begin
+              if typData^.ClassType.InheritsFrom(THeaderBlock) then begin
-                tmpObj.Direction := hdIn;
+                Get(typItm.DataType,locName,tmpHeader);
-                ACallContext.AddHeader(tmpObj,True);
+                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

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;

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);

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 =
+         '<?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.
 

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)

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}