+ add support for interface types (both reference counted and raw ones)

git-svn-id: trunk@37704 -

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

@@ -271,6 +271,28 @@ type
 
   end;
 
+  TInterfaceType = (
+    itRefCounted, { aka COM interface }
+    itRaw         { aka CORBA interface }
+  );
+
+  TRttiInterfaceType = class(TRttiType)
+  protected
+    function GetIntfBaseType: TRttiInterfaceType; virtual; abstract;
+    function GetDeclaringUnitName: String; virtual; abstract;
+    function GetGUID: TGUID; virtual; abstract;
+    function GetGUIDStr: String; virtual;
+    function GetIntfFlags: TIntfFlags; virtual; abstract;
+    function GetIntfType: TInterfaceType; virtual; abstract;
+  public
+    property BaseType: TRttiInterfaceType read GetIntfBaseType;
+    property DeclaringUnitName: String read GetDeclaringUnitName;
+    property GUID: TGUID read GetGUID;
+    property GUIDStr: String read GetGUIDStr;
+    property IntfFlags: TIntfFlags read GetIntfFlags;
+    property IntfType: TInterfaceType read GetIntfType;
+  end;
+
   { TRttiInstanceType }
 
   TRttiInstanceType = class(TRttiStructuredType)
@@ -411,6 +433,29 @@ type
     function GetReferenceToRawData: pointer;
   end;
 
+  TRttiRefCountedInterfaceType = class(TRttiInterfaceType)
+  private
+    function IntfData: PInterfaceData; inline;
+  protected
+    function GetIntfBaseType: TRttiInterfaceType; override;
+    function GetDeclaringUnitName: String; override;
+    function GetGUID: TGUID; override;
+    function GetIntfFlags: TIntfFlags; override;
+    function GetIntfType: TInterfaceType; override;
+  end;
+
+  TRttiRawInterfaceType = class(TRttiInterfaceType)
+  private
+    function IntfData: PInterfaceRawData; inline;
+  protected
+    function GetIntfBaseType: TRttiInterfaceType; override;
+    function GetDeclaringUnitName: String; override;
+    function GetGUID: TGUID; override;
+    function GetGUIDStr: String; override;
+    function GetIntfFlags: TIntfFlags; override;
+    function GetIntfType: TInterfaceType; override;
+  end;
+
 resourcestring
   SErrUnableToGetValueForType = 'Unable to get value for type %s';
   SErrUnableToSetValueForType = 'Unable to set value for type %s';
@@ -680,6 +725,8 @@ begin
           end;
         case ATypeInfo^.Kind of
           tkClass   : Result := TRttiInstanceType.Create(ATypeInfo);
+          tkInterface: Result := TRttiRefCountedInterfaceType.Create(ATypeInfo);
+          tkInterfaceRaw: Result := TRttiRawInterfaceType.Create(ATypeInfo);
           tkSString,
           tkLString,
           tkAString,
@@ -886,6 +933,95 @@ begin
     result := @FBuffer;
 end;
 
