Rtti accessing fields and properties in complex data structures - delphi

As already discussed in Rtti data manipulation and consistency in Delphi 2010 a consistency between the original data and rtti values can be reached by accessing members by using a pair of TRttiField and an instance pointer. This would be very easy in case of a simple class with only basic member types (like e.g. integers or strings).
But what if we have structured field types?
Here is an example:
TIntArray = array [0..1] of Integer;
TPointArray = array [0..1] of Point;
TExampleClass = class
private
FPoint : TPoint;
FAnotherClass : TAnotherClass;
FIntArray : TIntArray;
FPointArray : TPointArray;
public
property Point : TPoint read FPoint write FPoint;
//.... and so on
end;
For an easy access of Members I want to buil a tree of member-nodes, which provides an interface for getting and setting values, getting attributes, serializing/deserializing values and so on.
TMemberNode = class
private
FMember : TRttiMember;
FParent : TMemberNode;
FInstance : Pointer;
public
property Value : TValue read GetValue write SetValue; //uses FInstance
end;
So the most important thing is getting/setting the values, which is done - as stated before - by using the GetValue and SetValue functions of TRttiField.
So what is the Instance for FPoint members? Let's say Parent is the Node for TExample class, where the instance is known and the member is a field, then Instance would be:
FInstance := Pointer (Integer (Parent.Instance) + TRttiField (FMember).Offset);
But what if I want to know the Instance for a record property? There is no offset in this case. So is there a better solution to get a pointer to the data?
For the FAnotherClass member, the Instance would be:
FInstance := Parent.Value.AsObject;
So far the solution works, and data manipulation can be done by using rtti or the original types, without losing information.
But things get harder, when working with arrays. Especially the second array of Points. How can I get the instance for the members of points in this case?

