View Issue Details

IDProjectCategoryView StatusLast Update
0031318FPCRTLpublic2017-02-22 22:15
ReporterMichal GawryckiAssigned ToMichael Van Canneyt 
PrioritynormalSeverityminorReproducibilityN/A
Status resolvedResolutionfixed 
Product Version3.1.1Product Build 
Target Version3.2.0Fixed in Version3.1.1 
Summary0031318: Streaming interface properties
DescriptionTReader / TWriter does not support interface type properties (tkInterface).
Patch attached, but I am not sure whether the procedure "TReadre.ReadProperty" should read properties with tkInterface type (I think not, so these changes are commented out).
Also, I'm not sure what about tkInterfaceRaw.
TagsNo tags attached.
Fixed in Revision35474
FPCOldBugId
FPCTarget
Attached Files
  • intfpropstream-rtl.patch (4,717 bytes)
    Index: rtl/objpas/classes/reader.inc
    ===================================================================
    --- rtl/objpas/classes/reader.inc	(revision 35369)
    +++ rtl/objpas/classes/reader.inc	(working copy)
    @@ -722,7 +722,10 @@
             FOnReferenceName(Self,Ref);
           C:=FindNestedComponent(R.FRoot,Ref);
           If Assigned(C) then
    -        SetObjectProp(R.FInstance,R.FPropInfo,C)
    +        if R.FPropInfo^.PropType^.Kind = tkInterface then
    +          SetInterfaceProp(R.FInstance,R.FPropInfo,C)
    +        else
    +          SetObjectProp(R.FInstance,R.FPropInfo,C)
           else
             begin
             P:=Pos('.',R.FRelative);
    @@ -1256,6 +1259,8 @@
     
             if PropInfo^.PropType^.Kind = tkClass then
               Obj := TObject(GetObjectProp(Instance, PropInfo))
    +        //else if PropInfo^.PropType^.Kind = tkInterface then
    +        //  Obj := TObject(GetInterfaceProp(Instance, PropInfo))
             else
               Obj := nil;
     
    @@ -1385,7 +1390,7 @@
           begin
             SetVariantProp(Instance,PropInfo,ReadVariant);
           end;
    -    tkClass:
    +    tkClass, tkInterface:
           case FDriver.NextValue of
             vaNil:
               begin
    Index: rtl/objpas/classes/writer.inc
    ===================================================================
    --- rtl/objpas/classes/writer.inc	(revision 35369)
    +++ rtl/objpas/classes/writer.inc	(working copy)
    @@ -874,6 +874,8 @@
       VarValue, DefVarValue : tvardata;
       BoolValue, DefBoolValue: boolean;
       Handled: Boolean;
    +  IntfValue: IInterface;
    +  CompRef: IInterfaceComponentReference;
     
     begin
       // do not stream properties without getter
    @@ -1181,6 +1183,79 @@
               Driver.EndProperty;
               end;
           end;
    +    tkInterface:
    +      begin
    +        IntfValue := GetInterfaceProp(Instance, PropInfo);
    +        if Assigned(IntfValue) and Supports(IntfValue, IInterfaceComponentReference, CompRef) then
    +          begin
    +          Component := CompRef.GetComponent;
    +          if HasAncestor then
    +          begin
    +            AncestorObj := TObject(GetObjectProp(Ancestor, PropInfo));
    +            if (AncestorObj is TComponent) then
    +            begin
    +              //writeln('TWriter.WriteProperty AncestorObj=',TComponent(AncestorObj).Name,' OwnerFit=',TComponent(AncestorObj).Owner = FRootAncestor,' ',TComponent(ObjValue).Name,' OwnerFit=',TComponent(ObjValue).Owner = Root);
    +              if (AncestorObj<> Component) and
    +               (TComponent(AncestorObj).Owner = FRootAncestor) and
    +               (Component.Owner = Root) and
    +               (UpperCase(TComponent(AncestorObj).Name) = UpperCase(Component.Name)) then
    +              begin
    +                // different components, but with the same name
    +                // treat it like an override
    +                AncestorObj := Component;
    +              end;
    +            end;
    +          end else
    +            AncestorObj := nil;
    +
    +          if not Assigned(Component) then
    +            begin
    +            if Component <> AncestorObj then
    +              begin
    +              Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
    +              Driver.WriteIdent('NIL');
    +              Driver.EndProperty;
    +              end
    +            end
    +          else if ((not (csSubComponent in Component.ComponentStyle))
    +                 or ((Component.Owner<>Instance) and (Component.Owner<>Nil))) then
    +            begin
    +            if (Component <> AncestorObj)
    +                and not (csTransient in Component.ComponentStyle) then
    +              begin
    +              Name:= '';
    +              C:= Component;
    +              While (C<>Nil) and (C.Name<>'') do
    +                begin
    +                If (Name<>'') Then
    +                  Name:='.'+Name;
    +                if C.Owner = LookupRoot then
    +                  begin
    +                  Name := C.Name+Name;
    +                  break;
    +                  end
    +                else if C = LookupRoot then
    +                  begin
    +                  Name := 'Owner' + Name;
    +                  break;
    +                  end;
    +                Name:=C.Name + Name;
    +                C:= C.Owner;
    +                end;
    +              if (C=nil) and (Component.Owner=nil) then
    +                if (Name<>'') then              //foreign root
    +                  Name:=Name+'.Owner';
    +              if Length(Name) > 0 then
    +                begin
    +                Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
    +                WriteIdent(Name);
    +                Driver.EndProperty;
    +                end;  // length Name>0
    +              end; //(Component <> AncestorObj)
    +            end;
    +          end; //Assigned(IntfValue) and Supports(IntfValue,..
    +               //else write NIL ?
    +      end;
       end;
     end;
     
    
    intfpropstream-rtl.patch (4,717 bytes)
  • intfpropstream-tests.patch (2,225 bytes)
    Index: tests/test/units/fpcunit/tccompstreaming.pp
    ===================================================================
    --- tests/test/units/fpcunit/tccompstreaming.pp	(revision 35369)
    +++ tests/test/units/fpcunit/tccompstreaming.pp	(working copy)
    @@ -56,6 +56,7 @@
         Procedure TestTStreamedOwnedComponents;
         Procedure TestTMethodComponent;
         Procedure TestTMethodComponent2;
    +    Procedure TestTOwnedInterface;
       end;
       { TMyItem }
     
    @@ -1229,6 +1230,28 @@
         end;
     end;
     
    +Procedure TTestComponentStream.TestTOwnedInterface;
    +
    +Var
    +  C : TComponent;
    +
    +begin
    +  C:=TOwnedInterface.Create(Nil);
    +  Try
    +    SaveToStream(C);
    +    ExpectSignature;
    +    ExpectFlags([],0);
    +    ExpectBareString('TOwnedInterface');
    +    ExpectBareString('TestTOwnedInterface');
    +    ExpectBareString('IntfProp');
    +    ExpectIdent('InterfacedComponent');
    +    ExpectEndOfList;
    +    ExpectEndOfList;
    +  Finally
    +    C.Free;
    +    end;
    +end;
    +
     { TMyColl }
     
     function TMyColl.GetIt(index : Integer): TMyItem;
    Index: tests/test/units/fpcunit/testcomps.pp
    ===================================================================
    --- tests/test/units/fpcunit/testcomps.pp	(revision 35369)
    +++ tests/test/units/fpcunit/testcomps.pp	(working copy)
    @@ -491,6 +491,26 @@
         Procedure MyMethod2;
       end;
     
    +  // Interface as published property
    +
    +  ITestInterface = interface
    +  end;
    +
    +  TTestIntfComponent = class(TComponent, ITestInterface)
    +  end;
    +
    +  { TOwnedInterface }
    +
    +  TOwnedInterface = class(TComponent)
    +  Private
    +    F : ITestInterface;
    +  Public
    +    Constructor Create(AOwner : TComponent); override;
    +    Destructor Destroy; override;
    +  Published
    +    Property IntfProp: ITestInterface Read F Write F;
    +  end;
    +
     Implementation
     
     procedure TChildrenComponent.GetChildren(Proc: TGetChildProc; Root: TComponent);
    @@ -950,5 +970,22 @@
      // Do nothng
     end;
     
    +{ TOwnedInterface }
     
    +constructor TOwnedInterface.Create(AOwner: TComponent);
    +var
    +  C : TTestIntfComponent;
    +begin
    +  inherited Create(AOwner);
    +  C := TTestIntfComponent.Create(Self);
    +  C.Name:='InterfacedComponent';
    +  IntfProp:=C;
    +end;
    +
    +Destructor TOwnedInterface.Destroy;
    +begin
    +  F := nil; // prevent memory leak
    +  inherited;
    +end;
    +
     end.
    

