Browse Source

* due to different result handling of integers and interfaces, GetInterfaceProp cannot use GetOrdProp, resolves #21684

git-svn-id: trunk@20857 -
florian 13 years ago
parent
commit
4c472a1569
3 changed files with 56 additions and 6 deletions
  1. 1 0
      .gitattributes
  2. 28 6
      rtl/objpas/typinfo.pp
  3. 27 0
      tests/webtbs/tw21684.pp

+ 1 - 0
.gitattributes

@@ -12353,6 +12353,7 @@ tests/webtbs/tw21592.pp svneol=native#text/pascal
 tests/webtbs/tw21593.pp svneol=native#text/pascal
 tests/webtbs/tw2163.pp svneol=native#text/plain
 tests/webtbs/tw21674.pp svneol=native#text/pascal
+tests/webtbs/tw21684.pp svneol=native#text/pascal
 tests/webtbs/tw2176.pp svneol=native#text/plain
 tests/webtbs/tw2177.pp svneol=native#text/plain
 tests/webtbs/tw2178.pp svneol=native#text/plain

+ 28 - 6
rtl/objpas/typinfo.pp

@@ -1222,16 +1222,38 @@ begin
   Result:=GetInterfaceProp(Instance,FindPropInfo(Instance,PropName));
 end;
 
-function GetInterfaceProp(Instance: TObject; PropInfo: PPropInfo): IInterface;
 
+function GetInterfaceProp(Instance: TObject; PropInfo: PPropInfo): IInterface;
+type
+  TGetInterfaceProc=function:IInterface of object;
+  TGetInterfaceProcIndex=function(index:longint):IInterface of object;
+var
+  TypeInfo: PTypeInfo;
+  AMethod : TMethod;
 begin
-{$ifdef cpu64}
-  Result:=IInterface(GetInt64Prop(Instance,PropInfo));
-{$else cpu64}
-  Result:=IInterface(PtrInt(GetOrdProp(Instance,PropInfo)));
-{$endif cpu64}
+  Result:=nil;
+
+  TypeInfo := PropInfo^.PropType;
+  case (PropInfo^.PropProcs) and 3 of
+    ptfield:
+      Result:=IInterface(PPointer(Pointer(Instance)+PtrUInt(PropInfo^.GetProc))^);
+    ptstatic,
+    ptvirtual :
+      begin
+        if (PropInfo^.PropProcs and 3)=ptStatic then
+          AMethod.Code:=PropInfo^.GetProc
+        else
+          AMethod.Code:=PPointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.GetProc))^;
+        AMethod.Data:=Instance;
+        if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
+          Result:=TGetInterfaceProcIndex(AMethod)(PropInfo^.Index)
+        else
+          Result:=TGetInterfaceProc(AMethod)();
+      end;
+  end;
 end;
 
+
 procedure SetInterfaceProp(Instance: TObject; const PropName: string; const Value: IInterface);
 
 begin

+ 27 - 0
tests/webtbs/tw21684.pp

@@ -0,0 +1,27 @@
+{$mode delphi}{$H+}{$M+}
+
+uses
+  Classes, SysUtils,
+  typinfo;
+
+type
+  { TTest }
+  TTest = class
+  private
+    function GetX: IUnknown ;
+  published
+    property X: IUnknown read GetX;
+  end;
+
+function TTest.GetX: IUnknown;
+begin
+  Result := TInterfacedPersistent.Create;
+end;
+
+var
+  V: IUnknown;
+  FT: TTest;
+begin
+  FT := TTest.Create;
+  V := GetInterfaceProp(FT, 'X');
+end.