* Read/Write static properties. Patch from Lipinast Lekrisov

packages/rtl-objpas/src/inc/rtti.pp

@@ -560,6 +560,8 @@ type
     function GetIndex: Integer; virtual;
     function GetIsClassProperty: boolean; virtual;
   protected
+    procedure SetStaticPropValue(const AValue: TValue); virtual;
+    function GetStaticPropValue: TValue; virtual;
     function GetName: string; override;
     function GetHandle: Pointer; override;
   public
@@ -968,12 +970,12 @@ generic function OpenArrayToDynArrayValue<T>(constref aArray: array of T): TValu
 
 { these resource strings are needed by units implementing function call managers }
 resourcestring
-  SErrInvokeNotImplemented = 'Invoke functionality is not implemented';
+  SErrInvokeNotImplemented = 'Invoke functionality is not implemented on this platform. Use external managers, e.g. ffi.manager.';
   SErrInvokeResultTypeNoValue = 'Function has a result type, but no result pointer provided';
   SErrInvokeFailed = 'Invoke call failed';
   SErrMethodImplCreateFailed  = 'Failed to create method implementation';
   SErrCallbackNotImplemented = 'Callback functionality is not implemented';
-  SErrCallConvNotSupported = 'Calling convention not supported: %s';
+  SErrCallConvNotSupported = 'Calling convention not supported: %s.  Enable external managers, e.g. ffi.manager.';
   SErrTypeKindNotSupported = 'Type kind is not supported: %s';
   SErrCallbackHandlerNil = 'Callback handler is Nil';
   SErrMissingSelfParam = 'Missing self parameter';
@@ -1390,6 +1392,8 @@ resourcestring
   SErrVirtIntfMethodNil = 'Method %1:d of ''%0:s'' is Nil';
   SErrVirtIntfCreateVmt = 'Failed to create VMT for ''%s''';
 //  SErrVirtIntfIInterface = 'Failed to prepare IInterface method callbacks';  
+  SErrCannotWriteToClassProperty = 'Cannot write to class property "%s"';
+  SErrCannotReadClassProperty = 'Cannot read class property "%s"';
   SErrCannotWriteToIndexedProperty = 'Cannot write to indexed property "%s"';
   SErrCannotReadIndexedProperty = 'Cannot read indexed property "%s"';
 
@@ -2386,7 +2390,7 @@ function TValue.GetIsEmpty: boolean;
 begin
   result := (FData.FTypeInfo=nil) or
             ((Kind in [tkSString, tkObject, tkRecord, tkArray]) and not Assigned(FData.FValueData)) or
-            ((Kind in [tkClass, tkClassRef, tkInterfaceRaw]) and not Assigned(FData.FAsPointer));
+            ((Kind in [tkPointer, tkClass, tkClassRef, tkInterfaceRaw]) and not Assigned(FData.FAsPointer));
 end;
 
 
@@ -6843,6 +6847,34 @@ begin
   result := FAttributes;
 end;
 