TRttiField.GetValue where the field's type is a value type gets you a copy. This is by design. TValue.MakeWithoutCopy is for managing reference counts on things like interfaces and strings; it is not for avoiding this copy behaviour. TValue is intentionally not designed to mimic Variant's ByRef behaviour, where you can end up with references to (e.g.) stack objects inside a TValue, increasing the risk of stale pointers. It would also be counter-intuitive; when you say GetValue, you should expect a value, not a reference.
Probably the most efficient way to manipulate values of value types when they are stored inside other structures is to step back and add another level of indirection: by calculating offsets rather than working with TValue directly for all the intermediary value typed steps along the path to the item.
This can be encapsulated fairly trivially. I spent the past hour or so writing up a little TLocation record which uses RTTI to do this:
type
TLocation = record
Addr: Pointer;
Typ: TRttiType;
class function FromValue(C: TRttiContext; const AValue: TValue): TLocation; static;
function GetValue: TValue;
procedure SetValue(const AValue: TValue);
function Follow(const APath: string): TLocation;
procedure Dereference;
procedure Index(n: Integer);
procedure FieldRef(const name: string);
end;
function GetPathLocation(const APath: string; ARoot: TLocation): TLocation; forward;
{ TLocation }
type
PPByte = ^PByte;
procedure TLocation.Dereference;
begin
if not (Typ is TRttiPointerType) then
raise Exception.CreateFmt('^ applied to non-pointer type %s', [Typ.Name]);
Addr := PPointer(Addr)^;
Typ := TRttiPointerType(Typ).ReferredType;
end;
procedure TLocation.FieldRef(const name: string);
var
f: TRttiField;
begin
if Typ is TRttiRecordType then
begin
f := Typ.GetField(name);
Addr := PByte(Addr) + f.Offset;
Typ := f.FieldType;
end
else if Typ is TRttiInstanceType then
begin
f := Typ.GetField(name);
Addr := PPByte(Addr)^ + f.Offset;
Typ := f.FieldType;
end
else
raise Exception.CreateFmt('. applied to type %s, which is not a record or class',
[Typ.Name]);
end;
function TLocation.Follow(const APath: string): TLocation;
begin
Result := GetPathLocation(APath, Self);
end;
class function TLocation.FromValue(C: TRttiContext; const AValue: TValue): TLocation;
begin
Result.Typ := C.GetType(AValue.TypeInfo);
Result.Addr := AValue.GetReferenceToRawData;
end;
function TLocation.GetValue: TValue;
begin
TValue.Make(Addr, Typ.Handle, Result);
end;
procedure TLocation.Index(n: Integer);
var
sa: TRttiArrayType;
da: TRttiDynamicArrayType;
begin
if Typ is TRttiArrayType then
begin
// extending this to work with multi-dimensional arrays and non-zero
// based arrays is left as an exercise for the reader ... :)
sa := TRttiArrayType(Typ);
Addr := PByte(Addr) + sa.ElementType.TypeSize * n;
Typ := sa.ElementType;
end
else if Typ is TRttiDynamicArrayType then
begin
da := TRttiDynamicArrayType(Typ);
Addr := PPByte(Addr)^ + da.ElementType.TypeSize * n;
Typ := da.ElementType;
end
else
raise Exception.CreateFmt('[] applied to non-array type %s', [Typ.Name]);
end;
procedure TLocation.SetValue(const AValue: TValue);
begin
AValue.Cast(Typ.Handle).ExtractRawData(Addr);
end;
This type can be used to navigate locations within values using RTTI. To make it slightly easier to use, and slightly more fun for me to write, I also wrote a parser - the Follow method:
function GetPathLocation(const APath: string; ARoot: TLocation): TLocation;
{ Lexer }
function SkipWhite(p: PChar): PChar;
begin
while IsWhiteSpace(p^) do
Inc(p);
Result := p;
end;
function ScanName(p: PChar; out s: string): PChar;
begin
Result := p;
while IsLetterOrDigit(Result^) do
Inc(Result);
SetString(s, p, Result - p);
end;
function ScanNumber(p: PChar; out n: Integer): PChar;
var
v: Integer;
begin
v := 0;
while (p >= '0') and (p <= '9') do
begin
v := v * 10 + Ord(p^) - Ord('0');
Inc(p);
end;
n := v;
Result := p;
end;
const
tkEof = #0;
tkNumber = #1;
tkName = #2;
tkDot = '.';
tkLBracket = '[';
tkRBracket = ']';
var
cp: PChar;
currToken: Char;
nameToken: string;
numToken: Integer;
function NextToken: Char;
function SetToken(p: PChar): PChar;
begin
currToken := p^;
Result := p + 1;
end;
var
p: PChar;
begin
p := cp;
p := SkipWhite(p);
if p^ = #0 then
begin
cp := p;
currToken := tkEof;
Exit(currToken);
end;
case p^ of
'0'..'9':
begin
cp := ScanNumber(p, numToken);
currToken := tkNumber;
end;
'^', '[', ']', '.': cp := SetToken(p);
else
cp := ScanName(p, nameToken);
if nameToken = '' then
raise Exception.Create('Invalid path - expected a name');
currToken := tkName;
end;
Result := currToken;
end;
function Describe(tok: Char): string;
begin
case tok of
tkEof: Result := 'end of string';
tkNumber: Result := 'number';
tkName: Result := 'name';
else
Result := '''' + tok + '''';
end;
end;
procedure Expect(tok: Char);
begin
if tok <> currToken then
raise Exception.CreateFmt('Expected %s but got %s',
[Describe(tok), Describe(currToken)]);
end;
{ Semantic actions are methods on TLocation }
var
loc: TLocation;
{ Driver and parser }
begin
cp := PChar(APath);
NextToken;
loc := ARoot;
// Syntax:
// path ::= ( '.' <name> | '[' <num> ']' | '^' )+ ;;
// Semantics:
// '<name>' are field names, '[]' is array indexing, '^' is pointer
// indirection.
// Parser continuously calculates the address of the value in question,
// starting from the root.
// When we see a name, we look that up as a field on the current type,
// then add its offset to our current location if the current location is
// a value type, or indirect (PPointer(x)^) the current location before
// adding the offset if the current location is a reference type. If not
// a record or class type, then it's an error.
// When we see an indexing, we expect the current location to be an array
// and we update the location to the address of the element inside the array.
// All dimensions are flattened (multiplied out) and zero-based.
// When we see indirection, we expect the current location to be a pointer,
// and dereference it.
while True do
begin
case currToken of
tkEof: Break;
'.':
begin
NextToken;
Expect(tkName);
loc.FieldRef(nameToken);
NextToken;
end;
'[':
begin
NextToken;
Expect(tkNumber);
loc.Index(numToken);
NextToken;
Expect(']');
NextToken;
end;
'^':
begin
loc.Dereference;
NextToken;
end;
else
raise Exception.Create('Invalid path syntax: expected ".", "[" or "^"');
end;
end;
Result := loc;
end;
Here's an example type, and a routine (P) that manipulates it:
type
TPoint = record
X, Y: Integer;
end;
TArr = array[0..9] of TPoint;
TFoo = class
private
FArr: TArr;
constructor Create;
function ToString: string; override;
end;
{ TFoo }
constructor TFoo.Create;
var
i: Integer;
begin
for i := Low(FArr) to High(FArr) do
begin
FArr[i].X := i;
FArr[i].Y := -i;
end;
end;
function TFoo.ToString: string;
var
i: Integer;
begin
Result := '';
for i := Low(FArr) to High(FArr) do
Result := Result + Format('(%d, %d) ', [FArr[i].X, FArr[i].Y]);
end;
procedure P;
var
obj: TFoo;
loc: TLocation;
ctx: TRttiContext;
begin
obj := TFoo.Create;
Writeln(obj.ToString);
ctx := TRttiContext.Create;
loc := TLocation.FromValue(ctx, obj);
Writeln(loc.Follow('.FArr[2].X').GetValue.ToString);
Writeln(obj.FArr[2].X);
loc.Follow('.FArr[2].X').SetValue(42);
Writeln(obj.FArr[2].X); // observe value changed
// alternate syntax, not using path parser, but location destructive updates
loc.FieldRef('FArr');
loc.Index(2);
loc.FieldRef('X');
loc.SetValue(24);
Writeln(obj.FArr[2].X); // observe value changed again
Writeln(obj.ToString);
end;
The principle can be extended to other types and Delphi expression syntax, or TLocation may be changed to return new TLocation instances rather than destructive self-updates, or non-flat array indexing may be supported, etc.

