* Made a start with rtti unit + some basic tests

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

.gitattributes

@@ -1859,6 +1859,7 @@ packages/fcl-base/src/os2/eventlog.inc svneol=native#text/plain
 packages/fcl-base/src/pooledmm.pp svneol=native#text/plain
 packages/fcl-base/src/rtfdata.inc svneol=native#text/plain
 packages/fcl-base/src/rtfpars.pp svneol=native#text/plain
+packages/fcl-base/src/rtti.pp svneol=native#text/plain
 packages/fcl-base/src/rttiutils.pp svneol=native#text/plain
 packages/fcl-base/src/streamcoll.pp svneol=native#text/plain
 packages/fcl-base/src/streamex.pp svneol=native#text/plain
@@ -1877,6 +1878,7 @@ packages/fcl-base/src/wince/fileinfo.pp svneol=native#text/plain
 packages/fcl-base/src/wtex.pp svneol=native#text/plain
 packages/fcl-base/tests/fclbase-unittests.pp svneol=native#text/plain
 packages/fcl-base/tests/tests_fptemplate.pp svneol=native#text/plain
+packages/fcl-base/tests/tests_rtti.pas svneol=native#text/plain
 packages/fcl-base/texts/fptemplate.txt svneol=native#text/plain
 packages/fcl-db/Makefile svneol=native#text/plain
 packages/fcl-db/Makefile.fpc svneol=native#text/plain

packages/fcl-base/fpmake.pp

@@ -57,6 +57,8 @@ begin
     T:=P.Targets.AddUnit('fptimer.pp',AllWindowsOSes+AllUnixOSes);
     T:=P.Targets.AddUnit('gettext.pp');
     T:=P.Targets.AddUnit('idea.pp');
+    T:=P.Targets.AddUnit('rtti.pp');
+      T.ResourceStrings:=true;
     T:=P.Targets.AddUnit('inicol.pp');
       T.ResourceStrings:=true;
       with T.Dependencies do

packages/fcl-base/src/rtti.pp