Activities

Michal Gawrycki

2017-02-01 15:54

reporter  

intfpropstream-rtl.patch (4,717 bytes)
Index: rtl/objpas/classes/reader.inc
===================================================================
--- rtl/objpas/classes/reader.inc	(revision 35369)
+++ rtl/objpas/classes/reader.inc	(working copy)
@@ -722,7 +722,10 @@
         FOnReferenceName(Self,Ref);
       C:=FindNestedComponent(R.FRoot,Ref);
       If Assigned(C) then
-        SetObjectProp(R.FInstance,R.FPropInfo,C)
+        if R.FPropInfo^.PropType^.Kind = tkInterface then
+          SetInterfaceProp(R.FInstance,R.FPropInfo,C)
+        else
+          SetObjectProp(R.FInstance,R.FPropInfo,C)
       else
         begin
         P:=Pos('.',R.FRelative);
@@ -1256,6 +1259,8 @@
 
         if PropInfo^.PropType^.Kind = tkClass then
           Obj := TObject(GetObjectProp(Instance, PropInfo))
+        //else if PropInfo^.PropType^.Kind = tkInterface then
+        //  Obj := TObject(GetInterfaceProp(Instance, PropInfo))
         else
           Obj := nil;
 
@@ -1385,7 +1390,7 @@
       begin
         SetVariantProp(Instance,PropInfo,ReadVariant);
       end;