+{ TRttiRefCountedInterfaceType }
+
+function TRttiRefCountedInterfaceType.IntfData: PInterfaceData;
+begin
+  Result := PInterfaceData(FTypeData);
+end;
+
+function TRttiRefCountedInterfaceType.GetIntfBaseType: TRttiInterfaceType;
+var
+  context: TRttiContext;
+begin
+  if not Assigned(IntfData^.Parent) then
+    Exit(Nil);
+
+  context := TRttiContext.Create;
+  try
+    Result := context.GetType(IntfData^.Parent^) as TRttiInterfaceType;
+  finally
+    context.Free;
+  end;
+end;
+
+function TRttiRefCountedInterfaceType.GetDeclaringUnitName: String;
+begin
+  Result := IntfData^.UnitName;
+end;
+
+function TRttiRefCountedInterfaceType.GetGUID: TGUID;
+begin
+  Result := IntfData^.GUID;
+end;
+
+function TRttiRefCountedInterfaceType.GetIntfFlags: TIntfFlags;
+begin
+  Result := IntfData^.Flags;
+end;
+
+function TRttiRefCountedInterfaceType.GetIntfType: TInterfaceType;
+begin
+  Result := itRefCounted;
+end;
+
+{ TRttiRawInterfaceType }
+
+function TRttiRawInterfaceType.IntfData: PInterfaceRawData;
+begin
+  Result := PInterfaceRawData(FTypeData);
+end;
+
+function TRttiRawInterfaceType.GetIntfBaseType: TRttiInterfaceType;
+var
+  context: TRttiContext;
+begin
+  if not Assigned(IntfData^.Parent) then
+    Exit(Nil);
+
+  context := TRttiContext.Create;
+  try
+    Result := context.GetType(IntfData^.Parent^) as TRttiInterfaceType;
+  finally
+    context.Free;
+  end;
+end;
+
+function TRttiRawInterfaceType.GetDeclaringUnitName: String;
+begin
+  Result := IntfData^.UnitName;
+end;
+
+function TRttiRawInterfaceType.GetGUID: TGUID;
+begin
+  Result := IntfData^.IID;
+end;
+
+function TRttiRawInterfaceType.GetGUIDStr: String;
+begin
+  Result := IntfData^.IIDStr;
+end;
+
+function TRttiRawInterfaceType.GetIntfFlags: TIntfFlags;
+begin
+  Result := IntfData^.Flags;
+end;
+
+function TRttiRawInterfaceType.GetIntfType: TInterfaceType;
+begin
+  Result := itRaw;
+end;
+
 { TRttiFloatType }
 
 function TRttiFloatType.GetFloatType: TFloatType;
@@ -1613,6 +1749,13 @@ begin
   end;
 end;
 
+{ TRttiInterfaceType }
+
+function TRttiInterfaceType.GetGUIDStr: String;
+begin
+  Result := GUIDToString(GUID);
+end;
+
 { TRttiInstanceType }
 
 function TRttiInstanceType.GetMetaClassType: TClass;

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

@@ -59,6 +59,11 @@ type
     procedure TestReferenceRawDataEmpty;
 
     procedure TestIsManaged;
+
+    procedure TestInterface;
+{$ifdef fpc}
+    procedure TestInterfaceRaw;
+{$endif}
   end;
 
 implementation
@@ -109,6 +114,15 @@ type
   end;
   {$M-}
 
+  {$M+}
+  ITestInterface = interface
+    procedure Test;
+    function Test2: LongInt;
+    procedure Test3(aArg1: LongInt; const aArg2: AnsiString; var aArg3: Boolean; out aArg4: Word);
+    function Test4(aArg1: array of LongInt; aArg2: array of const): AnsiString;
+  end;
+  {$M-}
+
   TManagedRec = record
     s: string;
   end;
@@ -1269,6 +1283,39 @@ begin
   CheckEquals(false, IsManaged(nil), 'IsManaged for nil');
 end;
 
+procedure TTestCase1.TestInterface;
+var
+  context: TRttiContext;
+  t: TRttiType;
+begin
+  context := TRttiContext.Create;
+  try
+    t := context.GetType(TypeInfo(IInterface));
+    Check(t is TRttiInterfaceType, 'Type is not an interface type');
+
+    t := context.GetType(TypeInfo(ITestInterface));
+    Check(t is TRttiInterfaceType, 'Type is not an interface type');
+  finally
+    context.Free;
+  end;
+end;
+
+{$ifdef fpc}
+procedure TTestCase1.TestInterfaceRaw;
+var
+  context: TRttiContext;
+  t: TRttiType;
+begin
+  context := TRttiContext.Create;
+  try
+    t := context.GetType(TypeInfo(ICORBATest));
+    Check(t is TRttiInterfaceType, 'Type is not a raw interface type');
+  finally
+    context.Free;
+  end;
+end;
+{$endif}
+
 initialization
 {$ifdef fpc}
   RegisterTest(TTestCase1);