@@ -0,0 +1,755 @@
+{ Extended RTTI compatibility unit
+
+  Copyright (C) 2013 Joost van der Sluis [email protected]
+
+  This library is free software; you can redistribute it and/or modify it
+  under the terms of the GNU Library General Public License as published by
+  the Free Software Foundation; either version 2 of the License, or (at your
+  option) any later version with the following modification:
+
+  As a special exception, the copyright holders of this library give you
+  permission to link this library with independent modules to produce an
+  executable, regardless of the license terms of these independent modules,and
+  to copy and distribute the resulting executable under terms of your choice,
+  provided that you also meet, for each linked independent module, the terms
+  and conditions of the license of that module. An independent module is a
+  module which is not derived from or based on this library. If you modify
+  this library, you may extend this exception to your version of the library,
+  but you are not obligated to do so. If you do not wish to do so, delete this
+  exception statement from your version.
+
+  This program is distributed in the hope that it will be useful, but WITHOUT
+  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+  FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
+  for more details.
+
+  You should have received a copy of the GNU Library General Public License
+  along with this library; if not, write to the Free Software Foundation,
+  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+}
+unit Rtti;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes,
+  SysUtils,
+  contnrs,
+  typinfo;
+
+type
+  TRttiType = class;
+  TRttiProperty = class;
+  TRttiInstanceType = class;
+
+  TAttributeArray = array of TCustomAttribute;
+  TRttiPropertyArray = array of TRttiProperty;
+  TRttiTypeArray = array of TRttiType;
+
+  IValueData = interface
+  ['{1338B2F3-2C21-4798-A641-CA2BC5BF2396}']
+    procedure ExtractRawData(ABuffer: pointer);
+    procedure ExtractRawDataNoCopy(ABuffer: pointer);
+    function GetDataSize: integer;
+    function GetReferenceToRawData: pointer;
+  end;
+
+  TValueData = record
+    FTypeInfo: PTypeInfo;
+    FValueData: IValueData;
+    case integer of
+      0:  (FAsUByte: Byte);
+      1:  (FAsUWord: Word);
+      2:  (FAsULong: LongWord);
+      3:  (FAsObject: TObject);
+      4:  (FAsClass: TClass);
+      5:  (FAsSByte: Shortint);
+      9:  (FAsDouble: Double);
+      10: (FAsExtenden: Extended);
+      12: (FAsCurr: Currency);
+      14: (FAsSInt64: Int64);
+  end;
+
+  { TValue }
+
+  TValue = object
+  private
+    FData: TValueData;
+    function GetTypeDataProp: PTypeData;
+  public
+    function AsString: string;
+    function AsExtended: Extended;
+    function AsObject: TObject;
+    function IsObject: boolean;
+    function AsBoolean: boolean;
+    function AsCurrency: Currency;
+    function AsInteger: Integer;
+    property TypeData: PTypeData read GetTypeDataProp;
+  end;
+
+  { TRttiContext }
+
+  TRttiContext = object
+  private
+    FContextToken: IInterface;
+  public
+    class function Create: TRttiContext;
+    destructor Free;
+    function GetType(ATypeInfo: PTypeInfo): TRttiType;
+    function GetType(AClass: TClass): TRttiType;
+    function GetTypes: TRttiTypeArray;
+  end;
+
+  { TRttiObject }
+
+  TRttiObject = class
+  public
+    function GetAttributes: TAttributeArray; virtual; abstract;
+  end;
+
+  { TRttiNamedObject }
+
+  TRttiNamedObject = class(TRttiObject)
+  protected
+    function GetName: string; virtual;
+  public
+    property Name: string read GetName;
+  end;
+
+  { TRttiType }
+
+  TRttiType = class(TRttiNamedObject)
+  private
+    FTypeInfo: PTypeInfo;
+    FAttributesResolved: boolean;
+    FAttributes: TAttributeArray;
+    FPropertiesResolved: boolean;
+    FProperties: TRttiPropertyArray;
+    function GetAsInstance: TRttiInstanceType;
+  protected
+    FTypeData: PTypeData;
+    function GetName: string; override;
+    function GetIsInstance: boolean; virtual;
+    function GetTypeKind: TTypeKind; virtual;
+  public
+    constructor create(ATypeInfo : PTypeInfo);
+    function GetAttributes: TAttributeArray; override;
+    function GetProperties: TRttiPropertyArray;
+    function GetProperty(const AName: string): TRttiProperty; virtual;
+    destructor destroy; override;
+    property IsInstance: boolean read GetIsInstance;
+    property AsInstance: TRttiInstanceType read GetAsInstance;
+    property TypeKind: TTypeKind read GetTypeKind;
+  end;
+
+  TRttiStructuredType = class(TRttiType)
+
+  end;
+
+  { TRttiFloatType }
+
+  TRttiFloatType = class(TRttiType)
+  private
+    function GetFloatType: TFloatType;
+  public
+    property FloatType: TFloatType read GetFloatType;
+  end;
+
+
+  TRttiStringKind = (skShortString, skAnsiString, skWideString, skUnicodeString);
+
+  { TRttiStringType }
+
+  TRttiStringType = class(TRttiType)
+  private
+    function GetStringKind: TRttiStringKind;
+  public
+    property StringKind: TRttiStringKind read GetStringKind;
+  end;
+
+
+  { TRttiInstanceType }
+
+  TRttiInstanceType = class(TRttiStructuredType)
+  private
+    function GetMetaClassType: TClass;
+  protected
+    function GetIsInstance: boolean; override;
+  public
+    property MetaClassType: TClass read GetMetaClassType;
+
+  end;
+
+  { TRttiMember }
+
+  TMemberVisibility=(mvPrivate, mvProtected, mvPublic, mvPublished);
+
+  TRttiMember = class(TRttiNamedObject)
+  private
+    FParent: TRttiType;
+  protected
+    function GetVisibility: TMemberVisibility; virtual;
+  public
+    constructor create(AParent: TRttiType);
+    property Visibility: TMemberVisibility read GetVisibility;
+    property Parent: TRttiType read FParent;
+
+  end;
+
+  { TRttiProperty }
+
+  TRttiProperty = class(TRttiMember)
+  private
+    FPropInfo: PPropInfo;
+    FAttributesResolved: boolean;
+    FAttributes: TAttributeArray;
+    function GetPropertyType: TRttiType;
+  protected
+    function GetName: string; override;
+    function GetAttributes: TAttributeArray; override;
+  public
+    constructor create(AParent: TRttiType; APropInfo: PPropInfo);
+    function GetValue(Instance: pointer): TValue;
+    property PropertyType: TRttiType read GetPropertyType;
+
+  end;
+
+implementation
+
+type
+
+  { TRttiPool }
+
+  TRttiPool = class
+  private
+    FAllTypesResolved: boolean;
+    FTypesList: TRttiTypeArray;
+  public
+    function GetTypes: TRttiTypeArray;
+    function GetType(ATypeInfo: PTypeInfo): TRttiType;
+    destructor Destroy; override;
+  end;
+
+  IPooltoken = interface
+  ['{3CDB3CE9-AB55-CBAA-7B9D-2F3BB1CF5AF8}']
+    function RttiPool: TRttiPool;
+  end;
+
+  { TPoolToken }
+
+  TPoolToken = class(TInterfacedObject, IPooltoken)
+  public
+    constructor Create;
+    destructor Destroy; override;
+    function RttiPool: TRttiPool;
+  end;
+
+  { TValueDataIntImpl }
+
+  TValueDataIntImpl = class(TInterfacedObject, IValueData)
+  private
+    FDataSize: integer;
+    FBuffer: pointer;
+  public
+    constructor Create(ACopyFromBuffer: Pointer; ALen: integer);
+    destructor Destroy; override;
+    procedure ExtractRawData(ABuffer: pointer);
+    procedure ExtractRawDataNoCopy(ABuffer: pointer);
+    function GetDataSize: integer;
+    function GetReferenceToRawData: pointer;
+  end;
+
+resourcestring
+  SErrUnableToGetValueForType = 'Unable to get value for type %s';
+  SErrInvalidTypecast         = 'Invalid typecast';
+
+var
+  PoolRefCount : integer;
+  GRttiPool    : TRttiPool;
+
+{ TRttiPool }
+
+function TRttiPool.GetTypes: TRttiTypeArray;
+var
+  UnitList        : PUnitInfoList;
+  UnitInd, TypeInd: longint;
+  UnitInfo        : PUnitInfo;
+  UnitDataList    : PextRTTIDataList;
+  ExtRttiData     : PExtRTTIData;
+  TypelistUnitInd : longint;
+  ARttiType       : TRttiType;
+  UnitStartIndex  : LongInt;
+  l               : LongInt;
+
+begin
+  if not FAllTypesResolved then
+    begin
+    UnitList:=GetUnitList;
+    TypelistUnitInd:=0;
+    SetLength(FTypesList,0);
+    for UnitInd:=0 to UnitList^.UnitCount-1 do
+      begin
+      UnitInfo := UnitList^.Units[UnitInd];
+      UnitDataList := GetRTTIDataListForUnit(UnitInfo);
+      l := GetRTTIDataCountForUnit(UnitInfo);
+      UnitStartIndex := length(FTypesList);
+      SetLength(FTypesList,UnitStartIndex+l);
+      for TypeInd:=0 to l-1 do
+        begin
+        ExtRttiData := @UnitDataList^[TypeInd];
+        if Assigned(ExtRttiData^.TypeData) then
+          begin
+          case ExtRttiData^.TypeData^.Kind of
+            tkClass   : ARttiType := TRttiInstanceType.Create(ExtRttiData^.TypeData);
+            tkSString,
+            tkLString,
+            tkAString,
+            tkUString,
+            tkWString : ARttiType := TRttiStringType.Create(ExtRttiData^.TypeData);
+            tkFloat   : ARttiType := TRttiFloatType.Create(ExtRttiData^.TypeData);
+          else
+            ARttiType := TRttiType.Create(ExtRttiData^.TypeData);
+          end; {case}
+          end
+        else
+          ARttiType := TRttiType.Create(ExtRttiData^.TypeData);
+        FTypesList[UnitStartIndex+TypeInd] := ARttiType;
+        end;
+      end;
+    FAllTypesResolved:=true;
+    end;
+  result := FTypesList;
+end;
+
+function TRttiPool.GetType(ATypeInfo: PTypeInfo): TRttiType;
+var
+  ATypesList: TRttiTypeArray;
+  i: integer;
+begin
+  ATypesList := GetTypes;
+  result := nil;
+  for i := 0 to length(ATypesList)-1 do
+     begin
+       if ATypesList[i].FTypeInfo=ATypeInfo then
+         begin
+         result := ATypesList[i];
+         break;
+         end;
+     end;
+end;
+
+destructor TRttiPool.Destroy;
+var
+  i: LongInt;
+begin
+  for i := 0 to length(FTypesList)-1 do
+    FTypesList[i].Free;
+  inherited Destroy;
+end;
+
+{ TPoolToken }
+
+constructor TPoolToken.Create;
+begin
+  inherited Create;
+  inc(PoolRefCount);
+  if PoolRefCount=1 then
+    GRttiPool := TRttiPool.Create;
+end;
+
+destructor TPoolToken.Destroy;
+begin
+  dec(PoolRefCount);
+  if PoolRefCount=0 then
+    GRttiPool.Free;
+  inherited;
+end;
+
+function TPoolToken.RttiPool: TRttiPool;
+begin
+  result := GRttiPool;
+end;
+
+{ TValueDataIntImpl }
+
+constructor TValueDataIntImpl.create(ACopyFromBuffer: Pointer; ALen: integer);
+begin
+  FDataSize:=ALen;
+  if ALen>0 then
+    begin
+      Getmem(FBuffer,FDataSize);
+      system.move(ACopyFromBuffer^,FBuffer^,FDataSize);
+    end;
+end;
+
+destructor TValueDataIntImpl.Destroy;
+begin
+  if assigned(FBuffer) then
+    Freemem(FBuffer);
+  inherited Destroy;
+end;
+
+procedure TValueDataIntImpl.ExtractRawData(ABuffer: pointer);
+begin
+  system.move(FBuffer^,ABuffer^,FDataSize);
+end;
+
+procedure TValueDataIntImpl.ExtractRawDataNoCopy(ABuffer: pointer);
+begin
+  system.move(FBuffer^,ABuffer^,FDataSize);
+end;
+
+function TValueDataIntImpl.GetDataSize: integer;
+begin
+  result := FDataSize;
+end;
+
+function TValueDataIntImpl.GetReferenceToRawData: pointer;
+begin
+  result := FBuffer;
+end;
+
+{ TRttiFloatType }
+
+function TRttiFloatType.GetFloatType: TFloatType;
+begin
+  result := FTypeData^.FloatType;
+end;
+
+{ TValue }
+
+function TValue.GetTypeDataProp: PTypeData;
+begin
+  result := GetTypeData(FData.FTypeInfo);
+end;
+
+function TValue.AsString: string;
+var
+  s: string;
+begin
+  case fdata.FTypeInfo^.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);
+  end;
+  result := s;
+end;
+
+function TValue.AsExtended: Extended;
+begin
+  case TypeData^.FloatType of
+    ftDouble   : result := FData.FAsDouble;
+    ftExtended : result := FData.FAsExtenden;
+  end;
+end;
+
+function TValue.AsObject: TObject;
+begin
+  if IsObject then
+    result := FData.FAsObject
+  else
+    raise exception.Create(SErrInvalidTypecast);
+end;
+
+function TValue.IsObject: boolean;
+begin
+  result := fdata.FTypeInfo^.Kind = tkClass;
+end;
+
+function TValue.AsBoolean: boolean;
+begin
+  result := boolean(FData.FAsSInt64)
+end;
+
+function TValue.AsCurrency: Currency;
+begin
+  result := FData.FAsCurr;
+end;
+
+function TValue.AsInteger: Integer;
+begin
+  result := Integer(FData.FAsSInt64)
+end;
+
+{ TRttiStringType }
+
+function TRttiStringType.GetStringKind: TRttiStringKind;
+begin
+  case TypeKind of
+    tkSString : result := skShortString;
+    tkLString : result := skAnsiString;
+    tkAString : result := skAnsiString;
+    tkUString : result := skUnicodeString;
+    tkWString : result := skWideString;
+  end;
+end;
+
+{ TRttiInstanceType }
+
+function TRttiInstanceType.GetMetaClassType: TClass;
+begin
+  result := FTypeData^.ClassType;
+end;
+
+function TRttiInstanceType.GetIsInstance: boolean;
+begin
+  Result:=True;
+end;
+
+{ TRttiMember }
+
+function TRttiMember.GetVisibility: TMemberVisibility;
+begin
+  result := mvPublished;
+end;
+
+constructor TRttiMember.create(AParent: TRttiType);
+begin
+  inherited create();
+  FParent := AParent;
+end;
+
+{ TRttiProperty }
+
+function TRttiProperty.GetPropertyType: TRttiType;
+begin
+  GRttiPool.GetType(FPropInfo^.PropType);
+end;
+
+function TRttiProperty.GetName: string;
+begin
+  Result:=FPropInfo^.Name;
+end;
+
+function TRttiProperty.GetAttributes: TAttributeArray;
+var
+  i: Integer;
+begin
+  if not FAttributesResolved then
+    begin
+      setlength(FAttributes,FPropInfo^.AttributeCount);
+      for i := 0 to FPropInfo^.AttributeCount-1 do
+        begin
+          FAttributes[i]:=TCustomAttribute(GetPropAttribute(FPropInfo,i));
+        end;
+      FAttributesResolved:=true;
+    end;
+  result := FAttributes;
+end;
+
+constructor TRttiProperty.create(AParent: TRttiType; APropInfo: PPropInfo);
+begin
+  inherited create(AParent);
+  FPropInfo := APropInfo;
+end;
+
+function TRttiProperty.GetValue(Instance: pointer): TValue;
+var
+  S: ansistring;
+begin
+  result.FData.FTypeInfo:=FPropInfo^.PropType;
+
+  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);
+    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;
+  else
+    raise Exception.CreateFmt(SErrUnableToGetValueForType,[FPropInfo^.Name]);
+  end;
+end;
+
+function TRttiType.GetIsInstance: boolean;
+begin
+  result := false;
+end;
+
+function TRttiType.GetAsInstance: TRttiInstanceType;
+begin
+  // This is a ridicoulous design, but Delphi-compatible...
+  result := TRttiInstanceType(self);
+end;
+
+function TRttiType.GetTypeKind: TTypeKind;
+begin
+  result := FTypeInfo^.Kind;
+end;
+
+function TRttiType.GetName: string;
+begin
+  Result:=FTypeInfo^.Name;
+end;
+
+constructor TRttiType.create(ATypeInfo: PTypeInfo);
+begin
+  inherited create();
+  FTypeInfo:=ATypeInfo;
+  if assigned(FTypeInfo) then
+    FTypeData:=GetTypeData(ATypeInfo);
+end;
+
+function TRttiType.GetAttributes: TAttributeArray;
+var
+  i: Integer;
+  erd: PExtRTTIData;
+begin
+  if not FAttributesResolved then
+    begin
+    erd := GetExtRTTIData(FTypeInfo);
+    setlength(FAttributes,FTypeData^.AttributeCount);
+    for i := 0 to FTypeData^.AttributeCount-1 do
+      FAttributes[i]:=GetClassAttribute(erd,i);
+    FAttributesResolved:=true;
+    end;
+  result := FAttributes;
+end;
+
+function aligntoptr(p : pointer) : pointer;inline;
+   begin
+{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+     result:=align(p,sizeof(p));
+{$else FPC_REQUIRES_PROPER_ALIGNMENT}
+     result:=p;
+{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
+   end;
+
+
+function TRttiType.GetProperties: TRttiPropertyArray;
+var
+  propcount: integer;
+  PropList: PPropList;
+  APropInfo: PPropInfo;
+  TypeInfo: PTypeInfo;
+  TypeRttiType: TRttiType;
+  TD: PTypeData;
+  TP: PPropInfo;
+  Count: longint;
+begin
+  if not FPropertiesResolved then
+    begin
+      TypeInfo := FTypeInfo;
+
+      // Get the total properties count
+      SetLength(FProperties,FTypeData^.PropCount);
+      // Clear list
+      FillChar(FProperties[0],FTypeData^.PropCount*sizeof(TRttiProperty),0);
+      TypeRttiType:= self;
+      repeat
+        TD:=GetTypeData(TypeInfo);
+
+        // published properties count for this object
+        TP:=aligntoptr(PPropInfo(aligntoptr((Pointer(@TD^.UnitName)+Length(TD^.UnitName)+1))));
+        // skip the attribute-info if available
+        TP:=aligntoptr(pointer(TP)+(TD^.AttributeCount*sizeof(TAttributeProc)));
+        Count:=PWord(TP)^;
+        // Now point TP to first propinfo record.
+        Inc(Pointer(TP),SizeOF(Word));
+        TP:=aligntoptr(TP);
+        While Count>0 do
+          begin
+            // Don't overwrite properties with the same name
+            if FProperties[TP^.NameIndex]=nil then
+              FProperties[TP^.NameIndex]:=TRttiProperty.Create(TypeRttiType, TP);
+
+            // Point to TP next propinfo record.
+            // Located at Name[Length(Name)+1] !
+            TP:=aligntoptr(PPropInfo(pointer(@TP^.Name)+PByte(@TP^.Name)^+(TP^.AttributeCount*SizeOf(TAttributeProc))+1));
+            Dec(Count);
+          end;
+        TypeInfo:=TD^.Parentinfo;
+        TypeRttiType:= GRttiPool.GetType(TypeInfo);
+      until TypeInfo=nil;
+    end;
+
+  result := FProperties;
+end;
+
+function TRttiType.GetProperty(const AName: string): TRttiProperty;
+var
+  FPropList: TRttiPropertyArray;
+  i: Integer;
+begin
+  result := nil;
+  FPropList := GetProperties;
+  for i := 0 to length(FPropList)-1 do
+    if sametext(FPropList[i].Name,AName) then
+      begin
+        result := FPropList[i];
+        break;
+      end;
+end;
+
+destructor TRttiType.Destroy;
+var
+  i: Integer;
+begin
+  for i := 0 to high(FAttributes) do
+    FAttributes[i].Free;
+  for i := 0 to high(FProperties) do
+    FProperties[i].Free;
+  inherited destroy;
+end;
+
+{ TRttiNamedObject }
+
+function TRttiNamedObject.GetName: string;
+begin
+  result := '';
+end;
+
+{ TRttiContext }
+
+class function TRttiContext.Create: TRttiContext;
+begin
+  result.FContextToken := nil;
+end;
+
+destructor TRttiContext.Free;
+begin
+  FContextToken := nil;
+end;
+
+function TRttiContext.GetType(ATypeInfo: PTypeInfo): TRttiType;
+begin
+  if not assigned(FContextToken) then
+    FContextToken := TPoolToken.Create;
+  result := (FContextToken as IPooltoken).RttiPool.GetType(ATypeInfo);
+end;
+
+
+function TRttiContext.GetType(AClass: TClass): TRttiType;
+begin
+  if assigned(AClass) then
+    result := GetType(PTypeInfo(AClass.ClassInfo))
+  else
+    result := nil;
+end;
+
+function TRttiContext.GetTypes: TRttiTypeArray;
+
+begin
+  if not assigned(FContextToken) then
+    FContextToken := TPoolToken.Create;
+  result := (FContextToken as IPooltoken).RttiPool.GetTypes;
+end;
+
+initialization
+  PoolRefCount := 0;
+end.
+

packages/fcl-base/tests/fclbase-unittests.pp

@@ -3,7 +3,7 @@ program fclbase_unittests;
 {$mode objfpc}{$H+}
 
 uses
-  Classes, consoletestrunner, tests_fptemplate;
+  Classes, consoletestrunner, tests_fptemplate, tests_rtti;
 
 var
   Application: TTestRunner;

packages/fcl-base/tests/tests_rtti.pas

@@ -0,0 +1,183 @@
+unit tests_rtti;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, fpcunit, testutils, testregistry,
+  Rtti;
+
+type
+
+  { TTestCase1 }
+
+  TTestCase1= class(TTestCase)
+  published
+    procedure GetTypes;
+    procedure GetTypeInteger;
+    procedure GetClassProperties;
+
+    procedure GetClassAttributes;
+    procedure GetClassPropertiesAttributes;
+
+    procedure GetClassPropertiesValue;
+  end;
+
+  { TIntAttribute }
+
+  TIntAttribute = class(TCustomAttribute)
+  private
+    FInt: Integer;
+  public
+    constructor create(AInt: integer); virtual;
+    property Int: integer read FInt;
+  end;
+
+  [TIntAttribute(1)]
+  [TIntAttribute(2)]
+  TGetClassProperties = class
+  private
+    FPubPropRO: integer;
+    FPubPropRW: integer;
+  published
+    property PubPropRO: integer read FPubPropRO;
+    [TIntAttribute(3)]
+    property PubPropRW: integer read FPubPropRW write FPubPropRW;
+    property PubPropSetRO: integer read FPubPropRO;
+    [TIntAttribute(4)]
+    property PubPropSetRW: integer read FPubPropRW write FPubPropRW;
+  end;
+
+implementation
+
+{ TIntAttribute }
+
+constructor TIntAttribute.create(AInt: integer);
+begin
+  FInt:=AInt;
+end;
+
+procedure TTestCase1.GetTypes;
+var
+  LContext: TRttiContext;
+  LType: TRttiType;
+  IsTestCaseClassFound: boolean;
+begin
+  LContext := TRttiContext.Create;
+
+  { Enumerate all types declared in the application }
+  for LType in LContext.GetTypes() do
+    begin
+    if LType.Name='TTestCase1' then
+      IsTestCaseClassFound:=true;
+    end;
+  LContext.Free;
+  CheckTrue(IsTestCaseClassFound, 'RTTI information does not contain class of testcase.');
+end;
+
+procedure TTestCase1.GetTypeInteger;
+var
+  LContext: TRttiContext;
+  LType: TRttiType;
+begin
+  LContext := TRttiContext.Create;
+
+  LType := LContext.GetType(TypeInfo(integer));
+  CheckEquals(LType.Name, 'LongInt');
+
+  LContext.Free;
+end;
+
+procedure TTestCase1.GetClassProperties;
+var
+  LContext: TRttiContext;
+  LType: TRttiType;
+  PropList: TRttiPropertyArray;
+begin
+  LContext := TRttiContext.Create;
+
+  LType := LContext.GetType(TypeInfo(TGetClassProperties));
+  PropList := LType.GetProperties;
+
+  CheckEquals(4, length(PropList));
+  CheckEquals('PubPropRO', PropList[0].Name);
+  CheckEquals('PubPropRW', PropList[1].Name);
+  CheckEquals('PubPropSetRO', PropList[2].Name);
+  CheckEquals('PubPropSetRW', PropList[3].Name);
+
+  LContext.Free;
+end;
+
+procedure TTestCase1.GetClassAttributes;
+var
+  LContext: TRttiContext;
+  LType: TRttiType;
+  AttrList: TAttributeArray;
+begin
+  LContext := TRttiContext.Create;
+
+  LType := LContext.GetType(TypeInfo(TGetClassProperties));
+  AttrList := LType.GetAttributes;
+
+  CheckEquals(2, length(AttrList));
+  CheckEquals('TIntAttribute', AttrList[0].ClassName);
+  CheckEquals('TIntAttribute', AttrList[1].ClassName);
+  CheckEquals(1, TIntAttribute(AttrList[0]).Int);
+  CheckEquals(2, TIntAttribute(AttrList[1]).Int);
+
+  LContext.Free;
+end;
+
+procedure TTestCase1.GetClassPropertiesAttributes;
+var
+  LContext: TRttiContext;
+  LType: TRttiType;
+  PropList: TRttiPropertyArray;
+  AttrList: TAttributeArray;
+begin
+  LContext := TRttiContext.Create;
+
+  LType := LContext.GetType(TypeInfo(TGetClassProperties));
+  PropList := LType.GetProperties;
+
+  AttrList := PropList[1].GetAttributes;
+  CheckEquals(1, length(AttrList));
+  CheckEquals(3, TIntAttribute(AttrList[0]).Int);
+
+  AttrList := PropList[3].GetAttributes;
+  CheckEquals(1, length(AttrList));
+  CheckEquals(4, TIntAttribute(AttrList[0]).Int);
+
+  LContext.Free;
+end;
+
+procedure TTestCase1.GetClassPropertiesValue;
+var
+  AGetClassProperties: TGetClassProperties;
+  LContext: TRttiContext;
+  LType: TRttiType;
+  AValue: TValue;
+begin
+  LContext := TRttiContext.Create;
+
+  LType := LContext.GetType(TGetClassProperties);
+
+  AGetClassProperties := TGetClassProperties.Create;
+  try
+    AGetClassProperties.PubPropRW:=12345;
+
+    AValue := LType.GetProperty('PubPropRW').GetValue(AGetClassProperties);
+    CheckEquals(12345, AValue.AsInteger);
+
+  finally
+    AGetClassProperties.Free;
+  end;
+
+  LContext.Free;
+end;
+
+initialization
+  RegisterTest(TTestCase1);
+end.
+