+function TRttiProperty.GetStaticPropValue: TValue;
+
+var
+  getter: CodePointer;
+  Args: array of TValue;
+
+begin
+  case FPropInfo^.PropProcs and 3 of
+    ptField:
+      TValue.Make(PtrUInt(FPropInfo^.GetProc), FPropInfo^.PropType, Result);
+    ptStatic,
+    ptVirtual:
+      begin
+        if (FPropInfo^.PropProcs and 3)=ptStatic then
+          getter:=FPropInfo^.GetProc
+        else
+          getter:=PCodePointer(Pointer(Parent.AsInstance.MetaClassType)+PtrUInt(FPropInfo^.GetProc))^;
+        if ((FPropInfo^.PropProcs shr 6) and 1)=0 then
+          Args := []
+        else
+          Args := [FPropInfo^.Index];
+        Result := {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Rtti.Invoke(getter, Args, ccReg, FPropInfo^.PropType, FPropInfo^.IsStatic, False);
+      end;
+  else
+    raise EPropertyError.CreateFmt(SErrCannotReadClassProperty, [FPropInfo^.Name]);
+  end;
+end;
+
 function TRttiProperty.GetValue(Instance: pointer): TValue;
 
   procedure ValueFromBool(value: Int64);
@@ -6951,6 +6983,11 @@ var
   M: TMethod;
   Int: IUnknown;
 begin
+  if FPropInfo^.IsStatic then
+    begin
+    Result:= GetStaticPropValue();
+    exit;
+    end;
   case FPropinfo^.PropType^.Kind of
     tkSString:
       begin
@@ -7058,8 +7095,42 @@ begin
   end
 end;
 
+procedure TRttiProperty.SetStaticPropValue(const AValue: TValue);
+
+var
+  setter: CodePointer;
+  Args: array of TValue;
+
+begin
+  case (FPropInfo^.PropProcs shr 2) and 3 of
+    ptField:
+      AValue.Cast(FPropInfo^.PropType).ExtractRawData(FPropInfo^.SetProc);
+    ptStatic,
+    ptVirtual:
+      begin
+        if ((FPropInfo^.PropProcs shr 2) and 3)=ptStatic then
+          setter:=FPropInfo^.SetProc
+        else
+          setter:=PCodePointer(Pointer(Parent.AsInstance.MetaClassType)+PtrUInt(FPropInfo^.SetProc))^;
+        if ((FPropInfo^.PropProcs shr 6) and 1)=0 then
+          Args := [AValue.Cast(FPropInfo^.PropType)]
+        else
+          Args := [FPropInfo^.Index, AValue.Cast(FPropInfo^.PropType)];
+        {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}Rtti.Invoke(setter, Args, ccReg, nil, FPropInfo^.IsStatic, False);
+      end;
+  else
+    raise EPropertyError.CreateFmt(SErrCannotWriteToClassProperty, [FPropInfo^.Name]);
+  end;
+end;
+
+
 procedure TRttiProperty.SetValue(Instance: pointer; const AValue: TValue);
 begin
+  if FPropInfo^.IsStatic then
+    begin
+    SetStaticPropValue(aValue);
+    exit;
+    end;
   case FPropinfo^.PropType^.Kind of
     tkSString,
     tkAString:
@@ -7988,10 +8059,10 @@ end;
 
 function TRttiRecordMethod.GetParameters(aWithHidden : Boolean): TRttiParameterArray;
 begin
-  if  (Length(FParams[aWithHidden]) > 0) then
-    Exit(FParams[aWithHidden]);
   if FHandle^.ParamCount = 0 then
     Exit(Nil);
+  if (Length(FParams[aWithHidden]) > 0) then
+    Exit(FParams[aWithHidden]);
   ResolveParams;
   Result := FParams[aWithHidden];
 end;

packages/rtl-objpas/tests/testrunner.rtlobjpas.lpi

@@ -87,6 +87,10 @@
         <Filename Value="utmathvectorbase.pas"/>
         <IsPartOfProject Value="True"/>
       </Unit>
+      <Unit>
+        <Filename Value="tests.rtti.attrtypes2.pp"/>
+        <IsPartOfProject Value="True"/>
+      </Unit>
     </Units>
   </ProjectOptions>
   <CompilerOptions>

packages/rtl-objpas/tests/testrunner.rtlobjpas.pp

@@ -55,7 +55,7 @@ uses
   utcvector,
   utcquaternion
 {$IFDEF HAS_MONITOR}
-  ,utcfpmonitor
+  ,utcfpmonitor, tests.rtti.attrtypes2
 {$ENDIF}
   ;
 

packages/rtl-objpas/tests/tests.rtti.attrtypes2.pp

@@ -0,0 +1,146 @@
+unit tests.rtti.attrtypes2;
+
+{$mode objfpc}{$H+}
+{$modeswitch advancedrecords}
+
+interface
+
+uses
+  Classes,
+  SysUtils,
+  TypInfo,
+  Rtti
+  {$ifndef Windows},
+  ffi.manager
+  {$endif};
+
+{$RTTI EXPLICIT
+  FIELDS([vcPublic])
+  PROPERTIES([vcPublic,vcPublished])
+  METHODS([vcPublic,vcPublished])}
+
+var
+  ErrorCount: Integer;
+
+type
+  TTestAttr2Record = record
+    fa:integer;
+    fa2:integer;
+    fa3:integer;
+  public
+    function Offset(arg1, arg2: Integer): Integer;
+    property TestIProp[i1, i2: Integer]: Integer read Offset;
+    constructor Create(a1, a2: Integer); overload;
+    constructor Create(rec: TTestAttr2Record); overload;
+    class function StaticFunc(d: Double; p: TPoint; r: TRect): string; static;
+  end;
+
+  TTestAttr2Class = class
+  private
+    class var
+      static_var: Integer;
+    class function GetStaticProp: Integer; static;
+    class procedure SetStaticProp(value: Integer); static;
+
+    function GetIndProp(arg1, arg2: Integer): TObject;
+    procedure SetIndProp(arg1, arg2: Integer; value: TObject);
+  public
+    fa, fa2:integer;
+    property TestIProp[i: Integer; i2: Integer]: TObject read GetIndProp write SetIndProp;
+    class property StaticProp: Integer read GetStaticProp write SetStaticProp;
+    procedure MethodForNil(arg1, arg2: TObject);
+    class function StaticMethod(str: string): Integer; static;
+    constructor Create(a1, a2: Integer);
+    class procedure ClassProc(var int: Integer; var str: string);
+  end;
+
+  TInherited2Class = class(TTestAttr2Class)
+  end;
+
+
+implementation
+
+uses fpcunit;
+
+procedure Check(ACondition: boolean; const AMessage: string);
+begin
+  TAssert.AssertTrue(AMessage,ACondition);
+end;
+
+
+function TTestAttr2Record.Offset(arg1, arg2: Integer): Integer;
+begin
+  fa := fa + arg1;
+  fa2 := fa2 + arg2;
+  Result := fa + fa2;
+end;
+
+constructor TTestAttr2Record.Create(a1, a2: Integer);
+begin
+  Check((fa = 60) and (fa2 = 80) and (fa3 = 90), 'Original TTestAttr2Record was delivered incorrectly');
+  fa := a1;
+  fa2 := a2;
+end;
+
+constructor TTestAttr2Record.Create(rec: TTestAttr2Record);
+begin
+  fa := rec.fa;
+  fa2 := rec.fa2;
+end;
+
+class function TTestAttr2Record.StaticFunc(d: Double; p: TPoint; r: TRect): string;
+begin
+  Result := 'experiment_'+d.ToString+'_'+p.X.ToString+'_'+p.Y.ToString+'_'+r.Left.ToString+'_'+r.Top.ToString+'_'+r.Right.ToString+'_'+r.Bottom.ToString;
+end;
+
+class function TTestAttr2Class.GetStaticProp: Integer;
+begin
+  Result := static_var;
+end;
+
+class procedure TTestAttr2Class.SetStaticProp(value: Integer);
+begin
+  static_var := Value;
+end;
+
+function TTestAttr2Class.GetIndProp(arg1, arg2: Integer): TObject;
+begin
+  fa := arg1;
+  fa2 := arg2;
+  Result := Self;
+end;
+
+procedure TTestAttr2Class.SetIndProp(arg1, arg2: Integer; value: TObject);
+begin
+  fa := arg1;
+  fa2 := arg2;
+  Check((arg1 = 653) and (arg2 = 796) and ((value as TTestAttr2Class).fa2 = 796),
+    'The setter of an indexed property is incorrectly called');
+end;
+
+procedure TTestAttr2Class.MethodForNil(arg1, arg2: TObject);
+begin
+  Check((arg1 = nil) and (arg2 = nil), 'MethodForNil did not get only nil');
+end;
+
+class function TTestAttr2Class.StaticMethod(str: string): Integer;
+begin
+  Check(str = 'simple string', 'The static method argument is incorrect');
+  Result := 7775;
+end;
+
+class procedure TTestAttr2Class.ClassProc(var int: Integer; var str: string);
+begin
+  Check(Self.ClassName = 'TInherited2Class', 'Incorrect class transfer to Self');
+  Inc(int, 12);
+  str := str + '_addon';
+end;
+
+constructor TTestAttr2Class.Create(a1, a2: Integer);
+begin
+  fa:=a1;
+  fa2:=a2;
+end;
+
+end.
+

packages/rtl-objpas/tests/tests.rtti.pas

@@ -118,6 +118,8 @@ type
     Procedure TestProtectedPropertyAttributes;
     Procedure TestPublicPropertyAttributes;
     Procedure TestPublishedPropertyAttributes;
+    procedure TestGetStaticProperty;
+    procedure TestSetStaticProperty;
   end;
 
   { TTestRecordExtendedRTTI }
@@ -136,7 +138,11 @@ type
 implementation
 
 uses
-  Tests.Rtti.Util, {tests.rtti.exttypes, } tests.rtti.attrtypes, tests.rtti.types;
+  Tests.Rtti.Util,
+  {tests.rtti.exttypes, }
+  tests.rtti.attrtypes2,
+  tests.rtti.attrtypes,
+  tests.rtti.types;
 
 
 
@@ -2072,6 +2078,31 @@ begin
   AssertEquals('Attribute value ',5,M3.Int);
 end;
 
+procedure TTestClassExtendedRTTI.TestGetStaticProperty;
+var
+  Obj : TRttiObject;
+  RttiData : TRttiInstanceType absolute obj;
+  Prop : TRttiProperty;
+begin
+  Obj:=FCtx.GetType(TypeInfo(TTestAttr2Class));
+  TTestAttr2Class.StaticProp:=4539;
+  Prop:=rttiData.GetProperty('StaticProp');
+  AssertEquals('Class property is set or got incorrectly via methods', 4539, Prop.GetValue(nil).AsInteger);
+end;
+
+procedure TTestClassExtendedRTTI.TestSetStaticProperty;
+var
+  Obj : TRttiObject;
+  RttiData : TRttiInstanceType absolute obj;
+  Prop : TRttiProperty;
+begin
+  Obj:=FCtx.GetType(TypeInfo(TTestAttr2Class));
+  Prop:=rttiData.GetProperty('StaticProp');
+  // Write
+  Prop.SetValue(nil, 4539);
+  AssertEquals('Property correctly set',4539,TTestAttr2Class.StaticProp);
+end;
+
 
 { TTestRecordExtendedRTTI }