You're touching a few concepts and problems with this question. First of all you've mixed in some record types and some properties, and I'd like to handle this first. Then I'll give you some short info on how to read the "Left" and "Top" fields of a record when that record is part of an field in a class... Then I'll give you suggestions on how to make this work generically. I'm probably going to explain a bit more then it's required, but it's midnight over here and I can't sleep!
Example:
TPoint = record
Top: Integer;
Left: Integer;
end;
TMyClass = class
protected
function GetMyPoint: TPoint;
procedure SetMyPoint(Value:TPoint);
public
AnPoint: TPoint;
property MyPoint: TPoint read GetMyPoint write SetMyPoint;
end;
function TMyClass.GetMyPoint:Tpoint;
begin
Result := AnPoint;
end;
procedure TMyClass.SetMyPoint(Value:TPoint);
begin
AnPoint := Value;
end;
Here's the deal. If you write this code, at runtime it will do what it seems to be doing:
var X:TMyClass;
x.AnPoint.Left := 7;
But this code will not work the same:
var X:TMyClass;
x.MyPoint.Left := 7;
Because that code is equivalent to:
var X:TMyClass;
var tmp:TPoint;
tmp := X.GetMyPoint;
tmp.Left := 7;
The way to fix this is to do something like this:
var X:TMyClass;
var P:TPoint;
P := X.MyPoint;
P.Left := 7;
X.MyPoint := P;
Moving on, you want to do the same with RTTI. You may get RTTI for both the "AnPoint:TPoint" field and for the "MyPoint:TPoint" field. Because using RTTI you're essentially using a function to get the value, you'll need do use the "Make local copy, change, write back" technique with both (the same kind of code as for the X.MyPoint example).
When doing it with RTTI we'll always start from the "root" (a TExampleClass instance, or a TMyClass instance) and use nothing but a series of Rtti GetValue and SetValue methods to get the value of the deep field or set the value of the same deep field.
We'll assume we have the following:
AnPointFieldRtti: TRttiField; // This is RTTI for the AnPoint field in the TMyClass class
LeftFieldRtti: TRttiField; // This is RTTI for the Left field of the TPoint record
We want to emulate this:
var X:TMyClass;
begin
X.AnPoint.Left := 7;
end;
We'll brake that into steps, we're aiming for this:
var X:TMyClass;
V:TPoint;
begin
V := X.AnPoint;
V.Left := 7;
X.AnPoint := V;
end;
Because we want to do it with RTTI, and we want it to work with anything, we will not use the "TPoint" type. So as expected we first do this:
var X:TMyClass;
V:TValue; // This will hide a TPoint value, but we'll pretend we don't know
begin
V := AnPointFieldRtti.GetValue(X);
end;
For the next step we'll use the GetReferenceToRawData to get a pointer to the TPoint record hidden in the V:TValue (you know, the one we pretend we know nothing about - except the fact it's a RECORD). Once we get a pointer to that record, we can call the SetValue method to move that "7" inside the record.
LeftFieldRtti.SetValue(V.GetReferenceToRawData, 7);
This is allmost it. Now we just need to move the TValue back into X:TMyClass:
AnPointFieldRtti.SetValue(X, V)
From head-to-tail it would look like this:
var X:TMyClass;
V:TPoint;
begin
V := AnPointFieldRtti.GetValue(X);
LeftFieldRtti.SetValue(V.GetReferenceToRawData, 7);
AnPointFieldRtti.SetValue(X, V);
end;
This can obviously be expanded to handle structures of any depth. Just remember that you need to do it step-by-step: The first GetValue uses the "root" instance, then the next GetValue uses an Instance that's extracted from the previous GetValue result. For records we may use TValue.GetReferenceToRawData, for objects we can use TValue.AsObject!
The next tricky bit is doing this in a generic way, so you can implement your bi-directional tree-like structure. For that, I'd recommend storing the path from "root" to your field in the form of an TRttiMember array (casting will then be used to find the actual runtype type, so we can call GetValue and SetValue). An node would look something like this:
TMemberNode = class
private
FMember : array of TRttiMember; // path from root
RootInstance:Pointer;
public
function GetValue:TValue;
procedure SetValue(Value:TValue);
end;
The implementation of GetValue is very simple:
function TMemberNode.GetValue:TValue;
var i:Integer;
begin
Result := FMember[0].GetValue(RootInstance);
for i:=1 to High(FMember) do
if FMember[i-1].FieldType.IsRecord then
Result := FMember[i].GetValue(Result.GetReferenceToRawData)
else
Result := FMember[i].GetValue(Result.AsObject);
end;
The implementation of SetValue would be a tiny little bit more involved. Because of those (pesky?) records we'll need to do everything the GetValue routine does (because we need the Instance pointer for the very last FMember element), then we'll be able to call SetValue, but we might need to call SetValue for it's parent, and then for it's parent's parent, and so on... This obviously means we need to KEEP all the intermediary TValue's intact, just in case we need them. So here we go:
procedure TMemberNode.SetValue(Value:TValue);
var Values:array of TValue;
i:Integer;
begin
if Length(FMember) = 1 then
FMember[0].SetValue(RootInstance, Value) // this is the trivial case
else
begin
// We've got an strucutred case! Let the fun begin.
SetLength(Values, Length(FMember)-1); // We don't need space for the last FMember
// Initialization. The first is being read from the RootInstance
Values[0] := FMember[0].GetValue(RootInstance);
// Starting from the second path element, but stoping short of the last
// path element, we read the next value
for i:=1 to Length(FMember)-2 do // we'll stop before the last FMember element
if FMember[i-1].FieldType.IsRecord then
Values[i] := FMember[i].GetValue(Values[i-1].GetReferenceToRawData)
else
Values[i] := FMember[i].GetValue(Values[i-1].AsObject);
// We now know the instance to use for the last element in the path
// so we can start calling SetValue.
if FMember[High(FMember)-1].FieldType.IsRecord then
FMember[High(FMember)].SetValue(Values[High(FMember)-1].GetReferenceToRawData, Value)
else
FMember[High(FMember)].SetValue(Values[High(FMember)-1].AsObject, Value);
// Any records along the way? Since we're dealing with classes or records, if
// something is not a record then it's a instance. If we reach a "instance" then
// we can stop processing.
i := High(FMember)-1;
while (i >= 0) and FMember[i].FieldType.IsRecord do
begin
if i = 0 then
FMember[0].SetValue(RootInstance, Values[0])
else
if FMember[i-1].FieldType.IsRecord then
FMember[i].SetValue(FMember[i-1].GetReferenceToRawData, Values[i])
else
FMember[i].SetValue(FMember[i-1].AsObject, Values[i]);
// Up one level (closer to the root):
Dec(i)
end;
end;
end;
... And this should be it. Now some warnings:
DON'T expect this to compile! I actually wrote every single bit of code in this post in the web browser. For technical reasons I had access to the Rtti.pas source file to look up method and field names, but I don't have access to an compiler.
I'd be VERY careful with this code, especially if PROPERTIES are involved. A property can be implemented without an backing field, the setter procedure might not do what you expect. You might run into circular references!

