We're seeing an issue with Delphi XE where, at times, TRttiType.GetTypes returns an empty array. Other times, using the exact same code, the array contains the expected types. The error is occurring when marshalling/unmarshalling classes over DataSnap using TJSONMarshal and TJSONUnMarshal.
Any idea why the call to GetTypes in the unit below would return an empty array? (The $M directive should not be required. It is there as I've tried several brute-force approaches, including $STRONGLINKTYPES.)
unit uTest;
interface
uses
Classes;
type
{$M+}
TMyClass = class(TPersistent)
public
Value1 : Integer;
Value2 : String;
Value3 : Currency;
Value4 : Boolean;
Value5 : Double;
end;
procedure Test;
implementation
uses
Dialogs, Rtti, SysUtils;
procedure Test;
var
c: TRttiContext;
t: TRttiType;
a: TArray<TRttiField>;
begin
c := TRttiContext.Create;
t := c.GetType(TypeInfo(TMyClass));
if Assigned(t) then begin
a := t.GetFields;
ShowMessage(IntToStr(High(a)));
end
else
ShowMessage('TMyClass not found');
end;
procedure ForceReferenceToClass(C: TClass);
var
dummy: TObject;
begin
dummy := C.Create();
dummy.Free();
end;
initialization
ForceReferenceToClass(TMyClass);
end.
Thanks
Related
I wrote a simple console program to cast some RTTI magic:
program TypeCast;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils, System.RTTI, Generics.Collections;
type
TSpr = class
public
s: string;
i: Integer;
b: Boolean;
end;
var
Spr: TSpr;
vCtx: TRTTIContext;
vType: TRTTIType;
vField: TRTTIField;
Dict: TDictionary<string, TRTTIField>;
begin
try
Spr := TSpr.Create;
vType := vCtx.GetType(TSpr.ClassInfo);
Dict := TDictionary<string, TRTTIField>.Create;
for vField in vType.GetFields do
Dict.AddOrSetValue(vField.Name, vField);
Dict['s'].SetValue(Spr, 'Hello World!');
Dict['i'].SetValue(Spr, 123);
Dict['b'].SetValue(Spr, True);
Writeln(Spr.s);
Writeln(Spr.i);
Writeln(Spr.b);
Spr.Free;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
Readln;
end.
Output:
Hello World!
123
TRUE
If I compile and run this program, it works fine. But if I use such technique to forward variables of these types to object, defined in another package, it gets me into lot of troubles.
MCVE stuff / Steps To Reproduce:
...assuming you are starting from empty environment...
Create PluginInterface package. Add there UClassManager
unit UClassManager;
interface
uses
Classes, Contnrs;
type
TClassManager = class(TClassList);
function ClassManager: TClassManager;
implementation
var
Manager: TClassManager;
function ClassManager: TClassManager;
begin
Result := Manager;
end;
initialization
Manager := TClassManager.Create;
finalization
Manager.Free;
end.
and UPlugin units.
unit UPlugin;
interface
uses RTTI;
type
TPlugin = class
public
procedure Init; virtual; abstract;
function SetProp(Key: string; Value: TValue): Boolean; virtual; abstract;
end;
TPluginClass = class of TPlugin;
IPluginHost = interface
function RunPlugin(PluginName: string): TPlugin; // Run Plugin by it's ClassName
end;
var
Host: IPluginHost;
implementation
end.
Create VCL Forms Application, enable runtime packages, add reference to PluginInterface and add TButton onto it. Make these handlers for corresponding events:
procedure TForm1.FormCreate(Sender: TObject);
begin
LoadPackage('UniversalSpr.bpl');
Host := Self;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Plugin: TPlugin;
begin
Plugin := Host.RunPlugin('TSprPlugin');
Plugin.Init;
Plugin.SetProp('SprTableName', 'MATERIALS');
Plugin.SetProp('EditRights', True);
Plugin.SetProp('BeforePostValue1', 3);
end;
function TForm1.RunPlugin(PluginName: string): TPlugin;
var
I: Integer;
begin
Result := nil;
for I := 0 to ClassManager.Count - 1 do
if ClassManager[I].ClassNameIs(PluginName) then begin
Result := TPluginClass(ClassManager[I]).Create;
Break;
end;
end;
Of coarse, TForm1 should be descendant of IPluginHost. And don't forget to add UClassManager and UPlugin into uses clause. Other units will be added automatically by IDE.
Create package UniversalSpr and place it's output file into the same directory where your application is placed. Implement UPlugin inside TSprPlugin:
unit USprPlugin;
interface
uses
UPlugin, RTTI, Generics.Collections;
type
TSpr = class
SprTableName: string;
BeforePostValue1: int64;
EditRights: boolean;
end;
TSprPlugin = class(TPlugin)
procedure Init; override;
function SetProp(Key: string; Value: TValue): Boolean; override;
private
Spr: TSpr;
PropDict: TDictionary<string, TRTTIField>;
end;
implementation
procedure TSprPlugin.Init;
var
vCtx: TRTTIContext;
vType: TRTTIType;
vField: TRTTIField;
begin
if not Assigned(Spr) then
Spr := TSpr.Create;
vType := vCtx.GetType(Spr.ClassInfo);
if not Assigned(PropDict) then
PropDict := TDictionary<string, TRTTIField>.Create;
for vField in vType.GetFields do
PropDict.Add(vField.Name, vField);
end;
function TSprPlugin.SetProp(Key: string; Value: TValue): Boolean;
var
Field: TRTTIField;
begin
Result := PropDict.TryGetValue(Key, Field);
if Result then
// here I get Access Violation
Field.SetValue(Spr, Value);
end;
end.
After you click Button1, you can pass specified values into properties setter/mutator, but if you try to repeat my TypeCast trick inside the routine, you'll get Access Violation trying to access 00000004.
Also, investigation and advanced debugging shows that Field.FieldType evaluates correctly (which explains why InsufficientRTTI is not thrown), but if I want to get Field.Fieldtype.Handle, I get the infamous AV.
I can set the value just skipping Cast from original SetValue method:
function TSprPlugin.SetProp(Key: string; Value: TValue): Boolean;
var
Field: TRTTIField;
begin
Result := PropDict.TryGetValue(Key, Field);
if Result then
Value.ExtractRawData(PByte(Spr) + Field.Offset);
end;
Dalija recommended to avoid packages, I already took this into accout, that's why I created TypeCast to test RTTI. But I need packages, because of design of my application, I cannot just rewrite it to be monolythic. What can I do to avoid this Access Violation without abandoning packages?
Your current code has some issues regardless whether you use runtime packages or not. Your MCVE is not exactly minimal, and you have added too many steps from your working console application to your packaged code that does not work.
In debugging your issue you should have started from encapsulating logic into TSprPlugin class and testing that class directly without messing with runtime packages. When you are sure that TSprPlugin code functions properly, then you can add packages and see how it goes.
Right now your code fails with following simple test project
program test;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils,
USprPlugin in 'USprPlugin.pas',
UPlugin in 'UPlugin.pas';
var
Plugin: TPlugin;
begin
Plugin := TSprPlugin.Create;
Plugin.Init;
Plugin.SetProp('SprTableName', 'MATERIALS');
Plugin.SetProp('EditRights', True);
Plugin.SetProp('BeforePostValue1', 3);
end.
Moving vCtx from local variable to TSprPlugin field solves the issue for above test case.
unit USprPlugin;
interface
uses
UPlugin, RTTI, UniversalSprUnit, Generics.Collections;
type
TSprPlugin = class(TPlugin)
vCtx: TRTTIContext;
procedure Init; override;
function SetProp(Key: string; Value: TValue): Boolean; override;
private
Spr: TSpr;
PropDict: TDictionary<string, TRTTIField>;
end;
implementation
procedure TSprPlugin.Init;
var
vType: TRTTIType;
vField: TRTTIField;
begin
vCtx := TRttiContext.Create;
if not Assigned(Spr) then
Spr := TSpr.Create;
vType := vCtx.GetType(Spr.ClassInfo);
if not Assigned(PropDict) then
PropDict := TDictionary<string, TRTTIField>.Create;
for vField in vType.GetFields do
PropDict.Add(vField.Name, vField);
end;
function TSprPlugin.SetProp(Key: string; Value: TValue): Boolean;
var
Field: TRTTIField;
begin
Result := PropDict.TryGetValue(Key, Field);
if Result then
// here I get Access Violation
Field.SetValue(Spr, Value);
end;
end.
Starting from there you can add up additional functionality step by step ensuring that each step didn't break functionality.
Also, you are not releasing Spr and PropDict fields thus creating memory leak, but I am not sure if that code is not included just because it is not directly connected with issues you are having, or you are really having memory leak there.
In my library i'm invoking methods under specific conditions, which requires stdcall calling convention. Currently i'm using compiler static resolution, implemented as rather large list of well-known method signatures and corresponding overloaded versions of my subroutine. This works but looks quite fugly and doesnt 100% cover all possible methods. I would like to add a possibility to work with generic method pointer and assert proper calling convention by asking RTTI. And here i'm stuck, please advise.
Input: code/data pair of pointers as in TMethod
Output: boolean indicator, true if method is stdcall
I'd preferable use "classic" RTTI to create less version dependencies, however i cant find any calling convention indicator within "classic" RTTI...
NB: This question is UNRELATED to importing external functions
You can extract calling convention information from extended RTTI (available since Delphi 2010).
uses RTTI, TypInfo;
function GetMethCallConv(AMeth: TMethod; out Conv: TCallConv): Boolean;
var
Ctx: TRttiContext;
Meth: TRttiMethod;
Typ: TRttiType;
begin
Ctx:= TRttiContext.Create;
try
Typ:= Ctx.GetType(TObject(AMeth.Data).ClassType);
for Meth in Typ.GetMethods do begin
if Meth.CodeAddress = AMeth.Code then begin
Conv:= Meth.CallingConvention;
Exit(True);
end;
end;
Exit(False);
finally
Ctx.Free;
end;
end;
//test
type
TMyObj = class
public
procedure MyMeth(I: Integer); stdcall;
end;
procedure TMyObj.MyMeth(I: Integer);
begin
ShowMessage(IntToStr(I));
end;
procedure TForm2.Button2Click(Sender: TObject);
var
Conv: TCallConv;
Meth: TMethod;
MyObj: TMyObj;
begin
MyObj:= TMyObj.Create;
Meth.Code:= #TMyObj.MyMeth;
Meth.Data:= MyObj;
if GetMethCallConv(Meth, Conv) then begin
case Conv of
ccReg: ShowMessage('Register');
ccCdecl: ShowMessage('cdecl');
ccPascal: ShowMessage('Pascal');
ccStdCall: ShowMessage('StdCall');
ccSafeCall: ShowMessage('SafeCall');
end;
end;
MyObj.Free;
end;
Update
For "classic" RTTI read Sertac answer; the following works OK on Delphi 2010:
uses ObjAuto;
function GetMethCallConv2(AMeth: TMethod; out Conv: TCallingConvention): Boolean;
var
Methods: TMethodInfoArray;
I: Integer;
P: PMethodInfoHeader;
begin
Result:= False;
Methods:= GetMethods(TObject(AMeth.Data).ClassType);
if not Assigned(Methods) then Exit;
for I:= Low(Methods) to High(Methods) do begin
P:= Methods[I];
if P^.Addr = AMeth.Code then begin
Inc(Integer(P), SizeOf(TMethodInfoHeader) - SizeOf(ShortString) + 1 +
Length(PMethodInfoHeader(P)^.Name));
Conv:= PReturnInfo(P).CallingConvention;
Result:= True;
Exit;
end;
end;
end;
{$TYPEINFO ON}
{$METHODINFO ON}
type
TMyObj = class
public
procedure MyMeth(I: Integer);
end;
procedure TMyObj.MyMeth(I: Integer);
begin
ShowMessage(IntToStr(I));
end;
procedure TForm2.Button3Click(Sender: TObject);
var
Conv: TCallingConvention;
Meth: TMethod;
MyObj: TMyObj;
begin
MyObj:= TMyObj.Create;
Meth.Code:= #TMyObj.MyMeth;
Meth.Data:= MyObj;
if GetMethCallConv2(Meth, Conv) then begin
case Conv of
ccRegister: ShowMessage('Register');
ccCdecl: ShowMessage('cdecl');
ccPascal: ShowMessage('Pascal');
ccStdCall: ShowMessage('StdCall');
ccSafeCall: ShowMessage('SafeCall');
end;
end;
MyObj.Free;
end;
Including Delphi 7 and up, when METHODINFO directive is on, run-time generates information about, at least having public visibility, method parameters and return types and calling convention (TYPEINFO should also be on).
Not sure if the below sample would help you directly since it works on an instance and method's name and not its address, but perhaps you can construct a look-up table for name-address of methods beforehand.
type
{$METHODINFO ON}
TSomeClass = class
public
procedure Proc1(i: Integer; d: Double); stdcall;
procedure Proc2;
end;
{$METHODINFO OFF}
TForm1 = class(TForm)
Button1: TButton;
procedure FormCreate(Sender: TObject);
private
FSomeClass: TSomeClass;
..
uses
objauto;
procedure TForm1.FormCreate(Sender: TObject);
begin
FSomeClass := TSomeClass.Create;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Info: Pointer;
begin
Info := GetMethodInfo(FSomeClass, 'Proc1');
if Assigned(Info) then begin
Inc(Integer(Info), SizeOf(TMethodInfoHeader) - SizeOf(ShortString) + 1 +
Length(PMethodInfoHeader(Info).Name));
if PReturnInfo(Info).CallingConvention = ccStdCall then
// ...
end;
Beware and do some testing though, tested on D2007 the working is somewhat unpredictable. For instance, if the above 'Proc1' is changed to procedure Proc1(i: Pointer; d: Double); no detailed RTTI is generated.
See here on how to find out:
http://rvelthuis.de/articles/articles-convert.html#cconvs
IOW, you can simply try if it works, or you take a look at the exported name (_name#17 or similar) or you take a look at a disassembly, e.g. in the CPU view.
Summarization:
1. Manual typecast when debugging, as LachlanG and Ken pointed out.
2. Make use of the concept of Debugger Visualizers introduced since Delphi 2010.
3. Switch to generics counterparts.
=========================================
Take the following code for example:
If breakpoints are set at the end of TestRegular, and at the end of TestGenerics, respectively, one can see the items of the generic list(and even the content of the items) through the debug inspector, but nothing meaningful (not even the count) for the regular tobjectlist, when one hovers the mouse on the tmp variable. I am wondering if there is some way to achieve similar debug-time functionality for regular tobjectlist?
unit Unit2;
interface
uses
Contnrs, Generics.Collections,
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs;
type
TMyItem = class;
TMyItemList = class;
TForm2 = class;
TMyItem = class
private
fname: string;
public
property name: string read fname;
constructor Create(aName: string);
end;
TMyItemList = class(TObjectList)
protected
procedure SetObject (Index: Integer; Item: TMyItem);
function GetObject (Index: Integer): TMyItem;
public
function Add (Obj: TMyItem): Integer;
procedure Insert (Index: Integer; Obj: TMyItem);
property Objects [Index: Integer]: TMyItem
read GetObject write SetObject; default;
end;
TForm2 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
procedure TestRegular;
procedure TestGenerics;
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
{$R *.dfm}
{ TMyItem }
constructor TMyItem.Create(aName: string);
begin
fname := aName;
end;
{ TMyItemList }
function TMyItemList.Add(Obj: TMyItem): Integer;
begin
Result := inherited Add (Obj);
end;
procedure TMyItemList.SetObject(Index: Integer; Item: TMyItem);
begin
inherited SetItem (Index, Item);
end;
function TMyItemList.GetObject(Index: Integer): TMyItem;
begin
Result := inherited GetItem (Index) as TMyItem;
end;
procedure TMyItemList.Insert(Index: Integer; Obj: TMyItem);
begin
inherited Insert(Index, Obj);
end;
{TForm2}
procedure TForm2.FormCreate(Sender: TObject);
begin
TestGenerics;
TestRegular;
end;
procedure TForm2.TestRegular;
var
tmp: TMyItemList;
begin
tmp := TMyItemList.Create;
tmp.Add(TMyItem.Create('1'));
tmp.Add(TMyItem.Create('2'));
tmp.Free;
end;
procedure TForm2.TestGenerics;
var
tmp: TObjectList<TMyItem>;
begin
tmp := TObjectList<TMyItem>.Create;
tmp.Add(TMyItem.Create('1'));
tmp.Add(TMyItem.Create('2'));
tmp.Free;
end;
end.
I don't think you'll be able to improve what appear in the mouse cursor hover hint.
You can however use typecasts inside Debug windows just as you can within source code.
For example you could typecast the tmp variable to TObjectList(tmp) from within the Evaluation Window (Ctrl F7) or create a Watch (Ctrl F5) on the typecasted variable.
There are Debugger Visualizers that allow you to customise the debugger's visualization capabilities. I've never used them, but it is my understanding that you could combine them with some RTTI and give richer information about a TObject instance.
However, using generics is what you want here. It gives compile time typing which has manifest advantages. I'd simply do it that way.
I have a TList. It contains a collection of objects of the same type. These objects are descended from a TPersistent, and have about 50 different published properties.
In my application, the user can issue a search of these objects, and the results of the search are displayed in a TDrawGrid, with the specific columns displayed being based on the properties being searched. For example, if the user searches on 'invoice', an 'invoice' column is displayed in the results' grid. I would like to be able to let the user sort this grid. The kicker, of course, is that I wont know up front what columns are in the grid.
Normally to sort a TList, I'd just make a function, such as SortOnName( p1, p2), and call the TList's sort() method. I'd like to go one step further and find a way to pass a property name to the sort method and use RTTI to make the comparison.
I could, of course, make 50 different sort methods and just use that. Or, set a variable globally or as part of the class doing all this work to indicate to the sorting method what to sort on. But I was curious if any of the Delphi pro's out there had other ideas on how to implement this.
Delphi 7 version
Here's an example of how to achieve that. I used Delphi2010 to implement it but it should work in Delphi7 at least as I used TypInfo unit directly.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
ListBox1: TListBox;
Edit1: TEdit;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
FList: TList;
procedure DoSort(PropName: String);
procedure DoDisplay(PropName: String);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
TypInfo;
var
PropertyName: String;
type
TPerson = class
private
FName: String;
FAge: Integer;
published
public
constructor Create(Name: String; Age: Integer);
published
property Name: String read FName;
property Age: Integer read FAge;
end;
{ TPerson }
constructor TPerson.Create(Name: String; Age: Integer);
begin
FName := Name;
FAge := Age;
end;
function ComparePersonByPropertyName(P1, P2: Pointer): Integer;
var
propValueP1, propValueP2: Variant;
begin
propValueP1 := GetPropValue(P1, PropertyName, False);
propValueP2 := GetPropValue(P2, PropertyName, False);
if VarCompareValue(propValueP1, propValueP2) = vrEqual then begin
Result := 0;
end else if VarCompareValue(propValueP1, propValueP2) = vrGreaterThan then begin
Result := 1;
end else begin
Result := -1;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FList := TList.Create;
FList.Add(TPerson.Create('Zed', 10));
FList.Add(TPerson.Create('John', 20));
FList.Add(TPerson.Create('Mike', 30));
FList.Add(TPerson.Create('Paul', 40));
FList.Add(TPerson.Create('Albert', 50));
FList.Add(TPerson.Create('Barbara', 60));
FList.Add(TPerson.Create('Christian', 70));
Edit1.Text := 'Age';
DoSort('Age'); // Sort by age
DoDisplay('Age');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
DoSort(Edit1.Text);
DoDisplay(Edit1.Text);
end;
procedure TForm1.DoSort(PropName: String);
begin
PropertyName := PropName;
FList.Sort(ComparePersonByPropertyName);
end;
procedure TForm1.DoDisplay(PropName: String);
var
i: Integer;
strPropValue: String;
begin
ListBox1.Items.Clear;
for i := 0 to FList.Count - 1 do begin
strPropValue := GetPropValue(FList[i], PropName, False);
ListBox1.Items.Add(strPropValue);
end;
end;
end.
BTW, I used a simple form with a listbox, an edit and a button. The listbox shows the contents of the list (FList) sorted. The button is used to sort the list according to what the user has typed in the editbox.
Delphi 2010 version (uses references to methods)
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm2 = class(TForm)
ListBox1: TListBox;
Edit1: TEdit;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
FList: TList;
FPropertyName: String; { << }
procedure DoSort(PropName: String);
procedure DoDisplay(PropName: String);
function CompareObjectByPropertyName(P1, P2: Pointer): Integer; { << }
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
{$R *.dfm}
uses
TypInfo;
type
TPerson = class
private
FName: String;
FAge: Integer;
published
public
constructor Create(Name: String; Age: Integer);
published
property Name: String read FName;
property Age: Integer read FAge;
end;
{ TPerson }
constructor TPerson.Create(Name: String; Age: Integer);
begin
FName := Name;
FAge := Age;
end;
/// This version uses a method to do the sorting and therefore can use a field of the form,
/// no more ugly global variable.
/// See below (DoSort) if you want to get rid of the field also ;)
function TForm2.CompareObjectByPropertyName(P1, P2: Pointer): Integer; { << }
var
propValueP1, propValueP2: Variant;
begin
propValueP1 := GetPropValue(P1, FPropertyName, False);
propValueP2 := GetPropValue(P2, FPropertyName, False);
if VarCompareValue(propValueP1, propValueP2) = vrEqual then begin
Result := 0;
end else if VarCompareValue(propValueP1, propValueP2) = vrGreaterThan then begin
Result := 1;
end else begin
Result := -1;
end;
end;
procedure TForm2.FormCreate(Sender: TObject);
begin
FList := TList.Create;
FList.Add(TPerson.Create('Zed', 10));
FList.Add(TPerson.Create('John', 20));
FList.Add(TPerson.Create('Mike', 30));
FList.Add(TPerson.Create('Paul', 40));
FList.Add(TPerson.Create('Albert', 50));
FList.Add(TPerson.Create('Barbara', 60));
FList.Add(TPerson.Create('Christian', 70));
Edit1.Text := 'Age';
DoSort('Age'); // Sort by age
DoDisplay('Age');
end;
procedure TForm2.Button1Click(Sender: TObject);
begin
DoSort(Edit1.Text);
DoDisplay(Edit1.Text);
end;
procedure TForm2.DoSort(PropName: String);
begin
FPropertyName := PropName; { << }
FList.SortList(CompareObjectByPropertyName); { << }
/// The code above could be written with a lambda, and without CompareObjectByPropertyName
/// using FPropertyName, and by using a closure thus referring to PropName directly.
/// Below is the equivalent code that doesn't make use of FPropertyName. The code below
/// could be commented out completely and just is there to show an alternative approach.
FList.SortList(
function (P1, P2: Pointer): Integer
var
propValueP1, propValueP2: Variant;
begin
propValueP1 := GetPropValue(P1, PropName, False);
propValueP2 := GetPropValue(P2, PropName, False);
if VarCompareValue(propValueP1, propValueP2) = vrEqual then begin
Result := 0;
end else if VarCompareValue(propValueP1, propValueP2) = vrGreaterThan then begin
Result := 1;
end else begin
Result := -1; /// This is a catch anything else, even if the values cannot be compared
end;
end);
/// Inline anonymous functions (lambdas) make the code less readable but
/// have the advantage of "capturing" local variables (creating a closure)
end;
procedure TForm2.DoDisplay(PropName: String);
var
i: Integer;
strPropValue: String;
begin
ListBox1.Items.Clear;
for i := 0 to FList.Count - 1 do begin
strPropValue := GetPropValue(FList[i], PropName, False);
ListBox1.Items.Add(strPropValue);
end;
end;
end.
I marked with { << } the main changes.
Upgrade to Delphi >= 2009, and then you can use anonymous methods to pass a function declaration directly into TList.Sort.
An example can be found at
http://delphi.about.com/od/delphitips2009/qt/sort-generic.htm
I don't know of any other way, other than the methods you describe in your question.
The following code (constructed only to demonstrate the problem) compiles and works in Delphi 2010. In Delphi 2009, compiler fails with "E2035 Not enough actual parameters".
program Project50;
{$APPTYPE CONSOLE}
uses
SysUtils;
type
TMyProc = reference to procedure(param: integer);
var
a: TProc;
b: TMyProc;
begin
b := procedure (param: integer)
begin
end;
a := TProc(b); // <-- [DCC Error] Project50.dpr(19): E2035 Not enough actual parameters
end.
I have found only one very ugly hack to work around the problem (a: TProc absolute b). Does anybody knows of a nicer workaround for this compiler deficiency?
[TProc field is actually hidden inside a record that can store various 'executable' code - TProcedure, TMethod and TProc. Casting is used to store specific anonymous proc into this field.]
The trick is not to do
a := TProc(b);
but
TMyProc(a) := b;
That compiles and works in D2009. Sample project attached below.
program Project51;
{$APPTYPE CONSOLE}
uses
SysUtils;
type
TMyProc = reference to procedure(var param: integer);
TStorage = record
FDelegate: TProc;
end;
var
a : TMyProc;
b : TMyProc;
param: integer;
stg : TStorage;
begin
b := procedure (var param: integer)
begin
param := 2*param;
end;
// stg.FDelegate := TMyProc(b); // doesn't compile in Delphi 2009, compiles in Delphi 2010
TMyProc(stg.FDelegate) := b;
param := 21;
TMyProc(stg.FDelegate)(param);
Writeln(param);
Readln;
end.
However, this doesn't work if casting to a local variable.
var
p: TProc;
a: TMyProc;
TMyProc(p) := a; // this will not compile
Curiouser and curiouser.
I have found a hack #2:
program Project1;
{$APPTYPE CONSOLE}
uses
SysUtils;
type
TMyProc = reference to procedure(param: integer);
var
a: TProc;
b: TMyProc;
begin
b := procedure (param: integer)
begin
Writeln('asdf');
end;
PPointer(#a)^ := PPointer(#b)^;
a;
readln;
end.
I am in doubt what are you trying to achieve by assigning TMyProc (with param argument) to TProc (without argument)?
Updated: A hack #3 (should increment ref counter, the idea is stolen from System._IntfCopy):
procedure AnonCopy(var Dest; const Source);
var
P: Pointer;
begin
P:= Pointer(Dest);
if Pointer(Source) <> nil
then IInterface(Source)._AddRef;
Pointer(Dest):= Pointer(Source);
if P <> nil then
IInterface(P)._Release;
end;
var
a: TProc;
b: TMyProc;
begin
b := procedure (param: integer)
begin
Writeln('asdf');
end;
AnonCopy(a, b);
// PPointer(#a)^ := PPointer(#b)^;
a;
readln;
end.
It appears that the best way would be to use generics to store the correct type of delegate in the record. No hacks required.
program Project51;
{$APPTYPE CONSOLE}
uses
SysUtils;
type
TMyProc = reference to procedure(var param: integer);
TStorage<T> = record
FDelegate: T;
end;
var
a : TMyProc;
b : TMyProc;
p : TProc;
param: integer;
stg : TStorage<TMyProc>;
begin
b := procedure (var param: integer)
begin
param := 2*param;
end;
stg.FDelegate := b;
param := 21;
stg.FDelegate(param);
Writeln(param);
Readln;
end.