-    tkClass:
+    tkClass, tkInterface:
       case FDriver.NextValue of
         vaNil:
           begin
Index: rtl/objpas/classes/writer.inc
===================================================================
--- rtl/objpas/classes/writer.inc	(revision 35369)
+++ rtl/objpas/classes/writer.inc	(working copy)
@@ -874,6 +874,8 @@
   VarValue, DefVarValue : tvardata;
   BoolValue, DefBoolValue: boolean;
   Handled: Boolean;
+  IntfValue: IInterface;
+  CompRef: IInterfaceComponentReference;
 
 begin
   // do not stream properties without getter
@@ -1181,6 +1183,79 @@
           Driver.EndProperty;
           end;
       end;
+    tkInterface:
+      begin
+        IntfValue := GetInterfaceProp(Instance, PropInfo);
+        if Assigned(IntfValue) and Supports(IntfValue, IInterfaceComponentReference, CompRef) then
+          begin
+          Component := CompRef.GetComponent;
+          if HasAncestor then
+          begin
+            AncestorObj := TObject(GetObjectProp(Ancestor, PropInfo));
+            if (AncestorObj is TComponent) then
+            begin
+              //writeln('TWriter.WriteProperty AncestorObj=',TComponent(AncestorObj).Name,' OwnerFit=',TComponent(AncestorObj).Owner = FRootAncestor,' ',TComponent(ObjValue).Name,' OwnerFit=',TComponent(ObjValue).Owner = Root);
+              if (AncestorObj<> Component) and
+               (TComponent(AncestorObj).Owner = FRootAncestor) and
+               (Component.Owner = Root) and
+               (UpperCase(TComponent(AncestorObj).Name) = UpperCase(Component.Name)) then
+              begin
+                // different components, but with the same name
+                // treat it like an override
+                AncestorObj := Component;
+              end;
+            end;
+          end else
+            AncestorObj := nil;
+
+          if not Assigned(Component) then
+            begin
+            if Component <> AncestorObj then
+              begin
+              Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
+              Driver.WriteIdent('NIL');
+              Driver.EndProperty;
+              end
+            end
+          else if ((not (csSubComponent in Component.ComponentStyle))
+                 or ((Component.Owner<>Instance) and (Component.Owner<>Nil))) then
+            begin
+            if (Component <> AncestorObj)
+                and not (csTransient in Component.ComponentStyle) then
+              begin
+              Name:= '';
+              C:= Component;
+              While (C<>Nil) and (C.Name<>'') do
+                begin
+                If (Name<>'') Then
+                  Name:='.'+Name;
+                if C.Owner = LookupRoot then
+                  begin
+                  Name := C.Name+Name;
+                  break;
+                  end
+                else if C = LookupRoot then
+                  begin
+                  Name := 'Owner' + Name;
+                  break;
+                  end;
+                Name:=C.Name + Name;
+                C:= C.Owner;
+                end;
+              if (C=nil) and (Component.Owner=nil) then
+                if (Name<>'') then              //foreign root
+                  Name:=Name+'.Owner';
+              if Length(Name) > 0 then
+                begin
+                Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
+                WriteIdent(Name);
+                Driver.EndProperty;
+                end;  // length Name>0
+              end; //(Component <> AncestorObj)
+            end;
+          end; //Assigned(IntfValue) and Supports(IntfValue,..
+               //else write NIL ?
+      end;
   end;
 end;
 