You seem to be misunderstanding the way an instance pointer works. You don't store a pointer to the field, you store a pointer to the class or the record that it's a field of. Object references are pointers already, so no casting is needed there. For records, you need to obtain a pointer to them with the # symbol.
Once you have your pointer, and a TRttiField object that refers to that field, you can call SetValue or GetValue on the TRttiField, and pass in your instance pointer, and it takes care of all the offset calculations for you.
In the specific case of arrays, GetValue it will give you a TValue that represents an array. You can test this by calling TValue.IsArray if you want. When you have a TValue that represents an array, you can get the length of the array with TValue.GetArrayLength and retrieve the individual elements with TValue.GetArrayElement.
EDIT: Here's how to deal with record members in a class.
Records are types too, and they have RTTI of their own. You can modify them without doing "GetValue, modify, SetValue" like this:
procedure ModifyPoint(example: TExampleClass; newXValue, newYValue: integer);
var
context: TRttiContext;
value: TValue;
field: TRttiField;
instance: pointer;
recordType: TRttiRecordType;
begin
field := context.GetType(TExampleClass).GetField('FPoint');
//TValue that references the TPoint
value := field.GetValue(example);
//Extract the instance pointer to the TPoint within your object
instance := value.GetReferenceToRawData;
//RTTI for the TPoint type
recordType := context.GetType(value.TypeInfo) as TRttiRecordType;
//Access the individual members of the TPoint
recordType.GetField('X').SetValue(instance, newXValue);
recordType.GetField('Y').SetValue(instance, newYValue);
end;
It looks like the part you didn't know about is TValue.GetReferenceToRawData. That will give you a pointer to the field, without you needing to worry about calculating offsets and casting pointers to integers.

