paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-04 17:50:19 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Fixed setting of RAW interfaces

Browse Source 
git-svn-id: trunk@17391 -
This commit is contained in:
michael 2011-05-02 19:16:53 +00:00
parent 90af29cda9
commit 7069db2194
1 changed files with 67 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
rtl/objpas/typinfo.pp
View File

@ -349,6 +349,11 @@ function GetInterfaceProp(Instance: TObject; PropInfo: PPropInfo): IInterface;
procedure SetInterfaceProp(Instance: TObject; const PropName: string; const Value: IInterface);
procedure SetInterfaceProp(Instance: TObject; PropInfo: PPropInfo; const Value: IInterface);
function GetRawInterfaceProp(Instance: TObject; const PropName: string): Pointer;
function GetRawInterfaceProp(Instance: TObject; PropInfo: PPropInfo): Pointer;
procedure SetRawInterfaceProp(Instance: TObject; const PropName: string; const Value: Pointer);
procedure SetRawInterfaceProp(Instance: TObject; PropInfo: PPropInfo; const Value: Pointer);
// Auxiliary routines, which may be useful
Function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
Function GetEnumValue(TypeInfo : PTypeInfo;const Name : string) : Integer;
@ -1261,6 +1266,68 @@ begin
end;
end;
end;
tkInterfaceRaw:
Raise Exception.Create('Cannot set RAW interface from IUnknown interface');
end;
end;
{ ---------------------------------------------------------------------
RAW (Corba) Interface wrapprers
---------------------------------------------------------------------}
function GetRawInterfaceProp(Instance: TObject; const PropName: string): Pointer;
begin
Result:=GetRawInterfaceProp(Instance,FindPropInfo(Instance,PropName));
end;
function GetRawInterfaceProp(Instance: TObject; PropInfo: PPropInfo): Pointer;
begin
{$ifdef cpu64}
Result:=Pointer(GetInt64Prop(Instance,PropInfo));
{$else cpu64}
Result:=Pointer(PtrInt(GetOrdProp(Instance,PropInfo)));
{$endif cpu64}
end;
procedure SetRawInterfaceProp(Instance: TObject; const PropName: string; const Value: Pointer);
begin
SetRawInterfaceProp(Instance,FindPropInfo(Instance,PropName),Value);
end;
procedure SetRawInterfaceProp(Instance: TObject; PropInfo: PPropInfo; const Value: Pointer);
type
TSetPointerProcIndex=procedure(index:longint;const i:Pointer) of object;
TSetPointerProc=procedure(i:Pointer) of object;
var
AMethod : TMethod;
begin
case Propinfo^.PropType^.Kind of
tkInterfaceRaw:
begin
case (PropInfo^.PropProcs shr 2) and 3 of
ptField:
PPointer(Pointer(Instance)+PtrUInt(PropInfo^.SetProc))^:=Value;
ptstatic,
ptvirtual :
begin
if ((PropInfo^.PropProcs shr 2) and 3)=ptStatic then
AMethod.Code:=PropInfo^.SetProc
else
AMethod.Code:=PPointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.SetProc))^;
AMethod.Data:=Instance;
if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
TSetPointerProcIndex(AMethod)(PropInfo^.Index,Value)
else
TSetPointerProc(AMethod)(Value);
end;
end;
end;
tkInterface:
Raise Exception.Create('Cannot set interface from RAW interface');
end;
end;