I'm trying to invoke a constructor obtained via RTTI (running D2010 version 14.0.3593.25826). The constructor takes a mixture of strings and objects as its arguments, all of which should be initialized to '' or nil. (Disclaimer: I know that the desired constructor will be the one with maximum number of parameters, hence the weird-looking, although suboptimal design.)
The code goes as follows:
program sb_rtti;
{$APPTYPE CONSOLE}
uses RTTI, TypInfo, SysUtils;
type
TMyClass = class (TObject)
FField1: string;
FObject1: TObject;
public
constructor Create(Field1: string = ''; Object1: TObject = nil);
end;
constructor TMyClass.Create(Field1: string; Object1: TObject);
begin
FField1 := Field1;
FObject1 := Object1;
end;
function GetConstructor(rType: TRttiType) : TRttiMethod;
var
MaxParams: integer;
Methods: TArray<TRttiMethod>;
Method: TRttiMethod;
Params: TArray<TRttiParameter>;
begin
Methods := rType.GetMethods('Create');
MaxParams := 0;
for Method in Methods do begin
Params := Method.GetParameters();
if (Length(Params) > MaxParams) then begin
Result := Method;
MaxParams := Length(Params);
end;
end;
end;
procedure InitializeParam(Param: TRttiParameter; ActualParam: TValue);
begin
if (Param.ParamType.TypeKind = TTypeKind.tkClass) then begin
ActualParam := TValue.From<TObject>(nil);
end else if (Param.ParamType.TypeKind = TTypeKind.tkString) then begin
ActualParam := TValue.From<string>('');
end else if (Param.ParamType.TypeKind = TTypeKind.tkUString) then begin
ActualParam := TValue.From<UnicodeString>('');
end else begin
// Other types goes here
end;
end;
var
Context: TRttiContext;
Constr: TRttiMethod;
Params: TArray<TRttiParameter>;
ResultValue: TValue;
rType: TRttiType;
ActualParams: array of TValue;
i: integer;
CurrentParam: TRttiParameter;
begin
Context := TRttiContext.Create();
rType := Context.GetType(TypeInfo(TMyClass));
Constr := GetConstructor(rType);
try
if (Constr <> nil) then begin
Params := Constr.GetParameters();
SetLength(ActualParams, Length(Params));
for i := 0 to Length(Params) - 1 do begin
CurrentParam := Params[i] as TRttiParameter;
InitializeParam(CurrentParam, ActualParams[i]);
end;
ResultValue := Constr.Invoke(rType.AsInstance.MetaclassType, ActualParams);
end;
except
on E : Exception do
WriteLn(E.ToString);
end;
ReadLn;
end.
Now, when the line ResultValue := Constr.Invoke(rType.AsInstance.MetaclassType, ActualParams); is executed, an EInvalidCast exception is raised. The exception may be traced to the TValue.Cast-method at line 1336.
However, the meat of the problem seems to be found at the previous point in the call stack, more precisely at line 4093 in rtti.pas (argList[currArg] := Args[i].Cast(parList[i].ParamType.Handle);).
My bet is that I'm using rtti in ways I'm not supposed to, yet, I can't find the "right way" described anywhere. Can anybody please point me in the right direction? Thanks!
You have a problem in the InitializeParam procedure because in the assignment of the ActualParam parameter, you are setting the value of the local copy of that parameter – remember that TValue (the type of ActualParam) is a record. So to fix the problem you must pass the ActualParam as a var parameter.
procedure InitializeParam(Param: TRttiParameter; var ActualParam: TValue);
It just occurred to me to hard-code the argument initialization by replacing
for i := 0 to Length(Params) - 1 do begin
CurrentParam := Params[i] as TRttiParameter;
InitializeParam(CurrentParam, ActualParams[i]);
end;
with
ActualParams[0] := TValue.From<string>('');
ActualParams[1] := TValue.From<TObject>(nil);
which solves the problem.
Related
I am using Delphi 10.1 Berlin update 2. Following is the code that reproduces the problem:
uses
System.SysUtils,
Rtti;
type
TEnum = (t1, t2);
TIndexedEnum = (to1=1, to2);
TClass1 = class
constructor Create(pEnum: TEnum);
end;
TClass2 = class
constructor Create(pEnum: TIndexedEnum);
end;
constructor TClass1.Create(pEnum: TEnum);
begin
end;
constructor TClass2.Create(pEnum: TIndexedEnum);
begin
end;
function MethodParamCount(pMethodName: String; pClass: TClass): Integer;
var
rContext: TRttiContext;
rType: TRttiType;
FMethods: TArray<TRttiMethod>;
I: Integer;
begin
rContext := TRttiContext.Create;
rType := rContext.GetType(pClass);
FMethods := rType.GetMethods;
for I := Low(FMethods) to High(FMethods) do
if SameText(pMethodName, FMethods[I].Name) then
begin
Result := Length(FMethods[I].GetParameters);
Exit;
end;
Result := -1;
end;
begin
WriteLn(IntToStr(MethodParamCount('Create', TClass1))); // Prints 1
WriteLn(IntToStr(MethodParamCount('Create', TClass2))); // Prints 0
ReadLn;
end.
Is that a bug of the RTTI implementation, or I am missing something? Is there a way to circumvent this issue without changing the class implementation?
Edit: I want to find a constructor without any parameters so I can call it using Invoke(). The thing is, RTTI is telling me there are no parameters for a method that actually has a parameter.
I don't understand why this very simple code failed? I'm on Delphi Tokyo release 2.
{$APPTYPE CONSOLE}
uses
System.SysUtils,
System.Generics.Collections;
procedure Main;
var
aQueue: TQueue<TBytes>;
aBytes: TBytes;
begin
aQueue := TQueue<TBytes>.create;
aBytes := TEncoding.UTF8.GetBytes('abcd');
aQueue.Enqueue(aBytes);
aBytes := aQueue.Dequeue;
Writeln(Length(aBytes)); // outputs 4 as expected
aBytes := TEncoding.UTF8.GetBytes('abcd');
aQueue.Enqueue(aBytes);
aBytes := aQueue.Dequeue;
Writeln(Length(aBytes)); // outputs 0
end;
begin
Main;
Readln;
end.
Is this a bug?
NOTE: The code works correctly on XE4, but fails also on Berlin.
This is indeed a bug. The code works correctly in XE7, but not XE8. In XE8 the output is 0 for both attempts.
Certainly the XE8 generic collections were very buggy and subsequent releases fixed many of the defects. Clearly not all have been fixed.
In XE8 Embarcadero attempted to address the issue of generic bloat caused by weaknesses in their compile/link model. Unfortunately, instead of tackling the problem at the root, they chose instead to address the issue in the library code for generic collections. Doing so they completely broke many of the generic collection classes, proving that their unit testing was weak. And of course, by addressing the problem this way they failed to address the issue of generic bloat for classes other than those in the generic collections. All in all, a sorry story that is seemingly still not over.
loki has just submitted a bug report: RSP-20400.
Note that this bug report is incorrect because (at least according to Stefan Glienke) the bug has been fixed in Tokyo 10.2.3. So upgrading to 10.2.3 should be the simplest way to resolve the problem.
Perhaps this bug report is more appropriate: RSP-17728.
Writing a generic queue isn't even difficult. Here's one that is known to work:
type
TQueue<T> = class
private
FItems: TArray<T>;
FCount: Integer;
FFront: Integer;
private
function Extract(Index: Integer): T; inline;
function GetBack: Integer; inline;
property Back: Integer read GetBack;
property Front: Integer read FFront;
procedure Grow;
procedure RetreatFront; inline;
public
property Count: Integer read FCount;
procedure Clear;
procedure Enqueue(const Value: T);
function Dequeue: T;
function Peek: T;
public
type
TEnumerator = record
private
FCollection: TQueue<T>;
FCount: Integer;
FCapacity: Integer;
FIndex: Integer;
FStartIndex: Integer;
public
class function New(Collection: TQueue<T>): TEnumerator; static;
function GetCurrent: T;
property Current: T read GetCurrent;
function MoveNext: Boolean;
end;
public
function GetEnumerator: TEnumerator;
end;
function GrownCapacity(OldCapacity: Integer): Integer;
var
Delta: Integer;
begin
if OldCapacity>64 then begin
Delta := OldCapacity div 4
end else if OldCapacity>8 then begin
Delta := 16
end else begin
Delta := 4;
end;
Result := OldCapacity + Delta;
end;
{ TQueue<T> }
function TQueue<T>.Extract(Index: Integer): T;
begin
Result := FItems[Index];
if IsManagedType(T) then begin
Finalize(FItems[Index]);
end;
end;
function TQueue<T>.GetBack: Integer;
begin
Result := Front + Count - 1;
if Result>high(FItems) then begin
dec(Result, Length(FItems));
end;
end;
procedure TQueue<T>.Grow;
var
Index: Integer;
Value: T;
Capacity: Integer;
NewItems: TArray<T>;
begin
Capacity := Length(FItems);
if Count=Capacity then begin
SetLength(NewItems, GrownCapacity(Capacity));
Index := 0;
for Value in Self do begin
NewItems[Index] := Value;
inc(Index);
end;
FItems := NewItems;
FFront := 0;
end;
end;
procedure TQueue<T>.RetreatFront;
begin
inc(FFront);
if FFront=Length(FItems) then begin
FFront := 0;
end;
end;
procedure TQueue<T>.Clear;
begin
FItems := nil;
FCount := 0;
end;
procedure TQueue<T>.Enqueue(const Value: T);
begin
Grow;
inc(FCount);
FItems[Back] := Value;
end;
function TQueue<T>.Dequeue: T;
var
Index: Integer;
begin
Assert(Count>0);
Result := Extract(Front);
RetreatFront;
dec(FCount);
end;
function TQueue<T>.Peek: T;
begin
Assert(Count>0);
Result := FItems[Front];
end;
function TQueue<T>.GetEnumerator: TEnumerator;
begin
Result := TEnumerator.New(Self);
end;
{ TQueue<T>.TEnumerator }
class function TQueue<T>.TEnumerator.New(Collection: TQueue<T>): TEnumerator;
begin
Result.FCollection := Collection;
Result.FCount := Collection.Count;
Result.FCapacity := Length(Collection.FItems);
Result.FIndex := -1;
Result.FStartIndex := Collection.Front;
end;
function TQueue<T>.TEnumerator.GetCurrent: T;
var
ActualIndex: Integer;
begin
ActualIndex := (FStartIndex + FIndex) mod FCapacity;
Result := FCollection.FItems[ActualIndex];
end;
function TQueue<T>.TEnumerator.MoveNext: Boolean;
begin
inc(FIndex);
Result := FIndex<FCount;
end;
To add to David's answer, the bug is in the Enqueue method. The top branch should be handling all reference counted managed types.
if IsManagedType(T) then
if (SizeOf(T) = SizeOf(Pointer)) and (GetTypeKind(T) <> tkRecord) then
FQueueHelper.InternalEnqueueMRef(Value, GetTypeKind(T))
else
FQueueHelper.InternalEnqueueManaged(Value)
else
But here we see that dynamic arrays are conspicuously missing in InternalEnqueueMref, which falls through without doing anything:
procedure TQueueHelper.InternalEnqueueMRef(const Value; Kind: TTypeKind);
begin
case Kind of
TTypeKind.tkUString: InternalEnqueueString(Value);
TTypeKind.tkInterface: InternalEnqueueInterface(Value);
{$IF not Defined(NEXTGEN)}
TTypeKind.tkLString: InternalEnqueueAnsiString(Value);
TTypeKind.tkWString: InternalEnqueueWideString(Value);
{$ENDIF}
{$IF Defined(AUTOREFCOUNT)}
TTypeKind.tkClass: InternalEnqueueObject(Value);
{$ENDIF}
end;
end;
It's so egregious, in fact, that the compiler actually produces no code for Enqueue when compiled (other than preamble) since the futility of the exercise can be determined from the types at compile time.
Project1.dpr.15: aQueue.Enqueue(aBytes);
0043E19E 8B45F8 mov eax,[ebp-$08]
0043E1A1 8945F4 mov [ebp-$0c],eax
0043E1A4 8B45FC mov eax,[ebp-$04]
0043E1A7 83C008 add eax,$08
0043E1AA 8945F0 mov [ebp-$10],eax
Project1.dpr.16: aBytes := aQueue.Dequeue;
0043E1AD 8D45EC lea eax,[ebp-$14]
This bug, therefore, would be expected to affect TQueue<T> for T being any type of dynamic array.
I have 2 years old project which I am rebooting back to life. I have debug window which shows different information, and one part of them is that it serializes various google protobuf objects and shows them.
Here is how typical protobuf class looks like:
// Generated by the protocol buffer compiler. DO NOT EDIT!
// Source: message.proto
unit Poker.Protobufs.Objects.PingParams;
interface
uses
System.SysUtils,
{$IFNDEF FPC} System.Generics.Collections {$ELSE} Contnrs {$ENDIF},
pbOutput, Poker.Protobufs.Objects.Base, Poker.Protobufs.Reader, Poker.Types;
type
TPB_PingParams = class(TProtobufBaseObject)
private
const
kUptimeFieldNumber = 1;
var
FUptime: UInt32;
FHasBits: UINT32;
procedure set_has_Uptime;
procedure clear_has_Uptime;
procedure SetUptime(const AValue: UInt32);
public
constructor Create(const AFrom: TPB_PingParams; const ALightweight: Boolean = FALSE); overload;
destructor Destroy; override;
procedure LoadFromProtobufReader(const AProtobufReader: TProtobufReader; const ASize: Integer); override;
procedure MergeFrom(const AFrom: TPB_PingParams);
procedure Clear;
function IsInitialized: Boolean; override;
// required uint32 Uptime = 1;
function has_Uptime: Boolean;
procedure clear_Uptime;
property Uptime: UInt32 read FUptime write SetUptime;
end;
TPB_PingParamsList = class(TObjectList<TPB_PingParams>)
procedure Assign(const APB_PingParamsList: TList<TPB_PingParams>);
end;
implementation
uses
pbPublic;
constructor TPB_PingParams.Create(const AFrom: TPB_PingParams; const ALightweight: Boolean = FALSE);
begin
inherited Create(ALightweight);
MergeFrom(AFrom);
end;
destructor TPB_PingParams.Destroy;
begin
inherited;
end;
procedure TPB_PingParams.LoadFromProtobufReader(const AProtobufReader: TProtobufReader; const ASize: Integer);
var
tag, field_number, wire_type, endpos: Integer;
begin
endpos := AProtobufReader.getPos + ASize;
while (AProtobufReader.getPos < endpos) and
(AProtobufReader.GetNext(tag, wire_type, field_number)) do
case field_number of
kUptimeFieldNumber: begin
Assert(wire_type = WIRETYPE_VARINT);
FUptime := AProtobufReader.readUInt32;
set_has_Uptime;
end;
else
AProtobufReader.skipField(tag);
end;
end;
procedure TPB_PingParams.MergeFrom(const AFrom: TPB_PingParams);
begin
if AFrom.has_Uptime then
SetUptime(AFrom.Uptime);
end;
function TPB_PingParams.IsInitialized: Boolean;
begin
if (FHasBits and $1) <> $1 then
Exit(FALSE);
Exit(TRUE);
end;
procedure TPB_PingParams.clear_Uptime;
begin
FUptime := 0;
clear_has_Uptime;
end;
function TPB_PingParams.has_Uptime: Boolean;
begin
result := (FHasBits and 1) > 0;
end;
procedure TPB_PingParams.set_has_Uptime;
begin
FHasBits := FHasBits or 1;
end;
procedure TPB_PingParams.clear_has_Uptime;
begin
FHasBits := FHasBits and not 1;
end;
procedure TPB_PingParams.SetUptime(const AValue: UInt32);
begin
if not Lightweight then
Assert(not has_Uptime);
FUptime := AValue;
if not Lightweight then
ProtobufOutput.writeUInt32(kUptimeFieldNumber, AValue);
set_has_Uptime;
end;
procedure TPB_PingParams.Clear;
begin
if FHasBits = 0 then
Exit;
clear_Uptime;
end;
procedure TPB_PingParamsList.Assign(const APB_PingParamsList: TList<TPB_PingParams>);
var
pbobj: TPB_PingParams;
begin
Clear;
for pbobj in APB_PingParamsList do
Add(TPB_PingParams.Create(pbobj, TRUE));
end;
end.
And my serialization function:
function SerializeObject(const AObject: TObject): String;
var
t: TRttiType;
p: TRttiProperty;
properties: TArray<TRttiProperty>;
method: TRttiMethod;
begin
result := '';
if not Assigned(AObject) then
Exit;
t := TRttiContext.Create.GetType(AObject.ClassType);
properties := t.GetProperties;
for p in properties do
begin
method := t.GetMethod(Format('has_%s', [p.Name]));
if (Assigned(method)) and
(method.Invoke(AObject, []).AsBoolean) then
result := result + Format('%s: %s; ', [p.Name, ValueToStr(p, p.GetValue(AObject))]);
end;
end;
It is specifically designed to serialize fields that begin with has_ in protobuf objects. Now, I didn't change anything in the code over last 2 years, and this was working before. But now it doesn't. Line properties = t.GetProperties returns empty array for my protobuf classes.
My guess is that I had some globally defined compiler directive which allowed me to serialize public methods in the class. But I cannot figure out which one.
If I put {$M+} in front of my protobuf classes, and move methods to published, it works (kinda). But this worked before just like it is shown in the sources, without any {$M+} directives or similar. So I'm curious what I miss.
Compiler is same as before, XE2.
The extended RTTI has the GetDeclaredProperties function which is exactly what i need, however i faced problems if i use the extended RTTI in multi-threading.
Therefore, i used GetPropList, but this gives me a list of all properties - not only published in the current class (or explicit stated).
i.e.
TBaseSettings = class(TPersistent)
published
property Charset: string read FCharset write FCharset;
end;
TBasicSettings = class(TBaseSettings)
published
property forums: Variant read fforums write fforums;
end;
TConcreteSettings = class(TBasicSettings)
published
property forums; // <-- make it explicit visible: OK
property prefix: Variant read fprefix write fprefix; // <-- OK
end;
I don't want to read the Charset property.
My first guess was to use a modified version of https://stackoverflow.com/a/1565686 to check for inheritance, but actually the forums property is also inherited.
Maybe this is not possible with the classic RTTI? I use Delphi 2010.
In case it's convenient to have your code calling GetDeclaredPropList in a similar way to calling GetPropList, see below.
Edit: I've rewritten the code in Delphi 7 and I believe it should work in Delphi 2010, too (which I don't have at hand).
type
PPropData = ^TPropData;
function AfterString(P: Pointer): Pointer;
begin
Result := Pointer(NativeUInt(P) + (PByte(P)^ + 1));
end;
function GetPropData(TypeData: PTypeData): PPropData;
begin
Result := AfterString(#TypeData^.UnitName);
end;
function NextPropInfo(PropInfo: PPropInfo): PPropInfo;
begin
Result := AfterString(#PropInfo^.Name);
end;
procedure GetDeclaredPropInfos(TypeInfo: PTypeInfo; PropList: PPropList);
var
TypeData: PTypeData;
PropData: PPropData;
PropInfo: PPropInfo;
I: Integer;
begin
TypeData := GetTypeData(TypeInfo);
PropData := GetPropData(TypeData);
FillChar(PropList^, Sizeof(PPropInfo) * PropData^.PropCount, 0);
PropInfo := PPropInfo(#PropData^.PropList);
for I := 0 to PropData^.PropCount - 1 do
begin
PropList^[I] := PropInfo;
PropInfo := NextPropInfo(PropInfo);
end;
end;
function GetDeclaredPropList(TypeInfo: PTypeInfo; out PropList: PPropList): Integer; overload;
begin
Result := GetPropData(GetTypeData(TypeInfo))^.PropCount;
if Result > 0 then
begin
GetMem(PropList, Result * SizeOf(Pointer));
GetDeclaredPropInfos(TypeInfo, PropList);
end;
end;
function GetDeclaredPropList(AObject: TObject; out PropList: PPropList): Integer; overload;
begin
Result := GetDeclaredPropList(PTypeInfo(AObject.ClassInfo), PropList);
end;
// example usage:
var
I, Count: Integer;
PropList: PPropList;
PropInfo: PPropInfo;
begin
Count := GetDeclaredPropList(TypeInfo(TConcreteSettings), PropList);
try
for I := 0 to Count - 1 do
begin
PropInfo := PropList^[I];
Writeln(PropInfo^.Name);
end;
finally
FreeMem(PropList);
end;
end.
var
TypeData: PTypeData;
PropData: PPropData;
PropInfo: PPropInfo;
I: Integer;
begin
TypeData := GetTypeData(TypeInfo(TConcreteSettings));
PropData := GetPropData(TypeData);
if Assigned(PropData) then
begin
PropInfo := #PropData^.PropList;
for I := 0 to PropData^.PropCount - 1 do
begin
Writeln(PropInfo^.Name);
PropInfo := NextPropInfo(PropInfo);
end;
end;
end;
For implementation of GetPropData and NextPropInfo see my other answer above.
I have a procedure that needs to insert an array of TObjects into to a list. The list can be of any of the supported types, e.g. TObjectList, TObjectList<T>, TROArray, etc.
The procedure looks like this:
type
TObjectArray = Array of TObject;
...
procedure TMyClass.DoAssignObjectList(const ObjectArray: TObjectArray;
const DstList: TObject);
var
i: Integer;
begin
if DstList is TObjectList then
begin
for i := 0 to pred(TObjectList(DstList).Count) do
TObjectList(DstList).Add(ObjectArray[i]);
end else
if DstList is TObjectList<T> then // Obviously this doesn't work
begin
for i := 0 to pred(TObjectList<T>(DstList).Count) do
TObjectList<T>(DstList).Add(ObjectArray[i]);
end
else
begin
raise Exception.CreateFmt(StrNoDoAssignORMObject, [DstList.ClassName]);
end;
end;
How can I check that an object is a TObjectList<T> and then add the elements of an array to it?
You have to use a bit RTTI to get some more information about the generic type.
The following code uses Spring4D which has some methods for that:
uses
...
Spring.Reflection;
procedure DoAssignObjectList(const ObjectArray: TObjectArray;
const DstList: TObject);
function IsGenericTObjectList(const obj: TObject): Boolean;
var
t: TRttiType;
begin
t := TType.GetType(obj.ClassInfo);
Result := t.IsGenericType and (t.GetGenericTypeDefinition = 'TObjectList<>');
end;
begin
...
if IsGenericTObjectList(DstList) then
begin
for i := 0 to pred(TObjectList<TObject>(DstList).Count) do
TObjectList<TObject>(DstList).Add(ObjectArray[i]);
...
end;
Additionally to that you can also get information about the generic parameter type of the list to check if the objects you are putting into it are matching the requirements (only works on a generic type of course):
function GetGenericTObjectListParameter(const obj: TObject): TClass;
var
t: TRttiType;
begin
t := TType.GetType(obj.ClassInfo);
Result := t.GetGenericArguments[0].AsInstance.MetaclassType;
end;
As I was writing this question I figured out a way to do this using RTTI. It should work with any list that has a procedure Add(AObject: TObject).
procedure TransferArrayItems(const Instance: TObject;
const ObjectArray: TObjectArray);
const
AddMethodName = 'Add';
var
Found: Boolean;
LMethod: TRttiMethod;
LIndex: Integer;
LParams: TArray<TRttiParameter>;
i: Integer;
RTTIContext: TRttiContext;
RttiType: TRttiType;
begin
Found := False;
LMethod := nil;
if length(ObjectArray) > 0 then
begin
RTTIContext := TRttiContext.Create;
RttiType := RTTIContext.GetType(Instance.ClassInfo);
for LMethod in RttiType.GetMethods do
begin
if SameText(LMethod.Name, AddMethodName) then
begin
LParams := LMethod.GetParameters;
if length(LParams) = 1 then
begin
Found := TRUE;
for LIndex := 0 to length(LParams) - 1 do
begin
if LParams[LIndex].ParamType.Handle <> TValue(ObjectArray[0]).TypeInfo
then
begin
Found := False;
Break;
end;
end;
end;
if Found then
Break;
end;
end;
if Found then
begin
for i := Low(ObjectArray) to High(ObjectArray) do
begin
LMethod.Invoke(Instance, [ObjectArray[i]]);
end;
end
else
begin
raise Exception.CreateFmt(StrMethodSNotFound, [AddMethodName]);
end;
end;
end;