* Implemented more Delphi-compatilibity functions + tests

 * Adapted tests so they compile on Delphi

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

packages/fcl-base/src/rtti.pp

@@ -76,15 +76,27 @@ type
   private
     FData: TValueData;
     function GetTypeDataProp: PTypeData;
+    function GetTypeInfo: PTypeInfo;
+    function GetTypeKind: TTypeKind;
   public
+    function IsArray: boolean;
     function AsString: string;
     function AsExtended: Extended;
-    function AsObject: TObject;
+    function IsClass: boolean;
+    function AsClass: TClass;
     function IsObject: boolean;
+    function AsObject: TObject;
+    function IsOrdinal: boolean;
+    function AsOrdinal: Int64;
     function AsBoolean: boolean;
     function AsCurrency: Currency;
     function AsInteger: Integer;
+    function ToString: string;
+    function IsType(ATypeInfo: PTypeInfo): boolean;
+    function TryAsOrdinal(out AResult: int64): boolean;
+    property Kind: TTypeKind read GetTypeKind;
     property TypeData: PTypeData read GetTypeDataProp;
+    property TypeInfo: PTypeInfo read GetTypeInfo;
   end;
 
   { TRttiContext }
@@ -130,7 +142,13 @@ type
     FTypeData: PTypeData;
     function GetName: string; override;
     function GetIsInstance: boolean; virtual;
+    function GetIsManaged: boolean; virtual;
+    function GetIsOrdinal: boolean; virtual;
+    function GetIsRecord: boolean; virtual;
+    function GetIsSet: boolean; virtual;
     function GetTypeKind: TTypeKind; virtual;
+    function GetTypeSize: integer; virtual;
+    function GetBaseType: TRttiType; virtual;
   public
     constructor create(ATypeInfo : PTypeInfo);
     function GetAttributes: specialize TArray<TCustomAttribute>; override;
@@ -138,8 +156,14 @@ type
     function GetProperty(const AName: string): TRttiProperty; virtual;
     destructor destroy; override;
     property IsInstance: boolean read GetIsInstance;
+    property isManaged: boolean read GetIsManaged;
+    property IsOrdinal: boolean read GetIsOrdinal;
+    property IsRecord: boolean read GetIsRecord;
+    property IsSet: boolean read GetIsSet;
+    property BaseType: TRttiType read GetBaseType;
     property AsInstance: TRttiInstanceType read GetAsInstance;
     property TypeKind: TTypeKind read GetTypeKind;
+    property TypeSize: integer read GetTypeSize;
   end;
 
   TRttiStructuredType = class(TRttiType)
@@ -172,11 +196,15 @@ type
 
   TRttiInstanceType = class(TRttiStructuredType)
   private
+    function GetDeclaringUnitName: string;
     function GetMetaClassType: TClass;
   protected
     function GetIsInstance: boolean; override;
+    function GetTypeSize: integer; override;
+    function GetBaseType: TRttiType; override;
   public
     property MetaClassType: TClass read GetMetaClassType;
+    property DeclaringUnitName: string read GetDeclaringUnitName;
 
   end;
 
@@ -214,6 +242,8 @@ type
 
   end;
 
+function IsManaged(TypeInfo: PTypeInfo): boolean;
+
 implementation
 
 type
@@ -267,6 +297,11 @@ var
   PoolRefCount : integer;
   GRttiPool    : TRttiPool;
 
+function IsManaged(TypeInfo: PTypeInfo): boolean;
+begin
+  result := TypeInfo^.Kind in [tkString, tkAString, tkLString, tkInterface, tkArray, tkDynArray];
+end;
+
 { TRttiPool }
 
 function TRttiPool.GetTypes: specialize TArray<TRttiType>;
@@ -423,28 +458,50 @@ begin
   result := GetTypeData(FData.FTypeInfo);
 end;
 
+function TValue.GetTypeInfo: PTypeInfo;
+begin
+  result := FData.FTypeInfo;
+end;
+
+function TValue.GetTypeKind: TTypeKind;
+begin
+  result := FData.FTypeInfo^.Kind;
+end;
+
+function TValue.IsArray: boolean;
+begin
+  result := kind in [tkArray, tkDynArray];
+end;
+
 function TValue.AsString: string;
 var
   s: string;
 begin
-  case fdata.FTypeInfo^.Kind of
+  case Kind of
     tkSString,
     tkAString   : begin
                     setlength(s,FData.FValueData.GetDataSize);
                     system.move(FData.FValueData.GetReferenceToRawData^,s[1],FData.FValueData.GetDataSize);
                   end;
   else
