* Implemented TValue.IsEmpty, TValue.Make

 * Implemented TRttiProperty.SetValue, .IsReadable, .IsWriteble and .Visibility
 * TRttiProperty.GetValue now uses TValue.Make, where possible
 * More Delphi-compatibility changes

git-svn-id: branches/joost/classattributes@25172 -

packages/fcl-base/src/rtti.pp

@@ -61,7 +61,7 @@ type
       0:  (FAsUByte: Byte);
       1:  (FAsUWord: Word);
       2:  (FAsULong: LongWord);
-      3:  (FAsObject: TObject);
+      3:  (FAsObject: Pointer);
       4:  (FAsClass: TClass);
       5:  (FAsSByte: Shortint);
       9:  (FAsDouble: Double);
@@ -78,7 +78,10 @@ type
     function GetTypeDataProp: PTypeData;
     function GetTypeInfo: PTypeInfo;
     function GetTypeKind: TTypeKind;
+    function GetIsEmpty: boolean;
   public
+    class function Empty: TValue;
+    class procedure Make(ABuffer: pointer; ATypeInfo: PTypeInfo; out result: TValue);
     function IsArray: boolean;
     function AsString: string;
     function AsExtended: Extended;
@@ -97,6 +100,7 @@ type
     property Kind: TTypeKind read GetTypeKind;
     property TypeData: PTypeData read GetTypeDataProp;
     property TypeInfo: PTypeInfo read GetTypeInfo;
+    property IsEmpty: boolean read GetIsEmpty;
   end;
 
   { TRttiContext }
@@ -221,7 +225,6 @@ type
     constructor create(AParent: TRttiType);
     property Visibility: TMemberVisibility read GetVisibility;
     property Parent: TRttiType read FParent;
-
   end;
 
   { TRttiProperty }
@@ -232,14 +235,20 @@ type
     FAttributesResolved: boolean;
     FAttributes: specialize TArray<TCustomAttribute>;
     function GetPropertyType: TRttiType;
+    function GetIsWritable: boolean;
+    function GetIsReadable: boolean;
+    function GetVisibility: TMemberVisibility;
   protected
     function GetName: string; override;
     function GetAttributes: specialize TArray<TCustomAttribute>; override;
   public
     constructor create(AParent: TRttiType; APropInfo: PPropInfo);
     function GetValue(Instance: pointer): TValue;
+    procedure SetValue(Instance: pointer; const AValue: TValue);
     property PropertyType: TRttiType read GetPropertyType;
-
+    property IsReadable: boolean read GetIsReadable;
+    property IsWritable: boolean read GetIsWritable;
+    property Visibility: TMemberVisibility read GetVisibility;
   end;
 
 function IsManaged(TypeInfo: PTypeInfo): boolean;
@@ -291,7 +300,8 @@ type
 
 resourcestring
   SErrUnableToGetValueForType = 'Unable to get value for type %s';
-  SErrInvalidTypecast         = 'Invalid typecast';
+  SErrUnableToSetValueForType = 'Unable to set value for type %s';
+  SErrInvalidTypecast         = 'Invalid class typecast';
 
 var
   PoolRefCount : integer;
@@ -453,6 +463,33 @@ end;
 
 { TValue }
 
+class function TValue.Empty: TValue;
+begin
+  result.FData.FTypeInfo := nil;
+end;
+
+class procedure TValue.Make(ABuffer: pointer; ATypeInfo: PTypeInfo; out result: TValue);
+var
+  S: ansistring;
+begin
+  result.FData.FTypeInfo:=ATypeInfo;
+  case ATypeInfo^.Kind of
+    tkAString  : result.FData.FValueData := TValueDataIntImpl.Create(@PAnsiString(ABuffer)^[1],length(PAnsiString(ABuffer)^));
+    tkClass    : result.FData.FAsObject := PPointer(ABuffer)^;
+    tkInteger  : result.FData.FAsSInt64 := PInt64(ABuffer)^;
+    tkBool     : result.FData.FAsSInt64 := Int64(PBoolean(ABuffer)^);
+    tkFloat    : begin
+                   case GetTypeData(ATypeInfo)^.FloatType of
+                     ftCurr   : result.FData.FAsCurr := PCurrency(ABuffer)^;
+                     ftDouble : result.FData.FAsDouble := PDouble(ABuffer)^;
+                   end;
+                 end;
+  else
+    raise Exception.CreateFmt(SErrUnableToGetValueForType,[ATypeInfo^.Name]);
+  end;
+end;
+
+
 function TValue.GetTypeDataProp: PTypeData;
 begin
   result := GetTypeData(FData.FTypeInfo);