intfpropstream-rtl.patch (4,717 bytes)

Michal Gawrycki

2017-02-01 15:55

reporter  

intfpropstream-tests.patch (2,225 bytes)
Index: tests/test/units/fpcunit/tccompstreaming.pp
===================================================================
--- tests/test/units/fpcunit/tccompstreaming.pp	(revision 35369)
+++ tests/test/units/fpcunit/tccompstreaming.pp	(working copy)
@@ -56,6 +56,7 @@
     Procedure TestTStreamedOwnedComponents;
     Procedure TestTMethodComponent;
     Procedure TestTMethodComponent2;
+    Procedure TestTOwnedInterface;
   end;
   { TMyItem }
 
@@ -1229,6 +1230,28 @@
     end;
 end;
 
+Procedure TTestComponentStream.TestTOwnedInterface;
+
+Var
+  C : TComponent;
+
+begin
+  C:=TOwnedInterface.Create(Nil);
+  Try
+    SaveToStream(C);
+    ExpectSignature;
+    ExpectFlags([],0);
+    ExpectBareString('TOwnedInterface');
+    ExpectBareString('TestTOwnedInterface');
+    ExpectBareString('IntfProp');
+    ExpectIdent('InterfacedComponent');
+    ExpectEndOfList;
+    ExpectEndOfList;
+  Finally
+    C.Free;
+    end;
+end;
+
 { TMyColl }
 
 function TMyColl.GetIt(index : Integer): TMyItem;
Index: tests/test/units/fpcunit/testcomps.pp
===================================================================
--- tests/test/units/fpcunit/testcomps.pp	(revision 35369)
+++ tests/test/units/fpcunit/testcomps.pp	(working copy)
@@ -491,6 +491,26 @@
     Procedure MyMethod2;
   end;
 
+  // Interface as published property
+
+  ITestInterface = interface
+  end;
+
+  TTestIntfComponent = class(TComponent, ITestInterface)
+  end;
+
+  { TOwnedInterface }
+
+  TOwnedInterface = class(TComponent)
+  Private
+    F : ITestInterface;
+  Public
+    Constructor Create(AOwner : TComponent); override;
+    Destructor Destroy; override;
+  Published
+    Property IntfProp: ITestInterface Read F Write F;
+  end;
+
 Implementation
 
 procedure TChildrenComponent.GetChildren(Proc: TGetChildProc; Root: TComponent);
@@ -950,5 +970,22 @@
  // Do nothng
 end;
 
+{ TOwnedInterface }
 
+constructor TOwnedInterface.Create(AOwner: TComponent);
+var
+  C : TTestIntfComponent;
+begin
+  inherited Create(AOwner);
+  C := TTestIntfComponent.Create(Self);
+  C.Name:='InterfacedComponent';
+  IntfProp:=C;
+end;
+
+Destructor TOwnedInterface.Destroy;
+begin
+  F := nil; // prevent memory leak
+  inherited;
+end;
+
 end.

Michael Van Canneyt

2017-02-22 22:15

administrator   ~0098383

Applied the patch, thank you very much !

Issue History

Date Modified Username Field Change
2017-02-01 15:54 Michal Gawrycki New Issue
2017-02-01 15:54 Michal Gawrycki File Added: intfpropstream-rtl.patch
2017-02-01 15:55 Michal Gawrycki File Added: intfpropstream-tests.patch
2017-02-01 17:41 Michael Van Canneyt Assigned To => Michael Van Canneyt
2017-02-01 17:41 Michael Van Canneyt Status new => assigned
2017-02-22 22:15 Michael Van Canneyt Fixed in Revision => 35474
2017-02-22 22:15 Michael Van Canneyt Note Added: 0098383
2017-02-22 22:15 Michael Van Canneyt Status assigned => resolved
2017-02-22 22:15 Michael Van Canneyt Fixed in Version => 3.1.1
2017-02-22 22:15 Michael Van Canneyt Resolution open => fixed
2017-02-22 22:15 Michael Van Canneyt Target Version => 3.2.0