mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-20 19:29:26 +02:00
* Use pointer get/set methods
git-svn-id: trunk@37496 -
This commit is contained in:
michael
parent
3d3bbcfa9c
commit
a3bcefd78c
@ -1403,6 +1403,7 @@ end;
|
||||
---------------------------------------------------------------------}
|
||||
|
||||
Function GetOrdProp(Instance : TObject;PropInfo : PPropInfo) : Int64;
|
||||
|
||||
type
|
||||
TGetInt64ProcIndex=function(index:longint):Int64 of object;
|
||||
TGetInt64Proc=function():Int64 of object;
|
||||
@ -1425,6 +1426,7 @@ begin
|
||||
Signed := false;
|
||||
DataSize := 4;
|
||||
case TypeInfo^.Kind of
|
||||
// We keep this for backwards compatibility, but internally it is no longer used.
|
||||
{$ifdef cpu64}
|
||||
tkInterface,
|
||||
tkInterfaceRaw,
|
||||
@ -1506,13 +1508,14 @@ begin
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
else
|
||||
raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]);
|
||||
end;
|
||||
end;
|
||||
|
||||
Resourcestring
|
||||
SErrCannotWriteToProperty = 'Cannot write to property %s.';
|
||||
|
||||
Procedure SetOrdProp(Instance : TObject;PropInfo : PPropInfo;Value : Int64);
|
||||
|
||||
type
|
||||
TSetInt64ProcIndex=procedure(index:longint;i:Int64) of object;
|
||||
TSetInt64Proc=procedure(i:Int64) of object;
|
||||
@ -1692,6 +1695,73 @@ begin
|
||||
SetOrdProp(Instance,PropInfo,StringToSet(PropInfo,Value));
|
||||
end;
|
||||
|
||||
{ ---------------------------------------------------------------------
|
||||
Pointer properties - internal only
|
||||
---------------------------------------------------------------------}
|
||||
|
||||
Function GetPointerProp(Instance: TObject; PropInfo : PPropInfo): Pointer;
|
||||
|
||||
Type
|
||||
TGetPointerProcIndex = function (index:longint): Pointer of object;
|
||||
TGetPointerProc = function (): Pointer of object;
|
||||
|
||||
var
|
||||
AMethod : TMethod;
|
||||
|
||||
begin
|
||||
case (PropInfo^.PropProcs) and 3 of
|
||||
ptField:
|
||||
Result := PPointer(Pointer(Instance) + LongWord(PropInfo^.GetProc))^;
|
||||
ptStatic,
|
||||
ptVirtual:
|
||||
begin
|
||||
if (PropInfo^.PropProcs and 3)=ptStatic then
|
||||
AMethod.Code:=PropInfo^.GetProc
|
||||
else
|
||||
AMethod.Code:=PCodePointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.GetProc))^;
|
||||
AMethod.Data:=Instance;
|
||||
if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
|
||||
Result:=TGetPointerProcIndex(AMethod)(PropInfo^.Index)
|
||||
else
|
||||
Result:=TGetPointerProc(AMethod)();
|
||||
end;
|
||||
else
|
||||
raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]);
|
||||
end;
|
||||
end;
|
||||
|
||||
Procedure SetPointerProp(Instance: TObject; PropInfo : PPropInfo; Value: Pointer);
|
||||
|
||||
type
|
||||
TSetPointerProcIndex = procedure(index: longint; p: pointer) of object;
|
||||
TSetPointerProc = procedure(p: pointer) of object;
|
||||
|
||||
var
|
||||
AMethod : TMethod;
|
||||
|
||||
begin
|
||||
case (PropInfo^.PropProcs shr 2) and 3 of
|
||||
ptField:
|
||||
PPointer(Pointer(Instance) + LongWord(PropInfo^.SetProc))^:=Value;
|
||||
ptStatic,
|
||||
ptVirtual:
|
||||
begin
|
||||
if ((PropInfo^.PropProcs shr 2) and 3)=ptStatic then
|
||||
AMethod.Code:=PropInfo^.SetProc
|
||||
else
|
||||
AMethod.Code:=PCodePointer(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;
|
||||
else
|
||||
raise EPropertyError.CreateFmt(SErrCannotWriteToProperty, [PropInfo^.Name]);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
{ ---------------------------------------------------------------------
|
||||
Object properties
|
||||
---------------------------------------------------------------------}
|
||||
@ -1716,11 +1786,7 @@ end;
|
||||
|
||||
Function GetObjectProp(Instance: TObject; PropInfo : PPropInfo; MinClass: TClass): TObject;
|
||||
begin
|
||||
{$ifdef cpu64}
|
||||
Result:=TObject(GetInt64Prop(Instance,PropInfo));
|
||||
{$else cpu64}
|
||||
Result:=TObject(PtrInt(GetOrdProp(Instance,PropInfo)));
|
||||
{$endif cpu64}
|
||||
Result:=TObject(GetPointerProp(Instance,PropInfo));
|
||||
If (MinClass<>Nil) and (Result<>Nil) Then
|
||||
If Not Result.InheritsFrom(MinClass) then
|
||||
Result:=Nil;
|
||||
@ -1734,12 +1800,9 @@ end;
|
||||
|
||||
|
||||
Procedure SetObjectProp(Instance: TObject; PropInfo : PPropInfo; Value: TObject);
|
||||
|
||||
begin
|
||||
{$ifdef cpu64}
|
||||
SetInt64Prop(Instance,PropInfo,Int64(Value));
|
||||
{$else cpu64}
|
||||
SetOrdProp(Instance,PropInfo,PtrInt(Value));
|
||||
{$endif cpu64}
|
||||
SetPointerProp(Instance,PropInfo,Pointer(Value));
|
||||
end;
|
||||
|
||||
|
||||
@ -1748,6 +1811,7 @@ begin
|
||||
Result:=GetTypeData(FindPropInfo(Instance,PropName,[tkClass])^.PropType)^.ClassType;
|
||||
end;
|
||||
|
||||
|
||||
Function GetObjectPropClass(AClass: TClass; const PropName: string): TClass;
|
||||
begin
|
||||
Result:=GetTypeData(FindPropInfo(AClass,PropName,[tkClass])^.PropType)^.ClassType;
|
||||
@ -1789,6 +1853,8 @@ begin
|
||||
else
|
||||
Result:=TGetInterfaceProc(AMethod)();
|
||||
end;
|
||||
else
|
||||
raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]);
|
||||
end;
|
||||
end;
|
||||
|
||||
@ -1800,11 +1866,14 @@ begin
|
||||
end;
|
||||
|
||||
procedure SetInterfaceProp(Instance: TObject; PropInfo: PPropInfo; const Value: IInterface);
|
||||
|
||||
type
|
||||
TSetIntfStrProcIndex=procedure(index:longint;const i:IInterface) of object;
|
||||
TSetIntfStrProc=procedure(i:IInterface) of object;
|
||||
|
||||
var
|
||||
AMethod : TMethod;
|
||||
|
||||
begin
|
||||
case Propinfo^.PropType^.Kind of
|
||||
tkInterface:
|
||||
@ -1848,11 +1917,7 @@ 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}
|
||||
Result:=GetPointerProp(Instance,PropInfo);
|
||||
end;
|
||||
|
||||
procedure SetRawInterfaceProp(Instance: TObject; const PropName: string; const Value: Pointer);
|
||||
@ -1862,38 +1927,9 @@ begin
|
||||
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:=PCodePointer(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;
|
||||
else
|
||||
raise EPropertyError.CreateFmt(SErrCannotWriteToProperty, [PropInfo^.Name]);
|
||||
end;
|
||||
end;
|
||||
tkInterface:
|
||||
Raise Exception.Create('Cannot set interface from RAW interface');
|
||||
end;
|
||||
SetPointerProp(Instance,PropInfo,Value);
|
||||
end;
|
||||
|
||||
{ ---------------------------------------------------------------------
|
||||
@ -1906,14 +1942,17 @@ begin
|
||||
end;
|
||||
|
||||
function GetDynArrayProp(Instance: TObject; PropInfo: PPropInfo): Pointer;
|
||||
|
||||
type
|
||||
{ we need a dynamic array as that type is usually passed differently from
|
||||
a plain pointer }
|
||||
TDynArray=array of Byte;
|
||||
TGetDynArrayProc=function:TDynArray of object;
|
||||
TGetDynArrayProcIndex=function(index:longint):TDynArray of object;
|
||||
|
||||
var
|
||||
AMethod : TMethod;
|
||||
|
||||
begin
|
||||
Result:=nil;
|
||||
if PropInfo^.PropType^.Kind<>tkDynArray then
|
||||
@ -1934,6 +1973,8 @@ begin
|
||||
else
|
||||
Result:=Pointer(TGetDynArrayProc(AMethod)());
|
||||
end;
|
||||
else
|
||||
raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]);
|
||||
end;
|
||||
end;
|
||||
|
||||
@ -1943,14 +1984,17 @@ begin
|
||||
end;
|
||||
|
||||
procedure SetDynArrayProp(Instance: TObject; PropInfo: PPropInfo; const Value: Pointer);
|
||||
|
||||
type
|
||||
{ we need a dynamic array as that type is usually passed differently from
|
||||
a plain pointer }
|
||||
TDynArray=array of Byte;
|
||||
TSetDynArrayProcIndex=procedure(index:longint;const i:TDynArray) of object;
|
||||
TSetDynArrayProc=procedure(i:TDynArray) of object;
|
||||
|
||||
var
|
||||
AMethod: TMethod;
|
||||
|
||||
begin
|
||||
if PropInfo^.PropType^.Kind<>tkDynArray then
|
||||
Exit;
|
||||
@ -1980,13 +2024,16 @@ end;
|
||||
---------------------------------------------------------------------}
|
||||
|
||||
Function GetStrProp(Instance: TObject; PropInfo: PPropInfo): AnsiString;
|
||||
|
||||
type
|
||||
TGetShortStrProcIndex=function(index:longint):ShortString of object;
|
||||
TGetShortStrProc=function():ShortString of object;
|
||||
TGetAnsiStrProcIndex=function(index:longint):AnsiString of object;
|
||||
TGetAnsiStrProc=function():AnsiString of object;
|
||||
|
||||
var
|
||||
AMethod : TMethod;
|
||||
|
||||
begin
|
||||
Result:='';
|
||||
case Propinfo^.PropType^.Kind of
|
||||
@ -2012,6 +2059,8 @@ begin
|
||||
else
|
||||
Result:=TGetShortStrProc(AMethod)();
|
||||
end;
|
||||
else
|
||||
raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]);
|
||||
end;
|
||||
end;
|
||||
tkAString:
|
||||
@ -2032,6 +2081,8 @@ begin
|
||||
else
|
||||
Result:=TGetAnsiStrProc(AMethod)();
|
||||
end;
|
||||
else
|
||||
raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
@ -2039,13 +2090,16 @@ end;
|
||||
|
||||
|
||||
Procedure SetStrProp(Instance : TObject;PropInfo : PPropInfo; const Value : AnsiString);
|
||||
|
||||
type
|
||||
TSetShortStrProcIndex=procedure(index:longint;const s:ShortString) of object;
|
||||
TSetShortStrProc=procedure(const s:ShortString) of object;
|
||||
TSetAnsiStrProcIndex=procedure(index:longint;s:AnsiString) of object;
|
||||
TSetAnsiStrProc=procedure(s:AnsiString) of object;
|
||||
|
||||
var
|
||||
AMethod : TMethod;
|
||||
|
||||
begin
|
||||
case Propinfo^.PropType^.Kind of
|
||||
tkWString:
|
||||
@ -2096,8 +2150,6 @@ begin
|
||||
raise EPropertyError.CreateFmt(SErrCannotWriteToProperty, [PropInfo^.Name]);
|
||||
end;
|
||||
end;
|
||||
else
|
||||
raise EPropertyError.CreateFmt(SErrCannotWriteToProperty, [PropInfo^.Name]);
|
||||
end;
|
||||
end;
|
||||
|
||||
@ -2157,6 +2209,8 @@ begin
|
||||
else
|
||||
Result:=TGetWideStrProc(AMethod)();
|
||||
end;
|
||||
else
|
||||
raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
@ -2201,23 +2255,28 @@ begin
|
||||
end;
|
||||
|
||||
Function GetUnicodeStrProp(Instance: TObject; const PropName: string): UnicodeString;
|
||||
|
||||
begin
|
||||
Result:=GetUnicodeStrProp(Instance, FindPropInfo(Instance, PropName));
|
||||
end;
|
||||
|
||||
|
||||
procedure SetUnicodeStrProp(Instance: TObject; const PropName: string; const Value: UnicodeString);
|
||||
|
||||
begin
|
||||
SetUnicodeStrProp(Instance,FindPropInfo(Instance,PropName),Value);
|
||||
end;
|
||||
|
||||
|
||||
Function GetUnicodeStrProp(Instance: TObject; PropInfo: PPropInfo): UnicodeString;
|
||||
|
||||
type
|
||||
TGetUnicodeStrProcIndex=function(index:longint):UnicodeString of object;
|
||||
TGetUnicodeStrProc=function():UnicodeString of object;
|
||||
|
||||
var
|
||||
AMethod : TMethod;
|
||||
|
||||
begin
|
||||
Result:='';
|
||||
case Propinfo^.PropType^.Kind of
|
||||
@ -2243,6 +2302,8 @@ begin
|
||||
else
|
||||
Result:=TGetUnicodeStrProc(AMethod)();
|
||||
end;
|
||||
else
|
||||
raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
@ -2250,11 +2311,14 @@ end;
|
||||
|
||||
|
||||
Procedure SetUnicodeStrProp(Instance: TObject; PropInfo: PPropInfo; const Value: UnicodeString);
|
||||
|
||||
type
|
||||
TSetUnicodeStrProcIndex=procedure(index:longint;s:UnicodeString) of object;
|
||||
TSetUnicodeStrProc=procedure(s:UnicodeString) of object;
|
||||
|
||||
var
|
||||
AMethod : TMethod;
|
||||
|
||||
begin
|
||||
case Propinfo^.PropType^.Kind of
|
||||
tkSString,tkAString:
|
||||
@ -2291,8 +2355,10 @@ function GetRawbyteStrProp(Instance: TObject; PropInfo: PPropInfo): RawByteStrin
|
||||
type
|
||||
TGetRawByteStrProcIndex=function(index:longint): RawByteString of object;
|
||||
TGetRawByteStrProc=function():RawByteString of object;
|
||||
|
||||
var
|
||||
AMethod : TMethod;
|
||||
|
||||
begin
|
||||
Result:='';
|
||||
case Propinfo^.PropType^.Kind of
|
||||
@ -2320,6 +2386,8 @@ begin
|
||||
else
|
||||
Result:=TGetRawByteStrProc(AMethod)();
|
||||
end;
|
||||
else
|
||||
raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
@ -2335,8 +2403,10 @@ procedure SetRawByteStrProp(Instance: TObject; PropInfo: PPropInfo; const Value:
|
||||
type
|
||||
TSetRawByteStrProcIndex=procedure(index:longint;s:RawByteString) of object;
|
||||
TSetRawByteStrProc=procedure(s:RawByteString) of object;
|
||||
|
||||
var
|
||||
AMethod : TMethod;
|
||||
|
||||
begin
|
||||
case Propinfo^.PropType^.Kind of
|
||||
tkWString:
|
||||
@ -2369,11 +2439,11 @@ begin
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure SetRawByteStrProp(Instance: TObject; const PropName: string; const Value: RawByteString);
|
||||
|
||||
begin
|
||||
SetRawByteStrProp(Instance,FindPropInfo(Instance,PropName),Value);
|
||||
|
||||
end;
|
||||
|
||||
|
||||
@ -2385,6 +2455,7 @@ end;
|
||||
---------------------------------------------------------------------}
|
||||
|
||||
function GetFloatProp(Instance : TObject;PropInfo : PPropInfo) : Extended;
|
||||
|
||||
type
|
||||
TGetExtendedProc = function:Extended of object;
|
||||
TGetExtendedProcIndex = function(Index: integer): Extended of object;
|
||||
@ -2394,8 +2465,10 @@ type
|
||||
TGetSingleProcIndex = function(Index: integer):Single of object;
|
||||
TGetCurrencyProc = function : Currency of object;
|
||||
TGetCurrencyProcIndex = function(Index: integer) : Currency of object;
|
||||
|
||||
var
|
||||
AMethod : TMethod;
|
||||
|
||||
begin
|
||||
Result:=0.0;
|
||||
case PropInfo^.PropProcs and 3 of
|
||||
@ -2443,11 +2516,14 @@ begin
|
||||
Result:=TGetCurrencyProcIndex(AMethod)(PropInfo^.Index);
|
||||
end;
|
||||
end;
|
||||
else
|
||||
raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
Procedure SetFloatProp(Instance : TObject;PropInfo : PPropInfo; Value : Extended);
|
||||
|
||||
type
|
||||
TSetExtendedProc = procedure(const AValue: Extended) of object;
|
||||
TSetExtendedProcIndex = procedure(Index: integer; AValue: Extended) of object;
|
||||
@ -2457,8 +2533,10 @@ type
|
||||
TSetSingleProcIndex = procedure(Index: integer; AValue: Single) of object;
|
||||
TSetCurrencyProc = procedure(const AValue: Currency) of object;
|
||||
TSetCurrencyProcIndex = procedure(Index: integer; AValue: Currency) of object;
|
||||
|
||||
Var
|
||||
AMethod : TMethod;
|
||||
|
||||
begin
|
||||
case (PropInfo^.PropProcs shr 2) and 3 of
|
||||
ptfield:
|
||||
@ -2535,12 +2613,15 @@ end;
|
||||
|
||||
|
||||
Function GetMethodProp(Instance : TObject;PropInfo : PPropInfo) : TMethod;
|
||||
|
||||
type
|
||||
TGetMethodProcIndex=function(Index: Longint): TMethod of object;
|
||||
TGetMethodProc=function(): TMethod of object;
|
||||
|
||||
var
|
||||
value: PMethod;
|
||||
AMethod : TMethod;
|
||||
|
||||
begin
|
||||
Result.Code:=nil;
|
||||
Result.Data:=nil;
|
||||
@ -2564,16 +2645,21 @@ begin
|
||||
else
|
||||
Result:=TGetMethodProc(AMethod)();
|
||||
end;
|
||||
else
|
||||
raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
Procedure SetMethodProp(Instance : TObject;PropInfo : PPropInfo; const Value : TMethod);
|
||||
|
||||
type
|
||||
TSetMethodProcIndex=procedure(index:longint;p:TMethod) of object;
|
||||
TSetMethodProc=procedure(p:TMethod) of object;
|
||||
|
||||
var
|
||||
AMethod : TMethod;
|
||||
|
||||
begin
|
||||
case (PropInfo^.PropProcs shr 2) and 3 of
|
||||
ptField:
|
||||
@ -2629,8 +2715,8 @@ end;
|
||||
|
||||
Procedure SetVariantProp(Instance : TObject;PropInfo : PPropInfo; const Value: Variant);
|
||||
begin
|
||||
CheckVariantEvent(CodePointer(OnSetVariantProp));
|
||||
OnSetVariantProp(Instance,PropInfo,Value);
|
||||
CheckVariantEvent(CodePointer(OnSetVariantProp));
|
||||
OnSetVariantProp(Instance,PropInfo,Value);
|
||||
end;
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user