@@ -468,6 +505,11 @@ begin
   result := FData.FTypeInfo^.Kind;
 end;
 
+function TValue.GetIsEmpty: boolean;
+begin
+  result := (FData.FTypeInfo=nil);
+end;
+
 function TValue.IsArray: boolean;
 begin
   result := kind in [tkArray, tkDynArray];
@@ -507,19 +549,19 @@ end;
 function TValue.AsObject: TObject;
 begin
   if IsObject then
-    result := FData.FAsObject
+    result := TObject(FData.FAsObject)
   else
     raise EInvalidCast.Create(SErrInvalidTypecast);
 end;
 
 function TValue.IsObject: boolean;
 begin
-  result := fdata.FTypeInfo^.Kind = tkObject;
+  result := fdata.FTypeInfo^.Kind = tkClass;
 end;
 
 function TValue.IsClass: boolean;
 begin
-  result := fdata.FTypeInfo^.Kind = tkClass;
+  result := false;
 end;
 
 function TValue.AsClass: TClass;
@@ -659,6 +701,22 @@ begin
   GRttiPool.GetType(FPropInfo^.PropType);
 end;
 
+function TRttiProperty.GetIsReadable: boolean;
+begin
+  result := assigned(FPropInfo^.GetProc);
+end;
+
+function TRttiProperty.GetIsWritable: boolean;
+begin
+  result := assigned(FPropInfo^.SetProc);
+end;
+
+function TRttiProperty.GetVisibility: TMemberVisibility;
+begin
+  // At this moment only pulished rtti-property-info is supported by fpc
+  result := mvPublished;
+end;
+
 function TRttiProperty.GetName: string;
 begin
   Result:=FPropInfo^.Name;
@@ -687,29 +745,61 @@ begin
 end;
 
 function TRttiProperty.GetValue(Instance: pointer): TValue;
+type
+  TGetProcIndex=function(index:longint):pointer of object;
+  TGetProc=function:pointer of object;
 var
-  S: ansistring;
+  ABuffer: pointer;
+  AMethod: TMethod;
+  AGetMethodIndex: TGetProcIndex;
+  AGetMethod: TGetProc;
+  s: string;
+  i: int64;
 begin
-  result.FData.FTypeInfo:=FPropInfo^.PropType;
+  if (FPropInfo^.PropProcs) and 3 = ptfield then
+    begin
+    ABuffer := Pointer(Instance)+PtrUInt(FPropInfo^.GetProc);
+    TValue.Make(ABuffer, FPropInfo^.PropType, result);
+    end
+  else
+    begin
+    case FPropinfo^.PropType^.Kind of
+      tkAString:
+        begin
+          s := GetStrProp(TObject(Instance), FPropInfo);
+          TValue.Make(@s, FPropInfo^.PropType, result);
+        end;
+      tkInteger,
+      tkInt64,
+      tkQWord,
+      tkChar,
+      tkBool,
+      tkWChar:
+        begin
+          i := GetOrdProp(TObject(Instance), FPropInfo);
+          TValue.Make(@i, FPropInfo^.PropType, result);
+        end;
+    else
+      result := TValue.Empty;
+    end
+    end;
+end;
 