-    raise exception.Create(SErrInvalidTypecast);
+    raise EInvalidCast.Create(SErrInvalidTypecast);
   end;
   result := s;
 end;
 
 function TValue.AsExtended: Extended;
 begin
-  case TypeData^.FloatType of
-    ftDouble   : result := FData.FAsDouble;
-    ftExtended : result := FData.FAsExtenden;
-  end;
+  if Kind = tkFloat then
+    begin
+    case TypeData^.FloatType of
+      ftDouble   : result := FData.FAsDouble;
+      ftExtended : result := FData.FAsExtenden;
+    else
+      raise EInvalidCast.Create(SErrInvalidTypecast);
+    end;
+    end
+  else
+    raise EInvalidCast.Create(SErrInvalidTypecast);
 end;
 
 function TValue.AsObject: TObject;
@@ -452,29 +509,89 @@ begin
   if IsObject then
     result := FData.FAsObject
   else
-    raise exception.Create(SErrInvalidTypecast);
+    raise EInvalidCast.Create(SErrInvalidTypecast);
 end;
 
 function TValue.IsObject: boolean;
+begin
+  result := fdata.FTypeInfo^.Kind = tkObject;
+end;
+
+function TValue.IsClass: boolean;
 begin
   result := fdata.FTypeInfo^.Kind = tkClass;
 end;
 
+function TValue.AsClass: TClass;
+begin
+  if IsClass then
+    result := FData.FAsClass
+  else
+    raise EInvalidCast.Create(SErrInvalidTypecast);
+end;
+
+function TValue.IsOrdinal: boolean;
+begin
+  result := Kind in [tkInteger, tkInt64, tkBool];
+end;
+
 function TValue.AsBoolean: boolean;
 begin
-  result := boolean(FData.FAsSInt64)
+  if (Kind = tkBool) then
+    result := boolean(FData.FAsSInt64)
+  else
+    raise EInvalidCast.Create(SErrInvalidTypecast);
+end;
+
+function TValue.AsOrdinal: int64;
+begin
+  if IsOrdinal then
+    result := FData.FAsSInt64
+  else
+    raise EInvalidCast.Create(SErrInvalidTypecast);
 end;
 
 function TValue.AsCurrency: Currency;
 begin
-  result := FData.FAsCurr;
+  if (Kind = tkFloat) and (TypeData^.FloatType=ftCurr) then
+    result := FData.FAsCurr
+  else
+    raise EInvalidCast.Create(SErrInvalidTypecast);
 end;
 
 function TValue.AsInteger: Integer;
 begin
-  result := Integer(FData.FAsSInt64)
+  if Kind in [tkInteger, tkInt64] then
+    result := integer(FData.FAsSInt64)
+  else
+    raise EInvalidCast.Create(SErrInvalidTypecast);
+end;
+
+function TValue.ToString: String;
+begin
+  case Kind of
+    tkString,
+    tkAString : result := AsString;
+    tkInteger : result := IntToStr(AsInteger);
+    tkBool    : result := BoolToStr(AsBoolean, True);
+  else
+    result := '';
+  end;
 end;
 
+function TValue.IsType(ATypeInfo: PTypeInfo): boolean;
+begin
+  result := ATypeInfo = TypeInfo;
+end;
+
+function TValue.TryAsOrdinal(out AResult: int64): boolean;
+begin
+  result := IsOrdinal;
+  if result then
+    AResult := AsOrdinal;
+end;
+
+
 { TRttiStringType }
 
 function TRttiStringType.GetStringKind: TRttiStringKind;
@@ -495,11 +612,33 @@ begin
   result := FTypeData^.ClassType;
 end;
 
+function TRttiInstanceType.GetDeclaringUnitName: string;
+begin
+  result := FTypeData^.UnitInfo^.UnitName;
+end;
+
+function TRttiInstanceType.GetBaseType: TRttiType;
+var
+  AContext: TRttiContext;
+begin
+  AContext := TRttiContext.Create;
+  try
+    result := AContext.GetType(FTypeData^.ParentInfo);
+  finally
+    AContext.Free;
+  end;
+end;
+
 function TRttiInstanceType.GetIsInstance: boolean;
 begin
   Result:=True;
 end;
 
+function TRttiInstanceType.GetTypeSize: integer;
+begin
+  Result:=sizeof(TObject);
+end;
+
 { TRttiMember }
 
 function TRttiMember.GetVisibility: TMemberVisibility;