Related

How to check the disposed record?

I want to know disposed record by pointer variable.
For example, I have the record like below and the global variables(T, P).
TTest = record
iA: Integer;
sA: string;
end;
pTest = ^TTest;
T: pTest;
P: Pointer;
And then call below procedure.
...
procedure TestCreate;
begin
New(T);
T^.iA := 100;
T^.sA := 'ABCD';
// 1.
P := T;
// 2.
Dispose(T);
// 3.
WriteLn( IntToStr(pTest(P)^.iA) );
// -> Show the 100
end;
Is there a way I can know with pointer 'P' that if record 'T' has been disposed?
There is no way to tell, from just the pointer alone, whether the value pointed to is still valid or not. It is not possible without some additional code to keep track of it somehow.
As a side note, I hope you know that you can work with records without involving pointers at all? For example:
type
TTest = record
iA: Integer;
sA: string;
end;
var
T: TTest;
begin
T.iA := 100;
T.sA := 'ABCD';

How do I check whether an array contains a particular value?

how do I correctly write this ?:
If number is different from Array[1] to Array[x-1] the begin......
where number is an integer and array is an array of integers from 1 to x
I believe you want to do something if number is not found in the array MyArray. Then you can do it like this:
NoMatch := True;
for i := Low(MyArray) to High(MyArray) do
if MyArray[i] = number then
begin
NoMatch := False;
Break;
end;
if NoMatch then
DoYourThing;
You could create a function that checks if a number is found in an array. Then you can use this function every time you need to perform such a check. And each time, the code will be more readable. For example, you could do it like this:
function IsNumberInArray(const ANumber: Integer;
const AArray: array of Integer): Boolean;
var
i: Integer;
begin
for i := Low(AArray) to High(AArray) do
if ANumber = AArray[i] then
Exit(True);
Result := False;
end;
...
if not IsNumberInArray(number, MyArray) then
DoYourThing;
If you use a old version of Delphi, you have to replace Exit(True) with begin Result := True; Exit; end. In newer versions of Delphi, I suppose you could also play with stuff like generics.
You could also write a Generic version, however you can't use generics with stand-alone procedures, they need to be bound to a class or record. Something like the following
unit Generics.ArrayUtils;
interface
uses
System.Generics.Defaults;
type
TArrayUtils<T> = class
public
class function Contains(const x : T; const anArray : array of T) : boolean;
end;
implementation
{ TArrayUtils<T> }
class function TArrayUtils<T>.Contains(const x: T; const anArray: array of T): boolean;
var
y : T;
lComparer: IEqualityComparer<T>;
begin
lComparer := TEqualityComparer<T>.Default;
for y in anArray do
begin
if lComparer.Equals(x, y) then
Exit(True);
end;
Exit(False);
end;
end.
usage would be
procedure TForm6.Button1Click(Sender: TObject);
begin
if TArrayUtils<integer>.Contains(3, [1,2,3]) then
ShowMessage('Yes')
else
ShowMessage('No');
end;
Should work with parameters like TArray<integer> or array of integer as well as constant arrays (shown) - and you could add many other methods to the class, such as IndexOf or Insert...
From Delphi 10.3 you can omit the <integer> due to type inferencing so would look like TArrayUtils.Contains(3, [1,2,3]).
I had the same question and solved it like this:
if value in myArray then
...
But as I needed to compare with specific values, I simply did:
if value in [0, 1, 2, 3] then
...

Is this the correct way to return an empty generic value?