-  case Result.FData.FTypeInfo^.Kind of
-    tkSString,
-    tkAString  : begin
-                   s := GetStrProp(TObject(Instance),FPropInfo);
-                   result.FData.FValueData := TValueDataIntImpl.Create(@s[1],length(s));
-                 end;
-    tkClass    : result.FData.FAsObject := GetObjectProp(TObject(Instance),FPropInfo);
+procedure TRttiProperty.SetValue(Instance: pointer; const AValue: TValue);
+begin
+  case FPropinfo^.PropType^.Kind of
+    tkAString:
+      SetStrProp(TObject(Instance), FPropInfo, AValue.AsString);
     tkInteger,
-    tkBool     : result.FData.FAsSInt64 := GetOrdProp(TObject(Instance),FPropInfo);
-    tkFloat    : begin
-                   case GetTypeData(FPropInfo^.PropType)^.FloatType of
-                     ftCurr   : result.FData.FAsCurr := GetFloatProp(TObject(Instance),FPropInfo);
-                     ftDouble : result.FData.FAsDouble := GetFloatProp(TObject(Instance),FPropInfo);
-                   end;
-                 end;
+    tkInt64,
+    tkQWord,
+    tkChar,
+    tkBool,
+    tkWChar:
+      SetOrdProp(TObject(Instance), FPropInfo, AValue.AsOrdinal);
   else
-    raise Exception.CreateFmt(SErrUnableToGetValueForType,[FPropInfo^.Name]);
-  end;
+    raise exception.create(SErrUnableToSetValueForType);
+  end
 end;
 
 function TRttiType.GetIsInstance: boolean;

packages/fcl-base/tests/tests_rtti.pas

@@ -34,7 +34,18 @@ type
     procedure TestPropGetValueString;
     procedure TestPropGetValueInteger;
     procedure TestPropGetValueBoolean;
+    procedure TestPropGetValueProcString;
+    procedure TestPropGetValueProcInteger;
+    procedure TestPropGetValueProcBoolean;
+
+    procedure TestPropSetValueString;
+    procedure TestPropSetValueInteger;
+    procedure TestPropSetValueBoolean;
+
     procedure TestGetValueStringCastError;
+    procedure TestMakeObject;
+    procedure TestGetIsReadable;
+    procedure TestIsWritable;
   end;
 
 implementation
@@ -65,18 +76,50 @@ type
     property PubPropSetRW: integer read FPubPropRW write FPubPropRW;
   end;
 
+  { TTestValueClass }
+
   TTestValueClass = class
   private
     FAInteger: integer;
     FAString: string;
     FABoolean: boolean;
+    function GetAInteger: integer;
+    function GetAString: string;
+    function GetABoolean: boolean;
+    procedure SetWriteOnly(AValue: integer);
   published
     property AInteger: Integer read FAInteger write FAInteger;
     property AString: string read FAString write FAString;
     property ABoolean: boolean read FABoolean write FABoolean;
+    property AGetInteger: Integer read GetAInteger;
+    property AGetString: string read GetAString;
+    property AGetBoolean: boolean read GetABoolean;
+    property AWriteOnly: integer write SetWriteOnly;
   end;
 
 
+{ TTestValueClass }
+
+function TTestValueClass.GetAInteger: integer;
+begin
+  result := FAInteger;
+end;
+
+function TTestValueClass.GetAString: string;
+begin
+  result := FAString;
+end;
+
+function TTestValueClass.GetABoolean: boolean;
+begin
+  result := FABoolean;
+end;
+
+procedure TTestValueClass.SetWriteOnly(AValue: integer);
+begin
+  // Do nothing
+end;
+
 { TIntAttribute }
 
 constructor TIntAttribute.create(AInt: integer);
@@ -135,6 +178,61 @@ begin
   end;
 end;
 