@@ -578,17 +717,47 @@ begin
   result := false;
 end;
 
+function TRttiType.GetIsManaged: boolean;
+begin
+  result := Rtti.IsManaged(FTypeInfo);
+end;
+
+function TRttiType.GetIsOrdinal: boolean;
+begin
+  result := false;
+end;
+
+function TRttiType.GetIsRecord: boolean;
+begin
+  result := false;
+end;
+function TRttiType.GetIsSet: boolean;
+
+begin
+  result := false;
+end;
+
 function TRttiType.GetAsInstance: TRttiInstanceType;
 begin
   // This is a ridicoulous design, but Delphi-compatible...
   result := TRttiInstanceType(self);
 end;
 
+function TRttiType.GetBaseType: TRttiType;
+begin
+  result := nil;
+end;
+
 function TRttiType.GetTypeKind: TTypeKind;
 begin
   result := FTypeInfo^.Kind;
 end;
 
+function TRttiType.GetTypeSize: integer;
+begin
+  result := -1;
+end;
+
 function TRttiType.GetName: string;
 begin
   Result:=FTypeInfo^.Name;

packages/fcl-base/tests/tests_rtti.pas

@@ -1,11 +1,18 @@
 unit tests_rtti;
 
+{$ifdef fpc}
 {$mode objfpc}{$H+}
+{$endif}
 
 interface
 
 uses
-  Classes, SysUtils, fpcunit, testutils, testregistry,
+{$IFDEF FPC}
+  fpcunit,testregistry, testutils,
+{$ELSE FPC}
+  TestFramework,
+{$ENDIF FPC}
+  Classes, SysUtils, typinfo,
   Rtti;
 
 type
@@ -22,8 +29,17 @@ type
     procedure GetClassPropertiesAttributes;
 
     procedure GetClassPropertiesValue;
+
+    procedure TestTRttiTypeProperties;
+    procedure TestPropGetValueString;
+    procedure TestPropGetValueInteger;
+    procedure TestPropGetValueBoolean;
+    procedure TestGetValueStringCastError;
   end;
 
+implementation
+
+type
   { TIntAttribute }
 
   TIntAttribute = class(TCustomAttribute)
@@ -49,7 +65,17 @@ type
     property PubPropSetRW: integer read FPubPropRW write FPubPropRW;
   end;
 
-implementation
+  TTestValueClass = class
+  private
+    FAInteger: integer;
+    FAString: string;
+    FABoolean: boolean;
+  published
+    property AInteger: Integer read FAInteger write FAInteger;
+    property AString: string read FAString write FAString;
+    property ABoolean: boolean read FABoolean write FABoolean;
+  end;
+
 
 { TIntAttribute }
 
@@ -76,6 +102,172 @@ begin
   CheckTrue(IsTestCaseClassFound, 'RTTI information does not contain class of testcase.');
 end;
 