I have a HashTable and I need some way to return a not_found result.
type
TCell<T> = record
.....
property key: cardinal read FKey write FKey;
property data: T read FData write FData;
end;
THashTable<T> = class(TEnumerable<T>)
private
FCells: array of TCell<T>;
FEmpty: T;
...
constructor Create(InitialSize: cardinal); overload;
function Lookup(key: cardinal): T;
...
end;
constructor THashTable<T>.Create(InitialSize: cardinal);
begin
inherited Create;
// Initialize regular cells
FArraySize:= InitialSize;
Assert((FArraySize and (FArraySize - 1)) = 0); // Must be a power of 2
SetLength(FCells, FArraySize);
FillChar(FEmpty, SizeOf(FEmpty), #0); //Superfluous I know, just there to
//demonstrate the point.
end;
Given the above structure, how do I return a not found result?
If I had pointers, I would return a nil pointer to T.
But pointers to generic types are not allowed.
So I've come up with the solution below:
function THashTable<T>.Lookup(key: cardinal): T;
var
Cell: NativeUInt;
begin
if (key <> 0) then begin
// Check regular cells
Cell:= First_Cell(IntegerHash(key));
while (true) do begin
if (FCells[Cell].key = key) then Exit(FCells[Cell].data);
if not (FCells[Cell].key = 0) then Exit(FEmpty); <<-- is this correct?
Cell:= Circular_Next(Cell);
end;
end else begin
Result:= FEmpty; <<--- Can I return an empty generic like this?
end;
end;
Can I return a zero-initialized generic to mean no result?
Or will I run into problems with structured types of (classes/records/variants/strings etc).
Note that I do understand the ambiguity when T is an integer. Zero might very well be a valid value and it would thus be indistinguishable from not_found.
I'm not worried about those results.
What you're looking for is default(T), which will return a zero value for any type T.
I would suggest changing the function to use an output var parameter for the data, then you can use a Boolean for the Result, eg:
function THashTable<T>.Lookup(key: cardinal; var Value: T): Boolean;
var
Cell: NativeUInt;
begin
Result := False;
if (key <> 0) then begin
// Check regular cells
Cell := First_Cell(IntegerHash(key));
while Cell <> -1 do begin
if (FCells[Cell].key = key) then begin
Value := FCells[Cell].data;
Exit(True);
end;
if (FCells[Cell].key <> 0) then Break;
Cell := Circular_Next(Cell);
end;
end;
end;
#S.MAHDI suggested that you could write this code:
Result := T(nil);
My initial reaction was that this would not compile because the cast is clearly invalid. For example, this code does not compile:
var
P: Pointer;
....
Result := T(P);
For that code the compiler reports: E2089 Invalid typecast.
But the assignment of T(nil) does compile. And when you look at the code generated, for all the cases I investigated, the code was identical to that generated for Default(T).
So, my conclusion is that this apparently undocumented syntax T(nil) is treated specially by the compiler in a generic context, and is an alias for Default(T).
I would be very interested to know if anyone can point to any official documentation for this feature.
I've decided to return a pointer to the generic type instead.
type
//P<T> = ^T;
P<T> = record {holding a pointer to T with some operator overloading}
....
FCells: array of T <<-- holds T directly now.
function THashTable<K,T>.Lookup(const key: K): P<T>;
begin
....
if found then Result:= #FCells[CorrectIndex]
else Result:= nil;
end;

How do I sort a generic list using a custom comparer?

I'm kinda a Delphi-newbie and I don't get how the Sort method of a TList of Records is called in order to sort the records by ascending integer value.
I have a record like the following:
type
TMyRecord = record
str1: string;
str2: string;
intVal: integer;
end;
And a generic list of such records:
TListMyRecord = TList<TMyRecord>;
Have tried to find a code-example in the help files and found this one:
MyList.Sort(#CompareNames);
Which I can't use, since it uses classes. So I tried to write my own compare function with a little different parameters:
function CompareIntVal(i1, i2: TMyRecord): Integer;
begin
Result := i1.intVal - i2.intVal;
end;
But the compiler always throws a 'not enough parameters' - error when I call it with open.Sort(CompareIntVal);, which seems obvious; so I tried to stay closer to the help file:
function SortKB(Item1, Item2: Pointer): Integer;
begin
Result:=PMyRecord(Item1)^.intVal - PMyRecord(Item2)^.intVal;
end;
with PMyRecord as PMyRecord = ^TMyRecord;
I have tried different ways of calling a function, always getting some error...
The Sort overload you should be using is this one:
procedure Sort(const AComparer: IComparer<TMyRecord>);
Now, you can create an IComparer<TMyRecord> by calling TComparer<TMyRecord>.Construct. Like this:
var
Comparison: TComparison<TMyRecord>;
....
Comparison :=
function(const Left, Right: TMyRecord): Integer
begin
Result := Left.intVal-Right.intVal;
end;
List.Sort(TComparer<TMyRecord>.Construct(Comparison));
I've written the Comparison function as an anonymous method, but you could also use a plain old style non-OOP function, or a method of an object.
One potential problem with your comparison function is that you may suffer from integer overflow. So you could instead use the default integer comparer.
Comparison :=
function(const Left, Right: TMyRecord): Integer
begin
Result := TComparer<Integer>.Default.Compare(Left.intVal, Right.intVal);
end;
It might be expensive to call TComparer<Integer>.Default repeatedly so you could store it away in a global variable:
var
IntegerComparer: IComparer<Integer>;
....
initialization
IntegerComparer := TComparer<Integer>.Default;
Another option to consider is to pass in the comparer when you create the list. If you only ever sort the list using this ordering then that's more convenient.
List := TList<TMyRecord>.Create(TComparer<TMyRecord>.Construct(Comparison));
And then you can sort the list with
List.Sort;
The concise answer:
uses
.. System.Generics.Defaults // Contains TComparer
myList.Sort(
TComparer<TMyRecord>.Construct(
function(const Left, Right: TMyRecord): Integer
begin
Result := Left.intVal - Right.intVal;
end
)
);
I want to share my solution (based on the input I have gathered here).
It's a standard setup. A filedata class that holds data of a single file in a generic TObjectList. The list has the two private attributes fCurrentSortedColumn and fCurrentSortAscending to control the sort order. The AsString-method is the path and filename combined.
function TFileList.SortByColumn(aColumn: TSortByColums): boolean;
var
Comparison: TComparison<TFileData>;
begin
result := false;
Comparison := nil;
case aColumn of
sbcUnsorted : ;
sbcPathAndName: begin
Comparison := function(const Left, Right: TFileData): integer
begin
Result := TComparer<string>.Default.Compare(Left.AsString,Right.AsString);
end;
end;
sbcSize : begin
Comparison := function(const Left, Right: TFileData): integer
begin
Result := TComparer<int64>.Default.Compare(Left.Size,Right.Size);
if Result = 0 then
Result := TComparer<string>.Default.Compare(Left.AsString,Right.AsString);
end;
end;
sbcDate : begin
Comparison := function(const Left, Right: TFileData): integer
begin
Result := TComparer<TDateTime>.Default.Compare(Left.Date,Right.Date);
if Result = 0 then
Result := TComparer<string>.Default.Compare(Left.AsString,Right.AsString);
end;
end;
sbcState : begin
Comparison := function(const Left, Right: TFileData): integer
begin
Result := TComparer<TFileDataTestResults>.Default.Compare(Left.FileDataResult,Right.FileDataResult);
if Result = 0 then
Result := TComparer<string>.Default.Compare(Left.AsString,Right.AsString);
end;
end;
end;
if assigned(Comparison) then
begin
Sort(TComparer<TFileData>.Construct(Comparison));
// Control the sort order
if fCurrentSortedColumn = aColumn then
fCurrentSortAscending := not fCurrentSortAscending
else begin
fCurrentSortedColumn := aColumn;
fCurrentSortAscending := true;
end;
if not fCurrentSortAscending then
Reverse;
result := true;
end;
end;
I found a much simpler modified sort function to alphabetize a TList of records or nonstandard list of items.
Example
PList = ^TContact;
TContact = record //Record for database of user contact records
firstname1 : string[20];
lastname1 : string[20];
phonemobile : Integer; //Fields in the database for contact info
phonehome : Integer;
street1 : string;
street2 : string;
type
TListSortCompare = function (Item1,
Item2: TContact): Integer;
var
Form1: TForm1;
Contact : PList; //declare record database for contacts
arecord : TContact;
Contacts : TList; //List for the Array of Contacts
function CompareNames(i1, i2: TContact): Integer;
begin
Result := CompareText(i1.lastname1, i2.lastname1) ;
end;
and the function to call to sort your list
Contacts.Sort(#CompareNames);

Delphi: how to set the length of a RTTI-accessed dynamic array using DynArraySetLength?

I'd like to set the length of a dynamic array, as suggested in this post. I have two classes TMyClass and the related TChildClass defined as
TChildClass = class
private
FField1: string;
FField2: string;
end;
TMyClass = class
private
FField1: TChildClass;
FField2: Array of TChildClass;
end;
The array augmentation is implemented as
var
RContext: TRttiContext;
RType: TRttiType;
Val: TValue; // Contains the TMyClass instance
RField: TRttiField; // A field in the TMyClass instance
RElementType: TRttiType; // The kind of elements in the dyn array
DynArr: TRttiDynamicArrayType;
Value: TValue; // Holding an instance as referenced by an array element
ArrPointer: Pointer;
ArrValue: TValue;
ArrLength: LongInt;
i: integer;
begin
RContext := TRTTIContext.Create;
try
RType := RContext.GetType(TMyClass.ClassInfo);
Val := RType.GetMethod('Create').Invoke(RType.AsInstance.MetaclassType, []);
RField := RType.GetField('FField2');
if (RField.FieldType is TRttiDynamicArrayType) then begin
DynArr := (RField.FieldType as TRttiDynamicArrayType);
RElementType := DynArr.ElementType;
// Set the new length of the array
ArrValue := RField.GetValue(Val.AsObject);
ArrLength := 3; // Three seems like a nice number
ArrPointer := ArrValue.GetReferenceToRawData;
DynArraySetLength(ArrPointer, ArrValue.TypeInfo, 1, #ArrLength);
{ TODO : Fix 'Index out of bounds' }
WriteLn(ArrValue.IsArray, ' ', ArrValue.GetArrayLength);
if RElementType.IsInstance then begin
for i := 0 to ArrLength - 1 do begin
Value := RElementType.GetMethod('Create').Invoke(RElementType.AsInstance.MetaclassType, []);
ArrValue.SetArrayElement(i, Value);
// This is just a test, so let's clean up immediatly
Value.Free;
end;
end;
end;
ReadLn;
Val.AsObject.Free;
finally
RContext.Free;
end;
end.
Being new to D2010 RTTI, I suspected the error could depend on getting ArrValue from the class instance, but the subsequent WriteLn prints "TRUE", so I've ruled that out. Disappointingly, however, the same WriteLn reports that the size of ArrValue is 0, which is confirmed by the "Index out of bounds"-exception I get when trying to set any of the elements in the array (through ArrValue.SetArrayElement(i, Value);). Do anyone know what I'm doing wrong here? (Or perhaps there is a better way to do this?) TIA!
Dynamic arrays are kind of tricky to work with. They're reference counted, and the following comment inside DynArraySetLength should shed some light on the problem:
// If the heap object isn't shared (ref count = 1), just resize it. Otherwise, we make a copy
Your object is holding one reference to it, and so is the TValue. Also, GetReferenceToRawData gives you a pointer to the array. You need to say PPointer(GetReferenceToRawData)^ to get the actual array to pass to DynArraySetLength.
Once you've got that, you can resize it, but you're left with a copy. Then you have to set it back onto the original array.
TValue.Make(#ArrPointer, dynArr.Handle, ArrValue);
RField.SetValue(val.AsObject, arrValue);
All in all, it's probably a lot simpler to just use a list instead of an array. With D2010 you've got Generics.Collections available, which means you can make a TList<TChildClass> or TObjectList<TChildClass> and have all the benefits of a list class without losing type safety.
I think you should define the array as a separate type:
TMyArray = array of TMyClass;
and use that.
From an old RTTI based XML serializer I know the general method that you use should work (D7..2009 tested):
procedure TXMLImpl.ReadArray(const Name: string; TypeInfo: TArrayInformation; Data: Pointer; IO: TParameterInputOutput);
var
P: PChar;
L, D: Integer;
BT: TTypeInformation;
begin
FArrayType := '';
FArraySize := -1;
ComplexTypePrefix(Name, '');
try
// Get the element type info.
BT := TypeInfo.BaseType;
if not Assigned(BT) then RaiseSerializationReadError; // Not a supported datatype!
// Typecheck the array specifier.
if (FArrayType <> '') and (FArrayType <> GetTypeName(BT)) then RaiseSerializationReadError;
// Do we have a fixed size array or a dynamically sized array?
L := FArraySize;
if L >= 0 then begin
// Set the array
DynArraySetLength(PPointer(Data)^,TypeInfo.TypeInformation,1,#L);
// And restore he elements
D := TypeInfo.ElementSize;
P := PPointer(Data)^;
while L > 0 do begin
ReadElement(''{ArrayItemName},BT,P,IO); // we allow any array item name.
Inc(P,D);
Dec(L);
end;
end else begin
RaiseNotSupported;
end;
finally
ComplexTypePostfix;
end;
end;
Hope this helps..

Resources