+procedure TTestCase1.TestMakeObject;
+var
+  AValue: TValue;
+  ATestClass: TTestValueClass;
+begin
+  ATestClass := TTestValueClass.Create;
+  ATestClass.AInteger := 54329;
+  TValue.Make(@ATestClass, TypeInfo(TTestValueClass),AValue);
+  CheckEquals(AValue.IsClass, False);
+  CheckEquals(AValue.IsObject, True);
+  Check(AValue.AsObject=ATestClass);
+  CheckEquals(TTestValueClass(AValue.AsObject).AInteger, 54329);
+  ATestClass.Free;
+end;
+
+procedure TTestCase1.TestGetIsReadable;
+var
+  c: TRttiContext;
+  ARttiType: TRttiType;
+  AProperty: TRttiProperty;
+begin
+  c := TRttiContext.Create;
+  try
+    ARttiType := c.GetType(TTestValueClass);
+    AProperty := ARttiType.GetProperty('aBoolean');
+    CheckEquals(AProperty.IsReadable, true);
+    AProperty := ARttiType.GetProperty('aGetBoolean');
+    CheckEquals(AProperty.IsReadable, true);
+    AProperty := ARttiType.GetProperty('aWriteOnly');
+    CheckEquals(AProperty.IsReadable, False);
+  finally
+    c.Free;
+  end;
+end;
+
+procedure TTestCase1.TestIsWritable;
+var
+  c: TRttiContext;
+  ARttiType: TRttiType;
+  AProperty: TRttiProperty;
+begin
+  c := TRttiContext.Create;
+  try
+    ARttiType := c.GetType(TTestValueClass);
+    AProperty := ARttiType.GetProperty('aBoolean');
+    CheckEquals(AProperty.IsWritable, true);
+    AProperty := ARttiType.GetProperty('aGetBoolean');
+    CheckEquals(AProperty.IsWritable, false);
+    AProperty := ARttiType.GetProperty('aWriteOnly');
+    CheckEquals(AProperty.IsWritable, True);
+  finally
+    c.Free;
+  end;
+end;
+
 procedure TTestCase1.TestPropGetValueBoolean;
 var
   ATestClass : TTestValueClass;
@@ -222,7 +320,7 @@ begin
       CheckEquals('Hello World',AValue.ToString);
       Check(TypeInfo(string)=AValue.TypeInfo);
       Check(AValue.TypeData=GetTypeData(AValue.TypeInfo));
-//      Check(AValue.IsEmpty=false);
+      Check(AValue.IsEmpty=false);
       Check(AValue.IsObject=false);
       Check(AValue.IsClass=false);
       CheckEquals(AValue.IsOrdinal, false);
@@ -239,6 +337,182 @@ begin
   end;
 end;
 