+procedure TTestCase1.TestGetValueStringCastError;
+var
+  ATestClass : TTestValueClass;
+  c: TRttiContext;
+  ARttiType: TRttiType;
+  AValue: TValue;
+  i: integer;
+  HadException: boolean;
+begin
+  c := TRttiContext.Create;
+  try
+    ATestClass := TTestValueClass.Create;
+    ATestClass.AString := '12';
+    try
+      ARttiType := c.GetType(ATestClass.ClassInfo);
+      AValue := ARttiType.GetProperty('astring').GetValue(ATestClass);
+      HadException := false;
+      try
+        i := AValue.AsInteger;
+      except
+        on E: Exception do
+          if E.ClassType=EInvalidCast then
+            HadException := true;
+      end;
+      Check(HadException, 'No or invalid exception on invalid cast');
+    finally
+      AtestClass.Free;
+    end;
+  finally
+    c.Free;
+  end;
+end;
+
+procedure TTestCase1.TestPropGetValueBoolean;
+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('aBoolean');
+      AValue := AProperty.GetValue(ATestClass);
+      CheckEquals(true,AValue.AsBoolean);
+      ATestClass.ABoolean := false;
+      CheckEquals(true, AValue.AsBoolean);
+      CheckEquals('True', AValue.ToString);
+      CheckEquals(True, AValue.IsOrdinal);
+      CheckEquals(1, AValue.AsOrdinal);
+    finally
+      AtestClass.Free;
+    end;
+      CheckEquals(True,AValue.AsBoolean);
+  finally
+    c.Free;
+  end;
+end;
+
+procedure TTestCase1.TestPropGetValueInteger;
+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('ainteger');
+      AValue := AProperty.GetValue(ATestClass);
+      CheckEquals(472349,AValue.AsInteger);
+      ATestClass.AInteger := 12;
+      CheckEquals(472349, AValue.AsInteger);
+      CheckEquals('472349', AValue.ToString);
+      CheckEquals(True, AValue.IsOrdinal);
+    finally
+      AtestClass.Free;
+    end;
+      CheckEquals(472349,AValue.AsInteger);
+  finally
+    c.Free;
+  end;
+end;
+
+procedure TTestCase1.TestPropGetValueString;
+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('astring');
+      AValue := AProperty.GetValue(ATestClass);
+      CheckEquals('Hello World',AValue.AsString);
+      ATestClass.AString := 'Goodbye World';
+      CheckEquals('Hello World',AValue.AsString);
+      CheckEquals('Hello World',AValue.ToString);
+      Check(TypeInfo(string)=AValue.TypeInfo);
+      Check(AValue.TypeData=GetTypeData(AValue.TypeInfo));
+//      Check(AValue.IsEmpty=false);
+      Check(AValue.IsObject=false);
+      Check(AValue.IsClass=false);
+      CheckEquals(AValue.IsOrdinal, false);
+      CheckEquals(AValue.TryAsOrdinal(i), false);
+      CheckEquals(AValue.IsType(TypeInfo(string)), true);
+      CheckEquals(AValue.IsType(TypeInfo(integer)), false);
+      CheckEquals(AValue.IsArray, false);
+    finally
+      AtestClass.Free;
+    end;
+    CheckEquals('Hello World',AValue.AsString);
+  finally
+    c.Free;
+  end;
+end;
+
+procedure TTestCase1.TestTRttiTypeProperties;
+var
+  c: TRttiContext;
+  ARttiType: TRttiType;
+
+begin
+  c := TRttiContext.Create;
+  try
+    ARttiType := c.GetType(TTestValueClass);
+    Check(assigned(ARttiType));
+    CheckEquals(ARttiType.Name,'TTestValueClass');
+    Check(ARttiType.TypeKind=tkClass);
+//    CheckEquals(ARttiType.IsPublicType,false);
+    CheckEquals(ARttiType.TypeSize,4);
+    CheckEquals(ARttiType.IsManaged,false);
+    CheckEquals(ARttiType.BaseType.classname,'TRttiInstanceType');
+    CheckEquals(ARttiType.IsInstance,True);
+    CheckEquals(ARttiType.AsInstance.DeclaringUnitName,'tests_rtti');
+    Check(ARttiType.BaseType.Name='TObject');
+    Check(ARttiType.AsInstance.BaseType.Name='TObject');
+    CheckEquals(ARttiType.IsOrdinal,False);
+    CheckEquals(ARttiType.IsRecord,False);
+    CheckEquals(ARttiType.IsSet,False);
+  finally
+    c.Free;
+  end;
+
+end;
+
 procedure TTestCase1.GetTypeInteger;
 var
   LContext: TRttiContext;
@@ -93,7 +285,7 @@ procedure TTestCase1.GetClassProperties;
 var
   LContext: TRttiContext;
   LType: TRttiType;
-  PropList: specialize TArray<TRttiProperty>;
+  PropList: {$ifdef fpc}specialize{$endif} TArray<TRttiProperty>;
 begin
   LContext := TRttiContext.Create;
 
@@ -113,7 +305,7 @@ procedure TTestCase1.GetClassAttributes;
 var
   LContext: TRttiContext;
   LType: TRttiType;
-  AttrList: specialize TArray<TCustomAttribute>;
+  AttrList: {$ifdef fpc}specialize{$endif} TArray<TCustomAttribute>;
 begin
   LContext := TRttiContext.Create;
 
@@ -133,8 +325,8 @@ procedure TTestCase1.GetClassPropertiesAttributes;
 var
   LContext: TRttiContext;
   LType: TRttiType;
-  PropList: specialize TArray<TRttiProperty>;
-  AttrList: specialize TArray<TCustomAttribute>;
+  PropList: {$ifdef fpc}specialize{$endif} TArray<TRttiProperty>;
+  AttrList: {$ifdef fpc}specialize{$endif} TArray<TCustomAttribute>;
 begin
   LContext := TRttiContext.Create;
 
@@ -178,6 +370,10 @@ begin
 end;
 
 initialization
+{$ifdef fpc}
   RegisterTest(TTestCase1);
+{$else fpc}
+  RegisterTest(TTestCase1.Suite);
+{$endif fpc}
 end.