+procedure TTestCase1.TestPropGetValueProcBoolean;
+var
+  ATestClass : TTestValueClass;
+  c: TRttiContext;
+  ARttiType: TRttiType;
+  AProperty: TRttiProperty;
+  AValue: TValue;
+begin
+  c := TRttiContext.Create;
+  try
+    ATestClass := TTestValueClass.Create;
+    ATestClass.ABoolean := true;
+    try
+      ARttiType := c.GetType(ATestClass.ClassInfo);
+      Check(assigned(ARttiType));
+      AProperty := ARttiType.GetProperty('aGetBoolean');
+      AValue := AProperty.GetValue(ATestClass);
+      CheckEquals(true,AValue.AsBoolean);
+    finally
+      AtestClass.Free;
+    end;
+      CheckEquals(True,AValue.AsBoolean);
+  finally
+    c.Free;
+  end;
+end;
+
+procedure TTestCase1.TestPropSetValueString;
+var
+  ATestClass : TTestValueClass;
+  c: TRttiContext;
+  ARttiType: TRttiType;
+  AProperty: TRttiProperty;
+  AValue: TValue;
+  s: string;
+begin
+  c := TRttiContext.Create;
+  try
+    ATestClass := TTestValueClass.Create;
+    try
+      ARttiType := c.GetType(ATestClass.ClassInfo);
+      AProperty := ARttiType.GetProperty('astring');
+
+      s := 'ipse lorem or something like that';
+      TValue.Make(@s, TypeInfo(s), AValue);
+      AProperty.SetValue(ATestClass, AValue);
+      CheckEquals(ATestClass.AString, s);
+      s := 'Another string';
+      CheckEquals(ATestClass.AString, 'ipse lorem or something like that');
+    finally
+      AtestClass.Free;
+    end;
+  finally
+    c.Free;
+  end;
+end;
+
+procedure TTestCase1.TestPropSetValueInteger;
+var
+  ATestClass : TTestValueClass;
+  c: TRttiContext;
+  ARttiType: TRttiType;
+  AProperty: TRttiProperty;
+  AValue: TValue;
+  i: integer;
+begin
+  c := TRttiContext.Create;
+  try
+    ATestClass := TTestValueClass.Create;
+    try
+      ARttiType := c.GetType(ATestClass.ClassInfo);
+      AProperty := ARttiType.GetProperty('aInteger');
+
+      i := -43573;
+      TValue.Make(@i, TypeInfo(i), AValue);
+      AProperty.SetValue(ATestClass, AValue);
+      CheckEquals(ATestClass.AInteger, i);
+      i := 1;
+      CheckEquals(ATestClass.AInteger, -43573);
+    finally
+      AtestClass.Free;
+    end;
+  finally
+    c.Free;
+  end;
+end;
+
+procedure TTestCase1.TestPropSetValueBoolean;
+var
+  ATestClass : TTestValueClass;
+  c: TRttiContext;
+  ARttiType: TRttiType;
+  AProperty: TRttiProperty;
+  AValue: TValue;
+  b: boolean;
+begin
+  c := TRttiContext.Create;
+  try
+    ATestClass := TTestValueClass.Create;
+    try
+      ARttiType := c.GetType(ATestClass.ClassInfo);
+      AProperty := ARttiType.GetProperty('aboolean');
+
+      b := true;
+      TValue.Make(@b, TypeInfo(b), AValue);
+      AProperty.SetValue(ATestClass, AValue);
+      CheckEquals(ATestClass.ABoolean, b);
+      b := false;
+      CheckEquals(ATestClass.ABoolean, true);
+      TValue.Make(@b, TypeInfo(b), AValue);
+      AProperty.SetValue(ATestClass, AValue);
+      CheckEquals(ATestClass.ABoolean, false);
+    finally
+      AtestClass.Free;
+    end;
+  finally
+    c.Free;
+  end;
+end;
+
+procedure TTestCase1.TestPropGetValueProcInteger;
+var
+  ATestClass : TTestValueClass;
+  c: TRttiContext;
+  ARttiType: TRttiType;
+  AProperty: TRttiProperty;
+  AValue: TValue;
+begin
+  c := TRttiContext.Create;
+  try
+    ATestClass := TTestValueClass.Create;
+    ATestClass.AInteger := 472349;
+    try
+      ARttiType := c.GetType(ATestClass.ClassInfo);
+      Check(assigned(ARttiType));
+      AProperty := ARttiType.GetProperty('agetinteger');
+      AValue := AProperty.GetValue(ATestClass);
+      CheckEquals(472349,AValue.AsInteger);
+    finally
+      AtestClass.Free;
+    end;
+      CheckEquals(472349,AValue.AsInteger);
+  finally
+    c.Free;
+  end;
+end;
+
+procedure TTestCase1.TestPropGetValueProcString;
+var
+  ATestClass : TTestValueClass;
+  c: TRttiContext;
+  ARttiType: TRttiType;
+  AProperty: TRttiProperty;
+  AValue: TValue;
+  i: int64;
+begin
+  c := TRttiContext.Create;
+  try
+    ATestClass := TTestValueClass.Create;
+    ATestClass.AString := 'Hello World';
+    try
+      ARttiType := c.GetType(ATestClass.ClassInfo);
+      Check(assigned(ARttiType));
+      AProperty := ARttiType.GetProperty('agetstring');
+      AValue := AProperty.GetValue(ATestClass);
+      CheckEquals('Hello World',AValue.AsString);
+    finally
+      AtestClass.Free;
+    end;
+    CheckEquals('Hello World',AValue.AsString);
+  finally
+    c.Free;
+  end;
+end;
+
+
 procedure TTestCase1.TestTRttiTypeProperties;
 var
   c: TRttiContext;